## generate sample data and functional coefficients
set.seed(1)
n <- 40
p <- 18
r <- 100
s <- seq(0, 1, length.out = r)
beta_basis <- splines::bs(s, df = p, intercept = TRUE) # basis
coef_data <- matrix(rnorm(n*floor(p/2)), n, floor(p/2))
fun_data <- coef_data %*% t(splines::bs(s, df = floor(p/2), intercept = TRUE))
x_0 <- apply(matrix(rnorm(p, sd=1),p,1), 1, fdaSP::softhresh, 1)
x_fun <- beta_basis %*% x_0
b <- fun_data %*% x_fun + rnorm(n, sd = sqrt(crossprod(fun_data %*% x_fun ))/10)
l <- 10^seq(2, -4, length.out = 30)
maxit <- 1000
## set the hyper-parameters
maxit <- 1000
rho_adaptation <- TRUE
rho <- 1
reltol <- 1e-5
abstol <- 1e-5
## run cross-validation
mod_cv <- f2sSP_cv(vY = b, mX = fun_data, M = p,
group_weights = NULL, var_weights = NULL, standardize.data = FALSE, splOrd = 4,
lambda = NULL, lambda.min = 1e-5, nlambda = 30, cv.fold = 5, intercept = FALSE,
control = list("abstol" = abstol,
"reltol" = reltol,
"adaptation" = rho_adaptation,
"rho" = rho,
"print.out" = FALSE))
### graphical presentation
plot(log(mod_cv$lambda), mod_cv$mse, type = "l", col = "blue", lwd = 2, bty = "n",
xlab = latex2exp::TeX("$\\log(\\lambda)$"), ylab = "Prediction Error",
ylim = range(mod_cv$mse - mod_cv$mse.sd, mod_cv$mse + mod_cv$mse.sd),
main = "Cross-validated Prediction Error")
fdaSP::confband(xV = log(mod_cv$lambda), yVmin = mod_cv$mse - mod_cv$mse.sd,
yVmax = mod_cv$mse + mod_cv$mse.sd)
abline(v = log(mod_cv$lambda[which(mod_cv$lambda == mod_cv$lambda.min)]),
col = "red", lwd = 1.0)
### comparison with oracle error
mod <- f2sSP(vY = b, mX = fun_data, M = p,
group_weights = NULL, var_weights = NULL,
standardize.data = FALSE, splOrd = 4,
lambda = NULL, nlambda = 30,
lambda.min = 1e-5, intercept = FALSE,
control = list("abstol" = abstol,
"reltol" = reltol,
"adaptation" = rho_adaptation,
"rho" = rho,
"print.out" = FALSE))
err_mod <- apply(mod$sp.coef.path, 1, function(x) sum((x - x_0)^2))
plot(log(mod$lambda), err_mod, type = "l", col = "blue",
lwd = 2, xlab = latex2exp::TeX("$\\log(\\lambda)$"),
ylab = "Estimation Error", main = "True Estimation Error", bty = "n")
abline(v = log(mod$lambda[which(err_mod == min(err_mod))]), col = "red", lwd = 1.0)
abline(v = log(mod_cv$lambda[which(mod_cv$lambda == mod_cv$lambda.min)]),
col = "red", lwd = 1.0, lty = 2)
Run the code above in your browser using DataLab