# R code from "Two-Parameter Link Functions, With Applications to # Negative Binomial, Weibull and Quantile regression", # by Miranda-Soberanis and Yee, # submitted to 'Computational Statistics'. # July 2021. #------------------------------------------# ## RESUBMITTED on February 2022. ## NEWS: # a) Code to generate Figure 4 updated. # b) Figure 4 plots scaled. #------------------------------------------# # Notes: # 1. This code runs under Linux and may need # edits to work on Windows or Macintosh. # 2. Five R packages are needed below. # (a) The latest versions of VGAM and VGAMextra. # Details below. CRAN versions may be insufficient. # (b) Also needed is the 'quantreg', 'SemiPar', and 'COUNT' packages, # which are available on CRAN # http://CRAN.R-project.org/package=quantreg # http://CRAN.R-project.org/package=COUNT # http://CRAN.R-project.org/package=gamlss options(digits = 5) # Get VGAM running ------------------------------------ # If not yet installed then this gets the latest CRAN version: # install.packages("VGAM") library("VGAM") # Note: minimally, these examples require VGAM version 1.1-5 or higher. if (packageVersion("VGAM") < "1.1.5") warning("you need to update 'VGAM' to at least version 1.1-0") # Note: the latest version is currently available at # http://www.stat.auckland.ac.nz/~yee/VGAM/prerelease # Get VGAMextra running --------------------------------------------- # If not yet installed then this gets the latest CRAN version: # install.packages("VGAMextra") library("VGAMextra") # Note: minimally, these examples require VGAMextra version 0.0-4 or higher. if (packageVersion("VGAMextra") < "0.0.4") warning("you need to update 'VGAMextra' to the latest version 0.0-5") # Note: the latest version is also available at # http://www.stat.auckland.ac.nz/~vmir178 # Get quantreg running --------------------------------------------- # If not yet installed then this gets the latest CRAN version: # install.packages("quantreg") library("quantreg") # Get COUNT running --------------------------------------------- # If not yet installed then this gets the latest CRAN version: # install.packages("COUNT") library("COUNT") # Get gamlss running --------------------------------------------- # If not yet installed then this gets the latest CRAN version: # install.packages("gamlss") library("gamlss") # ================================================================ ############################################################## ## CODE - EXAMPLE 1 - Section 5.1.1 Simulated Data ## # Generating the 'ndata' data frame. library("COUNT") n <- 1000 set.seed(1) x2 <- runif(n) x3 <- runif(n) alpha <- 1 / exp(7) # value of alpha = 1 / size xb <- -3 + 1.25 * x2 + 0.1 * x3 mu <- 1 / ((exp(-xb) - 1) * alpha) prob <- 1 / (1 + alpha * mu) ndata <- data.frame(y = rnbinom(n, size=1/alpha, prob = prob), x2, x3) ###---------------------- TABLE 2 ------------------------------### library("VGAM") #'fit1' from vglm(), and the estimated coefficients. fit1 <- vglm(y ~ x2 + x3, negbinomial(lmu = "nbcanlink"), ndata) mymat1 <- summary(fit1)@coef3 ## --- TABLE 2 LEFT - HAND SIDE (LHS) --- ## round(mymat1[-2, -4], 3) # 'fit2' from ml.nbc(), and estimated coefficients + CL + UL fit2 <- ml.nbc(y ~ x2 + x3, data = ndata) mymat3 <- matrix(round(c(fit2$Estimate[-4], fit2$SE[-4], fit2$Z[-4]), 3), nrow = 3, ncol = 3, byrow = FALSE) rownames(mymat3) <- c("(Intercept):1", "x2", "x3") colnames(mymat3) <- c("Estimate", "Std. Error", "z value") ## --- TABLE 2 RIGHT - HAND SIDE (RHS) --- ## mymat3 ## --------------- TABLE 3: 95% Wald CIs ---------------- ## mymat <- mymat1[c(1, 3, 4, 2), 1 , drop = FALSE] ULimVGAM <- c(mymat + 1.96 * mymat1[ c(1, 3, 4, 2), 2, drop = TRUE]) LLimVGAM <- c(mymat - 1.96 * mymat1[ c(1, 3, 4, 2), 2, drop = TRUE]) mymat3 <- data.frame(mymat3) mymat3[4, ] <- c(fit2[4, c(1, 2, 3)]) ULimCOUNT <- c(mymat3[, 1, drop = TRUE] + 1.96 * mymat3[, 2, drop = TRUE]) LLimCOUNT <- c(mymat3[, 1, drop = TRUE] - 1.96 * mymat3[, 2, drop = TRUE]) mymat <- matrix(c(LLimVGAM, ULimVGAM, LLimCOUNT, ULimCOUNT), nrow = 4, ncol = 4, byrow = FALSE) mymat[4, c(4, 3)] <- 1/mymat[4, c(4, 3)] mymat[4, c(1, 2)] <- exp(mymat[4, c(1, 2)]) colnames(mymat) <- c("2.5%", "97.5%", "2.5%", "97.5%") rownames(mymat) <- c("(Intercept):1", "x2", "x3", "k") ## TABLE 3 ## round(mymat, 3) # END OF EXAMPLE 1 - R CODE # ################################################################## ## CODE - EXAMPLE 2 - Section 5.1.2 Lake Otamangakau trout data ## library("VGAM") # Fit the four models ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, data("trapO", package = "VGAMdata") use.df <- trapO trapo.nb1 <- vglm(BMTW ~ bs(doy), negbinomial(parallel = TRUE, zero = NULL), data = use.df, trace = FALSE) trapo.nb2 <- vglm(BMTW ~ bs(doy), negbinomial, data = use.df, trace = FALSE) trapo.nbh <- vglm(BMTW ~ bs(doy), negbinomial(zero = NULL), data = use.df, trace = FALSE) trapo.nbc <- vglm(BMTW ~ bs(doy), negbinomial(lmu = "nbcanlink", zero = NULL), data = use.df, trace = FALSE) all.wffci <- c('nb1' = AIC(trapo.nb1), 'nb2' = AIC(trapo.nb2), 'nbh' = AIC(trapo.nbh), 'nbc' = AIC(trapo.nbc)) ### ---------------------- TABLE 4 ------------------------- ### round(sort(all.wffci) , 2) ### ---------------------- FIGURE 1 ---------------------- ### par(mfrow = c(1, 2), mar = c(3.9, 4.0, 0.2, 0.4) + 0.1, mgp = c(2.3, 1, 0)) use.df <- trapO # Exploratory ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, trapo.vgam.nbh <- vgam(BMTW ~ s(doy), negbinomial(zero = NULL), data = use.df, trace = FALSE) # Component functions plotted together plot(trapo.vgam.nbh, se = TRUE, overlay = TRUE, llwd = c(2, 2), lcol = c("blue", "darkorange"), scol = c("blue", "darkorange"), slty = "longdash", rcol = "darkgreen") put.caption("(a)", c(0.18, 0.82)) # Plot the fitted values ,,,,,,,,,,,,,,,,,,,,,,,,, # Need to sort from LHS to RHS when plotting: ooo <- with(use.df, order(doy)) plot(fitted(trapo.nbc)[ooo] ~ doy, use.df[ooo, ], ylab = "Fitted values", las = 1, xlab = "Day of year", type = "l", col = "blue") points(fitted(trapo.nbc) ~ doy, use.df, pch = 19, col = "blue", cex = 0.25) month1 <- c(feb = 32, mar = 60, apr = 91, may =121, jun = 152, jul = 182, aug = 213, sep = 244) abline(v = month1, col = "gray50", lty = "dashed") # Nadirs put.caption("(b)", c(0.18, 0.82)) ## END OF R CODE - EXAMPLE 2 Section 5.1.2 ## ############################################################### ## CODE - EXAMPLE 3 - Section 5.2 Weibull quantile modelling ## library("gamlss") library("VGAMextra") ### -----------------------Fitting Model(5.1) -------------------- ### ## Fitting Model (5.1) with GAMLSS - BCCG distribution ## data(rent99) ## 'rent99' is the Munich rental guide data rent99[, "area"] <- as.numeric(rent99[, "area"]) fitgamlss <- gamlss(rent ~ s(area), sigma.formula = ~ 1, nu.formula = ~1, family = BCCG(mu.link = "log"), data = rent99, trace = FALSE) ## Fitting Model (5.1) with VGAM and VGAMextra - Weibull distribution ## ## ---- (additional fit -- Needed for QQplots) ---- ## fitvgam <- vgam(rent ~ s(area), family = weibullRff(link1 = "weibullMlink"), data = rent99, trace = FALSE) ## Fitting Model (5.1) with VGAMextra: Weibull quantile modelling ## ## with weibullQlink() ## tau <- c(0.05, 0.25, 0.50, 0.75, 0.95) fittau <- vgam(Q.reg(rent, length = 5)~ s(area), family = weibullRff(link1 = "weibullQlink", percentile = tau* 100, zero = "shape"), data = rent99, trace = FALSE) ### -------------------- Table 6 ------------------------### ## AICs and BICs - Table 6. rbind(AIC(fitgamlss), AIC(fitvgam)) rbind(BIC(fitgamlss), BIC(fitvgam)) ### --------------------- Figure 2 -------------------------### par(mfrow = c(1, 2)) par(mar = c(4.0, 4.0, 1.5, 0.5) + 0.1) ## QQplot- Weibull scores <- rent99$rent w_scores = qweibull(ppoints(length(scores)), shape = loglink(predictors(fitvgam)[, 2], inverse = TRUE), scale = weibullMlink(predictors(fitvgam)[, 1], shape = loglink(predictors(fitvgam)[, 2], inverse = TRUE), inverse = TRUE) ) qqplot(x = w_scores, y = scores, pch = 20, cex = 0.75, ylab = "Sample Quantiles", xlab = "Theoretical Quantiles", main = "") #title("Weibull QQ-Plot") qqline(scores, distribution = function(p) { qweibull(p, shape = loglink(predictors(fitvgam)[, 2], inverse = TRUE), scale = weibullMlink(predictors(fitvgam)[, 1], shape = loglink(predictors(fitvgam)[, 2], inverse = TRUE), inverse = TRUE) ) } , col="red",lwd = 2,lty = 2, probs = c(0.0090, 0.011817)) mtext("(a)", line = 2.5, outer = FALSE, at = 2000, side = 2, cex = 1.5, las = 2) ## QQ plots - GAMLSS w_scores <- qBCCG(ppoints(length(scores)), mu = fitted(fitgamlss), sigma = exp(fitgamlss$sigma.coefficients), nu = exp(fitgamlss$nu.coefficients) ) qqplot(x = w_scores, y = scores, pch = 20, cex = 0.75, ylab = "Sample Quantiles", xlab = "Theoretical Quantiles", main = "" ) qqline(scores, distribution = function(p) { qBCCG(p, mu = fitted(fitgamlss), sigma = exp(fitgamlss$sigma.coefficients), nu = exp(fitgamlss$nu.coefficients) ) }, col="red",lwd = 2,lty = 2, probs = c(0.25, 0.32)) mtext("(b)", line = 2.5, outer = FALSE, at = 2000, side = 2, cex = 1.5, las = 2) ## End Figure 2 ## ### --------------------- Figure 3 -------------------------### ## FIGURE 3 - Quantile curves GAMLSS (BCCG) vs VGAMextra (Weibull) par(mar = c(4.0, 4.0, 1.5, 0.5) + 0.15) plot(rent ~ area, pch = 19, data = rent99, cex = 0.12, xlab = "area", col= "black", ylab = "rent", main = 'Weibull and BCCG quantile curves.') ### --- Figure 3: Adding Quantile curves from GAMLSS ----### nu <- predict(fitgamlss, what = "nu") sigma <- exp(predict(fitgamlss, what = "sigma")) mu <- exp(predict(fitgamlss, what = "mu")) tau <- 5/100 pred50 <- mu * qBCCG(p = tau, mu = 1, sigma = sigma, nu = nu) pc5 <- 100* length(pred50[pred50 > rent99$rent])/dim(rent99)[1] pred50 <- data.frame(area = rent99$area, pred50) pred50 <- pred50[order(pred50[, 1]), ] matplot(pred50[, 1], pred50[, 2], type = "l", add = T, lwd = 1.25, lty = "solid", col = "red") tau <- 25/100 pred50 <- mu * qBCCG(p = tau, mu = 1, sigma = sigma, nu = nu) pc25 <- 100* length(pred50[pred50 > rent99$rent])/dim(rent99)[1] pred50 <- data.frame(area = rent99$area, pred50) pred50 <- pred50[order(pred50[, 1]), ] matplot(pred50[, 1], pred50[, 2], type = "l", add = T, lwd = 1.25, lty = "solid", col = "red") tau <- 50/100 pred50 <- mu * qBCCG(p = tau, mu = 1, sigma = sigma, nu = nu) pc50 <- 100* length(pred50[pred50 > rent99$rent])/dim(rent99)[1] pred50 <- data.frame(area = rent99$area, pred50) pred50 <- pred50[order(pred50[, 1]), ] matplot(pred50[, 1], pred50[, 2], type = "l", add = T, lwd = 1.25, lty = "solid", col = "red") tau <- 75/100 pred50 <- mu * qBCCG(p = tau, mu = 1, sigma = sigma, nu = nu) pc75 <- 100* length(pred50[pred50 > rent99$rent])/dim(rent99)[1] pred50 <- data.frame(area = rent99$area, pred50) pred50 <- pred50[order(pred50[, 1]), ] matplot(pred50[, 1], pred50[, 2], type = "l", add = T, lwd = 1.25, lty = "solid", col = "red") tau <- 95/100 pred50 <- mu * qBCCG(p = tau, mu = 1, sigma = sigma, nu = nu) pc95 <- 100* length(pred50[pred50 > rent99$rent])/dim(rent99)[1] pred50 <- data.frame(area = rent99$area, pred50) pred50 <- pred50[order(pred50[, 1]), ] matplot(pred50[, 1], pred50[, 2], type = "l", add = T, lwd = 1.25, lty = "solid", col = "red") ## --- Figure 3: Adding Quantile curves from VGAMextra --- ## ## --- Weibull quantile modelling --- ## predvgam <- fitted(fittau)[, 1] pc5v <- 100* length(predvgam[predvgam > rent99$rent])/dim(rent99)[1] pred50 <- data.frame(area = rent99$area, predvgam) pred50 <- pred50[order(pred50[, 1]), ] matplot(pred50[, 1], pred50[, 2], type = "l", add = T, lwd = 1.5, lty = "dashed", col = "blue") predvgam <- fitted(fittau)[, 2] pc25v <- 100* length(predvgam[predvgam > rent99$rent])/dim(rent99)[1] pred50 <- data.frame(area = rent99$area, predvgam) pred50 <- pred50[order(pred50[, 1]), ] matplot(pred50[, 1], pred50[, 2], type = "l", add = T, lwd = 1.25, lty = "dashed", col = "blue") predvgam <- fitted(fittau)[, 3] pc50v <- 100* length(predvgam[predvgam > rent99$rent])/dim(rent99)[1] pred50 <- data.frame(area = rent99$area, predvgam) pred50 <- pred50[order(pred50[, 1]), ] matplot(pred50[, 1], pred50[, 2], type = "l", add = T, lwd = 1.25, lty = "dashed", col = "blue") predvgam <- fitted(fittau)[, 4] pc75v <- 100* length(predvgam[predvgam > rent99$rent])/dim(rent99)[1] pred50 <- data.frame(area = rent99$area, predvgam) pred50 <- pred50[order(pred50[, 1]), ] matplot(pred50[, 1], pred50[, 2], type = "l", add = T, lwd = 1.25, lty = "dashed", col = "blue") predvgam <- fitted(fittau)[, 5] pc95v <- 100* length(predvgam[predvgam > rent99$rent])/dim(rent99)[1] pred50 <- data.frame(area = rent99$area, predvgam) pred50 <- pred50[order(pred50[, 1]), ] matplot(pred50[, 1], pred50[, 2], type = "l", add = T, lwd = 1.25, lty = "dashed", col = "blue") legend("topleft", c("VGAMextra - WeibullQlink", "GAMLSS - BCCG"), lwd = rep(2, 1.25), lty = c("dashed", "solid"), col = c("blue", "red")) ##------------------- Table 7 -----------------------## rbind(c(pc5 , pc25 , pc50 , pc75 , pc95 ), c(pc5v, pc25v, pc50v, pc75v, pc95v)) detach("package:quantreg") detach("package:gamlss") ## END OF R CODE - Section 5.2 Weibull quantile modelling ### ################################################################# ## CODE - EXAMPLE 4 - Sections 5.3.1 Quantile Modeling ## ## with the Gaussian distribution ## ## The data is formatted according to Table A.4 qrdata <- read.csv("bweight.csv") qrdata$Black <- as.factor(qrdata$Black) qrdata$Married <- as.factor(qrdata$Married) qrdata$Boy <- as.factor(qrdata$Boy) qrdata$MomSmoke <- as.factor(qrdata$MomSmoke) qrdata$MomEdLevel <- as.factor(qrdata$MomEdLevel) qrdata$Weight <- as.numeric(qrdata$Weight) qrdata$MomWtGain <- as.numeric(qrdata$MomWtGain) qrdata$Visit <- as.numeric(qrdata$Visit) ## The first six observations head(qrdata) ### VGLM quantile modelling from Section 5.3.1-Normal distribution ## PERCENTILES of interest. mytau <- 100 * c(0.05, 0.25, 0.50, 0.75, 0.95) ## VGLM quantile modelling - eta_1 is handled by 'uninormalQlink()'. fit.qr.mod <- vglm(Q.reg(Weight, pvector = mytau) ~ Black + Married + Boy + Visit + MomEdLevel + MomSmoke + CigsPerDay + MomAge + MomWtGain + I(MomAge^2) + I(MomWtGain^2), uninormalff(link1 = "uninormalQlink", lsd = "loglink", zero = NULL, percentile = mytau), trace =FALSE, data = qrdata) summary(fit.qr.mod) ## -------------- CODE - FIGURE 4 ------------------# par(mfrow = c(2, 2)) mymat <- coef(fit.qr.mod, mat = TRUE) BlackCoef <- mymat["Black1", c(TRUE, FALSE)] Bcqr <- coef(fit.quantreg)[2, ] plot(mytau, BlackCoef, pch = 17, col = "black", ylab = "Black Mother", cex = 1.35, xlab = "Percentile (%)", lwd = 4, ylim = c(-300, 100), xlim = c(0, 100), xaxt = "n") axis(side = 1, at = c(5, 25, 50, 75, 95)) points(100*pretau, Bcqr, lwd = 3, pch = 17, cex = 1.35, col = "orange") lines(mytau, BlackCoef, col = "black", lty = 1, lwd = 1.5) lines(100*pretau, Bcqr, col = "orange", lty = "dashed", lwd = 1.5) abline(h = 0, lty = 2) legend("topleft", legend = c("uninormalQlink() - Miranda & Yee (2022)", "QR - Koenker & Basset (1978)"), lwd = 1.5, col = c("black", "orange"), cex = 0.75, pch = c(17, 17), lty = c("solid", "dashed")) cpdqr <- coef(fit.quantreg)[10, ] CigpdCoef <- mymat["nCigsPerDay1", c(TRUE, FALSE)] plot(mytau, CigpdCoef, pch = 17, col = "black", ylab = "Cigarettes per day", cex =1.35, xlab = "Percentile (%)", lwd = 4, ylim = c(-300, 100), xlim =c(0, 100), xaxt = "n") axis(side = 1, at = c(5, 25, 50, 75, 95)) points(mytau, cpdqr, lwd = 3, pch = 17, cex = 1.35, col = "orange") lines(mytau, cpdqr, col = "orange", lty = "dashed", lwd = 1.5) lines(mytau, CigpdCoef, col = "black", lty = 1, lwd = 1.5) abline(h = 0, lty = 2) legend("topleft", legend = c("uninormalQlink() - Miranda & Yee (2022)", "QR - Koenker & Basset (1978)"), lwd = 1.5, col = c("black", "orange"), cex = 0.75, pch = c(17, 17), lty = c("solid", "dashed")) MomAge <- mymat["MomAge", c(TRUE, FALSE)] mageqr <- coef(fit.quantreg)[11, ] plot(mytau, MomAge, pch = 21, col = "black", ylab = "Mom's Age", xlab = "Percentile (%)", ylim =c(-1, 30), xlim = c(0, 100), lwd = 4, xaxt = "n") axis(side = 1, at = c(5, 25, 50, 75, 95)) points(mytau, mageqr, lwd = 3, pch = 17, cex = 1.35, col = "orange") lines(mytau, MomAge, col = "black", lty = 1, lwd = 1.5) lines(mytau, mageqr, col = "orange", lty = "dashed", lwd = 1.5) abline(h = 0, lty = 2) legend("topleft", legend = c("uninormalQlink() - Miranda & Yee (2022)", "QR - Koenker & Basset (1978)"), lwd = 1.5, col = c("black", "orange"), cex = 0.75, pch = c(17, 17), lty = c("solid", "dashed")) MomwtCoef <- mymat["MomWtGain", c(TRUE, FALSE)] momwtqr <- coef(fit.quantreg)[12, ] plot(mytau, MomwtCoef, pch = 21, col = "black", ylab = "Mom weight gain", xlab = "Percentile (%)", lwd = 4, xlim = c(0, 100), ylim = c(-1, 30), xaxt = "n") axis(side = 1, at = c(5, 25, 50, 75, 95)) points(mytau, momwtqr, lwd = 3, pch = 17, cex = 1.35, col = "orange") lines(mytau, MomwtCoef, col = "black", lty = 1, lwd = 1.5) lines(mytau, momwtqr, col = "orange", lty = "dashed", lwd = 1.5) abline(h = 0, lty = 2) legend("topleft", legend = c("uninormalQlink() - Miranda & Yee (2022)", "QR - Koenker & Basset (1978)"), lwd = 1.5, col = c("black", "orange"), cex = 0.75, pch = c(17, 17), lty = c("solid", "dashed")) ### END OF R CODE - EXAMPLE 4 - Section 5.3.1 ### detach("package:VGAMextra") detach("package:VGAM") detach("package:SparseM") detach("package:COUNT") detach("package:sandwich") detach("package:msme") detach("package:lattice") detach("package:MASS") detach("package:splines") detach("package:quantreg") detach("package:gamlss")