# ......................................................................................
# ........................Cvičení 3 - Diskrétní náhodná veličina........................
# ..................Martina Litschmannová, Adéla Vrtková, Michal Béreš..................
# ......................................................................................

# Nezobrazuje-li se vám text korektně, nastavte File \ Reopen with Encoding... na UTF-8
# Pro zobrazení obsahu skriptu použijte CTRL+SHIFT+O
# Pro spouštění příkazů v jednotlivých řádcích použijte CTRL+ENTER

#  Příklady ####
# * Příklad 1. ####
# Majitel servisního střediska nabídl prodejně automobilů, která si zřídila autopůjčovnu
# své
# služby. Za každý automobil zapůjčený jeho prostřednictvím obdrží od autopůjčovny 500,-
# Kč.
# Zároveň se však zavázal, že každý den investuje do údržby zapůjčených automobilů 800,-
# Kč.
# Počet automobilů zapůjčených prostřednictvím servisního střediska za 1 den je popsán
# následující pravděpodobnostní funkcí:
# Obrázek viz sbírka úloh.
# ** 1. a) ####
# Hodnota pravděpodobnostní funkce pro 5 automobilů byla špatně čitelná. Určete ji:

x = c(0,1,2,3,4,5,6)
p = c(0.01,0.40,0.25,0.15,0.10,0,0.03)
1 - sum(p) # počítačová aritmetika zde může zlobit
round(1 - sum(p), digits=2) # zaokrouhlíme na setiny
p[6] = round(1 - sum(p), digits=2) # zápis pro x=5 je 6-tá pozice
p

plot(x, p)

plot(x, p, type="h")

# Začínáme s grafikou -> graf dále upravujeme - používáme další parametry
plot(x, p,
     ylim=c(0,0.5),                    # parametr pro rozsah osy y
     ylab="p(x)",                      # parametr pro popis osy y
     main="Pravděpodobnostní funkce",  # parametr pro název grafu
     type="p",                         # určuje o jaký typ grafu se jedná (p -> points, bodový)
     pch=19,                           # parametr pro vzhled zobrazovaných bodů
     col=c("blue","red","green"),      # barvy
     cex=2,                            # parametr pro upravení velikosti celého grafu (ve smyslu zvětší 2x)
     cex.lab=1.3,                      # parametr zvlášť pro velikost názvů os
     cex.axis=1.3,                     # parametr zvlášť pro velikost hodnot na osách
     cex.main=1.3)                     # parametr pro velikost názvu grafu

text(0.5,0.0,"X ... počet zapůjčených automobilů", cex=1.3, col="blue", adj=c(0,0))

# Pravděpodobnostní funkce
pravd.f = function(x,p){
    plot(x, p, # plná kolečka - v skutečných hodnotách
        ylab='p(x)',xaxt='n',pch=19,ylim=c(0,max(p)),main="Pravdepodobnostni funkce")
    lines(c(min(x)-100,max(x)+100),c(0, 0))
    for(i in 1:length(x)){
        lines(c(min(x)-100,max(x)+100), c(p[i],p[i]),
              type = 'l', lty = 3, lwd=0.5) # horizontální grid
        lines(c(x[i],x[i]), c(-0.1,1.1),
              type = 'l', lty = 3, lwd=0.5) # vertikální grid
    }
    par(new=TRUE) # že chceme kreslit do jednoho grafu
    plot(x, p*0, # prázdná kolečka - tam kde je definovaná nenulová hodnota
        ylab='p(x)', xaxt='n', ylim=c(0,max(p)))
    axis(1, at=x,labels=x) # nastavení hodnot na X
    axis(4, at=p,labels=p, las=2, cex.axis=0.7, tck=-.01) # a Y
}

pravd.f(x, p)

#  Poznámky k úvodu do grafiky
#  základem jsou tzv. high-level funkce, které vytvoří graf (tj. otevřou grafické okno a
# vykreslí dle zadaných parametrů)
#  na ně navazují tzv. low-level funkce, které něco do aktviního grafického okna
# přidají, samy o sobě neotevřou nové
#  výše použitá funkce "text" je low-level funkce - přidá text do stávajícího aktivního
# grafického okna
#  další low-level funkce - např. abline, points, lines, legend, title, axis ... které
# přidají přímku, body, legendu...
#  tzn. před použitím "low-level" funkce je potřeba, volat "high-level" funkci (např.
# plot, boxplot, hist, barplot, pie,...)
#
#  další grafické parametry naleznete v nápovědě
#  nebo např. zde http://www.statmethods.net/advgraphs/parameters.html
#  nebo zde https://flowingdata.com/2015/03/17/r-cheat-sheet-for-graphical-parameters/
#  nebo http://bcb.dfci.harvard.edu/~aedin/courses/BiocDec2011/2.Plotting.pdf

# ** 1. b) ####
# Určete a zakreslete distribuční funkci náhodné veličiny X, která je definována jako
# počet
# zapůjčených automobilů.

p
F = cumsum(p)
F

plot(x, F, type="s") # zjednodušený graf distribuční funkce

# Funkce pro výpočet a vykreslení distribuční funkce
dist.f = function(x,p){
    F = cumsum(p)
    F_ext = c(0, F) # natáhneme F o 0 na začátku
    x_ext = c(x[1]-1, x, x[length(x)]+1) # a x z obou stran

    plot(x, F, ylab="F(x)", xaxt='n', ylim=c(0,1), # prazdná kolečka
         type='p', main="Distribucni funkce")
    par(new=TRUE) # že chceme kreslit do jednoho grafu
    plot(x, F_ext[1:(length(F_ext)-1)], # plná kolečka
         ylab="F(x)", xaxt='n', ylim=c(0,1), type='p', pch=19)

    for(i in 1:(length(x_ext)-1)){
        lines(c(min(x)-100,max(x)+100), c(F_ext[i],F_ext[i]),
              type = 'l', lty = 3, lwd=0.5) # horizontální grid
        lines(c(x_ext[i],x_ext[i]), c(-0.1,1.1),
              type = 'l', lty = 3, lwd=0.5) # vertikální grid
        lines(x_ext[i:(i+1)], c(F_ext[i],F_ext[i])) # graf - čáry
    }
    axis(1, at=x,labels=x) # nastavení hodnot na X
    axis(4, at=F,labels=F, las=2, cex.axis=0.7, tck=-.01) # a Y
    return(F)
}

dist.f(x,p)

# ** 1. c)  ####
# Určete střední hodnotu, rozptyl, směrodatnou odchylku a modus počtu zapůjčených
# automobilů během jednoho dne.

# Střední hodnota
x*p
EX = sum(x*p)
EX

# Rozptyl
EX2 = sum(x*x*p)  # druhý obecný moment
DX = EX2 - EX^2
DX

# Směrodatná odchylka
sigma.X = sqrt(DX)
sigma.X

# Funkce pro výpočet základních číselných charakteristik
souhrn=function(x,p){
  EX = sum(x*p)
  EX2 = sum(x*x*p)
  DX = EX2-EX^2
  sigma.X = sqrt(DX)
  # zápis výsledků do tabulky
  tab = rbind(EX, DX, sigma.X)
  tab.popis = c("str. hodnota","rozptyl","smer. odchylka")
  rownames(tab) = tab.popis
  return(tab)
}

souhrn(x, p)

# ** 1. d) ####
# Určete pravděpodobnostní funkci a distribuční funkci náhodné veličiny Y, která je
# definována jako denní příjem majitele servisu.

y = 500*x
y

pravd.f(y, p)

# Distribuční funkce
dist.f(y,p)

# ** 1. e)  ####
# Určete střední hodnotu, směrodatnou odchylku a modus příjmu majitele servisu ze
# zapůjčených automobilů během jednoho dne.

souhrn(y,p)

# ** 1. f)  ####
# Určete pravděpodobnost, že příjem majitele servisu (náhodná veličina Y) z půjčování
# automobilů převýší jeho výdaje.

# zisk
z=500*x-800
z

# příjem převýší výdaje, když je zisk kladný
z > 0

p
sum(p[z>0])

# ** 1. g)  ####
# Určete střední hodnotu, směrodatnou odchylku a modus náhodné veličiny Z, která je
# definována jako zisk majitele servisu ze zapůjčených automobilů během jednoho dne.

souhrn(z, p)

# * Příklad č. 2 ####
# Pro distribuční funkci náhodné veličiny X platí:
#
# $F(x)=\begin{cases}
# 0   &      x \leq -1 \\
# 0.3 & -1 < x \leq  0 \\
# 0.7 &  0 < x \leq  1 \\
# 1   & -1 < x
# \end{cases}$
#
# ** 2. a)  ####
# Určete pravděpodobnostní funkci náhodné veličiny X, její střední hodnotu a směrodatnou
# odchylku.

F = c(0, 0.3, 0.7, 1)
F
x = c(-1,0,1)
x

diff(F)

p = diff(F)
x
p

pravd.f(x,p)

dist.f(x,p)

souhrn(x,p)

# ** 2. b)  ####
# Náhodná veličina Y = 1 − 3X, určete P(y), F(y), E(Y), D(Y).

y = 1 - 3*x
pravd.f(y,p)

dist.f(y,p)   # Nesmyslný výstup - čím je to způsobeno?
y
p

y
sort(y)
idx_sorted = order(y) # funkce order vrátí indexy setřízeného pořadí
idx_sorted
y = y[idx_sorted]
p_y = p[idx_sorted]
p_y

dist.f(y,p_y)

souhrn(y, p_y)

# ** 2. c)  ####
# Náhodná veličina W = $3X^2$, určete P(w), F(w), E(W), D(W).

w = 3*x*x
w

pravd.f(w,p)
dist.f(w,p)

w
w_uniq = unique(w)
w_uniq
w_sorted = sort(w_uniq)
w_sorted

p_w = w_sorted*0 # inicializace pole o stejné velikosti
for(i in 1:length(w_sorted)){
    p_w[i] = sum(p[w == w_sorted[i]])
}
p_w

pravd.f(w_sorted,p_w)
dist.f(w_sorted,p_w)
souhrn(w_sorted,p_w)

# * Příklad 3. ####
# V dílně jsou dva stroje pracující nezávisle na sobě. Pravděpodobnost poruchy prvního
# stroje
# je 0,2, pravděpodobnost poruchy druhého stroje je 0,3. Náhodná veličina X je
# definována jako
# počet současně porouchaných strojů. Určete:
# ** 3. a)  ####
# pravděpodobnostní funkci náhodné veličiny X,

x = c(0, 1, 2)
x
p1 = 0.2
p2 = 0.3

p = x*0
# spočteme jednotlivé pravděpodobnosti počtu porouchaných strojů
p[1] = (1 - p1)*(1 - p2) # 0 porouchaných tedy oba v provozu
p[3] = p1*p2 # 2 tedy porouchané oba
p
1 - sum(p)
p[2] = (1 - p1)*p2 + p1*(1 - p2) # právě jeden - buď první nebo druhý
p

sum(p)

pravd.f(x,p)

# ** 3. b) ####
# distribuční funkci náhodné veličiny X,

dist.f(x,p)

# ** 3. c) ####
# střední hodnotu a rozptyl náhodné veličiny X.

souhrn(x,p)


#  James Rekow

connectedSubgraphs = function(g, v, numSubgraphs){

  #  ARGS: g - graph
  #        v - number of vertices in the connected subgraphs to be returned
  #
  #  RETURNS: connectedList - a list of numeric vectors of vertices forming connected subgraphs
  #           of g, all of which have v vertices, or NULL if no such subgraphs are found

  ##  remove after editing
  conGraph = g
  synthM = v
  M = vcount(g)
  ##

  #  create adjacency matrix for connectivity graph
  adjMat = as.matrix(get.adjacency(conGraph, type = "both"))

  #  make a list to store samples that are not part of any connected subgraphs with
  #  M or more vertices
  unfitSamples = c()

  constructSynthChrt = function(synthM, M, adjMat, unfitSamples){

    #  samples in the synthetic cohort
    synthSamples = 0 * (1:synthM)

    validStartSamples = 1:M

    if(length(unfitSamples > 0)){
      validStartSamples = validStartSamples[-unfitSamples]
    }

    #  select the first sample
    newSample = sample(validStartSamples, 1)

    #  add the first sample to the synthetic cohort
    synthSamples[1] = newSample

    #  remove extraneous edges connecting to newSample from the adjacency matrix
    adjMat[newSample, ] = 0

    #  samples which are connected to any of the samples in the existing synthetic cohort
    potentialSamples = which(adjMat[ , synthSamples[1]] == 1)

    for(ii in 2:synthM){

      #  if there are no potential samples, but the synthetic cohort is not large enough, mark all
      #  of the synthSamples produced on this iteration as unfit, as they form a connected subgraph
      #  that is disconnected from all of the other samples, but insufficiently large to create a
      #  synthetic cohort with synthM samples
      if(length(potentialSamples) == 0){

        #  return the negative indices of samples if they are not part of any connected synthetic
        #  cohort with at least synthM vertices
        synthSamples = -synthSamples
        break

      } #  end if

      ##  select a new sample to add to the synthetic cohort
      if(length(potentialSamples) == 1){
        newSample = potentialSamples[1]
      } #  end if

      if(length(potentialSamples) > 1){
        newSample = sample(potentialSamples, 1)
      } #  end if

      #  remove extraneous edges connecting to newSample from the adjacency matrix
      adjMat[newSample, ] = 0

      #  remove the newly added sample from the vector of potential samples
      potentialSamples = potentialSamples[potentialSamples != newSample]

      #  identify new potential samples from non-reduntant edges incident to newSample
      newPotentialSamples = which(adjMat[ , newSample] == 1)

      #  add new potential samples to potential samples
      potentialSamples = append(potentialSamples, newPotentialSamples)

      #  add the new sample to synthSamples
      synthSamples[ii] = newSample

    } #  end while loop

    return(synthSamples)

  } #  end constructSynthChrt function

  while(length(unfitSamples) < (M - synthM)){

    synthSamples = constructSynthChrt(synthM = synthM, M = M, adjMat = adjMat,
                                      unfitSamples = unfitSamples)

    if(synthSamples[1] < 0){
      unfitSamples = append(unfitSamples, -synthSamples)
      print(unfitSamples)
      print(synthSamples)

    } #  end if

    else{
      break
    } #  end else

  } #  end while loop

  if(synthM > (M - length(unfitSamples))){
    warning("No valid synthetic cohorts could be created.")
    return(NULL)
  } #  end if

  else{
    #  synthChrt = abdList[synthSamples]
    #  for testing
    return(synthSamples)
    #  end for testing
    return(synthChrt)
  } #  end else

} #  end connectedSubgraphs function


#' @export
#' @title applySum
#' @description apply a sum and return a formated data frame. If 3 columns of data then a weighted sum is returned, if 1 column (vector) then a count is returned. Must contain index, variable, weight in this sequence
#' @family poorly documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
  applySum = function( f, method="fast", newnames=NULL ) {
    cnames= c("id", "x", "w" )

    if (is.null( newnames )) newnames=names(f)

    if( is.vector(f) ) {

      out = as.data.frame( xtabs( ~ f) , stringsAsFactors=FALSE  )

    } else {

      # data.frame metod

      nv = ncol(f)
      names(f) = cnames[1:nv]

      if( nv==3 ) f$x = f$x* f$w

      o = which( is.finite( f$x) )
      if ( length(o) == 0 ) return( "No data?")
      f = f[o,]

      if (method=="slow") {
        r = by( f, f$id, with, sum( x, na.rm=TRUE ))
        out = data.frame( id=names(r), x=as.numeric(as.vector(r)) , stringsAsFactors=FALSE )

      } else if (method=="fast") {
        f$id = as.factor( f$id )
        l0 = 1 / median( f$x, na.rm=TRUE ) # a scaling factor to help avoid overflow errors
        f$x = as.numeric( f$x * l0)
        out = as.data.frame( xtabs( f$x ~ f$id) / l0, stringsAsFactors=FALSE )
      }

    }

    names(out) = newnames[1:2]
    return( out )
  }


## expect full
coef(summary(lm(handed.mom=="left"~pgs.mom, alspac.table)))[2,]
coef(summary(lm(handed=="left"~pgs.child, alspac.table)))[2,]

## expect half
coef(summary(lm(handed=="left"~pgs.mom, alspac.table)))[2,]
coef(summary(lm(handed.mom=="left"~pgs.child, alspac.table)))[2,]
coef(summary(lm(handed.partner=="left"~pgs.child, alspac.table)))[2,]

## expect none
coef(summary(lm(handed.partner=="left"~pgs.mom, alspac.table)))[2,]

## > ## expect full
## > coef(summary(lm(handed.mom=="left"~pgs.mom, alspac.table)))[2,]
##    Estimate  Std. Error     t value    Pr(>|t|)
## 0.010956810 0.003365612 3.255518297 0.001138108
## > coef(summary(lm(handed=="left"~pgs.child, alspac.table)))[2,]
##    Estimate  Std. Error     t value    Pr(>|t|)
## 0.009986924 0.004019210 2.484797507 0.012988935
## > ## expect half
## > coef(summary(lm(handed=="left"~pgs.mom, alspac.table)))[2,]
##    Estimate  Std. Error     t value    Pr(>|t|)
## 0.007112932 0.004114507 1.728744635 0.083905784
## > coef(summary(lm(handed.mom=="left"~pgs.child, alspac.table)))[2,]
##    Estimate  Std. Error     t value    Pr(>|t|)
## 0.005276617 0.003416938 1.544253144 0.122578262
## > coef(summary(lm(handed.partner=="left"~pgs.child, alspac.table)))[2,]
##    Estimate  Std. Error     t value    Pr(>|t|)
## 0.007452921 0.004287903 1.738127207 0.082271549
## > ## expect none
## > coef(summary(lm(handed.partner=="left"~pgs.mom, alspac.table)))[2,]
##     Estimate   Std. Error      t value     Pr(>|t|)
## -0.003808645  0.004456123 -0.854699271  0.392775118


E04ABJ Example Program Results

The minimum lies in the interval 4.49340940 to 4.49340951
Its estimated position is 4.49340945,
where the function value is -0.2172
10 function evaluations were required


# @importFrom tibble tibble
#' @importFrom stats approxfun
survival_features <- function(time, event) {
  ft <- tibble(time = time, event = event)
  ft <- ft[order(ft$time),]

  # lifetime distribution function
  ret <- tibble(time = double(), lifetime_dist = double())
  time_split <- split(seq_len(nrow(ft)), as.factor(ft$time))
  for (i in seq_along(time_split)) {
    time <- as.double(names(time_split)[i])
    prop <- sum(ft$event[ft$time <= time] == 1) / length(ft$event)
    ret <- rbind(ret, tibble(time = time, lifetime_dist = prop))
  }
  ret$survival_dist <- 1 - ret$lifetime_dist
  ret$hazard <- -log(ret$survival_dist)
  ret
}

#' @importFrom fu dep_terms extract_vars indep_terms
#' @importFrom crayon red
#' @importFrom keras loss_mean_squared_error
#' @export
dcoxph <- function(data,
                   formula,
                   hidden_layers = integer(),
                   hidden_layers_activation =
                    rep("linear", length(hidden_layers)),
                   use_bias = rep(FALSE, length(hidden_layers) + 1),
                   loss = neg_log_prop_haz_lik,
                   optimizer = optimizer_adadelta(),
                   metrics = neg_log_prop_haz_lik,
                   output_activation = "linear",
                   batch_size = nrow(data),
                   epochs = 1000,
                   verbose = FALSE,
                   validation_split = 0.2,
                   name = NULL,
                   zero_weights = TRUE,
                   ...) {

  # Get the time and event variables to create the hazard function.
  surv_vars <- extract_vars(dep_terms(formula))
  indep_vars <- indep_terms(formula, data)

  xf <- model.frame(
    as.formula(paste("~", paste(c(surv_vars, indep_vars), collapse = " + "))),
    data)

  # I just want the cleaned up data frame. I don't want the term attributes or else
  # I'll get an error when I try to make a model matrix with another formula.
  attributes(xf)$terms <- NULL

  var_desc <- make_variable_desc(xf, formula)
  error_on_no_indep_var(var_desc)
  error_on_conditional_var(var_desc)
  error_on_bad_hidden_layer_desc(hidden_layers, hidden_layers_activation)

  if (any(!(xf[[surv_vars[2]]] %in% c(0, 1)))) {
    stop(red("Event variables should be 0 if right censored or 1 if an event",
             "took place."))
  }

  # The Nelson-Aalen estimate of the hazard function.
  #haz <- muhaz(xf[[surv_vars[1]]], xf[[surv_vars[[2]]]],
  #             n.est.grid = 2*nrow(xf),
  #             bw.grid = xf[[surv_vars[1]]],
  #             min.time = 0,
  #             max.time = max(xf[[surv_vars[1]]]))
  #sf <- tibble(time = xf[[surv_vars[1]]],
  #             hazard = approxfun(x = haz$est.grid, y = haz$haz.est)(time))

  # TODO: refactor this. There is a lot of overlap with the dlr function.

  x_train <- make_model_matrix(formula, xf)
  mm_column_var_assign <- attributes(x_train)$assign
  column_var_name <- names(xf)
  mm_column_var_name <- colnames(x_train)

  model <-
    create_input_and_hidden_layers(
      x_train,
      hidden_layers,
      hidden_layers_activation,
      use_bias,
      name)

  input_shape <- NULL
  if (length(hidden_layers) == 0) {
    input_shape <- ncol(x_train)
  }

  model %>%
    layer_dense(units = 1, input_shape = input_shape, name = "hazard_output",
                use_bias = FALSE, activation = output_activation,
                kernel_initializer = "random_normal")

  type <- "hazard_dlr"
  y_train <- matrix(c(xf[[surv_vars[1]]], xf[[surv_vars[2]]]), ncol = 2)

  mm_col_names <- colnames(x_train)

  compile(model, loss = loss, optimizer = optimizer, metrics = metrics)

  history <- model %>%
    fit(x_train, y_train, batch_size = batch_size, epochs = epochs,
        validation_split = validation_split, verbose = verbose)

  ret <- list(formula = formula,
              hidden_layers = hidden_layers,
              hidden_layers_activation = hidden_layers_activation,
              column_var_name = column_var_name,
              mm_column_var_name = mm_column_var_name,
              mm_column_var_assign = mm_column_var_assign,
              loss = loss,
              var_desc = var_desc,
              model = model,
              history = history,
              mm_col_names = mm_col_names)

  class(ret) <- c("survival_dglm", "dglm")
  ret
}


#' @title
#' Nested reduced-rank regression with given ranks
#'
#' @description
#' This function implements the blockwise coordinate descent algorithm
#' to get the nested reduced-rank regression estimator with
#' given rank values \code{(r, rx, ry)}.
#'
#' @usage
#' NRRR.est(Y, X, Ag0 = NULL, Bg0 = NULL,
#'          rini, r, rx, ry, jx, jy, p, d, n,
#'          maxiter = 100, conv = 1e-4,
#'          method = c("RRR", "RRS")[1], lambda = 0)
#'
#'
#' @param Y response matrix of dimension n-by-jy*d.
#' @param X design matrix of dimension n-by-jx*p.
#' @param Ag0 an initial estimator of matrix U. If \code{Ag0 = NULL} then generate it
#'            by \code{\link{NRRR.ini}}. Default is NULL.
#' @param Bg0 an initial estimator of matrix V. If \code{Bg0 = NULL} then generate it
#'            by \code{\link{NRRR.ini}}. Default is NULL.
#' @param rini,r rank of the local reduced-rank structure. \code{rini} is used
#'               in \code{\link{NRRR.ini}} to get the initial
#'               estimators of U and V.
#' @param rx number of latent predictors.
#' @param ry number of latent responses.
#' @param jx number of basis functions to expand the functional predictor.
#' @param jy number of basis functions to expand the functional response.
#' @param p number of predictors.
#' @param d number of responses.
#' @param n sample size.
#' @param maxiter the maximum iteration number of the
#'                blockwise coordinate descent algorithm. Default is 100.
#' @param conv the tolerance level used to control the convergence of the
#'             blockwise coordinate descent algorithm. Default is 1e-4.
#' @param method 'RRR' (default): no additional ridge penalty; 'RRS': add an
#'               additional ridge penalty.
#' @param lambda the tuning parameter to control the amount of ridge
#'               penalization. It is only used when \code{method = 'RRS'} and
#'               a positive value should be provided.
#'               Default is 0.
#'
#' @return The function returns a list:
#'   \item{Ag}{the estimated U.}
#'   \item{Bg}{the estimated V.}
#'   \item{Al}{the estimated A.}
#'   \item{Bl}{the estimated B.}
#'   \item{C}{the estimated coefficient matrix C.}
#'   \item{df}{degrees of freedom of the model.}
#'   \item{sse}{sum of squared errors.}
#'   \item{ic}{a vector containing values of BIC, BICP, AIC, GCV.}
#   \item{obj}{a vector contains all objective function (sse) values along iteration.}
#'   \item{iter}{the number of iterations needed to converge.}
#'
#' @details
#' The \emph{nested reduced-rank regression (NRRR)} is proposed to solve
#' a multivariate functional linear regression problem where both the response and
#' predictor are multivariate and functional (i.e., \eqn{Y(t)=(y_1(t),...,y_d(t))^T}
#' and \eqn{X(s)=(x_1(s),...,y_p(s))^T}). To control the complexity of the
#' problem, NRRR imposes a nested reduced-rank structure on the regression
#' surface \eqn{C(s,t)}. Specifically, a global dimension reduction makes use of the
#' correlation within the components of multivariate response and multivariate
#' predictor. Matrices U (d-by-ry) and V (p-by-rx) provide weights to form ry latent
#' functional responses and rx latent functional predictors, respectively.
#' Dimension reduction is achieved
#' once \eqn{ry < d} or \eqn{rx < p}. Then, a local dimension reduction is
#' conducted by restricting the latent regression surface \eqn{C^*(s,t)} to be of low-rank.
#' After basis expansion and truncation, also by applying proper rearrangement to
#' columns and rows of the resulting data matrices and coefficient matrices, we
#' have the nested reduced-rank problem:
#' \deqn{ \min_{C} || Y - XC ||_F^2, s.t., C = (I_{jx} \otimes V) BA^T (I_{jy} \otimes U)^T,}
#' where \eqn{BA^T} is a full-rank decomposition to control the local
#' rank and \eqn{jx, jy} are the number of basis functions. Beyond the functional
#' setup, this structure can also be applied to multiple scenarios, including
#' multivariate time series autoregression analysis and tensor-on-tensor regression.
#' This problem is non-convex and has no explicit solution, thus we use a
#' blockwise coordinate descent algorithm to find a local solution. The convergence
#' is decided by the change in objective values between two neighboring iterations.
#'
#'
#'
#'
#'
#' @references Liu, X., Ma, S., & Chen, K. (2020).
#' Multivariate Functional Regression via Nested Reduced-Rank Regularization.
#' arXiv: Methodology.
#' @examples
#' library(NRRR)
#' simDat <- NRRR.sim(n = 100, ns = 200, nt = 200, r = 5, rx = 3, ry = 3,
#'                    jx = 15, jy = 15, p = 10, d = 6, s2n = 1, rho_X = 0.5,
#'                    rho_E = 0, Sigma = "CorrAR")
#' fit_init <- with(simDat, NRRR.est(Y = Yest, X = Xest,
#'                  Ag0 = NULL, Bg0 = NULL, rini = 5, r = 5,
#'                  rx = 3, ry = 3, jx = 15, jy = 15,
#'                  p = 10, d = 6, n = 100))
#' fit_init$Ag
#' @importFrom MASS ginv
#' @export
NRRR.est <- function(Y, X, Ag0 = NULL, Bg0 = NULL, rini, r, rx, ry, jx, jy, p, d, n,
                    maxiter = 100, conv = 1e-4,
                    method = c("RRR", "RRS")[1], lambda = 0) {
  if (rini == 0) stop("rini cannot be 0")
  if (r == 0) stop("r cannot be 0")
  if(p < rx) stop("rx cannot be greater than p")
  if(d < ry) stop("ry cannot be greater than d")

  if (method == "RRS" & lambda != 0) { # RRS is reduced rank ridge regression.
    Y <- rbind(Y, matrix(nrow = p * jx, ncol = d * jy, 0.0))
    X <- rbind(X, sqrt(lambda) * diag(nrow = p * jx, ncol = p * jx))
    n <- n + p * jx
  }

  # require(rrpack)
  # compute initial values of U and V
  if (is.null(Ag0) | is.null(Bg0)) {
    ini <- NRRR.ini(Y, X, rini, rx, ry, jx, jy, p, d, n)
    Ag0 <- ini$Ag
    Bg0 <- ini$Bg
  }

  if (d == ry) {
    Yl0 <- Y
  } else {
    Yl0 <- Y %*% kronecker(diag(jy), Ag0)
  }
  if (p == rx) {
    Xl0 <- X
  } else {
    Xl0 <- X %*% kronecker(diag(jx), Bg0)
  }

  # Given Ag (U) and Bg (V), compute Al and Bl
  if (r > min(dim(Yl0)[2])) stop("r cannot be greater than jy*ry")
  fitRR <- RRR(Yl0, Xl0, nrank = r)
  Bl0 <- fitRR$C_ls %*% fitRR$A
  Al0 <- fitRR$A

  obj <- vector() # collect all objective function (sse) values
  obj[1] <- Obj(Y, X, Ag0, Bg0, Al0, Bl0, jx, jy)$obj
  objnow <- obj[1] + 10
  iter <- 1
  while (iter < maxiter & abs(obj[iter] - objnow) > conv) { # use sse to control convergence.

    ### For updating Ag (U)###
    if (d == ry) {
      Ag1 <- diag(nrow = ry, ncol = ry) # an identity matrix
      Yl0 <- Y
    } else {
      Xg <- Xl0 %*% Bl0 %*% t(Al0)
      Yg0 <- matrix(nrow = d, ncol = ry, 0)
      for (j in 1:jy) {
        a1 <- d * (j - 1) + 1
        b1 <- d * j

        a2 <- ry * (j - 1) + 1
        b2 <- ry * j

        Yg0 <- Yg0 + t(Y[, a1:b1]) %*% (Xg[, a2:b2])
      }
      svdYg0 <- svd(Yg0)
      Ag1 <- svdYg0$u %*% t(svdYg0$v)
      Yl0 <- Y %*% kronecker(diag(jy), Ag1)
    }

    ### For updating Bg (V)###
    if (p == rx) {
      Bg1 <- diag(nrow = rx, ncol = rx)
      Xl0 <- X
    } else {
      yB <- as.vector(Yl0 %*% Al0)
      XB <- matrix(nrow = n * r, ncol = rx * p, 0)
      for (j in 1:jx) {
        a1 <- rx * (j - 1) + 1
        b1 <- rx * j

        a2 <- p * (j - 1) + 1
        b2 <- p * j

        XB <- XB + kronecker(matrix(t(Bl0)[, a1:b1], nrow = r, ncol = rx), X[, a2:b2])
      }
      Bg1 <- matrix(nrow = p, ncol = rx, byrow = FALSE, MASS::ginv(t(XB) %*% XB +
                   0.0000001 * diag(1, rx * p, rx * p)) %*% t(XB) %*% yB)

      Bg1 <- qr.Q(qr(Bg1))
      Xl0 <- X %*% kronecker(diag(jx), Bg1)
    }

    ### For updating Al (A) and Bl (B)###
    fitRR <- RRR(Yl0, Xl0, nrank = r)
    Bl1 <- fitRR$C_ls %*% fitRR$A
    Al1 <- fitRR$A

    iter <- iter + 1
    Objiter <- Obj(Y, X, Ag1, Bg1, Al1, Bl1, jx, jy)
    obj[iter] <- Objiter$obj
    objnow <- obj[iter - 1]
    C <- Objiter$C

    Al0 <- Al1
    Bl0 <- Bl1
    Ag0 <- Ag1
    Bg0 <- Bg1
  }

  # compute rank of X
  xr <- sum(svd(X)$d > 1e-2)
  # compute degrees of freedom of NRRR
  df <- ifelse(xr / jx > rx, rx * (xr / jx - rx), 0) + ry * (d - ry) + (jy * ry + jx * rx - r) * r
  # obtain sse
  sse <- ifelse(Objiter$sse < 0.1, 0, Objiter$sse)
  # compute information criterion
  BIC <- log(sse) + log(d * jy * n) / d / jy / n * df
  BICP <- log(sse) + 2 * log(d * jy * p * jx) / d / jy / n * df
  AIC <- log(sse) + 2 / d / jy / n * df
  GCV <- sse / d / jy / n / (1 - df / d / jy / n)^2

  if (method == "RRS") sse <- sse - lambda * sum(Objiter$C^2)

  # if (!quietly) {
  #   cat("SSE = ", sse, "DF = ", df, "\n", sep = "")
  # }
  return(list(
    Ag = Ag1, Bg = Bg1, Al = as.matrix(Al1), Bl = as.matrix(Bl1), C = C, df = df,
    sse = sse, ic = c(BIC, BICP, AIC, GCV), obj = obj, iter = iter
  ))
}


# 4. faza: Analiza podatkov
library("tidyverse")

#=================================================================
#uvozim in zdruzim tabele
prihod <- read.csv(file = file.path('podatki','transferIN10.csv'))
for (i in 11:19){
  prihod <- rbind(prihod, read.csv(file = file.path('podatki',paste0('transferIN',i,'.csv'))))
}

odhod <- read.csv(file = file.path('podatki','transferOUT10.csv'))
for (i in 11:19){
  odhod <- rbind(odhod, read.csv(file = file.path('podatki',paste0('transferOUT',i,'.csv'))))
}

#=================================================================
#stevilo prestopov, povprecna vrednost, povprecna starost, skupna vrednost prestopov

prestopi <- data.frame("Leto" = 2010:2019)

steviloIn <- prihod %>% group_by(Leto, add = FALSE) %>%  summarise(n = n())
steviloOut <- odhod %>% group_by(Leto, add = FALSE) %>%  summarise(n = n())
prestopi$stevilo_prihodov <- steviloIn$n
prestopi$stevilo_odhodov <- steviloOut$n

avgIn <- prihod %>% group_by(Leto, add = FALSE) %>%  summarize(n = round(mean(Vrednost.transferja, na.rm=TRUE),2))
avgOut <- odhod %>% group_by(Leto, add = FALSE) %>%  summarize(n = round(mean(Vrednost.transferja, na.rm=TRUE),2))
prestopi$Povprecna_vrednost_prihoda <- avgIn$n
prestopi$Povprecna_vrednost_odhoda <- avgOut$n

avgIn <- prihod %>% group_by(Leto, add = FALSE) %>%  summarize(n = round(mean(Starost, na.rm=TRUE),1))
avgOut <- odhod %>% group_by(Leto, add = FALSE) %>%  summarize(n = round(mean(Starost, na.rm=TRUE),1))
prestopi$Povprecna_starost_prihoda <- avgIn$n
prestopi$Povprecna_starost_odhoda <- avgOut$n

avgIn <- prihod %>% group_by(Leto, add = FALSE) %>%  summarize(n = sum(Vrednost.transferja))
avgOut <- odhod %>% group_by(Leto, add = FALSE) %>%  summarize(n = sum(Vrednost.transferja))
prestopi$Skupna_vrednost_prihodov <- avgIn$n
prestopi$Skupna_vrednost_odhodov <- avgOut$n

rownames(prestopi) <- prestopi[,1]
prestopi <- prestopi[-1]

#=================================================================
#polozaji
polozaj <- data.frame("Leto" = 2010:2019)

#popravimo, kadar je stevilo vrstic manjse od 10 (npr za 2012 ni prestopov vezistov -> ni vrstice -> dodam 2012 0)
popravi <- function(polozaj_in){
  if (nrow(polozaj_in)!=10){
    popravek <- setdiff(2010:2019,polozaj_in$Leto)
    df <- tibble('Leto'=popravek,'n'=0)
    popravek<- rbind(polozaj_in,df)
    popravek <- popravek %>% arrange(popravek,'Leto')
    return(popravek)
  }
  else{return(polozaj_in)}
}

polozaj_in <- prihod %>% group_by(Leto, add = FALSE) %>% filter(Polozaj=='FW'|Polozaj=='LW') %>% summarise(n = n())
polozaj_in <- popravi(polozaj_in)
polozaj$Napadalec_prihod <- polozaj_in$n

polozaj_in <- prihod %>% group_by(Leto, add = FALSE) %>% filter(Polozaj=='MF'|Polozaj=='CM'|Polozaj=='DM') %>% summarise(n = n())
polozaj_in <- popravi(polozaj_in)
polozaj$Vezist_prihod <- polozaj_in$n

polozaj_in <- prihod %>% group_by(Leto, add = FALSE) %>% filter(Polozaj=='DF'|Polozaj=='RB') %>% summarise(n = n())
polozaj_in <- popravi(polozaj_in)
polozaj$Branilec_prihod <- polozaj_in$n

polozaj_in <- prihod %>% group_by(Leto, add = FALSE) %>% filter(Polozaj=='GK') %>% summarise(n = n())
polozaj_in <- popravi(polozaj_in)
polozaj$Vratar_prihod <- polozaj_in$n

polozaj_out <- odhod %>% group_by(Leto, add = FALSE) %>% filter(Polozaj=='FW') %>% summarise(n = n())
polozaj_out <- popravi(polozaj_out)
polozaj$Napadalec_odhod <- polozaj_out$n

polozaj_out <- odhod %>% group_by(Leto, add = FALSE) %>% filter(Polozaj=='MF'|Polozaj=='CM') %>% summarise(n = n())
polozaj_out <- popravi(polozaj_out)
polozaj$Vezist_odhod <- polozaj_out$n

polozaj_out <- odhod %>% group_by(Leto, add = FALSE) %>% filter(Polozaj=='DF'|Polozaj=='LB'|Polozaj=='RB'|Polozaj=='LWB'|Polozaj=='CB') %>% summarise(n = n())
polozaj_out <- popravi(polozaj_out)
polozaj$Branilec_odhod <- polozaj_out$n

polozaj_out <- odhod %>% group_by(Leto, add = FALSE) %>% filter(Polozaj=='GK') %>% summarise(n = n())
polozaj_out <- popravi(polozaj_out)
polozaj$Vratar_odhod <- polozaj_out$n

rownames(polozaj) <- polozaj[,1]
polozaj <- polozaj[-1]

#=================================================================
#katere drzave so bolj prestopane -> zemljevid

drzave_prihodi <- data.frame("Leto" = 2010:2019)
drzave_odhodi <- data.frame("Leto" = 2010:2019)

drzave_prihodi_vrednost <- data.frame("Leto" = 2010:2019)
drzave_odhodi_vrednost <- data.frame("Leto" = 2010:2019)

drzave_in <- unique(prihod$Drzavljanstvo)
drzave_out <- unique(odhod$Drzavljanstvo)

for (i in drzave_in){
  df <- prihod %>%group_by(Leto,add=FALSE) %>% filter(Drzavljanstvo==i)%>%summarise(n=n())
  df <- popravi(df)
  drzave_prihodi[toString(i)] <- df$n

  df <- prihod %>%group_by(Leto,add=FALSE) %>% filter(Drzavljanstvo==i)%>%summarise(n = sum(Vrednost.transferja))
  df <- popravi(df)
  drzave_prihodi_vrednost[toString(i)] <- df$n
}
rownames(drzave_prihodi) <- drzave_prihodi[,1]
drzave_prihodi <- drzave_prihodi[-1]
drzave_prihodi<- drzave_prihodi[ , order(names(drzave_prihodi))]

rownames(drzave_prihodi_vrednost) <- drzave_prihodi_vrednost[,1]
drzave_prihodi_vrednost <- drzave_prihodi_vrednost[-1]
drzave_prihodi_vrednost<- drzave_prihodi_vrednost[ , order(names(drzave_prihodi_vrednost))]

for (i in drzave_out){
  df <- odhod %>%group_by(Leto,add=FALSE) %>% filter(Drzavljanstvo==i)%>%summarise(n=n())
  df <- popravi(df)
  drzave_odhodi[toString(i)] <- df$n

  df <- odhod %>%group_by(Leto,add=FALSE) %>% filter(Drzavljanstvo==i)%>%summarise(n = sum(Vrednost.transferja))
  df <- popravi(df)
  drzave_odhodi_vrednost[toString(i)] <- df$n
}
rownames(drzave_odhodi_vrednost) <- drzave_odhodi_vrednost[,1]
drzave_odhodi_vrednost <- drzave_odhodi_vrednost[-1]
drzave_odhodi_vrednost<- drzave_odhodi_vrednost[ , order(names(drzave_odhodi_vrednost))]
#==============================================================================================
#poglejmo skupno stevilo
drzave <- bind_rows(prihod,odhod)
drzave_imena <- unique(drzave$Drzavljanstvo)

drzave_vsi <- data.frame("Leto" = 2010:2019)

for (i in drzave_imena){
  df <- drzave %>%group_by(Leto,add=FALSE) %>% filter(Drzavljanstvo==i)%>%summarise(n=n())
  df <- popravi(df)
  drzave_vsi[toString(i)] <- df$n
}

rownames(drzave_vsi) <- drzave_vsi[,1]
drzave_vsi <- drzave_vsi[-1]
drzave_vsi<- drzave_vsi[ , order(names(drzave_vsi))]

#==============================================================================================
#transponiramo dfje za vizualizacijo

drzave_odhodi <- as.data.frame(t(drzave_odhodi))
drzave_prihodi <- as.data.frame(t(drzave_prihodi))
drzave_vsi <- as.data.frame(t(drzave_vsi))
drzave_odhodi_vrednost <- as.data.frame(t(drzave_odhodi_vrednost))
drzave_prihodi_vrednost <- as.data.frame(t(drzave_prihodi_vrednost))

drzave_vsi <- tibble::rownames_to_column(drzave_vsi, "Drzave")
colnames(drzave_vsi) <- c('Drzave',2010:2019)

drzave_prihodi <- tibble::rownames_to_column(drzave_vsi, "x")
drzave_prihodi <- drzave_prihodi[,-1]

drzave_odhodi <- drzave_odhodi[-1,]
drzave_odhodi <- tibble::rownames_to_column(drzave_odhodi, "Drzave")
colnames(drzave_odhodi) <- c('Drzave',2010:2019)

drzave_prihodi_vrednost <- tibble::rownames_to_column(drzave_prihodi_vrednost, "Drzave")
drzave_odhodi_vrednost <- tibble::rownames_to_column(drzave_odhodi_vrednost, "Drzave")

#=================================================================
#shranimo izluscene/'analizirane' podatke v CSV-je

path = "analiza/"

write.csv(drzave_odhodi,paste0(path,'drzave_odhodi.csv'), row.names = TRUE)
write.csv(drzave_prihodi,paste0(path,'drzave_prihodi.csv'), row.names = TRUE)
write.csv(drzave_vsi,paste0(path,'drzave_vsi.csv'), row.names = TRUE)
write.csv(drzave_odhodi_vrednost,paste0(path,'drzave_odhodi_vrednost.csv'), row.names = TRUE)
write.csv(drzave_prihodi_vrednost,paste0(path,'drzave_prihodi_vrednost.csv'), row.names = TRUE)
write.csv(polozaj,paste0(path,'polozaj.csv'), row.names = TRUE)
write.csv(prestopi,paste0(path,'prestopi.csv'), row.names = TRUE)


library(ggplot2)
qplot(x,y)


library(raster)
library(watershed)

neretva = stack("output/neretva.grd")
Tp = pixel_topology(neretva)

pts = as.data.frame(rasterToPoints(neretva$stream))
pts$ca = NA
nr = nrow(pts)
reaches = unique(pts$stream)
for(r in reaches) {
	i = which(pts$stream == r)
	pts$ca[i] = catchment(neretva, type="points", y = as.matrix(pts[i, 1:2]), area = TRUE, Tp = Tp)
	dn = sum(!is.na(pts$ca))
	cat(paste0(Sys.time(), "  ", dn, "/", nr, " (", round(100 * dn/nr, 0), "%)", "\r"))
}
ca = rasterFromXYZ(pts[, c('x', 'y', 'ca')])
writeRaster(ca, "output/catchment.tif", overwrite = TRUE, gdal=c("COMPRESS=DEFLATE"))


# Day 9: Smoke Basin

get_day9_input_path <- function() {
    paste(getwd(), "/2021/Day 9/Day9_input.txt", sep = "")
}

part1 <- function() {
    readings <- readLines(get_day9_input_path())

    basin_rows <- length(readings)
    basin_cols <- nchar(readings[1])
    basin <- matrix(ncol = basin_cols)[-1, ]

    for (i in seq_len(length(readings))) {
        basin <- rbind(basin, strtoi(unlist(strsplit(readings[i], ""))))
    }

    total_risk_level <- 0

    for (r in seq_len(basin_rows)) {
        for (c in seq_len(basin_cols)) {
            total_risk_level <- total_risk_level +
                calc_risk_level(basin, r, c, basin_rows, basin_cols)
        }
    }

    print(total_risk_level)
}

part2 <- function() {
    readings <- readLines(get_day9_input_path())

    basin_rows <- length(readings)
    basin_cols <- nchar(readings[1])
    basin <- matrix(ncol = basin_cols)[-1, ]
    low_points <- matrix(ncol = 2)[-1, ]
    basin_sizes <- c()

    for (i in seq_len(length(readings))) {
        basin <- rbind(basin, strtoi(unlist(strsplit(readings[i], ""))))
    }

    for (r in seq_len(basin_rows)) {
        for (c in seq_len(basin_cols)) {
            if (calc_risk_level(basin, r, c, basin_rows, basin_cols) > 0) {
                low_points <- rbind(low_points, c(r, c))
            }
        }
    }

    for (i in seq_len(length(low_points) / 2)) {
        # Sprawl from low points to make basins
        ind_basin <- get_basin_from_low_point(
                        basin,
                        low_points[i, 1],
                        low_points[i, 2],
                        basin_rows,
                        basin_cols)

        # Get size of individual basin
        ind_basin_size <- length(ind_basin) / 2
        basin_sizes <- append(basin_sizes, ind_basin_size)
    }

    basin_sizes <- sort(basin_sizes, decreasing = TRUE)

    # Multiply sizes of 3 largest basins
    print(prod(basin_sizes[1:3]))
}

calc_risk_level <- function(basin, row, col, max_row, max_col) {
    point_val <- basin[row, col]
    risk_level <- 0
    adj_point_vals <- c()

    # Up Value
    if (row > 1) {
        adj_point_vals <- append(adj_point_vals, basin[row - 1, col])
    }

    # Down Value
    if (row < max_row) {
        adj_point_vals <- append(adj_point_vals, basin[row + 1, col])
    }

    # Left Value
    if (col > 1) {
        adj_point_vals <- append(adj_point_vals, basin[row, col - 1])
    }

    # Right Value
    if (col < max_col) {
        adj_point_vals <- append(adj_point_vals, basin[row, col + 1])
    }

    if (sum(adj_point_vals > point_val) == length(adj_point_vals)) {
        risk_level <- point_val + 1
    }

    risk_level
}

get_basin_from_low_point <- function(basin, row, col, max_row, max_col) {
    basin_points <- matrix(ncol = 2)[-1, ]
    new_points <- matrix(ncol = 2)[-1, ]

    basin_points <- rbind(basin_points, c(row, col))
    new_points <- rbind(new_points, c(row, col))

    while (length(new_points) > 0) {
        adj_points <- get_adj_points(basin,
                                    new_points[1, 1],
                                    new_points[1, 2],
                                    max_row, max_col)
        new_points <- new_points[-1, ]
        new_points <- rbind(new_points)

        for (i in seq_len(length(adj_points) / 2)) {
            adj_point_r <- adj_points[i, 1]
            adj_point_c <- adj_points[i, 2]
            point_val <- basin[adj_point_r, adj_point_c]
            if (point_val < 9) {
                match <- FALSE
                for (p in seq_len(length(basin_points) / 2)) {
                    match <- (basin_points[p, 1] == adj_point_r &&
                                basin_points[p, 2] == adj_point_c)
                    if (match) break
                }

                if (!match) {
                    basin_points <- rbind(basin_points,
                                        c(adj_point_r, adj_point_c))
                    new_points <- rbind(new_points,
                                        c(adj_point_r, adj_point_c))
                }
            }
        }
    }
    basin_points
}

get_adj_points <- function(basin, row, col, max_row, max_col) {
    adj_points <- matrix(ncol = 2)[-1, ]

    # Up Value
    if (row > 1) {
        adj_points <- rbind(adj_points, c(row - 1, col))
    }

    # Down Value
    if (row < max_row) {
        adj_points <- rbind(adj_points, c(row + 1, col))
    }

    # Left Value
    if (col > 1) {
        adj_points <- rbind(adj_points, c(row, col - 1))
    }

    # Right Value
    if (col < max_col) {
        adj_points <- rbind(adj_points, c(row, col + 1))
    }

    adj_points
}

part1()
part2()


dice_values =  c("d4", "d6", "d8", "d10", "d12", "d20", "d100")

roll = function(n, d) sum(sample(d, size=n, replace=TRUE))

output$main_dice <- renderUI({
  mainPanel(
    tabsetPanel(
      tabPanel("Basic", uiOutput("dice_roller_basic_ui")),
      # tabPanel("Advanced", uiOutput("dice_roller_advanced_ui")),
      tabPanel("Scatter", uiOutput("dice_roller_scatter_ui"))
    )
  )
})

output$dice_roller_basic_ui <- renderUI({
  list(
    sidebarLayout(
      sidebarPanel(
        radioButtons(inputId="dice_d", label="Die", dice_values, selected="d20", inline=FALSE),
        checkboxInput(inputId="dice_accum", label="Accumulate?", value = FALSE, width = NULL),

        actionButton("dice_button_basic_roll", "Roll!")
      ),

      mainPanel(
        renderUI({
          localstate$dice_roller_basic
        })
      )
    )
  )
})

dice_roller_basic = function(input)
{
  observeEvent(input$dice_button_basic_roll, {
    accum = input$dice_accum

    d = as.integer(sub(input$dice_d, pattern="^d", replacement=""))
    res = roll(1, d)

    if (accum)
    {
      old = localstate$dice_roller_basic_accum
      localstate$dice_roller_basic_accum = c(old, res)
      res = sum(old) + res

      resf = paste(
        paste(cumsum(old), collapse="
"),
        "
",
        paste("", res, ""))
    }
    else
    {
      localstate$dice_roller_basic_accum = NULL
      if (!accum && d == 20 && (res == 1 || res == 20))
        resf = paste("", res, "")
      else
        resf = paste("", res, "")
    }

    localstate$dice_roller_basic = HTML(resf)
  })

  invisible()
}

output$dice_roller_advanced_ui <- renderUI({
  list(
    sidebarLayout(
      sidebarPanel(
        radioButtons(inputId="dice_advanced_d", label="Die", dice_values, selected="d20", inline=FALSE),

        actionButton("dice_button_clear", "Clear"),
        actionButton("dice_button_add", "Add"),
        actionButton("dice_button_roll", "Roll!")
      ),

      mainPanel(
        renderUI({
          localstate$dice_roller_advanced
        })
      )
    )
  )
})

init_dice = function()
{
  bins = sapply(dice_values, function(.) 0L)
  names(bins) = dice_values

  localstate$dice_bins = bins
}

reset_dice = function()
{
  for (i in 1:length(localstate$dice_bins))
    localstate$dice_bins[i] = 0L

  invisible()
}

dice_roller_advanced = function(input)
{
  observeEvent(input$dice_button_add, {
    die = input$dice_advanced_d
    localstate$dice_bins[die] = localstate$dice_bins[die] + 1L

    localstate$dice_roller_advanced = HTML(paste(localstate$dice_bins, collapse=" "))
  })

  observeEvent(input$dice_button_clear, {
    init_dice()
    localstate$dice_roller_advanced = HTML("")
  })

  observeEvent(input$dice_button_roll, {
    res = ""
    tot = 0L
    bins = localstate$dice_bins
    first = TRUE

    for (i in 1:length(bins))
    {
      if (bins[i] > 0)
      {
        n = bins[i]
        d = as.integer(gsub(names(bins[i]), pattern="^d", replacement=""))

        val = roll(n, d)

        if (first)
        {
          res = paste(res, val)
          first = FALSE
        }
        else
          res = paste(res, "+", val)
      }
    }

    reset_dice()
    localstate$dice_roller_advanced = HTML(res)
  })

  invisible()
}

output$dice_roller_scatter_ui <- renderUI({
  list(
    sidebarLayout(
      sidebarPanel(
        actionButton("dice_button_scatter_roll", "Roll!")
      ),

      mainPanel(
        renderPlot({
          localstate$dice_roller_scatter
        })
      )
    )
  )
})

dice_roller_scatter = function(input)
{
  observeEvent(input$dice_button_scatter_roll, {
    localstate$dice_roller_scatter = gmhelper:::roll_scatter()
  })

  invisible()
}


####################################################################################
#
# Mark Cembrowski, Janelia Research Campus, April 8 2015
#
# This script looks for the number of mossy cell-enriched transcripts relative
# to neighbouring DG GCs and CA3 PCs.
#
####################################################################################

ca4EnrichVsFold <- function(fpkmThres=10){

	theFolds <- c(2:10)
	df <- as.data.frame(matrix(nrow=theFolds,ncol=3))

	theMask <- setdiff(colnames(fpkmPoolMat),c('dg_d','ca4','ca3_d'))

	for (ii in 1:length(theFolds)){
		numDgEnrich <- length(enrichedGenes('dg_d',fpkmThres=fpkmThres,
			foldThres=theFolds[ii],avgPass=T,mask=theMask))
		numCa4Enrich <- length(enrichedGenes('ca4',fpkmThres=fpkmThres,
			foldThres=theFolds[ii],avgPass=T,mask=theMask))
		numCa3Enrich <- length(enrichedGenes('ca3_d',fpkmThres=fpkmThres,
			foldThres=theFolds[ii],avgPass=T,mask=theMask))
		df[ii,] <- c(numDgEnrich,numCa4Enrich,numCa3Enrich)
	}

	df <- cbind(theFolds,df)
	colnames(df) <- c('theFolds','dg','ca4','ca3')

	# Plot.
	gg <- ggplot(df,aes(x=theFolds))
	gg <- gg + geom_line(aes(y=dg),colour='red')
	gg <- gg + geom_line(aes(y=ca4),colour='magenta')
	gg <- gg + geom_line(aes(y=ca3),colour='green')
	gg <- gg + theme_bw()
	gg <- gg + expand_limits(y=0)
	gg <- gg + xlab('Fold difference') + ylab('Number of genes')
	print(gg)

	invisible(df)
}


\name{from_igraph}
\alias{from_igraph}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{
  Convert an igraph object to a PAFit_net object
}
\description{
  This function converts an \code{igraph} object (of package \pkg{igraph}) to a \code{PAFit_net} object.
}
\usage{
  from_igraph(net)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
  \item{net}{
    An object of class \code{igraph}.
  }
}

\value{
  The function returns a \code{PAFit_net} object.
}

\author{
  Thong Pham \email{thongphamthe@gmail.com}
}

\examples{
  library("PAFit")
  # a network from Bianconi-Barabasi model
  net          <- generate_BB(N = 50 , m = 10 , s = 10)
  igraph_graph <- to_igraph(net)
  back         <- from_igraph(igraph_graph)
}


score <- function(input) {
    if ((input[4]) <= (0.75)) {
        var0 <- c(1.0, 0.0, 0.0)
    } else {
        if ((input[3]) <= (4.75)) {
            var0 <- c(0.0, 1.0, 0.0)
        } else {
            if ((input[3]) <= (5.049999952316284)) {
                if ((input[4]) <= (1.75)) {
                    var0 <- c(0.0, 0.8333333333333334, 0.16666666666666666)
                } else {
                    var0 <- c(0.0, 0.08333333333333333, 0.9166666666666666)
                }
            } else {
                var0 <- c(0.0, 0.0, 1.0)
            }
        }
    }
    if ((input[4]) <= (0.800000011920929)) {
        var1 <- c(1.0, 0.0, 0.0)
    } else {
        if ((input[1]) <= (6.25)) {
            if ((input[3]) <= (4.8500001430511475)) {
                var1 <- c(0.0, 0.9487179487179487, 0.05128205128205128)
            } else {
                var1 <- c(0.0, 0.0, 1.0)
            }
        } else {
            if ((input[4]) <= (1.550000011920929)) {
                var1 <- c(0.0, 0.8333333333333334, 0.16666666666666666)
            } else {
                var1 <- c(0.0, 0.02564102564102564, 0.9743589743589743)
            }
        }
    }
    return(((var0) + (var1)) * (0.5))
}


rhyper_actual <- function(nn, m, n, k=5) {
  nn = as.numeric(nn)
  m = as.numeric(m)
  n = as.numeric(n)
  k = as.numeric(k)

  rhyper.list <- rhyper(nn, m, n, k)
  freq.table <- table(rhyper.list)
  df.table <- as.data.frame(freq.table)

  return(list(df.table$rhyper.list, df.table$Freq, df.table$Freq / (m + k), rhyper.list))
}

do.call(rhyper_actual, input)


library(RcppDE)
library(data.table)
library(dHRUM)
dtHrus <- as.data.table(read.csv("../dHRUM/Calibrations/Amalie/distributedModel/Soils_RVK_VVK.csv"))
dtHrus[Povodi=='BP',sum(Area)]

SoilBP <- dtHrus[Povodi=='BP',]

SoilBP[RVK >0, meanRVK :=mean(RVK)]
SoilBP[VVK>0, meanVVK :=mean(VVK)]

mVVK <- SoilBP[id==4,meanVVK]
mRVK <- SoilBP[id==4,meanRVK]

SoilBP[is.na(meanVVK), meanVVK :=mVVK]
SoilBP[is.na(meanRVK), meanRVK :=mRVK]

SoilBP[RVK ==0, RVK :=mRVK]
SoilBP[VVK ==0, VVK :=mVVK]

NhrusBP <- nrow(SoilBP)

dny=c(30,60,90,120,150,180,210,240,270,300,330,355,364)
p_OBS=dny/365.25

# BP 96.68961 (1.736-2.430446)
RaBP = 96# odhad Martin Hanel
QmBP = c(26, 18, 14, 12, 10, 8.0, 7.0, 6.0, 4.5, 3.5, 2.5, 1.0, 0.5)
A=sum(SoilBP$Area)# plocha BP
RmBP = QmBP * (3600*24) / A #CHMU ZHU 4.42 v datech SoilBP 4.41

nHrus <- NhrusBP
Areas <- SoilBP$Area
IdsHrus <- SoilBP$id
dhrusBP <- initdHruModel(nHrus,Areas,IdsHrus)

filname2 = "../dHRUM/Calibrations/Amalie/indata/BP_1960_01_01.txt"
setPTInputsToAlldHrusFromFile(dHRUM_ptr = dhrusBP, filname2)
calcPetToAllHrus(dHRUM_ptr = dhrusBP,50.1,"Hamon")

# ParDF = data.frame( B_SOIL = 1.6, C_MAX = 100, B_EVAP = 2,  KS = 0.1, KF = 0.2, ADIV = 0.3, CDIV = 0.03,
#                     SDIV = 0.03, CAN_ST = 2, STEM_ST = 2, CSDIV = 0.3, TETR = 5, DDFA = 0.5, TMEL = 0, RETCAP = 10 )
#
# nParIhru <- ncol(ParDF)
#
# parsvec=as.numeric(ParDF[1,])
# for(i in 1:(nHrus-1)){
#   ParDF <- rbind(ParDF,parsvec)
# }
# ParDF$C_MAX <- SoilBP$RVK

ParDFup1 = data.frame( B_SOIL = 2., C_MAX = 800, B_EVAP = 2,  KS = 0.4, KF = 0.7, ADIV = 0.9, CDIV = 0.1,
                       SDIV = 0.05, CAN_ST = 2., STEM_ST = 2., CSDIV = 0.8, TETR = 4, DDFA = 0.8, TMEL = 0.0,
                       RETCAP = 2 )

parsvec=as.numeric(ParDFup1[1,])
for(i in 1:(nHrus-1)){
  ParDFup1 <- rbind(ParDFup1,parsvec)
}
# ParDFup1$C_MAX <- SoilBP$RVK
# ParDFup1$C_MAX <- SoilBP$VVK

ParDFlow1 = data.frame( B_SOIL = 0.6, C_MAX = 10, B_EVAP = 0.6,  KS = 0.002, KF = 0.2, ADIV = 0.01, CDIV = 0.05,
                        SDIV = 0.01, CAN_ST = 0.1, STEM_ST = 0.1, CSDIV = 0.01, TETR = 0, DDFA = 0.08, TMEL = -10.0,
                        RETCAP = 1 )

parsvec=as.numeric(ParDFlow1[1,])
for(i in 1:(nHrus-1)){
  ParDFlow1 <- rbind(ParDFlow1,parsvec)
}

ParDFlow1$C_MAX <- SoilBP$RVK
ParDFup1$C_MAX <- SoilBP$RVK + SoilBP$VVK

ParNams <- names(ParDFlow1)

nParIhru <- ncol(ParDFlow1)

length(as.numeric(as.matrix(ParDFlow1)))
length(as.numeric(as.matrix(ParDFup1)))

mae = function(myPar){
  newmat <- as.data.frame(matrix(myPar,nrow = nHrus, ncol = nParIhru))
  names(newmat) <- ParNams
  setParsToDistdHRUM(dhrusBP, newmat, FALSE)
  # # for( i in 1:1000){
  calcHBInAlldHrus(dHRUM_ptr = dhrusBP)
  gatherHBdata(dHRUM_ptr = dhrusBP)
  # # }
  dta <- getOutput(dHRUM_ptr = dhrusBP)
  dF <-data.frame(dta$outDta)
  names(dF) <- dta$VarsNams
  simRM=as.numeric(quantile(dF$TOTR,probs=(1-p_OBS), na.rm = TRUE))
  mymae =as.double(sum(abs(simRM - RmBP)))
  # # mymae=NA
  # if(is.na(mymae)) mymae = 9999
  # (return as.double(mymae))
}

itermaxW=2
decntr<-DEoptim.control(VTR = 0, strategy = 2, bs = FALSE, NP = 5550,
                        itermax = itermaxW, CR = 0.25, F = 0.7, trace = TRUE,
                        initialpop = NULL, storepopfrom = itermaxW + 1,
                        storepopfreq = 1, p = 0.2, c = 0, reltol = sqrt(.Machine$double.eps),
                        steptol = itermaxW)

u=DEoptim( lower=as.numeric(as.matrix(ParDFlow1)),
           upper=as.numeric(as.matrix(ParDFup1)), fn=mae, control = decntr)

# u$optim$bestmem

ParBestVec <- as.numeric(u$optim$bestmem)
ParBestDF <- as.data.frame(matrix(ParBestVec,nrow = nHrus, ncol = nParIhru))
names(ParBestDF) <- ParNams
saveRDS(ParBestDF,file ="./Calibrations/Amalie/Params/Amalie/distModelOrigParams/BP.rds")

parsDF <- readRDS(file ="./Calibrations/Amalie/Params/Amalie/distModelOrigParams/BP.rds")
setParsToDistdHRUM(dhrusBP, parsDF, TRUE)
# # for( i in 1:1000){
calcHBInAlldHrus(dHRUM_ptr = dhrusBP)
gatherHBdata(dHRUM_ptr = dhrusBP)
# # }
dta <- getOutput(dHRUM_ptr = dhrusBP)
dF <-data.frame(dta$outDta)
names(dF) <- dta$VarsNams
plot(dF$TOTR, type='l')
plot(dF$BASF, type='l')
plot(dF$DIRR, type='l')
plot(dF$SOIS, type='l')
plot(dF$GROS, type='l')
plot(dF$SNOW, type='l')
simBest=as.numeric(quantile(dF$TOTR,probs=(1-p_OBS), na.rm = TRUE))
plot(RmBP, simBest)

plot(p_OBS,RmBP, pch=19, ylim=range(c(RmBP,simBest)),
     main = paste0("Brejlský potok - kalibrace dHRUM - ",nHrus," HRU jednotek"),xlab="P(Qm)", ylab="Qm [mm/den]")
points(p_OBS,simBest,col="red",pch=19)
grid()

ParsOrig <- parsDF
dtaORIG <- dF

# surface retention
ParsCC_SURstor <- ParsOrig
ParsCC_SURstor$RETCAP <- ParsCC_SURstor$RETCAP * 1.30
setParsToDistdHRUM(dhrusBP, ParsCC_SURstor, TRUE)
# # for( i in 1:1000){
calcHBInAlldHrus(dHRUM_ptr = dhrusBP)
gatherHBdata(dHRUM_ptr = dhrusBP)
# # }
dtaSURSTCC <- getOutput(dHRUM_ptr = dhrusBP)
dFsurCC <-data.frame(dtaSURSTCC$outDta)
names(dFsurCC) <- dta$VarsNams

dFsurCC <-  as.data.table(dFsurCC)
dtaORIG <-  as.data.table(dtaORIG)

is.data.table(dFsurCC)
dFsurCC[,DTM:= as.Date(paste(YEAR,MONTH,DAY,sep="-"))]

ccOUt <- dFsurCC[, .(SURS = mean(SURS),SOIS =mean(SOIS)), by=.(MONTH)]
origOut <- dtaORIG[, .(SURS =mean(SURS),SOIS =mean(SOIS)), by=.(MONTH)]

mean(ccOUt$SURS) - mean(origOut$SURS)
mean(ccOUt$SOIS) - mean(origOut$SOIS)

cmax_change <- seq(from = 0.5,to =1.5, by=0.05)
soil_change <-c()
gs_change <- c()
SMAX <-c()
BF <- c()
# soil max capacity
for(i in 1:length(cmax_change)){
  ParsCC_SMAXstor <- ParsOrig
  ParsCC_SMAXstor$C_MAX <- ParsCC_SURstor$C_MAX * cmax_change[i]
  setParsToDistdHRUM(dhrusBP, ParsCC_SMAXstor, PrintPars = FALSE)
  # # for( i in 1:1000){
  calcHBInAlldHrus(dHRUM_ptr = dhrusBP)
  gatherHBdata(dHRUM_ptr = dhrusBP)
  # # }
  dtaSOILTCC <- getOutput(dHRUM_ptr = dhrusBP)
  dFsoilCC <-data.frame(dtaSOILTCC$outDta)
  names(dFsoilCC) <- dta$VarsNams
  dFsoilCC <-  as.data.table(dFsoilCC)
  dtaORIG <-  as.data.table(dtaORIG)
  dFsoilCC[,DTM:= as.Date(paste(YEAR,MONTH,DAY,sep="-"))]
  ccOUt <- dFsoilCC[, .(GRS = mean(GROS),SOIS =mean(SOIS),BF = sum(BASF)), by=.(MONTH)]
  origOut <- dtaORIG[, .(GRS =mean(GROS),SOIS =mean(SOIS),BF = sum(BASF)), by=.(MONTH)]
  gs_change[i] <- mean(ccOUt$GRS) - mean(origOut$GRS)
  soil_change[i] <- mean(ccOUt$SOIS) - mean(origOut$SOIS)
  SMAX[i] <- mean(ParsCC_SMAXstor$C_MAX / (ParsCC_SMAXstor$B_SOIL +1))
  BF[i] <- mean(ccOUt$BF) - mean(origOut$BF)
}

plot(cmax_change,SMAX)
plot(cmax_change,gs_change)
plot(cmax_change,soil_change)
plot(cmax_change,BF)

plot(SMAX,gs_change)
plot(SMAX,soil_change)
plot(SMAX,BF)


library(Seurat)
library(ggplot2)

#devtools::install_github("choisy/cutoff")
#install.packages("bbmle")
library(choisycutoff)
library(zoo)
library(reshape2)
library(gridExtra)
library(ggExtra)

rplot<-function(object, features, assay, identName, withAllCells=FALSE){
  DefaultAssay(object = object) <- assay
  data <- FetchData(object = object, vars = c(features, identName))
  mdata<-melt(data, id.vars=identName)
  if (withAllCells) {
    mdata2<-mdata
    mdata2[,1] = "All cells"
    mdata<-rbind(mdata, mdata2)
  }
  gfinal=list()
  for(feature in features){
    ddata=mdata[mdata$variable==feature,]
    g<-ggplot(ddata, aes_string(x="value")) +
      geom_histogram(aes(y=..density..), bins=50, colour="black", fill="white", position="identity") +
      geom_density(color="red") +
      facet_grid(reformulate(".", identName), scale="free_y") +
      xlab(feature) + theme_bw() + theme(strip.background=element_rect(colour="black", fill=NA),
                                         strip.text = element_text(size = 24),
                                         axis.text=element_text(size=18),
                                         axis.title=element_text(size=24))
    if (feature != features[1]){
      g = g + ylab("")
    }
    gfinal = append(gfinal, list(g))
  }
  grid.arrange(grobs=gfinal, nrow=1)
}

my_startval <- function(values,D1="normal",D2="normal") {
  den <- tryCatch(
    expr = {
      res=density(values, bw="SJ")
      return(res)
    },
    error = function(e){
      res=density(values)
      return(res)
    }
  )
  w=1
  x=den$x
  y=den$y
  y.smooth=den$y
  n <- length(y.smooth)
  y.max <- rollapply(zoo(y.smooth), 2*w+1, max, align="center")
  delta <- y.max - y.smooth[-c(1:w, n+1-1:w)]
  i.max <- which(delta <= 0) + w
  res=data.frame(x=x[i.max], i=i.max, y=y[i.max])
  res=res[order(res$y, decreasing = T),]
  if(nrow(res)>2){
    #the highest peaks should be the negative one, positive one is always in the right side.
    res=res[res$x>=res$x[1],]

    if(nrow(res)>2){
      res=res[1:2,]
    }
  }
  res=res[order(res$x),]

  xx=x[x>min(res$x) & x<max(res$x)]
  yy=y[x>min(res$x) & x<max(res$x)]
  yy.min=min(yy)
  ii.min=which(yy==yy.min)
  thresh=xx[ii.min]

  sel <- values<thresh
  data1 <- values[sel]
  data2 <- values[!sel]
  lambda <- length(data1)/length(values)
  param1 <- MASS::fitdistr(data1,D1)$est
  param2 <- MASS::fitdistr(data2,D2)$est
  out <- c(param1,param2,lambda)
  names(out) <- c("mu1","sigma1","mu2","sigma2","lambda")
  return(out)
}

t=1e-64
my_em<-function(values, data_name="em", D1="normal", D2="normal", t=1e-64){
  start <- as.list(my_startval(values, D1, D2))

  D1b <- choisycutoff:::hash[[D1]]
  D2b <- choisycutoff:::hash[[D2]]
  lambda0 <- 0
  with(start, {
    while (abs(lambda0 - mean(lambda)) > t) {
      lambda <- mean(lambda)
      lambda0 <- lambda
      distr1 <- lambda * D1b(values, mu1, sigma1)
      distr2 <- (1 - lambda) * D2b(values, mu2, sigma2)
      lambda <- distr1/(distr1 + distr2)
      mLL2 <- function(mu1, sigma1, mu2, sigma2) return(choisycutoff:::mLL(mu1,
                                                                     sigma1, mu2, sigma2, lambda, values, D1b, D2b))
      start <- as.list(log(c(mu1 = mu1, sigma1 = sigma1,
                             mu2 = mu2, sigma2 = sigma2)))
      out <- bbmle::mle2(mLL2, start, "Nelder-Mead")
      coef <- out@coef
      coef_n <- names(coef)
      names(coef) <- NULL
      for (i in 1:4) assign(coef_n[i], exp(coef[i]))
    }
    out <- list(lambda = lambda, param = exp(out@coef), D1 = D1,
                D2 = D2, deviance = out@min, data = values, data_name = data_name,
                out = out, t = t)
    class(out) <- "em"
    return(out)
  })
}

my_cutoff<-function (object, t = 1e-64, nb = 10, distr = 2, type1 = 0.05, level = 0.95)
{
  coef <- object$out@coef
  the_names <- names(coef)
  coef <- exp(mc2d::rmultinormal(nb, coef, as.vector(object$out@vcov)))
  coef <- as.list(data.frame(t(coef)))
  coef <- lapply(coef, function(x) {
      names(x) <- the_names
      return(as.list(x))
  })
  out <- sapply(coef, function(x) choisycutoff:::lci0(x, mean(object$lambda),
      choisycutoff:::hash[[object$D1]], choisycutoff:::hash[[object$D2]], object$data, t))
  lambda <- rnorm(nb, out[1, ], out[2, ])
  coef <- sapply(coef, function(x) unlist(x))
  the_names <- c(rownames(coef), "lambda")
  coef <- rbind(coef, lambda)
  coef <- lapply(as.data.frame(coef), function(x) {
      names(x) <- the_names
      return(as.list(x))
  })
  out <- sapply(coef, function(x) with(x, choisycutoff:::cutoff0(mu1,
      sigma1, mu2, sigma2, lambda, object$D1, object$D2, distr, type1)))
  out <- MASS::fitdistr(out, "normal")
  the_mean <- out$estimate["mean"]
  level <- (1 - level)/2
  level <- c(level, 1 - level)
  ci <- the_mean + qt(level, Inf) * out$sd["mean"]
  out <- c(the_mean, ci)
  names(out) <- c("Estimate", paste(100 * level, "%"))
  return(out)
}

get_cutoff<-function(values, prefix){
  my_out <- my_em(values,"normal","normal")
  cut_off <- my_cutoff(my_out)
  png(paste0(prefix, ".cutoff.png"), width=2000, height=1600, res=300)
  hist(values,200,F,xlab="concentration",ylab="density", main=NULL,col="grey")
  lines(density(values),lwd=1.5,col="blue")
  lines(my_out,lwd=1.5,col="red")
  abline(v=cut_off[1],lwd=1.5,col="brown")
  dev.off()
  return(cut_off[1])
}

split<-function(h5file, output_prefix, hashtag_regex=NA) {
  if(grepl('.rds$', h5file)){
    meta<-readRDS(h5file)
    meta<-as.matrix(meta)
    #tag number should less than cell number
    if(ncol(meta) < nrow(meta)){
      meta=t(meta)
    }
  }else{
    sdata<-Read10X_h5(h5file)
    meta<-sdata[[2]]
    meta<-as.matrix(meta)
  }
  mat<-meta
  write.csv(mat, file=paste0(output_prefix, ".alltags.exp.csv"))

  cat("All tags: ", paste(rownames(mat), collapse=","), "\n")

  if (!is.na(hashtag_regex)) {
    htos<-mat[grepl(hashtag_regex, rownames(mat)),]
    if (nrow(htos) == 0){
      stop(paste0("Cannot find hashtag based on regex ", hashtag_regex, " for tags ", paste(rownames(mat), collapse=",")))
    }
    cat("All hash tags matched regex: ", paste(rownames(htos), collapse=","), "\n")
  }else{
    htos<-mat
  }
  rownames(htos)<-gsub("^TotalSeqC_", "", rownames(htos))
  rownames(htos)<-gsub("^TotalSeq_", "", rownames(htos))
  rownames(htos)<-gsub('.TotalSeqC$', "", rownames(htos))

  empty_cell_sum<-apply(htos, 2, sum)
  htos<-htos[,empty_cell_sum > 0]

  write.csv(htos, file=paste0(output_prefix, ".hto.exp.csv"))

  pbmc.hashtag <- CreateSeuratObject(counts = htos, assay="HTO")
  # Normalize HTO data, here we use centered log-ratio (CLR) transformation
  pbmc.hashtag <- NormalizeData(pbmc.hashtag, assay = "HTO", normalization.method = "CLR")
  DefaultAssay(object = pbmc.hashtag) <- "HTO"

  #Idents(pbmc.hashtag) <- "HTO_classification"
  tagnames=rownames(pbmc.hashtag[["HTO"]])

  width=max(10, length(tagnames) * 5)
  pdf(paste0(output_prefix, ".tag.dist.pdf"), width=width, height=6)
  rplot(pbmc.hashtag, assay="HTO", features = tagnames, identName="orig.ident")
  dev.off()

  data <- FetchData(object=pbmc.hashtag, vars=tagnames)
  colnames(data)<-gsub("hto_","",colnames(data))

  tagname=tagnames[1]
  for (tagname in tagnames) {
    values=data[,tagname]
    values=values[values>0]
    cat(paste0("get cutoff of ", tagname, " ...\n"))
    cutoff=get_cutoff(values, paste0(output_prefix, "_", tagname))
    data[,paste0(tagname,"_pos")] = ifelse(data[,tagname]>cutoff, tagname, "Negative")
  }

  cat(paste0("get classification ...\n"))
  class_names=paste0(tagnames, "_pos")
  data$HTO_classification=unlist(apply(data, 1, function(x){
    xx=unique(x[class_names])
    if (length(xx) > 1){
      xx = xx[xx != "Negative"]
      if (length(xx) > 1) {
        return("Doublet")
      }
    }
    return(xx)
  }))

  data$HTO_classification.global=unlist(apply(data, 1, function(x){
    xx=unique(x[class_names])
    if (length(xx) > 1){
      xx = xx[xx != "Negative"]
      if (length(xx) > 1) {
        return("Doublet")
      }else{
        return("Singlet")
      }
    }
    return("Negative")
  }))

  pbmc.hashtag[["HTO_classification"]] = data$HTO_classification
  pbmc.hashtag[["HTO_classification.global"]] = data$HTO_classification.global

  width=max(1600, length(tagnames) * 600)
  height=1400

  png(paste0(output_prefix, ".class.dist.png"), width=width, height=height)
  rplot(pbmc.hashtag, assay = "HTO", features = tagnames, identName="HTO_classification")
  dev.off()

  if (length(tagnames) == 2) {
    pdf(paste0(output_prefix, ".class.point.png"), width=width, height=height)
    print(FeatureScatter(object = pbmc.hashtag, feature1 = tagnames[1], feature2 = tagnames[2],group.by="HTO_classification"))
    dev.off()
  }

  tmat=data.frame(t(htos))
  tmat$HTO = obj$HTO_classification
  tmat$HTO.global = obj$HTO_classification.global
  write.csv(tmat, paste0(output_prefix, ".csv"))

  VariableFeatures(pbmc.hashtag)<-rownames(pbmc.hashtag)
  pbmc.hashtag<-ScaleData(pbmc.hashtag)
  pbmc.hashtag<-RunUMAP(pbmc.hashtag, features=rownames(pbmc.hashtag))

  png(paste0(output_prefix, ".umap.class.png"), width=1000, height=800)
  g<-DimPlot(pbmc.hashtag, reduction = "umap", group.by="HTO_classification")
  print(g)
  dev.off()

  png(paste0(output_prefix, ".umap.tag.png"), width=1600, height=1600)
  g<-FeaturePlot(pbmc.hashtag, features=tagnames, reduction = "umap")
  print(g)
  dev.off()

  hto_names=unique(pbmc.hashtag$HTO_classification)
  a_hto_names=hto_names[!(hto_names %in% c("Doublet","Negative"))]
  a_hto_names=a_hto_names[order(a_hto_names)]
  hto_names=c(a_hto_names, "Negative", "Doublet")
  cols=rep("gray", length(hto_names))
  names(cols)=hto_names
  cols[['Negative']]="blue"
  cols[["Doublet"]]="red"

  pbmc.hashtag$HTO_classification=factor(pbmc.hashtag$HTO_classification, levels=hto_names)
  png(paste0(output_prefix, ".umap.all.png"), width=1000, height=800)
  g<-DimPlot(pbmc.hashtag, reduction = "umap", label=T, group.by="HTO_classification", order=c("Negative", "Doublet"))+
    scale_color_manual(values=cols)
  print(g)
  dev.off()
}

args = commandArgs(trailingOnly=TRUE)

if (length(args) == 0) {
  h5file = "/data/cqs/seurat_data/hto12_hto_valid.rds"
  output_prefix = "/scratch/cqs/shengq2/papers/20210703_scrna_hto/hto_samples_cutoff/result/hto12/hto12.HTO"
  hashtag_regex='Hashtag|TotalSeqC_|C025|Benign|Tumor|HTO|HEK|THP|K562|KG1'
}else{
  h5file = args[1]
  output_prefix = args[2]
  hashtag_regex = args[3]
}

print(paste0("h5file=", h5file))
print(paste0("output_prefix=", output_prefix))
print(paste0("hashtag_regex=", hashtag_regex))

split(h5file, output_prefix, hashtag_regex)


#####################################################################################
#                                                                                #
# TITLE: Building Health State Transition Models in R: Chapter 3.5                  #
#                                                                                #
# DESCRIPTION: Here we use the 'for' function in arrays                             #
#                                                                                #
# AUTHOR: Ian Cromwell                                                              #
#                                                                                #
# DATE: September, 2014                                                             #
#                                                                                #
#####################################################################################

test <- array(0, dim=c(10,1,1))

start <- 1
finish <- 10

for (x in start:finish)
  {
  test[x,,] <- x^2
  }

test2 <- array(0, dim=c(10,1,1))
start2 <- 3
finish2 <- 7
for (x in start2:finish2)
{
  test2[x,,] <- x^2
}

test3 <- array(0, dim=c(10,1,1))
start3 <- 4
finish3 <- 9
for (x in start3:finish3)
{
  test3[x,,] <- 1 + test3[(x-1),,]^2
}


#Open psv file
fil<-file(paste(data.path,"sms.psv",sep=""), "rb")

#Read dimension of vector = number of parameters
dim<-readBin(fil,integer(),1)

#read values, assume a very high number of observations
psv<-readBin(fil, numeric(), 1E6)

# calc number of MCMC set
dim2<-length(psv)/dim
#reformat
psv<-matrix(psv,  dim,dim2)

par(mfcol=c(3,4))

for (i in seq(590,601)) plot(density(psv[i,]),main=paste("par:",i))

for (i in seq(590,601)) plot((psv[i,]),main=paste("par:",i),type='l',ylab='')


##feature importance

gbmcihi <- h2o.loadModel("./hypeTune_results/top_gbm_cihi_models_cv/gbm_cihi_cv_1")

h2o.varimp(gbmcihi)
h2o.varimp_plot(gbmcihi, num_of_features = 30)

png("./varImport/CIHI_varimp.png", width = 8, height = 10, units = "in", res = 300)
h2o.varimp(gbmcihi) %>%
as.data.frame() %>%
select(variable, scaled_importance) %>%
ggplot(aes(x = reorder(variable, scaled_importance),
 weight = scaled_importance)) +
geom_bar(fill = "dodgerblue1") +
#scale_fill_discrete(name = "variable name")+
theme_classic() + ggtitle("Variable Importance: GBM in-hospital model") +
xlab("") + ylab("scaled importance") +
coord_flip()
dev.off()

####top 20 version with variable names
 [1] "acutelos"          "admambul"          "main_PhysInj_1L"   "age_grp"
 [5] "scu"               "cacsitcnt"         "cacsit1_grp3"      "triage"
 [9] "main_Zfactors_1L"  "prv_grp"           "main_MentBehav_1L" "patserv_34"
[13] "frail_grp"         "all_Cachx_3L"      "dementia_main"     "patserv_12"
[17] "rural"             "patserv_17"        "readm_90d"         "weightloss"

name_ <- c("Acute LOS", "ED arrival method", "Physical Inj. main diagnosis", "Age",
"Special care unit", "ED investigative technology count", "Investigative technology type", "Triage score",
"Z codes main diagnosis", "ED main health provider", "Mental/behavioural main diagnosis", "Orthopaedic surgery in hospital",
"Frailty index", "Cachexia diagnosis", "Dementia  main diagnosis", "Cardiology service in hosptial",
"Rural/urban", "Neurology service in hospital", "90-day readmission", "Weightloss comorbidity")

png("./varImport/Top20_CIHI_varimp.png", width = 8, height = 10, units = "in", res = 300)
h2o.varimp(gbmcihi) %>%
as.data.frame() %>%
select(variable, scaled_importance) %>%
head(20) %>%
mutate(varName = name_) %>%
ggplot(aes(x = reorder(varName, scaled_importance),
 weight = scaled_importance)) +
geom_bar(fill = "dodgerblue1") +
#scale_fill_discrete(name = "variable name")+
theme_classic() + ggtitle("Top 20 Predictors: GBM in-hospital model") +
xlab("") + ylab("scaled importance") +
coord_flip()
dev.off()

#################ED models

gbmed <- h2o.loadModel("./hypeTune_results/top_gbm_ed_models_cv/GBM_model_R_1626226288660_14594")

h2o.varimp(gbmed)
h2o.varimp_plot(gbmed, num_of_features = 30)

png("./varImport/ED_varimp.png", width = 8, height = 10, units = "in", res = 300)
h2o.varimp(gbmed) %>%
as.data.frame() %>%
select(variable, scaled_importance) %>%
ggplot(aes(x = reorder(variable, scaled_importance),
 weight = scaled_importance)) +
geom_bar(fill = "dodgerblue1") +
#scale_fill_discrete(name = "variable name")+
theme_classic() + ggtitle("Variable Importance: GBM Emergency Department model") +
xlab("") + ylab("scaled importance") +
coord_flip()
dev.off()

name__ <- c("ED arrival method", "Physical Inj. main diagnosis", "Age",
"ED investigative technology count", "Investigative technology type", "Triage score",
"Mental/behavioural main diagnosis", "Frailty index",
"Income quintiles", "Ethnic concentration quintiles", "Residential Instability quintiles",
"Z codes main diagnosis", "Charlson Index", "Waiting time from triage to first assessment",
"Dependency quintiles", "Time from first asses. to discharge from ED",
"Cachexia diagnosis", "Musculoskeletal diseases as main diagnosis", "Dementia main diagnosis",
"Weightloss comorbidity")

png("./varImport/Top20_ED_varimp.png", width = 8, height = 10, units = "in", res = 300)
h2o.varimp(gbmed) %>%
as.data.frame() %>%
select(variable, scaled_importance) %>%
head(20) %>%
mutate(varName = name__) %>%
ggplot(aes(x = reorder(varName, scaled_importance),
 weight = scaled_importance)) +
geom_bar(fill = "dodgerblue1") +
#scale_fill_discrete(name = "variable name")+
theme_classic() + ggtitle("Top 20 Predictors: GBM Emergency Department model") +
xlab("") + ylab("scaled importance") +
coord_flip()
dev.off()


cat('halfhelmert_contrasts() now available as a function\n')
halfhelmert_contrasts = function(...){
	contr.helmert(...)*.5
}


subroutine collincheck(nadj,madj,npts,x,y,ntot,eps)

# Collinearity check --- experimental.  Runs through the adjacency
# list to see if any of the putative triangles in the triangulation
# that has so far been created are "degenerate", i.e. are actually
# just three points lying on a straight line.

implicit double precision(a-h,o-z)
dimension x(-3:ntot), y(-3:ntot)
dimension nadj(-3:ntot,0:madj)
logical collin, changed

nerror  = -1
changed = .false.
repeat {
    do j = 1,npts {
       nj = nadj(j,0)
       do k = 1,nj {
           k1 = nadj(j,k)
           call succ(k2,j,k1,nadj,madj,ntot,nerror)
           if(nerror > 0) {
               call intpr("Error number =",-1,nerror,1)
               call rexit("Error in succ, called from collincheck.")
           }

# Check whether triangle j, k1, k2 is really a triangle.
           call crossutil(j,k1,k2,x,y,ntot,eps,collin)

# If collinear, remove the triangle from the mix.
           if(collin) {
               changed = .true.
# First determine which of k1 and k2 is closer to j.  It
# *should* be k1, but y'never know in these chaotic
# circumstances.
           sd1 = (x(k1) - x(j))**2 + (y(k1) - y(j))**2
           sd2 = (x(k2) - x(j))**2 + (y(k2) - y(j))**2
           if(sd1 < sd2) {
               kr = k2
           } else {
               kr = k1
           }
# Delete kr ("r" for "remove") from the adjacency list of j and j
# from the adjacency list of kr.
               call delet(j,kr,nadj,madj,ntot,nerror)
               if(nerror > 0) {
                   call intpr("Error number =",-1,nerror,1)
                   call rexit("Error in collincheck.")
               }
               break
           }
       }
       if(changed) break
    }
}
until(!changed)
return
end


# The doughnut function permits to draw a donut plot
doughnut <-
function (x, labels = names(x), edges = 200, outer.radius = 0.8,
          inner.radius=0.6, clockwise = FALSE,
          init.angle = if (clockwise) 90 else 0, density = NULL,
          angle = 45, col = NULL, border = FALSE, lty = NULL,
          main = NULL, ...)
{
    if (!is.numeric(x) || any(is.na(x) | x < 0))
        stop("'x' values must be positive.")
    if (is.null(labels))
        labels <- as.character(seq_along(x))
    else labels <- as.graphicsAnnot(labels)
    x <- c(0, cumsum(x)/sum(x))
    dx <- diff(x)
    nx <- length(dx)
    plot.new()
    pin <- par("pin")
    xlim <- ylim <- c(-1, 1)
    if (pin[1L] > pin[2L])
        xlim <- (pin[1L]/pin[2L]) * xlim
    else ylim <- (pin[2L]/pin[1L]) * ylim
    plot.window(xlim, ylim, "", asp = 1)
    if (is.null(col))
        col <- if (is.null(density))
          palette()
        else par("fg")
    col <- rep(col, length.out = nx)
    border <- rep(border, length.out = nx)
    lty <- rep(lty, length.out = nx)
    angle <- rep(angle, length.out = nx)
    density <- rep(density, length.out = nx)
    twopi <- if (clockwise)
        -2 * pi
    else 2 * pi
    t2xy <- function(t, radius) {
        t2p <- twopi * t + init.angle * pi/180
        list(x = radius * cos(t2p),
             y = radius * sin(t2p))
    }
    for (i in 1L:nx) {
        n <- max(2, floor(edges * dx[i]))
        P <- t2xy(seq.int(x[i], x[i + 1], length.out = n),
                  outer.radius)
        polygon(c(P$x, 0), c(P$y, 0), density = density[i],
                angle = angle[i], border = border[i],
                col = col[i], lty = lty[i])
        Pout <- t2xy(mean(x[i + 0:1]), outer.radius)
        lab <- as.character(labels[i])
        if (!is.na(lab) && nzchar(lab)) {
            lines(c(1, 1.05) * Pout$x, c(1, 1.05) * Pout$y)
            text(1.1 * Pout$x, 1.1 * Pout$y, labels[i],
                 xpd = TRUE, adj = ifelse(Pout$x < 0, 1, 0),
                 ...)
        }
        ## Add white disc
        Pin <- t2xy(seq.int(0, 1, length.out = n*nx),
                  inner.radius)
        polygon(Pin$x, Pin$y, density = density[i],
                angle = angle[i], border = border[i],
                col = "white", lty = lty[i])
    }

    title(main = main, ...)
    invisible(NULL)
}


########################### FUNCOES RELATIVAS AO USO E EXTRACAO DE GRADES ##########################

#' Objetos \code{gradecolina}
#'
#' Tabelas regulares amostradas de um objeto \code{\link{interpolador}}.
#'
#' A chamada do metodo \code{predict} em objetos da classe \code{interpolador} e suas subclasses
#' pode ser retornada de forma mais completa. Esta forma consiste na tabela regularmente espacada
#' para representacao discreta da curva colina.
#'
#' Objetos do tipo \code{gradecolina} sao uma lista de dois elementos, o primeiro dos quais um
#'     data.table com as colunas
#'
#' \describe{
#' \item{\code{hl}}{queda liquida}
#' \item{\code{pot}}{potencia gerada}
#' \item{\code{rend}}{rendimento interpolado}
#' \item{\code{inhull}}{booleano indicando se o ponto foi interpolado (\code{TRUE}) ou extrapolado (\code{FALSE})}
#' }
#'
#' O segundo elemento e um objeto \code{curvacolina}, contendo a colina original.
#'
#' @name gradecolina
#'
#' @family gradecolina
NULL

#' Construtor Interno De \code{gradecolina}
#'
#' Funcao interna do pacote, nao deve ser chamada pelo usuario
#'
#' @param pontos data.frame-like contendo coordenadas interpoladas
#' @param rends vetor numerico de rendimentos interpolados
#' @param interpolador tipo de interpolador de onde foi extraida
#'
#' @return objeto da classe \code{gradecolina}; lista de dois elementos, o primeiro dos quais um
#'     data.table com as colunas
#'
#' \describe{
#' \item{\code{hl}}{queda liquida}
#' \item{\code{pot}}{potencia gerada}
#' \item{\code{rend}}{rendimento interpolado}
#' \item{\code{inhull}}{booleano indicando se o ponto foi interpolado (\code{TRUE}) ou extrapolado (\code{FALSE})}
#' }
#'
#' O segundo elemento e um objeto \code{curvacolina}, contendo a colina original
#'
#' @importFrom geometry inhulln convhulln

new_gradecolina <- function(pontos, rends, interpolador) {

    hl <- pot <- vaz <- rend <- NULL

    colina <- getcolina(interpolador)

    nhl  <- length(unique(pontos[, "hl"]))
    npot <- length(unique(pontos[, "pot"]))

    grade <- as.data.table(cbind(pontos, rend = rends))

    inhull <- inhulln(convhulln(colina$CC[, list(hl, pot)]), data.matrix(pontos))
    grade$inhull <- inhull

    out <- list(grade = grade, colina = colina)
    class(out) <- "gradecolina"
    attr(out, "interp") <- class(interpolador)[1]
    attr(out, "nhl")  <- nhl
    attr(out, "npot") <- npot

    return(out)
}

# METODOS ------------------------------------------------------------------------------------------

#' Interpolacao Bilinear
#'
#' Interpolacao bilinear de \code{pontos} na grade bivariada \code{gradecolina}
#'
#' \code{predict.gradecolina} interpola pontos arbitrarios especificados atraves do argumento
#' \code{pontos}. \code{fitted.gradecolina} interpola os pontos da propria curva colina original
#' na grade. \code{residuals.gradecolina} retorna os erros de interpolacao dos pontos da colina
#' original na grade.
#'
#' @param object objeto da classe \code{gradecolina}
#' @param pontos data.frame-like contendo as coordenadas \code{hl} e \code{pot} dos pontos a
#'     interpolar.
#' @param full.output booleano -- se \code{FALSE} (padrao) retorna apenas o vetor de rendimentos
#'     interpolados nas coordenadas \code{pontos}; se \code{TRUE} um data.table de \code{pontos} com
#'     a coluna \code{rend} adicionada
#' @param ... existe somente para consistencia de metodos. Nao possui utilidade
#'
#' @examples
#'
#' # usando o interpolador de triangulacao
#' tri <- interpolador(colinadummy, "triangulacao")
#'
#' # extrai uma grade dele
#' coord <- coordgrade(colinadummy, 10, 10)
#' gradecolina <- predict(tri, coord, as.gradecolina = TRUE)
#'
#' # interpolando pontos arbitrarios
#' coord_interp <- coordgrade(colinadummy, 25, 25)
#' pred <- predict(gradecolina, coord_interp)
#' pred <- predict(gradecolina, coord_interp, full.output = TRUE)
#'
#' # interpolando a propria curva colina
#' fitt <- fitted(gradecolina)
#'
#' # residuos
#' resid <- residuals(gradecolina)
#'
#' @return set \code{full.output = FALSE} vetor de rendimentos interpolados, do contrario um
#'     \code{data.table} contendo \code{pontos} adicionado da coluna \code{rend} com resultado da
#'     interpolacao
#'
#' @name interpolacao_bilinear
#'
#' @family gradecolina
#'
#' @import data.table
#' @importFrom geometry inhulln convhulln
#'
#' @export

predict.gradecolina <- function(object, pontos, full.output = FALSE, ...) {

    hl <- pot <- ordem0 <- NULL

    gradecolina <- as.data.table(object[[1]])
    pontos      <- as.data.table(pontos)

    hlGrade  <- gradecolina[, unique(hl)]
    potGrade <- gradecolina[, unique(pot)]
    rendGrade <- data.matrix(dcast(gradecolina, hl ~ pot, value.var = "rend")[, -1])

    pontos[, ordem0 := seq_len(.N)]
    setorder(pontos, pot)
    hlPred  <- pontos[, hl]
    potPred <- pontos[, pot]

    interp <- INTERPBILIN(hlGrade, potGrade, rendGrade, hlPred, potPred)

    if(full.output) {
        out    <- cbind(pontos[, list(hl, pot)], rend = as.numeric(interp))

        # o inhulln reclama se receber uma matriz de inteiros (inacreditavelmente), entao precisa
        # somar um 0.0 para converter a matriz em floats
        pts    <- data.matrix(pontos[, list(hl, pot)]) + .0
        inhull <- inhulln(convhulln(object$colina$CC[, list(hl, pot)]), pts)

        out[, inhull := inhull]
    } else {
        # a funcao em cpp retorna um vetor coluna (pro R, uma matriz N x 1)
        out <- as.numeric(interp)
    }

    out <- out[order(pontos$ordem0)]

    return(out)
}

#' @rdname interpolacao_bilinear
#'
#' @export

fitted.gradecolina <- function(object, full.output = FALSE, ...) {

    hl <- pot <- NULL

    fitt <- predict(object, object$colina$CC[, list(hl, pot)], full.output)

    return(fitt)
}

#' @rdname interpolacao_bilinear
#'
#' @export

residuals.gradecolina <- function(object, ...) {

    obs  <- object$colina$CC$rend
    prev <- fitted(object)
    res <- obs - prev

    return(res)
}

#' Escrita De \code{gradecolina}
#'
#' Metodo para facilitacao de escrita de \code{gradecolina} lida pelas funcoes do pacote
#'
#' @param x objeto \code{gradecolina} a ser escrito
#' @param file caminho para escrita com extensao de aquivo
#'
#' @return Escreve grade em \code{x} no caminho especificado
#'
#' @family gradecolina
#'
#' @import data.table
#'
#' @export

write.gradecolina <- function(x, file) fwrite(x$grade, file, quote = FALSE, sep = ";")