## ----setup, include = FALSE---------------------------------------------------
knitr::opts_chunk$set(collapse = TRUE, comment = "#>")
library(functionals)
set.seed(1)
has_rsample <- requireNamespace("rsample", quietly = TRUE)

## -----------------------------------------------------------------------------
by_species <- fmapg(iris, function(d) {
  fit <- lm(Sepal.Length ~ Petal.Length, data = d)
  c(slope = unname(coef(fit)[2]), r2 = summary(fit)$r.squared)
}, by = "Species")

do.call(rbind, by_species)

## -----------------------------------------------------------------------------
specs <- data.frame(
  response  = "mpg",
  predictor = c("wt", "hp", "wt + hp", "wt * hp"),
  stringsAsFactors = FALSE
)

aic_tbl <- fmapr(specs, function(row) {
  f   <- reformulate(row$predictor, row$response)
  fit <- lm(f, data = mtcars)
  data.frame(model = deparse(f), aic = AIC(fit), adj_r2 = summary(fit)$adj.r.squared)
})
do.call(rbind, aic_tbl)

## -----------------------------------------------------------------------------
grid <- expand.grid(df = c(2, 3, 4, 5), span = NA)
fits <- fmapn(list(df = grid$df), function(df) {
  fit <- smooth.spline(mtcars$wt, mtcars$mpg, df = df)
  c(df = df, gcv = fit$cv.crit)
})
do.call(rbind, fits)

## ----eval = has_rsample-------------------------------------------------------
set.seed(42)
folds <- rsample::vfold_cv(mtcars, v = 5)

cv_rows <- fcv(folds$splits, function(split) {
  tr <- rsample::analysis(split)
  te <- rsample::assessment(split)
  fit  <- lm(mpg ~ wt + hp, data = tr)
  pred <- predict(fit, newdata = te)
  data.frame(rmse = sqrt(mean((te$mpg - pred)^2)))
})

cv <- do.call(rbind, cv_rows)
c(mean_rmse = mean(cv$rmse), sd_rmse = sd(cv$rmse))

## ----eval = FALSE-------------------------------------------------------------
# cv_rows <- fcv(folds$splits, evaluate_one, ncores = 5, pb = TRUE)

## ----eval = has_rsample-------------------------------------------------------
safe_rows <- fcv(folds$splits, function(split) {
  tr <- rsample::analysis(split)
  if (nrow(tr) < 3) stop("degenerate fold")
  data.frame(rmse = sd(rsample::assessment(split)$mpg))
}, .on_error = "pass")

ok <- !vapply(safe_rows, inherits, logical(1), "functionals_error")
do.call(rbind, safe_rows[ok])

## -----------------------------------------------------------------------------
boot_coef <- frepeat(times = 200, .seed = 2024, simplify = TRUE, expr = function() {
  idx <- sample(nrow(mtcars), replace = TRUE)
  coef(lm(mpg ~ wt, data = mtcars[idx, ]))[["wt"]]
})

c(
  estimate = coef(lm(mpg ~ wt, data = mtcars))[["wt"]],
  boot_se  = sd(boot_coef),
  ci_lo    = unname(quantile(boot_coef, 0.025)),
  ci_hi    = unname(quantile(boot_coef, 0.975))
)

## -----------------------------------------------------------------------------
# same result, more cores; .seed is invariant to ncores
b2 <- frepeat(times = 200, .seed = 2024, simplify = TRUE, ncores = 2, expr = function() {
  idx <- sample(nrow(mtcars), replace = TRUE)
  coef(lm(mpg ~ wt, data = mtcars[idx, ]))[["wt"]]
})
identical(round(sd(boot_coef), 10), round(sd(b2), 10))

## ----eval = has_rsample-------------------------------------------------------
learners <- list(
  lm_wt      = function(tr) lm(mpg ~ wt, data = tr),
  lm_wt_hp   = function(tr) lm(mpg ~ wt + hp, data = tr),
  lm_full    = function(tr) lm(mpg ~ ., data = tr)
)

cv_rmse <- function(fit_fun) {
  rows <- fcv(folds$splits, function(split) {
    tr <- rsample::analysis(split); te <- rsample::assessment(split)
    p  <- predict(fit_fun(tr), newdata = te)
    sqrt(mean((te$mpg - p)^2))
  })
  mean(unlist(rows))
}

bench_tbl <- fmap(learners, cv_rmse, .on_error = "fill", .fill = NA_real_)
data.frame(learner = names(bench_tbl), cv_rmse = round(unlist(bench_tbl), 3))