#' @title assess_privacy
#' @description At this time, data with privacy considerations must be aggregated such that each
#' polygon has a minimum of 5 unique values for sensitive fields like Licenses, License Holders, and
#' Vessels.  This function takes a dataframe and shapefile and for each polygon in the
#' shapefile calculates 1) aggregate values for a number of (user-specified) fields , and 2)
#' how many unique values exist in each polygon for each of a number of sensitive fields.
#' @param df a dataframe to be analyzed. If left \code{NULL}, a value for \code{db} should be provided

#' @param grid.shape default is \code{"hex"}.  This identifies the shape of the
#' you want to aggregate your data into.  The options are "hex" or "square"

#' @param lat.field the default is \code{"LATITUDE"}. This is the name of the
#' field holding latitude values (in decimal degrees)

#' @param lon.field the default is \code{"LONGITUDE"}.  This is the name of the
#' field holding longitudevalues (in decimal degrees)

#' @param calculate the default is \code{c("MEAN", "COUNT", "SUM")}. These are the
#' analytics which should be performed for every field identified in \code{agg.field}.
#' For example, if KEPT_WT and DISCAD_WT are both identified in \code{agg.field},
#' then for every resultant aggregated polygon (e.g. hexagon), the mean, count
#' and sum of both of these fields is calculated for every polygon.

#' @param rule.of default is \code{5} Whether or not data can be shown (even
#' aggregated) depends on the presence of a threshold number of unique values
#' for certain sensitive fields.  This parameter sets that threshold.

#' @param agg.fields the default is \code{"KEPT_WT"}.  These are the fields in the data that contain
#' the values you want to aggregate (e.g. calulate the mean, sum or count of.  This field needs to be
#' numeric.

#' @param sens.fields the defaults are \code{NULL}  These are fields
#' to which the "rule of 5" should be applied. The Treasury Secretariat states that when data is
#' shown to the public, certain fields must have at least 5 unique values for these fields
#' aggregated together. When run, this function will look at these fields, and calculate how many
#' unique values exist for each.  It will then populate a field 'TOTUNIQUE' with the minimum number
#' of unique values of all the assessed fields. If this is 5 or more, a field called 'CAN_SHOW' will
#' be marked as 'YES' (otherwise it will be 'NO').

#' @param facet.field default is \code{NULL}.  In cases like bycatch data, you may have a dataframe
#' where each row might represent different species.  You probably want a breakdown of each individual
#' species, rather than summing them all up to get some generic weight of all species combined. This is
#' the field that will be used to aggregate data by common values (like Species_Code) .

#' @param key.fields default is \code{NULL}.  This is a vector of fields that are required
#' to uniquely identify each fishing set.  If a \code{facet.field} is provided, the \code{facet.field},
#' \code{key.fields} and \code{agg.fields} are all pulled off of the original data and then merged back
#' onto it. The key.fields are instrumental in ensuring that the data is able to get rejoined back to the
#' original sets.

#' @param for.public default is \code{TRUE}. While calculating the aggregated values within each
#' 2min cell, this script first establishes whether or not cells within an area have enough unique
#' values of sensitive fields to be allowed to show any data at all.  If this parameter is \code{TRUE},
#' the calculated valued value for areas that cannot be shown will be wiped prior to generating the
#' output files.
#'
#' @param create.shps default is \code{TRUE}.  This indicates whether or not
#' shapefiles should be created for 1) the polygon file (with aggregated values
#' for each polygon and an indication of whether or not each polygon meets the
#' privacy constraints), and 2) the 2 min gridded data (only for within those
#' polygons that meet the privacy constraints).

#' @param create.centroid.csv default is \code{FALSE}.  This indicates whether or not a csv  should
#' be created for the 2 min gridded data (only for within those polygons that meet the privacy
#' constraints).  This is a more portable option than the shapefiles or SpatialPolygonsDataFrame
#' (i.e. it is a dramatically smaller file, usable without a GIS).
#'
#' @param file.id default is \code{NULL} Whatever is entered here will be used
#' to name the output shapefiles and/or plots.  If nothing is enetered, the
#' output files will just be named using timestamps.

#' @param agg.poly.shp default is \code{NULL}.  This is the shapefile that has
#' polygons that should be checked for sufficient unique values of the
#' sens.fields.  If NULL, NAFO zones will be used.  Otherwise, a path to any
#' polygon shapefile can be provided.

#' @param agg.poly.field default is \code{NULL}.  This identifies the field within
#' the shapefile provided to agg.poly.shp that should be used to check for
#' sufficient unique values of the sens.fields.
#' @param ignore.col.limit default is \code{FALSE} ESRI's ArcGIS doesn't like when
#' a shapefile has more than 255 columns.  By default, this function will halt with a warning
#' if it detects that it is producing too many columns.  To ignore the warning, and produce the
#' shapefile anyways, set it to TRUE.
#' @import data.table

#' @return a SpatialPolygonsDataFrame, and generates a shapefile
#' @family privacy
#' @author  Mike McMahon, \email{Mike.McMahon@@dfo-mpo.gc.ca}
#' @export
#' @note If sensitive fields have names that are different than what is provided in the \code{sen.fields},
#' they will not be detected, or included in the checks.  Please make very sure you correctly
#' identify such fields.
#'
#' It should be also noted that shapefiles can only have 255 columns, which can
#' be exceeded by this function relatively easily when a \code{facet.field} is
#' provided (e.g. for bycatch species).  For example, if all 3 default \code{calculate}
#' fields are requested on 3 different \code{agg.fields}, and there are 30
#' unique values in the \code{facet.field}, this will result in (3*3*30 =) 270
#' fields plus 3 or 4 additional housekeeping fields. In this event, a warning
#' will be provided, but no shapefiles will be output.
assess_privacy <- function(
  df= NULL,
  grid.shape = 'hex',
  lat.field = 'LATITUDE',
  lon.field = 'LONGITUDE',
  rule.of = 5,
  agg.fields = "KEPT_WT",
  calculate = c("MEAN", "COUNT", "SUM"),
  sens.fields = NULL,
  facet.field = NULL,
  key.fields = NULL,
  for.public = TRUE,
  create.shps = TRUE,
  create.centroid.csv = FALSE,
  file.id = NULL,
  agg.poly.shp = NULL,
  agg.poly.field = NULL,
  ignore.col.limit = FALSE
){
  #set up
  ts = format(Sys.time(), "%Y%m%d_%H%M")
  `:=` <- function (x, value) value

  analyticChooser <- function(x, calculate){
    #this function is called by the aggregate functions to allow use to select which analytics are calculated for all agg.fields
    res <- NA
    if ("CNT" %in% calculate)  res= c(res, round(length(x[x!=0]), 0))
    if ("SUM" %in% calculate)  res= c(res, round(sum(x), 4))
    if ("MEAN" %in% calculate)  res= c(res, round(mean(x), 4))
    res = res[!is.na(res)]
    return(res)
  }

  mkCentroidDf <- function(grid = NULL){
    # the default polygons are large.  This can convert them to csvs
    this <- as.data.frame(geosphere::centroid(grid))
    colnames(this) <- c("lon", "lat")
    this <- data.frame("ID" = 1:nrow(this), this)
    sp::coordinates(this) <- c("lon", "lat")
    sp::proj4string(this) <- sp::proj4string(grid) # assign projection

    this@data <- sp::over(x = this, y = grid, returnList = FALSE)
    this@data[,c("LON","LAT")] <- sp::coordinates(this)
    this_csv <- this@data
    return(this_csv)
  }

  #deal with cases where differing rows may refer to different species in the same sets
  #in short:
  #1)pull key.fields, facet.field and agg.fields into dfLong
  #2)dcast dfLong to dfWide (e.g. every species gets it's own column instead of row)
  #3)with most of these fields removed, unique() the remaining (set-related) info and drastically reduce nrows
  #4)merge the wide species data back onto the shortened set info
  if (!is.null(key.fields) && !is.null(facet.field) && !is.null(agg.fields)){
    foo <- function(df, id, measure, val) {
      res = data.table::dcast(data.table::setDT(df), paste(paste(id, collapse = " + "), "~",
                                                           paste(measure, collapse = " + ")), function(x) analyticChooser(x, calculate),
                              value.var = val)
      res = data.table::setDF(res)
      return(res)
    }
    dfLong <- df[,c(key.fields,c(facet.field, agg.fields))]
    dfLong <- dfLong[!is.na(dfLong[facet.field]),]

    dfRest= df[,!names(df) %in% c(facet.field, agg.fields)]
    dfRestU <- unique(dfRest)
    if (nrow(dfRest)==nrow(dfRestU)){
      stop(cat("facet.field must identify a single identifier field that causes repeated sets - e.g. species code/name","\n",
               "agg.fields must identify the vaulues you want information for related to the facet.field - e.g. kept_wt, discarded wt, etc","\n",
               "key.fields must identify enough fields required to identify unique fishing sets - e.g. trip & set","\n"))
    }else{
      dfWide <- foo(dfLong, id=key.fields, measure = facet.field,val = agg.fields)
      # dfWide$ALL_TOT<-NA
      # dfWide$ALL_TOT <- rowSums(dfWide[,!names(dfWide) %in% key.fields],na.rm = T)
      agg.fields <- names(dfWide[,!names(dfWide) %in% key.fields])
      # cat("Updated agg.fields to reflect new, faceted data structure","\n")
      df<-dfRestU
    }
  }
  df = df_to_sp(df, lat.field, lon.field)
  # df = Mar.utils::df_qc_spatial(df, lat.field, lon.field, FALSE)
  # sp::coordinates(df) = c(lon.field, lat.field)
  # sp::proj4string(df) = sp::CRS(SRS_string="EPSG:4326")
  if (is.null(agg.poly.shp)){
    agg.poly=  Mar.data::NAFOSubunits
    defFields <- c("NAFO_1", "NAFO_2", "NAFO_3","NAFO_BEST")
    # know that the CRS of agg.poly obj is WGS84, but perhaps saved with
    #slight variations in the text
      sp::proj4string(agg.poly) <- sp::CRS(as.character(NA))
      sp::proj4string(agg.poly) = sp::CRS(SRS_string="EPSG:4326")

    if (is.null(agg.poly.field)){
      agg.poly.field = 'NAFO_BEST'
    }
    defFields = defFields[!defFields %in% agg.poly.field]
    agg.poly@data[ ,defFields] <- list(NULL)
  }else{
    agg.poly <- rgdal::readOGR(dsn = agg.poly.shp, verbose = FALSE)
    if (is.na(sp::proj4string(agg.poly))) {
      cat('\nNo projection found for input shapefile - assuming geographic.')
      sp::proj4string(agg.poly) = sp::CRS(SRS_string="EPSG:4326")
    }
    #convert the shape to geographic
    agg.poly <- suppressWarnings(sp::spTransform(agg.poly,sp::CRS(SRS_string="EPSG:4326")))
  }
  pip <- sp::over( df, agg.poly , fn = NULL)
  df@data = cbind(df@data, pip)

  if (!is.null(key.fields) && !is.null(facet.field) && !is.null(agg.fields)) df <- sp::merge(df, dfWide, by=key.fields, all.x=T)
  df@data[agg.fields][is.na(df@data[agg.fields])] <- 0
  df@data[agg.fields] <- lapply(df@data[agg.fields], as.numeric)

  calc= NA
  if ("MEAN" %in% calculate) calc = c(calc, "MEAN = round(mean(x), 4)")
  if ("CNT" %in% calculate) calc =  c(calc, "CNT = round(length(x[x!=0]), 0)")
  if ("SUM" %in% calculate) calc = c(calc, "SUM = round(sum(x), 4)")
  calc = calc[!is.na(calc)]
  #
  #
  # POLY.agg <- as.data.frame(as.list(stats::aggregate(
  #   df@data[agg.fields],
  #   by = df@data[c(agg.poly.field)],
  #   FUN = function(x)
  #     c(
  #       MEAN = round(mean(x), 4),
  #       CNT = round(length(x[x!=0]), 0),
  #       SUM = round(sum(x), 4)
  #     )
  # )))

  POLY.agg <- as.data.frame(as.list(stats::aggregate(
    df@data[agg.fields],
    by = df@data[c(agg.poly.field)],
    FUN = function(x) analyticChooser(x, calculate)
  )))

  POLY.agg[,2:ncol(POLY.agg)] <- sapply(POLY.agg[,2:ncol(POLY.agg)], as.numeric)
  if (!is.null(sens.fields)){
    POLY.agg.sens = as.data.frame(as.list(stats::aggregate(
      df@data[intersect(sens.fields, colnames(df@data))],
      by = df@data[c(agg.poly.field)],
      FUN = function(x)
        c(
          CNT = round(length(unique(x)), 0)
        )
    )))

    POLY.agg.sens$TOTUNIQUE = apply(as.data.frame(POLY.agg.sens[,2:ncol(POLY.agg.sens)]), 1, min)
    POLY.agg.sens$CAN_SHOW <- 'NA'
    if (nrow(POLY.agg.sens[POLY.agg.sens$TOTUNIQUE>=rule.of,])>0) POLY.agg.sens[POLY.agg.sens$TOTUNIQUE>=rule.of,]$CAN_SHOW <- 'YES'
    if (nrow(POLY.agg.sens[POLY.agg.sens$TOTUNIQUE<rule.of,])>0) POLY.agg.sens[POLY.agg.sens$TOTUNIQUE< rule.of,]$CAN_SHOW <- 'NO'
    POLY.agg = merge(POLY.agg, POLY.agg.sens)
    if (for.public){
      #if the output is for the public, all of the calculated aggregate values for polys that can't
      #be shown need to be dropped
      keepFields = c(agg.poly.field, "CAN_SHOW")
      POLY.agg[POLY.agg$CAN_SHOW == "NO",!names(POLY.agg) %in% keepFields]<-NA
      #also, all of the fields with the counts of the unique numbers of all of the sensitive fields
      #should be dropped
      POLY.agg[ ,c(sens.fields,"TOTUNIQUE")] <- list(NULL)
    }
    POLY.agg = sp::merge(agg.poly,POLY.agg)
    rm(POLY.agg.sens)
  }else{
    POLY.agg$CAN_SHOW = 'YES'
    POLY.agg = sp::merge(agg.poly,POLY.agg)
  }
  allowed.areas = POLY.agg@data[!is.na(POLY.agg$CAN_SHOW) & POLY.agg$CAN_SHOW=='YES',agg.poly.field]
  allowed.areas.sp = agg.poly[agg.poly@data[[agg.poly.field]] %in% allowed.areas,]
  df$ORD_df = seq.int(nrow(df))
  if (grid.shape =="hex"){
    grid2Min<-Mar.data::hex
  } else{
    grid2Min<-Mar.data::grid2Min
  }
  # know that the CRS of both grid2Min obj is WGS84, but perhaps saved with
  #slight variations in the text
  sp::proj4string(grid2Min) <- sp::CRS(as.character(NA))
  sp::proj4string(grid2Min) = sp::CRS(SRS_string="EPSG:4326")

  grid2Min$ORD_gr <-  seq.int(nrow(grid2Min))
  if (length(allowed.areas)>0){
    #clip the data to those overlaying acceptable NAFO
    df <- df[allowed.areas.sp, ]
    grid2Min <- grid2Min[allowed.areas.sp,]
    #step 1 -- figure out which grid each point is in.
    join <- sp::over(df, grid2Min)
    join$ORD_df <- seq.int(nrow(join))
    df@data = cbind(df@data,join)
    grid.agg = as.data.frame(as.list(stats::aggregate(
      df@data[agg.fields],
      by = df@data[c('ORD_gr')],
      # FUN = function(x)
      #   c(
      #     MEAN = round(mean(x), 4),
      #     CNT = round(length(x[x!=0]), 0),
      #     SUM = round(sum(x), 4)
      #   )
      FUN = function(x) analyticChooser(x, calculate)
    )))
    #step 3 -- append the aggregated data back onto the grid
    grid2Min=sp::merge(grid2Min, grid.agg)
    #populate all empty cells with 0
    grid2Min@data[!names(grid2Min@data) %in% c("HEXID", "ORD_gr")][is.na(grid2Min@data[!names(grid2Min@data) %in% c("HEXID", "ORD_gr")])] <- 0
    file.id = ifelse(!is.null(file.id),paste0(file.id,"_"),"")
    POLY.agg.name = paste0(file.id,'POLY_AGG_', ts)
    this.df.name = paste0(file.id,'Grid2Min_', ts)
    this.csv.name = paste0(file.id,'Grid2MinCentroid_', ts)

    # there are 3 analytics possible within the agg function via (analyticChooser) - CNT, SUM and MEAN
    # the resultant column get added to the data with the original names with "*.1", "*.2", or "*.3"
    # appended, depending on which analytic the values correspond with
    # the next bit will help establish which appended number corresponds with which analytic
    # possible analytics
    usedAnal <- intersect(c("CNT", "SUM", "MEAN"), calculate) # this returns the ones that were run
    nums <- match(calculate,usedAnal)
    for (i in 1:length(nums)){
      thisSearch = nums[i]
      thisrep = usedAnal[thisSearch]
      colnames(POLY.agg@data) <- sub(paste0("\\.", thisSearch), paste0("_",thisrep), colnames(POLY.agg@data))
      colnames(grid2Min@data) <- sub(paste0("\\.", thisSearch), paste0("_",thisrep), colnames(grid2Min@data))
    }
results <- list()
    if (create.centroid.csv) {
      this <- mkCentroidDf(grid2Min)
      results$centroidCsv <- this
      write.csv(this, paste0(this.csv.name,".csv"))
      message(paste0("\nCreated csv ", getwd(), .Platform$file.sep, this.csv.name,".csv\n"))
    }
    if (create.shps){
      if (!ignore.col.limit && max(ncol(POLY.agg@data), ncol(grid2Min@data))>255){
        warning("\nCan not create shapefiles.  Shapefiles are limited to 255 fields, and your data will have more than that.
The number of fields is determined by:
1) the number of unique values found in your facet.field (if present, e.g. bycatch species);
2) the number of specified agg.fields (e.g. kept_weight, discarded weight);
3) for each combination above, a sum, count and mean is calculated;
4) several housekeeping fields are also created")
      }else{
      POLY.agg = prepare_shape_fields(POLY.agg)
      rgdal::writeOGR(obj = POLY.agg, dsn= getwd(), layer = POLY.agg.name, driver="ESRI Shapefile", overwrite_layer=TRUE)
      message(paste0("\nCreated shapefile ", getwd(), .Platform$file.sep, POLY.agg.name,".shp\n"))
      grid2Min = prepare_shape_fields(grid2Min)
      rgdal::writeOGR(obj = grid2Min, dsn=getwd(), layer = this.df.name, driver="ESRI Shapefile", overwrite_layer=TRUE)
      message(paste0("\nCreated shapefile ", getwd(), .Platform$file.sep, this.df.name,".shp\n"))
      }
    }
    results$Grid2Min <- grid2Min
    results$POLY_AGG <- POLY.agg
  }else{
    print("No polygon has enough unique values to allow aggregated data to be shown")
    results= list("Grid2Min" = NULL, "POLY_AGG" = NULL)
  }
  return(invisible(results))
}


#!/usr/bin/env Rscript

options(stringAsfactors = FALSE, useFancyQuotes = FALSE)

# Taking the command line arguments
args <- commandArgs(trailingOnly = TRUE)

if(length(args)==0)stop("No file has been specified! Please select a file for blank filtering!\n")

require(xcms)
inputPeakML<-NA
output<-NA
blank<-"blank"
sample<-"sample"
method<-"max"
rest<-F
previousEnv<-NA
phenoFile<-NA
phenoDataColumn<-NA
for(arg in args)
{
  argCase<-strsplit(x = arg,split = "=")[[1]][1]
  value<-strsplit(x = arg,split = "=")[[1]][2]
  if(argCase=="input")
  {
    previousEnv=as.character(value)
  }
  if(argCase=="blank")
  {
    blank=as.character(value)
  }
  if(argCase=="sample")
  {
    sample=as.character(value)
  }
  if(argCase=="method")
  {
    method=as.character(value)
  }
  if(argCase=="rest")
  {
    rest=as.logical(value)
  }
  if(argCase=="phenoFile")
  {
    phenoFile=as.character(value)
  }
  if(argCase=="phenoDataColumn")
  {
    phenoDataColumn=as.character(value)
  }
  if(argCase=="output")
  {
    output=as.character(value)
  }
}

if(is.na(previousEnv) | is.na(output) | any(is.na(blank))) stop("All input, output and blank need to be specified!\n")

load(file = previousEnv)
inputXCMS<-get(varNameForNextStep)
if(!is.na(phenoDataColumn) && !is.na(phenoFile))
{
fileNameMap<-read.csv(phenoFile,stringsAsFactors = F,header = T)

for(i in 1:nrow(inputXCMS@phenoData))
{
massTracesXCMSSet@phenoData[i]<-fileNameMap[fileNameMap[,1]==rownames(massTracesXCMSSet@phenoData)[i],phenoDataColumn]
}
}

SpecificCorrelation<-function(x,d=c(1:length(x)))
{
  if(length(na.omit(x))<=2)return(data.frame(pvalue=1,cor=as.numeric(0)))
  y<-d
  tmpToCor<-cbind(x,y)
  tmpToCor<-na.omit(tmpToCor)
  tmp<-cor.test(tmpToCor[,1],tmpToCor[,2])
  return(data.frame(pvalue=tmp$p.value,cor=as.numeric(tmp$estimate)))
}
xset<-inputXCMS
idx <- xcms:::groupidx(xset)
removeGR<-c()
removePk<-c()

for( i in seq_along(idx)){
  peak_select <- xcms::peaks(xset)[idx[[i]], ]
  peaks<-rep(NA,nrow(xset@phenoData))
if(class(peak_select)=="numeric")
{
 peaks[peak_select["sample"]]<-peak_select["into"]
}else
{
peaks[peak_select[,"sample"]]<-peak_select[,"into"]
}

  names(peaks)<-c(as.character(xset@phenoData[,1]))

  blankSamples<-peaks[names(peaks)==blank]
  realSamples<-NA
  if(rest)
  {
    realSamples<-peaks[names(peaks)!=blank]
  }else{
    realSamples<-peaks[names(peaks)==sample]
  }

  blankSamples[is.na(blankSamples)]<-0
  realSamples[is.na(realSamples)]<-0

  controlRemove<-F
  if(method=="median")
    controlRemove<-median(blankSamples)>=median(realSamples)
  if(method=="mean")
    controlRemove<-mean(blankSamples)>=mean(realSamples)
  if(method=="max")
    controlRemove<-max(blankSamples)>=max(realSamples)

  if(controlRemove)
  {

    removeGR<-c(removeGR,i)
    removePk<-c(removePk,idx[[i]])
  }
}

for(i in removeGR)
{
  xset@groupidx[[i]]<-NULL
  xset@groups<-xset@groups[-i,]
}

preprocessingSteps<-c(preprocessingSteps,"blankFilter")

varNameForNextStep<-as.character("xset")

save(list = c("xset","preprocessingSteps","varNameForNextStep"),file = output)


library(rJava)
library(rgeos)
library(sp)
library(maptools)
library(raster)
library(dismo)
library(rgdal)

countries <- readOGR("./ne_50m_admin_0_countries/ne_50m_admin_0_countries.shp")
Ethiopia <- countries[countries$NAME == "Ethiopia", ]

# raster directories at 2.5 arc minutes
worldclim_directory <- "04_worldclim_layers"
ccsm_directory <- "06_ccsm_layers"
miroc_directory <- "05_miroc_layers"

# read in layers
worldclim_layers <- stack(list.files(worldclim_directory, full.names=T))
names(worldclim_layers) <- gsub("wc2.0_", "", names(worldclim_layers))
names(worldclim_layers) <- gsub("_2.5m_", "", names(worldclim_layers))
ccsm_layers <- stack(list.files(ccsm_directory, full.names=T))
names(ccsm_layers) <- gsub("cclgmbi", "bio", names(ccsm_layers))
miroc_layers <- stack(list.files(miroc_directory, full.names=T))
names(miroc_layers) <- gsub("mrlgmbi", "bio", names(miroc_layers))

# clip layers to eastern Africa
# max lat = 20, min lat = -20, max long = 55, min long = 10
clip_east_africa <- cbind(c(10, 55, 55, 10), c(20, 20, -20, -20))
clip_east_africa <- SpatialPolygons(list(Polygons(list(Polygon(clip_east_africa)), 1)))
worldclim_layers <- crop(worldclim_layers, clip_east_africa)
ccsm_layers <- crop(ccsm_layers, clip_east_africa)
miroc_layers <- crop(miroc_layers, clip_east_africa)

# find correlation of layers in worldclim dataset
layerStats(worldclim_layers, 'pearson', na.rm=T)$'pearson correlation coefficient'
# manually inspect output and choose the layers to keep
# here, we will keep all layers with less than 0.65 correlation
# bioclim layers = 1, 2, 3, 12, 14, 15
bioclim_keep <- c("bio1", "bio2", "bio3", "bio12", "bio14", "bio15")
worldclim_layers <- dropLayer(worldclim_layers, seq(1:length(names(worldclim_layers)))[is.na(match(names(worldclim_layers),bioclim_keep))])
ccsm_layers <- dropLayer(ccsm_layers, seq(1:length(names(ccsm_layers)))[is.na(match(names(ccsm_layers),bioclim_keep))])
miroc_layers <- dropLayer(miroc_layers, seq(1:length(names(miroc_layers)))[is.na(match(names(miroc_layers),bioclim_keep))])
# need to multiply current worldclim bio 1 and bio 2 * 10
worldclim_layers[[1]] <- worldclim_layers[[1]] * 10
worldclim_layers[[5]] <- worldclim_layers[[5]] * 10

# set up all lists for the entire process
input_files <- list()
training_points <- list()
testing_points <- list()
species_names <- list()
clipping_masks <- list()
raster_stacks <- list()
bioclim_values <- list()
niche_models_R <- list()
thresholds <- list()
projections_contemporary <- list()
projections_miroc <- list()
projections_ccsm <- list()
reclass_contemporary <- list()
reclass_miroc <- list()
reclass_ccsm <- list()
tests <- list()

# files of occurrence data
input_folder <- "03_final_points"
input_file_list <- list.files(input_folder, pattern="*rarefy.csv", full.name=T)
for(a in 1:length(input_file_list)) {
	input_files[[a]] <- read.csv(input_file_list[a])
	species_names[[a]] <- sapply(strsplit(sapply(strsplit(input_file_list[a], "/"), "[[", 2), "_"), "[[", 1)
}

# set up training and testing points
# set up percent of training and testing points
test_proportion <- 0.2
for(a in 1:length(input_files)) {
	a_rep <- input_files[[a]]
	a_rep <- data.frame(Long=a_rep[,2], Lat=a_rep[,1])
	a_test_points <- sample(1:nrow(a_rep), floor(nrow(a_rep) * test_proportion))
	training_points[[a]] <- a_rep[-a_test_points, ]
	testing_points[[a]] <- a_rep[a_test_points, ]

	# convert points to spatial points and add CRS WGS84
	coordinates(training_points[[a]]) <- c("Long", "Lat")
	proj4string(training_points[[a]]) <- CRS("+init=epsg:4326")
	coordinates(testing_points[[a]]) <- c("Long", "Lat")
	proj4string(testing_points[[a]]) <- CRS("+init=epsg:4326")
}

# set up training region for each species
# here we will use 250 km (250 *1000 m)
model_buffer <- 250 * 1000
for(a in 1:length(input_files)) {
	a_rep <- training_points[[a]]

	# create a projection of the points in CRS
	a_rep <- spTransform(a_rep, CRS=CRS("+init=epsg:3857"))

	# buffer the points by the model buffer and transform back to WGS84
	clipping_masks[[a]] <- spTransform(gBuffer(a_rep, width=model_buffer), CRS=CRS("+init=epsg:4326"))

	# create a training raster stack for each species
	raster_stacks[[a]] <- crop(worldclim_layers, clipping_masks[[a]])
	raster_stacks[[a]] <- mask(raster_stacks[[a]], clipping_masks[[a]])
}

# extract bioclim values for observed points and 500 background points
for(a in 1:length(input_files)) {
	bioclim_values[[a]] <- extract(raster_stacks[[a]], training_points[[a]])
	a_rep <- sampleRandom(raster_stacks[[a]], 500)
	a_rep <- data.frame(rbind(cbind(presence=1, bioclim_values[[a]]), cbind(presence=0, a_rep)))
	bioclim_values[[a]] <- a_rep
}

# perform maxent models for each species
for(a in 1:length(input_files)) {
	niche_models_R[[a]] <- maxent(x=bioclim_values[[a]][ ,2:ncol(bioclim_values[[a]])], p=bioclim_values[[a]][ ,1], path="./07_maxent_output")
	projections_contemporary[[a]] <- predict(niche_models_R[[a]], worldclim_layers)
	projections_ccsm[[a]] <- predict(niche_models_R[[a]], ccsm_layers)
	projections_miroc[[a]] <- predict(niche_models_R[[a]], miroc_layers)
}

# model reclassify function
# model is already read in as a raster
# threshold is numeric between 0 and 1
reclass_ENM <- function(model, threshold) {
  require(raster)
  y <- model
  y[y >= threshold] <- 1
  y[y < threshold] <- NA
  return(y)
}

# test the models accuracy with testing points and reclassify simultaneously
for(a in 1:length(input_files)) {
  train_values <- extract(projections_contemporary[[a]], training_points[[a]])
  thresholds[[a]] <- sort(train_values)[floor(length(train_values) - length(train_values) * 0.9)]
  reclass_contemporary[[a]] <- reclass_ENM(projections_contemporary[[a]], thresholds[[a]])
  reclass_ccsm[[a]] <- reclass_ENM(projections_ccsm[[a]], thresholds[[a]])
  reclass_miroc[[a]] <- reclass_ENM(projections_miroc[[a]], thresholds[[a]])

  # pull out whether test points are predicted or not
  # and also null hypothesis of "How many points are predicted out of total points?"
  perc_predicted <- as.vector(table(reclass_contemporary[[a]]@data@values)[1] / (reclass_contemporary[[a]]@ncols * reclass_contemporary[[a]]@nrows))
  test_values <- extract(reclass_contemporary[[a]], testing_points[[a]])
  test_values[is.na(test_values)] <- 0
  tests[[a]] <- binom.test(length(test_values[test_values == 1]), length(test_values), p = perc_predicted, alternative="g")
}

# crop the thresholded models to just ethiopia
worldclim_ethiopia <- crop(worldclim_layers[[1]], Ethiopia)
worldclim_ethiopia <- mask(worldclim_ethiopia, Ethiopia)
for(a in 1:length(input_files)) {
  reclass_contemporary[[a]] <- crop(reclass_contemporary[[a]], Ethiopia)
  reclass_contemporary[[a]][is.na(reclass_contemporary[[a]])] <- 0
  reclass_contemporary[[a]] <- mask(reclass_contemporary[[a]], Ethiopia)
  reclass_ccsm[[a]] <- crop(reclass_ccsm[[a]], Ethiopia)
  reclass_ccsm[[a]][is.na(reclass_ccsm[[a]])] <- 0
  reclass_ccsm[[a]] <- mask(reclass_ccsm[[a]], Ethiopia)
  reclass_miroc[[a]] <- crop(reclass_miroc[[a]], Ethiopia)
  reclass_miroc[[a]][is.na(reclass_miroc[[a]])] <- 0
  reclass_miroc[[a]] <- mask(reclass_miroc[[a]], Ethiopia)
}

par(mfrow=c(2,3))
for(a in 1:6) {
  plot(reclass_contemporary[[a]])
  lines(Ethiopia)
}
for(a in 1:6) {
  plot(reclass_ccsm[[a]])
  lines(Ethiopia)
}
for(a in 1:6) {
  plot(reclass_miroc[[a]])
  lines(Ethiopia)
}

# make a polygon that connects the populations east and west of the GRV
# with a 100 km buffer
grv_points <- rbind(c(7.095, 39.789), c(8.967, 38.572))
grv_points <- data.frame(Long=grv_points[,2], Lat=grv_points[,1])
coordinates(grv_points) <- c("Long", "Lat")
proj4string(grv_points) <- CRS("+init=epsg:4326")
grv_lines <- spLines(grv_points)
proj4string(grv_lines) <- CRS("+init=epsg:4326")
grv_lines2 <- spTransform(grv_lines, CRS=CRS("+init=epsg:3857"))
grv_points2 <- spTransform(grv_points, CRS=CRS("+init=epsg:3857"))
grv_buffer_size <- 100 * 1000
grv_buffer <- spTransform(gBuffer(grv_lines2, width=grv_buffer_size), CRS=CRS("+init=epsg:4326"))
east_buffer <- spTransform(gBuffer(grv_points2[1], width=grv_buffer_size), CRS=CRS("+init=epsg:4326"))
west_buffer <- spTransform(gBuffer(grv_points2[2], width=grv_buffer_size), CRS=CRS("+init=epsg:4326"))

plot(reclass_contemporary[[a]])
points(grv_points, pch=19, cex=0.8)
lines(grv_buffer)
lines(east_buffer)
lines(west_buffer)
lines(Ethiopia)

# calculate statistics through time of the models
model_stats <- c()
# columns of output =
# 1. genus name
# 2. area contemporary in Ethiopia
# 3. area contemporary in close region
# 4. area contemporary east
# 5. area contemporary west
# 6. mean area past in Ethiopia
# 7. mean area past in close region
# 8. mean area past east
# 9. mean area past west
for(a in 1:length(input_files)) {
  # 1 and 2
  a_rep <- c(species_names[[a]],
              cellStats(area(reclass_contemporary[[a]]) * reclass_contemporary[[a]],
              stat='sum'))
  # 3
  a_temp <- mask(crop(reclass_contemporary[[a]], grv_buffer), grv_buffer)
  a_rep <- c(a_rep, cellStats(area(a_temp) * a_temp, stat='sum'))
  # 4
  a_temp <- mask(crop(reclass_contemporary[[a]], east_buffer), east_buffer)
  a_rep <- c(a_rep, cellStats(area(a_temp) * a_temp, stat='sum'))
  # 5
  a_temp <- mask(crop(reclass_contemporary[[a]], west_buffer), west_buffer)
  a_rep <- c(a_rep, cellStats(area(a_temp) * a_temp, stat='sum'))
  # 6
  a_temp1 <- cellStats(area(reclass_ccsm[[a]]) * reclass_ccsm[[a]], stat='sum')
  a_temp2 <- cellStats(area(reclass_miroc[[a]]) * reclass_miroc[[a]], stat='sum')
  a_rep <- c(a_rep, mean(c(a_temp1, a_temp2)))
  # 7
  a_temp1 <- mask(crop(reclass_ccsm[[a]], grv_buffer), grv_buffer)
  a_temp1 <- cellStats(area(a_temp1) * a_temp1, stat='sum')
  a_temp2 <- mask(crop(reclass_miroc[[a]], grv_buffer), grv_buffer)
  a_temp2 <- cellStats(area(a_temp2) * a_temp2, stat='sum')
  a_rep <- c(a_rep, mean(c(a_temp1, a_temp2)))
  # 8
  a_temp1 <- mask(crop(reclass_ccsm[[a]], east_buffer), east_buffer)
  a_temp1 <- cellStats(area(a_temp1) * a_temp1, stat='sum')
  a_temp2 <- mask(crop(reclass_miroc[[a]], east_buffer), east_buffer)
  a_temp2 <- cellStats(area(a_temp2) * a_temp2, stat='sum')
  a_rep <- c(a_rep, mean(c(a_temp1, a_temp2)))
  # 9
  a_temp1 <- mask(crop(reclass_ccsm[[a]], west_buffer), west_buffer)
  a_temp1 <- cellStats(area(a_temp1) * a_temp1, stat='sum')
  a_temp2 <- mask(crop(reclass_miroc[[a]], west_buffer), west_buffer)
  a_temp2 <- cellStats(area(a_temp2) * a_temp2, stat='sum')
  a_rep <- c(a_rep, mean(c(a_temp1, a_temp2)))
  # add to total
  model_stats <- rbind(model_stats, a_rep)
}
model_stats <- data.frame(Species=as.character(model_stats[,1]),
                          Current_Ethiopia=as.numeric(model_stats[,2]),
                          Current_close=as.numeric(model_stats[,3]),
                          Current_east=as.numeric(model_stats[,4]),
                          Current_west=as.numeric(model_stats[,5]),
                          LGM_Ethiopia=as.numeric(model_stats[,6]),
                          LGM_close=as.numeric(model_stats[,7]),
                          LGM_east=as.numeric(model_stats[,8]),
                          LGM_west=as.numeric(model_stats[,9]))
write.table(model_stats, file="model_output.txt", quote=F, row.names=F, sep="\t")

# save
save.image("modeling.RData")


#----- SOME FUNCTIONS -----#

# Remove unnecessary data received from the Spotify API, and
# select which columns are usefull to us.
remove_junk <- function(data) {
    select(data,Genre=playlist_name,
           PlaylistLength=playlist_num_tracks,
           Artist=artist_name,
           Album=album_name,
           Track=track_name,
           Date=track_added_at,
           Popularity=track_popularity,
           Danceability=danceability,
           Energy=energy,
           Key=key,
           Loudness=loudness,
           Mode=mode,
           Speechiness=speechiness,
           Acousticness=acousticness,
           Instrumentalness=instrumentalness,
           Liveness=liveness,
           Valence=valence,
           Tempo=tempo,
           Duration=duration_ms,
           TimeSignature=time_signature,
           KeyMode=key_mode)
}

get_analysis <- function(id) {
    # return(get_tidy_audio_analysis(id) %>%
    #        select(segments) %>%
    #        unnest(segments) %>%
    #        select(start, duration, pitches))
    return(get_tidy_audio_analysis(id) %>%
    compmus_align(bars, segments) %>%
    select(bars) %>% unnest(bars) %>%
    mutate(
        pitches =
            map(segments,
                compmus_summarise, pitches,
                method = 'rms', norm = 'euclidean')) %>%
    mutate(
        timbre =
            map(segments,
                compmus_summarise, timbre,
                method = 'mean')))
}

plot_chroma <- function(data) {
    return(data %>%
        mutate(pitches = map(pitches, compmus_normalise, 'chebyshev')) %>%
        compmus_gather_chroma %>%
        ggplot(
            aes(
                x = start + duration / 2,
                width = duration,
                y = pitch_class,
                fill = value)) +
        geom_tile() +
        labs(x = 'Time (s)', y = NULL, fill = 'Magnitude') +
        theme_minimal())
}

plot_cesptro <- function(data) {
    return(data %>%
        compmus_gather_timbre %>%
        ggplot(
            aes(
                x = start + duration / 2,
                width = duration,
                y = basis,
                fill = value)) +
        geom_tile() +
        labs(x = 'Time (s)', y = NULL, fill = 'Magnitude') +
        scale_fill_viridis_c(option = 'E') +
        theme_classic())
}

plot_ssm <- function(data) {
    return(data %>%
        compmus_self_similarity(timbre, 'cosine') %>%
        ggplot(
            aes(
                x = xstart + xduration / 2,
                width = xduration,
                y = ystart + yduration / 2,
                height = yduration,
                fill = d)) +
        geom_tile() +
        coord_fixed() +
        scale_fill_viridis_c(option = 'E', guide = 'none') +
        theme_classic() +
        labs(x = '', y = ''))
}

# -------- Load Data --------- #

if (!file.exists("data/ff.rds") {
    future_funk <- remove_junk(get_playlist_audio_features("bkd0b33gypt1ixtyg44x4y2ui","4a0xb2zui3hIPll7CMgeSu"))
    writeRDS(future_funk, "data/ff.rds")
} else {
    future_funk <- readRDS("data/ff.rds")
}

if (!file.exists("data/kfb.rds") {
    kawaii_future_bass <- remove_junk( get_playlist_audio_features("bkd0b33gypt1ixtyg44x4y2ui","75OfhBfc4tnQ8MFdiPiMcx"))
    writeRDS(kawaii_future_bass, "data/kfb.rds")
} else {
    kawaii_future_bass <- readRDS("data/kfb.rds")
}

if (!file.exists("data/fp.rds") {
    futurepop <- remove_junk(get_playlist_audio_features("bkd0b33gypt1ixtyg44x4y2ui","1TBQdi8VdYsvruWv1W5HjB"))
    writeRDS(futurepop, "data/fp.rds")
} else {
    futurepop <- readRDS("data/fp.rds")
}

if (!file.exists("data/fa.rds") {
    future_ambient <- remove_junk(get_playlist_audio_features("bkd0b33gypt1ixtyg44x4y2ui","2dZ7eWcGRtuyseKY5QNZoP"))
    writeRDS(future_ambient, "data/fa.rds")
} else {
    future_ambient <- readRDS("data/fa.rds")
}

if (!file.exists("data/fg.rds") {
    future_garage <- remove_junk(get_playlist_audio_features("bkd0b33gypt1ixtyg44x4y2ui","2IgZ50kclGP2tNVx7mu9vL"))
    writeRDS(future_garage, "data/fg.rds")
} else {
    future_garage <- readRDS("data/fg.rds")
}


#' Plot several single-cell datasets/samples dimensionality reductions (PCA, UMAP, tSNE) in a single plot 3D plot, each layer corresponding to a dataset/sample.
#'
#' `multi_cluster_plot()` plot dimensionality reduction (PCA, UMAP, tSNE) of a batch of samples/datasets.
#'
#' This function will plot a list of single-cell datasets/samples dimensionality reduction in a 3D layered plot.
#'
#' @param sce_list List. A list of single cell experiments. At least 2 single cell experiments are needed.
#' @param similarity_table DataFrame. Optional. A similarity table previously calculated using ClusterFoldSimilarity function.
#' @param dim_method Character. Specify the dimensionality reduction used, either PCA, UMAP or tSNE. Default: PCA.
#' @param pdf_name Character. If specify the plot is saved on a PDF file with the given name. Default: plot in the current graphic device.
#'
#' @return A dimensionality reduction 3D plot (PCA, UMAP, tSNE) of a batch of samples/datasets.
#'
#' @import scatterplot3d
#'
#' @export
multi_cluster_plot <- function(sce_list = NULL,similarity_table = NULL,dim_method="PCA",pdf_name = NULL){

  # sce_list <- pancreas.sc.list
  if(is.null(sce_list) | (length(sce_list)<2)){
    stop("At least two Single Cell Experiments are needed for cluster comparison.")
  }
  # Function starts by loading dependencies
  if(class(sce_list[[1]]) == "Seurat" ){
    if (!requireNamespace("Seurat", quietly = TRUE)) {
      stop("Package \"Seurat\" needed for this function to work. Please install it.",
           call. = FALSE)}
    is_seurat <- TRUE
    is_sce <- FALSE
  }
  if(class(sce_list[[1]]) == "SingleCellExperiment" ){
    if (!requireNamespace("SingleCellExperiment", quietly = TRUE)) {
      stop("Package \"SingleCellExperiment\" needed for this function to work. Please install it.",
           call. = FALSE)}
    is_seurat <- FALSE
    is_sce <- TRUE
  }
  if(dim_method == "PCA"){
    dimMeth <- "PCA"
    if(is_sce){useDimFunc <- scater::calculatePCA}
    if(is_seurat){useDimFunc <- Seurat::RunPCA}
  }
  if(dim_method == "UMAP"){
    dimMeth <- "UMAP"
    if(is_sce){useDimFunc <- scater::calculateUMAP}
    if(is_seurat){useDimFunc <- Seurat::RunUMAP}
      }
  if(dim_method == "tSNE"){
    dimMeth <- "tSNE"
    if(is_sce){useDimFunc <- scater::calculateTSNE}
    if(is_seurat){useDimFunc <- Seurat::RunTSNE}
  }

  if(is_seurat){getDimFunc <- function(x,dim_method = dimMeth,useDimFunc=useDimFunc){
    if(dimMeth %in% names(x@reductions)){return(Seurat::Embeddings(x[[dim_method]])[,1:2]) # If the dimensionality has been previously calculated, we obtain the values.
    }else{
        return(useDimFunc(x)) # If the required dimensionality is NOT in the object, we calculate it.
      }}
  }
  if(is_sce){getDimFunc <- function(x,dim_method = dimMeth,useDimFunc=useDimFunc){
    if(dimMeth %in% SingleCellExperiment::reducedDimNames(x)){return(SingleCellExperiment::reducedDim(x,dimMeth)[,1:2]) # If the dimensionality has been previously calculated, we obtain the values.
    }else{
      return(useDimFunc(x)) # If the required dimensionality is NOT in the object, we calculate it.
    }}
  }

  # if(is_sce){
  #   if(dimMeth %in% reducedDimNames(sce_list[[1]])){data <- reducedDim(sce_list[[1]],dimMeth)}else{data <- useDimFunc(sce_list[[1]])}
  #   }
  if(is_sce){
    data <- cbind.data.frame(getDimFunc(sce_list[[1]]),sample_id=1, cluster =  SingleCellExperiment::colLabels(sce_list[[1]]))
    for (i in seq_along(sce_list)[-1]){
      data <- rbind.data.frame(data,cbind.data.frame(getDimFunc(sce_list[[i]]),sample_id=i, cluster = SingleCellExperiment::colLabels(sce_list[[i]])))
    }
    }
  if(is_seurat){data <- cbind.data.frame(getDimFunc(sce_list[[1]]),sample_id=1, cluster =  Seurat::colLabels(sce_list[[1]]))}

  data$sample_id <- data$sample_id
  y_max <- max(data[,1]) +2
  y_min <- min(data[,1]) -2
  z_max <- max(data[,2]) +2
  z_min <- min(data[,2]) -2
  if(!is.null(pdf_name)){
    graphics.off()
    pdf(file = pdf_name, width = 40, height = 16)
  }

  cluster_colors <- c("#D1E5F0","#A6761D","#252525","#0868AC","#08306B","#004529","#0570B0","#2171B5","#A50026","#BCBDDC","#B15928","#8C96C6","#1B7837","#238B45",
                      "#A6BDDB","#DE77AE","#3F007D","#D0D1E6","#313695","#FB6A4A","#B3B3B3","#E08214","#006837","#7BCCC4","#081D58","#F46D43","#78C679","#C7EAE5",
                      "#74C476","#02818A","#67001F","#FDDBC7","#C6DBEF","#E31A1C","#BDBDBD","#FDD49E","#EF6548","#FC8D62","#F7F7F7","#969696","#253494","#D73027",
                      "#FEC44F","#CCEBC5","#053061","#1D91C0","#FB9A99","#FEE0D2","#762A83","#FDBF6F","#D9D9D9","#A8DDB5","#67A9CF","#FEB24C","#B2182B","#FD8D3C",
                      "#800026","#045A8D","#ADDD8E","#542788","#525252")

  data <- cbind.data.frame(data, color = "NA")

  if(!is.null(similarity_table)){ # If a similarity table is available...

    for (i in seq_along(sce_list)){ # Sample loop - i
    for (j in unique(similarity_table[similarity_table$dataset_l==i,]$cluster_l)){ # Cluster loop - j
      # Coloring of the clusters
      if(all(data[(data$sample_id == i) & (data$cluster == j),]$color == "NA")){
        single_color <- sample(cluster_colors,size = 1)
        cluster_colors <- setdiff(cluster_colors,single_color)
        data[data$sample_id == i & data$cluster == j,]$color <- single_color
      }else{
      single_color <- unique(data[(data$sample_id == i) & (data$cluster == j),]$color)
      }

      indx <- similarity_table[similarity_table$dataset_l==i & similarity_table$cluster_l == j,c("dataset_r","cluster_r")]

      indx2 <- do.call(rbind.data.frame,
                       apply(indx,1,function(x){
                         similarity_table[(similarity_table$dataset_l == x[1]) & (similarity_table$cluster_l == x[2]) &
                                            (similarity_table$dataset_r == i) & (similarity_table$cluster_r == j),c("dataset_l","cluster_l")]
                       }))

      indx3 <- unlist(apply(indx2,1,function(x){
        tmp <- which( (data$sample_id == x[1]) & (data$cluster == x[2]))
        if(all(data[tmp,]$color == "NA")){return(tmp)}
        }))

      if(length(indx3) != 0){
        data[indx3,]$color <- single_color
      }
    }}
  } # END of similarity table processing

  data_na <- data[data$color == "NA",]
  if(nrow(data_na) != 0){
    # samples_pre <- rownames()
    data_na <- do.call(rbind,unname(by(data_na,data_na[,c("cluster")],function(x){
    single_color <- sample(cluster_colors,size = 1)
    cluster_colors <- setdiff(cluster_colors,single_color)
    x[,"color"] <- single_color
    return(x)
    })))
  data[rownames(data_na),]$color <- data_na$color
  }

  spd <- scatterplot3d::scatterplot3d(x = data$sample_id,y = data[,1],z = data[,2],color = data$color,
                                      angle = 60,pch = 20,box = FALSE,col.grid = "grey",
                                      cex.symbols = 0.6,ylim = c(y_min,y_max), zlim = c(z_min,z_max),asp = -2,
                                      xlab = "sample / dataset",ylab ="X2",zlab = "X1")

  for (i in as.numeric(unique(data$sample_id))){
  x0 <- i
  spd$points3d(x=rep(x0,5),y=c(y_min,y_min,y_max,y_max,y_min), z=c(z_min,z_max,z_max,z_min,z_min), type="l", col="black", lwd=0.8)
  }

  if(!is.null(pdf_name))dev.off()
}


## necessary libraries
library(raster)
library(tidyverse)
library(ncdf4)

## load data
data <- read.csv("database//uniqueID.csv")

## Create spatial points dataframe
gps <- data ## assign data to separate dataframe
coordinates(gps) <- ~Lon+Lat ## define lat and lon
crs.world <-CRS("+proj=longlat +datum=WGS84") ## define CRS
proj4string(gps) <- crs.world ## assign CRS to coordinates

## list variables
occurdat <- list.files("C:\\Users\\Alessandro\\Downloads\\", pattern="*.nc", recursive = TRUE,  full.names = TRUE)

## run loop to extract each band
crudat <- data.frame() ## create empty dataframe
for(i in 548:1404){ ## start with the first year of study
temp <- raster(occurdat[4], band=i) ## select band iteration
values <- raster::extract(temp, gps) ## extract from raster based on coordinates
time.frame <- temp@z[[1]] ## extract timeframe
temporary <- data.frame(gps$uniqueID, temp=values, date=time.frame)  ## assign to temporary dataframe
crudat <- rbind(crudat, temporary) ## join temporary dataframe to master dataframe
print(i) ## print iteration to ensure its working
}

## assign new date columns
crudat["year.raster"] <- format(as.Date(crudat$date, format="%Y-%m-%d"),"%Y")
crudat["month.raster"] <- format(as.Date(crudat$date, format="%Y-%m-%d"),"%m")

## convert each year to numeric values from characters
year.avg$year.raster <- as.numeric(year.avg$year.raster)
year.avg$year <- as.numeric(year.avg$year)

## select study years only
cur.avg <-  year.avg[year.avg$year==year.avg$year.raster,] ## year study was conducted
lag.avg <-  year.avg[year.avg$year==year.avg$year.raster+1,] ## year before study was conducted

## run loop to download selected year
crudat <- data.frame()

for(i in 1:63){
## Select year for iteration
yearTarget <- ((1955+i)-1901)*12 ## determine surveyed year from multiples of 12
yearRange <- seq(yearTarget-11,yearTarget+12, 1) ## generate range of years in multiples of 12 for dataset

tryCatch({ ## put error catch for years without lakes surveyed
## subset GPS points by that year
gpsYear <- subset(gps, Year==(1955+i))
if (nrow(gpsYear)==0) stop("No lakes surveyed that year")

yearData <- data.frame() ## create empty dataframe
for(j in yearRange){
temp <- raster(occurdat[1], band=j) ## select band iteration
values <- raster::extract(temp, gpsYear) ## extract from raster based on coordinates
time.frame <- temp@z[[1]] ## extract timeframe
temporary <- data.frame(gpsYear$uniqueID, variable=values, date=time.frame,  ## assign to temporary dataframe
	surveyYear=ifelse(j < max(yearRange)-11, "lag","survey"))  ## create lag year column based on lower 12 months of yearly range
yearData <- rbind(yearData, temporary) ## join temporary dataframe to master dataframe
}
crudat <- rbind(crudat, yearData)
}, error=function(e){cat("ERROR :",conditionMessage(e), "\n")})
print(i)
}

## move lag year data into a separate column
crudat[crudat$surveyYear=="survey","variable.lagged"] <- crudat[crudat$surveyYear=="lag", "variable"] ## move lag data into its own column
crudat <- crudat[crudat$surveyYear=="survey",] ## drop lag year data

## assign numeric date columns
crudat["Year"] <- as.numeric(format(as.Date(crudat$date, format="%Y-%m-%d"),"%Y"))
crudat["Month"] <- as.numeric(format(as.Date(crudat$date, format="%Y-%m-%d"),"%m"))

## Repeat for other variables and assign to datframe

## rename variable
names(crudat)[c(2,5)] <- c("pet","pet.lag")
pet <- crudat

## drop repeated columns
tmax <- tmax[,-c(3:4)]
tmin <- tmin[,-c(3:4)]
pre <- pre[,-c(3:4)]
pet <- pet[,-c(3:4)]

## rename unique ID column
names(tmax)[1] <- "uniqueID"
names(tmin)[1] <- "uniqueID"
names(pre)[1] <- "uniqueID"
names(pet)[1] <- "uniqueID"

fullCru <- merge(tmax, tmin, by=c("uniqueID","Year","Month")) ## join tmax and tmin
fullCru <- merge(fullCru, pre, by=c("uniqueID","Year","Month")) ## join precipitation
fullCru <- merge(fullCru, pet, by=c("uniqueID","Year","Month")) ## join potential evapotranspiration

write.csv(fullCru, "database//CRUmissing.csv", row.names=FALSE)

## solar radiation dataset

## list variables
occurdat <- list.files("C:\\Users\\Alessandro\\Downloads\\", pattern="*.tif", recursive = TRUE,  full.names = TRUE)

srad <- data.frame()
for(i in 1:12){
solar <- raster(occurdat[15+i])
values <- data.frame(raster::extract(solar, gps))
values[,"month"] <- i
values[,"uniqueID"] <- gps$uniqueID
srad <- rbind(srad, values)
print(i)
}

names(srad)[1] <- "values"

srad.wide <- tidyr::spread(srad, month, values)
write.csv(srad.wide, "database//solarRadiation.csv", row.names=FALSE)


10
* 15

20
- 10 # no error but unary minus here


#+---------------------------------------------------------------------------------------------------------------------+
#| 1.a. FIX.EVIDENCE: (v. 1)                                                                                |
#|                                                                                |
#| This function fixes the evidence.txt as follows:                                                                    |
#| If we have similar peptides, this function takes the sequence i and:                                                |
#| Sets PEP as min(PEP(i)),                                                                                |
#| and RT as median(Retention.times(i)).                                                                               |
#| Also evidence.txt will be shrinked and filtered to PEP<0.05 to occupy less memory.                                  |
#| The output ev.ed.txt will be used for making the library and selecting the reference experiment.                    |
#|                                                                                |
#| Example: fix.evidence(path.in = 'C:/../evidence.txt',                                                               |
#|                      path.out = 'C:/../ev.ed.txt')                                                                  |
#|                                                                                |
#+---------------------------------------------------------------------------------------------------------------------+

fix.evidence <- function(path.in, path.out){
  # read input file as tab-delimited, text file
  ev <- read.delim(path.in, header = TRUE, stringsAsFactors = FALSE)
  # only take peptides with PEP < 0.05
  # only take columns we need
  ev <- ev[ev$PEP<0.05, c('Raw.file', 'Sequence', 'PEP', 'Retention.time')]

  # get the list of all experiments (raw files) in the input file
  exps <- unique(ev$Raw.file)

  # create output table
  all.exps <- data.frame(Raw.file=character(), Sequence=character(), PEP=numeric(), Retention.time=numeric())

  # loop thru experiments
  for (i in exps) {
    # get current experiment
    exp <- subset(ev, ev$Raw.file==i)

    # count # of "scans"/IDs for each peptide
    # some of these will come from consolidated PSMs, and will not be further consolidated because
    # of different charges, i.e., +1, +2
    pep.frqs <- as.data.frame(table(exp$Sequence))

    # get peptides where we have more than one "scan"
    red.peps.list <- as.character(pep.frqs[pep.frqs$Freq>1, 'Var1'])
    # for these peptides, take the smallest PEP and the median RT
    red.peps <- data.frame(Raw.file=as.character(rep(i, length(red.peps.list))),
                           Sequence=as.character(rep(NA, length(red.peps.list))),
                           PEP=as.numeric(rep(NA, length(red.peps.list))),
                           Retention.time=as.numeric(rep(NA, length(red.peps.list))),
                           stringsAsFactors=FALSE)

    for (j in 1:length(red.peps.list)) {
      red.peps$Sequence[j] <- red.peps.list[j]
      red.peps$PEP[j] <- min(exp[exp$Sequence==red.peps.list[j], 'PEP'])
      red.peps$Retention.time[j] <- median(exp[exp$Sequence==red.peps.list[j], 'Retention.time'])
    }

    # consolidate list so that all peptides have a unique PEP and RT
    exp <- rbind(red.peps, exp[!(exp$Sequence %in% red.peps.list), ])
    # add to output table
    all.exps <- rbind(all.exps, exp)
  }
  # scrub row names
  row.names(all.exps) <- NULL
  # write to output file - ev.ed.txt
  write.table(all.exps, path.out, sep = '\t', row.names = FALSE, quote = FALSE)
}


# source('backtest_lib.r')

#####################   Snow      ##########################
strategy_naive <- function(starttime,endtime, symbol, env, bid, ask, mktprice, positionbook, pendingbook){
  # Active portion of strategy

  actiontime <- env[[mktprice]][["Date"]] # Times to perform active portion

  actcounter <- 1 # count for which action time we are on

  # Constants
  quantity <- 1
  highprice <- 111
  midprice <- 110.3
  lowprice <- 109.5
  interval <- 0.05

  # Order number initialize
  ordercounter <- 1

  looprow <- length(env[[mktprice]][["Date"]]) # Assuming starttime and endtime are times in seconds

  #order format: msgtype, symbol, price, amount, b/s, market/limit/stop, refnumber, time
  #response format: orderID, DateCreated, DateExecuted, Symbol, Price, amount, b/s, market/limit/stop
  cat(looprow)
  for (i in 1:looprow){
    #check market condition

    response <- update_orderbook(env[[bid]][["HIGH"]][i], env[[ask]][["LOW"]][i],
                                 env, pendingbook,
                                 env[[mktprice]][["Date"]][i])

    # Passive portion
    if (nrow(response)!=0){
      passiveupdate(response)
    }
    #active portion of strategy
    if (env[[mktprice]][["Date"]][i] == actiontime[actcounter]){
      actcounter <- actcounter +1
      orderline = data.frame(matrix(NA, 0, length(order_msg_spec)))
      colnames(orderline) <- order_msg_spec
      currposition <- env[[positionbook]][[length(env[[positionbook]])]]
      corsymbol <- (env[[positionbook]][[length(env[[positionbook]])]][[Con_FieldName_Sym]] == symbol)
      currposition[corsymbol,Con_FieldName_Qty]
      #what does this if do
      if(env[[mktprice]][["LOW"]][i] >= highprice & length(currposition[corsymbol,Con_FieldName_Qty])==0){
        entry <- nrow(orderline)+1
        orderline[entry, Con_FieldName_MsgType] <- Con_MsgType_New
        orderline[entry, Con_FieldName_OrdID] <- ordercounter
        ordercounter <- ordercounter + 1
        orderline[entry, Con_FieldName_Sym] <- symbol
        orderline[entry, Con_FieldName_Price] <- env[[ask]][["LOW"]][i]
        orderline[entry, Con_FieldName_Qty] <- quantity
        orderline[entry, Con_FieldName_Side] <- Con_Side_Sell
        orderline[entry, Con_FieldName_OrdType] <- Con_OrdType_Mkt
      }
      else if(env[[mktprice]][["HIGH"]][i] <= lowprice & length(currposition[corsymbol,Con_FieldName_Qty])==0){
        entry <- nrow(orderline) + 1
        orderline[entry, Con_FieldName_MsgType] <- Con_MsgType_New
        orderline[entry, Con_FieldName_OrdID] <- ordercounter
        ordercounter <- ordercounter + 1
        orderline[entry, Con_FieldName_Sym] <- symbol
        orderline[entry, Con_FieldName_Price] <- env[[bid]][["HIGH"]][i]
        orderline[entry, Con_FieldName_Qty] <- quantity
        orderline[entry, Con_FieldName_Side] <- Con_Side_Buy
        orderline[entry, Con_FieldName_OrdType] <- Con_OrdType_Mkt
      }
      #is this if condition ever going to be satisfied?
      else if(env[[mktprice]][["HIGH"]][i] >= midprice-interval & env[[mktprice]][["HIGH"]][i] <= midprice+interval
              & length(currposition[corsymbol,Con_FieldName_Qty]) != 0){
        if(currposition[corsymbol,Con_FieldName_Qty]>0) {
          entry <- nrow(orderline) + 1
          orderline[entry, Con_FieldName_MsgType] <- Con_MsgType_New
          orderline[entry, Con_FieldName_OrdID] <- ordercounter
          ordercounter <- ordercounter + 1
          orderline[entry, Con_FieldName_Sym] <- symbol
          orderline[entry, Con_FieldName_Price] <- env[[bid]][["HIGH"]][i]
          orderline[entry, Con_FieldName_Qty] <- quantity
          orderline[entry, Con_FieldName_Side] <- Con_Side_Sell
          orderline[entry, Con_FieldName_OrdType] <- Con_OrdType_Mkt
        }
        else if(currposition[corsymbol,Con_FieldName_Qty] < 0) {
          entry <- nrow(orderline) + 1
          orderline[entry, Con_FieldName_MsgType] <- Con_MsgType_New
          orderline[entry, Con_FieldName_OrdID] <- ordercounter
          ordercounter <- ordercounter + 1
          orderline[entry, Con_FieldName_Sym] <- symbol
          orderline[entry, Con_FieldName_Price] <- env[[ask]][["LOW"]][i]
          orderline[entry, Con_FieldName_Qty] <- quantity
          orderline[entry, Con_FieldName_Side] <- Con_Side_Buy
          orderline[entry, Con_FieldName_OrdType] <- Con_OrdType_Mkt
        }
      }
      #orderline<- orderline[,-1]
      response <- handle_orders(orderline, env, pendingbook, env[[bid]][["HIGH"]][i], env[[ask]][["LOW"]][i], env[[mktprice]][["Date"]][i])
      if (nrow(response)!=0){
        passiveupdate(response)
      }
    }
  }

}

passiveupdate <- function(response){
  # Send subsequent orders

  #if (some condition to send cancel orders){
  #  send cancel orders
  #}
}
##################################################


#formats and combines phenotype (of a single trait)
#and genotype datasets of multiple
#populations

options(echo = FALSE)

library(stringr)
library(randomForest)
library(lme4)
library(data.table)
library(phenoAnalysis)
library(dplyr)
library(tibble)

allArgs <- commandArgs()

inFile <- grep("input_files",
               allArgs,
               ignore.case = TRUE,
               perl = TRUE,
               value = TRUE
               )

outFile <- grep("output_files",
                allArgs,
                ignore.case = TRUE,
                perl = TRUE,
                value = TRUE
                )

outFiles <- scan(outFile,
                 what = "character"
                 )

combinedGenoFile <- grep("genotype_data",
                         outFiles,
                         ignore.case = TRUE,
                         fixed = FALSE,
                         value = TRUE
                         )

combinedPhenoFile <- grep("phenotype_data",
                          outFiles,
                          ignore.case = TRUE,
                          fixed = FALSE,
                          value = TRUE
                          )

inFiles <- scan(inFile,
                what = "character"
                )
print(inFiles)

traitFile <- grep("trait_",
                  inFiles,
                  ignore.case = TRUE,
                  fixed = FALSE,
                  value = TRUE
                  )

trait <- scan(traitFile,
              what = "character",
              )

traitInfo <- strsplit(trait, "\t");
traitId   <- traitInfo[[1]]
traitName <- traitInfo[[2]]

#extract trait phenotype data from all populations
#and combine them into one dataset

allPhenoFiles <- grep("phenotype_data",
                  inFiles,
                  ignore.case = TRUE,
                  fixed = FALSE,
                  value = TRUE
                  )
message("phenotype files: ", allPhenoFiles)

allGenoFiles <- grep("genotype_data",
                  inFiles,
                  ignore.case = TRUE,
                  fixed = FALSE,
                  value = TRUE
                  )

popIds            <- c()
combinedPhenoPops <- c()
cnt               <- 0

for (popPhenoFile in allPhenoFiles) {

     cnt <- cnt + 1

     phenoData <- fread(popPhenoFile,
                        na.strings = c("NA", " ", "--", "-", "."))

     phenoData <- data.frame(phenoData)

     phenoTrait <- getAdjMeans(phenoData,
                               traitName=traitName,
                               calcAverages=TRUE)

     popIdFile <- basename(popPhenoFile)
     popId     <- str_extract(popIdFile, "\\d+")
     popIds    <- c(popIds, popId)

     newTraitName <- paste(traitName, popId, sep = "_")
     colnames(phenoTrait)[2] <- newTraitName

     if (cnt == 1 ) {
         print('no need to combine, yet')
         combinedPhenoPops <- phenoTrait

     } else {
         print('combining...phenotypes')

         combinedPhenoPops <- full_join(combinedPhenoPops, phenoTrait, by='genotypes')
     }
 }

combinedPhenoPops <- column_to_rownames(combinedPhenoPops, var='genotypes')

# #fill in missing data in combined phenotype dataset
# #using row means
naIndices <- which(is.na(combinedPhenoPops), arr.ind=TRUE)
combinedPhenoPops <- as.matrix(combinedPhenoPops)
combinedPhenoPops[naIndices] <- rowMeans(combinedPhenoPops, na.rm=TRUE)[naIndices[,1]]
combinedPhenoPops <- as.data.frame(combinedPhenoPops)

message("combined total number of stocks in phenotype dataset (before averaging): ", length(rownames(combinedPhenoPops)))

combinedPhenoPops$Average<-round(apply(combinedPhenoPops,
                                        1,
                                        function(x)
                                        { mean(x) }
                                        ),
                                  digits = 2
                                  )

markersList      <- c()
combinedGenoPops <- c()
cnt              <- 0

for (popGenoFile in allGenoFiles) {

    uniqGenoNames <- c()
    cnt <- cnt + 1

    genoData <- fread(popGenoFile,
                      na.strings = c("NA", " ", "--", "-"),
                      )

    genoData <- data.frame(genoData)
    message('cnt of genotypes in dataset: ', length(rownames(genoData)))
    genoData <- genoData[!duplicated(genoData[,'V1']), ]
    message('cnt of unique genotypes in dataset: ', length(rownames(genoData)))
    rownames(genoData) <- genoData[, 1]
    genoData[, 1] <- NULL

    popGenoFile <- basename(popGenoFile)
    popId       <- str_extract(popGenoFile, "\\d+")
    popIds      <- c(popIds, popId)

    #popMarkers <- colnames(genoData)
    #message("No of markers from population ", popId, ": ", length(popMarkers))

   # message("sum of geno missing values: ", sum(is.na(genoData)))
   # genoData <- genoData[, colSums(is.na(genoData)) < nrow(genoData) * 0.5]
   # genoData <- data.frame(genoData)
   # message("sum of geno missing values: ", sum(is.na(genoData)))
    ## if (sum(is.na(genoData)) > 0) {
    ##     message("sum of geno missing values: ", sum(is.na(genoData)))
    ##     genoData <- na.roughfix(genoData)
    ##     message("total number of stocks for pop ", popId,": ", length(rownames(genoData)))
    ## }

    if (cnt == 1 ) {
        print('no need to combine, yet')
        message('cnt of genotypes first dataset: ', length(rownames(genoData)))
        combinedGenoPops <- genoData

    } else {
        print('combining genotype datasets...')

        uniqGenoNames <- unique(rownames(combinedGenoPops))

        message('cnt of genotypes in new dataset ', popId, ': ',  length(rownames(genoData)) )

        genoData <- genoData[!(rownames(genoData) %in% uniqGenoNames),]

        message('cnt of unique genotypes from new dataset ', popId, ': ', length(rownames(genoData)))

        if (!is.null(genoData)) {
            combinedGenoPops <- rbind(combinedGenoPops, genoData)
        } else {
            message('dataset ', popId, ' has no unique genotypes.')
        }
    }

}

combinedGenoPops <- combinedGenoPops[order(rownames(combinedGenoPops)), ]
message("combined number of genotypes in combined dataset: ", length(rownames(combinedGenoPops)))

message("writing data to files...")
#if(length(combinedPhenoFile) != 0 )
#  {
      fwrite(combinedPhenoPops,
                  file = combinedPhenoFile,
                  sep = "\t",
                  quote = FALSE,
                  row.names = TRUE,
                  )
#  }

#if(length(combinedGenoFile) != 0 )
#  {
      fwrite(combinedGenoPops,
                  file = combinedGenoFile,
                  sep = "\t",
                  quote = FALSE,
                   row.names = TRUE,
                  )
#  }

q(save = "no", runLast = FALSE)


getSessionId = function(session) {
  id = 0
  if(!is.null(session) && is.list(session)) {
    id = session$id
  } else {
    id = paste0("i",concerto$session$id)
  }
  return(id)
}

getSafeItems = function(nextItems) {
  itemsNum = dim(nextItems)[1]
  if(itemsNum > 0) {
    for(i in 1:itemsNum) {
      item = as.list(nextItems[i,])

      if(is.character(item$responseOptions)) { item$responseOptions = fromJSON(item$responseOptions) }
      responseOptionsRandomOrder = item$responseOptions$optionsRandomOrder == "1"
      orderedOptions = c()

      if(length(item$responseOptions$options) > 0) {
        if(responseOptionsRandomOrder) {
          orderedOptions = item$responseOptions$options[sample(1:length(item$responseOptions$options))]
        } else {
          orderedOptions = item$responseOptions$options
        }
      }
      item$responseOptions$options = orderedOptions
      item$responseOptions = toJSON(item$responseOptions)

      nextItems[i,] = item
    }
  }
  return(nextItems)
}

getSafePastResponses = function(nextItems, session, responseBank) {
  responseBank = fromJSON(responseBank)
  if(is.null(responseBank$table)) {
    concerto.log("no response bank defined")
    return(NULL)
  }

  sql = "
SELECT * FROM {{table}}
WHERE
{{sessionIdColumn}}='{{sessionId}}' AND
{{itemIdColumn}} IN ({{itemIds}})
"
  responses = concerto.table.query(sql, list(
    table=responseBank$table,
    sessionIdColumn=responseBank$columns$session_id,
    sessionId=getSessionId(session),
    itemIdColumn=responseBank$columns$item_id,
    itemIds=paste(nextItems[,"id"], collapse=",")
  ))
  if(dim(responses)[1] > 0) {
    responses[,"score"] = NULL
    return(responses)
  }
  return(NULL)
}

concerto.log(prevPage, "previous page")
concerto.log(direction, "direction")
nextPage = as.numeric(prevPage) + as.numeric(direction)

pageFirstItemIndex = (nextPage - 1) * as.numeric(settings$itemsPerPage) + 1
pageLastItemIndex = min(nextPage * as.numeric(settings$itemsPerPage), dim(items)[1])

nextItemsIndices = pageFirstItemIndex:pageLastItemIndex
concerto.log(nextItemsIndices, "next item indices")
nextItems = items[nextItemsIndices,]
nextItemsSafe = getSafeItems(nextItems)
pastResponsesSafe = getSafePastResponses(nextItems, session, settings$responseBank)


source("R/header.r")

myPalette <- colorRampPalette((brewer.pal(9, "YlOrRd")), space="Lab")
theme_opts <- list(theme(
	panel.grid.minor = element_blank(),
	panel.grid.major = element_blank(),
	# panel.background=element_blank(),
	panel.background = element_rect(color = "black",fill=NA, size = .5, linetype = "solid"),
	#panel.border=element_rect(color = "black",fill=NA, size = 0.4, linetype = "solid"),
	plot.background = element_blank(),
	plot.background=element_blank(),
	panel.border=element_rect(color = "black",fill=NA, size = .5, linetype = "solid"),
	legend.position="right",
	#panel.border = element_blank(),
	#axis.line = element_blank(),
	#axis.text.x = element_blank(),
	#axis.text.y = element_blank(),
	#axis.ticks = element_blank(),
	#panel.margin = unit(5,"lines"),
	#panel.margin = unit(0,"null"),
	#plot.margin = rep(unit(0,"null"),4),
	axis.title.x = element_blank(),
	axis.title.y = element_blank(),
	plot.title = element_text()))

nc<-new("mapncdf", filename="data/Climate_CX_v2_2000.nc",
	varname="TmaxdegC",start_ind=c(1,1,180),count_ind=c(-1,-1,1))
#nc<-new("mapncdf", filename="data/tas_A1_2.nc",
# varname="tas",start_ind=c(1,1,1),count_ind=c(-1,-1,1))
kkk1<-mapConvert(nc)
kkk1$dataframe$lat<- kkk1$dataframe$lat-0.25/2
kkk1$dataframe$lon<- kkk1$dataframe$lon-0.25/2
kkk<-kkk1
from<-"+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0"
to<-"NA"
to<-"+proj=laea +lat_0=52 +lon_0=10 +x_0=3 210 000 +y_0=4 321 000"
#to<-"+proj=robin"
coordinates(kkk1$dataframe)<- ~lon+lat
kkk1<-kkk1$dataframe
projection(kkk1)<-from
lines_proj<-graticules(10,10,proj=to)
lines<-lines2dataframe(lines_proj)
kkk<-mapProjection(kkk,from,to)
knn<-kkk[!is.na(kkk$val),]

boundary<-c(min(knn$lon),max(knn$lon),min(knn$lat),max(knn$lat))
plot.title = paste("LPJmL 0.25 Degree NCDF Climate Inputs")
plot.subtitle = "Parameter: daily average tas - Time: 2006-07-01"

p<-gratText(lines_proj,boundary)
g<-ggplot(knn,aes(lon,lat))+geom_raster(aes(fill=val))+
scale_fill_gradientn(colours=myPalette(11), na.value="white",
		     guide= guide_colorbar(title=expression(degree~C), title.position="top",#guide_legend
			     barwidth = 1, barheight = 10, direction="vertical",
			     draw.ulim = T, draw.llim =T ))+
 theme_opts+
 coord_equal()+
 ggtitle(bquote(atop(.(plot.title), atop(italic(.(plot.subtitle)), ""))))+
 scale_x_continuous(limits = c(min(knn$lon), max(knn$lon)), expand = c(0, 0),
		    breaks=as.vector(p$x[,1]),labels=bquote(.(as.vector(p$x$txt))))+
scale_y_continuous(limits = c(min(knn$lat), max(knn$lat)), expand = c(0, 0),
		   breaks=as.vector(p$y[,1]), labels=p$y[,2])+
geom_path(data=lines,aes(lon,as.numeric(lat),group=group),color="grey",size=0.25)#graticules

country<-new("shapefile",dir="data/admin_countries/10m/",layer="ne_10m_admin_0_countries",
	     proj_to= to)
w_h<-function(lim){
return(abs((lim[2]-lim[1])/(lim[3]-lim[4])))
}
d<-addLines(country,gg=g,size=0.35)
saveMap(paste("std_colorbar.jpeg",sep=""),d, LOGO=TRUE,width=6,height=6)


##' Plot performance against the null model
##'
##' @param forecasts a list of data frames with scored forecasts
##' @param data data frame with data
##' @param null data frame with scored null model
##' @param horizons forecast horizons to consider
##' @importFrom dplyr bind_rows mutate filter group_by ungroup summarise select
##' @importFrom tidyr gather spread
##' @importFrom ggplot2 aes geom_vline geom_hline geom_point geom_linerange scale_x_discrete scale_colour_brewer xlab ylab facet_wrap expand_limits coord_flip theme position_dodge
##' @importFrom cowplot theme_cowplot
##' @importFrom binom binom.confint
##' @return ggplot object
##' @author Sebastian Funk
null_model_plot <- function(forecasts, null, horizons = c(7, 14)) {

  model_names <- lapply(forecasts, function(x) {
    c(rev(sort(as.character(unique(x$model)))), "")
  })

  model_names <- unlist(model_names)
  model_names <- model_names[-length(model_names)]

  comp_scores <- bind_rows(forecasts) %>%
    bind_rows(null) %>%
    mutate(horizon = as.integer(value_date - creation_date)) %>%
    filter(horizon %in% horizons)

  comp_sc <- list()
  for (cmodel in setdiff(model_names, "")) {
    comp_sc[[cmodel]] <- comp_scores %>%
      filter(model %in% c(cmodel, "null")) %>%
      mutate(model = factor(model)) %>%
      group_by(geography, value_desc, creation_date,
               value_date, horizon, interval) %>%
      mutate(n = n()) %>%
      ungroup() %>%
      filter(n == 2) %>%
      group_by(geography, value_desc, creation_date,
               value_date, horizon, model) %>%
      summarise(WIS = mean(score), MAE = mean(ae, na.rm = TRUE), .groups = "drop") %>%
      mutate(model = if_else(model == cmodel, "submitted", as.character(model))) %>%
      gather(metric, score, WIS, MAE) %>%
      spread(model, score) %>%
      mutate(model = cmodel)
  }

  better_null <- comp_sc %>%
    bind_rows() %>%
    filter(!is.na(submitted)) %>%
    group_by(model, value_desc, horizon, metric) %>%
    summarise(x = sum(submitted < null), n = n(), .groups = "drop")

  better_null_confint <-
    binom.confint(better_null$x, better_null$n, method = "exact")

  better_null <- better_null %>%
    cbind(better_null_confint %>% select(mean, lower, upper)) %>%
    mutate(horizon = paste(horizon, "days")) %>%
    filter(n > 10) %>%
    mutate(model =
             factor(model,
                    levels = intersect(model_names, c("", unique(model)))))

  p <- ggplot(better_null %>% filter(metric == "WIS"),
              aes(x = model, y = mean, ymin = lower, ymax = upper,
                  colour =
                    factor(horizon, levels = c("7 days", "14 days")))) +
    geom_vline(xintercept = "", linetype = "dashed") +
    geom_hline(yintercept = 0.5, linetype = "dotted") +
    geom_point(position = position_dodge(width = 0.5)) +
    geom_linerange(position = position_dodge(width = 0.5)) +
    scale_x_discrete(drop = FALSE) +
    scale_colour_brewer("Forecast horizon", palette = "Dark2") +
    xlab("") + ylab("Proportion of forecasts improved over null model") +
    facet_wrap( ~ value_desc, nrow = 2) +
    expand_limits(y = c(0, 1)) +
    cowplot::theme_cowplot() +
    coord_flip() +
    theme(legend.position = "bottom")

  return(p)
}