# TODO: model with subj as third cue.

# source("act-s.r")
# reset_params()

######################################################################
##
## Standard reflexive interference model with 4 conditions.
##
## Uses csim to compute fan
## Includes a variation of fan effect size determined by the activation of competing chunk
## Parameters:
##   abl= antecedent base level activation
##   dbl= distractor base level activation
## Returns a list of
##   l= latencies by condition
##   m= misretrievals by condition
##   a= activations of antecedent and distractor AT RETRIEVAL for interference conditions
##   b= "BASE" activations without fan for interference conditions
##
######################################################################
refl_model_4cond_orig <- function(iterations=1000, csim=cuesim, ND=1, cweights=c(strWeight(),semWeight()), print=0){
  ta <- NULL  ## collects target activations
  l <- NULL   ## collects latencies
  r <- NULL   ## collects retrievals
  baseact <- NULL   ## collects chunk base activations
  finalact <- NULL  ## collects chunk act including fan / interference
  for(i in 1:iterations){
    a <- matrix(rep(NA,8),nrow=4)   ## Chunk activations
    b <- NULL
    fs <- NULL
    ##
    ##
    ## a) MATCH/INT: full match with fan from partially matching chunk
      b[1] <- activation(fan=c(1,1), match=c(0,0), bl=blc, times=lp, weights=cweights)                  # +c +a
      b[2] <- activation(fan=c(NA,1), match=c(-1,0), bl=dbl, times=ldp, weights=cweights)      # -c +a
      fs[1] <- fan_strength(b[1],b[2])
      fs[2] <- fan_strength(b[2],b[1])
    a[1,1] <- activation(fan=c(1+(ND*(1+csim)*fs[1]), 1+(ND*fs[1])), match=c(0,0), bl=blc, times=lp, weights=cweights)  # +c +a
    a[1,2] <- activation(fan=c(NA, ND+((1)*fs[2])), match=c(-1,0), bl=dbl, times=ldp, weights=cweights)     # -c +a
    ##
    ## b) MATCH/NOINT: full match, no fan
    a[2,1] <- activation(fan=c(1,1), match=c(0,0), bl=blc, times=lp, weights=cweights)     # +c +a
    a[2,2] <- activation(fan=c(NA,NA), match=c(-1,-1), bl=dbl, times=ldp, weights=cweights) # -c -a
    ##
    ## c) MISMATCH/INT: partial match with fan from partially matching chunk
      b[3] <- activation(fan=c(1,NA), match=c(0,-1), bl=blc, times=lp, weights=cweights) # +c -a
      b[4] <- activation(fan=c(NA,1), match=c(-1,0), bl=dbl, times=ldp, weights=cweights) # -c +a
      fs[3] <- fan_strength(b[3],b[4])
      fs[4] <- fan_strength(b[4],b[3])
    a[3,1] <- activation(fan=c(1+(ND*(1+csim)*fs[3]), NA), match=c(0,-1), bl=blc, times=lp, weights=cweights) # +c -a
    a[3,2] <- activation(fan=c(NA, ND+((1+csim)*fs[4])), match=c(-1,0), bl=dbl, times=ldp, weights=cweights) # -c +a
    ##
    ## d) MISMATCH/NOINT: partial match, no fan
    a[4,1] <- activation(fan=c(1,NA), match=c(0,-1), bl=blc, times=lp, weights=cweights)   # +c -a
    a[4,2] <- activation(fan=c(NA,NA), match=c(-1,-1), bl=dbl, times=ldp, weights=cweights) # -c -a
    ##
    ##
    r <- rbind(r, apply(a,1,retrieve))  ## retrieved chunk index
    maxacts <- apply(a,1,max)           ## maximum activation per condition
    l <- rbind(l, latency(maxacts))     ## latencies
    ##
    ta <- rbind(ta, a[,1])              ## target activations
    #
    baseact <- rbind(baseact, b)
    finalact <- rbind(finalact, c(a[1,],a[3,]))
  }
  ## correct retrievals:
  c <- r
  c[r!=1] <- 0
  ## retrieval failures:
  f <- r
  f[r==0] <- 1; f[r!=0] <- 0
  ## misretrievals:
  m <- 1-c
  m[f==1] <- 0
  ##
  if(print!=0) print(colMeans(l))
  if(print!=0) print(colMeans(m))
  if(print!=0) print(colMeans(f))
  colnames(baseact) <- c("match.int.ant","match.int.dis","mismatch.int.ant", "mismatch.int.dis")
  colnames(finalact) <- c("match.int.ant","match.int.dis","mismatch.int.ant", "mismatch.int.dis")
  return(list(l=l,c=c,f=f,m=m,baseact=baseact,act=finalact))
}

refl_model_4cond <- function(iterations=1000, csim=cuesim, ND=1, cweights=c(strWeight(),semWeight()), print=0){
  ta <- NULL  ## collects target activations
  l <- NULL   ## collects latencies
  r <- NULL   ## collects retrievals
  baseact <- NULL   ## collects chunk base activations
  finalact <- NULL  ## collects chunk act including fan / interference
  for(i in 1:iterations){
    a <- matrix(rep(NA,8),nrow=4)   ## Chunk activations
    b <- NULL
    fs <- NULL
    ##
    ##
    ## a) MATCH/INT: full match with fan from partially matching chunk
    res <- final_activation(c(1,1), c(NA,1), N2=ND, csim=cuesim, weights=cweights, bl1=blc, bl2=dbl, times1=lp, times2=ldp)
    a[1,1] <- res$a1
    a[1,2] <- res$a2
    b[1] <- res$b1
    b[2] <- res$b2
    ##
    ## b) MATCH/NOINT: full match, no fan
    res <- final_activation(c(1,1), c(NA,NA), N2=ND, csim=cuesim, weights=cweights, bl1=blc, bl2=dbl, times1=lp, times2=ldp)
    a[2,1] <- res$a1
    a[2,2] <- res$a2
    # b[1] <- res$b1
    # b[2] <- res$b2
    ##
    ## c) MISMATCH/INT: partial match with fan from partially matching chunk
    res <- final_activation(c(1,NA), c(NA,1), N2=ND, csim=cuesim, weights=cweights, bl1=blc, bl2=dbl, times1=lp, times2=ldp)
    a[3,1] <- res$a1
    a[3,2] <- res$a2
    b[3] <- res$b1
    b[4] <- res$b2
    ##
    ## d) MISMATCH/NOINT: partial match, no fan
    res <- final_activation(c(1,NA), c(NA,NA), N2=ND, csim=cuesim, weights=cweights, bl1=blc, bl2=dbl, times1=lp, times2=ldp)
    a[4,1] <- res$a1
    a[4,2] <- res$a2
    # b[1] <- res$b1
    # b[2] <- res$b2
    ##
    ##
    r <- rbind(r, apply(a,1,retrieve))  ## retrieved chunk index
    maxacts <- apply(a,1,max)           ## maximum activation per condition
    l <- rbind(l, latency(maxacts))     ## latencies
    ##
    ta <- rbind(ta, a[,1])              ## target activations
    #
    baseact <- rbind(baseact, b)
    finalact <- rbind(finalact, c(a[1,],a[3,]))
  }
  ## correct retrievals:
  c <- r
  c[r!=1] <- 0
  ## retrieval failures:
  f <- r
  f[r==0] <- 1; f[r!=0] <- 0
  ## misretrievals:
  m <- 1-c
  m[f==1] <- 0
  ##
  if(print!=0) print(colMeans(l))
  if(print!=0) print(colMeans(m))
  if(print!=0) print(colMeans(f))
  colnames(baseact) <- c("match.int.ant","match.int.dis","mismatch.int.ant", "mismatch.int.dis")
  colnames(finalact) <- c("match.int.ant","match.int.dis","mismatch.int.ant", "mismatch.int.dis")
  return(list(l=l,c=c,f=f,m=m,baseact=baseact,act=finalact))
}

######################################################################
##
## Reflexive interference model including +subj as cue
##
######################################################################
refl_model_4cond_subj_cue <- function(iterations=1000, ND=1, cweights=c(strWeight(),semWeight(), semWeight()), subj=TRUE, print=0){
  SF <- ifelse(subj, 1, NA)   ## Distractor subject feature
  SFM <- ifelse(subj, 0, -1)   ## Subject feature match
  SFC <- ifelse(subj, 0, 1)   ## Cuesim multiplicator
  ta <- NULL  ## collects target activations
  l <- NULL   ## collects latencies
  r <- NULL   ## collects retrievals
  baseact <- NULL   ## collects chunk base activations
  finalact <- NULL  ## collects chunk act including fan / interference
  for(i in 1:iterations){
    a <- matrix(rep(NA,8),nrow=4)   ## Chunk activations
    b <- NULL
    fs <- NULL
    ##
    ## a) MATCH/INT: full match with fan from partially matching chunk
    res <- final_activation(c(1,1,1), c(NA,1,SF), N2=ND, csim=cuesim, weights=cweights, bl1=blc, bl2=dbl, times1=lp, times2=ldp)
    a[1,1] <- res$a1
    a[1,2] <- res$a2
    b[1] <- res$b1
    b[2] <- res$b2
    ##
    ## b) MATCH/NOINT:
    res <- final_activation(c(1,1,1), c(NA,NA,SF), N2=ND, csim=cuesim, weights=cweights, bl1=blc, bl2=dbl, times1=lp, times2=ldp)
    a[2,1] <- res$a1
    a[2,2] <- res$a2
    # b[] <- res$b1
    # b[] <- res$b2
    ##
    ## c) MISMATCH/INT: partial match with fan from partially matching chunk
    res <- final_activation(c(1,NA,1), c(NA,1,SF), N2=ND, csim=cuesim, weights=cweights, bl1=blc, bl2=dbl, times1=lp, times2=ldp)
    a[3,1] <- res$a1
    a[3,2] <- res$a2
    b[3] <- res$b1
    b[4] <- res$b2
    ##
    ## d) MISMATCH/NOINT: partial match, no fan
    res <- final_activation(c(1,NA,1), c(NA,NA,SF), N2=ND, csim=cuesim, weights=cweights, bl1=blc, bl2=dbl, times1=lp, times2=ldp)
    a[4,1] <- res$a1
    a[4,2] <- res$a2
    # b[] <- res$b1
    # b[] <- res$b2
    ##
    ##
    r <- rbind(r, apply(a,1,retrieve))  ## retrieved chunk index
    maxacts <- apply(a,1,max)           ## maximum activation per condition
    l <- rbind(l, latency(maxacts))     ## latencies
    ##
    ta <- rbind(ta, a[,1])              ## target activations
    #
    baseact <- rbind(baseact, b)
    finalact <- rbind(finalact, c(a[1,],a[3,]))
  }
  ## correct retrievals:
  c <- r
  c[r!=1] <- 0
  ## retrieval failures:
  f <- r
  f[r==0] <- 1; f[r!=0] <- 0
  ## misretrievals:
  m <- 1-c
  m[f==1] <- 0
  ##
  if(print!=0) print(colMeans(l))
  if(print!=0) print(colMeans(m))
  if(print!=0) print(colMeans(f))
  colnames(baseact) <- c("match.int.ant","match.int.dis","mismatch.int.ant", "mismatch.int.dis")
  colnames(finalact) <- c("match.int.ant","match.int.dis","mismatch.int.ant", "mismatch.int.dis")
  return(list(l=l,c=c,f=f,m=m,baseact=baseact,act=finalact))
}

######################################################################
##
## Multiple feature mismatch model (Parker & Phillips, 2014)
##
######################################################################
refl_model_4cond_mult_feature_mismatch_orig <- function(iterations=1000, csim=cuesim, ND=1, cweights=c(strWeight(),semWeight(),semWeight()), print=0){
  ta <- NULL  ## collects target activations
  l <- NULL   ## collects latencies
  r <- NULL   ## collects retrievals
  baseact <- NULL   ## collects chunk base activations
  finalact <- NULL  ## collects chunk act including fan / interference
  for(i in 1:iterations){
    a <- matrix(rep(NA,12),ncol=2)   ## Chunk activations
    b <- NULL
    fs <- NULL
    ##
    ##
    ## a) MATCH/INT: full match with fan from partially matching chunk
      b[1] <- activation(fan=c(1,1,1), match=c(0,0,0), bl=blc, times=lp, weights=cweights)         # +c +g +n
      b[2] <- activation(fan=c(NA,1,1), match=c(-1,0,0), bl=dbl, times=ldp, weights=cweights)      # -c +g +n
      fs[1] <- fan_strength(b[1],b[2])
      fs[2] <- fan_strength(b[2],b[1])
    a[1,1] <- activation(fan=c(1+(ND*(1+csim)*fs[1]), 1+(ND*fs[1]), 1+(ND*fs[1])), match=c(0,0,0), bl=blc, times=lp, weights=cweights)
    a[1,2] <- activation(fan=c(NA, ND+(1*fs[2]), ND+(1*fs[2])), match=c(-1,0,0), bl=dbl, times=ldp, weights=cweights)
    ##
    ## b) MATCH/NOINT: full match, no fan
      b[3] <- activation(fan=c(1,1,1), match=c(0,0,0), bl=blc, times=lp, weights=cweights)         # +c +g +n
      b[4] <- activation(fan=c(NA,NA,1), match=c(-1,-1,0), bl=dbl, times=ldp, weights=cweights)    # -c -g +n
      fs[3] <- fan_strength(b[3],b[4])
      fs[4] <- fan_strength(b[4],b[3])
    a[2,1] <- activation(fan=c(1+(ND*(1+csim)*fs[3]),1+(ND*(1+csim)*fs[3]),1+(ND*fs[3])), match=c(0,0,0), bl=blc, times=lp, weights=cweights)     # +c +g +n
    a[2,2] <- activation(fan=c(NA,NA,ND+(1*fs[4])), match=c(-1,-1,0), bl=dbl, times=ldp, weights=cweights) # -c -g +n
    ##
    ## c) 1MISMATCH/INT: partial match with fan from partially matching chunk
      b[5] <- activation(fan=c(1,NA,1), match=c(0,-1,0), bl=blc, times=lp, weights=cweights) # +c -g +n
      b[6] <- activation(fan=c(NA,1,1), match=c(-1,0,0), bl=dbl, times=ldp, weights=cweights) # -c +g +n
      fs[5] <- fan_strength(b[5],b[6])
      fs[6] <- fan_strength(b[6],b[5])
    a[3,1] <- activation(fan=c(1+(ND*(1+csim)*fs[5]), NA, 1+(ND*fs[5])), match=c(0,-1,0), bl=blc, times=lp, weights=cweights)
    a[3,2] <- activation(fan=c(NA, ND+((1+csim)*fs[6]), ND+(1*fs[6])), match=c(-1,0,0), bl=dbl, times=ldp, weights=cweights)
    ##
    ## d) 1MISMATCH/NOINT: partial match, no fan
      b[7] <- activation(fan=c(1,NA,1), match=c(0,-1,0), bl=blc, times=lp, weights=cweights)       # +c -g +n
      b[8] <- activation(fan=c(NA,NA,1), match=c(-1,-1,0), bl=dbl, times=ldp, weights=cweights)    # -c -g +n
      fs[7] <- fan_strength(b[7],b[8])
      fs[8] <- fan_strength(b[8],b[7])
    a[4,1] <- activation(fan=c(1+(ND*(1+csim)*fs[7]),NA,1+(ND*fs[7])), match=c(0,-1,0), bl=blc, times=lp, weights=cweights)   # +c -g +n
    a[4,2] <- activation(fan=c(NA,NA,ND+(1*fs[8])), match=c(-1,-1,0), bl=dbl, times=ldp, weights=cweights) # -c -g +n
    ##
    ## e) 2MISMATCH/INT:
      b[9] <- activation(fan=c(1,NA,NA), match=c(0,-1,-1), bl=blc, times=lp, weights=cweights) # +c -g -n
      b[10] <- activation(fan=c(NA,1,1), match=c(-1,0,0), bl=dbl, times=ldp, weights=cweights) # -c +g +n
      fs[9] <- fan_strength(b[9],b[10])
      fs[10] <- fan_strength(b[10],b[9])
    a[5,1] <- activation(fan=c(1+(ND*(1+csim)*fs[9]), NA, NA), match=c(0,-1,-1), bl=blc, times=lp, weights=cweights)
    a[5,2] <- activation(fan=c(NA, ND+((1+csim)*fs[10]), ND+((1+csim)*fs[10])), match=c(-1,0,0), bl=dbl, times=ldp, weights=cweights)
    ##
    ## f) 2MISMATCH/NOINT:
      b[11] <- activation(fan=c(1,NA,NA), match=c(0,-1,-1), bl=blc, times=lp, weights=cweights)   # +c -g -n
      b[12] <- activation(fan=c(NA,NA,1), match=c(-1,-1,0), bl=dbl, times=ldp, weights=cweights)  # -c -g +n
      fs[11] <- fan_strength(b[11],b[12])
      fs[12] <- fan_strength(b[12],b[11])
    a[6,1] <- activation(fan=c(1+(ND*(1+csim)*fs[11]), NA, NA), match=c(0,-1,-1), bl=blc, times=lp, weights=cweights)   # +c -g +n
    a[6,2] <- activation(fan=c(NA,NA,ND+((1+csim)*fs[12])), match=c(-1,-1,0), bl=dbl, times=ldp, weights=cweights) # -
    ##
    r <- rbind(r, apply(a,1,retrieve))  ## retrieved chunk index
    maxacts <- apply(a,1,max)           ## maximum activation per condition
    l <- rbind(l, latency(maxacts))     ## latencies
    ##
    ta <- rbind(ta, a[,1])              ## target activations
    #
    baseact <- rbind(baseact, b)
    # finalact <- rbind(finalact, c(a[1,],a[3,]))
  }
  ## correct retrievals:
  c <- r
  c[r!=1] <- 0
  ## retrieval failures:
  f <- r
  f[r==0] <- 1; f[r!=0] <- 0
  ## misretrievals:
  m <- 1-c
  m[f==1] <- 0
  ##
  if(print!=0) print(colMeans(l))
  if(print!=0) print(colMeans(m))
  if(print!=0) print(colMeans(f))
  # colnames(baseact) <- c("match.int.ant","match.int.dis","mismatch.int.ant", "mismatch.int.dis")
  # colnames(finalact) <- c("match.int.ant","match.int.dis","mismatch.int.ant", "mismatch.int.dis")
  return(list(l=l,c=c,m=m,f=f,baseact=baseact))
}

######################################################################
##
## Multiple feature mismatch model (Parker & Phillips, 2014)
##
######################################################################
refl_model_4cond_mult_feature_mismatch <- function(iterations=1000, csim=cuesim, ND=1, cweights=c(strWeight(),semWeight(),semWeight()), print=0){
  SF <- ifelse(subj, 1, NA)   ## Distractor subject feature
  ta <- NULL  ## collects target activations
  l <- NULL   ## collects latencies
  r <- NULL   ## collects retrievals
  baseact <- NULL   ## collects chunk base activations
  finalact <- NULL  ## collects chunk act including fan / interference
  for(i in 1:iterations){
    a <- matrix(rep(NA,12),ncol=2)   ## Chunk activations
    b <- NULL
    fs <- NULL
    ##
    ##
    ## a) MATCH/INT: full match with fan from partially matching chunk
    ## +c +g +n +s
    ## -c +g +n +s
    res <- final_activation(c(1,1,1), c(NA,1,1), N2=ND, csim=cuesim, weights=cweights, bl1=blc, bl2=dbl, times1=lp, times2=ldp)
    a[1,1] <- res$a1
    a[1,2] <- res$a2
    b[1] <- res$b1
    b[2] <- res$b2
    ##
    ## b) MATCH/NOINT: full match, no fan
    res <- final_activation(c(1,1,1), c(NA,NA,1), N2=ND, csim=cuesim, weights=cweights, bl1=blc, bl2=dbl, times1=lp, times2=ldp)
    a[2,1] <- res$a1
    a[2,2] <- res$a2
    b[3] <- res$b1
    b[4] <- res$b2
    ##
    ## c) 1MISMATCH/INT: partial match with fan from partially matching chunk
    res <- final_activation(c(1,NA,1), c(NA,1,1), N2=ND, csim=cuesim, weights=cweights, bl1=blc, bl2=dbl, times1=lp, times2=ldp)
    a[3,1] <- res$a1
    a[3,2] <- res$a2
    b[5] <- res$b1
    b[6] <- res$b2
    ##
    ## d) 1MISMATCH/NOINT: partial match, no fan
    res <- final_activation(c(1,NA,1), c(NA,NA,1), N2=ND, csim=cuesim, weights=cweights, bl1=blc, bl2=dbl, times1=lp, times2=ldp)
    a[4,1] <- res$a1
    a[4,2] <- res$a2
    b[7] <- res$b1
    b[8] <- res$b2
    ##
    ## e) 2MISMATCH/INT:
    res <- final_activation(c(1,NA,NA), c(NA,1,1), N2=ND, csim=cuesim, weights=cweights, bl1=blc, bl2=dbl, times1=lp, times2=ldp)
    a[5,1] <- res$a1
    a[5,2] <- res$a2
    b[9] <- res$b1
    b[10] <- res$b2
    ##
    ## f) 2MISMATCH/NOINT:
    res <- final_activation(c(1,NA,NA), c(NA,NA,1), N2=ND, csim=cuesim, weights=cweights, bl1=blc, bl2=dbl, times1=lp, times2=ldp)
    a[6,1] <- res$a1
    a[6,2] <- res$a2
    b[11] <- res$b1
    b[12] <- res$b2
    ##
    r <- rbind(r, apply(a,1,retrieve))  ## retrieved chunk index
    maxacts <- apply(a,1,max)           ## maximum activation per condition
    l <- rbind(l, latency(maxacts))     ## latencies
    ##
    ta <- rbind(ta, a[,1])              ## target activations
    #
    baseact <- rbind(baseact, b)
    # finalact <- rbind(finalact, c(a[1,],a[3,]))
  }
  ## correct retrievals:
  c <- r
  c[r!=1] <- 0
  ## retrieval failures:
  f <- r
  f[r==0] <- 1; f[r!=0] <- 0
  ## misretrievals:
  m <- 1-c
  m[f==1] <- 0
  ##
  if(print!=0) print(colMeans(l))
  if(print!=0) print(colMeans(m))
  if(print!=0) print(colMeans(f))
  # colnames(baseact) <- c("match.int.ant","match.int.dis","mismatch.int.ant", "mismatch.int.dis")
  # colnames(finalact) <- c("match.int.ant","match.int.dis","mismatch.int.ant", "mismatch.int.dis")
  return(list(l=l,c=c,m=m,f=f,baseact=baseact))
}

######################################################################
##
## Multiple feature mismatch model (Parker & Phillips, 2014)
##
######################################################################
refl_model_4cond_mult_feature_mismatch_subj_cue <- function(iterations=1000, csim=cuesim, ND=1, cweights=c(strWeight(),semWeight(),semWeight(),semWeight()), subj=TRUE, print=0){
  SF <- ifelse(subj, 1, NA)   ## Distractor subject feature
  ta <- NULL  ## collects target activations
  l <- NULL   ## collects latencies
  r <- NULL   ## collects retrievals
  baseact <- NULL   ## collects chunk base activations
  finalact <- NULL  ## collects chunk act including fan / interference
  for(i in 1:iterations){
    a <- matrix(rep(NA,12),ncol=2)   ## Chunk activations
    b <- NULL
    fs <- NULL
    ##
    ##
    ## a) MATCH/INT: full match with fan from partially matching chunk
    ## +c +g +n +s
    ## -c +g +n +s
    res <- final_activation(c(1,1,1,1), c(NA,1,1,SF), N2=ND, csim=cuesim, weights=cweights, bl1=blc, bl2=dbl, times1=lp, times2=ldp)
    a[1,1] <- res$a1
    a[1,2] <- res$a2
    b[1] <- res$b1
    b[2] <- res$b2
    ##
    ## b) MATCH/NOINT: full match, no fan
    res <- final_activation(c(1,1,1,1), c(NA,NA,1,SF), N2=ND, csim=cuesim, weights=cweights, bl1=blc, bl2=dbl, times1=lp, times2=ldp)
    a[2,1] <- res$a1
    a[2,2] <- res$a2
    b[3] <- res$b1
    b[4] <- res$b2
    ##
    ## c) 1MISMATCH/INT: partial match with fan from partially matching chunk
    res <- final_activation(c(1,NA,1,1), c(NA,1,1,SF), N2=ND, csim=cuesim, weights=cweights, bl1=blc, bl2=dbl, times1=lp, times2=ldp)
    a[3,1] <- res$a1
    a[3,2] <- res$a2
    b[5] <- res$b1
    b[6] <- res$b2
    ##
    ## d) 1MISMATCH/NOINT: partial match, no fan
    res <- final_activation(c(1,NA,1,1), c(NA,NA,1,SF), N2=ND, csim=cuesim, weights=cweights, bl1=blc, bl2=dbl, times1=lp, times2=ldp)
    a[4,1] <- res$a1
    a[4,2] <- res$a2
    b[7] <- res$b1
    b[8] <- res$b2
    ##
    ## e) 2MISMATCH/INT:
    res <- final_activation(c(1,NA,NA,1), c(NA,1,1,SF), N2=ND, csim=cuesim, weights=cweights, bl1=blc, bl2=dbl, times1=lp, times2=ldp)
    a[5,1] <- res$a1
    a[5,2] <- res$a2
    b[9] <- res$b1
    b[10] <- res$b2
    ##
    ## f) 2MISMATCH/NOINT:
    res <- final_activation(c(1,NA,NA,1), c(NA,NA,1,SF), N2=ND, csim=cuesim, weights=cweights, bl1=blc, bl2=dbl, times1=lp, times2=ldp)
    a[6,1] <- res$a1
    a[6,2] <- res$a2
    b[11] <- res$b1
    b[12] <- res$b2
    ##
    r <- rbind(r, apply(a,1,retrieve))  ## retrieved chunk index
    maxacts <- apply(a,1,max)           ## maximum activation per condition
    l <- rbind(l, latency(maxacts))     ## latencies
    ##
    ta <- rbind(ta, a[,1])              ## target activations
    #
    baseact <- rbind(baseact, b)
    # finalact <- rbind(finalact, c(a[1,],a[3,]))
  }
  ## correct retrievals:
  c <- r
  c[r!=1] <- 0
  ## retrieval failures:
  f <- r
  f[r==0] <- 1; f[r!=0] <- 0
  ## misretrievals:
  m <- 1-c
  m[f==1] <- 0
  ##
  if(print!=0) print(colMeans(l))
  if(print!=0) print(colMeans(m))
  if(print!=0) print(colMeans(f))
  # colnames(baseact) <- c("match.int.ant","match.int.dis","mismatch.int.ant", "mismatch.int.dis")
  # colnames(finalact) <- c("match.int.ant","match.int.dis","mismatch.int.ant", "mismatch.int.dis")
  return(list(l=l,c=c,m=m,f=f,baseact=baseact))
}

########################################################
##
## Test-run models
##
########################################################
# reset_params()

# lf <<- 0.4
# mp <<- 0.2
# ans <<- 0.15
# cuesim <<- -1
# fsf <<- 0
# mas <<- 1
# rth <<- -1.5
# ldp <<- 1.5
# cueweighting <<- 1
# normalizeWeights <<- FALSE
# model <- refl_model_4cond_mult_feature_mismatch(iterations=3000,print=1)
# with(model, c(colMeans(l)[1]-colMeans(l)[2],colMeans(l)[3]-colMeans(l)[4],colMeans(l)[5]-colMeans(l)[6]))

# ## Original model: inhib/facil
# gaze
# rbrt
# lf <<- .15
# mp <<- 1.2
# ans <<- 0.15
# cuesim <<- 0
# fsf <<- 0
# mas <<- 3
# w <<- 1
# dbl <<- 0
# model <- refl_model_4cond(print=1)
# with(model, c(colMeans(l)[1]-colMeans(l)[2],colMeans(l)[3]-colMeans(l)[4]))

# ## Original model, prominent distr.:
# dbl <<- 1
# model <- refl_model_4cond(print=1)
# with(model, c(colMeans(l)[1]-colMeans(l)[2],colMeans(l)[3]-colMeans(l)[4]))

# ## Exp1: none/inhib
# lf <<- .3
# mp <<- 1
# ans <<- 0.2
# cuesim <<- -1
# fsf <<- 4
# dbl <<- 0
# model <- refl_model_4cond(iterations=3000,print=1)
# with(model, c(colMeans(l)[1]-colMeans(l)[2],colMeans(l)[3]-colMeans(l)[4]))

# ## Prominent distr.
# lf <<- .15
# mp <<- 1.2
# ans <<- 0.15
# cuesim <<- -1
# fsf <<- 0
# dbl <<- 1
# model <- refl_model_4cond(print=1)
# with(model, c(colMeans(l)[1]-colMeans(l)[2],colMeans(l)[3]-colMeans(l)[4]))

# ## Exp2: mult distr
# lf <<- .15
# mp <<- 1.2
# ans <<- 0.15
# cuesim <<- 0
# fsf <<- 0
# mas <<- 3
# w <<- 1
# dbl <<- 0
# model <- refl_model_4cond_mult_distr(print=1)
# with(model, c(colMeans(l)[1]-colMeans(l)[2],colMeans(l)[3]-colMeans(l)[4]))

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

# ## Exp2: inhib/-
# gaze
# rbrt
# lf <- .13
# mp <- 1.2
# cuesim <- -.6
# fsf <- 4
# ans <- 0.1
# model <- similarity_model_3_exp2(1000, csim=cuesim, data=exp2, print=2)
# fit2(exp2, round(colMeans(model$l)), print=2)

# ## Multiple distr.: inhib/-
# gaze
# rbrt
# lf <- .15
# mp <- 1.2
# cuesim <- -.3
# fsf <- 4
# ans <- 0.15
# model <- similarity_model_3_mult_distr(1000, csim=cuesim, data=exp2, print=2)
# fit(rbrt, round(colMeans(model$l)), print=2)

# ## none/none
# gaze
# rbrt
# lf <- .13
# mp <- 1.2
# cuesim <- -.8
# fsf <- 4
# ans <- 0.1
# similarity_model_3_exp1(1000, csim=cuesim, data=gaze, print=2)

# ## none/facil
# gaze
# rbrt
# lf <- .13
# mp <- 1.2
# cuesim <- -.9
# fsf <- 4
# ans <- 0.1
# similarity_model_3_exp1(1000, csim=cuesim, data=gaze, print=2)

# ## inhib/facil
# gaze
# rbrt
# lf <- .13
# mp <- 1.2
# cuesim <- -.9
# fsf <- 1
# ans <- 0.1
# similarity_model_3_exp1(1000, csim=cuesim, data=gaze, print=2)

# ## inhib/none
# gaze
# rbrt
# lf <- .13
# mp <- 1.2
# cuesim <- -.8
# fsf <- 1
# ans <- 0.1
# similarity_model_3_exp1(1000, csim=cuesim, data=gaze, print=2)

# ## inhib/-
# gaze
# rbrt
# lf <- .13
# mp <- 1.2
# cuesim <- 0
# fsf <- 4
# ans <- 0.1
# similarity_model_3_exp1(1000, csim=cuesim, data=gaze, print=2)


library(data.table)

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

load('../generated/model/mcmc-results.rdata', v=F)

spplist <- fread('../acap-species-list.csv')[base_species == T]
setkeyv(spplist, 'code.sra')

load('../generated/pst-samples.rdata', v=F)
load('../../input-data/grid/grids.rdata')

## ** APF

mcsel <- mcmc[variable %in% mc_attributes[role == 'flag_quarter0_spatial0' & vartype == 'apf_t', variable]]
mcsel <- merge(mcsel, mc_attributes, by = 'variable', all.x=T, all.y=F)
apf_samples <- mcsel[, .(apf = sum(value)), .(species_code, sample)]

apf_samples[spplist,
            `:=`(cname = upper1st(i.cname),
                 sname = i.Taxa),
            on = c('species_code' = 'code.sra')]

saveRDS(apf_samples, '../generated/apf-samples.rds')

apf_sp_summ <- apf_samples[
  , .(mean     = mean(apf),
      median   = median(apf),
      sd       = sd(apf),
      lcl      = quantile(apf, 0.025, names=F),
      ucl      = quantile(apf, 0.975, names=F),
      nsamples = .N), .(species_code)]

apf_sp_summ[spplist,
            `:=`(common_name = upper1st(i.cname),
                 sname = i.Taxa),
            on = c('species_code' = 'code.sra')]
setorder(apf_sp_summ, -mean)

fwrite(apf_sp_summ, '../generated/apf-summary.csv')

## * Aggregated spatial APF
#TBC
mcsel_space <- mcmc[variable %in% mc_attributes[role == 'quarter0_spatial1' & vartype == 'apf_t', variable]]
mcsel_space <- merge(mcsel_space, mc_attributes, by = 'variable', all.x=T, all.y=F)
apf_samples_space <- mcsel_space[, .(apf = sum(value)), .(grid_id, sample)]
apf_grid <- merge(apf_samples_space[, .(apf=mean(apf)), grid_id], grid, by='grid_id')
write.csv(apf_grid[, .(longitude=centre.y, latitude=centre.x, captures=apf)], row.names=FALSE, file='../generated/apf-mean-grid.csv')

## ** Risk

risk_ratio <- merge(pst_samples, apf_samples, by = c('species_code', 'sample'))
risk_ratio[, riskratio := apf / pst]

### APF by genus
mcsel_genus <- mcmc[variable %in% mc_attributes[role == 'quarter0_spatial1' & vartype == 'apf_t', variable]]
mcsel_genus <- merge(mcsel_genus, mc_attributes, by = 'variable', all.x=T, all.y=F)
apf_samples_genus <- merge(mcsel_genus, spplist[, .(species_code=code.sra, genus=vulgroup)], by='species_code', all.x=T)
apf_genus <- apf_samples_genus[, .(apf=sum(value)), .(sample, genus)][, .(amean=mean(apf), ali=quantile(apf, 0.025), aui=quantile(apf, 0.975)), genus]
write.csv(apf_genus, row.names=FALSE, file='../generated/apf-genus.csv')

## ** Summarise
risk_summ <- risk_ratio[, .(pst_mean = mean(pst),
                            pst_lcl  = quantile(pst, 0.025, names = F),
                            pst_ucl  = quantile(pst, 0.975, names = F),
                            apf_mean = mean(apf),
                            apf_lcl  = quantile(apf, 0.025, names = F),
                            apf_ucl  = quantile(apf, 0.975, names = F),
                            rr_med  = median(riskratio),
                            rr_lcl   = quantile(riskratio, 0.025, names = F),
                            rr_ucl   = quantile(riskratio, 0.975, names = F),
                            rr_p_ov_1 = mean(riskratio > 1)), species_code]
risk_summ[, `:=`(pst_ci = sprintf('%s--%s',
                                  format(round(pst_lcl,1), big.mark=' ', trim=T),
                                  format(round(pst_ucl,1), big.mark=' ', trim=T)),
                 apf_ci = sprintf('%s--%s',
                                  format(round(apf_lcl), big.mark=' ', trim=T),
                                  format(round(apf_ucl), big.mark=' ', trim=T)),
                 rr_ci = sprintf('%s--%s',
                                 format(round(rr_lcl,2), big.mark=' ', trim=T),
                                 format(round(rr_ucl,2), big.mark=' ', trim=T)))]

risk_summ <- merge(spplist[, .(species_code=code.sra, sname=Taxa, cname)], risk_summ, by = 'species_code')

saveRDS(risk_ratio, '../generated/risk-ratios.rds')
fwrite(risk_summ, '../generated/risk-ratios-summary.csv')


#!/usr/bin/env Rscript

#######################################################################
#######################################################################
## Created on April. 29, 2021 call edgeR
## Copyright (c) 2021 Jianhong Ou (jianhong.ou@gmail.com)
#######################################################################
#######################################################################
pwd <- getwd()
pwd <- file.path(pwd, "lib")
dir.create(pwd)
.libPaths(c(pwd, .libPaths()))

library(edgeR)
writeLines(as.character(packageVersion("edgeR")), "edgeR.version.txt")

binsize = "diffhic_bin5000"
## load n.cores
args <- commandArgs(trailingOnly=TRUE)
if(length(args)>0){
  binsize <- args[[1]]
  args <- args[-1]
}
if(length(args)>0){
  args <- lapply(args, function(.ele) eval(parse(.ele)))
}else{
  args <- list()
}

## get peaks
pf <- dir("peaks", "bedpe", full.names = TRUE)
peaks <- lapply(pf, read.delim)
### reduce the peaks
peaks <- unique(do.call(rbind, peaks)[, c("chr1", "start1", "end1",
                                          "chr2", "start2", "end2")])

## get counts
pc <- dir("long", "bedpe", full.names = FALSE)
cnts <- lapply(file.path("long", pc), read.table)
samples <- sub("(_REP\\d+)\\.(.*?)\\.long.intra.bedpe", "\\1", pc)
cnts <- lapply(split(cnts, samples), do.call, what=rbind)
sizeFactor <- vapply(cnts, FUN=function(.ele) sum(.ele[, 7], na.rm = TRUE),
                     FUN.VALUE = numeric(1))

getID <- function(mat) gsub("\\s+", "", apply(mat[, seq.int(6)], 1, paste, collapse="_"))
peaks_id <- getID(peaks)
cnts <- do.call(cbind, lapply(cnts, function(.ele){
  .ele[match(peaks_id, getID(.ele)), 7]
}))
cnts[is.na(cnts)] <- 0
names(peaks_id) <- paste0("p", seq_along(peaks_id))
rownames(cnts) <- names(peaks_id)

pf <- as.character(binsize)
dir.create(pf)

fname <- function(subf, ext, ...){
  pff <- ifelse(is.na(subf), pf, file.path(pf, subf))
  dir.create(pff, showWarnings = FALSE, recursive = TRUE)
  file.path(pff, paste(..., ext, sep="."))
}

## write counts
write.csv(cbind(peaks, cnts), fname(NA, "csv", "raw.counts"), row.names = FALSE)
## write sizeFactors
write.csv(sizeFactor, fname(NA, "csv", "library.size"), row.names = TRUE)

## coldata
sampleNames <- colnames(cnts)
condition <- sub("_REP.*$", "", sampleNames)
coldata <- data.frame(condition=factor(condition),
                      row.names = sampleNames)
## write designtable
write.csv(coldata, fname(NA, "csv", "designTab"), row.names = TRUE)

contrasts.lev <- levels(coldata$condition)

if(length(contrasts.lev)>1 || any(table(condition)>1)){
  contrasts <- combn(contrasts.lev, 2, simplify = FALSE)
  ## create DGEList
  group <- coldata$condition
  y <- DGEList(counts = cnts,
               lib.size = sizeFactor,
               group = group)

  ## do differential analysis
  names(contrasts) <- vapply(contrasts,
                             FUN=paste,
                             FUN.VALUE = character(1),
                             collapse = "-")
  y <- calcNormFactors(y)
  design <- model.matrix(~0+group)
  colnames(design) <- levels(y$samples$group)
  y <- estimateDisp(y,design)
  fit <- glmQLFit(y, design)

  ## PCA
  pdf(fname(NA, "pdf", "Multidimensional.scaling.plot-plot"))
  plotMDS(y)
  dev.off()
  ## plot dispersion
  pdf(fname(NA, "pdf", "DispersionEstimate-plot"))
  plotBCV(y)
  dev.off()
  ## plot QL dispersions
  pdf(fname(NA, "pdf", "Quasi-Likelihood-DispersionEstimate-plot"))
  plotQLDisp(fit)
  dev.off()

  res <- mapply(contrasts, names(contrasts), FUN = function(cont, name){
    BvsA <- makeContrasts(contrasts = name, levels = design)
    qlf <- glmQLFTest(fit, contrast = BvsA)
    rs <- topTags(qlf, n = nrow(qlf), sort.by = "none")
    ## MD-plot
    pdf(fname(name, "pdf", "Mean-Difference-plot", name))
    plotMD(qlf)
    abline(h=0, col="red", lty=2, lwd=2)
    dev.off()
    ## PValue distribution
    pdf(fname(name, "pdf", "PValue-distribution-plot", name))
    hist(rs$table$PValue, breaks = 20)
    dev.off()
    ## save res
    res <- as.data.frame(rs)
    res <- cbind(peaks, res[names(peaks_id), ])
    write.csv(res, fname(name, "csv", "edgeR.DEtable", name), row.names = FALSE)
    ## save metadata
    elementMetadata <- do.call(rbind, lapply(c("adjust.method","comparison","test"), function(.ele) rs[[.ele]]))
    rownames(elementMetadata) <- c("adjust.method","comparison","test")
    colnames(elementMetadata)[1] <- "value"
    write.csv(elementMetadata, fname(name, "csv", "edgeR.metadata", name), row.names = TRUE)
    ## save subset results
    res.s <- res[res$FDR<0.05 & abs(res$logFC)>1, ]
    write.csv(res.s, fname(name, "csv", "edgeR.DEtable", name, "padj0.05.lfc1"), row.names = FALSE)
    ## Volcano plot
    res$qvalue <- -10*log10(res$PValue)
    pdf(fname(name, "pdf", "Volcano-plot", name))
    plot(x=res$logFC, y=res$qvalue,
         main = paste("Volcano plot for", name),
         xlab = "log2 Fold Change", ylab = "-10*log10(P-value)",
         type = "p", col=NA)
    res.1 <- res[res$padj>=0.05 & abs(res$logFC)<=1, ]
    if(nrow(res.1)>0) points(x=res.1$logFC, y=res.1$qvalue, pch = 20, cex=.5, col="gray80")
    if(nrow(res.s)>0) points(x=res.s$logFC, y=res.s$qvalue, pch = 19, cex=.5, col=ifelse(res.s$logFC>0, "brown", "darkblue"))
    dev.off()
    res$qvalue <- -10*log10(res$PValue)
    png(fname(name, "png", "Volcano-plot", name))
    plot(x=res$logFC, y=res$qvalue,
         main = paste("Volcano plot for", name),
         xlab = "log2 Fold Change", ylab = "-10*log10(P-value)",
         type = "p", col=NA)
    res.1 <- res[res$padj>=0.05 & abs(res$logFC)<=1, ]
    if(nrow(res.1)>0) points(x=res.1$logFC, y=res.1$qvalue, pch = 20, cex=.5, col="gray80")
    if(nrow(res.s)>0) points(x=res.s$logFC, y=res.s$qvalue, pch = 19, cex=.5, col=ifelse(res.s$logFC>0, "brown", "darkblue"))
    dev.off()
  })
}


require(graphics)
require(Matrix)

pdf(file="plots/Experiment3b.pdf",
  width=4.5, height=4.0, family="serif", pointsize=14)

datasets = c("Adult", "Covtype", "USCensus", "KDD98")
plot_colors <- c("orangered", "black", "orange", "cornflowerblue")

data = matrix(0, 5, 7); #dataset x params
data[1,] = as.matrix(c(0.36,0.68,0.84,0.92,0.96,0.98,0.99))

for(i in 1:(nrow(data)-1)) {
  for(j in 1:ncol(data)) {
    fname = paste("results/Experiment3_",datasets[i],"_a",data[1,j],".dat",sep="")
    if( file.exists(fname) ) {
      data[i+1,j] = as.matrix(read.table(fname, sep=","))[1,4]
    }
    else {
      print(paste(fname," does not exist"))
    }
  }
}

data[1,] = 1-data[1,]

print(data)

plot(   data[1,], data[5,],
        type="o",
        pch=19,
        cex=1.1,
        col=plot_colors[4],
        ylim = c(1,2e6),
        xlab="",
        ylab="",
        axes=FALSE,
        bg=plot_colors[4],
        log="xy",
        lwd=1.1,
        lty=1
  )

axis(2, las=2,at=c(1,10,100,1000,1e4,1e5,1e6), labels=c("1","10","100","1000","1e4","1e5","1e6"))
axis(1, las=1, at=c(0.01,0.02,0.04,0.08,0.16,0.32,0.64),
      labels=c("0.99",".98",".96",".92",".84",".68",".36"))
mtext(2, text="Top-1 Slice Size", line=2.7)
mtext(1, text=expression(paste("Weight Parameter ",alpha)), line=2)

lines(data[1,2:7], data[2,2:7], type="o", pch=15, lty=1, lwd=1.1, col=plot_colors[1], bg=plot_colors[1], cex=1.0)
lines(data[1,2:7], data[3,2:7], type="o", pch=17, lty=1, lwd=1.1, col=plot_colors[2], bg=plot_colors[2], cex=1.0)
lines(data[1,2:7], data[4,2:7], type="o", pch=25, lty=1, lwd=1.1, col=plot_colors[3], bg=plot_colors[3], cex=1.0)

box()

legend( "bottomright",
       c("USCensus","Adult", "KDD98", "Covtype"), col=plot_colors[c(3,1,4,2)],
       pch=c(25,15,19,17), lty=c(1), lwd=c(1.1), bty="n", ncol=2, pt.bg=plot_colors[c(3,1,4,2)]);

text(0.32, 1000, expression(paste(sigma," = 0.01n")))

dev.off()


# This is a test/example rd file
# Two spheres, pure diffuse surface, one distant light behind eye.

Display "Simple Shading"  "Screen" "rgbdouble"
Format 640 480
CameraFOV 5
CameraEye 0 0 50

WorldBegin

FarLight 0 0 -1  1.0  1.0  1.0  1.0

Ka 0.0
Kd 1.0

Translate 1.25 0 0

Sphere 1.0 -1.0 1.0 360.0

Translate -2.5 0 0

Sphere 1.0 -1.0 1.0 360.0

WorldEnd


library(tidyverse)
library(reticulate)

np <- import("numpy")

data <- np$load(
  "./outputs/all_scores_mag_models_mnecommonsubjects_interval_shuffle-split.npy",
  allow_pickle = T)[[1]] %>%
  as.data.frame()

data["mne"] <- np$load(
  "./outputs/scores_mag_models_mne_intervals.npy",
  allow_pickle = T)[[1]]["mne_shuffle_split"] %>%
  as.data.frame()

data$dummy <- NULL
data$rand_riemannwass <-  NULL
data$unsup_riemannwass <-  NULL
data$sup_riemannwass <-  NULL

data_long <- data %>% gather(key = "estimator", value = "score")
# move to long format
data_long$estimator <- factor(data_long$estimator)

# set distance types
est_types <- c(
  # "dummy",
  "log-diag",
  "log-diag",
  "log-diag",
  "log-diag",
  "Wasserstein",
#   "Wasserstein",
#   "Wasserstein",
#   "Wasserstein",
  "geometric",
  "geometric",
  "geometric",
  "geometric",
  "MNE"
)

# categorical colors based on: https://jfly.uni-koeln.de/color/
color_cats <- c(
  "#000000",
  "#009D79",# blueish green
  "#E36C2F",  #vermillon
  "#EEA535",  # orange
  "#0072B2" #blue
)

# beef up long data
data_long$est_type <- rep(est_types, each = 100)  %>%
  factor(., levels = c("dummy", "log-diag", "Wasserstein", "geometric",
                       "MNE"))
data_long$fold <- rep(1:100, times = length(est_types))

# prepare properly sorted x labels
sort_idx <-  apply(data, 2, mean) %>% order()
levels_est <- c(
  # "dummy",
  "identity",
  "random",
  "unsupervised",
  "supervised",
  "identity",
  # "random[r]",
  # "unsupervised[r]",
#   "SPoC[r]",
  "identity",
  "random",
  "unsupervised",
  "supervised",
  "biophysics"
)[sort_idx]

ggplot(data = data_long %>% subset(estimator != "dummy"),
       mapping = aes(y = score, x = reorder(estimator, score))) +
  geom_jitter(alpha = 0.5, aes(color = est_type), size = 3.5) +
  geom_boxplot(mapping = aes(fill = est_type), alpha = 0.2,
               outlier.fill = NA, outlier.colour = NA) +
  theme_minimal() +
  labs(y = "mean absolute error (years)", x = NULL) +
  theme(text = element_text(family = "Helvetica", size = 18),
        legend.position = "top", legend.text = element_text( size = 18)) +
  coord_flip() +
  scale_fill_manual(values = color_cats[2:5], name = NULL) +
  scale_color_manual(values = color_cats[2:5], name = NULL) +
  scale_x_discrete(labels = parse(text = levels_est))

ggsave("./figures/fig1_meg_data_full_intervals.png", width = 8, height = 6, dpi = 300)
ggsave("./figures/fig1_meg_data_full_intervals.pdf", width = 8, height = 6, dpi = 300)


#!/usr/bin/Rscript

stateShipments <- read.csv('../data/StateShipments.csv', skip=2, na.strings="")
desel <- c("Origin", "Total", "X")
test <- !(colnames(stateShipments) %in% desel)
ss <- stateShipments[, test]

desel <- c("Total", "NA.")
rn <- make.names(stateShipments$Origin)
test <- !(rn %in% desel)
ss <- ss[test, ]
rownames(ss) <- rn[test]
stopifnot(rownames(ss) == colnames(ss))
ss[is.na(ss)] <- 0

key <- match(colnames(ss), c(make.names(state.name), 'District.of.Columbia',
                             'Mexico', 'Canada', 'Other.states'))
nms <- c(state.abb, 'DC', 'Mexico', 'Canada', 'otherStates')[key]

rownames(ss) <- colnames(ss) <- nms
write.csv(data.matrix(ss),
          'shipment-flows-origins-on-rows-dests-on-columns.csv',
          row.names=TRUE)


gdi.data <- read.csv("/media/Linux_backup/snpchip/structure/results/wtccc/GDI_DISC_RAND001_100T1D_100NBS_level3_all.csv");
pdf("gdi_test_RAND001_100T1D_100NBS_level3_all.pdf",paper="a4r",
    width=11,height=8);
plot(gdi.data$SNPs,gdi.data$GDI, ylab = "Genome Diagnostic Index",
     xlab = "Number of SNPs");
plot(gdi.data$SNPs,gdi.data$GDI - c(0,gdi.data$GDI[-(dim(gdi.data)[1])]),
     ylab = "GDI difference", xlab = "Number of SNPs",
     col = sapply(gdi.data$GDI - c(0,gdi.data$GDI[-(dim(gdi.data)[1])]),
       function(x){
       if(x<0)
         return ("red");
       if(x==0)
         return("yellow");
       if(x>0)
         return("green");
     }));
abline(h=0);
dummy <- dev.off();


#!/usr/bin/env Rscript

# install.packages('devtools')
# devtools::install_github('wmay/dwnominate')
library(dwnominate)
library(pscl)

rcList <- list()

for (councilPeriod in 22:23) {
    dat <- readLines(paste("votes-", councilPeriod, ".fwf", sep = ""))
    names <- substring(dat, 1, 12)
    dat <- substring(dat, 13)
    rows <- length(dat)
    mat <- matrix(
        NA,
        ncol = nchar(dat[1]),
        nrow = rows
    )
    for(i in 1:rows){
        mat[i,] <- as.numeric(
            unlist(
                strsplit(dat[i], split = character(0))
            )
        )
    }
    rc <- rollcall(
        mat,
        yea = 1,
        nay = 2,
        missing = c(0, 3, 4, 5, 6, 7, 8),
        notInLegis = 9,
        legis.names = names,
        desc = paste("DC Council", councilPeriod)
    )
    summary(rc, verbose = TRUE)
    rcList <- append(rcList, rc)
}

results <- dwnominate(rcList)
plot(results)


#!/usr/bin/env Rscript
library(scatterD3)
library(htmlwidgets)
## https://github.com/juba/scatterD3
## https://cran.r-project.org/web/packages/scatterD3/scatterD3.pdf
## https://cran.r-project.org/web/packages/scatterD3/vignettes/introduction.html

caption = list(title = "Notes",
               subtitle = "",
               text = "Builds 50 to 80 ran with excessive coverage reporting set to -Dcoverage=1. The straight line represents the linear regression on throughput.")

data <- read.csv(file('stdin'), header=T, as.is=T)

## Derive some data
data$labels <- ifelse(data$CLOUD == "aws-ec2","", data$CLOUD)
data$urls <- sprintf("https://tla.msr-inria.inria.fr/build/job/M-HEAD-master-TLC-performances/CLOUD=%s,SPEC=%s/%s/", data$CLOUD, data$SPEC, data$BUILD_NUMBER)
data$tooltips <- sprintf("Cloud: %s
Spec: %s
Build number: %s
Commit: %s (%s)", data$CLOUD, data$SPEC, data$BUILD_NUMBER, data$REVISION, data$BRANCH)

## linear regression of throuphput
lma <- lm(VALUE ~ BUILD_NUMBER, data=subset(data, MEASUREMENT == "Throughput"))
line <- data.frame(slope = coef(lma)["BUILD_NUMBER"], intercept = coef(lma)["(Intercept)"], stroke = "red", stroke_width = 3, stroke_dasharray = "7,5")

s <- scatterD3(data = data, x = BUILD_NUMBER, y = VALUE, y_log=T, xlab = "Build Number", ylab = "log(Time&Throughput)",
               col_var=SPEC, symbol_var = MEASUREMENT,
               url_var = urls, tooltip_text = data$tooltips,
               lab = labels, caption = caption,
               lines = line)
saveWidget(s, file="index.html")


library(bayesplot)
library(ggplot2)

## allow the effect of each NPI to come in gradually
gradual.npi.effect <- function(stan_data, lambda=0.7) {
  grad.effect <- round(1 - exp(-lambda * 1:20), 2)

  ## loop over countries
  for (m in 1:nrow(stan_data$X)) {
    first.day <- apply(stan_data$X[m, , ], 2, function(z) which(z == 1)[1])
    for (p in 1:length(first.day)) {
      if (is.na(first.day[p])) next
      stan_data$X[m, first.day[p] + 1:length(grad.effect) - 1, p] <- grad.effect
    }
  }

  return(stan_data)
}

## save results data
save.results <- function(fit, processed_data, modelname) {
  out <- rstan::extract(fit)
  prediction <- out$prediction
  estimated.deaths <- out$E_deaths
  estimated.deaths.cf <- out$E_deaths0

  stan_data <- processed_data$stan_data
  dates <- processed_data$dates
  deaths_by_country <- processed_data$deaths_by_country
  reported_cases <- processed_data$reported_cases
  countries <- countries$Regions

  save(fit, prediction, dates, reported_cases, deaths_by_country, countries,
       estimated.deaths, estimated.deaths.cf, stan_data, processed_data,
       file=paste0("results/", modelname, "-stanfit.Rdata"))
}

## deaths/counterfactual and MSE
get.deaths.mse <- function(fit, processed_data, forecast=0) {
  cases.pr <- rstan::extract(fit, "prediction")[[1]]
  deaths.pr <- rstan::extract(fit, "E_deaths")[[1]]
  deaths.cf <- rstan::extract(fit, "E_deaths0")[[1]]
  deaths.ob <- processed_data$deaths_by_country
  dates <- processed_data$dates
  S <- nrow(deaths.pr) # number of samples

  ## loop over countries
  cum.deaths.mse <- NULL
  for (m in 1:length(dates)) {
    ## consider only deaths within the modelled period
    N <- length(dates[[m]])
    if (forecast > 0)
      per <- tail(1:N, forecast)
    else
      per <- 1:N
    mse <- apply(deaths.pr[, , m], 1,
                 function(z) mean((z[per] - deaths.ob[[m]][per])^2))
    cum.deaths.mse <- rbind(cum.deaths.mse,
                            c(sum(colMeans(deaths.pr[, 1:N, m])),
                              sum(colMeans(deaths.cf[, 1:N, m])),
                              sum(colMeans(cases.pr[, 1:N, m])),
                              mean(mse)))

  }

  cum.deaths.mse <- as.data.frame(cum.deaths.mse)
  rownames(cum.deaths.mse) <- names(dates)
  colnames(cum.deaths.mse) <- c("deaths", "counterfactual", "infections", "mse")
  cum.deaths.mse[, 1:3] <- round(cum.deaths.mse[, 1:3])
  cum.deaths.mse$mse <- round(cum.deaths.mse$mse, 1)
  return(cum.deaths.mse)
}

## compute ranges of herd immunity threshold from posterior means of parameters
hit <- function(fit) {
  R0 <- rstan::extract(fit, "mu")[[1]]
  alpha <- tryCatch(matrix(rstan::extract(fit, "a_het")[[1]],
                           nrow(R0), ncol(R0)),
                    error=function(e) Inf)
  hit <- 1 - (1 / R0)^(1 - 1 / (1 + alpha))
  list(hit=colMeans(hit), R0=colMeans(R0),
       range.hit=range(colMeans(hit)),
       range.R0=range(colMeans(R0)),
       alpha=mean(alpha))
}

## create some plots
plot.mu.rt.rhat <- function(modelname) {
  filename <- paste0("results/", modelname, "-stanfit.Rdata")
  print(sprintf("loading: %s", filename))
  load(filename)
  print('Generating mu, rt plots')
  out <- rstan::extract(fit)
  mu <- as.matrix(out$mu)
  colnames(mu) <- countries
  g <- mcmc_intervals(mu, prob=0.9)
  ggsave(sprintf("figures/%s-mu.png", modelname), g, width=4, height=6)
  tmp <- lapply(1:length(countries), function(i) (out$Rt_adj[, stan_data$N[i], i]))
  Rt_adj <- do.call(cbind, tmp)
  colnames(Rt_adj) <- countries
  g <- mcmc_intervals(Rt_adj, prob=0.9)
  ggsave(sprintf("figures/%s-final-rt.png", modelname), g, width=4, height=6)

  print("Generating rhat plot")
  g <- mcmc_rhat_hist(rhat(fit))
  ggsave(sprintf("figures/%s-rhat.png", modelname), g, width=4, height=6)
}

## export Stan's neg_binomial_2_lpmf function as negbim2
cat("Exporting Stan's neg_binomial_2_lpmf\n")
rstan::expose_stan_functions(rstan::stanc(model_code='
functions {
  real negbim2(int[] n, real[] mu, real phi) {
    return neg_binomial_2_lpmf(n | mu, phi);
  }
}
model{}
'))

dic <- function(fit, stan_data) {

  ## total likelihood
  lik <- rowSums(rstan::extract(fit, "log_lik")[[1]])

  ## mean deviance
  d1 <- -2 * mean(lik)

  ## deviance of the mean
  d2 <- 0
  for (m in 1:stan_data$M) {
    per <- stan_data$EpidemicStart[m]:stan_data$N[m]
    deaths.ob <- stan_data$deaths[per, m]
    deaths.pr <- rstan::extract(fit, "E_deaths")[[1]][, per, m]
    phi <- rstan::extract(fit, "phi")[[1]]
    d2 <- d2 + negbim2(deaths.ob, colMeans(deaths.pr), mean(phi))
  }
  d2 <- -2 * d2

  return(round(c(pD=d1 - d2, pV=mean(var(-2 * lik)) / 2, dic=2 * d1 - d2, deviance=d1), 1))
}

waic <- function(fit) {
  loo::waic(rstan::extract(fit, "log_lik")[[1]])
}

## collect summary measures of fit
fit.summary <- function(fit, processed_data, stan_data, forecast) {
  dic.model <- dic(fit, stan_data)
  hit.model <- hit(fit)
  waic.model <- waic(fit)
  loo.model <- loo(fit)
  mm <- get.deaths.mse(fit, processed_data, forecast)
  mm.sums <- colSums(mm)
  data.frame(
    Deviance=dic.model["deviance"],
    pD=dic.model["pD"],
    DIC=dic.model["dic"],
    R0=round(mean(hit.model$R0), 2),
    alpha=gsub("Inf", "\U221E", round(mean(hit.model$alpha), 2)),
    H=round(mean(hit.model$hit), 2),
    Infections=mm.sums["infections"],
    UK.Infections=mm["United_Kingdom", "infections"],
    Deaths=mm.sums["deaths"],
    Counterfactual=mm.sums["counterfactual"],
    row.names=deparse(substitute(fit)), stringsAsFactors=FALSE)
}

## collect statistics on the sampler behaviour
sampler.stats <- function(fit) {
    sp <- rstan::get_sampler_params(fit, inc_warmup=FALSE)
    accept.stat <- sapply(sp, function(x) mean(x[, "accept_stat__"]))
    stepsize <- sapply(sp, function(x) mean(x[, "stepsize__"]))
    divergences <- sapply(sp, function(x) sum(x[, "divergent__"]))
    treedepth <- sapply(sp, function(x) max(x[, "treedepth__"]))
    gradients <- sapply(sp, function(z) sum(z[, "n_leapfrog__"]))
    et <- round(rstan::get_elapsed_time(fit), 2)
    res <- cbind(accept.stat, stepsize, divergences, treedepth, gradients, et)
    avg <- colMeans(res)
    tot <- colSums(res)
    round(rbind(res, all=c(avg[1:2], tot[3], max(res[, 4]), tot[5:7])), 4)
}


## https://israeldi.github.io/bookdown/_book/monte-carlo-simulation-of-stock-portfolio-in-r-matlab-and-python.html

##-----------------------------------------------------------------------------
## setup
os <- .Platform$OS.type
if (os == 'windows') {
    ## load generic modules
    source("F:\\Documents\\01_Dave's Stuff\\Programs\\GitHub_home\\R-setup\\setup.r")
    ## identify working folder
    path <- c("f:/Documents/01_Dave's Stuff/Programs/GitHub_home/Retirement/")
} else {
    ## os == unix
    source('~/GitHub_repos/R-setup/setup.r')
    path <- c('~/GitHub_repos/Retirement/')
}
## set working folder
setwd(path)
## load local modules
r_files <- list.files(paste(path, 'modules/', sep=''), pattern="*.[rR]$", full.names=TRUE)
for (f in r_files) {
    ## cat("f =",f,"\n")
    source(f)
}

is.date <- function(x) inherits(x, 'Date')

##-----------------------------------------------------------------------------
## SET PARAMETERS FOR MONTE CARLO SIMULATIONS
## Set number of Monte Carlo Simulations
mc_rep    <- 10
period    <- 'years'
## Set simulation start and approximate end dates
sim_start <- as.Date(format(Sys.Date(), "%Y-%m-01"))
sim_end   <- as.Date('2030-11-30')    # must be a day in the period

##-----------------------------------------------------------------------------
## Define starting value and weights for each asset and total value
## create matrix of values for each account
value0 <- cbind(invest = 100000,
                ira    = 200000,
                roth   = 300000)
nacct  <- ncol(value0)
tvalue0 <- sum(value0)
weights <- c(value0[[1]]/tvalue0,
             value0[[2]]/tvalue0,
             value0[[3]]/tvalue0)
print(weights)

## Define asset allocation for each account
allocation <- '
account US_L US_S Inter Fixed Cash
invest    50   10     0    30   10
ira       40   30     5    20    5
roth      50   30    10    10    0
'
allocation <- readall(allocation)
rownames(allocation) <- allocation$account
allocation$account   <- NULL
allocation <- as.matrix(allocation / 100)
print(allocation)

##-----------------------------------------------------------------------------
## OBTAIN BENCHMARK HISTORICAL DATA
## category       ETF  description
## -------------  ---  ---------------
## USL            SPY  S&P 500
## USS            IWM  Russell 2000
## International  EFA  MSCI EAFE (TRN)
## Fixed          AGG  Bloomberg US Aggregate Bond
## Cash           SHV FTSE 3-month treasury bill

## periods per year
if (period == 'years') {
    nperiod <- 1
} else if (period == 'months') {
    nperiod <- 12
} else if (period == 'weeks') {
    nperiod <- 52
} else {
    ## days
    ## number of periods will change a bit each year
    ## 365.25 (days on average per year) * 5/7 (proportion work days per week)
    ## - 6 (weekday holidays) - 3*5/7 (fixed date holidays) = 252.75 ≈ 253
    nperiod <- 253
}

out <- equityget(c('SPY', 'IWM', 'EFA', 'AGG', 'SHV'), from='1995-01-01',
                 period=period)
benchclose  <- out$close
benchtwr    <- out$twr
colnames(benchclose) <- c('US_L', 'US_S', 'Inter', 'Fixed', 'Cash')
colnames(benchtwr)  <- c('US_L', 'US_S', 'Inter', 'Fixed', 'Cash')
## plot closing prices and TWR
plotspace(1,2)
plotxts(benchclose)
## plotzoo(benchclose)
plotxts(benchtwr)

## only keep twr for dates where all are defined
benchtwr <- na.omit(benchtwr)

##-----------------------------------------------------------------------------
## DATA FOR EACH ASSET

## Determine mean for each asset and covariance matrix
return <- '
    Date    invest    ira   roth
1/31/17       0.01   0.02   0.03
2/28/17       0.02   0.03   0.05
3/31/17       0.05   0.04   0.30
4/30/17       0.03   0.05   0.02
5/31/17       0.05   0.04   0.02
6/30/17       0.07   0.08   0.01
7/31/17       0.08   0.07   -0.02
8/31/17       0.05   0.07   0.02
9/30/17       0.08   0.10   0.03
10/31/17      0.09   0.10   0.05
11/30/17      0.10   0.09   0.02
12/31/17      0.10   0.09   0.03
1/31/17       0.06   0.08   0.05
2/28/17       0.03   0.04   0.06
3/31/17       0.01   0.05   0.06
'

## set monthly changes to account
monthly_spending <- c( 1000,
                       0,
                       0)
monthly_saving   <- c( 500,
                       0,
                       0)
monthly_change <-  monthly_saving - monthly_spending

## calculate changes per period
period_change  <- monthly_change * 12 / nperiod

## set specific date spending and saving (specify at end of a period)
saving <- '
    Date    invest    ira    roth
2/28/22          0   2000       0
3/30/22          0      0     500
4/30/22          0   1000    1000
'
saving <- readall(saving)

spending <- '
    Date    invest    ira   roth
1/31/22     1000        0      0
4/30/22        0      500      0
'
spending <- readall(spending)

## convert to XTS
## note the format used below must match that in the dataframe being read
saving   <- xts::as.xts(zoo::read.zoo(saving,   index.column = 1, format = "%m/%d/%y" ))
spending <- xts::as.xts(zoo::read.zoo(spending, index.column = 1, format = "%m/%d/%y" ))

##-----------------------------------------------------------------------------
## determine number of timesteps and create date sequence
if (period == 'years') {
    ntimestep <- as.numeric(format(sim_end, "%Y")) - as.numeric(format(sim_start,"%Y"))
    ## Create sequence of dates at ends of periods for simulation
    ## (+1 on ntimestep is so start with initial value)
    Date      <- seq(as.Date(sim_start), length=ntimestep+1, by=period) - 1
} else if (period == 'months') {
    ntimestep <- lubridate::interval(sim_start, sim_end) %/% months(1) + 1
    Date      <- seq(as.Date(sim_start), length=ntimestep+1, by=period) - 1
} else if (period == 'weeks') {
    ntimestep <- ceiling( (sim_end - sim_start) / 7 )  # rounds up
    Date      <- seq(as.Date(sim_start), length=ntimestep+1, by=period) - 1
} else {
    ## period = 'days'
    ## install.packages('bizdays')
    holidays <- timeDate::holidayNYSE(year = c(2021:2051))
    bizdays::create.calendar("USA", holiday =holidays, weekdays=c("saturday", "sunday"))
    Date <- bizdays::bizseq(sim_start, sim_end, "USA")
}
## Number of timesteps for the simulation
ntimestep = length(Date) - 1   # minus 1 because Date constains time zero

## split off 1st date since mc will only iterate on future dates
date0    <- Date[1]
datesim  <- Date[2:length(Date)]

##-----------------------------------------------------------------------------
## READ IN DATA FOR EACH ASSET

## ##----------------------
## ## OLD
## return_in   <- as_tibble(readall(return))
##
## ## convert date field to date format
## return_in$Date   <- as.Date(return_in$Date, "%m/%d/%y")
##
## ## convert return columns as matrix for efficiency later
## returnm <- as.matrix(return_in[2:ncol(return_in)])
##
## use above plus following to get old results
## benchtwr <- returnm
## ## OLD
## ##----------------------

## number of benchmarks used
nbench  <- ncol(benchtwr)

## calculate mean return for each benchmark asset
means <- colMeans(benchtwr)

## Get the Variance Covariance Matrix of benchmark returns
## pairsdf(as.matrix(benchtwr))
covarm <- cov(benchtwr)
print(covarm)

## Lower Triangular Matrix from Choleski Factorization, L where L * t(L) = covarm
## check with as.matrix(L) %*% as.matrix(t(L)) = covarm
## needed for R_i = mean_i + L_ij * Z_ji
L = t( chol(covarm) )
print(L)

dlh need to rethink save_expand and spend_expand
currently, there is no entry for the 0th year,
but I say additions and subtractions are at the end of every year

## create xts object with row for each datesim and column for each account
accounts     <- names(spending)
zeros        <- xts::xts(matrix(0, length(datesim), length(accounts)),
                         datesim, dimnames=list(NULL, accounts))
save_expand  <- zeros
spend_expand <- zeros

## add user specified entries to saving
for (i in 1:nrow(saving)) {
    irow <- birk::which.closest(datesim, zoo::index(saving[i]))
    save_expand[irow,] <- saving[i,]
}

## add usser speified spending entries
for (i in 1:nrow(spending)) {
    irow <- birk::which.closest(datesim, zoo::index(spending[i]))
    spend_expand[irow,] <- spending[i,]
}

## create single xts object with the total amount added and removed
inout <- save_expand - spend_expand

## add every period additions and subtractions
for (i in 1:nacct) {
  inout[,i] <- inout[,i] + period_change[i]
}

##-----------------------------------------------------------------------------
## START MONTE CARLO SIMULATION

## initialize variables
## twr and totalvalue matrices
## row for each timestep
## column for each mc sim
twr        <- matrix(0, ntimestep, mc_rep)
totalvalue <- twr
## same as above for value but with 2nd dimension for each account
value      <- array(0, dim=c(ntimestep, nacct, mc_rep))

## Extend means vector to a matrix
## one row for each benchmark repeated in columns for each timestep
meansm <- matrix(rep(means, ntimestep), nrow = nbench)

## set seed if want to repeat exactly
set.seed(200)
for (i in 1:mc_rep) {
    ## do following for each monte carlo simulation

    cat('simulation', i, '\n')

    ## start with initial values for each account
    valueold   <- value0

    ## obtain random z values for each account (rows) for each date increment (columns)
    Z <- matrix( rnorm( nbench * ntimestep ), ncol = ntimestep)

    ## simulate returns for each increment forward in time (assumed same as whatever data was)
    sim_benchtwr <- meansm + L %*% Z
    ## to view as a dataframe
    ## dfsim <- as_tibble(as.data.frame(t(sim_benchtwr)))

    ## Calculate vector of portfolio returns
    twr_i <- cumprod( weights %*% allocation %*% sim_benchtwr + 1 ) -1 # ntimestep entries

    ## Add it to the monte-carlo matrix
    twr[,i] <- twr_i;

    ## figure out account values and new weights
    for (j in 1:ntimestep) {
        ## for each time increment
        ## if (j == ntimestep-1) browser()
        cat('simulation', i, '; timestep', j, '\n')

        ## growth due to market
        sb     <- sim_benchtwr[,j]   # vector of bencmark returns for time j
        growth <- t( allocation %*% sb ) * valueold

        ## add or remove funds at end of each period
        in_out <- inout[j,]

        ## value for simulation i
        value[j,,i] <- as.numeric(valueold + growth + in_out)
        ## value for each account
        valueold     <- value[j,,i]
        ## total value for all accounts combined
        totalvalue[j,i] <- sum(valueold)

        ## recalculate weights after adjustments
        weights <- as.numeric(valueold / sum(valueold))
    }
}

##-----------------------------------------------------------------------------
## GATHER RESULTS

## put twr results into dataframe
twr <- as.data.frame(twr)
## add row for starting value
ones <- rep(0, ncol(twr))
twr <- rbind(ones, twr)
## ## add date
## twr <- as_tibble(cbind(Date=Date, twr))

## put total value results into dataframe
totalvalue <- as.data.frame(totalvalue)
totalvalue <- rbind(sum(value0), totalvalue)
## totalvalue <- as_tibble(cbind(Date=Date, totalvalue))

## value is size ntimestep x nbench x mc_rep
## e.g., value[1,,2] returns 1st timestep results for all account values for mc_rep=2
##       value[,,1]  returns all timestep results for all account values for mc_rep=1
##       value[,1,]  returns all timestep results for 1st account for all mc_reps

##-----------------------------------------------------------------------------
## DISPLAY RESULTS

## plot results
plotspace(2,1)

## PLOT TWR
## --------
## first establish plot area
ylim <- range(twr)
plot(Date, twr$V1, type='n',
     ylab='Simulation Returns',
     ylim=ylim)
for (i in 2:ncol(twr)) {
    lines(Date, t(twr[i]), type='l')
}

## Construct Confidential Intervals for returns
## first define function
ci <- function(df, conf) {
    ## calculate confidence limit for specified confidence level
    ## note specified conf = 1 - alpha
    ## i.e., if want alpha=0.05 to get 95% conf limit, specify 0.95
    apply(df, 1, function(x) quantile(x, conf))
}
## create dataframe of confidence intervals
df <- twr
cis <- as_tibble( data.frame(Date,
                             conf_99.9_upper_percent = ci(df, 0.999),
                             conf_99.0_upper_percent = ci(df, 0.99),
                             conf_95.0_upper_percent = ci(df, 0.95),
                             conf_50.0_percent       = ci(df, 0.5),
                             conf_95.0_lower_percent = ci(df, 0.05),
                             conf_99.0_lower_percent = ci(df, 0.01),
                             conf_99.9_lower_percent = ci(df, 0.001)) )

## plot confidence intervals on simulation
lines(cis$Date, cis$conf_99.9_upper_percent, lwd=4, lty=2, col='red')
lines(cis$Date, cis$conf_50.0_percent      , lwd=4,        col='red')
lines(cis$Date, cis$conf_99.9_lower_percent, lwd=4, lty=2, col='red')
legend('topleft',
       legend=c('simulation', 'upper 99.99', 'mean', 'lower 99.99'),
       col=c('black', 'red', 'red', 'red'),
       lty=c(1,2,1,2))

## PLOT VALUE
## ----------
## first establish plot area
ylim <- range(totalvalue)
plot(Date, totalvalue$V1, type='n',
     ylab='Simulation Value',
     ylim=ylim)
for (i in 2:ncol(totalvalue)) {
    lines(Date, t(totalvalue[i]), type='l')
}

## Construct Confidential Intervals for returns
## first define function
ci <- function(df, conf) {
    ## calculate confidence limit for specified confidence level
    ## note specified conf = 1 - alpha
    ## i.e., if want alpha=0.05 to get 95% conf limit, specify 0.95
    apply(df, 1, function(x) quantile(x, conf))
}
## create dataframe of confidence intervals
df <- totalvalue
cis <- as_tibble( data.frame(Date,
                             conf_99.9_upper_percent = ci(df, 0.999),
                             conf_99.0_upper_percent = ci(df, 0.99),
                             conf_95.0_upper_percent = ci(df, 0.95),
                             conf_90.0_upper_percent = ci(df, 0.90),
                             conf_50.0_percent       = ci(df, 0.50),
                             conf_90.0_lower_percent = ci(df, 0.10),
                             conf_95.0_lower_percent = ci(df, 0.05),
                             conf_99.0_lower_percent = ci(df, 0.01),
                             conf_99.9_lower_percent = ci(df, 0.001)) )

## plot confidence intervals on simulation
lines(cis$Date, cis$conf_99.9_upper_percent, lwd=4, lty=2, col='red')
lines(cis$Date, cis$conf_50.0_percent      , lwd=4,        col='red')
lines(cis$Date, cis$conf_99.9_lower_percent, lwd=4, lty=2, col='red')
legend('topleft',
       legend=c('simulation', 'upper 99.99', 'mean', 'lower 99.99'),
       col=c('black', 'red', 'red', 'red'),
       lty=c(1,2,1,2))

##-----------------------------------------------------------------------------
## final results at end of simulation
## Porfolio Returns statistics at end of simulation
cum_final <- as.numeric( twr[nrow(twr),] )
cum_final_stats <- data.frame(mean   = mean(cum_final),
                              median = median(cum_final),
                              sd     = sd(cum_final))
print(cum_final_stats)

final <- cbind(save_expand, spend_expand[2:ncol(spend_expand)],
               ci(twr, 0.001), ci(totalvalue, 0.001))
cat('                   Saving            Spending      TWR (99.9% LB CI)   Value (99.9% LB CI)\n',
    '             ------------------ ------------------ ------------------  -------------------\n')
print(final)
ci(twr, 0.999)

## ## create dataframe of mean and upper/lower ci for each account
## value <- data.frame(matrix(0,    # Create data frame of zeros
##                            nrow = length(datesim),
##                            ncol = mc_rep))
## for (i in 1:nbench) {
##     cat('account', i, '\n')
##     value <- value[,i,]
## }


sd_section("Starting Points",
           "Introductory material",
           c("ggtern_package",
             "ggtern",
             "ggplot"))

sd_section("Ternary Coordinates",
           "Definitions for the ternary coordinate system.",
           c("coord_tern")
)

sd_section("Ternary Scales",
           "Definitions for the ternary axes.",
           c("scale_X_continuous",
             'tern_limits')
)

sd_section("Approved Layers",
           "Information on the layers which are available and approve for use.",
           c("approved_layers")
)

sd_section("Geoms",
          paste(c("Geoms, short for geometric objects, describe the type of plot you will produce.",
                  "Several of the geoms are accompanied by dedicated stats."), collapse=" "),
          c("geom_crosshair_tern",
            "geom_confidence_tern",
            "geom_density_tern",
            "geom_interpolate_tern",
            "geom_Xline",
            "geom_Xisoprop",
            "geom_errorbarX",
            "geom_smooth_tern",
            "geom_point_swap",
            "geom_mask",
            "geom_label_viewport",
            "geom_text_viewport",
            "geom_mean_ellipse",
            "geom_hex_tern",
            "geom_tri_tern",
            "geom_polygon_closed"
          )
)

sd_section("Annotation",
           "Specialised functions for adding annotations to a plot.",
           c("annotate",
             "annotation_raster_tern")
)

sd_section("Positional Adjustments",
           "Position adjustments can be used to fine tune positioning of objects to achieve effects like dodging, jittering and stacking.",
           c("position_nudge_tern",
             "position_jitter_tern")
)

sd_section("Calculations",
           "Various calculation routines.",
           c("ternary_transformation",
             "mahalanobis_distance")
)

sd_section("Theme Elements",
           "New theme elements, unique to ggtern.",
           c("theme",
             "theme_elements")
)

sd_section("Themes",
           "Complete themes available for use.",
           c("theme_complete",
             "ggtern_themes")
)

sd_section("Convenience Functions",
           "Functions for the rapid customization of plot appearance.",
           c("theme_convenience_functions",
             "theme_arrowlength",
             "theme_gridsontop",
             "theme_bordersontop",
             "theme_clockwise",
             "theme_legend_position",
             "theme_noarrows",
             "theme_nomask",
             "theme_novar_tern",
             "theme_rotate",
             "theme_showgrid",
             "theme_showlabels",
             "theme_showprimary",
             "theme_showtitles",
             "theme_ticksoutside",
             "theme_ticklength",
             "theme_mesh",
             "theme_latex",
             "theme_zoom_X"
             )
)

sd_section("Labels",
           "Ternary-specific Labels.",
           c("ggtern_labels",
             "ggtern_labels_arrow_suffix",
             "label_formatter",
             "breaks_tern",
             'labels_tern')
)

sd_section("Data",
           "The following datasets have been included in the present package.",
           c("data_Feldspar",
             "data_Fragments",
             "data_USDA",
             "data_WhiteCells",
             "data_SkyeLava")
)

sd_section("Legend Keys",
           "Functions related to the renderin of legend keys.",
           c('draw_key_tern'))

sd_section("Arrangement & Saving",
           "The following funcions are useful for saving and printing.",
           c("arrangeGrob",
             "ggsave"))


#set working directory
setwd("C:\\Users\\Eva\\Google Drive\\Admissions\\NYU\\Admitted\\Courses\\DSGA 3001_9 Responsible DS\\Project\\nutritional-label-for-loan-recommendation-system\\data\\raw")

data <- read.csv("cs-training.csv", header=T)
colnames (data)

##############
# create validation
##############
#
train <- sample(nrow(data), floor(nrow(data) * 0.66))
training <- data[train, ]
validation <- data[-train, ]
remove (train)   # remove data to free up space

# install.packages("DMwR")

#######################
# SMOTE
#######################
# Literature: http://cran.r-project.org/web/packages/DMwR/DMwR.pdf

require(DMwR)
# must set ydata as factor and has to be placed at the end!!!!!!!!
data$ydata <- as.factor(data$ydata)
data <- SMOTE(ydata ~ ., data
                ,k = 5
                ,perc.over = 700,perc.under=200)
table(data$ydata)

####################################################
#modelling procedure
####################################################

################
#GBM
################
require(gbm)

model <- gbm(
  ydata ~ .,
  distribution = "adaboost",
  data = data,
  #var.monotone = NULL,
  n.trees = 5000,
  interaction.depth = 4,
  n.minobsinnode = 30,
  shrinkage = 0.05,
  bag.fraction = 0.2,
  train.fraction = 0.8,
  #cv.folds=5,
  #keep.data = TRUE,
  verbose = TRUE)

predict <- predict.gbm (model, test, n.trees = 5000, type = "response")

################
# Random Forest
################
require(randomForest)
data$ydata <- as.factor(data$ydata)

model <- randomForest (ydata ~ ., data, ntree = 250, nodesize = 100)
predict <- predict (model, test, type = "prob")

################
#caret
################
#http://cran.r-project.org/web/packages/caret/caret.pdf
require(caret)
require(MASS)

data$ydata <- as.factor(data$ydata)
model <- train (ydata ~ ., data, method = "xxx")
# replace xxx with a function found in caret

predict <- predict (model, test)

#################
# write output
#################

write.csv(predict, file = "predict.csv", quote = FALSE, row.names = FALSE)


library("readxl")
library("here")
library("dplyr")
library("janitor")
library("tidyr")
library("ggplot2")
library("scales")
library("binom")
library("lubridate")
library("rvest")
library("ggrepel")
library("viridis")
library("purrr")
library("sf")

url <- paste0("https://www.gov.uk/government/collections/",
              "nhs-test-and-trace-statistics-england-weekly-reports")
session <- session(url)

weekly_url <- session %>%
  html_nodes(xpath = "//div/ul/li/a") %>%
  html_attr("href") %>%
  grep("weekly-statistics", ., value = TRUE) %>%
  pluck(1)

latest <- session %>%
  session_jump_to(weekly_url)

url <- latest %>%
  html_nodes(xpath = "//div/h3/a") %>%
  html_attr("href") %>%
  grep(pattern = "tests.reported", value = TRUE, ignore.case = TRUE)

filename <- sub("^.*/([^/]+)$", "\\1", url)

dir <- tempdir()
download.file(url, file.path(dir, filename))

ltlas <- read_excel(file.path(dir, filename), sheet = "Table_4")
header_row <- which(ltlas[, 1] == "LTLA")

ltlas <- ltlas %>%
  row_to_names(header_row) %>%
  as_tibble() %>%
  clean_names() %>%
  select(-total) %>%
  mutate(test_result = sub("Total number of (positive|negative) LFD tests",
                           "\\1", test_result)) %>%
  filter(grepl("(positive|negative)", test_result)) %>%
  pivot_longer(names_to = "date", starts_with("x")) %>%
  mutate(value = as.integer(value)) %>%
  filter(!is.na(value)) %>%
  mutate(date = as.Date(sub("^.+([0-9]{2})_([0-9]{2})_([0-9]{2})$",
                            "20\\3-\\2-\\1", date))) %>%
  pivot_wider(names_from = "test_result") %>%
  mutate(total = positive + negative) %>%
  filter(!is.na(total))

uncert <- binom.confint(ltlas$positive, ltlas$total, method = "exact") %>%
  select(mean, lower, upper)

df <- ltlas %>%
  bind_cols(uncert) %>%
  filter(date != "2020-12-24", date >= "2021-02-01")

wr_latest <- df %>%
  mutate(rel_error = (abs(lower - mean) + abs(upper - mean)) / (2 * mean)) %>%
  select(date, ltla, estimate = mean, rel_error)

wr_previous <- wr_latest %>%
  mutate(date = date + 7)

wr <- wr_latest %>%
  inner_join(wr_previous, by = c("date", "ltla"),
             suffix = c("", "_previous")) %>%
  mutate(ratio = estimate / estimate_previous,
         rel_error = rel_error + rel_error_previous,
         lower_ratio = pmax(0, ratio - rel_error * ratio),
         upper_ratio = ratio + rel_error * ratio) %>%
  select(date, ltla, ends_with("ratio"))

inc_r <- df %>%
  inner_join(wr, by = c("ltla", "date")) %>%
  mutate(label = if_else(ltla_name %in% c("Bolton", "Blackburn with Darwen",
                                          "Liverpool", "Tower Hamlets"),
                         ltla_name, NA_character_))

latest <- inc_r %>%
  filter(date > max(date) - 7) %>%
  mutate(label = if_else(ratio > 2 | mean > 0.01,
                         ltla_name, NA_character_))

p <- ggplot(latest, aes(y = mean, x = ratio, colour = region_name)) +
  geom_point() +
  geom_errorbarh(alpha = 0.15, aes(xmin = lower_ratio, xmax = upper_ratio)) +
  geom_errorbar(alpha = 0.15, aes(ymin = lower, ymax = upper)) +
  geom_text_repel(aes(label = label), show.legend = FALSE) +
  scale_y_continuous("LFD positive prevalence", labels = scales::percent_format(.5)) +
  xlab("Weekly relative growth") +
  theme_bw() +
  coord_cartesian(xlim = c(0, ceiling(max(latest$ratio)) + 1)) +
  geom_vline(xintercept = 1, linetype = "dashed") +
  scale_color_brewer("Region", palette = "Paired")

suppressWarnings(dir.create(here::here("figure")))
ggsave(here::here("figure", "lfd_prev_growth.svg"), p, width = 11, height = 7)

labels <- inc_r %>%
  filter(date == max(date)) %>%
  arrange(desc(mean)) %>%
  head(n = 20) %>%
  mutate(date = date + 2)

last_10_weeks <- inc_r %>%
  filter(date > max(date) - weeks(10)) %>%
  mutate(label = if_else(ltla %in% labels$ltla & date == max(date),
                         ltla_name, NA_character_))

p <- ggplot(last_10_weeks, aes(x = date, y = mean,
                               colour = region_name,
                               group = ltla)) +
  geom_point() +
  geom_line(alpha = 0.2) +
  scale_colour_brewer("", palette = "Set1") +
  theme_bw() +
  xlab("") +
  expand_limits(x = max(last_10_weeks$date + 7), y = 0) +
  scale_y_continuous("LFD prevalence", labels = scales::label_percent()) +
  theme(legend.position = "bottom") +
  geom_text_repel(aes(label = label), show.legend = FALSE)

ggsave(here::here("figure", "lfd_last_10_weeks.svg"), p, width = 10, height = 6)

p <- ggplot(last_10_weeks, aes(x = date, y = mean,
                               colour = region_name,
                               group = ltla)) +
  geom_point() +
  geom_line(colour = "black", alpha = 0.2) +
  scale_colour_brewer("", palette = "Set1") +
  theme_bw() +
  xlab("") +
  expand_limits(x = max(last_10_weeks$date + 7), y = 0) +
  scale_y_continuous("LFD prevalence", labels = scales::label_percent()) +
  theme(legend.position = "bottom") +
  geom_text_repel(aes(label = label), show.legend = FALSE) +
  facet_wrap(~ region_name)

ggsave(here::here("figure", "lfd_last_10_weeks_regions.svg"), p, width = 12, height = 10)

england_ltla_shape <- st_read(here::here("data", "Local_Authority_Districts_(December_2021)_UK_BUC")) %>%
  rename(geo_code = LAD21CD) %>%
  filter(grepl("^E", geo_code))

all_ltlas_dates <-
  expand_grid(ltla = unique(england_ltla_shape$geo_code),
              date = unique(last_10_weeks$date))

last_10_weeks_all <- last_10_weeks %>%
  right_join(all_ltlas_dates, by = c("ltla", "date")) %>%
  replace_na(list(mean = 0))

map <- england_ltla_shape %>%
  inner_join(last_10_weeks_all %>%
            rename(geo_code = ltla), by = "geo_code")

p <- ggplot(map, aes(x = LAT, y = LONG, fill = mean)) +
  geom_sf(colour = NA) +
  theme_void() +
  theme(panel.background = element_rect(fill = "white", colour = "white"),
	plot.background = element_rect(fill = "white", colour = "white")) +
  scale_fill_viridis("LFD prevalence", labels = scales::label_percent()) +
  facet_wrap( ~ date, nrow = 1)

ggsave(here::here("figure", "lfd_last_10_weeks_maps.svg"), p, width = 12, height = 4)

p_testing <- ggplot(df, aes(x = date, y = mean,
                        ymin = lower, ymax = upper)) +
  geom_point() +
  geom_line() +
  geom_ribbon(alpha = 0.35) +
  scale_colour_brewer("", palette = "Dark2") +
  scale_fill_brewer("", palette = "Dark2") +
  theme_bw() +
  expand_limits(y = 0) +
  scale_y_continuous("Proportion positive", labels = scales::percent) +
  facet_wrap(~ltla_name) +
  xlab("Final Wednesday of week of data")

ggsave(here::here("figure", "lfd_ltla.svg"), p_testing, width = 25, height = 25)


## Analysis of Full Foodwebs in different nutrient landscapes
library(plyr)
library(ggplot2)
library(igraph)
library(raster)
library(matrixStats)
library("viridis")

require(doParallel)
######

cl<-makeCluster(16)    ##### WARNING! Number of cores may depend on your machine!
registerDoParallel(cl)

data.end<-foreach (i=c(1:15,30:44),.combine = "rbind") %dopar% {

  persistance<-data.frame(Scenario=numeric(0),Nutrient.factor=numeric(0),Nutrient=numeric(0),Web=numeric(0),Landscape=numeric(0),Patch=numeric(0), Species=numeric(0), Persist=numeric(0), Growth1=numeric(0),Growth2=numeric(0), Plant=numeric(0))

  local<-read.table("../../Simulations/FullWeb/SummaryMass.out", sep=",", header=T)

  subset.nutrient<-subset(local,local$nut==i)
Nutrients<- read.table(paste("../../Simulations/FullWeb/Nutrients/Nutrient_", i, ".out",sep=""),header=F)

  for (w in 1)
  {
    subset.web<-subset(subset.nutrient,subset.nutrient$web==w)

    for (l in 1:5)
    {
      subset.landscape<-subset(subset.web,subset.web$landscape==l)

  for (p in 0:49)
  {
      subset.patch<- subset(subset.landscape, subset.landscape$patch==p)

  for (k in 0:39)
  {
    subset.sp<-subset(subset.patch,subset.patch$species==k)

    if (subset.sp$biomass.tend.10k==0 && subset.sp$biomass.tend.20k==0 && subset.sp$biomass.tend!=0)
    {
      persist<-NA
      mean.net.growth1<-NA
      mean.net.growth2<-NA

    } else {
      persist<-(sum(subset.sp$biomass.tend)>0)*1
      mean.net.growth1<-subset.sp$Mean.net.growth1
      mean.net.growth2<-subset.sp$Mean.net.growth2
    }
    if.basal<-subset.sp$if.basal.spp
    if (i<20)
    {scen<-"Homogenious"} else if (i<35 && i>16) {scen<-"HeterogeneousMeso"} else if (i<40 && i>34) {scen<-"HeterogeneousOligo"} else {scen<-"HeterogeniousEutro"}

    vec<-data.frame(Scenario=scen,Nutrient.factor=i,Nutrient=Nutrients[p+1,], Web=w,Landscape=l,Patch=p,Species=k,Persist=persist, Growth1=mean.net.growth1, Growth2=mean.net.growth2, Plant=if.basal)

    persistance<-rbind(persistance,vec)

    }
   }
  }
  }
return(persistance)
}
str(data.end)

persistance1<-data.end
write.table(persistance1,"data.out")
persistance1<-read.table("data.out")
persistence2<-read.table("../FullWeb/data.out")

for.plot<-ddply(persistance1,.(Scenario,Nutrient.factor,Nutrient,Web,Patch,Landscape, Plant), summarize, Persistance=sum(Persist))

plants<-subset(for.plot,for.plot$Plant==1)
animals<-subset(for.plot,for.plot$Plant==0)

pdf("FigPlantAnimal.pdf",width=12,height=8, onefile = T)
ggplot(plants, aes(x=log10(Nutrient),y=Persistance,color=Scenario))  + geom_point(size=0.2) + geom_smooth(size=0.5) + labs(x="Nutrient Supply log10[]",y=expression(bold(paste("Plant ",alpha,"-Diversity")))) +
  theme_classic() + theme(axis.text=element_text(size=22),text=element_text(size=22, face="bold"),
                          axis.title=element_text(size=22,face="bold"))
ggplot(animals, aes(x=log10(Nutrient),y=Persistance,color=Scenario))   + geom_point(size=0.2) + geom_smooth(size=0.5) + labs(x="Nutrient Supply log10[]",y=expression(bold(paste("Animal ",alpha,"-Diversity")))) +
  theme_classic() + theme(axis.text=element_text(size=22),text=element_text(size=22, face="bold"),
                          axis.title=element_text(size=22,face="bold"))

dev.off()
for.plot1<-ddply(persistance1,.(Scenario,Nutrient.factor,Nutrient,Web,Patch,Landscape), summarize, Persistance=sum(Persist))

pdf("Fig4.pdf",width=12,height=8)
ggplot(for.plot1, aes(x=log10(Nutrient),y=Persistance,color=Scenario))  + geom_count(position = position_jitter(w = 0.05, h = 0),shape=1, alpha=1, stroke = 0.8) + geom_smooth(size=1) + labs(x="Local Nutrient Supply log10[]",y=expression(bold(paste(alpha,"-Diversity")))) +
  theme_classic() + theme(axis.text=element_text(size=22),text=element_text(size=22, face="bold"),
                         axis.title=element_text(size=22,face="bold"))

dev.off()

for.plot1.sub<-subset(for.plot1,for.plot1$Scenario!="Homogenious")
pdf("Fig4add.pdf", width=12, height=4, onefile = T)
ggplot(for.plot1, aes(y=log10(Nutrient),x=Scenario,color=Scenario)) + geom_violin( draw_quantiles = c(0.5), na.rm=T) + stat_summary(fun.y=mean, geom="point", shape=23, size=2) +coord_flip() + theme_classic() + theme(axis.text=element_text(size=22),text=element_text(size=22, face="bold"),
                                                                                axis.title=element_text(size=22,face="bold"))
ggplot(for.plot1, aes(y=log10(Nutrient),x=Scenario,color=Scenario)) + geom_violin( draw_quantiles = c(0.5), na.rm=T)  +coord_flip() + theme_classic()+ theme(axis.text=element_text(size=22),text=element_text(size=22, face="bold"),
                                                                                axis.title=element_text(size=22,face="bold"))

dev.off()

for.plot2<-ddply(persistance1,.(Scenario,Nutrient.factor,Nutrient,Web,Landscape), summarize, Persistance=mean(Persist))
ggplot(for.plot2, aes(x=as.factor(Nutrient.factor),y=Persistance,color=as.factor(Scenario))) + geom_violin(trim=T, draw_quantiles = c(0.05, 0.5, 0.95), na.rm=T, scale="width")+ ggtitle("Gamma Diversity")

######
data.end<-foreach (i=c(21:23),.combine = "rbind") %dopar% {

  persistance<-data.frame(Scenario=numeric(0),Nutrient.factor=numeric(0),Nutrient=numeric(0),Web=numeric(0),Landscape=numeric(0),Patch=numeric(0), Species=numeric(0), Persist=numeric(0), Growth1=numeric(0),Growth2=numeric(0), Plant=numeric(0))

  local<-read.table("../Simulations/FullWeb/SummaryMass.out", sep=",", header=T)

  subset.nutrient<-subset(local,local$nut==i)
  Nutrients<- read.table(paste("../Simulations/FullWeb/Nutrients/Nutrient_", i, ".out",sep=""),header=F)

  for (w in 1)
  {
    subset.web<-subset(subset.nutrient,subset.nutrient$web==w)

    for (l in 1:5)
    {
      subset.landscape<-subset(subset.web,subset.web$landscape==l)

      for (p in 0:49)
      {
        subset.patch<- subset(subset.landscape, subset.landscape$patch==p)

        for (k in 0:39)
        {
          subset.sp<-subset(subset.patch,subset.patch$species==k)

          if (subset.sp$biomass.tend.10k==0 && subset.sp$biomass.tend.20k==0 && subset.sp$biomass.tend!=0)
          {
            persist<-NA
            mean.net.growth1<-NA
            mean.net.growth2<-NA

          } else {
            persist<-(sum(subset.sp$biomass.tend)>0)*1
            mean.net.growth1<-subset.sp$Mean.net.growth1
            mean.net.growth2<-subset.sp$Mean.net.growth2
          }
          if.basal<-subset.sp$if.basal.spp
          if (i>16)
          {scen<-"Heterogenious"} else {scen<-"Homogenious"}

          vec<-data.frame(Scenario=scen,Nutrient.factor=i,Nutrient=Nutrients[p+1,], Web=w,Landscape=l,Patch=p,Species=k,Persist=persist, Growth1=mean.net.growth1, Growth2=mean.net.growth2, Plant=if.basal)

          persistance<-rbind(persistance,vec)

        }
      }
    }
  }
  return(persistance)
}

persistance2<-data.end

for.plot<-ddply(persistance2,.(Scenario,Nutrient.factor,Nutrient,Web,Patch,Landscape, Plant), summarize, Persistance=mean(Persist))

plants<-subset(for.plot,for.plot$Plant==1)
animals<-subset(for.plot,for.plot$Plant==0)
pdf("PlotsHeterogenious.pdf", onefile=T)
ggplot(plants, aes(x=log10(Nutrient),y=Persistance,color=as.factor(Nutrient.factor)))  + geom_point(size=0.2) + geom_smooth(size=0.5) + ggtitle("Plants")
ggplot(animals, aes(x=log10(Nutrient),y=Persistance,color=as.factor(Nutrient.factor)))  + geom_point(size=0.2) + geom_smooth(size=0.5) + ggtitle("Animals")

for.plot1<-ddply(persistance2,.(Scenario,Nutrient.factor,Nutrient,Web,Patch,Landscape), summarize, Persistance=mean(Persist))

ggplot(for.plot1, aes(x=log10(Nutrient),y=Persistance,color=as.factor(Nutrient.factor)))  + geom_point(size=0.2) + geom_smooth(size=0.5) + ggtitle("All Species")

for.plot2<-ddply(persistance2,.(Scenario,Nutrient.factor,Nutrient,Web,Landscape), summarize, Persistance=mean(Persist))
ggplot(for.plot2, aes(x=as.factor(Nutrient.factor),y=Persistance,color=as.factor(Nutrient.factor))) + geom_violin(trim=T, draw_quantiles = c(0.05, 0.5, 0.95), na.rm=T, scale="width") + ggtitle("Gamma Diversity")
dev.off()


x_files <- list.files(pattern="*txt")
sample_names <- substr(x_files, 1, nchar(x_files)-10)
sample_names <- paste(substr(sapply(strsplit(sample_names, "_"), "[[", 1), 1, 1), "_",
						sapply(strsplit(sample_names, "_"), "[[", 2), "_",
						sapply(strsplit(sample_names, "_"), "[[", 3), "_",
						sapply(strsplit(sample_names, "_"), "[[", 4), sep="")

coverage_max_to_check <- 60
plot_max <- coverage_max_to_check + 2

output1 <- list()
output2 <- list()
mean_coverage <- c()
for(a in 1:length(x_files)) {
  a_rep <- scan(x_files[a])
  a_output <- c()
  for(b in 1:plot_max) {
    if(b == plot_max) {
      a_output <- c(a_output, length(a_rep[a_rep >= (b - 1)]))
    } else {
      a_output <- c(a_output, length(a_rep[a_rep == (b - 1)]))
    }
  }
  a_output2 <- a_output / sum(a_output)
  output1[[a]] <- a_output
  output2[[a]] <- a_output2
  mean_coverage <- c(mean_coverage, mean(a_rep))
}

rm(a_rep)
save.image("setophaga_coverage.RData")

load("setophaga_coverage.RData")

par(mfrow=c(7,8))
for(a in 1:length(output2)) {
  plot(0:61, output2[[a]], pch=19, cex=0.1, xlab="Coverage", ylab="Proportion S.coronata genome", main=sample_names[a], ylim=c(0,0.3))
  poly.plot <- rbind(cbind(0:61, output2[[a]]), c(61, 0), c(0,0))
  polygon(poly.plot, col="gray")
  abline(v=mean_coverage[a], col="red")
}

mean_coverage_samples <- cbind(sample_names, mean_coverage)

write.table(mean_coverage_samples, "mean_coverage_samples.txt", sep = "\t")