apply_transition <- function(rg, transition_table) {
  tt1 <- transition_table[order(risk_grade_to),.(risk_grade_to, cumprob = cumsum(tran_prob)),risk_grade]
  mcf <- sapply(unique(tt1$risk_grade), function(rg) {
    cp <- tt1[risk_grade == rg, unique(sort(cumprob))]
    function(x) as.integer(cut(x, c(-Inf, cp)))
  })

  urg <- unique(rg)
  res <- copy(rg)
  sapply(urg, function(u) {
    ii <- which(u == rg)
    res[ii] <<- mcf[[u]](runif(length(ii)))
  })
  res
}

churn_transition <- function(indata, pct) {
  indata[runif(.N) >= pct, ]
}

default_transition <- function(indata) {
  indata2 <- copy(indata)[,default := ifelse(default>=1, default+1,  risk_grade_pd >= runif(.N))]
  indata2
}

update_valuation <- function(indata, macro_period_id, macros_table) {
  indata2 <- copy(indata)[,value := value * macros_table[macro_period_id+1, hpi]/macros_table[macro_period_id, hpi]]
  return(indata2)
}

originate_new_loans <- function(indata, target_dollar, sim_period_id) {
  # browser()
  mean_bal <- indata[,mean(curr_bal)]
  res <- indata[sample(1:.N, max(1,target_dollar/mean_bal), replace = T),]
  res[,orig_period_id := rep(sim_period_id, .N)]

  if(res[,sum(curr_bal) - target_dollar >= mean_bal]) {
    return(res)
  } else {
    return(rbindlist(list(res, originate_new_loans(indata, target_dollar - res[,sum(curr_bal)], sim_period_id))))
  }
}

simulate_one_period <- function(indata, sim_period_id, origdata, target_dollar, macros_table, transition_table) {
  #browser()
  indata2 <- indata %>%
    default_transition %>%
    churn_transition(0.1) %>%
    {.[,risk_grade := apply_transition(risk_grade, transition_table)]} %>%
    update_valuation(sim_period_id, macros_table) %>%
    {rbindlist(list(., originate_new_loans(origdata, target_dollar, sim_period_id)), use.names = T, fill = T)}

  # this is used to indicate the latest
  indata2[,period_id := rep(sim_period_id,.N)]

  new_losses <- indata2[default >= 2, ]
  # print(new_losses[,sum(pmax(0, curr_bal - value))])

  list(indata = indata2[default < 2,], new_losses = new_losses)
}


devtools::load_all()
library(magrittr)
source("/mnt/hgfs/Documents/covid-exeedance/read_data.r")
source("/mnt/hgfs/Documents/covid-exeedance/smoother.R")
source("/mnt/hgfs/Documents/covid-exeedance/create_matrices.r")

ncols = length(300:(NCOL(baseline.matrix.f)-1))

LTLA[,c('y','x')] = vlatlong2km(LTLA[, c("latitude", "longitude")])

ws = matrix(NA, nrow = nrow(LTLA), ncol = ncols)

t = 300:(NCOL(baseline.matrix.f)-1)

for (TT in t){

  cylinders = CreateCylinders(Positives, baseline.matrix.p, week.range = c(TT-200, TT),
                              n.cylinders = 10000, coord.df=LTLA, only.last=T)
  I = TT -300 + 1
  ws[,I] = apply(LTLA, 1, FUN=warning.score2, TT, cylinders)

}

t = 300:(NCOL(baseline.matrix.p)-1)
plot(t,ws[1,], type='l', col=tab.gray, xlim=c(500,600), ylab = 'w (warning score)', main='Positives')
lines(t,ws[10,], type='l', col=tab.red)
# lines(t,ws[100,], type='l', col=tab.green)
# lines(t,ws[200,], type='l', col=tab.blue)
# lines(t,ws[300,], type='l', col=tab.orange)

norm<-function(x){
  return(x / max(x))
}
t=1:NCOL(baseline.matrix.f)
lines(t, norm(Positives[1,]), type='l', lty=3, col=tab.gray)
lines(t, norm(Positives[10,]), type='l', lty=3,col=tab.red)
# lines(t, norm(Positives[100,]), type='l', lty=3,col=tab.green)
# lines(t, norm(Positives[200,]), type='l', lty=3,col=tab.blue)
# lines(t, norm(Positives[300,]), type='l', lty=3, col=tab.orange)

lines(t, norm(colSums(baseline.matrix.p)), col='blue')

legend('topleft', c('baseline (not to scale)', 'w Hartepool', 'w Kingston', '# cases Hartep. (not to scale)', '# cases Kingst. (not to scale)'),
       col=c('blue', tab.gray,tab.red,tab.gray,tab.red), lty=c(1,1,1,3,3), cex=0.8)

idx = which(ws[, 483] > 0.95)
# LTLA[idx,1]
# [1] "South Bucks"           "Forest of Dean"        "Basingstoke and Deane" "Broxbourne"            "Hertsmere"
# [6] "Watford"               "Ipswich"               "Stevenage"

t = 300:(NCOL(baseline.matrix.p)-1)
plot(t,ws[idx[1],], type='l', col=tab.gray, xlim=c(700,785), ylab = 'ws (warning score)', main='Positives')
lines(t,ws[idx[2],], type='l', col=tab.red)
lines(t,ws[idx[7],], type='l', col=tab.blue)

t=1:NCOL(baseline.matrix.f)
lines(t, norm(Positives[idx[1],]), type='l', lty=3, col=tab.gray)
lines(t, norm(Positives[idx[2],]), type='l', lty=3,col=tab.red)
lines(t, norm(Positives[idx[7],]), type='l', lty=3,col=tab.blue)

lines(t, norm(colSums(baseline.matrix.p)), col='blue')
legend('bottomleft', c('baseline (not to scale)',  "ws South Bucks", "ws Forest of Dean", "ws Ipswich",
                    '# cases S.Bucks (not to scale)', '# cases FDean (not to scale)', '# Ipswich (not to scale)'),
       col=c('blue', tab.gray,tab.red,tab.blue,
             tab.gray,tab.red, tab.blue), lty=c(1,1,1,1,1,3,3,3,3), cex=0.7)


#######################################################################################################
#   Kalman filter and smoother function based on Koopman and Durbin's KFAS package
#   y_t = Z_t * alpha_t + eps_t (observation equation)
#   alpha_t+1 = T_t * alpha_t + R_t * eta_t(transition equation)
#   Note the different time indexing for transition equation
#   The y_t,y_{t-1} stacked vector with parameters vectors reconfigured to output the
#     smoothed lag-1 covariances needed by the EM algorithm
#######################################################################################################
MARSSkfas <- function(MLEobj, only.logLik = FALSE, return.lag.one = TRUE, return.kfas.model = FALSE) {
  MODELobj <- MLEobj[["marss"]]
  control <- MLEobj[["control"]]
  diffuse <- MODELobj[["diffuse"]]
  model.dims <- attr(MODELobj, "model.dims")

  n <- model.dims$data[1]
  TT <- model.dims$data[2]
  m <- model.dims$x[1]
  g1 <- model.dims$Q[1]
  h1 <- model.dims$R[1]
  l1 <- model.dims$L[1]
  par.1 <- parmat(MLEobj, t = 1)
  t.B <- matrix(par.1$B, m, m, byrow = TRUE)
  # create the YM matrix
  YM <- matrix(as.numeric(!is.na(MODELobj$data)), n, TT)

  # Make sure the missing vals in yt are NAs if there are any
  yt <- MODELobj$data
  yt[!YM] <- as.numeric(NA)

  # Stack the y so that we can get the lag-1 covariance smoother from the Kalman filter output
  # stack.yt=rbind(yt[,1:TT,drop=FALSE],cbind(NA,yt[,1:(TT-1),drop=FALSE]))
  # stack.yt=t(stack.yt)

  # KFS needs time going down rows so yt can be properly converted to ts object
  yt <- t(yt)

  # Build the Zt matrix which is n x (m+1) or n x (m+1) x T; (m+1) because A is in Z
  if (model.dims$Z[3] == 1 & model.dims$A[3] == 1) {
    # not time-varying
    Zt <- cbind(par.1$Z, par.1$A)
    stack.Zt <- matrix(0, n, 2 * (m + 1))
    stack.Zt[1:n, 1:(m + 1)] <- Zt
  } else {
    Zt <- array(0, dim = c(n, m + 1, TT))
    stack.Zt <- array(0, dim = c(n, 2 * (m + 1), TT))
    pars <- parmat(MLEobj, c("Z", "A"), t = 1:TT)
    Zt[1:n, 1:m, ] <- pars$Z
    Zt[1:n, m + 1, ] <- pars$A
    stack.Zt[1:n, 1:(m + 1), ] <- Zt
  }

  # Build the Tt matrix which is (m+1) x (m+1) or (m+1) x (m+1) x T; (m+1) because x has extra row of 1s (for the A)
  #    Tt=cbind(rbind(parList$B,matrix(0,1,m)),matrix(c(parList$U,1),m+1,1))
  if (model.dims$B[3] == 1 & model.dims$U[3] == 1) {
    # not time-varying
    Tt <- cbind(rbind(par.1$B, matrix(0, 1, m)), matrix(c(par.1$U, 1), m + 1, 1))
    stack.Tt <- matrix(0, 2 * (m + 1), 2 * (m + 1))
    stack.Tt[1:(m + 1), 1:(m + 1)] <- Tt
    stack.Tt[(m + 2):(2 * m + 2), 1:(m + 1)] <- diag(1, m + 1)
  } else {
    Tt <- array(0, dim = c(m + 1, m + 1, TT))
    stack.Tt <- array(0, dim = c(2 * (m + 1), 2 * (m + 1), TT))
    pars <- parmat(MLEobj, c("B", "U"), t = 1:TT)
    # pars uses i+1 because in KFAS x(t)=B(t-1)x(t-1) versus MARSS where x(t)=B(t)x(t-1)
    # KFAS sets prior on x(1) so recursions start at x(2); thus B(0) never appears in the KFAS recursions
    Tt[1:m, 1:m, 1:(TT - 1)] <- pars$B[, , 2:TT]
    Tt[1:m, m + 1, 1:(TT - 1)] <- pars$U[, , 2:TT]
    Tt[m + 1, m + 1, ] <- 1
    # in KFAS T[,,TT] is not used since x(T)=B(t-1)x(t-1) is the last computation
    # Set to 0 since is.SSModel does like NA in any parameters
    Tt[, , TT] <- 0
    stack.Tt[(m + 2):(2 * m + 2), 1:(m + 1), ] <- diag(1, m + 1)
    stack.Tt[1:(m + 1), 1:(m + 1), ] <- Tt
    stack.Tt[, , TT] <- 0 # see comment above re setting TT value
  }

  # Build the Ht (R) matrix which is n x n or n x n x T
  if (model.dims$R[3] == 1) {
    # not time-varying
    Ht <- tcrossprod(par.1$H %*% par.1$R, par.1$H)
  } else {
    Ht <- array(0, dim = c(n, n, TT))
    for (i in 1:TT) {
      Ht[, , i] <- tcrossprod(parmat(MLEobj, "H", t = i)$H %*% parmat(MLEobj, "R", t = i)$R, parmat(MLEobj, "H", t = i)$H)
    }
  }

  # Build the Qt matrix which is g1 x g1 or g1 x g1 x T;
  if (model.dims$Q[3] == 1) {
    # not time-varying
    Qt <- par.1$Q
    stack.Qt <- matrix(0, 2 * g1, 2 * g1)
    stack.Qt[1:g1, 1:g1] <- Qt
  } else {
    # See notes for Tt re differences in parameter indexing for the process equation
    Qt <- array(0, dim = c(g1, g1, TT))
    stack.Qt <- array(0, dim = c(2 * g1, 2 * g1, TT))
    for (i in 1:(TT - 1)) {
      # i+1 since in KFAS my B(t) equals B(t-1)
      Qt[, , i] <- parmat(MLEobj, "Q", t = i + 1)$Q
      stack.Qt[1:g1, 1:g1, i] <- Qt[, , i]
    }
    # see comments on setting of T re TT value; TT value never appears in the KFAS recursions
    # but is.SSModel check does not like any NAs in the parameters
    Qt[, , TT] <- 0
    stack.Qt[, , TT] <- 0
  }

  # build the Rt (G) matrix; process error is G(t)%*%w(t); extra row at bottom for for U (1s row in x)
  if (model.dims$G[3] == 1) {
    # not time-varying
    Rt <- matrix(0, m + 1, g1)
    Rt[1:m, 1:g1] <- par.1$G
    stack.Rt <- matrix(0, 2 * (m + 1), 2 * g1)
    stack.Rt[1:(m + 1), 1:g1] <- Rt
  } else {
    # See notes for Tt re differences in parameter indexing for the process equation
    Rt <- array(0, dim = c(m + 1, g1, TT))
    stack.Rt <- array(0, dim = c(2 * (m + 1), 2 * g1, TT))
    for (i in 1:(TT - 1)) {
      # i+1 since in KFAS my B(t) equals B(t-1)
      Rt[, , i] <- matrix(0, m + 1, g1)
      Rt[1:m, 1:g1, i] <- parmat(MLEobj, "G", t = i + 1)$G
      stack.Rt[1:(m + 1), 1:g1, i] <- Rt[, , i]
    }
    # see comments on setting of T re TT value; TT value never appears in the KFAS recursions
    # but is.SSModel check does not like any NAs in the parameters
    Rt[, , TT] <- 0
    stack.Rt[, , TT] <- 0
  }

  # Build the a1 and P1 matrices
  # First compute x10 and V10 if tinitx=0
  if (MODELobj$tinitx == 0) { # Compute needed x_1 | x_0
    # B(1),U(1), and Q(1) correct here since equivalent to B(0), etc in KFAS terminology
    x00 <- par.1$x0
    V00 <- tcrossprod(par.1$L %*% par.1$V0, par.1$L)
    x10 <- par.1$B %*% x00 + par.1$U # Shumway and Stoffer treatment of initial states
    V10 <- par.1$B %*% V00 %*% t.B + par.1$Q # eqn 6.20
  } else {
    x10 <- par.1$x0
    x00 <- matrix(10, m, 1) # dummy; not defined
    V10 <- par.1$V0
    V00 <- diag(0, m) # dummy; not defined
  }
  a1 <- rbind(x10, 1)
  stack.a1 <- rbind(x10, 1, x00, 1)
  if (diffuse) {
    P1inf <- matrix(0, m + 1, m + 1)
    P1inf[1:m, 1:m] <- V10
    stack.P1inf <- matrix(0, 2 * (m + 1), 2 * (m + 1))
    stack.P1inf[1:m, 1:m] <- V10
    stack.P1inf[(m + 2):(2 * m + 1), (m + 2):(2 * m + 1)] <- V00
    P1 <- matrix(0, m + 1, m + 1)
    stack.P1 <- matrix(0, 2 * (m + 1), 2 * (m + 1))
  } else {
    P1inf <- matrix(0, m + 1, m + 1)
    stack.P1inf <- matrix(0, 2 * (m + 1), 2 * (m + 1))
    P1 <- matrix(0, m + 1, m + 1)
    P1[1:m, 1:m] <- V10
    # P1 is the var-cov matrix for the stacked x1,x0
    # it is matrix(c(V10,B*V00,V00*t(B),V00),2,2)
    # x1=B*x0+U+w; in the var-cov mat looks like
    # E[x1*t(x1)] E[(Bx0+U+w1)*t(x0)] -   E[x1]*E[x1]     E[(Bx0+U+w1)]E[t(x0)]
    # E[x0*t(Bx0+U+w1)] E[x0*t(x0)]       E[(Bx0+U+w1)]E[t(x0)] - E[x0]E[t(x0)]
    stack.P1 <- matrix(0, 2 * (m + 1), 2 * (m + 1))
    stack.P1[1:m, 1:m] <- V10
    stack.P1[(m + 2):(2 * m + 1), (m + 2):(2 * m + 1)] <- V00
    stack.P1[1:m, (m + 2):(2 * m + 1)] <- par.1$B %*% V00
    stack.P1[(m + 2):(2 * m + 1), 1:m] <- V00 %*% t(par.1$B)
  }

  if (!return.lag.one) {
    kfas.model <- SSModel(yt ~ -1 + SSMcustom(Z = Zt, T = Tt, R = Rt, Q = Qt, a1 = a1, P1 = P1, P1inf = P1inf), H = Ht)
  } else {
    kfas.model <- SSModel(yt ~ -1 + SSMcustom(Z = stack.Zt, T = stack.Tt, R = stack.Rt, Q = stack.Qt, a1 = stack.a1, P1 = stack.P1, P1inf = stack.P1inf), H = Ht)
  }

  if (only.logLik) {
    return(list(logLik = logLik(kfas.model)))
  }
  # This works because I do not allow the location of 0s on the diagonal of R or Q to be time-varying
  if (n == 1) {
    diag.R <- unname(par.1$R)
  } else {
    diag.R <- unname(par.1$R)[1 + 0:(n - 1) * (n + 1)]
  }

  if (any(diag.R == 0)) { # because KFAS 1.0.4 added a warning message
    ks.out <- suppressWarnings(KFS(kfas.model, simplify = FALSE))
  } else {
    ks.out <- KFS(kfas.model, simplify = FALSE)
  } # simplify=FALSE so 1.0.0 returns LL
  # because 1.0.0 has time down columns instead of across rows
  if (packageVersion("KFAS") != "0.9.11") {
    ks.out$a <- t(ks.out$a)
    ks.out$alphahat <- t(ks.out$alphahat)
  }

  VtT <- ks.out$V[1:m, 1:m, , drop = FALSE]
  Vtt1 <- ks.out$P[1:m, 1:m, 1:TT, drop = FALSE]
  if (!return.lag.one) {
    Vtt1T <- NULL
  } else {
    Vtt1T <- ks.out$V[1:m, (m + 2):(2 * m + 1), , drop = FALSE]
  }
  # zero out rows cols as needed when R diag = 0
  # Check that if any R are 0 then model is solveable
  if (any(diag.R == 0)) {
    VtT[abs(VtT) < .Machine$double.eps] <- 0
    Vtt1[abs(Vtt1) < .Machine$double.eps] <- 0
    if (return.lag.one) Vtt1T[abs(Vtt1T) < .Machine$double.eps] <- 0
  }

  x10T <- ks.out$alphahat[1:m, 1, drop = FALSE]
  V10T <- matrix(VtT[, , 1], m, m)
  if (MODELobj$tinitx == 1) {
    x00 <- matrix(NA, m, 1)
    V00 <- matrix(NA, m, m)
    x0T <- x10T
    V0T <- V10T
  } else { # MODELobj$tinitx==0
    Vtt1.1 <- sub3D(Vtt1, t = 1)
    Vinv <- pcholinv(Vtt1.1)
    if (m != 1) Vinv <- symm(Vinv) # to enforce symmetry after chol2inv call
    J0 <- V00 %*% t.B %*% Vinv # eqn 6.49 and 1s on diag when Q=0; Here it is t.B[1]
    xtT.1 <- ks.out$alphahat[1:m, 1, drop = FALSE]
    x0T <- x00 + J0 %*% (ks.out$alphahat[1:m, 1, drop = FALSE] - ks.out$a[1:m, 1, drop = FALSE]) # eqn 6.47
    V0T <- V00 + J0 %*% (VtT[, , 1] - Vtt1[, , 1]) * t(J0) # eqn 6.48
  }

  if (!return.kfas.model) kfas.model <- NULL

  # not using ks.out$v (Innov) and ks.out$F (Sigma) since I think there might be a bug (I misunderstand KFAS) when R is not diagonal.
  rtn.list <- list(
    xtT = ks.out$alphahat[1:m, , drop = FALSE],
    VtT = VtT,
    Vtt1T = Vtt1T,
    x0T = x0T,
    V0T = V0T,
    x10T = ks.out$alphahat[1:m, 1, drop = FALSE],
    V10T = V10T,
    x00T = x00,
    V00T = V00,
    Vtt = "Use MARSSkfss to get Vtt",
    Vtt1 = Vtt1,
    J = "Use MARSSkfss to get J",
    J0 = "Use MARSSkfss to get J0",
    Kt = "Use MARSSkfss to get Kt",
    xtt1 = ks.out$a[1:m, 1:TT, drop = FALSE],
    xtt = "Use MARSSkfss to get xtt",
    Innov = "Use MARSSkfss to get Innov",
    Sigma = "Use MARSSkfss to get Sigma",
    kfas.model = kfas.model,
    logLik = ks.out$logLik,
    ok = TRUE,
    errors = NULL
  )
  # apply names
  X.names <- attr(MODELobj, "X.names")
  for(el in c("xtT", "xtt1", "x0T", "x00T", "x10T")) rownames(rtn.list[[el]]) <- X.names
  return(rtn.list)
}


#
# script to run for the first time
#
# see https://github.com/IRkernel/IRkernel
#

#
# specify a location by default
#

cat(".Rprofile: Setting UK repositoryn")
r = getOption("repos")
r["CRAN"] = "http://cran.uk.r-project.org"
options(repos = r)
rm(r)

#
# installation for the notebook IKernel
#

install.packages(c('devtools'))
install.packages(c('rzmq','repr','IRkernel','IRdisplay'),
                 repos = c('http://irkernel.github.io/', getOption('repos')))
IRkernel::installspec(user=F)

#
# installation of others packages
#

install.packages(c('actuar',
                    'ADGofTest',
                    'AUC',
                    'bigglm',
                    'clusterGeneration',
                    'caret',
                    'corrplot',
                    'dendroextras',
                    'DiagrammeR',
                    'data.table',
                    'distr',
                    'distrEx',
                    'doSNOW',
                    'doParallel',
                    'dplyr',
                    'e1071',
                    'FactoMineR',
                    'Factoshiny',
                    'fastcluster',
                    'ff',
                    'ffbase',
                    'foreach',
                    'forecast',
                    'ggmaps',
                    'ggplot2',
                    'graph',
                    'hflights',
                    'HistData',
                    'igraph',
                    'ineq',
                    'KernSmooth',
                    'LaF',
                    'lubridate',
                    'magrittr',
                    'maps',
                    'maptools',
                    'MASS',
                    'microbenchmark',
                    'mgcv',
                    'mnormt',
                    'memoise',
                    'multicore',
                    'network',
                    'neuralnet',
                    'nnet',
                    'normtest',
                    'nws',
                    'parallel',
                    'plyr',
                    'pmml',
                    'pROC',
                    'pryr',
                    'qcc',
                    'quantreg',
                    'R.utils',
                    'randomForest',
                    'rattle',
                    'Rcmdr',
                    'Rcpp',
                    'Rcurl',
                    'rgl',
                    'rmarkdown',
                    'RMongo',
                    'RMySQL',
                    'rpart',
                    'RODBC',
                    'RPostgreSQL',
                    'rPython',
                    'RSQLite',
                    'reshape2',
                    'rgdal',
                    'rmpi',
                    'rvest',
                    'shiny',
                    'sna',
                    'snow',
                    'SOAR',
                    'som',
                    'sp',
                    'spatstat',
                    'speedglm',
                    'sqldf',
                    'stringr',
                    'tidyr',
                    'tcltk',
                    'tm',
                    'VGAM',
                    'xgboost',
                    'XML',
                    'xml2',
                    'xlsx',
                    'xts',
                    'wordcloud',
                    'YieldCurve',
                    'zoo'))

#
# big memory
# http://www.thecoatlessprofessor.com/programming/installing-the-bigmemory-package-and-biglm-on-windows-os-x-or-linux/
# https://r-forge.r-project.org/R/?group_id=556
#
# Install Bigmemory packages from r-forge page
#
# This part is commented out because rpy2 requires 3.2.x and bigmemory binaries are only available
# for R 3.1.3 (2015/09/18).

# install.packages("bigmemory", repos="http://R-Forge.R-project.org")

# install.packages("bigmemory.sri", repos="http://R-Forge.R-project.org")
# install.packages("biganalytics", repos="http://R-Forge.R-project.org")
# install.packages("bigalgebra", repos="http://R-Forge.R-project.org")
# install.packages("bigkmeans", repos="http://R-Forge.R-project.org")
# install.packages("bigrf", repos="http://R-Forge.R-project.org")
# install.packages("bigtabulate", repos="http://R-Forge.R-project.org")

# Install Boost Header and biglm package from CRAN

# install.packages(c("BH","biglm"))


source("common/src/eval/basic_stats.r") # For "statistics" list

boot_stat = function(k, x, y, fitModel, stat){
  results = rep(NULL, k)
  full_dat = cbind(y,x)
  n = nrow(x)
  for(i in 1:k){
    ix = sample(n, replace=TRUE)
    xa = x[ix,]
    ya = y[ix]
    xb = x[-ix,]
    yb = y[-ix]

    mod = suppressWarnings(fitModel(xa, ya))
    results[i] = stat(mod, xb, yb)
  }
  results
}

args <- commandArgs(TRUE)  ## reports/task0/logreg.r_bootstrap.txt accuracy
if(length(args)>0){
  outpath = args[1]
  task_name = gsub("(task.*)/reports/(.*\\.r)_bootstrap.txt","\\1", outpath)
  mod_name  = gsub("(task.*)/reports/(.*\\.r)_bootstrap.txt","\\2", outpath)
  stat_name = args[2]
  data_path = paste0(task_name, "/data/processed/train.rdata")

  load(data_path)
  stat_func = statistics[[stat_name]]

  mod_funcs = paste0(task_name, "/src/models/", mod_name)
  source(mod_funcs)

  k = 200
  results = boot_stat(k, X, Y, train_model, stat_func)

  fname = paste0(task_name, "/data/processed/", mod_name, "_bootstrap.rdata")
  dir.create(dirname(fname), showWarnings = FALSE)
  save(results, file = fname)

  agg_results = t(data.frame(quantile(results, c(.05, .5, .95))))
  rownames(agg_results) = stat_name

  dir.create(dirname(outpath), showWarnings = FALSE)
  write.csv(agg_results, file = outpath)

  source("common/src/eval/eval_db/dbapi.r")
  result_name = paste("bootstrap",stat_name, k, sep="_")
  m = prep_results(agg_results)
  m$field_name = gsub("X([0-9]{1,2})\\.$", "\\1%", m$field_name)
  m$field_name = gsub("X([0-9]{1,2}\\.[0-9]+)$", "\\1%", m$field_name)

  log_model_result(task_name, mod_name, result_name, m)
  dbDisconnect(conn)
}


# Check if RStudio is running to set the working directory to the script directory
# https://stackoverflow.com/questions/35986037/detect-if-an-r-session-is-run-in-rstudio-at-startup
is.na(Sys.getenv("RSTUDIO", unset = NA))
if (!is.na(Sys.getenv("RSTUDIO", unset = NA))) {
  # Get current directory
  current_dir <- dirname(rstudioapi::getSourceEditorContext()$path)
  # Set working directory to current directory (script directory)
  setwd(current_dir)
} else {
  # If sourced https://stackoverflow.com/questions/13672720/r-command-for-setting-working-directory-to-source-file-location-in-rstudio
  this.dir <- dirname(parent.frame(2)$ofile)
  setwd(this.dir)
}
# Include the excel helper functions
source("excelhelper.r")

# libraries for data manipulation
library(dplyr)

# Read the input files
diamonds<- getTable("diamonds")

# Multiply length, width, and depth together in a new column called "cubic"
diamonds <- mutate(diamonds, cubic=length*width*depth)

# let's round the carat values to the nearest 0.25 carat so that our numbers are not all over the place.
# this is an alternative way to mutate
diamonds$carat2 <- round(diamonds$carat/.25)*.25

# Select only the calculated column to return less information
diamonds <- select(diamonds, carat2, cubic)

# Write the result
writeResult(tablenames = list("result"=diamonds))

# Signal the end of the process
done()

# free up all variables
#rm(list=ls())


#' Powers.
#'
#' This package was created for a STAT547 assignment to practice developing packages in R.
#' It contains two functions, log_10 and cube. These can be used to calculate the log base ten of and cubed values of a vector.
#' There is more detail about this package in the vignette file.
#'
#' @name Powers
#' @docType package
NULL


context("convert_variable")

test_that("convert_variable returns vector of correct class", {
  vlogical <- variable(as.logical(0:9))
  vinteger <- variable(1:10)
  vnumeric <- variable(1:10 + 0.1)
  vfactor <- variable(factor(1:10))
  vdate <- variable(as.Date("2000-01-01") + 1:10)
  vposixt <- variable(as.POSIXct("2000-01-01", tz= "UTC") + 1:10)

  mlogical <- variable(matrix(as.logical(0:9)))
  minteger <- variable(matrix(as.integer(1:10)))
  mdouble <- variable(matrix(1:10 + 0.1))

  alogical <- variable(array(as.logical(0:9)))
  ainteger <- variable(array(as.integer(1:10)))
  adouble <- variable(array(1:10 + 0.1))

  expect_that(convert_variable(vlogical, as.logical(0:9)), is_a("integer"))
  expect_that(convert_variable(vinteger, 1:10), is_a("integer"))
  expect_that(convert_variable(vnumeric, 1:10 + 0.1), is_a("numeric"))
  expect_that(convert_variable(vfactor, factor(1:10)), is_a("integer"))
  expect_that(convert_variable(vdate, as.Date("2000-01-01") + 1:10), is_a("integer"))
  expect_that(convert_variable(vposixt, as.POSIXct("2000-01-01", tz= "UTC") + 1:10), is_a("integer"))

  expect_that(convert_variable(mlogical, matrix(as.logical(0:9))), is_a("matrix"))
  expect_that(convert_variable(minteger, matrix(1:10)), is_a("matrix"))
  expect_that(convert_variable(mdouble, matrix(1:10 + 0.1)), is_a("matrix"))

  expect_that(storage.mode(convert_variable(mlogical, matrix(as.logical(0:9)))), equals("integer"))
  expect_that(storage.mode(convert_variable(minteger, matrix(1:10))), equals("integer"))
  expect_that(storage.mode(convert_variable(mdouble, matrix(1:10 + 0.1))), equals("double"))

  expect_that(convert_variable(alogical, array(as.logical(0:9))), is_a("array"))
  expect_that(convert_variable(ainteger, array(1:10)), is_a("array"))
  expect_that(convert_variable(adouble, array(1:10 + 0.1)), is_a("array"))

  expect_that(storage.mode(convert_variable(alogical, array(as.logical(0:9)))), equals("integer"))
  expect_that(storage.mode(convert_variable(ainteger, array(1:10))), equals("integer"))
  expect_that(storage.mode(convert_variable(adouble, array(1:10 + 0.1))), equals("double"))

  expect_that(convert_variable(vlogical, as.logical(0:9), centre = T), is_a("integer"))
  expect_that(convert_variable(vinteger, 1:10, centre = T), is_a("integer"))
  expect_that(convert_variable(vnumeric, 1:10 + 0.1, centre = T), is_a("numeric"))
  expect_that(convert_variable(vfactor, factor(1:10), centre = T), is_a("integer"))
  expect_that(convert_variable(vdate, as.Date("2000-01-01") + 1:10, centre = T), is_a("integer"))
  expect_that(convert_variable(vposixt, as.POSIXct("2000-01-01", tz= "UTC") + 1:10, centre = T), is_a("integer"))

  expect_that(convert_variable(mlogical, matrix(as.logical(0:9)), centre = T), is_a("matrix"))
  expect_that(convert_variable(minteger, matrix(1:10), centre = T), is_a("matrix"))
  expect_that(convert_variable(mdouble, matrix(1:10 + 0.1), centre = T), is_a("matrix"))

  expect_that(storage.mode(convert_variable(mlogical, matrix(as.logical(0:9)), centre = T)), equals("integer"))
  expect_that(storage.mode(convert_variable(minteger, matrix(1:10), centre = T)), equals("integer"))
  expect_that(storage.mode(convert_variable(mdouble, matrix(1:10 + 0.1), centre = T)), equals("double"))

  expect_that(convert_variable(alogical, array(as.logical(0:9)), centre = T), is_a("array"))
  expect_that(convert_variable(ainteger, array(1:10), centre = T), is_a("array"))
  expect_that(convert_variable(adouble, array(1:10 + 0.1), centre = T), is_a("array"))

  expect_that(storage.mode(convert_variable(alogical, array(as.logical(0:9)), centre = T)), equals("integer"))
  expect_that(storage.mode(convert_variable(ainteger, array(1:10), centre = T)), equals("integer"))
  expect_that(storage.mode(convert_variable(adouble, array(1:10 + 0.1), centre = T)), equals("double"))

  expect_that(convert_variable(vlogical, as.logical(0:9), standardise = T), is_a("integer"))
  expect_that(convert_variable(vinteger, 1:10, standardise = T), is_a("numeric"))
  expect_that(convert_variable(vnumeric, 1:10 + 0.1, standardise = T), is_a("numeric"))
  expect_that(convert_variable(vfactor, factor(1:10), standardise = T), is_a("integer"))
  expect_that(convert_variable(vdate, as.Date("2000-01-01") + 1:10, standardise = T), is_a("numeric"))
  expect_that(convert_variable(vposixt, as.POSIXct("2000-01-01", tz= "UTC") + 1:10, standardise = T), is_a("numeric"))

  expect_that(convert_variable(mlogical, matrix(as.logical(0:9)), standardise = T), is_a("matrix"))
  expect_that(convert_variable(minteger, matrix(1:10), standardise = T), is_a("matrix"))
  expect_that(convert_variable(mdouble, matrix(1:10 + 0.1), standardise = T), is_a("matrix"))

  expect_that(storage.mode(convert_variable(mlogical, matrix(as.logical(0:9)), standardise = T)), equals("integer"))
  expect_that(storage.mode(convert_variable(minteger, matrix(1:10), standardise = T)), equals("double"))
  expect_that(storage.mode(convert_variable(mdouble, matrix(1:10 + 0.1), standardise = T)), equals("double"))

  expect_that(convert_variable(alogical, array(as.logical(0:9)), standardise = T), is_a("array"))
  expect_that(convert_variable(ainteger, array(1:10), standardise = T), is_a("array"))
  expect_that(convert_variable(adouble, array(1:10 + 0.1), standardise = T), is_a("array"))

  expect_that(storage.mode(convert_variable(alogical, array(as.logical(0:9)), standardise = T)), equals("integer"))
  expect_that(storage.mode(convert_variable(ainteger, array(1:10), standardise = T)), equals("double"))
  expect_that(storage.mode(convert_variable(adouble, array(1:10 + 0.1), standardise = T)), equals("double"))

})

test_that("convert_variable returns vector of correct length", {
  vlogical <- variable(as.logical(0:9))
  vinteger <- variable(1:10)
  vnumeric <- variable(1:10 + 0.1)
  vfactor <- variable(factor(1:10))
  vdate <- variable(as.Date("2000-01-01") + 1:10)
  vposixt <- variable(as.POSIXct("2000-01-01", tz= "UTC") + 1:10)

  expect_that(length(convert_variable(vlogical, as.logical(0:9))), equals(10))
  expect_that(length(convert_variable(vinteger, 1:10)), equals(10))
  expect_that(length(convert_variable(vnumeric, 1:10 + 0.1)), equals(10))
  expect_that(length(convert_variable(vfactor, factor(1:10))), equals(10))
  expect_that(length(convert_variable(vdate, as.Date("2000-01-01") + 1:10)), equals(10))
  expect_that(length(convert_variable(vposixt, as.POSIXct("2000-01-01", tz= "UTC") + 1:10)), equals(10))
})

test_that("convert_variable returns vector of correct values", {
  vlogical <- variable(as.logical(0:9))
  vinteger <- variable(1:10)
  vnumeric <- variable(1:10 + 0.1)
  vfactor <- variable(factor(1:10))
  vdate <- variable(as.Date("2000-01-01") + 1:10)
  vposixt <- variable(as.POSIXct("2000-01-01", tz= "UTC") + 1:10)

  expect_that(convert_variable(vlogical, TRUE), equals(1))
  expect_that(convert_variable(vinteger, as.integer(1)), equals(1))
  expect_that(convert_variable(vnumeric, 1), equals(1))
  expect_that(convert_variable(vfactor, factor(1)), equals(1))
  expect_that(convert_variable(vdate, as.Date("2000-01-01")), equals(1))
  expect_that(convert_variable(vposixt, as.POSIXct("2000-01-01", tz= "UTC")), equals(1))
})


#' Plot yield curves
#'
#' Plot yield and SSB per recruit as a function of F and create associated csv file.
#' @param asap name of the variable that read in the asap.rdat file
#' @param a1 list file produced by grab.aux.files function
#' @param nyrs.ave number of years to average for calculating Reference Points
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @export

PlotYieldCurves <- function(asap,a1,nyrs.ave,save.plots,od,plotf){

  nages<- asap$parms$nages
  nyears <- asap$parms$nyears
  if (asap$options$isfecund == 1){
    fec.age <- rep(1, nages)
  }else{
    fec.age <- apply(asap$WAA.mats$WAA.ssb[(nyears-nyrs.ave+1):nyears,],2,mean)
  }
  mat.age <- apply(asap$maturity[(nyears-nyrs.ave+1):nyears,],2,mean)
  wgt.age <- apply(asap$WAA.mats$WAA.catch.all[(nyears-nyrs.ave+1):nyears,],2,mean)
  M.age <- apply(asap$M.age[(nyears-nyrs.ave+1):nyears,],2,mean)
  sel.mat <- asap$F.age[(nyears-nyrs.ave+1):nyears,]/apply(asap$F.age[(nyears-nyrs.ave+1):nyears,],1,max)
  sel.age<- apply(sel.mat,2,mean)
  spawn.time <- asap$options$frac.yr.spawn

  F.range <- seq(0,2.0, by=0.01)
  nF <- length(F.range)
  ypr.vec <- rep(0, nF)
  spr.vec <- rep(0, nF)

  spr0<- s.per.recr(nages=nages, fec.age=fec.age, mat.age=mat.age, M.age= M.age, F.mult=0, sel.age=sel.age, spawn.time=spawn.time)

  for(j in 1:nF) {

    spawn.per.recr = s.per.recr(nages=nages, fec.age=fec.age, mat.age=mat.age, M.age= M.age, F.mult=F.range[j], sel.age=sel.age, spawn.time=spawn.time)
    spr.vec[j] = spawn.per.recr/spr0
    ypr.vec[j] = ypr(nages, wgt.age=wgt.age, M.age=M.age,  F.mult=F.range[j], sel.age=sel.age )
  } # end loop over F

  par(mfrow=c(1,1), mar=c(4,4,2,4) )

  plot(F.range, ypr.vec, type='n', xlab="Full F", ylab="Yield per Recruit", lwd=2,
       col="blue3", ylim=c(0,1.2*max(ypr.vec)))
  abline(v=seq(0.1,2.0, by=0.1), col="grey85")
  lines(F.range, ypr.vec, lwd=2, col="blue3" )
  points(F.range, ypr.vec, pch=19, col="blue3" )
  scale.spr.vec <- max(spr.vec)/max(ypr.vec)

  lines(F.range, spr.vec/scale.spr.vec, col="red", lwd=2 )
  axis(side=4, at=seq(0,1,by=0.1)/scale.spr.vec, lab=seq(0,1,by=0.1), las=2,
       col='black', col.axis="black")
  mtext(side=4, "% SPR", line=3, col="red")
  title (paste0("YPR-SPR Reference Points (Years Avg = ", nyrs.ave,")"), outer=T, line=-1 )

  if (save.plots) savePlot(paste0(od, "YPR.SPR.Curves.", plotf), type=plotf)

  ypr.table <- as.data.frame(matrix(NA, nrow=nF, ncol=3) )
  ypr.table[,1] <- F.range
  ypr.table[,2] <- ypr.vec
  ypr.table[,3] <- spr.vec

  par(mfrow=c(1,1), mar=c(2,2,2,2))
  plot(seq(1,42), seq(-3,38), type='n', axes=F, bty='n',xlab="",ylab="")

  text(x=0,y=36, labels="F", font=2, pos=4)
  text(x=4, y=36, labels="YPR" , font=2, pos=4)
  text(x=9, y=36, labels="SPR", font=2, pos=4 )

  text(x=15,y=36, labels="F", font=2, pos=4)
  text(x=19, y=36, labels="YPR" , font=2, pos=4)
  text(x=24, y=36, labels="SPR", font=2, pos=4 )

  text(x=30,y=36, labels="F", font=2, pos=4)
  text(x=34, y=36, labels="YPR" , font=2, pos=4)
  text(x=39, y=36, labels="SPR", font=2, pos=4 )

  for (i in 1:35) {
    text(x=0, y=seq(35,1, by=-1), labels=F.range[1:35], cex=0.82, pos=4, font=1 )
    text(x=4, y=seq(35,1, by=-1), labels=round(ypr.vec[1:35],4), cex=0.82, pos=4, font=1 )
    text(x=9, y=seq(35,1, by=-1), labels=round(spr.vec[1:35],4), cex=0.82, pos=4, font=1 )
  }
  for (i in 36:70) {
    text(x=15, y=seq(35,1, by=-1), labels=F.range[36:70], cex=0.82, pos=4, font=1)
    text(x=19, y=seq(35,1, by=-1), labels=round(ypr.vec[36:70],4), cex=0.82, pos=4, font=1)
    text(x=24, y=seq(35,1, by=-1), labels=round(spr.vec[36:70],4), cex=0.82, pos=4, font=1)
  }
  for (i in 71:105) {
    text(x=30, y=seq(35,1, by=-1), labels=F.range[71:105], cex=0.82, pos=4, font=1)
    text(x=34, y=seq(35,1, by=-1), labels=round(ypr.vec[71:105],4), cex=0.82, pos=4, font=1)
    text(x=39, y=seq(35,1, by=-1), labels=round(spr.vec[71:105],4), cex=0.82, pos=4, font=1)
  }
  title (paste0("YPR-SPR Reference Points (Years Avg = ", nyrs.ave,")"), outer=T, line=-1 )

  if (save.plots) savePlot(paste0(od, "YPR.SPR.Table.", plotf), type=plotf)

  frep1 <-asap$options$Freport.agemin
  frep2 <-asap$options$Freport.agemax
  if (frep1==frep2) freport <-F.range*sel.age[frep1:frep2]
  if (frep2>frep1) freport <-F.range*mean(sel.age[frep1:frep2])

  asap.name <- a1$asap.name

  ypr.table<- as.data.frame(cbind(F.range, ypr.vec, spr.vec, spr.vec*spr0,freport))
  colnames(ypr.table) <- c("Full.F", "YPR", "SPR", "SSBPR",paste0("Freport_",frep1,"-",frep2))
  write.csv( ypr.table, file=paste0(od,"YPR.Table_",asap.name,".csv"), row.names=F )

  return()
} # end function


library(ggplot2)
# postscript("test.eps")
t<-seq(-3.14,3.14,0.1)
qplot(t,sin(t),color="b",geom="line")+theme(text = element_text(family = 'Times'))
dev.off()
system('cmd /c D:/Program/SumatraPDF/SumatraPDF.exe Rplots.pdf')


#' Create a Supervised Deep Learning Model
#' @importFrom fu make_variable_desc
#' @importFrom keras keras_model_sequential layer_dense %>% compile fit
#' optimizer_adadelta loss_mean_squared_error loss_categorical_crossentropy
#' @export
dglm <- function(data,
                 formula,
                 hidden_layers = integer(),
                 hidden_layers_activation =
                   rep("linear", length(hidden_layers)),
                 hidden_layer_names =
                   paste("hidden_layer", seq_along(hidden_layers), sep = "_"),
                 use_bias = rep(TRUE, length(hidden_layers)),
                 loss = NULL,
                 optimizer = optimizer_adadelta(),
                 metrics = NULL,
                 output_activation = NULL,
                 output_activation_bias = TRUE,
                 batch_size = nrow(data),
                 epochs = 1000,
                 verbose = FALSE,
                 validation_split = 0.2,
                 count_model = FALSE,
                 name = NULL) {

  xf <- model.frame(formula, data)

  var_desc <- make_variable_desc(xf, formula)

  error_on_more_than_one_dep_var(var_desc)
  error_on_no_indep_var(var_desc)
  error_on_conditional_var(var_desc)
  error_on_unsupported_dependent_var(var_desc, c("numeric", "factor"))
  error_on_bad_hidden_layer_desc(hidden_layers, hidden_layers_activation)

  x_train <- make_model_matrix(formula, xf)

  # make sure there is an intercept, if not warning
  mm_column_var_assign <- attributes(x_train)$assign
  column_var_name <- names(xf)
  mm_column_var_name <- colnames(x_train)

  model <-
    create_input_and_hidden_layers(
      x_train,
      hidden_layers,
      hidden_layers_activation,
      hidden_layer_names,
      use_bias,
      name)

  if (var_desc$class[var_desc$role == "dependent"] == "factor") {

   #              categorical_loss = loss_categorical_crossentropy,
   #              continuous_loss = loss_mean_squared_error,
   # output_activation <- "softmax"

    if (is.null(loss)) {
      loss <- loss_categorical_crossentropy
    }
    if (is.null(metrics)) {
      metrics
    }

    if (is.null(output_activation)) {
      output_activation <- "softmax"
    }

    # Are the encodings other than one-hot to consider?
    oh <- make_one_hot(xf[[var_desc$name[var_desc$role == "dependent"]]])

    input_shape <- NULL
    if (length(hidden_layers) == 0) {
      input_shape <- ncol(x_train)
    }

    model %>%
      layer_dense(
          units=length(var_desc$levels[var_desc$role == "dependent"][[1]]),
          input_shape = input_shape,
          name = paste(output_activation, "output", sep = "_"),
          activation = output_activation,
          use_bias = output_activation_bias)

    type <- "categorical_dglm"
    loss <- loss_categorical_crossentropy
    y_train <-
      to_one_hot(xf[[var_desc$name[var_desc$role == "dependent"]]],
                   oh)
  } else if (var_desc$class[var_desc$role == "dependent"] == "numeric") {
    input_shape <- NULL
    if (length(hidden_layers) == 0) {
      input_shape <- ncol(x_train)
    }

    if (is.null(loss)) {
      loss <- loss_mean_squared_error
    }
    model %>%
      layer_dense(units = 1, input_shape = input_shape,
                  name = "continuous_output", use_bias = TRUE,
                  activation = output_activation)

    type <- "continuous_dglm"
    y_train <- as.matrix(xf[[var_desc$name[var_desc$role == "dependent"]]])
  } else {
    stop("Unsupported dependent variable type.")
  }

  if (is.null(metrics)) {
    metrics <- loss
  }

  mm_col_names <- colnames(x_train)

  model %>%
    compile(loss = loss, optimizer = optimizer, metrics = metrics)

  history <- model %>%
    fit(x_train, y_train, batch_size = batch_size, epochs = epochs,
        validation_split = validation_split, verbose = verbose)

  ret <- list(formula = formula,
              hidden_layers = hidden_layers,
              hidden_layers_activation = hidden_layers_activation,
              column_var_name = column_var_name,
              mm_column_var_name = mm_column_var_name,
              mm_column_var_assign = mm_column_var_assign,
              loss = loss,
              var_desc = var_desc,
              model = model,
              history = history,
              mm_col_names = mm_col_names)
  class(ret) <- c(type, "dglm")
  ret
}

#' @export
plot_training_history <- function(x, metrics, smooth, theme_bw) {
  UseMethod("plot_training_history", x)
}

#' @importFrom crayon red
#' @export
plot_training_history.default <- function(x, metrics, smooth, theme_bw) {
  print(red("Don't know how to plot training history for an object of type:",
            paste(class(x), collapse = " ")))
}

#' @importFrom ggplot2 ggplot aes aes_ geom_point scale_shape theme_bw
#' theme_minimal geom_smooth facet_grid element_text scale_x_continuous theme
#' element_blank element_rect
#' @importFrom tools toTitleCase
#' @export
plot_training_history.dglm <- function(x, metrics = NULL,
    smooth = getOption("keras.plot.history.smooth", TRUE),
    theme_bw = FALSE) {

  df <- as.data.frame(x$history)
  if (is.null(metrics))
      metrics <- Filter(function(name) !grepl("^val_", name),
          names(x$history$metrics))
  df <- df[df$metric %in% metrics, ]
  do_validation <- any(grepl("^val_", names(x$history$metrics)))

  names(df) <- toTitleCase(names(df))
  df$Metric <- toTitleCase(as.character(df$Metric))
  df$Data <- toTitleCase(as.character(df$Data))

  int_breaks <- function(x) pretty(x)[pretty(x)%%1 == 0]
  if (do_validation) {
    if (theme_bw) {
      p <- ggplot(df,
                  aes_(~Epoch, ~Value, color = ~Data, fill = ~Data,
                       linetype = ~Data, shape = ~Data))
    } else {
      p <- ggplot(df, aes_(~Epoch, ~Value, color = ~Data, fill = ~Data))
    }
  } else {
    p <- ggplot(df, ggplot2::aes_(~Epoch, ~Value))
  }
  smooth_args <- list(se = FALSE, method = "loess", na.rm = TRUE)
  if (theme_bw) {
    smooth_args$size <- 0.5
    smooth_args$color <- "gray47"
    p <- p +
      theme_bw() +
      geom_point(col = 1, na.rm = TRUE, size = 2) +
      scale_shape(solid = FALSE)
  }
  else {
    p <- p + geom_point(shape = 21, col = 1, na.rm = TRUE)
  }
  if (smooth && x$history$params$epochs >= 10) {
    p <- p + do.call(geom_smooth, smooth_args)
  }
  p + facet_grid(Metric ~ ., switch = "y", scales = "free_y") +
    scale_x_continuous(breaks = int_breaks) +
    theme_minimal() +
    theme(axis.title.y = element_blank(),
          strip.placement = "outside",
          strip.text = element_text(colour = "black", size = 11),
          strip.background = element_rect(fill = NA, color = NA))
}


#Script to read in the data output from traffic_times.py and plot the average
#travel durations at each 10 minute interval across the three model types

traffic=read.csv('schaumburg_traffic.csv')

traffic$time = paste(traffic$hour,traffic$minute,sep='.')
traffic$time_nb = as.numeric(traffic$time)
traffic$time = factor(traffic$time)
traffic$new_day = ifelse(traffic$weekday==0,'Monday',
						ifelse(traffic$weekday==1,'Tuesday',
						ifelse(traffic$weekday==2,'Wednesday',
						ifelse(traffic$weekday==3,'Thursday',
						'Friday'))))

traffic$new_day=factor(traffic$new_day)
time_means = aggregate(duration~travel_type+model+time_nb,data=traffic,mean)
time_means$time_nb = as.numeric(time_means$time)

best_guess_t = time_means[time_means$model=="best_guess"&time_means$travel_type=="to_work",]
pessimistic_t = time_means[time_means$model=="pessimistic"&time_means$travel_type=="to_work",]
optimistic_t = time_means[time_means$model=="optimistic"&time_means$travel_type=="to_work",]

best_guess_f = time_means[time_means$model=="best_guess"&time_means$travel_type=="from_work",]
pessimistic_f = time_means[time_means$model=="pessimistic"&time_means$travel_type=="from_work",]
optimistic_f = time_means[time_means$model=="optimistic"&time_means$travel_type=="from_work",]

xrange_t = range(time_means$time_nb[time_means$travel_type=="to_work"])
yrange_t = range(time_means$duration[time_means$travel_type=="to_work"])

xrange_f = range(time_means$time_nb[time_means$travel_type=="from_work"])
yrange_f = range(time_means$duration[time_means$travel_type=="from_work"])

plot.new()
par(mfrow=c(1,2))

plot(xrange_t,yrange_t,type="n", xlab="Time(Hour:Minute)", ylab="Duration(Minutes)",lwd=1.5, col=1,xaxt="n")
axis(1, at=time_means$time_nb[time_means$travel_type=="to_work"], las=2)
lines(pessimistic_t$time, pessimistic_t$duration, type="b", lwd=1.5, col=1)
lines(best_guess_t$time, best_guess_t$duration, type="b", lwd=1.5, col=2)
lines(optimistic_t$time, optimistic_t$duration, type="b", lwd=1.5, col=3)
title("Travel Times To Schaumburg")

plot(xrange_f,yrange_f,type="n", xlab="Time(Hour:Minute)", ylab="Duration(Minutes)",lwd=1.5, col=1,xaxt="n")
axis(1, at=time_means$time_nb[time_means$travel_type=="from_work"], las=2)
lines(pessimistic_f$time, pessimistic_f$duration, type="b", lwd=1.5, col=1)
lines(best_guess_f$time, best_guess_f$duration, type="b", lwd=1.5, col=2)
lines(optimistic_f$time, optimistic_f$duration, type="b", lwd=1.5, col=3)

title("Travel Times From Schaumburg")


#!/usr/bin/env Rscript

#======================
# script to sort the input locus pairs according to their genomic distance (ascending order)
# required for spline fitting
#======================

args <- commandArgs(TRUE)

InpFile <- args[1]
OutFile <- args[2]

tempDistFile <- paste0(dirname(OutFile), '/temp_Genomic_Distance.bed')
system(paste0("awk -F[\'\t\'] \'function abs(v) {return v < 0 ? -v : v} {if (NR>1) {print abs($5-$2)}}\' ", InpFile, " | sort -k1,1n | uniq > ", tempDistFile))

# copy the first line in the output file
system(paste("awk \'{if (NR==1) {print $0}}\' ", InpFile, " > ", OutFile))

DistData <- read.table(tempDistFile, header=F, sep="\t", stringsAsFactors=F)
DistValues <- sort(as.integer(DistData[,1]))

# temp_Dist_LocusPairFile <- paste0(dirname(OutFile), '/temp_Dist_LocusPair.bed')
for (i in 1:length(DistValues)) {
	currDist <- DistValues[i]
	cat(sprintf("\n Processing distance value for sorting locus pairs based on interaction distance: %s ", currDist))

	system(paste0("awk -F[\'\t\'] \'function abs(v) {return v < 0 ? -v : v} {if ((NR>1) && (abs($5-$2) == ", currDist, ")) {print $0}}\' ", InpFile, " | sort -k7,7nr >> ", OutFile))

}	# end distance value loop

system(paste("rm", tempDistFile))
# system(paste("rm", temp_Dist_LocusPairFile))


ctd_bin_calculate <- function(data, binSize = 1, imageVolume, rev = FALSE){

  # browser()
  cast_id <-unique(data$cast_id)

  cast_id <-unique(data$cast_id)
  max_cast_depth <- max(data$depth) # ADDED BY KS TO IDENTIFY EACH TOWYO CHUNK

  p <- data$depth
  max_depth <- max(p, na.rm = TRUE)
  min_depth <- min(p, na.rm = TRUE)
  x_breaks <- seq(from = floor(min_depth), to = ceiling(max_depth), by = binSize)
  if (rev == TRUE){
    x_breaks <- seq(from = ceiling(max_depth), to = floor(min_depth), by = - binSize) #reversed by KS
  }

  # error when cast is too small
  if(max_depth - min_depth < binSize){
    warning(paste('Cast', cast_id, 'is too small to calculate information for bins of size', binSize))
    data.frame(NULL)
  }else{

    # Get variables of interest using oce bin functions

    min_time_s <- oce::binApply1D(p, data$time/1000, xbreaks = x_breaks, min)$result
    max_time_s <- oce::binApply1D(p, data$time/1000, xbreaks = x_breaks, max)$result
    min_depth <- oce::binApply1D(p, data$depth, xbreaks = x_breaks, min)$result
    max_depth <- oce::binApply1D(p, data$depth, xbreaks = x_breaks, max)$result
    # n_roi_bin <- oce::binApply1D(p, data$n_roi, xbreaks = x_breaks, sum)$result
    temperature <- oce::binApply1D(p, data$temperature, xbreaks = x_breaks, mean)$result
    salinity <- oce::binApply1D(p, data$salinity, xbreaks = x_breaks, mean)$result
    density <- oce::binApply1D(p, data$sigmaT, xbreaks = x_breaks, mean)$result
    fluorescence <- oce::binApply1D(p, data$fluorescence_mv, xbreaks = x_breaks, mean)$result
    turbidity <- oce::binApply1D(p, data$turbidity_mv, xbreaks = x_breaks, mean)$result
    avg_hr <- oce::binApply1D(p, data$time/(1000*3600), xbreaks = x_breaks, mean)$result
    if (rev == TRUE){

      depth <- rev(oce::binApply1D(p, data$depth, xbreaks = x_breaks, mean)$xmids)

    }else{ # simplify?

      depth <- oce::binApply1D(p, data$salinity, xbreaks = x_breaks, mean)$xmids

    }
    # calculates number of frames captured per depth bin by counting number of pressure observations per bin
    n_frames <- oce::binApply1D(p, data$depth, xbreaks = x_breaks, length)$result # KS edit 10/9/19

    # WARNING
    # binApply1D does not calculate NAs, if there is binned depth range that does
    # not contain any data, the binApply function will not create an empty or NA
    # placeholder bin in that case the result length will be different than the
    # length of midpoints since the variable "pressure" is a mid point calculation it is used to
    # test for non existent empty bins. If there are non existant empty bins,
    # binMean1D will calculate them as NA, this loop finds where the bins would
    # have been located and removes those indexes from the pressure vector so the
    # length of variables is all identical

    if (!(length(depth) == length(salinity))) {

      salinity_mean <- binMean1D(p, data$salinity, xbreaks = x_breaks)$result

      idx_rm <- which(is.na(salinity_mean))

      # informs user where bins were removed due to NAs
      # note if a bin is 'NA' typically because there is no valid data in that depth range,
      # if you have a lot of NA bins, think about increasing your binSize
      message(paste('Removed bins at', depth[idx_rm]))

      lp <- length(depth)
      depth <- depth[-idx_rm]
      if (length(n_frames) == lp){
        n_frames <- n_frames[-idx_rm]
      }

    }
    # make sure n_frames matches the length of other data frame rows
    if (length(n_frames) > length(depth)){
      n_frames <- n_frames[-length(n_frames)]
    }
    if( length(n_frames) < length(depth)){
      n_frames <- c(n_frames, 0)
    }
    if (length(n_frames) != length(depth)){
      length(n_frames) <- length(depth)
    }
    # Get derived variables

    time_diff_s <- max_time_s - min_time_s

    # calculate concentration based on opticalSetting

    # "Old way" of calculating concentration assuming constant frame rate of 15 fps
    # conc_m3 <- n_roi_bin/((imageVolume/1e09)*(15)*(time_diff_s)) #

    # "New way" of calculating concentration by summing volume associated with frames over depth bin
    vol_sampled_bin_m3 <- (imageVolume/1e09)*n_frames
    #conc_m3 <- n_roi_bin/(vol_sampled_bin_m3) # KS edit 10/9/19

    depth_diff <- max_depth - min_depth

    # Output
    data.frame(depth, min_depth, max_depth, depth_diff, min_time_s, max_time_s, time_diff_s,
               # n_roi_bin, conc_m3,
               temperature, salinity, density, fluorescence, turbidity, avg_hr, n_frames, vol_sampled_bin_m3,
               towyo = cast_id, max_cast_depth) # MAX CAST PRESSURE ADDED BY KS
  } # end else loop for size error
}


# update:2022.01.15
library(shiny)
library(shinydashboard)
library(plotly)

sidebarPanel2 <- function (..., out = NULL, width = 4)
{
  div(class = paste0("col-sm-", width),
      tags$form(class = "well", ...),
      out
  )
}

theme_basic <- function() {
  fill.colour <- "white"
  theme_classic() +
    theme(plot.background    = element_rect(fill = fill.colour)) +
    theme(panel.background   = element_rect(fill = fill.colour)) +
    theme(panel.grid.major   = element_line(colour = "grey95")) +
    theme(panel.grid.major.x = element_blank()) +
    theme(axis.line          = element_blank()) +
    theme(axis.ticks.x       = element_blank()) +
    theme(axis.ticks.y       = element_line(colour = "grey95")) +
    theme(text               = element_text(colour = "grey20"))
}
#------------ ui-app.R ------------ ---
#------------ ui-header & sidebar -----
header <- dashboardHeader(title = "Probability")
sidebar <- dashboardSidebar(width = NULL,disable = FALSE,## 可以把邊邊關起來
                            sidebarMenu(
                              menuItem("Summary", tabName = "Page0", icon = icon("list")),
                              menuItem("Basic Probability", tabName = "Page1", icon = icon("list")),
                              menuItem("Discrate", tabName = "Page2", icon = icon("chart-bar")),
                              menuItem("Continuous", tabName = "Page3", icon = icon("chart-area"))
                              # menuItem("About",tabName = "final", icon = icon("address-card"))
                              # ref of icon : https://fontawesome.com/v5.15/icons
                            ))
#------------ ui-Body content -----
body <- dashboardBody(
  tags$head(tags$style(HTML('
                            /* logo */
                            .skin-blue  .main-header .logo {
                            background-color: #204969;
                            font-family: "monospace", Times, "Times New Roman", serif;
                            font-weight: bold;
                            font-size: 24px;
                            }
                             /* logo when hovered */
                            .skin-blue  .main-header .logo:hover {
                            background-color: #FFB6C1;
                            }
                            /* navbar (rest of the header) */
                            .skin-blue .main-header .navbar {
                            background-color: #f4b943;
                            }
                            /* main sidebar */
                            .skin-blue .main-sidebar {
                            background-color: #204969;
                            font-size: 16px;
                            }
                            /* body */
                            .content-wrapper, .right-side {
                            background-color: #fff7f7;
                            }
                            /* boxboxbox */
                            ') #HTML
                       ) # tags$style
            ), #tags$head
  tabItems(
    #-------------- Page0 -------------
    tabItem(tabName = "Page0",
            # Boxes need to be put in a row (or column)
            fluidRow(
              box(title = "Definitions",width = 12,
                  solidHeader = FALSE,
                  collapsible = FALSE,
                  uiOutput("summary")
                  ) # box
            ) # fluidRow
    ), # tabItem
    #-------------- Page1 -------------
    tabItem(tabName = "Page1",
            fluidRow(
              box(title = "Flipping a coin", width = 6,
                  collapsible = FALSE,
                  sidebarPanel2(
                               out = h6("A classic example of a probabilistic experiment is a fair coin toss,
                                        in which the two possible outcomes are heads or tails. In this case,
                                        The probability of flipping a head or a tail is 1/2."),
                               "Flip the coin:",
                               # sliderInput("n_coin","number",
                               #             value = 1,
                               #             min = 1,
                               #             max = 1000),
                               hr(),
                               actionButton("action1", "Flip the coin"),
                               hr(),
                               actionButton("action2", "Flip 100 times")
                  ), # sidebarPanel2
                  mainPanel(plotOutput("plot_coin"))
                  ),
              box(title = "Rolling a dice", width = 6,
                  collapsible = FALSE,
                  sidebarPanel(width = 4,
                               "Roll the dice:",
                               sliderInput("n_dice","number",
                                           value = 1,
                                           min = 1,
                                           max = 1000)
                  ),
                  mainPanel(plotOutput("plot_dice"))
              )
            )
            # ,
            # fluidRow(
            #   box(title = "coin", width = 6,
            #       collapsible = FALSE,
            #       tableOutput("data_coin")
            #   )
            # )

    ),
    #-------------- Page2 -------------
    tabItem(tabName = "Page2",
            # #----------- radioButtons ----------------------
            # fluidRow(
            #   box(title = "Discrate",width = 4,
            #       status = "warning",
            #       solidHeader = FALSE,
            #       collapsible = FALSE,
            #       "Choose one of the following major discrete distributions.",
            #       br(),
            #       radioButtons("dist1", "Distribution type:",
            #                    c("Binomial","Negative Binomial",
            #                      "Geometric","Poisson"))
            #   ),
            #   box(title = "Definitions",width = 8,
            #       status = "warning",
            #       solidHeader = FALSE,
            #       collapsible = FALSE,
            #       uiOutput("txt1")
            #       # htmlOutput("txt1")
            #       # verbatimTextOutput("txt1")
            #   )
            # ),
            #----------- bin ------------------------------------
            fluidRow(
              box(title = "Binomial", width = 6,
                  status = "warning",
                  collapsible = TRUE,
                  sidebarPanel(width = 4,
                               sliderInput("n","number",
                                           value = 10,
                                           min = 10,
                                           max = 100),
                               sliderInput("p",
                                           "Probability",
                                           value = 0.6,
                                           min = 0,
                                           max = 1)
                  ),
                  mainPanel(plotOutput("plot_bin1"))
              ),
              #----------- nb ------------------------------------
              box(title = "Negative Binomial",width = 6,
                  status = "warning",
                  solidHeader = FALSE,
                  collapsible = TRUE,
                  sidebarPanel(width = 4,
                               sliderInput("r","number",
                                           value = 10,
                                           min = 1,
                                           max = 100),
                               sliderInput("p_nb","Probability",
                                           value = 0.6,
                                           min = 0,
                                           max = 1)),
                  mainPanel(plotOutput("plot_nb1")))
            ),
            #----------- geo ------------------------------------
            fluidRow(
              box(title = "Geometric",width = 6,
                  status = "warning", solidHeader = FALSE,
                  collapsible = TRUE,
                  sidebarPanel(width = 4,
                               sliderInput("p_geo","Probability",
                                           value = 0.6,
                                           min = 0.1,
                                           max = 1)
                  ),
                  mainPanel(plotOutput("plot_geo1"))
              ),
              #----------- Poi ------------------------------------
              box(title = "Poisson",width = 6,
                  status = "warning", solidHeader = FALSE,
                  collapsible = TRUE,
                  sidebarPanel(width = 4,
                               sliderInput("lambda","lambda",
                                           value = 2,
                                           min = 0.1,
                                           max = 50)
                  ),
                  mainPanel(plotOutput("plot_poi1"))
              )
            )
    ),
    #-------------- Page3 -------------
    tabItem(tabName = "Page3",
            # fluidRow(
            #   box(title = "Continuous",width = 4,
            #       solidHeader = FALSE,
            #       collapsible = FALSE,
            #       "Choose one of the following major continuous distributions.",
            #       br(),
            #       radioButtons("dist2", "Distribution type:",
            #                    c("Uniform","Exponential","Normal"))
            #       ),
            #   box(title = "Definitions",width = 8,solidHeader = FALSE,
            #       collapsible = FALSE,
            #       uiOutput("txt2")
            #   )
            # ),
            #----------- unif ------------------------------------
            fluidRow(
              box(title = "Uniform", width = 6,
                  collapsible = TRUE,
                  sidebarPanel(width = 4,
                               # numericInput("min", "Minimum", 2),
                               # numericInput("max", "Maximum", 5)
                               sliderInput("unifRange", "Range",
                                           min = 0, max = 20,
                                           value = c(2, 5))
                               ),
                  mainPanel(plotOutput("plot_unif1"))
              ),

              #----------- Exponential  ------------------------------------
              box(title = "Exponential ",width = 6,
                  solidHeader = FALSE,
                  collapsible = TRUE,
                  sidebarPanel(width = 4,
                               sliderInput("lambda2","lambda",
                                           value = 2,
                                           min = 0.1,
                                           max = 5,
                                           step = 0.1)
                               ),
                  mainPanel(plotOutput("plot_exp1")))
            ),
            #----------- Normal ------------------------------------
            fluidRow(
              box(title = "Normal", width = 6,
                  collapsible = TRUE,
                  sidebarPanel(width = 4,
                               sliderInput("mu","mu",
                                           value = 175,
                                           min = 0,
                                           max = 200,
                                           step = 0.1),
                               sliderInput("sigma","sigma",
                                           value = 6,
                                           min = 0.1,
                                           max = 50,
                                           step = 0.1)
                               ),
                  mainPanel(plotOutput("plot_norm1"))
                  )
              )
    ),
    #-------------- final -------------
    tabItem(tabName = "final",
            # fluidRow(
            #   column(width = 4,
            #          box(
            #            title = "Updata:2022/01/07", width = NULL, solidHeader = TRUE, status = "warning"
            #          )
            #   )
            # ),
            fluidRow(
              infoBox("Updata", "2022/01/07", icon = icon("edit"), fill = FALSE,color = "light-blue")
            ) # fluidRow
    ) #tabItem
  ) # tabItems
) # dashboardBody
#------------ ui -----
ui <- dashboardPage(header, sidebar, body)

#------------ server -----
server <- function(input, output, session) {
  #------------ txt0 -----
  output$summary <- renderUI({
    withMathJax(includeHTML("dis_formula\\Summary.html"))
  })
  #------------ coin ------------
  # https://ithelp.ithome.com.tw/articles/10196754
  ##
  v <- reactiveValues(times = NULL)
  observeEvent(input$action1, {
    v$times <- trunc(runif(1, min = 1, max = 3))
  })
  observeEvent(input$action2, {
    v$times <- trunc(runif(100, min = 1, max = 3))
  })

  output$plot_coin <- renderPlot({
    if (is.null(v$times)) return()
    # count <- table(trunc(runif(1, min = 1, max = 3)))
    count <- table(v$times)
    sums <- integer(2)
    if(nrow(count)>1){
      sums <- count
    }else{
      ifelse(names(count)=="1",
             sums[1] <- as.numeric(count),
             sums[2] <- as.numeric(count))
    }

    # count <- as.numeric(table(trunc(runif(1, min = 1, max = 3))))[1:2]
    # count <- as.numeric(table(v$times))[1:2]
    # count[which(is.na(count))] <- 0

    dice <- data.frame(number = c("Heads","Tails"),
                       count = sums) %>%
      mutate(p = (count / sum(count)), theoretical = (1/2))

    title <- paste("Probability Distribution of coin")
    ggplot(dice) + theme_basic() +
      geom_bar(aes(x = number, y = p),
               stat = "identity", position = "dodge",
               fill = c("#a2d2ff","#bee1e6"))+
      ggtitle(title)+
      geom_hline(yintercept=1/2, linetype="dashed", color = "red")+
      # scale_x_continuous(labels = 1:2, breaks = 1:2)+
      scale_y_continuous(limits = c(0, max(dice$p)+0.05),
                         breaks = seq(0, max(dice$p)+0.05, by = 0.1))
  })
  # output$plot_coin <- renderPlot({
  #   sums <- integer(2)
  #   for (i in 1:input$n_coin) {
  #     # "roll" number between 1 and 6; add together
  #     outcome <- trunc(runif(1, min = 1, max = 3))
  #     # count result
  #     sums[outcome] <- sums[outcome] + 1
  #   }
  #   # prepare a data frame for graphing
  #   dice <- data.frame(number = c("Heads","Tails"), count = sums[1:2]) %>%
  #     mutate(p = (count / sum(count)), theoretical = (1/2))
  #
  #
  #   title <- paste("Probability Distribution of coin")
  #   ggplot(dice) + theme_basic() +
  #     geom_bar(aes(x = number, y = p),
  #              stat = "identity", position = "dodge",
  #              fill = c("#ff9e00","#00b4d8"))+
  #     ggtitle(title)+
  #     # scale_x_continuous(labels = 1:2, breaks = 1:2)+
  #     scale_y_continuous(limits = c(0, max(dice$p)+0.05),
  #                        breaks = seq(0, max(dice$p)+0.05, by = 0.1))
  # })

  # https://stackoverflow.com/questions/61287106/how-to-create-a-table-in-a-reactive-object-in-shiny

  # output$data_coin <- renderTable({
  #   tableData$d1
  # })

  #------------ dice ------------
  output$plot_dice <- renderPlot({
    sums <- integer(6)
    for (i in 1:input$n_dice) {
      # "roll" number between 1 and 6; add together
      outcome <- trunc(runif(1, min = 1, max = 7))
      # count result
      sums[outcome] <- sums[outcome] + 1
    }
    # prepare a data frame for graphing
    dice <- data.frame(number = 1:6, count = sums[1:6]) %>%
      mutate(p = (count / sum(count)), theoretical = (1/6))

    title <- paste("Probability Distribution of dice")
    ggplot(dice) + theme_basic() +
      geom_bar(aes(x = number, y = p),
               stat = "identity", position = "dodge",
               fill = c("#cdb4db","#ffc8dd","#ffafcc","#bde0fe","#a2d2ff","#bee1e6"))+
      ggtitle(title)+
      scale_x_continuous(labels = 1:6, breaks = 1:6)+
      scale_y_continuous(limits = c(0, max(dice$p)),
                         breaks = seq(0, max(dice$p), by = 0.05))+
      geom_hline(yintercept=1/6, linetype="dashed", color = "red")
  })
  #------------ button -------
  ## ## 以下為反應分配按鈕，程式碼過長
  ## n  <- 0
  ## observe({
  ##   dist1 <- input$dist1
  ##   n <- n+1
  ##   if (!is.null(dist1)) {
  ##     if (dist1=='dummy')  showActions ()
  ##     else {
  ##       if (dist1=='Binomial')
  ##         output$txt1  <- renderUI({
  ##           withMathJax(paste(input$dist1,"\n",
  ##                 "$$f(x)=\\binom{n}{x}p^{x}(1-p)^{n-x}$$","\n",
  ##                 "$$\\text{E}(X)=np$$","\n",
  ##                 "$$\\text{Var}(X)=np(1-p)$$"))
  ##
  ##         })
  ##       if (dist1=='Negative Binomial')
  ##         output$txt1  <- renderUI({
  ##           withMathJax(paste(input$dist1,"\n",
  ##                             "$$f(x)=\\binom{x+r-1}{r-1}p^{r}(1-p)^{x}$$","\n",
  ##                             "$$\\text{E}(X)=\\frac{rp}{1-p}$$","\n",
  ##                             "$$\\text{Var}(X)=\\frac{rp}{(1-p)^2}$$"))
  ##
  ##         })
  ##       if (dist1=='Geometric')
  ##         output$txt1  <- renderText (paste (input$dist1, "action C"))
  ##       if (dist1=='Poisson')
  ##         output$txt1  <- renderText (paste (input$dist1, "action C"))
  ##     }
  ##   }
  ## })

  #------------ txt1 -----
  output$txt1 <- renderUI({
    ## 會無法出現表格
    ## withMathJax(includeMarkdown(paste0("C:\\Users\\user\\R\\R_2021\\prob\\dis_formula\\",input$dist1,".md")))

    # withMathJax(includeHTML(paste0("C:\\Users\\user\\R\\R_2021\\prob\\dis_formula\\",input$dist1,".html")))
    withMathJax(includeHTML(paste0("dis_formula\\",input$dist1,".html")))
  })
  #------------ txt2 -----
  output$txt2 <- renderUI({
    ## withMathJax(includeMarkdown(paste0("C:\\Users\\user\\R\\R_2021\\prob\\dis_formula\\",input$dist1,".md")))

    # withMathJax(includeHTML(paste0("C:\\Users\\user\\R\\R_2021\\prob\\dis_formula\\",input$dist2,".html")))

    withMathJax(includeHTML(paste0("dis_formula\\",input$dist2,".html")))
    })
  #------------ Bin(n,p) #####
  output$plot_bin1 <- renderPlot({
    x <- seq(from = 0,to = input$n,by = 1) #成功次數
    plot(x,dbinom(x,size = input$n, prob=input$p), #
         pch=16,type="h", #type='l'
         main = paste("Binomial ( n=",input$n,", p=",input$p,")"),
         ylab='Probability',
         xlab ='x',
         lwd=4,
         col="deepskyblue")
  })
  #------------ NB(r,p) #####
  output$plot_nb1 <- renderPlot({
    x <- seq(from = 0,to = input$r,by = 1) #成功次數
    plot(x,dbinom(x,size = input$r, prob=input$p_nb), #
         pch=16,type="h",
         main = paste("Negative Binomial ( r=",input$r,", p=",input$p_nb,")"),
         ylab='Probability',
         xlab ='x',
         lwd=4,
         col="deepskyblue")
  })
  #------------ geo(p) #####
  output$plot_geo1 <- renderPlot({
    x <- seq(from = 0,to = 30,by = 1)
    plot(x,dgeom(x, prob=input$p_geo), #
         type = 'h',
         main = paste("Geometric ( p=",input$p_geo,")"),
         ylab = 'Probability',
         xlab = 'x',
         lwd=4,
         col="deepskyblue")
  })
  #------------ Poisson (λ) #####
  output$plot_poi1 <- renderPlot({
    x <- seq(from = 0,to = 30,by = 1)
    plot(x,dpois(x, lambda = input$lambda), #
         type = 'h', #type='o'
         main = paste("Poisson ( λ=",input$lambda,")"),
         ylab = 'Probability',
         xlab = 'x',
         lwd=4,
         col="deepskyblue")
  })
  #------------ unif (a,b) #####
  output$plot_unif1 <- renderPlot({

    # x <- seq(from = input$min-0.5,to = input$max+0.5, length=100)
    # plot(x,dunif(x,input$min,input$max),
    #      type = 'l',pch=16,
    #      main = paste("Unif ( a=",input$min,",","b=",input$max,")"),
    #      ylab = 'density',
    #      xlab = 'x',
    #      col="deepskyblue",
    #      lwd="4")

    x <- seq(from = min(input$unifRange)-3,to = max(input$unifRange)+3, length=100)
    plot(x,dunif(x,min(input$unifRange),max(input$unifRange)),
         type = 'l',pch=16,
         main = paste("Unif ( a=",min(input$unifRange),",","b=",max(input$unifRange),")"),
         ylab = 'density',
         xlab = 'x',
         col="deepskyblue",
         lwd="4")
  })
  #------------ exp (λ) ------------
  output$plot_exp1 <- renderPlot({

    x <- seq(from = min(rexp(100,input$lambda2)),to = max(rexp(100,input$lambda2)), by=0.01)
    plot(x,dexp(x,input$lambda2),
         type = 'l',pch=16,
         main = paste("Exp ( λ=",input$lambda2,")"),
         ylab = 'density',
         xlab = 'x',
         col="deepskyblue",
         lwd="4")
  })
  #------------ N(μ,σ) #####
  output$plot_norm1 <- renderPlot({
    x <- seq(from = min(rnorm(100,input$mu,input$sigma)), to = max(rnorm(100,input$mu,input$sigma)), by = 0.1)
    plot(x, dnorm(x,input$mu,input$sigma), type = "l",
         ylab = "density",
         main = paste("Normal ( μ=",input$mu,",σ=",input$sigma,")"),
         xlab = 'x',
         col="deepskyblue",
         lwd="4")
  })
}
shinyApp(ui, server)


# testing JAGS approaches for random study effects.

library(data.table)
library(doParallel)
source('NEFI_functions/tic_toc.r')
source('NEFI_functions/crib_fun.r')
source('NEFI_functions/sd_to_precision.r')
source('NEFI_functions/precision_matrix_match.r')
source('paths.r')
source('paths_fall2019.r')

#detect and register cores.
n.cores <- detectCores()
registerDoParallel(cores=n.cores)

# read in data
y.all <- readRDS(delgado_ramirez_abun.path)
d <- readRDS(delgado_ramirez_bahram_mapping.path)
d <- d[d$source != "Bahram",]

# set predictors
preds <- c("new.C.5","ph","forest","NPP","map","mat","relEM","ndep.glob","study_id")
#preds <- c("study_id","ph","map")
# format data
x <- d
rownames(x) <- x$sampleID

# subset to predictors
x <- x[,colnames(x) %in% preds]
#x <- x[1:400,] # testing

x$map <- x$map/1000
intercept <- rep(1, nrow(x))
x <- cbind(intercept, x)

#fit model using function.
#allfits <- foreach(i = 1:length(y.all)) %dopar% {
i <- 18
y <- y.all[[i]]
y <- as.data.frame(y)
x <- x[complete.cases(x),]
y <- y[complete.cases(y),]
x <- x[rownames(x) %in% rownames(y),]
y <- y[rownames(y) %in% rownames(x),]
y <- y[match(rownames(x), rownames(y)),] #order abundance table to match the metadata file
if(!sum(rownames(y) == rownames(x)) == nrow(y)){
  cat('Warning. x and y covariates not in the same order!')
}

# study_id as list
study_id <- as.integer(as.factor(x$study_id))
x$study_id <- NULL

# x <- fastDummies::dummy_cols(x,remove_first_dummy = T)
# x$study_id <- NULL
# x <- apply(x, 2, as.numeric)

new.preds <- colnames(x)[!colnames(x) %in% c("y[, i]")]

# set up the would-be function arguments
y=y;x_mu=x;
adapt = 100; burnin = 100; sample = 100;
parallel = T; parallel_method="simple"
silent.jags = F
n.chains = 3
x_sd = NA
jags.path = "/share/pkg.7/jags/4.3.0/install/bin/jags"

#grab names
y.names <- colnames(y)
x.names <- colnames(x_mu)
#make sd objects if they were not supplied.
if(is.na(x_sd)){x_sd = data.frame(rep(1,nrow(x_mu)))}
#Match up predictors and their SD. if no SD supplied we assign ~perfect precision.
x_sd <- precision_matrix_match(x_mu,x_sd)
#covert sd to precision. output is matrix.
x_precision <- sd_to_precision(x_sd)
#make sure every else is a matrix.
y <- as.matrix(y)
x_mu <- as.matrix(x_mu)

###setup jags data object.
jags.data <- list(N = nrow(y),
                  N.spp = ncol(y), #number of observations and number of species
                  N.preds = ncol(x_mu),         #number of x predictors
                  x = x_mu,                     #x-value mean matrix
                  y = y,
                  N.study = length(unique(study_id)),
                  study_id = study_id
                  )                        #species matrix, y

###specify JAGS model.
jags.model = "
model {

#parameter priors for each species.
alpha ~ dnorm(0, .01)

for(i in 1:N.preds){
x.mm[i,1] <- 0
for (j in 2:N.spp) {
x.mm[i,j] ~ dnorm(0, .01)
}
}

#prior for study tau:
study_tau ~ dgamma(0.01, 0.01)

#random study effects
for(s in 1:N.study){
for(j in 1:N.spp){
study_effect[s,j] ~ dnorm(0, study_tau)
}
}

#mean center all predictors (except intercept).
for(i in 1:N){
x.center[i,1] <- 1
for(j in 2:N.preds){
x.center[i,j] <- x[i,j] - mean(x[,j])
}
}

#save mean values for back transforming intercept values.
for(j in 1:N.preds){x.center.save[j] <- mean(x[,j])}

#fit species abundances as a linear combination of predictors and parameters.
for(i in 1:N){
for(j in 1:N.spp){
log(a0[i,j]) <- alpha + inprod(x.mm[,j], x.center[i,]) + study_effect[study_id[i],j]
}
y[i,1:N.spp] ~ ddirch(a0[i,1:N.spp])
}

#map to original parameterization, assuming first column of predictors is intercept.
for (j in 1:N.spp) {
x.m[1,j] <- alpha + x.mm[1,j] - inprod(x.mm[2:N.preds,j], x.center.save[2:N.preds])
for (i in 2:N.preds){
x.m[i,j] <- x.mm[i,j]
}
}

} #close model loop.
"

###Fit JAGS model.
#parallel or not parallel.
run.method = parallel_method
path <- jags.path

tic()
#run jags model.
jags.out <- runjags::run.jags(   model = jags.model,
                                 data = jags.data,
                                 adapt = adapt,
                                 burnin = 200,
                                 sample = 200,
                                 n.chains = n.chains,
                                 #method = run.method,
                                 method = 'simple', # necessary for Rstudio on SCC
                                 silent.jags = silent.jags,
                                 monitor = c('x.m','x.mm','alpha','deviance','study_effect','study_tau'),
                                 jags = jags.path)
toc()
#summarize output
out <- summary(jags.out)

#grab parmeters by species, make a list of species-parameter dataframes
output.list <- list()
for(i in 1:ncol(y)){
  z <- out[grep("^x\\.m\\[",rownames(out), value = T),]
  z <-   z[grep(paste0(',',i,']'),rownames(z)),]
  names <- c(x.names)
  z <- cbind(names,z)
  colnames(z)[1] <- 'predictor'
  output.list[[i]] <- data.frame(z)
}
names(output.list) <- y.names

#get x.mm and alpha means for calculating pD later.
x.mm <- out[grep('x.mm', rownames(out)),4]
dim(x.mm) <- c(length(x.names), ncol(y))
alpha <- out[grep('alpha', rownames(out)), 4]
study_tau <- out[grep('study_tau', rownames(out)), 4]
study_effects <- out[grep('study_effect', rownames(out)), 4]

#get the matrix of predicted y values.
super.x <- cbind(x_mu)
#super.x <- x_mu
pred.list <- list()
for(i in 1:ncol(y)){
  index <- paste0("study_effect[",study_id,",",i,"]")
  eff <- study_effects[which(names(study_effects) %in% index)]
  pred <- exp(as.matrix(super.x) %*% as.numeric(as.character(output.list[[i]][,5])) + eff[study_id])
  pred.list[[i]] <- pred
}
#
# pred.list <- list()
# for(i in 1:ncol(y)){
#   pred.list.list <- list()
#    for (n in 1:nrow(y)){
#    vals <- as.matrix(super.x)[n,1:3]
#    params <- as.numeric(as.character(output.list[[i]][,5]))
#    study_effect <- study_effects[super.x[n,4]]
# # vals <- as.matrix(super.x)[n,1:9]
# # params <- as.numeric(as.character(output.list[[i]][,5]))
# pred <- params[1] * vals[1] +
#   params[2] * vals[2] +
#   params[3] * vals[3] + study_effect
# #   params[4] * vals[4] +
# #   params[5] * vals[5] +
# #   params[6] * vals[6] +
# #   params[7] * vals[7] +
# #   params[8] * vals[8] +
# #   params[9] * vals[9] +
#  pred.list.list[[n]] <- exp(pred) #+ study_effects[super.x[,10]]
#    }
# #   pred.list.list[[i]] <- pred.list
# pred.list[[i]] <- pred.list.list
#
# }
# predicted <- (cbind(as.numeric(pred.list.list[[1]]),
#                     as.numeric(pred.list.list[[2]])))
# predicted <- predicted / rowSums(predicted)
#
#
#
#   pred.list.list <- list()
#   for(i in 1:ncol(y)){
#     pred.list <- list()
#
#     for (n in 1:nrow(y)){
#     vals <- as.matrix(super.x)[n,1:9]
#     params <- as.numeric(as.character(output.list[[i]][,5]))
#     study_effect <- study_effects[super.x[n,10]]
#     pred <- exp(vals %*% params + study_effect)
#     pred.list[[n]] <- pred #+ study_effects[super.x[,10]]
#     }
#     pred.list.list[[i]] <- pred.list
#   }
#   predicted <- (cbind(as.numeric(pred.list.list[[1]]),
#                       as.numeric(pred.list.list[[2]])))
#   predicted <- predicted / rowSums(predicted)
#
#
#
# vals <- as.matrix(super.x)[1,1:9]
# params <- as.numeric(as.character(output.list[[i]][,5]))
# study_effects[super.x[1,10]]
# exp(vals %*% params)/rowSums(predicted)[1,]

predicted <- as.data.frame(do.call('cbind',pred.list))
predicted <- apply(predicted, 2, as.numeric)
predicted <- predicted / rowSums(predicted)
colnames(predicted) <- colnames(y)
#get matrix of residuals
resid <- y - predicted

#get deviance score.
deviance <- out[grep('deviance',rownames(out)),]

#make a super output that also returns model
super.list <- list(jags.out, output.list,predicted,y,resid,deviance,x.mm,alpha,study_tau
                   )
names(super.list) <- c('jags_model','species_parameter_output','predicted','observed','residual','deviance','x.mm','alpha','study_tau'
                       )

fit <- super.list

# visualize
for(i in 1:ncol(fit$predicted)) {
  if (colnames(fit$predicted)[i]=="other") next()
plot(fit$observed[,i]/rowSums(fit$observed) ~ fit$predicted[,i],
     pch = 16, xlab="predicted abundance", ylab="observed abundance")
Axis(x="predicted", side=2)
abline(0,1,lwd = 2)
abline(lm(fit$observed[,i]/rowSums(fit$observed) ~ fit$predicted[,i]), lty = 2, col = 'purple')
#mod <- betareg::betareg(crib_fun(fit$observed[,i]/rowSums(fit$observed)) ~ crib_fun(fit$predicted[,i]))
#rsq <-round(summary(mod)$pseudo.r.squared, 3)
mod <- summary(lm(fit$observed[,i] ~ fit$predicted[,i]))
rsq <- mod$r.squared
mtext(colnames(fit$predicted)[i], side = 3)
mtext(paste0('R2=',rsq), side = 3, line = -1.5, adj = 0.05)
}


library(phybase)
mptree1 = "(buffalo:9.181489,(((indicus:1,cattle:1):1.181488,wisent:2.181488):0.000001,(bison:2.120149,yak:2.120149):0.061340):7.000000);"

spname <- species.name(mptree1)
nodematrix <- read.tree.nodes(str=mptree1, name=spname)$nodes
nodematrix[,5]<-2

genetrees=1:200000
for(i in 1:200000)
genetrees[i]<-sim.coaltree.sp(rootnode=11, nodematrix=nodematrix,nspecies=6,seq=rep(1,6), name=spname)$gt

write(genetrees,"wisent_simulated.tre")


df <- read.delim ("sample/peak1_nuc_hw1000_win100_step10_AT.txt") ##reading output file

png("sample/peak1_nuc_hw1000_win100_step10_AT.png")
plot (seq(from = -1000, to = 1000, by = 10), apply(df, MARGIN=2, mean) * 100, col="red", type="l", xlab="Distance from peak1 summit (bp)", ylab="AT content (%)", main="AT content around peak1", lwd=2)
abline(v=0, lty=2)
dev.off()


import::here(dplyr, .all=TRUE)
import::here(ggplot2, .all=TRUE)
import::here(tsibble, .all=TRUE)

# Examples
# -----------
# > plot_2_ts(fpp3::us_change, 'Consumption', 'Income', 'Quarter')
plot_2_ts = function(data, x, y, index_col) {
    data = data[, c(index_col, x, y)]
    colnames(data) = c('index', x, y)
    plt = data %>%
        tidyr::pivot_longer(
            c({{x}}, {{y}}),
            names_to = "var",
            values_to = "value"
        ) %>%
        ggplot(aes(x=index, y=value)) +
        geom_line() +
        facet_grid(vars(var), scales='free_y') +
        ggtitle(paste0(x, ' vs ', y))
    return(plt)
}

# Make scatter plot
#
# Examples
# -----------
# > plot_scatter(mtcars, 'mpg', 'disp')
# > data = mtcars
# > data['cyl_gt_5'] = ifelse(data['cyl'] > 5, 1, 0)
# > plot_scatter(data, 'mpg', 'disp', 'cyl_gt_5')
plot_scatter = function(data, x, y, z = NA) {
    if (is.na(z)) {
        plt = ggplot(data, aes_string(x = x, y = y)) +
            geom_point() +
            ggtitle(paste0(x, ' vs ', y))
    } else {
        plt = ggplot(data, aes_string(x = x, y = y, colour = z)) +
            geom_point() +
            ggtitle(paste0(x, ' vs ', y, ' coloured by ', z))
    }
    return(plt)
}

if (identical(environment(), globalenv())) {
    1
}


# Fit SSD to CCME data for several metals

# Copyright 2017 Province of British Columbia
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and limitations under the License.

# We compare fits for the distributions with AIC
# Refer to https://cran.r-project.org/web/packages/fitdistrplus/vignettes/FAQ.html
# for information on the fitdistrplus package.
# Refer to AICcmodavg package for details on creating the AIC tables and
# how to do model averaging.

# Load the necessary libraries
library(AICcmodavg)
library(actuar) # for the burr distribution
library(FAdist) # for log-logistic
library(fitdistrplus)
library(ggplot2)
library(grid)
library(gridGraphics)
library(plyr)   # for doing a separate analysi by chemical
library(VGAM) # for the gompertz, pareto, gumbel distributions

source("mygofstat.r")  # corrects and error in the code in the fistdistr package (groan)
#source("C:/R-repositories/SSD-fitting/CCME-fits/mygofstat.r")

#load test data
endpoints<-read.csv("CCME data.csv",header=TRUE,as.is=TRUE, strip.white=TRUE)
#endpoints<- read_csv("C:/R-repositories/SSD-fitting/CCME-fits/CCME data.csv")

head(endpoints)

xtabs(~Chemical, data=endpoints, exclude=NULL, na.action=na.pass)

# create a directory for plots
dir.create(file.path("Plots"))

#use descdist function from fitdistrplus package to identify candidate distributions - create a Cullen Frey graph
sumstats <- plyr::ddply(endpoints, "Chemical", function(x, boot){
    # create the individual plots
    png(file.path("Plots",paste(x$Chemical,".png",sep="")), h=6, w=6, units="in", res=300)
       res <- descdist(x$Conc,discrete=FALSE, boot=boot)
    dev.off()
    # return the summary statistics as a dataframe, rather than a list
    attr(res, "class") <- NULL # remove class attribute from results
    data.frame(res)
}, boot=100)

# summary statistics
sumstats

# create list of possible distributions (the pareto and burr distributions have been commented out of the list below because they are not included in SSD Master)
fit.list <- list( lnorm  = list(data=NULL, distr="lnorm",  method="mle"),
                  llog   = list(data=NULL, distr="llog",   method="mle"), # log logistic
                  gomp   = list(data=NULL, distr="gompertz",method="mle"),
                  lgumbel= list(data=NULL, distr="lgumbel",method="mle"), # log gumbel
                  gamma  = list(data=NULL, distr="gamma",  method="mle"),
#                  pareto = list(data=NULL, distr="pareto", method="mle"),
                  weibull= list(data=NULL, distr="weibull",method="mle")
#                  burr   = list(data=NULL, distr="burr",   method="mle")
                 )

# define log-gumbel distribution
# These functions are needed because this is a non-standard distribution
dlgumbel <- function(x, location=0, scale=0, log=FALSE){
            fx <- dgumbel(log(x), location=location, scale=scale, log=FALSE)/x
            if(log) fx <- log(fx)
            fx}
qlgumbel <- function(p, location=0, scale=0, lower.tail=TRUE, log.p=FALSE){
            if(log.p) p<- exp(p)
            if(!lower.tail) p <- 1-p
            exp( qgumbel(p, location=location, scale=scale))}
plgumbel <- function(q, location=0, scale=0, lower.tail=TRUE, log.p=FALSE){
             Fq <- pgumbel(log(q), location=location, scale=scale)
             if(!lower.tail) Fq <- 1-Fq
             if(log.p) Fq <- log(Fq)
             Fq}
rlgumbel <- function(n, location=0, scale=0){ exp(rgumbel(n, location=location, scale=scale))}

#endpoints <- endpoints[ endpoints$Chemical=="Boron_CCME",]  # for testing to fit only one chemical

# Fit each distribution from the list to each chemical
fit.all <- plyr::dlply(endpoints, "Chemical", function(x, probs=c(.05,.10), nboot=1000){
      cat("Analyzing ", x[1,"Chemical"],"\n")
      # fit all of the distributions in the list to this data. If
      # a distribution fitting does not converge, then it returns NULL
      dist.fits <- plyr::tryapply(fit.list, function(distr, x){
           distr$data <- x$Conc
           if(distr$distr=="burr"){
              distr$start <-list(shape1=4, shape2=1, rate=1)
              distr$method<- "mme"
              distr$order <- 1:3
              distr$memp  <- function (x, order){sum(x^order)}
           }
           if(distr$distr=='gamma'){
             distr$start <- list(scale=var(x$Conc)/mean(x$Conc),
                                    shape=mean(x$Conc)^2/var(x$Conc)^2)
           }
           if(distr$distr == 'gompertz'){
              # use the vgam to get the parameters of the fit
              fit <- vglm(Conc~1, gompertz, data=x)
              distr$start <- list(shape=exp(unname(coef(fit)[2])), scale=exp(unname(coef(fit)[1])) )
            }
           if(distr$distr=='lgumbel'){
             distr$start <- list(location=mean(log(x$Conc)), scale=pi*sd(log(x$Conc))/sqrt(6))
           }
           if(distr$distr=='pareto'){ #use the vgam package to estimate the starting values
             fit<- vglm(Conc~1, paretoff, data=x)
             distr$start  <- list(shape=exp(unname(coef(fit))))
             distr$fix.arg<- list(scale=fit@extra$scale)
           }
           if(distr$distr=="llog" ){ # log=logistic
              distr$start <- list(shape=mean(log(x$Conc)), scale=pi*sd(log(x$Conc))/sqrt(3))
           }
           cat("   Fitting ", distr$distr,"\n")
           res <- do.call("fitdist", distr)
           print(res)
           res
      },x=x)

      # Get the aic table by hand.
      aic.table <- plyr::ldply(dist.fits, function(x){
        # extract the distribution name and AIC value
        aic <- x$aic
        distname <- x$distname
        aicc <- AICcmodavg::AICc(x) # conflict with VGAM package
        nparm <- length(x$estimate)
        data.frame(distname=distname, aic=aic, k=nparm, aicc=aicc)
      })
      aic.table <- aic.table[order(aic.table$aicc),]
      aic.table$delta.aicc <- aic.table$aicc - min(aic.table$aicc)
      aic.table$weight     <- round(exp(-aic.table$delta.aicc/2)/sum(exp(-aic.table$delta.aicc/2)),3)

      # make predictions for HC5 based on all of the distributions
      # Include a bootstrap approximation to the se of the estimates
      pred.table <- plyr::ldply(dist.fits, function(x, probs=.05, nboot=1000){
        distname <- x$distname
        pred     <- quantile(x, probs)
        fit.boot <- bootdist(x, niter=nboot)
        #browser()
        se       <- apply(quantile(fit.boot, probs=probs)$bootquant, 2, sd, na.rm=TRUE)
        lcl      <- quantile(fit.boot, probs=probs)$quantCI[1,]
        ucl      <- quantile(fit.boot, probs=probs)$quantCI[2,]
        #cat("pred.table", distname, pred, se, lcl, ucl, "\n")
        data.frame(distname=distname, quantile=probs, pred=unlist(pred$quantiles), se=se, lcl=unlist(lcl), ucl=unlist(ucl) )
      }, probs=probs, nboot=nboot)

      pred.table <- merge(pred.table, aic.table[,c("distname","weight")])

      # compute the model averaged quantiles, the model averaged lcl and ucl, and unconditional se
      q.modavg <- plyr::ddply(pred.table, "quantile", function(x){
        avg.pred <- sum(x$pred * x$weight)
        avg.lcl  <- sum(x$lcl  * x$weight)
        avg.ucl  <- sum(x$ucl  * x$weight)
        # get the unconditional se
        avg.u.se <- sqrt(sum(x$weight * (x$se^2 + (x$pred-avg.pred)^2)))
        data.frame(avg.pred=avg.pred, avg.u.se=avg.u.se, avg.lcl=avg.lcl, avg.ucl=avg.ucl)
      })
      q.modavg

      # make the cdf plot comparing all of the fits
      # capture the plot and save it
      # get the list of distributions that were fit
      dist.names <- plyr::laply(dist.fits, function(x) x$distname)
      cdfcomp(dist.fits, xlogscale=TRUE, legendtext=dist.names,
              main=paste("Empirical and theoretical CDF's - ",x[1,"Chemical"],sep=""),
              fitcol=c("red","blue","darkgreen","black","darkblue","cyan","violet"),
              fitlty=1:3)
      gridGraphics::grid.echo()
      cdf.comp.plot <- grid::grid.grab()

      #compute the goodmess of fit statistics - NOTE this does not work for burr distribution, not sure why...
      # must check to see if more than one distribution was fit - groan.
      # Also had to fix an error in compute p-value for chi2 test when df=0
      if(length(dist.fits) ==1) {gof.stat <- mygofstat(dist.fits[[1]], fitnames=dist.names)}
      if(length(dist.fits) >1 ) {gof.stat <- mygofstat(dist.fits,fitnames =dist.names)}
#      The following fails because of a bug in gofstat. See mygofstat file for details
#      if(length(dist.fits) ==1) {gof.stat <- fitdistrplus::gofstat(dist.fits[[1]], fitnames=dist.names)}
#      if(length(dist.fits) >1 ) {gof.stat <- fitdistrplus::gofstat(dist.fits,fitnames =dist.names)}

      # return the entire fitting stuff for this distibution
      list(Chemical=x[1,"Chemical"], dist.fits=dist.fits, aic.table=aic.table, pred.table=pred.table,
           q.modavg=q.modavg,
           cdf.comp.plot =cdf.comp.plot,
           gof.stat =gof.stat)
})

display.results <- function(x){
   # display the results from the fitting functions
   cat("\n\n\n\n\n\n\n\n\n *******************************************************************\n")
   cat("\n\nResults when applied to ", x$Chemical, "\n")
   cat("\n\nAICc table \n")
   print(x$aic.table)

   cat("\n\nPredictions of endpoints \n")
   print(x$pred.table)

   cat("\n\nModel averaged endpoint \n")
   print(x$q.modavg)

   cat("\n\nCDF comparative plot\n")
   grid.newpage()
   grid.draw(x$cdf.comp.plot)

   cat("\n\nGoodness of fit statistics\n")
   print(x$gof.stat)

}

# display all of the results from all of the Chemicals
plyr::l_ply(fit.all, display.results)

# save the comparative plot
plyr::l_ply(fit.all, function(x){
   file.name=file.path("Plots",paste(x$Chemical,"-comparative-plot.png",sep=""))
   png(file.name, h=6, w=6, units="in", res=300)
      grid.newpage()
      grid.draw(x$cdf.comp.plot)
   dev.off()
})

# Make a nice plot of the estimates and ci and compare them to the CCME guidelines

ccme.csv<- textConnection(
"Chemical,n, HC5, lcl, ucl, dummy, dummy, dummy
Boron  , 28 , 1.5  , 1.2 , 1.7 , 1.2  , 0.59 , 3.20
Cadmium  , 36 , 0.09  , 0.04 , 0.24 , 0.14  , 0.06 , 0.34
Chloride  , 28 , 120  , 90 , 150 , 73  , 27 , 198
Endosulfan  , 12 , 0.003  , 0.0007 , 0.01 , 0.010  , 0.0012 , 0.51
Glyphosate  , 18 , 800  , 490 , 1320 , 900  , 459 ,  2301
Silver  , 9 , 0.25  , 0.17 , 0.39 , 0.19  , 0.069 , 0.89
Uranium , 13 , 15  , 8.5 , 25 , 15  , 3.1 , 124")

ccme <- read.csv(ccme.csv, header=TRUE, as.is=TRUE, strip.white=TRUE)
ccme$dummy <- NULL
ccme$dummy.1 <- NULL
ccme$dummy.2 <- NULL
ccme$EstType <- "CCME"
ccme$n  <- NULL
ccme

# get the estimates of HC5
fit.hc5 <- plyr::ldply(fit.all, function(x){
    # extract the model averaged
    q <- x$q.modavg[ x$q.modavg$quantile == 0.05,]
    data.frame( HC5=q$avg.pred, lcl=q$avg.lcl, ucl=q$avg.ucl, EstType="ModelAvg")
})

fit.hc5$Chemical <- gsub("_CCME", "", fit.hc5$Chemical)
fit.hc5quuantile <- NULL
fit.hc5

both <- rbind(ccme, fit.hc5)
both

lab_log10 <- function (x){
   # create nice labels for the next plot
   y <- as.character(x)
   y
}

compplot <- ggplot(data=both, aes(x=Chemical, y=HC5, color=EstType))+
  geom_point( position=position_dodge(w=0.4))+
  geom_errorbar(aes(ymin=lcl, ymax=ucl), width=0.1,position=position_dodge(w=0.4))+
  scale_y_log10(labels=lab_log10)+
  #scale_color_discrete(name="Method")+
  labs(x = "Chemical")+
  ylab(bquote('Log' ~HC[5]))+
  theme(axis.text.x = element_text(angle=45,hjust = 1))+
  scale_color_manual(labels = c("Least Squares", "MLE"), values = c("red", "black"))+
  guides(colour=guide_legend("Method"))
compplot

ggsave("Plots/compplot_mod.png", compplot, width = 5.97, height = 5.97)

#calculating percent difference of HC5 values
both.hc5 <- reshape2::dcast(both, Chemical ~ EstType, value.var="HC5")

both.hc5$perdiff <- abs(both.hc5$CCME - both.hc5$ModelAvg)/(both.hc5$CCME + both.hc5$ModelAvg)*2*100
both.hc5
summarize(both.hc5,
          mean.perdiff = mean(perdiff))

#calculate width ratio (ModelAvg/CCME)
both$ci.width <- both$ucl - both$lcl
both.hc5 <- reshape2::dcast(both, Chemical ~ EstType, value.var="ci.width")

both.hc5$width.ratio <- both.hc5$ModelAvg / both.hc5$CCME
both.hc5
summarize(both.hc5,
          mean.widthratio = mean(width.ratio))