## A central region of a set of functions
#----------------------------------------
if(requireNamespace("fda", quietly=TRUE)) {
cset <- curve_set(r=as.numeric(row.names(fda::growth$hgtf)),
obs=fda::growth$hgtf)
plot(cset) + ggplot2::ylab("height")
cr <- central_region(cset, coverage=0.50, type="erl")
plot(cr)
}
## Confidence bands for linear or polynomial regression
#------------------------------------------------------
# Simulate regression data according to the cubic model
# f(x) = 0.8x - 1.8x^2 + 1.05x^3 for x in [0,1]
par <- c(0,0.8,-1.8,1.05) # Parameters of the true polynomial model
res <- 100 # Resolution
x <- seq(0, 1, by=1/res); x2=x^2; x3=x^3;
f <- par[1] + par[2]*x + par[3]*x^2 + par[4]*x^3 # The true function
d <- f + rnorm(length(x), 0, 0.04) # Data
# Plot the true function and data
plot(f, type="l", ylim=range(d))
points(d)
# Estimate polynomial regression model
reg <- lm(d ~ x + x2 + x3)
ftheta <- reg$fitted.values
resid0 <- reg$residuals
s0 <- sd(resid0)
# Bootstrap regression
B <- 2000 # Number of bootstrap samples
B <- 20 # Number of bootstrap samples
ftheta1 <- array(0, c(B,length(x)))
s1 <- array(0,B)
for(i in 1:B) {
u <- sample(resid0, size=length(resid0), replace=TRUE)
reg1 <- lm((ftheta+u) ~ x + x2 + x3)
ftheta1[i,] <- reg1$fitted.values
s1[i] <- sd(reg1$residuals)
}
# Centering and scaling
meanftheta <- apply(ftheta1, 2, mean)
m <- array(0, c(B,length(x)))
for(i in 1:B) { m[i,] <- (ftheta1[i,]-meanftheta)/s1[i] }
# Central region computation
boot.cset <- curve_set(r=1:length(x), obs=ftheta+s0*t(m))
cr <- central_region(boot.cset, coverage=c(0.50, 0.80, 0.95), type="erl")
# Plotting the result
plot(cr) + ggplot2::labs(x=expression(italic(x)), y=expression(italic(f(x)))) +
ggplot2::geom_point(data=data.frame(id=1:length(d), points=d),
ggplot2::aes(x=id, y=points)) + # data points
ggplot2::geom_line(data=data.frame(id=1:length(d), points=f),
ggplot2::aes(x=id, y=points)) # true function
Run the code above in your browser using DataLab