################################################# # Requirements # Libraries library(VGAM) library(combinat) library(xtable) library(caret) # Function definitions # Description: Extracts the mantissa and exponent of a positive number # Argument x: Numeric vector with all elements >= 0 # Return: List with two elements # Numeric vector of mantissa # Numeric vector of exponents extract <- function(x){ e <- ifelse(x == 0, 0, floor(log10(x))) m <- x/10^e list(mantissa = m, exponent = e) } # Data # Output from file 1_DataPreparation.R load("CombinedNRSA0809_datFrame") ########################################### # Fit multinomial logistic regression model # Construct structure of formula based on ecological prior knowledge formulaInput <- BENT_MMI_COND ~ AGGR_ECO9_2015 + LRBS_USE + L_XFC_NAT + L_XCMGW + W1_HALL + NHDWAT_NADP2009_MEAN_NO3 + NHDWAT_NADP2009_MEAN_SO4 + NHDWAT_ELEV + NHDWAT_SLOPE + NHDWAT_PCT_CANOPY+ NHDWAT_PCT_IMPERV + NHDWAT_PCT_SAND + TMAX_ANN + WSAREA_NARS+PCT_AG + PCT_WET + PCT_SHRUB_GRASS # Construct structure of formulas of all pairwise interactions between covariates covariates <- attr(terms(formulaInput),"term.labels") interactTwo <- combn(x=covariates, m=2) interactThree <- combn(x=covariates, m=3) noInteractTwo <- dim(interactTwo)[2] noInteractThree <- dim(interactThree)[2] formulaInputFull <- formulaInput for(k in 1:noInteractTwo){ formulaInputFull <- update(formulaInputFull, formula(paste(". ~ . +", paste(interactTwo[, k], collapse=":"), sep=" "))) } for(k in 1:noInteractThree){ formulaInputFull <- update(formulaInputFull, formula(paste(". ~ . +", paste(interactThree[, k], collapse=":"), sep=" "))) } # Conduct forward-backward model selection # Start with formulaInput genAICpenalty <- sqrt(log(dim(datFrame)[1])) startvglm <- vglm(formula=formulaInput, data=datFrame, family=multinomial(refLevel = "Poor")) RESstep <- step4vglm(object=startvglm, scope=formulaInputFull, k=genAICpenalty) save(RESstep, file="parametricMultinomial_modelSelect_RESstep") # Estimate AIC and check for Hauk-Donner effects load("parametricMultinomial_modelSelect_RESstep") AIC(RESstep, k=genAICpenalty) hdeffCheck <- hdeff(RESstep) hdeffCheck[hdeffCheck] # WSAREA_NARS:1 L_XCMGW:WSAREA_NARS:1 L_XCMGW:WSAREA_NARS:2 # TRUE TRUE TRUE dim(datFrame)[1]/length(names(RESstep@coefficients)) length(names(RESstep@coefficients)) # -> Use Likelihood ratio tests instead of Wald tests # Likelihood ratio tests of each term in the model # lrtPvalues <- anova(object=RESstep, type="III", test="LRT")[, 5] lrtPvalues <- lrt.stat(RESstep, all.out = TRUE)$pvalues altFormulaInput <- formula(as.character(RESstep@call)[2]) finalVglm <- vglm(formula=altFormulaInput, data=datFrame, family=multinomial(refLevel = "Poor")) summaryFinalVglm <- summary(finalVglm) save(finalVglm, summaryFinalVglm, lrtPvalues, file="parametricMultinomial_summaryFinalVglm") ########################################## # Prepare tables for Supplemental material load("parametricMultinomial_summaryFinalVglm") # Lookup table to convert identifiers more interpretable variable names RichardCodes <- data.frame(Code=c("AGGR_ECO9_2015", "LRBS_USE", "L_XCMGW", "L_XFC_NAT", "NHDWAT_ELEV", "NHDWAT_NADP2009_MEAN_NO3", "NHDWAT_NADP2009_MEAN_SO4", "NHDWAT_PCT_CANOPY", "NHDWAT_PCT_IMPERV", "NHDWAT_PCT_SAND", "NHDWAT_SLOPE", "PCT_AG", "PCT_WET", "PCT_SHRUB_GRASS", "W1_HALL", "TMAX_ANN", "WSAREA_NARS"), Description=c("Ecoregion", "Log relative bed stability", "Riparian vegetation condition", "Fish cover", "Elevation", "NO3 deposition", "SO4 deposition", "Tree canopy", "Impervious surface", "Percent sandy soils", "Catchment slope", "Agriculture", "Wetlands", "Shrub/Grass", "Human Disturbance Index", "Max Temperature", "Watershed area")) # Conversion of variable names tempResponse <- sapply(strsplit(x=names(summaryFinalVglm@coef3[-c(1:2), 1]), split=":"), function(x) tail(x, 1)) var1temp <- sapply(strsplit(x=names(summaryFinalVglm@coef3[-c(1:2), 1]), split=":"), function(x) { return(x[1]) }) var1temp <- ifelse( regexpr(pattern="AGGR_ECO9_2015", text=var1temp)==1, RichardCodes[ RichardCodes$Code=="AGGR_ECO9_2015", "Description"], var1temp) var1temp <- sapply(1:length(var1temp), function(x) ifelse(sum(RichardCodes$Code==var1temp[x])==1, RichardCodes[ RichardCodes$Code==var1temp[x], "Description"], RichardCodes[1, "Description"])) var2temp <- sapply(strsplit(x=names(summaryFinalVglm@coef3[-c(1:2), 1]), split=":"), function(x) { lengthX <- length(x) if(lengthX==3){ return(x[2]) } else{ return("") } }) var2temp <- sapply(1:length(var2temp), function(x) ifelse(sum(RichardCodes$Code==var2temp[x])==1, RichardCodes[RichardCodes$Code==var2temp[x], "Description"], "")) tempResponse_Category <- ifelse(tempResponse==1, "Fair", "Good") # Compute adjusted p-values by Benjamini-Yuketeli pValTempAdjust <- p.adjust(lrtPvalues, method="BY") # Display p-values up to the fourth digit pValTempAdjust_new <- ifelse(extract(pValTempAdjust)$exponent==0, "1", ifelse(extract(pValTempAdjust)$exponent <= -4, paste("$", "< 10^{-4}", "$"), paste("$", round(extract(pValTempAdjust)$mantissa, 0), " * 10^{", extract(pValTempAdjust)$exponent, "}$", sep=""))) finalVglmRES <- data.frame(Var1=var1temp, Var2=var2temp, Response=tempResponse_Category, OR=exp(summaryFinalVglm@coef3[-c(1:2), 1]), lowCI095=exp(summaryFinalVglm@coef3[-c(1:2), 1]-qnorm(0.975)*summaryFinalVglm@coef3[-c(1:2), 2]), highCI095=exp(summaryFinalVglm@coef3[-c(1:2), 1]+qnorm(0.975)*summaryFinalVglm@coef3[-c(1:2), 2]), adjustPValue=pValTempAdjust_new) finalVglmRES <- finalVglmRES[pValTempAdjust <= 0.05, ] # Split table into main effects and interaction effects # Table with first 22 parametric main effects firstTable <- finalVglmRES[finalVglmRES$Var2=="", ] firstTable <- firstTable[order(firstTable$OR, decreasing=TRUE), ] firstTableTemp <- firstTable[1:round(dim(firstTable)[1]/2), ] # secondTable <- firstTable[(round(dim(firstTable)[1]/2)+1):dim(firstTable)[1], ] firstTable <- firstTableTemp # thirdTable <- finalVglmRES[finalVglmRES$Var2!="", ] thirdTable <- thirdTable[order(thirdTable$OR, decreasing=TRUE), ] # Use abbreviations in third table thirdTable$Var1 <- gsub("Human Disturbance Index", "HDI", thirdTable$Var1) thirdTable$Var2 <- gsub("Human Disturbance Index", "HDI", thirdTable$Var2) thirdTable$Var1 <- gsub("Riparian vegetation condition", "RVC", thirdTable$Var1) thirdTable$Var2 <- gsub("Riparian vegetation condition", "RVC", thirdTable$Var2) thirdTable$Var1 <- gsub("Log relative bed stability", "LRBS", thirdTable$Var1) thirdTable$Var2 <- gsub("Log relative bed stability", "LRBS", thirdTable$Var2) # fourthTable <- thirdTable[1:round(dim(thirdTable)[1]/2), ] thirdTable <- thirdTable[(round(dim(thirdTable)[1]/2)+1):dim(thirdTable)[1], ] # Change column names firstTable <- firstTable[, -2] names(firstTable)[1] <- "Variable" secondTable <- secondTable[, -2] names(secondTable)[1] <- "Variable" names(thirdTable)[1:2] <- c("Variable1", "Variable2") names(fourthTable)[1:2] <- c("Variable1", "Variable2") dim(firstTable) dim(secondTable) # Expand ecoregion by category xtab1 <- rbind(firstTable, secondTable) abbreviationConversion <- data.frame(Codes=levels(datFrame$AGGR_ECO9_2015), Description=levels(datFrame$AGGR_ECO9_2015)) extractCharacter <- gsub("2", "", gsub( "1", "", gsub(":", "", gsub("AGGR_ECO9_2015", "", rownames( xtab1[xtab1$Variable=="Ecoregion", ]), fixed=TRUE), fixed=TRUE), fixed=TRUE), fixed=TRUE) xtab1[xtab1$Variable=="Ecoregion", "Variable"] <- paste("Ecoregion", tolower( abbreviationConversion[abbreviationConversion$Codes %in% extractCharacter, "Description"])) # xtab2 <- rbind(fourthTable, thirdTable) extractCharacter <- gsub("2", "", gsub( "1", "", gsub(":", "", gsub("AGGR_ECO9_2015", "", sapply(strsplit(rownames( xtab2[xtab2$Variable1=="Ecoregion", ]), ":"), function(x) x[1]), fixed=TRUE), fixed=TRUE), fixed=TRUE), fixed=TRUE) if(length(extractCharacter)>0){ includeVec <- vector("character", length(extractCharacter)) for( k in 1:length(extractCharacter) ){ includeVec[k] <- paste("Ecoregion", tolower( abbreviationConversion[abbreviationConversion$Codes == extractCharacter[k], "Description"])) } xtab2[xtab2$Variable1=="Ecoregion", "Variable1"] <- includeVec } # extractCharacter <- gsub("2", "", gsub( "1", "", gsub(":", "", gsub("AGGR_ECO9_2015", "", sapply(strsplit(rownames( xtab2[xtab2$Variable2=="Ecoregion", ]), ":"), function(x) x[1]), fixed=TRUE), fixed=TRUE), fixed=TRUE), fixed=TRUE) if(length(extractCharacter)>0){ includeVec <- vector("character", length(extractCharacter)) for( k in 1:length(extractCharacter) ){ includeVec[k] <- paste("Ecoregion", tolower( abbreviationConversion[abbreviationConversion$Codes == extractCharacter[k], "Description"])) } xtab2[xtab2$Variable2=="Ecoregion", "Variable2"] <- includeVec } # Convert code to Latex table and store it in memory xtabCompute1 <- xtable(xtab1, caption=" ", label="multiLogitRES", digits=4, display=NULL) writeClipboard(str=capture.output(print(xtabCompute1, include.rownames=FALSE)), format = 1) xtabCompute2 <- xtable(xtab2, caption=" ", label="multiLogitRESinteract", digits=4, display=NULL) writeClipboard(str=capture.output(print(xtabCompute2, include.rownames=FALSE)), format = 1) ################################################### # Goodness of fit on complete data used in training # Load multinomial logit model load("parametricMultinomial_summaryFinalVglm") # Estimate probabilities of response classes Poor, Fair, Good preds <- predict(finalVglm, type="response") # Classification of observations by maximum probability predClasses <- colnames(preds)[apply(preds, 1, which.max)] # Construct confusion matrix # confMat <- confusionMatrix(data=factor(predClasses, levels=c("Poor", "Fair", "Good")), reference=factor(datFrame$BENT_MMI_COND, levels=c("Poor", "Fair", "Good"))) # Accuracy on the complete data set (training set) sum(diag(confMat$table))/sum(confMat$table) # 0.5925307 # Convert R-Code to Latex xtable(confMat$table) ################################################### # Predictive performance of multinomial logit model # Prepare list of data sets genAICpenalty <- sqrt(log(dim(datFrame)[1])) set.seed(0) cvFoldsOuter <- createFolds(y=datFrame[, "BENT_MMI_COND"], k=10, returnTrain = TRUE) confMatList <- vector("list", 10) for(j in 1:10){ # Fit model startvglm <- vglm(formula=formulaInput, data=datFrame[cvFoldsOuter[[j]], ], family=multinomial(refLevel = "Poor")) RESstep <- step4vglm(object=startvglm, scope=formulaInputFull, k=genAICpenalty) # Evaluation preds <- predict(RESstep, newdata=datFrame[-cvFoldsOuter[[j]], ], type="response") predClasses <- colnames(preds)[apply(preds, 1, which.max)] confMatList[[j]] <- confusionMatrix(data=factor(predClasses, levels=c("Poor", "Fair", "Good")), reference=datFrame[-cvFoldsOuter[[j]], "BENT_MMI_COND"]) cat("#################### Outer", j*10, "%", "\n") } save(confMatList, file="multinomialLogitModel_predPerf_confMatList") # Aggregated confusion matrix over all outer nested stratified cross validation folds load("multinomialLogitModel_predPerf_confMatList") xtable((confMatList[[1]]$table+ confMatList[[2]]$table+ confMatList[[3]]$table+ confMatList[[4]]$table+ confMatList[[5]]$table+ confMatList[[6]]$table+ confMatList[[7]]$table+ confMatList[[8]]$table+ confMatList[[9]]$table+ confMatList[[10]]$table)) # Accuracy evaluated on test data folds sum(diag((confMatList[[1]]$table+ confMatList[[2]]$table+ confMatList[[3]]$table+ confMatList[[4]]$table+ confMatList[[5]]$table+ confMatList[[6]]$table+ confMatList[[7]]$table+ confMatList[[8]]$table+ confMatList[[9]]$table+ confMatList[[10]]$table))) / sum(confMatList[[1]]$table+ confMatList[[2]]$table+ confMatList[[3]]$table+ confMatList[[4]]$table+ confMatList[[5]]$table+ confMatList[[6]]$table+ confMatList[[7]]$table+ confMatList[[8]]$table+ confMatList[[9]]$table+ confMatList[[10]]$table)