#' Calculate Coefficient Of Variation surfaces for gbm.auto predictions
#'
#' Bagging introduces stochasticity which can result in sizeable variance in
#' output predictions by gbm.auto for small datasets. This function runs a user-
#' specified number of loops through the same gbm.auto parameter combinations
#' and calculates the Coefficient Of Variation in the predicted abundance scores
#' for each site aka cell. This can be mapped, to spatially demonstrate the
#' output variance range.
#'
#' @param loops The number of loops required, integer.
#' @param savedir Save outputs to a temporary directory (default) else change to
#' current directory e.g. "/home/me/folder". Do not use getwd() here.
#' @param savecsv Save coefficients of variation in simple & extended format.
#' @param calcpreds Calculate coefficients of variation of predicted abundance?
#' @param varmap Create a map of the coefficients of variation outputs?
#' @param measure Map legend, coefficients of variation of what? Default CPUE.
#' @param cleanup Remove gbm.auto-generated directory each loop? Default FALSE.
#' @param grids See gbm.auto help for all subsequent params.
#' @param samples See gbm.auto help.
#' @param expvar See gbm.auto help.
#' @param resvar See gbm.auto help.
#' @param randomvar See gbm.auto help.
#' @param tc See gbm.auto help.
#' @param lr See gbm.auto help.
#' @param bf See gbm.auto help.
#' @param n.trees See gbm.auto help.
#' @param ZI See gbm.auto help. Choose one.
#' @param fam1 See gbm.auto help. Choose one.
#' @param fam2 See gbm.auto help. Choose one.
#' @param simp See gbm.auto help.
#' @param gridslat See gbm.auto help.
#' @param gridslon See gbm.auto help.
#' @param multiplot See gbm.auto help. Default False
#' @param cols See gbm.auto help.
#' @param linesfiles See gbm.auto help; TRUE or linesfiles calculations fail.
#' @param smooth See gbm.auto help.
#' @param savegbm See gbm.auto help.
#' @param loadgbm See gbm.auto help.
#' @param varint See gbm.auto help.
#' @param map See gbm.auto help.
#' @param shape See gbm.auto help.
#' @param RSB See gbm.auto help.
#' @param BnW See gbm.auto help.
#' @param alerts See gbm.auto help; default FALSE as frequent use can crash
#' RStudio.
#' @param pngtype See gbm.auto help. Choose one.
#' @param gaus See gbm.auto help.
#' @param MLEvaluate See gbm.auto help.
#' @param runautos Run gbm.autos, default TRUE, turn off to only collate
#' numbered-folder results.
#' @param Min.Inf Dummy param for package testing for CRAN, ignore.
#' @param ... Additional params for gbm.auto sub-functions including gbm.step.
#'
#' @return Returns a data frame of lat, long, 1 predicted abundance per loop,
#' and a final variance score per cell.
#'
#' @details
#' Thanks to a 2023 improvement to gbm.auto and gbm.loop,
#'
#'
#' @export
#' @importFrom beepr beep
#' @importFrom grDevices dev.off grey.colors png
#' @importFrom graphics axis barplot legend lines mtext par text
#' @importFrom stats var
#' @importFrom utils read.csv write.csv
#'
#' @examples
#' \donttest{
#' # Not run: downloads and saves external data.
#' library("gbm.auto")
#' data(grids) # load grids
#' data(samples) # load samples
#' gbmloopexample <- gbm.loop(loops = 2, samples = samples,
#' grids = grids, expvar = c(4:10), resvar = 11, simp = F)
#' }
#'
#' @author Simon Dedman, \email{simondedman@@gmail.com}
#'
gbm.loop <- function(loops = 10, # the number of loops required, integer
savedir = tempdir(), # save outputs to a temporary directory (default) else
# change to current directory e.g. "/home/me/folder". Do not use getwd() here.
savecsv = TRUE, # save the coefficients of variation in simple & extended format
calcpreds = TRUE, # calculate coefficients of variation of predicted abundance?
varmap = TRUE, # create a map of the coefficients of variation outputs?
measure = "CPUE", # map legend, coefficients of variation of what? Default CPUE
cleanup = FALSE, # remove gbm.auto-generated directory each loop?
grids = NULL, # explantory data to predict to. Import with (e.g.)
# read.csv and specify object name.
samples, # explanatory and response variables to predict from.
# Keep col names short, no odd characters, starting numerals or terminal periods
# Spaces may be converted to periods in directory names, underscores won't.
# Can be a subset
expvar, # list of column numbers of explanatory variables in
# 'samples', expected e.g. c(1,35,67,etc.). No default
resvar, # column number of response variable (e.g. CPUE) in
# samples. Expected, e.g. 12. No default. Column name should be species name.
randomvar = FALSE, # Add a random variable (uniform distribution, 0-1) to
# the expvars, to see whether other expvars perform better or worse than random.
tc = c(2), # permutations of tree complexity allowed, can be a
# vector with the largest sized number no larger than the number of
# explanatory variables e.g. c(2,7), or a list of 2 single numbers or vectors,
# the first to be passed to the binary BRT, the second to the Gaussian, e.g.
# tc = list(c(2,6), 2) or list(6, c(2,6))
lr = c(0.01), # permutations of learning rate allowed. Can be a
# vector or a list of 2 single numbers or vectors, the first to be passed to
# the binary BRT, the second to the Gaussian, e.g.
# lr = list(c(0.01,0.02),0.0001) or list(0.01,c(0.001, 0.0005))
bf = 0.5, # permutations of bag fraction allowed, can be single
# number, vector or list, per tc and lr
n.trees = 50, # from gbm.step, number of initial trees to fit. Can be
# single or list but not vector i.e. list(fam1, fam2)
ZI = "CHECK", # Are data zero-inflated? "CHECK"/FALSE/TRUE.
# Choose one.
# TRUE: delta BRT, log-normalised Gaus, reverse log-norm and bias corrected.
# FALSE: do Gaussian only, no log-normalisation.
# CHECK: Tests data for you. Default is TRUE.
fam1 = c("bernoulli", "binomial", "poisson", "laplace", "gaussian"),
# probability distribution family for 1st part of delta process, defaults to
# "bernoulli",
fam2 = c("gaussian", "bernoulli", "binomial", "poisson", "laplace"),
# probability distribution family for 2nd part of delta process, defaults to
# "gaussian",
simp = TRUE, # try simplfying best BRTs?
gridslat = 2, # column number for latitude in 'grids'
gridslon = 1, # column number for longitude in 'grids'
multiplot = FALSE, # create matrix plot of all line files? Default false
# turn off if large number of expvars causes an error due to margin size problems.
cols = grey.colors(1,1,1), # barplot colour vector. Assignment in order of
# explanatory variables. Default 1*white: white bars black borders. '1*' repeats
linesfiles = TRUE, # save individual line plots' data as csv's?
smooth = FALSE, # apply a smoother to the line plots? Default FALSE
savegbm = FALSE, # save gbm objects and make available in environment after running? Open with load("Bin_Best_Model")
loadgbm = NULL, # relative or absolute location of folder containing
# Bin_Best_Model and Gaus_Best_Model. If set will skip BRT calculations and do
# predicted maps and CSVs. Default NULL, character vector, "./" for working directory
varint = FALSE, # calculate variable interactions? Default:TRUE, FALSE
# for error "contrasts can be applied only to factors with 2 or more levels"
map = TRUE, # save abundance map png files?
shape = NULL, # set coast shapefile, else downloaded and autogenerated
RSB = FALSE, # run Unrepresentativeness surface builder?
BnW = FALSE, # repeat maps in black and white e.g. for print journals
alerts = FALSE, # play sounds to mark progress steps
pngtype = c("cairo-png", "quartz", "Xlib"), # file-type for png files,
# alternatively try "quartz" on Mac. Choose one.
gaus = TRUE, # do Gaussian runs as well as Bin? Default TRUE.
MLEvaluate = TRUE, # do machine learning evaluation metrics & plots? Default TRUE
# brv = NULL, # addresses devtools::check's no visible binding for global variable https://cran.r-project.org/web/packages/data.table/vignettes/datatable-importing.html#globals
# grv = NULL, # addresses devtools::check's no visible binding for global variable https://cran.r-project.org/web/packages/data.table/vignettes/datatable-importing.html#globals
# Bin_Preds = NULL, # addresses devtools::check's no visible binding for global variable https://cran.r-project.org/web/packages/data.table/vignettes/datatable-importing.html#globals
# Gaus_Preds = NULL, # addresses devtools::check's no visible binding for global variable https://cran.r-project.org/web/packages/data.table/vignettes/datatable-importing.html#globals
runautos = TRUE, # run gbm.autos, default TRUE, turn off to only collate numbered-folder results
Min.Inf = NULL, # addresses devtools::check's no visible binding for global variable https://cran.r-project.org/web/packages/data.table/vignettes/datatable-importing.html#globals
...) {
# Generalised Boosting Model / Boosted Regression Tree process chain automater
# Simon Dedman, 2012-8 simondedman@gmail.com github.com/SimonDedman/gbm.auto
####TODO####
# See how many loops until things stabilise, i.e. variance decreases, average smooths out, etc, is that even logical?
# Yes. min max av var should be similar between e.g. 1,000,000 loops & 1,000,001, but less likely between 1 & 2.
# But based on what though? Just do a line of x:loop# vs y: minmin/maxmax/avav/avvar?
# when change in variance from 1:2 to 1:3 to 1:n drops below a percentage threshold?
# Fix csvs colnames, see https://github.com/SimonDedman/gbm.auto/issues/37
# utils::globalVariables("Min.Inf") # addresses devtools::check's no visible binding for global variable https://cran.r-project.org/web/packages/data.table/vignettes/datatable-importing.html#globals
# if (alerts) if (!require(beepr)) {stop("you need to install the beepr package to run this function")}
# if (alerts) require(beepr)
oldpar <- par(no.readonly = TRUE) # defensive block, thanks to Gregor Sayer
oldwd <- getwd()
oldoptions <- options()
on.exit(par(oldpar))
on.exit(setwd(oldwd), add = TRUE)
on.exit(options(oldoptions), add = TRUE)
setwd(savedir)
if (alerts) options(error = function() {
beep(9)
graphics.off()}) # give warning noise if it fails
fam1 <- match.arg(fam1) # populate object from function argument in proper way
fam2 <- match.arg(fam2)
pngtype <- match.arg(pngtype)
if (runautos) { # run gbm.autos unless turned off
# test for presence of report.csvs, don't run those folders
runloops <- data.frame(loop = 1:loops, run = as.logical(rep(NA, loops))) # create recipient df
for (i in 1:loops) runloops[i, "run"] <- file.exists(paste0("./", i, "/Report.csv")) # check for Report.csvs in subfolders
# only want to keep the false ones. update gbm.loop for inputs
for (i in runloops[which(runloops$run == FALSE), "loop"]) { # loop through all gbm.autos
dir.create(paste0("./", i)) # create i'th folder
setwd(paste0("./", i)) # move to it
gbm.auto(grids = grids, # run i'th gbm.auto
samples = samples,
expvar = expvar,
resvar = resvar,
randomvar = randomvar,
tc = tc,
lr = lr,
bf = bf,
n.trees = n.trees,
ZI = ZI,
fam1 = fam1,
fam2 = fam2,
simp = simp,
gridslat = gridslat,
gridslon = gridslon,
multiplot = multiplot,
cols = cols,
linesfiles = linesfiles,
smooth = smooth,
savedir = "./", # current directory created & moved to above
savegbm = savegbm,
loadgbm = loadgbm,
varint = varint,
map = map,
shape = shape,
RSB = RSB,
BnW = BnW,
alerts = alerts,
pngtype = pngtype,
gaus = gaus,
MLEvaluate = MLEvaluate,
...) # accept other gbm.auto values than these basics
setwd("../") # move back up to root folder
if (cleanup) unlink(i, recursive = TRUE)
print(paste0("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX Gbm.auto loop ", i, " complete XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"))
} # close i loop & go to the next i
} # close runautos if optional
binbars.df <- data.frame(var = rep(NA, length(expvar)),
rel.inf = rep(NA, length(expvar)))
gausbars.df <- binbars.df # blank dataframes for bin & gaus bars data
report.df <- data.frame(BinCV = rep(NA, length(loops)),
AUC = rep(NA, length(loops)),
GausCV = rep(NA, length(loops)))
if (calcpreds) var.df <- grids[,c(gridslon, gridslat)] # create df with just lat & longs
for (i in 1:loops) { # loop through all gbm.autos
setwd(paste0("./", i, "/", colnames(samples[resvar]))) # set wd to loopnumber and species named subfolder
if (file.exists("Binary BRT Variable contributions.csv")) {
binbarstmp <- read.csv("Binary BRT Variable contributions.csv") # temp container for bin bars
if (i == 1) {binbars.df <- binbarstmp} else {# csv file to df unless df exists
binbars.df <- rbind(binbars.df, binbarstmp)} # if so add to bottom of existing
bin = TRUE} else bin = FALSE
# loop thru variables name linesfiles e.g. Bin_Best_line_[varname].csv
# adding i'th loop's values as new column
if (bin) for (j in colnames(samples[expvar])) {
if (inherits(samples[,j], "factor")) nreps = length(levels(samples[,j])) else nreps = 100
# Error in `[.data.frame`(samples, , j) : object 'j' not found ####
# rep 100 is fine for numeric variables but needs to match n(levels) of factorial variables.
if (!file.exists(paste0("Bin_Best_line_", j, ".csv"))) {tmp <- data.frame(x = rep(NA, nreps), y = rep(NA, nreps))}
#if file not created because simp, populate with NAs
if (file.exists(paste0("Bin_Best_line_", j, ".csv"))) {tmp <- read.csv(paste0("Bin_Best_line_", j, ".csv"))}
#else use values
colnames(tmp)[2] <- paste0("Loop",i)
if (i == 1) {assign(paste0("binline_", j), tmp)
} else {
assign(paste0("binline_", j), cbind(get(paste0("binline_", j)), tmp[,2]))
if (is.na(get(paste0("binline_", j))[1,1])) { #if the first cell is NA (all 1st col, x, is na)
assign(paste0("binline_", j), #rebuild same obj as df
data.frame(x = tmp[,1], #start with this loop's x values, hopefully not NA also
get(paste0("binline_", j))[,2:(i + 1)]))} #then add the remainder of the existing obj cols
}}
if (file.exists("Gaussian BRT Variable contributions.csv")) {
gausbarstmp <- read.csv("Gaussian BRT Variable contributions.csv") # temp container for Gaus lines
if (i == 1) {gausbars.df <- gausbarstmp} else {
gausbars.df <- rbind(gausbars.df, gausbarstmp)}
gaus = TRUE} else gaus = FALSE
if (gaus) for (k in colnames(samples[expvar])) {
if (inherits(samples[,k], "factor")) nreps = length(levels(samples[,k])) else nreps = 100
if (!file.exists(paste0("Gaus_Best_line_", k, ".csv"))) {tmp <- data.frame(x = rep(NA, nreps), y = rep(NA, nreps))}
#if the first loop is simplified then the first col of gausline will be NAs which should be the X for the linefiles
#else use existing csv file, 2 columns
if (file.exists(paste0("Gaus_Best_line_", k, ".csv"))) {tmp <- read.csv(paste0("Gaus_Best_line_", k, ".csv"))}
colnames(tmp)[2] <- paste0("Loop",i)
if (i == 1) {assign(paste0("gausline_", k), tmp)
} else {
assign(paste0("gausline_", k), cbind(get(paste0("gausline_", k)), tmp[,2]))
if (is.na(get(paste0("gausline_", k))[1,1])) { #if the first cell is NA (all 1st col, x, is na)
assign(paste0("gausline_", k), #rebuild same obj as df
data.frame(x = tmp[,1], #start with this loop's x values, hopefully not NA also
get(paste0("gausline_", k))[,2:(i + 1)]))} #then add the remainder of the existing obj cols
#column cbound but not named. Can name as string "col name" = 1:10, or
#objectname ColName = 1:10 but not formulaicly paste0("Col","Name") = 1:10
#or anything evaluated e.g. colnames(tmp)[2] = tmp[,2]
#colnames(paste0("gausline_", k))[i + 1] <- paste0("loop", i) #rename last column (loop# + 1)
}}
if (!file.exists("Abundance_Preds_only.csv")) calcpreds = FALSE
if (calcpreds) {
predtmp <- read.csv("Abundance_Preds_only.csv") # temp container for latest preds
var.df <- cbind(var.df, predtmp[,3]) # cbind preds to existing lat/longs or other preds
colnames(var.df)[2 + i] <- paste0("Loop_", i) # label newly added preds column
}
#Collect report CV & AUC scores
reporttmp <- read.csv("Report.csv") # temp container for bin bars
if ("Best.Binary.BRT" %in% colnames(reporttmp)) {
# copy BinCV score from this loop's report to allreport
# cv.statistics$deviance.mean is already in gbm.auto report.csv: "CV Mean Deviance: ", but ISN'T in bin_best column!
# Therefore need to lookup best against other cols to find it.
binbestcomboname <- as.character(reporttmp$Best.Binary.BRT[1])
binbestcomboname <- strsplit(binbestcomboname, "Model combo: ")[[1]][2]
# replace lr1e- with lr1e. in the case of very small lr's, R will convert the colname to a dot and the lookup will fail
binbestcomboname <- gsub(pattern = "lr1e-", replacement = "lr1e.", x = binbestcomboname)
# if binbestcomboname is simplified, value ends in _Simp, but colname is "Simplified.Binary.BRT.stats"
# need to use length because if grep doesn't find the pattern it returns integer(0) which doesn't evaluate to logical FALSE for ==1 for some reason
if (length(grep(pattern = "_Simp", x = binbestcomboname)) == 1) binbestcomboname <- "Simplified.Binary.BRT.stats"
report.df[i, "BinCV"] <- as.numeric(strsplit(reporttmp[, which(colnames(reporttmp) %in% binbestcomboname)][3], "CV Mean Deviance: ")[[1]][2])
# copy AUC score from this loop's report to allreport
auctmp <- as.character(reporttmp$Best.Binary.BRT[4])
aucspltmp <- strsplit(auctmp, "Training data AUC score: ")
aucsplnumtmp <- as.numeric(aucspltmp[[1]][2])
report.df[i, "AUC"] <- aucsplnumtmp
}
if ("Best.Gaussian.BRT" %in% colnames(reporttmp)) {
# copy GausCV score from this loop's report to allreport
gausbestcomboname <- as.character(reporttmp$Best.Gaussian.BRT[1])
gausbestcomboname <- strsplit(gausbestcomboname, "Model combo: ")[[1]][2]
gausbestcomboname <- gsub(pattern = "lr1e-", replacement = "lr1e.", x = gausbestcomboname)
if (length(grep(pattern = "_Simp", x = gausbestcomboname)) == 1) gausbestcomboname <- "Simplified.Gaussian.BRT.stats"
report.df[i, "GausCV"] <- as.numeric(strsplit(reporttmp[, which(colnames(reporttmp) %in% gausbestcomboname)][3], "CV Mean Deviance: ")[[1]][2])
}
setwd("../../") # move back up to root folder
print(paste0("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX Collate results loop ", i, " done XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"))
} # close i loop & go to the next i
####loops done create dfs####
# create bin & Gaus barplot stats data frames
if (bin) {binbars <- data.frame(Min.Inf = with(binbars.df, tapply(rel.inf, var, min)),
Av.Inf = with(binbars.df, tapply(rel.inf, var, mean)),
Max.Inf = with(binbars.df, tapply(rel.inf, var, max)),
Inf.variance = with(binbars.df, tapply(rel.inf, var, var)))
binbars <- binbars[order(-binbars[,"Av.Inf"]),]
binbarsgood <- subset(binbars, Min.Inf > 0)} #also create barplots for nonzero vars
if (gaus) {gausbars <- data.frame(Min.Inf = with(gausbars.df, tapply(rel.inf, var, min)),
Av.Inf = with(gausbars.df, tapply(rel.inf, var, mean)),
Max.Inf = with(gausbars.df, tapply(rel.inf, var, max)),
Inf.variance = with(gausbars.df, tapply(rel.inf, var, var)))
gausbars <- gausbars[order(-gausbars[,"Av.Inf"]),]
gausbarsgood <- subset(gausbars, Min.Inf > 0)}
# create linesfiles end-column stats (Min Av Max Var) for each variable
if (bin) for (l in colnames(samples[expvar])) {
assign(paste0("binline_", l), cbind(get(paste0("binline_", l)),
"MinLine" = apply(get(paste0("binline_", l))[, (2:(1 + loops))], MARGIN = 1, min, na.rm = TRUE)))
assign(paste0("binline_", l), cbind(get(paste0("binline_", l)),
"AvLine" = apply(get(paste0("binline_", l))[, (2:(1 + loops))], MARGIN = 1, mean, na.rm = TRUE)))
assign(paste0("binline_", l), cbind(get(paste0("binline_", l)),
"MaxLine" = apply(get(paste0("binline_", l))[, (2:(1 + loops))], MARGIN = 1, max, na.rm = TRUE)))
assign(paste0("binline_", l), cbind(get(paste0("binline_", l)),
"VarLine" = apply(get(paste0("binline_", l))[, (2:(1 + loops))], MARGIN = 1, var, na.rm = TRUE)))}
if (gaus) for (m in colnames(samples[expvar])) {
assign(paste0("gausline_", m), cbind(get(paste0("gausline_", m)),
"MinLine" = apply(get(paste0("gausline_", m))[, (2:(1 + loops))], MARGIN = 1, min, na.rm = TRUE)))
assign(paste0("gausline_", m), cbind(get(paste0("gausline_", m)),
"AvLine" = apply(get(paste0("gausline_", m))[, (2:(1 + loops))], MARGIN = 1, mean, na.rm = TRUE)))
assign(paste0("gausline_", m), cbind(get(paste0("gausline_", m)),
"MaxLine" = apply(get(paste0("gausline_", m))[, (2:(1 + loops))], MARGIN = 1, max, na.rm = TRUE)))
assign(paste0("gausline_", m), cbind(get(paste0("gausline_", m)),
"VarLine" = apply(get(paste0("gausline_", m))[, (2:(1 + loops))], MARGIN = 1, var, na.rm = TRUE)))}
# apply variances to a new column at the end of var.df
if (calcpreds) var.df[,"C of V"] <- apply(var.df[,(3:(2 + loops))], MARGIN = 1, var, na.rm = TRUE)
# Build CV & AUC stats report by scraping individual loops' reports
Minima <- c(min(report.df[, "BinCV"], na.rm = TRUE), min(report.df[, "AUC"], na.rm = TRUE), min(report.df[, "GausCV"], na.rm = TRUE))
Averages <- c(mean(report.df[, "BinCV"], na.rm = TRUE), mean(report.df[, "AUC"], na.rm = TRUE), mean(report.df[, "GausCV"], na.rm = TRUE))
Maxima <- c(max(report.df[, "BinCV"], na.rm = TRUE), max(report.df[, "AUC"], na.rm = TRUE), max(report.df[, "GausCV"], na.rm = TRUE))
Variances <- c(round(var(report.df[, "BinCV"], na.rm = TRUE), 5), round(var(report.df[, "AUC"], na.rm = TRUE), 5), round(var(report.df[, "GausCV"], na.rm = TRUE), 5))
# if all loops' values are NA (e.g. BinCV & AUC when only gaus), min will be Inf & max -Inf. A bit messy but Unimportant
report.df <- rbind(report.df, Minima, Averages, Maxima, Variances)
rep.len <- dim(report.df)[1]
rownames(report.df) <- c((1:(rep.len - 4)), "Minima", "Averages", "Maxima", "Variances")
####save csvs####
# create resvar named subfolder & go to it
dir.create(names(samples[resvar]))
setwd(names(samples[resvar]))
if (savecsv) {
if (bin) {write.csv(binbars, file = "BinBarsLoop.csv", row.names = T)
write.csv(binbarsgood, file = "BinBarsGoodLoop.csv", row.names = T)}
if (gaus) {write.csv(gausbars, file = "GausBarsLoop.csv", row.names = T)
write.csv(gausbarsgood, file = "GausBarsGoodLoop.csv", row.names = T)}
if (bin) for (n in colnames(samples[expvar])) {
write.csv(get(paste0("binline_", n)), file = paste0("BinLineLoop_", n, ".csv"), row.names = F)}
if (gaus) for (o in colnames(samples[expvar])) {
write.csv(get(paste0("gausline_", o)), file = paste0("GausLineLoop_", o, ".csv"), row.names = F)}
if (calcpreds) {write.csv(var.df, file = "VarAll.csv", row.names = F)
write.csv(var.df[,c(1,2,(3 + loops))], file = "VarOnly.csv", row.names = F)}
write.csv(report.df, file = "Report.csv", row.names = TRUE, col.names = c("LoopNo", "BinCV", "AUC", "GausCV"))
print(paste0("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX csv files created XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"))}
####plot linesfiles####
if (bin) for (p in colnames(samples[expvar])) {
yrange <- c(min(get(paste0("binline_", p))[,"MinLine"]), max(get(paste0("binline_", p))[,"MaxLine"]))
png(filename = paste0("Bin_Loop_lines_", p, ".png"),
width = 4*480, height = 4*480, units = "px", pointsize = 40, bg = "white", res = NA, family = "", type = pngtype)
par(mar = c(2.3,5,0.3,0.4), fig = c(0,1,0,1), las = 1, lwd = 8, bty = "n", mgp = c(1.25, 0.5, 0), xpd = NA)
plot(if (inherits(get(paste0("binline_", p))[,1], "character")) {x = 1:(length(get(paste0("binline_", p))[,1]))} else x = get(paste0("binline_", p))[,1],
# x doesn't work if it's a factor variable
y = get(paste0("binline_", p))[,"AvLine"],
type = "l",
xlab = paste0(p, " (", round(binbars[p, "Av.Inf"],1), "%)"),
ylab = "",
main = "",
yaxs = "r",
ylim = yrange,
axes = FALSE)
# x axis labels
if (inherits(get(paste0("binline_", p))[,1], "character")) {axis(1, at = 1:(length(get(paste0("binline_", p))[,1])), labels = get(paste0("binline_", p))[,1])} else axis(1)
axis(2) # y axis default
mtext("Marginal Effect", side = 2, line = 4.05, las = 0)
lines(if (inherits(get(paste0("binline_", p))[,1], "character")) {x = 1:(length(get(paste0("binline_", p))[,1]))} else x = get(paste0("binline_", p))[,1],
y = get(paste0("binline_", p))[,"MinLine"], col = "grey66") #[,1] is 1st column, X values, always the same
lines(if (inherits(get(paste0("binline_", p))[,1], "character")) {x = 1:(length(get(paste0("binline_", p))[,1]))} else x = get(paste0("binline_", p))[,1],
y = get(paste0("binline_", p))[,"MaxLine"], col = "grey33")
legend("top", # Need to shrink & move this, but where/how to move? if() based on values?
legend = c("Max","Av.","Min"), col = c("grey33","black","grey66"),
lty = 1,
pch = "-")
dev.off()}
if (gaus) for (q in colnames(samples[expvar])) {
yrange <- c(min(get(paste0("gausline_", q))[,"MinLine"]), max(get(paste0("gausline_", q))[,"MaxLine"]))
png(filename = paste0("Gaus_Loop_lines_", q, ".png"),
width = 4*480, height = 4*480, units = "px", pointsize = 40, bg = "white", res = NA, family = "", type = pngtype)
par(mar = c(2.3,5,0.3,0.4), fig = c(0,1,0,1), las = 1, lwd = 8, bty = "n", mgp = c(1.25,0.5,0), xpd = NA)
plot(if (inherits(get(paste0("gausline_", q))[,1], "character")) {x = 1:(length(get(paste0("gausline_", q))[,1]))} else x = get(paste0("gausline_", q))[,1],
y = get(paste0("gausline_", q))[,"AvLine"],
type = "l",
xlab = paste0(q, " (", round(gausbars[q, "Av.Inf"],1), "%)"),
ylab = "",
main = "",
yaxs = "r",
ylim = yrange,
axes = FALSE)
# x axis labels
if (inherits(get(paste0("gausline_", q))[,1], "character")) {axis(1, at = 1:(length(get(paste0("gausline_", q))[,1])), labels = get(paste0("gausline_", q))[,1])} else axis(1)
axis(2) # y axis default
mtext("Marginal Effect", side = 2, line = 4.05, las = 0)
lines(if (inherits(get(paste0("gausline_", q))[,1], "character")) {x = 1:(length(get(paste0("gausline_", q))[,1]))} else x = get(paste0("gausline_", q))[,1],
y = get(paste0("gausline_", q))[,"MinLine"], col = "grey66") #[,1] is 1st column, X values, always the same
lines(if (inherits(get(paste0("gausline_", q))[,1], "character")) {x = 1:(length(get(paste0("gausline_", q))[,1]))} else x = get(paste0("gausline_", q))[,1],
y = get(paste0("gausline_", q))[,"MaxLine"], col = "grey33")
legend("top", legend = c("Max","Av.","Min"), col = c("grey33","black","grey66"),
lty = 1, pch = "-")
dev.off()}
print(paste0("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX Line plots created XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"))
# bin & gaus barplots####
if (bin) {
pointlineseqbin <- seq(0, length(binbars[,2]) - 1, 1)
revseq <- rev(pointlineseqbin)
png(filename = "BinBarsLoop.png", width = 4*480, height = 4*480, units = "px",
pointsize = 4*12, bg = "white", res = NA, family = "", type = pngtype)
par(mar = c(2.5,0.3,0,0.5), fig = c(0,1,0,1), cex.lab = 0.5, mgp = c(1.5,0.5,0), cex = 1.3, lwd = 6)
midpoints <- barplot(rev(binbars[,2]), cex.lab = 1.2, las = 1,
horiz = TRUE, cex.names = 0.8, xlab = "Av. Influence %",
col = NA, border = NA,
xlim = c(0,2.5 + ceiling(max(binbars[,2]))),
ylim = c(0, length(binbars[,2])))
for (r in 1:length(binbars[,2])) {
lines(c(0, binbars[r,2]), c(revseq[r], revseq[r]), col = "black", lwd = 8)} #draw lines
text(0.1, pointlineseqbin + (length(binbars[,2])/55), labels = rev(rownames(binbars)), adj = 0, cex = 0.8)
axis(side = 1, lwd = 6, outer = TRUE, xpd = NA)
dev.off()
pointlineseqbin <- seq(0, length(binbarsgood[,2]) - 1, 1)
revseq <- rev(pointlineseqbin)
png(filename = "BinBarsGoodLoop.png", width = 4*480, height = 4*480, units = "px",
pointsize = 4*12, bg = "white", res = NA, family = "", type = pngtype)
par(mar = c(2.5,0.3,0,0.5), fig = c(0,1,0,1), cex.lab = 0.5, mgp = c(1.5,0.5,0), cex = 1.3, lwd = 6)
midpoints <- barplot(rev(binbarsgood[,2]), cex.lab = 1.2, las = 1,
horiz = TRUE, cex.names = 0.8, xlab = "Av. Influence %",
col = NA, border = NA,
xlim = c(0,2.5 + ceiling(max(binbarsgood[,2]))),
ylim = c(0, length(binbarsgood[,2])))
for (r in 1:length(binbarsgood[,2])) {
lines(c(0, binbarsgood[r,2]), c(revseq[r], revseq[r]), col = "black", lwd = 8)} #draw lines
text(0.1, pointlineseqbin + (length(binbarsgood[,2])/55), labels = rev(rownames(binbarsgood)), adj = 0, cex = 0.8)
axis(side = 1, lwd = 6, outer = TRUE, xpd = NA)
dev.off()}
if (gaus) {
pointlineseqgaus <- seq(0, length(gausbars[,2]) - 1, 1)
revseq <- rev(pointlineseqgaus)
png(filename = "GausBarsLoop.png", width = 4*480, height = 4*480, units = "px",
pointsize = 4*12, bg = "white", res = NA, family = "", type = pngtype)
par(mar = c(2.5,0.3,0,0.5), fig = c(0,1,0,1), cex.lab = 0.5, mgp = c(1.5,0.5,0), cex = 1.3, lwd = 6)
midpoints <- barplot(rev(gausbars[,2]), cex.lab = 1.2, las = 1,
horiz = TRUE, cex.names = 0.8, xlab = "Av. Influence %",
col = NA, border = NA,
xlim = c(0,2.5 + ceiling(max(gausbars[,2]))),
ylim = c(0, length(gausbars[,2])))
for (s in 1:length(gausbars[,2])) {
lines(c(0, gausbars[s,2]), c(revseq[s], revseq[s]), col = "black", lwd = 8)}
text(0.1, pointlineseqgaus + (length(gausbars[,2])/55), labels = rev(rownames(gausbars)), adj = 0, cex = 0.8)
axis(side = 1, lwd = 6, outer = TRUE, xpd = NA)
dev.off()
pointlineseqgaus <- seq(0, length(gausbarsgood[,2]) - 1, 1)
revseq <- rev(pointlineseqgaus)
png(filename = "GausBarsGoodLoop.png", width = 4*480, height = 4*480, units = "px",
pointsize = 4*12, bg = "white", res = NA, family = "", type = pngtype)
par(mar = c(2.5,0.3,0,0.5), fig = c(0,1,0,1), cex.lab = 0.5, mgp = c(1.5,0.5,0), cex = 1.3, lwd = 6)
midpoints <- barplot(rev(gausbarsgood[,2]), cex.lab = 1.2, las = 1,
horiz = TRUE, cex.names = 0.8, xlab = "Av. Influence %",
col = NA, border = NA,
xlim = c(0,2.5 + ceiling(max(gausbarsgood[,2]))),
ylim = c(0, length(gausbarsgood[,2])))
for (s in 1:length(gausbarsgood[,2])) {
lines(c(0, gausbarsgood[s,2]), c(revseq[s], revseq[s]), col = "black", lwd = 8)}
text(0.1, pointlineseqgaus + (length(gausbarsgood[,2])/55), labels = rev(rownames(gausbarsgood)), adj = 0, cex = 0.8)
axis(side = 1, lwd = 6, outer = TRUE, xpd = NA)
dev.off()}
print(paste0("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX Bar plots plotted XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"))
####map predabund CofVs####
if (calcpreds) if (varmap) { # if mapping requested,
if (is.null(shape)) { # and shape not set, check presence of basemap
if (!exists("gbm.basemap")) {stop("you need to install gbm.basemap to run this function")}
bounds = c(range(grids[,gridslon]),range(grids[,gridslat])) #then create bounds
#create standard bounds from data, and extra bounds for map aesthetic
xmid <- mean(bounds[1:2])
ymid <- mean(bounds[3:4])
xextramax <- ((bounds[2] - xmid) * 1.6) + xmid
xextramin <- xmid - ((xmid - bounds[1]) * 1.6)
yextramax <- ((bounds[4] - ymid) * 1.6) + ymid
yextramin <- ymid - ((ymid - bounds[3]) * 1.6)
extrabounds <- c(xextramin, xextramax, yextramin, yextramax)
shape <- gbm.basemap(bounds = extrabounds)
} else {shape <- shape} # if shape not null then use it.
png(filename = "CofVMap.png", width = 4*1920, height = 4*1920, units = "px",
pointsize = 4*48, bg = "white", res = NA, family = "", type = pngtype)
par(mar = c(3.2,3,1.3,0), las = 1, mgp = c(2.1,0.5,0), xpd = FALSE)
gbm.map(x = var.df[,gridslon], # add Unrepresentativeness alpha surface
y = var.df[,gridslat],
z = var.df[,"C of V"],
mapmain = "Coefficient of Variation: ",
species = names(samples[resvar]),
legendtitle = paste0("C. of V.: ", measure),
####change this####
shape = shape) #either autogenerated or set by user so never blank
#breaks = expm1(breaks.grid(log(2000), ncol = 8, zero = FALSE))/2000)
dev.off() #high value log breaks mean first ~5 values cluster near 0 for high
# res there, but high values captures in the last few bins.
} # close map optional
setwd("../") # go back up from samples-named wd to original parent
if (alerts) beep(3)
if (calcpreds) return(var.df) #return output
} # close function
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.