# From Max Gordon
require(rms)
# Same simulated data set as used in the cph-example
n <- 1000
set.seed(731)
age <- 50 + 12*rnorm(n)
sex <- factor(sample(c('Male','Female'), n,
                     rep=TRUE, prob=c(.6, .4)))
cens <- 15*runif(n)
h <- .02*exp(.04*(age-50)+.8*(sex=='Female'))
dt <- -log(runif(n))/h
e <- ifelse(dt <= cens,1,0)
dt <- pmin(dt, cens)

test <- data.frame(age = age,
                      sex = sex,
                      Start = 0,
                      dt = dt,
                      e = e)

dd <<- datadist(test); options(datadist='dd')

f <- cph(Surv(dt,e) ~ rcs(age,4) + sex, x=TRUE, y=TRUE)
cox.zph(f, "rank")             # tests of PH

# Now to the actual time-interaction
if(! require(Epi)) quit(save='no')

lxs <- Lexis(entry = list(Timeband = Start),
             exit = list(Timeband = dt, Age = age + dt),
             exit.status = e,
             data = test)
subset(lxs, lex.id %in% 1:3)

spl <-
  splitLexis(lxs,
             time.scale = "Timeband",
             breaks = seq(from = 0,
                          to = ceiling(max(lxs$lex.dur)),
                          by = .5))

subset(spl, lex.id %in% 1:3)

spl$Stop <- spl$Timeband + spl$lex.dur

dd <- datadist(spl)

#######################
# Regular interaction #
#######################
  coxph(Surv(time = Timeband, time2 = Stop, event = lex.Xst) ~ Age + sex*Timeband,
      data = spl)
# Gives:
# Call:
# coxph(formula = Surv(time = Timeband, time2 = Stop, event = lex.Xst) ~
#         Age + sex * Timeband, data = spl)
#
#
# coef exp(coef) se(coef)     z       p
# Age               0.0420     1.043  0.00558  7.53 5.0e-14
# sexMale          -0.9457     0.388  0.26014 -3.64 2.8e-04
# Timeband              NA        NA  0.00000    NA      NA
# sexMale:Timeband  0.0868     1.091  0.05360  1.62 1.1e-01
#
# Likelihood ratio test=72.7  on 3 df, p=1.11e-15  n= 13421, number of events= 183
# Warning message:
#   In coxph(Surv(time = Timeband, time2 = Stop, event = lex.Xst) ~  :
#              X matrix deemed to be singular; variable 3

cph(Surv(time = Timeband, time2 = Stop, event = lex.Xst) ~ Age + sex*Timeband,
    data = spl)
# Gives:
# X matrix deemed to be singular; variable Timeband
#
# Model Did Not Converge.  No summary provided.

###############################
# Forced singular interaction #
###############################
coxph(Surv(time = Timeband, time2 = Stop, event = lex.Xst) ~
        Age + sex + sex:Timeband,
      data = spl)
# Gives:
# Call:
# coxph(formula = Surv(time = Timeband, time2 = Stop, event = lex.Xst) ~
#         Age + sex + sex:Timeband, data = spl)
#
#
# coef exp(coef) se(coef)     z       p
# Age                 0.0420     1.043  0.00558  7.53 5.0e-14
# sexMale            -0.9457     0.388  0.26014 -3.64 2.8e-04
# sexFemale:Timeband -0.0868     0.917  0.05360 -1.62 1.1e-01
# sexMale:Timeband        NA        NA  0.00000    NA      NA
#
# Likelihood ratio test=72.7  on 3 df, p=1.11e-15  n= 13421, number of events= 183
# Warning message:
#   In coxph(Surv(time = Timeband, time2 = Stop, event = lex.Xst) ~  :
#              X matrix deemed to be singular; variable 4

coxph(Surv(time = Timeband, time2 = Stop, event = lex.Xst) ~ Age + sex + I((sex == "Male")*Timeband),
    data = spl)
# Gives:
# Call:
# coxph(formula = Surv(time = Timeband, time2 = Stop, event = lex.Xst) ~
#           Age + sex + I((sex == "Male") * Timeband), data = spl)
#
#
# coef exp(coef) se(coef)     z       p
# Age                            0.0420     1.043  0.00558  7.53 5.0e-14
# sexMale                       -0.9457     0.388  0.26014 -3.64 2.8e-04
# I((sex == "Male") * Timeband)  0.0868     1.091  0.05360  1.62 1.1e-01

cph(Surv(time = Timeband, time2 = Stop, event = lex.Xst) ~ Age + sex + sex:Timeband,
    data = spl)
# Gives:
# X matrix deemed to be singular; variable sex=Male * NA
#
# Model Did Not Converge.  No summary provided.

cph(Surv(time = Timeband, time2 = Stop, event = lex.Xst) ~
      rcs(Age, 4) + sex + asis((sex == "Male")*Timeband),
    data = spl)
# Gives:
# Err. in limits[[zname]] <- if (any(Limnames == zname)) { :
#   more elements supplied than there are to replace

#############
# After fix #
#############
fit_coxph <- coxph(Surv(time = Timeband, time2 = Stop, event = lex.Xst) ~ Age + sex + I((sex == "Male")*Timeband),
                        data = spl)

fit_cph <- cph(Surv(time = Timeband, time2 = Stop, event = lex.Xst) ~ Age + sex + asis((sex == "Male")*Timeband),
    data = spl)

# Basically the same
cbind(coxph=coef(fit_coxph),
      cph=coef(fit_cph))
# Although numerically not equivalent
expect_true(sum(abs(coef(fit_cph) - coef(fit_coxph))) <
              .Machine$double.eps)

#############
# Needs fix #
#############

Predict(fit_cph)
#  Err. in asis((sex == "Male") * Timeband) : object 'Timeband' not found

# Not really working as expected
contrast(fit_cph,
         a=list(sex = "Male"),
         b=list(sex = "Female"))
#  Err. in Getlimi(name[i], Limval, need.all = TRUE) :
#    no limits defined by datadist for variable sex_Timeband
contrast(fit_cph,
         a=list(sex = "Male",
                Timeband = 0),
         b=list(sex = "Female",
                Timeband = seq(0, 10, by=.1)))
# Err. in gendata(list(coefficients = c(0.0420352254526414, -0.945650117874665,  :
#   factor(s) not in design: Timeband

#Ok, thank you. I can get around the problem by manually generating an interaction variable - seems to work satisfactory:

spl_alt <-
  within(spl, {
    Male_time_int = (sex == "Male")*Timeband
  })

spl_alt$lex.Cst <- NULL
spl_alt$Start <- NULL
dd <- datadist(spl_alt)
options(datadist = "dd")

model <-
  cph(Surv(time = Timeband, time2 = Stop, event = lex.Xst) ~
        Age + sex + Male_time_int,
      data = spl_alt)

contrast(model,
         a = list(sex = "Male", Male_time_int = 0:5),
         b = list(sex = "Female", Male_time_int = 0))


n <- 200

dev.print(pdf, "toy_line_plot.pdf")
a  <-  2
b  <-  34
sig_sq  <- 12.35
getwd()
x  <- runif(n)

y  <-  a + b*x + rnorm(n, sd= sqrt(sig_sq))
(avg_x  <-  mean(x))
write(avg_x, 'avg_x.txt')
plot(x, y)
abline(a, b, col = 'purple')
dev.print(pdf, "toy_line_plot.pdf")


rm(list = ls())
setwd(dirname(parent.frame(2)$ofile))

library(plyr)
library(dplyr)

simulate.mse = function (epsilon, samples, operation, simple, input.size, seq.length, subset.ratio, overlap.ratio, range.a, range.b, range.mirror) {
  X = matrix(runif(samples*input.size*seq.length, range.a, range.b), samples * seq.length, input.size)

  if (range.mirror) {
    X.sign = matrix(rbinom(samples*input.size * seq.length, 1, 0.5), samples * seq.length, input.size) * 2 - 1
    X = X * X.sign
  }

  evaluate = function (W, U) {
    Sx = X %*% W
    Z = matrix(0, samples, dim(W)[2])
    for (i in 1:seq.length) {
      Z = Sx[((i-1)*samples + 1):(i*samples),] + Z %*% U
    }

    if (operation == 'add') {
      Y = Z[,1] + Z[,2]
    } else if (operation == 'sub') {
      Y = Z[,1] - Z[,2]
    } else if (operation == 'mul') {
      Y = Z[,1] * Z[,2]
    } else if (operation == 'div') {
      Y = Z[,1] / Z[,2]
    } else if (operation == 'squared') {
      Y = Z[,1] * Z[,1]
    } else if (operation == 'root') {
      Y = sqrt(Z[,1])
    }
    return(Y)
  }

  target.matrix = function (epsilon) {
    if (simple) {
      a.start = 1
      a.end = 2
      b.start = 1
      b.end = 4
    } else {
      subset.size = floor(subset.ratio * input.size)
      overlap.size = floor(overlap.ratio * subset.size)

      a.start = 1
      a.end = a.start + subset.size
      b.start = a.end - overlap.size
      b.end = b.start + subset.size
    }

    W = matrix(0 + epsilon, input.size, 2)
    W[a.start:a.end, 1] = 1 - epsilon
    W[b.start:b.end, 2] = 1 - epsilon
    return(W)
  }

  W.y = target.matrix(epsilon)
  U.y = (1 - epsilon) * diag(2)
  W.t = target.matrix(0)
  U.t = diag(2)
  errors = (evaluate(W.y, U.y) - evaluate(W.t, U.t))**2

  return(mean(errors))
}

cases = rbind(
  c(parameter='default', operation='add', simple=F, input.size=10, seq.length=100, subset.ratio=0.25, overlap.ratio=0.5, range.a=1, range.b=2, range.mirror=F),
  c(parameter='default', operation='sub', simple=F, input.size=10, seq.length=100, subset.ratio=0.25, overlap.ratio=0.5, range.a=1, range.b=2, range.mirror=F),
  c(parameter='default', operation='mul', simple=F, input.size=10, seq.length=100, subset.ratio=0.25, overlap.ratio=0.5, range.a=1, range.b=2, range.mirror=F),
  c(parameter='range', operation='add', simple=F, input.size=10, seq.length=10, subset.ratio=0.25, overlap.ratio=0.5, range.a=2, range.b=6, range.mirror=F),
  c(parameter='range', operation='sub', simple=F, input.size=10, seq.length=10, subset.ratio=0.25, overlap.ratio=0.5, range.a=2, range.b=6, range.mirror=F),
  c(parameter='range', operation='mul', simple=F, input.size=10, seq.length=10, subset.ratio=0.25, overlap.ratio=0.5, range.a=2, range.b=6, range.mirror=F)
)

for (input.size in c(10, 100, 1000)) {
  cases = rbind(cases, c(parameter='input.size', operation='add', simple=F, input.size=input.size, seq.length=10, subset.ratio=0.25, overlap.ratio=0.5, range.a=1, range.b=2, range.mirror=F))
}

for (seq.length in c(10, 20, 1000)) {
  cases = rbind(cases, c(parameter='seq.length', operation='add', simple=F, input.size=10, seq.length=seq.length, subset.ratio=0.25, overlap.ratio=0.5, range.a=1, range.b=2, range.mirror=F))
  cases = rbind(cases, c(parameter='seq.length', operation='sub', simple=F, input.size=10, seq.length=seq.length, subset.ratio=0.25, overlap.ratio=0.5, range.a=1, range.b=2, range.mirror=F))
  cases = rbind(cases, c(parameter='seq.length', operation='mul', simple=F, input.size=10, seq.length=seq.length, subset.ratio=0.25, overlap.ratio=0.5, range.a=1, range.b=2, range.mirror=F))
}

eps = data.frame(rbind(
  c(operation='mul', epsilon=0.00001),
  c(operation='add', epsilon=0.00001),
  c(operation='sub', epsilon=0.00001),
  c(operation='div', epsilon=0.00001)
))

mse = data.frame(cases) %>%
  merge(eps) %>%
  mutate(
    simple=as.logical(as.character(simple)),
    input.size=as.integer(as.character(input.size)),
    seq.length=as.integer(as.character(seq.length)),
    subset.ratio=as.numeric(as.character(subset.ratio)),
    overlap.ratio=as.numeric(as.character(overlap.ratio)),
    range.a=as.numeric(as.character(range.a)),
    range.b=as.numeric(as.character(range.b)),
    range.mirror=as.logical(as.character(range.mirror)),
    epsilon=as.numeric(as.character(epsilon))
  ) %>%
  rowwise() %>%
  mutate(
    threshold=simulate.mse(epsilon, 10000, operation, simple, input.size, seq.length, subset.ratio, overlap.ratio, range.a, range.b, range.mirror),
    extrapolation.range=ifelse(range.mirror, paste0('U[-',range.b,',-',range.a,'] ∪ U[',range.a,',',range.b,']'), paste0('U[',range.a,',',range.b,']')),
    operation=paste0('op-', operation)
  )

write.csv(mse, file="../results/function_task_recurrent_mse_expectation.csv", row.names=F)


library(base)
library(caret)
library(dummies)
library(e1071)
library(factoextra)
library(modules)
library(RSNNS)
library(rstudioapi)
library(stats)
library(tidyverse)
library(utils)

base::setwd(base::dirname(rstudioapi::getActiveDocumentContext()$path))
start <- base::Sys.time()

base::set.seed(0xACDC)

train_test_prop <- 0.75

data <- modules::use('data')$get_data$get_data()

target_column <- 47

data_dm <- dummies::dummy.data.frame(data = data[, 2:46], sep = '_')

data_norm <-
  base::as.data.frame(RSNNS::normalizeData(data_dm, type = '0_1'))

base::names(data_norm) <- base::names(data)[2:46]

index <-
  base::sample(base::nrow(data_norm),
               base::round(train_test_prop * base::nrow(data_norm)))

train <- data_norm[index, ]
test <- data_norm[-index, ]

train_label <- data[index, target_column]
test_label <- data[-index, target_column]

base::plot(factoextra::fviz_nbclust(train, kmeans, 'wss', k.max = 15))
base::plot(factoextra::fviz_nbclust(train, kmeans, 'silhouette', k.max = 15))

cluster <- stats::kmeans(train, centers = 2, nstart = 20)

base::print(cluster$size)

distEuclidean <- function(x, y) {
  z <- base::matrix(0, nrow = base::nrow(x), ncol = base::nrow(y))

  for (k in 1:base::nrow(y)) {
    z[, k] <- base::sqrt(base::colSums((base::t(x) - y[k, ]) ^ 2))
  }

  return(z)
}

clusters <- function(x, centers) {
  Distances <- distEuclidean(x, centers)
  Clusters <- base::apply(Distances, 1, which.min)

  return(Clusters)
}

do_kmeans <- function(set, label) {
  prediction <- clusters(set, cluster[['centers']])

  label <-
    base::as.factor(base::ifelse(label == 'legitimate', 2, 1))

  cm <- caret::confusionMatrix(label, base::as.factor(prediction))
  base::print(cm$table)
  base::print(cm$overall['Accuracy'])
}

base::print('Train:')
do_kmeans(train, train_label)

base::print('Test:')
do_kmeans(test, test_label)

base::print(base::Sys.time() - start)
base::rm(start, index)

predict_using_kmeans <- function(file = 'scripts/output.csv') {
  output <- utils::read.csv(
    file,
    header = TRUE,
    sep = ',',
    stringsAsFactors = FALSE,
    strip.white = TRUE
  )

  urls <- output$url
  output$url <- NULL

  results <-
    base::ifelse(clusters(output, cluster[['centers']]) == 2,
                 'legitimate',
                 'phishing')

  base::print(base::data.frame(url = urls, status = results))
}


######################################################################################################
# CS171 BioVis Project
# Spring 2013
# Author: John Mercer
# Code: This code computes the distribution for the TIM sequence lengths in the (for all TIMs)
#######################################################################################################

sequenceLengths <- read.table("/Users/mercicle/Documents/python_workspace/BioVis/Codes/TIMData/csvLengths.txt",sep = ",")

TIM_Sequence_Length <- unlist(sequenceLengths)
pdf(file="/Users/mercicle/Documents/python_workspace/BioVis/Codes/TIMData/TIM_sequence_lengths.pdf")
hist( TIM_Sequence_Length,
      main="Distribution of TIM Sequence Lengths",
      freq=FALSE,
      breaks = 20,
      col="blue",
      border="black")
#axis(2, at = seq(0, 1, 0.1), labels = paste(0:10, "%", sep = ""))
#axis(1, at = seq(0, 1000, 1), labels = paste(0:1000, sep = ""))
dev.off()

hist( TIM_Sequence_Length,
      main="Distribution of TIM Sequence Lengths",
      freq=TRUE,
      breaks = 20,
      col="lightblue",
      xlab="Length of Sequence",
      border="black")


[[[[[
   Show that a real r is Solovay random
   iff it is strong Chaitin random.

   An effective covering A_k of k is a function
   of k that enumerates bit strings s,
   which are the initial bits of the covered
   reals.  We assume that no s in A_k is a
   proper prefix or extension of another.
   Thus the measure of the cover A_k of k is
   exactly Sum_{s in A_k} of 2^{-|s|},
   where |s| is the length of the bit string s.
]]]]]

[Second part: not Ch random ===> not Sol random]

define (is-in? x l) [is x an element of list l?]
   if atom l     false
   if = x car l  true
   (is-in? x cdr l)

define      is-in?
value       (lambda (x l) (if (atom l) false (if (= x (car l))
             true (is-in? x (cdr l)))))

define (union x y) [set-theoretic union of two sets x y]
   if atom x y
   if (is-in? car x y) (union cdr x y)
   cons car x (union cdr x y)

define      union
value       (lambda (x y) (if (atom x) y (if (is-in? (car x) y
            ) (union (cdr x) y) (cons (car x) (union (cdr x) y
            )))))

define (is-bit-string? x) [is x a list of 0's and 1's?]
   if = x nil   true
   if atom x    false
   if = 0 car x (is-bit-string? cdr x)
   if = 1 car x (is-bit-string? cdr x)
   false

define      is-bit-string?
value       (lambda (x) (if (= x nil) true (if (atom x) false
            (if (= 0 (car x)) (is-bit-string? (cdr x)) (if (=
            1 (car x)) (is-bit-string? (cdr x)) false)))))

define C [test computer---real thing is eval read-exp]
   let (loop x y) [xx yy zz 01 ===> xyz]
     if = x y cons x (loop read-bit read-bit)
     nil
   (loop read-bit read-bit)

define      C
value       ((' (lambda (loop) (loop (read-bit) (read-bit))))
            (' (lambda (x y) (if (= x y) (cons x (loop (read-b
            it) (read-bit))) nil))))

[
 The hypothesis that
 the real number r is not Chaitin random
 means that there is a K such that
 for infinitely many values of n
   H(r_n) < n + K,
 where r_n is the first n bits of r.

 For this example, let's suppose that K = 5.
]

define K 5

define      K
value       5

[
 Our proof depends on the fact that there is a c such that
 the probability that an n-bit string s has
  H(s) < n + K
 is less than 2^{-H(n) + K + c}.
]

[
 Now let's do stage N of A_n = n-bit strings s with H(s) < |s| + K.
 At stage N we look at all programs p less than n + K bits in size for time up to N.
]

define (quasi-compressible N n)
   (look-at nil)

define      quasi-compressible
value       (lambda (N n) (look-at nil))

[this routine has free parameters N, n, K, C]

define (look-at p) [produces quasi-compressible strings of length n]
   if = length p + n K [p too long?]
      nil
   let v try N C ['eval read-exp] p
   if = success car v
      let w cadr v
      if (is-bit-string? w)
         if = n length w
            cons w nil
         nil
      nil
   [
    Also works with append below instead of union
    because duplicates are removed later by (process interval).
   ]
   (union (look-at append p cons 0 nil)
          (look-at append p cons 1 nil))

define      look-at
value       (lambda (p) (if (= (length p) (+ n K)) nil ((' (la
            mbda (v) (if (= success (car v)) ((' (lambda (w) (
            if (is-bit-string? w) (if (= n (length w)) (cons w
             nil) nil) nil))) (car (cdr v))) (union (look-at (
            append p (cons 0 nil))) (look-at (append p (cons 1
             nil))))))) (try N C p))))

[
 List of intervals in covering so far.
 used to avoid overlapping intervals in covering.

 This is easy to do because here because
 all intervals are the same length.
]
define intervals ()

define      intervals
value       ()

define (process-all x) [process list of intervals x]
   if atom x  intervals
   let intervals append (process car x) intervals
   (process-all cdr x)

define      process-all
value       (lambda (x) (if (atom x) intervals ((' (lambda (in
            tervals) (process-all (cdr x)))) (append (process
            (car x)) intervals))))

define (process interval) [process individual interval]
   if (is-in? interval intervals)
      [then don't need to repeat it]
      nil
      [else interval is fine as is]
      cons display interval nil

define      process
value       (lambda (interval) (if (is-in? interval intervals)
             nil (cons (display interval) nil)))

[
 Put it all together---Here is cover A_n
 covering all reals r having n-bit prefix r_n
 with H(r_n) < n + K.

 And we have measure \mu A_n <= 2^{-H(n)+K+c}
 so that Sum_n \mu A_n <= \Omega 2^{K+c} <= 2^{K+c} < infinity .

 Hence a real r which is not strongly Chaitin random
 will be in infinitely many of the A_n,
 which have convergent total measure,
 and hence will not be Solovay random.
]
define (A n)
   let intervals nil
   let (stage N)
      if = N 7 stop! [to stop test run---remove if real thing]
      let quasi-compressible-strings (quasi-compressible N n)
      let intervals (process-all quasi-compressible-strings)
      (stage + 1 N)
   [go!!!!!]
   (stage 0)

define      A
value       (lambda (n) ((' (lambda (intervals) ((' (lambda (s
            tage) (stage 0))) (' (lambda (N) (if (= N 7) stop!
             ((' (lambda (quasi-compressible-strings) ((' (lam
            bda (intervals) (stage (+ 1 N)))) (process-all qua
            si-compressible-strings)))) (quasi-compressible N
            n)))))))) nil))

[n = 2, i.e., quasi-compressible 2-bit strings]
(A 2)

expression  (A 2)
display     (0 0)
display     (0 1)
display     (1 0)
display     (1 1)
value       stop!


fit.limma <- function(methylation, design, dependent.variable, independent.variable, ...) {
    dep.idx <- which(colnames(design) == dependent.variable)
    fit <- lmFit(methylation, design=design[,-dep.idx,drop=F])
    fit <- eBayes(fit, ...)

    se <- (sqrt(fit$s2.post) * fit$stdev.unscaled[,independent.variable])
    ##alpha <- 0.975
    ##margin.error <- (se * qt(alpha, df=fit$df.total))
    ##estimate.ci <- fit$coefficient[,independent.variable] +/- margin.error
    data.frame(estimate=fit$coef[,independent.variable],
               se=se,
               t=fit$t[,independent.variable],
               p.value=fit$p.value[,independent.variable])
}

fit.limma.multi <- function(methylation,design,dependent.variable,independent.variables,...) {
    dep.idx <- which(colnames(design) == dependent.variable)
    fit <- lmFit(methylation, design=design[,-dep.idx,drop=F])
    fit <- eBayes(fit, ...)

    ## eBayes uses the is.fullrank() function to decide
    ## whether or not to calculate an F-statistic based on a somewhat arbitrary
    ## threshold. There is no warning and omitting the F-statistic
    ## causes topTable() below to fail. Here we compute it if it is missing.
    if (!("F" %in% names(fit))) {
        f.stat <- classifyTestsF(fit, fstat.only = TRUE)
        fit$F <- as.vector(f.stat)
        df1 <- attr(f.stat, "df1")
        df2 <- attr(f.stat, "df2")
        if (df2[1] > 1e+06)
            fit$F.p.value <- pchisq(df1 * fit$F, df1, lower.tail = FALSE)
        else
            fit$F.p.value <- pf(fit$F, df1, df2, lower.tail = FALSE)
    }
    stats <- topTable(fit,
                      coef=independent.variables,
                      number=nrow(methylation),
                      sort.by="none")

    data.frame(f=stats$F,
               p.value=stats$P.Value,
               sapply(independent.variables, function(independent.variable) {
                   se <- (sqrt(fit$s2.post) * fit$stdev.unscaled[,independent.variable])
                   data.frame(estimate=fit$coef[,independent.variable],
                              se=se,
                              t=fit$t[,independent.variable],
                              p.value=fit$p.value[,independent.variable])
               }, simplify=F))
}


#' IREQ
#'
#' Calculation of Required Clothing Insulation IREQ.
#'
#' @param t numeric    Air temperature in degC.
#' @param rh numeric   Relative humidity in percentage.
#' @param wind numeric Windspeed in meter per second.
#' @param tr numeric Mean radiant temperature in degC.
#' @param M numeric    Metabolic work in Watt per mq of the subject.
#' @param W   numeric  Mechanical work rate in Watt per mq of the subject.
#' @param clo numeric  Available basic clothing insulation in clo.
#' @param p  numeric   Air permeability of clothing ensemble lt on meters per second.
#' @param w  numeric   Walking speed in meters per second.
#' @param param  character Parameter of IREQ ISO 11079: "IREQ_neutral","IREQ_min","ICL_neutral","ICL_min","DLE_neutral","DLE_min","ICL_ISO11079"
#' @return IREQ value
#' @references ISO 11079, 2007-12-15, ERGONOMICS OF THE THERMAL ENVIRONMENT - DETERMINATION AND INTERPRETATION OF COLD STRESS WHEN USING REQUIRED CLOTHING INSULATION (IREQ) AND LOCAL COOLING EFFECTS.
#' @author    Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords IREQ
#' @export
#'
#'
#'
#'

IREQ=function(t,rh,wind,tr,M,W,clo,p,w,param="IREQ_neutral") {
                         if ( length(param)==1) {param=rep(param,length(t))}
                         ct$assign("t", as.array(t))
                         ct$assign("rh", as.array(rh))
                         ct$assign("v", as.array(wind))
                         ct$assign("Tr", as.array(tr))
                         ct$assign("M", as.array(M))
                         ct$assign("W", as.array(W))
                         ct$assign("Icl", as.array(clo))
                         ct$assign("p", as.array(p))
                         ct$assign("w", as.array(w))
                         ct$assign("param", as.array(param))
                         ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){ res[i]=IREQ(t[i],rh[i],v[i],Tr[i],M[i],W[i],Icl[i],p[i],w[i],param[i])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


library(ggplot2)
source("~/Documents/SickStick_QSEIR/SickStickModel_lite/helpers.R")

sick_day_nm <- 0
snmv <- NULL
rov <- NULL
for (TP in c(75, 85, 95)){
  # Currently Setting TN=TP
  TN = TP
for (beta in (seq(1, 150)*0.01)) {

  sick_day_nm=processData(
  0, # TP of SickStick X/100
  1, # TN of SickStick X/100
  beta, # Infection rate X/100
  0.01, # Recovery rate X/100
  1, # Disease progression rate X/100
  0, # Number of days remained quarantined before clear X
  0.01, # Reverse rate R - S, can also be considered as disease reocurrence rate X/100,
  1,
  0,
  0 )

  sick_day_ss=processData(
    TP, # TP of SickStick X/100
    TN, # TN of SickStick X/100
    beta, # Infection rate X/100
    0.01, # Recovery rate X/100
    1, # Disease progression rate X/100
    1, # Number of days remained quarantined before clear X
    0.01, # Reverse rate R - S, can also be considered as disease reocurrence rate X/100,
    1,
    0,
    0 )

  mu <- 0.01
  gamma <- 0.1
  sigma <- 1

  ro = beta*sigma/((gamma+mu)*(sigma+mu))
  rov <- c(rov, ro)
  snmv <- c(snmv, sick_day_ss-sick_day_nm)
}}

indicator <- c(rep("TP = 85%", 150 ), rep("TP = 75%", 150 ), rep("TP = 95%", 150 ))

long_95 <- data.frame(long_95[,1:2], Legend=indicator)

p <- ggplot(long_95,
            aes(x=ro, y=sn, group=indicator))
p <- p  +
  ggtitle("") +
  geom_line(aes(colour = indicator), size=2) +
  labs(x = "Ro Value", y = "Total Sick Days Saved (w/ - wo/) per Person per Year") +
  theme_linedraw() + theme(plot.background = element_rect(fill = "#ebebeb"))

print(p)


################################################################################
#
# Simplified script for example analysis for "A Simple Way to
# Incorporate Uncertainty and Risk into Forest Harvest Scheduling".
#
# Andrew Robinson  22 September 2015
#
################################################################################

## Set run parameters

set.seed(1)

n.coupes <- 1000

nsim <- 10000

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

## Call libraries

library(ggplot2)
library(gridExtra)
library(splines)
library(gamlss)
library(lpSolveAPI)
library(parallel)

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

## Generate fake albeit realistic data

coupes <-
    data.frame(HARVYEAR = sample(
                   2003:2013,
                   size = n.coupes,
                   replace = TRUE),
               ForestQualityClass = sample(
                   c("MAT_hq","MAT_lq","MIX_hq","MIX_lq"),
                   size = n.coupes,
                   replace = TRUE),
               grossArea = rweibull(n = n.coupes,
                   shape = 1.74,
                   scale = 70))

parameters <-
    data.frame(ForestQualityClass = c("MAT_hq","MAT_lq","MIX_hq","MIX_lq"),
               x.shapes = c(1.70, 1.45, 1.7, 0.90),
               x.scales = c(6800, 2400, 6000, 2600),
               recovery = c(0.5, 0.3, 0.5, 0.3),
               y.scales = c(1, 1.5, 2, 1.2))

coupes <- merge(coupes, parameters, all.x = TRUE)

coupes$grossHQSLest <- rweibull(n = nrow(coupes),
                                shape = coupes$x.shapes,
                                scale = coupes$x.scales)

coupes$SalesHQSL.s <-
    with(coupes, 200 * y.scales)
coupes$SalesHQSL.a <-
    with(coupes, grossHQSLest * recovery / SalesHQSL.s)

coupes$SalesHQSL <- rgamma(n = nrow(coupes),
                           shape = coupes$SalesHQSL.a,
                           scale = coupes$SalesHQSL.s)

pdf(file = "Figure 1 ex.pdf", height = 4, width = 4)
qplot(x = grossHQSLest / 1000,
      y = SalesHQSL / 1000,
      geom = c("point","smooth"),
      se = FALSE,
      xlab = expression(paste("Assessed HQ Sawlog ('000 ", m^3, ")")),
      ylab = expression(paste("Actual HQ Sawlog ('000 ", m^3, ")")),
      method = "lm",
      alpha = I(0.4),
      data = coupes) +
  geom_abline(aes(slope = 1, intercept = 0), linetype = 4, colour = "darkgrey") +
  geom_smooth(se = FALSE, linetype = 2)
dev.off()

str(coupes)

table(coupes$HARVYEAR)
table(coupes$ForestQualityClass)

coupes$fit <- TRUE
coupes$fit[coupes$HARVYEAR > 2007] <- FALSE

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

## Generate helper functions

summary.lpExtPtr <- function(x, target, ...) {
  cut.me <- get.variables(x)
  num.coupes.cut <- sum(cut.me)
  area.cut <- sum(cut.me * target$grossArea)
  volume.cut <- sum(cut.me * target$SalesHQSL)
  volume.cut.hat <- sum(cut.me * target$mu.hat)
  out <- list(cut.me = cut.me,
              num.coupes.cut = num.coupes.cut,
              area.cut = area.cut,
              volume.cut = volume.cut,
              volume.cut.hat = volume.cut.hat)
  class(out) <- "summary.lpExtPtr"
  return(out)
}

simulate.summary.lpExtPtr <-
  function(object, nsim = 1, seed = NULL, ...) {
    sim.volume <-
      lapply(1:nsim,
             function(x)
             with(to.cut[object$cut.me == 1, ],
                  sum(rGA(sum(object$cut.me),
                          mu = mu.hat,
                          sigma = sigma.hat))))
    return(unlist(sim.volume))
  }

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

## Fit and compare some models

test.0 <- gamlss(SalesHQSL ~ log(grossHQSLest),
                 sigma.formula = ~ 1,
                 sigma.link = "log",
                 family = GA(),
                 data = coupes)

test.1 <- gamlss(SalesHQSL ~ log(grossHQSLest),
                 sigma.formula = ~ log(grossHQSLest),
                 sigma.link = "log",
                 family = GA(),
                 data = coupes)

LR.test(test.0, test.1)

summary(test.1)

test.2 <- gamlss(SalesHQSL ~ pb(log(grossHQSLest)),
                 sigma.formula = ~ 1,
                 sigma.link = "log",
                 family = GA(),
                 data = coupes)

LR.test(test.0, test.2)

test.3 <- gamlss(SalesHQSL ~ log(grossHQSLest) * ForestQualityClass,
                 sigma.formula = ~ 1,
                 sigma.link = "log",
                 family = GA(),
                 data = coupes)

summary(test.3)
LR.test(test.0, test.3)

test.5 <- gamlss(SalesHQSL ~ poly(log(grossHQSLest), 2) * ForestQualityClass,
                 sigma.formula = ~ ForestQualityClass,
                 sigma.link = "log",
                 family = GA(),
                 data = coupes)

summary(test.5)
LR.test(test.0, test.5)

## Modest difference.

trajectory.5 <-
  with(coupes,
       expand.grid(grossHQSLest =
                   seq(from = min(grossHQSLest),
                       to = max(grossHQSLest),
                       length.out = 100),
                   ForestQualityClass = levels(coupes$ForestQualityClass)))

new.dist.5 <- predictAll(test.5, newdata = trajectory.5)

trajectory.5$mu <- new.dist.5$mu
trajectory.5$sigma <- new.dist.5$sigma
trajectory.5$upper.2 <- with(new.dist.5, qGA(0.95, mu = mu, sigma = sigma))
trajectory.5$lower.2 <- with(new.dist.5, qGA(0.05, mu = mu, sigma = sigma))
trajectory.5$upper.1 <- with(new.dist.5, qGA(0.67, mu = mu, sigma = sigma))
trajectory.5$lower.1 <- with(new.dist.5, qGA(0.33, mu = mu, sigma = sigma))

# setEPS()
# postscript("model.eps", height=6, width=6)
pdf("Figure 2 ex.pdf", height=6, width=6)

p.5 <-
  ggplot(coupes,
         aes(x = grossHQSLest / 1000,
             y = SalesHQSL / 1000)) +
#  geom_point(aes(shape = fit)) +
  geom_point(alpha=0.4) +
#  scale_colour_discrete(name = "Source", labels = c("Test","Fit")) +
  facet_wrap(~ ForestQualityClass) +
  xlab(expression(paste("Assessed HQ Sawlog ('000 ", m^3, ")"))) +
  ylab(expression(paste("Actual HQ Sawlog ('000 ", m^3, ")"))) +
#  geom_smooth(aes(colour = fit),
#              method = "lm", formula = y ~ pb(x), se = FALSE) +
  geom_line(aes(y = mu / 1000, x = grossHQSLest / 1000),
            data = trajectory.5) +
  geom_line(aes(y = lower.2 / 1000, x = grossHQSLest / 1000),
            linetype = "dashed", data = trajectory.5) +
  geom_line(aes(y = upper.2 / 1000, x = grossHQSLest / 1000),
            linetype = "dashed", data = trajectory.5) +
  geom_line(aes(y = lower.1 / 1000, x = grossHQSLest / 1000),
            linetype = "dotted", data = trajectory.5) +
  geom_line(aes(y = upper.1 / 1000, x = grossHQSLest / 1000),
            linetype = "dotted", data = trajectory.5) +
  ylim(c(0,10))
plot(p.5)

dev.off()

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

# Settle on model 5.  Obtain predictions for withheld stands

to.cut <-
  droplevels(subset(coupes, !fit &
                    ForestQualityClass %in%
                    levels(coupes$ForestQualityClass)))

to.cut.hat.cut <- predictAll(test.5, newdata = to.cut)

to.cut$mu.hat <- to.cut.hat.cut$mu
to.cut$sigma.hat <- to.cut.hat.cut$sigma

par(mfrow=c(1,3))
plot(SalesHQSL ~ mu.hat, data = to.cut)
plot(SalesHQSL ~ grossHQSLest, data = to.cut)
plot(mu.hat ~ grossHQSLest, data = to.cut)

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

### Now use LP to optimize. This script portion benefits from prior
### work at
### http://fishyoperations.com/r/linear-programming-in-r-an-lpsolveapi-example
### see also
### http://www.r-bloggers.com/linear-programming-in-r-an-lpsolveapi-example/

## Here's an example that cuts le 15 stands, total area le 1000 ha,
## one year, max volume.

## ops creates the annual constraints

ops <- data.frame(year = c('y1'),
                  area = c(1000),
                  equip = c(30))

lpmodel.harvest <- make.lp(2*NROW(ops) + NROW(to.cut), NROW(ops) * NROW(to.cut))

column <- 0
row <- 0

# build the model column by column

for(wg in ops$year){
  row <- row + 1
  for(coupe in seq(1, NROW(to.cut))){
    column <- column + 1
# this takes the arguments 'column','values' & 'indices' (as in where
# these values should be placed in the column)
    set.column(lpmodel.harvest,
               column,
               c(1, to.cut[coupe,'grossArea'], 1),
               indices = c(row, NROW(ops) + row, NROW(ops)*2 + coupe))
  }}

# set rhs weight constraints - first triplet
set.constr.value(lpmodel.harvest,                    # The lp model
                 rhs = ops$equip,                    # The values
                 constraints = seq(1, NROW(ops)))    # Where to put them

# set rhs volume constraints - second triplet
set.constr.value(lpmodel.harvest,
                 rhs = ops$area,
                 constraints = seq(NROW(ops)+1, NROW(ops)*2))

# set rhs availability constraints - last quadruplet

set.constr.value(lpmodel.harvest,
                 rhs = rep(1, NROW(to.cut)),
                 constraints = seq(NROW(ops)*2+1, NROW(ops)*2+NROW(to.cut)))

# set objective coefficients - here the simulated average

set.objfn(lpmodel.harvest, rep(to.cut$mu.hat, NROW(ops)))

# set objective direction

lp.control(lpmodel.harvest, sense = 'max')

# Ensure integers - works!

get.type(lpmodel.harvest)
set.type(lpmodel.harvest, 1:length(get.type(lpmodel.harvest)), "integer")

# solve the model; if this returns 0 then an optimal solution has been found

solve(lpmodel.harvest)

# this returns the proposed solution

get.objective(lpmodel.harvest)

# Coupe choices

(base <- summary(lpmodel.harvest, target = to.cut))

par(mfrow=c(1,3))
plot(SalesHQSL ~ mu.hat, data = to.cut,
     pch=c(1,19)[base$cut.me + 1])
plot(SalesHQSL ~ grossHQSLest, data = to.cut,
     pch=c(1,19)[base$cut.me + 1])
plot(mu.hat ~ grossHQSLest, data = to.cut,
     pch=c(1,19)[base$cut.me + 1])

#########################################################################################
#
# FTM I have a stand prescription.  I should generate a bunch of random volumes
# corresponding to these predictions.
#
#########################################################################################

base.sim.volume <-
  sapply(1:10000,
         function(x)
         with(to.cut[base$cut.me == 1,],
              sum(rGA(sum(base$cut.me), # if n = 1 then randoms are correlated!
                      mu = mu.hat,
                      sigma = sigma.hat)))) / 1000

## Graphical summary.

par(mfrow=c(1,2), mar=c(5,4,3,2), las=1)
plot(density(base.sim.volume), xlim = c(50,300), main="Distribution",
     xlab = expression(paste("Assessed Sawlog ('000 ", m^3, ")")))
abline(v = base$volume.cut/1000, lty = 2)
abline(v = base$volume.cut.hat/1000)
abline(v = quantile(base.sim.volume, p = c(0.05, 0.95)), col = "darkgrey")
#qqnorm(base.sim.volume); qqline(base.sim.volume)
plot(ecdf(base.sim.volume), xlim = c(0,500), main="CDF",
     xlab = expression(paste("Assessed Sawlog ('000 ", m^3, ")")))
abline(v = base$volume.cut/1000, lty = 2)
abline(v = base$volume.cut.hat/1000)
abline(v = quantile(base.sim.volume, p = c(0.05, 0.95)), col = "darkgrey")

## This provides us with, as hoped for, probabilistic information
## about the expected return.

## For example, what is the mean expected return?

mean(base.sim.volume)

## What is the probability of achieving the mean objective?

mean(base.sim.volume > base$volume.cut.hat / 1000)

## What is the 90% prediction interval?

quantile(base.sim.volume, p = c(0.05, 0.95))

## How can this be related back to headroom?  10%? 20%? 30%?

mean(base.sim.volume > base$volume.cut.hat * 0.9 / 1000) # 10% HR
mean(base.sim.volume > base$volume.cut.hat * 0.8 / 1000) # 20% HR
mean(base.sim.volume > base$volume.cut.hat * 0.7 / 1000) # 30% HR

## We could compare this with a clearly inadequate correction, such as
## a straight ratio, somehow.

## What is the proportion reduced relative to expectations?

(base$volume.cut.hat - base$volume.cut) / base$volume.cut.hat

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

# Now penalize optimization by uncertainty.  Start simply: use the 0.1
# quantile as the objective, and analyze as above.

set.objfn(lpmodel.harvest,
          rep(with(to.cut, qGA(0.1, mu = mu.hat, sigma = sigma.hat)),
              NROW(ops)))

solve(lpmodel.harvest)

get.objective(lpmodel.harvest)

# Coupe choices

(q10 <- summary(lpmodel.harvest, target = to.cut))

cor(base$cut.me, q10$cut.me)

q10.sim.volume <-
  sapply(1:10000,
         function(x)
         with(to.cut[q10$cut.me == 1,],
              sum(rGA(sum(q10$cut.me), # if n = 1 then randoms are correlated!
                      mu = mu.hat,
                      sigma = sigma.hat)))) / 1000

## Graphical summary.

par(mfrow=c(1,2), mar=c(5,4,3,2), las=1)
plot(density(q10.sim.volume), xlim = c(0,100), main="Distribution",
     xlab = expression(paste("Assessed Sawlog ('000 ", m^3, ")")))
lines(density(base.sim.volume), col = "darkgrey")
abline(v = q10$volume.cut/1000, lty = 2)
abline(v = q10$volume.cut.hat/1000)
abline(v = quantile(q10.sim.volume, p = c(0.05, 0.95)))
#qqnorm(base.sim.volume); qqline(base.sim.volume)
plot(ecdf(q10.sim.volume), xlim = c(0,100), main="CDF",
     xlab = expression(paste("Assessed Sawlog ('000 ", m^3, ")")))
lines(ecdf(base.sim.volume), col = "darkgrey")
abline(v = q10$volume.cut/1000, lty = 2)
abline(v = q10$volume.cut.hat/1000)
abline(v = quantile(q10.sim.volume, p = c(0.05, 0.95)))

## This provides us with, as hoped for, probabilistic information
## about the expected return.  For example, what is the probability of
## achieving the implied objective?

mean(q10.sim.volume > q10$volume.cut / 1000)

## How can this be related back to headroom?  10%? 20%? 30%?

mean(q10.sim.volume > q10$volume.cut * 0.9 / 1000) # 10% HR
mean(q10.sim.volume > q10$volume.cut * 0.8 / 1000) # 20% HR
mean(q10.sim.volume > q10$volume.cut * 0.7 / 1000) # 30% HR

quantile(q10.sim.volume, p = c(0.05, 0.95))

#### Compare with Base in Figure 3 (below)

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

## Try to minimize variance given constraints on volume

sum(to.cut$grossArea)

sum(to.cut$mu.hat)

to.cut$variance <- with(to.cut, mu.hat^2 * sigma.hat^2)

ops <- data.frame(year = c('y1'),
                  area = c(1000),
                  cut.out = c(17100))

# create an LP model

lpmodel.harvest <- make.lp(2*NROW(ops) + NROW(to.cut), NROW(ops) * NROW(to.cut))

# I used this to keep count within the loops, I admit that this could
# be done a lot neater

column <- 0
row <- 0

# build the model column per column

for(wg in ops$year){
  row <- row + 1
  for(coupe in seq(1, NROW(to.cut))){
    column <- column + 1
# this takes the arguments 'column','values' & 'indices' (as in where
# these values should be placed in the column)
    set.column(lpmodel.harvest,
               column,
               c(to.cut[coupe, 'mu.hat'], to.cut[coupe, 'grossArea'], 1),
               indices = c(row, NROW(ops) + row, NROW(ops)*2 + coupe))
  }}

# set rhs equipment constraints - first triplet
set.constr.value(lpmodel.harvest,                    # The lp model
                 rhs = ops$cut.out,                  # The values
                 constraints = seq(1, NROW(ops)))    # Where to put them

# set rhs area constraints - second triplet
set.constr.value(lpmodel.harvest,
                 rhs = ops$area,
                 constraints = seq(NROW(ops)+1, NROW(ops)*2))

# set rhs availability constraints - last quadruplet

set.constr.value(lpmodel.harvest,
                 rhs = rep(1, NROW(to.cut)),
                 constraints = seq(NROW(ops)*2+1, NROW(ops)*2+NROW(to.cut)))

set.constr.type(lpmodel.harvest,
                c(rep(">=", NROW(ops)),
                  rep("<=", NROW(ops)),
                  rep("<=", NROW(to.cut))))

# set objective coefficients - here the simulated average

set.objfn(lpmodel.harvest, rep(to.cut$variance, NROW(ops)))

# set objective direction

lp.control(lpmodel.harvest, sense='min')

# Ensure integers - works!

set.type(lpmodel.harvest, 1:length(get.type(lpmodel.harvest)), "integer")

# I in order to be able to visually check the model, I find it useful
# to write the model to a text file

write.lp(lpmodel.harvest, 'harvest.lp', type = 'lp')

# solve the model, if this return 0 an optimal solution is found

solve(lpmodel.harvest)

# this returns the proposed solution

get.objective(lpmodel.harvest)

# Coupe choices

(port.1 <- summary(lpmodel.harvest, target = to.cut))

out.1 <- simulate(port.1, nsim = 1000)

plot(density(out.1))

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

## Write a portfolio function

portfolio <- function(min.vol, target = to.cut, area = 2000) {
  ops <- data.frame(year = c('y1'),
                    area = c(area),
                    cut.out = c(min.vol))
  lpmodel.harvest <- make.lp(2*NROW(ops) + NROW(to.cut), NROW(ops) * NROW(to.cut))
  column <- 0
  row <- 0
  for(wg in ops$year){
    row <- row + 1
    for(coupe in seq(1, NROW(to.cut))){
      column <- column + 1
      set.column(lpmodel.harvest,
                 column,
                 c(to.cut[coupe, 'mu.hat'], to.cut[coupe, 'grossArea'], 1),
                 indices = c(row, NROW(ops) + row, NROW(ops)*2 + coupe))
    }}
  set.constr.value(lpmodel.harvest,                    # The lp model
                   rhs = ops$cut.out,                  # The values
                   constraints = seq(1, NROW(ops)))    # Where to put them
  set.constr.value(lpmodel.harvest,
                   rhs = ops$area,
                   constraints = seq(NROW(ops)+1, NROW(ops)*2))
  set.constr.value(lpmodel.harvest,
                   rhs = rep(1, NROW(to.cut)),
                   constraints = seq(NROW(ops)*2+1, NROW(ops)*2+NROW(to.cut)))
  set.constr.type(lpmodel.harvest,
                  c(rep(">=", NROW(ops)),
                    rep("<=", NROW(ops)),
                    rep("<=", NROW(to.cut))))
  set.objfn(lpmodel.harvest, rep(to.cut$variance, NROW(ops)))
  lp.control(lpmodel.harvest, sense='min')
  set.type(lpmodel.harvest, 1:length(get.type(lpmodel.harvest)), "integer")
  solve(lpmodel.harvest)
  return(summary(lpmodel.harvest, target = target))
}

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

minima <- (15:25)*1000

returns <- mclapply(minima, portfolio, mc.cores = 4)

lapply(returns, function(x) sum(x$cut.me))

sim.returns <- mclapply(returns, simulate, nsim = nsim, mc.cores = 4)

simexp <- data.frame(volume.cut = do.call(c, sim.returns),
                     minima = rep(minima, each = nsim))

ggplot(simexp,
       aes(x = factor(minima), y = volume.cut))  +
  geom_violin() +
  xlab(expression(paste("Minimum prescribed cut (", m^3, ")"))) +
  ylab(expression(paste("Achieved cut (", m^3, ")"))) +
  geom_point(aes(x = factor(minima), y = minima))

ggplot(simexp,
       aes(x = factor(minima), y = volume.cut))  +
  geom_boxplot() +
  xlab(expression(paste("Minimum prescribed cut (", m^3, ")"))) +
  ylab(expression(paste("Achieved cut (", m^3, ")")))

lapply(sim.returns, function (x) (var(x)) / mean(x))

cv <- function (x) (sd(x)) / mean(x)

sapply(sim.returns, cv)

sapply(sim.returns, sd)

sapply(sim.returns, mean)

sim.results <- data.frame(minima = minima,
                          mean = sapply(sim.returns, mean),
                          sd = sapply(sim.returns, sd),
                          cv = sapply(sim.returns, cv))

write.csv(sim.results, file = "simresults.csv", row.names = FALSE)

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

## What if we now try to achieve the same volume with min variance?

cf.base <- portfolio(mean(base.sim.volume)*1000)

cf.sim.volume <-
  sapply(1:10000,
         function(x)
         with(to.cut[cf.base$cut.me == 1,],
              sum(rGA(sum(cf.base$cut.me), # if n = 1 then randoms are correlated!
                      mu = mu.hat,
                      sigma = sigma.hat)))) / 1000

## Graphical summary.

par(mfrow=c(1,2), mar=c(5,4,3,2), las=1)
plot(density(base.sim.volume), xlim = c(20, 90), main="Distribution",
     xlab = expression(paste("Assessed Sawlog ('000 ", m^3, ")")))
lines(density(cf.sim.volume), col = "darkgrey")
abline(v = base$volume.cut/1000, lty = 2)
abline(v = base$volume.cut.hat/1000)
abline(v = quantile(base.sim.volume, p = c(0.05, 0.95)), lty = 3)
#qqnorm(base.sim.volume); qqline(base.sim.volume)
plot(ecdf(base.sim.volume), xlim = c(20, 90), main="CDF",
     xlab = expression(paste("Assessed Sawlog ('000 ", m^3, ")")))
lines(ecdf(q10.sim.volume), col = "grey")
lines(ecdf(cf.sim.volume), col = "darkgrey")
#abline(v = base$volume.cut/1000, lty = 2)
#abline(v = base$volume.cut.hat/1000)
#abline(v = quantile(base.sim.volume, p = c(0.05, 0.95)))

qq.base <- qqnorm(base.sim.volume, plot.it = FALSE)
qq.q10 <- qqnorm(q10.sim.volume, plot.it = FALSE)
qq.cf <- qqnorm(cf.sim.volume, plot.it = FALSE)

grain <- 1000

x.range <- (min(base.sim.volume) * 10):(max(base.sim.volume) * 10) / 10

flip <- function(object) return(list(x = object$y, y = object$x))

pdf(file = "Figure 3 ex.pdf", height = 3.5, width = 8)

par(mfrow=c(1,2), mar=c(5,4,1,2), las=1)
plot(density(base.sim.volume), main = "",
     xlab = expression(paste("Assessed HQ Sawlog ('000 ", m^3, ")")))
#lines(density(q10.sim.volume), col = "darkgrey")
abline(v = base$volume.cut/1000, lty = 2)
abline(v = base$volume.cut.hat/1000)
abline(v = quantile(base.sim.volume, p = c(0.05, 0.95)), lty = 3)

plot(with(flip(qq.base), predict(smooth.spline(x, y), x = x.range)),
     type = "l", axes = FALSE,
     ylim = c(-4, 4),
     xlab = expression(paste("Assessed HQ Sawlog ('000 ", m^3, ")")),
     ylab = expression(paste(F[x](X))))
box()
axis(1)
axis(2, at = c(-4:4), label = c("0", formatC(pnorm(-3:4))), cex.axis=0.8)
lines(with(flip(qq.q10), predict(smooth.spline(x, y), x = x.range)),
      type="l", lty = 2)
lines(with(flip(qq.cf), predict(smooth.spline(x, y), x = x.range)),
      type="l", lty = 3)
legend("bottomright", lty = 1:3, bty = "n", cex = 0.9,
       legend=c("Maximize Mean","Maximize Q10","Minimize Variance"))

dev.off()


# Below commands are for creating segmentation files and producing some QC images
# outputBasename used to construct names for files produced by this script

library(HMMcopy)

cmd_args=commandArgs(trailingOnly = TRUE)
# Arguments should be passed as: normal.wig, tumor.wig, refGC.wig, ref_mappable.wig, outputBasename
normalReads<-cmd_args[1]
tumorReads<-cmd_args[2]
gcContent<-cmd_args[3]
refMappable<-cmd_args[4]
outputBasename<-cmd_args[5]

tum_uncorrected_reads <- wigsToRangedData(tumorReads, gcContent, refMappable)
norm_uncorrected_reads <- wigsToRangedData(normalReads, gcContent, refMappable)
tum_corrected_copy <- correctReadcount(tum_uncorrected_reads)
norm_corrected_copy <- correctReadcount(norm_uncorrected_reads)

# Should take no longer than a few minutes on a human genome.
# The correctReadcount requires at least about 1000 bins to work properly.
# 2. Segmentation

# Below commands in R
# Normalizing Tumour by Normal
tum_corrected_copy$copy <- tum_corrected_copy$copy - norm_corrected_copy$copy

param <- HMMsegment(tum_corrected_copy, getparam = TRUE) # retrieve converged parameters via EM
param$mu <- log(c(1, 1.4, 2, 2.7, 3, 4.5) / 2, 2)
param$m <- param$mu
segmented_copy <- HMMsegment(tum_corrected_copy, param) # perform segmentation via Viterbi

# 3. Export
# Export to SEG format for CNAseq segmentation
segFile<-paste(outputBasename, "seg", sep = ".")
tsvFile<-paste(outputBasename, "tsv", sep = ".")

rangedDataToSeg(tum_corrected_copy, file = segFile)
write.table(segmented_copy$segs, file = tsvFile, quote = FALSE, sep = "\t")

options(bitmapType="cairo")
# 4. Visualization - produce some images with hard-coded dimensions

# Bias plots:
print("Producing CG Bias plot...")
png(filename = paste(outputBasename,"bias_plot","png", sep="."),width = 1200, height = 580, units="px", pointsize=15, bg="white")
plotBias(tum_corrected_copy)  # May be one plot per comparison  1200x580
dev.off()

chroms<-unique(segmented_copy$segs$chr)

# Segmentation plots:
# need to do it one plot per chromosome 1200x450
print("Producing Segmentation plots...")
par(mfrow = c(1, 1))
for (c in 1:length(chroms)) {
 if (!grepl("_",chroms[c]) && !grepl("M",chroms[c])) {
	 png(filename = paste(outputBasename,"s_plot", chroms[c], "png", sep="."),width = 1200, height = 450, units="px", pointsize=15, bg="white")
	 plotSegments(tum_corrected_copy, segmented_copy, pch = ".", ylab = "Tumour Copy Number", xlab = "Chromosome Position",chr = chroms[c], main = paste("Segmentation for Chromosome",chroms[c], sep=" "))
	 cols <- stateCols()
	 legend("topleft", c("HOMD", "HETD", "NEUT", "GAIN", "AMPL", "HLAMP"), fill = cols, horiz = TRUE, bty = "n", cex = 0.9)
	 dev.off()
 } else {
	 print(paste("Chromosome",c,"cannot be plotted with  plotSegments",sep = " "))
 }
}


require(ggplot2)
require(reshape2)

source('fmm_generative.r')

config = list(
    k = 4
  , n = 10000
  )

set.seed(42)

d      = model(config$k, config$n)
melted = melt(d)

p = ggplot(melted, aes(value, colour = factor(L1), fill = factor(L1))) +
      geom_density(alpha = 0.5)


library("tidyverse")
library("ggplot2")
library("ggrepel")
library("ggcorrplot")
library("DT")
library("gridExtra")
library("knitr")
library("ggpubr")

covid_data_2021_by_month <- read_csv("./data/Query1.csv")
data_final <- read_csv("./data/2020_2021_deaths_county_month.csv")

# Normalize population
data_final$original_total_pop <- data_final$total_pop
data_final <- data_final %>% mutate_at(c("total_pop"), ~(scale(.) %>% as.vector))

# get the new cases/deaths feature
data_offset <- filter(data_final, year == 2020 | (year == 2021 & month <= 11))
data_final <- filter(data_final, (year == 2020 & month >= 2) | year == 2021)

data_final$new_cases <- data_final$confirmed_cases - data_offset$confirmed_cases
data_final$new_deaths <- data_final$deaths - data_offset$deaths

# Get the rent burden feature
# Break up into Severe burden, rent burden and no burden

data_final$severe_burden = data_final$rent_over_50_percent / data_final$original_total_pop

data_final$rent_burden = (data_final$rent_40_to_50_percent +
                            data_final$rent_35_to_40_percent +
                            data_final$rent_30_to_35_percent) / data_final$original_total_pop
data_final$no_rent_burden = (data_final$rent_25_to_30_percent +
                               data_final$rent_20_to_25_percent +
                               data_final$rent_15_to_20_percent +
                               data_final$rent_10_to_15_percent +
                               data_final$rent_10_to_15_percent +
                               data_final$rent_under_10_percent) /
  data_final$original_total_pop

# Get cases/deaths per 1000
data_final$confirmed_cases_per1000 = data_final$confirmed_cases /
  (data_final$original_total_pop)*1000
data_final$deaths_per1000 = data_final$deaths /
  (data_final$original_total_pop)*1000

# Get the percentages of each population group
data_final$white_pop_per = data_final$white_pop / data_final$original_total_pop
data_final$black_pop_per = data_final$black_pop / data_final$original_total_pop
data_final$asian_pop_per = data_final$asian_pop / data_final$original_total_pop
data_final$hispanic_pop_per = data_final$hispanic_pop / data_final$original_total_pop
data_final$amerindian_pop_per = data_final$amerindian_pop / data_final$original_total_pop
data_final$other_race_pop_per = data_final$other_race_pop / data_final$original_total_pop
data_final$two_or_more_races_pop_per = data_final$two_or_more_races_pop / data_final$original_total_pop
data_final$not_hispanic_pop_per = data_final$not_hispanic_pop / data_final$original_total_pop

temp <- data_final %>% select(total_pop, original_total_pop, no_rent_burden, rent_burden,
                      severe_burden, median_income, new_cases, new_deaths,
                      deaths_per1000, confirmed_cases_per1000, month, year,
                      white_pop_per, black_pop_per, asian_pop_per, hispanic_pop_per,
                      amerindian_pop_per, other_race_pop_per, two_or_more_races_pop_per,
                      not_hispanic_pop_per)
temp
temp %>% write.csv(file = "datatable.csv")

temp %>% summary()

hist(x=x,breaks=10)

col_names <- colnames(temp)
x <- as.numeric(unlist(temp[col_names[1]]))
p <- ggplot(data_final, mapping = aes(x=x)) +
  geom_histogram(bins = 20) + ggtitle(col_names[1])

plots <- vector('list', ncol(temp))
for (i in 1:length(col_names)){
  x <- as.numeric(unlist(temp[col_names[i]]))
  filename <- sprintf(".\\charts\\%s.png", col_names[i])
  print(filename)
  ggplot(data_final, mapping = aes(x=x)) +
    xlab(col_names[i]) +
    geom_histogram(bins = 20) + ggtitle(col_names[i])

  ggsave(filename = filename, width = 3, height = 3)
}
plots
plots[3]


# directorio donde radican los datos
setwd("~/Desktop/sip/data/")

# lee datos
ft <- read.csv("ft-outdoors-infect.csv")
head(ft)

# dummy outdoors
ft$doutdoors <- 1 - ft$dindoors

# factors
ft$outdoors <- as.factor(ft$doutdoors)
levels(ft$outdoors) <- c("indoors", "outdoors")
ft$infect <-   as.factor(ft$dinfect)
levels(ft$infect) <-   c("0 secondary", ">0 secondary")

# xtab
table(ft$infect, ft$outdoors)
(16/6) / (11/77)

t <- table(ft$ninfect[ft$dinfect>0], ft$outdoors[ft$dinfect>0])
plot(t, col = c("gray","lightblue"))


library(foreach)
library(doSNOW)

source("codeKfixedLOG.r")
source("codeKvariable.r")
source("ncpu.r")

cl=makeCluster(ncpu, type = "SOCK")
registerDoSNOW(cl)

res=foreach(iter = 1:1000)%dopar%{
library(snipEM)
library(mvtnorm)
set.seed(iter+100)
pi=array(NA,c(kmax,kmax))
PI=array(NA,c(kmax,kmax,kmax,kmax))
pi[1,1]=PI[,1,,1]=1
for(j in 2:kmax) {
pi[j,1:j]=1/j}
for(h in 2:kmax) {
for(j in 1:kmax) {
if(j>1) {
PI[j,h,1:j,1:h]=1
if(h>1 & j>1) {
diag(PI[j,h,1:j,1:h])=pers+j
PI[j,h,1:j,1:h]=PI[j,h,1:j,1:h]/apply(PI[j,h,1:j,1:h],1,sum)
}}
if(j==1) {
PI[j,h,1,1:h]=1
PI[j,h,1,1]=pers+j
PI[j,h,1:j,1:h]=PI[j,h,1:j,1:h]/sum(PI[j,h,1:j,1:h])
}}}

inits=list()
inits$pi=pi
inits$PI=PI

xi=array(1,c(kmax,kmax,3))
sigma=xi
for(j in 1:kmax) {
for(u in 1:r) {
xi[j,1:j,u]=seq(0,sepp*j,length=j)}}
inits$xi=xi
inits$sigma=sigma
## generate data ###

y=array(NA,c(n,Ti,3))
prob=pi[k[1],1:k[1]]
u=sample(k[1],n,replace=TRUE,prob=prob)
y[,1,1]=rnorm(n,xi[k[1],u,1])
y[,1,2]=rnorm(n,xi[k[1],u,2])
y[,1,3]=rnorm(n,xi[k[1],u,3])
for(ti in 2:Ti) {
prob=PI[k[ti-1],k[ti],u,1:k[ti]]
for(i in 1:n) {
u[i]=sample(k[ti],1,replace=TRUE,prob=prob[i,])}
y[,ti,1]=rnorm(n,xi[k[ti],u,1])
y[,ti,2]=rnorm(n,xi[k[ti],u,2])
y[,ti,3]=rnorm(n,xi[k[ti],u,3])
}

## estimate models

rl2=try(rlm.fixed(y,k))
rlmin=try(rlm.fixed(y,k=rep(min(k),Ti)))
rlmax=try(rlm.fixed(y,k=rep(max(k),Ti)))
rl=try(rlm(y,lambda=0.1,kmax,cmax=1))
res=list()

# eval
res$rl=rl
res$rlfixed=rl2
res$rlmin=rlmin
res$rlmax=rlmax
res$ktrue=k

return(res)}

stopCluster(cl)

sp=ifelse(sepp>2.5,3,2)
save(res,file=paste("s",sp,"n",n,"TT",Ti,"r",r,"k",paste(k,collapse=""),".rda",sep=""))


dependencies <- as.character(unlist(scan('/tmp/requirements.txt', what=list(libraries=character()), quiet = TRUE)))

for (dep in dependencies){
    if(grepl('#', dep)){print(sprintf("Skipping %s", dep));next}
    library(dep, character.only=TRUE)
}

library(flexioR)
library(magrittr)

if ("keras" %in% dependencies) {
	model <- keras_model_sequential()
	model %>%
  	layer_dense(units = 256, activation = 'relu', input_shape = c(784)) %>%
  	layer_dropout(rate = 0.4) %>%
  	layer_dense(units = 128, activation = 'relu') %>%
  	layer_dropout(rate = 0.3) %>%
  	layer_dense(units = 10, activation = 'softmax')
}


rm(list=ls())
#library(caret) # for dummyVars
#library(RCurl) # download https data
library(Metrics) # calculate errors
library(xgboost) # model

###############################################################################
LOG = "tmp.log" #"CV_Train_Test.log"
STD = "tmp.std" #"CV_Train_Test.STD"
TRFile = "TR_Mul_Feat.csv"
###############################################################################

#~ skipFun(){

#~ 	}

MultiLogLoss <- function(act, pred)
{
  eps = 1e-15;
  nr <- nrow(pred)
  pred = matrix(sapply( pred, function(x) max(eps,x)), nrow = nr)
  pred = matrix(sapply( pred, function(x) min(1-eps,x)), nrow = nr)
  ll = sum(act*log(pred) + (1-act)*log(1-pred))
  ll = ll * -1/(nrow(act))
  # print (ll)
  return(ll);
}

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

TrainSet <- read.csv(TRFile, header=F)
dim(TrainSet)
names(TrainSet) <- c(1:19,"class")
names(TrainSet)

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

outcomeName <- c('class')
predictors <- names(TrainSet)[!names(TrainSet) %in% outcomeName]
adultsTrsf <- TrainSet

# play around with settings of xgboost - eXtreme Gradient Boosting (Tree) library
# https://github.com/tqchen/xgboost/wiki/Parameters
# max.depth - maximum depth of the tree
# nrounds - the max number of iterations

# take first 40% of the data only!
#~ trainPortion <- floor(nrow(adultsTrsf)*0.4)
#~ trainSet <- adultsTrsf[ 1:floor(trainPortion/2),]
#~ testSet <- adultsTrsf[(floor(trainPortion/2)+1):trainPortion,]

# take random 40% of the data only!
size=nrow(adultsTrsf)*0.6
set.seed(1291)
selected=sample(nrow(adultsTrsf),size)
trainPortion <- adultsTrsf[selected,]
otherPortion <- adultsTrsf[-selected,]

dtrain = xgb.DMatrix(data = as.matrix(trainPortion[,predictors]), label = trainPortion[,outcomeName])
dtest = xgb.DMatrix(data = as.matrix(otherPortion[,predictors]), label = otherPortion[,outcomeName])

watchlist <- list(train=dtrain, test=dtest)

sink(STD, append=T, split=F)

  for (tmp.eta in seq(0.1,1,0.05)) { 					#n=19	#n=120 increase
    #~ for (tmp.eta in seq(0.3,0.3,0.001)) {
    print (paste("tmp.eta",tmp.eta))
      for (tmp.cols in seq(0.3,0.3,-0.1)) { 					#n=1
        #~ for (tmp.cols in seq(0.3,0.3,0.1)) {
        print (paste("tmp.cols",tmp.cols))
        for (tmp.fold in seq(5,5,10)) { 					#n=1
          #~ for (tmp.fold in seq(3,3,20)) {
          print (paste("tmp.fold",tmp.fold))
          for (tmp.child in seq(3,3,-0.5)) { 					#n=1
            #~ for (tmp.child in seq(3,3,20)) {
            print (paste("tmp.child",tmp.child))
            for (tmp.delta in c(1.4,1.8)) { 				#n=2 seq(2,0,-0.2)
              #~ for (tmp.delta in seq(10,10,0.1)) {
              print (paste("tmp.delta",tmp.delta))
              for (tmp.depth in seq(30,20,-2)) {					#n=2  c(5,10,15,20)
                #~ for (tmp.depth in seq(5,5,1)) {
                print (paste("tmp.depth",tmp.depth))

            ###############################################################################
            # parameters

            #~ nrounds=1000
            nrounds=100
            cv.nfolds=tmp.fold #10
            param <- list(
              max.depth=tmp.depth,		#5,
              eta=tmp.eta,				#0.6,
              max_delta_step=tmp.delta,	#1,
              colsample_bytree=tmp.cols,	#0.6,
              min_child_weight=tmp.child,	#1
              objective='multi:softprob',
              eval_metric="mlogloss",
              num_class =3,
              verbose=1,
              nthread = 120
            )

            ###############################################################################
            #CV

            # train
            cvBegin=proc.time()
            bstCVres <- xgb.cv(
              param,
              data = dtrain,
              nrounds,
              subsample=0.6,
              early.stop.round=5,
              nfold=cv.nfolds)
            cvEnd=proc.time()
            cvTime=cvEnd-cvBegin

            mloglossCV=min(bstCVres[,test.mlogloss.mean])
            bstRoundCV=which.min(bstCVres[,test.mlogloss.mean])
            ###############################################################################
            #train

            trainBegin=proc.time()
            bst <- xgb.train(
              param,
              data = dtrain,
              bstRoundCV,
              watchlist=watchlist
            )
            gc()
            trainEnd=proc.time()
            trainTime=trainEnd-trainBegin

            ###############################################################################
            # predict

            predBegin=proc.time()
            predictions <- xgboost::predict(bst, as.matrix(otherPortion[,predictors]))
            predictions <- matrix(predictions, ncol = 3, byrow = TRUE)
            # err <- rmse(as.numeric(testSet[,outcomeName]), as.numeric(predictions))
            actual <- matrix(0, nrow(otherPortion), 3)
            for (z in 1:nrow(otherPortion)){
              actual[z,otherPortion[z,outcomeName]+1] <- 1
            }
            # print (act)
            # print (dim(predictions))
            err <- MultiLogLoss(actual,predictions)
            #print(param)
            #print(paste("External-mlogloss:",err))
            predEnd=proc.time()
            predTime=predEnd-predBegin

            ###############################################################################
            # logging

            write(
              c(
                "External-mlogloss: ",		round(err,4),
                "mloglossCV: ",				round(mloglossCV,4),

                "maxDepth: ",				param$max.depth,
                "min_child_weight: ", 		param$min_child_weight,
                "etaStep: ",				param$eta,
                "deltaStep: ",				param$max_delta_step,
                "colSample: ",				param$colsample_bytree,
                #~ 		"nrounds: ",				nrounds,

                "cvfolds: ",				cv.nfolds,
                #~ 		"mloglossCV: ",				round(mloglossCV,4),
                #~ 		"bstRoundCV: ",				bstRoundCV,
                "cvTime (sec): ",			round(cvTime[1:3],2),
                "trainTime (sec): ",		round(trainTime[1:3],2),

                #~ 		"External-mlogloss: ",		round(err,4),
                "predTime (sec): ",			round(predTime[1:3],2),

                "totalTime (sec): ",			round(predTime[3]+trainTime[3]+cvTime[3],2),
                "totalTime (min): ",			round((predTime[3]+trainTime[3]+cvTime[3])/60,2),

                "nrounds: ",				nrounds,
                "bstRoundCV: ",				bstRoundCV

              ),ncolumns=100,sep="\t",file=LOG,append=T)

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

          }#tmp.child
        }#tmp.fold
      }#tmp.cols
    }#tmp.delta
  }#tmp.eta
}#tmp.depth

sink()


model_leafnumber <- function (deltaTT = 23.5895677277199,
         phyllochron_t1 = 0.0,
         hasFlagLeafLiguleAppeared = 0,
         leafNumber_t1 = 0.0,
         phase = 1.0){
    #'- Name: LeafNumber -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: CalculateLeafNumber Model
    #'            * Author: Pierre MARTRE
    #'            * Reference: Modeling development phase in the
    #'                Wheat Simulation Model SiriusQuality.
    #'                See documentation at http://www1.clermont.inra.fr/siriusquality/?page_id=427
    #'            * Institution: INRA Montpellier
    #'            * Abstract: calculate leaf number. LeafNumber increase is caped at one more leaf per day
    #'- inputs:
    #'            * name: deltaTT
    #'                          ** description : daily delta TT
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : -20
    #'                          ** max : 100
    #'                          ** default : 23.5895677277199
    #'                          ** unit : °C d
    #'                          ** inputtype : variable
    #'            * name: phyllochron_t1
    #'                          ** description : phyllochron
    #'                          ** variablecategory : state
    #'                          ** inputtype : variable
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 1000
    #'                          ** default : 0
    #'                          ** unit : °C d leaf-1
    #'            * name: hasFlagLeafLiguleAppeared
    #'                          ** description : true if flag leaf has appeared (leafnumber reached finalLeafNumber)
    #'                          ** variablecategory : state
    #'                          ** datatype : INT
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** default : 0
    #'                          ** unit :
    #'                          ** inputtype : variable
    #'            * name: leafNumber_t1
    #'                          ** description :  Actual number of phytomers
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 25
    #'                          ** default : 0
    #'                          ** unit : leaf
    #'                          ** inputtype : variable
    #'            * name: phase
    #'                          ** description :  the name of the phase
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 7
    #'                          ** default : 1
    #'                          ** unit :
    #'                          ** uri : some url
    #'                          ** inputtype : variable
    #'- outputs:
    #'            * name: leafNumber
    #'                          ** description : Actual number of phytomers
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : leaf
    #'                          ** uri : some url
    leafNumber <- leafNumber_t1
    if (phase >= 1.0 && phase < 4.0)
    {
        if (hasFlagLeafLiguleAppeared == 0)
        {
            if (phyllochron_t1 == 0.0)
            {
                phyllochron_ <- 0.0000001
            }
            else
            {
                phyllochron_ <- phyllochron_t1
            }
            leafNumber <- leafNumber_t1 + min(deltaTT / phyllochron_, 0.999)
        }
    }
    return (list('leafNumber' = leafNumber))
}


#required packages
library("openxlsx")
library("stringr")
library(ComplexHeatmap)
library(circlize)
library(colorspace)
library(GetoptLong)
library(ggplot2)
library(gplots)
library(survival)
require("survival")
# install.packages("svglite")
library(survminer)
library(reticulate)

#set the project path
project_path = "./project/"

#load patient data (include survival info)
# study_cohort = read.xlsx(paste(project_path, "data/study_cohort.xlsx",sep=""), sheet = 1, colNames = TRUE)
cptac_cohort = read.xlsx(paste(project_path, "data/external/cptac_cohort.xlsx",sep=""), sheet = 1, colNames = TRUE)
target_cohort = read.xlsx(paste(project_path, "data/external/target_cohort.xlsx",sep=""), sheet = 1, colNames = TRUE)

length(rownames(target_cohort))

length(rownames(cptac_cohort))

#calculate the risk score based on expression and coef of the signature
#use coef estimated in TCGA study cohort

target_cohort$risk_lnc = (
    target_cohort$ENSG00000187185.4   * 0.11098351	+
    target_cohort$ENSG00000259641.4 * -0.76093818+
    target_cohort$ENSG00000218510.5 * -0.03033684 +
    target_cohort$ENSG00000257989.1 * -0.12374097 +
    target_cohort$ENSG00000206567.8 * -0.14095109 )

cptac_cohort$risk_lnc = (
    cptac_cohort$ENSG00000187185.4   * 0.11098351+
    cptac_cohort$ENSG00000259641.4 * -0.76093818+
    cptac_cohort$ENSG00000218510.5 * -0.03033684 +
    cptac_cohort$ENSG00000257989.1 * -0.12374097 +
    cptac_cohort$ENSG00000206567.8 * -0.14095109 )

#calculate the time-dependent roc (lncrna signature on external cohort)
library(timeROC)
targetROC<-timeROC(T=target_cohort$OS,# survival time

delta=target_cohort$Censor,# results, alive or death

marker=target_cohort$risk_lnc,# variables

cause=1,

weighting="marginal",

times=c(365*5,365*3),# time, survival at 3, 5 years

ROC = TRUE,

iid = TRUE)
targetROC

library(timeROC)
cptacROC<-timeROC(T=cptac_cohort$OS,# survival time

delta=cptac_cohort$Censor,# results, alive or death

marker=cptac_cohort$risk_lnc,# variables

cause=1,

weighting="marginal",

times=c(365*5,365*3),# time, survival at 3, 5 years

ROC = TRUE,

iid = TRUE)
cptacROC

#calculate hazard ratio
fit1 = coxph(Surv(OS, Censor) ~

risk_lnc
, data=target_cohort)

# summary(fit)

HR <- exp(coef(fit1))
CI <- exp(confint(fit1))
P <- coef(summary(fit1))[,5]
COEF <- coef(fit1)

colnames(CI) <- c("Lower", "Higher")

table22 <- as.data.frame(cbind(HR, CI,COEF, P))
table22

#calculate hazard ratio
fit1 = coxph(Surv(OS, Censor) ~

risk_lnc
, data=cptac_cohort)

# summary(fit)

HR <- exp(coef(fit1))
CI <- exp(confint(fit1))
P <- coef(summary(fit1))[,5]
COEF <- coef(fit1)

colnames(CI) <- c("Lower", "Higher")

table22 <- as.data.frame(cbind(HR, CI,COEF, P))
table22

title = paste(project_path,"results/target_cptac_time-dependent-roc", ".pdf", sep="")

#plot the time-dependent roc
plot(targetROC,time=365*3,col = "red",lwd=2,add =FALSE, title="")

plot(targetROC,time=365*5,col = "blue",lwd=2,add =TRUE)

plot(cptacROC,time=365*3,col = "green",lwd=2,add =TRUE)

legend("bottomright", c( "TARGET: ROC at 3 years (AUC = 0.60)", "TARGET: ROC at 5 years (AUC = 0.59)", "CPTAC: ROC at 3 years (AUC = 0.75)"), lty=c(1,1,1), lwd=c(2,2,2),col = c("red", "blue","green"), bty="n")

# dev.off()

#calculate the median risk score (lncrna signature)
mediam_risk_score = median(as.numeric(as.vector(target_cohort$risk_lnc)))
# mediam_risk_score = -0.221
target_cohort$risk_cluster <- 1
target_cohort$risk_cluster[which(target_cohort$risk_lnc <= mediam_risk_score)] <- 0
# mediam_risk_score

#plot the survival difference
library(survival)
require("survival")
# install.packages("svglite")
library(survminer)

dif = survdiff(Surv(OS, Censor) ~risk_cluster, data = target_cohort)
pv = pchisq(dif$chisq, length(dif$n)-1, lower.tail = FALSE)
pv = formatC(pv, format = "e", digits = 2)
ret = c("Log-rank\r\np = ",pv)
pvalue=paste(ret[1],ret[2], sep="")

fit<- survfit(Surv(OS, Censor) ~ risk_cluster, data = target_cohort)

p <- ggsurvplot(fit, data=target_cohort,risk.table = TRUE,tables.theme = theme_cleantable(),palette = c("#E7B890", "#2E9FCF"), ggtheme = theme_bw(),surv.median.line = "hv",legend.title = "Risk Score", legend.labs = c("Low", "High"), xlab='Time (days)', conf.int = TRUE,pval = pvalue,pval.method=TRUE,conf.int.style='ribbon', conf.int.alpha=0.1)

p = p + theme_survminer( font.main = c(16, "bold", "darkblue"), font.submain = c(15, "bold", "purple"), font.caption = c(14, "plain", "orange"), font.x = c(14, "bold"), font.y = c(14, "bold"), font.tickslab = c(12, "plain") )

p

# save the results
title = paste(project_path, "results/RiskScore-Survival-Target.tiff",sep="")
tiff(title, width=480*7, height=480*7, units="px", res=96*6, compression = "lzw")
print(p, newpage = FALSE)
dev.off()

mediam_risk_score = median(as.numeric(as.vector(cptac_cohort$risk_lnc)))
# mediam_risk_score = -0.221
cptac_cohort$risk_cluster <- 1
cptac_cohort$risk_cluster[which(cptac_cohort$risk_lnc <= mediam_risk_score)] <- 0
# mediam_risk_score

dif = survdiff(Surv(OS, Censor) ~risk_cluster, data = cptac_cohort)
pv = pchisq(dif$chisq, length(dif$n)-1, lower.tail = FALSE)
pv = formatC(pv, format = "e", digits = 2)
ret = c("Log-rank\r\np = ",pv)
pvalue=paste(ret[1],ret[2], sep="")

fit<- survfit(Surv(OS, Censor) ~ risk_cluster, data = cptac_cohort)

p <- ggsurvplot(fit, data=cptac_cohort,risk.table = TRUE,tables.theme = theme_cleantable(),palette = c("#E7B890", "#2E9FCF"), ggtheme = theme_bw(),surv.median.line = "hv",legend.title = "Risk Score", legend.labs = c("Low", "High"), xlab='Time (days)', conf.int = TRUE,pval = pvalue,pval.method=TRUE,conf.int.style='ribbon', conf.int.alpha=0.1)

p = p + theme_survminer( font.main = c(16, "bold", "darkblue"), font.submain = c(15, "bold", "purple"), font.caption = c(14, "plain", "orange"), font.x = c(14, "bold"), font.y = c(14, "bold"), font.tickslab = c(12, "plain") )

p

title = paste(project_path, "results/RiskScore-Survival-CPTAC.tiff",sep="")
tiff(title, width=480*7, height=480*7, units="px", res=96*6, compression = "lzw")
print(p, newpage = FALSE)
dev.off()


library(tidyverse)
library(janitor)

df <- read.delim("input 01-21.txt", header = F)

# Part I ------------------------------------------------------------------
janitor::tabyl(
df %>%
  mutate(dir = ifelse(lag(V1)>V1, "decrease", "increase")), dir
)

# Part II -----------------------------------------------------------------
janitor::tabyl(
df %>%
  mutate(depth = V1 + lag(V1) + lag(V1, n = 2L),
         dir = case_when(lag(depth) > depth ~ "decrease",
                         lag(depth) < depth ~ "increase",
                         lag(depth) == depth ~ NA_character_)), dir
)


missing_values <- function(dataset)
{
  for (i in 1:ncol(dataset))
  {
    if (is.numeric(dataset[,i]))
    {
      dataset[,i][is.na(dataset[,i])] = mean(is.na(dataset[,i])==F)
      next
    }
    if (is.factor(dataset[,i]))
    {
      dataset[,i][is.na(dataset[,i])] = tail(names(sort(table(dataset[,i]))), 1)
      next
    }
  }
  return(dataset)
}

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

outliers_grubbs <- function(dataset, alpha)
{
  for (i in 1:ncol(dataset))
  {
    if (is.numeric(dataset[,i])==TRUE)
    {
      while (grubbs.test(as.numeric(dataset[,i]))$p.value < alpha)
      {
        p1 <- grubbs.test(as.numeric(dataset[,i]))$alternative
        p2 <- readr::parse_number(p1)
        dataset <- dataset[-which(dataset[,i] %in% p2), ]
      }
    }
  }
  return(dataset)
}

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

coefficient_of_variation <- function(k) {
  x <- sd(k)/mean(k)
  return(as.numeric(x))
}


# MIT License
# Copyright (c) 2020 Abhinav Prakash, Vijay Panchang, Yu Ding, and Lewis Ntaimo

# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:

# The above copyright notice and this permission notice shall be included in all
# copies or substantial portions of the Software.

# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
# SOFTWARE.

source("function.r")
inputfile = "hackensack.csv"
outputfile = "Results/hackensack_constrained_MCMC_"
outputplot = "Hackensack River"
data_col = 3
year_col = 1
ReferenceYear = 2018
ReturnPeriod = 100
burn_in = 500
CSVFile = read.csv(file = inputfile, header = T)
Data = CSVFile[,data_col]
Year = CSVFile[,year_col]
time_index = time.index(Year,ReferenceYear)
parameters = draw.MCMC.samples(Data,time_index,InitialValues = c(50,1,20,0.8),LocationInterceptPrior = c(0,200),LocationSlopePrior = c(-5,5),ScalePrior = c(-50,50),ShapePrior = c(-1,1),ProposalWidth = c(2,0.15,1,0.05),n_samples=10000)
parameters = parameters[-c(1:burn_in),]
mu_post = parameters[,1]
muslope_post = parameters[,2]
scale_post = parameters[,3]
shape_post = parameters[,4]

### Expected and MAP Values of the parameters and the return event
bw = c(2,0.02,0.75,0.020,10)
d_mu = density(mu_post, bw = bw[1])
d_muslope = density(muslope_post, bw = bw[2])
d_scale = density(scale_post, bw= bw[3])
d_shape = density(shape_post, bw = bw[4])
mu_exp = mean(mu_post)
mu_map = d_mu$x[which.max(d_mu$y)]
muslope_exp = mean(muslope_post)
muslope_map = d_muslope$x[which.max(d_muslope$y)]
scale_exp = mean(scale_post)
scale_map = d_scale$x[which.max(d_scale$y)]
shape_exp =mean(shape_post)
shape_map = d_shape$x[which.max(d_shape$y)]
NLLH_exp = likelihood.val(Data,time_index,mu_exp,muslope_exp,scale_exp,shape_exp)
NLLH_map = likelihood.val(Data,time_index,mu_map,muslope_map,scale_map,shape_map)
cat("Expected Values of the Parameters:",'\n')
cat("Location Intercept:", mu_exp, '\n')
cat("Location Slope:", muslope_exp, '\n')
cat("Scale:",scale_exp, '\n')
cat("Shape:", shape_exp, '\n')
cat("NLLH:", NLLH_exp, '\n')
cat('\n',"MAP values of the Parameters:",'\n')
cat("Location Intercept:", mu_map, '\n')
cat("Location Slope:", muslope_map, '\n')
cat("Scale:",scale_map, '\n')
cat("Shape:", shape_map, '\n')
cat("NLLH:", NLLH_map, '\n')


# 산술연산

tot1 <- -5
tot2 <- 10

tot1+tot2
tot1-tot2
tot1*tot2
tot1/tot2
tot1^tot2

# 마지막 것은 제곱 **로 해도 됨


suppressWarnings(suppressPackageStartupMessages(library(lavaan)))
suppressWarnings(suppressPackageStartupMessages(library(tidyr)))

processVoxel <- function(v) {
    # Get all participant connectivity values for voxel v
    Y <- voxeldat[,v]

    # Merge covariates with voxel data, designmat is global in the npoint script
    df <- data.frame(designmat$idnum, designmat$time, designmat$mfq,
                     designmat$age, designmat$ECLVol.icv.scl1000, Y)

    # Rename cols to sensible variables. E.g., "designmat.idnum" becomes "idnum"
    colnames(df) <- c("idnum", "time", "mfq", "age", "ECLVol.icv.scl1000", "Y")

    # Widen the data for lavaan
    df_w <- reshape(df, idvar="idnum", timevar="time", direction="wide")

    require(lavaan)

    # Specify the LGM
    cor_lgc_model <- '
    # Intercept and Slope, Time unit Approx 18 months
    i =~ 1*Y.1 + 1*Y.2 + 1*Y.3
    s =~ 0*Y.1 + 1*Y.2 + 2*Y.3

    i_vol =~ 1*ECLVol.icv.scl1000.1 + 1*ECLVol.icv.scl1000.2 + 1*ECLVol.icv.scl1000.3
    s_vol =~ 0*ECLVol.icv.scl1000.1 + 1*ECLVol.icv.scl1000.2 + 2*ECLVol.icv.scl1000.3

    # Regressions
    i ~ age.1 + mfq.1
    s ~ age.1 + mfq.1
    i_vol ~ age.1 + mfq.1
    s_vol ~ age.1 + mfq.1 + i + s

    # Variances and covariances explicitly coded
    i ~~ s
    i_vol ~~ s_vol
    '

    # Try to fit the LGM for the voxel
    e <- try(fit <- lavaan::growth(cor_lgc_model, data=df_w,
                                   estimator="MLR", missing="ML"))

    # Return -999 for everything if model didn't fit
    if(inherits(e, "try-error")) {
        message("error thrown at voxel ", v)
        message(e)
        fit <- NULL
    }

    # Check residual variances for negative values. If the negative variances
    # are small enough though and SEs suggest that values could be greater than
    # 0, the negative variance could be due to sampling error - constrain the
    # residual variance to 0 and try again
    if (!is.null(fit)) {
        unstd_ests <- parameterEstimates(fit)
        vars <- subset(unstd_ests, op=="~~" & lhs==rhs)
        vars <- na.omit(vars)
        # If there are small negative variances constrain to positive value
        # and run again, else set fit to null and return -999 for everything
        if (sum(vars$est < 0) > 0) {
            # Create an updated model
            updated_model <- cor_lgc_model
            # Run through all variances and covariances
            for (i in 1:nrow(vars)){
                # Check if any variance < 0
                if ((vars[i,]$est < 0)) {
                    # If variance negative and the 95% confidence interval
                    # suggests that variance could be greater than 0, then
                    # constrain the residual variance to 0
                    if ((vars[i,]$est + vars[i,]$se*1.96 > 0)) {
                        # Add residual variance constraint to model
                        updated_model <- paste0(updated_model, "\n",
                                                vars[i,]$lhs, "~~0*",
                                                vars[i,]$rhs)
                    }
                }
            }

            e <- try(fit <- lavaan::growth(updated_model, data=df_w,
                                            estimator="MLR", missing="ML"))

            if(inherits(e, "try-error")) {
                message("error thrown at voxel",v)
                message(e)
                fit <- NULL
            }
        }
    }

    # If there are still negative latent variances. The voxel is beyond saving
    if (!is.null(fit)) {
        unstd_ests <- parameterEstimates(fit)
        vars <- subset(unstd_ests, op=="~~" & lhs==rhs)
        if (sum(vars$est < 0) > 0) {
            # Negative variances Exist. Set fit to NULL and return -999 for all
            fit <- NULL
        }
    }

    # Return -999 if model did not converge
    if (!is.null(fit)) {
        e2 <- try(fitStatsDummy <- fitmeasures(fit))
        if(inherits(e2, "try-error")) {
            message("convergence error thrown at voxel", v)
            message(e2)
            fit <- NULL
        }
    }

    # If the model ran successfully, extract fit stats and parameter estimates
    if (!is.null(fit)) {
        # Unstandardized Parameter Estimates
        unstd_ests <- parameterEstimates(fit)

        # Standardized Parameter Estimates
        param_ests <- standardizedsolution(fit)

        # Name parameters/pathways in the measurement and structural model
        param_ests$name <- paste0(param_ests$lhs, param_ests$op, param_ests$rhs)

        # Getp values from unstandardized solution and add to standardized ests
        param_ests$pvalue <- unstd_ests$pvalue

        # Get fit measures of interest
        fitStats <- fitmeasures(fit, c("chisq", "df.scaled", "pvalue", "rmsea",
                                       "rmsea.ci.lower", "rmsea.ci.upper",
                                       "cfi", "tli", "srmr"))

        # Return unstandardized and standardized estimates
        latent_int <- unstd_ests[unstd_ests$lhs %in% c('i', 's', 'i_vol', 's_vol') &
                                 unstd_ests$op %in% c('~1'),]
        latent_reg <- unstd_ests[unstd_ests$lhs %in% c('i', 's', 'i_vol', 's_vol') &
                                 unstd_ests$op %in% c('~'),]
        latent_varcov <- unstd_ests[unstd_ests$lhs %in% c('i', 's', 'i_vol', 's_vol') &
                                    unstd_ests$op %in% c('~~'),]

        latent_int_std <- param_ests[param_ests$lhs %in% c('i', 's', 'i_vol', 's_vol') &
                                     param_ests$op %in% c('~1'),]
        latent_reg_std <- param_ests[param_ests$lhs %in% c('i', 's', 'i_vol', 's_vol') &
                                     param_ests$op %in% c('~'),]
        latent_varcov_std <- param_ests[param_ests$lhs %in% c('i', 's', 'i_vol', 's_vol') &
                                        param_ests$op %in% c('~~'),]

        # Bind all coefficients of interest together
        ret <- rbind(latent_int, latent_reg, latent_varcov)
        ret_std <- rbind(latent_int_std, latent_reg_std, latent_varcov_std)

        # Make sure there is a column 'name' to sort by before proceeding
        if(! "name" %in% colnames(ret)){
            ret$name <- paste0(ret$lhs, ret$op, ret$rhs)
        }

        if(! "name" %in% colnames(ret_std)){
            ret_std$name <- paste0(ret_std$lhs, ret_std$op, ret_std$rhs)
        }

        # Make sure order of coefficients is correct
        ret <- ret[order(ret$name),]
        ret_std <- ret_std[order(ret_std$name),]

        # Create a new container for values to return to npoint, only keep
        # estimates and pvalues
        retvals <- c(ret$est, ret$pvalue, ret_std$est.std, ret_std$pvalue, fitStats)

        # Rename  the return values
        names(retvals) <-c(paste(ret$name, ".est", sep=""),
                           paste(ret$name, ".pvalue", sep=""),
                           paste(ret_std$name,".est_std", sep=""),
                           paste(ret_std$name, ".pvalue_std", sep=""),
                           "chisq", "df", "pvalue", "rmsea", "rmsea.ci.lower",
                           "rmsea.ci.upper", "cfi", "tli", "srmr")

    } else {
        # If the LGM didn't fit, e.g., from negative latent variances or from
        # other potential convergence issues, then return -999 for everything
        retvals <- rep(-999, 89)
        names(retvals) <- c("i_vol~~i_vol.est", "i_vol~~s_vol.est",
                            "i_vol~1.est", "i_vol~age.1.est", "i_vol~mfq.1.est",
                            "i~~i.est", "i~~s.est", "i~1.est", "i~age.1.est",
                            "i~mfq.1.est", "s_vol~~s_vol.est", "s_vol~1.est",
                            "s_vol~age.1.est", "s_vol~i.est", "s_vol~mfq.1.est",
                            "s_vol~s.est", "s~~s.est", "s~1.est", "s~age.1.est",
                            "s~mfq.1.est", "i_vol~~i_vol.pvalue",
                            "i_vol~~s_vol.pvalue", "i_vol~1.pvalue",
                            "i_vol~age.1.pvalue", "i_vol~mfq.1.pvalue",
                            "i~~i.pvalue", "i~~s.pvalue", "i~1.pvalue",
                            "i~age.1.pvalue", "i~mfq.1.pvalue",
                            "s_vol~~s_vol.pvalue", "s_vol~1.pvalue",
                            "s_vol~age.1.pvalue", "s_vol~i.pvalue",
                            "s_vol~mfq.1.pvalue", "s_vol~s.pvalue",
                            "s~~s.pvalue", "s~1.pvalue", "s~age.1.pvalue",
                            "s~mfq.1.pvalue", "i_vol~~i_vol.est_std",
                            "i_vol~~s_vol.est_std", "i_vol~1.est_std",
                            "i_vol~age.1.est_std", "i_vol~mfq.1.est_std",
                            "i~~i.est_std", "i~~s.est_std", "i~1.est_std",
                            "i~age.1.est_std", "i~mfq.1.est_std",
                            "s_vol~~s_vol.est_std", "s_vol~1.est_std",
                            "s_vol~age.1.est_std", "s_vol~i.est_std",
                            "s_vol~mfq.1.est_std", "s_vol~s.est_std",
                            "s~~s.est_std", "s~1.est_std", "s~age.1.est_std",
                            "s~mfq.1.est_std", "i_vol~~i_vol.pvalue_std",
                            "i_vol~~s_vol.pvalue_std", "i_vol~1.pvalue_std",
                            "i_vol~age.1.pvalue_std", "i_vol~mfq.1.pvalue_std",
                            "i~~i.pvalue_std", "i~~s.pvalue_std",
                            "i~1.pvalue_std", "i~age.1.pvalue_std",
                            "i~mfq.1.pvalue_std", "s_vol~~s_vol.pvalue_std",
                            "s_vol~1.pvalue_std", "s_vol~age.1.pvalue_std",
                            "s_vol~i.pvalue_std", "s_vol~mfq.1.pvalue_std",
                            "s_vol~s.pvalue_std", "s~~s.pvalue_std",
                            "s~1.pvalue_std", "s~age.1.pvalue_std",
                            "s~mfq.1.pvalue_std", "chisq", "df", "pvalue",
                            "rmsea", "rmsea.ci.lower", "rmsea.ci.upper", "cfi",
                            "tli", "srmr")
    }

    # Provide the return values to the main npoint script
    retvals
}


sub = data[,1:8]
str(sub)

# Explore the Original Data ----
summary(sub) # summary stats

cor_sub = sub[,2:8]

cor = cor(cor_sub) # correlation
png("pictures/original/cor_O.png")
print(corrplot::corrplot(cor))
dev.off()

p1 = ggplot(data, aes(timestamp, ETH_Close)) +
  stat_summary(fun.y = mean, ##adds the points
               geom = "point") +
  stat_summary(fun.y = mean, ##adds the line
               geom = "line",
               aes(group=1)) +
  stat_summary(fun.data = mean_cl_normal, ##adds the error bars
               geom = "errorbar",
               width = .2) +
  xlab('Time')+
  ylab('ETH Close Price')

png("pictures/original/ETH_Close_ggplot.png")
print(p1)
dev.off()

p2 = ggplot(data, aes(timestamp, BTC_Close)) +
  stat_summary(fun.y = mean, ##adds the points
               geom = "point") +
  stat_summary(fun.y = mean, ##adds the line
               geom = "line",
               aes(group=1)) +
  stat_summary(fun.data = mean_cl_normal, ##adds the error bars
               geom = "errorbar",
               width = .2) +
  xlab('Time')+
  ylab('BTC Close Price')

png("pictures/original/BTC_Close_ggplot.png")
print(p2)
dev.off()

p3 = ggplot(data, aes(timestamp, ETH_Energy)) +
  stat_summary(fun.y = mean, ##adds the points
               geom = "point") +
  stat_summary(fun.y = mean, ##adds the line
               geom = "line",
               aes(group=1)) +
  stat_summary(fun.data = mean_cl_normal, ##adds the error bars
               geom = "errorbar",
               width = .2) +
  xlab('Time')+
  ylab('ETH Energy Consumption (TWh)')

png("pictures/original/ETH_Energy_ggplot.png")
print(p3)
dev.off()

p4 = ggplot(data, aes(timestamp, BTC_Energy)) +
  stat_summary(fun.y = mean, ##adds the points
               geom = "point") +
  stat_summary(fun.y = mean, ##adds the line
               geom = "line",
               aes(group=1)) +
  stat_summary(fun.data = mean_cl_normal, ##adds the error bars
               geom = "errorbar",
               width = .2) +
  xlab('Time')+
  ylab('BTC Energy Consumption (TWh)')

png("pictures/original/BTC_Energy_ggplot.png")
print(p4)
dev.off()

p5 = ggplot(data, aes(timestamp, breakeven_inflation)) +
  stat_summary(fun.y = mean, ##adds the points
               geom = "point") +
  stat_summary(fun.y = mean, ##adds the line
               geom = "line",
               aes(group=1)) +
  stat_summary(fun.data = mean_cl_normal, ##adds the error bars
               geom = "errorbar",
               width = .2) +
  xlab('Time')+
  ylab('Breakeven Inflation')

png("pictures/original/breakeven_inflation_ggplot.png")
print(p5)
dev.off()

p6 = ggplot(data, aes(timestamp, BTC_Volume)) +
  stat_summary(fun.y = mean, ##adds the points
               geom = "point") +
  stat_summary(fun.y = mean, ##adds the line
               geom = "line",
               aes(group=1)) +
  stat_summary(fun.data = mean_cl_normal, ##adds the error bars
               geom = "errorbar",
               width = .2) +
  xlab('Time')+
  ylab('Bitcoin Volume')

png("pictures/original/BTC_Volume_ggplot.png")
print(p6)
dev.off()

p7 = ggplot(data, aes(timestamp, ETH_Volume)) +
  stat_summary(fun.y = mean, ##adds the points
               geom = "point") +
  stat_summary(fun.y = mean, ##adds the line
               geom = "line",
               aes(group=1)) +
  stat_summary(fun.data = mean_cl_normal, ##adds the error bars
               geom = "errorbar",
               width = .2) +
  xlab('Time')+
  ylab('Ethereum Volume')

png("pictures/original/ETH_Volume_ggplot.png")
print(p7)
dev.off()

png("pictures/original/grid_line_O.png")
print(plot_grid(p1, p2, p3, p4, p5, p6, p7))
dev.off()


## Demo de for Loops
## Prof. James Hunter
## from: https://rstudio.cloud/project/1181172
## 28 de maio de 2020
## Baseado em Cap. 21 de Grolemund & Wickham, R for Data Science (O'Reilly)

set.seed(42)

df <- tibble(
  a = rnorm(10),
  b = rnorm(10),
  c = rnorm(10),
  d = rnorm(10)
)

glimpse(df)

set.seed(42)
output <- numeric(length = ncol(df))

for(i in seq_along(output)) {
  output[i] <- median(df[[i]]) # dupla [[]] porque median veja df como lista
}

output


library(ggplot2)
library(dplyr)
library(patchwork)

gwas.dat = read.table('data/CRP_st_Whole_Blood.txt', header=T)
gwas.dat = subset(gwas.dat, !is.na(gwas.dat$CHR))

gwas.dat = gwas.dat[order(gwas.dat$CHR),]

cgenes = read.table('data/community_genes.txt', header=F)

gwas.dat = subset(gwas.dat, gwas.dat$gene_name %in% cgenes[,1])

nCHR <- length(unique(gwas.dat$CHR))
gwas.dat$BPcum <- NA
s <- 0
nbp <- c()
for (i in unique(gwas.dat$CHR)){
  nbp[i] <- max(gwas.dat[gwas.dat$CHR == i,]$POS)
  gwas.dat[gwas.dat$CHR == i,"BPcum"] <- gwas.dat[gwas.dat$CHR == i,"POS"] + s
  s <- s + nbp[i]
}

#
axis.set <- gwas.dat %>%
  group_by(CHR) %>%
  summarize(center = (max(BPcum) + min(BPcum)) / 2)
ylim <- abs(floor(log10(min(gwas.dat$pvalue)))) + 2

sig = 0.05/ dim(gwas.dat)[1]

# https://danielroelfs.com/blog/how-i-create-manhattan-plots-using-ggplot/

manhattan <- ggplot(gwas.dat, aes(x = BPcum, y = -log10(pvalue),
                                 color = as.factor(CHR), size = -log10(pvalue))) +
  geom_point(alpha = 0.75) +
  geom_hline(yintercept = -log10(sig), color = "grey40", linetype = "dashed") +
  scale_x_continuous(label = axis.set$CHR, breaks = axis.set$center) +
  scale_y_continuous(expand = c(0,0), limits = c(0, ylim)) +
#  scale_color_manual(values = rep(c("#276FBF", "#183059"), nCHR)) +
  scale_color_manual(values = rep(c("red", "blue"), nCHR)) +
  scale_size_continuous(range = c(0.5,3)) +
  labs(x = "Chromosome",
       y = expression(paste("-log"[10], plain(P)))) +
  theme_minimal() +
  theme(
    legend.position = "none",
    panel.border = element_blank(),
    panel.grid.major.x = element_blank(),
    panel.grid.minor.x = element_blank(),
    axis.text.x = element_text(angle = 0, size = 18, vjust = 0.5),
    axis.text.y = element_text(size = 15),
    axis.title = element_text(size = 22)
  ) +  labs(tag = expression(bold("B"))) + geom_text(aes(label=ifelse(pvalue < 1e-10, as.character(gene_name),"")), size=5, check_overlap=T, nudge_x = 1.25, nudge_y = -2.25)

 manhattan