###################################################### # Requirements # Library library(gbm) library(parallel) library(caret) library(xtable) library(mc2d) library(e1071) # Data # Output from file 1_DataPreparation.R load("CombinedNRSA0809_datFrame") ##################################################### # Tune gradient boosted tree (GBT) model # Create extra directory for temporary files if(!dir.exists("GBT_Tuning")){ dir.create("GBT_Tuning") } if(!dir.exists("GBT_TuningResults")){ dir.create("GBT_TuningResults") } # Generate simulation files that tunes the GBT model tempCode <- readLines("Template_GBT_Tuning.R") tempCodeMod <- tempCode for(i in 1:17000) { tempCodeMod <- tempCode tempCodeMod[1] <- gsub(pattern=" <- 1", replacement=paste(" <- ", i, sep=""), x=tempCode[1]) writeLines(tempCodeMod, con=paste("GBT_Tuning/Template_GBT_Tuning", i, ".R", sep="")) } # Run simulation to tune parameters of GBT # Note: This is computationally resource intensive and requires parallel processing. # Example code: Internal parallelization on one desktop computer noCores <- detectCores() clust0 <- makeCluster(noCores) evalIterations <- 1:17000 clusterEvalQ(cl=clust0, expr=setwd(paste(getwd()))) parLapplyLB(cl=clust0, X=evalIterations, FUN=function(x) source(paste("GBT_Tuning/Template_GBT_Tuning", x, ".R", sep=""))) # Actual implementation depends on the local cluster environment. # Directories and file access permissions have to be properly configured. # Combine results load("GBT_TuningResults/PDP_tuneGrid_Index_1") tuneGridComplete <- tuneGrid Indices <- list.files("GBT_TuningResults/", pattern="PDP_tuneGrid_Index_")[-1] Indices <- sort(as.numeric(substr(x=Indices, start=20, stop=.Machine$integer.max))) for(Index in Indices){ load(paste("GBT_TuningResults/PDP_tuneGrid_Index_", Index, sep="")) tuneGridComplete <- rbind(tuneGridComplete, tuneGrid) if(Index %% 200 == 0) {cat("Progress:", round(Index/length(Indices), 4)*100, "%", "\n")} } save(tuneGridComplete, file="tuneGridComplete_GBT", compress="xz") ########################################################################### # Fit final GBT 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 # Load tuning results and get best iteration load("tuneGridComplete_GBT") bestIter <- which.min(tuneGridComplete$AvgNegLogLik) # Estimation of final GBT model on the complete data set gbmFitFinal <- gbm(formula=formulaInput, distribution="multinomial", data=datFrame, n.minobsinnode=1, n.trees=tuneGridComplete[bestIter, "nTrees"], interaction.depth=tuneGridComplete[bestIter, "intActDepth"], n.cores=1) save(gbmFitFinal, file="GBT_final", compress="xz") ######################################################## # Goodness of fit on complete data set used in training # Load final GBT model load("GBT_final") # How well does the model fit the data? predsTemp <- predict(gbmFitFinal, newdata=datFrame, type="response", n.trees=gbmFitFinal$n.trees)[, , 1] predsLabel <- sapply(1:nrow(predsTemp), function(x) names(which.max(predsTemp[x, ]))) # Confusion matrix confMat <- confusionMatrix(data=factor(predsLabel, levels=c("Poor", "Fair", "Good")), reference=datFrame$BENT_MMI_COND) xtabCompute1 <- xtable(confMat$table, caption=" ", label="confMatFull", digits=4, display=NULL) writeClipboard(str=capture.output(print(xtabCompute1, include.rownames=FALSE)), format = 1) # Accuracy mean(ifelse(datFrame$BENT_MMI_COND==predsLabel, 1, 0)) # 89.41 % ########################################################################## # Goodness of fit with nested stratified cross validation (10 x 10) # Performance evaluation on test sets (outer folds) including # tuning process (inner folds) # Note: Grid search contains a lot iterations and this should be run on a # cluster with parallel processing # 1. Investigate performance in the inner folds # Create extra directory for temporary files if(!dir.exists("GBT_NestedCV")){ dir.create("GBT_NestedCV") } if(!dir.exists("GBT_NestedCVresults")){ dir.create("GBT_NestedCVresults") } # Generate simulation files # Jobs: 170000 tempCode <- readLines("Template_GBT_nestedCV.R") tempCodeMod <- tempCode for(i in 1:170000) { tempCodeMod <- tempCode tempCodeMod[1] <- gsub(pattern=" <- 1", replacement=paste(" <- ", i, sep=""), x=tempCode[1]) writeLines(tempCodeMod, con=paste("GBT_NestedCV/Template_GBT_nestedCV", i, ".R", sep="")) } # Example code: Internal parallelization on one desktop computer noCores <- detectCores() clust0 <- makeCluster(noCores) evalIterations <- 1:170000 clusterEvalQ(cl=clust0, expr=setwd(paste(getwd()))) parLapplyLB(cl=clust0, X=evalIterations, FUN=function(x) source(paste("GBT_NestedCV/Template_GBT_nestedCV", x, ".R", sep=""))) # Actual implementation depends on the local cluster environment. # Directories and file access permissions have to be properly configured. # Combine results load("GBT_NestedCVresults/PDP_tuneGrid_nestCV_Index_1") tuneGridComplete <- tuneGrid Indices <- list.files("GBT_NestedCVresults/", pattern="PDP_tuneGrid_nestCV_Index_")[-1] Indices <- sort(as.numeric(substr(x=Indices, start=nchar("PDP_tuneGrid_nestCV_Index_")+1, stop=.Machine$integer.max))) for(Index in Indices){ load(paste("GBT_NestedCVresults/PDP_tuneGrid_nestCV_Index_", Index, sep="")) tuneGridComplete <- rbind(tuneGridComplete, tuneGrid) if(Index %% 200 == 0) {cat("Progress:", round(Index/length(Indices), 4)*100, "%", "\n")} } save(tuneGridComplete, file="tuneGrid_GBT_nestedCV", compress="xz") ########################################### # 2. Investigate performance in outer folds # Combined load("tuneGrid_GBT_nestedCV") tuneGridCompleteSplit <- split(tuneGridComplete, tuneGridComplete$OuterFold) optParNestedCV <- t(sapply(1:length(tuneGridCompleteSplit), function(x) tuneGridCompleteSplit[[x]] [ which.min(tuneGridCompleteSplit[[x]] [, "AvgNegLogLik"]), ])) # Prepare list of data sets set.seed(0) cvFoldsOuter <- createFolds(y=datFrame[, "BENT_MMI_COND"], k=10, returnTrain = TRUE) # Formatting of categorical response tempTrain <- vector("list", 10) tempVal <- vector("list", 10) respMultinomVal <- vector("list", 10) for(j in 1:10) { tempTrain[[j]] <- datFrame[cvFoldsOuter[[j]], ] tempVal[[j]] <- datFrame[-cvFoldsOuter[[j]], ] respMultinomVal[[j]] <- model.matrix(~BENT_MMI_COND-1, data=data.frame(BENT_MMI_COND= tempVal[[j]]$BENT_MMI_COND)) } # Tune model # Evaluate out of sample accuracy tempNegLogLik <- vector("numeric", 10) accGBM <- vector("numeric", 10) confMatList <- vector("list", 10) for(j in 1:10) { # Estimate GBM gbmFit <- gbm(formula=formulaInput, distribution="multinomial", data=tempTrain[[j]], n.minobsinnode=1, n.trees=optParNestedCV[j, "nTrees"], interaction.depth=optParNestedCV[j, "intActDepth"], n.cores=1) # Evaluate prediction on validation data preds <- predict(gbmFit, newdata=tempVal[[j]], type="response", n.trees=gbmFit$n.trees)[, , 1] # Evaluate negative multinomial log-likelihood tempNegLogLik[j] <- -sum(dmultinomial(x=respMultinomVal[[j]] , size=1, prob=preds, log=TRUE)) # Evaluate predictive accuracy predClasses <- colnames(preds)[apply(preds, 1, which.max)] accGBM[j] <- mean(ifelse(predClasses==tempVal[[j]]$BENT_MMI_COND, 1, 0)) # Confusion matrix confMatList[[j]] <- confusionMatrix(data=factor(predClasses, levels=c("Poor", "Fair", "Good")), reference=factor(tempVal[[j]]$BENT_MMI_COND, levels=c("Poor", "Fair", "Good"))) cat("Progress", round(j / 10, 4)*100, "%", "\n") } # Aggregated confusion matrix in Latex format 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)) # Save results gbmEval <- list(OuterFold=1:10, Accuracy=accGBM, NegLogLik=tempNegLogLik) save(gbmEval, file=paste("GBT_nestedCV_eval", sep=""), compress="xz") # Average predictive accuracy load("GBT_nestedCV_eval") round(mean(gbmEval$Accuracy), 4) round(mean(gbmEval$NegLogLik), 4) ################################# # Permutation variable importance # Manuscript Figure 1 # Reproducibility seed set.seed(2019) # Formatting of responses RESPorg <- model.matrix(~BENT_MMI_COND+0, datFrame) # Calculate original loss function on the complete data set predsOrg <- as.matrix(predict.gbm(object=gbmFitFinal, newdata=datFrame, n.trees=gbmFitFinal$n.trees, type="response")[, , 1]) # multinomLogLik(yMat=RESP, predMat=predsOrg) negMultiLogLikOrg <- -sum(dmultinomial(x=RESPorg, size=1, prob=predsOrg, log=TRUE)) # Permutation based variable importance varImp <- as.data.frame(matrix(NA, nrow=25, ncol=dim(datFrame)[2]-1)) names(varImp) <- names(datFrame)[-1] permNo <- 25 indicesOrg <- 1:dim(datFrame)[1] noFeatures <- dim(datFrame)[2]-1 for(j in 2:dim(datFrame)[2] ){ for(m in 1:permNo){ # Permute original data datFramePerm <- datFrame datFramePerm[, j] <- datFrame[sample(indicesOrg), j] # Calculate new predictions predsPerm <- as.matrix(predict.gbm(object=gbmFitFinal, newdata=datFramePerm, n.trees=gbmFitFinal$n.trees, type="response")[, , 1]) # Calculate loss negMultiLogLikPerm <- -sum(dmultinomial(x=RESPorg, size=1, prob=predsPerm, log=TRUE)) # Comparison of permuted and original value varImp[m, j-1] <- negMultiLogLikPerm - negMultiLogLikOrg } cat("Feature", round((j-1)/noFeatures*100, 4), "%", "\n") } save(varImp, file="GBTfinal_varImp") # Overview load("GBTfinal_varImp") avgVarImp <- colMeans(varImp) avgVarImpPlot <- avgVarImp[order(avgVarImp, decreasing=FALSE)] # Convert variable identifiers to interpretable variable names codesConversion <- 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")) convNames <- sapply(1:length(avgVarImpPlot), function(x) codesConversion[ codesConversion$Code==names(avgVarImpPlot)[x], "Description"]) pdf("varImp_GBTFitFinal.pdf") par(mar=c(5, 4*4, 4, 2) + 0.1) barplot(avgVarImpPlot, horiz = TRUE, col = rainbow(avgVarImpPlot, start = 3/6, end = 4/6), names = convNames, xlab = "Permutation variable importance", las=1) par(mar=c(5, 4, 4, 2) + 0.1) dev.off() # Sensitivity Poor 613 / (613 + 97 + 101) # 0.755857 # Sensitivity Fair 76 / (194 + 76 + 146) # 0.1826923 # Sensitivity Good 336 / (131 + 100 + 336) # 0.5925926