## ----echo=FALSE---------------------------------------------------------------
require(Hmisc)
knitrSet()

## ----eval=FALSE---------------------------------------------------------------
## response ~ terms

## ----eval=FALSE---------------------------------------------------------------
## y ~ age + sex            # age + sex main effects
## y ~ age + sex + age:sex  # add second-order interaction
## y ~ age*sex              # second-order interaction +
##                          # all main effects
## y ~ (age + sex + pressure)^2
##                  # age+sex+pressure+age:sex+age:pressure...
## y ~ (age + sex + pressure)^2 - sex:pressure
##                        # all main effects and all 2nd order
##                        # interactions except sex:pressure
## y ~ (age + race)*sex     # age+race+sex+age:sex+race:sex
## y ~ treatment*(age*race + age*sex)
##                          # no interact. with race,sex
## sqrt(y) ~ sex*sqrt(age) + race
## # functions, with dummy variables generated if
## # race is an R factor (classification) variable
## y ~ sex + poly(age,2)# poly makes orthogonal polynomials
## race.sex <- interaction(race,sex)
## y ~ age + race.sex   # if desire dummy variables for all
##                      # combinations of the factors

## ----eval=FALSE---------------------------------------------------------------
## lrm(y ~ rcs(x,4))

## ----eval=FALSE---------------------------------------------------------------
## f  <- lrm(y ~ rcs(x,4) + x2 + x3)
## f2 <- update(f, subset=sex=="male")
## f3 <- update(f, .~.-x2)         # remove x2 from model
## f4 <- update(f, .~. + rcs(x5,5))# add rcs(x5,5) to model
## f5 <- update(f, y2 ~ .)     # same terms, new response var.

## ----eval=FALSE---------------------------------------------------------------
## y ~ sex + lsp(age,c(20,30,40,50,60)) +
##     sex %ia% lsp(age,c(20,30,40,50,60))

## ----eval=FALSE---------------------------------------------------------------
## y ~ lsp(age,30) + rcs(cholesterol,4) +
##     lsp(age,30) %ia% rcs(cholesterol,4)

## ----eval=FALSE---------------------------------------------------------------
## options(na.action="na.omit")# don't report frequency of NAs

## ----eval=FALSE---------------------------------------------------------------
## options(na.action="na.delete", na.detail.response=TRUE,
##         na.fun.response="mystats")
## # Just use na.fun.response="quantile" if don't care about n
## mystats <- function(y) {
##   z <- quantile(y, na.rm=T)
##   n <- sum(!is.na(y))
##   c(N=n, z)    # elements named N, 0%, 25%, etc.
## }

## ----eval=FALSE---------------------------------------------------------------
## fit <- ols(y ~ x1*x2*x3)
## # run, and print results:
## fastbw(fit, optional_arguments)
## # typically used in simulations:
## z <- fastbw(fit, optional_args)
## # least squares fit of reduced model:
## lm.fit(X[,z$parms.kept], Y)

## ----eval=FALSE---------------------------------------------------------------
## f <- lrm(y ~ x1 + x2 + ..., data=df, x=TRUE, y=TRUE)
## w <- which.influence(f, .4)
## nam <- names(w)
## for(i in 1:length(nam)) {
##    cat("Influential observations for effect of",
##        nam[i],"\n")
##    print(df[w[[i]],])
## }

## ----eval=FALSE---------------------------------------------------------------
## require(rms)               # make new functions available
## options(prType='latex')    # print, summary, anova LaTeX output
##                            # others: 'html', 'plain'
## options(grType='plotly')   # plotly graphics for ggplot, anova, summary
##                            # default is 'base' for static graphics
##
##
## ddist <- datadist(cholesterol, treat, num.diseases, age)
## # Could have used ddist <- datadist(data.frame.name)
## options(datadist="ddist")       # defines data dist. to rms
## cholesterol <- impute(cholesterol)
## fit <- lrm(y ~ treat + scored(num.diseases) + rcs(age) +
##                log(cholesterol+10) +
##                treat:log(cholesterol+10))
## fit                 # outputs plain, LaTeX, or html markup
##
## describe(y ~ treat + scored(num.diseases) + rcs(age))
## # or use describe(formula(fit)) for all variables used in
## # fit.  describe function (in Hmisc) gets simple statistics
## # on variables
## # fit <- robcov(fit)# Would make all statistics that follow
##                     # use a robust covariance matrix
##                     # would need x=TRUE, y=TRUE in lrm()
## specs(fit)          # Describe the design characteristics
## anova(fit)          # plain, LaTeX, or html
## anova(fit, treat, cholesterol) # Test these 2 by themselves
## plot(anova(fit))             # Summarize anova graphically
## summary(fit)                 # Est. effects; default ranges
##                              # prints plain, LaTeX, or html
## plot(summary(fit)) # Graphical display of effects with C.I.
## # Specific reference cell and adjustment value:
## summary(fit, treat="b", age=60)
## # Estimate effect of increasing age: 50->70
## summary(fit, age=c(50,70))
## # Increase age 50->70, adjust to 60 when estimating
## # effects of other factors:
## summary(fit, age=c(50,60,70))
## # If had not defined datadist, would have to define
## # ranges for all variables
##
## # Estimate and test treatment (b-a) effect averaged
## # over 3 cholesterols:
## contrast(fit, list(treat='b', cholesterol=c(150,200,250)),
##               list(treat='a', cholesterol=c(150,200,250)),
##          type='average')
##
## p <- Predict(fit, age=seq(20,80,length=100), treat,
##              conf.int=FALSE)
## plot(p)                  # Plot relationship between age and
## # or ggplot(p), plotp(p) # log odds, separate curve for each
##                          # treat, no C.I.
## plot(p, ~ age | treat)           # Same but 2 panels
## ggplot(p, groups=FALSE)
## bplot(Predict(fit, age, cholesterol, np=50))
##                      # 3-dimensional perspective plot for
##                      # age, cholesterol, and log odds
##                      # using default ranges for both
## # Plot estimated probabilities instead of log odds
## # Could also use plotp() for plotly, or ggplot()
## plot(Predict(fit, num.diseases,
##              fun=function(x) 1/(1+exp(-x)),
##              conf.int=.9), ylab="Prob")
## # Again, if no datadist were defined, would have to tell
## # plot all limits
## logit <- predict(fit, expand.grid(treat="b",num.dis=1:3,
##                   age=c(20,40,60),
##                   cholesterol=seq(100,300,length=10)))
## # Could obtain list of predictor settings interactively
## logit <- predict(fit, gendata(fit, nobs=12))
## # An easier approach is
## # Predict(fit, treat='b',num.dis=1:3,...)
##
## # Since age doesn't interact with anything, we can quickly
## # and interactively try various transformations of age,
## # taking the spline function of age as the gold standard.
## # We are seeking a linearizing transformation.
##
## ag <- 10:80
## logit <- predict(fit, expand.grid(treat="a", num.dis=0,
##                  age=ag,
##                  cholesterol=median(cholesterol)),
##                  type="terms")[,"age"]
## # Note: if age interacted with anything, this would be the
## # age `main effect' ignoring interaction terms
## # Could also use logit <- Predict(f, age=ag, ...)$yhat,
## # which allows evaluation of the shape for any level of
## # interacting factors.  When age does not interact with
## # anything, the result from predict(f, ..., type="terms")
## # would equal the result from Predict if all other terms
## # were ignored
##
## # Could also specify:
## # logit <- predict(fit,
## #                  gendata(fit, age=ag, cholesterol=...))
## # Unmentioned variables are set to reference values
##
## plot(ag^.5, logit)   # try square root vs. spline transform.
## plot(ag^1.5, logit)  # try 1.5 power
##
## # Pretty printing of table of estimates and
## # summary statistics:
## print(fit, latex=TRUE) # print (*\LaTeX*) code to console
## latex(fit)             # invokes latex.lrm, creates fit.tex
## # Draw a nomogram for the model fit
## plot(nomogram(fit))
##
## # Compose R function to evaluate linear predictors
## # analytically
## g <- Function(fit)
## g(treat='b', cholesterol=260, age=50)
## # Letting num.diseases default to reference value

## ----eval=FALSE---------------------------------------------------------------
## age.tertile <- cut2(age, g=3)
## # For auto ranges later, specify age.tertile to datadist
## fit <- lrm(y ~ age.tertile * rcs(cholesterol))

## ----eval=FALSE---------------------------------------------------------------
## require(rms)
## dd <- datadist(my.data)
## options(datadist='dd')
## pcfit <- princomp(~ pain.symptom1 + pain.symptom2 + sign1 +
##                     sign2 + sign3 + smoking)
## pc2 <- pcfit$scores[,1:2]         # first 2 PCs as matrix
## logistic.fit <- lrm(death ~ rcs(age,4) + pc2)
## predicted.logit <- predict(logistic.fit)
## linear.mod      <- ols(predicted.logit ~ rcs(age,4) +
##                        pain.symptom1 + pain.symptom2 +
##                        sign1 + sign2 + sign3 + smoking)
## # This model will have R-squared=1
## nom <- nomogram(linear.mod, fun=function(x)1/(1+exp(-x)),
##          funlabel="Probability of Death")
## # can use fun=plogis
## plot(nom)
## # 7 Axes showing effects of all predictors, plus a reading
## # axis converting to predicted probability scale

## ----eval=FALSE---------------------------------------------------------------
## f <- loess(y ~ age * pressure)
## plot(f)                           # cross-sectional plots
## ages <- seq(20,70,length=40)
## pressures <- seq(80,200,length=40)
## pred <- predict(f,
##                 expand.grid(age=ages, pressure=pressures))
## persp(ages, pressures, pred)      # 3-D plot

## ----eval=FALSE---------------------------------------------------------------
## require(rpart)
## f <- rpart(is.na(cholesterol) ~ age + sex + trig + smoking)
## plot(f)      # plots the tree
## text(f)      # labels the tree


# ......................................................................................
# .................. Cvičení 12. Vícevýběrové testy - Extra pro zájemce.................
# ..................................... 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

# * Načteme si testovací data a vyrobíme post-hoc + efekty pro ANOVU a KW test ####

data = readxl::read_excel("data/snehurka.xlsx")
# data jsou ve standardním dtovém formátu

# POST-HOC ANOVA
vysledky = aov(data$hodnota ~ data$typ)
PH.ANOVA = TukeyHSD(vysledky)[[1]]
PH.ANOVA

# počítání efektů ANOVA
library(dplyr)

# celkový průměr
prumer_vsech = mean(data$hodnota)

# průměry ve skupinách
efekty = data %>% group_by(typ) %>%
    summarize(mean_skup = mean(hodnota))

# efekty
efekty$efekt = efekty$mean_skup - prumer_vsech

# vypsat setřízené
efekty.ANOVA = efekty %>% arrange(desc(efekt))
efekty.ANOVA

# POST-HOC KW
# post hoc - jiná funkce s výstupem, který se nám více hodí
# číselně odpovídá té použité na cvičení

# install.packages("FSA")
result = FSA::dunnTest(data$hodnota ~ data$typ,   # library FSA
              method="bonferroni")
PH.KW = result$res
PH.KW

# počítání efektů KW
library(dplyr)

# celkový průměr
prumer_vsech = median(data$hodnota)

# průměry ve skupinách
efekty = data %>% group_by(typ) %>%
    summarize(mean_skup = median(hodnota))

# efekty
efekty$efekt = efekty$mean_skup - prumer_vsech

# vypsat setřízené
efekty.KW = efekty %>% arrange(desc(efekt))
efekty.KW

#  Pro zájemce (nepovinné) - vytvoření setřízené tabulky p-hodnot/pisménkové schéma ####
# automatizovaně

# install.packages("stringi")
# toto je knihovna pro hledání v textu
# budeme hledat jména šmoulů v párových post-hoc testech

# inicializujeme si matici (pro pěkný výsledek jako textovou)
# 7x7 protože máme 7 šmoulů
POST.HOC.Phodnoty = matrix(rep("-", len = 7*7), nrow = 7, ncol = 7)
# pojmenujeme její sloupce i řádky dle setřízených šmoulů
colnames(POST.HOC.Phodnoty) = efekty.ANOVA$typ
rownames(POST.HOC.Phodnoty) = efekty.ANOVA$typ
POST.HOC.Phodnoty

# smyčka přes všechny testy v post-hoc (řes názvy sloupců)
for(pair.test in rownames(PH.ANOVA)){
    # kteří trpaslíci jsou přítomni v tomto párovém testu?
    trp.truefalse = stringi::stri_detect_fixed(pair.test, efekty.ANOVA$typ)
    # jaké jsou indexy těchto trpaslíků
    # indexy pro zápis do matice - vždy 2 hodnoty
    indexy.trp = which(trp.truefalse)
    # zapíšu do matice (první index je menší -> automaticky do
    # horního trojuhelníku)
    POST.HOC.Phodnoty[indexy.trp[1], indexy.trp[2]] =
        round(max(PH.ANOVA[pair.test, 'p adj'], 0.001), digits = 3)
    # zapisujeme text (pokud je matice textová, čísla se automaticky
    # převedou na text), hodnoty na tisíciny
}
POST.HOC.Phodnoty

# ** Funkce pro aoutomatizované znaménkové schéma (ručně napsané a z balíčku) ####
# *** Ručně napsané funkce (to co bychom dělali na papír) ####

# tabulka p-hodnot

tabulka.phodnot = function(setrizene.typy, parove.testy.nazvy,
                           parove.testy.phodnoty){
    # pocet skupin
    n = length(setrizene.typy)
    POST.HOC.Phodnoty = matrix(rep(0, len = n*n), nrow = n, ncol = n)
    # pojmenujeme její sloupce i řádky dle setřízených typů
    colnames(POST.HOC.Phodnoty) = setrizene.typy
    rownames(POST.HOC.Phodnoty) = setrizene.typy

    # smyčka přes všechny testy v post-hoc (řes názvy sloupců)
    for(i in 1:length(parove.testy.nazvy)){
        pair.test = parove.testy.nazvy[i]
        # kteří trpaslíci jsou přítomni v tomto párovém testu?
        typ.truefalse = stringi::stri_detect_fixed(pair.test, setrizene.typy)
        # jaké jsou indexy těchto trpaslíků
        # indexy pro zápis do matice - vždy 2 hodnoty
        indexy.typ = which(typ.truefalse)
        # zapíšu do matice (první index je menší -> automaticky do
        # horního trojuhelníku)
        POST.HOC.Phodnoty[indexy.typ[1], indexy.typ[2]] =
            parove.testy.phodnoty[i]
    }
    return(POST.HOC.Phodnoty)
}

# písmenkové schéma z tabulky

pismenkove.schema = function(POST.HOC.Phodnoty, alpha){
    # jak je velká matice
    n = nrow(POST.HOC.Phodnoty)
    # inicilizace matice
    pis.schema = matrix(rep(0, len = n*n), nrow = n, ncol = n)
    # názvy řádků - kopie od vstupu
    rownames(pis.schema) = rownames(POST.HOC.Phodnoty)
    # nastavení diagonály na 1 - je v dané skupině
    diag(pis.schema) = 1

    # cyklus přes všechny sloupce kde můžeme něco vyplňovat
    for(i in 1:(n-1)){
        # cyklus přes všechny řádky v sloupci kde sledujeme pval
        for(j in (i+1):n){
            # je-li pval > alpha tak přidáme do hom. skupiny
            pis.schema[j, i] = POST.HOC.Phodnoty[i,j]>alpha
        }
    }
    return(pis.schema)
}

# *** Jak použít ručně napsané funkce pro ANOVU a KW test? ####

# Jak to udělat z POST-HOC ANOVY:

# vyrobíme vstupní data
setrizene.typy = efekty.ANOVA$typ
parove.testy.nazvy = rownames(PH.ANOVA)
parove.testy.phodnoty = PH.ANOVA[,'p adj']

# vyrobíme setřízenou tabulku phodnot
p.val.tab = tabulka.phodnot(setrizene.typy, parove.testy.nazvy,
                            parove.testy.phodnoty)
# vykreslíme zaokrouhlené na tisíciny
round(p.val.tab, digits = 3)

# z tabulky phodnot vyrobíme písmenkové schéma
pis.schema = pismenkove.schema(p.val.tab, 0.05)
pis.schema

# Jak to udělat z POST-HOC KW:

# vyrobíme vstupní data
setrizene.typy = efekty.KW$typ
parove.testy.nazvy = PH.KW$Comparison
parove.testy.phodnoty = PH.KW$P.adj

# vyrobíme setřízenou tabulku phodnot
p.val.tab = tabulka.phodnot(setrizene.typy, parove.testy.nazvy,
                            parove.testy.phodnoty)
# vykreslíme zaokrouhlené na tisíciny
round(p.val.tab, digits = 3)

# z tabulky phodnot vyrobíme písmenkové schéma
pis.schema = pismenkove.schema(p.val.tab, 0.05)
pis.schema

# * Písmenkové schéma pomocí vestavěné Rkové funkce ####
# Balíček rcompanion, funkce cldList

# v případě ANOVY

# nejprve vyrobíme dataframe se sloupci dvojic a phodnot
input = data.frame(dvojice = rownames(PH.ANOVA),
                   pval = PH.ANOVA[,'p adj'])

# písmenkové schéma, library rcompanion
# install.packages("rcompanion")
rcompanion::cldList(pval ~ dvojice,
        data = input,
        threshold = 0.05)

# v případě KW

# nejprve vyrobíme dataframe se sloupci dvojic a phodnot
input = data.frame(dvojice = PH.KW$Comparison,
                   pval = PH.KW$P.adj)

# písmenkové schéma, library rcompanion
# install.packages("rcompanion")
rcompanion::cldList(pval ~ dvojice,
        data = input,
        threshold = 0.05)


#' Create a tidy stats data frame from an lm object
#'
#' \code{tidy_stats.lm} takes an lm object and converts the object to a tidy
#' stats data frame.
#'
#' @param model Output of \code{lm()}.
#' @param args Unused.
#'
#' @examples
#' # Conduct a regression
#' ctl <- c(4.17,5.58,5.18,6.11,4.50,4.61,5.17,4.53,5.33,5.14)
#' trt <- c(4.81,4.17,4.41,3.59,5.87,3.83,6.03,4.89,4.32,4.69)
#' group <- gl(2, 10, 20, labels = c("Ctl","Trt"))
#' weight <- c(ctl, trt)
#'
#' model_lm <- lm(weight ~ group)
#' tidy_stats(model_lm)
#'
#' @export

tidy_stats.lm <- function(model, args = NULL) {

  # Get summary statistics
  summary <- summary(model)

  # Convert model coefficients output to a data frame
  output_coefficients <- tibble::as_data_frame(summary$coefficients)
  # Not included: Descriptives of residuals, residual standard error, residual
  # degrees of freedom

  # Rename columns
  output_coefficients <- rename_columns(output_coefficients)

  # Set group and term information, and add degrees of freedom
  output_coefficients <- output_coefficients %>%
    dplyr::mutate(
      df = summary$df[2],
      term = names(model$coefficients),
      term_nr = 1:dplyr::n(),
      group = "coefficients") %>%
    tidyr::gather("statistic", "value", -term, -term_nr, -group) %>%
    dplyr::arrange(term_nr)

  # Extract model fit
  output_model <- tibble::data_frame(
    group = "model",
    statistic = c("R squared", "adjusted R squared", "F", "numerator df",
      "denominator df"),
    value = c(summary$r.squared, summary$adj.r.squared, summary$fstatistic[1],
      summary$fstatistic[2], summary$fstatistic[3]))

  # Calculate model fit p value ourselves
  p <- pf(summary$fstatistic[1], summary$fstatistic[2], summary$fstatistic[3],
    lower.tail = FALSE)

  output_model <- dplyr::bind_rows(output_model, data_frame(group = "model",
    statistic = "p", value = p))

  # Combine coefficients and model output
  output <- dplyr::bind_rows(output_coefficients, output_model)

  # Add method
  output <- dplyr::mutate(output, method = "Linear model")

  # Reorder columns
  output <- dplyr::select(output, group, term_nr, term, everything())

  return(output)
}


function(age) {
  # this is example of density estimation function on R
  # age must vector:
  # like c(321.2, 432.1 ,431.9, 654.8,...)

  res <- density(age)#this is R default density function

  #return must be data.frame(x=XXX,y=XXX)
  return (data.frame(x=res$x, y=res$y))
}


 E04TAJ Example Program Results

 Solve the first LP

 E04MT, Interior point method for LP problems
 Status: converged, an optimal solution found
 Final primal objective value  8.500000E+02
 Final dual objective value    8.500000E+02

 Primal variables:
   idx   Lower bound       Value       Upper bound
     1   0.00000E+00    2.00000E+02         inf
     2   0.00000E+00    1.00000E+02    1.00000E+02

 The new variable has been added, solve the handle again

 E04MT, Interior point method for LP problems
 Status: converged, an optimal solution found
 Final primal objective value  9.000000E+02
 Final dual objective value    9.000000E+02

 Primal variables:
   idx   Lower bound       Value       Upper bound
     1   0.00000E+00    5.00000E+01         inf
     2   0.00000E+00    1.00000E+02    1.00000E+02
     3   0.00000E+00    5.00000E+01    5.00000E+01

 The new constraint has been added, solve the handle again

 E04MT, Interior point method for LP problems
 Status: converged, an optimal solution found
 Final primal objective value  8.750000E+02
 Final dual objective value    8.750000E+02

 Primal variables:
   idx   Lower bound       Value       Upper bound
     1   0.00000E+00    1.50000E+02         inf
     2   0.00000E+00    5.00000E+01    1.00000E+02
     3   0.00000E+00    5.00000E+01    5.00000E+01


# size preference

dev<-"screen"
nox<-1; noy<-1;
noxy<-nox*noy
par(ask=TRUE)
i<-0

##############################################################

#size preference
cleanup()
newplot(dev,nox,noy);

file<-file.path(data.path,'size_pref.out')
size<-read.table(file,comment.char = "#",header=T)

Plot.size.pref.all<-function(logval=T) {
    n<-dim(size)[1]
    size.ratio<-size[ ,"size.ratio"]
    size.var<-size[,"size.var"]

    file<-file.path(data.path,'min_max_size_pref.out')
    r<-matrix(scan(file,comment.char = "#"),ncol=2,byrow=F)
    r<-log(r)
    min_l<-round(min(r[1,]),2)
    max_l<-round(max(r[,2]),2)
    x<-seq(min_l,max_l, by=0.01)
    len.x<-length(x)
    y<-array(0,c(n,len.x))

    for (pred in (1:n)) if ((size[pred,"size.model"]==1) || (size[pred,"size.model"]==11) || (size[pred,"size.model"]==2)) {
      y[pred,]<-exp(-(x-size.ratio[pred])^2/(2.0*rep(size.var[pred],len.x)))
    }
    xlab<-'log(pred size/prey size)'
    if (logval==F) {
      x<-exp(x);
      xlab<-'pred size/prey size'
    }
    xx<-c(min(x),max(x))
    yy<-c(min(y),max(y))
    if (n>1) {
      plot(xx,yy,type='n',xlab=xlab,ylab='Preference')
          legend(x=0.2,y=0.9,sp.names[1:(n)],fill=(1:n))
      for (pred in (1:n)) if ((size[pred,"size.model"]==1) ||  (size[pred,"size.model"]==11)||(size[pred,"size.model"]==2)) {
        lines(x,y[pred,],col=pred)
        abline(v=size.ratio[pred],col=pred)
      }
    } else if ((size[1,"size.model"]==1) ||  (size[1,"size.model"]==11)||(size[1,"size.model"]==2)){
       plot(x,y[1,],xlab=xlab,ylab='Preference',col=1,type='l')
        abline(v=size.ratio[1],col=1)
    }
}

Plot.size.pref.all(logval=T)

##################################################################
# with special predator length dependent correction

stom<-Read.stomach.data()
min_pred<-tapply(stom$Predator.size,list(stom$Predator.n),min)
max_pred<-tapply(stom$Predator.size,list(stom$Predator.n),max)

cleanup()
newplot(dev,nox,noy);

file<-file.path(data.path,'size_pref.out')
size<-read.table(file,comment.char = "#",header=T)

Plot.size.pref.all<-function(logval=T) {
    if (SMS.control@size.select.model==1) nround<-0 else nround<-3;
    n<-dim(size)[1]
    size.ratio<-size[ ,"size.ratio"]
    size.var<-size[,"size.var"]
    pref.size.ratio.correction<-size[,"pref.size.ratio.correction"]

    file<-file.path(data.path,'min_max_size_pref.out')
    r<-matrix(scan(file,comment.char = "#"),ncol=2,byrow=F)
    r<-log(r)
    min_l<-min(r[1,])   # min pred/prey ratio
    max_l<-max(r[,2])   # max pred/prey ratio

    for (pred in (1:n)) if ((size[pred,"size.model"]==1) || (size[pred,"size.model"]==11) || (size[pred,"size.model"]==2)) {
       x<-seq(min_l,max_l, by=0.1)
      len.x<-length(x)

      l_step<-seq(min_pred,max_pred,(max_pred[pred]-min_pred[pred])/6)
      i<-0
      y<-array(0,c(length(l_step),len.x))
      for  (pred_l in (l_step)) {
        i<-i+1
        y[i,]<-exp(-((x-size.ratio[pred]-pref.size.ratio.correction[pred]*log(pred_l))^2/(2.0*rep(size.var[pred],len.x))))
      }
     }
    xlab<-'log(pred size/prey size)'

     if (logval==F) {
         x<-exp(x);
         xlab<-'pred size/prey size'
     }
     plot(x,y[1,],xlab=xlab,ylab='Preference',col=1,type='l',lwd=2)
     text(x[len.x],y[1,len.x],round(min_pred,nround))
     for (i in (2:length(l_step))) {
       lines(x,y[i,],col=i,lwd=2)
       text(x[len.x],y[i,len.x],round(l_step[i],nround))
     }
}

Plot.size.pref.all(logval=T)

####################################################################################

Plot.size.pref_min_max<-function(log.scale,newPlot=T) {
    dev<-"screen"
    nox<-1; noy<-2;
    noxy<-nox*noy
    par(ask=TRUE)
    i<-0

    if (newPlot) newplot(dev,nox,noy);

    file<-file.path(data.path,'min_max_size_pref.out')
    size<-scan(file,comment.char = "#")

    ncol=nsp-first.VPA+1
    npr<-length(size)/ncol/2

    min.size<-matrix(data=size,ncol=ncol,nrow=npr,byrow=TRUE)
    max.size<-matrix(data=size[(1+length(min.size)):(2*length(min.size))],ncol=ncol,nrow=npr,byrow=TRUE)

    file<-file.path(data.path,'size_pref.out')
    size<-read.table(file,comment.char = "#",header=T)

    for (pred in (1:npr)) if (size[pred,"size.model"]==0 | TRUE) {
    xx<-c(min(min.size[pred,]),max(max.size[pred,]))
    xx.all<-c(min(min.size),max(max.size))
    if (log.scale==1) xx.all<-log(xx.all)
    if (log.scale==1) xx<-log(xx)
    yy<-c(1,nsp+1)
    if (i==noxy & newPlot) {newplot(dev,nox,noy); i<-0 }
    par(mar=c(5,5,3,2))

    plot(xx,yy,type='n',xlab=ifelse(log.scale==1,'log(pred size/prey size)','pred size/prey size'),
          ylab=' ',main=sp.names[pred], xlim=xx.all, axes=FALSE,ylim=c(first.VPA,nsp+1))
    axis(1)
    ax<-sp.names[(first.VPA+1):(nsp+1)]
    axis(2, (first.VPA+1):(nsp+1), sp.names[(first.VPA):(nsp)],las=1)
    box()
    for (prey in (first.VPA:nsp)) {
        x<-c(min.size[pred,prey-first.VPA+1],max.size[pred,prey-first.VPA+1])
        if (x[2]>0) {
            if (log.scale==1) x<-log(x)
            y<-rep(prey+1,2)
            lines(x,y,col=prey-first.VPA+1,lwd=4)
           # x<-rep(min.size[pred,prey-first.VPA+1],2)
           # if (log.scale==1) x<-log(x)
           # y<-c(prey+0.85,prey-first.VPA+1+1.15)
           # lines(x,y,col=prey-first.VPA+1,lwd=2)
           # x<-rep(max.size[pred,prey-first.VPA+1],2)
           # if (log.scale==1) x<-log(x)
           # lines(x,y,col=prey-first.VPA+1,lwd=2)
        }
    }
    i<-i+1
    }
}
Plot.size.pref_min_max(1)  #log scale
Plot.size.pref_min_max(0,newPlot=F)  # no log scale


########################################################################
#                                                                      #
#   finite-map.rb                                                      #
#                                                                      #
########################################################################
=begin
[((<index|URL:index.html>))]
[((<finite-set|URL:finite-set.html>))]
((<Algebra::Map>))

= Algebra::Map
((*Map Class*))

The class which represents maps.

== File Name:
* ((|finite-map.rb|))

== SuperClass:
* ((|Set|))

== Included Module:

* ((|Powers|))

== Class Methods:

--- ::[]([x0 => y0, [x1 => y1, [x2 => y2, ...]]])
    Returns the map which has values ((|y0|)) at ((|x0|)),
    ((|y1|)) at ((|x1|)),  ((|y2|)) at ((|x2|))...

    Exampel:
      require "finite-map"
      include Algebra
      p Map[0 => 10, 1 => 11, 2 => 12]         #=> {0 => 10, 1 => 11, 2 => 12}
      p Map[{0 => 10, 1 => 11, 2 => 12}]       #=> {0 => 10, 1 => 11, 2 => 12}
      p Map.new(0 => 10, 1 => 11, 2 => 12)     #=> {0 => 10, 1 => 11, 2 => 12}
      p Map.new({0 => 10, 1 => 11, 2 => 12})   #=> {0 => 10, 1 => 11, 2 => 12}
      p Map.new_a([0, 10, 1, 11, 2, 12])       #=> {0 => 10, 1 => 11, 2 => 12}

--- ::new([x0 => y0, [x1 => y1, [x2 => y2, ...]]])
    Returns the map which has values ((|y0|)) at ((|x0|)),
    ((|y1|)) at ((|x1|)),  ((|y2|)) at ((|x2|))... This is the same
    as ((<::[]>)).

--- ::new_a(a)
    Returns the map defined so that the even-th elements are in domain and
    the odd-th elements are their image.

--- ::phi([t])
    Return the empty map (having empty set as domain).
    If ((|t|)) is given, ((<target=>)) is set by ((|t|)).

    Exampel:
      p Map.phi #=> {}
      p Map.phi(Set[0, 1]) #=> {}
      p Map.phi(Set[0, 1]).target #=> {0, 1}

--- ::empty_set
    Alias of ((<::phi>)).

--- ::singleton(x, y)
    Returns the map defined over singleton (({{x}})) and having value ((|y|))
    on it.

== Methods:

--- target=(s)
    Sets the codomain ((|s|)). This is used for ((<surjective?>)) and so on.

--- codomain=(s)
    Alias of ((<target=>)).

--- target
    Returns the codomain of ((|self|))

--- codomain
    Alias of ((<target>)).

--- source
    Returns the domain of ((|self|)).

    Example:
      require "finite-map"
      include Algebra
      m = Map[0 => 10, 1 => 11, 2 => 12]
      p m.source #=> {0, 1, 2}
      p m.target #=> nil
      m.target = Set[10, 11, 12, 13]
      p m.target #=> {10, 11, 12, 13}

--- domain
    Alias of ((<source>)).

--- phi([t])
    Returns the empty map. If ((|t|)) given, ((<target=>)) t is done.

--- empty_set
--- null
    Alias of ((<phi>)).

--- call(x)
    Return the value of ((|x|)).

--- act
--- []
    Alias of ((<call>)).

--- each
    Iterates for each (({[point, image]})) of the map.

    Example:
      require "finite-map"
      include Algebra
      Map[0 => 10, 1 => 11, 2 => 12].each do |x, y|
        p [x, y] #=> [1, 11], [0, 10], [2, 12]
      end

--- compose(other)
    Returns the composition map of ((|self|)) and ((|other|)).

    Example:
      require "finite-map"
      include Algebra
      f = Map.new(0 => 10, 1 => 11, 2 => 12)
      g = Map.new(10 => 20, 11 => 21, 12 => 22)
      p g * f #=> {0 => 20, 1 => 21, 2 => 22}

--- *
    Alias of ((<compose>)).

--- dup
    Duplicates ((|self|)). ((<target>)) is also duplicated if it is set.

--- append!(x, y)
    Let the value of ((|x|)) be ((|y|)).

    Example:
      require "finite-map"
      include Algebra
      m = Map[0 => 10, 1 => 11]
      m.append!(2, 12)
      p m #=> {0 => 10, 1 => 11, 2 => 12}

--- []=(x, y)
    Alias of ((<append!>)).

--- append(x, y)
    ((<dup>)) and ((<append!>))(x, y).

--- include?(x)
    Returns true if ((|x|)) is in the domain.

--- contains?(x)
    Alias of ((<include?>)).

--- member?(a)
    Returns true if there is (({[x, y]})) s.t. the value of ((|x|))
    is ((|y|)) and (({[x, y] == a})).

    Example:
      require "finite-map"
      include Algebra
      m = Map[0 => 10, 1 => 11]
      p m.include?(1)  #=> true
      p m.member?([1, 11]) #=> true

--- has?
    Alias of member?

--- image([s])
    Returns the image of ((|self|)). If ((|s|)) is indicated, returns
    the image of ((|s|)) by ((|self|)).

--- inv_image(s)
    Return the inverse image of ((|s|)) by ((|self|)).

--- map_s
    Returns the set given by evaluation of the block, iterating over each pair
    of (({[point, image]})).

    Example:
      require "finite-map"
      include Algebra
      p Map.new(0 => 10, 1 => 11, 2 => 12).map_s{|x, y| y - 2*x}
      #=> Set[10, 9, 8]

--- map_m
    Returns the map given by evaluation of the block, iterating over each pair
    of (({[point, image]})). The value of the block must be
    the two-dimensional array (({[x, y]})).

    Example:
      require "finite-map"
      include Algebra
      p Map.new(0 => 10, 1 => 11, 2 => 12).map_m{|x, y| [y, x]}
      #=> {10 => 0, 11 => 1, 12 => 2}

--- inverse
    Returns the inverse map of ((|self|)).

--- inv_coset
    Reterns the map corresponding each point to its set of inverse images.

    Examepe:
      require "finite-map"
      include Algebra
      m = Map[0=>0, 1=>0, 2=>2, 3=>2, 4=>0]
      p m.inv_coset #=> {0=>{0, 1, 4}, 2=>{2, 3}}
      m.codomain = Set[0, 1, 2, 3]
      p m.inv_coset #=> {0=>{0, 1, 4}, 1=>{}, 2=>{2, 3}, 3=>{}}

--- identity?
    Returns true if ((|self|)) is the identity map.

--- surjective?
    Returns true if ((|self|)) is surjective.
    ((<target>)) should be set before using this.

--- injective?
    Returns true if ((|self|)) is injective.

--- bijective?
    Returns true if ((|self|)) is bijective.
    ((<target>)) should be set before using this.

=end


#' Get lower triangle of a correlation matrix
#'
#' @param cormat Correlation matrix
#'
#' @return Lower triangle of matrix, upper is NA
#' @export
#'
#' @examples get_lower_tri(stats::cor(matrix(rnorm(500), 100, 5)))
get_lower_tri<-function(cormat){
  cormat[base::upper.tri(cormat)] <- NA
  return(cormat)
}

#' Get upper triangle of a correlation matrix
#'
#' @param cormat Correlation matrix
#'
#' @return Upper triangle of matrix, lower is NA
#' @export
#'
#' @examples get_upper_tri(stats::cor(matrix(rnorm(500), 100, 5)))
get_upper_tri <- function(cormat){
  cormat[base::lower.tri(cormat)]<- NA
  return(cormat)
}

#' Plots a correlation matrix
#'
#' The upper triangle is a heatmap, the lower triangle is a table.
#'
#' @param cormat Correlation matrix
#'
#' @return A ggplot object
#' @import ggplot2
#' @export
#'
#' @examples plot_corr(stats::cor(matrix(rnorm(500), 100, 5)))
plot_corr <- function(cormat){
  upper_tri <- get_upper_tri(cormat)
  melted_cormat <- reshape2::melt(upper_tri, na.rm=TRUE)
  out <- ggplot2::ggplot(data = melted_cormat, ggplot2::aes(Var2, Var1, fill = value))+
    ggplot2::geom_tile(color = "white")+
    ggplot2::scale_fill_gradient2(low = "blue", high = "red", mid = "white",
                         midpoint = 0, limit = c(-1,1), space = "Lab",
                         name="Pearson\nCorrelation") +
    ggplot2::theme_minimal()+
    ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 45, vjust = 1,
                                     size = 12, hjust = 1))+
    ggplot2::coord_fixed() +
    ggplot2::xlab("") + ggplot2::ylab("")  +
    ggplot2::geom_text(ggplot2::aes(Var2, Var1, label = round(value,2)), color = "black", size = 4) +
    ggplot2::theme(
      axis.title.x = ggplot2::element_blank(),
      axis.title.y = ggplot2::element_blank(),
      panel.grid.major = ggplot2::element_blank(),
      panel.border = ggplot2::element_blank(),
      panel.background = ggplot2::element_blank(),
      axis.ticks = ggplot2::element_blank(),
      legend.justification = c(1, 0),
      legend.position = c(0.6, 0.7),
      legend.direction = "horizontal")+
    ggplot2::guides(fill = ggplot2::guide_colorbar(barwidth = 7, barheight = 1,
                                 title.position = "top", title.hjust = 0.5))
  return(out)
}


library("rstan")
N <- 5
y <- c(10, 10, 12, 11, 9)

fit_integrated <- stan("rounding_integrated.stan",  iter=1e5, chains=4)
print(fit_integrated)

fit_latent <- stan("rounding_latent.stan",  iter=1e5, chains=4)
print(fit_latent)

fit_latent_2 <- stan("rounding_latent_2.stan",  init=function() list(mu=rnorm(1), sigma=exp(rnorm(1)), z=y), iter=1e5, chains=4)
print(fit_latent_2)


decomp <- function(n) {
    factor_counts <- rep(1,n)
    names(factor_counts) <- 1:n
    factor_counts[1] <- 0
    for (index in 2:n)
        if (factor_counts[index] > 0 && 2*index <= n) {
            rest_index <- seq(2*index,n,by=index)
            while( any(factor_counts[rest_index] > 0) ) {
                dist <- factor_counts[rest_index]
                factor_counts[index] <- factor_counts[index] + sum( factor_counts[rest_index] )
                factor_counts[2:(n%/%index)] <- factor_counts[2:(n%/%index)] + dist
                factor_counts[rest_index] <- factor_counts[rest_index] - dist
            }
        }
    accu <- ""
    for (index in 2:n)
        if (factor_counts[index] > 0) {
            if (accu != "") accu <- paste(accu," * ",sep="")
            accu <- if(factor_counts[index] == 1)
              paste(accu,index,sep="")
            else
              paste(accu,index,"^",factor_counts[index],sep="")
        }
    return(accu)
}


suppressMessages(library(randomForestSRC)) # survival forest
suppressMessages(library(dplyr))
suppressMessages(library(progress))

Xtest <- read.csv('../data/interim/aids_x_test.csv')
ytest <- read.csv('../data/interim/aids_y_test.csv')

testing <- cbind(Xtest, ytest)

model <- readRDS("../models/01_best_rfsurv.rds")

pred <- predict(model, testing); pred

writeLines(paste0("C-index: ", 1-na.omit(pred$err.rate)))

bootstrap_cindex <- function(mod, dat, N=1000) {
    pb <- progress_bar$new(total = N)
	c.indx <- NULL
    n <- nrow(dat)

	for (i in 1:N) {
        pb$tick()
        use <- sample(1:n, n, replace=TRUE)
        new_dat <- dat[use, ]
        score <- predict(mod, new_dat)$err.rate %>% na.omit
        c.indx <- c(c.indx, 1 - score)
	}
    return(c.indx)
}

scores <- bootstrap_cindex(model, testing)
avg.c <- mean(scores)
st.err.c <- sd(scores)
lower.c <- qnorm(.025, avg.c, st.err.c) %>% round(3)
upper.c <- qnorm(.975, avg.c, st.err.c) %>% round(3)

writeLines(paste0("Bootstrapped C-index: ", round(avg.c, 3)))
writeLines(paste0("95% CI: ", lower.c, " - ", upper.c))


library(merkhet)
suppressMessages(library(stats))
suppressMessages(library(float))
suppressMessages(library(fmlr))

m = 100000
n = 250
seed = 1234
type = "float"

# ------------------------------------------------------------------------------
b = bench(sprintf("pca - %dx%d (%s) type=%s", m, n, as.character(howbig(m, n, type=type)), type))

x_cpu = cpumat(m, n, type=type)
x_cpu$fill_runif(seed)
x_r = dbl(x_cpu$to_robj())

b$time(prcomp(x_r, retx=FALSE), name="R")

b$time({
  sdev_cpu = cpuvec(type=type)
  rot_cpu = cpumat(type=type)

  pca_cpu = stats_pca(TRUE, FALSE, x_cpu, sdev_cpu, rot_cpu)
}, name="fmlr - CPU")

if (fml_gpu())
{
  c = card()
  x_gpu = gpumat(c, type=type)
  x_gpu$from_robj(x_r)

  b$time({
    sdev_gpu = gpuvec(c, type=type)
    rot_gpu = gpumat(c, type=type)

    pca_gpu = stats_pca(TRUE, FALSE, x_gpu, sdev_gpu, rot_gpu)
    c$synch()
  }, name="fmlr - GPU")
}

b$print()


## Fromm Yuwei Zhu
require(rms)
n <- 100     # define sample size
set.seed(17) # so can reproduce the results
age            <- rnorm(n, 50, 10)
blood.pressure <- rnorm(n, 120, 15)
outcome        <- sample(c(1,2,3), n,TRUE)
sex            <- factor(sample(c('female','male'), n,TRUE))
ddist <- datadist(outcome, age,  blood.pressure, sex)
options( datadist = 'ddist')

modelform <- outcome ~ age+sex+blood.pressure
f <-lrm(modelform, x = TRUE, y = TRUE)
which.influence(f)


coordinateFromLinearIndex <- function(indices, dims) {
  coords <- array( 0, c( length(dims), length(indices) ) )
  dArray <- seq( length(dims), 1)
  for ( n in 1:length(dims) ) {
    d <- dArray[n]
    coords[d,] <- floor( (indices-1) / prod( dims[1:d-1] ) ) + 1;
    indices <- indices - (coords[d,]-1) * prod( dims[1:d-1] );
  }
  return( coords )
}


#' Skewness
#'
#' @param fs_samples_df df of all samples, with columns for sim, year, season, treatment, source
#'
#' @return summary of skewness per sample
#' @export
#'
#' @importFrom e1071 skewness
#' @importFrom dplyr group_by summarize ungroup
add_skew <- function(fs_samples_df) {

  sim_skews <- fs_samples_df %>%
    dplyr::group_by(sim, year, season, treatment, source) %>%
    dplyr::summarize(skew = e1071::skewness(abund)) %>%
    dplyr::ungroup()

  return(sim_skews)
}

#' Skewness
#'
#' @param fs_samples_df df of all samples, with column for abundance
#'
#' @return summary of skewness per sample
#' @export
#'
#' @importFrom e1071 skewness
#' @importFrom dplyr group_by_at summarize ungroup filter mutate
#' @importFrom vegan diversity
add_dis <- function(fs_samples_df) {

  if(is.na(fs_samples_df)) {
    return(NA)
  }

  groupvars <- colnames(fs_samples_df)[ which(!(colnames(fs_samples_df) %in% c("abund", "rank")))]

  sim_dis <- fs_samples_df %>%
    dplyr::group_by_at(.vars = groupvars) %>%
    dplyr::summarize(skew = e1071::skewness(abund),
                     shannon = vegan::diversity(abund, index = "shannon", base = exp(1)),
                     simpson = vegan::diversity(abund, index = "simpson")) %>%
    dplyr::ungroup()

  sim_percentiles <- sim_dis %>%
    dplyr::filter(source == "sampled", sim > 0) %>%
    dplyr::mutate(skew_percentile = get_percentiles(skew),
                  shannon_percentile = get_percentiles(shannon),
                  simpson_percentile = get_percentiles(simpson))

  sampled_percentile <- sim_dis %>%
    dplyr::filter(source == "observed", sim < 0) %>%
    dplyr::mutate(skew_percentile = get_percentile(skew, a_vector = sim_percentiles$skew_percentile),
                  shannon_percentile = get_percentile(shannon, a_vector = sim_percentiles$shannon_percentile),
                  simpson_percentile = get_percentile(simpson, a_vector = sim_percentiles$simpson_percentile))

  sim_dis <- dplyr::bind_rows(sim_percentiles, sampled_percentile)

  return(sim_dis)
}

#' Get percentile values
#'
#' @param a_vector Vector of values
#'
#' @return Vector of percentile values for all values in the vector
#' @export
#'
get_percentiles <- function(a_vector) {

  nvals <- length(a_vector)

  percentile_vals <- vapply(as.matrix(a_vector), FUN = count_below, a_vector = a_vector, FUN.VALUE = 100)

  percentile_vals <- 100 * (percentile_vals / nvals)

  return(percentile_vals)
}

#' Count values below a value
#'
#' @param a_value Focal value
#' @param a_vector Vector for comparison
#'
#' @return Number of values in vector below value
#' @export
#'
count_below <- function(a_value, a_vector) {
  return(sum(a_vector < a_value))
}

#' Get one percentile value
#'
#' @param a_value Focal value
#' @param a_vector Comparison vector
#'
#' @return Percentile of focal value within comparison vector
#' @export
get_percentile <- function(a_value, a_vector) {

  count_below <- sum(a_vector < a_value)

  nvals <- length(a_vector)

  percentile_val <- 100 * (count_below / nvals)

  return(percentile_val)
}


library("Matrix")

context("Sparse classification")

test_that("sparse matrix gets all values", {
  s1 <- sparseMatrix( i=1:4, j=2:5, x=c(1,-2,0,-1) )
  js1 <- toJavaCSMatrix( s1 )
  expect_equal( .jcall(js1, "I", "getNumNonZero"), 3 )
})

get.sparse.class <- function(n=800) {
  p = 40
  x = matrix(sample(0:1, n*p, prob=c(0.9, 0.1), replace=T), n, p)
  x = as(x, "sparseMatrix")
  f = function(x) (Matrix::rowSums(x[,1:20]) >= 3) + (Matrix::rowSums(x[,21:p]) >= 4)
  y = factor(f(x), levels=0:2)
  return(list(x=x, y=y))
}

train <- get.sparse.class(100)
test  <- get.sparse.class(101)

test_that("classification using sparse input", {
  et   <- extraTrees(train$x, train$y, nodesize=1, ntree=50)
  expect_equal( 50, et$ntree )
  expect_true(  et$factor )
  expect_false( et$multitask )

  ## standard prediction
  yhat <- predict(et, test$x)
  expect_true ( is.factor(yhat) )
  expect_equal( length(yhat), length(test$y) )
  expect_equal( levels(yhat), levels(test$y) )

  ## allValues prediction
  yall = predict(et, test$x, allValues=T)
  expect_true ( is.factor(yall[,1]) )
  expect_equal( nrow(yall), nrow(test$x) )
  expect_equal( ncol(yall), 50 )
  expect_false( is.numeric(yall) )
})


library(RCurl)
library(utils)
library(tidyverse)
library(devtools)
install.packages("ggplot2")
library(ggplot2)
library(ggfortify)
library(ggbiplot)

d <-read.table("NCyc_out.txt", header=TRUE, sep="\t")
trans <- t(d)
colnames(trans) = trans[1, ]
trans <-  trans[-1, ]

trans2 <- type.convert(trans[1:5,1:68])
trans3 <- t(trans2)

genes.pca <- prcomp(trans2[1:5,1:68], center = TRUE, scale. = TRUE)

summary(genes.pca)

autoplot(genes.pca)
#ggbiplot(genes.pca, ellipse = TRUE, labels=rownames(trans2), groups = )


#par(mfrow=c(1,2), mgp = c(1.5, 0.5, 0),tck=0.02)

V<- 4.66*10^(-13)

#V是基础弯月面体积

vne1<- 0.5*q[1]/fv + 4.66*10^(-13)

vne2<- (3*10^(-12))*0.9/fv + 4.66*10^(-13)

vne3<-(q[7]*(1-k))/fv+4.66*10^(-13)

#vne是体积增量

fv<-c(1:200)
q<-c(1.5*10^(-12),8.33*10^(-12),16.67*10^(-12),
     1.5/60*10^(-12),27/60*10^(-12),54/60*10^(-12),3*10^(-12))
k<-c(0.1,0.3,0.5,0.7,0.8)

#fv,q,k分别为电压频率，流量和占空比

coll<-rainbow(5)

plot(fv,vne2, col=coll[1],mgp = c(1.5, 0.5, 0),tck=0.02,type="b",pch=1,cex=0.6,lwd=1.5,lty=2,xlab = expression(italic(f["v"])(Hz)),
     ylab = expression (italic(V["ne"]+V["m"](m^3))),xlim=c(0,200),ylim=c(4.66*10^(-13), 9*10^(-13)))

pcc<-c(1,2,3,4,5)

for(i in 2:5){
  lines(fv,(q[7]*(1-k[i])/fv + 4.66*10^(-13)),col=coll[i],pch=pcc[i],cex=0.6, type="b",lwd=1.5,
        lty=2)
}

abline(h=(V+0.05*V),col="blue",lwd=1.5,lty=4)
abline(h=(V+0.1*V),col="blue",lwd=1.5,lty=4)
abline(h=(V+0.2*V),col="blue",lwd=1.5,lty=4)
abline(h=(V+0.6*V),col="blue",lwd=1.5,lty=4)

legend("topright",c("kv=0.1","kv=0.3","kv=0.5",
                    "kv=0.7","kv=0.8"),col=coll,
       inset = .02,pch=pcc,bty = "n",lty=2,lwd=1.5,cex=0.8)


REBOL [
    Title:   "Rectangle-pack"
    Date:    14-Feb-2012/20:39:44+1:00
    Name:    'rectangle-pack
    Version: 1.0.0
	History: [
		1.0.0 27-Oct-2010 {Initial version}
		1.1.0 14-Feb-2012 {
			Added pow2-rectangle-pack and pow2-box-pack functions.
			It's possible to specify pre-sorting method}
	]
    File: %rectangle-pack.r
    Author: "Oldes"
    Owner: none
    Rights: none
    Needs: none
    Tabs: none
    Usage: [
		probe pow2-rectangle-pack [
			120x10 "img1"
			125x5  "img2"
			100x4  "img3"
		]
		probe pow2-box-pack [
			120x10 "img1"
			125x5  "img2"
			100x4  "img3"
		]
	]
    Purpose: none
    Comment: {
    This code was inspired by this page:
    http://www.blackpawn.com/texts/lightmaps/default.html
    It's not exactly the same as this one is not using recursion, but works fine for my purposes.
    Here are for example packed bitmaps into 256x256 texture:
    http://box.lebeda.ws/~hmm/rebol/rectangle-pack-result.jpg
    }
    History: none
    Language: none
    Type: none
    Email: none
]

ctx-rectangle-pack: context [
	padding: 1x1
	max-size: 8192x8192
	verbose: 0

	round-to-pow2: func[v /local p][ repeat i 14 [if v <= (p: 2 ** i) [return p]] none]

	max-pow2-size: func[data /local maxpair ][
		maxpair:  0x0
		foreach [size id] data [
			maxpair: max maxpair size
		]
		maxpair/x: to-integer round-to-pow2 maxpair/x
		maxpair/y: to-integer round-to-pow2 maxpair/y
		maxpair
	]
	min-pow2-size: func[data /local minpair ][
		minpair:  0x0
		foreach [size id] data [
			minpair: max minpair size
		]
		minpair/x: to-integer round-to-pow2 minpair/x
		minpair/y: to-integer round-to-pow2 minpair/y
		minpair
	]
	pow2-area: func[size][
		(round-to-pow2 size/x) * (round-to-pow2 size/y)
	]

	set 'pow2-box-pack func[images /method sort-method /local size data-to-process result][

		size: min-pow2-size images
		size: as-pair tmp: min size/x size/y tmp

		data-to-process: copy images

		while [
			not empty? second result: rectangle-pack/method data-to-process size sort-method
		][
			size: size * 2
			;print reform ["retry with size:" size]
		]
		reduce [size result]
	]

	set 'pow2-rectangle-pack func[images /method sort-method /local size data-to-process result][

		minsize: min-pow2-size images
		data-to-process: copy images

		minArea:   to-integer #{7FFFFFFF}
		minResult: none

		size: minsize
		until [
			until [
				result: rectangle-pack/method data-to-process size sort-method
				area: size/x * size/y
				;print ["test size:" size]
				if empty? second result [
					if minArea >= area [
						;print ["???" result/3  ]
						if any [
							none? minResult
							minArea > area
							(pow2-area size) < (pow2-area minResult/1)
							all [
								(pow2-area size) = (pow2-area minResult/1)
								any [
									size/x = size/y
									(max size/x size/y) < (max minResult/1/x minResult/1/y)
								]
							]
						][
							minArea: area
							minResult: reduce [size result]
							;print ["NEW MIN AREA:" area]
						]
					]
					break
				]
				size/x: size/x * 2
				;print ["?X" area minArea]
				not all [
					area < minArea
					size/x <= max-size/x
				]
			]
			size/y: size/y * 2
			size/x: minsize/x
			area: pow2-area size
			;print ["?Y" area minArea size/y]
			not all [
				area <= minArea
				size/y <= max-size/y
			]
		]

		;print "-----------"
		;probe minArea
		unless minResult [
			probe result
			minResult: reduce [max-size result]
		]
		minResult
	]

	set 'rectangle-pack func[
		"Takes block of sizes and ids and tries to pack them to specified area, returns block with placed and skiped data"
		size-data   [block!] "block with [size1 id1 size2 id2 ...]"
		target-area [pair! ] "Size of the target area"
		/method sort-method
		/local placed skiped free-bins free-area placed? rw rh rx ry width height
	][
		if verbose > 0 [print ["RECTPACK to size:" target-area]]

		;sort-method: 3 ;louka kytky

		sort/compare/skip size-data func[a b /local oa ob][
			switch/default sort-method [
				2 [
					;precedence: side Y
					case [
						a/y < b/y [ 1]
						a/y > b/y [-1]
						a/x < b/x [ 1]
						a/x > b/x [-1]
						true      [ 0]
					]
				]
				3 [
					;predecence: area
					case[
						(oa: a/x * a/y) > (ob: b/x * b/y) [-1]
						oa < ob                           [ 1]
						true                              [ 0]
					]
				]
				4 [
					;precedence: any side's size
					case[
						(oa: max a/x a/y) > (ob: max b/x b/y) [-1]
						oa < ob                           [ 1]
						true                              [ 0]
					]
				]
			][;default = 1:
				;precedence: side X
				case [
					a/x < b/x [ 1]
					a/x > b/x [-1]
					a/y < b/y [ 1]
					a/y > b/y [-1]
					true      [ 0]
				]
			]
		] 2

		placed:    copy []
		skiped:    copy []
		free-bins: reduce [target-area/x target-area/y 0 0]

		foreach [size id] size-data [
			free-bins: head free-bins
			placed?: false
			while [not tail? free-bins][
				set [rw rh rx ry] free-bins
				width:  size/x + padding/x
				height: size/y + padding/y
				either all [
					width <= rw
					height <= rh
				][
					repend placed [as-pair rx ry size id]
					placed?: true
					change/part free-bins reduce either (rw  - width) > (rh - height) [
						[
							free-bins/1 - width
							free-bins/2
							free-bins/3 + width
							free-bins/4
							width
							free-bins/2 - height
							free-bins/3
							free-bins/4 + height
						]
					][
						[
							free-bins/1 - width
							height
							free-bins/3 + width
							free-bins/4
							free-bins/1
							free-bins/2 - height
							free-bins/3
							free-bins/4 + height
						]
					] 4
					break
				][
					free-bins: skip free-bins 4
				]
			]
			unless placed? [
				;print ["NOT FOUND SPACE FOR:" size "^/^-" id]
				repend skiped [size id]
			]
		]
		free-area: 0
		foreach [rw rh rx ry] free-bins [
			free-area: free-area + (rw * rh)
		]

		new-line/skip placed true 3
		reduce [placed skiped free-area]
	]
]


#' Get raw data and prepare for Plan B smooth
#'
#' Reads in csv file with Year in first column and as many survey indices as desired, standardizes series if desired, computes mean of all or user selected surveys, outputs csv file with Year and Mean Index.
#' @param data.dir directory with csv file
#' @param data.file.name name of csv file (without the .csv extension)
#' @param od directory for output (default=working directory)
#' @param standardize true/false flag to divide by mean of time series (default=FALSE)
#' @param usesurvey vector of true/false to select surveys to average (default=NA which means use all)
#' @param narmavgflag true/false flag for na.rm setting in average across multiple surveys (default=FALSE)
#' @param saveplots true/false flag to save output to od (default=FALSE)
#' @param nameplots added to start of saved files (default=""), spaces not recommended
#' @export

ReadRaw <- function(data.dir,
                    data.file.name,
                    od               = ".",
                    standardize      = FALSE,
                    usesurvey        = NA,
                    narmavgflag      = FALSE,
                    saveplots        = FALSE,
                    nameplots        = ""){

  raw.dat <- read.csv(file.path(data.dir, paste0(data.file.name,".csv")))

  # get some basic info about raw.dat
  cnames <- colnames(raw.dat)
  ncols <- length(cnames)

  # check for Year in first column
  if(cnames[1] != "Year" & cnames[1] != "YEAR"){
    return("Header of first column not Year or YEAR, please check to ensure correct file defined")
  }

  # print to screen the survey names in order to facilitate usesurvey variable
  print(cbind(1:(ncols-1), cnames[2:ncols]))

  # standardize each column, other than year of course, if desired
  raw.s <- raw.dat
  if(standardize == TRUE){
    for (i in 2:ncols){
      raw.s[,i] <- raw.dat[,i] / mean(raw.dat[,i], na.rm=T)
    }
  }

  # keep only used surveys, then average
  if(is.na(sum(usesurvey))) usesurvey <- rep(TRUE, (ncols - 1))
  colvals <- 2:ncols
  raw.a <- raw.s[, (colvals * usesurvey)] # tricky way to pick the surveys
  if(sum(usesurvey) == 0) return("No surveys selected, change usesurvey option and try again.")
  if(sum(usesurvey) == 1) raw.avg <- data.frame(Year = raw.dat[,1],
                                                avg = raw.a)
  if(sum(usesurvey) >= 2) raw.avg <- data.frame(Year = raw.dat[,1],
                                                avg = apply(raw.a, 1, mean, na.rm = narmavgflag))

  # save csv file of averaged values
  if(saveplots) write.csv(raw.avg,
                          file=file.path(od, paste0(nameplots,
                            "raw_converted_average_",data.file.name,".csv")),
                          row.names = FALSE)

  return(raw.avg)

}


REBOL [
    System: "REBOL [R3] Language Interpreter and Run-time Environment"
    Title: "REBOL 3 Mezzanine: Math"
    Rights: {
        Copyright 2012 REBOL Technologies
        REBOL is a trademark of REBOL Technologies
    }
    License: {
        Licensed under the Apache License, Version 2.0
        See: http://www.apache.org/licenses/LICENSE-2.0
    }
]

pi: 3.14159265358979323846

; Shorthands for radian forms of trig functions, first introduced by Red.
; http://www.red-lang.org/2014/08/043-floating-point-support.html

cos: :cosine/radians
sin: :sine/radians
tan: :tangent/radians  ; contentious with color "tan" (in CSS and elsewhere)
acos: :arccosine/radians
asin: :arcsine/radians
atan: :arctangent/radians

modulo: func [
    "Compute a remainder of A divided by B with the sign of B."
    return: [any-number! money! time!]
    a [any-number! money! time!]
    b [any-number! money! time!] "Must be nonzero."
    /adjusted "Set 'almost zero' and 'almost B' to zero"
][
    ; This function tries to find the remainder that is "almost non-negative"
    ; Example: 0.15 - 0.05 - 0.1 // 0.1 is negative,
    ; but it is "almost" zero, i.e. "almost non-negative"

    ; Compute the smallest remainder with the same sign as b
    let r: remainder a b
    if (sign? r) = negate sign? b [r: r + b]
    if not adjusted [return r]
    if (sign? a) = negate sign? b [a: negate a]
    ; If r is "almost" b (i.e. negligible compared to b), the
    ; result will be 0. Otherwise the result will be r
    any [
        a + r = a, b + r = b  ; 'almost zero'
        all [  ; 'almost b'
            (a + r) = (a + b)
            positive? (r + r) - b
        ]
    ] then [
        return 0.0
    ]
    return r
]

mod: enfixed :modulo
pow: enfixed :power

sign-of: func [
    "Returns sign of number as 1, 0, or -1 (to use as multiplier)."
    number [any-number! money! time!]
][
    case [
        positive? number [1]
        negative? number [-1]
    ] else [0]
]

extreme-of: func [
    {Finds the value with a property in a series that is the most "extreme"}

    return: "Position where the extreme value was found"
        [any-series!]
    series [any-series!]
    comparator "Comparator to use, e.g. LESSER? for MINIMUM-OF"
        [action!]
    /skip "Treat the series as records of fixed size"
        [integer!]
][
    skip: default [1]
    if 1 > skip [cause-error 'script 'out-of-range skip]
    let spot: series
    iterate-skip series skip [
        if (comparator first series first spot) [spot: series]
    ]
    return spot
]

minimum-of: redescribe [
    {Finds the smallest value in a series}
](
    specialize :extreme-of [comparator: :lesser?]
)

maximum-of: redescribe [
    {Finds the largest value in a series}
](
    specialize :extreme-of [comparator: :greater?]
)

; A simple iterative implementation; returns 1 for negative
; numbers. FEEL FREE TO IMPROVE THIS!
;
factorial: func [n [integer!]] [
    if n < 2 [return 1]
    let res: 1
    ; should avoid doing the loop for i = 1...
    count-up i n [res: res * i]
]

; This MATH implementation is from Gabrielle Santilli circa 2001, found
; via http://www.rebol.org/ml-display-thread.r?m=rmlXJHS. It implements the
; much-requested (by new users) idea of * and / running before + and - in
; math expressions. Expanded to include functions.
;
math: func [
    {Process expression taking "usual" operator precedence into account.}

    expr [block!]
        {Block to evaluate}
    /only
        {Translate operators to their prefix calls, but don't execute}

    ; !!! This creation of static rules helps avoid creating those rules
    ; every time, but has the problem that the references to what should
    ; be locals are bound to statics as well (e.g. everything below which
    ; is assigned with BLANK! really should be relatively bound to the
    ; function, so that it will refer to the specific call.)  It's not
    ; technically obvious how to do that, not the least of the problem is
    ; that statics are currently a usermode feature...and injecting relative
    ; binding information into something that's not the function body itself
    ; isn't implemented.

    <static>

    slash (the /)

    expr-val (_)

    expr-op (_)

    expression  ([
        term (expr-val: term-val)
        while [
            ['+ (expr-op: 'add) | '- (expr-op: 'subtract)]
            term (expr-val: compose [(expr-op) (expr-val) (term-val)])
        ]
        end
    ])

    term-val (_)

    term-op (_)

    term ([
        pow (term-val: power-val)
        while [
            ['* (term-op: 'multiply) | slash (term-op: 'divide)]
            pow (term-val: compose [(term-op) (term-val) (power-val)])
        ]
    ])

    power-val (_)

    pow ([
        unary (power-val: unary-val)
        opt ['** unary (power-val: compose [power (power-val) (unary-val)])]
    ])

    unary-val (_)

    pre-uop (_)

    post-uop (_)

    unary ([
        (post-uop: pre-uop: [])
        opt ['- (pre-uop: 'negate)]
        primary
        opt ['! (post-uop: 'factorial)]
        (unary-val: compose [(post-uop) (pre-uop) (prim-val)])
    ])

    prim-val (_)

    primary ([
        set prim-val any-number!
        | set prim-val [word! | path!] (prim-val: reduce [prim-val])
            ; might be a funtion call, looking for arguments
            while [
                nested-expression (append prim-val take nested-expr-val)
            ]
        | ahead group! into nested-expression (prim-val: take nested-expr-val)
    ])

    p-recursion (_)

    nested-expr-val ([])

    save-vars (func [][
            p-recursion: reduce [
                :p-recursion :expr-val :expr-op :term-val :term-op :power-val :unary-val
                :pre-uop :post-uop :prim-val
            ]
        ])

    restore-vars (func [][
            set [
                p-recursion expr-val expr-op term-val term-op power-val unary-val
                pre-uop post-uop prim-val
            ] p-recursion
        ])

    nested-expression ([
            ;all of the static variables have to be saved
            (save-vars)
            expression
            (
                ; This rule can be recursively called as well,
                ; so result has to be passed via a stack
                insert nested-expr-val ^expr-val
                restore-vars
            )
            ; vars could be changed even it failed, so restore them and fail
            | (restore-vars) fail

    ])
][
    clear nested-expr-val
    let res: either parse expr expression [expr-val] [blank]

    either only [
        res
    ][
        ret: reduce res
        all [
            1 = length of ret
            any-number? ret/1
        ] else [
            fail [
                unspaced ["Cannot be REDUCED to a number (" mold ret ")"]
                ":" mold res
            ]
        ]
        ret/1
    ]
]


library(tidyverse)
library(xgboost)

df <- read_csv('../data/WA_Retail-SalesMarketing_-ProfitCost.csv')

## remove records without revenue
df <- na.omit(df)

## Columns used for prediction
col_revenue <- c(
  'Year'
  , 'Product line'
  , 'Product type'
  , 'Product'
  , 'Order method type'
  , 'Retailer country'
  , 'Revenue')

df <- df[col_revenue]

df %>% head(5)

df <- df %>% mutate_if(is.character, as.factor)

options(repr.plot.width = 9, repr.plot.height = 3)
gg1 <- qplot(data=df, x=`Order method type`, y=Revenue, geom='col', fill=Year, main = 'Revenue by Order method' ) +
  scale_y_continuous(name="Revenue", labels = scales::comma) + coord_flip()  +
  theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank())

gg2 <- qplot(data=df, x=`Retailer country`, y=Revenue, geom='col', fill=Year, main = 'Revenue by Country'  ) +
  scale_y_continuous(name="Revenue", labels = scales::comma) + coord_flip()  +
  theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank())

gridExtra::grid.arrange(gg1, gg2, nrow = 1)

options(repr.plot.width = 8, repr.plot.height = 2)

## revenue by product line by year
qplot(data=df, x=`Product line`, y=Revenue, geom='col', fill=Year) +
  scale_y_continuous(name="Revenue", labels = scales::comma) + coord_flip()

options(repr.plot.width = 10, repr.plot.height = 4)
qplot(data=df, x=`Product line`, y=Revenue, geom='boxplot', color=`Product line`, facets = ' Year ~ .') +
  scale_y_continuous(name="Revenue", labels = scales::comma)  + ## mediana = 163000
  theme(axis.text.x = element_text(angle = 45, hjust = 1))

## revenue by year -> fazer a simulacao/modelo somente com estes dados
options(repr.plot.width = 8, repr.plot.height = 2)
qplot(data=df, x=Year, y=Revenue, geom='col', fill=Year)+
  scale_y_continuous(name="Revenue", labels = scales::comma) + coord_flip()

## define the target and prepare the data to run XGB
target <- 'Revenue'
idx_target <- which(col_revenue == target)

dfxgb <- df %>% mutate_if(is.character, as.factor)
dfxgb <- dfxgb %>% mutate_if(is.factor, as.integer)

set.seed(12345)
idx <- caret::createDataPartition(dfxgb$Revenue, p=0.80, list=FALSE)
train <- dfxgb[idx, ]
test <- dfxgb[-idx, ]

dtrain <- xgb.DMatrix(data = as.matrix(train[, -idx_target]), label= train[[target]])
dtest <- xgb.DMatrix(data = as.matrix(test[, -idx_target]))

## execution of XGB
set.seed(12345)
fit.xgb <- xgboost(data = dtrain,
                   objective = "reg:linear",
                   booster = "gbtree",
                   print_every_n = 25, ## print every 25
                   nrounds = 350)

### feature importance
## importance variable of the xgb model
imp_features <- xgb.importance(model = fit.xgb)

print(imp_features)

## Plot Feature importance
xgb.ggplot.importance(imp_features, rel_to_first = TRUE)

## Evaluate the prediction with test data
predict_xgb <- predict(fit.xgb, dtest)
predict_xgb <- ifelse(predict_xgb < 1, 0, predict_xgb)

## R^2 0.9016625 -> 90% -> 6% better than random forest python (84%)
print('---------------------------- R^2 evaluation')
print(MLmetrics::R2_Score(predict_xgb, test$Revenue))

## The Business Requirement request to predict the revenue for 2008 but do not provide data for 2008

## the trick here => we will use the same products sold on 2007 to predict the Revenue for 2008 and evaluate the results
#### the model used have R^2 of 0.9016 so we expect to achieve a confident result

df_2008 <- dfxgb %>% filter(Year==2007)

## update Year to 2008 and setup the Revenue to 0 -> Revenue will be updated with the prediction later
df_2008$Year <- 2008
df_2008$Revenue <- 0

print('-------------------------------------- INITIAL dataset: 2008 YEAR')
print(summary(df_2008))

## gernerate the data to use with XGB model (fit.xgb)
xgb_2008 <- xgb.DMatrix(data = as.matrix(df_2008[, -idx_target]), label= df_2008[[target]])

predict_revenue_2018 <- predict(fit.xgb, xgb_2008)
predict_revenue_2018 <- ifelse(predict_revenue_2018 < 1, 0, predict_revenue_2018)

## update the Revenue predition for year 2008 and compare with other Years
df_2008$Revenue <- predict_revenue_2018

## generate one dataset to compare the revenue form all Years
df_all <- rbind(dfxgb, df_2008)

print('-------------------------------------- PREDICTION: 2008 YEAR')
summary(df_all)

## info: 2008 is the Revenue Prediction
qplot(data=df_all, x=Year, y=Revenue, geom='col', fill=Year, main='Predicted Revenue for 2008')+
  scale_y_continuous(name="Revenue", labels = scales::comma) + coord_flip()

## Revenue by Year
revenue_by_year <- df_all %>% group_by(Year) %>% summarise(Total_Revenue = sum(Revenue))

print(revenue_by_year)

rev_2008_vs_2005 <- round( (revenue_by_year[revenue_by_year$Year==2008, 'Total_Revenue'] /
                            revenue_by_year[revenue_by_year$Year==2005, 'Total_Revenue']) * 100  , 2)

rev_2008_vs_2007 <- round( (revenue_by_year[revenue_by_year$Year==2008, 'Total_Revenue'] /
                            revenue_by_year[revenue_by_year$Year==2007, 'Total_Revenue']) * 100  , 2)

print(' -------------- Revenue 2008 vs 2005 ')
colnames(rev_2008_vs_2005) <- 'Percent Revenue_2008_vs_2005'
rev_2008_vs_2005

print(' -------------- Revenue 2008 vs 2007 ')
colnames(rev_2008_vs_2007) <- 'Percent Revenue_2008_vs_2007'
rev_2008_vs_2007

print('----------------  THE END')


sqrt(729)
b = 1947.0
as.character(b)
v = 1:6
class(v)
v = c(1, '10', T)
class(v)
v = as.character(c(1:26))
v[1] = "a"
v
names = c("VijayBaba", "ShreedharTwat", "PrateekPleb")
names
length(names)
names[1]
names[1:2]
names[2:3]
names[c(2,3)]
sort(names)
sort(names, decreasing=TRUE)
x = rep("a", 2)
y = seq(1:11)
z = c(x, y)
z

num = c(1, 2, NA, 4)
na.omit(num)

ran = 1:100
ran
samp = sample(ran, 50)
samp2 = sample(ran, 40, replace=TRUE)
class(samp)
a = LETTERS[1:26]
a
a = 1:999999999
summary(samp2)


## create variable y, such that cor(x,y) == r
rcor <- function(x,r) {
    e <- rnorm(length(x), mean=0, sd=sqrt(1-r^2))
    mx <- mean(x)
    sx <- sd(x)
    s <- (x-mx)/sx
    (r*s + e)*sx + mx
}

## create a variable that corresponds to a true dmr in a dataset
## 1. select a random cluster of CpG sites of minimum size
##    (defined by arguments cluster.sites, maxgap and cluster.number)
## 2. select CpG sites for DMR in the cluster (defined by dmr.sites,cluster.position)
## 3. sum standardized methylation for CpG sites in the DMR
## 4. generate variable with given correlation with the sum (defined by r).
generate.true.dmr.var <- function(mat, chr, pos, cluster.sites=40, dmr.sites=20, cluster.position=0.5, r=0.5, maxgap=500, cluster.number=NULL) {
    stopifnot(dmr.sites <= cluster.sites)
    stopifnot(cluster.position >= 0 && cluster.position <= 1)
    stopifnot(r >= 0 && r <= 1)
    ## identify clusters
    clusters <- dmrff:::bh.clusterMaker(chr, pos, maxGap=maxgap)
    cluster.size <- table(clusters)
    cluster.size <- cluster.size[which(cluster.size >= cluster.sites)]

    ## select a cluster
    if (is.null(cluster.number))
        cluster <- sample(names(cluster.size), 1)
    else {
        if (cluster.number > length(cluster.size))
            cluster.number <- 1
        cluster <- names(cluster.size)[cluster.number]
    }

    ## indices of cpg sites in the cluster
    cluster.idx <- which(clusters==cluster)

    ## indices of cpg sites in the dmr within in the cluster
    dmr.center <- max(1, floor(length(cluster.idx)*cluster.position))
    dmr.start <- max(1, dmr.center - floor(dmr.sites/2))
    dmr.end <- min(length(cluster.idx), dmr.start + dmr.sites -1)
    dmr.idx <- cluster.idx[dmr.start:dmr.end]

    ## sum CpG sites after scaling methylation
    dmr.mat <- t(scale(t(mat[dmr.idx,,drop=F])))
    dmr.avg <- colSums(dmr.mat)

    ## create a random variable correlated with the sum
    var <- rcor(dmr.avg,r)

    list(var=var, dmr.idx=dmr.idx, cluster.idx=cluster.idx)
}

## generate a random variable correlated with x
## the correlation is determined by 'distance'
## with correlation decreasing exponentially with increasing distance
generate.spatial <- function(x, distance) {
    mean.cor <- function(distance) 1/exp(distance/200)
    r <- rnorm(1, mean=mean.cor(distance), sd=0.15)
    if (r < -1) r <- -1
    if (r > 1) r <- 1
    rcor(x, r)
}

## generate DNA methylation for dataset of 'n' individuals
## with CpG sites at given positions ('pos') on a chromosome
## CpG sites are correlated with neighboring CpG sites according
## to their distance from the neighbors (see generate.spatial() above)
generate.methylation <- function(n, pos) {
    cpg.mean <- rep(NA, length(pos))
    cpg.mean[1] <- runif(1)
    cpg.change <- rnorm(length(pos), sd=0.1)
    for (i in 2:length(cpg.mean)) {
        new <- cpg.mean[i-1] + cpg.change[i]
        if (new < 0 | new > 1) cpg.change[i] <- -cpg.change[i]
        cpg.mean[i] <- cpg.mean[i-1] + cpg.change[i]
    }

    cpg.sd <- rnorm(length(pos), mean=0.2, sd=0.025)

    methylation <- matrix(NA, ncol=n, nrow=length(pos))
    methylation[1,] <- rnorm(ncol(methylation))
    distance <- tail(pos,-1) - head(pos,-1)
    for (i in 2:nrow(methylation))
        methylation[i,] <- generate.spatial(methylation[i-1,], distance[i-1])

    methylation <- t(scale(t(methylation)))
    methylation <- methylation*cpg.sd + cpg.mean
    idx <- which(methylation < 0 | methylation > 1, arr.ind=T)[,1]
    for (i in unique(idx)) {
        med.cpg <- median(methylation[i,])
        min.cpg <- min(methylation[i,])
        max.cpg <- max(methylation[i,])
        factor.min <- med.cpg/(med.cpg - min.cpg)
        factor.max <- (1-med.cpg)/(max.cpg - med.cpg)
        factor <- 1
        if (min.cpg < 0) factor <- min(factor.min, factor)
        if (max.cpg > 1) factor <- min(factor.max, factor)
        methylation[i,] <- (methylation[i,] - med.cpg)*factor + med.cpg
    }
    methylation
}

## generate random positions for 'n' CpG sites across a chromosome
## on average consecutive CpG sites are 200bp apart
generate.manifest <- function(n=1000) {
    manifest <- data.frame(chr=1, pos=sample(1:(200*n), n))
    manifest <- manifest[order(manifest$chr, manifest$pos),]
    manifest
}

## generate a dataset with methylation data and variables for 'n' samples
## with CpG site positions given by 'manifest'
generate.dataset <- function(n,manifest) {
    ## variable of interest and covariates
    data <- data.frame(variable=rnorm(n), ## variable of interest
                       covariate=rnorm(n),
                       categorical=factor(sample(0:3,n,replace=T)))

    methylation <- generate.methylation(n, manifest$pos)

    list(data=data, methylation=methylation)
}

## test associations of 'data[,varname]' with each row of 'methylation'
## adjusting for other covariates in 'data'.
ewas <- function(methylation, data, varname) {
    ret <- do.call(rbind, lapply(1:nrow(methylation), function(i) {
        fit <- lm(methylation[i,] ~ ., data=data)
        coef(summary(fit))[varname,]
    }))
    ret <- as.data.frame(ret)
    colnames(ret) <- c("estimate", "se", "t", "p.value")
    ret$p.adjust <- p.adjust(ret$p.value, "bonferroni")
    ret
}


trueGenotypes = as.matrix(read.table("data/trueGenotypes.txt"))

getMarkerCorrelations = function(mat, true) {
    cors = sapply(1:ncol(true), function(ii){
        cor(true[,ii], mat[,ii], use = "pair")
    })
    return(mean(cors, na.rm = T))
}

assessPeeling = function(filePrefix){

    newFile = as.matrix(read.table(paste0("outputs/", filePrefix)))

    print(" ")
    print(paste("Assessing peeling file:", filePrefix))
    newAcc = getMarkerCorrelations(newFile[,-1], trueGenotypes[,-1])
    print(paste("Comparing accuracies: ", round(newAcc, digits=3)))

}

assessPeeling("multilocus.dosages")
assessPeeling("hybrid.dosages")


# cat rf-grid.r | R --slave --vanilla --args TYPE TR

library(randomForest)
set.seed(0)

type <- commandArgs(TRUE)[1]

# load data
csv <- read.csv( commandArgs(TRUE)[2], header=FALSE ); tr.x <- csv[,2:ncol(csv)]
if ( 'classify' == type ) {
	tr.y <- factor(csv[,1])
} else {
	tr.y <- csv[,1]
}

best_acc   <- 0
best_mae   <- 1e10 # a dummy high value
best_mtry  <- 3
best_ntree <- 5
if ( 'classify' == type ) {
	for ( ntree in 5:10 ) {
		for ( mtry in 1:3 ) {
			rf <- randomForest( tr.y ~ ., data = tr.x, ntree=ntree, mtry=mtry, na.action=na.omit );
			rf$predicted[ is.na(rf$predicted) ] = 0;
			acc = sum( rf$predicted == rf$y ) / length(rf$y);
			if ( acc > best_acc ) {
				best_acc <- acc;
				best_mtry <- mtry;
				best_ntree <- ntree;
			}
		}
	}
} else {
	for ( ntree in 5:10 ) {
		for ( mtry in 1:3 ) {
			rf <- randomForest( tr.y ~ ., data = tr.x, ntree=ntree, mtry=mtry, na.action=na.omit );
			rf$predicted[ is.na(rf$predicted) ] = 0;
			mae = mean( abs( rf$predicted - rf$y ) )
			if ( mae < best_mae ) {
				best_mae <- mae;
				best_mtry <- mtry;
				best_ntree <- ntree;
			}
		}
	}
}
cat( sprintf( "%d %d\n", best_ntree, best_mtry ) )

# vi:nowrap:sw=4:ts=4


## Created on Tuesday, June  1, 2021 at 8:06pm EDT by WeekendEditor on WeekendEditorMachine.
## Copyright (c) 2021, SomeWeekendReading.blog.  All rights reserved.  As if you care.

toolsDir <- "../tools"                                 # Various tools available from author
source(file.path(toolsDir, "pipeline-tools.r"))        # Pipeline construction tools
source(file.path(toolsDir, "graphics-tools.r"))        # Various graphics hacks

library("glmnet")                                      # For glm()
library("plyr")                                        # For ddply()
library("PerformanceAnalytics")                        # For chart.Correlation()
library("psych")                                       # For paired.r()
library("animation")                                   # For saveGIF()
library("scatterplot3d")                               # For scatterplot3d()

##
## Research question: Should you diversify a stock portofolio with corporate bonds or
## with Treasury bonds?
##
## Some people look at low Treasury yields vs higher corporate yields, and pick the
## corporates.  I think this is wrong: a corporate bond is like a little bit of stock risk
## along with the (Treasury-like) bond risk.  You're trying to diversify away from stock
## risk by picking something that has stock risk, which is doomed to fail, or at least suboptimal!
##
## My theory of bonds is that I hold them for 2 reasons, in this priority order:
## (a) Risk (volatility) control & rebalancing: make my return's standard deviation lower,
##     and in case volatility shows up provide a store of value for rebalancing to/from stocks.
## (b) While you're waiting, try to earn some income.
##
## Given that I place a premium on (a), I sacrifice (b) and choose Treasuries.
##
## A test of this idea: can we take the return of a corporate bond index over a long time,
## and regress it on the stock market returns and Treasury returns over the same time?
##
##      CorpBondReturn = beta_0 + beta_1 * StockReturn + beta_2 * TreasuryReturn
##
## - Obviously, we mean corporates vs treasuries of approximately the same duration.
## - Also obviously, this is US-only, though it should apply elsewhere (e.g., gilts in the UK).
##
## Our strategy is (partially) supported if these (pre-specified!) things are true:
## (1) The Pearson correlation matrix shows lower Treasury/Stock correlation than
##     Corporate/Stock correlation.  (Can we quantify that with a Pearson test p-value?)
## (2) The regression, perhaps over limited time periods and perhaps for real (inflation-adjusted)
##     returns, overall has an F-statistic with a significant p-value, and a high enough
##     adjusted R^2.
## (3) The coefficient beta_1 for the stock market term has a t-statistic with a significant
##     p-value.  This indicates stock-like risk for the corporate bond, making it an inferior
##     diversifier for stock risk.
##

doit <- function(## Inputs
                 dataDir           = "./data",
                 tsmIttItcDataFile = "tsm-itt-itc-data.tsv",
                 minYear           = 1871,
                 maxYear           = 2020,
                 modernYear        = 1980,
                 minModernYear     = 1970,
                 maxModernYear     = 1990,

                 ## Outputs
                 resultsDir    = "./results",
                 txFile        = "corporates-vs-treasuries-transcript.txt",
                 corrChartFile = "correlation-chart-%s.png",
                 scattFile     = "scatterplot-3d-%s.gif",
                 cvPlotFile    = "cv-lasso-regression-%s.png",
                 startYrFile   = "start-year-dependency.png") {

  loadData <- function(dataDir, tsmIttItcDataFile, minYear, maxYear) {
    cat(sprintf("* Loading stock market, treasury, and corporate returns data"))
    f <- file.path(dataDir, tsmIttItcDataFile)         # Where the data lives
    cat(sprintf("\n  - Input file %s", f))             # Announce we're loading it
    tsmIttItcData <- read.table(f, sep = "\t", header = TRUE)
    cat(sprintf("\n  - Structure of data found:\n"))   # Show what fish we caught
    str(tsmIttItcData)                                 #

    stopifnot(colnames(tsmIttItcData) == c("Year",     # Check column names & types
                                           "TSM.Nominal", "ITT.Nominal", "ITC.Nominal",
                                           "TSM.Real",    "ITT.Real",    "ITC.Real"))
    stopifnot(class(tsmIttItcData$"Year")        == "integer" &&
              class(tsmIttItcData$"TSM.Nominal") == "numeric" &&
              class(tsmIttItcData$"ITT.Nominal") == "numeric" &&
              class(tsmIttItcData$"ITC.Nominal") == "numeric" &&
              class(tsmIttItcData$"TSM.Real")    == "numeric" &&
              class(tsmIttItcData$"ITT.Real")    == "numeric" &&
              class(tsmIttItcData$"ITC.Real")    == "numeric")
    cat(sprintf("  - Column names and types check out"))

    stopifnot(all(complete.cases(tsmIttItcData)))      # All data present?
    cat(sprintf("\n  - No missing data"))              #

    stopifnot(all(minYear <= tsmIttItcData$"Year" & tsmIttItcData$"Year" <= maxYear))
    cat(sprintf("\n  - Year range check passed: %d - %d", minYear, maxYear))

    cat("\n")                                          # Final newline

    tsmIttItcData                                      # Return the data
  }                                                    #

  correlationDifferenceSignificance <- function(df) {#
    stopifnot(ncol(df) == 3)                         # 3 columns: stock market first,
    stopifnot(grepl("^TSM\\..*$", colnames(df)[[1]]))#  then 2 bonds
    ## Does a Fisher Z-transform to get a more or less normally distributed score
    ## from the difference of the correlations, then getting the normal p-value.
    cor1 <- cor(df[, 1], df[, 2])                    #
    cor2 <- cor(df[, 1], df[, 3])                    #
    tst  <- paired.r(cor1, cor2, n = nrow(df), n2 = nrow(df), twotailed = FALSE)
    cat(sprintf("\n  - Significance of difference of correlations %.2f and %.2f (%d points):",
                cor1, cor2, nrow(df)))               #
    cat(sprintf("\n    Z = %.2f, p = %.2g", tst$"z", tst$"p"))
    tst$"p"                                          # Return the p-value
  }                                                  #

  plotCorrelations <- function(df, resultsDir, corrChartFile, scattFile, type) {

    f <- file.path(resultsDir, sprintf(corrChartFile, type))
    withPNG(f, 500, 500, FALSE, function() { chart.Correlation(df, histogram = TRUE, pch = 19) })
    cat(sprintf("\n  - Correlation chart of %s to %s", paste(colnames(df), collapse = ", "), f))
    correlationDifferenceSignificance(df)              #

    f <- file.path(resultsDir, sprintf(scattFile, type))
    saveGIF(expr = {                                   #
      withPars(function() {                            #
        ## It really wants there to be 50 frames, and not @ 0/360 degrees.
        ## We want a forward rotation, and then reverse course back to the start.
        ## Let's say we're rotating nDeg degrees and back.
        nDeg       <- 80                               #
        deltaAngle <- nDeg / 25                        #
        angles     <- seq(from = deltaAngle, to = nDeg, length.out = 25)
        angles     <- c(angles, rev(angles))           # Rotate forward then backward
        sapply(angles, function(angle) {               # Plot for each angle
          scatterplot3d(x = df[, 2], y = df[, 3], z = df[, 1],
                        type = "p", pch = 21, bg = "blue",
                        main  = sprintf("US Stocks, Treasuries, & Corporates: %s", type),
                        xlab  = colnames(df)[[2]],     # Arranges TSM on the real z axis!
                        ylab  = colnames(df)[[3]],     #
                        zlab  = colnames(df)[[1]],     #
                        mar   = c(3, 3, 3, 3),         #
                        mgp   = c(1.7, 0.5, 0),        # Gets ignored?
                        angle = angle)                 #
        })                                             #
      }, pty = "m",                                    #
         bg  = "white",                                #
         mgp = c(1.7, 0.5, 0))                         # Gets ignored?
      ## Had to throw out directory on dest file here, since it was causing
      ## bizarre errors in this very fragile software.
    }, movie.name = basename(f), interval = 0.1, ani.width = 400, ani.height = 400)
    cat(sprintf("\n  - Also, 3d scatterplot to %s\n", f))

    TRUE                                               # Flag that it was done
  }                                                    #

  doRegression <- function(df, resultsDir, cvPlotFile, type) {
    stopifnot(length(colnames(df)) == 4)               # Check that we have 4 columns of data
    stopifnot("Year" == colnames(df)[[1]])             # And that they're what we think they are
    stopifnot(grepl("^TSM\\..*$", colnames(df)[[2]]))  #
    stopifnot(grepl("^ITT\\..*$", colnames(df)[[3]]))  #
    stopifnot(grepl("^ITC\\..*$", colnames(df)[[4]]))  #

    df <- transform(df, Fold = (Year %% 3) + 1)        # Add crossvalidation fold number
    cvMdl <- cv.glmnet(x      = as.matrix(df[, c(2, 3)]),
                       y      = df[, 4, drop = TRUE],  #
                       foldid = df$"Fold",             #
                       alpha  = 1, family = "gaussian", type.measure = "mse")
    print(cvMdl)                                       #
    print(coef(cvMdl, s = "lambda.min"))               #
    f <- file.path(resultsDir, sprintf(cvPlotFile, type))
    withPNG(f, 400, 400, FALSE, function() {           #
      withPars(function() {                            #
        plot(cvMdl)                                    #
      }, pty = "m",                                    #
         bg  = "white",                                #
         mgp = c(1.7, 0.5, 0),                         #
         mar = c(3, 3, 2, 1))                          #
    })                                                 #

    mdl <- lm(as.formula(sprintf("%s ~ %s + %s",       #
                                 colnames(df)[[4]], colnames(df)[[2]], colnames(df)[[3]])),
              data = df)                               #
    print(summary(mdl))                                #
    list("cvMdl" = cvMdl, "mdl" = mdl)                 #
  }                                                    #

  startYearSensitivity <- function(tsmIttItcData, minModernYear, maxModernYear,
                                   resultsDir, startYrFile) {
    cat(sprintf("* Examining sensitivity of Treas/Corp real corr diff with start year:"))
    cat(sprintf("\n  - Start year: %d - %d", minModernYear, maxModernYear))
    cat(sprintf("\n  - End year: %d", max(tsmIttItcData$"Year")))
    expt      <- subset(tsmIttItcData,                 #
                        subset = Year >= minModernYear,#
                        select = c(Year, TSM.Real, ITT.Real, ITC.Real))
    corrPVals <<- ldply(minModernYear : maxModernYear, function(startYear) {
      foo <- subset(expt, subset = Year >= startYear, select = -Year)
      data.frame(StartYear = startYear, p = correlationDifferenceSignificance(foo))
    })                                                 #
    f <- file.path(resultsDir, startYrFile)            #
    withPNG(f, 400, 400, FALSE, function() {           #
      withPars(function() {                            #
        plot(x = corrPVals$"StartYear", y = corrPVals$"p",
             type = "b", pch = 21, bg = "blue", lty = "dotted",
             xlab = "Start Year", ylab = "Correlation Difference p-value",
             ylim = c(0.0, max(corrPVals$"p")),        #
             main = "Treas/Corp Real Correlation Diff vs Start Year")
      }, pty = "m",                                    #
         bg  = "white",                                #
         mgp = c(1.7, 0.5, 0),                         #
         mar = c(3, 3, 2, 1))                          #
    })                                                 #
    cat(sprintf("\n  - Results plotted to %s\n", f))   #
    TRUE                                               #
  }                                                    #

  ## Main body of script begins here
  withTranscript(dataDir, resultsDir, txFile, "Corporates vs Treasuries Analysis", function() {

    heraldPhase("Script Archival")                     # For peer review
    archiveAnalysisScript(resultsDir, "./corporates-vs-treasuries.r")

    heraldPhase("Loading datasets")                    # Load the dataset
    maybeAssign("tsmIttItcData", function() {          #  and sanity-check it a bit
      loadData(dataDir, tsmIttItcDataFile, minYear, maxYear)
    })                                                 #

    heraldPhase("Exploratory correlations")            #
    maybeAssign("realCorrelations", function() {       #
      cat(sprintf("* Real correlations:"))             #
      plotCorrelations(subset(tsmIttItcData, select = c(TSM.Real, ITT.Real, ITC.Real)),
                       resultsDir, corrChartFile, scattFile, "Real")
    })                                                 #
    maybeAssign("nominalCorrelations", function() {    #
      cat(sprintf("\n* Nominal correlations:"))        #
      plotCorrelations(subset(tsmIttItcData, select = c(TSM.Nominal, ITT.Nominal, ITC.Nominal)),
                       resultsDir, corrChartFile, scattFile, "Nominal")
    })                                                 #

    maybeAssign("realRegression", function() {         #
      doRegression(subset(tsmIttItcData, select = c(Year, TSM.Real, ITT.Real, ITC.Real)),
                   resultsDir, cvPlotFile, "Real")     #
    })                                                 #

    heraldPhase("Just modernity, thanks...")           # Drop distant past, different from now
    maybeAssign("tsmIttItcDataModern", function() {    # Just the recent past
      subset(tsmIttItcData, subset = Year >= modernYear)
    })                                                 #
    maybeAssign("realCorrelationsModern", function() { #
      cat(sprintf("* Real correlations:"))             #
      plotCorrelations(subset(tsmIttItcDataModern, select = c(TSM.Real, ITT.Real, ITC.Real)),
                       resultsDir, corrChartFile, scattFile, "Real 1980-2020")
    })                                                 #
    maybeAssign("realRegressionModern", function() {   #
      doRegression(subset(tsmIttItcDataModern, select = c(Year, TSM.Real, ITT.Real, ITC.Real)),
                   resultsDir, cvPlotFile,             #
                   sprintf("Real %d - %d",             #
                           min(tsmIttItcDataModern$"Year"), max(tsmIttItcDataModern$"Year")))
    })                                                 #

    heraldPhase("Start year sensitivity")              #
    maybeAssign("startYrSensDone", function() {        #
      startYearSensitivity(tsmIttItcData, minModernYear, maxModernYear, resultsDir, startYrFile)
    })                                                 #

  })                                                   #
}                                                      #


source('ifm_func.r')

# Strategy A - countertrend trading:
# When the closing price of the given stock is strictly less than the lowest low
# of the previous 5 days (not including today), if we haven't bought any shares
# of the stock, we buy in 1,000 shares (1 trading unit in Taiwan, later referred
# as 1 ticket) at opening price on the next day. Later each time this happens,
# we take an amount equivalent to all the money having used to acquire the tick-
# ets of the stock, and buy in as much as we can at opening price on the next d-
# ay. When the closing price of the given stock is strictly greater than the hi-
# ghest high of the previous 3 days (not including today), we sell out all of o-
# ur tickets at opening price on the following day (note that we consider this
# as resetting the money having used to acquire the tickets of the stock to 0).
strategy <- function(stock) {
    # Strategy.
    HI_MAX_D <- 3
    LO_MIN_D <- 5
    M_START <- max(HI_MAX_D, LO_MIN_D) + 1

    # Prepare data.
    opp <- Op(stock) # [op]en [p]rices
    clp <- Cl(stock) # [cl]ose [p]rices
    hi_max <- lag( runMax( Hi(stock), HI_MAX_D ), k=1 )
    lo_min <- lag( runMin( Lo(stock), LO_MIN_D ), k=1 )
    yesterday <- nrow(stock) - 1

    # Execute the strategy.
    pl <- setNames( rep( 0, length(clp) ), time(stock) )
    bought <- 0
    bought_n <- 0
    for (m in M_START:yesterday) {
        if ( as.numeric( clp[m] ) < as.numeric( lo_min[m] ) ) {
            to_bought_price <- as.numeric( opp[m+1] )
            to_bought_n <- max( 1, as.integer( bought / to_bought_price ) )
            bought <- bought + long( to_bought_price * to_bought_n )
            bought_n <- bought_n + to_bought_n
        }
        else if ( as.numeric( clp[m] ) > as.numeric( hi_max[m] ) ) {
            pl[m] <- -bought + short( as.numeric( opp[m+1] ) * bought_n )
            bought <- 0
            bought_n <- 0
        }
    }

    # Return [p]rofit-[l]oss.
    return(pl)
}


#library(caret) # for dummyVars
#library(RCurl) # download https data
library(Metrics) # calculate errors
library(xgboost) # model

MultiLogLoss <- function(act, pred)
{
  eps = 1e-15;
  nr <- nrow(pred)
  pred = matrix(sapply( pred, function(x) max(eps,x)), nrow = nr)
  pred = matrix(sapply( pred, function(x) min(1-eps,x)), nrow = nr)
  ll = sum(act*log(pred) + (1-act)*log(1-pred))
  ll = ll * -1/(nrow(act))
  # print (ll)
  return(ll);
}

###############################################################################

TRFile <- "TR_Mul_Feat.csv"

TrainSet <- read.csv(TRFile, header=F)
dim(TrainSet)
names(TrainSet) <- c(1:19,"class")
names(TrainSet)

###############################################################################

outcomeName <- c('class')
predictors <- names(TrainSet)[!names(TrainSet) %in% outcomeName]
adultsTrsf <- TrainSet

# play around with settings of xgboost - eXtreme Gradient Boosting (Tree) library
# https://github.com/tqchen/xgboost/wiki/Parameters
# max.depth - maximum depth of the tree
# nrounds - the max number of iterations

# take first 10% of the data only!
trainPortion <- floor(nrow(adultsTrsf)*0.4)

trainSet <- adultsTrsf[ 1:floor(trainPortion/2),]
testSet <- adultsTrsf[(floor(trainPortion/2)+1):trainPortion,]

#smallestError <- 100
#for (depth in seq(1,1,1)) {
#  for (rounds in seq(1000,1000,1)) {

    # train
	dtrain = xgb.DMatrix(data = as.matrix(trainSet[,predictors]), label = trainSet[,outcomeName])
	dtest = xgb.DMatrix(data = as.matrix(testSet[,predictors]), label = testSet[,outcomeName])
    watchlist <- list(train=dtrain, test=dtest)
    bst <- xgb.cv(data = dtrain,
                   max.depth=15, nround=10,num_class =3,
                   objective = "multi:softprob", verbose=1,eval_metric="mlogloss",
                   nthread=120,watchlist=watchlist,early.stop.round=3,nfold=5)
#    gc()

    # predict
#     predictions <- xgboost::predict(bst, as.matrix(testSet[,predictors]))
#     predictions <- matrix(predictions, ncol = 3, byrow = TRUE)
    # err <- rmse(as.numeric(testSet[,outcomeName]), as.numeric(predictions))
#     actual <- matrix(0, nrow(testSet), 3)
#     for (z in 1:nrow(testSet)){
#       actual[z,testSet[z,outcomeName]+1] <- 1
#     }
     # print (act)
    # print (dim(predictions))
#    err <- MultiLogLoss(actual,predictions)
#    if (err < smallestError) {
#      smallestError = err
#      print(paste("depth:",depth,"rounds:",rounds,"mlogloss:",err))
#      write(c("depth:",depth,"rounds:",rounds,"mlogloss:",err),ncolumns=6,sep="\t",file="result",append=T)
#    }
#  }
#}

###############################################################################


# 4. faza: Analiza podatkov

#dobiček v miljonih evrov

dobicek_regija
dobicek2 <- dobicek_regija %>% group_by(leto) %>% summarise(Profit=sum(Profit)/ 1e6)
dobicek2$leto <- parse_integer(dobicek2$leto)

graf_regresija1 <- ggplot(dobicek2, aes(x=leto, y=Profit)) + geom_point() +

  geom_smooth(method='lm', fullrange=TRUE, color='green', formula = y ~ x) +
  scale_x_continuous('leto', limits = c(2015,2025), breaks=seq(2015, 2025, 2)) +
  ylab('Dobički v milijonih evrov')+
  ggtitle('Napoved dobičkov v zdravstvu do leta 2025')
graf_regresija1


# Visualising the aesthetics

# A. Visible aesthetics
# 1. Color, shape and size attributes
ggplot(mtcars, aes(wt, mpg, color = fcyl)) +
  # Set the shape and size of the points
  geom_point(shape = 1, size = 4)

# 2. Color Vs Fill attributes
# shape: different shape values can be displayed. Value 21 allows a circle to be colored with a fill and outline
# fill: color the inside
# color: color the outline
# Map color to fam
ggplot(mtcars, aes(wt, mpg, fill = fcyl, color = fam)) +
  geom_point(shape = 21, size = 4, alpha = 0.6)

# 3. Comparing aesthetics
# Establish the base layer
plt_mpg_vs_wt <- ggplot(mtcars, aes(wt, mpg))

# Map fcyl to size
plt_mpg_vs_wt +
  geom_point(aes(size = fcyl))

# Map fcyl to alpha, not size
plt_mpg_vs_wt +
  geom_point(aes(alpha = fcyl))

# Map fcyl to shape, not alpha
plt_mpg_vs_wt +
  geom_point(aes(shape = fcyl))

# Use text layer and map fcyl to label
plt_mpg_vs_wt +
  geom_point(aes(shape = fcyl)) +
  geom_text(aes(label = fcyl))

# B. Attributes
# 1. Color, shape, size and alpha
# A hexadecimal color
my_blue <- "#4ABEFF"

ggplot(mtcars, aes(wt, mpg)) +
  # Set the point color and alpha
  geom_point(color = my_blue, alpha = 0.6)

# Change the color mapping to a fill mapping
ggplot(mtcars, aes(wt, mpg, fill = fcyl)) +
  # Set point size and shape
  geom_point(color = my_blue, size = 10, shape = 1)

# 2. Conflicts with aesthetics
ggplot(mtcars, aes(wt, mpg, color = fcyl)) +
  # Add point layer with alpha 0.5
  geom_point(alpha = 0.5)

ggplot(mtcars, aes(wt, mpg, color = fcyl)) +
  # Add text layer with label rownames(mtcars) and color red
  geom_text(label = rownames(mtcars), color = "red")

ggplot(mtcars, aes(wt, mpg, color = fcyl)) +
  # Add points layer with shape 24 and color yellow
  geom_point(shape = 24, color = "yellow")

# 3. Going all out
# 5 aesthetics
ggplot(mtcars, aes(mpg, qsec, color = fcyl, shape = fam, size = hp / wt)) +
  geom_point()

# C. Modifying aesthetics
# 1. Updating aesthetics labels
ggplot(mtcars, aes(fcyl, fill = fam)) +
  geom_bar() +
  # Set the axis labels
  labs(x = "Number of Cylinders", y = "Count")

# Using the scale_fill_manual
palette <- c(automatic = "#377EB8", manual = "#E41A1C")

ggplot(mtcars, aes(fcyl, fill = fam)) +
  geom_bar() +
  labs(x = "Number of Cylinders", y = "Count") +
  # Set the fill color scale
  scale_fill_manual("Transmission", values = palette)

# Adding a position parameter
palette <- c(automatic = "#377EB8", manual = "#E41A1C")

# Set the position so that the bars are side by side
ggplot(mtcars, aes(fcyl, fill = fam)) +
  geom_bar(position = "dodge") +
  labs(x = "Number of Cylinders", y = "Count")
  scale_fill_manual("Transmission", values = palette)

# 2. Setting a dummy aesthetic. Can setup limits on plots
# Plot 0 vs. mpg
ggplot(mtcars, aes(mpg, 0)) +
  # Add jitter
  geom_point(position = "jitter")

# define the y limits range
ggplot(mtcars, aes(mpg, 0)) +
  geom_jitter() +
  # Set the y-axis limits
  ylim(-2, 2)


# I am looking for one who can recompile existing functions in R or C++ to
# implement our idea on that.
# This example how we can inject our codes in differential testing
# obtained from https://github.com/satijalab/seurat/blob/master/R/differential_expression.R

ExpMean <- function(x, ...) {
  if (inherits(x = x, what = 'AnyMatrix')) {
    return(apply(X = x, FUN = function(i) {log(x = mean(x = exp(x = i) - 1) + 1)}, MARGIN = 1))
  } else {
    return(log(x = mean(x = exp(x = x) - 1) + 1))
  }
}

DifferentialAUC <- function(x, y) {
  require(ROCR)
  prediction.use <- prediction(
    predictions = c(x, y),
    labels = c(rep(x = 1, length(x = x)), rep(x = 0, length(x = y))),
    label.ordering = 0:1
  )
  perf.use <- performance(prediction.obj = prediction.use, measure = "auc")
  auc.use <- round(x = perf.use@y.values[[1]], digits = 3)
  return(auc.use)
}

AUCMarkerTest <- function(data1, data2, mygenes, print.bar = TRUE) {
  myAUC <- unlist(x = lapply(
    X = mygenes,
    FUN = function(x) {
      return(DifferentialAUC(
        x = as.numeric(x = data1[x, ]),
        y = as.numeric(x = data2[x, ])
      ))
    }
  ))
  myAUC[is.na(x = myAUC)] <- 0
  iterate.fxn <- ifelse(test = print.bar, yes = pblapply, no = lapply)
  avg_diff <- unlist(x = iterate.fxn(
    X = mygenes,
    FUN = function(x) {
      return(
        ExpMean(
          x = as.numeric(x = data1[x, ])
        ) - ExpMean(
          x = as.numeric(x = data2[x, ])
        )
      )
    }
  ))
  toRet <- data.frame(cbind(myAUC, avg_diff), row.names = mygenes)
  toRet <- toRet[rev(x = order(toRet$myAUC)), ]
  return(toRet)
}

MarkerTest <- function(
  data.use,
  cells.1,
  cells.2,
  verbose = TRUE
) {
  to.return <- AUCMarkerTest(
    data1 = data.use[, cells.1, drop = FALSE],
    data2 = data.use[, cells.2, drop = FALSE],
    mygenes = rownames(x = data.use),
    print.bar = verbose
  )
  to.return$power <- abs(x = to.return$myAUC - 0.5) * 2
  return(to.return)
}


#' Matrix Exponentiation
#'
#' Matrix exponentiation via Pade' approximations.
#'
#' @param x
#' A numeric matrix.
#' @param p
#' Order of the Pade' approximation.  Should be between 1 and 13.
#' 6 is typical.
#'
#' @return
#' exp(x)
#'
#' @export
expm <- function(x, p=6)
{
  if (nrow(x) != ncol(x))
    stop("Matrix exponentiation is only defined for square matrices.")

  if (p < 1L || p > 13L)
    stop("argument 'p' must be between 1 and 13.")

  if (!is.double(x))
    storage.mode(x) <- "double"

  exp <- .Call(R_libexpm_expm_5_1, x, as.integer(p))

  return( exp )
}