# This is an em for the exognous mobility case.
# It will estimate a non-stationary model, and will be able to impose monotonicity

# ------------- Initiliazing functions ---------------------

#' create a random model for EM with
#' endogenous mobility with multinomial pr
#' @export
m2.mixt.new <-function(nk,nf,fixb=F,stationary=F) {

  model = list()
  # model for Y1|Y2,l,k for movers and stayes
  model$A1    = array(0.9*(1 + 0.5*rnorm(nf*nk)),c(nf,nk))
  model$S1    = 0.3*array(1+0.5*runif(nf*nk),c(nf,nk))
  # model for Y4|Y3,l,k for movers and stayes
  model$A2    = array(0.9*(1 + 0.5*rnorm(nf*nk)),c(nf,nk))
  model$S2    = 0.3*array(1+0.5*runif(nf*nk),c(nf,nk))
  # model for p(K | l ,l') for movers
  model$pk1    = rdirichlet(nf*nf,rep(1,nk))
  # model for p(K | l ,l') for stayers
  model$pk0    = rdirichlet(nf,rep(1,nk))
  dim(model$pk0) = c(1,dim(model$pk0))

  model$nk    = nk
  model$nf    = nf

  for (l in 1:nf) {
    model$A1[l,] = sort(model$A1[l,])
    model$A2[l,] = sort(model$A2[l,])
  }

  if (fixb) {
    model$A2 = spread(rowMeans(model$A2),2,nk) + model$A1 - spread(rowMeans(model$A1),2,nk)
  }

  if (stationary) {
    model$A2 = model$A1
  }

  return(model)
}

# ------------- Simulating functions ---------------------

#' Using the model, simulates a dataset of movers
#' @export
m2.mixt.simulate.movers <- function(model,NNm=NA) {

  J1 = array(0,sum(NNm))
  J2 = array(0,sum(NNm))
  Y1 = array(0,sum(NNm))
  Y2 = array(0,sum(NNm))
  K  = array(0,sum(NNm))

  A1  = model$A1
  A2  = model$A2
  S1  = model$S1
  S2  = model$S2
  pk1  = model$pk1
  nk  = model$nk
  nf  = model$nf

  i =1
  for (l1 in 1:nf) for (l2 in 1:nf) {
    I = i:(i+NNm[l1,l2]-1)
    ni = length(I)
    jj = l1 + nf*(l2 -1)
    J1[I] = l1
    J2[I] = l2

    # draw k
    Ki = sample.int(nk,ni,T,pk1[jj,])
    K[I] = Ki

    # draw Y2, Y3
    Y1[I]  = A1[l1,Ki] + S1[l1,Ki] * rnorm(ni)
    Y2[I]  = A2[l2,Ki] + S2[l2,Ki] * rnorm(ni)

    i = i + NNm[l1,l2]
  }

  jdatae = data.table(k=K,y1=Y1,y2=Y2,j1=J1,j2=J2)
  return(jdatae)
}

#' Using the model, simulates a dataset of stayers.
#' @export
m2.mixt.simulate.stayers <- function(model,NNs) {

  J1 = array(0,sum(NNs))
  J2 = array(0,sum(NNs))
  Y1 = array(0,sum(NNs))
  Y2 = array(0,sum(NNs))
  K  = array(0,sum(NNs))

  A1  = model$A1
  A2  = model$A2
  S1  = model$S1
  S2  = model$S2
  pk0 = model$pk0
  nk  = model$nk
  nf  = model$nf

  # ------  impute K, Y1, Y4 on jdata ------- #
  i =1
  for (l1 in 1:nf) {
    I = i:(i+NNs[l1]-1)
    ni = length(I)
    J1[I] = l1

    # draw k
    Ki = sample.int(nk,ni,T,pk0[1,l1,])
    K[I] = Ki

    # draw Y2, Y3
    Y1[I]  = A1[l1,Ki] + S1[l1,Ki] * rnorm(ni)
    Y2[I]  = A2[l1,Ki] + S2[l1,Ki] * rnorm(ni)

    i = i + NNs[l1]
  }

  sdatae = data.table(k=K,y1=Y1,y2=Y2,j1=J1,j2=J1,x=1)

  return(sdatae)
}

#' Using the model, simulates a dataset of stayers.
#' @export
m2.mixt.simulate.stayers.withx <- function(model,NNsx) {

  J1 = array(0,sum(NNsx))
  J2 = array(0,sum(NNsx))
  Y1 = array(0,sum(NNsx))
  Y2 = array(0,sum(NNsx))
  K  = array(0,sum(NNsx))
  X  = array(0,sum(NNsx))

  A1  = model$A1
  A2  = model$A2
  S1  = model$S1
  S2  = model$S2
  pk0 = model$pk0
  nk  = model$nk
  nf  = model$nf
  nx  = nrow(NNsx)

  # ------  impute K, Y1, Y4 on jdata ------- #
  i =1
  for (l1 in 1:nf) for (x in 1:nx) {
    I = i:(i+NNsx[x,l1]-1)
    ni = length(I)
    J1[I] = l1

    # draw k
    Ki = sample.int(nk,ni,T,pk0[x,l1,])
    K[I] = Ki
    X[I] = x

    # draw Y2, Y3
    Y1[I]  = A1[l1,Ki] + S1[l1,Ki] * rnorm(ni)
    Y2[I]  = A2[l1,Ki] + S2[l1,Ki] * rnorm(ni)

    i = i + NNsx[x,l1]
  }

  sdatae = data.table(k=K,y1=Y1,y2=Y2,j1=J1,j2=J1,x=X)
  return(sdatae)
}

#' @export
m2.mixt.impute.movers <- function(jdatae,model) {

  A1  = model$A1
  S1  = model$S1
  pk1 = model$pk1
  A2  = model$A2
  S2  = model$S2
  nk  = model$nk
  nf  = model$nf

  # ------  impute K, Y1, Y4 on jdata ------- #
  jdatae.sim = copy(jdatae)
  jdatae.sim[, c('k_imp','y1_imp','y2_imp') := {
    ni = .N
    jj = j1 + nf*(j2-1)
    Ki  = sample.int(nk,.N,prob = pk1[jj,],replace=T)
    # draw Y1, Y4
    Y1 = rnorm(ni)*S1[j1,Ki] + A1[j1,Ki]
    Y2 = rnorm(ni)*S2[j2,Ki] + A2[j2,Ki]
    list(Ki,Y1,Y2)
  },list(j1,j2)]

  return(jdatae.sim)
}
#' @export
m2.mixt.impute.stayers <- function(sdatae,model) {

  A1  = model$A1
  S1  = model$S1
  pk0 = model$pk0
  A2  = model$A2
  S2  = model$S2
  nk  = model$nk
  nf  = model$nf

  # ------  impute K, Y1, Y4 on jdata ------- #
  sdatae.sim = copy(sdatae)
  sdatae.sim[, c('k_imp','y1_imp','y2_imp') := {
    ni = .N
    Ki  = sample.int(nk,.N,prob = pk0[x,j1,],replace=T)
    # draw Y2, Y3
    Y1  = A1[j1,Ki] + S1[j1,Ki] * rnorm(ni)
    Y2  = A2[j1,Ki] + S2[j1,Ki] * rnorm(ni) # false for movers
    list(Ki,Y1,Y2)
  },list(j1,x)]

  return(sdatae.sim)
}

#' Simulates data (movers and stayers) and attached firms ids. Firms have all same expected size.
#' @export
m2.mixt.simulate.sim <- function(model,fsize,smult=1,mmult=1) {
  jdata       = m2.mixt.simulate.movers(model,model$NNm*mmult)
  sdata       = m2.mixt.simulate.stayers(model,model$NNs*smult)

  # create some firm ids
  sdata <- sdata[,f1 := paste("F",j1 + model$nf*(sample.int(.N/fsize,.N,replace=T)-1),sep=""),j1]
  sdata <- sdata[,j1b:=j1]
  sdata <- sdata[,j1true := j1]
  jdata <- jdata[,j1true := j1][,j2true := j2]
  jdata <- jdata[,j1c:=j1]
  jdata <- jdata[,f1:=sample( unique(sdata[j1b %in% j1c,f1]) ,.N,replace=T),j1c]
  jdata <- jdata[,j2c:=j2]
  jdata <- jdata[,f2:=sample( unique(sdata[j1b %in% j2c,f1])  ,.N,replace=T),j2c]
  jdata$j2c=NULL
  jdata$j1c=NULL
  sdata$j1b=NULL
  sdata[,f2:=f1]

  sim = list(sdata=sdata,jdata=jdata)
  return(sim)
}

# -------------------- Estimating functions -----------------------------

#' Estimates the static model parameters for movers
#'
#' @export
m2.mixt.movers <- function(jdatae,model,ctrl) {

  start.time <- Sys.time()
  tic <- tic.new()

  dprior = ctrl$dprior
  model0 = ctrl$model0
  taum   = ctrl$tau

  ### ----- GET MODEL  ---
  nk  = model$nk
  nf  = model$nf
  A1  = model$A1
  S1  = model$S1
  A2  = model$A2
  S2  = model$S2
  pk1 = model$pk1

  # ----- GET DATA
  # movers
  Y1m = jdatae$y1
  Y2m = jdatae$y2
  J1m = jdatae$j1
  J2m = jdatae$j2
  JJm = J1m + nf*(J2m-1)
  Nm = jdatae[,.N]

  # get the constraints
  CS1  = cons.pad(cons.get(ctrl$cstr_type[1],ctrl$cstr_val[1],nk,nf),nk*nf*0, nk*nf*1)
  CS2  = cons.pad(cons.get(ctrl$cstr_type[2],ctrl$cstr_val[2],nk,nf),nk*nf*1,0)
  # combine them
  CS = cons.bind(CS1,CS2)

  # create the stationary contraints
  if (ctrl$fixb==T) {
    CS2 = cons.fixb(nk,nf,2)
    CS  = cons.bind(CS2,CS)
  }

  # create a constraint for the variances
  if (ctrl$model_var==T) {
    CSw = cons.none(nk,nf*2)
  } else{
    CS1  = cons.pad(cons.mono_k(nk,nf),nk*nf*0, nk*nf*3)
    CS2  = cons.pad(cons.mono_k(nk,nf),nk*nf*1, nk*nf*2)
    CSw  = cons.bind(CS1,CS2)
    CSw$meq = length(CSw$H)
  }

  # prepare matrices aggregated at the type level
  Dkj1f     = diag(nf)  %x% rep(1,nf) %x% diag(nk)            # A[k,l] coefficients for j1
  Dkj2f     = rep(1,nf) %x% diag(nf)  %x% diag(nk)            # A[k,l] coefficients for j2

  # regression matrix for the variance
  XX = rBind(
    cBind(    Dkj1f, 0*Dkj2f),
    cBind(  0*Dkj1f,   Dkj2f)
  )

  ## --- prepare regressions covariates --- #
  # create the depend variables

  lik_old  = -Inf
  lik      = -Inf
  lik_best = -Inf
  liks = 0
  likm=0

  lpt1 = array(0,c(Nm,nk))
  lpt2 = array(0,c(Nm,nk))
  lp   = array(0,c(Nm,nk))

  tic("prep")
  stop = F;
  for (step in 1:ctrl$maxiter) {

    model1 = list(nk=nk,nf=nk,A1=A1,A2=A2,S1=S1,S2=S2,
                  pk1=pk1,dprior=dprior)

    ### ---------- E STEP ------------- #
    # compute the tau probabilities and the likelihood
    if (is.na(taum[1]) | (step>1)) {

      # for efficiency we want to group by (l1,l2)
      for (l1 in 1:nf) for (l2 in 1:nf) {
        I = which( (J1m==l1) & (J2m==l2))
        ll = l1 + nf*(l2-1)
        if (length(I)==0) next;

        for (k in 1:nk) {
          lpt1[I,k] = lognormpdf(Y1m[I] , A1[l1,k], S1[l1,k])
          lpt2[I,k] = lognormpdf(Y2m[I] , A2[l2,k], S2[l2,k])

          # sum the log of the periods
          lp[I,k] = log(pk1[ll,k]) + lpt1[I,k] + lpt2[I,k]
        }
      }

      liks     = sum(logRowSumExp(lp))
      taum     = exp(lp - spread(logRowSumExp(lp),2,nk)) # normalize the k probabilities Pr(k|Y1,Y2,Y3,Y4,l)

      # compute prior
      lik_prior = (dprior-1) * sum(log(pk1))
      lik = liks + lik_prior

    } else {
      cat("skiping first max step, using supplied posterior probabilities\n")
    }

    tic("estep")

    if (stop) break;

    # ---------- MAX STEP ------------- #
    # taum = makePosteriorStochastic(tau = taum,m = ctrl$stochastic) # if we want to implement stochastic EM

    # we start by recovering the posterior weight, and the variances for each term
    rwm  = c(t(taum + ctrl$posterior_reg))

    if (ctrl$fixm==F) {
      DYY  = array(0,c(nk,nf,nf,2))
      WWT  = array(1e-7,c(nk,nf,nf,2))

      for (l1 in 1:nf) for (l2 in 1:nf) {
        I = which( (J1m==l1) & (J2m==l2))
        if (length(I)==0) next;
        for (k in 1:nk) {
          # compute the posterior weight, it's not time specific
          ww = sum(taum[I,k] + ctrl$posterior_reg)

          # construct dependent for each time period k,l2,l1,
          DYY[k,l2,l1,1] = sum(  Y1m[I] * (taum[I,k] + ctrl$posterior_reg) )/ww
          DYY[k,l2,l1,2] = sum(  Y2m[I] * (taum[I,k] + ctrl$posterior_reg) )/ww

          # Scaling the weight by the time specific variance
          WWT[k,l2,l1,1] = ww/pmax(ctrl$sd_floor,S1[l1,k]^2)
          WWT[k,l2,l1,2] = ww/pmax(ctrl$sd_floor,S2[l2,k]^2)
        }
      }

      WWT = WWT/sum(WWT)
      fit = slm.wfitc(XX,as.numeric(DYY),as.numeric(WWT),CS)$solution
      is  = 1
      A1  = t(rdim(fit[is:(is + nk*nf-1)],nk,nf)); is = is+nk*nf
      A2  = t(rdim(fit[is:(is + nk*nf-1)],nk,nf)); is = is+nk*nf

      # compute the variances!!!!
      DYY_bar   = array(0,c(nk,nf,nf,2))
      DYY_bar[] = XX%*%fit
      DYYV      = array(0,c(nk,nf,nf,2))

      for (l1 in 1:nf) for (l2 in 1:nf) {
        I = which( (J1m==l1) & (J2m==l2))
        if (length(I)==0) next;
        for (k in 1:nk) {
          # construct dependent for each time period k,l2,l1,
          ww = sum(taum[I,k] + ctrl$posterior_reg)
          DYYV[k,l2,l1,1] = sum(  (Y1m[I]  - DYY_bar[k,l2,l1,1])^2 * (taum[I,k] + ctrl$posterior_reg) )/ww
          DYYV[k,l2,l1,2] = sum(  (Y2m[I]  - DYY_bar[k,l2,l1,2])^2 * (taum[I,k] + ctrl$posterior_reg) )/ww
        }
      }

      fitv  = slm.wfitc(XX,as.numeric(DYYV),as.numeric(WWT),CSw)$solution
      is    = 1
      S1    = sqrt(t(rdim(fitv[is:(is + nk*nf-1)],nk,nf))); is = is+nk*nf
      S2    = sqrt(t(rdim(fitv[is:(is + nk*nf-1)],nk,nf))); is = is+nk*nf
      S1[S1<ctrl$sd_floor]=ctrl$sd_floor # having a variance of exacvtly 0 creates problem in the likelihood
      S2[S2<ctrl$sd_floor]=ctrl$sd_floor
    }
    tic("mstep-ols")

    ## -------- PK probabilities ------------ #
    ## --- movers --- #
    for (l1 in 1:nf) for (l2 in 1:nf) {
      jj = l1 + nf*(l2-1)
      I = which(JJm == jj)
      if (length(I)>1) {
        pk1[jj,] = colSums(taum[I,])
      } else if (length(I)==0) { # this deals with the case where the cell is empty
        pk1[jj,] = 1/nk
      } else {
        pk1[jj,] = taum[I,]
      }
      pk1[jj,] = (pk1[jj,] + dprior-1 )/(sum(pk1[jj,] + dprior -1 ))
    }

    #check_lik = computeLik(Y1m,Y2m,Y3m,Y4m,A12,B12,S12,A43,B43,S43,A2ma,A2mb,S2m,A3ma,A3mb,B32m,S3m)
    #if (check_lik<lik) cat("lik did not go down on pk1 update\n")

    tic("mstep-pks")

    # checking model fit
    if ((!any(is.na(model0))) & ((step %% ctrl$nplot) == (ctrl$nplot-1))) {
      I1 = order(colSums(A1))
      I2 = order(colSums(model0$A1))
      rr = addmom(A2[,I1],model0$A2[,I2],"A2")
      rr = addmom(A1[,I1],model0$A1[,I2],"A1",rr)
      rr = addmom(S2[,I1], model0$S2[,I2], "S2", rr,type="var")
      rr = addmom(S1[,I1], model0$S1[,I2], "S1", rr,type="var")
      rr = addmom(pk1,model0$pk1,"pk1",rr,type="pr")

      print(ggplot(rr,aes(x=val2,y=val1,color=type)) + geom_point() + facet_wrap(~name,scale="free") + theme_bw() + geom_abline(linetype=2))
    } else {
      if ((step %% ctrl$nplot) == (ctrl$nplot-1)) {
        wplot(A1)
      }
    }

    # -------- check convergence ------- #
    dlik = (lik - lik_old)/abs(lik_old)
    lik_old = lik
    lik_best = pmax(lik_best,lik)
    if ( (step %% ctrl$ncat) == 0) flog.info("[%3i][%s] lik=%4.4f dlik=%4.4e liks=%4.4e likm=%4.4e",step,ctrl$textapp,lik,dlik,liks,likm);
    if (step>10) if (abs(dlik)<ctrl$tol) break;

    tic("loop-wrap")
  }
  flog.info("[%3i][%s][final] lik=%4.4f dlik=%4.4e liks=%4.4e likm=%4.4e",step,ctrl$textapp,lik,dlik,liks,likm);

  # Y1 | Y2
  model$A1  = A1
  model$S1  = S1
  model$A2  = A2
  model$S2  = S2
  ## --movers --
  model$pk1  = pk1

  model$NNm  = acast(jdatae[,.N,list(j1,j2)],j1~j2,fill=0,value.var="N")
  model$likm = lik

  end.time <- Sys.time()
  time.taken <- end.time - start.time

  return(list(tic = tic(), model=model,lik=lik,step=step,dlik=dlik,time.taken=time.taken,ctrl=ctrl,liks=liks,likm=likm))
}

m2.mixt.rdim.pk1 <-function(pk1) {

}

#' use the marginal distributions to extract type distributions
#' within each cluster and observable characteristics
#' @export
m2.mixt.stayers <- function(sdata,model,ctrl) {

  # we set a linear programing problem to maximize likelihood subject
  # to non negetivity and summing to one

  # the objective weights are the the density evaluated at each k
  nk  = model$nk
  nf  = model$nf
  Y1  = sdata$y1   # firm id in period 1
  J1  = sdata$j1   #  wage in period 1
  X   = sdata$x    # observable category
  # @todo add code in case X is missing, just set it to one
  nx  = length(unique(X))
  N   = length(Y1)
  Wmu = t(model$A1)
  Wsg = t(model$S1)

  # we create the index for the movement
  # this needs to take into account the observable X
  J1x = X + nx*(J1-1) # joint in index for movement
  J1s <- Matrix(0, nrow = N, ncol = nf * nx, sparse = TRUE)
  II = 1:N + N*( J1x -1 ); J1s[II]=1
  tot_count = t(spread(Matrix::colSums(J1s),2,nk))
  empty_cells = (tot_count[1,]==0)

  #PI = rdirichlet(nf*nx,rep(1,nk))
  PI = rdim(model$pk0,nf*nx,nk)
  PI_old = PI

  lik_old = Inf
  iter_start =1

  for (count in iter_start:ctrl$maxiter) {
    # the coeffs on the pis are the sum of the norm pdf
    norm1 = dnorm(spread(Y1,2,nk),t(Wmu[,J1]),t(Wsg[,J1]))
    tau   = PI[J1x,]*norm1
    tsum  = Matrix::rowSums(tau)
    tau   = tau / spread( tsum ,2,nk  )
    lik   = - sum(log(tsum))

    PI    = t.default( as.array( t(tau) %*% J1s / tot_count  ))
    PI[empty_cells,] = array(1/nk,c(sum(empty_cells),nk))

    dPI = abs(PI - PI_old)
    max_change  = max(dPI)
    mean_change = mean(dPI)
    PI_old = PI

    if (!is.finite(lik)) { status = -5; break; }

    prg = (lik_old - lik)/lik
    lik_old = lik

    if ((count %% ctrl$ncat)==(ctrl$ncat-1)) {
      flog.info("[%3i][%s] lik=%4.4e inc=%4.4e max-pchg=%4.4e mean-pchg=%4.4e",count,ctrl$textapp,lik,prg,max_change,mean_change)
      flush.console()
    }

    if (max_change<ctrl$tol) {
      status = 1;
      msg = "converged";
      break;
    }

  }

  model$pk0  = rdim(PI,nx,nf,nk)
  model$liks = lik
  model$NNs  = sdata[,.N,j1][order(j1)][,N]

  return(model)
}

#' Estimates the static mixture model on 2 periods
#'
#' This estimator uses multiple starting values to try to find the global maxima.
#'
#' @export
m2.mixt.estimate.all <- function(sim,nk=6,ctrl,cl=NA) {
  start.time <- Sys.time()
  sdata = sim$sdata
  jdata = sim$jdata

  mm = mean(sdata$y1)
  ms = 2*sd(sdata$y1)

  # check that sdata has an x column
  if (!("x" %in% names(sdata))) {
    flog.info("creating an x column in sdata and set it to 1")
    sdata$x=1
  } else if (length(unique(sdata$x)) >= 50 ) {
    stop("likely too many values in the x column of sdata")
  }

  nf = max(sdata$j1);
  model_start = m2.mixt.new(nk,nf)

  res_para = m2.mixt.movers(jdata,model_start,ctrl=em.control(ctrl,cstr_type="para",textapp="para0",fixb=F))

  # use cluster if available
  if (!any(is.na(cl))) {
    flog.info("cluster -- exporting objects to nodes")
    # export environment to nodes
    clusterExport(cl,c("res_para","jdata","ctrl"),environment())
    mylapply <- function(...) parLapply(cl,...)
    nnodes=length(cl)
  } else {
    mylapply <- function(...) lapply(...)
    nnodes=1
  }

  flog.info("starting repetitions with %i nodes",nnodes)
  rr  = mylapply(1:ctrl$est_rep, function(i) {
    res_mixt = list()
    tryCatch({
      res_para$model$A1 = spread(sort(rnorm(nk))*ms+mm,1,nf)
      res_para$model$A2 = res_para$model$A1
      res_para_fixm = m2.mixt.movers(jdata,res_para$model,ctrl=em.control(ctrl,cstr_type="para",textapp=sprintf("paraf (%i/%i)",i,ctrl$est_rep),fixm=T,fixb=F))
      res_para_new  = m2.mixt.movers(jdata,res_para_fixm$model,ctrl=em.control(ctrl,textapp=sprintf("para1 (%i/%i)",i,ctrl$est_rep),cstr_type="para",fixm=F,fixb=F))
      res_mixt      = m2.mixt.movers(jdata,res_para_new$model,ctrl=em.control(ctrl,textapp=sprintf("move1 (%i/%i)",i,ctrl$est_rep)))

      # ------ compute connectedness ----- #
      res_mixt$connectedness = model.connectiveness(res_mixt$model)
      res_mixt$rep_id = i
    }, error = function(e) {catf("error in rep %i!\n",i);print(e);})
    flog.info("done with reptitions %i/%i",i,ctrl$est_rep)
    res_mixt
  })

  # backing up to disk
  save(rr,ctrl,file=paste(ctrl$file_backup_prefix,"data",sep="."))

  # extract likelihoods and connectedness
  rrd = ldply(rr,function(r) {
    data.frame(lik_mixt = r$model$likm,connectedness = r$connectedness,i=r$rep_id)
  })

  # selecting best starting value
  rrd     = data.table(rrd)
  rrd[, sel:=-1]
  rrd.sub = rrd[order(-lik_mixt)][1:ctrl$est_nbest]
  rrd[i %in% rrd.sub$i, sel:=0]
  Ibest = rrd.sub[order(-connectedness)][1,i]
  res_mixt = rr[[Ibest]]
  rrd[i==Ibest, sel:=1]

  # sub-sample the stayers for computational reasons (if too large)
  if (ctrl$sdata_subredraw==TRUE) {
    sim$sdata[,sample := rank(runif(.N))/.N<=ctrl$sdata_subsample,j1]
    flog.info("drawing %f from the stayers",ctrl$sdata_subsample)
  }

  res_mixt$model = m2.mixt.stayers(sim$sdata[sample==1],res_mixt$model,ctrl = em.control(ctrl,textapp="stayers"))
  res_mixt$second_stage_reps = rrd
  res_mixt$second_stage_reps_all = rr

  # ------ compute linear decomposition ------- #
  NNm = res_mixt$model$NNm
  NNs = res_mixt$model$NNs/ctrl$sdata_subsample
  NNm[!is.finite(NNm)]=0
  NNs[!is.finite(NNs)]=0
  share_s  = sum(NNs)/(sum(NNm) + sum(NNs))
  share_m  = sum(NNm)/(sum(NNm) + sum(NNs))

  NNs = round(NNs*ctrl$vdec_sim_size*share_s/sum(NNs))
  NNm = round(NNm*ctrl$vdec_sim_size*share_m/sum(NNm))

  # we simulate from the model both movers and stayers
  sdata.sim = m2.mixt.simulate.stayers(res_mixt$model,NNs)
  jdata.sim = m2.mixt.simulate.movers(res_mixt$model,NNm)
  sdata.sim = rbind(sdata.sim[,list(j1,k,y1)],jdata.sim[,list(j1,k,y1)])
  vdec  = lin.proj(sdata.sim,y_col = "y1",k_col="k",j_col = "j1")

  res_mixt$vdec = vdec
  res_mixt$ctrl = ctrl
  end.time <- Sys.time()

  res_mixt$time.taken <- end.time - start.time

  return(res_mixt)
}

#' Computes the variance decomposition by simulation
#' @export
m2.mixt.vdec <- function(model,nsim,stayer_share=1,ydep="y2") {

  if (ydep!="y1") flog.warn("ydep other than y1 is not implemented, using y1")

  # simulate movers/stayers, and combine
  NNm = model$NNm
  NNs = model$NNs
  NNm[!is.finite(NNm)]=0
  NNs[!is.finite(NNs)]=0

  NNs = round(NNs*nsim*stayer_share/sum(NNs))
  NNm = round(NNm*nsim*(1-stayer_share)/sum(NNm))
  flog.info("computing var decomposition with ns=%i nm=%i",sum(NNs),sum(NNm))

  # we simulate from the model both movers and stayers
  sdata.sim = m2.mixt.simulate.stayers(model,NNs)
  jdata.sim = m2.mixt.simulate.movers(model,NNm)
  sdata.sim = rbind(sdata.sim[,list(j1,k,y1)],jdata.sim[,list(j1,k,y1)])
  proj_unc  = lin.proj(sdata.sim,"y1","k","j1");

  return(proj_unc)
}

#' Compute mean effects
#' @export
m2.mixt.meaneffect <- function(model) {
  NNs = model$NNs*10 # used 10% sample
  NNm = model$NNm
  share_s  = sum(NNs)/(sum(NNm) + sum(NNs))
  share_m  = sum(NNm)/(sum(NNm) + sum(NNs))

  NNs = round(NNs*1e6*share_s/sum(NNs))
  NNm = round(NNm*1e6*share_m/sum(NNm))

  # we simulate from the model both movers and stayers
  sdata = m2.mixt.simulate.stayers(model,NNs)
  jdata = m2.mixt.simulate.movers(model,NNm)
  sdata = rbind(sdata[,list(j1,k,y1)],jdata[,list(j1,k,y1)])

  # compute decomposition
  #vdec  = lin.proj(sdata,y_col = "y1",k_col="k",j_col = "j1")
  #res_bs$mixt_all[[nn]]$vdec_1m = vdec
  rt    = sample.stats(sdata,"y1","pk0")

  # then we set the distribution to uniform
  model_nosort = copy(model)
  model_nosort$pk0[1,,] = spread(colSums(model_nosort$pk0[1,,] * spread(NNs/(sum(NNs)),2,model_nosort$nk)),1,model_nosort$nf)

  # movers
  dpk1 = m2.get.pk1(model)
  pk   = dpk1[,pr_k[1],k][,V1]
  model_nosort$pk1      = spread(pk,1,model$nf * model$nf)

  # simulate from uniform
  sdata = m2.mixt.simulate.stayers(model_nosort,NNs)
  jdata = m2.mixt.simulate.movers(model_nosort,NNm)
  sdata = rbind(sdata[,list(j1,k,y1)],jdata[,list(j1,k,y1)])
  rt2   = sample.stats(sdata,"y1","pku")

  return(rbind(rt,rt2))
}

# ------------- Testing functions ---------------------

# for more tests, look at tests/testthat/test_model_mixt2.R

# here we want to check a bunch of properties for the EM steps
# model1 and model2 should be 2 consecutive steps
m2.mixt.check <- function(Y1,Y2,J1,J2,JJ,nk,Nm,model1,...) {

  change = list(...)

  # compute posterior for model1
  res1 = with(model1,{
    taum = array(0,c(Nm,nk))
    lpm  = array(0,c(Nm,nk))
    likm = 0
    for (i in 1:Nm) {
      ltau = log(pk1[JJ[i],])
      lnorm1 = lognormpdf(Y1[i], A1[J1[i],], S1[J1[i],])
      lnorm2 = lognormpdf(Y2[i], A2[J2[i],], S2[J2[i],])
      lall = ltau + lnorm2 + lnorm1
      lpm[i,] = lall
      likm = likm + logsumexp(lall)
      taum[i,] = exp(lall - logsumexp(lall))
    }

    # compute prior
    lik_prior = (dprior-1) * sum(log(pk1)) # dirichlet distribution
    lik = likm + lik_prior
    list(taum = taum, lpm =lpm, lik=likm,lik_prior=lik_prior,post=lik)
  })

  model2 = copy(model1)
  model2[names(change)] = change[names(change)]

  # compute posterior for model2
  res2 = with(model2,{
    taum = array(0,c(Nm,nk))
    lpm  = array(0,c(Nm,nk))
    likm = 0
    for (i in 1:Nm) {
      ltau = log(pk1[JJ[i],])
      lnorm1 = lognormpdf(Y1[i], A1[J1[i],], S1[J1[i],])
      lnorm2 = lognormpdf(Y2[i], A2[J2[i],], S2[J2[i],])
      lall = ltau + lnorm2 + lnorm1
      lpm[i,] = lall
      likm = likm + logsumexp(lall)
      taum[i,] = exp(lall - logsumexp(lall))
    }

    # compute prior
    lik_prior = (dprior-1) * sum(log(pk1)) # dirichlet distribution
    lik = likm + lik_prior
    list(taum = taum, lpm =lpm, lik=likm,lik_prior=lik_prior,post=lik)
  })

  # do the analysis, Evaluate Q(theta | theta^t) , Q(theta^t | theta^t), H(theta | theta^t) and H(theta^t | theta^t)
  Q1 = sum( ( (res1$taum) * res1$lpm ))
  Q2 = sum( ( (res1$taum) * res2$lpm ))
  H1 = - sum( (res1$taum) * log(res1$taum))
  H2 = - sum( (res1$taum) * log(res2$taum))

  warn_str=""
  test = TRUE
  if (( Q2<Q1) | (H2<H1)) {
    warn_str = "!!!!!!!!!";
    test=FALSE
  }
  catf("[emcheck] %s Qd=%4.4e Hd=%4.4e %s\n",paste(names(change),collapse = ","),  Q2-Q1,H2-H1,warn_str)
  return(test)
}

m2.mixt.test <- function() {
  nf = 10
  nk = 6
  model = m2.mixt.new(nk,nf)
  NNm = floor(array(30000/(nf^2),c(nf,nf)))
  jdata = m2.mixt.simulate.movers(model,NNm)

  ctrl   = em.control(nplot=10,check_lik=F,fixb=F,est_rho=F,model0=model,dprior=1.05,maxiter=100)
  ctrl$posterior_reg=0
  ctrl$fixm=FALSE
  ctrl$ncat=5
  ctrl$check_lik=FALSE

  res = m2.mixt(jdata,model,ctrl)

  # trying to do the no from there with 3 components
  ctrl$model0=NA
  model_np = step2.static.em.np.new.from.ns(res$model,nm=3)
  res =   model_np = step2.static.em.np.movers.estimate(jdata,model_np,ctrl)

  # try to plot the outcome.

  res$model$W1

  res = m2.mixt.fixed(jdata,model)
}

em.endo.simulatebest <- function() {

  # load the grid
  load("inst/figures/src/em-endo-full_rhogrid-halton-6x10.dat",verbose=F)

  # find the best
  dd = data.frame()
  for (r in rr) {
    dd = rbind(dd,data.frame(rho=r$model$B32m,lik=r$lik,time=r$time.taken,step=r$step,dlik=r$dlik))
  }
  rbest = rr[[which.max(dd$lik)]]
  cat(sprintf("%i evaluations, best value is %f\n",length(rr),rbest$lik))

  # get number of movers
  load("../figures/src/em-endo-info.dat",verbose=F)

  # reweight the statyers to 30,0000
  tot = NNs[,sum(ni)]
  NNs[,ni := round(ni * 30000 /sum(ni)) ]
  setkey(NNs,j)
  NNs = NNs[,ni]

  # get the movers matrix
  NNm = acast(NNm,j1~j2,value.var="ni")

  # ----- simulate ------ #
  nk = rbest$model$nk;
  nf = rbest$model$nf;
  model = rbest$model
  jdatae = em.endo.full.simulate.movers(model,NNm)
  sdatae = em.endo.full.simulate.stayers(model,NNs)
  jdatae[,m:=1][,w:=1]
  sdatae[,m:=0][,w:=tot/.N]
  sdatae[,j2:=j1]
  adatae = rbind(sdatae,sdatae)
  cat(sprintf("simulated data with %i stayers and %i movers \n",sdatae[,.N],jdatae[,.N]))
  return(adatae)
}

#' @export
m2.get.pk1 <- function(model) {
  pk1 = rdim(model$pk1,model$nf,model$nf,model$nk)
  dd_post = data.table(melt(pk1,c('j1','j2','k')))
  pp = model$NNm/sum(model$NNm)
  dd_post <- dd_post[, pr_j1j2 := pp[j1,j2],list(j1,j2)  ]
  dd_post <- dd_post[, pr_j1j2k := pr_j1j2*value]
  dd_post <- dd_post[, pr_k := sum(pr_j1j2k),k]
  dd_post
}

#' Returns the uconditional type probability in the crossection
#' @export
m2.get.pk_unc <- function(model,supersample=0.1) {
  dpk1     = m2.get.pk1(model)
  pk_m     = acast(dpk1[,sum(pr_j1j2k),list(j1,k)],j1~k,value.var = "V1")
  NNs      = model$NNs*round(1/supersample) # used 10% sample
  NNm      = model$NNm
  share_s  = sum(NNs)/(sum(NNm) + sum(NNs))
  pk_unc   = share_s*rdim(res_main$model$pk0[,,I],res_main$model$nf,res_main$model$nk) +
    (1- share_s) * pk_m
  pk_unc
}

#' check the fit in the movers/stayers using imputed data
#' @export
m2.movers.checkfit <- function(jdata) {
  dd = jdata[, {
    d1=data.frame(src="data",
                  m1=mean(y1),m2=mean(y2),
                  d12=mean(y1-y2),
                  cov12=cov(y1,y2),v1=var(y1),v2=var(y2))
    d2=data.frame(src="imp",
                  m1=mean(y1_imp),m2=mean(y2_imp),
                  d12=mean(y1_imp-y2_imp),
                  cov12=cov(y1_imp,y2_imp),v1=var(y1_imp),v2=var(y2_imp))
    rbind(d1,d2)
  },list(j1,j2)]

  ddm = melt(dd,id.vars = c("j1","j2","src"))
  ddm = cast(ddm,j1+j2+variable~src,value = "value")
  ggplot(ddm,aes(x=data,y=imp)) + geom_point() + facet_wrap(~variable,scales = "free") + theme_bw() +
    geom_abline(linetype=2)
  ddm
}

#' check the fit in the movers/stayers using imputed data
#' @export
m2.stayers.checkfit <- function(sdata,r1,r4) {
  dd = jdata[, {
    d1=data.frame(src="data",
                  m1=mean(y1),m2=mean(y2),
                  d12=mean(y1-y2),
                  cov12=cov(y1,y2),v1=var(y1),v2=var(y2))
    d2=data.frame(src="imp",
                  m1=mean(y1_imp),m2=mean(y2_imp),
                  d12=mean(y1_imp-y2_imp),
                  cov12=cov(y1_imp,y2_imp),v1=var(y1_imp),v2=var(y2_imp))
    rbind(d1,d2)
  },list(j1)]

  ddm = melt(dd,id.vars = c("j1","src"))
  ddm = cast(ddm,j1+variable~src,value = "value")
  ggplot(ddm,aes(x=data,y=imp)) + geom_point() + facet_wrap(~variable,scales = "free") + theme_bw() +
    geom_abline(linetype=2)
  ddm
}


library(RColorBrewer)
source("style.r")

args = commandArgs(trailingOnly = TRUE)
data = read.csv(args[1])

mycolors <- colorRampPalette(brewer.pal(9, "Blues"))(60)
tgt = data.frame(x = c(23.919, 161/6), y = c(23.919, 140/6), type = c('Avg Target Tput', 'Mobius'))

p = ggplot() +
	geom_abline(slope = 1, color = "grey") +
	geom_line(data = data, mapping = aes(x = app1, y = app2, color = factor(round)), size = 0.7) +
	geom_point(data = data, mapping = aes(x = app1, y = app2, color = factor(round)), size = 3) +
	geom_point(data = tgt, mapping = aes(x = x, y = y, shape = type), fill = 'red', size = 3) +
	scale_color_manual(values = mycolors) +
	scale_shape_manual(values = c(22, 25)) +
	guides(color = FALSE) +
	xlab("Cust 1 Tput (tasks/round)") +
	ylab("Cust 2 Tput (tasks/round)") +
	theme(legend.position = "top", legend.margin=margin(0,0,0,0), legend.box.margin=margin(-7,-7,-7,-7)) +
	labs(color = "", shape = "")
ggsave(args[2], p, width = 3, height = 2.5, units = 'in')


library(randomForest)
library(ROCR)

train_tf_idf = read.csv("/Users/ouyamei/Documents/GitHub/kaggle-crisis/data/kaggle_train_tf_idf.csv")
train_wc = read.csv("/Users/ouyamei/Documents/GitHub/kaggle-crisis/data/kaggle_train_wc.csv")
test_wc = read.csv("/Users/ouyamei/Documents/GitHub/kaggle-crisis/data/kaggle_test_wc.csv")

features = train_tf_idf[0:3000,c(-1,-502)]
label = as.factor(train_tf_idf$Predict[0:3000])
features_v = train_tf_idf[3000:4000,c(-1,-502)]
label_v = as.factor(train_tf_idf$Predict[3000:4000])

# find a best mtry parameter
bestmtry <- tuneRF(features,label, ntreeTry=100,
     stepFactor=1.5,improve=0.01, trace=TRUE, plot=TRUE, dobest=FALSE)

# use parameter to train a random forest model
rf <- randomForest(x=features, y=label, mtry=373, ntree=500,
     keep.forest=TRUE, importance=TRUE)

# create more model to compare, actually tried more than this
rf2 <- randomForest(x=features, y=label, mtry=373, ntree=500,
     classwt=c(3293,707), importance=TRUE)

# get the statitic result
rf.pr = predict(rf,newdata=features_v)
error = mean(rf.pr!=label_v)
library(Epi)
ROC(form=label_v~rf.pr, plot="ROC")
important_varibles = importance(rf,type=1)


# since Feb. 23
# france = c(1,1,1,2,2,2,2,2,3,4,7,9,16,19,30,33,48,61,79,
#           91,127,148,175,264,372,450,562,674,860)
# Since Feb. 29
france = c(2,2,
           3,4,7,9,16,19,30,
           33,48,61,79,91,127,148,
           175,264,372,450,562,674,860,
           1100,1331)

startDate = ISOdate(2020, 2, 29)
population = 67000000
data = france
source('./approxnlsLM.r')


#######################################################################
# A benchmark script to compare the run time of S-RASTER and three
# other stream algorithms.
source('sraster.r')
printf <- function(...) cat(sprintf(...))

nr_repeats = 10L
n_clusters = 1000L
algorithms <- list(
  "Windowed k-means"=function() { DSC_TwoStage(micro = DSC_Window(horizon = 100),
               macro = DSC_Kmeans(k = 100)) },
  "DStream"=function() { DSC_DStream(gridsize = 0.0003) },
  "DBStream"=function() { DSC_DBSTREAM(r = 0.0002, Cm=0.0, gaptime = 25000) },
  "S-RASTER"=function() { DSC_SRaster(p=3.5, window_size = 10) }
)

write("run number,algorithm, user time[s],elapsed time[s],#clusters, #micro clusters", file="benchmark_results.csv")
write("algorithm,mean elapsed time[s],#clusters", file="mean_benchmark_results.csv")

datafile <- "data/data_10000.csv"
timed_datafile <- "data/timed_data_10000.csv"

for (alg_name in names(algorithms)) {
  alg_fun <- algorithms[[alg_name]]
  times <- c()
  clustereds <- c()
  for (run_number in 1:nr_repeats) {
    alg <- alg_fun()
    if (alg_name == "S-RASTER") {
      cat("Use timed data\n")
      stream <- DSD_ReadCSV(timed_datafile)
    } else {
      cat("Use 2D data\n")
      stream <- DSD_ReadCSV(datafile)
    }
    n_steps <- 10L
    for (x in 1:n_steps) {
      nr_points <- 500L*n_clusters
      t <- system.time({ update(alg, stream, nr_points) })
      times <- c(times, t[3])

      end_clusters <- NROW(get_centers(alg, type='macro'))
      clustereds <- c(clustereds, end_clusters)

      line <- sprintf("%d,%s,%.3f,%.3f,%d", run_number, alg_name, t[1], t[3], end_clusters)
      cat(paste(line, "\n"))
      write(line, file="benchmark_results.csv", append=TRUE)
    }
    close_stream(stream)
    #plot(a, type = "both", weights = FALSE)
  }
  m_times <- matrix(times, nrow = n_steps)
  avg_times <- apply(m_times, 1, mean)
  m_clustereds <- matrix(clustereds, nrow = n_steps)
  avg_clustereds <- apply(m_clustereds, 1, mean)
  for (i in 1:n_steps){
    mean_t = avg_times[[i]]
    mean_c = avg_clustereds[[i]]
    line <- sprintf("%s,%.3f,%.1f", alg_name, mean_t,mean_c)
    write(line, file="mean_benchmark_results.csv", append=TRUE)
  }
}

cat("Done!\n")


cat("#### Test estimateV specials for HEB25 with asreml4\n")
test_that("HEB25_estimateV_asreml4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(dae)
  library(asreml)
  library(asremlPlus)

  data(cart.dat)

  #us(Treatment):Genotype
  asreml.options(keep.order = TRUE) #required for asreml4 only
  HEB25.asr <- asreml(fixed = Height ~ Smarthouse + Check + Treatment.1 +
                        Smarthouse:xMainPosn + Smarthouse:xLane + Check:Treatment.1,
                      random = ~ us(Treatment.1):Genotype.ID + Smarthouse:Zones:Mainplots,
                      residual = ~idh(Treat.Smarthouse):Zones:Mainplots,
                      data = cart.dat, na.action=na.method(y="include", x="include"),
                      maxiter = 1000, trace = FALSE)
  summary(HEB25.asr)$varcomp
  Vus <- estimateV(HEB25.asr)
  Vus[1:10, 1:9]

  #corv(Treatment):Genotype
  HEB25.asr <- asreml(fixed = Height ~ Smarthouse + Check + Treatment.1 +
                        Smarthouse:xMainPosn + Smarthouse:xLane + Check:Treatment.1,
                      random = ~ corv(Treatment.1):Genotype.ID + Smarthouse:Zones:Mainplots,
                      residual = ~idh(Treat.Smarthouse):Zones:Mainplots,
                      data = cart.dat, na.action=na.method(y="include", x="include"),
                      maxiter = 1000, trace = FALSE)
  summary(HEB25.asr)$varcomp
  V <- estimateV(HEB25.asr)
  V[1:10, 1:9]
  testthat::expect_false(abs(V[1,1] - 7524245) > 10)

  #corh(Treatment):Genotype
  HEB25.asr <- asreml(fixed = Height ~ Smarthouse + Check + Treatment.1 +
                        Smarthouse:xMainPosn + Smarthouse:xLane + Check:Treatment.1,
                      random = ~ corh(Treatment.1):Genotype.ID + Smarthouse:Zones:Mainplots,
                      residual = ~idh(Treat.Smarthouse):Zones:Mainplots,
                      data = cart.dat, na.action=na.method(y="include", x="include"),
                      maxiter = 1000, trace = FALSE)
  summary(HEB25.asr)$varcomp
  V <- estimateV(HEB25.asr)
  V[1:10, 1:9]
  testthat::expect_false(abs(V[1,1] - 8234025) > 10)

  #corgh(Treatment):Genotype
  HEB25.asr <- asreml(fixed = Height ~ Smarthouse + Check + Treatment.1 +
                        Smarthouse:xMainPosn + Smarthouse:xLane + Check:Treatment.1,
                      random = ~ corgh(Treatment.1):Genotype.ID + Smarthouse:Zones:Mainplots,
                      residual = ~idh(Treat.Smarthouse):Zones:Mainplots,
                      data = cart.dat, na.action=na.method(y="include", x="include"),
                      maxiter = 1000, trace = FALSE)
  summary(HEB25.asr)$varcomp
  V <- estimateV(HEB25.asr)
  V[1:10, 1:9]
  testthat::expect_false(any(abs(Vus - V) > 1e+03))

  #corgh(Treatment):Genotype + diag
  HEB25.asr <- asreml(fixed = Height ~ Smarthouse + Check + Treatment.1 +
                        Smarthouse:xMainPosn + Smarthouse:xLane + Check:Treatment.1,
                      random = ~ corgh(Treatment.1):Genotype.ID + Smarthouse:Zones:Mainplots,
                      residual = ~diag(Treat.Smarthouse):Zones:Mainplots,
                      data = cart.dat, na.action=na.method(y="include", x="include"),
                      maxiter = 1000, trace = FALSE)
  summary(HEB25.asr)$varcomp
  Vdiag <- estimateV(HEB25.asr)
  Vdiag[1:10, 1:9]
  testthat::expect_false(any(abs(Vdiag - V) > 1e+03))

})


library(ggplot2)
library(scales)
library(ggpubr)
library(bayesplot)
library(matrixStats)
library(cowplot)
library(svglite)
library(gridExtra)

args <- commandArgs(trailingOnly = TRUE)
filename <- args[1]
model_input <- args[2]

if(model_input %in% c('combined', 'combinedTDI', 'combined_hospitals')){
  load(paste0(model_input, "/results/", filename))
} else{
  load(paste0('single/',model_input, "/results/", filename))
}

# plot_labels <- c("School Closure",
#                  "Self Isolation",
#                  "Public Events",
#                  "First Intervention",
#                  "Lockdown", 'Social distancing')

p_list <- list()

for(iter in 1:length(out$alpha[1,1,])){
  alpha = data.frame(as.matrix(out$alpha[,,iter]))

  # colnames(alpha) = plot_labels

  # suppressMessages({p = mcmc_intervals(alpha, prob = .9,transformations = function(x) exp(-x))+
  #   scale_x_continuous(limits = c(0,1.1), breaks=seq(0,1,0.2))+
  #   ggtitle(names(dates)[iter])})

  suppressMessages({p = mcmc_intervals(alpha, prob = .9,transformations = function(x) x)+
    ggtitle(names(dates)[iter])})

  class(p) <- 'ggplot'

  p_list[[iter]] <- p
}

for(i in 1:length(dates)){
  p_list[[i]] = ggplotGrob(p_list[[i]])
}
# p_list <- rev(p_list)
class(p_list) <- c("arrangelist", class(p_list))
if(model_input %in% c('combined', 'combinedTDI', 'combined_hospitals')){
  ggsave(paste0(model_input, "/results/alpha-", filename, ".pdf"), p_list,height=4,width=6)
} else{
  ggsave(paste0('single/',model_input, "/results/alpha-", filename, ".pdf"), p_list,height=4,width=6)
}


input <- readline("Enter two integers.  Space delimited, please:  ")
dims <- as.numeric(strsplit(input, " ")[[1]])
arr <- array(dim=dims)
ii <- ceiling(dims[1]/2)
jj <- ceiling(dims[2]/2)
arr[ii, jj] <- sum(dims)
cat("array[", ii, ",", jj, "] is ", arr[ii, jj], "\n", sep="")


# 4. faza: Napredna analiza podatkov

source("lib/libraries.r")

################################################################################
# RAZVRŠČANJE V SKUPINE -
# Razvrščanje držav v skupine glede na to, kakšne rezultate dosegajo

### Najprej k-means:

# Tabela s podatki o državah:
# | država | točke DH | točke SG | točke GS | točke SL | povprečen YB |

# Najprej spremenimo kratice držav, da lahko združimo z zemljevidom
prave.kratice <- REZULTATI.VREME %>%
  mutate(NSA = str_replace_all(REZULTATI.VREME$NSA, pattern = "SLO", replacement = "SVN"))
prave.kratice <- prave.kratice %>%
  mutate(NSA = str_replace_all(prave.kratice$NSA, pattern = "GER", replacement = "DEU"))
prave.kratice <- prave.kratice %>%
  mutate(NSA = str_replace_all(prave.kratice$NSA, pattern = "CRO", replacement = "HRV"))
prave.kratice <- prave.kratice %>%
  mutate(NSA = str_replace_all(prave.kratice$NSA, pattern = "SUI", replacement = "CHE"))
prave.kratice <- prave.kratice %>%
  mutate(NSA = str_replace_all(prave.kratice$NSA, pattern = "NED", replacement = "NLD"))
prave.kratice <- prave.kratice %>%
  mutate(NSA = str_replace_all(prave.kratice$NSA, pattern = "BUL", replacement = "BGR"))
prave.kratice <- prave.kratice %>%
  mutate(NSA = str_replace_all(prave.kratice$NSA, pattern = "GRE", replacement = "GRC"))
prave.kratice <- prave.kratice %>%
  mutate(NSA = str_replace_all(prave.kratice$NSA, pattern = "MON", replacement = "MCO"))
prave.kratice <- prave.kratice %>%
  mutate(NSA = str_replace_all(prave.kratice$NSA, pattern = "RSF", replacement = "RUS"))
prave.kratice

DH.analiza <- prave.kratice %>% filter(Disciplina == "DH") %>% group_by(NSA) %>%
  summarise(tocke.DH = sum(tocke_30))
SG.analiza <- prave.kratice %>% filter(Disciplina == "SG") %>% group_by(NSA) %>%
  summarise(tocke.SG = sum(tocke_30))
GS.analiza <- prave.kratice %>% filter(Disciplina == "GS") %>% group_by(NSA) %>%
  summarise(tocke.GS = sum(tocke_30))
SL.analiza <- prave.kratice %>% filter(Disciplina == "SL") %>% group_by(NSA) %>%
  summarise(tocke.SL = sum(tocke_30))
YB.analiza <- prave.kratice %>% group_by(NSA) %>% summarise(YB.povprecen = mean(YB))

drzave <- left_join(prave.kratice, DH.analiza, by = "NSA")
drzave <- left_join(drzave, SG.analiza, by = "NSA")
drzave <- left_join(drzave, GS.analiza, by = "NSA")
drzave <- left_join(drzave, SL.analiza, by = "NSA")
drzave <- left_join(drzave, YB.analiza, by = "NSA")

drzave <- drzave %>%
  dplyr::select(YB.povprecen, NSA, tocke.DH, tocke.SG, tocke.GS, tocke.SL)

drzave$tocke.DH[is.na(drzave$tocke.DH)] <- 0
drzave$tocke.SG[is.na(drzave$tocke.SG)] <- 0
drzave$tocke.GS[is.na(drzave$tocke.GS)] <- 0
drzave$tocke.SL[is.na(drzave$tocke.SL)] <- 0
drzave <- unique(drzave)

# Clustering s k-means
set.seed(123)

skupine <- drzave[,-2] %>%
  kmeans(centers = 5) %>%
  getElement("cluster") %>%
  as.ordered()
print(skupine)

tabela.skupine <- drzave %>%
  transform(NSA = as.factor(NSA)) %>%
  mutate(Skupine = as.numeric(skupine))

zemljevid.za.skupine <-
  uvozi.zemljevid(
    "http://www.naturalearthdata.com/http//www.naturalearthdata.com/download/50m/cultural/ne_50m_admin_0_countries.zip",
    "ne_50m_admin_0_countries",
    mapa = "zemljevidi",
    pot.zemljevida = "",
    encoding = "UTF-8"
  ) %>%
  fortify() %>% filter(long < 170 & long > -170 & lat > 0 & lat < 85)

zemljevid.po.skupinah <- ggplot() +
  aes(x = long, y = lat, group = group, fill = Skupine) +
  geom_polygon(data=tabela.skupine %>% right_join(zemljevid.za.skupine,
                                                  by = c("NSA" = "ADM0_A3"))) +
  xlab("") +
  ylab("") +
  ggtitle("Države s podobno strukturo smučarjev 2020/21") +
  coord_fixed(ratio = 2) +
  guides(fill=guide_legend(title="Skupina")) +
  theme(legend.title = element_text(color = "black", size = 11),
        legend.background = element_rect(colour ="#006699", fill = "white"),
        plot.title = element_text(color = "#006699", hjust = 0.5, size = 15))
zemljevid.po.skupinah

### Še hierarhično razvrščanje:
dendrogram <- drzave[,-2] %>%
  dist() %>%
  hclust()

plot(dendrogram,
     labels = drzave$NSA,
     ylab = "višina",
     main = NULL)

hc.kolena <- function(dendrogram, od = 1, do = NULL, eps = 0.5) {
  # število primerov in nastavitev parametra do
  n = length(dendrogram$height) + 1
  if (is.null(do)) {
    do = n - 1
  }
  k.visina = tibble(
    k = as.ordered(od:do),
    visina = dendrogram$height[do:od]
  ) %>%
    mutate(
      dvisina = visina - lag(visina)
    ) %>%
    mutate(
      koleno = lead(dvisina) - dvisina > eps
    )
  k.visina
}

# iz tabele k.visina vrne seznam vrednosti k, pri katerih opazujemo koleno
hc.kolena.k <- function(k.visina) {
  k.visina %>%
    filter(koleno) %>%
    dplyr::select(k) %>%
    unlist() %>%
    as.character() %>%
    as.integer()
}

# tabela s koleni za dendrogram
r <- hc.kolena(dendrogram)

diagram.kolena <- function(k.visina) {
  k.visina %>% ggplot() +
    geom_point(
      mapping = aes(x = k, y = visina),
      color = "red"
    ) +
    geom_line(
      mapping = aes(x = as.integer(k), y = visina),
      color = "red"
    ) +
    geom_point(
      data = k.visina %>% filter(koleno),
      mapping = aes(x = k, y = visina),
      color = "#006699", size = 2
    ) +
    ggtitle(paste("Kolena:", paste(hc.kolena.k(k.visina), collapse = ", "))) +
    xlab("število skupin (k)") +
    ylab("razdalja pri združevanju skupin") +
    theme_classic()
}

diagram.kolena(r)

################################################################################
# NAPOVEDNI MODEL
# Napovemo uvrstitev, ki jo pričakujemo od smučarja glede na to, katere smuči uporablja,
# v kateri disciplini tekmuje in glede na snežno podlago

# spemenimo imenske spremenljivke v numerične
one_hot = function(pod, spr) {
  domena = pod %>%
    dplyr::select({{spr}}) %>%
    unlist() %>%
    unique()
  for (v in domena) {
    pod = pod %>%
      mutate(
        "{{spr}}.{v}" := ifelse({{spr}} == v, 1, 0)
      )
  }
  pod %>% dplyr::select(-{{spr}})
}

smuci <- levels(REZULTATI.VREME$Ski)[-c(9)]

# Podatki, na katerih bom delala napovedi:
podatki <- REZULTATI.VREME %>%
  dplyr::select(Rank, Ski, Disciplina, sneg) %>%
  filter(Ski %in% smuci) %>%
  one_hot(Ski) %>% one_hot(Disciplina) %>% one_hot(sneg)

set.seed(123)
# linearna regresija, da napovemo uvrstitve tekmovalca glede na:
# smuči (1. MODEL)
lin.reg.smuci = lm(
  Rank ~ Ski.Atomic + Ski.Fischer + Ski.Head + Ski.Kaestle + Ski.Nordica + Ski.Rossignol +
    Ski.Salomon + Ski.Stoeckli + Ski.Voelkl + Ski.Dynastar + Ski.Blizzard,
  data = podatki)
print(lin.reg.smuci)

# smuči in disciplino (2.MODEL)
lin.reg.smuci.disc = lm(
  Rank ~  Disciplina.DH + Disciplina.SG + Disciplina.GS + Disciplina.SL +
    Ski.Atomic + Ski.Fischer + Ski.Head + Ski.Kaestle + Ski.Nordica + Ski.Rossignol +
    Ski.Salomon + Ski.Stoeckli  + Ski.Dynastar + Ski.Voelkl+ Ski.Blizzard,
  data = podatki)
print(lin.reg.smuci.disc)

# smuči in snežno podlago (3. MODEL)
lin.reg.smuci.sneg = lm(
  Rank ~ Ski.Atomic + Ski.Fischer + Ski.Head + Ski.Kaestle + Ski.Nordica + Ski.Rossignol +
    Ski.Salomon + Ski.Stoeckli + Ski.Blizzard + Ski.Dynastar + Ski.Voelkl + sneg.HARD +
    `sneg.SPRING CONDITIONS` + sneg.COMPACT + sneg.SOFT + sneg.PACKED,
  data = podatki)
print(lin.reg.smuci.sneg)

# Še model, ki vključuje tako smuči kot tudi disciplino in snežno podlago (4. MODEL):
lin.reg.skupaj = lm(
  Rank ~ Ski.Atomic + Ski.Fischer + Ski.Head + Ski.Kaestle + Ski.Nordica + Ski.Rossignol +
    Ski.Salomon + Ski.Stoeckli + Ski.Blizzard + Ski.Dynastar + Ski.Voelkl +
    Disciplina.DH + Disciplina.SG + Disciplina.GS + Disciplina.SL + sneg.HARD +
    `sneg.SPRING CONDITIONS` + sneg.COMPACT + sneg.SOFT + sneg.PACKED,
  data = podatki)
print(lin.reg.skupaj)

# prečno preverjanje
napaka.cv <- function(podatki, formula, k) {
  set.seed(123)
  n <- nrow(podatki)
  # naključno premešamo primere
  r <- sample(1:n)
  # razrez na k intervalov
  razrez <- cut(seq_along(r), k, labels = FALSE)
  # razbijemo vektor na k seznamov na osnovi razreza intervalov
  razbitje = split(r, razrez)
  # zdaj imamo dane indekse za vsakega od k-tih delov
  pp.napovedi = rep(0, nrow(podatki))
  # prečno preverjanje
  for (i in 1:length(razbitje)) {
    train.data = podatki[-razbitje[[i]],]  # učni podatki
    test.data = podatki[razbitje[[i]],]    # testni podatki
    # naučimo model
    model = lm(data = train.data, formula = formula)
    # napovemo za testne podatke
    napovedi = predict(model, newdata = test.data)
    pp.napovedi[razbitje[[i]]] = napovedi
  }
  # izračunamo MSE
  napaka = mean((pp.napovedi - podatki$Rank) ^ 2)
  return(napaka)
}

# formule za napovedi
formula.smuci <-
  Rank ~ Ski.Atomic + Ski.Fischer + Ski.Head + Ski.Kaestle + Ski.Nordica + Ski.Rossignol +
  Ski.Salomon + Ski.Stoeckli + Ski.Voelkl + Ski.Dynastar + Ski.Blizzard
formula.smuci.disc <-
  Rank ~  Disciplina.DH + Disciplina.SG + Disciplina.GS + Disciplina.SL +
  Ski.Atomic + Ski.Fischer + Ski.Head + Ski.Kaestle + Ski.Nordica + Ski.Rossignol +
  Ski.Salomon + Ski.Stoeckli  + Ski.Dynastar + Ski.Voelkl+ Ski.Blizzard
formula.smuci.sneg <-
  Rank ~ Ski.Atomic + Ski.Fischer + Ski.Head + Ski.Kaestle + Ski.Nordica + Ski.Rossignol +
  Ski.Salomon + Ski.Stoeckli + Ski.Blizzard + Ski.Dynastar + Ski.Voelkl + sneg.HARD +
  `sneg.SPRING CONDITIONS` + sneg.COMPACT + sneg.SOFT + sneg.PACKED
formula.skupaj <-
  Rank ~ Ski.Atomic + Ski.Fischer + Ski.Head + Ski.Kaestle + Ski.Nordica + Ski.Rossignol +
  Ski.Salomon + Ski.Stoeckli + Ski.Blizzard + Ski.Dynastar + Ski.Voelkl +
  Disciplina.DH + Disciplina.SG + Disciplina.GS + Disciplina.SL + sneg.HARD +
  `sneg.SPRING CONDITIONS` + sneg.COMPACT + sneg.SOFT + sneg.PACKED

napaka.smuci <- napaka.cv(podatki, formula.smuci, 10)
napaka.smuci.disc <- napaka.cv(podatki, formula.smuci.disc, 10)
napaka.smuci.sneg <- napaka.cv(podatki, formula.smuci.sneg, 10)
napaka.skupaj <- napaka.cv(podatki, formula.skupaj, 10)
print(c(napaka.smuci, napaka.smuci.disc, napaka.smuci.sneg, napaka.skupaj))
# --> najboljši model je tisti s smučmi in disciplino (2. model)

# Prikaz za 1. model:
uvrstitev <- c(1:length(smuci)) * 0
napovedi.za.smuci <- tibble(smuci, uvrstitev)

for (i in 1:length(smuci)){
  vzorec = podatki[1,2:12]
  vzorec[1,] = c(rep(0,i-1), 1, rep(0, length(smuci)-i))
  napovedi.za.smuci[i,2] <- predict(lin.reg.smuci, newdata = vzorec)
}
napovedi.za.smuci[2]

barve <- c("#FF0000", "#FF6633","#00CCCC", "#FFFF00", "#FFF7A9", "#009966",
           "#330000", "#FF3300", "#000066", "#990000", "#CCCC00")

graf.napovedi <-
  ggplot(napovedi.za.smuci) +
  aes(x = smuci, y = uvrstitev) +
  geom_bar(stat = "identity", aes(fill = smuci)) +
  scale_fill_manual(values = barve) +
  xlab("Smuči") +
  ylab("Uvrstitev") +
  ggtitle("Napovedane uvrstitve glede na smuči v sezoni 2020/21") +
  theme(legend.position = "none",
        plot.title = element_text(color = "#006699", hjust = 0.5, size = 15),
        axis.text.x = element_text(angle = 25))
graf.napovedi

# Primeri za v poročilo, delam jih na podlagi 2. modela, ker ima najmanjšo napako:
vzorec.2 = podatki[1, 2:16]
# Opazujmo smuči znamke Atomic, za katere smo ugotovili, da so najbolj vsestranske,
# torej primerne z tekmovanje v vseh disciplinah:
vzorec.2[1,] = c(rep(0,3), 1, rep(0, 7), 1, rep(0, 3))
pred.atomic.dh <- predict(lin.reg.smuci.disc, newdata = vzorec.2)
vzorec.2[1,] = c(rep(0,3), 1, rep(0, 8), 1, rep(0, 2))
pred.atomic.sg <- predict(lin.reg.smuci.disc, newdata = vzorec.2)
vzorec.2[1,] = c(rep(0,3), 1, rep(0, 9), 1, 0)
pred.atomic.gs <- predict(lin.reg.smuci.disc, newdata = vzorec.2)
vzorec.2[1,] = c(rep(0,3), 1, rep(0, 10), 1)
pred.atomic.sl <- predict(lin.reg.smuci.disc, newdata = vzorec.2)

Uvrstitev <- c(pred.atomic.dh, pred.atomic.sg, pred.atomic.gs, pred.atomic.sl)
Disciplina <- c("Smuk", "Superveleslalom", "Veleslalom", "Slalom")
# Tabela za v poročilo:
atomic <- t(tibble(Disciplina, Uvrstitev))


library(rrBLUP)
args <- commandArgs()
rep = 1
fold = 1
phe = read.table("/public10/home/sci0011/projects/tomato2/37_GS/01_phenotype/meta.txt",head=T)
ksnp = read.table("/public10/home/sci0011/projects/tomato2/37_GS/02_snps_only/K.txt",head=F)
kindel = read.table("/public10/home/sci0011/projects/tomato2/37_GS/03_indels_only/K.txt",head=F)
ksv = read.table("/public10/home/sci0011/projects/tomato2/37_GS/04_svs_only/K.txt",head=F)
# K = list(ksnp= as.matrix(ksnp),kindel = as.matrix(kindel),ksv = as.matrix(ksv))
cov =read.table("/public10/home/sci0011/projects/tomato2/17_cov/01_snps/pheno.cov",head=T)

Y = read.table(paste("/public10/home/sci0011/projects/tomato2/37_GS/01_phenotype/rep",rep,"_fold",fold,".txt",sep=""),head=T)
res = matrix(0,9,972)
res = as.data.frame(res)
res[1:3,1] = "snps"
res[1:3,2] = c("h2","fit","acc")

res[4:6,1] = "indels"
res[4:6,2] = c("h2","fit","acc")

res[7:9,1] = "svs"
res[7:9,2] = c("h2","fit","acc")

colnames(res) = c("marker","type",colnames(Y)[5:974])

for (p in 5:974){
  data = data.frame(y=Y[,p],gid=Y$IID)
  idx = is.na(Y[,p])

  colnames(ksnp) = Y$IID
  rownames(ksnp) = Y$IID
  ans <- kin.blup(data=data,geno="gid",pheno="y",K=as.matrix(ksnp))
  res[1,p-2]  = ans$Vg/(ans$Vg + ans$Ve)
  res[2,p-2]  = cor(Y[!idx,p],ans$g[!idx],use="pairwise.complete.obs")
  res[3,p-2]  = cor(phe[idx,p],ans$g[idx],use="pairwise.complete.obs")

  colnames(kindel) = Y$IID
  rownames(kindel) = Y$IID
  ans <- kin.blup(data=data,geno="gid",pheno="y",K=as.matrix(kindel))
  res[4,p-2]  = ans$Vg/(ans$Vg + ans$Ve)
  res[5,p-2]  = cor(Y[!idx,p],ans$g[!idx],use="pairwise.complete.obs")
  res[6,p-2]  = cor(phe[idx,p],ans$g[idx],use="pairwise.complete.obs")

  colnames(ksv) = Y$IID
  rownames(ksv) = Y$IID
  ans <- kin.blup(data=data,geno="gid",pheno="y",K=as.matrix(ksv))
  res[7,p-2]  = ans$Vg/(ans$Vg + ans$Ve)
  res[8,p-2]  = cor(Y[!idx,p],ans$g[!idx],use="pairwise.complete.obs")
  res[9,p-2]  = cor(phe[idx,p],ans$g[idx],use="pairwise.complete.obs")

}
write.table(res,paste("rep",rep,"_fold",fold,".rrBLUP.txt",sep=""),col.names = T,row.names = F,quote=F,sep="\t")


# H0: HDT-CB == OSTRICH
# Compare means with one-way ANOVA (analysis of variance)

ostrich <- read.csv('../beara/query/ostrich/_median_vm.csv')
ostrich <- ostrich[which(ostrich$offset==0),]
hdt <- read.csv('../beara/query/hdt-cb/_median_vm.csv')
#ks.test(ostrich$lookup.mus.inf, "pnorm", 1, 2) # p: 0.00293 -> normal distr
#ks.test(hdt$ms, "pnorm", 1, 2) # p: 0.02095 -> normal distr
#t.test(ostrich$lookup.mus.inf, hdt$ms)
# p: 1.68e-05
# => Reject H0, unequal means
#mean(ostrich$lookup.mus.inf) # 0.5622
#mean(hdt$ms) # 1.306266
# HDT-CB >= OSTRICH !

ostrich <- read.csv('../beara/query/ostrich/_median_dm.csv')
ostrich <- ostrich[which(ostrich$patch_start==0,ostrich$offset==0),]
hdt <- read.csv('../beara/query/hdt-cb/_median_dm.csv')
#ks.test(ostrich$lookup.mus.inf, "pnorm", 1, 2) # p: 7.167e-06 -> normal distr
#ks.test(hdt$ms, "pnorm", 1, 2) # p: 0.00148 -> normal distr
#t.test(ostrich$lookup.mus.inf, hdt$ms)
# p: 2.2e-16
# => Reject H0, unequal means
#mean(ostrich$lookup.mus.inf) # 0.05334
#mean(hdt$ms) # 0.3802984
# HDT-CB >= OSTRICH !

ostrich <- read.csv('../beara/query/ostrich/_median_vq.csv')
ostrich <- ostrich[which(ostrich$offset==0),]
hdt <- read.csv('../beara/query/hdt-cb/_median_vq.csv')
# just one sample...
# => Reject H0
#mean(ostrich$lookup.mus.inf) # 0.896
#mean(hdt$ms) # 0.777231
# HDT-CB < OSTRICH

ostrich <- read.csv('../bearb-daily/query/ostrich/_median_vm.csv')
ostrich <- ostrich[which(ostrich$offset==0),]
hdt <- read.csv('../bearb-daily/query/hdt-cb/_median_vm.csv')
#ks.test(ostrich$lookup.mus, "pnorm", 1, 2) # p: < 2.2e-16 -> normal distr
#ks.test(hdt$ms, "pnorm", 1, 2) # p: < 2.2e-16 -> normal distr
#t.test(ostrich$lookup.mus, hdt$ms)
# p: 2.2e-16
# => Reject H0, unequal means
#mean(ostrich$lookup.mus) # 0.1846292
#mean(hdt$ms) # 0.3473258
# HDT-CB < OSTRICH

ostrich <- read.csv('../bearb-daily/query/ostrich/_median_dm.csv')
ostrich <- ostrich[which(ostrich$patch_start==0,ostrich$offset==0),]
hdt <- read.csv('../bearb-daily/query/hdt-cb/_median_dm.csv')
#ks.test(ostrich$lookup.mus, "pnorm", 1, 2) # p: < 2.2e-16 -> normal distr
#ks.test(hdt$ms, "pnorm", 1, 2) # p: < 2.2e-16 -> normal distr
#t.test(ostrich$lookup.mus, hdt$ms)
# p: 0.02863
# => Accept H0, equal means
#mean(ostrich$lookup.mus) # 0.2104713
#mean(hdt$ms) # 0.1810234
# HDT-CB >= OSTRICH !

ostrich <- read.csv('../bearb-daily/query/ostrich/_median_vq.csv')
ostrich <- ostrich[which(ostrich$offset==0),]
hdt <- read.csv('../bearb-daily/query/hdt-cb/_median_vq.csv')
# just one sample...
# => Reject H0
#mean(ostrich$lookup.mus) # 0.294
#mean(hdt$ms) # 0.82898
# HDT-CB >= OSTRICH !

ostrich <- read.csv('../bearb-hourly/query/ostrich/_median_vm.csv')
ostrich <- ostrich[which(ostrich$offset==0),]
hdt <- read.csv('../bearb-hourly/query/hdt-cb/_median_vm.csv')
#ks.test(ostrich$lookup.mus.inf, "pnorm", 1, 2) # p: < 2.2e-16 -> normal distr
#ks.test(hdt$ms, "pnorm", 1, 2) # p: < 2.2e-16 -> normal distr
#t.test(ostrich$lookup.mus.inf, hdt$ms)
# p: 2.2e-16
# => Reject H0, unequal means
#mean(ostrich$lookup.mus.inf) # 0.3094276
#mean(hdt$ms) # 1.733312
# HDT-CB >= OSTRICH !

ostrich <- read.csv('../bearb-hourly/query/ostrich/_median_dm.csv')
ostrich <- ostrich[which(ostrich$patch_start==0,ostrich$offset==0),]
hdt <- read.csv('../bearb-hourly/query/hdt-cb/_median_dm.csv')
#ks.test(ostrich$lookup.mus.inf, "pnorm", 1, 2) # p: < 2.2e-16 -> normal distr
#ks.test(hdt$ms, "pnorm", 1, 2) # p: < 2.2e-16 -> normal distr
#t.test(ostrich$lookup.mus.inf, hdt$ms)
# p: 2.2e-16
# => Reject H0, unequal means
#mean(ostrich$lookup.mus.inf) # 0.3272151
#mean(hdt$ms) # 1.661122
# HDT-CB >= OSTRICH !

ostrich <- read.csv('../bearb-hourly/query/ostrich/_median_vq.csv')
ostrich <- ostrich[which(ostrich$offset==0),]
hdt <- read.csv('../bearb-hourly/query/hdt-cb/_median_vq.csv')
# just one sample...
# => Reject H0
#mean(ostrich$lookup.mus.inf) # 0.814
#mean(hdt$ms) # 3.95088
# HDT-CB >= OSTRICH !


fit.multi.loop <- function(methylation, design, dependent.variable, independent.variables, fit.function, stats.function, ...) {
    ret <- rep(NA,2 + length(independent.variables)*4)
    dep.idx <- which(colnames(design) == dependent.variable)
    ind.idx <- which(colnames(design) %in% independent.variables)

    do.call(rbind, mclapply(1:nrow(methylation), function(i) {
        design[,"methylation"] <- methylation[i,]   ## assign CpG site methylation
        idx <- which(!is.na(design[,"methylation"]))
        try({
            fit <- fit.function(x=design[idx,-dep.idx,drop=F], ## independent variables
                                y=design[idx,dep.idx],         ## dependent variable
                                ...)
            fit0 <- fit.function(x=design[idx,-c(dep.idx,ind.idx)],
                                 y=design[idx,dep.idx],
                                 ...)

            delta.dev <- abs(fit0$deviance-fit$deviance)
            delta.df <- abs(fit0$df.residual-fit$df.residual)
            dispersion <- fit$deviance/fit$df.residual
            f.stat <- (delta.dev/delta.df)/dispersion
            p.value <- pf(f.stat, delta.df, fit$df.residual, lower.tail=FALSE)
            ## derived from stats:::anova.glm, stats:::stat.anova, gaussian()$dev.resids, summary.glm
            ret <- c(f=f.stat, p.value=p.value,
                     unlist(sapply(independent.variables, function(independent.variable) {
                         stats.function(fit, independent.variable)
                     }, simplify=F)))
        }, silent=T)
        ret
    }))
}


# R Code
# Complexity Measure Experiment
# L. Garcia, A. Lorena, M. de Solto 2017
# Extract complexity measures from data

save <- function(aux, file) {
  name = gsub("arff", "RData", basename(file))
  dump("aux", name)
}

oracle <- function(tran, test) {
  rowMeans(sapply(1:FOLDS, function(i){
    classifiers(tran[[i]], test[[i]])
  }))
}

time <- function(data) {
  tmp = system.time(complexity(class ~., data$data))[3]
  c(tmp, system.time(oracle(data$tran, data$test))[3])
}

measures <- function(data) {
  tmp = complexity(class ~., data$data)
  c(tmp, oracle(data$tran, data$test))
}

root <- function(fun, file) {
  data = cfold(read.arff(file))
  aux = do.call(fun, list(data))
  save(aux, file)
  return(0)
}


# R script to set up PreservationSimulation/shelf data
# RBLandau 20141214
# revised 20150619
#

# REQUIRES the following to be defined as global strings before invoking
#  this script:
# - sInputFilename
# - sOutputFilename
# - sTitle
# - sSubtitle
# - sSummarizeFilename
# - sAnalyzeFilename
# This is all done in the shelf_call.r script.  Just edit the filenames and
#  title strings, and blast off.

# f n H e a d i n g I n f o
# Print a bunch of identifying information at the top of the report.
# Actually, also called to print the same info on the console to
#  reassure the user that we haven't gone haywire for many seconds.
fnHeadingInfo <- function(myfilename)
{
    sMynameIs <- myfilename
    cat(sTitle,"\n")
    cat(sSubtitle,"\n")
    cat("\n")
    cat("Input data from ", sInputFilename, "\n")
    cat("Output analysis into ", sOutputFilename, "\n\n")
    cat("analysis tables by ", sMynameIs, "\n")
    cat("and summarize script", sSummarizeFilename,"\n")
    cat(" at ",format(Sys.time(),"%Y%m%d_%H%M%S %Z"),"\n")
    cat("\n")
}#ENDFN fnHeadingInfo

# F U N C T I O N S

# W h a t e v e r S a m p l e S a d i s t i c s Y o u W a n t
# Prints a header line and then all these stats.
# The header line is anything you want, usually pairs of name and value.
WhateverSampleSadisticsYouWant <- function(headerline,vect)
{
    # for the grouping variables, args include name (p1n) and then value (p1).
    cat("====== ",headerline,"N",length(vect)," ======","\n")
    stem(vect)
    cat(headerline,"N",length(vect),"\n")
    cat("median","\t\t",median(vect,na.rm=TRUE),"\n")
    cat("trimean","\t",trimean(vect),"\n")
    cat("midmean","\t",midmean(vect),"\n")
    stat_mean <- mean(vect,na.rm=TRUE)
    cat("mean","\t\t",stat_mean,"\n")
    cat("stddev","\t\t",sd(vect,na.rm=TRUE),"\n")
    cat("IQR","\t\t",IQR(vect,na.rm=TRUE),"\n")
    cat("mad","\t\t",mad(vect,na.rm=TRUE),"\n")
    stat_SEM <- (sd(vect,na.rm=TRUE)/sqrt(length(vect)))
    cat("SEM","\t\t",stat_SEM,"\n")
    stat_MeanOverSEM <- stat_mean / stat_SEM
    stat_LogMeanOverSEM <- log10(stat_mean / stat_SEM)
    cat("MeanOverSEM","\t",stat_MeanOverSEM,"\n")
    cat("LogMeanOverSEM","\t",stat_LogMeanOverSEM,"\n")
    cat("\n")
}#ENDFN WhateverSampleSadisticsYouWant

# A couple particular functions for summarizing the loss data.
# These might be slightly more robust than just mean, and slightly
#  more broadly estimated than median.
# trimean was a JWT favorite.
trimean <-  function(vect)  { foo <- fivenum(vect); ans <- 0.5*foo[3] + 0.25*foo[2] + 0.25*foo[4]; ans }
midmean <-  function(vect)  { ans <- mean(vect,trim=0.25,na.rm=TRUE); ans }

# s u m m a r i z e
# Summarize function removed to separate file because it is extremely
#  grouping-dependent.
source(sSummarizeFilename)

# M A I N L I N E
# Code that executes rather than just defines other functions.
# There really should not be any top-level executable code outside this routine.
main <- function(){

    # W H A T ' S   M Y   N A M E
    # What is the name of this script?
    #  (There ought to be a way to introspect this, a la $0, but I can't find it
    #  in StackOverflow or Rblogs, rats.)
    sMynameIs <- sAnalyzeFilename   # Dumb, dumb, dumb.

    # I N P U T
    dat <- data.frame(read.table(sInputFilename, header=TRUE))
    # Use dataset with only the interesting columns: docsize, lifem, glitchimpact, copies, lost
    # because we don't want to aggregate anything else.
    datn <- fnSelectColumns(dat)
    #print(datn)

    # Expose the data so I can at least see them in R Studio for debugging.
    assign("dat", dat, envir=globalenv())
    assign("datn", datn, envir=globalenv())

    # How many documents in the collection?  Default = 10K.
    # Can be overridden by defining before this script is called.
    if (! exists("nDocs")) {nDocs <- 10000}

    # H E A D I N G S
    # Put out headings immediately to reassure the R user
    fnHeadingInfo(sMynameIs)

    # T A B L E S
    # Tables function removed to separate file.
    # Establish the table names in this context so they can be used
    #  inside the functions.

    # O U T P U T
    # Send output to a file so we can read it later.
    sink(sOutputFilename)
    # Include heading info in file
    fnHeadingInfo(sMynameIs)

    # Show results.
    # L O S S   C O U N T S
    if(TRUE){
        cat("Summary losses (midmeans)\n")
        summid <- fnTableMid(dat)
        print(summid)
        cat("\n")
    }#ENDIFFALSE

    # L O S S   P E R C E N T A G E S
    if(TRUE){
        cat("Percentage losses (midmeans)\n")
        summidpct <- fnTableMidPct(dat)
        print(summidpct)
        cat("\n")
    }#ENDIFFALSE

    # L O S S   C O U N T S
    if(0){
        cat("Summary losses (medians)\n")
        summed <- fnTableMed(dat)
        print(summed)
        cat("\n")
    }#ENDIFFALSE

    # L O S S   C O U N T S
    if(0){
        cat("Summary losses (trimeans)\n")
        sumtri <- fnTableTri(dat)
        print(sumtri)
        cat("\n")
    }#ENDIFFALSE

    cat("\n")

    if(1){
        # All the grouping and aggregation dependent code has been moved
        #  to a separate file.
        if (exists("bTablesOnly") & (! bTablesOnly))
        {
            cat("============================================\n\n")
            # Let's look at the distributions of the samples.
            fnDetailedSampleStats(datn)
        }
    }#ENDIFFALSE

    # Close the output sink manually.
    # Is there a way to do this automatically so it doesn't linger?
    sink()

}#ENDFN main

# Edit history:
# 20150701  RBL group by glitch impact (outside).
# 20150810  RBL ignore missing data (NA) values in most calcs.
# 20150918  RBL include more data in datn.
# 20160827  RBL include better header info in file.
# 20161006  RBL print lifem sanely when it has large values.
# 20170302  RBL narrow copies to 8 instead of 20.
# 20170310  RBL remove summarize function to separate file.
# 20170312  RBL remove the dump-stats, too, to grouping-specific file.
# 20170315  RBL repair some local data references.
# 20170318  RBL Add table of percentage losses.
#
#

#END


#####################################################
#
# contour_plot_functions.r   16 FEB 2017
#
# Functions that create the contour plots for
# figure 3.
#
#####################################################

make.3dcontour <- function(this.frame, scc.cols, scc.range=c(0,10000), exp.lo=NULL, exp.hi=NULL, make.cbar=T, ...) {

  # Get the old margins to reset later
  old.margins <- par("mar")

  # Get the levels of rho and c0
  these.rho <- unique(this.frame$rho)
  these.c0 <- unique(this.frame$c0)

  # Loop over the available rho values
  for(this.rho in these.rho) {

    # Loop over the available c0 values
    for(this.c0 in these.c0) {

      # Subset this.frame
      this.subframe <- this.frame[which(with(this.frame, rho==this.rho & c0==this.c0)),]

      # If SCC range is out of bounds, limit the plot
      this.subframe[which(with(this.subframe, SCC<scc.range[1])),"SCC"] <- scc.range[1]
      this.subframe[which(with(this.subframe, SCC>scc.range[2])),"SCC"] <- scc.range[2]

      # Make the temporary matrix to hold SCC
      temp <- matrix(this.subframe$SCC, nrow=length(unique(this.subframe$gamma)), byrow=T)

      # Exponent limits
      if(is.null(exp.lo)) {exp.lo <- floor(log10(min(temp[temp>=scc.range[1]]))) }
      if(is.null(exp.hi)) {exp.hi <- ceiling(log10(max(temp[temp<=scc.range[2]]))) }

      # Make the plot
      par(mar=c(4.5,4.5,2,1)+0.1)
      if(make.cbar) {
        image.plot(unique(this.subframe$gamma), unique(this.subframe$eta), log10(temp),
                 xlab="gamma [-]", ylab="eta [-]", breaks=seq(exp.lo,exp.hi,l=101), col=scc.cols,
                 axis.args = list(at=exp.lo:exp.hi, labels=parse(text=paste("10^", exp.lo:exp.hi, sep=""))))
      }
      else {
        image(unique(this.subframe$gamma), unique(this.subframe$eta), log10(temp),
                   xlab="gamma [-]", ylab="eta [-]", breaks=seq(exp.lo,exp.hi,l=101), col=scc.cols)
      }
      box()
      mtext(unique(this.subframe$focusregion), 3, line=0.25, cex=1.3)
      par(mar=old.margins)

    }
  }
}

make.3dcontour.rho.eta <- function(this.frame, scc.cols, scc.range=c(0,10000), exp.lo=NULL, exp.hi=NULL, make.cbar=T, ...) {

  # Get the old margins
  old.margins <- par("mar")

  # If SCC range is out of bounds, limit the plot
  this.frame[which(with(this.frame, SCC<scc.range[1])),"SCC"] <- scc.range[1]
  this.frame[which(with(this.frame, SCC>scc.range[2])),"SCC"] <- scc.range[2]

  # Cast rho as a percent
  this.frame$rho <- this.frame$rho * 100

  # Make the temporary matrix to hold SCC
  temp <- matrix(this.frame$SCC, nrow=length(unique(this.frame$rho)), byrow=T)

  # Exponent limits
  if(is.null(exp.lo)) {exp.lo <- floor(log10(min(temp[temp>=scc.range[1]]))) }
  if(is.null(exp.hi)) {exp.hi <- ceiling(log10(max(temp[temp<=scc.range[2]]))) }

  # Make the 3d contour plot
  par(mar=c(4.5,4.5,2,1)+0.1)
  if(make.cbar) {
    image.plot(unique(this.frame$rho), unique(this.frame$eta), log10(temp),
             xlab="rho [%]", ylab="eta [-]", breaks=seq(exp.lo,exp.hi,l=101), col=scc.cols,
             axis.args = list(at=exp.lo:exp.hi, labels=parse(text=paste("10^", exp.lo:exp.hi, sep=""))))
  }
  else {
    image(unique(this.frame$rho), unique(this.frame$eta), log10(temp),
               xlab="rho [%]", ylab="eta [-]", breaks=seq(exp.lo,exp.hi,l=101), col=scc.cols)
  }
  box()
  mtext(unique(this.frame$focusregion), 3, line=0.25, cex=1.3)
  par(mar=old.margins)

}


library(ggplot2)
library(dplyr)
library(tidyr)

plot_df = df %>%
    pivot_longer(cols = c("Expected_insns", "Functions",
                          "Inlined_percentage", "Num_partitions"),
                 names_to = "Parameter",
                 values_to = "Value")

ggplot(plot_df) +
    facet_wrap(Parameter ~ Parallel, ncol = 4, scales = "free_x") +
    geom_point(aes(x = Value,
                   y = CompileTime,
                   color = as.factor(Parallel)),
               alpha = 0.4) +
    scale_x_log10() +
    scale_y_log10() +
    scale_color_brewer(palette = "Dark2")


create_model <- function( dtm, k ) {

  library(stm)

  out <- readCorpus( dtm, type = "slam" )

  documents <- out$documents
  vocab <- out$vocab

  topic <- stm(documents, vocab, K = k, init.type = "Spectral", max.em.its = 50)

  return( topic )

}


#library(dplyr)
#library(plyr)
#library(nycflights13)

#data = filter(flights, month == 1, day == 1)

getdata <- function(flnm){
  data <- read.csv(flnm, header = FALSE, sep = ",")
  colnames(data) <- c("Date","Traffic")
  data
}
dat = getdata("D:/DATASETS/UKTraffic/internet-traffic-data-in-bits-5min.csv")
mt <- read.table("D:/DATASETS/UKTraffic/labels.txt", header = TRUE, sep = ",")
plot(dat$Traffic, cex = 0.7)
abline(v = mt$ID, col = "red")
#dat = tbl_df(dat)
#traffic = dat$Traffic
#plot(dat$Date, traffic, type = 'b', cex = 0.5, xlim = c(5000, 6000))

###########################
## INIT ROC
sdat = read.table("D:/DATASETS/UKTraffic/Scaled.txt")$V1
chps = read.table("D:/DATASETS/UKTraffic/out/chps.txt")$V1
stat = read.table("D:/DATASETS/UKTraffic/out/stat.txt")$V1
true_chps <- read.table("D:/DATASETS/UKTraffic/TrueChanges.txt", header = FALSE)$V1
#true_chps = true_chps$ID
mean(diff(true_chps))
sd(diff(true_chps))

plot(sdat, type = 'l')
abline(v = true_chps, col = "blue", lw = 2)
lines(stat, col = "red")

plot(sdat, type = 'l', xlim = c(5000, 6000))
plot(sdat, type = 'l', xlim = c(5400, 5600))
lines(stat, col = "red")
abline(v = chps, col = "blue")
abline(v = true_chps, col = "blue", lw = 2)

roc = read.table("D:/DATASETS/UKTraffic/out/ROCstatic.txt", sep = "," , header = TRUE)
plot(roc$FA, roc$TP)

###############################################
## PROBS FUNCTION FOR 10 CHANGES
probs10 <- read.table("D:/DATASETS/UKTraffic/probs/recprobs10.txt", header = F)
plot(probs10$V1, type = 'b', cex = 0.4, xlim = c(0, 2000))
abline(h = 0.003)
abline(h = 0.004)
# t-max = 2000 !
# plot probs with confirm test
probsconf <- read.table("D:/DATASETS/UKTraffic/probsconfirm.txt", header = F)
plot(probsconf$V1, type = 'l')

##################
## Recurrent PCCF for confirmed changes
tst_probs10 <- read.table("D:/DATASETS/UKTraffic/probs/tst_confProbs.txt", header = F)
plot(tst_probs10$V1, type = 'b', cex = 0.4)
abline(v = c(500, 6e3), col = "red")
#########
## test
tst_probs <- read.table("D:/DATASETS/UKTraffic/tst/tst_probsconf.txt", header = F)
plot(tst_probs$V1, type = 'l', cex = 0.4)
chps = read.table("D:/DATASETS/UKTraffic/tst/tst_allchps.txt", header = F)$V1
chps_tp = read.table("D:/DATASETS/UKTraffic/tst/tst_tpsok.txt", header = F)$V1
abline(v = chps, col = "red")
abline(v = chps_tp, col = "blue")
##################################
### Improvement Vs Delay
res1 <- read.table("D:/DATASETS/UKTraffic/out/ImprVsDelayH0.003.txt", header = TRUE, sep = ",")
res2 <- read.table("D:/DATASETS/UKTraffic/out/ImprVsDelayH0.004.txt", header = TRUE, sep = ",")
plt <- function(r){
  plot(r$Delay, r$fracTP, pch = 16, col = "blue", ylim = c(0,1), type = 'b')
  lines(r$Delay, r$fracFA, type = 'b')
}
plt(res1)
plt(res2)

roc = read.table("D:/DATASETS/UKTraffic/out/ROC.txt", sep = "," , header = TRUE)
plot(roc$FA, roc$TP)
roc1 <- read.table("D:/DATASETS/UKTraffic/out/ROCH0.003.txt", header = TRUE, sep = ",")
roc3 <- read.table("D:/DATASETS/UKTraffic/out/ROCH0.004.txt", header = TRUE, sep = ",")
lines(roc1$NewFPr, roc1$NewTPr, type = 'b', col = "red" )
lines(roc3$NewFPr, roc1$NewTPr, type = 'b', col = "blue" )

############################################
######### PLOT RESULTS LIKE IN PAPER


# @author: me@andreagirardi.it
# @since: Wed Mar 24 14:46:09 CET 2021
# @project: RExercises
# @module: COVID19
# @desc:
#
# R(t) : The number of people who become infected per infectious person at time 𝑡
#
# Install package COVID19
# https://cran.r-project.org/web/packages/COVID19/COVID19.pdf

# Dati positiv per provincia: https://github.com/pcm-dpc/COVID-19/tree/master/dati-province

> install.packages('COVID19')

> library('dplyr')
> library('CODID19')

# Select all data for Veneto region
# RAW = false (add NA in case of missing data, this won't generate a wrong chart)
> covidSource <- covid19('Italy', level=3, start="2020-11-01", raw = FALSE)

> covidSourceVeneto <- select(covidSource, id, date, population, school_closing, vaccines, tests, confirmed, deaths, hosp, administrative_area_level_1, administrative_area_level_2, administrative_area_level_3) %>% filter(administrative_area_level_2 == 'Veneto')
> g <- ggplot(covidSourceVeneto, aes(x = covidSourceVeneto$date) ) + geom_line(aes(y = covidSourceVeneto$confirmed), color = "red") + geom_line(aes(y = covidSourceVeneto$hosp), color = "green") + geom_line(aes(y = covidSourceVeneto$deaths), color = "blue")

> covidSourceVerona <- select(covidSource, id, date, confirmed, deaths, hosp, administrative_area_level_3, administrative_area_level_2) %>% filter(administrative_area_level_3 == 'Verona')
> ggplot(covidSourceVerona, aes(x = date)) + geom_line(aes(y = confirmed), color = "blue") + geom_line(aes(y = deaths), color = "red")

### Altro data source ####
> date21 <- read.csv(url('https://raw.githubusercontent.com/pcm-dpc/COVID-19/master/dati-province/dpc-covid19-ita-province-20210322.csv'))
> date22 <- read.csv(url('https://raw.githubusercontent.com/pcm-dpc/COVID-19/master/dati-province/dpc-covid19-ita-province-20210322.csv'))
> date23 <- read.csv(url('https://raw.githubusercontent.com/pcm-dpc/COVID-19/master/dati-province/dpc-covid19-ita-province-20210323.csv'))

> dataframe <- rbind(date21, date22, date23)
> select(dataframe, data, sigla_provincia, totale_casi) %>% filter(sigla_provincia == 'VR')

# How to Calcualte R(t)
# https://github.com/k-sys/covid-19/blob/master/Realtime%20R0.ipynb
# https://www.scienzainrete.it/articolo/metodo-lo-studio-dellandamento-provinciale-dellepidemia/roberto-battiston/2021-02-03
# Tutorial : https://www.datacamp.com/community/tutorials/replicating-in-r-covid19
#


pdf_file<-"pdf/timeseries_forecast_interval_1x5_index.pdf"
cairo_pdf(bg="grey98", pdf_file,width=11,height=7)

par(mfcol=c(1,5),omi=c(1.0,0.25,1.45,0.25),mai=c(0,0.75,0.25,0),family="Lato Light",las=1)

# Import data and prepare chart

UNPop<-read.csv("myData/UNPop.csv")

mySelection<-c("World","Northern America","China","Africa","Germany")
ymin<-rep(0, 5)
ymax<-rep(500, 5)
myTitle<-c("World","Northern America","China","Africa","Germany")

for (i in 1:length(mySelection)) {
source("scripts/inc_forecast_interval_05_index.r")
mtext(myTitle[i],side=3,adj=0,line=1,cex=1.1,font=3)

if (i==1)
{
legend(1900,-70,c("Upper prognosis ","Medium prognosis","Lower prognosis"),fill=c("grey","grey","grey"),border=F,pch=15,xpd=NA,col=c("black","white","orange"),bty="n",cex=1.6,ncol=3)
}
}

# Titling

mtext("UN Population Forecasts",3,line=7,adj=0,cex=2.25,family="Lato Black",outer=T)
mtext("2010=100, 5 year values",3,line=3.5,adj=0,cex=1.75,font=3,outer=T)
mtext("Source: UN World Population Prospects: The 2010 Revision",1,line=5,adj=1.0,cex=0.95,font=3,outer=T)
dev.off()


library(shiny)	#First load shiny library
load("../pcas.RDATA")	#Load data

#Define a server for the Shiny app
shinyServer(function(input, output) {
	output$paramchkbxgrp <- renderUI({
		if (is.null(input$var))
		return()

		#Check box group
		#Depending on input$var, we'll generate a different UI component and send it to the client.
		switch(input$var,
			"colless" = checkboxGroupInput("PARAMS", "",
				choices = c("Low" = "loIc",
					"Mid" = "midIc",
					"High" = "hiIc"),
				selected = c("loIc","midIc","hiIc")
			),
			"numsp" = checkboxGroupInput("PARAMS", "",
				choices = c("16 Species" = 16,
						"64 Species" = 64,
						"256 Species" = 256),
				selected = c(16,64,256)
			),
			"spatial" = checkboxGroupInput("PARAMS", "",
				choices = c("True" = "TRUE",
						"False" = "FALSE"),
				selected = c("TRUE","FALSE")
			)
		)
	})

	#X-axis
	output$sliderX <-renderUI({
		sliderInput(inputId="SLIDERX",
			label = h5("x-axes"),
			min = min(subset(foo,Var==input$var)[,"PC1"]),
			max = max(subset(foo,Var==input$var)[,"PC1"]),
			value = c(min(subset(foo,Var==input$var)[,"PC1"]),max(subset(foo,Var==input$var)[,"PC1"])))
	})
	#Y-axis
	output$sliderY <-renderUI({
		sliderInput(inputId="SLIDERY",
			label = h5("y-axes"),
			min = min(subset(foo,Var==input$var)[,"PC2"]),
			max = max(subset(foo,Var==input$var)[,"PC2"]),
			value = c(min(subset(foo,Var==input$var)[,"PC2"]),max(subset(foo,Var==input$var)[,"PC2"])))
	})

	#Create a reactive Shiny plot to send to the ui.r called "pcaplot"
	output$pcaplot <- renderPlot({
		#Match user's variable input selection by subsetting for when foo$Var==input$var
		fbar<-droplevels(foo[which(foo$Var==input$var),])

		#Generate colors to correspond to the different Variables' parameters. E.g., for the variable "colless", different colors for "loIc","midIc", and "hiIc"
		cols<-c("#1f77b4","#ff7f0e","#2ca02c")[1:length(levels(fbar$param))]

		#If the param is not selected, set the color value to grey with transparency
		cols[which(!(levels(fbar$param) %in% input$PARAMS))]<- rgb(0,0,0, alpha=25,maxColorValue=255)

		#Subset the pca_percent function for when Var==input$var
		pcaper<-pca_percent[which(pca_percent$Var==input$var),]
		#Render the scatterplot of PCA
		plot(PC2 ~ PC1, data=fbar, type="n", xlim=input$SLIDERX, ylim=input$SLIDERY,
			xlab=paste("PCA Axis 1 (",pcaper[2],"%)"),
			ylab=paste("PCA Axis 2 (",pcaper[3],"%)"))
		abline(h=0,v=0,col="red",lty=2)

		#For each of the different parameter values (different colors), plot the text names of the metrics
		for(i in levels(fbar$param)){
			foo2<-subset(fbar,param==i)
			labs<-paste("c(",paste("expression(",foo2$Rexpression,")",sep="",collapse=","),")",sep="")
			text(PC2 ~ PC1, data=foo2, labels=eval(parse(text=labs)), col=cols[which(levels(fbar$param)==i)],  cex=input$cexSlider)
		}

		#Add a legend for the different parameter values (with corresponding colors) of the selected Variable
		legend("topright", fill=cols, legend=levels(fbar$param))

  })
})


library(EpiNow2)
library(data.table)
library(here)

samples <- get_regional_results(results_dir = here::here("data-raw", "data", "rt", "samples"), samples = TRUE)$estimates$samples

samples <- samples[variable %in% "growth_rate"][,.(county = region, date, sample, value, type)]

grs <- samples[, list(low_95 = quantile(value, 0.025), high_95 = quantile(value, 0.975), median = median(value)), by = list(county, date, type)]

grs[date == "2020-10-23" & county == "pilot"]
grs[date == "2020-10-30" & county == "non-pilot"]

fwrite(grs, here("data-raw", "data", "rt", "growth-rates.csv"))