###############################################################################################################################################
#  fitted method for marssMLE objects; expected value of rhs minus error term
##############################################################################################################################################
fitted.marssMLE <- function(object, ...,
                            type = c("ytt1", "ytT", "xtT", "ytt", "xtt1"),
                            interval = c("none", "confidence", "prediction"),
                            level = 0.95,
                            output = c("data.frame", "matrix"),
                            fun.kf = c("MARSSkfas", "MARSSkfss")) {
  type <- match.arg.exact(type)
  output <- match.arg(output)
  interval <- match.arg(interval)
  conditioning <- substring(type, 3)
  type <- substr(type, 1, 1)
  # Allow user to force a particular KF function
  if(!missing(fun.kf)) object[["fun.kf"]] <- match.arg(fun.kf)

  MLEobj <- object
  if (is.null(MLEobj[["par"]])) {
    stop("fitted.marssMLE: The marssMLE object does not have the par element.  Most likely the model has not been fit.", call. = FALSE)
  }
  if (MLEobj[["convergence"]] == 54) {
    stop("fitted.marssMLE: MARSSkf (the Kalman filter/smoother) returns an error with the fitted model. Try MARSSinfo('optimerror54') for insight.", call. = FALSE)
  }

  if (interval != "none" && (!is.numeric(level) || length(level) != 1 || level > 1 || level < 0)) {
    stop("fitted.marssMLE: level must be a single number between 0 and 1.", call. = FALSE)
  }
  alpha <- 1 - level

  # need the model dims in marss form with c in U and d in A
  model.dims <- attr(MLEobj[["marss"]], "model.dims")
  TT <- model.dims[["x"]][2]
  n <- model.dims[["y"]][1]
  m <- model.dims[["x"]][1]

  if (type == "y") {
    if (conditioning == "T") hatxt <- MARSSkf(MLEobj)[["xtT"]]
    if (conditioning == "t1") hatxt <- MARSSkf(MLEobj)[["xtt1"]]
    if (conditioning == "t") hatxt <- MARSSkf(MLEobj)[["xtt"]]
    if (interval != "none") {
      if (conditioning == "T") hatVt <- MARSSkf(MLEobj)[["VtT"]]
      if (conditioning == "t1") hatVt <- MARSSkf(MLEobj)[["Vtt1"]]
      if (conditioning == "t") hatVt <- MARSSkf(MLEobj)[["Vtt"]]
    }
    Z.time.varying <- model.dims[["Z"]][3] != 1
    A.time.varying <- model.dims[["A"]][3] != 1
    R.time.varying <- model.dims[["R"]][3] != 1
    H.time.varying <- model.dims[["H"]][3] != 1

    val <- matrix(NA, n, TT)
    rownames(val) <- attr(MLEobj$marss, "Y.names")
    if (interval != "none") se <- val

    Zt <- parmat(MLEobj, "Z", t = 1)$Z
    At <- parmat(MLEobj, "A", t = 1)$A
    Rt <- parmat(MLEobj, "R", t = 1)$R
    Ht <- parmat(MLEobj, "H", t = 1)$H
    Rt <- Ht %*% tcrossprod(Rt, Ht)

    for (t in 1:TT) {
      # parmat returns marss form
      if (Z.time.varying) Zt <- parmat(MLEobj, "Z", t = t)$Z
      if (A.time.varying) At <- parmat(MLEobj, "A", t = t)$A
      val[, t] <- Zt %*% hatxt[, t, drop = FALSE] + At
      if (interval == "confidence") {
        se[, t] <- takediag(Zt %*% tcrossprod(hatVt[, , t], Zt))
      }
      if (interval == "prediction") {
        if (R.time.varying) Rt <- parmat(MLEobj, "R", t = t)$R
        if (H.time.varying) Ht <- parmat(MLEobj, "H", t = t)$H
        if (R.time.varying | H.time.varying) Rt <- Ht %*% tcrossprod(Rt, Ht)
        se[, t] <- takediag(Zt %*% tcrossprod(hatVt[, , t], Zt) + Rt)
      }
    }

    # Set up output
    if (output == "data.frame") {
      data.names <- attr(MLEobj[["model"]], "Y.names")
      data.dims <- attr(MLEobj[["model"]], "model.dims")[["y"]]
      model.tsp <- attr(MLEobj[["model"]], "model.tsp")
      nn <- data.dims[1]
      TT <- data.dims[2]
      ret <- data.frame(
        .rownames = rep(data.names, each = TT),
        t = rep(seq(model.tsp[1], model.tsp[2], 1 / model.tsp[3]), nn),
        y = vec(t(MLEobj[["model"]]$data)),
        stringsAsFactors = FALSE
      )
    }
  }

  if (type == "x") {
    if (conditioning == "T") hatxt <- MARSSkf(MLEobj)[["xtT"]]
    if (conditioning == "t1") hatxt <- MARSSkf(MLEobj)[["xtt"]]
    if (interval != "none") {
      if (conditioning == "T") hatVt <- MARSSkf(MLEobj)[["VtT"]]
      if (conditioning == "t1") hatVt <- MARSSkf(MLEobj)[["Vtt"]]
    }

    B.time.varying <- model.dims[["B"]][3] != 1
    U.time.varying <- model.dims[["U"]][3] != 1
    Q.time.varying <- model.dims[["Q"]][3] != 1
    G.time.varying <- model.dims[["G"]][3] != 1

    val <- matrix(NA, m, TT)
    rownames(val) <- attr(MLEobj[["marss"]], "X.names")
    if (interval != "none") se <- val

    x0 <- coef(MLEobj, type = "matrix")[["x0"]]
    if (interval != "none") V0 <- coef(MLEobj, type = "matrix")[["V0"]]
    Bt <- parmat(MLEobj, "B", t = 1)[["B"]]
    Ut <- parmat(MLEobj, "U", t = 1)[["U"]]
    Qt <- parmat(MLEobj, "Q", t = 1)[["Q"]]
    Gt <- parmat(MLEobj, "G", t = 1)[["G"]]
    Qt <- Gt %*% tcrossprod(Qt, Gt)

    if (MLEobj$model$tinitx == 0) {
      val[, 1] <- Bt %*% x0 + Ut
      if (interval == "confidence") se[, 1] <- takediag(Bt %*% tcrossprod(V0, Bt))
      if (interval == "prediction") se[, 1] <- takediag(Bt %*% tcrossprod(V0, Bt) + Qt)
    }
    if (MLEobj[["model"]][["tinitx"]] == 1) {
      val[, 1] <- x0
      if (interval != "none") se[, 1] <- takediag(V0)
    }
    for (t in 2:TT) {
      if (B.time.varying) Bt <- parmat(MLEobj, "B", t = t)[["B"]]
      if (U.time.varying) Ut <- parmat(MLEobj, "U", t = t)[["U"]]
      val[, t] <- Bt %*% hatxt[, t - 1, drop = FALSE] + Ut
      if (interval == "confidence") {
        se[, t] <- takediag(Bt %*% tcrossprod(hatVt[, , t - 1], Bt))
      }
      if (interval == "prediction") {
        if (Q.time.varying) Qt <- parmat(MLEobj, "Q", t = t)[["Q"]]
        if (G.time.varying) Gt <- parmat(MLEobj, "G", t = t)[["G"]]
        if (Q.time.varying | G.time.varying) Qt <- Gt %*% tcrossprod(Qt, Gt)
        se[, t] <- takediag(Bt %*% tcrossprod(hatVt[, , t - 1], Bt) + Qt)
      }
    }

    # Set up output
    if (output == "data.frame") {
      state.names <- attr(MLEobj[["model"]], "X.names")
      state.dims <- attr(MLEobj[["model"]], "model.dims")[["x"]]
      model.tsp <- attr(MLEobj[["model"]], "model.tsp")
      mm <- state.dims[1]
      TT <- state.dims[2]
      ret <- data.frame(
        .rownames = rep(state.names, each = TT),
        t = rep(seq(model.tsp[1], model.tsp[2], 1 / model.tsp[3]), mm),
        .x = vec(t(hatxt)),
        stringsAsFactors = FALSE
      )
    }
  }

  if (interval == "none") {
    if (output == "matrix") {
      return(val)
    }
    retlist <- list(.fitted = val)
  }
  if (interval == "confidence") {
    se[se < 0 & abs(se) < sqrt(.Machine$double.eps)] <- 0
    se <- sqrt(se) # was not sqrt earlier
    retlist <- list(
      .fitted = val,
      .se = se,
      .conf.low = val + qnorm(alpha / 2) * se,
      .conf.up = val + qnorm(1 - alpha / 2) * se
    )
  }
  if (interval == "prediction") {
    se[se < 0 & abs(se) < sqrt(.Machine$double.eps)] <- 0
    se <- sqrt(se) # was not sqrt earlier
    retlist <- list(
      .fitted = val,
      .sd = se,
      .lwr = val + qnorm(alpha / 2) * se,
      .upr = val + qnorm(1 - alpha / 2) * se
    )
  }
  if (output == "matrix") {
    return(retlist)
  }
  return(cbind(ret, as.data.frame(lapply(retlist, function(x) {
    vec(t(x))
  }))))
} # end of fitted.marssMLE


context("CV scores")

## linear regression
test_that("auc_roc returns NA when 1 value", {
  roc <- auc_roc(factor(1, levels=1:2), 0.5)
  expect_equal( roc, NA_real_ )
})

test_that("auc_roc returns a number when 2 values", {
  roc <- auc_roc(factor(c(1,2), levels=1:2), c(0.5, 0.2) )
  expect_equal( roc, 0 )
})

test_that("auc_pr returns NA when 1 value", {
  roc <- auc_pr(factor(c(1), levels=1:2), c(0.5) )
  expect_equal( roc, NA_real_ )
})

test_that("auc_pr returns a number when only one class", {
  roc <- auc_pr(factor(c(1,1,1), levels=1:2), c(0.5, 0.3, 0.25) )
  expect_equal( roc, NA_real_ )
})

test_that("auc_pr returns a number when more than 1 value", {
  roc <- auc_pr(factor(c(1,2), levels=1:2), c(0.5, 0.3) )
  expect_equal( roc, 0.25 )
})


#RUN dipbugs**.r WITH NO SEED UP TO SAMPLING, THEN THIS

#ch <- 1

## NEEDED TO RUN IN JAGS INSTEAD OF BUGS (ABSTENTIONS AND ABSENCES AS MISSING)
#rc <- apply(rc, 2, recode, recodes="-1=0; 0=NA")

## ## SORT BY PARTY 60th
## tmp <- 1:dim(rc)[1]
## tmp <- ifelse ( dipdat$part=="pan", tmp,
##         ifelse ( dipdat$part=="pri", tmp+1000,
##          ifelse ( dipdat$part=="prd", tmp+2000,
##           ifelse ( dipdat$part=="pt", tmp+3000,
##            ifelse ( dipdat$part=="pvem", tmp+4000,
##             ifelse ( dipdat$part=="conve", tmp+5000,
##              ifelse ( dipdat$part=="panal", tmp+6000,
##               ifelse ( dipdat$part=="psd", tmp+7000, tmp+8000 ))))))))
## ## rcold <- rc; dipold <- dipdat
## rc <- rc[,order(tmp)]; dipdat <- dipdat[order(tmp),]
## ## PARTY INDICES (FOR ANCHORS)
## PAN <- length(tmp[tmp<1001]); PRI <- PAN+length(tmp[tmp>1000&tmp<2001]);
## PRD <- PRI+length(tmp[tmp>2000&tmp<3001]); PT <- PRD+length(tmp[tmp>3000&tmp<4001])
## PVEM <- PT+length(tmp[tmp>4000&tmp<5001]); CONVE <- PVEM+length(tmp[tmp>5000&tmp<6001])
## PANAL <- CONVE+length(tmp[tmp>6000&tmp<7001]); PSD <- PANAL+length(tmp[tmp>7000&tmp<8001])

## SORT BY PARTY 61st
tmp <- 1:nrow(rc)
tmp <- ifelse ( dipdat$part=="pan", tmp,
        ifelse ( dipdat$part=="pri", tmp+1000,
         ifelse ( dipdat$part=="prd", tmp+2000,
          ifelse ( dipdat$part=="pt", tmp+3000,
           ifelse ( dipdat$part=="pvem", tmp+4000,
            ifelse ( dipdat$part=="conve", tmp+5000,
             ifelse ( dipdat$part=="panal", tmp+6000, tmp+7000 )))))))
rc <- rc[,order(tmp)]; dipdat <- dipdat[order(tmp),]
## PARTY INDICES (FOR ANCHORS)
PAN <- length(tmp[tmp<1001]); PRI <- PAN+length(tmp[tmp>1000&tmp<2001]);
PRD <- PRI+length(tmp[tmp>2000&tmp<3001]); PT <- PRD+length(tmp[tmp>3000&tmp<4001])
PVEM <- PT+length(tmp[tmp>4000&tmp<5001]); CONVE <- PVEM+length(tmp[tmp>5000&tmp<6001])
PANAL <- CONVE+length(tmp[tmp>6000&tmp<7001])

## DROPS VOTES NOT IN GACETA
#rcG <- rc[dgaceta==1,]
#votdatG <- votdat[dgaceta==1,]

## USED FOR SEED IN SEPARATE RUNS
#set.seed(round(ch*runif(1)*1000))
#runif(1) ## RANDOM NUMBER TO CHECK

##### LOADS SAVED RUNS
###load("loops5k.RData")

## BUGS VERSION
#####################################################################################
###   Static 2Dimensions, arbitrary three party-anchors, irt paremeterization     ###
#####################################################################################
#
## ## FOR 60th
## cat("
## model {
##   for (j in 1:J){                ## loop over diputados
##     for (i in 1:I){              ## loop over items
##       #v.hat[j,i] ~ dbern(p[j,i]);                                  ## voting rule
##       #p[j,i] <- phi(v.star[j,i]);                                  ## sets 0<p<1
##       v.star[j,i] ~ dnorm(mu[j,i],1)I(lo.v[j,i],hi.v[j,i]);   ## truncated normal sampling
##       mu[j,i] <- beta[i]*x[j] - alpha[i] + delta[i]*y[j] ## utility differential
##                   }
##                 }
## ## ESTO LO PUEDO SACAR POST ESTIMACION
## ##  for (i in 1:I){
## ##  a[i] <- beta[i] / delta[i]  ## pendiente de cutline
## ##  b[i] <- alpha[i] / delta[i] ## constante de cutline
## ##  }
##   ## priors ################
## for (j in 1:PAN){
##     x[j] ~  dnorm(1, 4)   # PAN
##     y[j] ~  dnorm(-1, 4)
##     }
## for (j in (PAN+1):PRI){
##     x[j] ~  dnorm(0, 4)    # PRI
##     y[j] ~  dnorm(.5, 4)
##     }
## for (j in (PRI+1):PRD){
##     x[j] ~  dnorm(-1, 4)    # PRD SEMI-INFORMATIVE
##     y[j] ~  dnorm(0, .1)
##     }
## for (j in (PRD+1):PVEM){
##     x[j] ~  dnorm(0, .1)    # REST UNINFORMATIVE
##     y[j] ~  dnorm(0, .1)
##     }
## for (j in (PVEM+1):CONVE){
##     x[j] ~  dnorm(-1, 4)    # CONVE
##     y[j] ~  dnorm(1, 4)
##     }
## for (j in (CONVE+1):J){
##     x[j] ~  dnorm(0, .1)    # REST UNINFORMATIVE
##     y[j] ~  dnorm(0, .1)
##     }
##     for(i in 1:I){
##         alpha[i] ~ dnorm( 0, 1)
##         beta[i]  ~ dnorm( 0, 1)
##         delta[i] ~ dnorm( 0, 1)
##                  }
## }
## ", file="model2Dj.irt.txt")
#
### FOR 61st
cat("
model {
  for (j in 1:J){                ## loop over diputados
    for (i in 1:I){              ## loop over items
      #v.hat[j,i] ~ dbern(p[j,i]);                                  ## voting rule
      #p[j,i] <- phi(v.star[j,i]);                                  ## sets 0<p<1
      v.star[j,i] ~ dnorm(mu[j,i],1)I(lo.v[j,i],hi.v[j,i]);   ## truncated normal sampling
      mu[j,i] <- beta[i]*x[j] - alpha[i] + delta[i]*y[j] ## utility differential
                  }
                }
## ESTO LO PUEDO SACAR POST ESTIMACION
##  for (i in 1:I){
##  a[i] <- beta[i] / delta[i]  ## pendiente de cutline
##  b[i] <- alpha[i] / delta[i] ## constante de cutline
##  }
  ## priors ################
for (j in 1:PAN){
    x[j] ~  dnorm(1, 4)   # PAN
    y[j] ~  dnorm(-1, 4)
    }
for (j in (PAN+1):PRI){
    x[j] ~  dnorm(0, 4)    # PRI
    y[j] ~  dnorm(1, 4)
    }
for (j in (PRI+1):PRD){
    x[j] ~  dnorm(-1, 4)    # PRD
    y[j] ~  dnorm(0, 1)
    }
for (j in (PRD+1):PT){
    x[j] ~  dnorm(-1, 4)    # PT
    y[j] ~  dnorm(-1, 4)
    }
for (j in (PT+1):J){
    x[j] ~  dnorm(0, .1)    # REST UNINFORMATIVE
    y[j] ~  dnorm(0, .1)
    }
    for(i in 1:I){
        alpha[i] ~ dnorm( 0, 1)
        beta[i]  ~ dnorm( 0, 1)
        delta[i] ~ dnorm( 0, 1)
                 }
}
", file="model2Dj.irt.txt")

## ## JAGS VERSION
## #####################################################################################
## ###   Static 2Dimensions, arbitrary three party-anchors, irt paremeterization     ###
## #####################################################################################
## ##
## ## FOR 60th
## cat("
## model {
##   for (j in 1:J){                                             ## loop over diputados
##     for (i in 1:I){                                           ## loop over items
##       v[j,i] ~ dbern(p[j,i]);                                 ## voting rule
##       probit(p[j,i]) <- mu[j,i];                              ## sets 0<p<1
##       mu[j,i] <- beta[i]*x[j] - alpha[i] + delta[i]*y[j]      ## utility differential
##                   }
##                 }
## ## ESTO LO PUEDO SACAR POST ESTIMACION
## ##  for (i in 1:I){
## ##  a[i] <- beta[i] / delta[i]  ## pendiente de cutline
## ##  b[i] <- alpha[i] / delta[i] ## constante de cutline
## ##  }
##   ## priors ################
## for (j in 1:PAN){
##     x[j] ~  dnorm(1, 4)   # PAN
##     y[j] ~  dnorm(-1, 4)
##     }
## for (j in (PAN+1):PRI){
##     x[j] ~  dnorm(0, 4)    # PRI
##     y[j] ~  dnorm(.5, 4)
##     }
## for (j in (PRI+1):PRD){
##     x[j] ~  dnorm(-1, 4)    # PRD SEMI-INFORMATIVE
##     y[j] ~  dnorm(0, .1)
##     }
## for (j in (PRD+1):PVEM){
##     x[j] ~  dnorm(0, .1)    # REST UNINFORMATIVE
##     y[j] ~  dnorm(0, .1)
##     }
## for (j in (PVEM+1):CONVE){
##     x[j] ~  dnorm(-1, 4)    # CONVE
##     y[j] ~  dnorm(1, 4)
##     }
## for (j in (CONVE+1):J){
##     x[j] ~  dnorm(0, .1)    # REST UNINFORMATIVE
##     y[j] ~  dnorm(0, .1)
##     }
##     for(i in 1:I){
##         alpha[i] ~ dnorm( 0, 1)
##         beta[i]  ~ dnorm( 0, 1)
##         delta[i] ~ dnorm( 0, 1)
##                  }
## }
## ", file="model2Dj.irt.txt")
## ##
## ###FOR 61st
## ###cat("
## ###model {
## ###  for (j in 1:J){                                             ## loop over diputados
## ###    for (i in 1:I){                                           ## loop over items
## ###      v[j,i] ~ dbern(p[j,i]);                                 ## voting rule
## ###      probit(p[j,i]) <- mu[j,i];                              ## sets 0<p<1
## ###      mu[j,i] <- beta[i]*x[j] - alpha[i] + delta[i]*y[j]      ## utility differential
## ###                  }
## ###                }
## ##### ESTO LO PUEDO SACAR POST ESTIMACION
## #####  for (i in 1:I){
## #####  a[i] <- beta[i] / delta[i]  ## pendiente de cutline
## #####  b[i] <- alpha[i] / delta[i] ## constante de cutline
## #####  }
## ###  ## priors ################
## ###for (j in 1:PAN){
## ###    x[j] ~  dnorm(1, 4)   # PAN
## ###    y[j] ~  dnorm(-1, 4)
## ###    }
## ###for (j in (PAN+1):PRI){
## ###    x[j] ~  dnorm(0, 4)    # PRI
## ###    y[j] ~  dnorm(1, 4)
## ###    }
## ###for (j in (PRI+1):PRD){
## ###    x[j] ~  dnorm(-1, 4)    # PRD
## ###    y[j] ~  dnorm(-1, 4)
## ###    }
## ###for (j in (PRD+1):J){
## ###    x[j] ~  dnorm(0, .1)    # REST UNINFORMATIVE
## ###    y[j] ~  dnorm(0, .1)
## ###    }
## ###    for(i in 1:I){
## ###        alpha[i] ~ dnorm( 0, 1)
## ###        beta[i]  ~ dnorm( 0, 1)
## ###        delta[i] ~ dnorm( 0, 1)
## ###                 }
## ###}
## ###", file="model2Dj.irt.txt")

myrun <- function (data=rc, votdat.data=votdat, sample.size=50)
{
start.time <- proc.time()
#### WORK WITH VOTE SAMPLE
sel <- sample(votdat.data$votid, size=sample.size); sel <- sel[order(sel)]
data <- data[votdat.data$votid %in% sel,]
votdat.data <- votdat.data[votdat.data$votid %in% sel,]
###rnd <- runif(nrow(rcG))
###rcG <- rcG[rnd<sample.size,]
###votdatG <- votdatG[rnd<sample.size,]
#rm(rnd)
J <- ncol(data); I <- nrow(data)
##
v <- data
v <- t(v)
#J <- nrow(v); I <- ncol(v)
lo.v <- ifelse(is.na(v)==TRUE | v== 1, 0, -5)
hi.v <- ifelse(is.na(v)==TRUE | v==-1,  0, 5)
vstar <- matrix (NA, nrow=J, ncol=I)
for (j in 1:J){
for (i in 1:I){
  vstar[j,i] <- ifelse(v[j,i]==0, 0, ifelse(v[j,i]==1, runif(1), -1*runif(1)))}}
rm(v)
ip.data <- list ("J", "I", "lo.v", "hi.v", "PAN", "PRI", "PRD", "PT")
ip.inits <- function (){
    list (
    v.star=vstar,
    delta=rnorm(I),
    alpha=rnorm(I),
    beta=rnorm(I),
    x=rnorm(J),
    y=rnorm(J)
    )
    }
ip.parameters <- c("delta","beta", "alpha", "x", "y") #, "deviance")
#
results <- bugs (ip.data, ip.inits, ip.parameters,
                "model2Dj.irt.txt", n.chains=2,
                n.iter=6000, n.burnin=4000, n.thin=20, debug=F,
#                bugs.seed = ch*10000,
                bugs.directory = "c:/Program Files (x86)/WinBUGS14/",
#                bugs.directory = "c:/Archivos de programa/WinBUGS14/",
                program = c("WinBUGS")
                )
time.elapsed <- round(((proc.time()-start.time)[3])/60/60,2); rm(start.time)
print(cat("\tTime elapsed in estimation:",time.elapsed,"hours","\n"))
res <- list("results"<-results, "sample"=sel)
return(res)
}

for (l in 26:33){
    print(paste("Loop G", l))
    results <- myrun(data=rcG, votdat.data=votdatG)
    assign(paste("resG", 33*(ch-1)+l, sep=""), results)
    }

third <- 1 # or 2 or 3
l <- 1
for (l in 1:33){
    print(paste("Loop", l))
    results <- myrun(data=rc, votdat.data=votdat)
    assign(paste("res", 33*(third-1)+l, sep=""), results)
    }

## LOAD DATA FOR POST ESTIMATION ANALYSIS

rm(list=ls())
#workdir <- c("/media/shared/01/Dropbox/data/rollcall/dipMex")
workdir <- c("~/Dropbox/data/rollcall/dipMex")
#workdir <- c("d:/01/Dropbox/data/rollcall/dipMex")
#workdir <- c("C:/Documents and Settings/emagarm/Mis documentos/My Dropbox/data/rollcall/dipMex")
#workdir <- c("C:/Documents and Settings/emm/Mis documentos/My Dropbox/data/rollcall/dipMex")
setwd(workdir)
#
#### IMPORT IDEAL POINTS ESTIMATED WITH ALL DATA
## 60th
load(file="ip60_5+5k.RData")
results <- list(results, results.2, results.3)
rm(results.2, results.3)
chains <- list ( results[[1]]$sims.matrix, results[[2]]$sims.matrix, results[[3]]$sims.matrix )
chains <- rbind(chains[[1]],chains[[2]],chains[[3]])
tmpx <-  chains[,grep(colnames(chains),pattern = "x")]
tmpy <-  chains[,grep(colnames(chains),pattern = "y")]
ips.x.60 <- rep(NA,times=ncol(tmpx)); ips.y.60 <- rep(NA,times=ncol(tmpx));
for (j in 1:ncol(tmpx)){
  ips.x.60[j] <- quantile (tmpx[,j], 0.5, names=F);
  ips.y.60[j] <- quantile (tmpx[,j], 0.5, names=F)
}
load(file="ip60_5+5k_gaceta.RData")
results <- list(results, results.2, results.3)
rm(results.2, results.3)
chains <- list ( results[[1]]$sims.matrix, results[[2]]$sims.matrix, results[[3]]$sims.matrix )
chains <- rbind(chains[[1]],chains[[2]],chains[[3]])
tmpx <-  chains[,grep(colnames(chains),pattern = "x")]
tmpy <-  chains[,grep(colnames(chains),pattern = "y")]
ips.g.x.60 <- rep(NA,times=ncol(tmpx)); ips.g.y.60 <- rep(NA,times=ncol(tmpx));
for (j in 1:ncol(tmpx)){
  ips.g.x.60[j] <- quantile (tmpx[,j], 0.5, names=F);
  ips.g.y.60[j] <- quantile (tmpy[,j], 0.5, names=F)
}

## 61st
load(file="ip61_2Dj_5+5k.RData")
ips.x.61 <- results$median$x
ips.y.61 <- results$median$y
rm(ch,chains,color.list,CONVE,count.votes,dgaceta,dipdat,dmember,hi.v,i,I,ip.data,ip.inits,ip.parameters,j,J,lo.v,PAN,PANAL,part.list,PRD,PRI,PSD,PT,PVEM,rc,results,time.elapsed,tmp,tmpx,tmpy,votdat,vstar)
#
load(file="ip61_2Dj_5+5k_gaceta.RData")
ips.g.x.61 <- results$median$x
ips.g.y.61 <- results$median$y
rm(color.list,CONVE,count.votes,dgaceta,dipdat,dmember,hi.v,i,I,ip.data,ip.inits,ip.parameters,j,J,lo.v,PAN,PANAL,part.list,PRD,PRI,PT,PVEM,rc,results,time.elapsed,tmp,votdat,vstar)
## NEEDS TO BE RE SET PROPERLY
#workdir <- c("/media/shared/01/Dropbox/data/rollcall/dipMex")
workdir <- c("~/Dropbox/data/rollcall/dipMex")
#workdir <- c("d:/01/Dropbox/data/rollcall/dipMex")
#workdir <- c("C:/Documents and Settings/emagarm/Mis documentos/My Dropbox/data/rollcall/dipMex")
#workdir <- c("C:/Documents and Settings/emm/Mis documentos/My Dropbox/data/rollcall/dipMex")

load("loops6k_60.RData")
#load("loops6k_61.RData")
workdir <- c("~/Dropbox/data/rollcall/dipMex")

resall <- list(res1 , res2 , res3 , res4 , res5 , res6 , res7 , res8 , res9 , res10, res11, res12, res13, res14, res15, res16, res17, res18, res19, res20, res21, res22, res23, res24, res25, res26, res27, res28, res29, res30, res31, res32, res33, res34, res35, res36, res37, res38, res39, res40, res41, res42, res43, res44, res45, res46, res47, res48, res49, res50, res51, res52, res53, res54, res55, res56, res57, res58, res59, res60, res61, res62, res63, res64, res65, res66, res67, res68, res69, res70, res71, res72, res73, res74, res75, res76, res77, res78, res79, res80, res81, res82, res83, res84, res85, res86, res87, res88, res89, res90, res91, res92, res93, res94, res95, res96, res97, res98, res99)

## point.x.all <- resall[[1]]$median$x
## point.x.allG <- resGall[[1]]$median$x
## point.y.all <- resall[[1]]$median$y
## point.y.allG <- resGall[[1]]$median$y

mi <- min(c(point.x.all, point.x.allG)); ma <- max(c(point.x.all, point.x.allG))
#par(mai=c(.4, .4, .4, .4)) ## SETS B L U R MARGIN SIZES
plot(c(mi,ma), c(mi,ma), type="n",
#           xlab="",
#           ylab="",
#           xaxt="n",
#           yaxt="n",
           xlab=c("1st dim. All votes"),
           ylab=c("1st dim. Gaceta votes only"),
           main="60th Legislature")
#           main="")
abline(0,1)
points(point.x.all, point.x.allG, pch=19, cex=.75, col=dipdat$color)

mi <- min(c(point.y.all, point.y.allG)); ma <- max(c(point.y.all, point.y.allG))
#par(mai=c(.4, .4, .4, .4)) ## SETS B L U R MARGIN SIZES
plot(c(mi,ma), c(mi,ma), type="n",
#           xlab="",
#           ylab="",
#           xaxt="n",
#           yaxt="n",
           xlab=c("2nd dim. All votes"),
           ylab=c("2nd dim. Gaceta votes only"),
           main="60th Legislature")
#           main="")
abline(0,1)
points(point.y.all, point.y.allG, pch=19, cex=.75, col=dipdat$color)
legend(1.8,-1.5, legend=part.list, cex=.75, pch=20, pt.cex=1.25, col=color.list, bg="white")

## 1st DIMENSION
myplot <- function(X)
    {
    tmp0 <- rep(0, 99)  ## TO RECEIVE COUNT OF THETAS BEYOND 95% CIs
    plot(c(1,99), c(-4,4), type="n",
               xlab="Sample of Gaceta votes only",
               ylab="Deviation from theta",
               main=paste("1st dim.", dipdat$part[X], "-", dipdat$id[X]))
    abline(0,0)
    for (l in 1:99){
        tmp <- get(paste("resG", l, sep=""))
        tmp <- tmp[[1]]$sims.list$x[,X]             ## COORDENADAS DEL DIP j EN LOOP l
    #    points(rep(l,100), tmp-point.x.all[X], pch=19, cex=.25, col=dipdat$color[X])
        tmp2 <- quantile (tmp-point.x.all[X], 0.025, names=F)
        tmp3 <- quantile (tmp-point.x.all[X], 0.975, names=F)
        if (tmp3<0 | tmp2>0){tmp0[l] <- 1}
        lines(c(l,l), c(tmp2,tmp3), lwd=.25)#, col=dipdat$color[X])
        tmp2 <- quantile (tmp-point.x.all[X], 0.25, names=F)
        tmp3 <- quantile (tmp-point.x.all[X], 0.75, names=F)
        lines(c(l,l), c(tmp2,tmp3), lwd=1)#, col=dipdat$color[X])
        }
    text(80,4, labels=paste("N off limits:", sum(tmp0)))
    }

j <- 450
myplot(j)

setwd("d:/01/Dropbox/MexRollCalls/graphs/thetaVSsampleG")
for (j in 1:ncol(rc))
    {
    pdf( paste("dim1-", j, ".pdf", sep=""))
    myplot(j)
    dev.off()
    }
setwd(workdir)

## 2nd DIMENSION
myplot <- function(X)
    {
    tmp0 <- rep(0, 99)  ## TO RECEIVE COUNT OF THETAS BEYOND 95% CIs
    plot(c(1,99), c(-4,4), type="n",
               xlab="Sample of Gaceta votes only",
               ylab="Deviation from theta",
               main=paste("2nd dim.", dipdat$part[X], "-", dipdat$id[X]))
    abline(0,0)
    for (l in 1:99){
        tmp <- get(paste("resG", l, sep=""))
        tmp <- tmp[[1]]$sims.list$y[,X]             ## COORDENADAS DEL DIP j EN LOOP l
    #    points(rep(l,100), tmp-point.y.all[X], pch=19, cex=.25, col=dipdat$color[X])
        tmp2 <- quantile (tmp-point.y.all[X], 0.025, names=F)
        tmp3 <- quantile (tmp-point.y.all[X], 0.975, names=F)
        if (tmp3<0 | tmp2>0){tmp0[l] <- 1}
        lines(c(l,l), c(tmp2,tmp3), lwd=.25)#, col=dipdat$color[X])
        tmp2 <- quantile (tmp-point.y.all[X], 0.25, names=F)
        tmp3 <- quantile (tmp-point.y.all[X], 0.75, names=F)
        lines(c(l,l), c(tmp2,tmp3), lwd=1)#, col=dipdat$color[X])
        }
    text(80,4, labels=paste("N off limits:", sum(tmp0)))
    }

j <- 450
myplot(j)

setwd("d:/01/Dropbox/MexRollCalls/graphs/thetaVSsampleG")
for (j in 1:ncol(rc))
    {
    pdf( paste("dim2-", j, ".pdf", sep=""))
    myplot(j)
    dev.off()
    }
setwd(workdir)

## GRAPH TO REPORT
j <- 100
#setwd(paste(workdir, "/graphs/", sep=""))
#pdf(file="tmp.pdf", width=10, height=5)
plot(c(1,ncol(rc)), c(-7,7), type="n",
#plot(c(1,150), c(-4,4), type="n",
#           xlab="Rank-ordered deputies (by gaceta-only coordinate)",
#           ylab="Samples net of gaceta-only coordinate",
           xlab="Diputados ordenados por coordenada (sólo Gaceta)",
           ylab="Cambio de coordenada en la muestra",
#           ylab="Deviation from gaceta-only coordinate",
#           main=paste("1st dimension"))
           main=paste("1a dimensión"))
abline(0,0)
ord <- rank(ips.g.x.61) # point.x.all)                           ## FOR RANK-ORDERING
for (j in c(1:length(ord))[order(ord)]){
#for (j in c(1:ncol(rc))[order(ord)]){
#for (j in c(1:150)[order(ord)]){
    tmp0 <- res1[[1]]$sims.list$x[,j]             ## COORDENADAS DEL DIP j EN LOOP 1
    for (l in 2:99){
        tmp <- get(paste("res", l, sep=""))
        tmp <- tmp[[1]]$sims.list$x[,j]             ## COORDENADAS DEL DIP j EN LOOP l
        tmp0 <- c(tmp0, tmp)                        ## COORDENADAS DEL DIP j EN TODOS LOS LOOPS
        }
    tmp2 <- quantile (tmp0-ips.g.x.61[j], 0.025, names=F)
    tmp3 <- quantile (tmp0-ips.g.x.61[j], 0.975, names=F)
    lines(c(ord[j],ord[j]), c(tmp2,tmp3), lwd=.25, col=dipdat$color[j])
    tmp2 <- quantile (tmp0-ips.g.x.61[j], 0.25, names=F)
    tmp3 <- quantile (tmp0-ips.g.x.61[j], 0.75, names=F)
    lines(c(ord[j],ord[j]), c(tmp2,tmp3), lwd=1, col=dipdat$color[j])
    }
#dev.off()
setwd(workdir)

j <- 100
setwd(paste(workdir, "/graphs/", sep=""))
pdf(file="tmp.pdf", width=10, height=5)
#plot(c(1,ncol(rc)), c(-6,8), type="n",
plot(c(1,ncol(rc)), c(-7,7), type="n",
#plot(c(1,150), c(-7,7), type="n",
#           xlab="Rank-ordered deputies (by gaceta-only coordinate)",
#           ylab="Samples net of gaceta-only coordinate",
           xlab="Diputados ordenados por coordenada (sólo Gaceta)",
           ylab="Cambio de coordenada en la muestra",
#           ylab="Deviation from gaceta-only coordinate",
#           main=paste("2nd dimension"))
           main=paste("2a dimensión"))
abline(0,0)
ord <- rank(ips.g.y.61) # point.y.all)                           ## FOR RANK-ORDERING
for (j in c(1:length(ord))[order(ord)]){
#for (j in c(1:150)[order(ord)]){
    tmp0 <- res1[[1]]$sims.list$y[,j]             ## COORDENADAS DEL DIP j EN LOOP 1
    for (l in 2:99){
        tmp <- get(paste("res", l, sep=""))
        tmp <- tmp[[1]]$sims.list$y[,j]             ## COORDENADAS DEL DIP j EN LOOP l
        tmp0 <- c(tmp0, tmp)                        ## COORDENADAS DEL DIP j EN TODOS LOS LOOPS
        }
    tmp2 <- quantile (tmp0-ips.g.y.61[j], 0.025, names=F)
    tmp3 <- quantile (tmp0-ips.g.y.61[j], 0.975, names=F)
    lines(c(ord[j],ord[j]), c(tmp2,tmp3), lwd=.25, col=dipdat$color[j])
    tmp2 <- quantile (tmp0-ips.g.y.61[j], 0.25, names=F)
    tmp3 <- quantile (tmp0-ips.g.y.61[j], 0.75, names=F)
    lines(c(ord[j],ord[j]), c(tmp2,tmp3), lwd=1, col=dipdat$color[j])
    }
dev.off()
setwd(workdir)

myplot <- function(X)
    {
    tmp0 <- rep(0, 99)  ## TO RECEIVE COUNT OF THETAS BEYOND 95% CIs
    plot(c(1,99), c(-4,4), type="n",
               xlab="Sample of Gaceta votes only",
               ylab="Deviation from theta",
               main=paste("1st dim.", dipdat$part[X], "-", dipdat$id[X]))
    abline(0,0)
    for (l in 1:99){
        tmp <- get(paste("resG", l, sep=""))
        tmp <- tmp[[1]]$sims.list$x[,X]             ## COORDENADAS DEL DIP j EN LOOP l
    #    points(rep(l,100), tmp-point.x.all[X], pch=19, cex=.25, col=dipdat$color[X])
        tmp2 <- quantile (tmp-point.x.all[X], 0.025, names=F)
        tmp3 <- quantile (tmp-point.x.all[X], 0.975, names=F)
        if (tmp3<0 | tmp2>0){tmp0[l] <- 1}
        lines(c(l,l), c(tmp2,tmp3), lwd=.25)#, col=dipdat$color[X])
        tmp2 <- quantile (tmp-point.x.all[X], 0.25, names=F)
        tmp3 <- quantile (tmp-point.x.all[X], 0.75, names=F)
        lines(c(l,l), c(tmp2,tmp3), lwd=1)#, col=dipdat$color[X])
        }
    text(80,4, labels=paste("N off limits:", sum(tmp0)))
    }

j <- 450
myplot(j)


#!/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()


library(lubridate)
options(lubridate.week.start=1)

days<-500
users<-100
workstations<-110
sources<-70

testset<-data.frame()
users_names<-sample(10001:10000000,size=users)
workstations_names<-sample(10001:10000000,size=workstations)
sources_names<-sample(10001:10000000,size=sources)

connection_type<-function(first_time,users_normal,users_names_normal,testset,mid_day){
  type<-c()
  if(first_time){
    type<-sample(c(2,10),users_normal,replace = T,prob = c(0.95,0.05))
  }else{
    for(i in 1:users_normal){
      types<-testset[users_names_normal[i]==testset[,5] & (testset[,8]==2 | testset[,8]==10),8]
      count<-table(types)
      prefer<-as.numeric(names(which.max(count)))
      if(mid_day){
        if(prefer==10){
          type[i]<-10
        }else{
          x<-c(2,7,11)
          prob<-c(0.55,0.25,0.2)
          type[i]<-sample(x,1,replace = T,prob = prob)
        }
      }else{
        if(prefer==10){
          prob<-c(0.05,0.95)
        }else{
          prob<-c(0.95,0.05)
        }
        type[i]<-sample(c(2,10),1,replace = T,prob = prob)
      }
      }
  }
  return(type)
}

workstation_choose<-function(first_time,users_normal,user_names_normal,workstations_names,testset){
  workstation<-c()
  if(first_time){
    workstation<-sample(workstations_names,users_normal)
  }else{
    for(i in 1:users_normal){
      workstations<-testset[users_names_normal[i]==testset[,5] & (testset[,8] %in% c(2,7,10,11)),2]
      count<-as.data.frame(table(workstations))
      count<-count[order(count$Freq,decreasing = T),]
      count[,3]<-match(count[,1],workstations_names)
      prob<-c(sample(0.05/length(workstations_names),length(workstations_names),replace = T))
      prob_per_occur<-0.95/sum(count$Freq)
      for(j in 1:nrow(count)){
        prob[count[j,3]]<-prob_per_occur*count[j,2]
      }
      workstation[i]<-sample(workstations_names,1,prob=prob)
    }
  }
  return(workstation)
}

source_allocation<-function(type,users,sources_names,sources){
  source<-c()
  for(i in 1:users){
    if(type[i]==2 || type[i]==7 || type[i]==11){
      source[i]<-sources_names[1]
    }else{
      source[i]<-sample(sources_names[2:sources],1)
    }
  }
  return(source)
}

source_port_allocation<-function(source,users,sources_names){
  source_port<-c()
  for(i in 1:users){
    if(source[i]==sources_names[1]){
      source_port[i]<-0
    }else{
      source_port[i]<-sample(c(1024:65534),1)
    }
  }
  return(source_port)
}

build_group<-function(users){
  group<-sample(c(1,2,3,4),users,replace=T,prob = c(0.225,0.6,0.15,0.025))
  return(group)
}

build_sample<-function(users_normal,users_names_normal,workstations,workstations_names,sources,sources_names,first_time,testset,time,date,mid_day){
  type<-connection_type(first_time,users_normal,users_names_normal,testset,mid_day)
  workstation<-workstation_choose(first_time,users_normal,user_names_normal,workstations_names,testset)
  source<-source_allocation(type,users_normal,sources_names,sources)
  source_port<-source_port_allocation(source,users_normal,sources_names)
  datetime<-sapply(time,function(x){return(date+seconds(x))})
  datetime<-as_datetime(datetime)
  new_testset<-data.frame(Event_Typ=4624,Host=workstation,Date=datetime,ID=1,User=users_names_normal,Source=source,Source_Port=source_port,Logon_Type=type)
  testset<-rbind(testset,new_testset)
  return(testset)
}

build_sample_2<-function(users,users_names,workstations,workstations_names,sources,sources_names,first_time,testset,workstart,workend,lunchstart,lunchend,date,group){
  event_anzahl<-c()
  time_type<-c()
  for(i in 1:length(group)){
    if(group[i]==1){
      mean<-0
      sd<-0
      allday<-F
    }else if(group[i]==2){
      mean<-4
      sd<-2
      allday<-F
    }else if(group[i]==3){
      mean<-30
      sd<-10
      allday<-F
    }else{
      mean<-100
      sd<-20
      allday<-T
    }
    event_anzahl[i]<-round(rnorm(1,mean,sd),digits = 0)
    time_type[i]<-allday
  }

  for(i in 1:users){
    workstation<-c()
    source<-c()
    source_port<-c()
    if(event_anzahl[i]>0){
      workstation<-append(workstation,sample(workstations_names,replace=T,event_anzahl[i]))
      source<-append(source,sample(sources_names[2:sources],replace=T,event_anzahl[i]))
      source_port<-append(source_port,sample(c(1024:65534),replace=T,event_anzahl[i]))

      if(time_type[i]){
        time<-sample(c(1:86400),event_anzahl[i])
      }else{
        time<-sample(c(workstart[i]:lunchstart[i],lunchend[i]:workend[i]),event_anzahl[i])
      }

      datetime<-sapply(time,function(x){return(date+seconds(x))})
      datetime<-as_datetime(datetime)
      new_testset<-data.frame(Event_Typ=4624,Host=workstation,Date=datetime,ID=1,User=users_names[i],Source=source,Source_Port=source_port,Logon_Type=3)
      testset<-rbind(testset,new_testset)
    }
  }
  return(testset)
}

for (i in 1:days) {

  date<-as_datetime("2021-05-31")+days(i)

  mid_day<-F

  if(i==1){
    first_time<-T
    group<-build_group(users)
    users_not_normal<-which(group %in% 4)
    users_normal<-users-length(users_not_normal)
    users_names_normal<-users_names[-c(users_not_normal)]
  }else{
    first_time<-F
  }

  if(wday(date)!=6 && wday(date)!=7){
    workstart<-rnorm(users,mean=28800,sd=600)
    workstart_normal<-workstart[-c(users_not_normal)]
    testset<-build_sample(users_normal,users_names_normal,workstations,workstations_names,sources,sources_names,first_time,testset,workstart_normal,date,mid_day)
    first_time<-F
    mid_day<-T

    lunchstart<-rnorm(users,mean=45000,sd=1800)
    lunchstart_normal<-lunchstart[-c(users_not_normal)]
    lunchtime<-rnorm(users,mean = 1800,sd=300)
    lunchend<-lunchstart+lunchtime
    lunchend_normal<-lunchend[-c(users_not_normal)]
    testset<-build_sample(users_normal,users_names_normal,workstations,workstations_names,sources,sources_names,first_time,testset,lunchend_normal,date,mid_day)

    worktime<-rnorm(users,mean=28800,sd=300)
    workend<-workstart+worktime
    workend_normal<-workend[-c(users_not_normal)]
    testset<-build_sample_2(users,users_names,workstations,workstations_names,sources,sources_names,first_time,testset,workstart,workend,lunchstart,lunchend,date,group)

    for(j in 1:users_normal){
      breaks<-round(rnorm(1,mean=5,sd=2),digits = 0)
      if(breaks>0){
        break_time<-sample(c(workstart_normal[j]:lunchstart_normal[j],lunchend_normal[j]:workend_normal[j]),breaks)
        testset<-build_sample(breaks,rep(users_names_normal[j],breaks),workstations,workstations_names,sources,sources_names,first_time,testset,break_time,date,mid_day)
      }
    }
  }

}

write.table(testset,"/home/rmey/Dokumente/my_projekt/Testset/Version_3.csv",row.names = F,col.names = F,sep=",")

### Adding Testcases
library(lubridate)
options(lubridate.week.start=1) #Wochentag beginnt Montag
Sys.setenv(TZ='UTC')
## Viele Hosts bei einem Nutzer bei dem es untypisch ist, Version 2 nutzen
user_to_manipulate=1196840
testset<-rbind(testset,data.frame(Event_Typ=4624,Host=sample(workstations_names,1),Date="2021-06-15 08:00:00 UTC",ID=1,User=user_to_manipulate,Source=sources_names[1],Source_Port=0,Logon_Type=2))

#Hosts+1Tag
for(i in 1:50){
  datetime<-as_datetime(as_datetime("2021-06-15 00:00:00 UTC")+minutes(i*15))
  testset<-rbind(testset,data.frame(Event_Typ=4624,Host=sample(workstations_names,1),Date=datetime,ID=1,User=user_to_manipulate,Source=sources_names[1],Source_Port=0,Logon_Type=2))
}

#Host+ mehrere Tage hintereinander
for(j in 1:10){
  date<-as_datetime("2021-06-15 00:00:00 UTC")+days(j)
  if(wday(date)!=6 && wday(date)!=7){
    freq<-sample(30:70,1)
    for(i in 1:freq){
      datetime<-as_datetime(date+minutes(i*15))
      testset<-rbind(testset,data.frame(Event_Typ=4624,Host=sample(workstations_names,1),Date=datetime,ID=1,User=user_to_manipulate,Source=sources_names[1],Source_Port=0,Logon_Type=2))
    }
  }
}

#Host+ mehrere Tage, aber nicht hintereinander
for(j in 1:10){
  date<-as_datetime("2021-06-15 00:00:00 UTC")+days(j)
  active<-sample(c(1,0),1,prob=c(0.65,0.35))
  if(wday(date)!=6 && wday(date)!=7 && active){
    freq<-sample(30:70,1)
    for(i in 1:freq){
      datetime<-as_datetime(date+minutes(i*15))
      testset<-rbind(testset,data.frame(Event_Typ=4624,Host=sample(workstations_names,1),Date=datetime,ID=1,User=user_to_manipulate,Source=sources_names[1],Source_Port=0,Logon_Type=2))
    }
  }
}

## Untypische Nutzerzeiten, Version 3

#AM wocheende aktiv ein Event ein Tag
testset<-rbind(testset,data.frame(Event_Typ=4624,Host=sample(workstations_names,1),Date=as_datetime("2021-06-13 08:00:00 UTC"),ID=1,User=user_to_manipulate,Source=sources_names[1],Source_Port=0,Logon_Type=2))

#An einem Wocheend Tag, aber mehrere Events
for(i in 1:50){
  datetime<-as_datetime(as_datetime("2021-06-13 00:00:01 UTC")+minutes(i*15))
  testset<-rbind(testset,data.frame(Event_Typ=4624,Host=workstations_names[1],Date=datetime,ID=1,User=user_to_manipulate,Source=sources_names[1],Source_Port=0,Logon_Type=2))
}

#An mehreren Wocheendtagen
for(j in 1:14){
  date<-as_datetime("2021-06-15 00:00:00 UTC")+days(j)
  if(wday(date)==6 || wday(date)==7){
    freq<-sample(30:70,1)
    for(i in 1:freq){
      datetime<-as_datetime(date+minutes(i*15))
      testset<-rbind(testset,data.frame(Event_Typ=4624,Host=workstations_names[1],Date=datetime,ID=1,User=user_to_manipulate,Source=sources_names[1],Source_Port=0,Logon_Type=2))
    }
  }
}

#An mehreren Wocheendtagen nicht hintereinander
for(j in 1:14){
  date<-as_datetime("2021-06-15 00:00:00 UTC")+days(j)
  active<-sample(c(1,0),1,prob=c(0.65,0.35))
  if(wday(date)==6 || wday(date)==7){
    if(active==1){
      freq<-sample(30:70,1)
      for(i in 1:freq){
        datetime<-as_datetime(date+minutes(i*15))
        testset<-rbind(testset,data.frame(Event_Typ=4624,Host=sample(workstations_names,1),Date=datetime,ID=1,User=user_to_manipulate,Source=sources_names[1],Source_Port=0,Logon_Type=2))
      }
    }
  }
}

# Ein Event außerhalb der gewöhnlichen Arbeitszeit
testset<-rbind(testset,data.frame(Event_Typ=4624,Host=workstations_names[1],Date="2021-06-15 23:01:02 UTC",ID=1,User=user_to_manipulate,Source=sources_names[1],Source_Port=0,Logon_Type=2))

#Mehrere Events außerhalb der gewöhnlichen Arbeitszeit
for(i in 1:40){
  date<-as_datetime(as_datetime("2021-06-15 23:00:00 UTC")+minutes(i*2))
  testset<-rbind(testset,data.frame(Event_Typ=4624,Host=workstations_names[1],Date=date,ID=1,User=user_to_manipulate,Source=sources_names[1],Source_Port=0,Logon_Type=2))
}

#Mehrere Events, außerhalb der Arbeitszeit an mehreren Tagen
for(j in 1:10){
  date<-as_datetime("2021-06-15 22:00:00 UTC")+days(j)
  if(wday(date)!=6 && wday(date)!=7){
    freq<-sample(30:70,1)
    for(i in 1:freq){
      datetime<-as_datetime(date+minutes(i*15))
      testset<-rbind(testset,data.frame(Event_Typ=4624,Host=workstations_names[1],Date=datetime,ID=1,User=user_to_manipulate,Source=sources_names[1],Source_Port=0,Logon_Type=2))
    }
  }
}

# Ein Event außerhalb der Arbeitszeit aller zwei Stunde beginn 16:00
n<-0
for (i in seq(0,16,2)){
  n<-n+1
  x<-rbind(testset,data.frame(Event_Typ=4624,Host=3779310,Date=as_datetime("2021-06-15 16:00:01 UTC")+hours(i),ID=1,User=user_to_manipulate,Source=sources_names[1],Source_Port=0,Logon_Type=2))
  write.table(x,paste("/home/rmey/Dokumente/my_projekt/Testset/Version_3_Testcase_9_",n,".csv",sep=""),row.names = F,col.names = F,sep=",")
}

##Verhaltenswechsel von Interactive zu Remote

#Ein Remote Event
testset<-testset[!(testset$User==user_to_manipulate & date(testset$Date)=="2021-06-15"),]
datetime<-as_datetime("2021-06-15 08:02:02 UTC")
testset<-rbind(testset,data.frame(Event_Typ=4624,Host=workstations_names[1],Date=datetime,ID=1,User=user_to_manipulate,Source=sources_names[1],Source_Port=0,Logon_Type=2))

datetime<-as_datetime("2021-06-15 11:02:02 UTC")
testset<-rbind(testset,data.frame(Event_Typ=4624,Host=workstations_names[1],Date=datetime,ID=1,User=user_to_manipulate,Source=sources_names[2],Source_Port=49992,Logon_Type=10))

#Mehrere Remotes ein Tag
testset<-testset[!(testset$User==user_to_manipulate & date(testset$Date)=="2021-06-15"),]
datetime<-as_datetime("2021-06-15 08:02:02 UTC")
testset<-rbind(testset,data.frame(Event_Typ=4624,Host=workstations_names[1],Date=datetime,ID=1,User=user_to_manipulate,Source=sources_names[1],Source_Port=0,Logon_Type=2))

for(i in 1:20){
  datetime<-as_datetime("2021-06-15 10:02:02 UTC")+minutes(sample(1:420,1))
  testset<-rbind(testset,data.frame(Event_Typ=4624,Host=workstations_names[2],Date=datetime,ID=1,User=user_to_manipulate,Source=sources_names[2],Source_Port=sample(c(1024:65534),1),Logon_Type=10))
}

# Nutzer ist zwei Wochen weg

testset<-testset[!(testset$User==user_to_manipulate & testset$Date>=as.Date("2021-06-14 00:00:00 UTC") & testset$Date <=as.Date("2021-06-27 23:59:59 UTC")),]

# Alle Nutzer fallen weg einer bleibt da an einem Tag
`%notin%` <- Negate(`%in%`)
testset<-testset[!(testset$User %notin% (user_to_manipulate) & testset$Date>=as.Date("2021-06-14 00:00:00 UTC") & testset$Date<as.Date("2021-06-15 00:00:00 UTC")),]

# Zeitumstellung aller Nutzer ab dem 28.06 annahme es exsitieren zwei Standorte eine in dd (~30%)

german_location_workers<-sample(users_names_normal,30)
needs_rework<-testset[testset$User %in% german_location_workers & testset$Date >=as.Date("2021-06-28 00:00:00 UTC"),]
testset<-testset[!(testset$User %in% german_location_workers & testset$Date >=as.Date("2021-06-28 00:00:00 UTC")),]

for(i in 1:nrow(needs_rework)){
  needs_rework[i,3]<-as_datetime(needs_rework[i,3])+hours(1)
}

testset<-rbind(testset,needs_rework)

write.table(data.frame(german_location_workers),"/home/rmey/Dokumente/my_projekt/Testset/Version_3_Testcase_16_german_workers.csv",row.names = F,col.names = F,sep=",")

# Auswerten dessen

result<-read.csv("/home/rmey/Dokumente/FindMaliciousEvents_235/Ergebnisse.csv")
result_without_manipulation<-read.csv("/home/rmey/Dokumente/FindMaliciousEvents_232/Ergebnisse.csv")
workers<-read.csv("/home/rmey/Dokumente/my_projekt/Testset/Version_3_Testcase_16_german_workers.csv",header = F)
result[,1]<-sub("^X","",sub("\\.[0-9]*$","",result[,1]))
result_without_manipulation[,1]<-sub("^X","",sub("\\.[0-9]*$","",result_without_manipulation[,1]))

position<-data.frame()
for(i in 1:nrow(workers)){
  position[i,1]<-which(result$X==workers[i,1])-which(result_without_manipulation$X==workers[i,1])
}
colMeans(position)

# Nutzer wechselt vollständig ins Home-Office ab dem 05.06.2021
testset<-testset[!(testset$User==user_to_manipulate & testset$Date>=as.Date("2021-06-05 00:00:00 UTC")),]

for (i in 5:days) {

  date<-as_datetime("2021-05-31")+days(i)

  mid_day<-F

  if(wday(date)!=6 && wday(date)!=7){
    workstart<-rnorm(1,mean=28800,sd=600)
    testset<-rbind(testset,data.frame(Event_Typ=4624,Host=workstations_names[2],Date=as_datetime(date+seconds(workstart)),ID=1,User=user_to_manipulate,Source=sources_names[2],Source_Port=sample(c(1024:65534),1),Logon_Type=10))
    first_time<-F
    mid_day<-T

    lunchstart<-rnorm(1,mean=45000,sd=1800)
    lunchtime<-rnorm(1,mean = 1800,sd=300)
    lunchend<-lunchstart+lunchtime
    testset<-rbind(testset,data.frame(Event_Typ=4624,Host=workstations_names[2],Date=as_datetime(date+seconds(lunchend)),ID=1,User=user_to_manipulate,Source=sources_names[2],Source_Port=sample(c(1024:65534),1),Logon_Type=10))

    worktime<-rnorm(users,mean=28800,sd=300)
    workend<-workstart+worktime

    for(j in 1:1){
      breaks<-round(rnorm(1,mean=5,sd=2),digits = 0)
      if(breaks>0){
        break_time<-sample(c(workstart[j]:lunchstart[j],lunchend[j]:workend[j]),breaks)
        testset<-rbind(testset,data.frame(Event_Typ=4624,Host=workstations_names[2],Date=as_datetime(date+seconds(break_time)),ID=1,User=user_to_manipulate,Source=sources_names[2],Source_Port=sample(c(1024:65534),1),Logon_Type=10))
      }
    }
  }

}

## EIn User wird zweifach verwendet ab dem 15.06.2021, nur zur hälfte in der Arbeitszeit, gleich zu den vorher Nutzer aktivitäten, nicht am WE
user_to_manipulate<-4346631
for (i in 15:days) {

  date<-as_datetime("2021-05-31")+days(i)

  mid_day<-F

  if(wday(date)!=6 && wday(date)!=7){
    workstart<-rnorm(1,mean=43200,sd=600)
    testset<-rbind(testset,data.frame(Event_Typ=4624,Host=workstations_names[2],Date=as_datetime(date+seconds(workstart)),ID=1,User=user_to_manipulate,Source=sources_names[2],Source_Port=sample(c(1024:65534),1),Logon_Type=10))
    first_time<-F
    mid_day<-T

    lunchstart<-rnorm(1,mean=57600,sd=1800)
    lunchtime<-rnorm(1,mean = 1800,sd=300)
    lunchend<-lunchstart+lunchtime
    testset<-rbind(testset,data.frame(Event_Typ=4624,Host=workstations_names[2],Date=as_datetime(date+seconds(lunchend)),ID=1,User=user_to_manipulate,Source=sources_names[2],Source_Port=sample(c(1024:65534),1),Logon_Type=10))

    worktime<-rnorm(users,mean=28800,sd=300)
    workend<-workstart+worktime

    for(j in 1:1){
      breaks<-round(rnorm(1,mean=5,sd=2),digits = 0)
      if(breaks>0){
        break_time<-sample(c(workstart[j]:lunchstart[j],lunchend[j]:workend[j]),breaks)
        testset<-rbind(testset,data.frame(Event_Typ=4624,Host=workstations_names[2],Date=as_datetime(date+seconds(break_time)),ID=1,User=user_to_manipulate,Source=sources_names[2],Source_Port=sample(c(1024:65534),1),Logon_Type=10))
      }
    }

    network<-round(rnorm(1,mean=5,sd=2),digits = 0)
    if(network>0){
      break_time<-sample(c(workstart[j]:lunchstart[j],lunchend[j]:workend[j]),network)
      testset<-rbind(testset,data.frame(Event_Typ=4624,Host=sample(workstations_names,network),Date=as_datetime(date+seconds(break_time)),ID=1,User=user_to_manipulate,Source=sources_names[2],Source_Port=sample(c(1024:65534),1),Logon_Type=3))
    }

  }

}

## Alle Hosts haben ab dem 15.06 einen neuen Nutzer mehr mit dem Event Typ 3 mit einem Event typ 3
user_to_manipulate<-1234567

for(i in 15:days){
  date<-as_datetime("2021-05-31")+days(i)
  for(j in workstations_names){
    date<-as_datetime(date+seconds(sample(0:86399,1)))
    testset<-rbind(testset,data.frame(Event_Typ=4624,Host=j,Date=date,ID=1,User=user_to_manipulate,Source=sources_names[2],Source_Port=sample(c(1024:65534),1),Logon_Type=3))
  }
}

result_without<-read.csv("/home/rmey/Dokumente/FindMaliciousEvents_351/Ergebnisse.csv")
result_with<-read.csv("/home/rmey/Dokumente/FindMaliciousEvents_356/Ergebnisse.csv")

result_without[,1]<-data.frame(Identifier=sub("^X","",sub("\\.[0-9]*$","",result_without[,1])))
result_with[,1]<-data.frame(Identifier=sub("^X","",sub("\\.[0-9]*$","",result_with[,1])))

diff<-data.frame()
for(i in 1:nrow(result_with)){
  diff[i,1]<-abs(result_with[i,ncol(result_with)]) - abs(result_without[result_without$X==result_with[i,1],ncol(result_without)])
}
colMeans(diff)

write.table(testset,"/home/rmey/Dokumente/my_projekt/Testset/Version_3_Testcase_19_v1.csv",row.names = F,col.names = F,sep=",")


physics.convert.to.meters <- function(km) {
    return(km * 1000)
}


switchop <- function(s, x, y) {
  if(s < 0) x || y
  else if (s > 0) x && y
  else xor(x, y)
}


##Fig3D  Fig S5
exo.corfilt2=cor(t(exo.filt2))
exo.corfilt2.lda=cor(exo.filt2.lda10)

# Make an Igraph object from this matrix:

plot(network)

library(RColorBrewer)
coul = brewer.pal(nlevels(as.factor(mtcars$cyl)), "Set2")
# Map the color to cylinders
my_color=coul[as.numeric(as.factor(mtcars$cyl))]

# plot
par(bg="grey13", mar=c(0,0,0,0))
set.seed(4)
plot(network,
    vertex.size=12,
    vertex.color=my_color,
    vertex.label.cex=0.7,
    vertex.label.color="white",
    vertex.frame.color="transparent"
    )
# title a

rownames(exo.corfilt2)=gsub("\\d+:","", rownames(exo.corfilt2))
colnames(exo.corfilt2)=gsub("\\d+:","", colnames(exo.corfilt2))

rownames(exo.corfilt2.lda)=gsub("X\\d:","", rownames(exo.corfilt2.lda))
colnames(exo.corfilt2.lda)=gsub("X\\d+","", colnames(exo.corfilt2.lda))

#topn = 10

toprank.lda = t(apply(exo.filt2.lda10, 1 , function(x,y){x=as.numeric(x); yy=y[order(x,decreasing=T)[1:10]]; yy;}, y=gsub("X\\d+", "", colnames(exo.filt2.lda10))))

toprank.cut = t(apply(exo.filt2.lda10, 1 , function(x,y){x=as.numeric(x); xx=x[order(x,decreasing=T)[1:10]]; xx;}, y=gsub("X\\d+", "", colnames(exo.filt2.lda10))))

top.dup=as.vector(toprank.lda)[duplicated(as.vector(toprank.lda))]
top.uniq=as.vector(toprank.lda)[-which(duplicated(as.vector(toprank.lda)))]

member=rep("",length(unique(as.vector(toprank.lda))))
names(member)=unique(as.vector(toprank.lda))
for(i in 1:10){
  member[as.character(toprank.lda[i,])] = paste(member[as.character(toprank.lda[i,])], i,sep=",")

}

member=gsub("^,","",member)

for (x in names(member)){
  asmember[x]

}

toprank.lda
##cluster edge betweenness
cutoff = 0.3

exo.cf2.nw =abs( exo.corfilt2)
exo.cf2.nw[exo.cf2.nw < cutoff]=0
cnet=graph_from_adjacency_matrix( exo.cf2.nw, weighted=T, mode="undirected", diag=F)
V(cnet)$label=V(cnet)$name
                                        #l =
cnet=delete.vertices(cnet, degree(cnet)==0)
V(cnet)[name %in% names(member)]$label= paste(V(cnet)[name %in% names(member)]$label,"(", member[V(cnet)[name %in% names(member)]$name],")",sep="")

#ceb = cluster_edge_betweenness(cnet)
ceb = cluster_label_prop(cnet)
#ceb=cluster_fast_greedy(cnet)

plot(ceb, cnet, edge.arrow.mode=0,  vertex.label=V(cnet)$label, vertex.label.cex=0.5, vertex.size=1)

dev.copy2pdf(file="microbe.corRAW.network.c0.2lp.pdf")

cutoff=0.8

 exo.cf2.lda = abs(exo.corfilt2.lda)
exo.cf2.lda[exo.cf2.lda < cutoff]=0
cnet2=graph_from_adjacency_matrix( exo.cf2.lda, weighted=T, mode="undirected", diag=F)
 V(cnet2)$label=V(cnet2)$name

#g=cnet                                      #l =
cnet2=delete.vertices(cnet2, degree(cnet2)==0)
V(cnet2)[name %in% names(member)]$label= paste(V(cnet2)[name %in% names(member)]$label,"(", member[V(cnet2)[name %in% names(member)]$name],")",sep="")

ceb = cluster_edge_betweenness(cnet2)
#ceb = cluster_label_prop(cnet2)
#ceb=cluster_fast_greedy(cnet)

plot(ceb, cnet2, edge.arrow.mode=0,  vertex.label=V(cnet2)$label, vertex.label.cex=0.5, vertex.size=1)
dev.copy2pdf(file="microbe.corLDA.network.c0.8.pdf")


require(raster)
require(sp)
require(maptools)
require(rgdal)

# -------------------------------------------------------------------------------------------------------
# surface_downwelling_shortwave_flux_in_air

# alias: surface_downwelling_shortwave_flux

# The surface called "surface" means the lower boundary of the atmosphere. "shortwave" means shortwave radiation.
# Downwelling radiation is radiation from above. It does not mean "net downward".
# Surface downwelling shortwave is the sum of direct and diffuse solar radiation incident on the surface, and is sometimes called "global radiation".
# When thought of as being incident on a surface, a radiative flux is sometimes called "irradiance".
# In addition, it is identical with the quantity measured by a cosine-collector light-meter and sometimes called "vector irradiance".
# In accordance with common usage in geophysical disciplines, "flux" implies per unit area, called "flux density" in physics.
# -------------------------------------------------------------------------------------------------------

# read in the dat file downloaded from the CRU TS20 website
sunp <- read.table("/workspace/UA/malindgren/projects/iem/PHASE2_DATA/RSDS_working/September2012_finalRuns/10min_sunshine/original_data/TS20/grid_10min_sunp.dat")

# change the colnames to something more useable
colnames(sunp) <- c("lat","lon","Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec")

# create a shapefile
sunp.pts <- SpatialPoints(coordinates(sunp[,2:1]))

sunp.spdf <- SpatialPointsDataFrame(sunp.pts, as.data.frame(sunp))

colNums <- 3:ncol(sunp)

template <- raster("/Data/Base_Data/Climate/Canada/CRU_Climatology/Temperature/cru_tmean_1/")
values(template) <- NA

# this loop
for(i in colNums){
	print(i)

	if(nchar(i) == 1){ d=paste("0",i-2, sep="")	}else{ d=i-2 }

	rasterize(sunp.spdf, template, field=colnames(sunp)[i] ,filename=paste("/workspace/UA/malindgren/projects/iem/PHASE2_DATA/RSDS_working/September2012_finalRuns/10min_sunshine/output_rasters/sunp_cru_10min_",d,"_1961_1990.tif", sep=""), overwrite=T)

}

####################################################################################################################
# read in the NetCDF as a stack
cld.ts31 <- stack("/workspace/UA/malindgren/projects/iem/PHASE2_DATA/RSDS_working/September2012_finalRuns/10min_sunshine/original_data/TS31/cru_ts_3_10.1901.2009.cld.dat.nc")
cld.ts31.tmp <- brick("/workspace/UA/malindgren/projects/iem/PHASE2_DATA/RSDS_working/September2012_finalRuns/10min_sunshine/original_data/TS31/cru_ts_3_10.1901.2009.cld.dat.nc")

# read in the cru climatology
# this is in SUNP percentage units
sunp.ts20.clim <- stack(list.files("/workspace/UA/malindgren/projects/iem/PHASE2_DATA/RSDS_working/September2012_finalRuns/10min_sunshine/output_rasters", pattern="tif", full.names=TRUE))

# all this does is bring the layernames in as something more descript.  The stack layernames are not as good as the brick
# so I give the stack the brick names
cld@layernames <- cld.ts31.tmp@layernames
rm(cld.ts31.tmp) # remove the unneeded brick

# AKCanada Extent for spatial subsetting
AKCanada.akalb <- raster("/workspace/Shared/Michael/ArcGIS_Shared/clipper/alaska_west_canada_clipper_forDownscaling.tif")

# project the extent
AKCanada.wgs84 <- projectExtent(AKCanada.akalb, projection(cld.ts31))

# grab the cell ids at the intersection of the new extent and the original data
cld.ts31.desiredCells <- cellsFromExtent(cld.ts31, extent(AKCanada.wgs84), expand=FALSE)

# extract those cells and create a new stack
cld.ts31.desiredCells.e <- cld[cld.ts31.desiredCells,drop=F]

#####  TS20 climatology data  #########################################################################
# grab the cell ids at the intersection of the new extent and the original data
sunp.ts20.clim.desiredCells <- cellsFromExtent(sunp.ts20.clim, extent(AKCanada.wgs84), expand=FALSE)
# now spatially subset those cells to a new stack
sunp.ts20.clim.desiredCells.e <- sunp.ts20.clim[sunp.ts20.clim.desiredCells,drop=F]

# would be a good idea to do the sunshine percent to cloud percent conversion
# I think this is working correctly now it is units of percent without the percent sign
cld.ts20.clim.desiredCells.e <- 100 - ts20.clim.desiredCells.e

# temporally subset the stack object to be 1961-1990 for all 12 months
# these numbers were pre-calculated outside of the code
cld.ts31.subset <- subset(cld.ts31.desiredCells.e, 721:1080)

# create an empty brick using the extent from the other stack and no layers in it yet.
cld.ts31.clim <- brick(extent(cld.ts31.subset), nrows=nrow(cld.ts31.subset), ncols=ncol(cld.ts31.subset), crs=projection(cld.ts31.subset), nl=1)

# create climatology
for(j in 1:12){
	#monthLayers<-seq(j, nlayers(cld.subset), by= 12)
	cld.clim.tmp <- mean(subset(cld.ts31.subset, seq(j, nlayers(cld.ts31.subset), by=12)))
	cld.ts31.clim <- addLayer(cld.ts31.clim, cld.clim.tmp)
}

yearList <- 1901:2009

# create anomalies HISTORICAL
# make an empty brick object
cld.ts31.anom <- brick(extent(cld.ts31.desiredCells.e), nrows=nrow(cld.ts31.desiredCells.e), ncols=ncol(cld.ts31.desiredCells.e), crs=projection(cld.ts31.desiredCells.e), nl=nlayers(cld.ts31.desiredCells.e))

# this is the centroid values of the cru ts20 That is used as the output points to
#  interpolate to from the 0.5 degree to the 10 min spatial resolution of the ts20 climatology
out_xy <- coordinates(cld.ts20.clim.desiredCells.e)

# calculate and write out the anomalies
for(i in 1:12){ # go through a list of months
	print(paste("	MONTH WORKING = ",i))
	# use the sequence command to create an index of all of the same month during the entire timeseries
	monthList <- seq(i, nlayers(cld.ts31.desiredCells.e), 12)

	# here we select the month we want from the ts20 climatology
	cld.ts20.clim.current <- subset(cld.ts20.clim.desiredCells.e,i,drop=T)

	# this line will create a 2 character month for filenaming procedures (if needed)
	if(nchar(i)<2){ month=paste("0",i,sep="")}else{month=paste(i,sep="")}

	# here we subset the cld
	cld.ts31.clim.current <- subset(cld.ts31.clim, i, drop=T)

	count=0 # a counter to iterate through the years

	for(j in monthList){
		print(paste("anomalies iter ",j))
		count=count+1
		cld.current <- subset(cld.desiredCells.e, j, drop=T)

		# this line generates a proportional anomaly
		anom <- cld.current/cld.clim.current

		# write out the 0.5 resolution anomalies (temporary file)
		writeRaster(anom, filename=paste("/workspace/UA/malindgren/projects/iem/PHASE2_DATA/RSDS_working/September2012_finalRuns/outputs/anomalies/anomalies_original_resolution/","cld_pct_proportionalAnom_cru_ts31_", month,"_",yearList[count],".tif",sep=""), overwrite=T)

		# # # # # # INTERPOLATION SECTION # # # # # #
		in_xy <- coordinates(anom)
		z_in <- getValues(anom)

		xyz <- cbind(in_xy,z_in)
		xyz.na <- na.omit(xyz)

		in_xy <- xyz.na[,1:2]
		z_in <- xyz.na[,3]

		anom.spline	<- interp(x=in_xy[,1],y=in_xy[,2],z=z_in,xo=seq(min(out_xy[,1]),max(out_xy[,1]),l=ncol(cld.ts20.clim.desiredCells.e)), yo=seq(min(out_xy[,2]),max(out_xy[,2]),l=nrow(cld.ts20.clim.desiredCells.e),linear=F))

		# transpose the data here
		nc.interp <- t(anom.spline$z)[,nrow(anom.spline$z):1]

		# turn that into a new raster object
		nc.interp.r <- raster(nc.interp, xmn=xmin(cld.ts20.clim.desiredCells.e), xmx=xmax(ts20.clim.desiredCells.e), ymn=ymin(ts20.clim.desiredCells.e), ymx=ymax(ts20.clim.desiredCells.e), crs=projection(ts20.clim.desiredCells.e))

		# write out the interpolated to 10min resolution anomalies (temporary file)
		writeRaster(anom, filename=paste("/workspace/UA/malindgren/projects/iem/PHASE2_DATA/RSDS_working/September2012_finalRuns/outputs/anomalies/interpolated_10min/","cld_pct_proportionalAnom_cru_ts31_10min_", month,"_",yearList[count],".tif",sep=""), overwrite=T)

		cld.ts31.downscaled <- cld.ts20.current*anom

		# write out the downscaled cloud raster
		writeRaster(anom, filename=paste("/workspace/UA/malindgren/projects/iem/PHASE2_DATA/RSDS_working/September2012_finalRuns/outputs/anomalies/interpolated_10min/","cld_pct_cru_ts31_10min_", month,"_",yearList[count],".tif",sep=""), overwrite=T)

	}
}

#########  RUN ABOVE AS A TEST!!!  ##################  FIX BELOW!

# here we need to create a filelist that follows the chronology of the timeseries
fileList <- character()
for(i in yearList){
	print(i)
	for(j in 1:12){
		if(nchar(j)<2){ month=paste("0",j,sep="")}else{month=paste(j,sep="")}
		fileList <- append(fileList, paste("/workspace/UA/malindgren/projects/iem/PHASE2_DATA/CRU_TS20/anomalies/","cld_anom_cru_ts31_", month,"_",i,".tif",sep=""), after=length(fileList))
	}
}

cld.anom <- stack(fileList)

# lets create a new empty brick using the information from the 10min data
cld.anom.interp <- brick(ts20.clim.desiredCells.e, values=F, nl=1)

# here we need to interpolate the 0.5 resolution anomalies to something that matches the cru ts20 10 min data
# get the centroid xy
# here we create the interpolated anomalies using a spline interpolation down to 10min resolution
for (f in 1:nlayers(cld.anom)){
	print(basename(fileList[f]))
	inFile <- unlist(strsplit(basename(fileList[f]), "_"))
	outFile <- paste(inFile[1],inFile[2], inFile[3], inFile[4], "10min_interp", inFile[5], inFile[6], sep="_")
	# this is input xy and z data to use in interpolation
	in_xy <- coordinates(subset(cld.subset.climatology, f, drop=T))
	z_in <- getValues(subset(cld.subset.climatology, f, drop=T))

	xyz <- cbind(in_xy,z_in)
	xyz.na <- na.omit(xyz)

	in_xy <- xyz.na[,1:2]
	z_in <- xyz.na[,3]

	# this is the centroid values of the cru ts20
	out_xy <- coordinates(ts20.clim.desiredCells.e)

	anom.spline	<- interp(x=in_xy[,1],y=in_xy[,2],z=z_in,xo=seq(min(out_xy[,1]),max(out_xy[,1]),l=ncol(ts20.clim.desiredCells.e)), yo=seq(min(out_xy[,2]),max(out_xy[,2]),l=nrow(ts20.clim.desiredCells.e),linear=F))

	# transpose the data here
	nc.interp <- t(anom.spline$z)[,nrow(anom.spline$z):1]

	# turn that into a new raster object
	nc.interp.r <- raster(nc.interp, xmn=xmin(ts20.clim.desiredCells.e), xmx=xmax(ts20.clim.desiredCells.e), ymn=ymin(ts20.clim.desiredCells.e), ymx=ymax(ts20.clim.desiredCells.e), crs=projection(ts20.clim.desiredCells.e))
	# write out the new raster here
	writeRaster(nc.interp.r, filename=paste("/workspace/UA/malindgren/projects/iem/PHASE2_DATA/RSDS_working/September2012_finalRuns/outputs/anomalies/interpolated_10min/", outFile, sep=""), overwrite=TRUE)

	# and add that layer to a new stack as well
	cld.anom.interp <- addLayer(cld.anom.interp, nc.interp.r)
}

# here I am going to downscale the historical data to 10 min (CLOUD COVER)

for(m in 1:12){
	monthList <- seq(i, nlayers(cld.anom.interp), 12)
	print(paste("working on: ", f,sep=""))

	cld.anom.interp.current <- subset(cld.anom.interp, monthList)

	cld.ts20.clim <- subset()

}

# next loop will involve some calculation between the new cloud cover data and the

	# next we need to turn the girr to nirr
	# nirr = girr * (0.251 + (0.509*(1.0 - clds/100.0)));
	nirr = cld.subset.v * (0.251 + (0.509*(1.0 - clds/100.0)))

3. CALCULATE THE HISTORICAL ANOMALIES
4. CALCULATE THE FUTURE ANOMALIES
5. INTERPOLATE THE HISTORICAL / FUTURE ANOMALIES TO MATCH THE TS20
6. MULTIPLY/ADD THE ANOMALIES TO THE CRU TS20 CLIMATOLOGY

* WHAT ABOUT THE UNITS?

# get the values of the stack
cld.subset.v <- getValues(cld.subset)

# apply the function from Dave to create a nirr value using apply()
nirr = cld.subset.v * (0.251 + (0.509*(1.0 - cld.subset.v/100.0)))

# now we return the modified values to the stack.
values(cld.subset2) <- cld.subset.v

# what we have produced in the above code is the NIRR (essentially the same as RSDS accd to Fengming/Dave)
if (clds > -0.1) {
	nirr = cld.subset.v * (0.251 + (0.509*(1.0 - clds/100.0))) # basically percent cloudcover
	}else {
		nirr = -999.9; }


source("helpers.r")

# Parameter setting
if (length(commandArgs()) > 4) {
  seed_script1 <- as.numeric(commandArgs()[5])
} else {
  if (!exists("seed_script1")) seed_script1 <- 1
}

if (length(commandArgs()) > 5) {
  batchj <- as.numeric(commandArgs()[6])
} else {
  if (!exists("batchj")) batchj <- 4
}

rseed = seed_script1

####
####
#### Read the Data
####
alldata = read.csv("alldata.csv", sep = ",")

source("helpers.r")

pdfname <- "UNSC" # unscaled
targetname <- "BCR5y"
valtyp <- "LOOCV"
errorfun <- "aucerror"
cormethod <- "spearman"
cl_family <- "binomial"
k <- 50  # number of bootsraps per run and model. k=100 means 100 BSs, so 100 errors, formed to one boxplot with one median
z <- 1    # number of runs. z=30 means 30 runs, so histograms are averaged over 30 histograms, there are 30 distances of histograms to the average histogram.
e <- 1000 # end. Look at the e best models at most (default 1000).
ntree <- 200 # number of trees for a random forest
ctype="rf"

predNames20 = c("ATRN", "BTD", "CADM1", "CATD", "CERU", "CFAH", "ECM1", "FINC", "GOLM1", "HYOU1", "ICAM1", "LG3BP",
                "LUM", "NCAM1", "PIGR", "PLXB2", "POSTN", "TRFE", "TSP1", "VTNC", "ZA2G")

predNames20 <- sort(predNames20)

predNamesRef_PSA <- c("PSA_Dens")
predNamesRef_PSABX <- c(predNamesRef_PSA, "BX_GS")

alldata <- removeNas(alldata, unique(c(predNamesRef_PSABX, predNames20, targetname)))

# Train on one batch ProCOC X
train_data_global <- alldata[which(alldata$reading==1 & alldata$ProCOC==batchj), ]
test_data_global <- alldata[which(alldata$reading==1 & alldata$ProCOC!=batchj), ]
pdfname <- paste(c(pdfname, "_batch", batchj), collapse = "")
pdfname <- paste(c(pdfname, "_", errorfun, "_", ctype), collapse="")

dat_train <- train_data_global
dat_test  <- test_data_global # for overall validation, will not be used in CV

dat_train <- removeNas(dat_train, unique(c(predNamesRef_PSABX, predNames20, targetname)))
dat_test  <- removeNas(dat_test, unique(c(predNamesRef_PSABX, predNames20, targetname)))

X <- dat_train

n <- length(predNames20)  # number of predictors from which a combination can be chosen (default 20)
p <- 5  # highest number of predictors in one model (default 5)

# LOAD INDICES
indexfile <- paste(as.character(n), as.character(p), ".RData", sep="")
if (file.exists(indexfile)) {
  load(indexfile)
} else {
  allInd <- CreateIndices(n, p)
  save(allInd, file=indexfile)
}

# BOOTSTRAPS
indRowNA <- dim(X)[1]+1
d = dim(X[-indRowNA,])[1]
allind <- c(1:d)
bserrorsAllz <- list()
bsindAll <- allInd

tablesNew <- TRUE

# calculate reference models PSA
RF_refs_PSABX <- list()
GLM_refs_PSABX <- list()
RF_refs_PSA <- list()
GLM_refs_PSA <- list()

RF_refs_PSABX_errors <- c()
GLM_refs_PSABX_errors <- c()
RF_refs_PSA_errors <- c()
GLM_refs_PSA_errors <- c()

train_inds <- list()
test_inds <- list()
set.seed(rseed)
for (i in 1:k) {
  set.seed(i)
  ind <- order(dat_train[,targetname])[sampling::strata(dat_train[order(dat_train[,targetname]),], targetname, round(0.69 * as.numeric(summary(dat_train[, targetname])[2:3])), "srswor")$ID_unit]
  ind_oob <- (1:nrow(dat_train))[-ind]

  train_inds <- c(train_inds, list(ind))
  test_inds <- c(test_inds, list(ind_oob))

  dat_fold_train <- dat_train[ind, ]
  dat_fold_test  <- dat_train[ind_oob, ]

  ##
  ## Random Forest
  ##
  require(randomForest)
  set.seed(rseed)
  rf_fit <- randomForest(formula(paste(c("as.factor(", targetname, ")~", paste(predNamesRef_PSABX, collapse="+")), collapse="")), data.frame(dat_fold_train), importance=TRUE, na.action=na.omit, ntree = ntree, mtry=length(predNamesRef_PSABX))
  #RF_refs_PSABX_errest <- c(RF_refs_PSABX_errest, 1-sum(diag(rf_fit$confusion))/sum(rf_fit$confusion[1:2, 1:2]))
  if (errorfun == "aucerror") {
    RF_refs_PSABX_errors <- c(RF_refs_PSABX_errors, errormeasureAUC(dat_fold_test[, targetname], predict(rf_fit, newdata = dat_fold_test, type="prob")[,2]))
  } else if (errorfun == "surverror") {
    RF_refs_PSABX_errors <- c(RF_refs_PSABX_errors, errormeasureSURV(predict(rf_fit, newdata = dat_fold_test), dat_fold_test))
  } else {
    RF_refs_PSABX_errors <- c(RF_refs_PSABX_errors, errormeasure(dat_fold_test[, targetname], predict(rf_fit, newdata = dat_fold_test)))
  }
  RF_refs_PSABX <- c(RF_refs_PSABX, list(rf_fit))

  set.seed(rseed)
  rf_fit <- randomForest(formula(paste(c("as.factor(", targetname, ")~", paste(predNamesRef_PSA, collapse="+")), collapse="")), data.frame(dat_fold_train), importance=TRUE, na.action=na.omit, ntree = ntree, mtry=length(predNamesRef_PSA))
  if (errorfun == "aucerror") {
    RF_refs_PSA_errors <- c(RF_refs_PSA_errors, errormeasureAUC(dat_fold_test[, targetname], predict(rf_fit, newdata = dat_fold_test, type="prob")[,2]))
  } else if (errorfun == "surverror") {
    RF_refs_PSA_errors <- c(RF_refs_PSA_errors, errormeasureSURV(predict(rf_fit, newdata = dat_fold_test), dat_fold_test))
  } else {
    RF_refs_PSA_errors <- c(RF_refs_PSA_errors, errormeasure(dat_fold_test[, targetname], predict(rf_fit, newdata = dat_fold_test)))
  }
  RF_refs_PSA <- c(RF_refs_PSA, list(rf_fit))

}

###
### Validation Functions
###

doClassifierSurvivalFitWithClassifier <- function(data, classifier, tit, classifierPSA=NA, classifierPSABX=NA, legend=TRUE, doPlot=TRUE, plotSurvivalRatherThanROC=TRUE, plotPSA=TRUE, plotPSABX=TRUE, plotNCCN=TRUE, cutoff=0.5, cutoffPSA=0.5, cutoffPSABX=0.5, ctype="rf", mark = 3, lwd=1, ...) {
  require(pROC)
  require(survival)

  data. <- data

  if (ctype=="rf") {
    data.$Score <- predict(classifier, newdata = data., type="prob")[,2]
  } else {
    data.$Score <- predict(classifier, newdata = data., type="response")
  }

  rocScore = roc(data.[, targetname], data.$Score, ci=TRUE)
  if (cutoff<0) {
    cutoff = rocScore$thresholds[which.max(rocScore$specificities + rocScore$sensitivities)[1]]
  }
  if (class(data.$Score) == "numeric") {
    data.$Score <- factor(data.$Score >= cutoff)
  }
  levels(data.$Score) <- c("LOW", "HIGH")

  Pred.surv <- survfit(Surv(time=Time_BCR_free_survival, event=Status_BCR, type="right") ~ Score, data = data.)
  Pred.cox  <-   coxph(Surv(time=Time_BCR_free_survival, event=Status_BCR, type="right") ~ Score, data = data.)

  if (doPlot) {
    if (plotSurvivalRatherThanROC)
      plot(Pred.surv, col = 1:2, ylab="Cumulative Survival", xlab="Months", main=tit, sub=paste(c("n = ", paste(Pred.surv$n, collapse=" / "), ",  p=", format(summary(Pred.cox)$logtest[3], digits=3, nsmall=2)), collapse=""), lwd=lwd, mark=mark, ...)
    else {
      plot(rocScore, col = 1, main=tit, sub=paste(c("n = ", length(rocScore$cases)+length(rocScore$controls)), collapse=""), mar=c(5.1,4.1,4.2,2.1), ...)
      cis = rocScore$ci[c(1,3)]
      text(x=0.4, y=0.4, labels=paste(c("AUC ", format(auc(rocScore), digits=3, nsmall=2), " [", format(cis[1], digits=3, nsmall=2), ";", format(cis[2], digits=3, nsmall=2), "]"), collapse=""), pos = 4, col=1)
    }

    if (plotPSA && !is.na(classifierPSA)) {
      if (ctype=="rf") {
        data.$PSAScore <- predict(classifierPSA, newdata = data., type="prob")[,2]
      } else {
        data.$PSAScore <- predict(classifierPSA, newdata = data., type="response")
      }
      rocPSA = roc(data.[, targetname], data.$PSAScore, ci=TRUE)
      if (cutoffPSA<0) {
        cutoffPSA = rocPSA$thresholds[which.max(rocPSA$specificities + rocPSA$sensitivities)[1]]
      }
      if (class(data.$PSAScore) == "numeric") {
        data.$PSAScore <- factor(data.$PSAScore >= cutoffPSA)
      }
      levels(data.$PSAScore) <- c("LOW", "HIGH")

      PredPSA.surv <- survfit(Surv(time=Time_BCR_free_survival, event=Status_BCR, type="right") ~ PSAScore, data = data.)
      PredPSA.cox  <-   coxph(Surv(time=Time_BCR_free_survival, event=Status_BCR, type="right") ~ PSAScore, data = data.)

      if (plotSurvivalRatherThanROC) {
        lines(PredPSA.surv, col = c("gray", "orange"), lty=2, mark=mark, lwd=lwd)
        mtext(text=paste(c("PSA ", paste(PredPSA.surv$n, collapse="/"), " (p=", format(summary(PredPSA.cox)$logtest[3], digits=3, nsmall=2), ")"), collapse=""), col="darkgray", side = 3, adj = 0, cex=0.7)
      } else {
        plot(rocPSA, col = "darkgray", lty=2, add=TRUE, ...)
        mtext(text=paste(c("PSA ", paste(c("n = ", length(rocPSA$cases)+length(rocPSA$controls)), collapse=""), " (p=", format(roc.test(rocScore, rocPSA)$p.value, digits=3, nsmall=2), ")"), collapse=""), col="darkgray", side = 3, adj = 0, cex=0.7)
        cis = rocPSA$ci[c(1,3)]
        text(x=0.4, y=0.3, labels=paste(c("AUC ", format(auc(rocPSA), digits=3, nsmall=2), " [", format(cis[1], digits=3, nsmall=2), ";", format(cis[2], digits=3, nsmall=2), "]"), collapse=""), pos = 4, col="darkgray")
      }
    }

    if (plotPSABX && !is.na(classifierPSABX)) {
      if (ctype=="rf") {
        data.$PSABXScore <- predict(classifierPSABX, newdata = data., type="prob")[,2]
      } else {
        data.$PSABXScore <- predict(classifierPSABX, newdata = data., type="response")
      }
      rocPSABX = roc(data.[, targetname], data.$PSABXScore, ci=TRUE)
      if (cutoffPSABX<0) {
        cutoffPSABX = rocPSABX$thresholds[which.max(rocPSABX$specificities + rocPSABX$sensitivities)[1]]
      }
      if (class(data.$PSABXScore) == "numeric") {
        data.$PSABXScore <- factor(data.$PSABXScore >= cutoffPSABX)
      }
      levels(data.$PSABXScore) <- c("LOW", "HIGH")

      PredPSABX.surv <- survfit(Surv(time=Time_BCR_free_survival, event=Status_BCR, type="right") ~ PSABXScore, data = data.)
      PredPSABX.cox  <-   coxph(Surv(time=Time_BCR_free_survival, event=Status_BCR, type="right") ~ PSABXScore, data = data.)

      if (plotSurvivalRatherThanROC) {
        lines(PredPSABX.surv, col = c("lightblue3", "lightblue4"), lty=4, mark=mark, lwd=lwd)
        mtext(text=paste(c("PSA/BX ", paste(PredPSABX.surv$n, collapse="/"), " (p=", format(summary(PredPSABX.cox)$logtest[3], digits=3, nsmall=2), ")"), collapse=""), col="lightblue3", side = 3, adj = 1, cex=0.7)
      } else {
        plot(rocPSABX, col = "lightblue3", lty=4, add=TRUE, ...)
        mtext(text=paste(c("PSA/BX ", paste(c("n = ", length(rocPSABX$cases)+length(rocPSABX$controls)), collapse=""), " (p=", format(roc.test(rocScore, rocPSABX)$p.value, digits=3, nsmall=2), ")"), collapse=""), col="lightblue3", side = 3, adj = 1, cex=0.7)
        cis = rocPSABX$ci[c(1,3)]
        text(x=0.4, y=0.2, labels=paste(c("AUC ", format(auc(rocPSABX), digits=3, nsmall=2), " [", format(cis[1], digits=3, nsmall=2), ";", format(cis[2], digits=3, nsmall=2), "]"), collapse=""), pos = 4, col="lightblue3")
      }
    }

    if (plotNCCN) {
      # References NCCN
      rocNCCN = roc(data.[, targetname], data.$NCCN_risk_group_Bx, ci=TRUE)
      PredNCCN.surv <- survfit(Surv(time=Time_BCR_free_survival, event=Status_BCR, type="right") ~ NCCN_risk_group_Bx>2, data = data.)
      PredNCCN.cox  <-   coxph(Surv(time=Time_BCR_free_survival, event=Status_BCR, type="right") ~ NCCN_risk_group_Bx>2, data = data.)

      if (plotSurvivalRatherThanROC) {
        lines(PredNCCN.surv, col = c("palegreen3", "palegreen4"), lty=5, mark=mark, lwd=lwd)
        mtext(text=paste(c("NCCN ", paste(PredNCCN.surv$n, collapse="/"), " (p=", format(summary(PredNCCN.cox)$logtest[3], digits=3, nsmall=2), ")"), collapse=""), col="palegreen3", side = 4, adj = 1, cex=0.7)
      } else {
        plot(rocNCCN, col = "palegreen3", lty=5, add=TRUE, ...)
        mtext(text=paste(c("NCCN ", paste(c("n = ", length(rocNCCN$cases)+length(rocNCCN$controls)), collapse=""), " (p=", format(roc.test(rocScore, rocNCCN)$p.value, digits=3, nsmall=2), ")"), collapse=""), col="palegreen3", side = 4, adj = 1, cex=0.7)
        cis = rocNCCN$ci[c(1,3)]
        text(x=0.4, y=0.1, labels=paste(c("AUC ", format(auc(rocNCCN), digits=3, nsmall=2), " [", format(cis[1], digits=3, nsmall=2), ";", format(cis[2], digits=3, nsmall=2), "]"), collapse=""), pos = 4, col="palegreen3")
      }
    }

    if (legend) {
      if (plotSurvivalRatherThanROC && !is.null(names(Pred.surv$strata))) {
        leg = names(Pred.surv$strata)
        leglty = c(1,1)
        legcol = c("black", "red")

        if (plotPSA && !is.na(classifierPSA)) {
          leg = c(leg, names(PredPSA.surv$strata))
          leglty = c(leglty, c(2,2))
          legcol = c(legcol, c("gray", "orange"))
        }
        if (plotPSABX && !is.na(classifierPSABX)) {
          leg = c(leg, names(PredPSABX.surv$strata))
          leglty = c(leglty, c(4,4))
          legcol = c(legcol, c("lightblue3", "lightblue4"))
        }
        if (plotNCCN) {
          leg = c(leg, names(PredNCCN.surv$strata))
          leglty = c(leglty, c(5,5))
          legcol = c(legcol, c("palegreen3", "palegreen4"))
        }
        legend("bottomleft", leg, col=legcol, lty=leglty, bty="n", cex=0.8)
      }
    }
  }

  return (summary(Pred.cox)$logtest[3])
}

doClassifierSurvivalFitWithPrednames <- function(datatrain, datatest, predNames, targetname, tit="", ranseed = rseed, ktree = ntree, doPlot=TRUE, cutoff=0.5, cutoffPSA=0.5, cutoffPSABX=0.5, ctype="rf", plotSurvivalRatherThanROC=TRUE, ...) {

  set.seed(ranseed)
  if (ctype=="rf") {
    require(randomForest)
    classifier = randomForest(formula(paste(c("as.factor(", targetname, ")~", paste(unique(predNames), collapse="+")), collapse="")), data.frame(datatrain), importance=TRUE, na.action=na.omit, ntree = ktree, mtry=length(unique(predNames)))
  } else {
    classifier = glm(formula(paste(c("as.factor(", targetname, ")~", paste(unique(predNames), collapse="+")), collapse="")), family=binomial, data=data.frame(datatrain))
  }

  set.seed(ranseed)
  if (ctype=="rf") {
    classifierPSA = randomForest(formula(paste(c("as.factor(", targetname, ")~", paste("PSA_Dens", collapse="+")), collapse="")), data.frame(datatrain), importance=TRUE, na.action=na.omit, ntree = ktree)
  } else {
    classifierPSA = glm(formula(paste(c("as.factor(", targetname, ")~", paste("PSA_Dens", collapse="+")), collapse="")), family=binomial, data=data.frame(datatrain))
  }

  set.seed(ranseed)
  if (ctype=="rf") {
    classifierPSABX = randomForest(formula(paste(c("as.factor(", targetname, ")~", paste(unique(c("PSA_Dens", "BX_GS")), collapse="+")), collapse="")), data.frame(datatrain), importance=TRUE, na.action=na.omit, ntree = ktree, mtry=2)
  } else {
    classifierPSABX = glm(formula(paste(c("as.factor(", targetname, ")~", paste(unique(c("PSA_Dens", "BX_GS")), collapse="+")), collapse="")), family=binomial, data=data.frame(datatrain))
  }

  if (is.na(tit) || tit=="") {
    tit = paste(predNames, collapse=" + ")
  }

  return (doClassifierSurvivalFitWithClassifier(datatest, classifier, tit, classifierPSA, classifierPSABX, doPlot=doPlot, cutoff=cutoff, cutoffPSA=cutoffPSA, cutoffPSABX=cutoffPSABX, ctype=ctype, plotSurvivalRatherThanROC=plotSurvivalRatherThanROC, ...))
}

doSurvivalTestWithPrednames <- function(predNames, alldata.=alldata, doPlot=TRUE, ctype="rf", plotSurvivalRatherThanROC=TRUE, ...) {
  par_before <- par(no.readonly = TRUE)
  par(mfrow=c(2,2))
  I   <- doClassifierSurvivalFitWithPrednames(alldata.[which(alldata.$reading==1 & alldata.$ProCOC!=1), ], alldata.[which(alldata.$reading==1 & alldata.$ProCOC==1), ], predNames, targetname, tit="ProCOC I", legend=FALSE, doPlot=doPlot, cutoff=-1, cutoffPSA=-1, cutoffPSABX=-1, ctype=ctype, plotSurvivalRatherThanROC=plotSurvivalRatherThanROC, ...)
  II  <- doClassifierSurvivalFitWithPrednames(alldata.[which(alldata.$reading==1 & alldata.$ProCOC!=2), ], alldata.[which(alldata.$reading==1 & alldata.$ProCOC==2), ], predNames, targetname, tit="ProCOC II", legend=FALSE, doPlot=doPlot, cutoff=-1, cutoffPSA=-1, cutoffPSABX=-1, ctype=ctype, plotSurvivalRatherThanROC=plotSurvivalRatherThanROC, ...)
  III <- doClassifierSurvivalFitWithPrednames(alldata.[which(alldata.$reading==1 & alldata.$ProCOC!=3), ], alldata.[which(alldata.$reading==1 & alldata.$ProCOC==3), ], predNames, targetname, tit="ProCOC III", legend=FALSE, doPlot=doPlot, cutoff=-1, cutoffPSA=-1, cutoffPSABX=-1, ctype=ctype, plotSurvivalRatherThanROC=plotSurvivalRatherThanROC, ...)
  IV  <- doClassifierSurvivalFitWithPrednames(alldata.[which(alldata.$reading==1 & alldata.$ProCOC!=4), ], alldata.[which(alldata.$reading==1 & alldata.$ProCOC==4), ], predNames, targetname, tit="ProCOC IV", legend=TRUE, doPlot=doPlot, cutoff=-1, cutoffPSA=-1, cutoffPSABX=-1, ctype=ctype, plotSurvivalRatherThanROC=plotSurvivalRatherThanROC, ...)
  if (doPlot) {
    at. = 1.5
    if (plotSurvivalRatherThanROC)
      at. = -10
    mtext(paste(predNames, collapse=" + "),line = 24, at = at., col="sienna3")
    mtext(paste(c("Batchwise\nCross-Validated"), collapse=""),line = 3.5, at = at., col="tomato")
  }
  par(par_before)
  return (c(I=I, II=II, III=III, IV=IV))
}

doSurvivalTestWithPrednamesBatchwise <- function(predNames, alldata.=alldata, doPlot=TRUE, ctype="rf", plotSurvivalRatherThanROC=TRUE, ...) {
  par_before <- par(no.readonly = TRUE)
  par(mfrow=c(2,2))
  allbatches <- c()
  for (batch in 1:4) {
    I   <- doClassifierSurvivalFitWithPrednames(alldata.[which(alldata.$reading==1 & alldata.$ProCOC==batch), ], alldata.[which(alldata.$reading==1 & alldata.$ProCOC==1), ], predNames, targetname, tit="ProCOC I", legend=FALSE, doPlot=doPlot, cutoff=-1, cutoffPSA=-1, cutoffPSABX=-1, ctype=ctype, plotSurvivalRatherThanROC=plotSurvivalRatherThanROC, ...)
    II  <- doClassifierSurvivalFitWithPrednames(alldata.[which(alldata.$reading==1 & alldata.$ProCOC==batch), ], alldata.[which(alldata.$reading==1 & alldata.$ProCOC==2), ], predNames, targetname, tit="ProCOC II", legend=FALSE, doPlot=doPlot, cutoff=-1, cutoffPSA=-1, cutoffPSABX=-1, ctype=ctype, plotSurvivalRatherThanROC=plotSurvivalRatherThanROC, ...)
    III <- doClassifierSurvivalFitWithPrednames(alldata.[which(alldata.$reading==1 & alldata.$ProCOC==batch), ], alldata.[which(alldata.$reading==1 & alldata.$ProCOC==3), ], predNames, targetname, tit="ProCOC III", legend=FALSE, doPlot=doPlot, cutoff=-1, cutoffPSA=-1, cutoffPSABX=-1, ctype=ctype, plotSurvivalRatherThanROC=plotSurvivalRatherThanROC, ...)
    IV  <- doClassifierSurvivalFitWithPrednames(alldata.[which(alldata.$reading==1 & alldata.$ProCOC==batch), ], alldata.[which(alldata.$reading==1 & alldata.$ProCOC==4), ], predNames, targetname, tit="ProCOC IV", legend=TRUE, doPlot=doPlot, cutoff=-1, cutoffPSA=-1, cutoffPSABX=-1, ctype=ctype, plotSurvivalRatherThanROC=plotSurvivalRatherThanROC, ...)
    if (doPlot) {
      at. = 1.5
      if (plotSurvivalRatherThanROC)
        at. = -10
      mtext(paste(predNames, collapse=" + "),line = 24, at = at., col="sienna3")
      mtext(paste(c("Trained on Batch ", batch), collapse=""),line = 3.5, at = at., col="tomato")
    }
    allbatches <- c(allbatches, list(c(I=I, II=II, III=III, IV=IV)))
  }
  par(par_before)
  return (allbatches)
}

doCV <- function(dat_train, predNames, targetname, rseed = 1, testdata = NA, k_fold = k, ncores = round(0.5*detectCores()), doPlot=FALSE, addToPlot=NA, tit=NA, smoothAUC=FALSE, plotSurvivalRatherThanROC=TRUE, ...) {
  require(doParallel)
  require(pROC)
  require(survival)
  require(randomForestSRC)

  registerDoParallel(cores=ncores)

  CVfolds <- foreach(i=1:k_fold,.combine="c", .packages = c('randomForest', 'boot', 'survival', 'randomForestSRC')) %do% { #inner loop. Change %dopar% to %do% to run sequentially (a normal for loop)

    if (is.na(addToPlot)) {
      addToPlot_ = i!=1
    } else {
      addToPlot_ = addToPlot
    }
    if (is.na(tit)) {
      tit_ = paste(predNames, collapse=" + ")
    } else {
      tit_ = tit
    }

    ind <- train_inds[[i]]
    ind_oob <- test_inds[[i]]

    dat_fold_train <- dat_train[ind, ]
    dat_fold_test  <- dat_train[ind_oob, ]

    CVfold <- c()

    ##
    ## Random Forest
    ##
    if (ctype=="rf") {
      require(randomForest)
      set.seed(rseed)
      CVfold$fit_RF_PSABX       <- randomForest(formula(paste(c("as.factor(", targetname, ")~", paste(unique(c(predNamesRef_PSABX, predNames)), collapse="+")), collapse="")), data.frame(dat_fold_train), importance=TRUE, na.action=na.omit, ntree = ntree, mtry=length(unique(c(predNamesRef_PSABX, predNames))))
      if (errorfun == "aucerror") {
        CVfold$fit_RF_PSABX_error <- errormeasureAUC(dat_fold_test[, targetname], predict(CVfold$fit_RF_PSABX, newdata = dat_fold_test, type="prob")[,2])
      }

      set.seed(rseed)
      CVfold$fit_RF_PSA       <- randomForest(formula(paste(c("as.factor(", targetname, ")~", paste(unique(c(predNamesRef_PSA, predNames)), collapse="+")), collapse="")), data.frame(dat_fold_train), importance=TRUE, na.action=na.omit, ntree = ntree, mtry=length(unique(c(predNamesRef_PSA, predNames))))
      if (errorfun == "aucerror") {
        CVfold$fit_RF_PSA_error <- errormeasureAUC(dat_fold_test[, targetname], predict(CVfold$fit_RF_PSA, newdata = dat_fold_test, type="prob")[,2], doPlot=(doPlot && !plotSurvivalRatherThanROC), smoothAUC, add=addToPlot_, main=tit_, getROC = FALSE, ...)
        CVfold$fit_RF_PSA_ROC   <- errormeasureAUC(dat_fold_test[, targetname], predict(CVfold$fit_RF_PSA, newdata = dat_fold_test, type="prob")[,2], doPlot=FALSE, smoothAUC, add=addToPlot_, main=tit_, getROC = TRUE, ...)

        if (!smoothAUC) {
          roc_ = CVfold$fit_RF_PSA_ROC
          cutoff = roc_$thresholds[which.max(roc_$specificities + roc_$sensitivities)[1]]
          dat_fold_test$Score = predict(CVfold$fit_RF_PSA, newdata = dat_fold_test, type="prob")[,2]
          if (class(dat_fold_test$Score) == "numeric") {
            dat_fold_test$Score <- factor(dat_fold_test$Score >= cutoff)
          }
          levels(dat_fold_test$Score) <- c("LOW", "HIGH")

          Pred.surv <- survfit(Surv(time=Time_BCR_free_survival, event=Status_BCR, type="right") ~ Score, data = dat_fold_test)
          Pred.cox  <-   coxph(Surv(time=Time_BCR_free_survival, event=Status_BCR, type="right") ~ Score, data = dat_fold_test)

          CVfold$fit_RF_PSA_SURV <- Pred.surv
          CVfold$fit_RF_PSA_COX <- Pred.cox

          if (doPlot && plotSurvivalRatherThanROC) {
            if (!addToPlot_) {
              plot(Pred.surv, ylab="Cumulative Survival", xlab="Months", main=tit_, ...)
            } else {
              lines(Pred.surv, ...)
            }
          }
        }
      }

      set.seed(rseed)
      CVfold$fit_RF       <- randomForest(formula(paste(c("as.factor(", targetname, ")~", paste(unique(c(predNames)), collapse="+")), collapse="")), data.frame(dat_fold_train), importance=TRUE, na.action=na.omit, ntree = ntree, mtry=length(unique(c(predNames))))
      if (errorfun == "aucerror") {
        CVfold$fit_RF_error <- errormeasureAUC(dat_fold_test[, targetname], predict(CVfold$fit_RF, newdata = dat_fold_test, type="prob")[,2], getROC=FALSE)
        CVfold$fit_RF_ROC <- errormeasureAUC(dat_fold_test[, targetname], predict(CVfold$fit_RF, newdata = dat_fold_test, type="prob")[,2], getROC=TRUE)
      }
    }
    list(CVfold)
  }

  return (CVfolds)
}


# GetScalingDocsizeData.r

source("../common/DataUtil.r")

# G E T   D A T A
rm(results)
results <- fndfGetGiantData("./")
# Get fewer columns to work with, easier to see.
dat.docsize <- fndfGetDocsizeData(results)

# T A B U L A T E   D A T A
# Tabulate columns by copies and sector lifetime.
tbl.docsize <- data.frame(with(dat.docsize,
            tapply(mdmlosspct, list(docsize, lifem), FUN=identity)))
# Re-form the data into a table for printing.
foo<-(with(dat.docsize,
       tapply(mdmlosspct, list(docsize, lifem), FUN=identity)))
foo2<-cbind(as.numeric(levels(factor(results$docsize))), foo)
tbl2<-data.frame(foo2)
colnames(tbl2)<-c("docsize",as.numeric(colnames(foo2[,2:ncol(foo2)])))

# Pretty-print a table to a file with explanatory headings.
sOutputFilename <- "./Data_ScalingDocsize.txt"
sTitle <- "Document losses with single copy and varying document size"
sSubtitle <- "Table of percentage loss of collection tabulated\n" %+%
    "by document size (MB) and sector half-lifetime" %+% "\n\n" %+%
    "Note how document size and sector life scale together" %+% "\n\n\n" %+%
    "               sector half-life (megahours)"
sink(sOutputFilename)
cat("MIT Preservation Simulation Project", "\n\n")
cat(sOutputFilename, format(Sys.time(),"%Y%m%d_%H%M%S%Z"), "\n\n")
cat(sTitle, "\n\n")
cat(sSubtitle, "\n\n")
cat("\n")
# Micah succeeded in bending dcast to his will, thanks; see email.
library(reshape2)
bar.small <- dat.docsize[,c("lifem", "docsize", "mdmlosspct")]
bar.melted <- melt(bar.small, id=c("docsize", "lifem"))
bar.recast <- dcast(bar.melted, docsize~lifem)
print(bar.recast)
sink()

# Also print the raw table for use in a spreadsheet of comparisons.
sComparisonDataFilename <- "Data_Scaling_DocsizeSpreadsheetData.txt"
sink(sComparisonDataFilename)
print(bar.small, n=nrow(bar.small))
sink()

# P L O T   D A T A
library(ggplot2)

# Show lines for docsizes 5, 50, 500, 5000 MB; copies=1; over wiiiide range.
nDocsize <- 5; trows <- dat.docsize[dat.docsize$docsize==nDocsize,]
gp <- ggplot(data=trows,aes(x=lifem,y=safe(mdmlosspct)))
gp <- gp +
        scale_x_log10() + scale_y_log10() +
        annotation_logticks()

# docsize 5 MB
gp <- gp +
        aes(trows, x=(lifem), y=(safe(mdmlosspct))) +
        geom_point(data=trows,
            color="red", size=5, shape=("5")) +
        geom_line(data=trows,
            linetype="dashed", color="blue", size=1)

# docsize 50 MB
nDocsize <- 50; trows <- dat.docsize[dat.docsize$docsize==nDocsize,]
gp <- gp +
        aes(trows, x=(lifem), y=(safe(mdmlosspct))) +
        geom_point(data=trows,
            color="red", size=5, shape=("B")) +
        geom_line(data=trows, linetype="dashed", color="blue", size=1)

# docsize 500 MB
nDocsize <- 500; trows <- dat.docsize[dat.docsize$docsize==nDocsize,]
gp <- gp +
        aes(trows, x=(lifem), y=(safe(mdmlosspct))) +
        geom_point(data=trows,
            color="red", size=5, shape=("C")) +
        geom_line(data=trows, linetype="dashed", color="black", size=1)

# docsize 5000 MB
nDocsize <- 5000; trows <- dat.docsize[dat.docsize$docsize==nDocsize,]
gp <- gp +
        aes(trows, x=(lifem), y=(safe(mdmlosspct))) +
        geom_point(data=trows,
            color="red", size=5, shape=("D")) +
        geom_line(data=trows, linetype="dashed", color="black", size=1)

gp <- gp + ggtitle("Larger documents are larger targets to random errors\n" %+%
                "and therefore are lost more frequently.\n\n" %+%
                "Losses for collection with copies=1")
gp <- gp + xlab("sector half-life (megahours)")
gp <- gp + ylab("percent permanent document losses")
gp <- gp + theme(
            axis.text=element_text(size=12),
            axis.title=element_text(size=18),
            plot.title=element_text(size=18,face="bold"),
            panel.border = element_rect(color = "black", fill=NA, size=1)
            )

plot(gp)
fnPlotMakeFile(gp, "baseline-scalingdocsize.png")

# Unwind any remaining sink()s to close output files.
while (sink.number() > 0) {sink()}


#==============================================================================
#	Test for has.offset method in model.interface.
#==============================================================================
library(testthat)
library(model.adapter)

#------------------------------------------------------------------------------
#	Create test data.
#------------------------------------------------------------------------------
test.data <- list(
	# Test formula with no offset.
	call.no.offset = list(
		x = substitute(glm(Petal.Length ~ ., data = iris)),
		expected = character()
	),
	# Test formula with two offset without and with log.
	call.formula.1 = list(
		x = substitute(
			glm(
				Petal.Length ~ . + offset(iris$Sepal.Width)
				+ offset(log(iris$Petal.Width)),
				data = iris
			)
		),
		expected = c("iris$Sepal.Width", "iris$Petal.Width")
	),
	# Test formula without '$'.
	call.formula.2 = list(
		x = substitute(
			glm(Petal.Length ~ . + offset(Sepal.Width), data = iris)
		),
		expected = c("Sepal.Width")
	),
	# Test argument with '$'
	call.argument.1 = list(
		x = substitute(
			glm(Petal.Length ~ ., offset = iris$Sepal.Width, data = iris)
		),
		expected = c("iris$Sepal.Width")
	),
	# Test argument with log
	call.argument.2 = list(
		x = substitute(
			glm(Petal.Length ~ ., offset = log(Sepal.Width), data = iris)
		),
		expected = c("Sepal.Width")
	),
	# Test argument with log and '$'
	call.argument.3 = list(
		x = substitute(
			glm(Petal.Length ~ ., offset = log(iris$Sepal.Width), data = iris)
		),
		expected = c("iris$Sepal.Width")
	),
	# Test argument and formula together.
	call.both = list(
		x = substitute(
			glm(
				Petal.Length ~ . + offset(log(Petal.Width)),
				offset = Sepal.Width, data = iris
			)
		),
		expected = c("Petal.Width", "Sepal.Width")
	)
)

for (i in names(test.data)) {
	test.data[[gsub("^call", "object", i)]] <- test.data[[i]]
	test.data[[i]]$x <- eval(test.data[[i]]$x)
}

#------------------------------------------------------------------------------
#	Run tests.
#------------------------------------------------------------------------------
test_that(
	"Testing model.interface.derault$has.offset()",
	{
		for (i in names(test.data)) {
			expect_equal(
				model.adapter:::model.interface.default()$get.offset.names(
					test.data[[i]]$x, .GlobalEnv, "stats"
				),
				test.data[[i]]$expected, info = sprintf("While testing %s", i)
			)
		}
	}
)