########################################################
# The MIT License (MIT)
#
# Copyright (c) 2014 Florian D. Schneider & Sonia Kéfi
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in all
# copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
# SOFTWARE.
#
########################################################

### grazing model: Schneider and Kéfi (2015, in review)

grazing <- list()
class(grazing) <- "ca_model"
grazing$name <- "Spatial Grazing Model"
grazing$ref <- "Schneider and Kéfi 2015, in review"
grazing$states <- c("+", "0", "-")
grazing$cols <- grayscale(3)
grazing$parms <- list(
  del = 0.9, # local seed dispersal
  b = 0.2, # environmental quality
  c_ = 0.2, # global competition
  m0 = 0.05, # intrinsic mortality
  g = 0.2, # grazing pressure
  r = 0.01, # regeneration rate of degraded cells
  f = 0.9, # local facilitation
  d = 0.2, # intrinsic degradation rate
  protect = 0.9 # associational resistance against grazing
)
grazing$update <- function(x_old, parms_temp, delta = 0.2, subs = 10, timestep = NA) {

  x_new <- x_old

  for(s in 1:subs) {

    parms_temp$rho_plus <- sum(x_old$cells == "+")/(x_old$dim[1]*x_old$dim[2]) # get initial vegetation cover
    parms_temp$Q_plus <- count(x_old, "+")/4  # count local density of occupied fields for each cell:

    # 2 - drawing random numbers
    rnum <- runif(x_old$dim[1]*x_old$dim[2]) # one random number between 0 and 1 for each cell

    # 3 - setting transition probabilities

    if(parms_temp$rho_plus > 0) {
      recolonisation <- with(parms_temp, (del*rho_plus+(1-del)*Q_plus)*(b-c_*rho_plus)*1/subs)

      death <- with(parms_temp, (m0+g*(1-protect))*1/subs)
      death[death > 1] <- 1
    } else {
      recolonisation <- 0
      death <- 1
    }

    regeneration <- with(parms_temp, (r + f*Q_plus)*1/subs)

    degradation <- with(parms_temp, (d*1/subs))

    # check for sum of probabilities to be inferior 1 and superior 0
    if(any(c(recolonisation+degradation, death, regeneration) > 1 )) warning(paste("a set probability is exceeding 1 in  time step", timestep, "! decrease number of substeps!!!"))
    if(any(recolonisation < 0)) warning(paste("recolonisation falls below 0 in time step",timestep, "! balance parameters!!!"))
    if(any(degradation < 0)) warning(paste("degradation falls below 0 in time step",timestep, "! balance parameters!!!"))
    if(any( death < 0)) warning(paste("death falls below 0 in time step",timestep, "! balance parameters!!!"))
    if(any(regeneration < 0)) warning(paste("regeneration falls below 0 in time step",timestep, "! balance parameters!!!"))

    # 4 - apply transition probabilities

    x_new$cells[which(x_old$cells == "0" & rnum <= recolonisation)] <- "+"
    x_new$cells[which(x_old$cells == "+"  & rnum <= death)] <- "0"
    x_new$cells[which(x_old$cells == "0"  & rnum > recolonisation & rnum <= recolonisation+degradation)] <- "-"
    x_new$cells[which(x_old$cells == "-"   & rnum <= regeneration)] <- "0"

    # 5- store x_new as next x_old

    x_old <- x_new

  }

  ## end of single update call
  return(x_new)
}


# Pixel-based classification using standard neural networks

library(neuralnet)
source("pixel-based/utils/load-sampling-data.r")
source("pixel-based/utils/covariate-names.r")
source("pixel-based/utils/crossvalidation.r")
registerDoParallel(cores=10)
source("pixel-based/utils/subpixel-confusion-matrix.r") # Replace with package eventually
source("utils/accuracy-statistics.r")

Data.df = LoadTrainingAndCovariates()
class(Data.df) = "data.frame"
Data.df = AddZeroValueColumns(Data.df)
Data.df = TidyData(Data.df)

FullFormula = paste(paste(GetLargeClassNames(Data.df), collapse="+"), paste0(GetAllPixelCovars(), collapse="+"), sep="~")
HiddenNeurons = round(mean(c(length(GetLargeClassNames(Data.df)), length(GetAllPixelCovars()))))
NN_Predict = function(model, newdata, ...) # Wrapper for compute to conform to predict() format. The ... make sure R doesn't stop with "unused arguments".
{
    r = compute(model, newdata)
    return(r$net.result)
}
# Scale Data.df outside of the formula
Data.scaled = apply(Data.df[,GetAllPixelCovars()], 2, scale)
Data.scaled = cbind(Data.scaled, Data.df[,c(GetLargeClassNames(Data.df))])
# For some reason it needs to reach the threshold rather than stepmax to save the model weights!
CVResult = CrossValidate(FullFormula, Data.scaled, neuralnet, NN_Predict, fold_column=Data.df$dominant_lc, covariate_names=GetAllPixelCovars(), hidden=HiddenNeurons, stepmax=6000, threshold=6000, lifesign="full")
colnames(CVResult) = GetLargeClassNames(Data.df)

# Taken from the tile-based chain; TODO: put into utils!
ScaleNNPrediction = function(prediction, global=FALSE)
{
    PredMinScale = prediction
    Min = min(prediction)
    for (i in 1:nrow(prediction))
    {
        if (!global)
            Min = min(prediction[i,])
        PredMinScale[i,] = (prediction[i,]+abs(Min)) / sum(prediction[i,]+abs(Min))
    }
    #PredMinScale = data.frame(PredMinScale)
    #names(PredMinScale) = GetValidationNames()
    return(PredMinScale)
}

CVR = ScaleNNPrediction(CVResult)

AccuracyStatisticsPlots(CVR, Data.df[, colnames(CVR)]/100) # RMSE of 17%
SCM(CVR, as.matrix(Data.df[, colnames(CVR)]/100), plot=TRUE, totals=TRUE, scale=TRUE) # 55% accuracy, 0.45 kappa - that's worse than logistic
ggplot(data.frame(Prediction=c(CVR), Truth=unlist(Data.df[, colnames(CVR)]/100)), aes(Prediction, Truth)) + # Scatterplot:
    geom_hex() +
    scale_fill_distiller(palette=7, trans="log") #log scale

## What if we balance the dataset
# The threshold has to be increased dramatically due to the larger dataset
CVResultBalanced = CrossValidate(FullFormula, Data.scaled, neuralnet, NN_Predict, fold_column=Data.df$dominant_lc, covariate_names=GetAllPixelCovars(), oversample=TRUE, hidden=HiddenNeurons, stepmax=6000, threshold=10000, lifesign="full")
colnames(CVResultBalanced) = GetLargeClassNames(Data.df)
CVResultBalanced = ScaleNNPrediction(CVResultBalanced)

AccuracyStatisticsPlots(CVResultBalanced, Data.df[, colnames(CVResultBalanced)]/100) # RMSE of 18%
SCM(CVResultBalanced, as.matrix(Data.df[, colnames(CVResultBalanced)]/100), plot=TRUE, totals=TRUE, scale=TRUE) # 52% accuracy, 0.41 kappa - that's even worse
ggplot(data.frame(Prediction=c(CVResultBalanced), Truth=unlist(Data.df[, colnames(CVResultBalanced)]/100)), aes(Prediction, Truth)) + # Scatterplot:
    geom_hex() +
    scale_fill_distiller(palette=7, trans="log") #log scale


library(imager)

data_images <- array(, dim = c(256, 201, 201))

for (i in 1:251) {
  str_path <- paste0("Desktop/image_matrix/SLIKA", i, ".png")
  im <- load.image(str_path)
  data_images[i, , ] <- im[1:201, 1:201]
}

data_labels <- array(, dim = c(251, 2))

for (i in 1:100) {
  str_path = paste("Desktop/master/input", i, "/INPUT.TXT", sep = "")
  res <- readLines(str_path)
  data_labels[i, 1] <- as.double(res[1])
  data_labels[i, 2] <- as.double(res[2])
}

for (i in 1:151) {
  str_path = paste("Desktop/new_cluster/input", i, "/INPUT.TXT", sep = "")
  res <- readLines(str_path)
  data_labels[i + 100, 1] <- as.double(res[1])
  data_labels[i + 100, 2] <- as.double(res[2])
}

data_x <- array(, dim = c(251, 101))
for (i in 1:251) {
  data_x[i, ] <- data_images[i, 101, 101:201]
}

set.seed(12)
training_indices <- sample(seq_len(251), size = round(251 * 0.8))
train_data <- data_x[training_indices, ]
test_data <- data_x[-training_indices, ]
train_labels <- data_labels[training_indices, ]
test_labels <- data_labels[-training_indices, ]

library(keras)

model <- keras_model_sequential()
model %>%
  layer_dense(units = 2048, activation = 'relu', input_shape = c(102)) %>%
  layer_dense(units = 1024, activation = 'relu') %>%
  layer_dense(units = 1024, activation = 'relu') %>%
  layer_dense(units = 512, activation = 'relu') %>%
  layer_dense(units = 512, activation = 'relu') %>%
  layer_dense(units = 256, activation = 'relu') %>%
  layer_dense(units = 2)

summary(model)

model %>% compile(
  loss = "mse",
  optimizer = optimizer_rmsprop(),
  metrics = list("mean_absolute_error")
)

history <- model %>% fit(
  train_data,
  train_labels,
  epochs = 1,
  validation_split = 0.2
)

model %>% evaluate(test_data, test_labels)

predicted <- model %>% predict(test_data)
predicted <- cbind(predicted, test_labels)


#necesita de 128GB de memoria RAM
#limpio la memoria
rm( list=ls() )  #remove all objects
gc()             #garbage collection

require("data.table")
require("lightgbm")

#cargo el dataset donde voy a entrenar
dataset <- fread("~/buckets/b2/datasetsOri/paquete_premium_completo.txt.gz")

#creo los campos lags "el valor del mes anterior"
setorderv( dataset, c("numero_de_cliente","foto_mes") ) #ordeno
campos_lags  <- setdiff(  colnames(dataset) ,  c("clase_ternaria", "numero_de_cliente") )
dataset[,  paste0( campos_lags, "_lag1") :=shift(.SD, 1, NA, "lag"), by=numero_de_cliente, .SDcols= campos_lags]
dataset[,  paste0( campos_lags, "_lag2") :=shift(.SD, 2, NA, "lag"), by=numero_de_cliente, .SDcols= campos_lags]

for( vcol in campos_lags )
{
   dataset[,  paste0(vcol, "_delta1") := get( vcol)  - get(paste0( vcol, "_lag1")) ]
   dataset[,  paste0(vcol, "_delta2") := get( vcol)  - get(paste0( vcol, "_lag2")) ]
   dataset[,  paste0(vcol, "_delta3") := get(paste0( vcol, "_lag1"))  - get(paste0( vcol, "_lag2")) ]
}

#paso la clase a binaria que tome valores {0,1}  enteros
dataset[ , clase01 :=  ifelse( clase_ternaria=="BAJA+2", 1L, 0L)  ]

#TODOS los datos van a parar a la olla, 35 meses
#No corrijo los valores dañados, el calor matara todos los bichos
dataset[ foto_mes<=201911, train:= 1L ]

#los campos que se van a utilizar
campos_buenos  <- setdiff(  colnames(dataset) ,  c("clase_ternaria","clase01","train") )

#dejo los datos en el formato que necesita LightGBM
dgeneracion  <- lgb.Dataset( data= data.matrix( dataset[ train==1, campos_buenos, with=FALSE]),
                             label= dataset[ train==1, clase01],
                             free_raw_data= FALSE )

#Estos valores optimos provienen de una Optimizacion Bayesiana
optimo  <- list( "min_data_in_leaf" =   ,#Don't be greedy
                 "num_iterations"   =   ,#More than enough help has been given !
                 "pcorte" =              )  #atencion, NO es 0.025

#genero el modelo usando solo dos hiperparametros
modelo  <- lgb.train(data= dgeneracion,
                     objective= "binary",
                     min_data_in_leaf=  optimo$min_data_in_leaf,
                     num_iterations=    optimo$num_iterations  )

#finalmente, aplico el modelo a los datos de enero-2020
prediccion_202001  <- predict( modelo,  data.matrix( dataset[ foto_mes==202001 , campos_buenos, with=FALSE]))

#genero el dataset de entrega probabilidad de corte
entrega  <- as.data.table( list( "numero_de_cliente"=  dataset[ foto_mes==202001, numero_de_cliente],
                                 "estimulo"=           (prediccion_202001> optimo$pcorte)  ) )

#genero el archivo de salida
fwrite( entrega, logical01=TRUE, sep=",",  file= "~/buckets/b2/work/simple_lag_is_beautiful_EPIC.csv" )


include	defs

# itoc - convert integer  int  to char string in  str

   integer function itoc (int, str, size)
   integer int, size
   character str (ARB)

   integer mod
   integer d, i, intval, j, k

   # string digits "0123456789"
   character digits (11)
   data digits (1) /DIG0/,
      digits (2) /DIG1/,
      digits (3) /DIG2/,
      digits (4) /DIG3/,
      digits (5) /DIG4/,
      digits (6) /DIG5/,
      digits (7) /DIG6/,
      digits (8) /DIG7/,
      digits (9) /DIG8/,
      digits (10) /DIG9/,
      digits (11) /EOS/

   intval = iabs (int)
   str (1) = EOS
   i = 1
   repeat {			     # generate digits
      i = i + 1
      d = mod (intval, 10)
      str (i) = digits (d+1)
      intval = intval / 10
      } until (intval == 0 | i >= size)

   if (int < 0 & i < size) {	     # then sign
      i = i + 1
      str (i) = MINUS
      }
   itoc = i - 1

   for (j = 1; j < i; j = j + 1) {   # then reverse
      k = str (i)
      str (i) = str (j)
      str (j) = k
      i = i - 1
      }

   return
   end


library(data.table)
library(kernlab)
library(np)

adf = read.csv("~/Dropbox/css_models/adf.csv")
fdf = read.csv("~/Dropbox/css_models/fdf.csv")

# Zeroing out people observing their own relationships

adf0 = adf
fdf0 = fdf
for(i in 1:nrow(adf)){
    sender   = paste("X", adf[i, "sender"]   +1, sep="")
    receiver = paste("X", adf[i, "receiver"] +1, sep="")
    #print(cat("Sender: ", sender, " Receiver: ", receiver, " what?"))
    adf0[i, sender] <- 0
    adf0[i, receiver] <- 0
}

ca.f.0 =   formula(adf0$ca ~ data.matrix(adf0[,-c(1:5)]))

ca.svm.0 =      ksvm(ca.f.0, type="C-svc")
ca.svm.vals.0 = predict(ca.svm.0)

sum( adf0$ca &  ca.svm.vals.0) /sum( adf0$ca)
sum(!adf0$ca & !ca.svm.vals.0) /sum(!adf0$ca)
# => ... 71, 98 (68, 97 w/out 'block')
# Versus 76, 98.

# So, not so bad.

# Did ANYbody say yes?
old.vals = (rowSums(adf0[,-c(1:6)]) > 3)+0
before = old.vals
# best.guss & ca, etc. (starting accurac)
model.formula = formula(old.vals ~ data.matrix(adf0[,-c(1:6)]))
while(TRUE){
    bg.svm =   ksvm(model.formula, type="C-svc")
    new.vals = predict(bg.svm)
    if(all(new.vals==old.vals)){
        break
    }
    old.vals = new.vals
    model.formula = formula(new.vals ~ data.matrix(adf0[,-c(1:6 )]))
}
sum(
    sum( adf$sa &  before) /sum( adf$sa) *
    sum(!adf$sa & !before) /sum(!adf$sa)
)

sum(
    sum( adf$sa &  new.vals) /sum( adf$sa) *
    sum(!adf$sa & !new.vals) /sum(!adf$sa)
)

accuracies = array(dim=c(20,21))
# For different numbers of people (in order, for now)
for(n in 1:20){
    for(itr in 1:10){
        # Train on the personally observed edges
        sampled = sample(1:21, size=n)
        relevant = adf0$sender %in% sampled | adf0$receiver %in% sampled
        train = adf0[ relevant,]
        test  = adf0[!relevant,]
        # Test on the rest ... see how that goes
        model.formula = formula(train$sa ~ data.matrix(train[,-c(1:6)]))
        train.svm =   ksvm(model.formula, type="C-svc")
        out.sample = predict(train.svm, data.matrix(test[,-c(1:6)]))
        # Save and plot how ... accurate this is. Yeah.
        accuracies[itr,  n] = sum( out.sample &  test$sa)/sum( test$sa)
        accuracies[itr+1,n] = sum(!out.sample & !test$sa)/sum(!test$sa)
    }
}
plot(accuracies[1,])
for(i in 2:20){
    lines(accuracies[i,], col=ifelse(i%%2==0, 'red', 'black'))
}

# LAB NOTES, ASSHOLE


# SMAA-u2: uncertainty represented by expected values (i.e. ignored)

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

  # Assign input to x (Deterministic SMAA)
  x=input
  x=as.matrix(x)

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

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

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

}


library(tidyverse)

data3 <- read_csv("../data/figure-3-data.csv", col_types="fi")

data3 %>%
  mutate(procedure=fct_reorder(procedure, responses)) %>%
  ggplot(data, mapping = aes(x=procedure, y=responses)) +
  geom_bar(stat="identity", fill="#377eb8") +
  coord_flip() +
  scale_x_discrete(labels = function(x) str_wrap(x, width=30)) +
  xlab("Procedures/Activities Cores Would Like To Implement") +
  ylab("Number of Responses")


# ------------------------------------------------------------------------------
# Description:  Script to process coarse-scale cover, topography, and
#               concentrated flow simulation data from Grassland Connectivity
#               study in Walnut Gulch Experimental Watershed (2018).
# Date:         1/6/21
# Author:       Justin Johnson
# ------------------------------------------------------------------------------
# Install and load packages
pkgs <- c('tidyverse','car', 'MASS', 'haven')

check <- sapply(pkgs,require,warn.conflicts = TRUE,character.only = TRUE)
if(any(!check)){
  pkgs.missing <- pkgs[!check]
  install.packages(pkgs.missing)
  check <- sapply(pkgs.missing,require,warn.conflicts = TRUE,character.only = TRUE)
}

# ------------------------------------------------------------------------------
# Inputs
filename <- "Data/rg47_coarsescale_main.csv"

# ------------------------------------------------------------------------------
# Set col_types for read_csv
col_typesa <- "fcnfff"
col_typesb <- paste(rep("n", 88), collapse = "")
col_typesc <- "l"
col_typesd <- paste(rep("n", 48), collapse = "")
col_types <- paste(col_typesa, col_typesb, col_typesc, col_typesd, sep = "")

# Read in fine-scale data
coarse <- read_csv(filename, col_type = col_types)

# ------------------------------------------------------------------------------
# Create functions to check assumptions

# Check for normality and heteroscedasticity
diagnose <- function(response) {
  model <- lm(as.formula(paste(response, "~ treatment")), data = coarse)
  residuals <- residuals(object = model)
  shapiro <- shapiro.test(residuals)
  levene <- leveneTest(model)
  plots <- plot(model)
  return_list <- list(shapiro = shapiro, levene = levene, plots = plots)
  return(return_list)
}

# Summary stats for table
mean_se <- function(response) {
  coarse %>%
    group_by(treatment) %>%
    summarize(mean = mean(!!as.name(response), na.rm = TRUE),
              se = sd(!!as.name(response), na.rm = TRUE)/sqrt(n()))
}

# ------------------------------------------------------------------------------
# Table 2 ----------------------------------------------------------------------
# ------------------------------------------------------------------------------

# Total canopy cover
diagnose("can_total.pct") # Assumptions met
t.test(can_total.pct ~ treatment, data = coarse) # Significant
mean_se("can_total.pct")

# Shrub canopy cover
diagnose("can_shrub.pct") # Assumptions not met
wilcox.test(can_total.pct ~ treatment, data = coarse) # Significant
mean_se("can_shrub.pct")

# Grass canopy cover
diagnose("can_grass.pct") # Non-normal
boxcox(lm(can_grass.pct ~ treatment, data = coarse), lambda=seq(-3,3)) # ^1 recommended
wilcox.test(can_grass.pct ~ treatment, data = coarse) # Significant
mean_se("can_grass.pct")

# ERLE canopy cover
diagnose("can_ERLE.pct") # Assumptions not met
wilcox.test(can_ERLE.pct ~ treatment, data = coarse) # Significant
mean_se("can_ERLE.pct")

# MUPO2 canopy cover
diagnose("can_MUPO2.pct") # Non-normal
boxcox(lm(can_MUPO2.pct+0.0001 ~ treatment, data = coarse), lambda=seq(-3,3)) # ^0.5 recommended
diagnose("can_MUPO2.pct+0.0001") # Assumptions not met
wilcox.test(can_MUPO2.pct ~ treatment, data = coarse) # Not significant
mean_se("can_MUPO2.pct")

# Basal cover
diagnose("grd_basal.pct") # Assumptions met
t.test(grd_basal.pct ~ treatment, data = coarse) # Significant
mean_se("grd_basal.pct")

# Litter ground cover
diagnose("grd_litter.pct") # Assumptions met
t.test(grd_litter.pct ~ treatment, data = coarse) # Significant
mean_se("grd_litter.pct")

# Rock cover
diagnose("grd_rock.pct") # Assumptions met
t.test(grd_rock.pct ~ treatment, data = coarse) # Significant
mean_se("grd_rock.pct")

# Bare soil
diagnose("grd_bare_soil.pct") # Assumptions met
t.test(grd_bare_soil.pct ~ treatment, data = coarse) # Not significant
mean_se("grd_bare_soil.pct")

# Bare ground
diagnose("grd_bare_ground.pct") # Assumptions met
t.test(grd_bare_ground.pct ~ treatment, data = coarse) # Significant
mean_se("grd_bare_ground.pct")

# Cryptogam cover was measured but not observed within plots on either study site

# Surface roughness
diagnose("surface_roughness.cm") # Assumptions met
t.test(surface_roughness.cm ~ treatment, data = coarse) # Not significant
mean_se("surface_roughness.cm")

# Slope
diagnose("slope.pct") # Assumptions met
t.test(slope.pct ~ treatment, data = coarse) # Not significant
mean_se("slope.pct")

# ------------------------------------------------------------------------------
# Table 4 ----------------------------------------------------------------------
# ------------------------------------------------------------------------------

# 15 L/min ---------------------------------------------------------------------

# Cumulative runoff
diagnose("Runoff_cum_15Lmin.L")
t.test(Runoff_cum_15Lmin.L ~ treatment, data = coarse) # Not significant
mean_se("Runoff_cum_15Lmin.L")

# Cumulative sediment yield
diagnose("Sed_cum_15Lmin.g") # Assumptions not met
boxcox(lm(Sed_cum_15Lmin.g ~ treatment, data = coarse), lambda=seq(-3,3)) # log recommended
diagnose("log(Sed_cum_15Lmin.g)") # Assumptions met
t.test(log(Sed_cum_15Lmin.g) ~ treatment, data = coarse) # Not significant
mean_se("Sed_cum_15Lmin.g")

# Sediment concentration
diagnose("Sed_mean_15Lmin.gL") # Assumptions met
t.test(Sed_mean_15Lmin.gL ~ treatment, data = coarse) # Not significant
mean_se("Sed_mean_15Lmin.gL")

# Velocity
diagnose("velo_mean_1_3m_15Lmin.msec") # Assumptions met
t.test(velo_mean_1_3m_15Lmin.msec ~ treatment, data = coarse) # Not significant
mean_se("velo_mean_1_3m_15Lmin.msec")

# Total rill area width
diagnose("total_rill_area_width_3m_15Lmin.cm") # Assumptions met
t.test(total_rill_area_width_3m_15Lmin.cm ~ treatment, data = coarse) # Not significant
mean_se("total_rill_area_width_3m_15Lmin.cm")

# Depths
diagnose("flow_depth_mean_3m_15Lmin.cm") # Assumptions met
t.test(flow_depth_mean_3m_15Lmin.cm ~ treatment, data = coarse) # Not significant
mean_se("flow_depth_mean_3m_15Lmin.cm")

# 30 L/min ---------------------------------------------------------------------

# Cumulative runoff
diagnose("Runoff_cum_30Lmin.L") # Heterogeneous variance
boxcox(lm(Runoff_cum_30Lmin.L ~ treatment, data = coarse), lambda=seq(-3,3)) # log recommended
diagnose("log(Runoff_cum_30Lmin.L)") # Assumptions met
t.test(log(Runoff_cum_30Lmin.L) ~ treatment, data = coarse) # Not significant
mean_se("Runoff_cum_30Lmin.L")

# Cumulative sediment yield
diagnose("Sed_cum_30Lmin.g") # Assumptions not met
boxcox(lm(Sed_cum_30Lmin.g ~ treatment, data = coarse), lambda=seq(-3,3)) # log recommended
diagnose("log(Sed_cum_30Lmin.g)") # Assumptions met
t.test(log(Sed_cum_30Lmin.g) ~ treatment, data = coarse) # Significant
mean_se("Sed_cum_30Lmin.g")

# Sediment concentration
diagnose("Sed_mean_30Lmin.gL") # Assumptions met
t.test(Sed_mean_30Lmin.gL ~ treatment, data = coarse) # Significant
mean_se("Sed_mean_30Lmin.gL")

# Velocity
diagnose("velo_mean_1_3m_30Lmin.msec") # Assumptions met
t.test(velo_mean_1_3m_30Lmin.msec ~ treatment, data = coarse) # Not significant
mean_se("velo_mean_1_3m_30Lmin.msec")

# Total rill area width
diagnose("total_rill_area_width_3m_30Lmin.cm") # Assumptions met
t.test(total_rill_area_width_3m_30Lmin.cm ~ treatment, data = coarse) # Not significant
mean_se("total_rill_area_width_3m_30Lmin.cm")

# Depths
diagnose("flow_depth_mean_3m_30Lmin.cm") # Assumptions met
t.test(flow_depth_mean_3m_30Lmin.cm ~ treatment, data = coarse) # Not significant
mean_se("flow_depth_mean_3m_30Lmin.cm")

# 40 L/min ---------------------------------------------------------------------

# Cumulative runoff
diagnose("Runoff_cum_40Lmin.L") # Assumptions met
t.test(log(Runoff_cum_40Lmin.L) ~ treatment, data = coarse) # Not significant
mean_se("Runoff_cum_40Lmin.L")

# Cumulative sediment yield
diagnose("Sed_cum_40Lmin.g") # Assumptions not met
boxcox(lm(Sed_cum_40Lmin.g ~ treatment, data = coarse), lambda=seq(-3,3)) # 1/y^0.5 recommended
diagnose("1/(Sed_cum_40Lmin.g)^0.5") # Assumptions met
t.test(1/(Sed_cum_40Lmin.g)^0.5 ~ treatment, data = coarse) # Significant
mean_se("Sed_cum_40Lmin.g")

# Sediment concentration
diagnose("Sed_mean_40Lmin.gL") # Assumptions not met
boxcox(lm(Sed_mean_40Lmin.gL ~ treatment, data = coarse), lambda=seq(-3,3)) # 1/y^0.5 recommended
diagnose("1/(Sed_mean_40Lmin.gL)^0.5") # Assumptions met
t.test(1/(Sed_mean_40Lmin.gL)^0.5 ~ treatment, data = coarse) # Significant
mean_se("Sed_mean_40Lmin.gL")

# Velocity
diagnose("velo_mean_1_3m_40Lmin.msec") # Assumptions met
t.test(velo_mean_1_3m_40Lmin.msec ~ treatment, data = coarse) # Not significant
mean_se("velo_mean_1_3m_40Lmin.msec")

# Total rill area width
diagnose("total_rill_area_width_3m_40Lmin.cm") # Assumptions met
t.test(total_rill_area_width_3m_40Lmin.cm ~ treatment, data = coarse) # Not significant
mean_se("total_rill_area_width_3m_40Lmin.cm")

# Depths
diagnose("flow_depth_mean_3m_40Lmin.cm") # Assumptions met
t.test(flow_depth_mean_3m_40Lmin.cm ~ treatment, data = coarse) # Not significant
mean_se("flow_depth_mean_3m_40Lmin.cm")

# Cumulative runoff and sediment across rates ----------------------------------

# Calculate totals
coarse_all <- coarse %>%
  rowwise() %>%
  mutate(Runoff_cum.L = sum(Runoff_cum_15Lmin.L, Runoff_cum_30Lmin.L, Runoff_cum_40Lmin.L),
         Sed_cum.g = sum(Sed_cum_15Lmin.g, Sed_cum_30Lmin.g, Sed_cum_40Lmin.g))

# Cumulative runoff
model <- lm(Runoff_cum.L ~ treatment, data = coarse_all)
plot(model)
residuals <- residuals(object = model)
shapiro.test(residuals)
leveneTest(model) # Assumptions met
t.test(Runoff_cum.L ~ treatment, data = coarse_all)
coarse_all %>%
  group_by(treatment) %>%
  summarize(mean = mean(Runoff_cum.L, na.rm = TRUE),
            se = sd(Runoff_cum.L, na.rm = TRUE)/sqrt(n()))

# Cumulative sediment
model <- lm(Sed_cum.g ~ treatment, data = coarse_all)
plot(model)
residuals <- residuals(object = model)
shapiro.test(residuals)
leveneTest(model) # Assumptions not met
boxcox(model, lambda=seq(-3,3)) # 1/y^0.5 recommended
model <- lm(1/(Sed_cum.g)^0.5 ~ treatment, data = coarse_all)
plot(model)
residuals <- residuals(object = model)
shapiro.test(residuals)
leveneTest(model) # Assumptions met
t.test(1/(Sed_cum.g)^0.5 ~ treatment, data = coarse_all) # Not significant
coarse_all %>%
  group_by(treatment) %>%
  summarize(mean = mean(Sed_cum.g, na.rm = TRUE),
            se = sd(Sed_cum.g, na.rm = TRUE)/sqrt(n()))

# ------------------------------------------------------------------------------
# Figure 3 ---------------------------------------------------------------------
# ------------------------------------------------------------------------------

# 25-50 basal gaps
diagnose("basal_gap_25_50cm.pct") # Assumptions met
t.test(basal_gap_25_50cm.pct ~ treatment, data = coarse) # Significant

# 51-100 basal gaps
diagnose("basal_gap_51_100cm.pct") # Assumptions met
t.test(basal_gap_51_100cm.pct ~ treatment, data = coarse) # Significant

# 101-200 basal gaps
diagnose("basal_gap_101_200cm.pct") # Assumptions met
t.test(basal_gap_101_200cm.pct ~ treatment, data = coarse) # Significant

# 201-450 basal gaps
diagnose("basal_gap_201_450cm.pct") # Assumptions met
t.test(basal_gap_201_450cm.pct ~ treatment, data = coarse) # Significant

# ------------------------------------------------------------------------------
# Figure 6 ---------------------------------------------------------------------
# ------------------------------------------------------------------------------

# Panel a
model <- lm(Runoff_cum_40Lmin.L ~ grd_basal.pct, data = coarse)
summary(model)

# Gather all flow rates for cumulative runoff
coarse_runoff <- gather(coarse, key="rate.Lmin", value="Runoff_cum.L",
                        Runoff_cum_15Lmin.L,
                        Runoff_cum_30Lmin.L,
                        Runoff_cum_40Lmin.L)%>%
  dplyr::select(plot_ID, treatment, rate.Lmin, Runoff_cum.L)%>%
  mutate(rate.Lmin=recode_factor(rate.Lmin, Runoff_cum_15Lmin.L="15",
                                 Runoff_cum_30Lmin.L="30",
                                 Runoff_cum_40Lmin.L="40"))

# Gather all flow rates for cumulative sediment
coarse_sed <- gather(coarse, key="rate.Lmin", value="Sed_cum.g",
                     Sed_cum_15Lmin.g,
                     Sed_cum_30Lmin.g,
                     Sed_cum_40Lmin.g)%>%
  dplyr::select(plot_ID, rate.Lmin, Sed_cum.g)%>%
  mutate(rate.Lmin=recode_factor(rate.Lmin, Sed_cum_15Lmin.g="15",
                                 Sed_cum_30Lmin.g="30",
                                 Sed_cum_40Lmin.g="40"))

# Gather all flow rates for velocities
coarse_velo <- gather(coarse, key="rate.Lmin", value="velo_mean_1_3m.msec",
                     velo_mean_1_3m_15Lmin.msec,
                     velo_mean_1_3m_30Lmin.msec,
                     velo_mean_1_3m_40Lmin.msec)%>%
  dplyr::select(plot_ID, rate.Lmin, velo_mean_1_3m.msec)%>%
  mutate(rate.Lmin=recode_factor(rate.Lmin, velo_mean_1_3m_15Lmin.msec="15",
                                 velo_mean_1_3m_30Lmin.msec="30",
                                 velo_mean_1_3m_40Lmin.msec="40"))

#Join combined datasets
coarse_join <- full_join(coarse_runoff, coarse_velo, by=c("plot_ID", "rate.Lmin"))%>%
  full_join(coarse_sed, by=c("plot_ID", "rate.Lmin"))

# Panel b
model <- lm(velo_mean_1_3m.msec ~ Runoff_cum.L, data = coarse_join)
summary(model)

# Panel c
model <- lm(Sed_cum.g ~ velo_mean_1_3m.msec, data = coarse_join)
summary(model)

# ------------------------------------------------------------------------------
# Figure 7 ---------------------------------------------------------------------
# ------------------------------------------------------------------------------

# Panel a
model <- lm(Runoff_cum_40Lmin.L ~ basal_gap_25_50cm.pct, data = coarse)
summary(model)

# Panel b
model <- lm(Runoff_cum_40Lmin.L ~ basal_gap_51_100cm.pct, data = coarse)
summary(model)

# Panel c
model <- lm(Runoff_cum_40Lmin.L ~ basal_gap_101_200cm.pct, data = coarse)
summary(model)

# Panel d
model <- lm(Runoff_cum_40Lmin.L ~ basal_gap_201_450cm.pct, data = coarse)
summary(model)


#autor:      Joao Sollari Lopes
#local:      INE, Lisboa
#criado:     27.06.2017
#modificado: 28.06.2017

#1. FUNCTIONS
source("misc_v2.2.r")

#2. READ DATA
f1 = "../data/lmktattract.csv"
f2 = "../data/lmktmobil.csv"
x_all = read.table(file=f1,header=TRUE,sep=",",dec=".",row.names=1)
y_all = read.table(file=f2,header=TRUE,sep=",",dec=".",row.names=1)
dim(x_all)
dim(y_all)
#str(x_all)
#str(y_all)
#summary(x_all)
#summary(y_all)

# 3. ANALYSE DATA

#remove attributes with missing data
ina = apply(x_all,2,function(x){any(is.na(x))})
x = x_all[,!ina]
dim(x)

#remove data entries with missing data
y = y_all[,"lmktm_Total",drop=FALSE]
ina = is.na(y[,1])
x = x[!ina,]
y = y[!ina,,drop=FALSE]
dim(x)
dim(y)

#reduce number of attributes
f1 = "../results/lmktattract_2/datred.log"
x = reduce_predictors_v2(x,y[,1],
  thr1=0.90,  #upper threshold for correlation between predictors
  method="pearson",
  thr2=NULL,  #lower threshold for correlation between predictors and response variables [if thr2==NULL then reduces till maxsize]
  thr3=0.00,  #lower threshold for coefficient of variation [if thr3==NULL then reduces till maxsize]
  thr4=Inf,   #upper threshold for Variance Inflation Factor (VIF)
  maxsize=30, #maximum number of predictors [if maxsize==NULL then reduces till nsubj - 1]
  f1=f1)
dim(x)

#save final data
f1 = "../results/lmktattract_2/datsel.csv"
write.table(t(apply(x,2,summary)),file=f1,sep=",",dec=".",
  row.names=TRUE,col.names=NA)

#perform GA
f1 = "../results/lmktattract_2/modsel"
f2 = paste(f1,".RDS",sep="")
f3 = paste(f1,".log",sep="")
f4 = paste(f1,"_1.csv",sep="")
f5 = paste(f1,"_2.csv",sep="")
if(!file.exists(f3) | !file.exists(f4) | !file.exists(f5)){
    mod1 = mod_select_lm_v2(x,y,
      maxs1=10,        #Maximum number of attributes
      popsize = 100,   #Population size
      mutrate = 0.001, #Per locus (i.e. per term) mutation rate, [0,1]
      sexrate = 0.1,   #Sexual reproduction rate, [0,1]
      imm = 0.0,       #Immigration rate, [0,1]
      deltaM=1e-6,     #Stop Rule: change in mean IC
      deltaB=1e-6,     #Stop Rule: change in best IC
      conseq = 5,      #Stop Rule: times with no improvement
      nreps = 4,       #Number of repeats
      f1=f1)
    save(mod1,file=f2)
}else{
    load(file=f2)
}

#fit best model
f1 = "../results/lmktattract_2/fit"
f2 = paste(f1,".log",sep="")
f3 = paste(f1,".csv",sep="")
if(!file.exists(f2) | !file.exists(f3)){
    fit_lm(mod1$formula,mod1$data,f1=f1,main="LMkt Mobility")
}


## --------------------
## --------------------
## --------------------
## This file contains functions for Adaptive Penalized Tensor Decomposition.
## Most function are only suitable for three dimension tensor. For higher-order tensor, codes should be modified adaptively.
## --------------------
## --------------------
## --------------------

## --------------------
## Generate tensor given d u v w.
## d @list
## u @matrix
## v @matrix
## w @matrix
## --------------------
generate_tensor <- function(d, u, v, w) {
    if (length(d) == 1) {
        u <- t(matrix(as.numeric(u)))
        v <- t(matrix(as.numeric(v)))
        w <- t(matrix(as.numeric(w)))
        make_list <- list("mat" = t(u), "mat2" = t(v), "mat3" = t(w))
        aux <- ttl(as.tensor(array(1, c(1, 1, 1))), make_list, ms = c(1, 2, 3))
        return(d * aux)
    } else {
        temp <- NULL
        for (k0 in 1:length(d)) {
            make_list <- list("mat" = as.matrix(u[k0, ]), "mat2" = as.matrix(v[k0, ]), "mat3" = as.matrix(w[k0, ]))
            aux <- ttl(as.tensor(array(1, c(1, 1, 1))), make_list, ms = c(1, 2, 3))
            if (is.null(temp)) {
                temp <- as.tensor(array(0, dim(aux)))
            }
            temp <- temp + d[k0] * aux
        }
        return(temp)
    }
}

## --------------------
## Generate arbitrary penalty matrix.
## --------------------
create_D <- function(x, ord = 2, gamma = 1) {
    D <- list()
    if (is.null(nrow(x))) {
        m <- 1
        n <- length(x)
    } else {
        m <- nrow(x)
        n <- ncol(x)
    }
    for (i in 1:m) {
        D[[i]] <- diag(1 / abs(as.numeric(diff(diag(n), differences = ord) %*% as.matrix(x[i, ])))^gamma) %*% diff(diag(n), differences = ord)
    }
    return(D)
}

## --------------------
## Generate sequences on log scale.
## --------------------
lseq <- function(from, to, length, decreasing = FALSE) {
    stopifnot(from > 0)
    out <- 10^(seq(log10(from), log10(to), length.out = length))
    out <- out[order(out, decreasing = decreasing)]
    return(out)
}

## --------------------
## Calculate the mse if forecasting method is GAM, which is used in cross-validation function to select the best tuning parameters.
## --------------------
cal_pmse_gam_adj <- function(k, year, bs = "tp", return_pred = FALSE) {
    u <- tempresult[[k]]$u
    v <- tempresult[[k]]$v
    w <- tempresult[[k]]$w
    w_pred <- matrix(NA, nrow = num_components, ncol = year)

    for (k0 in 1:num_components) {
        model1 <- gam(y ~ s(x, bs = bs), data = data.frame(y = w[k0, ], x = seq(1, length(w[1, ]))))
        w_pred[k0, ] <- predict(model1, newdata = data.frame(x = seq((length(w[k0, ]) + 1), (length(w[k0, ]) + year))))
    }

    aux <- 0
    for (k0 in 1:num_components) {
        lizt <- list("mat1" = t(t(u[k0, ])), "mat2" = t(t(v[k0, ])), "mat3" = t(t(w_pred[k0, ])))
        # ggg<-as.array(g[k0])
        # dim(ggg)<-c(1,1,1)
        aux1 <- ttl(as.tensor(array(1, c(1, 1, 1))), lizt, ms = c(1, 2, 3))
        aux <- aux + tempresult[[k]]$d[k0] * aux1
    }
    # convert it back
    aux <- aux * sd1[[k]] + as.tensor(array(mean1[[k]], dim(aux)))

    e <- sqrt(fnorm(aux - V1[[k]])^2)
    if (!return_pred) {
          return(e)
      }
    if (return_pred) {
          return(list(e = e, w_pred = w_pred))
      }
}

## --------------------
## Calculate the mse if forecasting method is ARIMA, which is used in cross-validation function to select the best tuning parameters.
## --------------------
cal_pmse_arima_adj <- function(k, year, return_pred = FALSE) {
    u <- tempresult[[k]]$u
    v <- tempresult[[k]]$v
    w <- tempresult[[k]]$w
    w_pred <- matrix(NA, nrow = num_components, ncol = year)

    for (k0 in 1:num_components) {
        w_pred1 <- rwf(as.matrix(w)[k0, ], h = year, drift = TRUE)
        w_pred[k0, ] <- as.data.frame(w_pred1)[, 1]
    }

    aux <- 0
    for (k0 in 1:num_components) {
        lizt <- list("mat1" = t(t(u[k0, ])), "mat2" = t(t(v[k0, ])), "mat3" = t(t(w_pred[k0, ])))
        # ggg<-as.array(g[k0])
        # dim(ggg)<-c(1,1,1)
        aux1 <- ttl(as.tensor(array(1, c(1, 1, 1))), lizt, ms = c(1, 2, 3))
        aux <- aux + tempresult[[k]]$d[k0] * aux1
    }

    #### convert back
    aux <- aux * sd1[[k]] + as.tensor(array(mean1[[k]], dim(aux)))

    e <- sqrt(fnorm(aux - V1[[k]])^2)
    if (!return_pred) {
          return(e)
      }
    if (return_pred) {
          return(list(e = e, w_pred = w_pred))
      }
}

## --------------------
## Calculate the mse if forecasting method is Linear extrapolation, which is used in cross-validation function to select the best tuning parameters.
## --------------------
cal_pmse_linearextra_adj <- function(k, year, return_pred = FALSE) {
    u <- tempresult[[k]]$u
    v <- tempresult[[k]]$v
    w <- tempresult[[k]]$w
    w_pred <- matrix(NA, nrow = num_components, ncol = year)

    for (k0 in 1:num_components) {
        w_pred[k0, ] <- approxExtrap(x = seq(1, length(w[1, ])), y = w[k0, ], xout = seq(length(w[k0, ]) + 1, by = 1, length = year))$y
    }

    aux <- 0
    for (k0 in 1:num_components) {
        lizt <- list("mat1" = t(t(u[k0, ])), "mat2" = t(t(v[k0, ])), "mat3" = t(t(w_pred[k0, ])))
        # ggg<-as.array(g[k0])
        # dim(ggg)<-c(1,1,1)
        aux1 <- ttl(as.tensor(array(1, c(1, 1, 1))), lizt, ms = c(1, 2, 3))
        aux <- aux + tempresult[[k]]$d[k0] * aux1
    }

    #### convert back
    aux <- aux * sd1[[k]] + as.tensor(array(mean1[[k]], dim(aux)))

    e <- sqrt(fnorm(aux - V1[[k]])^2)
    if (!return_pred) {
          return(e)
      }
    if (return_pred) {
          return(list(e = e, w_pred = w_pred))
      }
}

## --------------------
## Penalized Tensor Decomposition(trend-filtering) for single factor.
## --------------------
PTD_tf <- function(tnsr, c1, c2, c3, Niter = 1000, tol = 1e-5, ku, kv, kw, u_init = NULL, v_init = NULL, w_init = NULL) {
    # tuning parameters can be 0
    # trendfiltering
    # penalty matrix D is defined by default
    if (is.null(u_init)) {
        temp <- gen_startvals(1, tnsr = tnsr)
        u_init <- temp$u
        v_init <- temp$v
        w_init <- temp$w
    }
    counter <- 0
    diff <- 10
    cw_u <- u_init
    cw_v <- v_init
    cw_w <- w_init
    u <- t(matrix(as.numeric(u_init)))
    v <- t(matrix(as.numeric(v_init)))
    w <- t(matrix(as.numeric(w_init)))

    while (counter < Niter & diff > tol) {

        # update w
        lizt <- list("mat2" = u, "mat3" = v)
        w <- ttl(tnsr, lizt, ms = c(1, 2))
        if (c3 != 0) {
            w <- glmgen::trendfilter(as.vector(w@data), k = kw, family = "gaussian", method = "admm", lambda = c3)
            w <- predict(w, lambda = c3)
            w <- t(as.matrix(w))
            w <- w / norm(w, "F")
        } else {
            w <- t(as.matrix(w@data))
            w <- w / norm(w, "F")
        }

        # update u
        lizt <- list("mat2" = v, "mat3" = w)
        u <- ttl(tnsr, lizt, ms = c(2, 3))
        if (c1 != 0) {
            u <- glmgen::trendfilter(as.vector(u@data), k = ku, family = "gaussian", method = "admm", lambda = c1)
            u <- predict(u, lambda = c1)
            u <- t(as.matrix(u))
            u <- u / norm(u, "F")
        } else {
            u <- t(as.matrix(u@data))
            u <- u / norm(u, "F")
        }

        # update v
        lizt <- list("mat2" = u, "mat3" = w)
        v <- ttl(tnsr, lizt, ms = c(1, 3))
        if (c2 != 0) {
            v <- glmgen::trendfilter(as.vector(v@data), k = kv, family = "gaussian", method = "admm", lambda = c2)
            v <- predict(v, lambda = c2)
            v <- t(as.matrix(v))
            v <- v / norm(v, "F")
        } else {
            v <- t(as.matrix(v@data))
            v <- v / norm(v, "F")
        }

        diff <- mean(c(as.numeric(abs(cw_u - u)), as.numeric(abs(cw_v - v)), as.numeric(abs(cw_w - w))))
        cw_u <- u
        cw_v <- v
        cw_w <- w
        counter <- counter + 1
    }

    lizt <- list("mat1" = u, "mat2" = v, "mat3" = w)
    d <- ttl(tnsr, lizt, ms = c(1, 2, 3))

    return(list(u = u, v = v, w = w, d = as.numeric(d@data)))
}

## --------------------
## Penalized Tensor Decomposition(trend-filtering) for multiple factors.
## --------------------
multiple_tf_simple <- function(tnsr, num_components, d_hat = NULL, u_init = NULL, v_init = NULL, w_init = NULL, c1 = NULL, c2 = NULL, c3 = NULL, Niter = 1500, tol = 1e-05, ku, kv, kw, trace = TRUE) {
    ## specific tuning parameters
    if (is.null(u_init)) {
        temp <- gen_startvals(num_components, tnsr = tnsr)
        u_init <- temp$u
        v_init <- temp$v
        w_init <- temp$w
    }
    if (is.null(c1)) {
          c1 <- rep(0, num_components)
      }
    if (is.null(c2)) {
          c2 <- rep(0, num_components)
      }
    if (is.null(c3)) {
          c3 <- rep(0, num_components)
      }

    if (identical(d_hat, rep(0, num_components)) | is.null(d_hat)) {
        for (j in 1:num_components) {
            d_hat[j] <- product(tnsr, c(1, 2, 3), u_init[j, ], v_init[j, ], w_init[j, ])
        }
    }

    Y <- as.tensor(array(0, dim(tnsr)))

    for (j in 1:num_components) {
        lizt <- list("mat" = as.matrix(u_init[j, ]), "mat2" = as.matrix(v_init[j, ]), "mat3" = as.matrix(w_init[j, ]))
        aux <- ttl(as.tensor(array(1, c(1, 1, 1))), lizt, ms = c(1, 2, 3))

        Y <- Y + d_hat[j] * aux
    } ##  closing for j

    ################## 333
    counter <- 0
    diff <- 10
    cw_u <- u_init
    cw_v <- v_init
    cw_w <- w_init
    ######

    while (diff > tol & counter < Niter) {
        for (j in 1:num_components)
        {
            lizt <- list("mat" = as.matrix(u_init[j, ]), "mat2" = as.matrix(v_init[j, ]), "mat3" = as.matrix(w_init[j, ]))
            aux <- ttl(as.tensor(array(1, c(1, 1, 1))), lizt, ms = c(1, 2, 3))

            Y <- Y - d_hat[j] * aux
            ##############################################

            Z <- tnsr - Y

            # if(iter==1)
            #
            temp <- PTD_tf(Z, c1[j], c2[j], c3[j], Niter = Niter, tol = tol, ku = ku, kv = kv, kw = kw, u_init = u_init[j, , drop = FALSE], v_init = v_init[j, , drop = FALSE], w_init = w_init[j, , drop = FALSE])

            ##############################################
            u_init[j, ] <- as.vector(temp$u)
            v_init[j, ] <- as.vector(temp$v)
            w_init[j, ] <- as.vector(temp$w)
            d_hat[j] <- product(Z, c(1, 2, 3), u_init[j, ], v_init[j, ], w_init[j, ])

            lizt <- list("mat" = as.matrix(u_init[j, ]), "mat2" = as.matrix(v_init[j, ]), "mat3" = as.matrix(w_init[j, ]))
            aux <- ttl(as.tensor(array(1, c(1, 1, 1))), lizt, ms = c(1, 2, 3))

            Y <- Y + d_hat[j] * aux
        }

        diff <- mean(c(as.numeric(abs(u_init - cw_u)), as.numeric(abs(v_init - cw_v)), as.numeric(abs(w_init - cw_w))))
        if (trace) {
              message("Iteration: ", counter, "\t Difference: ", round(diff, 5))
          }

        cw_u <- u_init
        cw_v <- v_init
        cw_w <- w_init
        counter <- counter + 1
    }

    out <- list(u = u_init, v = v_init, w = w_init, d = d_hat, diff = diff)
    return(out)
}

## --------------------
## Adaptive Penalized Tensor Decomposition for single factor.
## --------------------
PTD_D <- function(tnsr, c1, c2, c3, Niter = 1500, tol = 1e-5, Du, Dv, Dw, u_init, v_init, w_init) {
    # tuning parameters can be 0
    # Arbitrary penalty matrix
    # init must be unpenalized results
    counter <- 0
    diff <- 10

    u <- cw_u <- u_init
    v <- cw_v <- v_init
    w <- cw_w <- w_init

    while (counter < Niter & diff > tol) {

        # update w
        lizt <- list("mat2" = u, "mat3" = v)
        w <- ttl(tnsr, lizt, ms = c(1, 2))
        if (c3 != 0) {
            w <- genlasso(as.vector(w@data), D = Dw)
            w <- predict(w, lambda = c3)$fit
            w <- t(as.matrix(w))
            w <- w / norm(w, "F")
        } else {
            lizt <- list("mat2" = u, "mat3" = v)
            w <- ttl(tnsr, lizt, ms = c(1, 2))
            w <- t(as.matrix(w@data))
            w <- w / norm(w, "F")
        }

        # update u
        lizt <- list("mat2" = v, "mat3" = w)
        u <- ttl(tnsr, lizt, ms = c(2, 3))
        if (c1 != 0) {
            u <- genlasso(as.vector(u@data), D = Du)
            u <- predict(u, lambda = c3)$fit
            u <- t(as.matrix(u))
            u <- u / norm(u, "F")
        } else {
            lizt <- list("mat2" = v, "mat3" = w)
            u <- ttl(tnsr, lizt, ms = c(2, 3))
            u <- t(as.matrix(u@data))
            u <- u / norm(u, "F")
        }

        # update v
        lizt <- list("mat2" = u, "mat3" = w)
        v <- ttl(tnsr, lizt, ms = c(1, 3))
        if (c2 != 0) {
            v <- genlasso(as.vector(v@data), D = Dv)
            v <- predict(v, lambda = c2)$fit
            v <- t(as.matrix(v))
            v <- v / norm(v, "F")
        } else {
            lizt <- list("mat2" = u, "mat3" = w)
            v <- ttl(tnsr, lizt, ms = c(1, 3))
            v <- t(as.matrix(v@data))
            v <- v / norm(v, "F")
        }

        diff <- mean(c(as.numeric(abs(cw_u - u)), as.numeric(abs(cw_v - v)), as.numeric(abs(cw_w - w))))
        cw_u <- u
        cw_v <- v
        cw_w <- w
        counter <- counter + 1
    }

    lizt <- list("mat1" = u, "mat2" = v, "mat3" = w)
    d <- ttl(tnsr, lizt, ms = c(1, 2, 3))

    return(list(u = u, v = v, w = w, d = as.numeric(d@data)))
}

## --------------------
## Adaptive Penalized Tensor Decomposition for single factor.
## --------------------
multiple_D_adaptive <- function(tnsr, num_components, d_hat = NULL, u_init, v_init, w_init, c1 = NULL, c2 = NULL, c3 = NULL, Niter = 15, tol = 1e-05, Du, Dv, Dw, trace = TRUE)
                                # tuning parameters for each dimension are the same
                                # inital values cant be null
                                # Dv and Dw should be a list of matrices
# to save computation time temp , only run 15 times
{
    ## specific tuning parameters
    if (!is.list(Du)) {
        Du <- list(Du)
    }
    if (!is.list(Dv)) {
        Dv <- list(Dv)
    }
    if (!is.list(Dw)) {
        Dw <- list(Dw)
    }
    if (length(Dv) != num_components & length(Dw) != num_components & length(Du) != num_components) {
        return(print("wrong penalty matrix"))
    }
    if (is.null(d_hat)) {
        for (j in 1:num_components) {
            d_hat[j] <- product(tnsr, c(1, 2, 3), u_init[j, ], v_init[j, ], w_init[j, ])
        }
    }
    Y <- as.tensor(array(0, dim(tnsr)))

    for (j in 1:num_components) {
        lizt <- list("mat" = as.matrix(u_init[j, ]), "mat2" = as.matrix(v_init[j, ]), "mat3" = as.matrix(w_init[j, ]))
        aux <- ttl(as.tensor(array(1, c(1, 1, 1))), lizt, ms = c(1, 2, 3))

        Y <- Y + d_hat[j] * aux
    } ##  closing for j

    ################## 333
    cw_u <- u_init
    cw_v <- v_init
    cw_w <- w_init
    counter <- 0
    diff <- 10

    ######

    while (diff > tol & counter < Niter) {
        for (j in 1:num_components)
        {
            lizt <- list("mat" = as.matrix(u_init[j, ]), "mat2" = as.matrix(v_init[j, ]), "mat3" = as.matrix(w_init[j, ]))
            aux <- ttl(as.tensor(array(1, c(1, 1, 1))), lizt, ms = c(1, 2, 3))

            Y <- Y - d_hat[j] * aux
            ##############################################

            Z <- tnsr - Y

            # if(iter==1)
            #
            temp <- PTD_D(Z, c1[j], c2[j], c3[j],
                Niter = Niter, tol = tol, Du = Du[[j]], Dv = Dv[[j]], Dw = Dw[[j]],
                u_init = u_init[j, , drop = FALSE], v_init = v_init[j, , drop = FALSE], w = w_init[j, , drop = FALSE]
            )

            ##############################################
            u_init[j, ] <- as.vector(temp$u)
            v_init[j, ] <- as.vector(temp$v)
            w_init[j, ] <- as.vector(temp$w)
            d_hat[j] <- temp$d

            lizt <- list("mat" = as.matrix(u_init[j, ]), "mat2" = as.matrix(v_init[j, ]), "mat3" = as.matrix(w_init[j, ]))
            aux <- ttl(as.tensor(array(1, c(1, 1, 1))), lizt, ms = c(1, 2, 3))

            Y <- Y + d_hat[j] * aux
        }

        diff <- mean(c(as.numeric(abs(u_init - cw_u)), as.numeric(abs(v_init - cw_v)), as.numeric(abs(w_init - cw_w))))
        if (trace) {
              message("Iteration: ", counter, "\t Difference: ", round(diff, 5))
          }

        cw_u <- u_init
        cw_v <- v_init
        cw_w <- w_init
        counter <- counter + 1
    }

    out <- list(u = u_init, v = v_init, w = w_init, d = d_hat)
    return(out)
}

## --------------------
## Prediction based on ATPD result.
## Forecasting method is GAM.
## --------------------
gam_predict <- function(result, year, bs = "tp") {
    u <- result$u
    v <- result$v
    w <- result$w
    d <- result$d
    w_pred <- matrix(NA, nrow = nrow(u), ncol = year)
    num_components <- length(d)
    for (k0 in 1:num_components) {
        model1 <- mgcv::gam(y ~ s(x, bs = bs), data = data.frame(y = w[k0, ], x = seq(1, length(w[1, ]))))
        w_pred[k0, ] <- predict(model1, newdata = data.frame(x = seq((length(w[k0, ]) + 1), (length(w[k0, ]) + year))))
    }

    aux <- 0
    for (k0 in 1:num_components) {
        lizt <- list("mat1" = t(t(u[k0, ])), "mat2" = t(t(v[k0, ])), "mat3" = t(t(w_pred[k0, ])))
        # ggg<-as.array(g[k0])
        # dim(ggg)<-c(1,1,1)
        aux1 <- ttl(as.tensor(array(1, c(1, 1, 1))), lizt, ms = c(1, 2, 3))
        aux <- aux + d[k0] * aux1
    }
    return(aux)
}

## --------------------
## Prediction based on ATPD result.
## Forecasting method is ARIMA.
## --------------------
arima_predict <- function(result, year) {
    u <- result$u
    v <- result$v
    w <- result$w
    d <- result$d
    w_pred <- matrix(NA, nrow = nrow(u), ncol = year)
    num_components <- length(d)

    for (k0 in 1:num_components) {
        w_pred1 <- rwf(as.matrix(w)[k0, ], h = year, drift = TRUE)
        w_pred[k0, ] <- as.data.frame(w_pred1)[, 1]
    }

    aux <- 0
    for (k0 in 1:num_components) {
        lizt <- list("mat1" = t(t(u[k0, ])), "mat2" = t(t(v[k0, ])), "mat3" = t(t(w_pred[k0, ])))
        # ggg<-as.array(g[k0])
        # dim(ggg)<-c(1,1,1)
        aux1 <- ttl(as.tensor(array(1, c(1, 1, 1))), lizt, ms = c(1, 2, 3))
        aux <- aux + d[k0] * aux1
    }

    return(aux)
}

## --------------------
## Prediction based on ATPD result.
## Forecasting method is Linear Extrapolation.
## --------------------
linextrap_predict <- function(result, year) {
    u <- result$u
    v <- result$v
    w <- result$w
    d <- result$d
    w_pred <- matrix(NA, nrow = nrow(u), ncol = year)
    num_components <- length(d)

    for (k0 in 1:num_components) {
        w_pred[k0, ] <- approxExtrap(x = seq(1, length(w[1, ])), y = w[k0, ], xout = seq(length(w[k0, ]) + 1, by = 1, length = year))$y
    }

    aux <- 0
    for (k0 in 1:num_components) {
        lizt <- list("mat1" = t(t(u[k0, ])), "mat2" = t(t(v[k0, ])), "mat3" = t(t(w_pred[k0, ])))
        # ggg<-as.array(g[k0])
        # dim(ggg)<-c(1,1,1)
        aux1 <- ttl(as.tensor(array(1, c(1, 1, 1))), lizt, ms = c(1, 2, 3))
        aux <- aux + d[k0] * aux1
    }

    return(aux)
}


#!/usr/bin/Rscript

library(lme4)
library(coefplot2)
library(glmmADMB)
library(Hmisc)
library(ggplot2)

load('flows-checkpoint3.RData')

## Refit with glmmadmb due to warnings about gradients above tolerance with lme4 fits

modNames <- c('glmeundirhmax', 'glmedirhmax', 'glmehmax')
fFin <- f[modNames]

tmpf <- function(x) {
    test <- !is.na(om$cases1WksAgo)
    data <- om[test, ]
    glmmadmb(x, data=data, family='nbinom')
}
mFin <- lapply(fFin, tmpf)
save.image('flows-checkpoint4.RData')

## Plot of predicted cases vs flow

scales <- c(week=iqr(om$weekCent),
            internal=iqr(log(om$internalFlow)),
            cmedDense=iqr(log(om$cmedDense*om$nFarms*om$nFarms)),
            undirected=iqr(log(om$undirectedFlow)),
            directeted=iqr(log(om$directedFlow)))
sink(file='scales.txt')
print(scales)
sink()

centers <- c(week=mean(om$weekCent),
            internal=mean(log(om$internalFlow)),
            cmedDense=mean(log(om$cmedDense*om$nFarms*om$nFarms)),
            undirected=mean(log(om$undirectedFlow)),
            directeted=mean(log(om$directedFlow)))

fund <- fortify(m$glmeundirhmax, data=model.frame(m$glmeundirhmax))
stopifnot(all.equal(attributes(fund$logUndirectedFlowScaled)[["scaled:center"]], centers[['undirected']]))
stopifnot(all.equal(attributes(fund$logUndirectedFlowScaled)[["scaled:scale"]][["75%"]], scales[['undirected.75%']]))

theme_set(new=theme_classic())
fund$log10UndirectedFlow <- log10(exp(scales['undirected.75%'] * as.numeric(fund$logUndirectedFlowScaled) + centers['undirected']))
fund$predCases <- exp(fund$.fitted)
fund$smoothpred <- predict(loess(predCases~log10UndirectedFlow, data=fund, span=.5))
fund$casesJittered <- runif(fund$cases, min=-1, max=1)*0.2 + fund$cases

g <- ggplot(data=fund, aes(x=log10UndirectedFlow, y=casesJittered))
g <- g + geom_point(col="#4477AA", alpha=.5)
g <- g + geom_line(aes(y=smoothpred), col='red')
g <- g + labs(x='Log10(#swine / y)', y='Positive accessions')
g <- g + coord_trans(y="log1p")
g <- g + theme(text = element_text(size=10))
g <- g + theme(line = element_line(size=0.25))

ggsave('flows-prediction.eps', width=4, height=4, pointsize=12, device=cairo_ps)
ggsave('flows-prediction.pdf', width=4, height=4, pointsize=12, device=cairo_pdf)

## Plots of fixed effects

ct <- lapply(mFin, function(x) coeftab(x)[, 1:2])

extractEsts <- function(pattern, type) {
  tmpf <- function(x) grep(pattern, rownames(x))
  inds <- lapply(ct, tmpf)
  res <- list()
  mapply(function(x, y) x[y, type], ct, inds)
}

patterns <- list(flow='Flow', dense='logCmedDenseScaled', week='weekCent', inf='Inf')
ests <- sapply(patterns, extractEsts, type='Estimate')
sds <- sapply(patterns, extractEsts, type='Std. Error')
weekIqr <- iqr(model.frame(m$glmedirhmax)$weekCent)
ests[, 'week'] <- ests[, 'week']*weekIqr
sds[, 'week'] <- sds[, 'week']*weekIqr

stopifnot(rownames(ests) == c('glmeundirhmax', 'glmedirhmax', 'glmehmax'))
ests <- cbind(ests, baseline=c(hund$maximum, hdir$maximum, hint$maximum))
sds <- cbind(sds, baseline=0)

tmpf <- function() {
    longnames <- c(flow='Scaled log(flow)', inf='Log(positive accessions)',
                   week='Centered week', dense='Scaled log(farm density)', baseline='Baseline risk')
    pal <- c("blue"="#4477AA", "red"="#DDCC77", "yellow"="#CC6677")
    pch <- 15:17
    for(i in seq_len(nrow(ests))){
        coefplot2(ests[i, ], sds[i, ], varnames=longnames[colnames(ests)],
                  offset=(i-1)/10, col=pal[i], add=i>1, pch=pch[i],
                  main="Regression estimates", cex.main=1, font.main=1)
    }
    legend('topright', legend=c('undirected', 'directed', 'none'), col=pal, pch=pch, title='Interstate flow')
}

pdf('coefplot.pdf', width=5,height=4)
tmpf()
dev.off()
## This works better than making the ps with R for some reason
system('pdftops coefplot.pdf')

res <- 100
png('coefplot.png', width=5*res, height=4*res, res=res)
tmpf()
dev.off()

## Table of likelihoods, dispersion, parameters, random effects

getNBTheta <- function(x) {
    if(inherits(x, 'glmmadmb')) {
        summary(x)$alpha
    } else {
        as.numeric(strsplit(family(x)$family, split='\\(|\\)')[[1]][2])
    }
}
getLL <- function(x) as.numeric(logLik(x))
getSD <- function(x) as.numeric(sqrt(VarCorr(x)$stateF))
getdf <- function(x) attr(logLik(x), 'df')
getintercept <- function(x) fixef(x)['(Intercept)']

modList <- c(mFin, m[c('nbme', 'nbmeN')])
disp <- sapply(modList, getNBTheta)
llik <- sapply(modList, getLL)
resd <- sapply(modList, getSD)
df <- sapply(modList, getdf)
int <- sapply(modList, getintercept)

tmpf <- function() {
  tab <- data.frame(baseline=I('no'), int=unname(int), disp, resd, df, llik)
  rownames(tab) <- names(modList)
  tab[c('glmeundirhmax', 'glmedirhmax', 'glmehmax'), 'baseline'] <- 'yes'
  tab[, 'df'] <- tab[, 'df'] + ifelse(tab[, 'baseline'] == 'yes', 1, 0)
  aic <- 2*-tab[, 'llik'] + 2*tab[, 'df']
  tab <- cbind(tab, deltaAIC = aic - min(aic))
  flowTerm <- c(glmeundirhmax='undirected', glmedirhmax='directed', glmehmax='internal',
                nbme='internal', nbmeN='none')
  tab <- data.frame(flowTerm=flowTerm[rownames(tab)], tab)
  tf <- format.df(tab)
  align <- paste(attr(tf, "col.just"), collapse="|")
  align <- paste('|', align, '|', sep='')
  longnames <- c(flowTerm='Flow term', baseline='Fit $\\eta$?',
                 disp='$\\hat{\\theta}$', df='d.f.', llik='Log lik.',
                 deltaAIC='$\\Delta$ AIC', resd='$\\hat{\\sigma}$',
                 int='Intercept')
  colnames(tab) <- longnames[colnames(tf)]
  tab <- latexTabular(tab, helvetica=FALSE, align=align, translate=FALSE,
                   cdec=c(0,0,1,2,2,0,1,1))
  tab <- gsub('\\\\multicolumn\\{1\\}\\{c\\}', '', tab)
  tab <- gsub('(\\\\)\\s?(\n)', '\\1\\\\hline\\2', tab)
  tab <- gsub('(\\n)(\\{Flow term\\})', '\\1\\\\hline\\2', tab)
  cat(tab, file='tab.tex')
  list(aic=aic, tab=tab)
}
tables <- tmpf()

## Dotplot of AICs

tmpf <- function() {
    tab <- tables$tab
    aic <- tables$aic
    flowTerm <- c(glmeundirhmax='Within-state + undirected between state',
                  glmedirhmax='Within-state + directed between state',
                  glmehmax='Within-state only',
                  nbme='Within-state only, fixed other risks ',
                  nbmeN='No flow, fixed other risks')
    labels <- flowTerm[rownames(tab)]
    dotchart2(tables$aic, labels=labels, xlab='AIC (i.e., Estimated information loss)', dotsize=2)
}
png('aic.png', width=7*res, height=4*res, res=res)
tmpf()
dev.off()

save.image('flows-checkpoint5.RData')


x <- c(0.2, 1.2, 0.9, 2.2, 6.2, 3.6, 5.3, 6.2, 7.1, 8.6, 9.0)
y <- c(1.1, 2.3, 1.1, 3.6, 0.1, 4.8, 6.5, 7.8, 9.0, 9.4, 9.8)
df <- data.frame(x, y)


library(pbdPAPI)

x <- runif(1e6)

### Sorting is not a floating point operation.
system.flops(sort(x))

system.flops(x+1)

### It does require lots of memory access, though.
system.cache(sort(x))

system.utilization(sort(x))


# ==============================
# Preparation of simulations results (Strata level)
# Nuno Prista, SLU Aqua, 2019 @ KustMonitoring project
# ==============================

rm(list=ls())

library(data.table)

# source functions
source("000_Funs/func_do_summary_stratified_mean_time_series.r")

# select scenario
	scenario <- "AllocOrigin" # "AllocScenarioHerringN", "AllocOrigin"

# produces datasets
	for (site in c("Asköfjärden", "Galtfjärden","Gaviksfjärden","Holmön","Kinnbäcksfjärden","Kvädöfjärden_Warm","Lagnö","Långvindsfjärden","Norrbyn", "Råneå","Torhamn")
	{

		# use during testing
		# site<-"Asköfjärden"

	print(site)

	dir_sim_outputs <- paste("002_Sim_Outputs/",scenario,"/",sep="")

		# loads original data
			dir_inputs<-"001_Inputs/prepared_main/"
			load(file=paste("001_Inputs/prepared_main/",site,".Rdata",sep=""))

		# loads simulations
			sim_strata<-readRDS(file=paste(dir_sim_outputs, site, "_", scenario,"_5000sims_res_strata.rds", sep=""))
			load(file=paste(dir_sim_outputs,site, "_", scenario,"_5000sims_settings.Rdata", sep=""))
				# deletes unnecessary columns
					sim_strata <- sim_strata[,!c(".id")]
				# creates useful IDs
					sim_strata[, ID:=paste(Year, variable, stratum),]
				# sets key
					setkey(sim_strata, ID)

		# =============
		# Present ("true") estimates: point estimates
		# =============

		# runs stratified mean on site data set
			res_strata<-c()
			for (i in target_vars)
			{
			res_strata<-rbind(res_strata, do_summary_stratified_mean_time_series(x = dt_site, target_var = i, strata_var = "DepthStratum", strata_size_var = "NStations", period_var = "Year", klab = TRUE)$stratum_res)
			}
				# fixes columns
				colnames(res_strata)[colnames(res_strata)=="period"]<-"Year"
				# creates IDs
				res_strata$ID<-paste(res_strata$Year, res_strata$variable, res_strata$stratum); sum(duplicated(res_strata$ID))==0
				# sets to data.table
				res_strata<-data.table(res_strata)
				setkey(res_strata, ID)

			# a look into the final structure of the objects
				res_strata[,.N, c("ID")]

		# =============
		# Present ("true") estimates: Bootstrap CIs
		# =============

		# Calculates bootstrap CIs from replicates
				#bootlow_perc, boothigh_perc = percentile bootstrap centered on true mean

			nlevls<-nlevels(sim_strata$SampSize)

		# if nlevls>1 splits series (for memory saving)
			if(nlevls>1){
			sim_strata1<-sim_strata[SampSize %in% levels(SampSize)[1:(nlevls%/%2)],]
			sim_strata2<-sim_strata[SampSize %in% levels(SampSize)[(nlevls%/%2+1):nlevls],]

			# cleans up
			rm(sim_strata); gc()

			sim_strata1[, `:=`(true_n = res_strata[sim_strata1]$n, true_mean = res_strata[sim_strata1]$mean_x, true_var_x = res_strata[sim_strata1]$var_x, true_var_mean = res_strata[sim_strata1]$var_mean_x, true_clow_mean = res_strata[sim_strata1]$clow_mean, true_chigh_mean = res_strata[sim_strata1]$chigh_mean, true_rse_mean = res_strata[sim_strata1]$rse_mean_x),]

			ls1<-split(sim_strata1, paste(sim_strata1$Year, sim_strata1$SampSize, sim_strata1$variable, sim_strata1$stratum))
			ls2<-lapply(ls1, function(x){
			  a<-quantile(x$mean, c(0.025, 0.975), na.rm=T);
			  b<-quantile(x$mean-mean(x$mean, na.rm=T), c(0.025, 0.975), na.rm=T);
			  ci <- x$true_mean[1]+b;
			  data.frame(Area= x$Area[1], Season= x$Season[1], Year = x$Year[1], variable=x$variable[1], stratum = x$stratum[1], stratum_size = x$stratum_size[1], SampSize = x$SampSize[1],
						 true_n = x$true_n[1], true_mean = x$true_mean[1], true_var_x =x$true_var_x[1], true_var_mean =x$true_var_mean[1], true_rse_mean = x$true_rse_mean[1], true_clow_mean = x$true_clow_mean[1], true_chigh_mean = x$true_chigh_mean[1],
						 boot_mean_n = mean(x$n, na.rm=T), boot_mean = mean(x$mean_x, na.rm=T), boot_var_x = mean(x$var_x, na.rm=T), boot_var_mean=var(x$mean_x, na.rm=T), boot_se=sqrt(var(x$mean_x, na.rm=T)), boot_rse = round(sqrt(var(x$mean_x, na.rm=T))/x$true_mean[1]*100,1),
						 bootlow = a[1], boothigh = a[2],
						 bootlow_perc = ci[1], boothigh_perc = ci[2],
						 bootNA=sum(is.na(x$mean_x))) })
			boot_res_strata1 <- rbindlist(ls2)
			gc(); rm(ls1, ls2, sim_strata1); gc()

			sim_strata2[, `:=`(true_n = res_strata[sim_strata2]$n, true_mean = res_strata[sim_strata2]$mean_x, true_var_mean = res_strata[sim_strata2]$var_mean_x,true_var_x = res_strata[sim_strata2]$var_x, true_clow_mean = res_strata[sim_strata2]$clow_mean, true_chigh_mean = res_strata[sim_strata2]$chigh_mean, true_rse_mean = res_strata[sim_strata2]$rse_mean_x),]

			ls1<-split(sim_strata2, paste(sim_strata2$Year, sim_strata2$SampSize, sim_strata2$variable, sim_strata2$stratum))
			ls2<-lapply(ls1, function(x){
			  a<-quantile(x$mean, c(0.025, 0.975), na.rm=T);
			  b<-quantile(x$mean-mean(x$mean, na.rm=T), c(0.025, 0.975), na.rm=T);
			  ci <- x$true_mean[1]+b;
			  data.frame(Area= x$Area[1], Season= x$Season[1], Year = x$Year[1], variable=x$variable[1], stratum = x$stratum[1], stratum_size = x$stratum_size[1], SampSize = x$SampSize[1],
						 true_n = x$true_n[1], true_mean = x$true_mean[1], true_var_mean =x$true_var_mean[1], true_var_x =x$true_var_x[1], true_rse_mean = x$true_rse_mean[1], true_clow_mean = x$true_clow_mean[1], true_chigh_mean = x$true_chigh_mean[1],
						 boot_mean_n = mean(x$n, na.rm=T), boot_mean = mean(x$mean_x, na.rm=T), boot_var_x = mean(x$var_x, na.rm=T), boot_var_mean=var(x$mean_x, na.rm=T), boot_se=sqrt(var(x$mean_x, na.rm=T)), boot_rse = round(sqrt(var(x$mean_x, na.rm=T))/x$true_mean[1]*100,1),
						 bootlow = a[1], boothigh = a[2],
						 bootlow_perc = ci[1], boothigh_perc = ci[2],
						 bootNA=sum(is.na(x$mean_x))) })
			boot_res_strata2 <- rbindlist(ls2)
			boot_res_strata<-rbind(boot_res_strata1, boot_res_strata2)

			rm(ls1, ls2, sim_strata2, boot_res_strata1, boot_res_strata2); gc()

			} else { # if nlevls==1 uses simpler procedure

			  sim_strata[, `:=`(true_n = res_strata[sim_strata]$n, true_mean = res_strata[sim_strata]$mean_x, true_var_x = res_strata[sim_strata]$var_x, true_var_mean = res_strata[sim_strata]$var_mean_x, true_clow_mean = res_strata[sim_strata]$clow_mean, true_chigh_mean = res_strata[sim_strata]$chigh_mean, true_rse_mean = res_strata[sim_strata]$rse_mean_x),]

			  ls1<-split(sim_strata, paste(sim_strata$Year, sim_strata$SampSize, sim_strata$variable, sim_strata$stratum))
			  ls2<-lapply(ls1, function(x){
				a<-quantile(x$mean, c(0.025, 0.975), na.rm=T);
				b<-quantile(x$mean-mean(x$mean, na.rm=T), c(0.025, 0.975), na.rm=T);
				ci <- x$true_mean[1]+b;
				data.frame(Area= x$Area[1], Season= x$Season[1], Year = x$Year[1], variable=x$variable[1], stratum = x$stratum[1], stratum_size = x$stratum_size[1], SampSize = x$SampSize[1],
						   true_n = x$true_n[1], true_mean = x$true_mean[1], true_var_x =x$true_var_x[1], true_var_mean =x$true_var_mean[1], true_rse_mean = x$true_rse_mean[1], true_clow_mean = x$true_clow_mean[1], true_chigh_mean = x$true_chigh_mean[1],
						   boot_mean_n = mean(x$n, na.rm=T), boot_mean = mean(x$mean_x, na.rm=T), boot_var_x = mean(x$var_x, na.rm=T), boot_var_mean=var(x$mean_x, na.rm=T), boot_se=sqrt(var(x$mean_x, na.rm=T)), boot_rse = round(sqrt(var(x$mean_x, na.rm=T))/x$true_mean[1]*100,1),
						   bootlow = a[1], boothigh = a[2],
						   bootlow_perc = ci[1], boothigh_perc = ci[2],
						   bootNA=sum(is.na(x$mean_x))) })
			  boot_res_strata <- rbindlist(ls2)
			  rm(ls1, ls2, sim_strata); gc()
			}

			boot_res_strata$SampSize<-factor(as.character(boot_res_strata$SampSize), levels=sort(unique(boot_res_strata$SampSize))); unique(boot_res_strata$SampSiz)

			boot_res_strata<-boot_res_strata[order(SampSize, Year, variable, stratum),]

			# adds bootstrap ci with normal approx (See article)
			boot_res_strata$bootlow_aprox<-boot_res_strata$true_mean-1.96*sqrt(boot_res_strata$boot_var_mean)
			boot_res_strata$boothigh_aprox<-boot_res_strata$true_mean+1.96*sqrt(boot_res_strata$boot_var_mean)

			# adds boot_mean_bias and boot_mean_bias_perc
			boot_res_strata$boot_mean_bias<-boot_res_strata$boot_mean-boot_res_strata$true_mean
			boot_res_strata$boot_mean_bias_perc<-round(boot_res_strata$boot_mean_bias/boot_res_strata$true_mean*100,1)
			tapply(boot_res_strata$boot_mean_bias_perc, boot_res_strata$SampSize, function(x) {quantile(x, na.rm=TRUE)})

			# adds boot_var_bias and boot_var_bias_perc
			boot_res_strata$boot_var_bias<-boot_res_strata$boot_var_x-boot_res_strata$true_var_x
			boot_res_strata$boot_var_bias_perc<-round(boot_res_strata$boot_var_bias/boot_res_strata$true_var_x*100,1)
			tapply(boot_res_strata$boot_var_bias_perc, boot_res_strata$SampSize, function(x) {quantile(x, na.rm=TRUE)})

			# adds boot_var_mean_bias and boot_var_mean_bias_perc
			boot_res_strata$boot_var_mean_bias<-boot_res_strata$boot_var_mean-boot_res_strata$true_var_mean
			boot_res_strata$boot_var_mean_bias_perc<-round(boot_res_strata$boot_var_mean_bias/boot_res_strata$true_var_mean*100,1)
			tapply(boot_res_strata$boot_var_mean_bias_perc, boot_res_strata$SampSize, function(x) {mean(x, na.rm=TRUE)})
			tapply(boot_res_strata$boot_var_mean_bias_perc, boot_res_strata$SampSize, function(x) {quantile(x, na.rm=TRUE)})
			tapply(boot_res_strata$boot_var_mean_bias_perc, paste(boot_res_strata$SampSize, boot_res_strata$variable), function(x) {quantile(x, na.rm=TRUE)})

			# a look into the final structure of the objects
			table(boot_res_strata$Year, boot_res_strata$SampSize, boot_res_strata$variable)
			#table(sim_samples[repl==1,]$Year, sim_samples[repl==1,]$SampSize)
			tapply(boot_res_strata$true_mean,list(boot_res_strata$Year, boot_res_strata$SampSize, boot_res_strata$variable), mean)

		# =============
		# Save prepared objects
		# =============
			dir_sim_outputs<-paste(dir_sim_outputs,"prepared/",sep=""); dir.create(dir_sim_outputs, showWarnings = FALSE)
			filename<-paste(site,"_",scenario,"_",nsim,"sims_res_strata_prep.rdata",sep="");
			save(boot_res_strata, res_strata, target_vars, nsim, cpus, scenario, site, sampOpt, file = paste(dir_sim_outputs,filename,sep=""))
			print(paste(dir_sim_outputs,filename,sep=""))
			gc()
	}


## This file documents the package.

#' @title
#' Bootstrap network indices
#'
#' @description
#' R package for resampling network metrics/indices (bootstrapping without
#' replacement). It wraps around the [bipartite][bip] package functions
#' \code{\link[bipartite]{networklevel}} and
#' \code{\link[bipartite]{specieslevel}}.
#'
#' Assuming a network/web like `Safariland` from the `bipartite` package, one
#' can sample interactions without replacement from the network until all
#' interactions have been used. The sampling procedure starts with a small
#' sample size to which interactions are added until all are consumed. Every
#' time we sample interactions, a smaller version of the entire network can be
#' built and a network index/metric can be computed. The sampling procedure can
#' be repeated as many times as needed, giving the possibility to compute mean
#' values with quantile-based confidence intervals. The mean values across
#' sample sizes can be plotted and indices of different networks can be visually
#' compared. See examples at
#' [README](https://github.com/valentinitnelav/plotbiomes/blob/develop/README.md)
#'
#' [bip]: https://cran.r-project.org/web/packages/bipartite/index.html
#'
#' @section Help:
#' Examples at: [README](https://github.com/valentinitnelav/plotbiomes/blob/develop/README.md)
#'
#' GitHub page [here](https://github.com/valentinitnelav/bootstrapnet)
#'
#' @author
#' Valentin Stefan, Tiffany Knight
#'
#' @md
#'
#' @docType package
#'
#' @name plotbiomes
NULL


p = bio.snowcrab::load.environment()

a = logbook.db('logbook.filtered.positions')

ii = which(a$cfa =='cfa4x')
a = a[ii,]
a$datf = strptime(a$date.fished,format='%Y-%m-%d')
ij = which(is.na(a$datf))
a$datf[ij] = strptime(a$date.fished[ij],format='%Y%m%d')
b= aggregate(date.fished~yr,data = a, FUN=min)
b$datf = strptime(b$date.fished,format='%Y-%m-%d')

out = data.frame(yr=NA,nblocks=NA,nsamples=NA,meancpue=NA,sdcpue=NA)
for(i in 1:nrow(b)) {
                r = a[which(a$yr == b[i,'yr']),]
                r = r[which(r$datf>= b$[i,'datf'] & r$datf <= 60*60*24*12),] #12 days
                out[i,'yr'] = b[i,'yr']
                out[i,'nblocks'] = nrow(unique(cbind(r[which(!is.na(r$landings)),c('lat','lon')])))
                out[i,'nsamples'] = nrow(r[which(!is.na(r)),])
                out[i,'meancpue'] = mean(r$cpue,na.rm=T)
                out[i,'sdcpue'] = sd(r$cpue,na.rm=T)
}

#plot the cpue
ylim=c(min(out$meancpue-out$sdcpue),max(out$meancpue+out$sdcpue))
with(out,plot(yr,meancpue,type='b',ylim=ylim,xlab='Year',ylab='CPUE'))
with(out,arrows(x0=yr,y0=meancpue,y1=meancpue+sdcpue,length=0.05,angle=90))
with(out,arrows(x0=yr,y0=meancpue,y1=meancpue-sdcpue,length=0.05,angle=90))

#plot the area of the fishery

with(out,plot(yr,nblocks,xlab='Year',ylab='Number of grid cells fished',type='b'))


options(echo=TRUE) # if you want see commands in output file
args <- commandArgs(trailingOnly = TRUE)
kmax <- as.integer(args[[3]])
# print(args)
# print(args[[1]])

# q()

#library("missMDA")
d <- read.table(args[[1]], sep="\t", header=TRUE, na.strings="NA", colClass=c('factor'))

require(NPBayesImpute)
model <- CreateModel(d, NULL, kmax, 0, 0.25, 0.25)

# burn-in
model$Run(10000,0,0)

for (y in 0:99) {
        model$Run(0, 100, 1)
        result <- model$snapshot
        imputed <- GetDataFrame(result$ImputedX,d)
        write.table(imputed, file=paste(args[[2]], ".", y, sep=""), sep="\t", quote=FALSE)
}
# res.impute <- imputeMCA(d, threshold=0.015, maxiter=9000)
# write.table(res.impute$completeObs, file=args[[2]], sep="\t", quote=FALSE)


#  James Rekow

abdListCreator_optimizedBaseCase = function(intIx = NULL, M = 40, N = 20, iStrength = 1, univ = 1, sigmaMax = 0.1,
                                            thresholdMult = 10 ^ (-1), maxSteps = 10 ^ 4, tStep = 10 ^ (-2),
                                            intTime = 1, interSmplMult = 0.01, lambda = 0){

  #  ARGS: intTime - total time for intra cohort interactions to be modeled
  #        lambda - rate parameter for the exponentially distributed wait times between interactions
  #        intIx - indices of interacting samples
  #
  #  RETURNS: abdList - a list of length M containing the integrated and interacted (if pairProb > 0)
  #                     numerical abundance vectors of length N from a single cohort
  #
  #  NOTE: base non-zero lambda is 0.1 for the time being. Expected value of waiting time is 1 / rate

  source("cohortCreator.r")
  source("eulerIntegrate.r")
  source("intraCohortInteraction_optimizedBaseCase.r")

  #  if intIx is not specified, randomly select half of the samples to interact
  if(is.null(intIx)){

    numI = floor(M / 2)
    intIx = sample(1:M, numI)

  } #  end if

  #  used to determine if the system is near equilibrium
  threshold = {thresholdMult * tStep} ^ 2

  #  define integrator function to apply eulerIntegrate with desired parameter vals
  integrator = function(smpl){
    return(eulerIntegrate(smpl, threshold = threshold, maxSteps = maxSteps, tStep = tStep))
  } #  end integrator function

  #  create cohort
  chrt = cohortCreator(M = M, N = N, iStrength = iStrength, univ = univ, sigmaMax = sigmaMax)

  #  integrate samples in the cohort and store the abundance vectors in a list
  abdList = lapply(chrt, integrator)

  #  simulate intra-cohort interaction if lambda > 0
  if(lambda > 0){

    #  update the abundances of each sample in the cohort
    for(i in 1:M){
      chrt[[i]][[1]] = abdList[[i]]
    } #  end for

    #  simulate intra-cohort interactions
    abdList = intraCohortInteraction_optimizedBaseCase(intIx = intIx, chrt = chrt, M = M, N = N,
                                                       lambda = lambda, threshold = threshold,
                                                       maxSteps = maxSteps, tStep = tStep,
                                                       intTime = intTime, interSmplMult= interSmplMult)

  } #  end if

  return(abdList)

  } #  end abdListCreator_optimizedBaseCase function


#Create rasters of precipitation seasonality
#From CA, NV climate data from http://albers.cnr.berkeley.edu
#For Patrick Baldwin IGS

rm(list = ls())
library(raster)
library(tidyverse)
library(ncdf4)

url <- "http://albers.cnr.berkeley.edu/data/noaa/livneh/CA_NV/"
dir <- "C:/Users/k1076631/Google Drive/Teaching/2018-19/Undergrad/IGS/Patrick/CA-NV_ClimSum/"
fp <- "livneh_CA_NV_15Oct2014."

#function to download nc file and create on HD
download_nc <- function(url, dir, fileprefix, year, month)
{
  link <- paste0(url,fileprefix,create_yrmon(year,month),".nc")
  dest <- paste0(dir,"Data/CANV",create_yrmon(year,month),".nc")
  download.file(url=link,destfile=dest,mode="wb")
}

#function to create year month text string for files
#assumed Nov and Dec from previous year are part of THIS year
create_yrmon <- function(year,mon)
{
  ifelse(mon > 10,
    return(paste0(year-1,mon)),  #if Nov, Dec, use previous year
    return(paste0(year,sprintf("%02d",mon))) #else use this year
  )
}

#function to extract @prec' layer from nc file and output as raster
nc_raster <- function(filename)
{
  nc1 <- nc_open(filename)

  pre_array <- ncvar_get(nc1,"Prec")
  lon <- ncvar_get(nc1,"lon")
  lat <- ncvar_get(nc1,"lat")

  M <- length(lon)
  N <- length(lat)
  dx <- diff(lon[1:2])
  dy <- diff(lat[1:2])

  r <- raster(t(pre_array[,,1][,N:1]), xmn=lon[1]-dx/2, xmx=lon[M]+dx/2, ymn=lat[1]-dy/2, ymx=lat[N]+dy/2, crs=CRS("+init=epsg:4326"))

  return(r)
}

#loop to work through mutiple years
years <- seq(1971,2010,1)

for(year in years)
{
  #download data for this year
  for(i in seq(1,12,1))
  {
    download_nc(url, dir, fp, year, i)
  }

  #create winter brick (six months)
  winter <- stack()
  win <- c(11, 12, seq(1,4,1))
  for(j in win)
  {
   r <- nc_raster(paste0(dir,"Data/CANV", create_yrmon(year, j),".nc"))
   winter <- stack(winter,r)
  }
  names(winter) <- c("Nov","Dec","Jan","Feb","Mar","Apr")

  #create summer brick (six months)
  summer <- stack()
  summ <- c(seq(5,10,1))
  for(j in summ)
  {
   r <- nc_raster(paste0(dir,"Data/CANV", create_yrmon(year, j),".nc"))
   summer <- stack(summer,r)
  }
  names(summer) <- c("May","Jun","Jul","Aug","Sep","Oct")

  #sum values (to get total pptn) in thebricks
  wintersum <- stackApply(winter,indices=rep.int(1,6),fun=sum,na.rm=FALSE)
  summersum <- stackApply(summer,indices=rep.int(1,6),fun=sum,na.rm=FALSE)

  #calc sasonality (total winter pptn minus total summer pptn)
  seasonality <- wintersum - summersum

  #write files to disk
  writeRaster(seasonality, paste0(dir,"pptnSeasonality_",year,".asc"),format="ascii",overwrite=TRUE)
  writeRaster(wintersum, paste0(dir,"pptnWinter_Sum_",year,".asc"),format="ascii",overwrite=TRUE)
  writeRaster(summersum, paste0(dir,"pptnSummer_Sum_",year,".asc"),format="ascii",overwrite=TRUE)

  print(paste0(year," complete."))
}


#' chol
#'
#' Cholesky factorization.
#'
#' @param x
#' An fmlmat matrix.
#' @param ...
#' Ignored.
#'
#' @name chol
#' @rdname chol
#' @export
chol.fmlmat = function(x, ...)
{
  ret = DATA(x)$dupe()
  linalg_chol(ret)
  wrapfml(linalg_xpose(ret))
}


op=function(x,y)
{
a = as.integer(readline(prompt="enter choice:"))
n=switch(a,x+y,x-y,x%%y,x*y,x/y)
print(n)
}
op(5,2)


options(bitmapType='cairo')
library(DNAcopy)
cn <- read.table(inputfile, header=T, stringsAsFactors = F)
CNA.object <-CNA( genomdat = cn$adjusted_log_ratio, chrom = cn$chrom, maploc = cn$chr_start, data.type = 'logratio')
CNA.smoothed <- smooth.CNA(CNA.object)
segs <- segment(CNA.smoothed, verbose=0, min.width=2)
segs2 = segs$output
write.table(segs2[,2:6], file=outputfile, row.names=F, col.names=F, quote=F, sep="\t")


cat(sapply(readLines(tail(commandArgs(), n=1)), function(s) {
  n <- nchar(s) / 2
  r <- 1
  for (i in 1:n) {
    if ((substr(s, i, i) == "A" && substr(s, i+n, i+n) == "B") || (substr(s, i, i) == "B" && substr(s, i+n, i+n) == "A")) {
      r <- 0
      break
    } else if (substr(s, i, i) == "*" && substr(s, i+n, i+n) == "*") {
      r <- r * 2
    }
  }
  r
}), sep="\n")


# LEXICAL CORRESPONDENCE ANALYSIS
library(FactoMineR)
library(Factoshiny)
library(factoextra)
library(plotly)
library(GPArotation)
library(MASS)
library(ca)

doc_sent_df <- sentiment
doc_sent_matrix <- as.matrix(doc_sent_df)
sent_doc_matrix <- t(doc_sent_matrix)
sent_doc_df <- as.data.frame(sent_doc_matrix)

df_ordinato15 <- df_ordinato[1:15, ]
rownames(df_ordinato15)
row.names(termdoc_matrix)

#WORDS (15) x SENTIMENTS (10)
termdoc_matrix_new <- termdoc_matrix[c(126, 66, 95, 19, 24, 119, 28, 192, 106, 86, 78, 43, 166, 17, 157), ]

term_sent <- termdoc_matrix_new %*%  doc_sent_matrix
sent_term <- t(term_sent)

sent_term_df <- as.data.frame(sent_term)

doc_term <- t(termdoc_matrix_new)
doc_term_df <- as.data.frame(doc_term)

term_sent
sommacol <- colSums(term_sent)
tabcontingenza <- rbind(term_sent, sommacol)
sommariga <- rowSums(tabcontingenza)
tabcontingenza <- cbind(tabcontingenza, sommariga)
tab_freq_rel <- tabcontingenza/70449
tab_freq_rel <- round(tab_freq_rel, 3)
tab_freqre_100 <- tab_freq_rel*100

#CORRESPONDENCE ANALYSIS ON term_sent WITH factomineR
res.ca_termsent <- CA(term_sent)
summary(res.ca_termsent)
round(res.ca_termsent$row$cos2[, c(1, 2)], digits = 3)
round(res.ca_termsent$col$cos2[, c(1, 2)], digits = 3)

plot(res.ca_termsent)
HCPCshiny(res.ca_termsent)

fviz_ca_biplot(res.ca_termsent,repel=TRUE) #grafico parole e sentimenti
fviz_ca_row(res.ca_termsent,repel=TRUE)#grafico delle parole
fviz_ca_col(res.ca_termsent,repel=TRUE)#grafico dei sentimenti

par(mfrow=c(1, 2))

fviz_contrib(res.ca_termsent,choice="col",axes=1)#contributo delle colonne alle due dimenisioni
fviz_contrib(res.ca_termsent,choice="col",axes=2)
fviz_contrib(res.ca_termsent,choice="col",axes=c(1:2))
fviz_contrib(res.ca_termsent,choice="row",axes=1)
fviz_contrib(res.ca_termsent,choice="row",axes=2)
fviz_contrib(res.ca_termsent,choice="row",axes=c(1:2)) #contributo delle righe alle due dimenisioni

fviz_ca_row(res.ca_termsent,axes=c(1,2),c("point","text"),shape.row=19,repel=TRUE) #alcuni aggiustamenti grafici

#CORRESPONDENCE ANALYSIS WITH "ca"
ca_termsent <- ca(term_sent)
summary(ca_termsent)
plot.ca(ca_termsent, mass=c(TRUE, TRUE))
plot.ca(ca_termsent, arrows = c(TRUE, TRUE))

coordriga <- res.ca_termsent$row$coord[, 1:2]
coordriga <- as.matrix(coordriga)

plot(density(coordriga[, 1]))
plot(density(coordriga[, 2]))

den3d <- kde2d(coordriga[, 1], coordriga[,2], n = c(100,100))
plot_ly(x=den3d$x, y=den3d$y, z=den3d$z) %>% add_surface()

dist_coordriga <- dist(coordriga, method = "manhattan")
hclust_coordriga <- hclust(dist_coordriga,method = "ward.D2")
plot(hclust_coordriga, xlab = "", hang = -1)

#MODEL BASED CLUSTERING ON 2 DIM
library(mclust)
provacluster <- Mclust(coordriga)
summary(provacluster)
plot(provacluster)
plot(provacluster, "classification")
text(coordriga, labels = row.names(coordriga), col = provacluster$classification)

kmeans_termini <- kmeans(coordriga, centers = 3, nstart=10, algorithm = "MacQueen")
summary(kmeans_termini)
plot(coordriga, col=kmeans_termini$cluster, pch=19)
text(coordriga, labels = rownames(coordriga), col = kmeans_termini$cluster)

library(ppclust)
fuzzy_termini <- fcm(coordriga, centers =2)
plot(coordriga, col=fuzzy_termini$cluster)
text(coordriga, labels = rownames(coordtermini_2), col = fuzzy_termini$cluster)

###CORRESPONDENCE ANALYSIS ON DOC_TERM
res.ca_docterm <- CA(doc_term)
summary(res.ca_docterm)
plot(res.ca_docterm)
HCPCshiny(res.ca_docterm)
fviz_ca_col(res.ca_docterm,repel=TRUE)

for (i in 1:nrow(doc_term_df)) {
  for(j in 1:ncol(doc_term_df)) {
    if(doc_term_df[i,j]==0){
      doc_term_df[i,j]="No"
    }else{doc_term_df[i,j]="Yes"
    }
  }
}

for (i in 1:nrow(doc_sent_df)) {
  for(j in 1:ncol(doc_sent_df)) {
    if(doc_sent_df[i,j]==0){
      doc_sent_df[i,j]="No"
    }else{doc_sent_df[i,j]="Yes"
    }
  }
}

#PLSCA ON SENT_TERM AND SENT_DOC

for (i in 1:nrow(sent_doc_df)) {
  for(j in 1:ncol(sent_doc_df)) {
    if(sent_doc_df[i,j]==0){
      sent_doc_df[i,j]="No"
    }else{sent_doc_df[i,j]="Yes"
    }
  }
}

PLSCA_2 <- tepPLSCA(sent_term_df, sent_doc_df, make_data1_nominal = F, make_data2_nominal = T)
coordtermini_2 <- PLSCA_2$TExPosition.Data$fi[, 1:2]

dist_coordtermini2 <- dist(coordtermini_2)
hclust_termini2 <- hclust(dist_coordtermini2, method = "ward.D2")
plot(hclust_termini2, xlab = "", hang = -1)

cluster_termini_2 <- Mclust(coordtermini_2)
summary(cluster_termini_2)
plot(cluster_termini_2, "classification")
text(coordtermini_2, labels = rownames(coordtermini_2), col = cluster_termini_2$classification)
plot(cluster_termini_2, "BIC")
plot(cluster_termini_2, "uncertainty")
plot(cluster_termini_2, "density")

kmeans_termini <- kmeans(coordtermini_2, centers = 2, nstart=10, algorithm = "MacQueen")
summary(kmeans_termini)
plot(coordtermini_2, col=kmeans_termini$cluster, pch=19)
text(coordtermini_2, labels = rownames(coordtermini_2), col = kmeans_termini$cluster)

library(ppclust)
fuzzy_termini <- fcm(coordtermini_2, centers =2)
plot(coordtermini_2, col=fuzzy_termini$cluster)
text(coordtermini_2, labels = rownames(coordtermini_2), col = fuzzy_termini$cluster)

plot(density(term_sent[3, ]))
plot(density(term_sent[, 5]))

#celebr & disgust
par(mfrow=c(2, 1))
par(mar=c(2, 2, 2, 2)+0.1)
plot(density(term_sent[, 3]))
plot(density(term_sent[4, ]))
term_sent[4, ]
term_sent[, 3]

# AC ENCODED THROUGH 0, 1

for (i in 1:nrow(doc_term)) {
  for(j in 1:ncol(doc_term)) {
    if(doc_term[i,j]==0){
      doc_term[i,j]==0
    }else{doc_term[i,j]==1
    }
  }
}

for (i in 1:nrow(doc_sent_matrix)) {
  for(j in 1:ncol(doc_sent_matrix)) {
    if(doc_sent_matrix[i,j]==0){
      doc_sent_matrix[i,j]==0
    }else{doc_sent_matrix[i,j]==1
    }
  }
}

term_doc_01 <- t(doc_term)
term_sent_nuova <- term_doc_01 %*% doc_sent_matrix
is.numeric(doc_sent_matrix[1, 1])


# get_marker_spillover.r
#
# Copyright (c) 2020 VIB (Belgium) & Babraham Institute (United Kingdom)
#
# Software written by Carlos P. Roca, as research funded by the European Union.
#
# This software may be modified and distributed under the terms of the MIT
# license. See the LICENSE file for details.

#' Get spillover coefficients
#'
#' Calculates spillover coefficients with robust linear models.
#'
#' @param scale.untransformed Logical indicating if calculation has to be run
#'     in untransformed or transformed (bi-exponential) scale.
#' @param flow.gate List of vectors with ids of gated events per sample.
#' @param flow.control List with data and metadata of a set of controls.
#' @param asp List with AutoSpill parameters.
#'
#' @return List of two matrices, with regressions intercepts and coefficients.
#'
#' @references Roca \emph{et al}:
#'     AutoSpill: A method for calculating spillover coefficients to compensate
#'     or unmix high-parameter flow cytometry data.
#'     \emph{bioRxiv} 2020.06.29.177196;
#'     \href{https://doi.org/10.1101/2020.06.29.177196}{doi:10.1101/2020.06.29.177196}
#'     (2020).
#'
#' @seealso \code{\link{gate.flow.data}}, \code{\link{read.flow.control}}, and
#'     \code{\link{get.autospill.param}}.
#'
#' @export

get.marker.spillover <- function( scale.untransformed, flow.gate, flow.control,
    asp )
{
    if ( scale.untransformed )
        expr.data <- flow.control$expr.data.untr
    else
        expr.data <- flow.control$expr.data.tran

    marker.spillover.zero <- rep( 0, flow.control$marker.n )
    names( marker.spillover.zero ) <- flow.control$marker

    marker.spillover <- mclapply( flow.control$sample, function( samp )
    {
        marker.proper <- samp

        marker.proper.expr <- expr.data[
            which( flow.control$event.sample == samp )[ flow.gate[[ samp ]] ],
            marker.proper ]

        marker.expr.n <- length( marker.proper.expr )

        # identify extreme expression values

        expr.trim.n <- round( marker.expr.n * asp$rlm.trim.factor )

        marker.proper.expr.low <- sort( marker.proper.expr )[ expr.trim.n ]
        marker.proper.expr.high <- sort( marker.proper.expr,
            decreasing = TRUE )[ expr.trim.n ]

        marker.spillover.inte <- marker.spillover.zero
        marker.spillover.coef <- marker.spillover.zero

        for ( marker in flow.control$marker )
            if ( marker == marker.proper )
                marker.spillover.coef[ marker ] <- 1.0
            else
            {
                marker.expr <- expr.data[
                    which( flow.control$event.sample == samp )[
                        flow.gate[[ samp ]] ],
                    marker ]

                marker.expr.low <- sort( marker.expr )[ expr.trim.n ]
                marker.expr.high <- sort( marker.expr, decreasing = TRUE )[
                    expr.trim.n ]

                # trim expression values for both markers

                expr.trim.idx <- which (
                    marker.proper.expr > marker.proper.expr.low &
                        marker.proper.expr < marker.proper.expr.high &
                        marker.expr > marker.expr.low &
                        marker.expr < marker.expr.high
                )

                marker.proper.expr.trim <- marker.proper.expr[ expr.trim.idx ]
                marker.expr.trim <- marker.expr[ expr.trim.idx ]

                # fit robust linear model

                spillover.model.result <- fit.robust.linear.model(
                    marker.proper.expr.trim, marker.expr.trim,
                    marker.proper, marker, asp )

                marker.spillover.inte[ marker ] <-
                    spillover.model.result[ 1, 1 ]

                marker.spillover.coef[ marker ] <-
                    spillover.model.result[ 2, 1 ]
            }

        c( marker.spillover.inte, marker.spillover.coef )
    },
    mc.cores = get.worker.process( asp$worker.process.n ) )

    marker.spillover <- do.call( rbind, marker.spillover )
    rownames( marker.spillover ) <- flow.control$marker

    list(
        inte = marker.spillover[ , 1 : flow.control$marker.n ],
        coef = marker.spillover[ , 1 : flow.control$marker.n +
                flow.control$marker.n ]
    )
}


read.fit<-function(baseF='sms'){
  # Code modified from Anders Nielsen's SAM code

  # Function to read a basic fit

  ret<-list()

  parfile<-as.numeric(scan(file.path(data.path,paste(baseF,".par",sep='')),
                      what='', n=16, quiet=TRUE)[c(6,11,16)])
  ret$nopar<-as.integer(parfile[1])
  ret$nlogl<-parfile[2]
  ret$maxgrad<-parfile[3]

  lin<-readLines(file.path(data.path,paste(baseF,".cor",sep='')))
  ret$npar<-length(lin)-2
  ret$logDetHess<-as.numeric(strsplit(lin[1], '=')[[1]][2])
  sublin<-lapply(strsplit(lin[1:ret$npar+2], ' '),function(x)x[x!=''])
  ret$names<-unlist(lapply(sublin,function(x)x[2]))
  ret$est<-as.numeric(unlist(lapply(sublin,function(x)x[3])))
  ret$std<-as.numeric(unlist(lapply(sublin,function(x)x[4])))

  ret$cor<-matrix(NA, ret$npar, ret$npar)
  for(i in 1:ret$npar){
    ret$cor[1:i,i]<-as.numeric(unlist(lapply(sublin[i],
      function(x)x[5:(4+i)])))
    ret$cor[i,1:i]<-ret$cor[1:i,i]
  }
  ret$cov<-ret$cor*(ret$std%o%ret$std)

  b<-read.table(file.path(data.path,"par_exp.out"),comment.char = "#",header=T)
  ret$species<-b$species
  ret$year<-b$year
  ret$quarter<-b$quarter
  ret$age<-b$age
  ret$predator<-b$predator
  ret$prey<-b$prey
  ret$fleet<-b$fleet

  mslh<-function(name){
    idx<-which(ret$names==name)
      x<-cbind(ret$est[idx], ret$std[idx], ret$est[idx]-2*ret$std[idx],
             ret$est[idx]+2*ret$std[idx])
    colnames(x)<-c('est', 'std', 'low', 'hig')
    return(x)
  }
  ret$ssb<-mslh('hist_SSB')
  return(ret)
}


# step0. pre-defined parameters and functions
args <- commandArgs(T)
labelN <- args[1]
dataFN <- args[2]
outFN <- args[3]

# step1. read data and limit the maximum
data <- read.table(dataFN, sep = '\t', header = F, skip = 2)
firstRow <- read.table(dataFN, sep = '\t', header = F, nrows = 2)

# remove outliers
quan_k9 <- quantile(data[which(data[,1]>=0),1], 0.9999)
quan_methylDensity <- quantile(data[which(data[,2]>=0),2], 0.9999)
data[which(data[,1] > quan_k9),1] <- quan_k9
data[which(data[,2] > quan_methylDensity),2] <- quan_methylDensity

# step2. balance
# decide lambda according to mean
lambda <- mean(data[which(data[,2]>=0),2])/mean(data[which(data[,1]>=0),1])
# print(t(c(labelN, lambda)))
write.table(t(c(labelN, lambda)), file = outFN, sep = '\t', quote = F, row.names = F, col.names = F, append = T)


 DTPRFS Example Program Results

 Solution(s)
             1          2
 1     -3.0000    -5.0000
 2     -1.0000     1.0000
 3      2.0000    -1.0000
 4      1.0000     6.0000

 Backward errors (machine-dependent)
       6.9E-17    0.0E+00
 Estimated forward error bounds (machine-dependent)
       8.3E-14    2.6E-14


studyId = "test"
dataFile = "1_1_quality.data"
sense = 1
name = "Testing"
threshold1 = 8
threshold2 = 6

args = commandArgs(TRUE)
print(args)
if(length(args) == 6){
   studyId = args[[1]]
   dataFile = args[[2]]
   sense = as.numeric(args[[3]])
   name = args[[4]]
   threshold1 = as.numeric(args[[5]])
   threshold2 = as.numeric(args[[6]])
}

name = gsub("_"," ",name)

data = read.csv(dataFile,header=FALSE,sep=",",stringsAsFactors=TRUE)
data = as.numeric(data)

z = quantile(data,c(0.01,0.05,0.1,0.2,0.5,0.8,0.9))
#print(z)

#print(data)
#print(length(data))

if(sense == 0){
        #print('MIN')
        #data = data[data >= as.numeric(z[4])]

        best_val = min(data)
        delta = threshold1 - best_val
        cutoff = threshold1 + delta
        data = data[data <= cutoff]
} else {
        #print('MAX')
        #data = data[data <= as.numeric(z[6])]

        best_val = max(data)
        delta = threshold1 - best_val
        cutoff = threshold1 + delta
        data = data[data >= cutoff]
}

#print(data)
#print(length(data))

#barColor = rgb(0.0,0.5,1.0,1.0)
#barColor = rgb(0.0,0.4,0.6,1.0) #tbl dark 1
barColor = rgb(0.0,0.33,0.5,1.0) #tbl dark 2
#barColor = rgb(0.88,0.93,0.96,1.0) #tbl light
threshold1Color = rgb(0.15,0.5,1.0,1.0)
threshold2Color = rgb(1.0,0.5,0.0,1.0)

targetColor = rgb(1.0,0.2,0.2,0.8)

lineColor = rgb(0.0,0.0,0.0,0.3)
pointColor = rgb(0.0,0.0,0.0,0.3)
pointStyle = c(1,19)

fileName = paste(studyId,paste("dist","pdf",sep="."),sep="_")
pdf(fileName, pointsize=18, width=9, height=9)
	par(mar=c(4.5,4.5,0.5,0.5))
	nBreaks = max(1,min(40, max(data)-min(data)))

	if(nBreaks == 1){
		lim = c(min(data)-0.5,max(data)+0.5)
		hist(data, breaks=nBreaks, col=barColor, border='black', ylab="Solution Count", xlab="Objective Value", main="", xlim=lim) #, main=name
	} else {
		hist(data, breaks=nBreaks, col=barColor, border='black', ylab="Solution Count", xlab="Objective Value", main="")
	}
	abline(v=median(data), lw=6, col=targetColor)

	#if(threshold1 > 0){
	#	abline(v=threshold1, lw=6, col=threshold1Color)
	#}
	#abline(v=threshold2, lw=6, col=threshold2Color)
dev.off()


fname <- 'stats-quantiles.dat'
write('# GENERATED FILE, DO NOT EDIT.', fname)
write('# Quantiles calculated by R.', fname, append=TRUE)
write('# ==========================', fname, append=TRUE)
data <- seq(1000, 1999, 50)
write('seq = 1000 1999 50', fname, append=TRUE)
ps <- c(0.0, 0.01, 0.05, 0.1, 0.16, 0.2, 0.25, 0.31, 0.42, 0.45, 0.5, 0.55, 0.62, 0.75, 0.81, 0.87, 0.9, 0.95, 0.99, 1.0)
write(c('p = ', ps), fname, ncolumns= 22, append=TRUE)
for (N in c(1:9)) {
    write(c(N, ':', quantile(data, ps, type=N)), ncolumns=22, fname, append=TRUE)
    }