# cabal2nix/doc/analyze-hydra-space-requirements.r

library(data.table)
library(rjson)
library(foreach)
library(doParallel)

### Set up the workspace.

cores <- detectCores()
options(cores=cores, mc.cores=cores)
cl <- makeForkCluster(cores)
registerDoParallel(cl)
setDefaultCluster(cl)

builds <- foreach (i=list.files(".", "*.json"), .combine="rbind") %dopar% {
    print(i)
    l <- fromJSON(file=i)
    pkgset <- names(l)
    data.table(pkgset, pkg=names(l[[pkgset]]), out=unlist(l[[pkgset]]))
}
setkey(builds, pkgset, pkg)

t <- foreach (out=unique(builds$out), .combine="rbind") %dopar% {
    size <- system(paste("( du -sb", out, "| cut -f1 ) 2>/dev/null || true"), intern=TRUE)
    size <- if (identical(size, character(0))) "" else size
    data.table(out, size=as.integer(size))
}

builds <- merge(builds, t, by="out")

### Analyze the data.

# Total number of attributes in all package sets.
builds_total <- nrow(builds)

# Number of distict builds (output paths).
builds_unique <- length(unique(builds$out))

# Size of haskellPackages per platform.
haskellPackages <- unique(builds[pkgset != "ghc7102" & !is.na(size),list(out,size)])
haskellPackages_size <- sum(as.numeric(haskellPackages$size))

# List of distinct sizes.
sizes <- unique(builds[pkg != "ghc" & !is.na(size),list(out,size)])$size

# Average output path size.
avg_build_size <- mean(sizes)
sd_build_size <- sd(sizes)
summary(sizes / 1e6)

# Biggest builds.
biggest_builds <- head(builds[!is.na(size),list(size=mean(size)),by=pkg][order(size, decreasing=T)], n=20)
biggest_builds$size <- round(biggest_builds$size / 1e6, 1)

# Number of builds, distinguished by package set.
builds_by_pkgset <- builds[,list(attributes=length(pkg)), by=pkgset][order(pkgset)]


roundedFinalLeafNumber = int(finalLeafNumber+0.5);
if (leafNumber>=4 and "MainShootPlus1Tiller" not in calendarMoments):
    calendarMoments.append("MainShootPlus1Tiller")
    calendarCumuls.append(cumulTT)
    calendarDates.append(currentdate)
    hasZadokStageChanged = 1
    currentZadokStage = "MainShootPlus1Tiller"
elif (leafNumber>=5 and "MainShootPlus2Tiller" not in calendarMoments):
    calendarMoments.append("MainShootPlus2Tiller")
    calendarCumuls.append(cumulTT)
    calendarDates.append(currentdate)
    hasZadokStageChanged = 1
    currentZadokStage = "MainShootPlus2Tiller"
elif (leafNumber>=6 and "MainShootPlus3Tiller" not in calendarMoments):
    calendarMoments.append("MainShootPlus3Tiller")
    calendarCumuls.append(cumulTT)
    calendarDates.append(currentdate)
    hasZadokStageChanged = 1
    currentZadokStage = "MainShootPlus3Tiller"
elif (finalLeafNumber > 0 and leafNumber>=(slopeTSFLN * finalLeafNumber - intTSFLN) and "TerminalSpikelet" not in calendarMoments):
    calendarMoments.append("TerminalSpikelet")
    calendarCumuls.append(cumulTT)
    calendarDates.append(currentdate)
    hasZadokStageChanged = 1
    currentZadokStage = "TerminalSpikelet"
elif ((leafNumber >= (roundedFinalLeafNumber-4) and (roundedFinalLeafNumber-4) > 0) and "PseudoStemErection" not in calendarMoments):
    calendarMoments.append("PseudoStemErection")
    calendarCumuls.append(cumulTT)
    calendarDates.append(currentdate)
    hasZadokStageChanged = 1
    currentZadokStage = "PseudoStemErection"
elif ((leafNumber >= (roundedFinalLeafNumber-3) and (roundedFinalLeafNumber-3) > 0) and "1stNodeDetectable" not in calendarMoments):
    calendarMoments.append("1stNodeDetectable")
    calendarCumuls.append(cumulTT)
    calendarDates.append(currentdate)
    hasZadokStageChanged = 1
    currentZadokStage = "1stNodeDetectable"
elif ((leafNumber >= (roundedFinalLeafNumber-2) and (roundedFinalLeafNumber-2) > 0) and "2ndNodeDetectable" not in calendarMoments):
    calendarMoments.append("2ndNodeDetectable")
    calendarCumuls.append(cumulTT)
    calendarDates.append(currentdate)
    hasZadokStageChanged = 1
    currentZadokStage = "2ndNodeDetectable"
elif ((leafNumber >= (roundedFinalLeafNumber-1) and (roundedFinalLeafNumber-1) > 0) and "FlagLeafJustVisible" not in calendarMoments):
    calendarMoments.append("FlagLeafJustVisible")
    calendarCumuls.append(cumulTT)
    calendarDates.append(currentdate)
    hasZadokStageChanged = 1
    currentZadokStage = "FlagLeafJustVisible"
elif (("MidGrainFilling" not in calendarMoments) and phase == 4.5 and cumulTTFromZC_65 >= der):
    calendarMoments.append("MidGrainFilling")
    calendarCumuls.append(cumulTT)
    calendarDates.append(currentdate)
    hasZadokStageChanged = 1
    currentZadokStage = "MidGrainFilling"
else:
    hasZadokStageChanged = 0;


code 'cf_interest'
name '利息收入'
dimensions {
	accbook null
	monthEnd name:'cfDate'
}
dataRequest {
	table 'mcfd',{
		allDimensions (['organ','accbook','currency','cfDate'])
	}
	fields 'accbook,cfDate,sum(interest) value'
    groupFields 'accbook,cfDate'
	contextParams (['date','organ','currency','staticModel'])
}
derivedHeads{
    accbook ([new Head(name:'净利息收入',aggregate:true,formula:{
        def grids=thisColGrids({parent==null})
        def a=grids.find{it.rowHeadGrid.model?.alType=='A'}
        def l=grids.find{it.rowHeadGrid.model?.alType=='L'}
        if(a && l){
            a-l
         }
    })])
}
dataGrids {
	apply selectRows({children!=null}),{
		formula {sumChildren()}
	}
}


#' frostime
#'
#' Given a temperature t (Celsius) and wind ( m/sec) frost time following Wind Chill Frostbite Chart.
#'
#' @param numeric t Air temperature in Celsius degrees.
#' @param numeric  wind The wind speed in meter per seconds [m/s].
#' @return
#'
#'
#' @author  Istituto di Biometeorologia Firenze Italy  Alfonso Crisci \email{a.crisci@@ibimet.cnr.it}
#' @keywords  frostime
#' @references ISO 9920:2007 Ergonomics of the thermal environment -- Estimation of thermal insulation and water vapour resistance of a clothing ensemble.
#' @export
#'
#'
#'
#'

frostime <- function(t, wind) {
    .Call('biometeoR_frostime', PACKAGE = 'biometeoR', t, wind)
}


  # local function used below
  aggregated.fish.stats = function (sm ) {
    # w is a time metric
    # lon, lat, w , catch , effort and cpue are expected in sm
    l = aggregate( sm$catch, list(w=sm$w, lon=sm$lon, lat=sm$lat), function(x) sum(x, na.rm=T))
    names(l) = c("w", "lon", "lat", "catch")
    l = factor2number(l, c("w", "lon", "lat", "catch"))
    rownames(l) = NULL
    l$id = paste( l$w, l$lon, l$lat, sep="~" )

    e = aggregate( sm$effort, list(w=sm$w, lon=sm$lon, lat=sm$lat), function(x) sum(x, na.rm=T))
    names(e) = c("w", "lon", "lat", "effort")
    e = factor2number(e, c("w", "lon", "lat", "effort"))
    rownames(e) = NULL
    e$id = paste( e$w, e$lon, e$lat, sep="~" )

    cc = aggregate( sm$cpue, list(w=sm$w, lon=sm$lon, lat=sm$lat), function(x) mean(x, na.rm=T))
    names(cc) = c("w", "lon", "lat", "cpue")
    cc = factor2number(cc, c("w", "lon", "lat", "cpue"))
    rownames(cc) = NULL
    cc$id = paste( cc$w, cc$lon, cc$lat, sep="~" )

    x = merge( l, e, by="id", sort=F, suffixes=c("",".e") )
    x = merge( x, cc,  by="id", sort=F, suffixes=c("",".cc") )
    x = x[ , c("w", "lon", "lat", "catch", "effort", "cpue") ]
    return (x)
  }


#6

# library(disk.frame)
library(data.table)
library(future)
plan(multiprocess)
df = disk.frame("synthetic_data")

# i wnated to create a histroical transition matrix
nrow(df)# i only need one column

# random access to rows and columns
# and parallelised on all CPU cores
system.time(quick_freq <- df[default == 0 & month == 201712
               , by = risk_grade
               , .N
               , keep = c("default", "month", "risk_grade")]) # 1 second
quick_freq[order(risk_grade)]

pt = proc.time()
system.time(tmp <-  df[default == 0,.(month, account_id, risk_grade)
                       ,keep = c("month",
                                "account_id",
                                "risk_grade", "default")]) # 30 seconds

system.time(setkey(tmp, account_id, month)) # 2 seconds
system.time(tmp[order(month)
                , by = account_id
                , lag_risk_grade := lag(risk_grade)])

tran_tbl = tmp[order(lag_risk_grade, risk_grade)
               , by = .(month, lag_risk_grade, risk_grade)
               , .N] # negligible

tran_tbl
timetaken(pt)


# -- ----------------------------------------------------------------------------------------- -- #
# -- ----------------------------------------------------------------------------------------- -- #
# -- ----------------------------------------------------------------------------------------- -- #

# Remover todos los objetos del "Environment"
rm(list = ls())

# los 0s aceptados antes de expresas una cifra en notaci?n cient?fica
#options("scipen"=100, "digits"=4)

# Cargas librerias a utilizar
suppressMessages(library(plotly)) # Graficas interactivas
suppressMessages(library(Quandl)) # Descargar Precios
suppressMessages(library(ROI))    # Optimizacion para portafolio
suppressMessages(library(knitr))  # Opciones de documentaci?n + c?digo
suppressMessages(library(openxlsx))   # Leer archivos XLSx
suppressMessages(library(kableExtra)) # Tablas en HTML
suppressMessages(library(PortfolioAnalytics)) # Teoria Moderna de Portafolios

options(knitr.table.format = "html")

# Cargar el token de QUANDL
Quandl.api_key("dN9QssXxzTxndaqKUQ_i")

# Funcion para descagar precios
Bajar_Precios <- function(Columns, Tickers, Fecha_In, Fecha_Fn) {

  # Funcion para descargar N cantidad de activos desde QUANDL
  # -- Dependencias: QUANDL
  # -- Columns : columnas a incluir : character : c("date", "adj_close", ... )
  # -- Tickers : Tickers o claves de pizarra de los activos : character : "TSLA"
  # -- Fecha_In : Fecha Inicial : character : "2017-01-02"
  # -- Fecha_Fn : Fecha Final : character : "2017-08-02"

  # Peticion para descargar precios
  Datos <- Quandl.datatable("WIKI/PRICES", qopts.columns=Columns,
                            ticker=Tickers,
                            date.gte=Fecha_In, date.lte=Fecha_Fn)
  return(Datos)
}

# Tickers de acciones contenidas en ETF-IAK

Datos_ETF <- read.xlsx("IAK_holdings.xlsx", sheet = 1)
tk <- as.character(na.omit(Datos_ETF[which(Datos_ETF[,1] == "Ticker")+1:length(Datos_ETF[,1]),1]))
cs <- c("date", "adj_close")

# Fecha inicial y fecha final
fs <- c("2016-09-01", "2018-09-01")

# Descargar Precios
Datos <- list()

for(i in 1:length(tk)) {
  Datos[[i]] <- Bajar_Precios(Columns=cs, Ticker=tk[i], Fecha_In=fs[1], Fecha_Fn=fs[2])
}
names(Datos) <- tk

# Cambiar el orden de los datos que previamente descargamos
for(i in 1:length(tk)){
  Datos[[i]]<-Datos[[i]][order(Datos[[i]][,1]), ]
}

# -- ----------------------------------------------------------------------------------------- -- #
# -- ----------------------------------------------------------------------------------------- -- #
# -- ----------------------------------------------------------------------------------------- -- #

longitudes <- c()

for(i in 1:length(Datos)){
  longitudes[i] <- length(Datos[[i]]$date)
}

maximo <- max(longitudes)
completos <- which(longitudes == maximo)

DatosN <- Datos[completos]

# Vector para almacenar columnas de interes
columnas <- c()
nuevos   <- c()

# Funci?n para repetir una funci?n por cada columna del data.frame
Precios <- do.call(cbind, DatosN)

# Crear vector con nombres de columnas de interes = "nombredeactivo.adj_close_r"
for(i in 1:length(tk)){
  nuevos[i] <- paste(tk[i], ".adj_close", sep="")
}

# Extraer 1 renglon para obtener los nombres de las columnas
nombres <- colnames(Precios[1,(names(Precios) %in% nuevos)])

# Elejir una columna Date y las demas columnas de rendimientos
Precios <- Precios[,(names(Precios) %in% nuevos)]
row.names(Precios) <- DatosN[[1]]$date

# Reasignar nombres al data.frame
tk_completos <- as.character(tk[completos])
colnames(Precios) <- tk_completos

# -- ----------------------------------------------------------------------------------------- -- #
# -- ----------------------------------------------------------------------------------------- -- #
# -- ----------------------------------------------------------------------------------------- -- #

Historico <- data.frame("Date" = row.names(Precios),
                        "Precio" = Precios[,2],
                        "R_Precio" = 0,
                        "R_Activo" = 0,
                        "R_Cuenta" = 0,
                        "Capital" = 0, "Flotante" = 0, "Balance" = 0,
                        "Titulos" = 0, "Titulos_a" = 0,
                        "Operacion" = NA, "Comisiones" = 0, "Comisiones_a" = 0, "Mensaje" = NA)

# *Date*       : Fecha (Proviene desde los precios que bajaron).
# *Precio*     : Precio individual del activo.
# *R_Precio*   : Rendimiento diario del precio (dia a dia).
# *R_Activo*   : Rendimiento acumulado del precio (Cada dia respecto al precio inicial).
# *Capital*    : El dinero no invertido (Equivalente a Efectivo).
# *Flotante*   : El valor de la posicion (Precio diario X Titulos acumulados).
# *Balance*    : Capital + Flotante
# *R_Cuenta*   : Balance Actual / Capital Inicial - 1
# *Titulos*    : Titulos comprados en la operacion.
# *Titulos_a*  : Titulos acumulados.
# *Operacion*  : Indicativo de Compra (1), Mantener (0), Venta (-1).
# *Comisiones* : 0.0025 o 0.25% por el valor de la transaccion.
# *Mensaje*    : Un texto que indique alguna decision o indicativo de que ocurrio algo.

Regla0_R <- -0.01  # Considerar una oportunidad de compra en un rendimiento de -3% o menor.
Regla1_I <- 0.80   # Porcentaje de capital para comprar titulos para posicion Inicial.
Regla2_P <- 0.10   # Se utiliza el P% del L capital restante en cada compra.
Regla3_W <- tk_completos # Se realiza la misma estrategia para todos los activos en el portafolio.
Regla4_C <- 0.0025 # Comisiones pagadas por compra.
Regla5_K <- 100000 # Capital Inicial.

# -- ----------------------------------------------------------------------------------------- -- #
# -- ----------------------------------------------------------------------------------------- -- #
# -- ----------------------------------------------------------------------------------------- -- #

# -- Calcular los Titulos de posicion inicial
Historico$Titulos[1] <- (Regla5_K*Regla1_I)%/%Historico$Precio[1]

# -- Calcular los titulos acumulados
Historico$Titulos_a[1] <- Historico$Titulos[1]

# -- Se calculan comisiones iniciales
Historico$Comisiones[1] <- Historico$Titulos[1]*Historico$Precio[1]*Regla4_C

# -- Se calculan comisiones acumuladas
Historico$Comisiones_a[1] <- Historico$Comisiones[1]

# -- Calcular el valor Flotante de la posicion
Historico$Flotante[1] <- Historico$Titulos_a[1]*Historico$Precio[1]

# -- Todo remanente se dejara registrado en la cuenta de efectivo.
Historico$Capital[1] <- Regla5_K-Historico$Flotante[1]-Historico$Comisiones[1]

# -- Calcular el Balance
Historico$Balance[1] <- Historico$Flotante[1] + Historico$Capital[1]

# -- Iniciamos con una postura de mantener.
Historico$Operacion[1] <- 1

# -- El rendimiento de capital en el tiempo 1 es 0
Historico$R_Cuenta[1] <- 0

# -- Mensaje inicial
Historico$Mensaje[1] <- "Inicializacion de cartera"

# -- Calcular R_Precio
Historico$R_Precio <- round(c(0, diff(log(Historico$Precio))),4)

# -- Calcular R_Activo
PosturaInicial <- Regla5_K%/%Historico$Precio[1]

for(i in 1:length(Historico$Date)){
  Historico$R_Activo[i] <- (PosturaInicial*Historico$Precio[i])/(PosturaInicial*Historico$Precio[1]) - 1
}

# -- ----------------------------------------------------------------------------------------- -- #
# -- ----------------------------------------------------------------------------------------- -- #
# -- ----------------------------------------------------------------------------------------- -- #

for(i in 2:length(Historico$Date)){

  if(Historico$R_Precio[i] <= Regla0_R){ # Generar Señal

    if(Historico$Capital[i-1] > 0) { # Si hay suficiente capital desde el dia anterior

      if(Historico$Capital[i-1]*Regla2_P > Historico$Precio[i]) { # Si hay capital minimo para 1 operacion

        Historico$Mensaje[i] <- "Señal de Compra Ejecutada"

        Historico$Operacion[i] <- 1

        Historico$Titulos[i] <- (Historico$Capital[i-1]*Regla2_P)%/%Historico$Precio[i]

        Historico$Titulos_a[i] <- Historico$Titulos_a[i-1]+Historico$Titulos[i]

        Historico$Comisiones[i] <- Historico$Precio[i]*Historico$Titulos[i]*Regla4_C

        Historico$Comisiones_a[i] <- Historico$Comisiones_a[i-1] + Historico$Comisiones[i]

        Historico$Flotante[i] <- Historico$Precio[i]*Historico$Titulos_a[i]

        Historico$Capital[i] <- Historico$Capital[i-1] - Historico$Titulos[i]*Historico$Precio[i] - Historico$Comisiones[i]

        Historico$Balance[i] <- Historico$Capital[i] + Historico$Flotante[i]

        Historico$R_Cuenta[i] <- Historico$Balance[i]/Regla5_K - 1

      }

      else { # No hubo capital minimo para 1 operacion

        Historico$Mensaje[i] <- "Hubo Señal pero no hubo capital minimo para 1 operacion"

        Historico$Operacion[i] <- 0

        Historico$Titulos[i] <- 0

        Historico$Comisiones[i] <- 0

        Historico$Comisiones_a[i] <- Historico$Comisiones_a[i-1]

        Historico$Titulos_a[i] <- Historico$Titulos_a[i-1]

        Historico$Flotante[i] <- Historico$Titulos_a[i]*Historico$Precio[i]

        Historico$Capital[i] <- Historico$Capital[i-1]

        Historico$Balance[i] <- Historico$Flotante[i] + Historico$Capital[i]

        Historico$R_Cuenta[i] <- Historico$Balance[i]/Regla5_K - 1

      }
    }

    else { # No hubo capital

      Historico$Mensaje[i] <- "Hubo Señal pero no hubo capital"

      Historico$Operacion[i] <- 0

      Historico$Titulos[i] <- 0

      Historico$Comisiones[i] <- 0

      Historico$Comisiones_a[i] <- Historico$Comisiones_a[i-1]

      Historico$Titulos_a[i] <- Historico$Titulos_a[i-1]

      Historico$Flotante[i] <- Historico$Titulos_a[i]*Historico$Precio[i]

      Historico$Capital[i] <- Historico$Capital[i-1]

      Historico$Balance[i] <- Historico$Flotante[i] + Historico$Capital[i]

      Historico$R_Cuenta[i] <- Historico$Balance[i]/Regla5_K - 1

    }
  }

  else { # Sin señal

    Historico$Mensaje[i] <- "Sin Señal"

    Historico$Operacion[i] <- 0

    Historico$Titulos[i] <- 0

    Historico$Comisiones[i] <- 0

    Historico$Comisiones_a[i] <- Historico$Comisiones_a[i-1]

    Historico$Titulos_a[i] <- Historico$Titulos_a[i-1]

    Historico$Flotante[i] <- Historico$Titulos_a[i]*Historico$Precio[i]

    Historico$Capital[i] <- Historico$Capital[i-1]

    Historico$Balance[i] <- Historico$Flotante[i] + Historico$Capital[i]

    Historico$R_Cuenta[i] <- Historico$Balance[i]/Regla5_K - 1
  }
}

# Guar

plot_ly(Historico) %>%
  add_trace(x = ~Date, y = ~round(R_Activo,4), type = 'scatter', mode = 'lines', name = 'Activo',
            line = list(color = 'red')) %>%
  add_trace(x = ~Date, y = ~round(R_Cuenta,4), type = 'scatter', mode = 'lines', name = 'Cuenta',
            line = list(color = 'blue')) %>%
  layout(title = "Rend del activo VS Rend de la cuenta",
         xaxis = list(title = "Fechas", showgrid = T),
         yaxis = list(title = "Rendimiento"),
         legend = list(orientation = 'h', y = -0.25, x = 0.5))

SharpeRatio(R = xts(x = Historico$R_Activo, order.by = as.Date(Historico$Date)), Rf = 0.0225, FUN = "StdDev")
SharpeRatio(R = xts(x = Historico$R_Cuenta, order.by = as.Date(Historico$Date)), Rf = 0.0225, FUN = "StdDev")

SortinoRatio(R = xts(x = Historico$R_Activo, order.by = as.Date(Historico$Date)), MAR = 0.0225/252)
SortinoRatio(R = xts(x = Historico$R_Cuenta, order.by = as.Date(Historico$Date)), MAR = 0.0225/252)


## Dependencies ##  install.packages(c('readr', 'curl', 'ggplot2', 'dplyr', 'stringr', 'fable', 'tsibble', 'dplyr', 'feasts', 'remotes', 'urca', 'sodium', 'plumber', 'jsonlite'))

## From prototype script to SageMaker-ready script
#  1. Make the script aware of how SageMaker places the input and config files
#  2. Refactor the code into "train", "evaluate" and "serve" as that how SageMaker
#     execute the codes from the container for training, evaluating and serving
#     the model.
library(fable)
library(tsibble)
library(dplyr)
library(jsonlite) # Library to read json
library(ggplot2)

## Container directories
# /opt/ml
# |-- input
# |   |-- config
# |   |   |-- hyperparameters.json
# |   |   `-- resourceConfig.json
# |   `-- data
# |       `-- <channel_name>
# |           `-- <input data>
# |-- model
# |   `-- <model files>
# |-- processing (if with SageMaker Processing)
#     `-- input
#     `-- output
# `-- output
#     `-- failure

## Assigning paths
prefix <- '/opt/ml'
input_path <- file.path(prefix, 'input', 'data')
training_data_path <- file.path(input_path, 'train')
output_path <- file.path(prefix, 'output')
model_path <- file.path(prefix, 'model')
param_path <- file.path(prefix, 'input', 'config', 'hyperparameters.json')

processing_path <- file.path(prefix, 'processing')
processing_input_path <- file.path(processing_path, 'input')
processing_output_path <- file.path(processing_path, 'output')

train <- function() {
  ## Extract (hyper)parameters
  training_params <- read_json(param_path)
  if (!is.null(training_params$city)) {
    city <- training_params$city}
  else {
    city <- 'Melbourne'}
  if (!is.null(training_params$ets_trend_method)) {
    ets_trend_method <- training_params$ets_trend_method}
  else {
    # Use Additive method by default
    ets_trend_method <- 'A'}
  # information criteria c('aicc', 'aic', 'bic')
  if (!is.null(training_params$ic)) {
    ic <- training_params$ic}
  else {
    ic <- 'aic'}

  ## Getting data from local path that is downloaded from S3
  training_file <- list.files(training_data_path, full.names=TRUE)
  print(training_file)
  training_data <- readRDS(training_file)

  tourism_city <- training_data %>%
    filter(Region == city)

  tourism_city %>%
    group_by(Purpose) %>%
    slice(1)

  ## Training ETS and ARIMA models
  fitted_model <- tourism_city %>%
    model(
      ets = ETS(Trips ~ trend(ets_trend_method), ic = ic),
      arima = ARIMA(Trips, ic = ic)
    )
  fitted_model

  ## Saving the model
  save(fitted_model, file = file.path(model_path,'model.rdata'))

  ## Print out model accuracy
  print(fitted_model %>%
          accuracy() %>%
          arrange(MASE)
        )
  }

# Evaluate the model and generate report
evaluate <- function(city) {

  ## Load model
  model_file <- file.path(processing_input_path, 'model.tar.gz')
  system(sprintf('tar zxvf %s', model_file))
  load('model.rdata')

  ## Load input data
  print(city)
  tourism_city <- tourism %>%
    filter(Region == city)

  tourism_city %>%
    group_by(Purpose) %>%
    slice(1)

  ## Analysis
  accuracy_report <- fitted_model %>%
                        accuracy() %>%
                        arrange(MASE)
  print(accuracy_report)
  write.csv(accuracy_report, file.path(processing_output_path,
                                       'forecast-accuracy-report.csv'))

  fc <- fitted_model %>%
    forecast(h = "5 years")

  fc %>%
    hilo(level = c(80, 95))
  fc

  fc %>%
    autoplot(tourism_city)

  ggsave(file.path(processing_output_path,  'forecast-report.png'))
  }

# Run at start-up
args <- commandArgs(trailingOnly = TRUE)
if (any(grepl('train', args))) {
  # How SageMaker run your training script:
  # https://docs.aws.amazon.com/sagemaker/latest/dg/your-algorithms-training-algo-dockerfile.html
  train()
}

if (any(grepl('evaluate', args))) {
  # How SageMaker run your processing script:
  # https://docs.aws.amazon.com/sagemaker/latest/dg/build-your-own-processing-container.html
  evaluate(args[2])
}


context("test for list-transformer")

f <- lforce
l <- liota(5)

test_that("test", {
  expect_identical(f(lmap(l, function(x) x ^ 2L)), f(lmap2(l, . ^ 2L)))
  expect_identical(f(lreverse(l)), f(4 %..% 0))
  expect_identical(
    f(ltranspose(llist(llist(1, 2, 3),llist(4, 5, 6)))),
    f(llist(llist(1, 4), llist(2, 5), llist(3, 6))))

})


#' Extract best model performances
#'
#' @param bmr A bmr object, result of the \code{\link{benchmark_sdm}} function.
#'
#' @return A dataframe containing the best model results (learner name, optimal iteration number and associated AUC).
#' @examples
#' \dontrun{
#' # download benchmarking data
#' benchmarking_data <- get_benchmarking_data("Lynx lynx",
#'                                            limit = 1500)
#'
#' # create a list of algorithms to compare
#' learners <- list(mlr::makeLearner("classif.randomForest",
#'                                   predict.type = "prob"),
#'                  mlr::makeLearner("classif.logreg",
#'                                   predict.type = "prob"))
#'
#' # run the model benchmarking process
#' bmr <- benchmark_sdm(benchmarking_data$df_data,
#'                      learners = learners,
#'                      dataset_type = "default",
#'                      sample = FALSE)
#'
#' # get best model results
#' # you should obtain a dataframe containing the highest performing (by AUC)
#' # algorithm name, iteration and associated AUC
#' best_results <- get_best_model_results(bmr)
#' best_results
#' }
#' @export
get_best_model_results <- function(bmr) {
    perf <- mlr::getBMRPerformances(bmr, as.df = TRUE)
    best_results <- perf %>%
        dplyr::group_by(learner.id) %>%
        dplyr::top_n(n = 1)
    best_results$task.id <- NULL

    return(best_results)
}


#' Plot of factor means
#'
#' Generates a plot of the means of factors
#'
#' @param this_factor \code{tis} object of the factors from a weekly seasonal adjustment
#' @param this_period Integer scalar; vector with period number of the observations.
#' @param this_col Character scalar; color used for factor plots. Default is \code{green}.
#' @param y_limit Numeric vector of length 2; Range of values you wish the plot to be plotted over. Default is range of the seasonal factors.
#' @param this_freq integer scalar; time series frequency.
#' @param this_trans Logical scalar; indicates if the adjustment was done with a log transform. Default is TRUE.
#' @param this_title Character string; main title of plot.  Default is \code{'Mean of Seasonal Factors'}.
#' @param forecast Integer scalar; Number of forecasts appended to the factors. Default is 0.
#' @param this_type Character string; type of factors plotted.  Default is  \code{'seasonal'}.
#' @param add_line Logical scalar; indicates if this line is being added to an existing plot. Default is FALSE.
#' @return Generate plot of the means of factors by period, or add a line to an existing plot. If factors not specified, print out error message and return NULL.
#' @examples
#' ic_sf_range <- range(ic_sf, ic_sf_auto, ic_sf_auto_ljung, ic_sf_tc)
#' this_color <- c("#4682B4", "#7846B4", "#B47846", "#82B446")
#' plot_sf_mean(ic_sf,
#'              this_period = ic_week,
#'              this_col = this_color[1],
#'              y_limit = ic_sf_range,
#'              this_freq = 53,
#'              this_type = 'Combined',
#'              this_trans = FALSE,
#'              this_title = 'Initial Claims (Weekly Combined Factors)')
#' plot_sf_mean(ic_sf_auto,
#'              this_period = ic_week,
#'              this_col = this_color[2],
#'              this_freq = 53,
#'              this_trans = FALSE,
#'              add_line = TRUE)
#' plot_sf_mean(ic_sf_auto_ljung,
#'              this_period = ic_week,
#'              this_col = this_color[3],
#'              this_freq = 53,
#'              this_trans = FALSE,
#'              add_line = TRUE)
#' plot_sf_mean(ic_sf_tc,
#'              this_period = ic_week,
#'              this_col = this_color[4],
#'              this_freq = 53,
#'              this_trans = FALSE,
#'              add_line = TRUE)
#' legend('topright',
#'        legend=c('ic (default)', 'ic (auto outliers)', 'ic (auto, ljung cv)', 'ic (auto tc)'),
#'        col=this_color,
#'        lty=rep(1,4),
#'        cex=0.75)
#' @import stats
#' @import graphics
#' @export
plot_sf_mean <- function(this_factor = NULL, this_period = NULL, this_col = "green", y_limit = range(this_factor),
    this_freq, this_trans = TRUE, this_title = "Mean of Seasonal Factors", forecast = 0, this_type = "Seasonal",
    add_line = FALSE) {
    # Author: Brian C. Monsell (OEUS), Version 1.10, 3/23/2021

    # Check if factors, period is specified
    if (is.null(this_factor)) {
        stop("Argument this_factor must be specified.")
    }

    if (is.null(this_period)) {
        stop("Argument this_period must be specified.")
    }

    # Extract seasonal factors
    sf <- this_factor[1:(length(this_factor) - forecast)]

    if (length(this_period) > length(sf)) {
        period <- this_period[1:(length(this_period) - forecast)]
    } else {
        period <- this_period
    }

    # Initialize vector of seasonal factor means
    this_factor_mean <- array(0, this_freq)

    # Compute seasonal means
    for (i in 1:this_freq) {
        this_factor_mean[i] <- mean(sf[period == i])
    }

    # Add line for seasonal means to plot
    if (add_line) {
        lines(1:this_freq, this_factor_mean, type = "b", col = this_col)
    } else {
        # set value for horizontal line
        if (this_trans) {
            h_bar <- 1
        } else {
            h_bar <- 0
        }
        # Plot seasonal means
        plot(this_factor_mean, type = "b", main = this_title, sub = paste("Average ", this_type, " Factors by Week of Year"),
            ylab = " ", xlab = " ", ylim = y_limit, col = this_col)
        # generate horizontal line
        abline(h = h_bar, col = "grey", lty = 2)
    }
}


#' Run a Rasch model from R using Winsteps.
#'
#' This function uses the Winsteps software to batch analyze a given list of
#'   dataframes/matrices. The results are read back into R without leaving the
#'   R interface or interacting with the Winsteps GUI.
#'
#' @param itmsL List of dataframes or matrices of item responses to be analyzed.
#' @param demsL List of dataframes or matrices of person identifiers/demographic
#'   fields.
#' @param titleL Optional list of names for control and datafiles written to the
#'   working directory.
#' @param keep Character vector of the external Winsteps files to retain.
#'   Possible arguments are \code{c("all", "none", "iFile", "pFile","cntrlFile",
#'   "dtaFile", "outFile", "bat")}. If \code{"all"} or \code{"none"} are
#'   supplied, no other arguments are neccessary. All other arguments can be
#'   combinded to select a specific set of files to keep. Other arguments
#'   correspond to, respectively, item, person, control, data, output, and the
#'   .bat (batch processing) files. Defaults to "none", in which case none of
#'   the files used to run the analyses are retained.
#' @param ... Additional arguments passed to \code{\link{batch_r2Winsteps}}.
#' @seealso \code{\link{batch_r2Winsteps}} \code{\link{batchWinsteps}}
#'   \code{\link{batch.pfile}} \code{\link{batch.ifile}}
#' @export
#' @return List containing all item and person parameters from the given
#'   analyses.

batchRunWinsteps <- function(itmsL, demsL, titleL = NULL, keep = "none", ...) {

#---------- Check for previously run analyses & remove i and p files ----------
#Create name vectors of all files
    if(!is.null(titleL)){
        pFileNameV <- rep(NA, length(itmsL))
        iFileNameV <- rep(NA, length(itmsL))
       # sFileNameV <- rep(NA, length(itmsL))
        cntrlFileV <- rep(NA, length(itmsL)) # used later for keep = FALSE
        dtaFileV <- rep(NA, length(itmsL))   #
        outFileV <- rep(NA, length(itmsL))   #

        for(i in 1:length(itmsL)){
            pFileNameV[i] <- paste(titleL[i], "Pfile.txt", sep = "")
            iFileNameV[i] <- paste(titleL[i], "Ifile.txt", sep = "")
           # sFileNameV[i] <- paste(titleL[i], "Sfile.txt", sep = "")
            cntrlFileV[i] <- paste(titleL[i], "Cntrl.txt", sep = "") #
            dtaFileV[i] <- paste(titleL[i], "Dta.txt", sep = "")     #
            outFileV[i] <- paste(titleL[i], "Out.txt", sep = "")     #
        }
    }

    if(is.null(titleL)){
        pFileNameV <- rep(NA, length(itmsL))
        iFileNameV <- rep(NA, length(itmsL))
       # sFileNameV <- rep(NA, length(itmsL))
        cntrlFileV <- rep(NA, length(itmsL)) #
        dtaFileV <- rep(NA, length(itmsL))   #
        outFileV <- rep(NA, length(itmsL))   #

        for(i in 1:length(itmsL)){
            pFileNameV[i] <- paste("r2Winsteps", i, "Pfile.txt", sep = "")
            iFileNameV[i] <- paste("r2Winsteps", i, "Ifile.txt", sep = "")
         #   sFileNameV[i] <- paste("r2Winsteps", i, "Sfile.txt", sep = "")
            cntrlFileV[i] <- paste("r2Winsteps", i, "Cntrl.txt", sep = "") #
            dtaFileV[i]   <- paste("r2Winsteps", i, "Dta.txt", sep = "")   #
            outFileV[i]   <- paste("r2Winsteps", i, "Out.txt", sep = "")   #
        }
    }

    if(any(sapply(iFileNameV, file.exists))) {
        warning("Previously estimated item file(s) removed.")
    }

    for(i in 1:length(iFileNameV)){
        if (file.exists(iFileNameV[i]) == TRUE) {
            invisible(file.remove(iFileNameV[i]))
        }
    }

    if(any(sapply(pFileNameV, file.exists))) {
        warning("Previously estimated person file(s) removed.")
    }
    for(i in 1:length(pFileNameV)){
        if (file.exists(pFileNameV[i]) == TRUE) {
            invisible(file.remove(pFileNameV[i]))
        }
    }

    # if(any(sapply(sFileNameV, file.exists))) {
    #     warning("Previously estimated structure file(s) removed.")
    # }

    # for(i in 1:length(sFileNameV)){
    #     if (file.exists(sFileNameV[i]) == TRUE) {
    #         invisible(file.remove(sFileNameV[i]))
    #     }
    # }

#------------------------ Get files ready for analysis ------------------------
    if(is.null(titleL)){
        lastPfileName <- paste("r2Winsteps", length(itmsL), "Pfile.txt",
            sep = "")
        lastIfileName <- paste("r2Winsteps", length(itmsL), "Ifile.txt",
            sep = "")
     #   lastSfileName <- paste("r2Winsteps", length(itmsL), "Sfile.txt",
     #      sep = "")
    }
    else{
        lastPfileName <- paste(titleL[[length(titleL)]], "Pfile.txt", sep = "")
        lastIfileName <- paste(titleL[[length(titleL)]], "Ifile.txt", sep = "")
     #   lastSfileName <- paste(titleL[length(titleL)], "Sfile.txt", sep = "")
    }

    demNamesL <- lapply(demsL, names)

 #-------------------------------- run analysis -------------------------------
    call <- batch_r2Winsteps(itmsL, demsL, titleL = titleL, ...)
    batName <- ifelse(is.null(as.list(call)$batName), "r2WinstepsBatch",
        as.list(call)$batName)
    batFile <- paste0(batName, ".bat")
    batFile <- file.path(getwd(), batFile)

    if(.Platform$OS.type == "windows") {
      system(paste("open", batFile))
    }
    else {
      system(paste("wine cmd.exe /C", batFile))
    }

    repeat {
        Sys.sleep(0.1)

        if(file.exists(lastPfileName) &
            file.exists(lastIfileName)) { #&
           # file.exists(lastSfileName)) {
                pTemp <- readLines(lastPfileName)
                iTemp <- readLines(lastIfileName)
            #    sTemp <- readLines(lastSfileName)
            #    split <- strsplit(sTemp[length(sTemp)], " ")[[1]]
            if(length(pTemp) == (nrow(demsL[[length(demsL)]]) + 2) &
                 length(iTemp) == (ncol(itmsL[[length(itmsL)]]) + 2)) { #&
                #    split[length(split)] == names(itms)[ncol(itms)]) {
                break
            }
        }
    }
#------------------------------- Import results -------------------------------
    p <- batch.pfile(demNameL = demNamesL,
            files = substr(pFileNameV, 1, nchar(pFileNameV) - 4))
    i <- batch.ifile(files = substr(iFileNameV, 1, nchar(iFileNameV) - 4))
  #  s <- batch.sfile(files = substr(sFileNameV, 1, nchar(sFileNameV) - 4))

    pars <- vector("list", length(p))

    for(loop in seq_along(pars)) {
        pars[[loop]] <- structure(
                    list("ItemParameters" = i[[loop]],
                         "PersonParameters" = p[[loop]]),
                class = "r2Winsteps")
    }
    names(pars) <- substr(names(i), 1, nchar(names(i)) - 5)

#----------------------- Remove files, if requested -----------------------

    keepL <- list("iFile" = iFileNameV, "pFile" = pFileNameV,
                #  "sFile" = sFileNameV,
                  "cntrlFile" = cntrlFileV,
                  "dtaFile" = dtaFileV, "outFile" = outFileV, "bat" = batFile)

    suppressWarnings(
        if (keep == "all") {
            keep <- c("iFile", "pFile", #"sfile",
                "cntrlFile", "dtaFile",
                      "outFile", "bat")
        }
    )
    m <- names(keepL) %in% keep

    remove <- keepL[!m]

    invisible(sapply(remove, file.remove))

return(structure(pars, class = "batchRunWinsteps"))
}


#' fts2kmh
#'
#' Conversion speed in feet per second to kilometers per hour.
#'
#' @param fts numeric  Speed in feets per second.
#' @return kilometers per hour
#'
#'
#' @author  Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  fts2kmh
#'
#' @export
#'
#'
#'
#'

fts2kmh=function(fts) {
                         ct$assign("fts", as.array(fts))
                         ct$eval("var res=[]; for(var i=0, len=fts.length; i < len; i++){ res[i]=fts2kmh(fts[i])};")
                          res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


library( rgdal )
library(dplyr)
library(ggplot2)
library(shiny)
library(plotly)
## IMPORTANT
# To display new variables, go and add them to datasetInput manually

# Define UI for dataset viewer app ----
ui <- fluidPage(

  # App title ---
  # Sidebar layout with a input and output definitions ----
  sidebarLayout(

    # Sidebar panel for inputs ----
    sidebarPanel(

      # Input: Simple integer interval ----
      sliderInput("year", "Year:",
                  min = 1990, max = 2060,
                  value = c(2020,2050), step = 10),

      # Input: Selector for choosing dataset ----
      selectInput(inputId = "dataset",
                  label = "Choose a dataset:",
                  choices = c('Energy production by source','Final energy','Water widthrawals by source','Final water use',
                              'Water for crops','Crop land use',
                              'Total cost of technology','Energy for water','Water for energy','water for Irrigation',
                              'Activity','Capacity',"New installed capacity",'Input',"Investment cost",'Output',"Demand",'Emission'
                  ) ),

      helpText("The grouping categories are also the dependencies of the selected dataset"),
      conditionalPanel(condition="input.tabselected==1",
                       # Input: Selector for choosing grouping dimension ----
                       selectInput(inputId = "grouping",
                                   label = "Choose a grouping dimension:",
                                   choices = c("tec","commodity","node") )
                      ),

      uiOutput("ui_fill_inputs")

    ),

    # Main panel for displaying outputs ----
    mainPanel(

      # Output: Tabset w/ plot, summary, and table ----
      tabsetPanel(type = "tabs",
                  id = "tabselected",
                  tabPanel("Plot", value = 1, plotlyOutput("plot"),
                           textOutput("explanation"),
                           radioButtons(inputId = 'png_pdf', label = 'Select the graphic output format:', choices = list('png','pdf')),
                           downloadButton("downloadPlot", "Download Figure")
                           ),

                  tabPanel("Table",value=3,
                           downloadButton("downloadData", "Download"),
                           tableOutput("table")
                           )
      )

    )
  )
)

# Define server logic to summarize and view selected dataset ----
server <- function(input, output,session) {

  # Return the requested dataset ----
  datasetInput <- reactive({
    switch(input$dataset,
           'Energy production by source' = raw_extraction$energy_prod_by_source,
           'Final energy' = raw_extraction$final_energy_by_use,
           'Water widthrawals by source' = raw_extraction$water_by_source,
           'Final water use' = raw_extraction$final_water_by_use,
           'Water for crops' = raw_extraction$water_for_crops,
           'Crop land use' = raw_extraction$area_by_crop,
           'Total cost of technology' = raw_extraction$cost_by_technology,
           'Energy for water' = raw_extraction$energy_for_water,
           'Water for energy' = raw_extraction$water_for_energy,
           'water for Irrigation' = raw_extraction$water_for_irrigation,
           'Activity' = raw_extraction$ACT,
           'Capacity' = raw_extraction$CAP,
           "New installed capacity" = raw_extraction$CAP_NEW,
           'Input' = raw_extraction$input,
           "Investment cost" = raw_extraction$inv_cost,
           'Output' = raw_extraction$output,
           "Demand" = raw_extraction$demand_fixed,
           'Emission' = raw_extraction$EMISS
    )
  })
  observe({

    group_chs <- (datasetInput() %>% names() %>% as.data.frame() %>% filter(!. %in% c('node','value')))$.
    updateSelectInput(session, "grouping",
                      label = "Choose a grouping dimension:",
                      choices = group_chs )

    updateSelectInput(session, "time",
                      label = "Choose a time:",
                      choices = (unique( (datasetInput())$time ) ),
                      selected = 'year')
  })

  build_inputs <- function(choices) {
    output = tagList()
    for(i in choices){
      output[[i]] = tagList()
      output[[i]][[1]] = selectInput(inputId = paste0(i),
                                     label = paste0('Choose a ',i),
                                     choices =  unique(datasetInput() %>% select_('i')) ,multiple = TRUE)
    }
    return(output)
  }

  output$ui_fill_inputs <- renderUI({
    group_chs <- (datasetInput() %>% names() %>% as.data.frame() %>% filter(!. %in% c('node','year_all','value')))$.
    build_inputs(as.character(group_chs))

  })

  output$plot <- renderPlotly({

    plot_data <- datasetInput() %>%
      filter(scenario %in% input$scenario) %>%
      #     the if condition to chekc that column is always there, otherwise repeat the scenario choice
      # have not found smarter solution
      filter({if("commodity" %in% names(.)) commodity %in% input$commodity else scenario %in% input$scenario} ) %>%
      filter({if("level" %in% names(.)) level %in% input$level else scenario %in% input$scenario} ) %>%
      filter({if("time" %in% names(.)) time %in% input$time else scenario %in% input$scenario} ) %>%
      filter({if("tec" %in% names(.)) tec %in% input$tec else scenario %in% input$scenario}) %>%
      filter({if("type" %in% names(.)) type %in% input$type else scenario %in% input$scenario}) %>%
      filter(year_all >= min(input$year) & year_all <= max(input$year)) %>% # homogenize the names of year/year all
      mutate(year_all = as.numeric(year_all)) %>%
      group_by_('node',input$grouping) %>%
      summarize(value = sum(value)) %>%
      as.data.frame()

    basin.tidy2 <- dplyr::left_join(basin.tidy, plot_data, by='node') %>%
      filter(!is.na(value))

    plot1 <<- ggplot() +
      geom_polygon(data = basin.tidy, aes(long,lat, group=group),color='black',fill = "#f5f5f2",size = 0.1) +
      geom_polygon(data = basin.tidy2, aes(long,lat, group=group,fill=value),alpha=0.8,color='black',size = 0.1) +
      coord_map("azequalarea") +
      facet_wrap(as.formula(paste("~", input$grouping)))+
      scale_fill_gradient(low = "#56B1F7", high = "#132B43")+
      theme_map()

    ggplotly(plot1)
  })

  output$explanation <- renderText({
    'The grouping category will be shown in the legend. When selecting indexes DIFFERENT than the GROUPING category, the values will be SUMMED UP in the plot over the selected elements'
  })

  output$downloadPlot <- downloadHandler(
    filename = function() {
      paste(input$dataset, input$png_pdf, sep = ".")
    },
    content = function(file) {
      if(input$png_pdf == 'png')
      png(file)
      else
      pdf(file)

      print(plot1)
      dev.off()
    }
  )

  # Show the first "n" observations ----
  output$table <- renderTable({

    name_col <- datasetInput() %>% names()

    table_data <<- datasetInput() %>%
      filter(scenario %in% input$scenario) %>%
      #     the if condition to chekc that column is always there, otherwise repeat the scenario choice
      # have not found smarter solution
      filter({if("commodity" %in% names(.)) commodity %in% input$commodity else scenario %in% input$scenario} ) %>%
      filter({if("level" %in% names(.)) level %in% input$level else scenario %in% input$scenario} ) %>%
      filter({if("time" %in% names(.)) time %in% input$time else scenario %in% input$scenario} ) %>%
      filter({if("tec" %in% names(.)) tec %in% input$tec else scenario %in% input$scenario}) %>%
      filter({if("type" %in% names(.)) type %in% input$type else scenario %in% input$scenario}) %>%
      filter(year_all >= min(input$year) & year_all <= max(input$year)) # homogenize the names of year/year all

    table_data
  })

  output$downloadData <- downloadHandler(
    filename = function() {
      paste(input$dataset, ".csv", sep = "")
    },
    content = function(file) {
      write.csv(table_data, file, row.names = FALSE)
    }
  )

  theme_map <<- function(...) {
#    theme_minimal() +
      theme(
        text = element_text(family = "Ubuntu Regular", color = "#22211d"),
        axis.line = element_blank(),
        axis.text.x = element_blank(),
        axis.text.y = element_blank(),
        axis.ticks = element_blank(),
        axis.title.x = element_blank(),
        axis.title.y = element_blank(),
        # panel.grid.minor = element_line(color = "#ebebe5", size = 0.2),
        panel.grid.major = element_line(color = "#ebebe5", size = 0.2),
        panel.grid.minor = element_blank(),
        plot.background = element_rect(fill = "#f5f5f2", color = NA),
        panel.background = element_rect(fill = "#f5f5f2", color = NA),
        legend.background = element_rect(fill = "#f5f5f2", color = NA),
        panel.border = element_blank(),
        ...
      )
  }

}

# Create Shiny app ----
shinyApp(ui = ui, server = server)


scrape.btx <- function() {

    # fail if not installed
    library("jsonlite")

    # scrape raw data
    rawdata = readLines("https://bittrex.com/api/v1.1/public/getmarketsummaries")
    edges = jsonlite::fromJSON(rawdata)
    print("requests done")

    # parsed edge data
    market.names = edges$result$MarketName
    pairs = apply(as.matrix(market.names), 1, function(row) {
        # original data is a nested list
        strsplit(row, "-")[[1]]
    })

    # so it becomes and N by 2 matrix
    pairs = as.matrix(t(pairs))

    # bittrex returns flipped coin pairs
    reverse.pairs = cbind(pairs[,2], pairs[,1])

    bids = as.numeric(as.character(edges$result$Bid))
    asks = 1/as.numeric(as.character(edges$result$Ask))
    asks[which(asks==Inf)] = 0

    bids.pairs = cbind(reverse.pairs, bids)
    asks.pairs = cbind(pairs, asks)

    graph = rbind(asks.pairs, bids.pairs)

    # return
    return(graph)
}


pm_data =
  read_csv("data/county_pm25.csv") %>%
  select(
    county_code = fips,
    PM2.5_concentration = pm25
  ) %>%
  group_by(county_code) %>%
  summarise(
    PM2.5_concentration = mean(PM2.5_concentration)
  ) %>%
  # Keep track of whether PM data exists for counties.
  mutate(in_pm_data = TRUE)


# 3. faza: Vizualizacija podatkov

# # Uvozimo zemljevid.
# zemljevid <- uvozi.zemljevid("http://baza.fmf.uni-lj.si/OB.zip", "OB",
#                              pot.zemljevida="OB", encoding="Windows-1250")
# levels(zemljevid$OB_UIME) <- levels(zemljevid$OB_UIME) %>%
#   { gsub("Slovenskih", "Slov.", .) } %>% { gsub("-", " - ", .) }
# zemljevid$OB_UIME <- factor(zemljevid$OB_UIME, levels=levels(obcine$obcina))
# zemljevid <- fortify(zemljevid)
#
# # Izračunamo povprečno velikost družine
# povprecja <- druzine %>% group_by(obcina) %>%
#   summarise(povprecje=sum(velikost.druzine * stevilo.druzin) / sum(stevilo.druzin))

require(ggplot2)
require(dplyr)
colnames(starostni_razredi) <- c("namen_uporabe", "starost1", "starost2", "starost3", "starost4", "starost5", "starost6")
graf1 <- ggplot(starostni_razredi) + aes(x=namen_uporabe, y=starost1) + geom_bar(stat="identity")

nekej1 <-st_raz_07 %>% gather(starosti,stevilo,starost1,starost2,starost3,starost4,starost5,starost6)

neki <- c("starost1", "25_34", "35_44", "45_54", "55_64", "65_74")

st_raz_07 <- starostni_razredi[c(1:62),]

ggplot(data=st_raz_07, aes(x=namen_uporabe, y=starost1, fill=starost1)) + geom_bar(stat="identity")

st_raz_08 <- starostni_razredi[c(63:124),]

ggplot(data=st_raz_08, aes(x=namen_uporabe, y=16-24, fill=16-24)) + geom_bar(stat="identity")

st_raz_09 <- starostni_razredi[c(125:186),]

ggplot(data=st_raz_09, aes(x=namen_uporabe, y=16-24, fill=16-24)) + geom_bar(stat="identity")


#!/usr/bin/Rscript
#X11(type="Xlib")
#install.packages("plot3D")
library("plot3D")
for (i in 0:9) {
    filename = paste("../../../target/out",i,".txt", sep="")
    print(paste("reading", filename))
    mat <- read.csv(file = filename, header = FALSE)
    png(paste("../../../target/plot",i,".png",sep=""), height = 700, width =1000 )
    box3D(
      x0 = mat[,1], y0 = mat[,2], z0=mat[,3],
      x1 = mat[,4], y1 = mat[,5], z1=mat[,6],
      col = c("red", "lightblue", "orange"),
      alpha = 0.3,
      border = "black",
      lwd = 2)
    dev.off()
}


rootDir <- path #root directory
retroDir <- paste0(rootDir,"/OUTPUT_LISA_SAR_RETRO/")

#These are the flow grid bins
flowSeq <- c(20,seq(50,350,50))
#Mapping to grid array
flowSeqID <- 1:length(flowSeq)
#Temperature bins
tempSeq <- 9:18
#Mapping to grid array
tempSeqID <- 1:length(tempSeq)

#Set up array for gridded data of flow and temp
gridData <- array(0,dim=c(2,length(1:80),365,length(flowSeq),length(tempSeq)),
                  dimnames=list(migrationType = c("inriver","transport"),
                                compassYears=1:80,
                                julian=1:365,
                                flow=flowSeq,
                                temp=tempSeq))

#Read in the gridded compass data
for(ff in flowSeq){
  for(tt in tempSeq){
    for(mm in c("inriver","transport")){
      if(mm=="inriver"){
        cDat <- read.table(paste0(rootDir,"/DATA_COMPASS_FILES_PA/ch1_Flow-",ff,"_",tt,"deg_bonarrival.out"), header = TRUE)
        tmpcDat <- cDat[,3:367]
        gridData[mm,,,flowSeqID[flowSeq==ff],tempSeqID[tempSeq==tt]] <- as.matrix(tmpcDat)
      }
      if(mm=="transport"){
        cDat <- read.table(paste0(rootDir,"/DATA_COMPASS_FILES_PA/ch1_Flow-",ff,"_",tt,"deg_bonarrival_transport.out"), header = TRUE)
        tmpcDat <- cDat[cDat$MigrationType==mm,4:368]
        gridData[mm,,,flowSeqID[flowSeq==ff],tempSeqID[tempSeq==tt]] <- as.matrix(tmpcDat)
      }
    }
  }
}
gridYears <- unique(cDat[,1])
save(gridData,gridYears,file=paste0(rootDir,"gridData.rData"))


#!/usr/bin/env Rscript
#
# Use generalized linear models to test for differences in allele
# frequency.
#
# Each read is treated as an observation, and pools are the replicates.
# A likelihood ratio test is used to produce a p-value.
#
# Usage:
#
#   snp_by_snp_glm.r [--randomize] <sync file> <file with pool names>
#       <group 1 pools> <group 2 pools>
#
#   The names of the pools in each group should be separated by commas.
#
#==============================================================================#

library(data.table)

options(warn=1)

#==============================================================================#

## From a sync file row, get read counts.
get_counts = function(sync_row, pools, pool_names) {
    contig = sync_row[[1]]
    pos = sync_row[[2]]
    ref_allele = toupper(sync_row[[3]])
    counts = structure(vector('list', length=length(pools)),
                       names=pools)
    for(pn in pools) {
        x = sync_row[[which(pool_names == pn) + 3]]
        cnts = as.numeric(unlist(strsplit(x, ':')))
        names(cnts) = c('A', 'T', 'C', 'G', 'N', 'D')
        ref_cnt = cnts[ref_allele]
        alt_cnt = (sum(cnts) - cnts['N']) - ref_cnt
        counts[[pn]] = c('ref'=ref_cnt, 'alt'=alt_cnt)
    }
    counts
}

## Test if this set of counts is variable
is_variable = function(counts) {
    ref = sum(sapply(counts, function(x) x[1]))
    alt = sum(sapply(counts, function(x) x[2]))
    return((ref != 0) && (alt != 0))
}

null_result = list('p'=NaN, 'effect'=NaN, term=NA, converged=NA,
                   'freqs0'=NA, 'freqs1'=NA)

## Run a GLM Use a likelihood ratio test to get p-values.
## Counts needs to be in the same order as groups
test = function(counts, groups) {
    resp = matrix(unlist(counts), ncol=2, byrow=TRUE)
    pools = factor(names(counts))
    trt = rep(names(groups), sapply(groups, length))
    freqs = structure(round(sapply(counts, function(x) x[1] / sum(x)), 4),
                      names=names(counts))
    freqs0 = paste(freqs[names(freqs) %in% groups[[1]]], collapse=',')
    freqs1 = paste(freqs[names(freqs) %in% groups[[2]]], collapse=',')
    ret = null_result
    if(length(unique(trt)) > 1) {
        m = glm(resp ~ trt, family=binomial('logit'))
        mnull = glm(resp ~ 1, family=binomial('logit'))
        lrt_p = anova(m, mnull, test='Chisq')[['Pr(>Chi)']][2]
        s = summary(m)
        conv = (m$converged && mnull$converged)
        fe = coefficients(m)[2]
        ret = list('p'=lrt_p,'effect'=fe, 'term'=names(fe),
                   'converged'=as.numeric(conv),
                   'freqs0'=freqs0, 'freqs1'=freqs1)
    }
    ret
}

#==============================================================================#

## Get arguments to the script
cargs = commandArgs(trailingOnly=TRUE)
i = 0
rand = FALSE
if(cargs[1] == '--randomize') {
    rand = TRUE
    i = 1
}
sync_file_name = cargs[i + 1]
pool_file_name = cargs[i + 2]
group_1 = Filter(function(x) x != '', unlist(strsplit(cargs[i + 3], ',')))
group_2 = Filter(function(x) x != '', unlist(strsplit(cargs[i + 4], ',')))

## Read in data
read_counts = fread(sync_file_name, sep='\t', stringsAsFactors=FALSE,
                    verbose=FALSE, showProgress=FALSE)
pool_names = scan(pool_file_name, what='character')

if(rand) {
    all_pools = c(group_1, group_2)
    rand_group_1 = sample(all_pools, length(group_1), FALSE)
    rand_group_2 = all_pools[!all_pools %in% rand_group_1]
    trts = list('group1'=rand_group_1, 'group2'=rand_group_2)
} else {
    trts = list('group1'=group_1, 'group2'=group_2)
}

## Test every SNP and print results
cat('contig\tpos\tref\tp\teffect\tterm\tconverged\tfreqs0\tfreqs1\n', file=stdout())
for(i in 1:nrow(read_counts)) {
    row_data = read_counts[i]
    contig = row_data[[1]]
    pos = row_data[[2]]
    ref = row_data[[3]]
    counts = get_counts(row_data, unlist(trts), pool_names)
    if(is_variable(counts)) {
        test_results = tryCatch(test(counts, trts),
                                error=function(e) null_result)
    } else {
        test_results = null_result
    }

    cat(paste(contig, pos, ref, test_results$p,
              test_results$effect, test_results$term, test_results$converged,
              test_results$freqs0, test_results$freqs1,
              sep='\t'),
        '\n', sep='', file=stdout())
}


require(rgeos)
require(rgdal)
require(raster)
require(rasterVis)
require(dplyr)
require(ncdf4)
require(tictoc)
memory.limit(size=1e9)

# ISWEL folder for data
setwd('P:/is-wel/indus/message_indus')

# location of water temp data
wd = 'P:/watxene/Wat-Data/wattemp/waterTemp_real'

# model names
md = unlist( strsplit( list.dirs(wd,recursive=FALSE) , paste0(wd,'/') ) )[seq(2,length( unlist( strsplit( list.dirs(wd,recursive=FALSE) , paste0(wd,'/') ) ) ),by=2)]

# basins to check
basin = c('Indus')

# Grab the basin boundaries
basin.spdf = readOGR( paste( getwd(), 'input', sep = '/' ), paste0( basin, '_bcu' ), verbose = FALSE )
basin.spdf = spTransform( basin.spdf, CRS("+proj=longlat") ) # temp[which(as.character(temp$BASIN) == basin | as.character(temp$PID) == '2256'),] for Karachi basin
basin.sp = gUnaryUnion( basin.spdf )
basin.sp = SpatialPolygons(list(Polygons(Filter(function(f){f@ringDir==1},basin.sp@polygons[[1]]@Polygons),ID=1)))
proj4string(basin.sp) = proj4string(basin.spdf)

water_temp.df = bind_rows( lapply( md, function( mmm ){

	# Get data from ncdfs across following variables
	vars = c( 'waterTemp_dailyTot', 'discharge_dailyTot_output' )
	vars2 = data.frame( waterTemp_dailyTot = 'waterTemp', discharge_dailyTot_output = 'discharge' )
	res = lapply( vars, function( vvv ){

		# Open ncdf without importing data
		nc = nc_open(paste0( wd, '/', mmm,  "/Mask17/", vvv, ".nc", sep='' ) )

		# Spatial extent matched to basin boundary
		lon = data.frame( lon = ncvar_get(nc, "lon") ) %>% filter( lon >= extent(basin.sp)[1] & lon <= extent(basin.sp)[2] )
		lon_start = min( which( ncvar_get(nc, "lon") == min( lon ) ), which( ncvar_get(nc, "lon") == max( lon ) ) )
		lon_count = max( which( ncvar_get(nc, "lon") == min( lon ) ), which( ncvar_get(nc, "lon") == max( lon ) ) ) - lon_start
		lat = data.frame( lat = ncvar_get(nc, "lat") ) %>% filter( lat >= extent(basin.sp)[3] & lat <= extent(basin.sp)[4] )
		lat_start = min( which( ncvar_get(nc, "lat") == min( lat ) ), which( ncvar_get(nc, "lat") == max( lat ) ) )
		lat_count = max( which( ncvar_get(nc, "lat") == min( lat ) ), which( ncvar_get(nc, "lat") == max( lat ) ) ) - lat_start
		basin_extent = extent( 	min( lon ), max( lon ),  min( lat ), max( lat ) )

		# Dates
		dates = sapply( min( ncvar_get(nc, "time") ):max( ncvar_get(nc, "time") ), function( iii ){ as.character( as.Date("1901-01-01") + iii ) } )
		dates = dates[ grepl( paste(2000:2020,collapse='|'), dates ) ] # limit to 2050

		# Import specific data from ncdf
		dat.df = bind_rows( lapply( 1:length(dates), function( ttt ){

			print( paste0( ttt, ' of ', length(dates) ) )

			r = raster( t( as.matrix( ncvar_get(  nc,
							as.character( unlist( vars2[ vvv ] ) ),
							start = c( lon_start, lat_start, ttt ),
							count = c( lon_count, lat_count, 1 ) ) ) ) )

			extent( r ) = basin_extent

			df = data.frame( 	lon = xFromCell( r, 1:length(r) ),
								lat = yFromCell( r, 1:length(r) ),
								time = dates[ ttt ],
								value = r[] ) %>%
				filter( !is.na( value ) )

			names( df )[ names( df ) == 'value' ] = vvv

			return( df )

			} ) )

		return( dat.df )

		nc_close(nc)

		} )

	# Merge the water temp and discharge data.frames
	res = left_join( res[[1]], res[[2]] )

	# Get the PID for each grid cell
	cells = unique( paste( res$lon, res$lat, sep = '-' ) )
	pts = data.frame( 	lon = as.numeric( unlist( strsplit( cells, '-' ) )[seq(1,2*length(cells),by=2)] ),
						lat = as.numeric( unlist( strsplit( cells, '-' ) )[seq(2,2*length(cells),by=2)] ),
						id = 1:length(cells) )
	coordinates(pts) = ~lon+lat

	pid2cell = over( pts, as(basin.spdf,'SpatialPolygons') )
	names(pid2cell) = basin.spdf@data$PID
	pid2cell = bind_rows( lapply( 1:length(pid2cell), function(jjj){ data.frame( PID = names(pid2cell)[jjj], id = unlist( pid2cell[[jjj]]] ) ) } ) )

	res = left_join( res, pid2cell )

	# Aggregate into PIDs using discharge to weight the mean temperature

	df = bind_rows( lapply( 1:length(basin.spdf), function( ppp ){

		extract( res

		df = data.frame( 	model = mmm,
							PID = ,
							month = ,
							value = )

		} ) )

	return( df )

	} ) )

availability.df = bind_rows( lapply( 1:length( basin.spdf ), function( ppp ){

	ncp.stack = crop( nc.stack, extent( basin.spdf[ ppp, ] ) )

	# get percent days below temp threshold
	availability.stack = do.call( stack, lapply( 1:12, function( mmm ){

		# get all days in a specific month
		stck = ncp.stack[[ which( as.numeric(unlist( strsplit( dts, '-' ) )[seq(2,3*length(dts),by=3)]) == mmm ) ]]

		# calulate percent days above threshold
		stck = calc( stck, fun = function(x){ which( x <= threshhold ) / length( x ) } )

		return( stck )

		} ) )

	return( data.frame( PID = basin.spdf@data$PID[ ppp ], month = 1:12, value = val ) )

	} ) )

# Create data frame for mapping months and years to days
nc_map.df = data.frame( id = 1:nlayers(nc.stack),
						year = as.numeric( unlist( strsplit( unlist( strsplit( names(nc.stack), '[.]' ) )[ seq(1,3*length(names(nc.stack)),by=3) ],'X' ) )[ seq(2,2*length( unlist( strsplit( names(nc.stack), '[.]' ) )[ seq(1,3*length(names(nc.stack)),by=3) ] ),by=2 ) ] ),
						month =  as.numeric( unlist( strsplit( names(nc.stack), '[.]' ) )[ seq(2,3*length(names(nc.stack)),by=3) ] ),
						day = as.numeric( unlist( strsplit( names(nc.stack), '[.]' ) )[ seq(3,3*length(names(nc.stack)),by=3) ] ) )

nc_decadal.stack = do.call( stack, lapply( 1:12, function( mmm ){

					mean( nc.stack[[ c( nc_map.df %>% filter( month == mmm ) %>% dplyr::select( id ) %>% unlist() ) ]] )

					} ) )

#vname<-nc$name  #--- CHOOSE VARIABLE NAME IF MULTIPLE
vname="waterTemp"


options(scipen=999)

x <- read.table("per_window_TE_cds_GC_bp.txt", sep="\t", stringsAsFactors=F, header=T)

# define window size form file
window_size <- x[1,3] - x[1,2] + 1
# define number of windows for line plots
num_windows <- 10

# what are the unique chromosomes and their bounding areas for plotting?
total_windows <- nrow(x)
chr <- unique(x[,1])
chr_polygons <- list()
# make the plotting polygons
for(a in 1:length(chr)) {
	a1 <- rownames(x)[x[,1] == chr[a]]
	a2 <- a1[length(a1)]
	a1 <- a1[1]
	chr_polygons[[a]] <- rbind(c(a1, 0), c(a2, 0), c(a2, 0.9), c(a1, 0.9), c(a1, 0))
}

# in separate plots
par(mfrow=c(3,1))
par(mar=c(1,5,1,1))
plot(c(-1,-1), ylim=c(0,0.4), xlim=c(1, nrow(x)), xaxt="n", col="white", bty="n", cex.axis=1.1, cex.lab=1.3, ylab="Prop. CDS")
odd <- 0
for(a in 1:length(chr_polygons)) {
	if(odd == 1) {
		polygon(chr_polygons[[a]], col="snow2", border="white")
		odd <- 0
	} else {
		odd <- 1
	}
}
points(x$cds / window_size, pch=19, cex=0.2, col="lightblue")
# sliding windows
x_axis_rep <- seq(from=1, to=total_windows, by=num_windows)
y_axis_rep <- c()
scaffold <- c()
for(b in 1:length(x_axis_rep)) {
	# pull out the rows for the window
	b_rows <- seq(from=(x_axis_rep[b] - as.integer(num_windows / 2) + 1), to=(x_axis_rep[b] + as.integer(num_windows / 2)))
	b_rows <- x[b_rows[b_rows > 0 & b_rows <= total_windows],]
	# keep only those on the same scaffold
	b_rows <- b_rows[b_rows[,1] == x[x_axis_rep[b], 1],]
	# get the mean of the stat
	y_axis_rep <- c(y_axis_rep, mean(b_rows$cds) / window_size)
	# record the scaffold
	scaffold <- c(scaffold, x[x_axis_rep[b],1])
}
# plot each scaffold at a time (so lines don't connect between scaffolds)
for(a in 1:length(unique(scaffold))) {
	a_rep <- cbind(x_axis_rep, y_axis_rep, scaffold)
	a_rep <- a_rep[a_rep[,3] == unique(scaffold)[a], ]
	lines(a_rep[,1:2], lwd=1.2, col="navyblue")
}

plot(c(-1,-1), ylim=c(0,0.8), xlim=c(1, nrow(x)), xaxt="n", col="white", bty="n", cex.axis=1.1, cex.lab=1.3, ylab="Prop. Repetitive")
odd <- 0
for(a in 1:length(chr_polygons)) {
	if(odd == 1) {
		polygon(chr_polygons[[a]], col="snow2", border="white")
		odd <- 0
	} else {
		odd <- 1
	}
}
points(x$TE_bp / window_size, pch=19, cex=0.2, col="lightblue")
# sliding windows
x_axis_rep <- seq(from=1, to=total_windows, by=num_windows)
y_axis_rep <- c()
scaffold <- c()
for(b in 1:length(x_axis_rep)) {
	# pull out the rows for the window
	b_rows <- seq(from=(x_axis_rep[b] - as.integer(num_windows / 2) + 1), to=(x_axis_rep[b] + as.integer(num_windows / 2)))
	b_rows <- x[b_rows[b_rows > 0 & b_rows <= total_windows],]
	# keep only those on the same scaffold
	b_rows <- b_rows[b_rows[,1] == x[x_axis_rep[b], 1],]
	# get the mean of the stat
	y_axis_rep <- c(y_axis_rep, mean(b_rows$TE_bp) / window_size)
	# record the scaffold
	scaffold <- c(scaffold, x[x_axis_rep[b],1])
}
# plot each scaffold at a time (so lines don't connect between scaffolds)
for(a in 1:length(unique(scaffold))) {
	a_rep <- cbind(x_axis_rep, y_axis_rep, scaffold)
	a_rep <- a_rep[a_rep[,3] == unique(scaffold)[a], ]
	lines(a_rep[,1:2], lwd=1.2, col="navyblue")
}

plot(c(-1,-1), ylim=c(0.25,0.5), xlim=c(1, nrow(x)), xaxt="n", col="white", bty="n", cex.axis=1.1, cex.lab=1.3, ylab="Prop. GC")
odd <- 0
for(a in 1:length(chr_polygons)) {
	if(odd == 1) {
		polygon(chr_polygons[[a]], col="snow2", border="white")
		odd <- 0
	} else {
		odd <- 1
	}
}
points(x$gc_bp / window_size, pch=19, cex=0.2, col="lightblue")
# sliding windows
x_axis_rep <- seq(from=1, to=total_windows, by=num_windows)
y_axis_rep <- c()
scaffold <- c()
for(b in 1:length(x_axis_rep)) {
	# pull out the rows for the window
	b_rows <- seq(from=(x_axis_rep[b] - as.integer(num_windows / 2) + 1), to=(x_axis_rep[b] + as.integer(num_windows / 2)))
	b_rows <- x[b_rows[b_rows > 0 & b_rows <= total_windows],]
	# keep only those on the same scaffold
	b_rows <- b_rows[b_rows[,1] == x[x_axis_rep[b], 1],]
	# get the mean of the stat
	y_axis_rep <- c(y_axis_rep, mean(b_rows$gc_bp) / window_size)
	# record the scaffold
	scaffold <- c(scaffold, x[x_axis_rep[b],1])
}
# plot each scaffold at a time (so lines don't connect between scaffolds)
for(a in 1:length(unique(scaffold))) {
	a_rep <- cbind(x_axis_rep, y_axis_rep, scaffold)
	a_rep <- a_rep[a_rep[,3] == unique(scaffold)[a], ]
	lines(a_rep[,1:2], lwd=1.2, col="navyblue")
}

# plot stat correlations
par(mfrow=c(1,3))
par(mar=c(5,5,1,1))
plot(x$TE_bp / 100000, x$cds / 100000, pch=19, cex=0.1, ylab="CDS Proportion", xlab="Repetitive Proportion")
plot(x$gc_bp / 100000, x$TE_bp / 100000, pch=19, cex=0.1, ylab="Repetitive Proportion", xlab="GC Proportion")
plot(x$gc_bp / 100000, x$cds / 100000, pch=19, cex=0.1, ylab="CDS Proportion", xlab="GC Proportion")


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

## Author: Zach Rivers, @riverspharmd, zrivers@fredhutch.org
## Contributors:

## Purpose: This file runs the logistic regression model for bivariate and
## multivariate logreg across three different outcomes.

## Depends on:
## 07PredictorExploration.r
## 10COSTTidyJoin.r
## tidyverse
## gtsummary
## flextable
## labelled

## Input:
## IntData/dat_wide.csv
## IntData/cost.csv

## Output:
##

## NOTE: This scoring system is inverse of COST scoring, where 0 is no FT and 1
## is FT. This applies to the discordance as 1: Discordant, 0: Concordant

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

# Packages______________________________________________________________________
library(tidyverse)
library(gtsummary)
library(flextable)
library(labelled)

# Functions_____________________________________________________________________
source("Functions/importing.r")
source("Functions/regressions.r")
source("Functions/tidying.r")

# Data In_______________________________________________________________________

## Predictors

pred_wide <- read_csv(
    "IntData/dat_wide.csv"
)

## COST

cost <- read_csv("IntData/cost.csv",
    col_types = "ccccn"
)

# Data Prep_____________________________________________________________________
## Prep Outcomes----------------------------------------------------------------
cost_outcomes <- build_outcome(dat = cost)

## Prep Predictors-------------------------------------------------------------
### Factor
pred_wide <- label_factors(dat = pred_wide)

### Build predictor datset
pred_wide <- build_predictors(dat = pred_wide)

### Label predictor dataset
var_label(pred_wide) <- lr_labels

## Join with outcomes-----------------------------------------------------------
pred_outcomes <- join_pred_out(
    pred_dat = pred_wide,
    outcome_dat = cost_outcomes
) %>%
    select(-c(partid)) %>%
    filter(is.na(age_p) == FALSE)

# Run Models____________________________________________________________________
## Prep Data Structures---------------------------------------------------------
### Build Model Pieces
pat_var <- c(
    "age_p",
    "gender_p",
    "ethnicity_p",
    "race_p",
    "education_p",
    "comorbid_sum_p"
)

clin_var <- c(
    "location",
    "stage",
    "dx"
)

care_var <- c(
    "age_c",
    "gender_c",
    "ethnicity_c",
    "race_c",
    "education_c",
    "comorbid_sum_c"
)

dyad_var <- c(
    "marital",
    "income",
    "children"
)

### Build Model Inputs
pat_input <- list(
    p1 = c(pat_var),
    p2 = c(pat_var, clin_var),
    p3 = c(pat_var, care_var),
    p4 = c(pat_var, dyad_var),
    p5 = c(pat_var, clin_var, care_var),
    p6 = c(pat_var, clin_var, dyad_var, "income * location"),
    p7 = c(pat_var, care_var, dyad_var),
    p8 = c(pat_var, clin_var, care_var, dyad_var, "income * location")
)

care_input <- list(
    c1 = c(care_var),
    c2 = c(care_var, clin_var),
    c3 = c(care_var, pat_var),
    c4 = c(care_var, dyad_var),
    c5 = c(care_var, clin_var, pat_var),
    c6 = c(care_var, clin_var, dyad_var, "income * location"),
    c7 = c(care_var, pat_var, dyad_var),
    c8 = c(care_var, clin_var, pat_var, dyad_var, "income * location")
)
# This just ensures no duplicates in the dyad analysis
dyad_input <- c(
    pat_input[1:7],
    care_input[c(1, 2, 4, 6, 8)]
)

### Build Table Spanners
p_spanner <- c(
    "Bivariate",
    "Patient",
    "Patient and Clinical",
    "Patient and Caregiver",
    "Patient and Dyad",
    "Patient, Clinical, and Caregiver",
    "Patient, Clinical, and Dyad",
    "Patient, Caregiver, and Dyad",
    "All Predictors"
)

c_spanner <- c(
    "Bivariate",
    "Caregiver",
    "Caregiver and Clinical",
    "Caregiver and Patient",
    "Caregiver and Dyad",
    "Caregiver, Clinical, and Patient",
    "Caregiver, Clinical, and Dyad",
    "Caregiver, Patient, and Dyad",
    "All Predictors"
)

# Same as before, no duplicates in the dyad analysis
dyad_spanner <- c(
    p_spanner[1:8],
    c_spanner[c(2, 3, 4, 7, 9)]
)

### Build empty lists
bv_lr_list <- list()
mv_lr_list <- list()
joined_model_list <- list()
joined_model_list_tidy <- list()

### Build loop input Lists
outcome_list <- list("p_fintox", "c_fintox", "con")
span_list <- list(p_spanner, c_spanner, dyad_spanner)
mod_input <- list(pat_input, care_input, dyad_input)
title_list <- list(
    "Patient Financial Toxicity",
    "Caregiver Financial Toxicity",
    "Discordance of Financial Toxicity Between Patients and Caregivers"
)

### loop over datsets
for (i in 1:3) {
    # Pull out parameters for this iteration
    mv_input <- mod_input[[i]]
    resp <- outcome_list[[i]]
    outcome_exclude <- unlist(outcome_list[-i])
    exp <- TRUE

    # Fit and tidy bivariate logreg
    bv_lr_list[[i]] <- bv_log_reg(
        dat = pred_outcomes,
        resp = resp,
        exp = exp
    )
    # Tell me that you're still running
    print(paste("Completed bivariate", i, "of Three"))

    # Fit multivariate logreg
    mv_log_reg_fits <- map(
        .x = mv_input,
        ~ mv_log_reg(
            input = .x,
            resp = resp,
            dat = pred_outcomes
        )
    )

    ### Tidy multivariate logreg
    mv_lr_list[[i]] <- map(
        .x = mv_log_reg_fits,
        ~ tidy_mv_log_reg(
            mod_fit = .x,
            exp = exp
        )
    )
    # Keep running
    print(paste("Completed multivariate", i, "of Three"))

    ### Join bv and mv together by outcome
    joined_model_list[[i]] <- c(
        bv_lr_list[i],
        mv_lr_list[[i]]
    )

    joined_model_list_tidy[[i]] <- tbl_merge(joined_model_list[[i]],
        tab_spanner = span_list[[i]]
    ) %>%
        modify_caption(title_list[[i]])

    # Wheeeee more loops
    print(paste("Completed Loop", i, "of Three"))
}

# Data Out _____________________________________________________________________

## Logistic Regression-----------------------------------------------------


library(data.table)
library(ggplot2)
library(xtable)

source('../../functions.r')
source('../../parameters.r')

spplist  <- fread('../../input-data/species-list.csv')
setkey(spplist, code)
nspp <- nrow(spplist)

load('mcmc-results.rdata')

## * APF by species

mcsel <- mcmc[variable %in% mc_attributes[role == 'month1_spatial0' & vartype == 'apf_t', variable]]
mcsel <- merge(mcsel, mc_attributes, by = 'variable', all.x=T, all.y=F)
apf_sp <- mcsel[, .(value = sum(value)), .(species, sample)][
  , .(mean     = mean(value),
      median   = median(value),
      sd       = sd(value),
      lcl      = quantile(value, 0.025, names=F),
      ucl      = quantile(value, 0.975, names=F),
      nsamples = .N), .(code = species)]
apf_sp <- apf_sp[spplist[base_species == T], on = 'code'][, .(common_name = upper1st(common_name), code, mean , sd, lcl, ucl)]
setorder(apf_sp, -mean)

fwrite(apf_sp, 'assets/apf_by_species.csv')


#' Function to discard subsets of an array (NA or drop)
#'
#' @param X        An n-dimensional array
#' @param along    Along which axis to apply \code{FUN}
#' @param FUN      Function to apply, needs to return \code{TRUE} (keep) or \code{FALSE}
#' @param subsets  Subsets that should be used when applying \code{FUN}
#' @param na.rm    Whether to omit columns and rows with \code{NA}s
#' @return         An array where filtered values are \code{NA} or dropped
#' @export
filter = function(X, along, FUN, subsets=base::rep(1,dim(X)[along]), na.rm=FALSE) {
#    .check$all(X, along, subsets)

    X = as.array(X)
    # apply the function to get a subset mask
    mask = as.array(map(X, along, function(x) FUN(x), subsets, drop=FALSE))
    if (mode(mask) != 'logical' || dim(mask)[1] != length(unique(subsets)))
        stop("FUN needs to return a single logical value")

    for (mcol in seq_along(ncol(mask)))
        for (msub in rownames(mask))
            if (!mask[msub, mcol])
                X[subsets==msub, mcol] = NA #FIXME: work for matrices as well

    if (na.rm)
        t(stats::na.omit(t(stats::na.omit(X))))
    else
        X
}


#===============================================================================
#	Test different types of call produce same results.
#
#	This test check whetehr direct input, via call(), via substitute(), call in
#	model object can produce same results.
#===============================================================================
library(testthat)
library(cv.models)
library(randomForest)
library(gbm)

#------------------------------------------------------------------------------
context("Test different types of call produce same result")

test_that(
	"Test different types of call produce same result with glm().", {
		# Import functions.
		source("utils.r", encoding = "UTF-8")
		# Prepare calls and object.
		data(iris)
		call.call <- call("glm", Petal.Length ~ ., data = iris)
		call.substitute <- substitute(glm(Petal.Length ~ ., data = iris))
		object <- glm(Petal.Length ~ ., data = iris)
		# Run cross validation.
		cv.default <- cv.models(
			glm(Petal.Length ~ ., data = iris), seed = 1, n.cores = 1
		)
		cv.call <- cv.models(call.call, seed = 1, n.cores = 1)
		cv.substitute <- cv.models(call.substitute, seed = 1, n.cores = 1)
		cv.object <- cv.models(object, seed = 1, n.cores = 1)
		# Test consistency of the results.
		expect_true(has.same.results(cv.default, cv.call))
		expect_true(has.same.results(cv.default, cv.substitute))
		expect_true(has.same.results(cv.default, cv.object))
	}
)

test_that(
	"Test different types of call produce same result with gbm().", {
		# Import functions.
		source("utils.r", encoding = "UTF-8")
		# Prepare calls and object.
		data(iris)
		call.call <- call(
			"gbm", Petal.Length ~ ., data = iris, distribution = "gaussian"
		)
		call.substitute <- substitute(
			gbm(Petal.Length ~ ., data = iris, distribution = "gaussian")
		)
		object <- gbm(Petal.Length ~ ., data = iris, distribution = "gaussian")
		# Run cross validation.
		cv.default <- cv.models(
			gbm(Petal.Length ~ ., data = iris, distribution = "gaussian"),
			n.trees = 100, seed = 1, n.cores = 1
		)
		cv.call <- cv.models(call.call, n.trees = 100, seed = 1, n.cores = 1)
		cv.substitute <- cv.models(
			call.substitute, n.trees = 100, seed = 1, n.cores = 1
		)
		cv.object <- cv.models(object, n.trees = 100, seed = 1, n.cores = 1)
		# Test consistency of the results.
		expect_true(has.same.results(cv.default, cv.call))
		expect_true(has.same.results(cv.default, cv.substitute))
		expect_true(has.same.results(cv.default, cv.object))
	}
)


# Structuring data

load('./Week 2/3 - Wednesday/data extraction practical/raw data/mammals_raw')
mammals <- lapply(mammals_raw, function(mat) as.data.frame(mat))

# harmonising column names for all pages and deleting first row for all
mammals <- lapply(mammals, function(dt) setNames(dt, c('english_name','species', unlist(dt[1,])[-(1:2)])))
mammals <- lapply(mammals, function(dt) dt[-1,])

ddata <- do.call("rbind", mammals)

ddata$family <- ifelse(grepl('AE$', ddata$species), # If species ends with "AE" (here $ means "end of the string")
                       ddata$species, # write family name
                       NA_character_) # write NA
ddata$family <- zoo::na.locf(ddata$family)  #complete NA values with last non-missing value

ddata$species <- ifelse(ddata$species == '', # if species name is missing, extract the last two words of english_name
                        stringi::stri_extract_first_regex(ddata$english_name, '(?<= )[A-Za-z]+ [a-z]+$'),
                        ddata$species)

ddata <- ddata[ !is.na(ddata$species) & ddata$species != ddata$family & !grepl('Total', ddata$english_name), ]

week 2/3 - Wednesday/data extraction practical/2.0 Example Structuring and cleaning data.r


# ==================================================================================================
# This file is part of the CLBlast project. The project is licensed under Apache Version 2.0. This
# project uses a tab-size of two spaces and a max-width of 100 characters per line.
#
# Author(s):
#   Cedric Nugteren <www.cedricnugteren.nl>
#
# This file implements the performance script for the Xaxpy routine
#
# ==================================================================================================

# Includes the common functions
args <- commandArgs(trailingOnly = FALSE)
thisfile <- (normalizePath(sub("--file=", "", args[grep("--file=", args)])))
source(file.path(dirname(thisfile), "common.r"))

# ==================================================================================================

# Settings
routine_name <- "xaxpy"
parameters <- c("-n","-incx","-incy",
                "-num_steps","-step","-runs","-precision")
precision <- 32

# Sets the names of the test-cases
test_names <- list(
  "multiples of 256K",
  "multiples of 256K (+1)",
  "around n=1M",
  "around n=16M",
  "strides (n=8M)",
  "powers of 2"
)

# Defines the test-cases
test_values <- list(
  list(c(256*kilo, 1, 1, 16, 256*kilo, num_runs, precision)),
  list(c(256*kilo+1, 1, 1, 16, 256*kilo, num_runs, precision)),
  list(c(1*mega, 1, 1, 16, 1, num_runs, precision)),
  list(c(16*mega, 1, 1, 16, 1, num_runs, precision)),
  list(
    c(8*mega, 1, 1, 1, 0, num_runs, precision),
    c(8*mega, 2, 1, 1, 0, num_runs, precision),
    c(8*mega, 4, 1, 1, 0, num_runs, precision),
    c(8*mega, 8, 1, 1, 0, num_runs, precision),
    c(8*mega, 1, 2, 1, 0, num_runs, precision),
    c(8*mega, 1, 4, 1, 0, num_runs, precision),
    c(8*mega, 1, 8, 1, 0, num_runs, precision),
    c(8*mega, 2, 2, 1, 0, num_runs, precision),
    c(8*mega, 4, 4, 1, 0, num_runs, precision),
    c(8*mega, 8, 8, 1, 0, num_runs, precision)
  ),
  list(
    c(32*kilo, 1, 1, 1, 0, num_runs, precision),
    c(64*kilo, 1, 1, 1, 0, num_runs, precision),
    c(128*kilo, 1, 1, 1, 0, num_runs, precision),
    c(256*kilo, 1, 1, 1, 0, num_runs, precision),
    c(512*kilo, 1, 1, 1, 0, num_runs, precision),
    c(1*mega, 1, 1, 1, 0, num_runs, precision),
    c(2*mega, 1, 1, 1, 0, num_runs, precision),
    c(4*mega, 1, 1, 1, 0, num_runs, precision),
    c(8*mega, 1, 1, 1, 0, num_runs, precision),
    c(16*mega, 1, 1, 1, 0, num_runs, precision),
    c(32*mega, 1, 1, 1, 0, num_runs, precision),
    c(64*mega, 1, 1, 1, 0, num_runs, precision)
  )
)

# Defines the x-labels corresponding to the test-cases
test_xlabels <- list(
  "vector sizes (n)",
  "vector sizes (n)",
  "vector sizes (n)",
  "vector sizes (n)",
  "increments/strides for x and y",
  "vector sizes (n)"
)

# Defines the x-axis of the test-cases
test_xaxis <- list(
  c("n", ""),
  c("n", ""),
  c("n", ""),
  c("n", ""),
  list(1:10, c("x1y1", "x2y1", "x4y1", "x8y1", "x1y2", "x1y4", "x1y8", "x2y2", "x4y4", "x8y8")),
  c("n", "x")
)

# ==================================================================================================

# Start the script
main(routine_name=routine_name, precision=precision, test_names=test_names, test_values=test_values,
     test_xlabels=test_xlabels, test_xaxis=test_xaxis, metric_gflops=FALSE)

# ==================================================================================================


#a naive function to sing for N bottles of beer...

song = function(bottles){

  for(i in bottles:1){ #for every integer bottles, bottles-1 ... 1

    cat(bottles," bottles of beer on the wall \n",bottles," bottles of beer \nTake one down, pass it around \n",
        bottles-1, " bottles of beer on the wall \n"," \n" ,sep="")       #join and print the text (\n means new line)

        bottles = bottles - 1 #take one down...

  }

}

song(99)#play the song by calling the function


#create maps of a single LC from observed LC maps
#useful for updating Other Agri and Other Capitals through simulation

rm(list=ls())
library(raster)

#sim_yrs <- seq(2018, 2018, 1)   #single LC made for all these years
sim_yrs <- c(2005, 2010)   #single LC made for all these years

#1 = Nature
#2 = Other Agri
#3 = Agri
#4 = Other
# = Pasture

#what is desired output LC?
target = 1  #change this so that this number is derived automaticall from the tname variables (using ifelse)

#target name (for output file name), e.g. OtherAgri, Other
tname <- "Nature"

#if binary true output a binary map where 1 = target LC and 0 is not
#if binary false, output map where target LC value is maintained, all others set to 0
binary = T

#create df for subs below
df <- data.frame(id=1:5, v=rep.int(0,5))
df[target,2] <- if(binary) 1 else target

for(i in seq_along(sim_yrs)){

  ObsLU <- raster(paste0("Data/ObservedLCmaps/LandCover",sim_yrs[i],"_PastureB_Disagg.asc"))

  maskmap <- raster(paste0("Data/ObservedLCmaps/sim10_BRmunis_latlon_5km.asc"))

  LU <- mask(ObsLU, maskmap)

  LU <- subs(LU, df)

  writeRaster(LU, paste0("Data/ObservedLCmaps/singleLC_",tname,"_",sim_yrs[i],"_PastureB_Disagg.asc"), format = 'ascii', overwrite=T)

}


######################
## cfg				##
######################
source("cfg.r")
graphics.off()

dat = loadInputData()

temp_file = 'temp/cal_jules_lambda_data.Rd'
grab_cache = TRUE

JULES_control     =  "data/JULES-mort/mort0/"
JULES_experiments =  paste0("data/JULES-mort/", c("mort1", "mortr", "resp0"))
Experiment_names  = c("frac_min = 1e-6", "frac_min = 0.1", "decreased resp")

######################
## open				##
######################
Jules_TC_fire_off = openJulesTree(JULES_control, annual_average = FALSE)

Jules_fire = lapply(JULES_experiments, openJulesTree,  1, "burnt_area_gb", annual_average = FALSE)# Jules_TC_fire_off = openJulesTree(Jules_fire_off_LU_off_fname)
Jules_fire = lapply(Jules_fire,  function(i) i * 60 * 60 * 24 * 365 )

Jules_TC_fire_on = lapply(JULES_experiments, openJulesTree, annual_average = FALSE)

lambda_from_run <- function(TC_fire_on, TC_fire_off, fire) {
    runLambda <- function(i) {
        rec = lambda_dgvm(TC_fire_off[[i+1]], TC_fire_off[[i]],
                          TC_fire_on[[i+1]], TC_fire_on[[i]], fire[[i+1]], return_r = TRUE)
        #half = log(2)/lambda
        return(rec)
    }
    rec = layer.apply(1:(nlayers(TC_fire_off)-1), runLambda)

    rec = mean(rec) / mean(TC_fire_off[[-1]] - TC_fire_on[[-1]])
    return(rec)
}

rec = mapply(lambda_from_run, Jules_TC_fire_on, fire = Jules_fire, MoreArgs = list(TC_fire_off = Jules_TC_fire_off))
half = lapply(rec, function(i) -log(2)/log(1-i))

dTC = mean(Jules_TC_fire_on[[1]] - Jules_TC_fire_off)

sample4weight <- function(hlf, dtc) {
    mask = !is.na(hlf + dtc)
    vhlf = hlf[mask]; vdtc = dtc[mask]
    smp = sample(abs(vhlf), 2*length(vhlf), replace = TRUE, prob = abs(vdtc))
    return(smp)
}

shalf = lapply(half, sample4weight, dTC)
names(shalf) = Experiment_names
options(scipen = 2)
boxplot(shalf, log = 'y')
mtext(side = 2, 'reaction half life', line = 2.5, cex = 1.1)


#' File Sampler
#'
#' A simple package for reading subsamples of flat text files by line in a
#' reasonably efficient manner.  We do so by sampling as the input file is
#' scanned and randomly choosing whether or not to dump the current line to an
#' external temporary file.  This temporary file is then read back into R.  For
#' (aggressive) downsampling, this is a very effective strategy; for resampling,
#' you are much better off reading the full dataset into memory.
#'
#' The basic function performs the sampling/reading in a single pass. There is
#' an alternative version which allows for an exact amout to be subsampled via
#' reservoir sampling, but this version requires 2 passes through the data.  The
#' heavy lifting is done entirely in C.
#'
#' This package, including the underlying C library, is licensed under the
#' permissive 2-clause BSD license.
#'
#' @author Drew Schmidt \email{wrathematics@@gmail.com}
#' @references Project URL: \url{https://github.com/wrathematics/filesampler}
#'
#' @importFrom utils read.csv
#'
#' @name filesampler
#' @docType package
#' @title File Sampler
#' @keywords package
NULL


##### Box Plots by season:
xlimits <- c(0.5,4.5)

BoxData <- ParamData

DetCount_Winter <- sum(BoxData[which(BoxData$Season == 1),]$nonDetect_Flag == FALSE)
DetCount_Spring <- sum(BoxData[which(BoxData$Season == 2),]$nonDetect_Flag == FALSE)
DetCount_Summer <- sum(BoxData[which(BoxData$Season == 3),]$nonDetect_Flag == FALSE)
DetCount_Fall <- sum(BoxData[which(BoxData$Season == 4),]$nonDetect_Flag == FALSE)

Data_Winter <- BoxData[which(BoxData$Season == 1),]
Data_Spring <- BoxData[which(BoxData$Season == 2),]
Data_Summer <- BoxData[which(BoxData$Season == 3),]
Data_Fall <- BoxData[which(BoxData$Season == 4),]

ND_Winter <- Data_Winter[which(Data_Winter$nonDetect_Flag == TRUE),]
ND_Spring <- Data_Spring[which(Data_Spring$nonDetect_Flag == TRUE),]
ND_Summer <- Data_Summer[which(Data_Summer$nonDetect_Flag == TRUE),]
ND_Fall <- Data_Fall[which(Data_Fall$nonDetect_Flag == TRUE),]

if (DetCount_Winter < 5 && any(BoxData$Season == 1, na.rm = TRUE)) {
    BoxData <- BoxData[-which(BoxData$Season == 1),]
}
if (DetCount_Spring < 5 && any(BoxData$Season == 2, na.rm = TRUE)) {
    BoxData <- BoxData[-which(BoxData$Season == 2),]
}
if (DetCount_Summer < 5 && any(BoxData$Season == 3, na.rm = TRUE)) {
    BoxData <- BoxData[-which(BoxData$Season == 3),]
}
if (DetCount_Fall < 5 && any(BoxData$Season == 4, na.rm = TRUE)) {
    BoxData <- BoxData[-which(BoxData$Season == 4),]
}

nonDetects <- BoxData[which(BoxData$nonDetect_Flag == TRUE),]
colorList <- c("blue", "blue", "blue", "blue")

if (nrow(BoxData) == 0 ) {
  plot(x=c(1:10), y=c(1:10), type="n", xaxt="n", yaxt="n", xlab="", ylab="", bty="n")
  text(x=5,y=5,"Not Plotted\n(No season has 5 or more detections)")

} else if (nrow(nonDetects) > 0 ) {
  boxplot( new_Result_Value ~ Season, data= BoxData, xaxt="n", border=colorList,
           log="y", xlim=xlimits, ylim=ylimits, las=2, cex.axis=0.8, xaxs="i", yaxs="i", main="")

  if (nrow(ND_Winter) > 0 ) {
    max_nonDetect <- max(ND_Winter$new_Result_Value)
    min_nonDetect <- min(ND_Winter$new_Result_Value)
    rect(xleft=0.5, xright=1.5, ybottom=ylimits[1], ytop=max_nonDetect, col="gray93", border="white")
  }
  if (nrow(ND_Spring) > 0 ) {
    max_nonDetect <- max(ND_Spring$new_Result_Value)
    min_nonDetect <- min(ND_Spring$new_Result_Value)
    rect(xleft=1.5, xright=2.5, ybottom=ylimits[1], ytop=max_nonDetect, col="gray93", border="white")
  }
  if (nrow(ND_Summer) > 0 ) {
    max_nonDetect <- max(ND_Summer$new_Result_Value)
    min_nonDetect <- min(ND_Summer$new_Result_Value)
    rect(xleft=2.5, xright=3.5, ybottom=ylimits[1], ytop=max_nonDetect, col="gray93", border="white")
  }
  if (nrow(ND_Fall) > 0 ) {
    max_nonDetect <- max(ND_Fall$new_Result_Value)
    min_nonDetect <- min(ND_Fall$new_Result_Value)
    rect(xleft=3.5, xright=4.5, ybottom=ylimits[1], ytop=max_nonDetect, col="gray93", border="white")
  }

  par(new=TRUE)
  boxplot( new_Result_Value ~ Season, data= BoxData, xaxt="n", border=colorList,
      lty="dashed", log="y", xlim=xlimits, ylim=ylimits, ylab=ParamList[i], las=2, cex.axis=0.8, xaxs="i", yaxs="i",
      main="\nBoxplot\nby Season")

  if (nrow(ND_Winter) > 0 ) {
    max_nonDetect <- max(ND_Winter$new_Result_Value)
    min_nonDetect <- min(ND_Winter$new_Result_Value)
    lines(x=c(0.5,1.5), y=c(min_nonDetect, min_nonDetect), lwd=1, col="red", lty="solid")
    lines(x=c(0.5,1.5), y=c(max_nonDetect, max_nonDetect), lwd=1, col="red", lty="dashed")
  }
  if (nrow(ND_Spring) > 0 ) {
    max_nonDetect <- max(ND_Spring$new_Result_Value)
    min_nonDetect <- min(ND_Spring$new_Result_Value)
    lines(x=c(1.5,2.5), y=c(min_nonDetect, min_nonDetect), lwd=1, col="red", lty="solid")
    lines(x=c(1.5,2.5), y=c(max_nonDetect, max_nonDetect), lwd=1, col="red", lty="dashed")
  }
  if (nrow(ND_Summer) > 0 ) {
    max_nonDetect <- max(ND_Summer$new_Result_Value)
    min_nonDetect <- min(ND_Summer$new_Result_Value)
    lines(x=c(2.5,3.5), y=c(min_nonDetect, min_nonDetect), lwd=1, col="red", lty="solid")
    lines(x=c(2.5,3.5), y=c(max_nonDetect, max_nonDetect), lwd=1, col="red", lty="dashed")
  }
  if (nrow(ND_Fall) > 0 ) {
    max_nonDetect <- max(ND_Fall$new_Result_Value)
    min_nonDetect <- min(ND_Fall$new_Result_Value)
    lines(x=c(3.5,4.5), y=c(min_nonDetect, min_nonDetect), lwd=1, col="red", lty="solid")
    lines(x=c(3.5,4.5), y=c(max_nonDetect, max_nonDetect), lwd=1, col="red", lty="dashed")
  }

} else {
  boxplot( new_Result_Value ~ Season, data= BoxData, xaxt="n", border=colorList,
       log="y", xlim=xlimits, ylim=ylimits, ylab=ParamList[i], las=2, cex.axis=0.8, xaxs="i", yaxs="i",
       main="\nBoxplot\nby Season", cex.axis=0.8)
}

### Axis labels and legend:
if (nrow(BoxData) > 0 ) {

  percentCensor <- c(nrow(ND_Winter), nrow(ND_Spring), nrow(ND_Summer), nrow(ND_Fall))
  percentCensor <- percentCensor / (
             c(nrow(ND_Winter), nrow(ND_Spring), nrow(ND_Summer), nrow(ND_Fall)) +
             c(DetCount_Winter, DetCount_Spring, DetCount_Summer, DetCount_Fall) )
  percentCensor <- round(100*percentCensor, 1)

  axislabels <- paste(c("Winter", "Spring", "Summer", "Fall"),
                      rep("\nDet=",4),
                      c(DetCount_Winter, DetCount_Spring, DetCount_Summer, DetCount_Fall),
                      rep("\n ND=",4),
                      c(nrow(ND_Winter), nrow(ND_Spring), nrow(ND_Summer), nrow(ND_Fall)),
                      rep("\n",4),
                      percentCensor,
                      rep("%",4),
                      sep="")
  axis(side=1, at=c(1:4), labels=rep("",4))
  mtext(side=1, line=3.5, at=c(1:4), text=axislabels, adj=0.5, padj=0, cex=0.6)

  ymax <- par("usr")[4]
  ymin <- par("usr")[3]
  ymin_legend <- 10^(ymax + 0.01*(ymax-ymin))
  ymax_legend <- 10^(ymax + 0.18*(ymax-ymin))

  legend(x=c(3.5,5), y=c(ymin_legend, ymax_legend), legend=c("max-ND", "min-ND", "ND Region"),
            lty=c("dashed", "solid", NA), border=rep(NA,3),
            col=c("red", "red", NA), fill=c(NA, NA, NA), xpd=NA, cex=0.8, bty="o", bg="white")
  rect(xleft=3.7, xright=4.05, ybottom=10^(ymax + 0.02*(ymax-ymin)), ytop=10^(ymax + 0.07*(ymax-ymin)), col="gray93", border=NA, xpd=NA)

}