# NOT RUN { # Example 1: quantile regression with smoothing splines set.seed(123); adata <- data.frame(x2 = sort(runif(n <- 500))) mymu <- function(x) exp(-2 + 6*sin(2*x-0.2) / (x+0.5)^2) adata <- transform(adata, y = rpois(n, lambda = mymu(x2))) mytau <- c(0.25, 0.75); mydof <- 4 fit <- vgam(y ~ s(x2, df = mydof), data = adata, trace = TRUE, maxit = 900, alaplace2(tau = mytau, llocat = "loge", parallel.locat = FALSE)) fitp <- vgam(y ~ s(x2, df = mydof), data = adata, trace = TRUE, maxit = 900, alaplace2(tau = mytau, llocat = "loge", parallel.locat = TRUE)) par(las = 1); mylwd <- 1.5 with(adata, plot(x2, jitter(y, factor = 0.5), col = "orange", main = "Example 1; green: parallel.locat = TRUE", ylab = "y", pch = "o", cex = 0.75)) with(adata, matlines(x2, fitted(fit ), col = "blue", lty = "solid", lwd = mylwd)) with(adata, matlines(x2, fitted(fitp), col = "green", lty = "solid", lwd = mylwd)) finexgrid <- seq(0, 1, len = 1001) for (ii in 1:length(mytau)) lines(finexgrid, qpois(p = mytau[ii], lambda = mymu(finexgrid)), col = "blue", lwd = mylwd) fit@extra # Contains useful information # Example 2: regression quantile at a new tau value from an existing fit # Nb. regression splines are used here since it is easier. fitp2 <- vglm(y ~ sm.bs(x2, df = mydof), data = adata, trace = TRUE, alaplace1(tau = mytau, llocation = "loge", parallel.locat = TRUE)) newtau <- 0.5 # Want to refit the model with this tau value fitp3 <- vglm(y ~ 1 + offset(predict(fitp2)[, 1]), alaplace1(tau = newtau, llocation = "loge"), data = adata) with(adata, plot(x2, jitter(y, factor = 0.5), col = "orange", pch = "o", cex = 0.75, ylab = "y", main = "Example 2; parallel.locat = TRUE")) with(adata, matlines(x2, fitted(fitp2), col = "blue", lty = 1, lwd = mylwd)) with(adata, matlines(x2, fitted(fitp3), col = "black", lty = 1, lwd = mylwd)) # Example 3: noncrossing regression quantiles using a trick: obtain # successive solutions which are added to previous solutions; use a log # link to ensure an increasing quantiles at any value of x. mytau <- seq(0.2, 0.9, by = 0.1) answer <- matrix(0, nrow(adata), length(mytau)) # Stores the quantiles adata <- transform(adata, offsety = y*0) usetau <- mytau for (ii in 1:length(mytau)) { # cat("\n\nii = ", ii, "\n") adata <- transform(adata, usey = y-offsety) iloc <- ifelse(ii == 1, with(adata, median(y)), 1.0) # Well-chosen! mydf <- ifelse(ii == 1, 5, 3) # Maybe less smoothing will help # lloc <- ifelse(ii == 1, "loge", "loge") # 2nd value must be "loge" fit3 <- vglm(usey ~ sm.ns(x2, df = mydf), data = adata, trace = TRUE, alaplace2(tau = usetau[ii], lloc = "loge", iloc = iloc)) answer[, ii] <- (if(ii == 1) 0 else answer[, ii-1]) + fitted(fit3) adata <- transform(adata, offsety = answer[, ii]) } # Plot the results. with(adata, plot(x2, y, col = "blue", main = paste("Noncrossing and nonparallel; tau = ", paste(mytau, collapse = ", ")))) with(adata, matlines(x2, answer, col = "orange", lty = 1)) # Zoom in near the origin. with(adata, plot(x2, y, col = "blue", xlim = c(0, 0.2), ylim = 0:1, main = paste("Noncrossing and nonparallel; tau = ", paste(mytau, collapse = ", ")))) with(adata, matlines(x2, answer, col = "orange", lty = 1)) # }
Run the code above in your browser using DataCamp Workspace