# 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)


## 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,]
## }


# Calculate warming of the hottest hour
# Also calculate hottest future hours (add to climatology)

require(ncdf4)
require(abind)
require(raster)
require(data.table)

###################
## Read in data
###################

# read in TXx rcp26
infile <- nc_open('data_dl/cmip5/txx_yr_modmean_rcp26_ave.nc') # tasmax for each month
	# print(infile)
	tasmax26 <- ncvar_get(infile, 'txxETCCDI') # 144 x 72 x 240 lon x lat x years 1861-2100)
	dim(tasmax26)
	dimnames(tasmax26) <- list(lon=1:144, lat=1:72, time=1:240)
	dimnames(tasmax26)[[1]] <- infile$var[['txxETCCDI']]$dim[[1]]$vals # add lon
	dimnames(tasmax26)[[2]] <- infile$var[['txxETCCDI']]$dim[[2]]$vals # add lat
	dimnames(tasmax26)[[3]] <- 1861:2100 # year of the CMIP5 time dimension
	nc_close(infile)

# read in tos rcp26
infile <- nc_open('data_dl/cmip5/tos_Omon_modmean_rcp26_ave.nc') # tos for each month
	# print(infile)
	tos26 <- ncvar_get(infile, 'tos') # tos 288 x 144 x 2800 lon x lat x months 1861-2100
	dim(tos26)
	dimnames(tos26) <- list(lon=1:288, lat=1:144, time=1:2880)
	dimnames(tos26)[[1]] <- infile$var[['tos']]$dim[[1]]$vals # add lon
	dimnames(tos26)[[2]] <- infile$var[['tos']]$dim[[2]]$vals # add lat
	dimnames(tos26)[[3]] <- paste(rep(1861:2100, rep(12, length(1861:2100))), paste('_', 1:12, sep=''), sep='') # year and month of the CMIP5 time dimension
	nc_close(infile)

# read in TXx rcp85
infile <- nc_open('data_dl/cmip5/txx_yr_modmean_rcp85_ave.nc') # tasmax for each month
	# print(infile)
	tasmax85 <- ncvar_get(infile, 'txxETCCDI') # 144 x 72 x 240 lon x lat x years 1861-2100)
	dim(tasmax85)
	dimnames(tasmax85) <- list(lon=1:144, lat=1:72, time=1:240)
	dimnames(tasmax85)[[1]] <- infile$var[['txxETCCDI']]$dim[[1]]$vals # add lon
	dimnames(tasmax85)[[2]] <- infile$var[['txxETCCDI']]$dim[[2]]$vals # add lat
	dimnames(tasmax85)[[3]] <- 1861:2100 # year of the CMIP5 time dimension
	nc_close(infile)

# read in tos rcp85
infile <- nc_open('data_dl/cmip5/tos_Omon_modmean_rcp85_ave.nc') # tos for each month
	# print(infile)
	tos85 <- ncvar_get(infile, 'tos') # tos 288 x 144 x 2800 lon x lat x months 1861-2100
	dim(tos85)
	dimnames(tos85) <- list(lon=1:288, lat=1:144, time=1:2880)
	dimnames(tos85)[[1]] <- infile$var[['tos']]$dim[[1]]$vals # add lon
	dimnames(tos85)[[2]] <- infile$var[['tos']]$dim[[2]]$vals # add lat
	dimnames(tos85)[[3]] <- paste(rep(1861:2100, rep(12, length(1861:2100))), paste('_', 1:12, sep=''), sep='') # year and month of the CMIP5 time dimension
	nc_close(infile)

# read in DTR (daily temperature range)
load('temp/dtrclimatology_interp1.25.rdata') # dtr125

# read in max hr climatologies
load('temp/tosmax.rdata') # tosmax 0.25x0.25 from OISST daily + HadDTR
load('temp/hadex2_txx.rdata') # hadex2txx 2.5x3.75 from HadEX2
	tasmax <- hadex2txx

##################################################################################
# permute CMIP5 dimensions: lat x lon x time
# lat 90 to -90; lon 0 to 360
##################################################################################
# change dimension order
tasmax26 <- aperm(tasmax26, c(2,1,3))
tasmax85 <- aperm(tasmax85, c(2,1,3))
tos26 <- aperm(tos26, c(2,1,3))
tos85 <- aperm(tos85, c(2,1,3))

# rotate so columns 0 -> 360 lon, rows 90 -> -90 lat
	# tasmax26
lons <- as.numeric(colnames(tasmax26)) # good

lats <- as.numeric(rownames(tasmax26))
newlatord <- sort(lats, decreasing=TRUE)
newrownms <- as.character(newlatord)
newlatord <- as.character(newlatord)

tasmax26 <- tasmax26[newlatord, ,]

	#image(tasmax26[,,1]) # north pole should be at the left, America at the top

	# tasmax85
lons <- as.numeric(colnames(tasmax85)) # good

lats <- as.numeric(rownames(tasmax85))
newlatord <- sort(lats, decreasing=TRUE)
newrownms <- as.character(newlatord)
newlatord <- as.character(newlatord)

tasmax85 <- tasmax85[newlatord, ,]

	#image(tasmax85[,,1])

	# tos26
lons <- as.numeric(colnames(tos26)) # good

lats <- as.numeric(rownames(tos26))
newlatord <- sort(lats, decreasing=TRUE)
newrownms <- as.character(newlatord)
newlatord <- as.character(newlatord)

tos26 <- tos26[newlatord, ,]

	#image(tos26[,,1])

	# tos85
lons <- as.numeric(colnames(tos85)) # good

lats <- as.numeric(rownames(tos85))
newlatord <- sort(lats, decreasing=TRUE)
newrownms <- as.character(newlatord)
newlatord <- as.character(newlatord)

tos85 <- tos85[newlatord, ,]

	#image(tos85[,,1])

############################
# Compute tosmax26 and 86 (CMIP5 temperatures)
# Irrelevant since we compute a delta?
############################
# extend dtr125 so that it matches the dimensions of tos85
dtr125l <- abind(list(dtr125)[rep(1,dim(tos85)[3]/dim(dtr125)[3])], along=3)
	dim(dtr125l)
	dim(tos26)
	dim(tos85)

# add to get daily maximum
tosmax26 <- tos26 + 0.5*dtr125l
tosmax85 <- tos85 + 0.5*dtr125l

#############################################
# Calculate CMIP5 anomalies from 1986-2005
#############################################
climtime <- as.character(1986:2005) # year of the climatology period
futtime <- as.character(2006:2100) # year the future period

# Reshape CMIP5 to lat x lon x month x year
	# not needed for tasmax26 and tasmax85 since already annual TXx

	# tosmax26
nms <- dimnames(tosmax26)
mos <- as.numeric(unlist(strsplit(nms[[3]], split='_'))[seq(2,length(nms[[3]])*2,by=2)]) # months
yrs <- as.numeric(unlist(strsplit(nms[[3]], split='_'))[seq(1,length(nms[[3]])*2,by=2)]) # years
dm <- dim(tosmax26)
tosmax26bymo <- array(tosmax26, dim=c(dm[1], dm[2], 12, dm[3]/12), dimnames=list(lat=nms[[1]], lon=nms[[2]], mo=1:12, year=sort(unique(yrs)))) # add a month dimension (3rd dimension)

	# tosmax85
nms <- dimnames(tosmax85)
mos <- as.numeric(unlist(strsplit(nms[[3]], split='_'))[seq(2,length(nms[[3]])*2,by=2)]) # months
yrs <- as.numeric(unlist(strsplit(nms[[3]], split='_'))[seq(1,length(nms[[3]])*2,by=2)]) # years
dm <- dim(tosmax85)
tosmax85bymo <- array(tosmax85, dim=c(dm[1], dm[2], 12, dm[3]/12), dimnames=list(lat=nms[[1]], lon=nms[[2]], mo=1:12, year=sort(unique(yrs)))) # add a month dimension (3rd dimension)

# find highest daily max within years (TXx)
tasmax26yr <- tasmax26 # already annual TXx on land (HadEX2)
tasmax85yr <- tasmax85
tosmax26yr <- apply(tosmax26bymo, MARGIN=c(1,2,4), FUN=max)
tosmax85yr <- apply(tosmax85bymo, MARGIN=c(1,2,4), FUN=max)

# calculate climatology as the highest TXx across 20-year chunk
tasmax26clim <- apply(tasmax26yr[,,climtime], MARGIN=c(1,2), FUN=max) # climatological average for CMIP5
tasmax26climlong <- abind(list(tasmax26clim)[rep(1,length(futtime))], along=3) # expand to match future projections
	dim(tasmax26climlong)

tasmax85clim <- apply(tasmax85yr[,,climtime], MARGIN=c(1,2), FUN=max) # climatological average for CMIP5
tasmax85climlong <- abind(list(tasmax85clim)[rep(1,length(futtime))], along=3) # expand to match future projections
	dim(tasmax85climlong)

tosmax26clim <- apply(tosmax26yr[,,climtime], MARGIN=c(1,2), FUN=max)
tosmax26climlong <- abind(list(tosmax26clim)[rep(1,length(futtime))], along=3)
	dim(tosmax26climlong)

tosmax85clim <- apply(tosmax85yr[,,climtime], MARGIN=c(1,2), FUN=max)
tosmax85climlong <- abind(list(tosmax85clim)[rep(1,length(futtime))], along=3)
	dim(tosmax85climlong)

# calculate deltas by years
tasmax26dyr <- tasmax26yr[,,futtime] - tasmax26climlong # CMIP5 deltas
tasmax85dyr <- tasmax85yr[,,futtime] - tasmax85climlong # CMIP5 deltas
tosmax26dyr <- tosmax26yr[,,futtime] - tosmax26climlong
tosmax85dyr <- tosmax85yr[,,futtime] - tosmax85climlong

# write out for use in future_tsm_byyear.r
save(tasmax26dyr, file='temp/tasmax26dyr.rdata')
save(tasmax85dyr, file='temp/tasmax85dyr.rdata')
save(tosmax26dyr, file='temp/tosmax26dyr.rdata')
save(tosmax85dyr, file='temp/tosmax85dyr.rdata')

#######################################################
# average warming by latitude for 2081-2100 and write out
# for use in figure
#######################################################
# Make a "not ocean" mask
searast <- raster(!is.na(tos26[,,1]), xmn=0, xmx=360, ymn=-90, ymx=90) # 1 for ocean, 0 for land
landrast <- raster(tasmax26dyr[,,1], xmn=0, xmx=360, ymn=-90, ymx=90)
seamask <- round(resample(searast, landrast, method='bilinear')) # includes areas >=50% land as land (floor): 0 is land, 1 is ocean
seamask <- as.matrix(seamask)
seamask[seamask==1] <- NA # turn ocean to NA
seamask <- abind(list(seamask)[rep(1,dim(tasmax26dyr)[3])], along=3) # expand to match future projections

# mask out ocean for terrestrial air temp
tasmax26dyrmask <- tasmax26dyr + seamask
tasmax85dyrmask <- tasmax85dyr + seamask

# data.frame to hold results
lstwarmingbylat <- data.table(lat=as.numeric(dimnames(tasmax26dyr)[[1]]))
sstwarmingbylat <- data.table(lat=as.numeric(dimnames(tosmax26dyr)[[1]]))

# average by lat
lstwarmingbylat$tasmax26 <- apply(tasmax26dyrmask[,,as.character(2081:2100)], MARGIN=1, FUN=mean, na.rm=TRUE)
lstwarmingbylat$tasmax85 <- apply(tasmax85dyrmask[,,as.character(2081:2100)], MARGIN=1, FUN=mean, na.rm=TRUE)
sstwarmingbylat$tosmax26 <- apply(tosmax26dyr[,,as.character(2081:2100)], MARGIN=1, FUN=mean, na.rm=TRUE)
sstwarmingbylat$tosmax85 <- apply(tosmax85dyr[,,as.character(2081:2100)], MARGIN=1, FUN=mean, na.rm=TRUE)

	# plot to check
	lstwarmingbylat[,plot(lat, tasmax26, type='l', ylim=c(0,6))]
	lstwarmingbylat[,lines(lat, tasmax85, lty=2)]
	sstwarmingbylat[,lines(lat, tosmax26, col='blue')]
	sstwarmingbylat[,lines(lat, tosmax85, col='blue', lty=2)]

# SD by lat
lstwarmingbylat$tasmax26sd <- apply(tasmax26dyrmask[,,as.character(2081:2100)], MARGIN=1, FUN=sd, na.rm=TRUE)
lstwarmingbylat$tasmax85sd <- apply(tasmax85dyrmask[,,as.character(2081:2100)], MARGIN=1, FUN=sd, na.rm=TRUE)
sstwarmingbylat$tosmax26sd <- apply(tosmax26dyr[,,as.character(2081:2100)], MARGIN=1, FUN=sd, na.rm=TRUE)
sstwarmingbylat$tosmax85sd <- apply(tosmax85dyr[,,as.character(2081:2100)], MARGIN=1, FUN=sd, na.rm=TRUE)

# Sample size by lat
lstwarmingbylat$tasmax26n <- apply(tasmax26dyrmask[,,as.character(2081)], MARGIN=1, FUN=function(x) sum(!is.na(x)))
lstwarmingbylat$tasmax85n <- apply(tasmax85dyrmask[,,as.character(2081)], MARGIN=1, FUN=function(x) sum(!is.na(x)))
sstwarmingbylat$tosmax26n <- apply(tosmax26dyr[,,as.character(2081)], MARGIN=1, FUN=function(x) sum(!is.na(x)))
sstwarmingbylat$tosmax85n <- apply(tosmax85dyr[,,as.character(2081)], MARGIN=1, FUN=function(x) sum(!is.na(x)))

# write out
write.csv(lstwarmingbylat, file='temp/warmingmaxhr_bylat_land.csv')
write.csv(sstwarmingbylat, file='temp/warmingmaxhr_bylat_ocean.csv')

##################################################################
# Add deltas to climatology to get future temperatures 2081-2100
##################################################################
# average deltas for 2081-2100
tasmax26d2100 <- apply(tasmax26dyr[,,dimnames(tasmax26dyr)[[3]] %in% 2081:2100], MARGIN=c(1,2), FUN=max)
tasmax85d2100 <- apply(tasmax85dyr[,,dimnames(tasmax85dyr)[[3]] %in% 2081:2100], MARGIN=c(1,2), FUN=max)
tosmax26d2100 <- apply(tosmax26dyr[,,dimnames(tosmax26dyr)[[3]] %in% 2081:2100], MARGIN=c(1,2), FUN=max)
tosmax85d2100 <- apply(tosmax85dyr[,,dimnames(tosmax85dyr)[[3]] %in% 2081:2100], MARGIN=c(1,2), FUN=max)

# create rasters for interpolation
tasmax26d2100r <- raster(tasmax26d2100, xmn=0, xmx=360, ymn=-90, ymx=90)
tasmax85d2100r <- raster(tasmax85d2100, xmn=0, xmx=360, ymn=-90, ymx=90)
tosmax26d2100r <- raster(tosmax26d2100, xmn=0, xmx=360, ymn=-90, ymx=90)
tosmax85d2100r <- raster(tosmax85d2100, xmn=0, xmx=360, ymn=-90, ymx=90)

tasmaxr <- raster(tasmax, xmn=0, xmx=360, ymn=-90, ymx=90)
tosmaxr <- raster(tosmax, xmn=0, xmx=360, ymn=-90, ymx=90)

# interpolate to resolution of the climatology (2.5x3.75 on land, 0.25x0.25 in ocean)
tasmax26d2100_025r <- resample(tasmax26d2100r, tasmaxr, method='bilinear')
tasmax85d2100_025r <- resample(tasmax85d2100r, tasmaxr, method='bilinear')
tosmax26d2100_025r <- resample(tosmax26d2100r, tosmaxr, method='bilinear')
tosmax85d2100_025r <- resample(tosmax85d2100r, tosmaxr, method='bilinear')

# add deltas to climatologies
tasmax26_2100r <- tasmaxr + tasmax26d2100_025r
tasmax85_2100r <- tasmaxr + tasmax85d2100_025r
tosmax26_2100r <- tosmaxr + tosmax26d2100_025r
tosmax85_2100r <- tosmaxr + tosmax85d2100_025r

# convert to matrices
tasmax26_2100 <- as.matrix(tasmax26_2100r)
tasmax85_2100 <- as.matrix(tasmax85_2100r)
tosmax26_2100 <- as.matrix(tosmax26_2100r)
tosmax85_2100 <- as.matrix(tosmax85_2100r)

#############################################
# Average future temperatures by latitude
#############################################

# data.frame to hold results
lstmaxhrlat_2100 <- data.table(lat=yFromRow(tasmax26_2100r, 1:nrow(tasmax26_2100r)))
sstmaxhrlat_2100 <- data.table(lat=yFromRow(tosmax26_2100r,1:nrow(tosmax26_2100r)))

# average by lat
lstmaxhrlat_2100$tasmax26 <- apply(tasmax26_2100, MARGIN=1, FUN=mean, na.rm=TRUE)
lstmaxhrlat_2100$tasmax85 <- apply(tasmax85_2100, MARGIN=1, FUN=mean, na.rm=TRUE)
sstmaxhrlat_2100$tosmax26 <- apply(tosmax26_2100, MARGIN=1, FUN=mean, na.rm=TRUE)
sstmaxhrlat_2100$tosmax85 <- apply(tosmax85_2100, MARGIN=1, FUN=mean, na.rm=TRUE)

	# plot to check
	lstmaxhrlat_2100[,plot(lat, tasmax26, type='l', ylim=c(0,50))]
	lstmaxhrlat_2100[,lines(lat, tasmax85, lty=2)]
	sstmaxhrlat_2100[,lines(lat, tosmax26, col='blue')]
	sstmaxhrlat_2100[,lines(lat, tosmax85, col='blue', lty=2)]

# SD by lat
lstmaxhrlat_2100$tasmax26sd <- apply(tasmax26_2100, MARGIN=1, FUN=sd, na.rm=TRUE)
lstmaxhrlat_2100$tasmax85sd <- apply(tasmax85_2100, MARGIN=1, FUN=sd, na.rm=TRUE)
sstmaxhrlat_2100$tosmax26sd <- apply(tosmax26_2100, MARGIN=1, FUN=sd, na.rm=TRUE)
sstmaxhrlat_2100$tosmax85sd <- apply(tosmax85_2100, MARGIN=1, FUN=sd, na.rm=TRUE)

# Sample size by lat
lstmaxhrlat_2100$tasmax26n <- apply(tasmax26_2100, MARGIN=1, FUN=function(x) sum(!is.na(x)))
lstmaxhrlat_2100$tasmax85n <- apply(tasmax85_2100, MARGIN=1, FUN=function(x) sum(!is.na(x)))
sstmaxhrlat_2100$tosmax26n <- apply(tosmax26_2100, MARGIN=1, FUN=function(x) sum(!is.na(x)))
sstmaxhrlat_2100$tosmax85n <- apply(tosmax85_2100, MARGIN=1, FUN=function(x) sum(!is.na(x)))

# write out
write.csv(lstmaxhrlat_2100, file='temp/lstmaxhrlat_2081-2100.csv')
write.csv(sstmaxhrlat_2100, file='temp/sstmaxhrlat_2081-2100.csv')


# Snow crab --- Areal unit modelling of habitat

# -------------------------------------------------
# Part 1 -- construct basic parameter list defining the main characteristics of the study

  year.assessment = 2020

  p = bio.snowcrab::snowcrab_parameters(
    project_class="carstm",
    yrs=2000:year.assessment,
    areal_units_type="tesselation",
    arstm_model_label = "nonseparable_space-time_pa_fishable_binomial",
    selection = list(type = "presence_absence")
  )

  if (0) {

      p$selection$type = "presence_absence"
      p$selection$biologicals=list(
        spec_bio=bio.taxonomy::taxonomy.recode( from="spec", to="parsimonious", tolookup=p$groundfish_species_code ),
        sex=0, # male
        mat=1, # do not use maturity status in groundfish data as it is suspect ..
        len= c( 95, 200 )/10, #  mm -> cm ; aegis_db in cm
        ranged_data="len"
      )
      p$selection$survey=list(
        data.source = c("snowcrab", "groundfish", "logbook"),
        yr = p$yrs,      # time frame for comparison specified above
        settype = 1, # same as geartype in groundfish_survey_db
        polygon_enforce=TRUE,  # make sure mis-classified stations or incorrectly entered positions get filtered out
        strata_toremove = NULL #,  # emphasize that all data enters analysis initially ..
        # ranged_data = c("dyear")  # not used .. just to show how to use range_data
      )
      p$variabletomodel = "pa"

      p$carstm_model_label = "nonseparable_space-time_pa_fishable_binomial"
      p$carstm_modelengine = "inla"
      p$formula = as.formula( paste(
        p$variabletomodel, ' ~ 1 ',
          ' + f( dyri, model="ar1", hyper=H$ar1 ) ',
          ' + f( inla.group( t, method="quantile", n=11 ), model="rw2", scale.model=TRUE, hyper=H$rw2) ',
          ' + f( inla.group( z, method="quantile", n=11 ), model="rw2", scale.model=TRUE, hyper=H$rw2) ',
          ' + f( inla.group( substrate.grainsize, method="quantile", n=11 ), model="rw2", scale.model=TRUE, hyper=H$rw2) ',
          ' + f( inla.group( pca1, method="quantile", n=11 ), model="rw2", scale.model=TRUE, hyper=H$rw2) ',
          ' + f( inla.group( pca2, method="quantile", n=11 ), model="rw2", scale.model=TRUE, hyper=H$rw2) ',
          ' + f( space, model="bym2", graph=slot(sppoly, "nb"), scale.model=TRUE, constr=TRUE, hyper=H$bym2 ) '
          ' + f( space_time, model="bym2", graph=slot(sppoly, "nb"), group=time_space, scale.model=TRUE, constr=TRUE, hyper=H$bym2, control.group=list(model="ar1", hyper=H$ar1_group)) '
      ) )

      p$family = "binomial"  # "nbinomial", "betabinomial", "zeroinflatedbinomial0" , "zeroinflatednbinomial0"
      p$carstm_model_inla_control_familiy = list(control.link=list(model='logit'))

    #  p$family  = "zeroinflatedbinomial1", #  "binomial",  # "nbinomial", "betabinomial", "zeroinflatedbinomial0" , "zeroinflatednbinomial0"
    #  p$carstm_model_inla_control_familiy = NULL

  }

  sppoly = areal_units( p=p )  # to reload
  plot( sppoly[, "au_sa_km2"]  )

  M = snowcrab.db( p=p, DS="carstm_inputs", redo=TRUE )  # will redo if not found

  fit = carstm_model( p=p, data='snowcrab.db( p=p, DS="carstm_inputs" )' ) # 151 configs and long optim .. 19 hrs

  # fit = carstm_model( p=p, DS="carstm_modelled_fit")

    # extract results
    if (0) {
      # very large files .. slow
      fit = carstm_model( p=p, DS="carstm_modelled_fit" )  # extract currently saved model fit
      plot(fit)
      plot(fit, plot.prior=TRUE, plot.hyperparameters=TRUE, plot.fixed.effects=FALSE )
    }

  res = carstm_model( p=p, DS="carstm_modelled_summary"  ) # to load currently saved results
  res$summary$dic$dic
  res$summary$dic$p.eff
  res$dyear

  plot_crs = p$aegis_proj4string_planar_km
  coastline=aegis.coastline::coastline_db( DS="eastcoast_gadm", project_to=plot_crs )
  isobaths=aegis.bathymetry::isobath_db( depths=c(50, 100, 200, 400), project_to=plot_crs )
  managementlines = aegis.polygons::area_lines.db( DS="cfa.regions", returntype="sf", project_to=plot_crs )

  time_match = list( year=as.character(2020)  )
  carstm_map(  res=res,
      vn="predictions",
      time_match=time_match ,
      coastline=coastline,
      managementlines=managementlines,
      isobaths=isobaths,
      main=paste("Habitat probability - mature male ", paste0(time_match, collapse="-") )
  )

  # map all :
  vn "= predictions"

  outputdir = file.path( p$modeldir, p$carstm_model_label, "predicted.probability.observation" )

  if ( !file.exists(outputdir)) dir.create( outputdir, recursive=TRUE, showWarnings=FALSE )

  brks = pretty(  res[[vn]]  )

  for (y in res$year ){

      time_match = list( year=y  )
      fn_root = paste("Predicted_abundance", paste0(time_match, collapse="-"), sep="_")
      fn = file.path( outputdir, paste(fn_root, "png", sep=".") )

        carstm_map(
          res=res,
          vn=vn,
          time_match=time_match,
          breaks =brks,
#          palette="-RdYlBu",
          coastline=coastline,
          isobaths=isobaths,
          managementlines=managementlines,
          main=paste("Habitat probability - mature male ", paste0(time_match, collapse="-") ),
          outfilename=fn
        )

  }

  snowcrab.db(p=p, DS="carstm_output_compute" )

  RES = snowcrab.db(p=p, DS="carstm_output_timeseries" )

  pa = snowcrab.db(p=p, DS="carstm_output_spacetime_pa"  )

# plots with 95% PI

  outputdir = file.path( p$modeldir, p$carstm_model_label, "aggregated_biomass_timeseries" )

  if ( !file.exists(outputdir)) dir.create( outputdir, recursive=TRUE, showWarnings=FALSE )

  (fn = file.path( outputdir, "cfa_all.png"))
  png( filename=fn, width=3072, height=2304, pointsize=12, res=300 )
    plot( cfaall ~ yrs, data=RES, lty="solid", lwd=4, pch=20, col="slateblue", type="b", ylab="Prob of observing snow crab", xlab="",  ylim=c(0,1))
    lines( cfaall_lb ~ yrs, data=RES, lty="dotted", lwd=2, col="slategray" )
    lines( cfaall_ub ~ yrs, data=RES, lty="dotted", lwd=2, col="slategray" )
  dev.off()

  (fn = file.path( outputdir, "cfa_south.png") )
  png( filename=fn, width=3072, height=2304, pointsize=12, res=300 )
    plot( cfasouth ~ yrs, data=RES, lty="solid", lwd=4, pch=20, col="slateblue", type="b", ylab="Prob of observing snow crab", xlab="",  ylim=c(0,1))
    lines( cfasouth_lb ~ yrs, data=RES, lty="dotted", lwd=2, col="slategray" )
    lines( cfasouth_ub ~ yrs, data=RES, lty="dotted", lwd=2, col="slategray" )
  dev.off()

  (fn = file.path( outputdir, "cfa_north.png"))
  png( filename=fn, width=3072, height=2304, pointsize=12, res=300 )
    plot( cfanorth ~ yrs, data=RES, lty="solid", lwd=4, pch=20, col="slateblue", type="b", ylab="Prob of observing snow crab", xlab="",  ylim=c(0,1))
    lines( cfanorth_lb ~ yrs, data=RES, lty="dotted", lwd=2, col="slategray" )
    lines( cfanorth_ub ~ yrs, data=RES, lty="dotted", lwd=2, col="slategray" )
  dev.off()

  (fn = file.path( outputdir, "cfa_4x.png"))
  png( filename=fn, width=3072, height=2304, pointsize=12, res=300 )
    plot( cfa4x ~ yrs, data=RES, lty="solid", lwd=4, pch=20, col="slateblue", type="b", ylab="Prob of observing snow crab", xlab="",  ylim=c(0,1))
    lines( cfa4x_lb ~ yrs, data=RES, lty="dotted", lwd=2, col="slategray" )
    lines( cfa4x_ub ~ yrs, data=RES, lty="dotted", lwd=2, col="slategray" )
  dev.off()

# end


subroutine baklo(x,y,w,npetc,wddnfl,spatol,match,
		etal,s,eta,beta,var,dof,
		qr,qraux,qpivot,effect,iv,v,iwork,work)
implicit double precision(a-h,o-z)
integer n,p,q,nit,maxit,qrank
integer npetc(7),wddnfl(*),match(*),qpivot(*),iv(*),iwork(*)
##integer which(q),dwhich(q),degree(q),nef(q),liv(q),lv(q),nvmax(q)
double precision x(*),y(*),w(*),spatol(*),
	etal(*),s(*),eta(*),beta(*),var(*),dof(*),
	qr(*),qraux(*),v(*),effect(*),work(*)
#work size: 4*n + sum( nef(k)*(pj+dj+4)+5+3*pj )	+5*n
#          = 9*n + sum( nef(k)*(pj+dj+4)+5+3*pj )

n=npetc(1)
p=npetc(2)
q=npetc(3)
maxit=npetc(5)
qrank=npetc(6)
call baklo0(x,n,p,y,w,q,wddnfl(1),wddnfl(q+1),wddnfl(2*q+1),
            spatol(1),wddnfl(3*q+1),dof,match,wddnfl(4*q+1),
            etal,s,eta,beta,var,spatol(q+1),
            nit,maxit,qr,qraux,qrank,qpivot,effect,
            work(1),work(n+1),work(2*n+1),work(3*n+1),
            iv,wddnfl(5*q+1),wddnfl(6*q+1),v,wddnfl(7*q+1),
            iwork(1),work(4*n+1))
npetc(4)=nit
npetc(6)=qrank
return
end

subroutine baklo0(x,n,p,y,w,q,which,dwhich,pwhich,span,degree,dof,match,nef,
			etal,s,eta,beta,var,tol,nit,maxit,
			qr,qraux,qrank,qpivot,effect,z,old,sqwt,sqwti,
			iv,liv,lv,v,nvmax,iwork,work)
implicit double precision(a-h,o-z)
integer n,p,q,which(q),dwhich(q),pwhich(q),degree(q),match(n,q),nef(q),nit,
		maxit,qrank,qpivot(p),iv(*),liv(q),lv(q),nvmax(q),iwork(q)
double precision x(n,p),y(n),w(n),span(q),dof(q),
			etal(n),s(n,q),eta(n),beta(p),var(n,q),tol,
			qr(n,p),qraux(p),v(*),effect(n),work(*)
#work should be sum( nef(k)*(pj+dj+4)+5+3*pj )	+5*n
double precision z(*),old(*),dwrss,ratio
double precision sqwt(n),sqwti(n)
logical anyzwt
double precision deltaf, normf,onedm7
integer job,info,slv,sliv,iw,j,dj,pj
onedm7=1d-7
job=1101;info=1
if(q==0)maxit=1
ratio=1d0
# fix up sqy's for weighted problems.
anyzwt=.false.
do i=1,n{
	if(w(i)>0d0){
		sqwt(i)=dsqrt(w(i))
		sqwti(i)=1d0/sqwt(i)
	}
	else{
		sqwt(i)=0d0
		sqwti(i)=0d0
		anyzwt=.true.
		}
	}
# if qrank > 0 then qr etc contain the qr decomposition
# else baklo computes it.
if(qrank==0){
	do i=1,n{
		do j=1,p{
			qr(i,j)=x(i,j)*sqwt(i)
			}
		}
	do j=1,p{qpivot(j)=j}
	call dqrdca(qr,n,n,p,qraux,qpivot,work,qrank,onedm7)
	}
do i=1,n{
	eta(i)=0d0
	for(j=1;j<=q;j=j+1){
		eta(i)=eta(i)+s(i,j)
		}
	}
nit=0
while ((ratio > tol )&(nit < maxit)){
	# first the linear fit
	deltaf=0d0
	nit=nit+1
	do i=1,n{
		z(i)=(y(i)-eta(i))*sqwt(i)
		old(i)=etal(i)
	}
#	call dqrsl1(qr,dq,qraux,qrank,sqz,one,work(1),etal,two,three)
#job=1101 -- computes fits, effects and beta
	call dqrsl(qr,n,n,qrank,qraux,z,work(1),effect(1),beta,
		work(1),etal,job,info)

# now unsqrt the fits
#Note: we dont have to fix up the zero weights till the end, since their fits
#are always immaterial to the computation
	do i=1,n{
		etal(i)=etal(i)*sqwti(i)
		}
	# now a single non-linear backfitting loop
	sliv=1
	slv=1
	iw=5*n+1
	for(k=1;k<=q;k=k+1){

		j=which(k)
		dj=dwhich(k)
		pj=pwhich(k)
		do i=1,n{
			old(i)=s(i,k)
			z(i)=y(i)-etal(i)-eta(i)+old(i)
		}
call lo1(x(1,j),z,w,n,dj,pj,nvmax(k),span(k),degree(k),match(1,k),
		nef(k),nit,dof(k),s(1,k),var(1,k),work(iw),
#	xin,win
	work(iw+pj+1),work(iw+nef(k)*dj+pj+1),
#	sqwin,sqwini,
	work(iw+nef(k)*(dj+1)+pj+2),work(iw + nef(k)*(dj+2)+pj+2),
#	xqr,qrank,
	work(iw+nef(k)*(dj+3)+pj+2),work(iw+nef(k)*(pj+dj+4)+pj+2),
#	qpivot,qraux,
#	work(iw+nef(k)*(pj+dj+4)+pj+3),work(iw+nef(k)*(pj+dj+4)+4+2*pj),
	iwork(1),work(iw+nef(k)*(pj+dj+4)+4+2*pj),
	iv(sliv),liv(k),lv(k),v(slv),
	work(1) )
#work should be sum( nef(k)*(pj+dj+4)+5+3*pj )	+5*n
# In the call above I give lo1 pieces of work to use for storing
# the  qr decomposition, and it gets the same undisturbed portion
# each time. The fact that it is given a double work word for qrank
# is irrelevant but convenient; it still stores the integer qrank there.
# I do this because there is a partition like this for each lo() term
# in the model, and the number of them is variable
		sliv=sliv+liv(k)
		slv=slv+lv(k)
		iw=iw+nef(k)*(pj+dj+4)+5+3*pj
		do i=1,n{
			eta(i)=eta(i)+s(i,k)-old(i)
			}
		deltaf=deltaf+dwrss(n,old,s(1,k),w)
		}
	normf=0d0
	do i=1,n{
		normf=normf+w(i)*eta(i)*eta(i)
		}
	if(normf>0d0){
		ratio=dsqrt(deltaf/normf)
		}
	 else {ratio = 0d0}
	}
#now package up the results
do j=1,p {work(j)=beta(j)}
do j=1,p {beta(qpivot(j))=work(j)}
if(anyzwt){
	do i=1,n {
		if(w(i) <= 0d0){
			etal(i)=0d0
			do j=1,p{
				etal(i)=etal(i)+beta(j)*x(i,j)
				}
			}
		}
	}

do i=1,n
	eta(i)=eta(i)+etal(i)

return
end


#!/usr/bin/env Rscript
library("rstan")
library("parallel")
library("bayesplot")
library("raster")
options(mc.cores = parallel::detectCores())

load("dat/shw_scale.Rdata")

#### DELETE THIS LINE ONCE EFFORT IS ADDED
shw_scale$effort <- 1

# set up an environmental data frame for stan
# start with just cells where we have all data
# include linear terms plus interactions for region
envDatAll <- with(shw_scale, data.frame(intercept=1, bathy=bathy, chla=chla, sst=sst, varsst=varsst,
                  dist=dist, east_region = as.integer(region=='E')))

envDatAll <- within(envDatAll, {
  east_chla <- east_region*chla
  east_sst <- east_region*sst
  east_varsst <- east_region*varsst
  east_dist <- east_region*dist
})

# counts, no gps, and no environmental NAs
# counts, GPS, and no environmental NAs
# GPS only, no environmental NAs
countRows <- which(!is.na(shw_scale$count) & is.na(shw_scale$ninds) & complete.cases(envDatAll))
gpsCountRows <- which(!is.na(shw_scale$ninds) & !is.na(shw_scale$count) & complete.cases(envDatAll))
gpsRows <- which(!is.na(shw_scale$ninds) & is.na(shw_scale$count) & complete.cases(envDatAll))

# data for fitting
envCount <- envDatAll[countRows,]
envCountGPS <- envDatAll[gpsCountRows,]
envGPS <- envDatAll[gpsRows,]

# set up remaining stan data
stanDat <- list(
  nCounts = nrow(envCount),
  nCountsGPS = nrow(envCountGPS),
  nGPS = nrow(envGPS),
  nEnvVars = ncol(envCount),
  envCount = as.matrix(envCount),
  envCountGPS = as.matrix(envCountGPS),
  envGPS = as.matrix(envGPS),
  counts = shw_scale[countRows,'count'],
  countsGPS = shw_scale[gpsCountRows,'count'],
  gpsCounts = shw_scale[gpsCountRows,'ninds'],
  gps = shw_scale[gpsRows,'ninds'],
  surveyEffortCounts = shw_scale[countRows,'effort'],
  surveyEffortCountsGPS = shw_scale[gpsCountRows,'effort'])

envAbunOnly <- rbind(envCount, envCountGPS)
stanDatAbun <- list(nCounts = nrow(envAbunOnly),
   nEnvVars = ncol(envAbunOnly),
   envCount = as.matrix(envAbunOnly),
   counts = shw_scale[c(countRows, gpsCountRows),'count'],
   surveyEffortCounts = shw_scale[c(countRows, gpsCountRows),'effort'])

envGPSOnly <- rbind(envCountGPS, envGPS)
stanDatGPS <- list(nGPS = nrow(envGPSOnly),
  nEnvVars = ncol(envGPSOnly),
  envGPS = as.matrix(envGPSOnly),
  gps = shw_scale[c(gpsCountRows, gpsRows),'ninds'])

# launch stan
modFull <- stan('shear.stan', data=stanDat, chains=4, iter=1000, cores=4)
modAerial <- stan('shear_abun_only.stan', data=stanDatAbun, chains=4, iter=1000, cores=4)
modGPS <- stan('shear_gps_only.stan', data=stanDatGPS, chains=4, iter=1000, cores=4)

# visualize results
paramsFull <- as.array(modFull)
betasFull <- rstan::extract(modFull)$beta
paramsAerial <- as.array(modAerial)
betasAerial <- rstan::extract(modAerial)$beta
paramsGPS <- as.array(modGPS)
betasGPS <- rstan::extract(modGPS)$beta

# look at betas and hyperparams
# mcmc_dens(paramsFull, pars=c('gpsScale', 'gpsSD'), regex_pars='beta')

# predict abundance for all replicates across entire region
logAbunFull <- as.matrix(envDatAll) %*% t(betasFull)
logAbunAerial <- as.matrix(envDatAll) %*% t(betasAerial)
logAbunGPS <- as.matrix(envDatAll) %*% t(betasGPS)

# make posterior mean and SD rasters
abunFullMeanRas <- rasterFromXYZ(cbind(shw_scale$lon, shw_scale$lat, exp(rowMeans(logAbunFull))))
abunFullSDRas <- rasterFromXYZ(cbind(shw_scale$lon, shw_scale$lat, apply(logAbunFull, 1, sd)))
abunAerialMeanRas <- rasterFromXYZ(cbind(shw_scale$lon, shw_scale$lat, exp(rowMeans(logAbunAerial))))
abunAerialSDRas <- rasterFromXYZ(cbind(shw_scale$lon, shw_scale$lat, apply(logAbunAerial, 1, sd)))
abunGPSMeanRas <- rasterFromXYZ(cbind(shw_scale$lon, shw_scale$lat, exp(rowMeans(logAbunGPS))))
abunGPSSDRas <- rasterFromXYZ(cbind(shw_scale$lon, shw_scale$lat, apply(logAbunGPS, 1, sd)))

aCols <- colorRampPalette(rev(c('#032838', '#4E788F', '#80A4B7', '#BAD0D9', '#F1EBDC')), bias=3)(100)
pdf("results.pdf", h=10, w=10)
par(mfrow=c(3,2), mar=c(0.5,0.5,4,4))
plot(abunFullMeanRas, col=aCols, xaxt='n', yaxt='n', zlim=c(0, maxValue(abunFullMeanRas)), main="Mean Predicted Abundance (Integrated)")
plot(abunFullSDRas, col=heat.colors(100), xaxt='n', yaxt='n', zlim=c(0, maxValue(abunFullSDRas)), main="SD Predicted Abundance")
plot(abunAerialMeanRas, col=aCols, xaxt='n', yaxt='n', zlim=c(0, maxValue(abunAerialMeanRas)), main="Mean Predicted Abundance (Aerial Only)")
plot(abunAerialSDRas, col=heat.colors(100), xaxt='n', yaxt='n', zlim=c(0, maxValue(abunAerialSDRas)), main="SD Predicted Abundance")
plot(abunGPSMeanRas, col=aCols, xaxt='n', yaxt='n', zlim=c(0, maxValue(abunGPSMeanRas)), main="Mean Predicted Abundance (GPS Only)")
plot(abunGPSSDRas, col=heat.colors(100), xaxt='n', yaxt='n', zlim=c(0, maxValue(abunGPSSDRas)), main="SD Predicted Abundance")
dev.off()


#Title: Estimate fitting decay curve
#Auther: Naoto Imamachi
#ver: 1.0.0
#Date: 2015-10-24

###Estimate_normalization_factor_function###
BridgeRHalfLifeCalcR2Select <- function(InputFile = "BridgeR_4_Normalized_expression_dataset.txt",
                                        group,
                                        hour,
                                        InforColumn = 4,
                                        CutoffDataPointNumber = 4,
                                        CutoffDataPoint1 = c(1,2),
                                        CutoffDataPoint2 = c(8,12),
                                        ThresholdHalfLife = c(8,12),
                                        OutputFile = "BridgeR_5C_HalfLife_calculation_R2_selection.txt"){
    ###Prepare_file_infor###
    time_points <- length(hour)
    group_number <- length(group)
    input_file <- fread(InputFile, header=T)
    output_file <- paste(OutputFile,".log",sep="")
    log_file <- OutputFile

    ###print_header###
    cat("",file=output_file)
    cat("",file=log_file)
    hour_label <- NULL
    CutoffDataPoint1 <- sort(CutoffDataPoint1, decreasing = T)
    CutoffDataPoint2 <- sort(CutoffDataPoint2, decreasing = F)
    CutoffDataPoint1_length <- length(CutoffDataPoint1)
    CutoffDataPoint2_length <- length(CutoffDataPoint2)

    for_iteration_number <- CutoffDataPoint1_length + CutoffDataPoint2_length
    for(a in 1:group_number){
        if(!is.null(hour_label)){
            cat("\t", file=output_file, append=T)
            cat("\t", file=log_file, append=T)
        }
        hour_label <- NULL
        for(x in hour){
            hour_label <- append(hour_label, paste("T", x, "_", a, sep=""))
        }
        infor_st <- 1 + (a - 1)*(time_points + InforColumn)
        infor_ed <- (InforColumn)*a + (a - 1)*time_points
        infor <- colnames(input_file)[infor_st:infor_ed]
        cat(infor,hour_label, sep="\t", file=output_file, append=T)
        cat("\t", sep="", file=output_file, append=T)
        cat(infor,hour_label, sep="\t", file=log_file, append=T)
        cat("\t", sep="", file=log_file, append=T)

        for_iteration_number2 <- for_iteration_number + 1
        for(number in 1:for_iteration_number2){
            cat("Model","Decay_rate_coef","coef_error","coef_p-value",
                "R2","Adjusted_R2","Residual_standard_error","half_life",
                sep="\t", file=output_file, append=T)
            cat("\t", sep="", file=output_file, append=T)
        }
        cat("Model","R2","half_life", sep="\t", file=output_file, append=T)
        cat("Model","R2","half_life", sep="\t", file=log_file, append=T)
    }
    cat("\n", sep="", file=output_file, append=T)
    cat("\n", sep="", file=log_file, append=T)

    ###calc_RNA_half_lives###
    ###Function1#################################
    half_calc <- function(time_exp_table,label){
        data_point <- length(time_exp_table$exp)
        if(!is.null(time_exp_table)){
            if(data_point >= CutoffDataPointNumber){
                if(as.numeric(as.vector(as.matrix(time_exp_table$exp[1]))) > 0){
                    model <- lm(log(time_exp_table$exp) ~ time_exp_table$hour - 1)
                    model_summary <- summary(model)
                    coef <- -model_summary$coefficients[1]
                    coef_error <- model_summary$coefficients[2]
                    coef_p <- model_summary$coefficients[4]
                    r_squared <- model_summary$r.squared
                    adj_r_squared <- model_summary$adj.r.squared
                    residual_standard_err <- model_summary$sigma
                    half_life <- log(2)/coef
                    if(coef < 0 || half_life >= 24){
                        half_life <- 24
                    }
                    cat(label,coef,coef_error,coef_p,r_squared,adj_r_squared,residual_standard_err,half_life, sep="\t", file=output_file, append=T)
                    return(c(half_life,r_squared))
                }else{
                    cat("low_expresion","NA","NA","NA","NA","NA","NA","NA", sep="\t", file=output_file, append=T)
                    return(c("NA","NA"))
                }
            }else{
                cat("few_data","NA","NA","NA","NA","NA","NA","NA", sep="\t", file=output_file, append=T)
                return(c("NA","NA"))
            }
        }else{
            cat("low_expresion","NA","NA","NA","NA","NA","NA","NA", sep="\t", file=output_file, append=T)
            return(c("NA","NA"))
        }
    }
    #############################################

    ###Function2#################################
    test_R2 <- function(time_point_exp_raw, cutoff_data_point, halflife_Raw, R2_Raw){
        test_times <- cutoff_data_point
        times_length <- length(test_times)
        times_index <- c(times_length)
        add_index <- times_length

        R2_list <- c(R2_Raw)
        half_list <- c(halflife_Raw)
        label_list <- c("Raw")
        for(counter in times_length:1){
            #excepted_time_points
            check_times <- test_times[times_index] #c(24), c(24,12), c(24,12,8)
            time_point_exp_del <- NULL
            time_point_exp_del_label <- paste("Delete_",paste(check_times,collapse="hr_"),"hr",sep="")
            label_list <- append(label_list, time_point_exp_del_label) #
            time_point_exp_del <- time_point_exp_raw
            for(times_list in check_times){
                time_point_exp_del <- time_point_exp_del[time_point_exp_del$hour != as.numeric(times_list),]
            }
            time_point_exp_del <- time_point_exp_del[time_point_exp_del$exp > 0,]
            halflife_R2_result <- half_calc(time_point_exp_del, time_point_exp_del_label)
            cat("\t", sep="", file=output_file, append=T)

            R2_list <- append(R2_list, halflife_R2_result[2]) #
            half_list <- append(half_list, halflife_R2_result[1]) #

            #Counter
            add_index <- add_index - 1
            times_index <- append(times_index, add_index)
        }

        R2_table <- data.frame(label=label_list, R2=R2_list, half=half_list)
        #R2_table <- R2_table[R2_table$R2 != "NA",]
        #sortlist <- order(R2_table$R2, decreasing = T)
        #R2_table <- R2_table[sortlist,]
        #result <- as.vector(as.matrix(R2_table[1,]))
        #cat(result, sep="\t", file=output_file, append=T)
        return(R2_table)
    }
    #############################################

    gene_number <- length(input_file[[1]])
    for(x in 1:gene_number){
        data <- as.vector(as.matrix(input_file[x,]))
        for(a in 1:group_number){
            if(a != 1){
                cat("\t", sep="", file=output_file, append=T)
                cat("\t", sep="", file=log_file, append=T)
            }
            infor_st <- 1 + (a - 1)*(time_points + InforColumn)
            infor_ed <- (InforColumn)*a + (a - 1)*time_points
            exp_st <- infor_ed + 1
            exp_ed <- infor_ed + time_points

            gene_infor <- data[infor_st:infor_ed]
            cat(gene_infor, sep="\t", file=output_file, append=T)
            cat("\t", file=output_file, append=T)
            cat(gene_infor, sep="\t", file=log_file, append=T)
            cat("\t", file=log_file, append=T)

            exp <- as.numeric(data[exp_st:exp_ed])
            cat(exp, sep="\t", file=output_file, append=T)
            cat("\t", file=output_file, append=T)
            cat(exp, sep="\t", file=log_file, append=T)
            cat("\t", file=log_file, append=T)

            ###Raw_data
            time_point_exp_raw <- data.frame(hour,exp)
            time_point_exp_base <- time_point_exp_raw[time_point_exp_raw$exp > 0, ]
            test <- half_calc(time_point_exp_base,"Exponential_Decay_Model") #T1/2 - R2
            cat("\t", sep="", file=output_file, append=T)

            ###Re-calculation of RNA half-life(Default: ThresholdHalfLife - 12hr)
            R2_list <- NULL
            half_list <- NULL
            label_list <- NULL
            if(test[1] == "NA"){
                for(number in 1:for_iteration_number){
                    cat("Notest","NA","NA","NA","NA","NA","NA","NA", sep="\t", file=output_file, append=T)
                    cat("\t", sep="", file=output_file, append=T)
                }
                cat("Notest","NA","NA", sep="\t", file=output_file, append=T)
                cat("Notest","NA","NA", sep="\t", file=log_file, append=T)
            }else if(test[1] < ThresholdHalfLife[1]){ #Default: <12hr => Delete 8,12hr
                for(number in 1:CutoffDataPoint1_length){
                    cat("Notest","NA","NA","NA","NA","NA","NA","NA", sep="\t", file=output_file, append=T)
                    cat("\t", sep="", file=output_file, append=T)
                }
                R2_table <- test_R2(time_point_exp_raw, CutoffDataPoint2, test[1], test[2]) #test[1], test[2] => T1/2, R2

            }else if(test[1] >= ThresholdHalfLife[1] && test[1] < ThresholdHalfLife[2]){
                R2_table1 <- test_R2(time_point_exp_raw, CutoffDataPoint1, test[1], test[2]) #test[1], test[2] => T1/2, R2
                R2_table2 <- test_R2(time_point_exp_raw, CutoffDataPoint2, test[1], test[2]) #test[1], test[2] => T1/2, R2
                R2_table <- rbind(R2_table1, R2_table2)

            }else if(test[1] >= ThresholdHalfLife[2]){ #Default: >=12hr => Delete 1,2hr
                for(number in 1:CutoffDataPoint2_length){
                    cat("Notest","NA","NA","NA","NA","NA","NA","NA", sep="\t", file=output_file, append=T)
                    cat("\t", sep="", file=output_file, append=T)
                }
                R2_table <- test_R2(time_point_exp_raw, CutoffDataPoint1, test[1], test[2]) #test[1], test[2] => T1/2, R2

            }
            ###R2_Selection###
            if(test[1] != "NA"){
                R2_table <- R2_table[R2_table$R2 != "NA",]
                sortlist <- order(R2_table$R2, decreasing = T)
                R2_table <- R2_table[sortlist,]
                result <- as.vector(as.matrix(R2_table[1,]))
                cat(result, sep="\t", file=output_file, append=T)
                cat(result, sep="\t", file=log_file, append=T)
            }
        }
        cat("\n", file=output_file, append=T)
        cat("\n", file=log_file, append=T)
    }
}

###TEST###
#output_file <- "test.txt"
#CutoffDataPointNumber <- 4
#x <- c(0,1,2,4,8,12)
#y <- c(1,0.9,0.8,0.5,0.3,0.1)
#table <- data.frame(hour=x,exp=y)
#test_data_point <- c(8,12)
#test_R2(table, test_data_point, 4.5, 0.992)

#    R2_list half_list      label_list
#1 0.9919170  4.547501     Delete_12hr
#2 0.9720505  4.378777 Delete_12hr_8hr

#########################
#test <- c(8,12,24,2,12,21,1)
#test_length <- length(test)
#test_index <- c(test_length)
#add_index <- test_length

#for(x in test_length:1){
#    print(test[test_index])
#    add_index <- add_index - 1
#    test_index <- append(test_index,add_index)
#}