############################################ # Requirements # Libraries library(gbm) library(iml) # Data # Output from file 1_DataPreparation.R load("CombinedNRSA0809_datFrame") # Load final gradient boosted tree model load("GBT_final") dummyResp <- model.matrix(~BENT_MMI_COND-1, datFrame) # 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 # Function definitions # Calculation of IAS IAS <- function(GBTmodel, compDat, ALEgridSize){ # Calculate average prediction f0 predMat <- predict.gbm(object=GBTmodel, newdata=compDat, n.trees=GBTmodel$n.trees, type="response")[, , 1] f0 <- colMeans(predMat) cat("Calculation of predictions and average prediction f0", "\n") # Define predictors for poor, fair and good outcome predModel_Poor = Predictor$new(model = GBTmodel, data=compDat, class="Poor", predict.fun = function(model, newdata) { predict.gbm(object=model, newdata=newdata, n.trees=model$n.trees, type="response")[, , 1]}, type = NULL) predModel_Fair = Predictor$new(model = GBTmodel, data=compDat, class="Fair", predict.fun = function(model, newdata) { predict.gbm(object=model, newdata=newdata, n.trees=model$n.trees, type="response")[, , 1]}, type = NULL) predModel_Good = Predictor$new(model = GBTmodel, data=compDat, class="Good", predict.fun = function(model, newdata) { predict.gbm(object=model, newdata=newdata, n.trees=model$n.trees, type="response")[, , 1]}, type = NULL) # Computation of ALE functions noVars <- dim(compDat)[2] # ALE_Poor <- vector("list", noVars) # ALE_Fair <- vector("list", noVars) # ALE_Good <- vector("list", noVars) featureNames <- names(compDat) ALE_Mat_Poor <- matrix(NA, nrow=dim(compDat)[1], ncol=noVars) ALE_Mat_Fair <- matrix(NA, nrow=dim(compDat)[1], ncol=noVars) ALE_Mat_Good <- matrix(NA, nrow=dim(compDat)[1], ncol=noVars) for( j in 1:noVars ){ # Approximate data points ALE_Poor by linear interpolation ALE_Poor <- FeatureEffect$new(predictor=predModel_Poor, feature=featureNames[j], method = "ale", grid.size = ALEgridSize, center.at = NULL) ALE_Mat_Poor[, j] <- approx(x=ALE_Poor$results[, ALE_Poor$feature.name], y=ALE_Poor$results$.ale, xout=compDat[, ALE_Poor$feature.name])$y # Approximate data points ALE_Fair by linear interpolation ALE_Fair <- FeatureEffect$new(predictor=predModel_Fair, feature=featureNames[j], method = "ale", grid.size = ALEgridSize, center.at = NULL) ALE_Mat_Fair[, j] <- approx(x=ALE_Fair$results[, ALE_Fair$feature.name], y=ALE_Fair$results$.ale, xout=compDat[, ALE_Fair$feature.name])$y # Approximate data points ALE_Good by linear interpolation ALE_Good <- FeatureEffect$new(predictor=predModel_Good, feature=featureNames[j], method = "ale", grid.size = ALEgridSize, center.at = NULL) ALE_Mat_Good[, j] <- approx(x=ALE_Good$results[, ALE_Good$feature.name], y=ALE_Good$results$.ale, xout=compDat[, ALE_Good$feature.name])$y } cat("Computation of ALE approximations", "\n") # Calculation of main effects and intercept mainEffects_Poor <- rowSums(ALE_Mat_Poor) + f0[1] mainEffects_Fair <- rowSums(ALE_Mat_Fair) + f0[2] mainEffects_Good <- rowSums(ALE_Mat_Good) + f0[3] # Calculation of IAS IAS_Poor <- sum((predMat[, 1]-mainEffects_Poor)^2) / sum((predMat[, 1]-f0[1])^2) IAS_Fair <- sum((predMat[, 2]-mainEffects_Fair)^2) / sum((predMat[, 2]-f0[2])^2) IAS_Good <- sum((predMat[, 3]-mainEffects_Good)^2) / sum((predMat[, 3]-f0[3])^2) IAS_Sum <- sum((predMat[, 1]-mainEffects_Poor)^2 + (predMat[, 2]-mainEffects_Fair)^2 + (predMat[, 3]-mainEffects_Good)^2) / sum((predMat[, 1] - f0[1])^2 + (predMat[, 2] - f0[2])^2 + (predMat[, 3] - f0[3])^2) return(c(IAS_Poor=IAS_Poor, IAS_Fair=IAS_Fair, IAS_Good=IAS_Good, IAS_Sum=IAS_Sum)) } ######################################################### # Global interaction strength of GBT (IAS) # Manuscript Section 2.4.1 # Fitted probabilities in the complete data set allPreds <- predict.gbm(object=gbmFitFinal, newdata=datFrame, n.trees=gbmFitFinal$n.trees, type="response")[, , 1] IAS_gbmFitFinal <- IAS(GBTmodel=gbmFitFinal, compDat=datFrame[, -1], ALEgridSize=100) IAS_gbmFitFinal save(IAS_gbmFitFinal, file="IAS_GBTFitFinal") # IAS_Poor IAS_Fair IAS_Good IAS_Sum # 0.5031865 0.6964180 0.5680998 0.5554424 ########################################################### # Local interaction strengths for specific covariates (H^2) # Manuscript Section 2.4.2 # Create directories for temporary R-code and results storage if(!dir.exists("InteractionFiles")){ dir.create("InteractionFiles") } if(!dir.exists("InteractionResults")){ dir.create("InteractionResults") } # Tune model without interactions (terminal nodes=2) regarding number of trees tempCode <- readLines("Template_GBT_Tuning_noInteract.R") tempCodeMod <- tempCode for(i in 1:2000) { tempCodeMod <- tempCode tempCodeMod[1] <- gsub(pattern=" <- 1", replacement=paste(" <- ", i, sep=""), x=tempCode[1]) writeLines(tempCodeMod, con=paste("InteractionFiles/Template_GBT_Tuning_noInteract", i, ".R", sep="")) } # Tuning of gradient boosted trees model without interactions # Note: Computing these iterations takes considerable amount of computatin time. # Usage of a cluster with parallel processing is recommended. # Example code: Internal parallelization on one desktop computer # Actual implementation depends on the local cluster environment. # Directories and file access permissions have to be properly configured. 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("InteractionFiles/Template_GBT_Tuning_noInteract", x, ".R", sep=""))) # Estimate Null model without interactions # Load tuning information load(paste("InteractionResults/PDP_tuneGrid_noInteract_Index_", 1, sep="")) tuneGridFinal <- tuneGrid for(Index in 2:2000) { load(paste("InteractionResults/PDP_tuneGrid_noInteract_Index_", Index, sep="")) tuneGridFinal <- rbind(tuneGridFinal, tuneGrid) } tuneGridFinal[which.min(tuneGridFinal$AvgNegLogLik), ] # Fit tuned null distribution model on complete data set gbmFitNoInteractFinal <- gbm(formula=formulaInput, distribution="multinomial", data=datFrame, n.minobsinnode=1, n.trees=tuneGridFinal[which.min(tuneGridFinal$AvgNegLogLik), "nTrees"], interaction.depth=1, n.cores=1) save(gbmFitNoInteractFinal, file="GBT_NoInteract_final", compress="xz") # Parametric bootstrap test for arbitrary H # Create code files tempCode <- readLines("Template_GBT_simInteractions.R") tempCodeMod <- tempCode for(i in 1:10000) { tempCodeMod <- tempCode tempCodeMod[1] <- gsub(pattern=" <- 1", replacement=paste(" <- ", i, sep=""), x=tempCode[1]) writeLines(tempCodeMod, con=paste("InteractionFiles/Template_GBT_simInteractions", i, ".R", sep="")) } # Tuning of gradient boosted trees model without interactions # Note: Computing these iterations takes considerable amount of computatin time. # Usage of a cluster with parallel processing is recommended. # Example code: Internal parallelization on one desktop computer # Actual implementation depends on the local cluster environment. # Directories and file access permissions have to be properly configured. noCores <- detectCores() clust0 <- makeCluster(noCores) evalIterations <- 1:170000 clusterEvalQ(cl=clust0, expr=setwd(getwd())) parLapplyLB(cl=clust0, X=evalIterations, FUN=function(x) source( paste("InteractionFiles/Template_GBT_simInteractions", x, ".R", sep=""))) ########################################## # Summarize interaction simulation results availFiles <- grep("RES_simInteract_boot_", list.files("InteractionResults/"),value=TRUE) bootRES <- NULL for(i in 1:length(availFiles)) { load(paste("InteractionResults/", availFiles[i], sep="")) bootRES <- rbind(bootRES, RES) cat("Progress=", round(i/length(availFiles), 4)*100, "%", "\n") } save(bootRES, file="bootRES_H0_nointeract", compress="xz") # Calculate observed two way and three way interaction values load("bootRES_H0_nointeract") # Two way interactions bootRESintOrder <- split(bootRES, bootRES$interaction_order) furtherSplit <- paste(bootRESintOrder[[1]] [, "variable_i"], bootRESintOrder[[1]] [, "variable_j"], sep=" + ") bootRES_intOrder2_varComb <- split(bootRESintOrder[[1]], furtherSplit) obsIntOrg2 <- data.frame(VarComb=sapply(1:length(bootRES_intOrder2_varComb), function(x) paste(unname(unlist( bootRES_intOrder2_varComb[[x]] [1, c("variable_i", "variable_j")])), collapse=" + ")), F_x_ij_Poor=NA, F_x_ij_Fair=NA, F_x_ij_Good=NA) for(j in 1:length(bootRES_intOrder2_varComb)) { obsIntOrg2[j, c("F_x_ij_Poor", "F_x_ij_Fair", "F_x_ij_Good")] <- interact.gbm(x=gbmFitFinal, data=datFrame, i.var = unname(unlist(bootRES_intOrder2_varComb[[j]] [1, c("variable_i", "variable_j")]))) cat("Progress:", round(j/length(bootRES_intOrder2_varComb), 4)*100, "%", "\n") } save(bootRES_intOrder2_varComb, file="bootRES_intOrder2_varComb", compress="xz") # Three way interactions furtherSplit3 <- paste(bootRESintOrder[[2]] [, "variable_i"], bootRESintOrder[[2]] [, "variable_j"], bootRESintOrder[[2]] [, "variable_k"], sep=" + ") bootRES_intOrder3_varComb <- split(bootRESintOrder[[2]], furtherSplit3) obsIntOrg3 <- data.frame(VarComb=sapply(1:length(bootRES_intOrder3_varComb), function(x) paste(unname(unlist( bootRES_intOrder3_varComb[[x]] [1, c("variable_i", "variable_j", "variable_k")])), collapse=" + ")), F_x_ijk_Poor=NA, F_x_ijk_Fair=NA, F_x_ijk_Good=NA) for(j in 1:length(bootRES_intOrder3_varComb)) { obsIntOrg3[j, c("F_x_ijk_Poor", "F_x_ijk_Fair", "F_x_ijk_Good")] <- interact.gbm(x=gbmFitFinal, data=datFrame, i.var = unname(unlist(bootRES_intOrder3_varComb[[j]] [1, c("variable_i", "variable_j", "variable_k")]))) cat("Progress:", round(j/length(bootRES_intOrder3_varComb), 4)*100, "%", "\n") } save(bootRES_intOrder3_varComb, file="bootRES_intOrder3_varComb", compress="xz") # Sum across all categories # Add row sums to cases for(j in 1:length(bootRES_intOrder2_varComb)) { bootRES_intOrder2_varComb[[j]]$F_x_ij_sum <- rowSums( bootRES_intOrder2_varComb[[j]] [, c("F_x_ij_Poor", "F_x_ij_Fair", "F_x_ij_Good")]) } for(j in 1:length(bootRES_intOrder3_varComb)) { bootRES_intOrder3_varComb[[j]]$F_x_ijk_sum <- rowSums( bootRES_intOrder3_varComb[[j]] [, c("F_x_ijk_Poor", "F_x_ijk_Fair", "F_x_ijk_Good")]) } obsIntOrg2$F_x_ij_sum <- rowSums(obsIntOrg2[, 2:4]) obsIntOrg3$F_x_ijk_sum <- rowSums(obsIntOrg3[, 2:4]) save(obsIntOrg2, file="obsStatSample_intOrder2", compress="xz") save(obsIntOrg3, file="obsStatSample_intOrder3", compress="xz") # Calculate monte carlo p-values # 1. Two way interactions load("obsStatSample_intOrder2") load("bootRES_intOrder2_varComb") obsIntOrg2$MCpvalue_Poor <- NA obsIntOrg2$MCpvalue_Fair <- NA obsIntOrg2$MCpvalue_Good <- NA for(j in 1:length(bootRES_intOrder2_varComb)) { # Poor higherVal <- sum(bootRES_intOrder2_varComb[[j]]$F_x_ij_Poor >= obsIntOrg2[j, "F_x_ij_Poor"]) obsIntOrg2[j, "MCpvalue_Poor"] <- (higherVal + 1) / (length(bootRES_intOrder2_varComb[[j]]$F_x_ij_Poor) + 1) # Fair higherVal <- sum(bootRES_intOrder2_varComb[[j]]$F_x_ij_Fair >= obsIntOrg2[j, "F_x_ij_Fair"]) obsIntOrg2[j, "MCpvalue_Fair"] <- (higherVal + 1) / (length(bootRES_intOrder2_varComb[[j]]$F_x_ij_Fair) + 1) # Good higherVal <- sum(bootRES_intOrder2_varComb[[j]]$F_x_ij_Good >= obsIntOrg2[j, "F_x_ij_Good"]) obsIntOrg2[j, "MCpvalue_Good"] <- (higherVal + 1) / (length(bootRES_intOrder2_varComb[[j]]$F_x_ij_Good) + 1) } sum(p.adjust(obsIntOrg2$MCpvalue_Poor, method="BY") <= 0.05, na.rm=TRUE) # 0 sum(p.adjust(obsIntOrg2$MCpvalue_Fair, method="BY") <= 0.05, na.rm=TRUE) # 17 sum(p.adjust(obsIntOrg2$MCpvalue_Good, method="BY") <= 0.05, na.rm=TRUE) # 2 save(obsIntOrg2, file="obsStatSample_intOrder2", compress="xz") # 2. Three way interactions load("obsStatSample_intOrder3") load("bootRES_intOrder3_varComb") obsIntOrg3$MCpvalue_Poor <- NA obsIntOrg3$MCpvalue_Fair <- NA obsIntOrg3$MCpvalue_Good <- NA for(j in 1:length(bootRES_intOrder3_varComb)) { # Poor higherVal <- sum(bootRES_intOrder3_varComb[[j]]$F_x_ijk_Poor >= obsIntOrg3[j, "F_x_ijk_Poor"]) obsIntOrg3[j, "MCpvalue_Poor"] <- (higherVal + 1) / (length(bootRES_intOrder3_varComb[[j]]$F_x_ijk_Poor) + 1) # Fair higherVal <- sum(bootRES_intOrder3_varComb[[j]]$F_x_ijk_Fair >= obsIntOrg3[j, "F_x_ijk_Fair"]) obsIntOrg3[j, "MCpvalue_Fair"] <- (higherVal + 1) / (length(bootRES_intOrder3_varComb[[j]]$F_x_ijk_Fair) + 1) # Good higherVal <- sum(bootRES_intOrder3_varComb[[j]]$F_x_ijk_Good >= obsIntOrg3[j, "F_x_ijk_Good"]) obsIntOrg3[j, "MCpvalue_Good"] <- (higherVal + 1) / (length(bootRES_intOrder3_varComb[[j]]$F_x_ijk_Good) + 1) } sum(p.adjust(obsIntOrg3$MCpvalue_Poor, method="BY") <= 0.05) # 0 sum(p.adjust(obsIntOrg3$MCpvalue_Fair, method="BY") <= 0.05) # 23 sum(p.adjust(obsIntOrg3$MCpvalue_Good, method="BY") <= 0.05) # 0 save(obsIntOrg3, file="obsStatSample_intOrder3", compress="xz") # -> Only interaction in probability of poor outcome! # Inspect interactions load("obsStatSample_intOrder2") load("obsStatSample_intOrder3") # Fair, Good obsIntOrg2[which(p.adjust(obsIntOrg2$MCpvalue_Poor, method="BY") <= 0.05), ] obsIntOrg2[which(p.adjust(obsIntOrg2$MCpvalue_Fair, method="BY") <= 0.05), ] obsIntOrg2[which(p.adjust(obsIntOrg2$MCpvalue_Good, method="BY") <= 0.05), ] # Order regarding magnitude obsIntOrg2_Fair_Sig <- obsIntOrg2[ which(p.adjust(obsIntOrg2$MCpvalue_Fair, method="BY") <= 0.05), ] obsIntOrg2_Fair_Sig[order(obsIntOrg2_Fair_Sig$F_x_ij_Fair, decreasing=TRUE), c("VarComb", "F_x_ij_Fair", "MCpvalue_Fair")] obsIntOrg2_Good_Sig <- obsIntOrg2[ which(p.adjust(obsIntOrg2$MCpvalue_Good, method="BY") <= 0.05), ] obsIntOrg2_Good_Sig[order(obsIntOrg2_Good_Sig$F_x_ij_Good, decreasing=TRUE), c("VarComb", "F_x_ij_Good", "MCpvalue_Good")] # Three way interactions have only low strength # Fair obsIntOrg3[which(p.adjust(obsIntOrg3$MCpvalue_Poor, method="BY") <= 0.05), ] obsIntOrg3[which(p.adjust(obsIntOrg3$MCpvalue_Fair, method="BY") <= 0.05), ] obsIntOrg3[which(p.adjust(obsIntOrg3$MCpvalue_Good, method="BY") <= 0.05), ] # Order results by magnitude obsIntOrg3_Fair_Sig <- obsIntOrg3[which(p.adjust(obsIntOrg3$MCpvalue_Fair, method="BY") <= 0.05), ] round(obsIntOrg3_Fair_Sig[order(obsIntOrg3_Fair_Sig$F_x_ijk_Fair, decreasing=TRUE), c("F_x_ijk_Fair")], 4) obsIntOrg3_Fair_Sig[order(obsIntOrg3_Fair_Sig$F_x_ijk_Fair, decreasing=TRUE), c("VarComb", "MCpvalue_Fair")]