# R CMD BATCH --no-save --no-restore '--args phenotype_file="blabla.txt" output_file="blalba.png" ' analyze_phenotype.r output.txt
library(plyr)
library(tidyr)
library(ggplot2)

args=(commandArgs(TRUE))

if(length(args)==0){
   print("No arguments supplied.")
   ##supply default values
   phenotype_file = 'phenotypes.txt'
   output_file = paste0(phenotype_file, ".png", sep="")
} else {
   for(i in 1:length(args)){
       eval(parse(text=args[[i]]))
   }
}

write(paste("phenotype file: ", phenotype_file), stderr())
write(paste("output_file: ", output_file), stderr())

errorfile = paste(phenotype_file, ".err", sep="");

phenodata = read.csv(phenotype_file,fill=TRUE, sep=",", header = TRUE, stringsAsFactors = T, na.strings="NA");

blocks = unique(phenodata$blockNumber)
print(paste("blocks: ", blocks));
studyNames = unique(phenodata$studyName)
accessions = unique(phenodata$germplasmName)
datamatrix <- c()
datasetnames <- c()
trial_accessions <- c()
all_accessions = unique(phenodata$germplasmName)

datamatrix = matrix(nrow = length(all_accessions), ncol=length(studyNames)) # * length(blocks))
wfAlltrialsdata <- c()
for (i in 1:(length(studyNames))) {

  trialdata <- phenodata[phenodata[,"studyName"]==studyNames[i], ] # & phenodata[,"blockNumber"]==n, ]

  metadata <- c('studyYear', 'studyDbId', 'studyName', 'studyDesign', 'locationDbId', 'locationName', 'germplasmDbId', 'germplasmSynonyms', 'observationLevel', 'observationUnitDbId', 'observationUnitName', 'plotNumber')

  trialdata <- trialdata[, !(names(trialdata) %in% metadata)]

  trialdata <- trialdata[, !(names(trialdata) %in% c('replicate', 'blockNumber'))]

  trialdata <- ddply(trialdata,
                     "germplasmName",
                     colwise(mean, na.rm=TRUE)
                     )

  trialdata <- data.frame(trialdata)

  trialdata <- trialdata[complete.cases(trialdata), ]

  colnames(trialdata)[2]<- make.names(studyNames[i])

  if( i == 1) {
    wfAllTrialsData <- trialdata
  } else {
    wfAllTrialsData <- merge(wfAllTrialsData, trialdata, by="germplasmName")
  }
}

#create a fake 4 trials dataset
#wfAllTrialsData <- merge(wfAllTrialsData, wfAllTrialsData, by="germplasmName")

names(wfAllTrialsData) <- make.names(names(wfAllTrialsData))

lfTrialsData <- function (wfTrialsData) {
 lfTrDa <- gather(wfTrialsData, Trials, Trait,
                        2:length(wfTrialsData),
                        factor_key=TRUE)

  return (lfTrDa)
}

datamatrix <- data.matrix(wfAllTrialsData)

if (nrow(datamatrix)==0) {
   write("No data was retrieved from the database for this combination of trials: ", file = errorfile);
}
if (ncol(datamatrix) < 2) {
   write("No data. Try again", file = errorfile);
}

# correlation
#
panel.cor <- function(x, y, digits=2, cex.cor)
{
   usr <- par("usr"); on.exit(par(usr))
   par(usr = c(0, 1, 0, 1))
   r <- abs(cor(x, y, use ="na.or.complete"))
   txt <- format(c(r, 0.123456789), digits=digits)[1]
   test <- cor.test(x,y,use ="na.or.complete")
   Signif <- ifelse(round(test$p.value,3)<0.001,"p<0.001",paste("p=",round(test$p.value,3)))
   text(0.5, 0.25, paste("r=",txt))
   text(.5, .75, Signif)
}

#pairs(data_test,lower.panel=panel.smooth,upper.panel=panel.cor)

#smooth

panel.smooth<-function (x, y, col = "black", bg = NA, pch = 18, cex = 0.8, col.smooth = "red", span = 2/3, iter = 3, ...)
{
    points(x, y, pch = pch, col = col, bg = bg, cex = cex)
    ok <- is.finite(x) & is.finite(y)
    if (any(ok))
    	lines(stats::lowess(x[ok], y[ok], f = span, iter = iter),
       	col = col.smooth, ...)
    }

#pairs(data,lower.panel=panel.smooth,upper.panel=panel.smooth)

#histo
panel.hist <- function(x, ...)
{
    usr <- par("usr"); on.exit(par(usr))
    par(usr = c(usr[1:2], 0, 1.5) )
    h <- hist(x, plot = TRUE)
    breaks <- h$breaks; nB <- length(breaks)
    y <- h$counts; y <- y/max(y)
    rect(breaks[-nB], 0, breaks[-1], y, col="red", ...)
}

scatterPlot <- function (wfTrialsData) {

  lfTrDa <-  lfTrialsData(wfTrialsData)

  scatter <- ggplot(wfTrialsData, aes_string(x=names(wfTrialsData)[2], y=names(wfTrialsData)[3])) +
                theme(plot.title = element_text(size=18,  face="bold", color="olivedrab4", margin = margin(40, 40, 40, 40)),
                      plot.margin = unit(c(0.75, 1, 0.75, 1), "cm"),
                      axis.title.x = element_text(size=14, face="bold", color="olivedrab4"),
                      axis.title.y = element_text(size=14, face="bold", color="olivedrab4"),
                      axis.text.x  = element_text(angle=90, vjust=0.5, size=10, color="olivedrab4"),
                      axis.text.y  = element_text(size=10, color="olivedrab4")) +
                geom_point(shape=1, color='DodgerBlue') +
                scale_x_continuous(breaks = round(seq(min(lfTrDa$Trait), max(lfTrDa$Trait), by = 2),1)) +
                scale_y_continuous(breaks = round(seq(min(lfTrDa$Trait), max(lfTrDa$Trait), by = 2),1)) +
                geom_smooth(method=lm, se=FALSE)

 return(scatter)

}

freqPlot <- function (wfTrialsData) {

  lfTrDa <- lfTrialsData(wfTrialsData)

  averages <- ddply(lfTrDa,  "Trials", summarise, traitAverage = mean(Trait))

  freq <- ggplot(lfTrDa, aes(x=Trait, fill=Trials)) +
  xlab("Trait values") +
  ylab("Frequency") +
  theme(plot.title = element_text(size=18, face="bold", color="olivedrab4",  margin = margin(40, 40, 40, 40)),
        plot.margin = unit(c(0.75, 1, 0.75, 1), "cm"),
        axis.title.x = element_text(size=14, face="bold", color="olivedrab4"),
        axis.title.y = element_text(size=14, face="bold", color="olivedrab4"),
        axis.text.x  = element_text(angle=90, size=10, color="olivedrab4"),
        axis.text.y  = element_text(size=10, color="olivedrab4"),
        legend.title=element_blank(),
        legend.text=element_text(size=12, color="olivedrab4"),
        legend.position="bottom") +
  geom_histogram(binwidth=2, alpha=.5, position="identity") +
  scale_x_continuous(breaks = round(seq(min(lfTrDa$Trait), max(lfTrDa$Trait), by = 2),1)) +
  scale_fill_manual(values=c("ForestGreen", "DodgerBlue")) +
  geom_vline(data=averages,
             aes(xintercept=traitAverage,  colour=Trials),
             linetype="dashed", size=2)

 return(freq)
}

# Multiple plot function: for how to use this function go here:
# http://www.cookbook-r.com/Graphs/Multiple_graphs_on_one_page_(ggplot2)/

multiplot <- function(..., plotlist=NULL, file, cols=1, layout=NULL) {
  library(grid)

  plots <- c(list(...), plotlist)

  numPlots = length(plots)

  if (is.null(layout)) {
    layout <- matrix(seq(1, cols * ceiling(numPlots/cols)),
                    ncol = cols, nrow = ceiling(numPlots/cols))
  }

 if (numPlots==1) {
    print(plots[[1]])

  } else {
    grid.newpage()
    pushViewport(viewport(layout = grid.layout(nrow(layout), ncol(layout))))

    for (i in 1:numPlots) {
      matchidx <- as.data.frame(which(layout == i, arr.ind = TRUE))

      print(plots[[i]], vp = viewport(layout.pos.row = matchidx$row,
                                      layout.pos.col = matchidx$col))
    }
  }
}

getTrialsPairs <- function (wfAllTrialsData) {
  combiTrMx <- combn(names(wfAllTrialsData[, 2:length(names(wfAllTrialsData))]), 2)
  nPairs   <- dim(combiTrMx)[2]

  allPairs <- c()
  for (i in 1:nPairs) {
    pairs  <- combiTrMx[, i]
   message("pair  " , i, " ",  pairs )
    allPairs[i] <- list(i=pairs)
  }

 return (list("trialsPairs"= allPairs, "pairsCount"= nPairs))
}

prTr        <- getTrialsPairs(wfAllTrialsData)
trialsPairs <- prTr[["trialsPairs"]]
pairsCount  <- prTr[["pairsCount"]]

message("pairs count ", pairsCount)

createGraphNames <- function (pairsCount) {
  graphNames <- c()

  for (i in 1:pairsCount) {
    pf <- paste("freq", i, sep="")
    ps <- paste("scatter", i, sep="")

    graphNames[i] <- list(i=c(ps, pf))
  }

  return(graphNames)
}

png(output_file, height= pairsCount * 400, width=800)

graphNames <- createGraphNames(pairsCount)

for (i in 1:pairsCount) {
  pnames <- graphNames[[i]]
  message(pnames, "  ", pnames[1], " ", pnames[2])

  scatter <- scatterPlot(wfAllTrialsData[, c("germplasmName", trialsPairs[[i]])])
  freq <- freqPlot(wfAllTrialsData[, c("germplasmName", trialsPairs[[i]])])

  assign(pnames[1], scatter)
  assign(pnames[2], freq)

}

if (pairsCount == 1) {
  multiplot(scatter1, freq1, cols=2)
} else if (pairsCount == 3) {
  multiplot(scatter1, freq1, scatter2, freq2, scatter3, freq3, cols=2)
} else if (pairsCount == 6) {
  multiplot(scatter1, freq1, scatter2, freq2, scatter3, freq3, scatter4, freq4, scatter5, freq5, scatter6, freq6, cols=2)
}

dev.off()


## Created on Thursday, December  5, 2013 at 3:24pm EST by WeekendEditor on WeekendEditorMachine.
## UnCopyright (u) 2013, nobody in particular.  All rights reversed.  As if you care.

##
## When is Dodds's Day?  When is Weekend Editrix's Day?
## Who are these "Dodds" and "Weekend Editrix" people, anyway?
##

## > cambSunData    <- doit(location = "Cambridge")
## > parisSunData   <- doit(location = "Paris")
## > athensSunData  <- doit(location = "Athens")
## > elkhartSunData <- doit(location = "Elkhart")
##
## up-arrow   is c-x 8 <RET> 2191
## degree     is C-x 8 <RET> b0
## dash/minus is C-x 8 <RET> 2212
doit <- function(location    = "Cambridge",
                 sunDataFile = sprintf("./sun-times-%s-%s.tsv", format(Sys.time(), "%Y"), location),
                 plotFile    = sub("^(.*)\\.tsv$", "\\1.png", sunDataFile)) {
  ## Dodds himself: http://web.fastermac.net/~dodds/analemma/greeting-message.htm (now defunct)
  ## Data sources:  https://www.timeanddate.com/sun/usa/boston
  ##                https://www.timeanddate.com/sun/france/paris
  ##                https://www.timeanddate.com/sun/greece/athens
  ## General notes: https://analemma.com/

  parseDate <- function(d) { as.POSIXct(strptime(d, format = "%d-%b-%y")) }

  parseTime <- function(d, t) {                        # Combine date & time into POSIXct
    as.POSIXct(strptime(sprintf("%s %s", as.character(d), as.character(t)),
                        format = "%d-%b-%y %I:%M %p")) #
  }                                                    #

  parseAngle <- function(theta) { as.numeric(gsub("^([+-]?[0-9\\.]+).*$", "\\1", theta)) }

  significantDays <- function(sunData) {               # Dodds, Weekend Editrix, and solstice
    sunDataTimes <- transform(sunData,                 # Hours since midnight
                              SunsetTime  = Sunset  - Date,
                              SunriseTime = Sunrise - Date)
    ## Each one gets several days @ extremum; take the middle day in the range
    dodds    <- subset(sunDataTimes, subset = SunsetTime == min(SunsetTime))
    dodds    <- dodds[ceiling(nrow(dodds) / 2),       "Date", drop = TRUE]
    solstice <- subset(sunDataTimes, subset = Day.Sec    == min(Day.Sec))
    solstice <- solstice[ceiling(nrow(solstice) / 2), "Date", drop = TRUE]
    editrix  <- subset(sunDataTimes, subset = SunriseTime == max(SunriseTime))
    editrix  <- editrix[ceiling(nrow(editrix) / 2),   "Date", drop = TRUE]
    c("Dodds" = dodds, "Solstice" = solstice, "Weekend Editrix" = editrix)
  }                                                    #

  withPars <- function(bodyFn, ...) {                  # Call bodyFn with graphics pars set
    oldParList <- NULL                                 # Capture old vals: params changed only
    tryCatch({ oldParList <- par(...); bodyFn() }, finally = par(oldParList))
  }                                                    # Guarantee old vals restored @ end

  withGraphicsToImageFile <- function(file, width, height, ask, deviceFn, bodyFn) {
    if (is.null(file)) {                               # If no file, then execute directly
      pixelsPerInch <- par("cra") / par("cin")         #   px/in horiz & vertical; new device
      dev.off()                                        #   on screen wants size in inches!
      dev.new(width = width / pixelsPerInch[[1]], height = height / pixelsPerInch[[2]])
      withPars(bodyFn, "ask" = ask)                    #   plotting goes to screen device
    } else                                             # Else there is a file, so execute
      tryCatch({                                       #  w/graphics redirected to a PNG file
        deviceFn(file, width = width, height = height, bg = "transparent")
        withPars(bodyFn, "ask" = FALSE)                # No asking, just go ahead and plot
      }, finally = dev.off())                          # Guarantee closure of the file device
  }                                                    #

  withPNG <- function(file, width, height, ask, bodyFn) {# Capture graphics to .png file
    withGraphicsToImageFile(file, width, height, ask, png, bodyFn)
  }                                                    #

  drawDateLine <- function(d, lab1, lab2) {            # Draw vertical line @ given date,
    parsedD <- as.POSIXct(d)                           #  with labels
    abline(v = parsedD, lty = "dotted", col = "black") # Black, dotted line
    text(x = parsedD, y = 7.5, srt = 90, adj = c(0, -0.3), labels = lab1)
    if (!is.null(lab2))                                # If 2nd label supplied, do that too
      text(x = parsedD, y = 7.5, srt = 90, adj = c(0, +1.2), labels = lab2)
  }                                                    #

  ## NB: dropped Nov 01-03, which was confusing things with the DST->EST time change.
  sunData <- transform(transform(subset(read.table(sunDataFile, sep = "\t", header = TRUE),
                                        ## Drop boring columns
                                        select = -c(Day.Length, Difference, Distance)),
                                 ## Parse dates & times as POSIX times
                                 Date     = parseDate(Date),
                                 Sunrise  = parseTime(Date, Sunrise),
                                 Sunset   = parseTime(Date, Sunset),
                               # Altitude = parseAngle(Altitude),
                                 Noon     = parseTime(Date, Noon)),
                       Day.Sec = as.numeric(difftime(Sunset, Sunrise, units = "secs")))

  sigDays     <- significantDays(sunData)              # Days of significance:
  doddsDay    <- sigDays[["Dodds"]]                    # - earliest sunset
  solsticeDay <- sigDays[["Solstice"]]                 # - shortest length
  editrixDay  <- sigDays[["Weekend Editrix"]]                  # - latest sunrise
  cat("Days of earliest sunset, shortest length, and latest sunrise:\n")
  print(subset(sunData, subset = Date %in% sigDays))   # Show these Very Important Days

  withPNG(sprintf(plotFile, location), 700, 450, FALSE, function() {
    withPars(function() {                              # Save/restore graphics parameters
      pointColors <- c("Sunrise" = "red", "Noon" = "green", "Sunset" = "blue")
      matplot(x = sunData$"Date",                      # Date of Nov - Jan
              y = subset(transform(sunData,            # Time of event (hr since midnight)
                                   Sunrise = as.numeric(Sunrise - Date),
                                   Noon    = as.numeric(Noon    - Date),
                                   Sunset  = as.numeric(Sunset  - Date)),
                         select = c(Sunrise, Noon, Sunset)),
              type = "p", col = "black", pch = 21, bg = pointColors, cex = 1.5,
              xaxt = "n", xlab = NA, ylab = "Time of Day (hr since midnight)",
              main = sprintf("%s Sunrise/Noon/Sunset: %s Winter Solstice",
                             location, strftime(sunData[1, "Date"], format = "%Y")))

      ticks <- seq(from = 1, to = nrow(sunData), by = 7)# Weekly ticks on time axis
      axis(1, sunData[ticks, "Date"], format(sunData[ticks, "Date"], "%b %d"))

      legend("topright", inset = c(0.02, 0.20), bg = "antiquewhite", pch = 21, pt.cex = 2,
             ## Reverse order to keep color labels in same order top-to-bottom as curves
             pt.bg = rev(pointColors), legend = rev(names(pointColors)))

      ## Add vertical lines at Very Important Days
      drawDateLine(doddsDay,    sprintf("Earliest Sunset: %s", doddsDay),    "Dodds's Day")
      drawDateLine(solsticeDay, sprintf("Shortest Day: %s",    solsticeDay), "Winter Solstice")
      drawDateLine(editrixDay,  sprintf("Latest Sunrise: %s",  editrixDay),  "Weekend Editrix's Day")

    }, "pty" = "m",                                    # Maximal plotting area
       "bg"  = "transparent",                          # Transparent background
       "ps"  = 18,                                     # Larger type size
       "las" = 2,                                      # Labels perp to axes
       "mgp" = c(2.2, 0.6, 0),                         # Pull in on tick labels & axis title
       "mar" = c(5, 3.5, 2, 0.5))                      # Allocate margins
  })                                                   # Done capturing graphics

  invisible(sunData)                                   # Return data, invisibly
}                                                      #


#' Front ends for Xsampler
#'
#' Front ends for Xsampler, for quick implementation of dynamic lattice basis and full Markov basis samplers. XGibbs and XMH are Gibbs and Metropolis-Hastings versions of Xsampler using dynamic lattice bases. XMarkovBasis_Gibbs and XMarkovBasis_MH are versions using a full Markov basis.
#' @param ... As for Xsampler
#' @return A list as for Xsampler
#' @export
#' @examples
#' data(BXno3way)
#' XGibbs(BXno3way$y,BXno3way$A,BXno3way$lambda,combine=T,tune.par=0.5)

XGibbs <- function (y, A, lambda, Reorder=TRUE, tune.par=0.5, combine=F, x.order=NULL, x.ini=NULL, Model="Poisson", NB.alpha=0, ndraws = 10000, burnin = 2000, verbose = 0, THIN = 1) {
	Xsampler(y=y,A=A,lambda=lambda,U=NULL,Method="Gibbs",combine=combine,Reorder=Reorder,tune.par=tune.par,x.order=x.order,x.ini=x.ini,Model=Model,Proposal=NULL,NB.alpha=NB.alpha,ndraws=ndraws,burnin=burnin,verbose=verbose,THIN=THIN)
}

#' Front ends for Xsampler
#'
#' Front ends for Xsampler, for quick implementation of dynamic lattice basis and full Markov basis samplers. XGibbs and XMH are Gibbs and Metropolis-Hastings versions of Xsampler using dynamic lattice bases. XMarkovBasis_Gibbs and XMarkovBasis_MH are versions using a full Markov basis.
#' @param ... As for Xsampler
#' @return A list as for Xsampler
#' @export
#' @examples
#' data(BXno3way)
#' XGibbs(BXno3way$y,BXno3way$A,BXno3way$lambda,combine=T,tune.par=0.5)

XMH <- function (y, A, lambda, Reorder=TRUE, tune.par=0.5, combine=F, Proposal="NonUnif",x.order=NULL, x.ini=NULL, Model="Poisson", NB.alpha=0, ndraws = 10000, burnin = 2000, verbose = 0, THIN = 1) {
	Xsampler(y=y,A=A,lambda=lambda,U=NULL,Method="MH",combine=combine,Reorder=Reorder,tune.par=tune.par,x.order=x.order,x.ini=x.ini,Model=Model,Proposal=Proposal,NB.alpha=NB.alpha,ndraws=ndraws,burnin=burnin,verbose=verbose,THIN=THIN)
}

#' Front ends for Xsampler
#'
#' Front ends for Xsampler, for quick implementation of dynamic lattice basis and full Markov basis samplers. XGibbs and XMH are Gibbs and Metropolis-Hastings versions of Xsampler using dynamic lattice bases. XMarkovBasis_Gibbs and XMarkovBasis_MH are versions using a full Markov basis.
#' @param ... As for Xsampler
#' @return A list as for Xsampler
#' @export
#' @examples
#' data(BXno3way)
#' XGibbs(BXno3way$y,BXno3way$A,BXno3way$lambda,combine=T,tune.par=0.5)

XMarkovBasis_Gibbs <- function (y, A, lambda, U, x.ini=NULL, Model="Poisson", NB.alpha=0, ndraws = 10000, burnin = 2000, verbose = 0, THIN = 1) {
	Xsampler(y=y,A=A,lambda=lambda,U=U,Method="Gibbs",Reorder=FALSE,x.order=NULL,x.ini=x.ini,Model=Model,Proposal=NULL,NB.alpha=NB.alpha,ndraws=ndraws,burnin=burnin,verbose=verbose,THIN=THIN)
}

#' Front ends for Xsampler
#'
#' Front ends for Xsampler, for quick implementation of dynamic lattice basis and full Markov basis samplers. XGibbs and XMH are Gibbs and Metropolis-Hastings versions of Xsampler using dynamic lattice bases. XMarkovBasis_Gibbs and XMarkovBasis_MH are versions using a full Markov basis.
#' @param ... As for Xsampler
#' @return A list as for Xsampler
#' @export
#' @examples
#' data(BXno3way)
#' XGibbs(BXno3way$y,BXno3way$A,BXno3way$lambda,combine=T,tune.par=0.5)

XMarkovBasis_MH <- function (y, A, lambda, U, x.ini=NULL, Model="Poisson", Proposal="NonUnif", NB.alpha=0, ndraws = 10000, burnin = 2000, verbose = 0, THIN = 1) {
	Xsampler(y=y,A=A,lambda=lambda,U=U,Method="MH",Reorder=FALSE,x.order=NULL,x.ini=x.ini,Model=Model,Proposal="Unif",NB.alpha=NB.alpha,ndraws=ndraws,burnin=burnin,verbose=verbose,THIN=THIN)
}


# Set up
source('2019-06-19-jsa-type-ch1/init.r')

# Parameters
theme = theme_minimal()
dir_plot = "C:\\Users\\ejysoh\\Dropbox\\msc-thesis\\research\\_figures\\_ch2\\"

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - Fig. 1 time series of species description
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
print(paste0(Sys.time(), " --- Fig. 1 time series of species description"))

species_per_year <- df[,.(.N), by=.(date.n)][order(date.n)]
template_year <- data.frame(date.n=min(species_per_year$date.n):max(species_per_year$date.n))
species_per_year <- merge(template_year, species_per_year, by="date.n", all.x=T, all.y=F)
species_per_year[is.na(species_per_year$N),]$N <- 0
species_per_year$N_cumsum <- cumsum(species_per_year$N)

species_per_year2 <- melt(species_per_year, "date.n", stringsAsFactors=F)
species_per_year2$variable <- factor(species_per_year2$variable, c("N_cumsum", "N"))
pt_sum <- data.table(species_per_year2)[, list(max=max(value)), by=c("variable")]
pts <- data.frame(date.n=rep(c(1914, 1919, 1939, 1945), 2),
                  variable=c(rep("N_cumsum", 4), rep("N", 4)),
                  value=c(rep(pt_sum[variable=="N_cumsum",]$max, 4),
                  rep(pt_sum[variable=="N",]$max, 4)))

labs <- c(`N` = "N species",
          `N_cumsum` = "Cumulative N species")
p1 <- ggplot(species_per_year2, aes(x=date.n, y=value)) +
    facet_wrap(.~variable, nrow=2, scales = "free_y", labeller= as_labeller(labs)) +
    geom_ribbon(pts[c(1,2,5,6),], mapping=aes(x=date.n, ymin=0, ymax=value), fill="red", alpha=0.2) +
    geom_ribbon(pts[c(1,2,5,6),], mapping=aes(x=date.n, ymin=0, ymax=value), fill="red", alpha=0.2) +
    geom_ribbon(pts[c(3,4,7,8),], mapping=aes(x=date.n, ymin=0, ymax=value), fill="red", alpha=0.2) +
    geom_ribbon(pts[c(3,4,7,8),], mapping=aes(x=date.n, ymin=0, ymax=value), fill="red", alpha=0.2) +
    geom_line(size=1) + geom_smooth() +
        xlab("") + ylab("") +
            theme

ggsave(paste0(dir_plot, 'fig-1.png'), p1, units="cm", width=21, height=10, dpi=300)

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - Fig 4. Species richness and area graph
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
print(paste0(Sys.time(), " --- Species richness and area graph"))
area <- read.csv('data/lookup/2019-12-20-richness-area.csv')

p4 = ggplot(area) +
    geom_point(aes(x=log(area), y=log(richness))) +
    stat_smooth(area, mapping=aes(x=log(area), y=log(richness)), method='lm', formula = y~x) +
    xlab("log(Area (million sq km))") + ylab("log(N species discovered)") +
    scale_y_continuous(limits=c(2, 10)) +
    theme

ggsave(paste0(dir_plot, 'fig-4.png'), p4, units="cm", width=10, height=10, dpi=300)

summary(lm(log(richness) ~ log(area), area))

######## EXTRA EDA ########

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - Time series
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
print(paste0(Sys.time(), " --- Time series"))

# Individual plots

# Cumulative bee species across years
## All bees
df_year <- unique(df_country[,c("idx", "date.n")])
summary_year <- df_year[,.(.N), by="date.n"][order(date.n)]
template_year <- data.frame(date.n=min(summary_year$date.n):max(summary_year$date.n))
summary_year <- merge(template_year, summary_year, by="date.n", all.x=T, all.y=F)
summary_year[is.na(summary_year$N),]$N <- 0
summary_year$N_cumsum <- cumsum(summary_year$N)
plot_year_cumsum <- ggplot(data = summary_year, aes(x=date.n, y=N_cumsum)) + geom_point() + geom_line() +
    xlab("Year") + ylab("Cumulative number of species")  + theme +
    ggtitle("Cumulative number of bee species time series (1758-2018)") +
    theme(plot.title = element_text(lineheight=.8, face="bold"))
plot_year <- ggplot(data = summary_year, aes(x=date.n, y=N)) + geom_point() + geom_line() +
    xlab("Year") + ylab("Number of species described in a year")  + theme +
    ggtitle("Number of species described time series (1758-2018)") +
    theme(plot.title = element_text(lineheight=.8, face="bold")) +  geom_smooth()

## By family
df_country2 <- merge(df_country, df[,c("idx", "family")], by="idx", all.x=T, all.y=F)
df_family <- unique(df_country2[,c("idx", "date.n", "family")])
summary_year_fam <- df_family[,.(.N), by=c("date.n", "family")]
template_year_fam <- expand.grid(date.n=min(summary_year_fam$date.n):max(summary_year_fam$date.n),
                                 family=unique(df_country2$family))
summary_year_fam <- merge(template_year_fam, summary_year_fam,
                          by=c("date.n", "family"), all.x=T, all.y=F)
summary_year_fam[is.na(summary_year_fam$N),]$N <- 0
summary_year_fam <- data.table(summary_year_fam)
summary_year_fam[, N_cumsum := cumsum(N), by="family"]

plot_year_fam_cumsum <- ggplot(data = summary_year_fam, aes(x=date.n, y=N_cumsum))
plot_year_fam_cumsum1 <- plot_year_fam_cumsum + geom_point() + geom_line() +
    xlab("Year") + ylab("Cumulative number of species") + theme +
    facet_wrap(. ~ family, ncol=3, scales = "free_y") +
    ggtitle("Cumulative number of bee species time series for each family (1758-2018)") +
    theme(plot.title = element_text(lineheight=.8, face="bold"))
plot_year_fam_cumsum2 <- plot_year_fam_cumsum + geom_point() + geom_line() +
    xlab("Year") + ylab("Cumulative number of species") + theme +
    facet_wrap(. ~ family, ncol=3) +
    ggtitle("Cumulative number of bee species time series for each family (1758-2018)") +
    theme(plot.title = element_text(lineheight=.8, face="bold"))
plot_year_fam <- ggplot(data = summary_year_fam, aes(x=date.n, y=N)) +
    geom_point() + geom_line() +
    xlab("Year") + ylab("Number of species described in a year")  + theme +
    facet_wrap(. ~ family, ncol=3, scales="free_y") +
    ggtitle("Number of species described time series (1758-2018)") +
    theme(plot.title = element_text(lineheight=.8, face="bold"))  +  geom_smooth()

## By tropics etc
get_first_type <- function(x) strsplit(x, "/")[[1]][1]
df_country2 <- df_country
df_country2$Latitude_type3 <- sapply(df_country2$Latitude_type, get_first_type)
df_trop <- unique(df_country2[,c("idx", "date.n", "Latitude_type3")])
summary_year_trop <- df_trop[,.(.N), by=c("date.n", "Latitude_type3")]
template_year_trop <- expand.grid(
        date.n=min(summary_year_fam$date.n):max(summary_year_fam$date.n),
        Latitude_type3=unique(df_country2$Latitude_type3))
summary_year_trop <- merge(template_year_trop, summary_year_trop,
                          by=c("date.n", "Latitude_type3"), all.x=T, all.y=F)
summary_year_trop[is.na(summary_year_trop$N),]$N <- 0
summary_year_trop <- data.table(summary_year_trop)
summary_year_trop[, N_cumsum := cumsum(N), by="Latitude_type3"]

plot_year_trop_cumsum <-
    ggplot(data = summary_year_trop,
           aes(x=date.n, y=N_cumsum, col=Latitude_type3)) +
    geom_point() + geom_line() +
    xlab("Year") + ylab("Cumulative number of species") + theme +
    ggtitle("Cumulative number of bee species time series for each family (1758-2018)") +
    theme(plot.title = element_text(lineheight=.8, face="bold"))
plot_year_trop <- ggplot(data = summary_year_trop, aes(x=date.n, y=N, col=Latitude_type3)) +
    # geom_point() + geom_line() +
    xlab("Year") + ylab("Cumulative number of species") + theme +
    ggtitle("Cumulative number of bee species time series for each family (1758-2018)") +
    theme(plot.title = element_text(lineheight=.8, face="bold")) + geom_smooth()

## By family and tropics/ not
df_country2 <- merge(df_country, df[,c("idx", "family")], by="idx", all.x=T, all.y=F)
df_country2$Latitude_type3 <- sapply(df_country2$Latitude_type, get_first_type)
df_trop <- unique(df_country2[,c("idx", "date.n", "family", "Latitude_type3")])
summary_year_fam_trop <- df_trop[, .(.N), by=c("date.n", "family", "Latitude_type3")]
template_year_fam_trop <- expand.grid(
    date.n=min(summary_year_fam$date.n):max(summary_year_fam$date.n),
    family=unique(df_country2$family), Latitude_type3=unique(df_country2$Latitude_type3))
summary_year_fam_trop <- merge(template_year_fam_trop, summary_year_fam_trop,
                          by=c("date.n", "family", "Latitude_type3"), all.x=T, all.y=F)
summary_year_fam_trop[is.na(summary_year_fam_trop$N),]$N <- 0
summary_year_fam_trop <- data.table(summary_year_fam_trop)
summary_year_fam_trop[, N_cumsum := cumsum(N), by=c("family", "Latitude_type3")]

plot_year_fam_trop_cumsum <-
    ggplot(data = summary_year_fam_trop,
           aes(x=date.n, y=N_cumsum, col=Latitude_type3)) + geom_point() + geom_line() +
        xlab("Year") + ylab("Cumulative number of species") + theme +
        facet_wrap(. ~ family, ncol=3) +
        ggtitle("Cumulative number of bee species time series for each family (1758-2018)") +
        theme(plot.title = element_text(lineheight=.8, face="bold"))
plot_year_fam_trop <- ggplot(data = summary_year_fam_trop, aes(x=date.n, y=N,
                             col=Latitude_type3)) +
    # geom_point() + geom_line() +
    xlab("Year") + ylab("Cumulative number of species") + theme +
    facet_wrap(. ~ family, ncol=3, scales = "free_y") +
    ggtitle("Cumulative number of bee species time series for each family (1758-2018)") +
    theme(plot.title = element_text(lineheight=.8, face="bold")) + geom_smooth()

# Combined plots
plot_year_cumsum
plot_year

plot_year_fam_cumsum1
plot_year_fam_cumsum2
plot_year_fam

plot_year_trop_cumsum
plot_year_trop

plot_year_fam_trop_cumsum
plot_year_fam_trop


#' Read MODFLOW .rch File
#'
#' This function reads in a rch file and creates a list
#' composed of the following vectors:
#' \describe{
#' \item{NRCHOP}{Atomic Vector of the is the recharge option code. Recharge fluxes are defined in a layer variable, RECH, with one value for
#'               each vertical column. Accordingly, recharge is applied to one cell in each vertical column, and the option code
#'               determines which cell in the column is selected for recharge.
#'               1—Recharge is only to the top grid layer.
#'               2—Vertical distribution of recharge is specified in layer variable IRCH.
#'               3—Recharge is applied to the highest active cell in each vertical column. A constant-head node intercepts
#'               recharge and prevents deeper infiltration.}
#' \item{IRCHCB}{Atomic Vector and is flag and a unit number.
#'               If IRCHCB > 0, cell-by-cell flow terms will be written to this unit number when "SAVE BUDGET" or a nonzero
#'               value for ICBCFL is specified in Output Control.
#'               If IRCHCB ≤ 0, cell-by-cell flow terms will not be written.}
#' \item{RCH}{Data Frame Composed of Layer, Row, Column, Stress Period, and Recharge rate applied to the top of the model domain}
#' }
#' @param rootname This is the root name of the rch file
#' @export

readrch <- function(rootname = NA){
    if(is.na(rootname)){
            rootname <- MFtools::getroot()
    }
    infl <- paste0(rootname, ".rch")
    MOD_DIMS <- MFtools::get_dims(rootname)
    NPER <-  MOD_DIMS$NPER
    NCOL <-  MOD_DIMS$NCOL
    NROW <-  MOD_DIMS$NROW
    linin <- readr::read_lines(infl) %>% .[!grepl("#", .)]              # READ IN RCH FILE BUT REMOVE COMMENTED LINES
    indx <- 1
    NRCHOP <- linin[indx] %>% MFtools::parse_MF_FW_ELMT(1) %>% as.integer()
    IRCHCB <- linin[indx] %>% MFtools::parse_MF_FW_ELMT(2) %>% as.integer()

    HDGLOC       <- grep("\\(", linin)
    HDG          <- linin[HDGLOC]
    UNI          <- substr(HDG, start = 1, stop = 10) %>% as.integer()
    MULT         <- substr(HDG, start = 11, stop = 20) %>% as.numeric()
    ARR_MULT     <- UNI / UNI
    ARR_MULT[is.na(ARR_MULT)] <- 0
    MULTLOC      <- grep("^0$", UNI)
    FRMT         <- substr(HDG, start = 21, stop = 30)
    FRMTREP      <- regmatches(FRMT, gregexpr("[[:digit:]]+", FRMT)) %>% lapply('[[', 1) %>% unlist() %>% as.integer()
    BLOCK_LENGTH <- (NROW * ceiling(NCOL / FRMTREP))
    BLOCK_START  <- HDGLOC + 1
    BLOCK_END    <- dplyr::lead(BLOCK_START) - 2
    BLOCK_END    <- ifelse(is.na(BLOCK_END), BLOCK_START + BLOCK_LENGTH - 1, BLOCK_END)
    if(length(BLOCK_END) > 1){
        BLOCK_END[length(BLOCK_END)] <- BLOCK_END[length(BLOCK_END) - 1] + BLOCK_LENGTH[length(BLOCK_END)] + 1
        }
    BLOCK_START  <- BLOCK_START * ARR_MULT
    BLOCK_END    <- BLOCK_END * ARR_MULT
    CELL_INDX    <- Map(seq, BLOCK_START, BLOCK_END)

    indx <- indx + 1
    BLOCKSIZE <- NROW * NCOL
    BLOCKEND <- ceiling(NPER / 50)
    INRECH_INIRCH_LOC <- HDGLOC - 1
    INRECH <- linin[INRECH_INIRCH_LOC] %>% parse_MF_FW_ELMT(1) %>% as.integer()
    INIRCH <- linin[INRECH_INIRCH_LOC] %>% parse_MF_FW_ELMT(2) %>% as.integer()

    indx <- HDGLOC[1]
    VAL <- vector(mode = "numeric", length = NPER * BLOCKSIZE)
if(length(MULTLOC[MULTLOC > 3]) > 0){
    # SPECIFIED CELLS: CELL BOTTOM ELEVATIONS SPECIFED USING MULT
    # SPEC_CELLS ARE THE CELLS THAT ARE DEFINED WHEN UNIT == 0
    SPEC_CELLS <- rep(BLOCKSIZE * (MULTLOC[MULTLOC > 3] - 4), each = BLOCKSIZE) + 1:BLOCKSIZE
    # ARR_CELLS ARE SPEFICIED IN ARRAYS.
    ARR_LOC    <- grep("^1$", ARR_MULT)
    ARR_CELL   <- rep(BLOCKSIZE * (ARR_LOC[ARR_LOC > 3] - 4), each = BLOCKSIZE) + 1:BLOCKSIZE
    VAL[SPEC_CELLS] <- rep(MULT[MULTLOC[MULTLOC > 3]], each = BLOCKSIZE)
    VAL[ARR_CELL] <- CELL_INDX %>% parse_MF_CELL_INDX(LINE = linin)
    }else{
    VAL <- CELL_INDX %>% MFtools::parse_MF_CELL_INDX(LINE = linin)
    }

    RCHdf <- tibble::data_frame(
                      LAY = 1 %>% as.integer(),
                      ROW = rep(rep(1:NROW, each = NCOL), NPER) %>% as.integer(),
                      COL = rep(rep(seq(1, NCOL, 1), NROW), NPER) %>% as.integer(),
                      SPER = rep(1:NPER, each = NCOL * NROW) %>% as.integer(),
                      RCH = VAL %>% as.numeric())
    rm(VAL)
    RCH <- list(NRCHOP = NRCHOP,
                IRCHCB = IRCHCB,
                RCH    = RCHdf)
    return(RCH)
    cat("WARNING################################\n")
    cat("More work is needed on this function if there are more than one stress period\n")
    cat("Use the readlpf function as a template\n")
    cat("#######################################\n")
    }


#' Deviation Area chart.
#'
#' area function will draw area chart for deviation analysis.
#' @param data input dataframe
#' @param date date variable
#' @param value value variable
#' @param title input data.frame
#' @param subtitle date variable
#' @param xtitle value variable
#' @param ytitle input data.frame
#' @param caption date variable
#' @return An object of class \code{ggplot}
#' @examples
#' #prepare data
#' economics$returns_perc <- c(0, diff(economics$psavert)/economics$psavert[-length(economics$psavert)])
#' economics<- as.data.frame(economics)
#'
#' #area chart
#' plot<- area(data=economics[1:100,],date = "date",value = "returns_perc")
#' plot
#'
#' @import ggplot2
#' @import scales
#' @import reshape2
#' @import ggthemes
#' @import gganimate
#' @import gapminder
#' @import ggalt
#' @import ggExtra
#' @import ggcorrplot
#' @import dplyr
#' @import treemapify
#' @import ggfortify
#' @import zoo
#' @import ggdendro
#' @export
area<-function(data,date,value,
               title=NULL,subtitle=NULL,xtitle=NULL,ytitle=NULL,caption=NULL){
  df<- data
  x<- date
  y<- value
  brks <- df[,x][seq(1, length(df[,x]), 12)]
  lbls <- lubridate::year(df[,x][seq(1, length(df[,x]), 12)])

  p<-ggplot(df, aes_string(x, y)) +
    geom_area() +
    scale_x_date(breaks=brks, labels=lbls) +
    theme_fivethirtyeight() +
    theme(axis.title = element_text(),
          legend.title = element_text(face = 4,size = 10),
          axis.text.x = element_text(angle=90),
          legend.direction = "horizontal", legend.box = "horizontal")+
    labs(title=title,
         subtitle = subtitle,
         x=xtitle,
         y=ytitle,
         caption=caption)

    return(p)
}


####
# sets styles for plotting the results
# of transition matrix analysis
# key vars are: "shift", "spread" and "maintenance"
####

library(ggplot2)

# for all line plots
pd <- position_dodge(.5)
Y.lab <- "Proportion of each transition"
shiftcol <- "#d92120" # red
spreadcol <- "#dea73a" # gold
maintcol <- "#404096" # dark blue
linecol <- "gray50" # mid gray
errorcol <- "gray30" # dark gray
zerocol <- "gray70" # light gray

# for gen1 subsets
plot1 <- function(df){
  ggplot(df, aes(
    x=as.character(cohort),
    y=prob,
    color=outcome,
    group=outcome)) +
    geom_errorbar(aes(
      ymin=prob-se, ymax=prob+se),
      width=.5, size=0.8, colour=errorcol, position=pd) +
    geom_line(position=pd, size=2.5) +
    geom_point(position=pd, size=5) +
    xlab(X.lab) + ylab(Y.lab) + labs(color="Transition") +
    ylim(0,1) +
    theme(axis.text=element_text(size=12))
}

# for gen2 subsets
plot2 <- function(df){
  ggplot(df, aes(
    x=as.character(cohort),
    y=prob,
    color=outcome,
    group=outcome)) +
    geom_errorbar(aes(
      ymin=prob-se, ymax=prob+se),
      width=.5, size=0.8, colour=errorcol, position=pd) +
    geom_line(position=pd, size=2.5, linetype = "dashed") +
    # dashed lines are the only difference between plot2 and plot1
    geom_point(position=pd, size=5) +
    xlab(X.lab) + ylab(Y.lab) + labs(color="Transition") +
    ylim(0,1) +
    theme(axis.text=element_text(size=12))
}


# Uvoz s spletne strani

library(XML)

# Vrne vektor nizov z odstranjenimi začetnimi in končnimi "prazninami" (whitespace)
# iz vozlišč, ki ustrezajo podani poti.
stripByPath <- function(x, path) {
  unlist(xpathApply(x, path,
                    function(y) gsub("^\\s*(.*?)\\s*$", "\\1", xmlValue(y))))
}

uvozi.obsojeni <- function() {
  url.obsojeni <- "podatki/obsojenir.htm"
  doc.obsojeni <- htmlTreeParse(url.obsojeni, useInternalNodes=TRUE,
                                encoding="UTF-8")

  # Poiščemo vse tabele v dokumentu
  tabele <- getNodeSet(doc.obsojeni, "//table")

  # Iz druge tabele dobimo seznam vrstic (<tr>) neposredno pod
  # trenutnim vozliščem
  vrstice <- getNodeSet(tabele[[1]], ".//tr")

  # Seznam vrstic pretvorimo v seznam (znakovnih) vektorjev
  # s porezanimi vsebinami celic (<td>) neposredno pod trenutnim vozliščem
  seznam <- lapply(vrstice[5:length(vrstice)-1], stripByPath, "./td")

  # Iz seznama vrstic naredimo matriko
  matrika <- matrix(unlist(seznam), nrow=length(seznam), byrow=TRUE)

  # Imena stolpcev matrike dobimo iz celic (<th>) glave (prve vrstice) prve tabele
  colnames(matrika) <- 2006:2013

  imena <- unlist(lapply(vrstice[5:length(vrstice)-1], stripByPath, "./th"))

  # Podatke iz matrike spravimo v razpredelnico
  return(data.frame(apply(matrika, 2, as.numeric), row.names=imena))
}


source("code/libs.r")
source("code/helpers.r")
source("code/get_data.r")

#Convert data to matrix and small matrix for testing
fal_mat = raster_to_matrix(fal_school)
fal_small = resize_matrix(fal_mat, 0.25)

# Create Basemap based on lat long range of site --------------------------
lat_range = c(50.158378, 50.162544)
long_range = c(-5.102861, -5.090522)

utm_bbox = convert_coords(lat = lat_range,
                          long = long_range,
                          to = crs(fal_school))

extent_zoomed = extent(utm_bbox[1], utm_bbox[2], utm_bbox[3], utm_bbox[4])
fal_zoom = crop(fal_school, extent_zoomed)
fal_zoom_mat = raster_to_matrix(fal_zoom)

maxcolor = "#e6dbc8"
mincolor = "#b6bba5"
contour_color = "#7d4911"
basemap = fal_zoom_mat %>%
  height_shade() %>%
  add_overlay(sphere_shade(fal_zoom_mat, texture = "bw", colorintensity = 5),
              alphalayer = 0.5) %>%
  add_shadow(lamb_shade(fal_zoom_mat), 0) %>%
  add_shadow(ambient_shade(fal_zoom_mat), 0) %>%
  add_shadow(texture_shade(
    fal_zoom_mat,
    detail = 8 / 10,
    contrast = 9,
    brightness = 11
  ),
  0.1)
# Create overlays for DTM data --------------------------------------------
#Route overlay
fal_lines = st_transform(p, crs = crs(fal_school))

#OS roads overlay
osm_bbox = c(long_range[1], lat_range[1], long_range[2], lat_range[2])
fal_highway = opq(osm_bbox) %>%
  add_osm_feature("highway") %>%
  osmdata_sf()

fal_roads = st_transform(fal_highway$osm_lines, crs = crs(fal_school))

fal_footpaths = subset(fal_roads,
                       highway == "footway")

fal_cyclepaths = subset(fal_roads,
                        highway == "cycleway")

fal_roads = subset(
  fal_roads,
  highway = c(
    "unclassified",
    "secondary",
    "tertiary",
    "residential",
    "service"
  )
)

fal_footpaths = st_transform(fal_footpaths$geometry, crs = crs(fal_school))
fal_roads = st_transform(fal_roads$geometry, crs = crs(fal_school))
fal_cyclepaths = st_transform(fal_cyclepaths$geometry, crs = crs(fal_school))
resting_area = st_transform(resting_area, crs = crs(fal_school))

dd = subset(pp, select = "geometry")
View(dd)
dd$name = "Table top"
dd = dd[-(16:22),]
dd = dd[-(1:7),]
dd = dd[-(8:14),]
dd = dd[-(8),]
dd = dd[-(10),]
dd = dd[-(1:4),]
dd$name[1] = "Resting Area"
dd$name[2] = "Drain"
dd$name[3] = "Scrub to clear"
dd$name[4] = "Path to clear"
dd$name[5] = "Resting Area"
dd$name[1] = "Table top"

dd = st_transform(dd, crs = crs(fal_school))
# Plot map ----------------------------------------------------------------
basemap %>%
  add_overlay(
    generate_line_overlay(
      fal_lines,
      extent = extent_zoomed,
      linewidth = 6,
      color = "#2d8a91",
      heightmap = fal_zoom_mat
    )
  ) %>%
  add_overlay(generate_label_overlay(dd, extent = extent_zoomed,
                                     text_size = 2, point_size = 1, color = "black",
                                     halo_color = "white", halo_expand = 10,
                                     halo_blur = 20, halo_alpha = 0.8,
                                     seed=1,
                                     heightmap = fal_zoom_mat, data_label_column = "name")) %>%
  add_overlay(
    generate_line_overlay(
      resting_area,
      extent = extent_zoomed,
      linewidth = 6,
      color = "black",
      heightmap = fal_zoom_mat
    )
  ) %>% plot_map(title_text = "Falmouth School Bike Track (Flashman Track and Trails)", title_offset = c(15,15),
           title_bar_color = "grey5", title_color = "white", title_bar_alpha = 1)

basemap %>%
  add_overlay(
    generate_line_overlay(
      fal_lines,
      extent = extent_zoomed,
      linewidth = 6,
      color = "#2d8a91",
      heightmap = fal_zoom_mat
    )
  ) %>% add_overlay(
    generate_line_overlay(
      resting_area,
      extent = extent_zoomed,
      linewidth = 6,
      color = "black",
      heightmap = fal_zoom_mat
    )
  ) %>%
  add_overlay(generate_label_overlay(dd, extent = extent_zoomed,
                                     text_size = 2, point_size = 1,
                                     halo_color = "white",halo_expand = 5,
                                     seed=1,
                                     heightmap = fal_zoom_mat, data_label_column = "name")) %>%
  plot_3d(fal_zoom_mat, windowsize = c(1200, 800))
render_camera(
  theta = 240,
  phi = 30,
  zoom = 0.5,
  fov = 60
)
render_snapshot(
  filename = "Plots/3d-track.png",
  clear = T
)
#Plot only route
l = points2line_trajectory(pp)
plot(l)


group_by_commas <- function(n) formatC(n, format='d', big.mark=',')


# wrapper
wrapper <- function(table, columns, options) {

    # initialize output list
    l <- list()

    # loop through all columns
    m <- list()
    for (key in names(columns)) {
        # load column data
        column <- as.numeric(columns[key])
        column_data <- suppressWarnings(as.numeric(as.character(table[column][[1]])))

        # collect vectors in list
        m <- append(m, list(column_data))
    }

    # identify optimal breaks
    hist_data <- hist(unlist(m), plot=FALSE)
    breaks <- hist_data$breaks;

    # add as first column
    l <- append(l, list(breaks[2: length(breaks)]))

    # loop through all columns
    for (key in seq(m)) {
        # load column data
        column_data <- m[[key]]

        # create hist data
        hist_data <- hist(column_data, breaks=breaks, plot=FALSE)

        # normalize densities
        count_sum <- sum(hist_data$counts)
        if (count_sum > 0) {
            hist_data$counts = hist_data$counts / count_sum
        }

        # collect vectors in list
        l <- append(l, list(hist_data$counts))
    }

    # return
    return (l)
}


# Make a shapefile of our Areas of Interest, for use in the NatCap's InVest software
# Also make a csv of lat/lon for landing points and grid connection points

#######################
## Load libraries
#######################
#require(maptools)
require(RColorBrewer)
#require(rgdal)
#require(PBSmapping)
#require(rgeos) # for gBuffer
require(sf)

##############################################################
## Read in and process data to create Areas of Interest (AOI)
##############################################################
climgrid <- readRDS('temp/SPsf2.rds') # the projection grid

# label by area of interest regions
climgrid$AOI <- NA
climgrid$AOI[climgrid$lon < -100 | climgrid$lon > 0] <- 'west'
climgrid$AOI[climgrid$lon >= -100 & climgrid$lon < 0] <- 'east'
sum(is.na(climgrid$AOI)) # 0
#    plot(climgrid['AOI'], lwd=0.001, axes=TRUE) # Aleutians are on the far right
#    plot(climgrid['AOI'], lwd=0.5, xlim=c(-70, -69), ylim=c(41,42), axes=TRUE) # zoom in (Cape Cod)

# project to North American Albers, but in WGS84 rather than NAD83
climgridp <- st_transform(climgrid, crs='+proj=aea +lat_1=20 +lat_2=60 +lat_0=40 +lon_0=-96 +x_0=0 +y_0=0 +ellps=GRS80 +datum=WGS84 +units=m +no_defs') # North America Albers Equal Area Conic from https://epsg.io/102008, except with WGS84
#    plot(climgridp['AOI'], lwd=0.001, axes=TRUE) # Aleutians are on the far right

# buffer slightly (1000 m) to aid merging the grid cells together
climgridbuf <- st_buffer(climgridp, 1000)

# merge all into multipart polygons based on AOI
climpoly <- aggregate(climgridbuf[,c('geometry')], by = list(AOI = climgridbuf$AOI), do_union = TRUE, FUN=function(x, ...) return(1))
#	 plot(climpoly['AOI'], lwd=0.01, axes=TRUE)
#    plot(climpoly['AOI'], lwd=1, xlim=c(1.9e6, 2.2e6), ylim=c(4e5,6e5), axes=TRUE) # zoom in (Cape Cod)

# buffer whole analysis area
climpolyb <- st_buffer(climpoly, dist = 100000) # 100km
#	plot(climpolyb, lwd=0.2, axes=TRUE)

# write out each region as a separate shapefile
# will throw an error if file already exists
for(i in 1:nrow(climpolyb)){
	st_write(climpolyb[i,], paste0('temp/AOI_', climpolyb$AOI[i], '.shp')) # write the .prj file as part of the shapefile. Overwrite
}

#######################################
## Make land and grid connection points
#######################################
# set parameters
crs <- '+proj=aea +lat_1=20 +lat_2=60 +lat_0=40 +lon_0=-96 +x_0=0 +y_0=0 +ellps=GRS80 +datum=NAD83 +units=m +no_defs' # North America Albers Equal Area Conic from https://epsg.io/102008
crslatlong = "+init=epsg:4326"

# read in files
coastlines <- st_read('data/natcap/NAmainland_lines.shp') # global coast layer from NatCap, trimmed to North America
#	plot(coastlines['id'], axes=TRUE) # a bit slow
townsUS <- st_read('dataDL/usgs/citiesx020_nt00007/citiesx020.shp') # US National Map cites and towns
    st_crs(townsUS) <- 4269 # set CRS to NAD83
#	plot(townsUS['NAME'], pch=16, cex=0.2, axes=TRUE)
#   plot(st_geometry(townsUS), add=TRUE, col='red') # to add to coastlines plot. Not working for some reason.
townsCan <- st_read('dataDL/statcan/lpc_000b16a_e/lpc_000b16a_e.shp') # Canadian census population centres

# project to North American Albers
coastlinesp <- st_transform(coastlines, crs = crs)
townsUSp <- st_transform(townsUS, crs = crs)
townsCanp <- st_transform(townsCan, crs = crs)

# find centroids for Canada
townsCanpc <- st_centroid(townsCanp)

    plot(st_geometry(coastlinesp), lwd=0.2, axes=TRUE)
    plot(st_geometry(townsUSp), pch=16, cex=0.1, add=TRUE, col='blue') # plots on top of NA well
    plot(st_geometry(townsCanpc), pch=16, cex=0.1, add=TRUE, col='green') # plots on top of NA well

# trim US towns to those >1000 people (Canada is already trimmed)
townsUS1000 <- townsUSp[which(townsUSp$POP_2000 >= 1000),]
	dim(townsUSp) # 35432
	dim(townsUS1000) # 9992

# combine US and Canada
names(townsCanpc)[names(townsCanpc)=='PCNAME'] <- 'NAME'
towns1000 <- rbind(townsUS1000[,c('NAME', 'geometry')], townsCanpc[,c('NAME', 'geometry')])

# trim town to those <50km from the NA coast
nearcoast <- st_is_within_distance(towns1000, coastlinesp, dist = 50*1000, sparse = FALSE) # slow (a few min). units in meters (50km). returns a matrix with columns corresponding to each coastline (includes a few major islands)
nearcoastany <- rowSums(nearcoast) > 0 # sum across rows: we don't care which coast a town is close to
	sum(nearcoast) # 2233
	sum(nearcoastany) # 1873. shows that some towns were close to multiple coastlines
	plot(st_geometry(towns1000[which(nearcoastany),]), col='red', pch=16, cex=1, add=TRUE) # adds to the plot before

towns1000nearcoast <- towns1000[which(nearcoastany),]

# find nearest point on the coastline to each town. So much faster than the old method of sampling!
#coastpoint.near <- st_as_sf(rgeos::gNearestPoints(as(towns1000nearcoast,"Spatial"), as(coastlinesp,"Spatial"))[2,]) # from https://gis.stackexchange.com/questions/288570/find-nearest-point-along-polyline-using-sf-package-in-r. But only returns one point. Would have to implement in a loop
towncoastlines <- st_nearest_points(towns1000nearcoast, coastlinesp) # returns LINESTRINGS from first to second geometry
towncoastlengths <- st_length(towncoastlines) # length of each line, so that we can find the closest coastline to each town
nearestptinds <- aggregate(list(ind = towncoastlengths), by = list(town = rep(1:nrow(towns1000nearcoast), each = nrow(coastlinesp))), FUN = function(x) which.min(x)) # find index of shortest line from town to a coast. Works because st_nearest_points returns a vector where y cycles fastest and x cycles slowest
nearestptinds2 <- nearestptinds$ind + seq(0, length.out = nrow(nearestptinds), by = nrow(coastlinesp)) # convert to an index into towncoastlines
pts <- st_cast(towncoastlines[nearestptinds2], "POINT") # gives all start (towns) & end (coastlines) points, alternating
coastpts <- pts[seq(2, length(pts), 2)] # just the end points (on coastlines)
	length(coastpts)

    #plot(st_geometry(towns1000nearcoast[1:10,]), axes = TRUE, col = 'blue') # to plot a few towns
	plot(st_geometry(towns1000nearcoast), axes = TRUE, col = 'blue', xlim = c(-2.3e6, -1.8e6), ylim = c(-4e5, 0)) # to plot a few towns
	#plot(st_geometry(towns1000nearcoast[1:100,]), axes = TRUE, col = 'blue') # to plot many towns
	plot(st_geometry(coastlinesp), add = TRUE)
    plot(st_geometry(coastpts), add = TRUE, col = 'red')

# project back to latlong in order to make a table for NatCap InVEST
coastpts.ll <- st_transform(coastpts, crs = crslatlong)
towns1000nearcoast.ll <- st_transform(towns1000nearcoast, crs = crslatlong)

# make output table of town and nearest landing point locations
# format as specified by NatCap InVEST Wave
towns.coords <- st_coordinates(towns1000nearcoast.ll)
coast.coords <- st_coordinates(coastpts.ll)

outgrid <- data.frame(ID=1:nrow(towns.coords), LAT=towns.coords[,2], LONG=towns.coords[,1], TYPE='GRID', LOCATION=towns1000nearcoast.ll$NAME)
outland <- data.frame(ID=(1+nrow(towns.coords)):(nrow(towns.coords)+nrow(coast.coords)), LAT=coast.coords[,2], LONG=coast.coords[,1], TYPE='LAND', LOCATION=towns1000nearcoast.ll$NAME)

	# make sure it looks OK
	plot(outland$LONG, outland$LAT, pch=16, cex=0.5)
	points(outgrid$LONG, outgrid$LAT, col='red', pch=16, cex=0.5) # the towns

    # combine town and landings points
    out <- rbind(outgrid, outland)

    head(out[out$TYPE == 'GRID', ])
    head(out[out$TYPE == 'LAND', ])
    tail(out[out$TYPE == 'GRID', ])
    tail(out[out$TYPE == 'LAND', ])

    # write out
    write.csv(out, file='output/landgridpts_northamerica.csv', row.names=FALSE)

# make output table of town and nearest landing point locations
# format as specified by NatCap InVEST Wind
out2 <- out[, c('ID', 'TYPE', 'LAT', 'LONG')]
names(out2)[names(out2)=='LAT'] <- 'LATI'
    head(out2)
    tail(out2)

    # write out
    write.csv(out2, file='output/landgridpts_northamerica_wind.csv', row.names=FALSE)


library(ggplot2)
library(ggthemes)

source('colors.r')

pdf('../pdfs/valence_poi_line.pdf',width=4.7239,height=3.2927)

poi = 'valence'

data_by_x = read.csv(file=paste0('../avgs_toppers/avg_',poi,'.csv'), sep=',', header = TRUE)
data_by_x$category <- rep('top_x', nrow(data_by_x))
data_by_x_left <- subset(data_by_x, year < 1979)
data_by_x_right <- subset(data_by_x, year > 1979)

data_remainder = read.csv(file=paste0('../avgs/avg_',poi,'.csv'), sep=',', header = TRUE)
data_remainder$category <- rep('remainder', nrow(data_remainder))
data_remainder_left <- subset(data_remainder, year < 1979)
data_remainder_right <- subset(data_remainder, year > 1979)

data <- rbind(data_by_x, data_remainder)

oldpar <- par(mar=rep(0,4))
plot <- ggplot() +
        geom_line(data=data_by_x_left, size=1, aes_string(x='year',y=paste0('avg_',poi), color='category')) +
        geom_line(data=data_by_x_right, size=1, aes_string(x='year',y=paste0('avg_',poi), color='category')) +
        geom_line(data=data_remainder_left, size=1, aes_string(x='year',y=paste0('avg_',poi), color='category')) +
        geom_line(data=data_remainder_right, size=1, aes_string(x='year',y=paste0('avg_',poi), color='category')) +
        geom_line(data=data_remainder_left, size=1, aes_string(x='year',y=paste0('avg_',poi), color='category')) +
        geom_line(data=data_remainder_right, size=1, aes_string(x='year',y=paste0('avg_',poi), color='category')) +
        geom_vline(xintercept = 1979, size = 0.5, color=grays[2]) +
        geom_vline(xintercept = 2008, size = 0.5, color=grays[2]) +
        scale_x_continuous(breaks = seq(1968, 2017, by = 10)) +
        # scale_y_continuous(breaks = seq(0, 1, by = 0.1)) +
        theme_wsj(color='white') +
        scale_colour_manual(values = c('#fcde05', grays[3]  )) +
        theme(plot.margin=grid::unit(c(0,0,0,0), 'mm'), legend.position='none')

par(reset)
print(plot)
par(reset)
dev.off()