source('poisson_process.r')

Driftless_Exact <- function(num_of_paths, beta, sigma, sigma_deriv, Texp=1, X0=0){
    # Simulate a 1-dimensional process using Monte Carlo with the exact method described in section 4 of the reference paper.
    # This process has zero drift and a general diffusion coefficient.
    # This can be used to simulate the payoff of an option and calculate the i}mplied volatility smile.
    #
    # Args:
    #     num_of_paths (int): The number of Monte Carlo paths
    #     beta (numeric): Arrival rate parameter passed to Poisson process
    #     sigma (function): The diffusion coefficient, a function of t (numeric) and X (np.array) returning a scalar
    #     sigma_deriv (function): The derivative of the diffusion coefficient with resect to X, a function of t (numeric) and X (np.array) returning a scalar
    #     Texp (Optional[numeric]): Time, in years, to simulate process.  Defaults to 1.
    #     X0 (Optional[numeric]): Initial value for the estimator process, Xhat. Defaults to 0.
    # Raises:
    #     Error: If sigma is not a function.
    #     Error: If sigma_deriv is not a function.
    if (!is.function(sigma)) stop('sigma must be a function')
    if (!is.function(sigma_deriv)) stop('sigma_deriv must be a function')
    ebT <- exp(beta*Texp)

    run_monte_carlo <- function(g_maker, strikes, num_paths_to_plot=FALSE){
        # Runs the Monte Carlo simulation to calculate E[g(X_T)] for different strikes.
        #
        # Args:
        #     g_maker (function): A function that returns a function f(x) <- g(x,K)
        #     strikes (array-like): An array of strikes to pass in to g_maker
        #     num_paths_to_plot (Optional[integer or logical]): How many paths should be plotted. Defaults to FALSE (no plot).  If TRUE, defaults to 100.
        # Returns:
        #     (array-like): An array of E[g(X_T)] for the range of strikes

        malliavin_weight <- function(k,antithetic=FALSE){
            # Generate the Malliavin weights. Needed to calculate psi and psi_antithetic.
            #
            # Args:
            #     k (int): The subscript index to identify which weight to calculate.
            a <- .5*sigma(t[k], Xhat[k])^2
            sigma_tilde <- sigma(t[k-1], Xhat[k-1]) + sigma_deriv(t[k-1], Xhat[k-1]) * (Xhat[k] - Xhat[k-1])
            a_tilde <- .5*sigma_tilde*sigma_tilde
            dt <- dt[k+1]
            dW_dt <- dW[k+1]/dt
            sgn <- if(antithetic && k==N_T+1) 1 else -1 # antithetic only differs for last weight at T_NT
            (a-a_tilde) / (2*a) * (sgn*sigma_deriv(t[k], Xhat[k]) * dW_dt + (dW_dt*dW_dt - 1/dt))
        }

        psi <- function(g,antithetic=FALSE)
            # Calculate psi from the reference paper.
            # E[psi] <- E[g(X_T)] where X_T is the last step of the standard Euler scheme process.
            #
            # Args:
            #     g (function): A function taking X_T and returning a scalar
            # Returns:
            #     numeric: An estimator in expectation for g(X_T)
            (g(X_T) - if(N_T>0) g(X_TNT) else 0) * g_multiple

        psi_antithetic <- function(g)
            # Calculate psi^- from the reference paper.
            #
            # Args:
            #     g (function): A function taking X_t and returning a scalar
            # Returns:
            #     numeric: An antithetic variable for psi
            (g(X_bar) - if(N_T>0) g(X_TNT) else 0) * g_multiple * antithetic_adjustment

        psi_average <- function(g)
            # Calculate average of psi and the antithetic psi.
            # Used to turn psi into finite variance.
            #
            # Args:
            #     g (function): A function taking X_T and returning a scalar
            # Returns:
            #     numeric: An estimator in expectation for g(X_T)
            (if(N_T>0) .5 * (psi(g) + psi_antithetic(g)) else psi(g))

        # The simulation starts here
        totals <- rep(0,length(strikes)) # A vector of prices for each strike, summed over paths

        # For plotting
        plotted_paths <- 0
        if (num_paths_to_plot==TRUE) num_paths_to_plot <- 100 # Default value
        num_paths_to_plot <- min(num_paths_to_plot, num_of_paths)
        line_colors <- rainbow(num_paths_to_plot)

        for (path in 1:num_of_paths){
            # Generate timesteps for the process Xhat determined by a Poisson process
            dt <- Poisson_Process(beta, Texp)
            t <- cumsum(dt)
            N_T <- length(t) - 2 # N_T is the # of arrivals before T (so last arrival and starting time don't count towards N_T)

            # Generate dW; Including 1st element of dt (zero) ensures a zero in front to match reference paper indices
            dW <- rnorm(length(dt), sd=sqrt(dt))

            # Simulate the process Xhat across time
            Xhat <- rep(X0, length(t)) # More efficient to just initialize all values as Y0
            for (k in 1:(length(t)-1)){
                c2 <- sigma_deriv(t[k], Xhat[k])
                if (c2 == 0){
                    Xhat[k+1] <- Xhat[k] + sigma(t[k], Xhat[k]) * dW[k+1]
                } else {
                    c1 <- sigma(t[k], Xhat[k]) - c2 * Xhat[k]
                    Xhat[k+1] <- -c1/c2 + (c1/c2 + Xhat[k]) * exp(-.5*(c2^2)*dt[k+1] + c2*dW[k+1])
                }
            }

            X_T <- Xhat[N_T+2] # Save the final value for easy access

            # Calculations for psi_antithetic (independent of g)
            if(N_T>0){
                # For brevity/quick access
                T_NT <- t[N_T+1];    X_TNT <- Xhat[N_T+1]

                # Calculate Xbar for psi_antithetic
                c2 <- sigma_deriv(T_NT, X_TNT)
                if (c2 == 0){
                    X_bar <- X_TNT - sigma(T_NT, X_TNT) * dW[N_T+1]
                } else {
                    c1 <- sigma(T_NT, X_TNT) - c2 * X_TNT
                    temp <- c1/c2
                    X_bar <- -temp + (temp + X_TNT) * exp(-c2*(.5*c2*dt[N_T+2] + dW[N_T+2]))
                }

                # Calculate the adjustment ratio for g_multiple in psi_antithetic (last_antithetic_weight / last_weight)
                antithetic_adjustment <- malliavin_weight(N_T+1,antithetic=TRUE) / malliavin_weight(N_T+1) # N_T + 1 b/c R starts from 1
            }

            # Calculates the product from k=1..N_T of malliavin_weight(k)
            # Using a default of 1 to protect against the edge case of no arrivals before T
            malliavin_product <- if(N_T>0) prod(malliavin_weight(2:(1+N_T))) else 1

            # g_multiple represents the portion of psi that is common across g functions of different strikes
            g_multiple <- ebT * beta^-N_T * malliavin_product

            # totals <- totals + vapply(strikes, function(K) psi_average(g_maker(K)), FUN.VALUE=1)
            totals <- totals + psi_average(g_maker(strikes))

            if (plotted_paths < num_paths_to_plot){ # Plots the first num_paths_to_plot paths.
                if (plotted_paths==0){ # First plot does labeling
                    plot(t, Xhat, main='Generated Paths', xlab='t', ylab=expression(hat('X')[t]), ylim=X0+sqrt(Texp)*c(-1,1), type='l', col=line_colors[plotted_paths+1])
                } else {
                    lines(t, Xhat, col=line_colors[plotted_paths+1])
                }
                plotted_paths <- plotted_paths + 1
            }
        }
        return(totals/num_of_paths)
    }
    return(list(run_monte_carlo=run_monte_carlo)) # Return a list holding the function so we can call it OO style
}


## Launch model
library(lhs)
library(doParallel)
library(foreach)

source("cat_face_mortality_pfire.r")

registerDoParallel(cores=16)

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

### Run experiment 0 - latin square generation

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

FIELD_SIZE=200                    # Number of rows/columns
SIM_LENGTH=700                    # number of years to run
FIRE_FREQ=20                      #  percentage of years
FIRE_PROB=25                      # Size as %age of field
MORTALITY_ON=TRUE                     # Non-fire Mortality turned on?
F_MORTALITY_ON=TRUE                    # Fire-Morality turned on?

MORT_b1 = 20                      # First mortality age break
MORT_b2 = 400                     # Second mortality age break

MORT_p1 =.02
MORT_p2 =.005
MORT_p3 =.02

MORT_F_b1 = 10                      # First fire mortality age break
MORT_F_b2 = 30                     # Second fire mortality age break
MORT_F_b3 = 400                     # Second fire mortality age break

MORT_F_p1 = 0.7
MORT_F_p2 = 0.3
MORT_F_p3 = 0.05
MORT_F_p4 = 0.4

NUMBER_SIMS=100

## Latin hypercube scaler functions;
gen_l=function(v){
  min_v=v-(v*.25)
  max_v=v+(v*.25)
  range=max_v-min_v
  function(x){min_v+(x*range)}
}

lhq=randomLHS(NUMBER_SIMS,7)
lhq[,1]=gen_l(MORT_p1)(lhq[,1])
lhq[,2]=gen_l(MORT_p2)(lhq[,2])
lhq[,3]=gen_l(MORT_p3)(lhq[,3])
lhq[,4]=gen_l(MORT_F_p1)(lhq[,4])
lhq[,5]=gen_l(MORT_F_p2)(lhq[,5])
lhq[,6]=gen_l(MORT_F_p3)(lhq[,6])
lhq[,7]=gen_l(MORT_F_p4)(lhq[,7])

output_dir="latin_sens"

dir.create(output_dir)

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

# Create dataframe to define this sim
# This can vary between runs
#
#########################################

sim_def_frame=data.frame(SIM_ID=1:NUMBER_SIMS)
sim_def_frame$FIELD_SIZE=FIELD_SIZE
sim_def_frame$SIM_LENGTH=SIM_LENGTH
sim_def_frame$FIRE_FREQ=FIRE_FREQ
sim_def_frame$FIRE_PROB=FIRE_PROB
sim_def_frame$MORTALITY_ON=MORTALITY_ON
sim_def_frame$F_MORTALITY_ON=F_MORTALITY_ON
sim_def_frame$MORT_b1 = MORT_b1
sim_def_frame$MORT_b2 = MORT_b2
sim_def_frame$MORT_p1 = lhq[,1]
sim_def_frame$MORT_p2 = lhq[,2]
sim_def_frame$MORT_p3 = lhq[,3]
sim_def_frame$MORT_F_b1 = MORT_F_b1
sim_def_frame$MORT_F_b2 = MORT_F_b2
sim_def_frame$MORT_F_b3 = MORT_F_b3
sim_def_frame$MORT_F_p1 = lhq[,4]
sim_def_frame$MORT_F_p2 = lhq[,5]
sim_def_frame$MORT_F_p3 = lhq[,6]
sim_def_frame$MORT_F_p4 = lhq[,7]
sim_def_frame$output_dir = output_dir

write.csv(sim_def_frame,paste0(output_dir,"/sim_list.csv"))

foreach(i=1:NUMBER_SIMS) %dopar% launch_sim(i)


myqr = function(A) {
  a = qr(A)
  q = qr.Q(a)
  r = qr.R(a)
  return(list(Q = q, R = r))
}


################################################################
#<--------------- 1. Set Parameters ---------------->
################################################################
p.from =      "2021-01-01"        #first day to get data
p.to =        "2021-01-31"        #last day to get data
p.period =    '30min'             #candle period - daily for BatchGetSymbols() or tick, 1min, 5min, 10min, 15min, 30min, hour, day, week, month for IQFeed data
p.sma.period    <-  20
p.sd.period     <-  20
# - upper and lower limits for z-score
p.lower.zscore  <-  -2
p.upper.zscore  <-  2
# - lookforward periods for performance Measure
p.look.forward <- c(1,2,3,4,5,10,20,50)

ticker <- c("IWM") #fn.list.SP500.symbols(500) #c("SPY", "QQQ", "IWM", "AAPL", "GOOG", "AMZN", "CSCO")#

################################################################
#<--------------- 2. Download All Data ---------------->
################################################################
ifelse(
  p.period == 'daily',
    all.sym <- fn.my.batchgetsymbols(ticker, p.from, p.to),
    all.sym <- lapply(ticker, function(x)(get_iqfeed_data(x, from = p.from, to = p.to, period = p.period)))
)

# - get rid of all the tickers that don't have any data
ifelse(
  p.period == 'daily',
  ticker <- unique(all.sym$ticker),
  ticker <- ticker
)
# - Counts the number of symbols
num.symbols   <- length(unique(ticker))

# - Counts number of periods total
num.days        <- length(unique(all.sym[[2]]))

# - Separate the data frame into lists of individual symbols
ifelse(
  p.period == 'daily',
  ind.sym <- lapply(ticker,function(x)(all.sym %>% filter(ticker == x))),
  ind.sym <- lapply(seq_along(ticker),
              function(x)(
                cbind(
                  "ticker" = ticker[[x]],
                  all.sym[[x]],
                  "adjusted.close" = all.sym[[x]]$close,
                  "period.return" = all.sym[[x]]$close/lag(all.sym[[x]]$close,1,default = 0)-1
                )
              )
            )
)

# - Counts number of periods total for each symbol
num.days.ind.sym  <-  lapply(ind.sym,function(x)(length(x[[2]])))

# - Extract close from each symbol
ifelse(
  p.period == 'daily',
  adj.close <- lapply(ind.sym,function(a)(a[[6]])),
  adj.close <- lapply(ind.sym,function(a)(a[[6]]))
)

# - Extract high from each symbol
ifelse(
  p.period == 'daily',
  high <- lapply(ind.sym,function(a)(a$high)),
  high <- lapply(ind.sym,function(a)(a$high))
)

# - Extract low from each symbol
ifelse(
  p.period == 'daily',
  low <- lapply(ind.sym,function(a)(a$low)),
  low <- lapply(ind.sym,function(a)(a$low))
)

################################################################
#<--------------- 3. Add Indicator(s)  ---------------->
################################################################
#- solve for simple moving average of close
df.sma <- lapply(ind.sym, function(x)(sma(x$close,p.sma.period)))
#- solve for standard deviation of close
df.sd <- lapply(ind.sym, function(x)(roll_sd(x$close,p.sd.period)))
# - number of standard deviations that price above or below the SMA
df.zscore <- mapply(function(x,y,z)((x-y$close)/z),df.sma,ind.sym,df.sd,SIMPLIFY=F)

# - location/index where z-score exceeded lower and upper z-score bounds
df.lower.zscore <- lapply(df.zscore, function(x)(which(x <= p.lower.zscore)))
df.upper.zscore <- lapply(df.zscore, function(x)(which(x >= p.upper.zscore)))

################################################################
#<--------------- 4. Add lookforward columns ---------------->
################################################################
# - add cumulative percentage returns for look-forward periods
# - lookforward "lf"- measures from the period after the current period until the cumulative total periods indicated
# - lookforward "lf" - for example, at time 1, lf.10 would measure the return from time 2 to time 11 (because the signal con only trigger the period after it fires)
# - lookback "lb"- measures from the period before the current period backward until the cumulative total periods indicated
# - lookback "lb" - for example, at time 20, lb.10 would measure the return from time 10 to time 19

df.all.sym <-
  lapply(ind.sym, #9 columns
    function(x)(
      x %>%
        mutate(
          lf.1 = lead(close,n=2)/lead(close,n=1)-1,     #10
          lf.2 = lead(close,n=3)/lead(close,n=1)-1,     #11
          lf.3 = lead(close,n=4)/lead(close,n=1)-1,     #12
          lf.4 = lead(close,n=5)/lead(close,n=1)-1,     #13
          lf.5 = lead(close,n=6)/lead(close,n=1)-1,     #14
          lf.10 = lead(close,n=11)/lead(close,n=1)-1,   #15
          lf.20 = lead(close,n=21)/lead(close,n=1)-1,   #16
          lf.50 = lead(close,n=51)/lead(close,n=1)-1,   #17
          lb.1 = lag(close,n=2)/lag(close,n=1)-1,       #18
          lb.2 = lag(close,n=3)/lag(close,n=1)-1,       #19
          lb.3 = lag(close,n=4)/lag(close,n=1)-1,       #20
          lb.4 = lag(close,n=5)/lag(close,n=1)-1,       #21
          lb.5 = lag(close,n=6)/lag(close,n=1)-1,       #22
          lb.10 = lag(close,n=11)/lag(close,n=1)-1,     #23
          lb.20 = lag(close,n=21)/lag(close,n=1)-1,     #24
          lb.50 = lag(close,n=51)/lag(close,n=1)-1,     #25
          my.sma = sma(close,p.sma.period),             #26
          my.sd = roll_sd(close,p.sd.period),           #27
          z.score = (my.sma-close)/my.sd                #28
        )
      )
    )

df.all.sym.bind <- rbindlist(df.all.sym)

# - return all the locations of df.all.sym where z-score was less than lower level
df.lower.forward <-
  lapply(seq_along(ticker),
    function(x)(
      df.all.sym[[x]][df.lower.zscore[[x]],]
    )
  )
all.lower <- rbindlist(df.lower.forward)

# - return all the locations of df.all.sym where z-score was greater than upper level
df.upper.forward <-
  lapply(seq_along(ticker),
    function(x)(
      df.all.sym[[x]][df.upper.zscore[[x]],]
    )
  )
all.upper <- rbindlist(df.upper.forward)

# - summrize the lookforward columns
summary(all.lower[,10:17])
summary(all.upper[,10:17])

# - baseline - summarize ALL lookforward columns
summary(df.all.sym.bind[,10:17])

# - average all look forwards
rep.1 <-
  cbind(
    "lower" = round(apply(all.lower[,10:17],2,function(x)(mean(x*100,na.rm=T))),5),
    "upper" = round(apply(all.upper[,10:17],2,function(x)(mean(x*100,na.rm=T))),5),
    "all" = round(apply(df.all.sym.bind[,10:17],2,function(x)(mean(x*100,na.rm=T))),5)
  )

# - conclusion: taking all signals does "worse" than average returns over same period IF we are assuming a reversion to the mean system.  conversely, taking all signals assuming a "momentum" system does better than average
# - if you consider the

################################################################
#<--------------- 5. Where was z-score x periods before it increased y percent ---------------->
################################################################
# - split each symbol's look.forward return columns into deciles
df.all.sym.decile.returns <-
  lapply(df.all.sym,
    function(x)(
      apply(
        x[,10:17],
        2,
        function(y)(
          quantile(y, prob = seq(0, 1, length = 11), type = 5,na.rm = T)
        )
      )
    )
  )

# - where was price in relationship to zscore before top 80 percent decile return for the lookforward 5,20,50 etc?
# - df.all.sym.decile.returns[[1]][,5][[9]] - for the first symbol, return column 5 (lookforward 5), the 9th percent return (which is the 80th percentile)
# - return each row of df.all.sym where above is true
df.all.sym.top80.5period <-
  lapply(seq_along(df.all.sym),
    function(x)(
      df.all.sym[[x]][which(df.all.sym[[x]]$lf.5 >= df.all.sym.decile.returns[[x]][,5][[9]]),]
    )
  )
df.all.sym.top80.20period <-
  lapply(seq_along(df.all.sym),
    function(x)(
      df.all.sym[[x]][which(df.all.sym[[x]]$lf.20 >= df.all.sym.decile.returns[[x]][,7][[9]]),]
    )
  )
df.all.sym.top80.50period <-
  lapply(seq_along(df.all.sym),
    function(x)(
      df.all.sym[[x]][which(df.all.sym[[x]]$lf.50 >= df.all.sym.decile.returns[[x]][,8][[9]]),]
    )
  )

# - solve for deciles of z-scores
df.all.sym.decile.zscore <-
  lapply(df.all.sym,
    function(x)(
      quantile(x$z.score, prob = seq(0, 1, length = 11), type = 5,na.rm = T)
    )
  )

# - calculate returns for bottom 20th and top 80th percentile zscores
df.all.sym.bottom20.zscore <-
  lapply(seq_along(df.all.sym),
    function(x)(
      df.all.sym[[x]][which(df.all.sym[[x]]$z.score <= df.all.sym.decile.zscore[[x]][[3]]),]
    )
  )
# find the mean return for all lookforward windows that have a bottom 20 zscore
mean.bottom20.zscore <-
  lapply(df.all.sym.bottom20.zscore,
    function(x)(
      apply(
        x[,10:17],
        2,
        function(y)(
          mean(y, na.rm = T)
        )
      )
    )
  )

df.all.sym.top80.zscore <-
  lapply(seq_along(df.all.sym),
    function(x)(
      df.all.sym[[x]][which(df.all.sym[[x]]$z.score >= df.all.sym.decile.zscore[[x]][[9]]),]
    )
  )
# find the mean return for all lookforward windows that have a bottom 20 zscore
mean.top80.zscore <-
  lapply(df.all.sym.top80.zscore,
    function(x)(
      apply(
        x[,10:17],
        2,
        function(y)(
          mean(y, na.rm = T)
        )
      )
    )
  )

# find the mean return for ALL zscores
mean.all.zscore <-
  lapply(df.all.sym,
    function(x)(
      apply(
        x[,10:17],
        2,
        function(y)(
          mean(y, na.rm = T)
        )
      )
    )
  )

rep.2 <-
  lapply(seq_along(ticker),
    function(x)(
      cbind.data.frame(
        "bottom.20" = round(mean.bottom20.zscore[[x]]*100,4),
        "top.80"= round(mean.top80.zscore[[x]]*100,4),
        "all.zscore"= round(mean.all.zscore[[x]]*100,4)
      )
    )
  )

rep.3 <-
  lapply(seq_along(ticker),
    function(x)(
      rep.2[[x]] %>%
        mutate(
          diff.bottom  =
            ifelse((all.zscore > 0 & bottom.20 > 0) | (all.zscore > 0 & bottom.20 < 0),
              bottom.20/all.zscore-1,
              -1*bottom.20/all.zscore-1
            ),
          diff.top = top.80/all.zscore-1
        )
      )
    )

##### - create HTML reports for rep.3
# name of each file to export
file.names <- c("Z-Score Decile Analysis")

file.names.2 <- paste0(today()," - ",p.from," - ",p.to," - ",file.names,".html")

# creating a table with the kable() command

# - limit.period for minus and plus
k.files.rep.3 <-
        lapply(seq_along(rep.3), function(x)(
          kable_styling(
              kable_input = kable(
                              rep.3[[x]],
                              "html",
                              align = "c",
                              caption = paste0("Decile Z-Score Analysis for ",ticker[[x]]),
                            ),
              bootstrap_options = "hover",
              full_width = TRUE
            )
          ))

# creating headings for the page
head <- c("
 Z-Score Decile Analysis
")

head2 <- paste0("
 For the time period: ",p.from," - ",p.to,"
","

 Date report run: ",today(),"
")

jumbotron <-
  paste0(
  "

",
  head,
  "

",
  head2,
  "
"
)

html.basic <-
paste0(
  "<!doctype html>

    <meta charset=\"utf-8\">
    <meta name=\"viewport\" content=\"width=device-width, initial-scale=1, shrink-to-fit=no\">

    <link rel=\"stylesheet\" href=\"https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/css/bootstrap.min.css\" crossorigin=\"anonymous\">

    <title></title>
  ",
  "",
  jumbotron,
  "
",
  k.files.rep.3,
  "
",
  "",
  ""
)

write(html.basic, file.names.2[[1]])

################################################################
#<--------------- 6.Using Linear Regression and In-Sample & Out-of-Sample Testing ---------------->
################################################################

# - identify the in sample portion of the data (80%)
in.samp = lapply(df.all.sym,
            function(x)(
              x[1:(round(length(x[[2]])*.8)),]
            )
          )
# - ID the out-of-sample portion of the data (20%)
out.samp = lapply(df.all.sym,
            function(x)(
              x[(round(length(x[[1]])*.8)):(length(x[[1]])),]
            )
          )

# - graphing the correlations on the in-sample data
# - simple - period.return vs z-score
plot(in.samp[[1]]$z.score, in.samp[[1]]$period.return, main="Scatterplot - Period Return vs Z-Score", xlab = "Z-Score", ylab = "Period Return (%)",pch=19)
# Add fit lines
abline(lm(in.samp[[1]]$period.return~in.samp[[1]]$z.score), col="red") # regression line (y~x)

# - graph all correlations
pairs(~period.return+lb.1+lb.2+lb.3+lb.4+lb.5+lb.10+lb.20+lb.50+z.score,data=in.samp[[1]],
   main="Simple Scatterplot Matrix")

# - applying multiple linear regression to the in-sample data, use the returns over the past 10, 20 and 50 periods and the z.score to model the look-forward return over the future 20 periods)
mod.1 = lapply(in.samp,
          function(x)(
            lm(period.return~lb.1+lb.2+lb.3+lb.4+lb.5+lb.10+lb.20+lb.50+z.score, x) #
          )
        )
# - apply the model to the out-of sample data and return the fit and upper and lower prediction intervals (NOT confidence intervals)
pred.1 = lapply(seq_along(mod.1),
          function(x)(
            predict(mod.1[[x]], newdata = out.samp[[x]], interval = "prediction")
          )
        )
# - evaluate the accuracy of the model (the lower the mae, rmse, the better)
myaccuracy.1 = lapply(seq_along(pred.1),
                  function(x)(
                    accuracy(pred.1[[x]][,1],out.samp[[x]]$period.return)
                  )
                )

# - graph the predicted return, actual return and upper and lower limits for
mydata = cbind(out.samp[[1]][1:120,],pred.1[[1]][1:120,])
ggplot(mydata, aes(x = time)) +
    geom_line(aes(y = period.return, colour = "period.return")) +
    geom_line(aes(y = fit, colour = "fit")) +
    geom_line(aes(y = upr, colour = "upr")) +
    geom_line(aes(y = lwr, colour = "lwr"))

# - graph the cumulative return of actual vs predicted
mydata2 = data.frame(
  "time"=seq_along(pred.1[[1]][,1]),
  "pred"=cumsum(pred.1[[1]][,1]),
  "actual"=cumsum(out.samp[[1]]$period.return))
ggplot(mydata2, aes(x=time)) + geom_line(aes(y=actual), colour="green") + geom_line(aes(y=pred), colour="red")  # second layer


source("C:/dssrt/dssrt.r")
library(ggplot2)
library(scales) ## required for probability axis

## Open file and get TSC
bwfile = opendss("C:/dssrt/test.dss")
bwcreek = getFullTSC(bwfile, "A=BRANDYWINE CREEK C=FLOW E=1DAY")
colnames(bwcreek) = "FLOW" ## TODO - add naming the columns by C-part

## Do people even use water years back east?
bwcreek$WY = 1900 + ifelse(.indexmon(bwcreek)+1 < 9, .indexyear(bwcreek), 1+.indexyear(bwcreek))

## Get peaks for each water year, assign probabilities
bwpeaks = aggregate(FLOW ~ WY, bwcreek, max)
bwpeaks = subset(bwpeaks, WY!=2013)
bwpeaks = bwpeaks[order(bwpeaks$FLOW),]
n = length(bwpeaks$FLOW)
bwpeaks$PROB = (1:n)/(1+n)

## Setup breaks for plot
xbreaks = c(0.1, 0.25, 0.5, 0.75, 0.9, 0.95, 0.975, 0.99, 0.995)
log.range = log10(range(bwpeaks$FLOW))
lower = 10^floor(log.range[1])
upper = 10^ceiling(log.range[2])
cap = lower
ybreaks = NULL
while(cap < upper){
  ybreaks = c(ybreaks, seq(cap, cap*9, by=cap))
  cap = cap*10
}

## ggplot2 frequency curve example
plt = ggplot(bwpeaks, aes(x=PROB, y=FLOW)) + geom_point() + theme_bw()
plt = plt + scale_y_continuous(trans="log10", breaks=ybreaks, name="Flow (cfs)")
plt = plt + scale_x_continuous(trans=probability_trans(distribution="norm"),
                               breaks=xbreaks, labels=paste0((1-xbreaks)*100,"%"),
                               name="Annual Chance of Exceedence")
plt = plt + ggtitle("Brandywine Creek nr. Wilmington, Delaware")
## show plot
plt


sites.glm <- function(methylation, design, dependent.variable, independent.variable, method, family, ...) {
    if (method == "rlm") {
        stats <- fit.loop(methylation, design, dependent.variable, independent.variable,
                          fit.rlm, stats.rlm, maxit=200, ...)
    }
    else if (method == "glm") {
        if (length(independent.variable) == 1)
            stats <- fit.loop(methylation, design, dependent.variable, independent.variable,
                              fit.glm, stats.glm, family=family, ...)
        else
            stats <- fit.multi.loop(methylation, design, dependent.variable, independent.variable,
                                    fit.glm, stats.glm, family=family, ...)
    }
    else {
        if (length(independent.variable) == 1)
            stats <- fit.limma(methylation, design, dependent.variable, independent.variable, ...)
        else
            stats <- fit.limma.multi(methylation, design, dependent.variable, independent.variable, ...)
    }
    stats <- as.data.frame(stats)
    stats$n <- rowSums(!is.na(methylation))
    stats
}

fit.rlm <- function(x, y, ...) {
    fit <- rlm(x=x, y=y, ...)
}

stats.rlm <- function(fit, var) {
    ret <- coeftest(fit, vcov=vcovHC(fit, type="HC0"))[var,]
    names(ret) <- c("estimate","se","z","p.value")
    ret
}

fit.glm <- function(x, y, ...) {
    fit <- glm.fit(x=x, y=y, ...)
}

stats.glm <- function(fit, var) {
    ret <- coef(summary.glm(fit))[var,]
    names(ret) <- c("estimate","se","t","p.value")
    ret
}


cat("\n----\nCheatsheet\n----\n")

rm(list=ls())

library(keras)

mnist <- dataset_mnist()
train_images <- mnist$train$x
train_labels <- mnist$train$y
test_images <- mnist$test$x
test_labels <- mnist$test$y

str(mnist)

model <- keras_model_sequential() %>%
  layer_dense(units = 512, activation = "relu", input_shape = c(28 * 28)) %>%
  layer_dense(units = 10, activation = "softmax")
model

401920 == 28*28*512 + 512
5130 == 512*10 + 10

model %>% compile(
  optimizer = "rmsprop",
  loss = "categorical_crossentropy",
  metrics = c("accuracy")
)

str(train_images)
train_images <- array_reshape(train_images, c(60000, 28 * 28))
str(train_images)
train_images <- train_images / 255

str(test_images)
test_images <- array_reshape(test_images, c(10000, 28 * 28))
str(test_images)
test_images <- test_images / 255

train_labels <- to_categorical(train_labels)
str(train_labels)
test_labels <- to_categorical(test_labels)
str(train_labels)

model %>%
  fit(
    train_images, train_labels,
    epochs = 5, batch_size = 128)

metrics <- model %>%
  evaluate(test_images, test_labels)
metrics

model %>%
  predict_classes(test_images[1:10,])

digit <- mnist$test$x[5,,]
str(digit)
range(digit)
plot(as.raster(digit, max = 255))

digit <- mnist$test$x[1,,]
str(digit)
range(digit)
plot(as.raster(digit, max = 255))

# ?reticulate::array_reshape

x <- 1:4
dim(x) <- c(2,2)
x
keras::array_reshape(x, c(2, 2))

K <- keras::backend()

inputTensor <- K$ones( c( 2L, 10L, 10L, 3L ) )

# interpolationType: "nearestNeighbor", "linear", "cubic",
#    "bicubic", "bilinear", "nearest"

outputTensor <- ANTsRNet::resampleTensor(inputTensor, c(5, 5), "bicubic")
dim(outputTensor)
outputTensor[1,,,1]

## Chapter 3

# require(lubridate)
# ymd(as.Date('2020-11-01')) %m+% months(213)

layer <- layer_dense(units = 32, input_shape = c(784))

model <- keras_model_sequential() %>%
  layer_dense(units = 32, input_shape = c(784)) %>%
  layer_dense(units = 32)

# 3.2.3 Using the functional Keras API

library(keras)

input_tensor <- layer_input(shape = c(784))

output_tensor <- input_tensor %>%
  layer_dense(units = 512, activation = "relu") %>%
  layer_dense(units = 10, activation = "softmax")

model <- keras_model(inputs = input_tensor, outputs = output_tensor)
model

model %>% compile(
  optimizer = "rmsprop",
  loss = "categorical_crossentropy",
  metrics = c("accuracy")
)

model %>% fit(
  train_images, train_labels,
  epochs = 5, batch_size = 128
)

metrics <- model %>%
  evaluate(test_images, test_labels)
metrics

model %>%
  predict_classes(test_images[1:10,])
# Error in py_get_attr_impl(x, name, silent) :
#   AttributeError: 'Model' object has no attribute 'predict_classes'

model %>%
  fit(input_tensor, output_tensor, batch_size = 128, epochs = 10)
# Error in py_call_impl(callable, dots$args, dots$keywords) :
#   TypeError: int() argument must be a string, a bytes-like object or a number, not 'NoneType'

# 3.4.1. The IMDB dataset

library(keras)

imdb <- dataset_imdb(num_words = 10000)

c(c(train_data, train_labels), c(test_data, test_labels)) %<-% imdb

str(train_data[[1]])
train_labels[[1]]
max(purrr::map_dbl(train_data, max))

word_index <- dataset_imdb_word_index()
str(word_index)
word_index$fawn
word_index['fawn']
word_index[1:4]

reverse_word_index <- names(word_index)
str(reverse_word_index)
# reverse_word_index[[1]] # fawn
names(reverse_word_index) <- word_index
reverse_word_index[1:4]

str(train_data[[1]])

# Note that the indices are offset by 3 because
# 0, 1, and 2 are reserved indices for “padding,”
# “start of sequence,” and “unknown.”

decoded_review <- purrr::map_chr(train_data[[1]], function(index) {
  word <- if (index >= 3)
    reverse_word_index[[as.character(index - 3)]]
  if (!is.null(word)) word else "?"
})

str(decoded_review)

# 3.5.1. The Reuters dataset

library(keras)

reuters <- dataset_reuters(num_words = 10000)
str(reuters)
c(c(train_data, train_labels), c(test_data, test_labels)) %<-% reuters
str(train_data)
str(train_labels)

train_data[[1]]
train_labels[[1]]

word_index <- dataset_reuters_word_index()
reverse_word_index <- names(word_index)
names(reverse_word_index) <- word_index

decoded_newswire <- purrr::map_chr(train_data[[1]], function(index) {
  word <- if (index >= 3)
    reverse_word_index[[as.character(index - 3)]]
  if (!is.null(word)) word else "?"
})

str(decoded_newswire)

# 3.6.1. The Boston Housing Price dataset

library(keras)

dataset <- dataset_boston_housing()
c(c(train_data, train_targets), c(test_data, test_targets)) %<-% dataset

str(train_data)
str(test_data)

# 3.6.4. Validating your approach using K-fold validation

k <- 3
# indices <- sample(1:18)
indices <- 1:18
folds <- cut(indices, breaks = k, labels = FALSE)
str(folds)

i = 1 # i = 2, i = 3
val_indices <- which(folds == i, arr.ind = TRUE)
val_indices
indices[val_indices]
indices[-val_indices]


 C02AHJ Example Program Results

 Roots of quadratic equation

 z =   1.0000E+00   +2.0000E+00*i
 z =   2.0000E+00   -3.0000E+00*i


#' @title
#' Densities of standardized abundances at each time for each cluster.
#'
#' @description
#' A pdf is saved containing the density plots at each time point for each cluster. These distributions should be approximately normally distributed to allow the application of GLMs.
#'
#'
#' @param Tc A matrix containing time course data.
#' @param clusters A vector with same length as number of profiles. The cluster labels are assumed to be numbers, starting from 1.
#' @param outfile Name of the output pdf file.
#' @param pdfHeight Height of a pdf page.
#' @param pdfWidth Width of a pdf page.
#' @param bandwidth Bandwidth of the density function.
#'
#'
#' @importFrom methods is
#' @importFrom stats density dnorm sd
#' @importFrom graphics polygon plot axis
#' @importFrom grDevices pdf dev.off
#'
#'
#'
#' @seealso \code{\link[e1071]{cmeans}} for clustering time profiles.
#'
#' @export
clusTpDistributions <- function(Tc, clusters, outfile="abundanceDistributions.pdf", pdfHeight=10, pdfWidth=10, bandwidth=0.5){

	list_matricies <- splitIntoSubMatrices(Tc, clusters)

	pdf(outfile, height=pdfHeight, width=pdfWidth)
	# par(mfrow = c(1, 1))

	plot(0, 0, ylim=c(0, 1.5), xlim=c(-3,3), yaxs="i", ylab="Density", main="Standardized distributions of standardized abundances at each time point for every cluster", xaxt="n", bty="n", yaxt="n", pch='.', xlab="Standardized abundance")
	axis(side =1 ,  at = seq(floor(min(Tc)), ceiling(max(Tc)), 1)) # x-axis label

	for (clusNum in 1:length(list_matricies)){

		for(tp in 1:ncol(list_matricies[[clusNum]])){
			tpMean <- mean(list_matricies[[clusNum]][,tp])
			tpSd <- sd(list_matricies[[clusNum]][,tp])

			standTpVals <- (list_matricies[[clusNum]][,tp] - tpMean)/tpSd

			d <- stats::density(standTpVals, bw=bandwidth)

			lines(d, col=rgb(0.7, 0.7, 0.7), lwd=0.25, xaxt="n", yaxt="n")
		}
	}

	x <- seq(-3, 3, length=100)
	# x <- seq(-3, 3, by = 0.05)
	y <- dnorm(x, mean = 0, sd = 1)

	lines(x, y, xaxt="n", yaxt="n")

	dev.off()
}

#' @title
#' Distribution density of event times.
#'
#' @description
#' A pdf is saved containing the density plots of every identified event's time distribution (calculated by calculating the time of event occurance for each profile). If these distributions are approximately normally distributed, then the Student's t-test can be used to compare them, otherwise the Mann-Whitney U test should be utilized.
#'
#'
#' @param Tc A matrix containing time course data.
#' @param clusters A vector with same length as number of profiles. The cluster labels are assumed to be numbers, starting from 1.
#' @param mat_events A matrix containing the time regions (and events for the centroid) generated by running the \code{calcEvents} function.
#' @param phosEventTh Value between 0 and 1, to define the threshold at which a phosphorylation (or increasing) event occurs. Here, a threshold of 0 corresponds to the minimum value within an interval. (Such an event is designated as 1).
#' @param dephosEventTh Value between 0 and 1, to define the threshold at which a dephosphorylation (or decreasing) event occurs. A threshold of 0 corresponds to the maximum value within an interval. (Such an event is designated as -1).
#' @param outfile Name of the output pdf file.
#' @param pdfHeight Height of a pdf page.
#' @param pdfWidth Width of a pdf page.
#' @param bandwidth Bandwidth of the density function.
#'
#'
#' @importFrom methods is
#' @importFrom stats density
#' @importFrom graphics legend polygon plot axis title lines par
#' @importFrom shape Arrows
#' @importFrom grDevices pdf dev.off rgb
#'
#'
#'
#' @seealso \code{\link[e1071]{cmeans}} for clustering time profiles, \code{\link{calcEvents}} for identifying events.
#'
#' @export
eventDistributions <- function(Tc, clusters, mat_events, phosEventTh, dephosEventTh, outfile="eventDistributions.pdf", pdfHeight=35, pdfWidth=10, bandwidth=0.25) {

	stopifnot(is(Tc, "matrix"), (length(clusters) == nrow(Tc)), is(mat_events, "matrix"), (phosEventTh >= 0 && phosEventTh <= 1), (dephosEventTh >= 0 && dephosEventTh <= 1))

	list_matricies <- splitIntoSubMatrices(Tc, clusters)

	list_distributions <- getDistOfAllEvents_v2(mat_events, list_matricies, phosEventTh, dephosEventTh)

	pdf(outfile, height=pdfHeight, width=pdfWidth)

	par(mfrow = c(length(list_matricies), 1))

	plotsList = list()
	counter_plotsList = 1
	for (eventNum in 1:nrow(mat_events)){
		addIt = FALSE
		plotCol = color_eventDist$up # phos colour
		if (mat_events[eventNum, 4] == -1){ # if dephos event
			plotCol = color_eventDist$down # dephos colour
		}

		if ((eventNum > 1) && (mat_events[eventNum, cols_matFifty$col_clus] ==  mat_events[eventNum-1, cols_matFifty$col_clus])) {

			isAnyNa <- is.na(list_distributions[[eventNum]][,2])
			if (any(isAnyNa)){
				naRmMat <- list_distributions[[eventNum]][-which(isAnyNa),]
			}
			else{
				naRmMat <- list_distributions[[eventNum]]
			}

			d <- getDensityValues(naRmMat, bandwidth)

			polygon(d$density, col=plotCol, border=plotCol)
			lines(c(d$x_med, d$x_med), c(0,d$y_med), col=plotCol)
			lines(c(d$x_mean, d$x_mean), c(0, d$y_mean), col=plotCol, lty="dashed")

			eventCol = color_events$down
			adjustment = -0.2
			if (mat_events[eventNum, 4] == 1){
				eventCol = color_events$up
				adjustment = 0.2
			}

			plotArrows(d, mat_events, eventNum, eventCol, adjustment);
			# Update event from centroid-event to median-event.
			mat_events[eventNum, cols_matFifty_v2$x] = d$x_med
		}

		else {

			isAnyNa <- is.na(list_distributions[[eventNum]][,2])
			if (any(isAnyNa)){
				naRmMat <- list_distributions[[eventNum]][-which(isAnyNa),]
			}
			else{
				naRmMat <- list_distributions[[eventNum]]
			}
			d <- getDensityValues(naRmMat, bandwidth)

			plot(d$density, col=plotCol, xlim=c(0, ncol(Tc)), ylim=c(0,2), xlab="Time", bty='n', yaxt="n", xaxt="n",  yaxs="i", main="", ylab=paste("Cluster ", mat_events[eventNum, 1]))

			polygon(d$density, col=plotCol, border=plotCol)
			lines(c(d$x_med, d$x_med), c(0,d$y_med), col=plotCol)
			lines(c(d$x_mean, d$x_mean), c(0, d$y_mean), col=plotCol, lty="dashed")

			eventCol = color_events$down
			adjustment = -0.2
			if (mat_events[eventNum, 4] == 1){
				eventCol = color_events$up
				adjustment = 0.2
			}

			plotArrows(d, mat_events, eventNum, eventCol, adjustment);

			# Update event from centroid-event to median-event.
			mat_events[eventNum, cols_matFifty_v2$x] = d$x_med

			if (eventNum == 1){
				 graphics::legend("topright", c("Increasing event", "Decreasing event", "Median density", "Mean density"), col=c(color_eventDist$up, color_eventDist$down, 'black', 'black'), lwd=c(10,10, 1, 1), lty=c(1, 1, 1, 2))
			}
			if (eventNum == nrow(mat_events)){
				axis(side =1 ,  at = seq(1, ncol(Tc), 1), labels= colnames(Tc))
			}
			else{
				axis(1, at=seq(1,ncol(Tc),1), col.ticks = 1, labels=FALSE)
			}
		}

	}

	dev.off()

	return (mat_events)
}

plotArrows <- function(d, mat_events, eventNum, eventCol, adjustment){
	if (mat_events[eventNum, 4] == -1){
		shape::Arrows(x0=d$x_med, x1=d$x_med, y0=d$y_med + 0.4 , y1=d$y_med+adjustment + 0.4 , arr.type="triangle", arr.length=0.01, arr.width=0.01, col=eventCol, lwd=2, lend=2, arr.adj=0)

		## sharp arrow heads
		shape::Arrows(x0=d$x_med, x1=d$x_med, y0=d$y_med + 0.4,  y1=d$y_med+adjustment + 0.4, arr.type="triangle", arr.length=0.13, arr.width=0.15, col=eventCol, arr.adj=0, segment=FALSE)
	}
	else{
		shape::Arrows(x0=d$x_med, x1=d$x_med, y0=d$y_med, y1=d$y_med+adjustment, arr.type="triangle", arr.length=0.01, arr.width=0.01, col=eventCol, lwd=2, lend=2, arr.adj=0)

		## sharp arrow heads
		shape::Arrows(x0=d$x_med, x1=d$x_med, y0=d$y_med,  y1=d$y_med+adjustment, arr.type="triangle", arr.length=0.13, arr.width=0.15, col=eventCol, arr.adj=0, segment=FALSE)

	}
}

getDensityValues <- function(naRmMat, bandwidth){
	d <- stats::density(naRmMat[,2], bw=bandwidth)

	dx <- mean(diff(d$x))
	n <- length(d$y)
	y.unit <- sum(d$y) * dx
	y.cs <- cumsum(d$y)

	x.med <- d$x[i.med <- length(y.cs[2*y.cs <= y.cs[n]])]
	y.med <- d$y[i.med]
	x.mean <- sum(d$y * d$x) * dx
	y.mean <- d$y[length(d$x[d$x < x.mean])]
	d$y[1] = 0
	d$y[length(d$y)] = 0

	return (list(density=d, x_med=x.med, y_med=y.med, x_mean=x.mean, y_mean=y.mean))
}


# Using ctrl,shift,C to create Comments
# //step 1.Downloaded Marketing data from Github//
# reading r file marketing.rda for Analysis
setwd("/home/carol/Desktop/R-Code/Practice/marketing.rda")
load("/home/carol/Desktop/R-Code/Practice/marketing.rda")
# view data for analysis
View(marketing)
# transform data into a dataframe
df<-data.frame(marketing)
View(df)
nrow(df)
ncol(df)
# Accessing ggplot for visualization
library(ggplot2)
View(df)
# Re-installing tidyverse for analysis purposes
install.packages("tidyverse" , Dependencies = "TRUE")
# Accessing tidyverse
library(tidyverse)
# Accessing(dplyr)
library(dplyr)
# visualizing the impact of facebook activity to sales
lm_F<-ggplot(data=df, aes(x=facebook, y=sales))+geom_point(color="blue")+geom_smooth(method="lm")
# linear model summary of sales based off facebook data
summary()
# visualizing the impact of youtube activity to sales
lm_Y<-ggplot(data=df, aes(x=youtube, y=sales))+ geom_point(color="red")+geom_smooth(method="lm")
# visualizing the impact of newspaper ads on sales
lm_N<-ggplot(data=df, aes(x=newspaper, y=sales))+geom_point(color="green")+geom_smooth(method="lm")
# Computing multiple linear regression coefficients
ls()
View(df)
head(df)
library(dplyr)
# remove sales in order to form X matrix
df2<-select(df,-sales)
View(df2)
head(df2)
nrow(df2)
ncol(df2)
#X Converting the dataframe into the X matrix
X<-data.matrix(df2)
View(df2)
head(df2)
max(df2)
#Creating the Response Variable
df3<-select(df, -facebook,-youtube,-newspaper)
View(df3)
head(df3)
max(df3)
nrow(df3)
ncol(df3)
# converting Df3 to Y matrix
Y<-data.matrix(df3)
View(df3)
#Creating the first column of ones
ones<-rep (1, times=200)
View(ones)
#Converting the column into  a matrix
Col1<-matrix(ones)
View(Col1)
# Creating the Dependent Variable
X2<-cbind(Col1,X)
View(X2)
# OLS estimates- Coefficients B1:BK
install.packages("matlib")
# Accessing matlib for computational purposes
library(matlib)
# Computing X2 Transpose
X2_T<-t(X2)
View(X2_T)
#Computing Xt times X
X_new<-X2_T %*% X2
View(X_new)
# Computing the inverse
Xinv<-inv(X_new)
# view inverse
View(Xinv)
# Compute for X transpose Y
X2T_Y<-X2_T %*% Y
View(X2T_Y)
# compute OLS B1-Bk
b1_k<-Xinv%*%X2T_Y
View(b1_k)
library(ggplot2)
View(df2)
View(df3)
# Create relationship for the linear model
ml_m<-lm(sales~youtube+facebook+newspaper, data=df)
#View Coefficients
print(ml_m)
#View summary Statistics
summary(ml_m)
#Plot the model
plot(ml_m)
# Create another Scatterplot
ggplot(data=df, aes(x=newspaper+youtube+facebook, y=sales))+geom_point(color="green")+geom_smooth(method="lm")
#ANOVA
aov(ml_m)
help(package="ggplot2")
# Run ggbin
ggplot(data=df, aes(x=newspaper+youtube+facebook, y=sales))+geom_bin_2d(mapping = NULL,data = NULL,stat = "bin2d",position = "identity")+geom_smooth(method="lm")


#Read in data
# Obtain data file as occurrence matrix from Fossilworks.
# Perform a standard search, select the generate diversity curves option, and download the 'presences.txt' file

occMatrix<-read.delim("presences.txt")

#Remove genus name and total occurrences columns
occMatrix<-occMatrix[,3:ncol(occMatrix)]

genera<-nrow(occMatrix)
bins<-ncol(occMatrix)
rangeFreq<-rep(0,bins)

# Replace all NAs with 0s
for (t in 1:nrow(occMatrix)){
  for (b in 1:bins){
    if(is.na(occMatrix[t,b])){
      occMatrix[t,b]=0
    }
  }
}

bins<-ncol(occMatrix)
twoTimers<-rep(0,10000)
threeTimers<-rep(0,10000)
partTimers<-rep(0,10000)
gapFillers<-rep(0,10000)
firstSeen<-rep(0,10000)
lastSeen<-rep(0,10000)

for (t in 1:nrow(occMatrix)){
  for (b in 1:bins){
    if (occMatrix[t,b]>0){
      if (firstSeen[t]==0){
        firstSeen[t]=b
      }
      lastSeen[t]=b
    }
    if (b>1){
      if ((occMatrix[t,b-1]>0) & (b<bins)){
        if (occMatrix[t,b]>0){
          twoTimers[b]<-twoTimers[b]+1
        }
        if ((occMatrix[t,b]>0) & (occMatrix[t,b+1]>0)){
          threeTimers[b]<-threeTimers[b]+1
        }
        else if((occMatrix[t,b]==0) & (occMatrix[t,b+1]>0)){
          partTimers[b]<-partTimers[b]+1
        }
      }
      if(b>1 & (occMatrix[t,b-1])>0 & b+1<bins){
        if((occMatrix[t,b+1]==0) & (occMatrix[t,b+2]>0)){
          gapFillers[b]<-gapFillers[b]+1
        }
      }
    }
  }
}

#plot(1:bins,log(gapFillers[1:13]),type="o",ylim=c(0,5),xlab="bins",ylab="log count")
#points(1:bins,log(partTimers[1:13]),col="green",type="o")
#points(1:bins,log(twoTimers[1:13]),col="red",type="o")
#points(1:bins,log(threeTimers[1:13]),col="blue",type="o")

#Calculate Foote rates (BC)
Nbt<-rep(0,14) # Crosses both boundaries
Nb<-rep(0,14) # Crosses bottom boundary
Nt<-rep(0,14) # Crosses top boundary

for (t in 1:nrow(occMatrix)){
  if(firstSeen[t]+1<lastSeen[t]){
    for (b in firstSeen[t]+1:lastSeen[t]-1){
      Nbt[b]<-Nbt[b]+1
    }
  }
  if (firstSeen[t]<lastSeen[t]){
    Nb[lastSeen[t]]<-Nb[lastSeen[t]]+1
    Nt[firstSeen[t]]<-Nt[firstSeen[t]]+1
  }
}

Nb
Nt
Nbt<-Nbt[1:14]

(Fext<-log((Nb+Nbt)/Nbt)) #Extinction rate
(Forig<-log((Nt+Nbt)/Nbt)) #Origination rate

#Calculate gap-filler estimates
twoTimers<-twoTimers[1:13]
partTimers<-partTimers[1:13]
threeTimers<-threeTimers[1:13]
gapFillers<-gapFillers[1:13]
GFest<-log((twoTimers+partTimers)/(threeTimers+partTimers+gapFillers))
GFest
median(GFest,na.rm=TRUE)

#Calculate three timer (3T) extinction rate
output=NULL
for (i in 1:bins){
  ThreeExt<-log(twoTimers[i]/threeTimers[i])+log(threeTimers[i+1]/(threeTimers[i+1]+partTimers[i+1]))
  output<-cbind(ThreeExt,output)
}
output
median(output,na.rm=TRUE)

# 3T origination rates
output=NULL
for (i in 1:bins){
  ThreeExt<-log(twoTimers[i+1]/threeTimers[i])+log(threeTimers[i+1]/(threeTimers[i+1]+partTimers[i+1]))
  output<-cbind(ThreeExt,output)
}
output

par(mfrow=c(2,2))
plot(Fext,type="o",xlab="bins")
plot(Forig, type="o",xlab="bins")
plot(gapFillers,type="o",xlab="bins")
plot(1:length(output),output,type="o",ylab="3T")


mark = function(x) {arrows(x,9, x,5, length=0.15, angle=10, lwd=2)}

z = rnorm(2000)
shift = c(rep(0, 400), rep(1.5, 600), rep(-2, 300), rep(-1, 700))
spike = c(rep(0,1600), rep(9, 5), rep(395,0))
plot(z+shift+spike, type='s', xlab='Time', ylab='Shift + Noise', ylim=c(-10,10))
mark(400)
mark(1000)
mark(1300)


reorder_columns<-function(m){

        n=nrow(m)
        k=ncol(m)
        cov=array(-1,k)
        for(j in 1:k){
                cov[j]=sum(m[,j])
        }

        new_order=c()
        while(length(which(cov[]==-1))!=k){
                max=max(cov)
                ids=which(cov[]==max)
                new_order=c(new_order,ids)
                for(i in ids){
                        cov[i]=-1
                }
        }

        new_m=matrix(-1,nrow=n,ncol=k)
        for(j in 1:length(new_order)){
                new_m[,j]=m[,new_order[j]]
        }
        return(new_m)
}

plot_one_matrix<-function(file_cov,tag_order){

        m=read.table(file_cov,skip=1,row.names=1)
        m=as.matrix(m)

        if(tag_order==TRUE){
                a=reorder_columns(m)
                b=reorder_columns(t(a))
                m=t(b)
        }

        nrow_m=nrow(m)
        ncol_m=ncol(m)
        num=2
        colors=colorRampPalette(c("lightgrey","black"))
        for(i in 1:nrow_m){
                if(sum(m[i,])==1){
                        id=which(m[i,]==1)
                        m[i,]=rep(3,ncol_m)
                        m[i,id]=2
                        num=4
                        colors=colorRampPalette(c("lightgrey","black","firebrick","#cfa9a9"))
                }
        }

        #colors=colorRampPalette(c("lightgrey","black","firebrick","#cfa9a9"))
        image(t(m[nrow(m):1,]), col=colors(num),axes = FALSE,xlab="",ylab="")
}

#============================================================================================
#============================================================================================
#   ARGUMENTS
#============================================================================================
#============================================================================================
args = commandArgs(trailingOnly=TRUE)
file_in=args[1]         # path for matrix file
file_out=args[2]        # path for output file

tag_order=FALSE

pdf(paste(file_out,"-",tag_order,".pdf",sep=""),width=10,height=10)
name=paste(file_in)
if(file.exists(name)){
	plot_one_matrix(name,tag_order)
}else{
	print(paste("File not found:",name))
}
dev.off()


get.stepwise.model.results = function( model.full ) {

    model.stepwise = stepAIC( model.full, direction="both" )

    print ("The stepwise selected model")
    model.stepwise$anova

    summary( model.stepwise )

    Anova ( model.stepwise )

    print ("The stepwise selected model coefficients")
    print(as.data.frame(coef( model.stepwise )))

    return( model.stepwise )
}


StanDDM_NCEN_Pure <- function(simulation, modal, data, control, seed, warmup, num_cores, iter){

    model_name <- paste('StanDDM_NCEN_Pure', modal, sep="") #modal assigned in main
    dir.create(paste(model_name, sep=''), showWarnings = FALSE)
    cat('\n///////////////Computing model: ', model_name, '///////////////\n')

    if(simulation){
        cat('\nCreating random parameters and simulating Data...\n')
        fakeParams <- makeFakeParams(nsub = 10, include = c())
        fakedat <- simulDat(fakeParams, n = 50)
        fakedat <- fakedat[[1]]
        data <- fake_data_processing(fakedat$data)

    }

    model_definition <-
    "
        data {
            int<lower=1> N;      // Number of subjects
            int<lower=0> Nu_max; // Max (across subjects) number of upper boundary responses
            int<lower=0> Nl_max; // Max (across subjects) number of lower boundary responses
            int<lower=0> Nu[N];  // Number of upper boundary responses for each subj
            int<lower=0> Nl[N];  // Number of lower boundary responses for each subj
            real RTu[N, Nu_max];  // upper boundary response times
            real RTl[N, Nl_max];  // lower boundary response times
            real minRT[N];       // minimum RT for each subject of the observed data
            real RTbound;        // lower bound or RT across all subjects (e.g., 0.1 second)
        }

    parameters {
        vector[4] mu_p;
        vector<lower=0>[4] sigma;

        // Subject-level raw parameters (for Matt trick)
        vector[N] alpha_pr;
        vector[N] beta_pr;
        vector[N] delta_pr;
        vector[N] tau_pr;
    }

    transformed parameters {
        // Transform subject-level raw parameters
        vector<lower=0>[N]         alpha; // boundary separation
        vector<lower=0, upper=1>[N] beta;  // initial bias
        vector<lower=0>[N]         delta; // drift rate
        vector<lower=RTbound, upper=max(minRT)>[N] tau; // nondecision time

        for (i in 1:N) {
            beta[i] = Phi_approx(mu_p[2] + sigma[2] * beta_pr[i]); //Phi approx so bounded between 0 and 1
            tau[i]  = Phi_approx(mu_p[4] + sigma[4] * tau_pr[i]) * (minRT[i]-RTbound) + RTbound; //non decision time //needs to be necessarily smaller than the RT. The bound makes sure that the sampled min non dec time stays //below the smallest RT by the order of the padding, which gets added after the sampling is done(tis sis why //there is a sum at the end. Phi approx = inverse probit.)
        }
        alpha = exp(mu_p[1] + sigma[1] * alpha_pr); //reparametrization as in Gelman manual second ed pg 313 and Kruschkes manual pg. 281
        delta = exp(mu_p[3] + sigma[3] * delta_pr); //exponential link so only positive values, hard limit on 0
    }

    model {
        // Hyperparameters
        mu_p  ~ normal(0, 1);
        sigma ~ cauchy(0, 5);

        // Individual parameters for non-centered parameterization
        alpha_pr ~ normal(0, 1);
        beta_pr  ~ normal(0, 1);
        delta_pr ~ normal(0, 1);
        tau_pr   ~ normal(0, 1);

        // Begin subject loop
        for (i in 1:N) {
            // Response time distributed along wiener first passage time distribution
            RTu[i, :Nu[i]] ~ wiener(alpha[i], tau[i], beta[i], delta[i]);
            RTl[i, :Nl[i]] ~ wiener(alpha[i], tau[i], 1-beta[i], -delta[i]);

        } // end of subject loop
    }

    generated quantities {

        // For log likelihood calculation
        real log_lik[N];

        { // local section, this saves time and space
            // Begin subject loop
            for (i in 1:N) {
                log_lik[i] = wiener_lpdf(RTu[i, :Nu[i]] | alpha[i], tau[i], beta[i], delta[i]);
                log_lik[i] = log_lik[i] + wiener_lpdf(RTl[i, :Nl[i]] | alpha[i], tau[i], 1-beta[i], -delta[i]);
            }
        }
    }
    "

    inits_fixed <- c(0.5, 0.5, 0.5, 0.15)
    init <- lapply(1:num_cores, function(i) {
        list(
            mu_p     = c(log(inits_fixed[1]), qnorm(inits_fixed[2]), log(inits_fixed[3]),
                         qnorm(inits_fixed[4])),
            sigma    = c(1.0, 1.0, 1.0, 1.0),
            alpha_pr = rep(log(inits_fixed[1]), data$forstan$N),
            beta_pr  = rep(qnorm(inits_fixed[2]), data$forstan$N),
            delta_pr = rep(log(inits_fixed[3]), data$forstan$N),
            tau_pr   = rep(qnorm(inits_fixed[4]), data$forstan$N)
        )
    })

    pars <-  c("alpha", "beta", "delta", "tau", "log_lik")

    cat('\nCompiling and fitting the model...\n')
    #-----------------------------------------------------------------
        fit <- stan(model_code = model_definition,
                    seed = seed,
                    data = data$forstan,
                    pars = pars,
                    warmup = warmup,
                    cores = num_cores,
                    control = control,
                    init = init,
                    iter = iter,
                    chains = num_cores)

    cat('\nSaving Stanfit object...\n')
    #-----------------------------------------------------------------
        saveit(fit = fit,
               string = model_name,
               file=paste(model_name, '/', model_name, '.RData', sep = ''))

    cat('\nExtracting and saving parameters...\n')
    #-----------------------------------------------------------------
        extracted_params <- parameter_extraction(
            fit,
            numsub=data$forstan$N,
            names=data$forsim$names)

        names(extracted_params) <- c('a', 'z', 'v', 't') #dependent on model
        write.csv(extracted_params, file = paste(model_name, '/',model_name,".csv", sep = ''),
                  row.names=FALSE)

        if(simulation){ #needs model_name, else that would be in main
            write.csv(fakeParams, file = paste(model_name, '/',model_name,"_template_params.csv",
                                               sep = ''), row.names=FALSE)

        }

    cat(paste('\nSimulating', data$forstan$N, 'subjects with fitted parameters:\n'))
    #-----------------------------------------------------------------
        sims <- simulDat(extracted_params)
        sims <- sims[[1]]

    cat(paste('\nSaving Plots...\n'))
    #-----------------------------------------------------------------
        models_plots(experim_dat = data$forsim$rawdat,
                     simul_dat = sims,
                     model_name = model_name)

        fit_quality(experim_dat = data$forsim$rawdat,
                 simul_dat = sims,
                 model_name = model_name)

        if(simulation){
            param_recovery(fit, data$forstan$N, fakeParams, model_name = model_name)
        }

    cat(paste('\nComputing/plotting model diagnostics:\n'))
    #-----------------------------------------------------------------
        model_diagnostics(fit)

    cat(paste('\nFor Reproducibility:\n'))
    #-----------------------------------------------------------------
        print(devtools::session_info())
        cat(paste('Seed:', seed, sep = ' '))

    cat('\n///////////////', model_name, 'has been computed.///////////////\n')
}#end function


b: a -> b (5)
d: a -> d (1)
c: b -> c (6)
e: c -> e (3)


x = c(0)
y = c(1)
for(i in 1:10) {
  x = c(x, i)
  y = c(y, i*i)
}
#x = c(0, 1, 2, 3, 4)
#y = c(1, 1, 4, 9, 16)
plot(x, y)


equity.eval <- function(symbol, bench, period='months', from=NULL, to=NULL,
                       duration = c('12 months', '36 months', '60 months'),
                       makeplots = TRUE,
                       twri = NULL, twrib = NULL) {

    ## given a single symbol and benchmark, creates:
    ##     dataframe containing duration, twrcum, alpha, beta, stdev, sharpe, twrcumb, stdevb, sharpeb
    ##     set of plots of: incremental TWR,
    ##                      cumulative twr (twrcum),
    ##                      incremental twr for symbol vs. benchmark,
    ##                      cumulative twr vs. standard deviation for symbol and benchmark

    ## options: symbol and bench names are taken (and overwritten) from twri and twrib if provided
    ##          from and to are used to define the maximum date range
    ##          duration = c('12 months', '36 months', '60 months') default makes plots for last 1, 3, and 5 yrs
    ##                   = c('1 year', '3 years', '5 years') makes plots for current year, last 3, and last 5
    ##                     Note: can specify any number of duration options
    ##                   = number instead returns the last this number of time steps
    ##                     Use this option with from/to to set a specific date range, e.g.:
    ##                         from='2020-10-28', to='2020-12-31', period='days', duration=99999

    ## extract names of symbol and bench from twri and twrib if they were not input
    if (missing(symbol)) symbol <- names(twri)
    if (missing(bench))  bench  <- names(twrib)

    ## test that there is only one symbol or twri column
    ##                and only one bench or twrib column
    if ( (class(symbol) == 'character' & length(symbol) > 1) |
         (length(names(twri))  > 1) |
         (length(names(twrib)) > 1)
        ) {
        cat('/nError: Multiple symbols passed into equity.eval/n')
        cat(  '       through "symbol", "bench", "twri", or "twrib./n')
        return()
    }

    ## get history
    if (is.null(twri)) {
        ## twri not passed in so obtain
        out  <- equity.history(symbol, period=period, from=from, to=to)
        twri <- out$twri
    }

    if (is.null(twrib)) {
        ## twrib not passed in so obtain (no need to worry about dates since will line up later)
        twrib <- equity.history(bench, period=period)$twri
    }

    ## if from and/or to not defined, extract xtsrange from twri
    if (is.null(from)) from <- zoo::index(twri[1,])
    if (is.null(to))   to   <- zoo::index(twri[nrow(twri),])
    xtsrange <- paste(from, '/', to, sep='')
    twri  <- twri[xtsrange]
    twrib <- twrib[xtsrange]

    ## combine twri and benchmarks to line up dates and remove NA
    ## first make sure the same dates will be considered identical
    zoo::index(twri)  <- as.Date( zoo::index(twri) )  # align/fix xts dates before cbind merge
    zoo::index(twrib) <- as.Date( zoo::index(twrib) ) # align/fix xts dates before cbind merge
    both <- na.omit( cbind(twri, twrib) )

    ## set plotspace to fill by columns first
    par(mfcol=c(3, length(duration)))

    ## strip out 1-year, 3-year, and 5-year histories, if available
    alpha    <- NA
    beta     <- NA
    twrcum   <- NA
    twrcumb <- NA
    stdev    <- NA
    stdevb <- NA
    sharpe   <- NA
    sharpeb <- NA

    i        <- 0
    for (durationi in duration) {
        i <- i + 1

        ## extract vectors for alpha and beta
        bothx <- xts::last(both, durationi)
        twrix       <- as.numeric( bothx[, 1] )
        twribx  <- as.numeric( bothx[, 2] )

        ## calculate cumulative returns for durationi
        twrcum[i]   <- prod(twrix + 1) - 1
        twrcumb[i] <- prod(twribx + 1) - 1

        ## calculate standard deviation and sharpe ratio for durationi
        stdev[i]       <- sd(twrix)
        stdevb[i]  <- sd(twribx)
        sharpe[i]      <- twrcum[i]   / stdev[i]
        sharpeb[i] <- twrcumb[i] / stdevb[i]

        ## plot incremental and cumulative returns for input duration
        xtscum <- cumprod(bothx+1)-1
        if (isTRUE(makeplots)) {
            print( plotxts(bothx, main="Inc" ) )    # oddly "print" is needed in a loop
            print( plotxts(xtscum, main="Cum") )

            ## add cumulative TWR to plot
            mtext(paste('TWR Cum = ', signif(twrcum[i],4)*100, '%;',
                        'Benchmark Cum = ', signif(twrcumb[i], 4)*100, '%',
                        sep=''),
                  side=3, line=0.75, cex=0.75)
        }

        ## determine alpha and beta for symbol i and create plot
        out <- alpha.beta(twrix, twribx,
                          plot = makeplots,
                          xlabel = paste('Incremental TWR for', bench, sep=' '),
                          ylabel = paste('Incremental TWR for', symbol, sep=' '),
                          range  = range(twrix, twribx, na.rm = TRUE),
                          main   = paste(durationi, '; period=', period, sep=''))
        alpha[i] <- out$alpha
        beta[i]  <- out$beta

    }
    df  <- data.frame(duration, twrcum, alpha, beta, stdev, sharpe,
                      twrcumb, stdevb, sharpeb)
    return(df)
}
## out <- equity.eval('AAPL', 'SPY', from='2020-10-11', to='2020-12-15',
##                   period='days', duration=99999 )


# test wfs simulations

require(foreach)
require(doParallel)
source('scripts/wfs_simp.r')

# make cluster
cl <- makeCluster(3)
registerDoParallel(cl)

# probability of fixation of a neutral allele should equal the initial frequency
	ne <- 100
	gen=1000 # run for a long time: likely to fixaton (expected time is 4N)
	smin <- smax <- 0
	fs <- seq(1/100, 91/100, by=5/100) # initial allele frequencies
	nsims <- 1000

	sims <- data.frame(f1=rep(fs, rep(nsims, length(fs))))
	sims$f2 <- sims$f1samp <- sims$f2samp <- NA
	for(j in 1:length(fs)){
		print(j)
		thesesims <- foreach(i=1:nsims, .combine=rbind) %dopar% {
			wfs_simp(i, f1=fs[j], s=0, c1=50, c2=50, gen=gen, ne=ne)
		}
		sims[((j-1)*1000+1):(j*1000),c('f2', 'f1samp', 'f2samp')] <- as.data.frame(thesesims)
	}

	propfix <- aggregate(list(prop=sims$f2), by=list(f1=sims$f1), FUN=function(x) sum(x==1)/nsims)

	# plot of proportion fixed vs. initial frequency
	quartz(width=5, height=4)
	# png(width=5, height=4, units='in', res=300, file='analysis/figures/wfs_sim_test_s=0.png')
	par(las=1)
	with(propfix, plot(f1, prop, xlab='Initial allele frequency', ylab='Proportion fixed', main='Ne=100, s=0, nsims=1000'))
	abline(0,1)

	dev.off()

# probability of fixation of a non-neutral allele should equal s if initial frequency is 1/ne
# (usually written as 2s, but that's when fitness of waa is 1+s2. here it is 1+s)
# for large N and small s
	ne <- 100
	gen=1000 # run for a long time: likely to fixation in 4N generations with drift
	ss <- seq(0.05,1,by=0.05)
	f1 <- 1/ne # starting allele freq
	nsims <- 1000

	sims2 <- data.frame(s=rep(ss, rep(nsims, length(ss))))
	sims2$f2 <- sims2$f1samp <- sims2$f2samp <- NA
	length(ss)
	for(j in 1:length(ss)){
		print(j)
		thesesims <- foreach(i=1:nsims, .combine=rbind) %dopar% {
			if(i %% 100 == 0) cat(i)
			wfs_simp(i, f1=f1, s=ss[j], c1=50, c2=50, gen=gen, ne=ne)
		}
		sims2[((j-1)*1000+1):(j*1000),c('f2', 'f1samp', 'f2samp')] <- as.data.frame(thesesims)
	}

	sum(sims2$f2 %in% c(0,1))/nsims/length(ss) # fraction that reached fixation: make gen larger until this=1
	propfix2 <- aggregate(list(prop=sims2$f2), by=list(s=sims2$s), FUN=function(x) sum(x==1)/nsims)
	propfix2$s_exp1 <- (1-exp(-propfix2$s))/(1-exp(-2*ne*propfix2$s)) # Eq. 2.21 in Graur & Li
	propfix2$s_exp2 <- propfix2$s/(1-exp(-2*ne*propfix2$s)) # Eq. 2.22 in Graur & Li

	# plot of proportion fixed vs. s
	quartz(width=5, height=4)
	# png(width=5, height=4, units='in', res=300, file='analysis/figures/wfs_sim_test_s>0.png')
	par(las=1)
	with(propfix2, plot(s, prop, xlab='Selection coefficient (s)', ylab='Proportion fixed at p=1', main='Ne=100, p0=1/Ne, nsims=1000', ylim=c(0,0.7)))
	with(propfix2, lines(s, s_exp1, col='green'))
	legend('topleft', col='green', lty=1, legend='(1-exp(-s))/(1-exp(-2*ne*s))', bty='n', cex=0.7)

	dev.off()

## examine how much drift vs. sampling variance for large ne
	ne <- 10000 # like NEA cod
	gen=11 # like NEA cod
	smin <- smax <- 0
	f1min <- f1max <- ne/2/ne # starting allele freq
	nsims <- 1000

	sims <- foreach(i=1:nsims, .combine=rbind) %dopar% {
		if(i %% 100 == 0) cat(i)
		wfs(i, f1min=f1min, f1max=f1max, smin=smin, smax=smax, c1=50, c2=50, gen=gen, ne=ne)
	}
	sims <- as.data.frame(sims)

	# examine drift variance and sampling variance
	par(mfrow=c(3,1))
	bks <- seq(0,1,length.out=20)
	hist(sims$f1samp, main='f1samp', breaks=bks, col='grey'); abline(v=f1min, col='red', lwd=2)
	hist(sims$f2, main='f2', breaks=bks, col='grey'); abline(v=f1min, col='red', lwd=2)
	hist(sims$f2samp-sims$f2, main='delta f2samp', breaks=seq(-0.5,0.5,length.out=20), col='grey'); abline(v=0, col='red', lwd=2)

## examine how much drift to expect for large Ne
	# observations
	dat <- locnms <- fread('analysis/Frequency_table_Lof07_Lof14.txt', header=TRUE); setnames(locnms, 3:7, c('N_CHR_1', 'Freq_1', 'N_CHR_2', 'Freq_2', 'ABS_DIFF')) # the name and observed frequencies of all the loci, from output by Bastiaan Star

	# simulations
	ne <- 10000
	gen=11 # run for a long time: likely to fixaton (expected time is 4N)
	fs <- seq(1/100, 91/100, by=5/100) # initial allele frequencies
	nsims <- 100000 # takes 20 min or so

	sims <- data.frame(f1=rep(fs, rep(nsims, length(fs))))
	sims$f2 <- sims$f1samp <- sims$f2samp <- NA
	for(j in 1:length(fs)){
		print(j)
		thesesims <- foreach(i=1:nsims, .combine=rbind) %dopar% {
			wfs_simp(i, f1=fs[j], s=0, c1=44, c2=44, gen=gen, ne=ne)
		}
		sims[((j-1)*nsims+1):(j*nsims),c('f2', 'f1samp', 'f2samp')] <- as.data.frame(thesesims)
	}

	xlims <- range(c(dat[,Freq_2-Freq_1], sims$f2samp-sims$f1samp))
	cols <- c('black', '#7fcdbb', '#edf8b1', '#2c7fb8') # sims, obs 44, low obs, high obs

	# plot histogram of diff vs. initial observed frequency
	quartz(width=7, height=6)
	# png(width=7, height=7, filename='analysis/figures/wfs_sim_test_hist_obsdiff_by_obsf1_with_data.png', units='in', res=300)
	f1s <- seq(0,1.1,by=0.1)
	bks <- seq(-1,1,by=0.05)
	par(mfrow=c(3,4), las=1, tcl=-0.3, mgp=c(2.4,0.6,0), mai=c(0.5, 0.5, 0.3, 0.05))
	for(i in 2:length(f1s)){
		inds <- (sims$f1samp >= f1s[i-1]) & (sims$f1samp < f1s[i])
		hst <- hist(sims$f2samp[inds] - sims$f1samp[inds], plot=FALSE, breaks=bks) # returns some 0 values that get eliminated, but appear as holes in the histogram: doesn't change our interpretation
		j <- which(hst$density>0)
		plot(hst$mids[j], hst$density[j], type='o', xlab='Sample ∆freq', ylab='log(density)', main=paste('initial ', f1s[i-1], '-', f1s[i], sep=''), pch=16, xlim=xlims, log='y', ylim=c(0.0001,20), col=cols[1])
		abline(v=c(-0.06, 0.06), col='grey', lty=3) # genome-wide allele frequency change

			# low sample size
		inds3 <- dat[,Freq_1 >= f1s[i-1] & Freq_1 < f1s[i] & (N_CHR_1<44 | N_CHR_2<44)]
		hst3 <- hist(dat[inds3,Freq_2 - Freq_1], plot=FALSE, breaks=bks) # returns some 0 values that get eliminated, but appear as holes in the histogram: doesn't change our interpretation
		j3 <- which(hst3$density>0)
		lines(hst3$mids[j3], hst3$density[j3], type='o', pch=16, col=cols[3])

			# high sample size
		inds4 <- dat[,Freq_1 >= f1s[i-1] & Freq_1 < f1s[i] & (N_CHR_1>44 & N_CHR_2>44)]
		hst4 <- hist(dat[inds4,Freq_2 - Freq_1], plot=FALSE, breaks=bks) # returns some 0 values that get eliminated, but appear as holes in the histogram: doesn't change our interpretation
		j4 <- which(hst4$density>0)
		lines(hst4$mids[j4], hst4$density[j4], type='o', pch=16, col=cols[4])

			# sample size 44
		inds2 <- dat[,Freq_1 >= f1s[i-1] & Freq_1 < f1s[i] & N_CHR_1==44 & N_CHR_2==44]
		hst2 <- hist(dat[inds2,Freq_2 - Freq_1], plot=FALSE, breaks=bks) # returns some 0 values that get eliminated, but appear as holes in the histogram: doesn't change our interpretation
		j2 <- which(hst2$density>0)
		lines(hst2$mids[j2], hst2$density[j2], type='o', pch=16, col=cols[2])

	}

	legend('bottomright', col=cols, lty=1, legend=c('Sims n=44', 'Obs n=44', 'Obs low n', 'Obs high n'), cex=0.7, bty='n')

	dev.off()

#######################
# clean up cluster
#######################
stopCluster(cl)


# REML estimation of variance components

# there are two basic packages for mixed models
#  nlme, with the lme function
#  lme4, with the lmer function

# the syntax to specify random effects differs slightly.

# the following illustrates lmer, which is slightly more flexible
#  and a lot faster

wool <- read.table('wool.txt',header=T)
#  after reshaping wool.txt into row column format

library(lme4)

# there is an outlier, remove that before continuing
#  (could also use subset=() in the lmer call

wool2 <- wool[wool$clean < 62,]

wool.vc <- lmer(clean~(1|bale),data=wool2)
wool.vc

# random effects in lmer are specified as the quantity that
#  varies (here the intercept) and the grouping variable
#  here the bale.
# for simple (e.g. 1-way random effects) uses, does not need
#  to be a factor.  Does't hurt to make it so.
# because bale is numeric, it isn't automatically convert to
#  a factor in read.table()

# lmer only allows REML (or full ML) estimation.

# bale needs to be a factor to use Nested effects (wool2.r)

wool2$bale.f <- as.factor(wool2$bale)
wool.vc <- lmer(clean~(1|bale.f),data=wool2)
wool.vc

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/wool.r


#==============================================================================
#	Test for randomForest
#==============================================================================

source("tests.r")

iris2 <- make.test.data.frame()

test.data <- list(
	call = list(
		substitute(
			glmmadmb(Sepal.Length ~ Petal.Length, family = "gaussian", data = iris2)
		),
		substitute(
			glmmadmb(bin ~ Petal.Length, family = "binomial", data = iris2)
		)
	),
	formula = list(
		Sepal.Length ~ Petal.Length,
		bin ~ Petal.Length
	),
	model.type = list("regression", "classification"),
	family = c("gaussian", "binomial"),
	link = list(gaussian()$linkfun, binomial()$linkfun),
	linkinv = list(gaussian()$linkinv, binomial()$linkinv)
)

test.model.adapter("glmmadmb", iris2, test.data)

rm(test.data, iris2)


    # copied from library carstm
    stmv_hyperparameters = function( reference_sd, alpha=0.5, reference_mean=0 ) {
      # some generic PC priors, scaled by sd of data
      # pc.prior to median .. minimally info. scale

      hyper = list(

        iid = list(
          prec = list(
            prior = "pc.prec",  # exponential decay
            param = c(reference_sd, alpha)
          )
        ),

        # means informative, sd marginally diffuse
        # see: inla.set.control.fixed.default() for defaults
        fixed = list(
            mean.intercept = reference_mean,
            prec.intercept = 1e-3,
            mean=0,
            prec=1e-2
        ),

        # param=c(u, alpha); u=sigma; alpha=prob;
        # see inla.doc("pc.prec")  ..prior sd attributable to rw2
        rw2 = list(
          prec = list(
            prior = "pc.prec",  # exponential decay
            param = c(reference_sd, alpha)
          )
        ),

        # see inla.doc("ar1") ; theta0, theta1 are expected
        # param=c(u, alpha); u=sigma; alpha=prob;
        # see inla.doc("pc.prec")  ..prior sd attributable to autocor rho
        # param=c(u, alpha); rho = 0.5; u=sqrt(1-rho); alpha=prob; see inla.doc("pc.cor1")
        ar1 = list(
          prec = list(
            prior = "pc.prec",  # exponential decay
            param = c(reference_sd, alpha)
          ),
          rho = list(
            prior = "pc.cor0", # inla.doc("pc.cor0") ..base model: rho = 0  --- expoential; will tend to 0 unless there is info
            param = c(sqrt(1-0.5), 0.1)  # rho=0.5; u=sqrt(1-rho)  ... 100-10% of probablity weight to rho 0.5 or less .. forces smooth and only goes high if really high
          )
        ),

        # naming convention is a bit different in groups .. Must be one of  theta theta1 rho logit correlation
        ar1_group = list(
          # theta1 = list(
          #   prior = "pc.prec",  # exponential decay
          #   param = c(reference_sd, alpha)
          # ),
          rho = list(
            prior = "pc.cor0", # inla.doc("pc.cor0") ..base model: rho = 0  --- expoential; will tend to 0 unless there is info
            param = c(sqrt(1-0.5), 0.1)  # rho=0.5; u=sqrt(1-rho)  ... 100-10% of probablity weight to rho 0.5 or less .. forces smooth and only goes high if really high
          )
        ),

        # param=c(u, alpha); u=phi (proportion spatial); alpha=prob
        bym2 = list(
          prec = list(
            prior = "pc.prec",
            param = c(reference_sd, alpha)
          ),
          phi = list(
            prior="pc",  # see bottom of inla.doc("bym2")
            param=c(0.5, 0.5) # c(phi=0.5, alpha=0.5)
          )
        )
      )

      return(hyper)
    }


# inspired in part by
# http://www.r-bloggers.com/how-to-plot-points-regression-line-and-residuals/
library(calibrate)
png("fig5.png", width=800, height=400)
df<-read.csv("./hampapprovalVSpopvote.csv",header=T)
row.names(df)<-df$state
hardest_hit_fund<-rep(0,50)
names(hardest_hit_fund)<-df$state
hardest_hit_fund[c("AL","AZ","CA","FL","GA","IL","IN","KY","MI","MS","NV","NJ","NC","OH","OR","RI","SC","TN")]=1
df$hardest_hit_fund<-hardest_hit_fund
linearModel<-lm(hamp_approval_rate~1+sign(popular_vote2012)+hardest_hit_fund, df)
plot(df$popular_vote2012,df$hamp_approval_rate,
	xlab="2012 Popular Vote %Romney - %Obama",
	ylab="MSA HAMP Loan Modification Approval Rate (%)")
pre<-predict(linearModel)
lines(df$popular_vote2012,pre,col="brown")
segments(df$popular_vote2012,df$hamp_approval_rate,df$popular_vote2012,pre,col="orange")
textxy(df$popular_vote2012, df$hamp_approval_rate, df$state, cex=0.7)
dev.off()


do_summary_stratified_mean_time_series <- function (x, target_var, strata_var, strata_size_var, period_var, klab){

	# calculates stratified mean statistics
	# Nuno Prista, SLU Aqua, Sweden
	# Developed @ KustMonitoring Review 2019

	#x is a data.frame values with
		# target values in target_var variable
		# a strata_var variable
		# a strata_size variable
		# period_var is a variable with the time series (e.g., Year, Year*Quarter)
		# strata_to_keep is a vector of strata to be used in computation of target_var

	# 2019-05-11: created from do_summary_stratified_mean
	# 2019-05-11: adapted to presence of missing values
	# 2019-05-11: adapted argument klab to configure strata according to indicator (email jens 09-05-2019)
	# 2019-05-11: added n_strata sampled to output - in case only disturbed stations are sampled a strata may end up not being sampled (overall mean will be biased)
	# 2019-05-15: correction of st_var_mean
	# 2019-05-15: added stratum ci (based on t distribution)
	# 2019-08-11: improvement of klab condition

	require(data.table)

	if(!is.data.table(x) & !is.data.frame(x)) stop ("x must be data.frame or data.table")
	if(!is.data.table(x)) x<-data.table(x)

# ==========================
# Stratified (st) results
# ==========================
	values<-parse(text=target_var)
	stratum<-parse(text=strata_var)
	size<-parse(text=strata_size_var)
	period<-parse(text=period_var)

	if(klab==TRUE)
		{
		# check on variable definition
		if (!target_var %in% c("CyprinidsB","CyprinidsN","EelN","EelpoutN","MesopredatorsN","PerchB","PerchN","PikeN","PiscivoresN", "CodN","FlounderN","HerringN", "PikeperchN", "WhitefishN"))
			{
			stop ("var stratification not defined - edit code")
			} else {
					if (target_var %in% c("CyprinidsB","CyprinidsN","EelN","EelpoutN","MesopredatorsN","PerchB","PerchN","PikeN","PiscivoresN")) { strata_to_keep <- c("0-3m", "3-6m", "6-10m") }
					if (target_var %in% c("CodN","FlounderN","HerringN", "PikeperchN", "WhitefishN") ) {	strata_to_keep <- c("0-3m", "3-6m", "6-10m", "10-20m") }
					x<-droplevels(x[eval(stratum) %in% strata_to_keep,])
					}
		} else strata_to_keep<-unique(x[,eval(stratum)])

	if (is.null(period_var)) { stop("must define period var\n")}

	if (!is.null(period_var))
		{
		# stratified variance
			# strata summary
				b1<-x[,list(stratum_size=eval(size)[1], variable = target_var, n=sum(!is.na(eval(values))), mean_x = mean(eval(values), na.rm=TRUE ), var_x = var(eval(values), na.rm=TRUE ), var_mean_x = var(eval(values), na.rm=TRUE )/sum(!is.na(eval(values))), se_mean_x = sd(eval(values), na.rm=TRUE )/sqrt(sum(!is.na(eval(values))))),list(eval(period), eval(stratum))][order(period, stratum)]
				b1[, `:=`(rse_mean_x = round(se_mean_x/mean_x*100,1), clow_mean = mean_x-qt(0.975,n)*se_mean_x, chigh_mean = mean_x+qt(0.975,n)*se_mean_x),]

			# stratified mean and stratified variance of the mean
				b2<-b1[, list( N=sum(stratum_size), n=sum(n), expect_strata = paste(strata_to_keep, collapse=","), samp_strata = paste(unique(stratum), collapse=","), n_strata = paste(n, collapse=","), st_mean = sum(mean_x*stratum_size/sum(stratum_size) ), st_var_mean = sum( 1*(var_mean_x)* ( (stratum_size/sum(stratum_size))^2) )   ), list(period)]
					# alternative calc (same results)
						# see above
			# stratified se of the mean
				b2[, st_se_mean:=sqrt(st_var_mean), period]
				b2[, st_rse_mean:=round(st_se_mean/st_mean*100,1), period]

		out<-list(pop_res = data.frame(type="stratified", variable = target_var, b2, clow_mean=b2$st_mean-2*b2$st_se_mean, chigh_mean=b2$st_mean+2*b2$st_se_mean), stratum_res = b1, type="stratified")

		}

out
}


sal = read.csv("Salaries.csv", header = TRUE)
Salary = sal$Salary
SincePhd = sal$Yrs.since.phd
Model = lm (Salary ~SincePhd)
predict(Model,data.frame(SincePhd=2)))
corval = cor(salary,SincePhd,method="pearson")


# Packages
require(lme4)
require(MuMIn)
library(reticulate)

# NumPy
np <- import("numpy")

# Read Data
path <- "/home/lucas/data/experiments/coha/analysis/"
files <- list.files(path)

# NP Array for Results
results <- array( data = rep(0,3*2*6*2), dim =  c(3,2,6,2))

i <- 1
for (model in list("word2vec", "glove", "fasttext")){
	j <- 1
	for (data_type in list("genuine", "random")){
		k <- 1
		for (size in list("0001", "0002", "0004", "0008", "0016", "0032")){
			file_name <- paste(model, data_type, size, sep = "_")
			if (file_name %in% files){
				npz <- np$load(paste(path,file_name, sep = ""))

				words = npz$f[["words"]]
				freq = npz$f[["frequencies"]]
				disp = npz$f[["displacements"]]

				d <- data.frame("words" = words, "freq" = freq, "disp" = disp)

				fm <- lmer(disp ~ freq + (1 | words), data = d)

				print(file_name)
				print(coef(summary(fm))[2])
				print(r.squaredGLMM(fm)[1])

				results[i,j,k,1] <- coef(summary(fm))[2]
				results[i,j,k,2] <- r.squaredGLMM(fm)[1]

			}
			k <- k + 1
		}
		j <- j + 1
	}
	i <- i + 1
}

np$save("analysis_results", results)


# Load EpiModel
suppressMessages(library(EpiModel))

control <- control.icm(type = "SIR", nsteps = 100, nsims = 10)
init <- init.icm(s.num = 997, i.num = 3, r.num = 0)

param <- param.icm(inf.prob = 0.05, act.rate = 10, rec.rate = 1/20,
                   a.rate = (10.5/365)/1000, ds.rate = (7/365)/1000, di.rate = (14/365)/1000,
                   dr.rate = (7/365)/1000)

sim <- icm(param, init, control)

plot(sim)
plot(sim, y = "si.flow", mean.col = "red", qnts.col = "red")


library(animation)
x <- c(1,2,3,5,6,9)
ani.options(interval = 1,ani.height = 1000,ani.width = 1000)
saveGIF({
  for(i in 1:length(x)){
    plot(x,rep(0,length(x)), pch = 20,cex = 3, axes = FALSE, xlab = "", ylab = "")
    abline(h = 0)
    text(x = x, y = rep(0.1,length(x)), c(expression(x[1]),expression(x[2]),expression(x[3]),
                                                expression(x[4]),expression(x[5]),expression(x[6])),
         cex = 2)
    text(x = x, y = rep(-0.1,length(x)),x,cex = 2)
    arrows(mean(x),-0.75,mean(x),0,length = 0.2,lwd = 2)
    text(mean(x),-0.85,expression(paste(mu[x], "(central value)")),cex = 1.5)
    text(mean(x),-0.95,paste("=",bquote(.(round(mean(x),2)))),cex = 1.5)
    arrows(7,0.75,x[4:6],0.2,length = 0.2,lwd = 2,lty = c(2,1,1))
    text(7,0.9,"Possible values of X",cex = 1.5)
    ##legend("topleft",bty = "n", legend = expression(paste("Var(X) = E[(X -",mu[X],")",""^2,"]")),cex = 1.3)
    arrows(mean(x),-0.25,x[i],-0.25,length = 0.1,code = 3,lwd = 2)
    text(mean(c(x[i],mean(x))),-0.3,bquote(x[.(i)] - mu[X]),cex = 2)
    text(mean(c(x[i],mean(x))),-0.4, paste("=",bquote(.(round(x[i] - mean(x),2)))),cex = 1.5)
    text(1.5,0.6,bquote((x[.(i)] - mu[X])^2),cex = 2)
    text(2.5,0.6, paste("=",bquote(.(round((x[i] - mean(x))^2,2)))),cex = 2)
  }}, movie.name = "var.gif"
)


dec2bin <- function(num) {
  ifelse(num == 0,
         0,
         sub("^0+","",paste(rev(as.integer(intToBits(num))), collapse = ""))
  )
}

for (anumber in c(0, 5, 50, 9000)) {
         cat(dec2bin(anumber),"\n")
}


# SMAA-Boot: uncertainty represented by the empirical probability distributions i.e.
# precisely the same probability distribution used in the MAUT results. Note that MAUT uses
# discrete draws from a continuous distribution. Thus, the discrete dbn may not match the
# theoretical dbn exactly. SMAA-Boot uses the empirical discrete dbn, SMAA1.r uses the
# theoretical dbn.

SMAABoot<-function(nI,J,runs,input,dstbn,ta,la)
{

  x=array(rep(0,nI*J*runs),c(runs,nI,J))
  # Generate bootstrap array of criterion values
  for (i in 1:nI){
    for (j in 1:J){
      x[,i,j]=sample(input[i,j,],runs,replace=TRUE)
    }
  }

  # Generate matrix of weights (inter-criteria importance)
  w=wts(nC,runs)

  # Compute utilities
  u=array(rep(0,runs*nI*J),c(runs,nI,J))
  for(j in 1:J)
  {
    cutoffs = c(0,ta[j],1)
    values = c(0,la[j],1)
    xt = as.vector(x[,,j])
    xt_pvf = smaa.pvf(xt,cutoffs=cutoffs,values=values,outOfBounds="clip")
    u[,,j] = matrix(xt_pvf,runs,nI)
  }

  # Run SMAA
  b = smaa(u,w)$ra
  b = unclass(b)
  b
}