### Single site sensitivity analysis
options(warn = -1)

require(tidyverse)
output <- readRDS(".data/SingleSim.rds")
output.succes <- do.call("bind_rows", output) %>%
	filter(conv != FALSE) %>% mutate(sd = exp(as.numeric(SIGMA)))

nowintering <- output.succes %>% filter(propWint == "0.0" & propA == "1.0") %>% mutate(MU = MU - mean(baseruns$MU))

baseruns <- nowintering %>% filter(LoS == 5 & ArrivalDate ==4)
nowintering <- nowintering%>% mutate(MU = MU - mean(baseruns$MU))
lm.dat <- mutate(nowintering, LoS = as.numeric(LoS), Pop = as.numeric(Pop), ArrivalDate = as.numeric(ArrivalDate))
lm.res <- lm(MU~LoS*ArrivalDate, lm.dat)

aug_lm <- broom::augment(lm.res, lm.dat)

#### Final plot # 1
simplt1 <-
ggplot(aug_lm, aes(LoS,.fitted, shape = as.factor(ArrivalDate))) + #geom_line() +
  stat_summary(aes(y=MU), fun.data = "mean_cl_boot" , #position = position_dodge(width = 0.15),
               fun.args = c(conf.int = 0.95, B = 2000), geom = "pointrange") +
  # geom_hline(yintercept = 0)+
  # geom_pointrange(position = position_jitter(width = 0.2),aes(y=MU, ymin=MU - sd, ymax = MU + sd )) +
   scale_shape_manual(values=c(2,1,19,15)) + geom_hline(yintercept = 0, linetype=2)+
  scale_y_continuous( breaks = seq(-6, 6, by = 2), minor_breaks = seq(-5, 5, by = 2)) +
  cowplot::background_grid(size.major = 1, major = "y", minor = "y", size.minor = .8)+
  labs(x = "\nMean length of stay", y= "Deviation from \nbaseline peak passage date", shape = "Mean\ndate of\narrival")

# Wintering birds ---------------------------------------------------------

outputWinter <- output.succes %>% filter(propA == "1.0") %>% mutate(MU = MU - mean(baseruns$MU))
baseWint <- outputWinter %>% filter(LoS == 5 & ArrivalDate ==4)

# Winter final plot 1
wintplt1 <-
  ggplot(baseWint, aes(as.numeric(propWint), MU)) +
  # geom_smooth(method="lm", formula = "y~poly(x,2)", se = F, colour = 'grey') +
  # geom_point()+
  stat_summary(fun.data= 'mean_cl_boot', geom="pointrange") +
  labs(x = "Proportion of Winter\nResidents in Population", y="Deviation from \nbaseline peak passage date") +#+ ggthemes::theme_few()
  geom_hline(yintercept = 0, linetype=2)+
  scale_y_continuous( breaks = seq(-6, 6, by = 1), minor_breaks = seq(-5, 5, by = 2)) +
  cowplot::background_grid(size.major = 1, major = "y", minor = "y", size.minor = .8)

wintplt2 <-
ggplot(outputWinter, aes(as.numeric(propWint), MU, shape = ArrivalDate)) + scale_x_continuous() +
  # geom_smooth(colour = 'grey', aes(linetype = ArrivalDate), method="lm", formula = "y~poly(x,2)", se = F) +
   stat_summary(position=position_dodge(width = 0.02), fun.data= 'mean_cl_boot') +
  scale_shape_manual(values=c(2,1,19,15)) +
  #scale_color_grey(start = 0.9, end = 0.2)+
  geom_hline(yintercept = 0, linetype=2)+
  scale_y_continuous( breaks = seq(-60, 20, by = 20), minor_breaks = seq(-60, 20, by = 10)) +
  cowplot::background_grid(size.major = 1, major = "y", minor = "y", size.minor = .8)+
  labs(x = "Proportion of Winter Residents in Population",
       y="Deviation from \nbaseline peak passage date",
       colour = "Mean\nArrival\nDate")

# Two groups --------------------------------------------------------------

two.shoes <- output.succes %>% filter(propWint == "0.0" & ArrivalDate >1) %>% mutate(MU = MU - mean(baseruns$MU, na.rm=T))

base2gr <-two.shoes %>% filter(LoS == 5 & ArrivalDate ==4)

twopops.plt <-
ggplot(base2gr, aes(as.numeric(propA), MU)) +
  # geom_smooth(method="lm", formula = "y~poly(x,2)", se = F, colour = "grey") +
  stat_summary(fun.data= 'mean_cl_boot', geom="pointrange") +
  labs(x = "Proportion of Baseline\nStrategy in Population", y="Deviation from baseline passage date")+
  geom_hline(yintercept = 0, linetype=2)+
  scale_y_continuous( breaks = seq(-6, 6, by = 0.5), minor_breaks = seq(-5, 5, by = 2)) +
  cowplot::background_grid(size.major = 1, major = "y", minor = "y", size.minor = .8)

# Smallpop ----------------------------------------------------------------

smallpop <- readRDS(".data/SingleSim_smallpop.rds") %>%
  do.call("rbind", .) %>% filter(conv == TRUE) %>% bind_rows(baseruns) %>%
mutate(Pop = as.numeric(as.character(Pop)), MU = MU - mean(baseruns$MU))

pop.plt <-
ggplot(smallpop, aes(Pop, MU))  +
  # geom_hline(yintercept = 0, colour = 'grey')+
  stat_summary( fun.data= 'mean_cl_boot') +
  scale_x_log10(breaks = c(1,10,50,100,500,1000, 10000))+
   # ggthemes::theme_few() +
  labs(y = "Deviation from baseline passage date", x = "Total number of birds stopping at site") +
  geom_hline(yintercept = 0, linetype=2)+ theme(axis.text.x = element_text(size = 10,angle=30, hjust = 0.9,vjust =0.9))+
  scale_y_continuous( breaks = seq(-6, 6, by = 1), minor_breaks = seq(-5, 5, by = 2)) +
  cowplot::background_grid(size.major = 1, major = "y", minor = "y", size.minor = .8)

require(cowplot)
legend1 <- cowplot::get_legend(wintplt2 + labs(shape = "Arrival\nDate"))
final.p <-plot_grid(simplt1  + theme(legend.position="none", text=element_text(size=10))+ ylab("") +
                      background_grid(major = 'y', minor = "none") + ylim(-6.5,5),
                    twopops.plt + ylab("")+ theme(legend.position="none", text=element_text(size=10))+
                      background_grid(major = 'y', minor = "none") +
                                    ylim(-6.5,5),
                    wintplt1 + ylab("")+ theme(legend.position="none", text=element_text(size=10))+
                      background_grid(major = 'y', minor = "none") +
                                    ylim(-6.5,5),
                    pop.plt+theme(legend.position="none", text=element_text(size=10))+ ylab("")+
                      background_grid(major = 'y', minor = "none") +
                                     ylim(-6.5,5),
                                  nrow=2,ncol=2, rel_heights = c(.45,.45,.1), labels = c("(A)", "(B)", "(C)", "(D)"),
                    hjust=-0.1)#,
                                  # left = "Deviation from baseline\npassage date (days)")

final.pLab <- gridExtra::grid.arrange(final.p, legend1, ncol =2, widths = c(0.9, 0.1), padding=unit(0.8, "line"),
                                      left= "Deviation from baseline passage date (days)")

# save_plot("../6th Submission/Figure5.tiff", final.pLab, base_width = 7, base_height = 7)

## Example of how to read and calculate peak passage date from output of model
# ---------------------------------------------------------------------------------
# Test def of peak passage date -------------------------------------------

# require(tidyverse)

# exampleRun <- read_tsv(".data/singleSimulation_[573]_[5]_[4]_[10000]_[0.0][1.0].csv") %>%
#   mutate()
# exPPest <- exampleRun %>%
#   filter(site == 0) %>%
#   group_by(Bird) %>%
#   summarize(meanD = floor(mean(time))) %>% ungroup %>%
#   group_by(meanD) %>%
#   summarize(nPass = n(),
#             peakPassage = mean(meanD),
#             medPassage = median(meanD))

# source("muEstimation.R")

# dataforCalc <- exampleRun %>% group_by(time) %>%
#   filter(site == 0) %>%
#   summarize(WESA = n()) %>%
#   ungroup %>% mutate(Year = 2016,
#                      SiteID = "Simulation",
#                      Day.of.Year = time) %>% filter(Day.of.Year >= quantile(exampleRun$time, 0.025)[1] & Day.of.Year <= quantile(exampleRun$time, 0.975)[1])
# results_1 <- calc.peak.prog(site = "Simulation", year = 2016, data = dataforCalc, species = "WESA", estimateCI = T, errorMethod = 'jackknife')
# results_1$results
# exPPest
# weighted.mean(dataforCalc$Day.of.Year, dataforCalc$WESA)
# options(warn = 0)


#####################################################################
# Fitting generalized additive models to fraction feeding data
# See '...GAM_robustness.r' for model justifications, including
# error family and link function and gamma wiggliness penalty
#####################################################################
#####################################################################
rm(list = ls())
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
library(plyr)
library(mgcv)
library(xtable) # for LaTeX export
library(ggplot2)
source('R/FracFeed-Functions.r') # Convenience functions
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Load saved 'fdat' w/ tWS
load('Data/FracFeed_DataPhylo.Rdata') # load full post-ToL FracFeed database
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
nrow(fdat) # total number of surveys in database
length(unique(fdat$Consumer.identity)) # total number of species in database
range(fdat$Latitude, na.rm = TRUE)
range(fdat$Year, na.rm = TRUE)

#####################################################################
# Summary stats by Taxonomic Group
##################################
TaxonGroupLevels <-
  c(
    'Ctenophores',
    'Cnidarians',
    'Annelids',
    'Chaetognaths',
    'Molluscs',
    'Echinoderms',
    'Arthropods',
    'Fish',
    'Reptiles',
    'Amphibians',
    'Birds',
    'Mammals'
  )
fdat$Taxon.group <- factor(fdat$Taxon.group, levels = TaxonGroupLevels)
sfdat <-
  ddply(
    fdat,
    .(Taxon.group),
    summarise,
    'Mean' = mean(fF),
    'Std.dev.' = sd(fF),
    Min = min(fF),
    Max = max(fF),
    Surveys = length(fF),
    Species = length(unique(Consumer.identity)),
    minObs = min(Total.stomachs.count, na.rm = T),
    maxObs = max(Total.stomachs.count, na.rm = T)
  )
sfdat[, 2:5] <- round(sfdat[, 2:5], 2)

setwd('Figures/Supp/')
print(
  xtable(sfdat, type = "latex", caption = 'Summary statistics for all taxa in the database, including those that could not be used in the analyses of the main text for lack of co-variate information. minObs and maxObs refer to the minimum and maximum number of individuals assessed in a single survey across all surveys of the group.'),
  file = "FracFeed-Tab-SummStats.tex",
  include.rownames = FALSE,
  table.placement = 'H'
)
setwd('../../')

pdf(
  'Figures/Supp/FracFeed-FigS-TaxonViolins.pdf',
  height = 3,
  width = 5
)
viol <-
  ggplot(fdat, aes(Taxon.group, Percent.feeding)) +
  geom_violin(scale = "width", bg = 'grey') +
  labs(x = '', y = 'Percent feeding') +
  theme_classic() + theme(axis.text.x = element_text(angle = 60, hjust = 1)) +
  stat_summary(fun.data = data_summary, color = "black") +
  annotate("text", x = 1:nrow(sfdat), y = 106,
           label = sfdat$Species, size = 1.5) +
  annotate("text", x = 1:nrow(sfdat), y = 103,
           label = paste0("(", sfdat$Surveys, ")"),                                                               size = 1.5)
print(viol)
dev.off()

################################################
# General model specifications
# (justified in GAM_robustness)
################################################
fam <- quasibinomial(link = 'logit')

# To get actual used sample size (after dropped rows)
# (needed for determining BIC-like gamma penalty)
fit <- gam(
  (FSc / TSc) ~
    s(tWS, bs = 'cc') + s(Lat) + s(DRlog) + s(Year) +
    TAlog + SAlog + Eco + EE + TG,
  family = fam,
  weights = TSc,
  knots = list(tWS = c(0, 365)),
  data = fdat,
  na.action = 'na.omit',
  method='REML'
)
gamma <- log(nrow(fit$model)) / 2

#######################
# All primary variables
#######################
fit1.cont <- fit <- gam(
  (FSc / TSc) ~
    s(tWS, bs = 'cc') + s(Lat) + s(DRlog) + s(Year) +
    TAlog + SAlog + Eco + EE + TG,
  family = fam,
  weights = TSc,
  knots = list(tWS = c(0, 365)),
  data = fdat,
  na.action = 'na.omit',
  method = 'REML',
  gamma = gamma
)

# Compare data lost vs. included
nrow(fit$model)
excl <- fdat[fit$na.action, ]
nrow(excl)

incl <- fdat[-fit$na.action, ]
nrow(incl)
length(unique(incl$Consumer.identity))
range(incl$Year, na.rm = TRUE)
range(incl$Lat, na.rm = TRUE)

nrow(fdat)
nrow(excl) + nrow(incl)
length(unique(fdat$Consumer.identity))

# odds ratio
exp(cbind("Odds ratio" = coef(fit)[c('TAlog', 'SAlog')],
          confint.default(fit, c('TAlog', 'SAlog'), level = 0.95)))
1 / exp(cbind("Odds ratio" = coef(fit)[c('SAlog')],
              confint.default(fit, c('SAlog'), level = 0.95)))

save(fit, file = 'Output/GAM/GAM_fit_wTaxInf.Rdata')

pdf('Output/GAM/GAM_fit_wTaxInf.pdf',
    height = 8,
    width = 10)
plot(
  fit,
  residuals = F,
  seWithMean = TRUE,
  shade = TRUE,
  rug = TRUE,
  all.terms = TRUE,
  pch = '.',
  pages = 1
)
par(mfrow = c(2, 2))
gam.check(fit)
dev.off()

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Same but with TA and SA as factors
fit1.fact <- fit <- gam(
  (FSc / TSc) ~
    s(tWS, bs = 'cc') + s(Lat) + s(DRlog) + s(Year) +
    TA + SA + Eco + EE + TG,
  family = fam,
  weights = TSc,
  knots = list(tWS = c(0, 365)),
  data = fdat,
  na.action = 'na.omit',
  method = 'REML',
  gamma = gamma
)

summary(fit)
logit_tr(summary(fit)$p.coeff)

save(fit, file = 'Output/GAM/GAM_fit_wTaxInf_TASAfact.Rdata')

pdf('Output/GAM/GAM_fit_wTaxInf_TASAfact.pdf',
    height = 8,
    width = 10)
plot(
  fit,
  residuals = F,
  seWithMean = TRUE,
  shade = TRUE,
  rug = TRUE,
  all.terms = TRUE,
  pch = '.',
  pages = 1
)
par(mfrow = c(2, 2))
gam.check(fit)
dev.off()

# Export summary tables
p.out <- summary(fit1.fact)$p.table
p.out[, 1:3] <- signif(p.out[, 1:3], 2)
p.out[, 4] <- signif(p.out[, 4], 3)
p.out[p.out[, 4] < 10 ^ -3, 4] <- '< 0.001'
p.out[p.out == 'NaN'] <- ''

rownames(p.out) <- sub('TA', '', rownames(p.out))
rownames(p.out) <- sub('SA', '', rownames(p.out))
rownames(p.out) <- sub('Eco', '', rownames(p.out))
rownames(p.out) <- sub('EE', '', rownames(p.out))
rownames(p.out) <- sub('TG', '', rownames(p.out))

s.out <- summary(fit1.fact)$s.table
s.out[, 1:3] <- round(s.out[, 1:3], 2)
s.out[, 4] <- round(s.out[, 4], 3)
s.out[s.out[, 4] < 10 ^ -3, 4] <- '< 0.001'

setwd('Figures/Supp/')
print(
  xtable(
    p.out,
    type = "latex",
    caption = 'Estimated effects (log-odds) of the parametric terms in the primary statistical model describing variation in the observed fraction of feeding individuals.  The intercept to which all effects are relative corresponds to an ectothermic marine mollusc surveyed at a spatial scale of up to 1 meter for under an hour.  Birds correspond to the endotherm baseline.',
    label = 'tab:gam_main_p'
  ),
  file = "FracFeed-Tab-GAM_main_ptable.tex",
  table.placement = 'H'
)

print(
  xtable(
    s.out,
    type = "latex",
    caption = 'Estimated effects of the smooth terms in the primary statistical model describing variation in the observed fraction of feeding individuals. $tWS$ refers to the days since the last winter solsctice, $Lat$ refers to latitude, $DRlog$ refers to $log_{10}$ of minimum diet richness, and $Year$ refers to the year of the survey.',
    label = 'tab:gam_main_s'
  ),
  file = "FracFeed-Tab-GAM_main_stable.tex",
  table.placement = 'H'
)
setwd('../../')

##############################################################
# Same (with TA and SA as factors) but relative to terrestrial
# (to ease language of main text)
##############################################################
orig <- levels(fdat$Eco)
fdat$Eco <- factor(fdat$Eco, levels = rev(orig))
fit <- gam(
  (FSc / TSc) ~
    s(tWS, bs = 'cc') + s(Lat) + s(DRlog) + s(Year) +
    TA + SA + Eco + EE + TG,
  family = fam,
  weights = TSc,
  knots = list(tWS = c(0, 365)),
  data = fdat,
  na.action = 'na.omit',
  method = 'REML',
  gamma = gamma
)

summary(fit)
trms <- summary(fit)$p.coeff
sel <- grep('Eco', names(trms))
# Log-odds
trms[sel]
# Odds-ratios
exp(trms[sel])
exp(cbind("Odds ratio" = coef(fit)[sel],
          confint.default(fit, sel, level = 0.95)))

# now to compare lakes and streams
fdat$Eco <- factor(fdat$Eco, levels = orig[c(3, 4, 5, 1, 2)])
fit <- gam(
  (FSc / TSc) ~
    s(tWS, bs = 'cc') + s(Lat) + s(DRlog) + s(Year) +
    TA + SA + Eco + EE + TG,
  family = fam,
  weights = TSc,
  knots = list(tWS = c(0, 365)),
  data = fdat,
  na.action = 'na.omit',
  method = 'REML',
  gamma = gamma
)

summary(fit)
trms <- summary(fit)$p.coeff
sel <- grep('Eco', names(trms))
# Log-odds
trms[sel]
# Odds-ratios
exp(trms[sel])
exp(cbind("Odds ratio" = coef(fit)[sel],
          confint.default(fit, sel, level = 0.95)))

# Reorder to original
fdat$Eco <- factor(fdat$Eco, levels = orig)

################################################################
# Same (with TA and SA as factors) but with DRlog as parametric linear term
# (to enable language of main text)
################################################################
fit <- gam(
  (FSc / TSc) ~
    s(tWS, bs = 'cc') + s(Lat) + DRlog + s(Year) +
    TA + SA + Eco + EE + TG,
  family = fam,
  weights = TSc,
  knots = list(tWS = c(0, 365)),
  data = fdat,
  na.action = 'na.omit',
  method = 'REML',
  gamma = gamma
)

summary(fit)
trms <- summary(fit)$p.coeff
sel <- grep('DRlog', names(trms))
# Log-odds
trms[sel]
# Odds-ratios
exp(cbind("Odds ratio" = coef(fit)[sel],
          confint.default(fit, sel, level = 0.95)))

####################################################################
# Without taxonomic information for phylogenetic tests
# (i.e. remove Endo/Ecto, Taxon Group, Diet richness and Ecosystem)
####################################################################
fit.noTaxInf <- fit <- gam(
  (FSc / TSc) ~
    s(tWS, bs = 'cc') + s(Lat) + s(Year) +
    TAlog + SAlog,
  family = fam,
  weights = TSc,
  knots = list(tWS = c(0, 365)),
  data = fdat,
  na.action = 'na.omit',
  method = 'REML',
  gamma = gamma
)

anova(fit)
summary(fit)

# How many data points included (because the others didn't have info for all variables)?
nrow(fit$model)
excl <- fdat[fit$na.action, ]
nrow(excl)

save(fit, file = 'Output/GAM/GAM_fit_noTaxInf.Rdata')

pdf(paste0('Output/GAM/GAM_fit_noTaxInf.pdf'),
    height = 8,
    width = 10)
plot(
  fit,
  residuals = F,
  seWithMean = TRUE,
  shade = TRUE,
  rug = TRUE,
  all.terms = TRUE,
  pch = '.',
  pages = 1
)
par(mfrow = c(2, 2))
gam.check(fit)
dev.off()

########################################################################
####################################
# Final model plus feeding data type
# (dismissed during robustness checks
# but requested by reviewers)
####################################
fit1.fact <- fit <- gam(
  (FSc / TSc) ~
    s(tWS, bs = 'cc') + s(Lat) + s(DRlog) + s(Year) +
    TA + SA + Eco + EE + TG + FD,
  family = fam,
  weights = TSc,
  knots = list(tWS = c(0, 365)),
  data = fdat,
  na.action = 'na.omit',
  method = 'REML',
  gamma = gamma
)

summary(fit)
logit_tr(summary(fit)$p.coeff)

pdf(
  'Output/GAM/GAM_fit_wTaxInf_TASAfact_wFD.pdf',
  height = 8,
  width = 10
)
plot(
  fit,
  residuals = F,
  seWithMean = TRUE,
  shade = TRUE,
  rug = TRUE,
  all.terms = TRUE,
  pch = '.',
  pages = 1
)
par(mfrow = c(2, 2))
gam.check(fit)
dev.off()

# Export summary tables
p.out <- summary(fit1.fact)$p.table
p.out[, 1:3] <- signif(p.out[, 1:3], 2)
p.out[, 4] <- signif(p.out[, 4], 3)
p.out[p.out[, 4] < 10 ^ -3, 4] <- '< 0.001'
p.out[p.out == 'NaN'] <- ''

rownames(p.out) <- sub('TA', '', rownames(p.out))
rownames(p.out) <- sub('SA', '', rownames(p.out))
rownames(p.out) <- sub('Eco', '', rownames(p.out))
rownames(p.out) <- sub('EE', '', rownames(p.out))
rownames(p.out) <- sub('TG', '', rownames(p.out))
rownames(p.out) <- sub('FD', '', rownames(p.out))

s.out <- summary(fit1.fact)$s.table
s.out[, 1:3] <- round(s.out[, 1:3], 2)
s.out[, 4] <- round(s.out[, 4], 3)
s.out[s.out[, 4] < 10 ^ -3, 4] <- '< 0.001'

setwd('Figures/Supp/')
print(
  xtable(
    p.out,
    type = "latex",
    caption = 'Estimated effects (log-odds) of the parametric terms in the primary statistical model but with data type (stomach contents versus direct observation) also included.',
    label = 'tab:gam_main_p'
  ),
  file = "FracFeed-Tab-GAM_main_wFD_ptable.tex",
  table.placement = 'H'
)

print(
  xtable(
    s.out,
    type = "latex",
    caption = 'Estimated effects of the smooth terms in the primary statistical model but with data type (stomach contents versus direct observation) also included.',
    label = 'tab:gam_main_wFD_s'
  ),
  file = "FracFeed-Tab-GAM_main_wFD_stable.tex",
  table.placement = 'H'
)
setwd('../../')

####################################################################
####################################################################
####################################################################


df = expand.table(Titanic)


# takes g_inputdir,g_filetable and g_outputdir
##and g_duration_slider, g_bin_size
# return activity plots

message("starting activity.r")
### compute the activities

act_table = data.frame()

#compute activities for each individum
for (i in c(1:nrow(id_table))) {
	act = c.activity(traj[id(traj)==id_table$id[i]],g_duration_slider/10)
	act_id = rep(id_table$id[i],nrow(act))
	act_group = rep(id_table$group[i],nrow(act))
	act_table = rbind(act_table,data.frame(act,id=act_id,group=act_group))

}

# filter activities which are smaller than the act slider
pause_table = act_table[act_table$act<0,]
pause_table$pause = - pause_table$act
act_table = act_table[act_table$act>0,]

#calculate total activity time for each individual
sum_act = c()
median_act = c()
median_pause = c()
number_pause = c()
for (i in c(1:nrow(id_table))) {
	act = act_table[act_table$id==id_table$id[i],]$act
	pause = pause_table[act_table$id==id_table$id[i],]$act
	sum_act = c(sum_act,sum(act))
	median_act = c(median_act,median(act))
	median_pause = c(median_pause, median(abs(pause)))
	number_pause = c(number_pause,length(pause))

}
act_table_2 = data.frame(sum_act,median_act,median_pause,number_pause,id=id_table$id,group=id_table$group)

message("starting writing activities.txt")

setwd(rgghome)

# create bins
if (g_bin_size==0)
	g_bin_size = 0.5
v = act_table$act
bins = seq(min(v[!is.na(v)])-g_bin_size,max(v[!is.na(v)])+g_bin_size,g_bin_size)

#create mean and sd table
mean_table = create.mean.table(act_table_2,group_ids,data_cols=1:4)

message("starting plots activity")
### create plots
mybarplot(mean_table$means$sum_act,mean_table$ses$sum_act,rownames(mean_table$means),
	main="Total activity time",ylab="Total activity time [s]")
mybarplot(mean_table$means$median_act,mean_table$ses$median_act,rownames(mean_table$means),
	main="Mean activity time",ylab="Median activity time [s]")

mybarplot(mean_table$means$number_pause,mean_table$ses$number_pause,rownames(mean_table$means),
	main="Number of pauses",ylab="Number of pauses")

mybarplot(mean_table$means$median_pause,mean_table$ses$median_pause,rownames(mean_table$means),
	main="Mean pause time",ylab="Median pause time [s]")

message("starting activity frequence plot")
hplot2 = histogram(~ act | group ,data=act_table,breaks=bins-0.01, type="percent",col=0)
hplot2 = update(hplot2,main="Activity Histogram (Groups)", ylab="frequency", xlab="activity time [s]",layout=c(2,2))
print(hplot2)

hplot2 = hist(pause_table$pause,breaks= c(seq(0,200, 0.05),  seq(220,1000,20)), plot=FALSE)
print(plot(hplot2, xlim=c(0,100)))

#hplot2$counts = (hplot2$counts/ length (pause_table$pause))
print(plot(hplot2, xlim=c(0,100)))

hplot2$counts[hplot2$counts==0] <- -1

hplot2$counts = log(hplot2$counts)
#hplot2$counts[is.na(hplot2$counts)] <- -1

print(plot(hplot2$counts, xlim=c(0,1000), pch=20, xlab = "pause length", ylab= "ln(counts)"))


#' Extract wet and dry N deposition data from NADP and CASTNET (2000-2015 average)
#' There are currently warnings. ignore them.
#'
#' @param longitude a vector of site longitude
#' @param latitude  a vector of site latitude
#' @param folder path to directory that contains sub directories 'wet_dep' and 'dry_dep'.
#' These then contain all ndep rasters.
#' folder path currently defaults to the directory in colin's folder on pecan2.
#'
#' @return returns a dataframe of wet, dry and total ndeposition values for all sites.
#' @export
#'
#' @examples

extract_ndep <- function(longitude,latitude,folder='/fs/data3/caverill/CASTNET_Ndep/'){
  #load dry deposition rasters
  dry.list <- list()
  for(i in 0:15){
    dry.list[[i+1]] <- raster::raster(file.path(folder,paste0('dry_dep/n_dw-',2000 + i,'.e00')))
  }
  #load wet deposition rasters
  wet.list <- list()
  for(i in 0:15){
    wet.list[[i+1]] <- raster::raster(file.path(folder,paste0('wet_dep/n_ww-',2000 + i,'.e00')))
  }

  #Fix the crs of each raster.
  for(i in 1:length(dry.list)){
    raster::crs(dry.list[[i]]) <- "+proj=aea +lat_1=29.5 +lat_2=45.5 +lat_0=23.0 +lon_0=-96.0 +x_0=0 +y_0=0 +ellps=GRS80 +towgs84=0,0,0,0,0,0,0 +units=m +no_defs"
  }
  for(i in 1:length(wet.list)){
    raster::crs(wet.list[[i]]) <- "+proj=aea +lat_1=29.5 +lat_2=45.5 +lat_0=23.0 +lon_0=-96.0 +x_0=0 +y_0=0 +ellps=GRS80 +towgs84=0,0,0,0,0,0,0 +units=m +no_defs"
  }

  #grab long/lat. (important longitude before latitude)
  points <- cbind(longitude,latitude)
  #reproject points
  points <- sp::SpatialPoints(points, proj4string = sp::CRS("+init=epsg:4326"))

  #extract dry deposition, convert to mean annual
  dry.out <- list()
  for(i in 1:length(dry.list)){
    dry.out[[i]] <- raster::extract(dry.list[[i]], points)
  }
  dry.dep <- Reduce('+',dry.out) / length(dry.out)
  #extract wet deposition
  wet.out <- list()
  for(i in 1:length(wet.list)){
    wet.out[[i]] <- raster::extract(wet.list[[i]], points)
  }
  wet.dep <- Reduce('+',wet.out) / length(wet.out)

  #total ndep and output.
  n.dep <- dry.dep + wet.dep
  output <- data.frame(n.dep, dry.dep, wet.dep)

  return(output)
}


# Set up hash table
keys <- c("John Smith", "Lisa Smith", "Sam Doe", "Sandra Dee", "Ted Baker")
values <- c(152, 1, 254, 152, 153)
names(values) <- keys
# Get value corresponding to a key
values["Sam Doe"]                          # vals["Sam Doe"]
# Get all keys corresponding to a value
names(values)[values==152]                 # "John Smith" "Sandra Dee"


RMSE_row<-function(data0)
{
        return(apply(data0^2,1,mean))
}

normalize_data2<-function(data0)
{
        data1<-data0
        for(i in 1:nrow(data1))
        {
                data1[i,]<-(data1[i,]-mean(data1[i,]))/sd(data1[i,])
        }
        return(data1)
}

Compute_base_ES_score<-function(ES_c,tg_selected_c)
{
	ccc<-c()
	for(i in 1:length(tg_selected_c))
	{
		ccc<-c(ccc,mean(ES_c[tg_selected_c[[i]]]))
	}
	names(ccc)<-names(tg_selected_c)
	return(ccc)
}

compute_CompRowspace_NN_selflist<-function(tg_data,tg_data_ng,tg_list,ROUNDS=3)
{
	Rbase_selected_R4_og<-Compute_Rbase_SVD(tg_data_ng,tg_list)
	Rbase_selected_R4<-Compute_Rbase_SVD(tg_data,tg_list)
	aaa<-matrix(0,length(tg_list),ROUNDS)
	bbb<-matrix(0,length(tg_list),ROUNDS)
	ddd<-matrix(0,length(tg_list),ROUNDS)
      for(j in 1:length(tg_list))
      {
		tg_data_c<-tg_data[tg_list[[j]],]
        	Base_c<-Rbase_selected_R4[-j,]
		#print(tg_data_c[,1:5])
		#print(j)
		#print(Base_c[,1:5])
		#print(j)
		tg_id_kk<-setdiff(1:length(tg_list),j)
		ccc<-c()
		ccc<-compute_CompRowspace_NN_uni(tg_data_c,module_RB=Base_c,ROUNDS=3)
		#print(ccc)
		if(length(ccc)>0)
		{
			tg_id1<-tg_id_kk[ccc[1,]]
			aaa[j,1:length(tg_id1)]<-tg_id1
			bbb[j,1:length(tg_id1)]<-ccc[2,]
			ddd[j,1:length(tg_id1)]<-ccc[3,]
		}
  	}
	tg_ids<-which(apply(bbb,1,min)<0.2)
	c_cell_depend<-list()
	N<-0
	nn<-c()
	for(j in 1:length(tg_ids))
	{
		tg_c<-aaa[tg_ids[j],which(ddd[tg_ids[j],]>0.1)]
		if(length(tg_c)>0)
		{
			data_ccc<-t(Rbase_selected_R4_og[c(tg_ids[j],tg_c),])
			colnames(data_ccc)<-c("Y",tg_c)
			rownames(data_ccc)<-1:nrow(data_ccc)
			data_ccc<-as.data.frame(data_ccc)
			lm_cc<-lm(Y~.+0,data=data_ccc)
			ccc<-summary(lm_cc)$coefficients
			cc1<-which((ccc[,4]<0.01)&ccc[,1]>0)
			cc2<-which((ccc[,4]<0.01)&ccc[,1]<0)
			dd1<-c()
			dd2<-c()
			if(length(cc1)>0)
			{
				dd1<-tg_c[cc1]
			}
			if(length(cc2)>0)
			{
				dd2<-tg_c[cc2]
			}
			dd3<-setdiff(tg_c,c(dd1,dd2))
			c_l<-c(tg_ids[j],dd2)
			c_r<-c(dd1)
			cc<-list(c_l,c_r)
			names(cc)<-c("right","left")
			N<-N+1
			c_cell_depend[[N]]<-cc
			nn<-c(nn,tg_ids[j])
		}
	}
	names(c_cell_depend)<-nn
	baba<-c()
	didi<-c()
	for(i in 1:length(c_cell_depend))
	{
		cc<-c_cell_depend[[i]]
		if((length(cc[[1]])==1)&(length(cc[[2]])>1))
		{
			baba<-c(baba,cc[[1]])
			didi<-c(didi,cc[[2]])
		}
	}
	baba<-unique(sort(baba))
	didi<-setdiff(unique(sort(didi)),baba)
	daye<-setdiff(1:length(tg_list),unique(sort(c(didi,baba))))
	ccc<-list(didi,baba,daye,c_cell_depend)
	names(ccc)<-c("Leaf_CT","Root_CT","Other_leat_CT","Cell_dependency")
      return(ccc)
}

compute_CompRowspace_NN_uni<-function(tg_data_c,module_RB=Base_c,ROUNDS=3)
{
          tg_list_c<-list()
          tg_list_c[[1]]<-rownames(tg_data_c)
          dd<-Compute_Rbase_SVD(tg_data_c,tg_list_c)
        dd<-dd/sd(dd)
          tg_list_selected<-c()
          ee_all<-c()
        ee_all<-c(ee_all,RMSE_row(dd))
        for(ii in 1:ROUNDS)
        {
        ccc<-cor(t(dd),t(module_RB))
                tg_id_c<-which(ccc==max(ccc))[1]
                if(ccc[tg_id_c]>0)
                {
                  tg_list_selected<-c(tg_list_selected,tg_id_c)
                ttt_ccc<-module_RB[tg_id_c,]%*%t(module_RB[tg_id_c,])/sum((module_RB[tg_id_c,])^2)
                dd<-dd-dd%*%ttt_ccc
                  ee_all<-c(ee_all,RMSE_row(dd))
                }
        }
        ee_all<-ee_all/ee_all[1]
          ee_all2<-ee_all[-1]
          if(length(ee_all2)>0)
          {
                for(i in 2:length(ee_all))
                {
                        ee_all2[i-1]<-ee_all[i-1]-ee_all[i]
                }
          }
          ee_all<-ee_all[-1]
          ccc<-c()
          if(length(ee_all)>0)
          {
             ccc<-rbind(tg_list_selected,ee_all,ee_all2)
 colnames(ccc)<-1:ncol(ccc)
          }
         return(ccc)
}

compute_CompRowspace_NN<-function(data_cc=tg_data,module_RB=module_selected[[4]],ROUNDS=3)
{
        data_CORS_cancer<-data_cc
        for(ii in 1:ROUNDS)
        {
        ccc<-cor(t(data_CORS_cancer),t(module_RB))
        if(nrow(module_RB)>1)
        {
                ddd<-apply(ccc,1,order)
                eee<-ddd[nrow(ddd),]
                eee<-eee*(apply(ccc,1,max)>0)
                tg_ids<-sort(setdiff(unique(eee),0))
                if(length(tg_ids)>0)
                {
                        for(i in 1:length(tg_ids))
                        {
                                ttt_ccc<-module_RB[tg_ids[i],]%*%t(module_RB[tg_ids[i],])/sum((module_RB[tg_ids[i],])^2)
                                data_CORS_cancer[names(which(eee==tg_ids[i])),]<-data_CORS_cancer[names(which(eee==tg_ids[i])),]-data_CORS_cancer[names(which(eee==tg_ids[i])),]%*%ttt_ccc
                        }
                }
        }
        else
        {
                ddd<-apply(ccc,1,order)
                eee<-ddd
                eee<-eee*(as.vector(ccc)>0)
                tg_ids<-sort(setdiff(unique(eee),0))
                if(length(tg_ids)>0)
                {
                        for(i in 1:length(tg_ids))
                        {
                                ttt_ccc<-module_RB[tg_ids[i],]%*%t(module_RB[tg_ids[i],])/sum((module_RB[tg_ids[i],])^2)
                                data_CORS_cancer[names(which(eee==tg_ids[i])),]<-data_CORS_cancer[names(which(eee==tg_ids[i])),]-data_CORS_cancer[names(which(eee==tg_ids[i])),]%*%ttt_ccc
                        }
                }
        }
        }
        return(data_CORS_cancer)
}

compute_IM_stat<-function(tg_list_c,immune_cell_uni_table=immune_cell_uni_table0_GS,IM_id_list0=ICTD::IM_id_list)
{
	ccc<-c()
	nn<-c()
	for(i in 1:length(tg_list_c))
	{
        ccc0<-c()
        for(j in 1:length(ICTD::IM_id_list))
        {
      if(length(ICTD::IM_id_list[[j]])>1)
      {
            cc0<-apply(immune_cell_uni_table[tg_list_c[[i]],IM_id_list0[[j]]],1,sum)/sum((1/(1:length(IM_id_list0[[j]]))))
      }
      else
      {
           cc0<-immune_cell_uni_table[tg_list_c[[i]],IM_id_list0[[j]]]
      }
                ccc0<-cbind(ccc0,cc0)
        }
        colnames(ccc0)<-names(ICTD::IM_id_list)
      ddd<-apply(ccc0,2,mean)
      ccc<-rbind(ccc,ddd)
      nn<-c(nn,colnames(ccc0)[which(ddd==max(ddd))[1]])
	}
	rownames(ccc)<-nn
	return(ccc)
}

identify_max_base<-function(tg_R1_c,data.matrix,tProp)
{
	cc<-Compute_Rbase_SVD(data.matrix,tg_R1_c)
	tg_R1_c_list<-list()
	dd<-cor(t(cc),t(tProp))
	for(i in 1:ncol(dd))
	{
		tg_id<-which(dd[,i]==max(dd[,i]))[1]
		tg_R1_c_list[[i]]<-tg_R1_c[[tg_id]]
	}
	names(tg_R1_c_list)<-colnames(dd)
	return(tg_R1_c_list)
}

identify_max_base2<-function(tg_R1_c,data.matrix,tProp)
{
	cc<-Compute_Rbase_SVD(data.matrix,tg_R1_c)
	tg_R1_c_list<-list()
	dd<-cor(t(cc),t(tProp))
	ff<-c()
	for(i in 1:ncol(dd))
	{
		tg_id<-which(dd[,i]==max(dd[,i]))[1]
		tg_R1_c_list[[i]]<-tg_R1_c[[tg_id]]
		ff<-c(ff,tg_id)
	}
	print(ff)
	names(tg_R1_c_list)<-colnames(dd)
	return(tg_R1_c_list)
}

select_R_base<-function(tg_R1_c,tg_id)
{
	tg_R1_cc<-list()
	for(i in 1:length(tg_id))
	{
		tg_R1_cc[[i]]<-tg_R1_c[[tg_id[i]]]
	}
	names(tg_R1_cc)<-names(tg_R1_c)[tg_id]
	return(tg_R1_cc)
}


ef <- function(model='Schwab', from=NA, to=NA, efdata=NA, adjdates=NULL, period='months',
               annualize=TRUE, addline=TRUE, col='black', lty=1, pch=3) {
    ## create Efficient Frontier points to assess TWR vs. risk

    ## model = 'Schwab' uses a blend of US L, US S, Inter, Fixed, and Cash
    ##       = 'SSP'    uses a blend of US L           and Fixed

    ## duration defined from one of the following
    ## addline == FALSE:
    ##     if false, then execution is assumed primarily to obtain output
    ##     for subsequent call with ef(symbols, efdata=efdata, from=xx, to=yy)
    ## from, to, and period:
    ##     from   = end of day to start
    ##     to     = end of day to end
    ##     period = 'months' (default), 'days', 'weeks', 'years'
    ## efdata:
    ##     efdata = output from prior execution of ef
    ##              used to extract twri for benchmark so no call needed to yahoo
    ##              efdata$twri needs to contain incremental twr values for:
    ##                  'SPY', 'IWM', 'EFA', 'AGG', 'SHV'
    ##              where:
    ##                  US L  = SPY
    ##                  US S  = IWM (iShares Russel 2000)
    ##                  Inter = EFA (iShares MSCI EAFE of large and mid cap
    ##                               in developed contries excluding US and Canada)
    ##                  Fixed = AGG
    ##                  Cash  = SHV (iShares Short Treasury Bond, < 1 yr)

    ## to just get twri data for subsequent use
    ##    twrief <- ef(period='months', addline=FALSE)$twri
    ## then to create ef line
    ##    ef(model='Schwab',

    if (is.na(efdata[1])) {
        ## efdata is not provided so need to get it
        symbol <- c('SPY', 'IWM', 'EFA', 'AGG', 'SHV')
        if (isFALSE(addline)) {
            ## do not worry about dates and just get data for subsequent call to ef()
            out <- equity.twri(symbol, period=period)
            twri <- na.omit(out)
        } else if (is.null(adjdates)) {
            out  <- equity.history(symbol, from=from, to=to, period=period)
            twri <- na.omit( out$twri )
        } else {
            out <- equity.twri(symbol, adjdates=adjdates)
            twri <- na.omit(out)
        }
        twri_in <- NA

    } else {
        ## efdata is provided so can use it directly
        if (class(efdata)[1] == 'xts') {
            ## input efdata is simply an xts object of twri values
            twri_in <- efdata
        } else {
            ## input efdata is full output of prior run of ef()
            twri_in <- efdata$twri
        }
        twri <- twri_in
    }

    ## restrict to duration
    if (is.na(from)) from <- zoo::index(twri)[1]
    if (is.na(to))   to   <- zoo::index(twri)[nrow(twri)]
    xtsrange <- paste(noquote(from), '/', noquote(to), sep='')
    xtsrange
    twri <- twri[xtsrange]

    if (model == 'test') {
        twri <- head(twri, 4)
        twri[1,] <- c(0.1, 0.11, 0.1, 0.1, 0.1)
        twri[2,] <- c(0.1, 0.12, 0.1, 0.1, 0.1)
        twri[3,] <- c(0.1, 0.13, 0.1, 0.1, 0.1)
        twri[4,] <- c(0.1, 0.14, 0.11, 0.1, 0.1)
    }

    ## calculate twrc and standard deviation
    ## 1st date should have twrc = 0
    ## twrc_apply <- apply(twri, 2, function(x) { prod(x+1) - 1 }) / (twri[1,] + 1)
    twrc  <- xts::as.xts( t(t(cumprod(twri+1)) / as.vector(twri[1,]+1) - 1) )
    twrcl <- tail(twrc, 1)
    std    <- apply(twri[2:nrow(twri)], 2, sd)

    if (isTRUE(annualize)) {

        ## calculate annualized standard deviation from monthly standard deviation
        ##    std(xi) = sqrt ( sum(xi-xbar)^2 / N ) for population which seems to be what finance world uses
        ## If have x = monthly TWR and want std for y = yearly TWR
        ## then set F * std(x) = std(y) and solve for F.
        ## If assume yi = 12*xi and give credit for the fact that 1 yearly entry is from 12 measurments,
        ## then can use Ny = 12*Nm and F = sqrt(12).
        ## std( TWR_monthly - avg_TWR_monthly )
        std  <- std * 12^0.5

        ## average annual return
        days.held <- as.numeric(as.Date(to) - as.Date(from))
        twrcl  <- (1 + twrcl)^(365.25 / days.held) - 1
    }

    ## define asset class weights for requested benchmark model
    if (model == 'Schwab') {
        ##              US L  US S  Inter Fixed  Cash
        ##              ----- ----- ----- -----  ----
        schwab_95_5  <- c(0.50, 0.20, 0.25, 0.00,  0.05)  # bench - aggressive (95 /  5)
        schwab_80_20 <- c(0.45, 0.15, 0.20, 0.15,  0.05)  # bench - mod agg    (80 / 20)
        schwab_60_40 <- c(0.35, 0.10, 0.15, 0.35,  0.05)  # bench - moderage   (60 / 40)
        schwab_40_60 <- c(0.25, 0.05, 0.10, 0.50,  0.10)  # bench - mod consv  (40 / 60)
        schwab_20_80 <- c(0.15, 0.00, 0.05, 0.50,  0.30)  # bench - consverv   (20 / 80)
        schwab_0_100 <- c(0.00, 0.00, 0.00, 0.40,  0.60)  # bench - short term ( 0 /100)
        weight <- rbind(schwab_95_5, schwab_80_20, schwab_60_40,
                        schwab_40_60, schwab_20_80, schwab_0_100)

    } else if (model == 'test') {
        ##              US L  US S  Inter Fixed  Cash
        ##              ----- ----- ----- -----  ----
        one         <- c(0.2, 0.3,  0.2,  0.2,   0.2)
        two         <- c(0,   1,    0,    1,     0  )
        weight <- rbind(one, two)

    } else {
        ##              US L  US S  Inter Fixed  Cash
        ##              ----- ----- ----- -----  ----
        SSP_500     <- c(1.00, 0.00, 0.00, 0.00,  0.00)
        bench_80_20 <- c(0.80, 0.00, 0.00, 0.20,  0.00)
        bench_60_40 <- c(0.60, 0.00, 0.00, 0.40,  0.00)
        bench_40_60 <- c(0.40, 0.00, 0.00, 0.60,  0.00)
        bench_20_80 <- c(0.20, 0.00, 0.00, 0.80,  0.00)
        US_bonds    <- c(0.00, 0.00, 0.00, 1.00,  0.00)
        weight <- rbind(SSP_500, bench_80_20, bench_60_40, bench_40_60, bench_20_80, US_bonds)
    }
    colnames(weight) <- c('US L', 'US S', 'Inter', 'Fixed', 'Cash')

    ## ## approximation (not too bad for twr;
    ##                   no good for sd since different benchmarks can compensate for eachother)
    ## ## calculate benchmark twr to define efficient frontier twr
    ## eftwr <- weight %*% twrc          # column vector
    ## colnames(eftwr) <- 'EF TWR'

    ## calculate twri for efficient frontier model
    eftwri <- twri %*% t(weight)              # matrix
    ## turn back into xts
    eftwri <- xts::as.xts( zoo::as.zoo( eftwri, zoo::index(twri)))

    ## calculate cumulative twr and standard deviation
    eftwrc  <- t(t(cumprod(eftwri+1)) / as.vector(eftwri[1,]+1) - 1)
    eftwrcl <- t( xts::last(eftwrc) )
    colnames(eftwrcl) <- 'eftwrc'
    efstd <- as.matrix( apply(eftwri[2:nrow(eftwri),], 2, sd) )  # column vector
    colnames(efstd)  <- 'efstd'

    if (isTRUE(annualize)) {
        ## calculate annualized standard deviation from monthly standard deviation
        eftwrcl <- (1 + eftwrcl)^(365.25 / days.held) - 1
        efstd   <- efstd * 12^0.5
    }

    ef <- as.data.frame( cbind(eftwrcl, efstd) )

    if (isTRUE(addline)) {
        ## plot lines for whatever period the data was supplied for
        lines(ef$efstd, ef$eftwrc, type='b', col=col, lty=lty, pch=pch)
    }

    return(list(model=model, weight=weight, twri_in=twri_in, twri=twri, twrc=twrc, std=std,
                eftwri=eftwri, ef=ef, from=from, to=to))
}
## ef(from='2020-12-31', to='2021-11-11')
## ef(model='simple', from='2015-12-31', to='2021-11-30')


# A set of "pluggable" R functions for automated model fitting of glm models to presence/absence data #
#
# Modified 12-2-09 to:  remove categorical covariates from consideration if they only contain one level
#                       ID factor variables based on "categorical" prefix and look for tifs in subdir
#                       Give progress reports
#                       write large output tif files in blocks to alleviate memory issues
#                       various bug fixes
#
#
# Modified 3-4-09 to use a list object for passing of arguements and data
#

# Libraries required to run this program #
#   PresenceAbsence - for ROC plots
#   XML - for XML i/o
#   rgdal - for geotiff i/o
#   sp - used by rdgal library
#   raster for geotiff o
options(error=NULL)

fit.glm.fct <- function(ma.name,tif.dir=NULL,output.dir=NULL,response.col="^response.binary",make.p.tif=T,make.binary.tif=T,
      simp.method="AIC",responseCurveForm=NULL,debug.mode=F,model.family="binomial",script.name="glm.r",opt.methods=2,save.model=TRUE,UnitTest=FALSE,MESS=FALSE){
    # This function fits a stepwise GLM model to presence-absence data.
    # written by Alan Swanson, 2008-2009
    ## Maintained and edited by Marian Talbert September 2010-
    # Arguements.
    # ma.name: is the name of a .csv file with a model array.  full path must be included unless it is in the current
    #  R working directory #
    # tif.dir: is the directory containing geotiffs for each covariate.  only required if geotiffs output of the
    #   response surface is requested #    # cov.list.name: is the name of a text file with the names of covariates to be included in models (one per line).
    # output.dir: is the directory that output files will be stored in.  if not given, files will go to the current working directory.
    # response.col: column number of the model array containing a binary 0/1 response.  all other columns will be considered explanatory variables.
    # make.p.tif: T if a geotiff of the response surface is desired.
    # make.binary.tif: T if a geotiff of the response surface is desired.
    # simp.method: model simplification method.  valid methods include: "AIC" and "BIC".
    # debug.mode: if T, output is directed to the console during the run.  also, a pdf is generated which contains response curve plots and perspective plots
    #    showing the effects of interactions deemed important.  if F, output is diverted to a text file and the console is kept clear
    #    except for final output of an xml file.  in either case, a set of standard output files are created in the output directory.
    #

    # Value:
    # returns nothing but generates a number of output files in the directory
    # "output.dir" named above.  These output files consist of:
    #
    # glm_output.txt:  a text file with fairly detailed results of the final model.
    # glm_output.xml:  an xml-formatted text file with results from the final model.
    # glm_response_curves.xml:  an xml-formatted text file with response curves for
    #   each covariate in the final model.
    # glm_prob_map.tif:  a geotiff of the response surface
    # glm_bin_map.tif:  a geotiff of the binary response surface.  threhold is based on the roc curve at the point where sensitivity=specificity.
    # glm_log.txt:   a file containing text output diverted from the console when debug.mode=F
    # glm_auc_plot.jpg:  a jpg file of a ROC plot.
    # glm_response_curves.pdf:  an pdf file with response curves for
    #   each covariate in the final model and perspective plots showing the effect of interactions deemed significant.
    #   only produced when debug.mode=T
    #  seed=NULL                                 # sets a seed for the algorithm, any inegeger is acceptable
    #  opt.methods=2                             # sets the method used for threshold optimization used in the
    #                                            # the evaluation statistics module
    #  save.model=FALSE                          # whether the model will be used to later produce tifs
    #
    # when debug.mode is true, these filenames will include a number in them so that they will not overwrite preexisting files. eg brt_1_output.txt.
    #
    times <- as.data.frame(matrix(NA,nrow=7,ncol=1,dimnames=list(c("start","read data","model fit",
            "model summary","response curves","tif output","done"),c("time"))))
    times[1,1] <- unclass(Sys.time())
    t0 <- unclass(Sys.time())
    #simp.method <- match.arg(simp.method)
    out <- list(
      input=list(ma.name=ma.name,
                 tif.dir=tif.dir,
                 output.dir=output.dir,
                 response.col=response.col,
                 make.p.tif=make.p.tif,
                 model.family=model.family,
                 make.binary.tif=make.binary.tif,
                 simp.method=simp.method,
                 model.type="stepwise glm",
                 model.source.file=script.name,
                 model.fitting.subset=NULL,
                 save.model=save.model,
                 run.time=paste(c(format(Sys.time(),"%Y-%m-%d"),format(Sys.time(),"%H:%M:%S")),collapse="T"),
                 sig.test="t-test p-value",
                 MESS=MESS),
      dat = list(missing.libs=NULL,
                 output.dir=list(dname=NULL,exist=F,readable=F,writable=F),
                 tif.dir=list(dname=NULL,exist=F,readable=F,writable=F),
                 tiff.ind=NULL,
                 tif.names=NULL,
                 bname=NULL,
                 bad.factor.covs=NULL, # factorchange
                 ma=list( status=c(exists=F,readable=F),
                          dims=c(NA,NA),
                          resp.name=NULL,
                          factor.levels=NA,
                          used.covs=NULL,
                          ma=NULL,
                          train.weights=NULL,
                          test.weights=NULL,
                          train.xy=NULL,
                          test.xy=NULL,
                          ma.subset=NULL
                          ),
                 ma.test=NULL),
      mods=list(final.mod=NULL,
                r.curves=NULL,
                tif.output=list(prob=NULL,bin=NULL),
                auc.output=NULL,
                interactions=NULL,  # not used #
                summary=NULL),
      time=list(strt=unclass(Sys.time()),end=NULL),
      error.mssg=list(NULL),
      ec=0    # error count #
      )
    # load libaries #
    out <- check.libs(list("PresenceAbsence","rgdal","XML","sp","survival","tools","raster","tcltk2","foreign","ade4"),out)

    # exit program now if there are missing libraries #
    if(!is.null(out$error.mssg[[1]])){
          cat(saveXML(glm.to.xml(out),indent=T),'\n')
          return()
          }

    if(is.na(match(simp.method,c("AIC","BIC")))){
        return()
        }

    # check output dir #

    out$dat$output.dir <- check.dir(output.dir)
    if(out$dat$output.dir$writable==F) {out$ec<-out$ec+1
              out$error.mssg[[out$ec]] <- paste("ERROR: output directory",output.dir,"is not writable")
              out$dat$output.dir$dname <- getwd()
              }

    # generate a filename for output #
    if(debug.mode==T){  #paste(bname,"_summary.txt",sep="")
            outfile <- paste(bname<-paste(out$dat$output.dir$dname,"/glm_",n<-1,sep=""),"_output.txt",sep="")
            while(file.access(outfile)==0) outfile<-paste(bname<-paste(out$dat$output.dir$dname,"/glm_",n<-n+1,sep=""),"_output.txt",sep="")
            capture.output(cat("temp"),file=outfile) # reserve the new basename #
    } else bname <- paste(out$dat$output.dir$dname,"/glm",sep="")
    out$dat$bname <- bname

    # sink console output to log file #
    if(!debug.mode) {sink(logname <- paste(bname,"_log.txt",sep=""));on.exit(sink)} else logname<-NULL
    options(warn=1)

    # check tif dir #
     if(!is.null(tif.dir)){
      out$dat$tif.dir <- check.dir(tif.dir)
      if(out$dat$tif.dir$readable==F & (out$input$make.binary.tif | out$input$make.p.tif)) {
                out$ec<-out$ec+1
                out$error.mssg[[out$ec]] <- paste("ERROR: tif directory",tif.dir,"is not readable")
                if(!debug.mode) {sink();on.exit();unlink(paste(bname,"_log.txt",sep=""))}
              cat(saveXML(brt.to.xml(out),indent=T),'\n')
              return()
              }
            }

    # find .tif files in tif dir #

    if(out$dat$tif.dir$readable)  out$dat$tif.names <- list.files(out$dat$tif.dir$dname,pattern=".tif",recursive=T)

    # check for model array #
    out$input$ma.name <- check.dir(out$input$ma.name)$dname
    if(UnitTest!=FALSE) options(warn=2)
    out <- read.ma(out)
    if(UnitTest==1) return(out)

    if(!is.null(out$error.mssg[[1]])){
          if(!debug.mode) {sink();on.exit();unlink(logname)}
          cat(saveXML(glm.to.xml(out),indent=T),'\n')
          return()
          }
      #allowing site weights

    times[2,1] <- unclass(Sys.time())
    if(!debug.mode) {sink();cat("Progress:20%\n");flush.console();sink(logname,append=T)} else {cat("\n");cat("20%\n")}  ### print time
    cat("\nbegin processing of model array:",out$input$ma.name,"\n")
    cat("\nfile basename set to:",out$dat$bname,"\n")
    if(debug.mode) assign("out",out,envir=.GlobalEnv)

    ##############################################################################################################
    #  Begin model fitting #
    ##############################################################################################################

    # Fit null GLM and run stepwise, then print results #
    cat("\n","Fitting stepwise GLM","\n")
    flush.console()
    penalty <- if(out$input$simp.method=="AIC") 2 else log(nrow(out$dat$ma$ma))
    scope.glm <- list(lower=as.formula(paste(out$dat$ma$resp.name,"~1")),
        upper=as.formula(paste(out$dat$ma$resp.name,"~",paste(out$dat$ma$used.covs,collapse='+'))))

    mymodel.glm.step <- step(glm(as.formula(paste(out$dat$ma$resp.name,"~1")),family=out$input$model.family,data=out$dat$ma$ma,weights=out$dat$ma$train.weights,na.action="na.exclude"),
          direction='both',scope=scope.glm,trace=0,k=penalty)

    out$mods$final.mod <- mymodel.glm.step

    out$dat$ma$used.covs <- attr(terms(formula(out$mods$final.mod)),"term.labels")
    #assign("out",out,envir=.GlobalEnv)
    t3 <- unclass(Sys.time())
    cat("\n","Finished with stepwise GLM","\n")
    cat("Summary of Model:","\n")
    print(out$mods$summary <- summary(mymodel.glm.step))
    if(!is.null(out$dat$bad.factor.cols)){
        cat("\nWarning: the following categorical response variables were removed from consideration\n",
            "because they had only one level:",paste(out$dat$bad.factor.cols,collapse=","),"\n\n")
        }
    flush.console()

    flush.console()
    times[3,1] <- unclass(Sys.time())
    if(!debug.mode) {sink();cat("Progress:40%\n");flush.console();sink(logname,append=T)} else cat("40%\n")

     #r<-residuals(out$mods$final.mod, "deviance")

    if(length(coef(out$mods$final.mod))==1) stop("Null model was selected.  \nEvaluation metrics and plots will not be produced")

    ##############################################################################################################
    #  Begin model output #
    ##############################################################################################################

    # Store .jpg ROC plot #
     txt0 <- paste("Generalized Linear Results\n",out$input$run.time,"\n\n","Data:\n\t ",ma.name,"\n\t ","n(pres)=",
        out$dat$ma$n.pres[2],"\n\t n(abs)=",out$dat$ma$n.abs[2],"\n\t number of covariates considered=",(length(names(out$dat$ma$ma))-1),
        "\n\n","Settings:\n","\n\t model family=",out$input$model.family,
        "\n\n","Results:\n\t ","number covariates in final model=",length(out$dat$ma$used.covs),
        "\n\t total time for model fitting=",round((unclass(Sys.time())-t0)/60,2),"min\n",sep="")

    capture.output(cat(txt0),file=paste(bname,"_output.txt",sep=""))

        capture.output(out$mods$summary,file=paste(bname,"_output.txt",sep=""),append=TRUE)
    if(!is.null(out$dat$bad.factor.cols)){
        capture.output(cat("\nWarning: the following categorical response variables were removed from consideration\n",
            "because they had only one level:",paste(out$dat$bad.factor.cols,collapse=","),"\n"),
            file=paste(bname,"_output.txt",sep=""),append=T)
        }

      auc.output <- make.auc.plot.jpg(out$dat$ma$ma,pred=predict(mymodel.glm.step,type='response'),plotname=paste(bname,"_auc_plot.jpg",sep=""),modelname="GLM",opt.methods=opt.methods,
            weight=out$dat$ma$train.weights,out=out)

      out$mods$auc.output<-auc.output

 # if(out$input$model.family=="poisson"){
 #     auc.output <- make.poisson.jpg(out$dat$ma$ma,pred=predict(mymodel.glm.step,type='response'),
 #     plotname=paste(bname,"_auc_plot.jpg",sep=""),modelname="BRT",
 #           weight=out$dat$ma$train.weights,out=out)

  #    out$mods$auc.output<-auc.output
   #   }

  #  out$mods$auc.output<-auc.output

    times[4,1] <- unclass(Sys.time())
    if(!debug.mode) {sink();cat("Progress:70%\n");flush.console();sink(logname,append=T)} else cat("70%\n")

    # Response curves #

if(is.null(responseCurveForm)){
responseCurveForm<-0}

if(debug.mode | responseCurveForm=="pdf"){
        nvar <- length(coef(out$mods$final.mod))-1
        pcol <- min(ceiling(sqrt(nvar)),4)
        prow <- min(ceiling(nvar/pcol),3)

        pdf(paste(bname,"_response_curves.pdf",sep=""),width=11,height=8.5,onefile=T)
            par(oma=c(2,2,4,2),mfrow=c(prow,pcol))
            r.curves <-my.termplot(out$mods$final.mod,plot.it=T)
            mtext(paste("GLM response curves for",basename(ma.name)),outer=T,side=3,cex=1.3)
            par(mfrow=c(1,1))
            graphics.off()
        } else r.curves<-try(my.termplot(out$mods$final.mod,plot.it=F))

        if(class(r.curves)!="try-error") {
            out$mods$r.curves <- r.curves
                } else {
            out$ec<-out$ec+1
            out$error.mssg[[out$ec]] <- paste("ERROR: problem fitting response curves",r.curves)
            }

    t4 <- unclass(Sys.time())
    cat("\nfinished with final model summarization, t=",round(t4-t3,2),"sec\n");flush.console()
    times[5,1] <- unclass(Sys.time())
    if(!debug.mode) {sink();cat("Progress:80%\n");flush.console();sink(logname,append=T)} else cat("80%\n")

    ##############################################################################################################
    # Make .tif of predictions #
    ##############################################################################################################
        out$mods$final.mod$contributions$var<-attr(terms(formula(out$mods$final.mod)),"term.labels")
         assign("out",out,envir=.GlobalEnv)

 save.image(paste(output.dir,"modelWorkspace",sep="\\"))
    if(out$input$make.p.tif==T | out$input$make.binary.tif==T){
        if((n.var <- length(coef(out$mods$final.mod)))<2){
            mssg <- "Error producing geotiff output:  null model selected by stepwise procedure - pointless to make maps"
            class(mssg)<-"try-error"
            } else {
            cat("\nproducing prediction maps...","\n","\n");flush.console()
            mssg <- proc.tiff(model=out$mods$final.mod,vnames=attr(terms(formula(out$mods$final.mod)),"term.labels"),
                tif.dir=out$dat$tif.dir$dname,filenames=out$dat$tif.ind,pred.fct=glm.predict,factor.levels=out$dat$ma$factor.levels,make.binary.tif=make.binary.tif,
                thresh=out$mods$auc.output$thresh,make.p.tif=make.p.tif,outfile.p=paste(out$dat$bname,"_prob_map.tif",sep=""),
                outfile.bin=paste(out$dat$bname,"_bin_map.tif",sep=""),tsize=50,NAval=-3000,fnames=out$dat$tif.names,logname=logname,out=out)     #"brt.prob.map.tif"
            }
      #  model=out$mods$final.mod;vnames=attr(terms(formula(out$mods$final.mod)),"term.labels");
#                tif.dir=out$dat$tif.dir$dname;pred.fct=glm.predict;factor.levels=out$dat$ma$factor.levels;make.binary.tif=make.binary.tif;
#                thresh=out$mods$auc.output$thresh;make.p.tif=make.p.tif;outfile.p=paste(out$dat$bname,"_prob_map.tif",sep="");
#                outfile.bin=paste(out$dat$bname,"_bin_map.tif",sep="");tsize=50;NAval=-3000;fnames=out$dat$tif.names
        if(class(mssg)=="try-error"){
          if(!debug.mode) {sink();on.exit();unlink(logname)}
          out$ec<-out$ec+1
          out$error.mssg[[out$ec]] <- paste("Error producing prediction maps:",mssg)
          cat(saveXML(glm.to.xml(out),indent=T),'\n')
          return()
        }  else {
            if(make.p.tif) out$mods$tif.output$prob <- paste(out$dat$bname,"_prob_map.tif",sep="")
            if(make.binary.tif) out$mods$tif.output$bin <- paste(out$dat$bname,"_bin_map.tif",sep="")
            t5 <- unclass(Sys.time())
            cat("\nfinished with prediction maps, t=",round(t5-t4,2),"sec\n");flush.console()
          }
        }
    times[6,1] <- unclass(Sys.time())
    if(!debug.mode) {sink();cat("Progress:90%\n");flush.console();sink(logname,append=T)} else cat("90%\n")

     # Evaluation Statistics on Test Data#

    if(!is.null(out$dat$ma$ma.test)) Eval.Stat<-EvaluationStats(out,thresh=auc.output$thresh,train=out$dat$ma$ma,
    train.pred=predict(mymodel.glm.step,type="response"),opt.methods)

    # Write summaries to xml #
    assign("out",out,envir=.GlobalEnv)
    doc <- glm.to.xml(out)

    #cat(paste("\ntotal time=",round((unclass(Sys.time())-t0)/60,2),"min\n\n\n",sep=""))
    if(!debug.mode) {
        sink();on.exit();unlink(logname)
        cat("Progress:100%\n");flush.console()
        cat(saveXML(doc,indent=T),'\n')
        flush.console()
        } else {cat("100%\n")}
    capture.output(cat(saveXML(doc,indent=T)),file=paste(out$dat$bname,"_output.xml",sep=""))
    assign("fit",out$mods$final.mod,envir=.GlobalEnv)
    times[7,1] <- unclass(Sys.time())

    times$net <- times$time - times$time[1]
    times$pct <- round(times$net/times$net[7]*100,2)
    times$process <- c(0,times$time[-1]-times$time[-7])
    times$ppcnt <- round(times$process/times$net[7]*100,2)
    write.csv(times,paste(bname,"times.csv",sep="_"))
    invisible(out)
}

glm.predict <- function(model,x) {
    # retrieve key items from the global environment #
    # make predictionss.

    y <- as.vector(predict(model,x,type="response"))

    # encode missing values as -1.
    y[is.na(y)]<- NaN

    # return predictions.
    return(y)
    }

logit <- function(x) 1/(1+exp(-x))

file_path_as_absolute <- function (x){
    if (!file.exists(epath <- path.expand(x)))
        stop(gettextf("file '%s' does not exist", x), domain = NA)
    cwd <- getwd()
    on.exit(setwd(cwd))
    if (file_test("-d", epath)) {
        setwd(epath)
        getwd()
    }
    else {
        setwd(dirname(epath))
        file.path(getwd(), basename(epath))
    }
}
#file_path_as_absolute(".")

glm.to.xml <- function(out){
    require(XML)
    schema.http="http://www.w3.org/2001/XMLSchema-instance"
    schema.fname="file:/Users/isfs2/Desktop/Source/2008-04-09/src/gov/nasa/gsfc/quickmap/ModelBuilder/modelRun_output_v2.xsd"
    xml.out <- newXMLDoc()
    mr <- newXMLNode("modelRunOutput",doc=xml.out,namespaceDefinitions=c(xsi=schema.http,noNamespaceSchemaLocation=schema.fname))#,parent=xml.out
    sm <- newXMLNode("singleModel",parent=mr)
    bg <- newXMLNode("background",parent=sm)
        newXMLNode("mdsName",out$input$ma.name,parent=bg)
        newXMLNode("runDate",out$input$run.time,parent=bg)
        lc <- newXMLNode("layersConsidered",parent=bg)#, parent = xml.out)
        kids <- lapply(paste(out$dat$tif.dir$dname,"/",out$dat$tif.names,sep=""),function(x) newXMLNode("layer", x))
        addChildren(lc, kids)
        mo <- newXMLNode("modelOutput",parent=sm)
        newXMLNode("modelType",out$input$model.type,parent=mo)
        newXMLNode("modelSourceFile",out$input$model.source.file,parent=mo)
        newXMLNode("devianceExplained",out$mods$auc.output$pct_dev_exp,parent=mo,attrs=list(type="percentage"))
        newXMLNode("nativeOutput",paste(out$dat$bname,"_output.txt",sep=""),parent=mo)
        newXMLNode("binaryOutputFile",out$mods$tif.output[[2]],parent=mo)
        newXMLNode("probOutputFile",out$mods$tif.output[[1]],parent=mo)
        newXMLNode("auc",out$mods$auc.output$auc,parent=mo)
        newXMLNode("rocGraphic",out$mods$auc.output$plotname,parent=mo)
        newXMLNode("rocThresh",out$mods$auc.output$thresh,parent=mo)
        newXMLNode("modelDeviance",out$mods$auc.output$dev_fit,parent=mo)
        newXMLNode("nullDeviance",out$mods$auc.output$null_dev,parent=mo)
        if(is.null(out$mods$r.curves)) rc.name <- NULL else rc.name <- paste(out$dat$bname,"_response_curves.xml",sep="")
        newXMLNode("responsePlotsFile",rc.name,parent=mo)
        newXMLNode("significanceDescription",out$input$sig.test,parent=mo)
        mfp <- newXMLNode("modelFitParmas",parent=mo)
            newXMLNode("simpMethod",out$input$model.type,parent=mfp)
            newXMLNode("simpCriteria",out$input$simp.method,parent=mfp)

        sv <- newXMLNode("significantVariables",parent=mo)
        if(!is.null(out$mods$summary)) {
            t.table <- out$mods$summary$coefficients
            t.table <- t.table[order(t.table[,4]),]
            dimnames(t.table)[[2]] <- c("coefficient","standardError","testStatistic","significanceMeasurement")
            t.table <- as.data.frame(t.table)
            for(i in 1:nrow(t.table)){
                x <- newXMLNode("sigVar",parent=sv)
                newXMLNode(name="name", row.names(t.table)[i],parent=x)
                kids <- lapply(1:ncol(t.table),function(j) newXMLNode(name=names(t.table)[j], t.table[i,j]))
                addChildren(x, kids)
                }
            }

    if(!is.null(out$mods$r.curves)){
        r.curves <-  out$mods$r.curves
        factor.levels <- out$dat$ma$factor.levels
        rc.out <- newXMLDoc()
        root <- newXMLNode("responseCurves",doc=rc.out,namespaceDefinitions=c(xsi=schema.http,noNamespaceSchemaLocation=schema.fname))
        for(i in 1:length(r.curves$names)){
            if(!is.na(f.index<-match(r.curves$names[i],names(factor.levels)))){
                  vartype <- "factor"} else vartype="continuous"
            x <- newXMLNode("responseCurve",attrs=list(covariate=r.curves$names[i],type=vartype),parent=root)
            kids <- lapply(1:length(r.curves$preds[[i]]),function(j){
                    newXMLNode(name="responsePt",parent=x,.children=list(
                        newXMLNode(name="explanatory",as.character(r.curves$preds[[i]])[j]),
                        newXMLNode(name="response",r.curves$resp[[i]][j])))})
            addChildren(x,kids)
            }
        saveXML(rc.out,rc.name,indent=T)

        } else { rc.name<-NULL }
    if(!is.null(out$error.mssg[[1]])) {
        kids <- lapply(out$error.mssg,function(j) newXMLNode(name="error",j))
        addChildren(mo,kids)
        }
    return(xml.out)
    }

get.cov.names <- function(model){
    return(attr(terms(formula(model)),"term.labels"))
    }

check.dir <- function(dname){
    if(is.null(dname)) dname <- getwd()
    dname <- gsub("[\\]","/",dname)
    end.char <- substr(dname,nchar(dname),nchar(dname))
    if(end.char == "/") dname <- substr(dname,1,nchar(dname)-1)
    exist <- suppressWarnings(as.numeric(file.access(dname,mode=0))==0) # -1 if bad, 0 if ok #
    if(exist) dname <- file_path_as_absolute(dname)
    readable <- suppressWarnings(as.numeric(file.access(dname,mode=4))==0) # -1 if bad, 0 if ok #
    writable <- suppressWarnings(as.numeric(file.access(dname,mode=2))==0) # -1 if bad, 0 if ok #
    return(list(dname=dname,exist=exist,readable=readable,writable=writable))
    }

get.image.info <- function(image.names){
    # this function creates a data.frame with summary image info for a set of images #
    require(rgdal)
    require(tools)
    n.images <- length(image.names)

    full.names <- image.names
    out <- data.frame(image=full.names,available=rep(F,n.images),size=rep(NA,n.images),
        type=factor(rep("unk",n.images),levels=c("asc","envi","tif","unk")))
    out$type[grep(".tif",image.names)]<-"tif"
    out$type[grep(".asc",image.names)]<-"asc"
    for(i in 1:n.images){
        if(out$type[i]=="tif"){
            x <-try(GDAL.open(full.names[1],read.only=T))
            suppressMessages(try(GDAL.close(x)))
            if(class(x)!="try-error") out$available[i]<-T
            x<-try(file.info(full.names[i]))
        } else {
            x<-try(file.info(full.names[i]))
            if(!is.na(x$size)) out$available[i]<-T
        }
        if(out$available[i]==T){
            out$size[i]<-x$size
            if(out$type[i]=="unk"){
                # if extension not known, look for envi .hdr file in same directory #
                if(file.access(paste(file_path_sans_ext(full.names[i]),".hdr",sep=""))==0)
                    out$type[i]<-"envi"
                }
        }
    }
    return(out)
}

#make.r.curves.glm <- function(model){
#    tms <- as.matrix(predict(model,type="terms"))
#    mf <- model.frame(model)
#    preds <- list()
#    response <- list()
#    p.names <- colnames(tms)
#    is.fac <- sapply(p.names, function(i) is.factor(mf[, i]))
#    for(i in 1:length(p.names)){
#        if(is.fac[i]){
#            ff <- mf[, p.names[i]]
#            if (!is.null(model$na.action)) ff <- naresid(model$na.action,ff)
#            xx <- as.numeric(ff)
#            ll <- levels(ff)
#            out <- rep(NA,length(ll))
#            for (j in seq_along(ll)) {
#                    ww <- which(ff == ll[j])[1]
#                    out[j]<-tms[ww,i]
#                    #out[j]<-tms[ff==ll[j],i][1]
#                    }
#
#            }
#
#
#
#data = NULL; envir = environment(formula(model));
#    partial.resid = FALSE; rug = FALSE; terms = NULL; se = FALSE;
#    xlabs = NULL; ylabs = NULL; main = NULL; col.term = 2; lwd.term = 1.5;
#    col.se = "orange"; lty.se = 2; lwd.se = 1; col.res = "gray";
#    cex = 1; pch = par("pch"); col.smth = "darkred"; lty.smth = 2;
#    span.smth = 2/3; ask = dev.interactive() && nb.fig < n.tms;
#    use.factor.levels = TRUE; smooth = NULL; ylim = "common";plot.it=F;
#terms="yell_250m_evi_16landcovermap_4ag05"
my.termplot <- function (model, data = NULL, envir = environment(formula(model)),
    partial.resid = FALSE, rug = FALSE, terms = NULL, se = FALSE,
    xlabs = NULL, ylabs = NULL, main = NULL, col.term = 2, lwd.term = 1.5,
    col.se = "orange", lty.se = 2, lwd.se = 1, col.res = "gray",
    cex = 1, pch = 1, col.smth = "darkred", lty.smth = 2,
    span.smth = 2/3, ask = dev.interactive() && nb.fig < n.tms,
    use.factor.levels = TRUE, smooth = NULL, ylim = "common",plot.it=F,
    ...)
{   # this function is borrowed from the stats library #

    which.terms <- terms
    terms <- if (is.null(terms))
        predict(model, type = "terms", se.fit = se)
    else predict(model, type = "terms", se.fit = se, terms = terms)
    n.tms <- ncol(tms <- as.matrix(if (se)
        terms$fit
    else terms))
    mf <- model.frame(model)
    if (is.null(data))
        data <- eval(model$call$data, envir)
    if (is.null(data))
        data <- mf
    if (NROW(tms) < NROW(data)) {
        use.rows <- match(rownames(tms), rownames(data))
    }
    else use.rows <- NULL
    nmt <- colnames(tms)
    cn <- parse(text = nmt)
    if (!is.null(smooth))
        smooth <- match.fun(smooth)
    if (is.null(ylabs))
        ylabs <- paste("Partial for", nmt)
    if (is.null(main))
        main <- ""
    else if (is.logical(main))
        main <- if (main)
            deparse(model$call, 500)
        else ""
    else if (!is.character(main))
        stop("'main' must be TRUE, FALSE, NULL or character (vector).")
    main <- rep(main, length.out = n.tms)
    pf <- envir
    carrier <- function(term) {
        if (length(term) > 1)
            carrier(term[[2]])
        else eval(term, data, enclos = pf)
    }
    carrier.name <- function(term) {
        if (length(term) > 1)
            carrier.name(term[[2]])
        else as.character(term)
    }
    if (is.null(xlabs))
        xlabs <- unlist(lapply(cn, carrier.name))
    if (partial.resid || !is.null(smooth)) {
        pres <- residuals(model, "partial")
        if (!is.null(which.terms))
            pres <- pres[, which.terms, drop = FALSE]
    }
    is.fac <- sapply(nmt, function(i) is.factor(mf[, i]))
    se.lines <- function(x, iy, i, ff = 2) {
        tt <- ff * terms$se.fit[iy, i]
        lines(x, tms[iy, i] + tt, lty = lty.se, lwd = lwd.se,
            col = col.se)
        lines(x, tms[iy, i] - tt, lty = lty.se, lwd = lwd.se,
            col = col.se)
    }
    if(plot.it) nb.fig <- prod(par("mfcol"))
    if (ask & plot.it) {
        oask <- devAskNewPage(TRUE)
        on.exit(devAskNewPage(oask))
    }
    ylims <- ylim
    if (identical(ylims, "common")) {
        ylims <- if (!se)
            range(tms, na.rm = TRUE)
        else range(tms + 1.05 * 2 * terms$se.fit, tms - 1.05 *
            2 * terms$se.fit, na.rm = TRUE)
        if (partial.resid)
            ylims <- range(ylims, pres, na.rm = TRUE)
        if (rug)
            ylims[1] <- ylims[1] - 0.07 * diff(ylims)
    }
    preds <- list()
    response <- list()
    p.names <- xlabs
    for (i in 1:n.tms) {
        if (identical(ylim, "free")) {
            ylims <- range(tms[, i], na.rm = TRUE)
            if (se)
                ylims <- range(ylims, tms[, i] + 1.05 * 2 * terms$se.fit[,
                  i], tms[, i] - 1.05 * 2 * terms$se.fit[, i],
                  na.rm = TRUE)
            if (partial.resid)
                ylims <- range(ylims, pres[, i], na.rm = TRUE)
            if (rug)
                ylims[1] <- ylims[1] - 0.07 * diff(ylims)
        }
        if (is.fac[i]) {
            ff <- mf[, nmt[i]]
            if (!is.null(model$na.action))
                ff <- naresid(model$na.action, ff)
            preds[[i]] <- ll <- levels(ff)
            xlims <- range(seq_along(ll)) + c(-0.5, 0.5)
            xx <- as.numeric(ff)
            response[[i]]<-rep(NA,length(ll))
            if (rug) {
                xlims[1] <- xlims[1] - 0.07 * diff(xlims)
                xlims[2] <- xlims[2] + 0.03 * diff(xlims)
            }

            if(plot.it){
                plot(1, 0, type = "n", xlab = xlabs[i], ylab = ylabs[i],
                    xlim = xlims, ylim = ylims, main = main[i], xaxt = "n",
                    ...)
                if (use.factor.levels)
                    axis(1, at = seq_along(ll), labels = ll, ...)
                else axis(1)
                for (j in seq_along(ll)) {
                    ww <- which(ff == ll[j])[c(1, 1)]
                    jf <- j + c(-0.4, 0.4)
                    lines(jf, response[[i]][j]<-tms[ww, i], col = col.term, lwd = lwd.term,...)
                    if (se) se.lines(jf, iy = ww, i = i)
                    }
            } else {
            for (j in seq_along(ll)) {
                    ww <- which(ff == ll[j])[c(1, 1)]
                    response[[i]][j]<-tms[ww, i]
                    }
                }
        }
        else {
            xx <- carrier(cn[[i]])
            if (!is.null(use.rows))
                xx <- xx[use.rows]
            xlims <- range(xx, na.rm = TRUE)
            if (rug)
                xlims[1] <- xlims[1] - 0.07 * diff(xlims)

            response[[i]]<-  logit(seq(min(tms[,i]),max(tms[,i]),length=100))  #aks
            preds[[i]]<-seq(min(xx),max(xx),length=100) #aks
            if(plot.it){
                 oo <- order(xx)
                 plot(xx[oo], logit(tms[oo, i]), type = "l", xlab = xlabs[i],
                    ylab = ylabs[i], xlim = xlims, ylim = logit(ylims),
                    main = main[i], col = col.term, lwd = lwd.term,
                    ...)
                if (se)
                    se.lines(xx[oo], iy = oo, i = i)
                }
        }
        if(plot.it){
            if (partial.resid) {
                if (!is.fac[i] && !is.null(smooth)) {
                    smooth(xx, pres[, i], lty = lty.smth, cex = cex,
                      pch = pch, col = col.res, col.smooth = col.smth,
                      span = span.smth)
                }
                else points(xx, pres[, i], cex = cex, pch = pch,
                    col = col.res)
            }
            if (rug) {
                n <- length(xx)
                lines(rep.int(jitter(xx), rep.int(3, n)), rep.int(ylims[1] +
                    c(0, 0.05, NA) * diff(ylims), n))
                if (partial.resid)
                    lines(rep.int(xlims[1] + c(0, 0.05, NA) * diff(xlims),
                      n), rep.int(pres[, i], rep.int(3, n)))
            }
        }
    }
    invisible(list(names=p.names,preds=preds,resp=response))
}

# Interpret command line argurments #
# Make Function Call #
 # Interpret command line argurments #
# Make Function Call #
make.p.tif=T
make.binary.tif=T
simp.method="AIC"
opt.methods=2
save.model=FALSE
MESS=FALSE

Args <- commandArgs(trailingOnly=FALSE)

    for (i in 1:length(Args)){
     if(Args[i]=="-f") ScriptPath<-Args[i+1]
     }

    print(Args)
    for (arg in Args) {
    	argSplit <- strsplit(arg, "=")
    	argSplit[[1]][1]
    	argSplit[[1]][2]
    	if(argSplit[[1]][1]=="c") csv <- argSplit[[1]][2]
    	if(argSplit[[1]][1]=="o") output <- argSplit[[1]][2]
    	if(argSplit[[1]][1]=="rc") responseCol <- argSplit[[1]][2]
    	if(argSplit[[1]][1]=="mpt") make.p.tif <- argSplit[[1]][2]
 			if(argSplit[[1]][1]=="mbt")  make.binary.tif <- argSplit[[1]][2]
 			if(argSplit[[1]][1]=="om")  opt.methods <- argSplit[[1]][2]
 			if(argSplit[[1]][1]=="savm")  save.model <- argSplit[[1]][2]
 			if(argSplit[[1]][1]=="sm")  simp.method <- argSplit[[1]][2]
 			if(argSplit[[1]][1]=="mes")  MESS <- argSplit[[1]][2]
    }
	print(csv)
	print(output)
	print(responseCol)

ScriptPath<-dirname(ScriptPath)
source(paste(ScriptPath,"LoadRequiredCode.r",sep="\\"))

make.p.tif<-as.logical(make.p.tif)
make.binary.tif<-as.logical(make.binary.tif)
save.model<-make.p.tif | make.binary.tif
opt.methods<-as.numeric(opt.methods)
MESS<-as.logical(MESS)

 fit.glm.fct(ma.name=csv,
      tif.dir=NULL,output.dir=output,
      response.col=responseCol,make.p.tif=make.p.tif,make.binary.tif=make.binary.tif,
      simp.method=simp.method,debug.mode=F,responseCurveForm="pdf",script.name="glm.r",opt.methods=opt.methods,save.model=save.model,MESS=MESS)