#' pGLS model comparison using phylogenetic analysis of covariance (gls.ancova)
#'
#' Computes F-ratio test of GLS models that include different sets of indicator variables.
#' @param form Model formula.
#' @param Sigma Matrix describing the covariance among data points. For the phylogenetic regression, this is based on a phylogeny (vcv(tree)).
#' @param ReducedModel The GLS model that includes the fewest indicator variables.
#' @param FullModel The GLS model that includes the fewest indicator variables.
#' @return Anova table.
#' @references Smaers & Rohlf (2016) Testing species' deviations from allometric preductions using the phylogenetic regression. Evolution. 70 (5): 1145-1149.
#' @examples see https://smaerslab.com/software/
#' @export

gls.ancova<-function (form, Sigma, ReducedModel, FullModel)
{
    Y<-c(data[,which(colnames(data)==all.vars(form)[1])])
    n <- length(Y); tr <- sum(diag(Sigma)); Sigma <- n * Sigma/tr; invSigma <- solve(Sigma)
    df_ReducedModel <- c(length(ReducedModel[1, ])); df_FullModel <- c(length(FullModel[1, ]))

    C <- solve(t(ReducedModel) %*% invSigma %*% ReducedModel)
    B <- C %*% t(ReducedModel) %*% invSigma %*% Y
    SS_unexpl_ReducedModel <- (t(Y - (ReducedModel %*% B)) %*% invSigma %*% (Y - (ReducedModel %*% B)))
    MS_unexpl_ReducedModel <- SS_unexpl_ReducedModel/c(n-df_ReducedModel)

    C <- solve(t(FullModel) %*% invSigma %*% FullModel)
    B <- C %*% t(FullModel) %*% invSigma %*% Y
    SS_unexpl_FullModel <- (t(Y - (FullModel %*% B)) %*% invSigma %*% (Y - (FullModel %*% B)))
    MS_unexpl_FullModel <- SS_unexpl_FullModel/c(n-df_FullModel)

    Fs <- ((SS_unexpl_ReducedModel - SS_unexpl_FullModel)/(c(n-df_ReducedModel) - c(n-df_FullModel)))/(SS_unexpl_FullModel/c(n-df_FullModel))
    P <- 1 - pf(Fs, (c(n-df_ReducedModel) - c(n-df_FullModel)), c(n-df_FullModel))

    Output <- as.data.frame(cbind(rbind(df_FullModel, df_ReducedModel),
        rbind(round(SS_unexpl_FullModel, 4), round(SS_unexpl_ReducedModel, 4)), rbind(round(MS_unexpl_FullModel, 4), round(MS_unexpl_ReducedModel, 4)), rbind(round(Fs, 4), ""), rbind(round(P, 4), "")))
    colnames(Output) <- c("df", "Sum Sq", "Mean Sum Sq", "F value", "Pr(>F)")
    rownames(Output) <- c("FullModel", "ReducedModel")
    return(Output)
}


##CHAPTER 4
library(modreg)
aux <- read.table("Data/Sr.dat")
x <- aux[,1]; y <- aux[,2]

postscript("Plots/plot-04-01.ps",horizontal=T)
plot(x,y,xlab="Time in millions of years", ylab="Strontium ratios")
abline(v=66.4)
dev.off()

pen <- c(0.1,.5,1,1.5)
postscript("Plots/plot-04-02.ps",horizontal=F)
par(mfrow=c(2,2))
sapply(1:length(pen),function(i){
plot(x,y,xlab="Time in millions of years", ylab="Strontium ratios",main=paste("penalty=",as.character(pen[i])))
  smooth <- smooth.spline(x,y,spar=pen[i])
  lines(smooth$x,smooth$y,lty=i,lwd=1.5)
})
dev.off()


library(corrplot)

# Load data
load("data_generated/Pregnancy_somalogic.RData")

si = info.soma$Visit < 4
sum(si)
info.soma = info.soma[si,]
dat.soma = dat.soma[si,]
colnames(dat.soma) = ann.soma$TargetFullName

# read old 8 somamers
s8 = fread("data/pred.soma.old.txt", sep="\t", header = F) %>% pull(1)

# read new 7 somamers
s7 = fread("data/pred.soma.new.txt", sep = "\t", header = F) %>% pull(1)

ss = c(s8,s7)
i.mod = match(ss, ann.soma$TargetFullName)

dat2 = dat.soma[, i.mod]

cc.mat = cor(dat2)
colnames(cc.mat) = NULL

png("figures/soma_8_vs_7_correlation.png", w=650, h=400)
corrplot(cc.mat, col=colorRampPalette(c("blue","white","red"))(10), tl.col="black")
dev.off()


library(Skillings.Mack)

mon=read.csv('mon_ary.txt')
tue=read.csv('tue_ary.txt')
wed=read.csv('wed_ary.txt')
thu=read.csv('thu_ary.txt')
fri=read.csv('fri_ary.txt')

df=cbind(mon,tue,wed,thu,fri)
colnames(df)=c('mon','tue','wed','thu','fri')
df.t=t(df)
result=Ski.Mack(df.t)
result$adjustedSum
result$varCovarMatrix
# p-value = 8e-6
# 统计量statistic = 29.08
# covariance matrix
#      [,1]  [,2]  [,3]  [,4]  [,5]
#[1,]  5638 -1436 -1418 -1400 -1384
#[2,] -1436  5744 -1455 -1436 -1417
#[3,] -1418 -1455  5752 -1449 -1430
#[4,] -1400 -1436 -1449  5729 -1444
#[5,] -1384 -1417 -1430 -1444  5675
# adjusted sum
#            [,1]        [,2]         [,3]         [,4]        [,5]
#[1,] 214.4152105 44.76001373 -36.15830105 -369.5651881 146.5482649


#!/bin/env Rscript

#write.table(data, "mama2.csv", sep="\t", quote = F, row.names = F)
data = read.table("713d498cc2f06d5e83d03c443691fb18.csv", header=T)
mean(abs(data$Diff));
hist(data$Diff);
boxplot(data$Diff)
plot(density(data$Diff))
sort(-table(abs(data$Diff)))[1] #mode

plot(ecdf(abs(data$Diff)))
ecdf(abs(data$Diff))(90)

quantile(abs(data$Diff), c(.50, .60, .75, .85, .90, .95, .97))

data2 <- data[order(data$Audio),]
plot(data2$Audio, abs(data2$Diff), type="l")
plot(aggregate(abs(data$Diff), by=list(data$Audio), FUN=mean), type="b")

#install.packages("plotrix")
install.packages("ggplot2")
library(ggplot2)

sd(abs(data$Diff))
shapiro.test(rnorm(100, mean = 17.775, sd = 17.05517))
wilcox.test(abs(data$Diff), conf.int = TRUE, conf.level = 0.95)

angle_diff <- function(a, b){
	diff = a - b;
	while (diff < -180) { diff = diff + 360; }
	while (diff > 180) { diff = diff - 360; }
	diff
}
data$new <- mapply(angle_diff, data$Clicked, data$Audio)
data$new <- mapply(angle_diff, -data$Clicked, data$Audio) #pro otoceny sluchatka

setwd("rdata");
files = list.files(pattern="*.csv")
data = NULL
for (i in 1:length(files)) data = rbind(data, read.table(files[i], header=T))

stat = NULL
for (i in 1:length(files)) { data = read.table(files[i], header=T); stat = rbind(stat, cbind(files[i], mean(abs(data$Diff)))); }

t.test(abs(data$Diff))
t.test(abs(data$Diff), conf.level=0.97)

#vykreslit
svg("out.svg")
hist(data$new, breaks=15)
dev.off()

#Directional
https://cran.r-project.org/web/packages/circular/circular.pdf
https://cran.r-project.org/web/packages/Directional/Directional.pdf

install.packages("circular")
install.packages("Directional")
circ.cor1(theta, phi, rads = FALSE)
spml.reg(y, x, rads = FALSE, seb = TRUE)

Directional::circ.cor1(data$Audio, data$Click, rads = FALSE)

#Polar plot
datapolar = aggregate(abs(data$Diff), by=list(data$Audio), FUN=mean)

library(plotrix)
polar.plot(datapolar$x,datapolar$Group.1,main="Polar Plot",radial.lim=c(0,45),start=90,clockwise=TRUE,lwd=3,line.col="blue",rp.type="polygon")
polar.plot(smooth.spline(datapolar$x)$y,datapolar$Group.1,main="Polar Plot",radial.lim=c(0,45),start=90,clockwise=TRUE,lwd=3,line.col="blue",rp.type="polygon")

#Vyhlad
plot(smooth.spline(datapolar$x)$y)
plot(smooth(datapolar$x))

#Moving average
http://www.markhneedham.com/blog/2014/09/13/r-calculating-rolling-or-moving-averages/
mav <- function(x,n=5){filter(x,rep(1/n,n), sides=2)}
mav(c(4,5,4,6), 3)

library(zoo)
rollmean(c(4,5,4,6), 3)

#Vyhlazeny polar plot
polar.plot(datapolar$x,datapolar$Group.1,radial.lim=c(0,45),start=90,clockwise=TRUE,lwd=3,line.col="blue",rp.type="s")
polar.plot(datapolar$x,datapolar$Group.1,main="Polar Plot",radial.lim=c(0,45),start=90,clockwise=TRUE,lwd=2,line.col="blue",rp.type="polygon", add=T)
polar.plot(smooth.spline(datapolar$x)$y,datapolar$Group.1,main="Polar Plot",radial.lim=c(0,45),start=90,clockwise=TRUE,lwd=2,line.col="red",rp.type="polygon",add=T)


library(pbdPAPI)

### ~40MiB
m <- 50000
n <- 100

x <- matrix(rnorm(m*n), m, n)
y <- matrix(rnorm(m), m, 1)

op <- expression(lm.fit(x=x, y=y))

report <- system.flops(eval(op))
count <- report$flpops
theoretical <- 2*n^2*(m-n/3)
mflops <- report$mflops

data.frame(m=m, n=n, measured=count, theoretical=theoretical, difference=count-theoretical, "pct.error"=(1.0 - (theoretical/count))*100, mflops=mflops)


#' @export
#' @title bio.blue
#' @description This function generates a vector of shades of blue (from white to blue) of the length selected by value of \code{n}.
#' @param \code{n} = the number of colors desired
#' @param \code{alpha} = the transparency desired (default is fully opaque/1)
#' @return character vector
#' @examples
#' bio.blue(5)
#' [1] "#FFFFFFFF" "#AAAAFFFF" "#5555FFFF" "#0000FFFF"
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
bio.blue <- function (n, alpha=1) {
    if ((n <- as.integer(n[1])) > 0) {
      blue = 4/6
      c( hsv( h = blue,
              s = seq(0, 1, length = (n-1)),
              v = 1,
              alpha = alpha )
       )
    }
  }


forecasters=c("ARIMA", "ARIMA101", "CS", "MEAN", "NAIVE", "ETS" ,"SES", "MEANJAVA", "CROSTON")
inputPath="output-data/wikiGer24_Oct11_21d-"
outputPath="output-plots/wikiGer24_Oct11_21d-"
fileExtension=".csv"
sequence_count=sequence(504)

calculateMASE <- function(f,y) { # f = vector with forecasts, y = vector with actuals
  if(length(f)!=length(y)){ stop("Vector length is not equal") }
  n <- length(f)
  return(mean(abs((y - f) / ((1/(n-1)) * sum(abs(y[2:n]-y[1:n-1]))))))
}

sanitizedMASE <- function(f,y) {
  # Check for precondition (equal length of both vectors)
  if(length(f) != length(y)) {
    stop("Vector length is not equal")
  }
  data = c()
  n <- length(f)

  # Collect all pairs collecting no NaN values
  for(i in 1:n){
    if(is.nan(f[i]) | is.nan(y[i])){
      # NaN pairs should not be used
      # so do nothing
    } else {
      data <- c(data,i)
    }
  }

  # construct new vectors without the pairs containing NaNs
  newF <- c()
  newY <- c()
  for(i in 1:length(data)) {
    newF <- c(newF,f[data[i]])
    newY <- c(newY,y[data[i]])
  }

  # calculate MASE with sanitized vectors and return it
  return(calculateMASE(newF,newY))
}

for (i in forecasters)
{
  filenamex=paste(inputPath,i,fileExtension,sep="")
  if(file.exists(filenamex)){
    results=read.table(file=filenamex, header=TRUE, sep=";", dec=".")
    printMase=FALSE
    maseString=""

    if(results$confidence[1] > 0)
    {
      printMase=TRUE
      start=1
      end=length(results$forecast)
      mase=sanitizedMASE(f=results$forecast[start:end],y=results$pageRequests[start:end])
      maseString = paste(" (MASE: ",mase,")",sep="")
      # print(paste(i,": ",mase,sep=""))
    }

    pdf(width=42,file=paste(outputPath, i, ".pdf",sep=""))
    plot(x=sequence_count,y=results$pageRequests,type="l",main=paste(i, maseString, sep=""),ylab="Page Requests",xlab="")
    lines(x=sequence_count,y=results$forecast,type="l",col="red")

    colors=c("black", "red")
    legends=c("Measurements", "Forecasts")

    if(printMase) {
      lines(x=sequence_count,y=results$confidenceUpper,lty=2,col="gray")
      lines(x=sequence_count,y=results$confidenceLower,lty=2,col="gray")
      colors=c("black", "red", "gray", "gray")
      legends=c("Measurements", "Forecasts (95% CI)", "Upper Confidence (95% CI)", "Lower Confidence (95% CI)")
    }

    # abline(h=mase,col="yellow")
    legend(
      "topleft",
      col=colors,
      lty=1,
      legend=legends)
    dev.off()
  }
}


old <- rbinom(n = 10000, size = 337, p = 0.1)
print(sum(old)/10000)


rm(list=ls())

A <- 1

A
A+6
B = 2
B
A <- B
A   #Ahora A toma el valor de B, y B continua conservando el mismo valor
B
## R base

#Redefinimos los valores A y B
A <-  10
B  <-  20
#Realizamos comparaciones lógicas

A >  B
A >= B
A <  B
A <= B
A == B
A != B

C <- A != B
C
## Operadores aritméticos:

#suma
A <- 5+6
A
#Resta
B <- 6-8
B
#cociente
C <- 6/2.5
C
#multiplicacion
D <- 6*2.5
D

## Funciones:
paste("Pega","estas",4,"palabras", sep = " ")

#Puedo concatenar caracteres almacenados en objetos
paste(A,B,C,sep = "**")

# Paste0 pega los caracteres sin separador
paste0(A,B,C)

1:5

sum(1:5)
mean(1:5,na.rm = TRUE)

A <-  1
class(A)

A <-  paste('Soy', 'una', 'concatenación', 'de', 'caracteres', sep = " ")
A
class(A)

A <- factor("Soy un factor, con niveles fijos")
class(A)

### Vectores

C <- c(1, 3, 4)
C

C <- C + 2
C

D <- C + 1:3 #esto es equivalente a hacer 3+1, 5+2, 6+9
D

E <- c("Carlos","Federico","Pedro")
E

E[2]

elemento2 <-  E[2]
elemento2
rm(elemento2)
elemento2
E[2] <- "Pablo"
E

### Data Frames

INDICE  <- c(100,   100,   100,
             101.8, 101.2, 100.73,
             102.9, 102.4, 103.2)

FECHA  <-  c("Oct-16", "Oct-16", "Oct-16",
             "Nov-16", "Nov-16", "Nov-16",
             "Dic-16", "Dic-16", "Dic-16")

GRUPO  <-  c("Privado_Registrado","Público","Privado_No_Registrado",
             "Privado_Registrado","Público","Privado_No_Registrado",
             "Privado_Registrado","Público","Privado_No_Registrado")

Datos <- data.frame(INDICE, FECHA, GRUPO)
Datos

Datos$FECHA
Datos[3,2]
Datos$FECHA[3]

Datos$FECHA[3,2]

Datos[Datos$FECHA=="Dic-16",]

###Por separado
Indices_Dic <- Datos$INDICE[Datos$FECHA=="Dic-16"]
Indices_Dic

mean(Indices_Dic)

### Todo junto
mean(Datos$INDICE[Datos$FECHA=="Dic-16"])

### Listas
superlista <- list(A,B,C,D,E,FECHA, DF = Datos, INDICE, GRUPO)
superlista

superlista$DF$FECHA[2]

# Lectura y escritura de archivos

## .csv  y  .txt
individual_t117 <- read.table(file = 'Fuentes/usu_individual_t117.txt',sep=";", dec=",", header = TRUE, fill = TRUE)

#View(individual_t117)
names(individual_t117)
summary(individual_t117)[,c(8,10,31,133)]
head(individual_t117)[,1:5]

## Excel
# install.packages("openxlsx") # por única vez
library(openxlsx) #activamos la librería

#creamos una tabla cualquiera de prueba
x <- 1:10
y <- 11:20
tabla_de_R <- data.frame(x,y)

# escribimos el archivo
write.xlsx( x = tabla_de_R, file = "archivo.xlsx",row.names = FALSE)
#Donde lo guardó? Hay un directorio por default en caso de que no hayamos definido alguno.
getwd()

#Si queremos exportar multiples dataframes a un Excel, debemos armar previamente una lista de ellos. Cada dataframe, se guardará en una pestaña de excel, cuyo nombre correspondera al que definamos para cada Dataframe a la hora de crear la lista.
Lista_a_exportar <- list("Indices Salarios" = Datos,
                         "Tabla Numeros" = tabla_de_R)

write.xlsx( x = Lista_a_exportar, file = "archivo_2_hojas.xlsx",row.names = FALSE)

#leemos el archivo especificando la ruta (o el directorio por default) y el nombre de la hoja que contiene los datos
Indices_Salario <- read.xlsx(xlsxFile = "archivo_2_hojas.xlsx",sheet = "Indices Salarios")
#alternativamente podemos especificar el número de orden de la hoja que deseamos levantar
Indices_Salario <- read.xlsx(xlsxFile = "archivo_2_hojas.xlsx",sheet = 1)
Indices_Salario

Clase 1 - Conceptos Principales de EPH y R Base/Clase 1- Introduccion.r


# Test de hipótesis (t test), errores Tipo I y II, significancia estadística (p-values).
#################################################################
cat("\014")
rm(list=ls())
graphics.off()

#################################################################
# Motivacion
#################################################################

# Hasta el momento sabemos interpretar las primeras dos columnas de nuestra tabla de regresion.
# Es decir, (a) los betas (Estimadores o Coeficientes) y (b) el error estandard.
# Tambien sabemos (c) que son los intervalos de confianza y cual es su relacion con los
# errores estandard. Sin embargo, hasta el momento no sabemos que son esas estrellas
# que aparecen en nuestra tabla.

# Esto es lo que aprenderemos hoy. El coeficiente nos dice el tamano del efecto.
# Sin embargo, hay una posibildiad de que estemos equivocados. Recuerda,
# nuestra logica es frecuentista. El 95% de confianza significa que si
# el mismo fenomeno se repitiera 100 veces, 95 veces sucederia lo que estamos
# prediciendo.

# Como hacemos este calculo? Esto esta muy relacionado a los intervalos de confianza.
# Para esto, necesitamos hacer tests de hipotesis y CALCULAR
# CUAN CERCANOS O LEJANOS ESTAMOS DE QUE NUESTROS BETAS SEAN LO QUE NOSOTROS
# CREEMOS QUE SON.

#################################################################
# Estimemos un modelo
#################################################################

# Cargar paquete para cargar bases que no son de R.
# install.packages("foreign")
library(foreign) # significa "foraneo"
options(scipen = 1000000) # apagar notacion cientifica.
dat = read.dta("https://github.com/hbahamonde/OLS/raw/master/Datasets/cow.dta")

# Hoy pensaremos en que factores ayudan a subir la poblacion en los paises.

# (1) Que relacion podria haber entre poblacion y democracia?
# (2) Que relacion podria haber entre poblacion y represion politica?

# Modelo
modelo.1 = lm(pop ~ democracy + repression, dat)

# resumen del modelo
options(scipen = 1000000) # apagar notacion cientifica.
summary(modelo.1)

# (1) Que podemos deducir de nuestro modelo? (Interpreta la tabla)

# Checklist: (SIEMPRE EJECUTAR ESTE CHECKLIST)
## (1) Interpretar estimadores.
summary(modelo.1)

## (2) Observar los errores estandard.
summary(modelo.1)

## (3) Checkear normalidad de los residuos: y' con residuos.
plot(modelo.1$fitted.values, modelo.1$residuals)

## (4) Checkear significancia estadistica (asunto de hoy).
summary(modelo.1)

#################################################################
# Significancia Estadistica: p-values
#################################################################

## Significancia: en simple, es la probabilidad de que nuestros betas sean 0.
## Es decir, la probabilidad de que, por ej., beta(1) no sea 2345, si no que 0.
## En este caso, hay un 69,84% de probabilidad de que el efecto sea 0.
## Asi mismo, hay un 24.41% de que beta(2) no sea 18707, si no que sea 0.

## (1) Hasta que punto debieramos rechazar la idea de que b1=0? Cual es el
## % "magico" que nos diga "ok, estoy segur@ de que b1=0 y no b1=2345?

## Estrellas denotan significancia.
### * = la probabilidad de que el beta sea 0 es igual/menor al 1%
### ** = la probabilidad de que el beta sea 0 es igual/menor al 0.1%
### *** = la probabilidad de que el beta sea 0 es igual a 0%

## Otros niveles:
### . = la probabilidad de que el beta sea 0 es igual al 5%

## (4) Checkear significancia estadistica:
### Que podemos decir de la significancia estadistica de nuestros coeficientes?

#################################################################
# Apliquemos lo que sabemos respecto a Intervalos de Confianza
#################################################################

# p-values e intervalos de confianza estan altamente relacionados.

# Plotear modelo
# install.packages("coefplot")
library(coefplot)
coefplot(modelo.1, strict = T) # plot de coeficientes

# mostrar el detalle de los intervalos de confianza
confint(modelo.1, strict = T)

#################################################################
# Pero ocurre algo muy raro aqui....?
#################################################################

# (1) Que similitudes encontramos entre nuestra tabla de regresion,
# "confint" y "coefplot"? Las tres herramientas nos estan comunicando el mismo
# mensaje de alerta.... o no?

# (2) Pero que diferencias encontramos entre la tabla, coefplot/confint?

# Veamos mas en detalle el problema...
# install.packages("effects")
library(effects)
plot(allEffects(modelo.1))

# otro ejemplo
options(scipen = 999999) # apagar notacion cientifica.
library(ggeffects)
mydf <- ggpredict(modelo.1)

mydf # ve los resultados.

plot(mydf$democracy)
plot(mydf$repression)

# (3) Que podemos concluir?

#################################################################
# OK, misterio resuelto. Y es por esto que necesitamos pensar en P-values
#################################################################

# En nuestra tabla de regresion, el "p-value" esta dado por la probabildiad de que
# el "valor t" ("t value") sea mayor al numero absoluto de t (en la tabla,
# esta denotado por "Pr(>|t|)").

# Volvamos a mirar la tabla
summary(modelo.1)

# Vamos por parte.
# Primero, veamos lo que el p-value es (los numeros en la columna  "Pr(>|t|)").

# (1) Un p-value es la probabilidad de que nuestro efecto sea "falso".
# Esto en matematicas significa que nuestro efecto sea realmente "0".

# (2) Como es una probabilidad, el p-value (o valor "p") es una escala
# que va de 0 a 1.

# (3) En ciencias sociales, existe la convencion de que un p-value
# superior al 5%, se cuenta como "falso." Es decir, cuando nuestro p-value,
# que es nuestra probabilidad de que nuestro efecto sea falso/cero, es mayor a 5%,
# concluimos que el efecto es "realmente" cero. Ahora, si el p-value es menor
# a 5%, consideramos que la probabilidad de que sea falso es chica, y podemos
# creer que nuestro efecto en realidad es "verdadero" o mas bien "no-cero" o "no falso".

# Recuerda: 5% significa 5/100=0.05. Entonces, un p-value menor a 0.05 indica que
# nuestro efecto es verdadero o "no-falso", y un p-value mayor a 0.05 indica que nuestro efecto es falso/0. Es por esto que los p-values de los coeficientes que son iguales o menores a 0.05 tienen estrellas, y los que son mayores no tienen.

#################################################################
# Estadistico T
#################################################################

# Lo siguiente es el "t value" o "valor t" (o "estadistico t").
# El t value es el coeficiente/error estandard.

48303/19052
2345/6036
18707/15973

# Esto significa que cuando el error estandard es grande (lo que es "malo"),
# t value se vuelve mas chico. Nosotros queremos lo contrario. Ojala t values
# que son cercanos a dos. En general, esos t values tienen un p-value < 0.05.

# En otras palabras, el t value es una medida de dispersion de nuestra estimacion.
# Mientras mas dispersa, mas alta es la probabilidad de que--en su dispersion--
# nuestra estimacion toque el cero.

#################################################################
# Al pensar en los p-values y los intervalos de confianza,
# hemos tratado de minimizar nuestros Errores Tipo 1 y 2.
#################################################################

# La logica en investigacion en ciencias sociales tiene que ver con la idea de
# ver si hay suficiente evidencia en contra de la "hipotesis nula" (es decir, no hay efecto). En otras palabras, un@ no trata de buscar "verdades" (o estimaciones estadisticamente
# significativas). Un@ trabaja con estimaciones que son hasta 5% falsas (o 95% verdaderas).

# En concreto, un@ trata de minimizar la posibildiad del error "Tipo 1".

# Error Tipo 2: falsos negativos.
# Error Tipo 1: falsos positivos.

# Definir ambos.

#################################################################
# Pensamiento Critico
#################################################################

# P-values.
#----

## (1) Criticas al p-value. Por que 5% y no 3% por ejemplo?
## (2) Comunicando resultados: tablas con CI en vez de estrellas.

# install.packages("texreg")
library(texreg)
screenreg(modelo.1, ci.force = F)

### Tabla que incorpora estas criticas
# install.packages("texreg")
library(texreg)
screenreg(modelo.1, ci.force = T) # nuestro paquete "screenreg" que ya conocemos,
# pero ahora, forzando los intervalos de confianza ("confidence intervals"), por
# eso, "ci.force = T" ("T" por "true").

# Asintotica
#----

## Asintotica, recordemos, es la idea frecuentista de tener
## una base de datos infinita. Como esto es imposible,
## "el mal menor" es tener la mayor cantidad de datos: mientras mas, mejor.

### Demostrar en la pizarra que esto puede llegar a conducir a otros problemas.
### Mas datos, varianza es mas chica, el valor esperado mas preciso.

#### (1) Mientras mas datos tenemos, nuestras distribuciones se ponen mas perfectas,
#### delgadas, y precisas. Eso hace que encontremos independencia estadistica mas facil.
#### (2) Falsos positivos!

hist(rnorm(10,0,1))
hist(rnorm(50,0,1))
hist(rnorm(250,0,1))
hist(rnorm(2500000,0,1))


tsort <- function(deps) {
	nm <- names(deps)
	libs <- union(as.vector(unlist(deps)), nm)

	s <- c()
	# first libs that depend on nothing
	for(x in libs) {
		if(!(x %in% nm)) {
			s <- c(s, x)
		}
	}

	k <- 1
	while(k > 0) {
		k <- 0
		for(x in setdiff(nm, s)) {
			r <- c(s, x)
			if(length(setdiff(deps[[x]], r)) == 0) {
				s <- r
				k <- 1
			}
		}
	}

	if(length(s) < length(libs)) {
		v <- setdiff(libs, s)
		stop(sprintf("Unorderable items :\n%s", paste("", v, sep="", collapse="\n")))
	}

	s
}


#optim function minimizes 'f'; c vector are starting values; lower is the
#constraint; I choose a null gradient because it was easiest to get up and running
#note that here the beta parameter is hard coded in as equal to 1
rm(list = ls())
#ap5 = .17
#a0 = ap5 + .5
#anp5 = ap5 + 1

ap5 = 1.27
a0 = 1.27
anp5 = 1.27

h <- function(WB,al) {

sy=1
sz=1

f <- function(B,WB,al) {
  Bp5 <- B[1]
  B0 <- B[2]
  Bnp5 <- B[3]
  -WB*((1/(1+exp(al - B0 + a0)))*(1/(1+exp((al - .5 - Bnp5 + anp5)/sy))) + (1/(1+exp(al - B0 + a0)))*(1/(1+exp((al + .5 - Bp5 + ap5)/sz))) + (1/(1+exp((al + .5 - Bp5 + ap5)/sz)))*(1/(1+exp((al - .5 - Bnp5 + anp5)/sy))) - 2*(1/(1+exp(al - B0 + a0)))*(1/(1+exp((al - .5 - Bnp5 + anp5)/sy)))*(1/(1+exp((al + .5 - Bp5 + ap5)/sz)))) + B0 + Bp5 + Bnp5
}

o <- optim(c(1,1,1,WB,al),function(B) f(B,WB,al),gr=NULL,method = "L-BFGS-B", lower = c(0,0,0), control = list(maxit=100000))
#o <- constrOptim(c(0.01,0.01,0.01,WB,al),function(B) f(B,WB,al),gr=NULL,method = "Nelder-Mead", ui = rbind(c(1,0,0),c(0,1,0),c(0,0,1)),ci=c(0,0,0))

X = round(- al -a0 + o$par[2], digits = 2)       #B0   these are shorthand variables for the exponents
Y = round(.5 - al -anp5 + o$par[3], digits = 2)    #Bnp5  in the logistic CDFs; I don't use them in the function
Z = round(-.5 - al - ap5 + o$par[1], digits=2)   #Bp5 but I've pasted in values here to check

pos <- c(Z,X,Y)
bribes <- c(o$par,-o$value)
#note I haven't fixed the win probability to include a's bribes
win <- c(((1/(1+exp(-X)))*(1/(1+exp(-Y/sy))) + (1/(1+exp(-X)))*(1/(1+exp(-Z/sz))) + (1/(1+exp(-Z/sz)))*(1/(1+exp(-Y/sy))) - 2*(1/(1+exp(-X)))*(1/(1+exp(-Y/sy)))*(1/(1+exp(-Z/sz)))))
out <- list("solns" = o$par[1:3], "pos" = pos, "objMax" = -o$value, "a" = al, "wb" = WB, "winProb" = win)
return(out)
}

# Create a dataframe of parameter values
wb_vector <- 5:20
a_vector <- seq(0.0, 0.0, 0.0)
params <- expand.grid("wb" = wb_vector, "a" = a_vector)

# Use "Map" to evaluate the "h" function at each pair of parameter values
results <- Map(h, al = params$a, WB = params$wb)

# Extract positions and bind to the parameter values
# WOULD LIKE TO HAVE BOTH SOLUTIONS AND POSITIONS IN OUTPUT VECTOR BUT DON'T KNOW HOW
solns <- lapply(seq_along(results), function(x) results[[x]]$solns)
netpos <- lapply(seq_along(results), function(x) results[[x]]$pos)
val <- lapply(seq_along(results), function(x) results[[x]]$objMax)
winProb <- lapply(seq_along(results), function(x) results[[x]]$winProb)
solns <- do.call("rbind", solns)
netpos <- do.call("rbind", netpos)
val <- do.call("rbind", val)
winProb <- do.call("rbind", winProb)
colnames(solns) <- c("foe", "middle", "friend")
colnames(netpos) <- c("Z", "X", "Y")
colnames(val) <- c("value")
colnames(winProb) <- c("winProb")
solns <- cbind(params, solns,netpos,val,winProb)
View(solns)


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

= Algebra::Set
((*集合のクラス*))

集合を表現するクラスです。２つの集合 ((|s|)), ((|t|)) に関して、
((|s|)) が ((|t|)) に含まれる事は ((<all?>)) を使って、

  s.all?{|x| t.member?(x)}

で表現されます。

== ファイル名:
* ((|finite-set.rb|))

== スーパークラス:
* ((|Object|))

== インクルードしているモジュール:

* ((|Enumerable|))

== クラスメソッド:

--- ::[]([obj0, [obj1, [obj2, ...]]])
    引数の列から ((|Set|)) オブジェクトを生成します。

    例: 全て {"a", [1, 2], 0} を生成する。
      require "finite-set"
      p Algebra::Set[0, "a", [1, 2]]
      p Algebra::Set.new(0, "a", [1, 2])
      p Algebra::Set.new_a([0, "a", [1, 2]])
      p Algebra::Set.new_h({0=>true, "a"=>true, [1, 2]=>true})

--- ::new([obj0, [obj1, [obj2, ...]]])
    引数の列から ((|Set|)) オブジェクトを生成します。

--- ::new_a(a)
    配列 ((|a|)) から ((|Set|)) オブジェクトを生成します。

--- ::new_h(h)
    ((|Hash|)) から ((|Set|)) オブジェクトを生成します。

--- self.empty_set
    空集合を生成する。

--- ::phi
--- ::null
    ((<::empty_set>)) のエイリアスです。

--- ::singleton(x)
    ((|x|)) 一元のみで構成される集合を生成します。

== メソッド:

--- empty_set
    空集合を生成する。

--- phi
--- null
    ((<empty_set>)) のエイリアスです。

--- empty?
    空集合であるとき真を返します。

--- phi?
--- empty_set?
--- null?
    ((<empty?>)) のエイリアスです。

--- singleton(x)
    ((|x|)) 一元のみで構成される集合を生成します。

--- singleton?
    一元のみで構成される集合であるとき真を返します。

--- size
    集合の大きさを返します。

--- each
    集合の各要素に関して繰り返します。繰り返しの順番は不定です。

    例:
      require "finite-set"
      include Algebra
      Set[0, 1, 2].each do |x|
        p x #=> 1, 0, 2
      end

--- separate
    集合の各要素をブロックパラメータに渡し、ブロックの値を真にする
    もので構成される集合を返します。

    例:
      require "finite-set"
      include Algebra
      p Set[0, 1, 2, 3].separate{|x| x % 2 == 0} #=> {2, 0}

--- select_s
--- find_all_s
    ((<separate>)) のエイリアスです。

--- map_s
    集合の各要素をブロックパラメータに渡し、ブロックの値によって
    構成される集合を返します。

    例:
      require "finite-set"
      include Algebra
      p Set[0, 1, 2, 3].map_s{|x| x % 2 + 1} #=> {2, 1}

--- pick
    集合の要素から一つ選んで値とします。どの要素が選ばれるかは
    不定です。空集合に対しては ((|nil|)) を返します。

--- shift
    集合の要素から一つ選んで取り出し値とします。どの要素が選ばれる
    かは不定です。

    例:
      require "finite-set"
      include Algebra
      s = Set[0, 1, 2, 3]
      p s.shift #=> 2
      p s #=> {0, 1, 3}

--- dup
    集合の複製を返します。（内部の Hash の複製によります。）

--- append!(x)
    集合に要素 ((|x|)) を付け加えます。返り値は ((|self|)) です。

--- push
--- <<
    ((|append!|)) のエイリアスです。

--- append(x)
    集合に要素 ((|x|)) を付け加えた複製を返します。

--- concat(other)
    集合に別の集合 ((|other|)) の要素を付け加えます。
    （((|+|)) の破壊版です。）

--- rehash
    内部の ((|Hash|)) オブジェクトを ((|rehash|)) します。

--- eql?(other)
    集合 ((|other|)) と等しいとき、真を返します。
    (({ self >= other and self <= other})) と同値です。

--- ==
    ((<eql?>)) のエイリアスです。

--- hash
    自身が ((|Hash|)) あるいは ((|Set|)) の要素となるときに利用される
    ハッシュ値関数です。

--- include?(x)
    集合が ((|x|)) を要素としているとき、真を返します。

--- member?
--- has?
--- contains?
    ((<include?>)) のエイリアスです。

--- superset?(other)
    集合が他の集合 ((|other|)) を包含するとき真を返します。
    (({other.all{|x| member?(x)}})) と同値です。

--- >=
--- incl?
    (({superset?})) のエイリアスです。

--- subset?(other)
    集合が他の集合 ((|other|)) の部分集合であるとき真を返します。
    (({self.all{|x| other.member?(x)}})) と同値です。

--- <=
--- part_of?
    ((|subset?|)) のエイリアスです。

--- <(other)
    ((|self|)) が ((|other|)) の真部分集合の時真を返します。

--- >(other)
    ((|self|)) が ((|other|)) を真に含む時真を返します。

--- union([other])
    ((|self|)) と ((|other|)) の合併集合を返します。
    ((|other|)) が省略された場合、自身を集合の集合とみなし、全ての
    要素の合併を返します。

    例:
      require "finite-set"
      include Algebra
      p Set[0, 2, 4].cup Set[1, 3] #=> {0, 1, 2, 3, 4}
      s = Set[*(0...15).to_a]
      s2 = s.separate{|x| x % 2 == 0}
      s3 = s.separate{|x| x % 3 == 0}
      s5 = s.separate{|x| x % 5 == 0}
      p Set[s2, s3, s5].union #=> {1, 7, 11, 13}

--- |
--- +
--- cup
    ((|union|)) のエイリアスです。

--- intersection([other])
    ((|self|)) と ((|other|)) の交わりの集合を返します。
    ((|other|)) が省略された場合、自身を集合の集合とみなし、全ての
    要素の共通部分を返します。

    例:
      require "finite-set"
      include Algebra
      p Set[0, 2, 4].cap(Set[4, 2, 0]) #=> {0, 2, 4}
      s = Set[*(0..30).to_a]
      s2 = s.separate{|x| x % 2 == 0}
      s3 = s.separate{|x| x % 3 == 0}
      s5 = s.separate{|x| x % 5 == 0}
      p Set[s2, s3, s5].cap #=> {0, 30}

--- &
--- cap
    ((|intersection|)) のエイリアスです。

--- difference(other)
    ((|self|)) から ((|other|)) に含まれる要素を取り除いたものを返します。

--- -
    ((|difference|)) のエイリアスです。

--- each_pair
    集合から異なる２つの要素を取り出して、ブロックパラメータに
    代入して繰り返します。

    例:
      require "finite-set"
      include Algebra
      s = Set.phi
      Set[0, 1, 2].each_pair do |x, y|
        s.push [x, y]
      end
      p s == Set[[0, 1], [0, 2], [1, 2]] #=> true

--- each_member(n)
    集合から異なる ((|n|)) 個の要素を取り出して、ブロックパラメータに
    代入して繰り返します。

    例:
      require "finite-set"
      include Algebra
      s = Set.phi
      Set[0, 1, 2].each_member(2) do |x, y|
        s.push [x, y]
      end
      p s == Set[[0, 1], [0, 2], [1, 2]] #=> true

--- each_subset
    集合の全ての部分集合をブロックパラメータに代入して繰り返します。

    例:
      require "finite-set"
      include Algebra
      s = Set.phi
      Set[0, 1, 2].each_subset do |t|
        s.append! t
      end
      p s.size = 2**3 #=> true

--- each_non_trivial_subset
    集合の空集合でない真部分集合をブロックパラメータに代入して繰り返します。

--- power_set
    集合の全ての部分集合の集合を返します。

--- each_product(other)
    ((|self|)) と ((|other|)) の全ての要素 ((|x|)), ((|y|)) に
    ついて、繰り返します。

   例:
      require "finite-set"
      include Algebra
      Set[0, 1].each_prodct(Set[0, 1]) do |x, y|
        p [x, y] #=> [0,0], [0,1], [1,0], [1,1]
      end

--- product(other)
    ((|self|)) と ((|other|)) の積集合を返します。積集合の各元
    は配列 (({[x, y]})) です。ブロックが与えられた時は、ブロック
    を評価した値で構成される集合を返します。

    例:
      require "finite-set"
      include Algebra
      p Set[0, 1].product(Set[0, 1]) #=> {[0,0], [0,1], [1,0], [1,1]}
      p Set[0, 1].product(Set[0, 1]){|x, y| x + 2*y} #=> {0, 1, 2, 3]

--- *
    ((<product>)) のエイリアスです。

--- equiv_class([equiv])
    集合を同値関係で割った商集合を返します。同値関係の与え方は次の３通りあります。

    (1) ブロックの評価値を真にする同値関係
          require "finite-set"
          include Algebra
          s = Set[0, 1, 2, 3, 4, 5]
          p s.equiv_class{|a, b| (a - b) % 3 == 0} #=> {{0, 3}, {1, 4}, {2, 5}}
    (2) 引数に与えられたオブジェクトに対するメソッド ((|call(x, y)|))
        の真偽値による同値関係
          require "finite-set"
          include Algebra
          o = Object.new
          def o.call(x, y)
            (x - y) % 3 == 0
          end
          s = Set[0, 1, 2, 3, 4, 5]
          p s.equiv_class(o) #=> {{0, 3}, {1, 4}, {2, 5}}
    (3) 引数に与えられた ((|Symbol|)) に応じたメソッドによる同値関係
          require "finite-set"
          include Algebra
          s = Set[0, 1, 2, 3, 4, 5]
          def q(x, y)
            (x - y) % 3 == 0
          end
          p s.equiv_class(:q) #=> {{0, 3}, {1, 4}, {2, 5}}

--- /
    ((<equiv_class>)) のエイリアスです。

--- to_a
    集合を配列にして返します。要素の並びの順は不定です。

--- to_ary
    ((<to_a>)) のエイリアスです。

--- sort
    ((<to_a>)) の値をソートして返します。

--- power(other)
    ((|other|)) から ((|self|)) への写像全ての集合を返します。
    写像は ((<Map|URL:finite-map-ja.html>)) の元として表現されます。

    例:
      require "finite-map"
      include Algebra
      a = Set[0, 1, 2, 3]
      b = Set[0, 1, 2]
      s =
      p( (a ** b).size )      #=> 4 ** 3 = 64
      p b.surjections(a).size #=> S(3, 4) = 36
      p a.injections(b).size  #=> 4P3 = 24

--- **
    ((<power>)) のエイリアスです。

--- identity_map
    自分への恒等写像を返します。

--- surjections(other)
    ((|other|)) から ((|self|)) への全射全ての集合を返します。

#--- injections0(other)

--- injections(other)
    ((|other|)) から ((|self|)) への単射全ての集合を返します。

--- bijections(other)
    ((|other|)) から ((|self|)) への全単射全ての集合を返します。

#--- monotonic_series #what is this?

= Enumerable

== ファイル名:
* ((|finite-set.rb|))

== メソッド:

--- any?
    ブロックを真にする要素があるとき、真を返します。
    ((|Enumerable#find|)) の別名です。(built-in of ruby-1.8)

--- all?
    全ての要素についてブロックが真であるとき、真を返します。

      !any?{|x| !yield(x)}

    と定義されています。(built-in of ruby-1.8)

=end


require(nleqslv)
require(xlsx)
library(rgl)

# Aaia?e?oai aoiaiua aaiiua
generate <- function(n, tet, sigma1=0.05, sigma2=0.5, sigma3=0.05, sigma4=0.8) {
  m <- length(tet)
  c(runif(n, -1, 1)) -> ksi
  eta <- apply(sapply(1:m, function(i) ksi^(i-1)), 1, function(r) sum(r * tet))

  rbinom(n, 1, 0.05) -> rb1
  rbinom(n, 1, 0.05) -> rb2

  sapply(rb1, function(x) rnorm(1, 0, switch(x + 1, sigma1, sigma2))) -> delta
  sapply(rb2, function(x) rnorm(1, 0, switch(x + 1, sigma3, sigma4))) -> eps
  X <- cbind(rep(1,n), apply(sapply(2:m, function(i) ksi^(i-1)), 2, function(r) r + delta))
  list(X = matrix(X, nrow = n, ncol = m), y = eta + eps, outliersX = rb1, outliersY = rb2)
}

mnk <- function (X, y) {
  c(solve(t(X) %*% (X)) %*% t(X) %*% matrix(y))
}

# Au?eneyai aaooa
rcr <- function(X, y, tet.init, g0=0.001, h=0.001, eps=1.e-8, g=NULL) {
  b0 <- tet.init[2:length(tet.init)]
  p <- length(tet.init) - 1

  r <- sqrt(apply(sapply(1:p, function(i) (X[,i+1] - mean(X[,i+1]))^2), 1, sum) + (y - mean(y))^2)
  fSxx <- function (i, j) sum((X[,i+1]-mean(X[,i+1])) * (X[,j+1]-mean(X[,j+1])) / r^2)
  fSxy <- function (j) sum((X[,j+1]-mean(X[,j+1])) * (y - mean(y)) / r^2)
  Syy <- sum((y-mean(y))^2 / r^2)

  Sxx <- matrix(0, nrow = p, ncol = p)
  Sxy <- numeric(p)
  for (i in 1:p) {
    for (j in 1:p) {
      Sxx[i,j] <- fSxx(i, j)
    }
    Sxy[i] <- fSxy(i)
  }

  SS <- function(b, gamma) {
    #gamma0 <- 1 - sum(gamma)
    gamma0 <- gamma[1]
    gamma.other <- gamma[2:length(gamma)]
    Sxx.sum <- 0
    Sxy.sum <- 0
    for (i in 1:p) {
      for (j in 1:p) {
        Sxx.sum <- Sxx.sum + b[i] * b[j] * Sxx[i, j]
      }
      Sxy.sum <- Sxy.sum + b[i] * Sxy[i]
    }
    #sum(sapply(1:5, function (j) sum(sapply(1:5, Sxx, j=j))))
    (gamma0 + sum(gamma.other / b^2)) * (Syy + Sxx.sum - 2 * Sxy.sum)
  }
# f <- function(v) SS(v[1:p], v[(p+1):(2*p)])
  fg <- function(b) function(g) SS(b, g)
  fb <- function(g) function(b) SS(b, g)
  df <- function(f) {
    function (v) {
      l <- length(v)
      grad <- numeric(l)
      for (i in 1:l) {
        v.plus.h <- v
        v.plus.h[i] <- v.plus.h[i] + h
        grad[i] <- (f(v.plus.h) - f(v)) / h
      }
      grad
    }
  }
  norm <- function(x) sqrt(sum(x^2))
  basis <- function(n, i) {
  	a <- numeric(n)
  	a[i] <- 1
  	a
  }

  g.init <- rep(g0, p)
  b.init <- b0
  calc_b <- function (g, b.init=b0) {
  	res <- nleqslv(b.init, df(fb(g)), method = "Newton")
  	res$x
  }

  F <- function(g.p) {
  	g <- c((1-sum(g.p)), g.p)
    b <- calc_b(g, b.init)
    b.init <- b
    #for (i in 1:(p+1)) if (g[i] < 0 || g[i] > 1) return(1000000.0)
    -sum(sapply(1:(p+1), function(i) SS(calc_b(basis(p+1, i), b.init), basis(p+1, i)) / SS(b, basis(p+1, i))))
  }

  theta <- function(gamma) {
  	b <- calc_b(gamma)
  	alpha <- mean(y) - sum(b * sapply(1:p, function(i) (mean(X[,i+1]))))
    c(alpha, b)
  }

 # plot ((1:100) / 100, sapply((1:100) / 100, F))
 #  x <- (1:100) / 100
 #  xn = length(x)
 #  z <- matrix(0, nrow = xn, ncol = xn)
 #  for (i in 1:xn){
 #  for (j in 1:xn){
 #    z[i,j] <- f(x[i], x[j])
 #  	}
	# }
 #  persp3d(z)
  if (!is.null(g)) return(theta(g))

  res <- optim(par=g.init, F)
  #res <- optimize(F, interval=c(0,1))
  g <- c((1-sum(res$par)), res$par)
  #g <- c((1-res$minimum), res$minimum)
  print(c(g, sum(g)))
  #print(c(-F(res$minimum),F(numeric(p)), theta(g)))
  print(c(-F(res$par), -F(numeric(p))))
  theta(g)

  # repeat {
  #   f <- fg(b)
  #   plot (sapply((0:100) / 100, f), (0:100) / 100)

  #   res <- nleqslv(g, df(fg(b)), method = "Newton")
  #   g <- res$x
  #   print (g)
  #   res <- nleqslv(b, df(fb(g)), method = "Newton")
  #   b_new <- res$x
  #   if (norm(b_new - b) / norm(b) <= eps) {
  #     break
  #   }
  #   b <- b_new
  # }

  # psi <- function (gamma) {
  #   t <- theta(gamma)
  #   sum((t - te)^2 /  te^2)
  # }

  # for (g in (1:100) / 100) {
  #   print(c(g, psi(c(1-g,g)), -F(g), theta(c(1-g,g))))
  # }

	# for (g1 in (0:100) / 100) {
	# 	for (g2 in (0:10) / 10) {
	# 		g <- c(1-g1-g2, g1, g2)
	# 		print(c(g, psi(g), -F(c( g1, g2)), theta(g)))
	# 	}
	# }

  #plot(psi, 0, 1)

  # g <-
  # p <- sapply(g, psi)
  # a <- sapply(g,

  # x <- data.frame(g = g, psi = p)
  # write.table(x, file = "rcr.csv", sep = ",",  qmethod = "double")

  # for (g1 in (0:10) / 50) {
  #   for (g2 in (0:10) / 50) {
  #     g <- c(g1, g2)
  #     print(c(g, psi(g), theta(g)))
  #   }
  # }

# F <- function(gamma) {
# t <- theta(gamma)
# b <- t[2]
# ((Syy - b * Sxy) / (Syy - b * Sxy + b^4 * Sxx - b^3 * Sxy) - gamma)^2
# }

# o = optimize(F, interval=c(-1, 100000))
# o$minimum

# repeat {

# gamma_new <- (Syy - b * Sxy) / (Syy - b * Sxy + b^4 * Sxx - b^3 * Sxy)

# f <- function(b) (gamma0 + gamma_new / b^2) * (Syy + b^2 * Sxx - 2 * b * Sxy)
# df <- function(b) (f(b + h) - f(b)) / h
# res <- nleqslv(b0, df, method = "Newton")
# b_new <- res$x

# print(gamma)
# if (abs(b_new - b) / abs(b) <= eps || k > 100) {
# break
# }
# #print(k)
# #print(abs(b_new - b) / abs(b))
# b <- b_new
# gamma <- gamma_new
# #k = k+1

# }
}

rcr_err <- function(X, y, tet.init, g0=0.001, h=0.001, eps=1.e-8, g=NULL) {
  b0 <- tet.init[2:length(tet.init)]
  p <- length(tet.init) - 1
  n <- length(y)

  r <- sqrt(apply(sapply(1:p, function(i) (X[,i+1] - mean(X[,i+1]))^2), 1, sum) + (y - mean(y))^2)
  fSxx <- function (i, j) sum((X[,i+1]-mean(X[,i+1])) * (X[,j+1]-mean(X[,j+1])) / r^2)
  fSxy <- function (j) sum((X[,j+1]-mean(X[,j+1])) * (y - mean(y)) / r^2)
  Syy <- sum((y-mean(y))^2 / r^2)

  Sxx <- matrix(0, nrow = p, ncol = p)
  Sxy <- numeric(p)
  for (i in 1:p) {
    for (j in 1:p) {
      Sxx[i,j] <- fSxx(i, j)
    }
    Sxy[i] <- fSxy(i)
  }

  SS <- function(b, gamma) {
    #gamma0 <- 1 - sum(gamma)
    gamma0 <- gamma[1]
    gamma.other <- gamma[2:length(gamma)]
    Sxx.sum <- 0
    Sxy.sum <- 0
    for (i in 1:p) {
      for (j in 1:p) {
        Sxx.sum <- Sxx.sum + b[i] * b[j] * Sxx[i, j]
      }
      Sxy.sum <- Sxy.sum + b[i] * Sxy[i]
    }
    (gamma0 + sum(gamma.other / b^2)) * (Syy + Sxx.sum - 2 * Sxy.sum)
  }

  fg <- function(b) function(g) SS(b, g)
  fb <- function(g) function(b) SS(b, g)
  df <- function(f) {
    function (v) {
      l <- length(v)
      grad <- numeric(l)
      for (i in 1:l) {
        v.plus.h <- v
        v.plus.h[i] <- v.plus.h[i] + h
        grad[i] <- (f(v.plus.h) - f(v)) / h
      }
      grad
    }
  }
  norm <- function(x) sqrt(sum(x^2))
  basis <- function(n, i) {
    a <- numeric(n)
    a[i] <- 1
    a
  }

  g.init <- rep(g0, p)
  b.init <- b0
  calc_b <- function (g, b.init=b0) {
    res <- nleqslv(b.init, df(fb(g)), method = "Newton")
    res$x
  }

  theta <- function(gamma) {
    b <- calc_b(gamma)
    alpha <- mean(y) - sum(b * sapply(1:p, function(i) (mean(X[,i+1]))))
    c(alpha, b)
  }

  F <- function(g.p) {
    g <- c((1-sum(g.p)), g.p)
    b <- calc_b(g, b.init)
    y.est <- X %*% matrix(theta(g))
    for (i in 1:(p+1)) if (g[i] < 0 || g[i] > 1) return(1000000.0)
    sum(abs(y - y.est)) / n
  }

  res <- optim(par=g.init, F)
  #res <- optimize(F, interval=c(0,1))
  g <- c((1-sum(res$par)), res$par)
  #g <- c((1-res$minimum), res$minimum)
  print(c(g, sum(g)))
  #print(c(-F(res$minimum),F(numeric(p)), theta(g)))
  print(c(F(res$par), F(numeric(p))))
  theta(g)
}

rcr_g0 <- function(X, y, tet.init) {
  m <- length(tet.init)
  g <- numeric(m)
  g[1] <- 1
  rcr(X, y, tet.init, g=g)
}

rcr2 <- function(x, y, b0=0.001, h=0.001, eps=1.e-8, k=0) {
  r <- sqrt((x-mean(x))^2 + (y - mean(y))^2)
  Sxx <- sum((x-mean(x))^2 / r^2)
  Sxy <- sum((x-mean(x)) * (y - mean(y)) / r^2)
  Syy <- sum((y-mean(y))^2 / r^2)
  my <- mean(y)
  mx <- mean(x)

  theta <- function() {
    f <- function(b) ((1 - (Syy - b * Sxy) / (Syy - b * Sxy + b^4 * Sxx - b^3 * Sxy)) + ((Syy - b * Sxy) / (Syy - b * Sxy + b^4 * Sxx - b^3 * Sxy)) / b^2) * (Syy + b^2 * Sxx - 2 * b * Sxy)
    df <- function(b) (f(b + h) - f(b)) / h
    res <- nleqslv(b0, df, method = "Newton")
    b <- res$x
    c(my - b * mx, b)
  }

# for (g in (1:100) / 100) {
# print(c(g, theta(g)))
# }

  theta()
# repeat {

# gamma_new <- (Syy - b * Sxy) / (Syy - b * Sxy + b^4 * Sxx - b^3 * Sxy)

# f <- function(b) (gamma0 + gamma_new / b^2) * (Syy + b^2 * Sxx - 2 * b * Sxy)
# df <- function(b) (f(b + h) - f(b)) / h
# res <- nleqslv(b0, df, method = "Newton")
# b_new <- res$x

# print(gamma)
# if (abs(b_new - b) / abs(b) <= eps || k > 100) {
# break
# }
# #print(k)
# #print(abs(b_new - b) / abs(b))
# b <- b_new
# gamma <- gamma_new
# #k = k+1

# }
}

rcr3 <- function(x, y, gamma_init=0.1, b0=0.001, h=0.001, eps=1.e-8) {

  r <- sqrt((x-mean(x))^2 + (y - mean(y))^2)
  Sxx <- sum((x-mean(x))^2 / r^2)
  Sxy <- sum((x-mean(x)) * (y - mean(y)) / r^2)
  Syy <- sum((y-mean(y))^2 / r^2)

  gamma <- gamma_init
  gamma0 <- 1 - gamma
  f  <- function(b) (gamma0 + gamma / b^2) * (Syy + b^2 * Sxx - 2 * b * Sxy)
  df <- function(b) (f(b + h) - f(b)) / h
  res <- nleqslv(b0, df, method = "Newton")
  b <- res$x

  repeat {

    gamma_new <- (Syy - b * Sxy) / (Syy - b * Sxy + b^4 * Sxx - b^3 * Sxy)

    gamma0 <- 1 - gamma_new
    f  <- function(b) (gamma0 + gamma_new / b^2) * (Syy + b^2 * Sxx - 2 * b * Sxy)
    df <- function(b) (f(b + h) - f(b)) / h
    res <- nleqslv(b0, df, method = "Newton")
    b_new <- res$x

    #print(gamma)
    if (abs(b_new - b) / abs(b) <= eps) {
      break
    }
    b <- b_new
    gamma <- gamma_new
  }
  c(mean(y) - b * mean(x), b)
}

als <- function(X, y, tet.init, sigma_init=0.01, eps=1.e-8) {
  m <- length(tet.init)
  n <- length(y)
  matrix(1, nrow=n, ncol=2*m) -> t
  matrix(0, nrow=m, ncol=m) -> P
  rep(1,m) -> R

  t[,2] <- X[,2]

  theta <- function(sd2) {
    for (i in 3:(2*m)) { t[,i] <- X[,2] * t[,i-1] - (i - 2) * sd2 * t[,i-2] }
    for (i in 1:m) { R[i] <- sum(t[,i] * y) }
    for (i in 1:m) { for (j in 1:m) { P[i,j] <- sum(t[,i+j-1]) } }
    c(solve(P) %*% matrix(R))
  }
  # F <- function(sd2) {
  #   tet <- theta(sd2)
  #   #((n * sd2)/(sum(y^2) - sum(R * tet)) - (var(x) / var(y)))^2
  #   #y.est <- apply(sapply(1:m, function(i) x^(i-1) * tet[i]), 1, sum)
  #   y.est <- apply(sapply(1:m, function(i) x^(i-1)), 1, function(r) sum(r * tet))
  #   (((n-m) * sd2)/sum((y - y.est)^2) - var(x)/var(y))^2
  #   #(((n-m) * sd2)/sum((y - sum(R * tet))^2) - 1)^2
  # }

  tet <- tet.init

  norm <- function(x) sqrt(sum(x^2))

  theta(0.01^2)

  #g <- var(x) / var(y)
  # g <- 1

  # print (c(var(x) / var(y), 1))
  # repeat {

  #   y.est <- apply(sapply(1:m, function(i) x^(i-1)), 1, function(r) sum(r * tet))

  #   # print (c(y- y.est))
  #   # break
  #   sd2 <- g * sum((y - y.est)^2) / (n - m)
  #   tet_new <- theta(sd2)
  #   nev <- norm(tet_new - tet) / norm(tet)
  #   print(c(nev, sd2))
  #   if (nev < eps) {
  #     break
  #   }
  #   tet <- tet_new
  # }
  # tet

  # o = optimize(F, interval=c(0, 10))
  # #o = BBoptim(par=0, fn=F)
  # sd2 <- o$minimum
  # print(sd2)
  # print(F(sd2))
  # #plot(F, 0, 10)
  # theta(0.0001)
}

err <- function (data, tet) {
  m <- length(tet)
  n <- length(data$y)
  y.est <- apply(sapply(1:m, function(i) data$X[,i]), 1, function(r) sum(r * tet))
  c(sum((data$y - y.est)^2) / n, sum(abs(data$y - y.est)) / n)
}

report <- function (N, te) {
  psi <- function (tet) sum((tet - te)^2 /  te^2)
  m <- length(te)
  out <- matrix(0, nrow=N, ncol=(m+2)*4)
  for (i in 1:N) {
    data <- generate(500, te)
    tet.mnk <- mnk(data$X, data$y)
    tet.als <- als(data$X, data$y, tet.init=tet.mnk)
    tet.rcr <- rcr(data$X, data$y, tet.init=tet.mnk)
    tet.rcr_g0 <- rcr_g0(data$X, data$y, tet.init=tet.mnk)
    out[i,] <- c(tet.mnk, err(data, tet.mnk), tet.als, err(data, tet.als), tet.rcr, err(data, tet.rcr), tet.rcr_g0, err(data, tet.rcr_g0))
  }
  x <- data.frame(out)
  write.xlsx(x, file = "report.xlsx")
}

model <- function(tet) {
  m <- length(tet)
  Vectorize(function (x) sum(sapply(1:m, function(i) x^(i-1)) * tet))
}

research <- function(f, m=3) {
  dx <- read.table(sprintf("data/x_%s.txt", f))
  dy <- read.table(sprintf("data/y_%s.txt", f))
  data <- list(X = sapply(1:m, function(i) dx$V1^(i-1)), y = dy$V1)

  tet.mnk <- mnk(data$X, data$y)
  print(sprintf("tet.mnk = (%s), err = %f", paste(tet.mnk, collapse=", "), err(data, tet.mnk)[2]))
  plot(model(tet.mnk), 0, 1)

  tet.als <- als(data$X, data$y, tet.init=tet.mnk)
  print(sprintf("tet.als = (%s), err = %f", paste(tet.als, collapse=", "), err(data, tet.als)[2]))
  plot(model(tet.als), 0, 1)

  tet.rcr <- rcr(data$X, data$y, tet.init=tet.mnk)
  print(sprintf("tet.rcr = (%s), err = %f", paste(tet.rcr, collapse=", "), err(data, tet.rcr)[2]))
  plot(model(tet.rcr), 0, 1)

  tet.rcr_err <- rcr_err(data$X, data$y, tet.init=tet.mnk)
  print(sprintf("tet.rcr_err = (%s), err = %f", paste(tet.rcr_err, collapse=", "), err(data, tet.rcr_err)[2]))
  plot(model(tet.rcr_err), 0, 1)

  tet.rcr_g0 <- rcr_g0(data$X, data$y, tet.init=tet.mnk)
  print(sprintf("tet.rcr_g0 = (%s), err = %f", paste(tet.rcr_g0, collapse=", "), err(data, tet.rcr_g0)[2]))
  plot(model(tet.rcr_g0), 0, 1)
}

outliersPlot <- function(te) {
  data <- generate(50, te)
  X.clean = data$X[data$outliersX == 0 & data$outliersY == 0,]
  y.clean = data$y[data$outliersX == 0 & data$outliersY == 0]
  X.outliers = data$X[data$outliersX == 1 | data$outliersY == 1,]
  y.outliers = data$y[data$outliersX == 1 | data$outliersY == 1]

  tet.mnk <- mnk(data$X, data$y)
  tet.als <- als(data$X, data$y, tet.init=tet.mnk)
  tet.als.clean <- als(X.clean, y.clean, tet.init=tet.mnk)

  plot(X.clean[,2], y.clean, col="black")
  plot(model(tet.als), -1, 1, col="red", lwd=2, add=TRUE)
  plot(model(tet.als.clean), -1, 1, col="black", lwd=2, add=TRUE)
  points(X.outliers[,2], y.outliers, col="red")
}

te <- c(1.3, 2.1, 0.4)
#report(1, te)

#research("2_year_421")
outliersPlot(te)

#data <- generate(500, te)
# plot(data$X[,2], data$y)
#b0 <- mnk(data$x, data$y, te=te)
#tet <- rcr(data$x, data$y, te=te, tet.init=b0)


library(libexpm)

n <- 250
n <- 10
x <- matrix(rnorm(n*n), n, n)

t1 <- system.time(exp1 <- expm(x))[3]

library(Matrix)
t2 <- system.time(exp2 <- Matrix::expm(x))[3]

t1
t2

all.equal(exp1, as.matrix(exp2), check.attributes=FALSE)


## Volcano plot with "significant" genes labeled
## From Stephen Turner, @genetics_blog
##
volcanoplot <- function (res, lfcthresh=2, sigthresh=0.05, main="Volcano Plot", legendpos="bottomright", labelsig=TRUE, textcx=1, ...) {
  with(res, plot(log2FoldChange, -log10(pvalue), pch=20, main=main, ...))
  with(subset(res, padj<sigthresh ), points(log2FoldChange, -log10(pvalue), pch=20, col="red", ...))
  with(subset(res, abs(log2FoldChange)>lfcthresh), points(log2FoldChange, -log10(pvalue), pch=20, col="orange", ...))
  with(subset(res, padj<sigthresh & abs(log2FoldChange)>lfcthresh), points(log2FoldChange, -log10(pvalue), pch=20, col="green", ...))
  if (labelsig) {
    require(calibrate)
    with(subset(res, padj<sigthresh & abs(log2FoldChange)>lfcthresh), textxy(log2FoldChange, -log10(pvalue), labs=Gene, cex=textcx, ...))
  }
  legend(legendpos, xjust=1, yjust=1, legend=c(paste("FDR<",sigthresh,sep=""), paste("|LogFC|>",lfcthresh,sep=""), "both"), pch=20, col=c("red","orange","green"))
}


### LIBRARIES
library(MASS)
library(readr)
library(precrec)
### FUNCTION
ty.lda <- function(x, groups){ ### https://stackoverflow.com/questions/5629550/classification-functions-in-linear-discriminant-analysis-in-r
	x.lda <- lda(groups ~ ., as.data.frame(x))
	gr <- length(unique(groups)) ### groups might be factors or numeric
	v <- ncol(x) ### variables
	m <- x.lda$means ### group means
	w <- array(NA, dim = c(v, v, gr))
	for(i in 1:gr){
		tmp <- scale(subset(x, groups == unique(groups)[i]), scale = FALSE)
		w[,,i] <- t(tmp) %*% tmp
	}
	W <- w[,,1]
	for(i in 2:gr)
		W <- W + w[,,i]
	V <- W/(nrow(x) - gr)
	iV <- solve(V)
	class.funs <- matrix(NA, nrow = v + 1, ncol = gr)
	colnames(class.funs) <- paste("group", 1:gr, sep=".")
	rownames(class.funs) <- c("constant", paste("var", 1:v, sep = "."))
	for(i in 1:gr) {
		class.funs[1, i] <- -0.5 * t(m[i,]) %*% iV %*% (m[i,])
		class.funs[2:(v+1) ,i] <- iV %*% (m[i,])
	}
	x.lda$class.funs <- class.funs
	return(x.lda)
}
### DATA
ue <- as.data.frame(read_csv('level1-uelda.csv.xz', col_names = FALSE))
colnames(ue) <- c('g', 'b', 'e', 'l', 'p', 'w')
be <- as.data.frame(read_csv('level1-belda.csv.xz', col_names = FALSE))
colnames(be) <- c('g', 'b', 'e', 'l', 'p', 'w')
### U|B ELDA MASS STYLE (+ == 1; - == 0)
c <- c('be', 'bel', 'belp', 'belpw', 'belw', 'bep', 'bepw', 'bew', 'bl', 'blp', 'blpw', 'blw', 'bp', 'bpw', 'el', 'elp', 'elpw', 'elw', 'ep', 'epw', 'lp', 'lpw')
uo <- data.frame(combination = character(), AUC = double(), scale = character(), fn = character())
bo <- data.frame(combination = character(), AUC = double(), scale = character(), fn = character())
uv <- as.integer(0.9*nrow(ue))
bv <- as.integer(0.9*nrow(be))
for(k in 1:length(c)){
	y <- unlist(strsplit(c[k], ''))
	u <- ty.lda(ue[1:uv,y], ue[1:uv,'g'])
	b <- ty.lda(be[1:bv,y], be[1:bv,'g'])
	ux <- rep(u$class.funs[1,2], nrow(ue)-uv)
	bx <- rep(b$class.funs[1,2], nrow(be)-bv)
	for(j in 2:nrow(u$class.funs)){
		ux <- ux+(u$class.funs[j,2]*ue[(uv+1):nrow(ue),y[j-1]])
		bx <- bx+(b$class.funs[j,2]*be[(bv+1):nrow(be),y[j-1]])
	}
	e <- evalmod(mmdata(ux, ue[(uv+1):nrow(ue),'g'], modnames = c('lda')), mode = 'prcroc', x_bins = 1000)
	uo <- rbind(uo, list(c[k], subset(auc(e), curvetypes == 'PRC')[,4], paste(u$scaling, collapse = ' | '), paste(u$class.funs[,2], collapse = ' | ')), stringsAsFactors = FALSE)
	e <- evalmod(mmdata(bx, be[(bv+1):nrow(be),'g'], modnames = c('lda')), mode = 'prcroc', x_bins = 1000)
	bo <- rbind(bo, list(c[k], subset(auc(e), curvetypes == 'PRC')[,4], paste(b$scaling, collapse = ' | '), paste(b$class.funs[,2], collapse = ' | ')), stringsAsFactors = FALSE)
}
colnames(uo) <- c('combination', 'AUC', 'scale', 'fn')
write.csv(uo, file = 'uelda.csv')
colnames(bo) <- c('combination', 'AUC', 'scale', 'fn')
write.csv(bo, file = 'belda.csv')


x = seq(-1,1,0.01)
fs = 1.8
fsc = 1.8

#complEx simple box, on differences
pdf("complex_simple_box.pdf",width=7,height=7)
op <- par(mar = c(5,5.5,2,2) +0.1)
contour(x,x,outer(x,x, function(x,y) pmax(0,x) + pmax(x,abs(y))),nlevels=10,cex.lab=fs+0.4, cex.axis=fs, cex.main=fs, cex.sub=fs, labcex=fsc, xlab=expression(Re(theta['b, i']- theta['r, i'])), ylab=expression(Im(theta['b, i'] - theta['r, i'])))
dev.off()

#complex simple sphere
pdf("complex_simple_sphere.pdf",width=7,height=7)
op <- par(mar = c(5,5.5,2,2) +0.1)
contour(x,x,outer(x,x, function(x,y) sqrt(x*x + y*y)),nlevels=10,cex.lab=fs+0.4, cex.axis=fs, cex.main=fs, cex.sub=fs, labcex=fsc, xlab=expression(Re(theta['b, i'] - theta['r, i'])), ylab=expression(Im(theta['b, i'] - theta['r, i'])))
dev.off()


require(tseriesChaos);
require(colorspace)
require(viridis)

#palette(qualitative_hcl("Set 2", n=9));
palette(c("black", "blue", "red"))

embedd = tseriesChaos::embedd;
sim.cont = tseriesChaos::sim.cont;
lorenz.s0 = c(9.227021424263037729929, 15.117356048661351408668, 17.911512308502612000893);

if(length(lorenz.ts) == 2001)
	lorenz.ts = NULL;

graphics.off();
dev.new(width=0.6*12, height=0.6*8);

logistic = function(iter=40000, r=4){
	res = rep(0, iter);
	res[1] = runif(min=0, max=1, n=1);
	for(i in 2:iter)
		res[i] = r*res[i-1]*(1 - res[i-1]);
	res;
}

lorenz.real = function(N=1000, t.step=0.03){
	data = matrix(0, nrow=N, ncol=3);

	t.end = N * t.step;
	gambiarra = sim.cont(lorenz.syst, 0, t.end, t.step,
		 start.x=lorenz.s0, parms=c(10, 28, -8/3), obs.fun = function(x) list(x));

	for(i in 1:N){
		data[i,] = gambiarra[[i]][[1]];
	}

	data;
}

lorenz.embedded = function(N=1000, m=3, d=3, t.step=0.03){
	t.end = N * t.step;
	series = sim.cont(lorenz.syst, 0, t.end, t.step,
		 start.x=lorenz.s0, parms=c(10, 28, -8/3), obs.fun = function(x)
		 x[1]);

	data = embedd(series, m=m, d=d);
	data;
}

norm1 = function(vec){ sum(abs(vec)); }
norm2 = function(vec){ sqrt(sum(vec**2)); }
normInf = function(vec){ max(abs(vec)); }

embedd.custom = function(series, indices){
	subseries = list();
	for(l in indices){
		subseries[[length(subseries) + 1]] = series[l:length(series)];
	}

	minLength = length(series) - max(indices);
	result = NULL;
	for(i in 1:length(subseries)){
		result = cbind(result, subseries[[i]][1:minLength] );
	}

	result;
}

divergence.plot = function(data, box.x, box.y, box.z, from=20, to=3996, by=5, shuffle=FALSE, smooth=TRUE, plot=T){
	result = NULL;

	inBox = (data[,1] > box.x[1]) & (data[,1] < box.x[2]);
	inBox = inBox & (data[,2] > box.y[1]) & (data[,2] < box.y[2]);
	inBox = inBox & (data[,3] > box.z[1]) & (data[,3] < box.z[2]);

	if(shuffle){
		data = data[sample(1:nrow(data)),];
	}

	for(i in seq(from, to, by=by)){
		nrows = nrow(data);
		half1 = inBox[1:i];
		half2 = inBox[(i+1):(2*i)];

		freq1 = sum(half1) / length(half1);
		freq2 = sum(half2) / length(half2);

		result = rbind(result, c(i, freq1, freq2, abs(freq1 - freq2)));
	}
	if(plot){
		if(smooth){
			sm = smooth.spline(2*result[,1], result[,4], df=30);
			lines(sm, lwd=2, col="#00007755");
		} else {
			lines(2*result[,1], result[,4], lwd=2, col="#000000AA");
		}
	}
	result;
}

lorenz.single = function(data){
	N = nrow(data);
	m = 3;
	d = 3;

	xrange = range(data[,1]);
	yrange = range(data[,2]);
	zrange = range(data[,3]);

	#xrange = c(-19.11338, 19.1377);
	#yrange = c(-19.11338, 19.1377);
	#zrange = c(-19.11338, 19.1377); # Yes they're all equal

	# Real lorenz system
	#xrange = c(5.3, 14.1);
	#yrange = c(11.25, 19.3);
	#zrange = c(16.5, 24.35);

	n = 2;
	box.x = min(xrange) + (c(n-3, n) + 1) * diff(xrange) / 10;
	box.y = min(yrange) + (c(n-3, n) + 3) * diff(yrange) / 10;
	box.z = min(zrange) + (c(n-3, n) + 7) * diff(zrange) / 10;

	plot(0, 1, xlab="Sample size", ylab=expression(paste(list(histogram,divergence), phantom(aaa), epsilon, phantom(aaa))), type="l", xlim=c(0, N), ylim=c(1e-5, 1), #log="y",
			 main=paste("Divergences for the Lorenz Map (non-shuffled, rate 0.03s, m = ", m, ", d = ", d, ")."), col="#FFFFFF");

	rgl::plot3d(data);
	rgl::lines3d(t(rbind(box.x, box.y, box.z)), col=2, lwd=3);

	inBox = (data[,1] > box.x[1]) & (data[,1] < box.x[2]);
	inBox = inBox & (data[,2] > box.y[1]) & (data[,2] < box.y[2]);
	inBox = inBox & (data[,3] > box.z[1]) & (data[,3] < box.z[2]);

	#print(inBox[seq(1, 10000, by=97)]);
	freq = sum(inBox) / nrow(data);

	print(freq);

	result = divergence.plot(data, box.x, box.y, box.z,
							 to=N/2, by=N%/%1000, shuffle=F, smooth=F);

	x = seq(0, N * 1.1, length=1000);
	lines(x, sqrt(  (1 / (-x)) * log(0.05/2)  ), col=2)
	lines(x, sqrt(  (1 / (-x)) * log(0.001/2)  ), col=3)
	lines(x, sqrt(  (1 / (-x)) * log(1e-10/2)  ), col=4)

	legend("topright", c(expression(eta == 0.05), expression(eta == 0.001), expression(eta == 1e-10)), col=c(2, 3, 4), lwd=1)
	legend("topleft", "the probability to exceed the\ncolored lines is at most eta");

	#savePlot("histogram-rule-lorenz.png");
	result;
}

simulate = function(data, divisions=6, name="Lorenz", plot.average=F, newPlot=T, plotIdx=1){
	N = nrow(data);
	m = 3;
	d = 3;

	xrange = range(data[,1]);
	yrange = range(data[,2]);
	zrange = range(data[,3]);

	if(newPlot)
		plot(0, 1, xlab="sample size", ylab="Divergence", type="l", xlim=c(0, N), ylim=c(1e-2, 1.3), #log="y",
			 main=paste("Full histogram divergences (", name,")", sep=""), col="#FFFFFF");

	avgResult = NULL;
	for(i in seq(0, divisions-1))
	for(j in seq(0, divisions-1))
	for(k in seq(0, divisions-1)){
		#if( any(c(i, j, k) != c(0, 2, 0)) ) next;

		box.x = min(xrange) + c(i, i+1) * diff(xrange) / divisions;
		box.y = min(yrange) + c(j, j+1) * diff(yrange) / divisions;
		box.z = min(zrange) + c(k, k+1) * diff(zrange) / divisions;

		cat(i, j, k, sep="/");
		cat("\n");
		print(rbind(box.x, box.y, box.z));

		# if resampling
		#data = data[seq(1, nrow(data), by=5),]

		#rgl::plot3d(data);
		#rgl::lines3d(t(rbind(box.x, box.y, box.z)), col=2, lwd=3);

		inBox = (data[,1] > box.x[1]) & (data[,1] < box.x[2]);
		inBox = inBox & (data[,2] > box.y[1]) & (data[,2] < box.y[2]);
		inBox = inBox & (data[,3] > box.z[1]) & (data[,3] < box.z[2]);

		#print(inBox[seq(1, 10000, by=97)]);
		freq = sum(inBox) / nrow(data);

		#if(freq == 0)
		print(N / (divisions**3));
		print(sum(inBox));
		if(sum(inBox) < N / (divisions**2))
			next;

		if(plot.average){
			result = divergence.plot(data, box.x, box.y, box.z,
								 to=N/2, by=N%/%1000, shuffle=F, plot=F);

			if(is.null(avgResult)){
				avgResult = result[,c(1, 4)];
			} else {
				avgResult[,2] = (avgResult[,2] + result[,4]);
			}
		} else {
			result = divergence.plot(data, box.x, box.y, box.z,
								 to=N/2, by=N%/%1000, shuffle=F);
		}
	}

	if(plot.average){
		# Times two because it holds the size of one half only
		lines(2*avgResult[,1], avgResult[,2], lwd=2, col=plotIdx, lty=plotIdx);
		grid(col="#00000044");
	}

	#epsilon = function(eta, x){
	#	sqrt(
	#		 2 * log(eta/2) / (-2*x)
	#	) / 2;
	#}

	x = seq(0, N * 1.1, length=1000);
	#lines(x, epsilon(0.05, x), col=2);
	#lines(x, epsilon(0.001, x), col=3);
	#lines(x, epsilon(1e-10, x), col=4);
	#lines(x, epsilon(0.2, x), col=5);

	#legend("topright", c(expression(eta == 0.05), expression(eta == 0.001), expression(eta == 1e-10), expression(eta == 0.2)), col=c(2, 3, 4, 5), lwd=1);
	#legend("bottomleft", "the probability to exceed the\ncolored lines is at most eta");

	if(plot.average){
		return(avgResult);
	} else {
		return(result);
	}
}

data = lorenz.real(5000); # 1,500,000 uses up about 60 MB
data2 = logistic(5000); data2 = embedd(data2, m=3, d=1);
result = simulate(data, name="Logistic", divisions=30, plot.average=T);
result = simulate(data2, name="NOAA Vancouver Precipitation", divisions=30, plot.average=T, newPlot=F, plotIdx=2);

#data = read.csv("../../sunspot.csv", sep=";"); data = data[,4]; data = embedd(data, m=3, d=17);

data = read.csv("NOAA-vancouver-clean.csv"); data = data[,"TAVG"]; data = embedd.custom(data, c(1, 2, 365));
result = simulate(data, name="NOAA Vancouver Precipitation", divisions=30, plot.average=T, newPlot=F, plotIdx=3);

#data2 = read.csv("../../NOAA-vancouver-clean.csv"); data2 = data2[,"PRCP7"]; data2 = data2[!is.na(data)]; data2 = data2[seq(1, length(data), by=7)]; data2 = embedd.custom(data2, c(1, 2, 365%/%7));
#data2 = read.csv("../../NOAA-vancouver-clean.csv"); data2 = data2[,"PRCP7"]; data2 = data2[!is.na(data)]; data2 = embedd.custom(data2, c(1, 2, 365));
#data = read.csv("../../NOAA-vancouver-clean.csv"); data = data[,"PRCP7"]; data = data[!is.na(data)]; data = embedd.custom(data, c(1, 2, 365));
#result = simulate(data, name="Whatever", divisions=10, plot.average=T);
#result = simulate(data2, name="NOAA Vancouver Precipitation", divisions=10, plot.average=T, newPlot=F, plotIdx=2);

#result = lorenz.single(data);

legend("topright", c("Lorenz", "Logistic", "NOAA Temperatures"), col=1:3, lty=1:3, lwd=2);

#savePlot("histogram-rule-lorenz.png");


#Read in the data
cdata <- read.table("german.data", h=F, sep = ' ')

#Add readable column names
colnames(cdata) <- c("chkngAcctStatus", "durationMonths", "creditHistory", "loanPurpose", "creditAmount", "savingsTotal", "crrntEmplmtSince", "instllmtPct", "persnlStatus", "othrDebtorGuaranters", "crrntResidenceSince", "propertyType", "age", "otherInstllmtType", "housingType", "existingCredits","jobStatus", "numDependents", "registeredPhone", "foriegnWorker", "goodBad")

set.seed(252)
split <- createDataPartition(y = cdata$goodBad, p = 0.7, list = F)
train <- cdata[split,]
test <- cdata[-split,]
startMdl <- glm(goodBad ~., train, family = binomial)
stepMdl <- step(startMdl, trace = FALSE, steps = 5000, k= log(nrow(train)))
#display summary
summary(stepMdl)
varImp(stepMdl, scale = FALSE)
stepPr  = predict(stepMdl, newdata = test, type = "response")
stepPred = prediction(stepPr, test$goodBad)
stepPerf = performance(stepPred, "tpr", "fpr")
plot(stepPerf, colorize =TRUE, main = "ROC Curve", col = 2, lwd = 2, print.cutoffs.at=seq(0,1,by=0.1), text.adj=c(-0.2,1.7))
abline( a =0, b = 1, lwd = 2, lty = 2, col = "gray")
round(auc(test$goodBad, stepPr), digits = 2)
set.seed(123)
ctrl <- trainControl(method = "repeatedcv",repeats = 3,classProbs = TRUE,summaryFunction = twoClassSummary)

cvFit <- train(goodBad ~ .,data = train, method = "glm", family = binomial, tuneLength = 5, trControl = ctrl,
           metric = "ROC")

#display summary
summary(cvFit)
varImp(cvFit, scale = FALSE)
cvPr  = predict(cvFit, newdata = test, type = "prob")
cvPred = prediction(cvPr[,2], test$goodBad)
cvPerf = performance(cvPred, "tpr", "fpr")
plot(cvPerf, colorize =TRUE, main = "ROC Curve", col = 2, lwd = 2, print.cutoffs.at=seq(0,1,by=0.1), text.adj=c(-0.2,1.7))
abline( a =0, b = 1, lwd = 2, lty = 2, col = "gray")
round(auc(test$goodBad, cvPr[,2]), digits = 2)


## Principle Components Analysis
## From Stephen Turner, @genetics_blog
## Could do with built-in DESeq2 function:
## DESeq2::plotMA(dds, ylim=c(-1,1), cex=1)
rld_pca <- function (rld, intgroup = "condition", ntop = 500, colors=NULL, legendpos="bottomleft", main="PCA Biplot", textcx=1, ...) {
  require(genefilter)
  require(calibrate)
  require(RColorBrewer)
  rv = rowVars(assay(rld))
  select = order(rv, decreasing = TRUE)[seq_len(min(ntop, length(rv)))]
  pca = prcomp(t(assay(rld)[select, ]))
  fac = factor(apply(as.data.frame(colData(rld)[, intgroup, drop = FALSE]), 1, paste, collapse = " : "))
  if (is.null(colors)) {
    if (nlevels(fac) >= 3) {
      colors = brewer.pal(nlevels(fac), "Paired")
    }   else {
      colors = c("black", "red")
    }
  }
  pc1var <- round(summary(pca)$importance[2,1]*100, digits=1)
  pc2var <- round(summary(pca)$importance[2,2]*100, digits=1)
  pc1lab <- paste0("PC1 (",as.character(pc1var),"%)")
  pc2lab <- paste0("PC1 (",as.character(pc2var),"%)")
  plot(PC2~PC1, data=as.data.frame(pca$x), bg=colors[fac], pch=21, xlab=pc1lab, ylab=pc2lab, main=main, ...)
  with(as.data.frame(pca$x), textxy(PC1, PC2, labs=rownames(as.data.frame(pca$x)), cex=textcx))
  legend(legendpos, legend=levels(fac), col=colors, pch=20)
  #     rldyplot(PC2 ~ PC1, groups = fac, data = as.data.frame(pca$rld),
  #            pch = 16, cerld = 2, aspect = "iso", col = colours, main = draw.key(key = list(rect = list(col = colours),
  #                                                                                terldt = list(levels(fac)), rep = FALSE)))
}


# Random forest
library(randomForest)
adult.rf = randomForest(income~educationNum+hoursPerWeek, data=adult.data, mtry=6, importance=TRUE)

#lm(income~education+workclass+maritalStatus+race+sex+poly(educationNum,8)+poly(hoursPerWeek,8), data=adult.data)

summary(adult.rf)

# do the prediction
yhat = predict(adult.rf,adult.test)

# if yhat is greater than .5 it is 1 else 0
yhat = ifelse(yhat >= 0.5 , 1, 0)

# get and display the mse
mean((yhat - adult.test$income) ^ 2)


a=array(c(1,5,8,7))
a
a1=array(1:15,dim=c(3,4,3))
a1
v1<-c(1,5,7,45,78,98)
v2<-c(10,12,15,18,16,11)
(a2<-array(c(v1,v2),dim=c(3,3,4),
           dimnames=list(c("R1","R2","R3"),
                         c("C1","C2","C3"),
                         c("M1","M2","M3","M4"))))

#access element
a1
a1[c(1,3),1:2,2]

a1[,,3]
a1[1:2,,]
a1[c(1,3),1:2,c(1,3)]
#create 2 vector of diff length\
v3<-c(10,20,40)
v4<-c(4,-5,6,7,10,12,10,-2,1)
(a3<-array(c(v3,v4),dim=c(3,3,2)))


 DPBEQU Example Program Results

 Matrix A
               1            2            3            4
 1    5.4900E+00   2.6800E+10
 2                 5.6300E+20  -2.3900E+10
 3                              2.6000E+00  -2.2200E+00
 4                                           5.1700E+00

 SCOND = 6.8E-11, AMAX = 5.6E+20

 Diagonal scaling factors
     4.3E-01    4.2E-11    6.2E-01    4.4E-01

 Scaled matrix
             1          2          3          4
 1      1.0000     0.4821
 2                 1.0000    -0.6247
 3                            1.0000    -0.6055
 4                                       1.0000


hello <- function(r=100) {
    # version of R
    print(R.version.string)

    # timing matrix multiplication
    ptm <- proc.time()
    n <- 1000
    a <- matrix(runif(n*n),n,n)
    b <- matrix(runif(n*n),n,n)
    c <- matrix(runif(n*n),n,n)
    for (i in 1:r)
        c = a %*% b
    print(proc.time() - ptm)
}

hello()


/*

 here's what you can expect to learn. The characteristics of binomial outcome variables, such as buys versus doesn't buy,
 and recovers or get worse, any kind of situation which you might have to make a decision between two or more alternatives
 is an appropriate kind of context for this course. You'll also learn about the reasons that binomial outcome variables create
 problems for standard analysis procedures such as simple and multiple regression.

You'll see how simple transformations that involve odds ratios and logarithms can solve the problems that binomial outcomes
bring to regression analysis. Now I use Excel in this course mainly to show you what goes on inside logistic regression's
black box. You'll be able to see the intermediate calculations involving those odds and those logarithms, and I use R to show
you how to reach the end point of the analysis quickly so that you can skip over those intermediate kinds of calculations.

*/


library(dplyr)
library(rpart)
library(caret)
library(e1071)
library(caTools)
leaf <- read.csv("leaf.csv", header = FALSE,
                 col.names = c("Class", "Speciment_n°", "Eccentricity", "Aspect_Ratio",
                               "Elongation", "Solidity", "Stochastic_Convexity",
                               "Isoperimetric_Factor", "Maximal_Indentation_Depth",
                               "Lobedness", "Average_Intensity", "Average_Contrast",
                               "Smoothness", " Third_Moment", "Uniformity",
                               "Entropy"))

set.seed(65283)
Train_dt <- read.csv("Train.csv", header = TRUE)
Test_dt <- read.csv("Test.csv", header = TRUE)
Train_dt <- Train_dt[,-1]
Test_dt <- Test_dt[,-1]
Train_dt$Class <- Train_dt$Class %>% as.factor
Test_dt$Class <- Test_dt$Class %>% as.factor
shuffled <- Train_dt[sample(nrow(Train_dt)),]

K <- 5
accuracy <- rep(0,K)
cps <- rep(0,K)
for (i in 1:K) {
  # These indices indicate the interval of the test set
  indexes <- (((i-1) * round((1/K)*nrow(shuffled))) + 1):((i*round((1/K) * nrow(shuffled))))
  #take all the rows execpt those between 1:indices
  if(exists("train") && exists("test")){
    rm(train)
    rm(test)
  }
  train <- shuffled[-indexes,]
  #take all the rows with indices = 1:indices
  test <- shuffled[indexes,]
  print(nrow(train) + nrow(test) == nrow(shuffled))
  numFolds <- trainControl(method = "cv", number = 4)
  cpGrid <- expand.grid(.cp = seq(0.01, 0.5, 0.01))

  train_dt <- train(Class~., data = train, method = "rpart", metric="Accuracy",
                    trControl = numFolds, tuneGrid = cpGrid)
  cps[i] <- train_dt$bestTune$cp

  tree <- rpart(Class ~ ., train, method="class", cp = cps[i])
  pred <- predict(tree, test[,-1],type="class")
  confusionM <- table(test$Class, pred)
  accuracy[i] <- sum(diag(confusionM))/sum(confusionM)
}

write(paste("CV mean:", mean(accuracy), "; CV sd:", sd(accuracy)), append = FALSE, file = "DT_result.txt")
write(c("Accuracies ", accuracy), append = TRUE, file = "DT_result.txt")
write(c("Best cps ", cps), append = TRUE, file = "DT_result.txt")

accuracies <- rep(0, K)
for(i in 1:K) {
  rf <- rpart(Class~., data = Train_dt, method="class", cp = cps[i])
  pred_dt <- predict(rf, Test_dt[,-1], type="class")
  cf_dt <- table(Test_dt$Class, pred_dt)
  accuracies[i] <- sum(diag(cf_dt))/sum(cf_dt)
  write(paste("Acc with cp = ", cps[i], ": ", sum(diag(cf_dt))/sum(cf_dt)), append = TRUE, file = "DT_result.txt")
}
write(paste("Mean acc:", mean(accuracies), "sd:", sd(accuracies)))


########## tento skript je nasim uvodnim seznamenim s Rkem ##########
#####################################################################
# povsimnete si, ze v tomto softwaru jsou komentare opatreny (alespon jednim) dvojitym krizkem
# a nezapomente, ze Rko rozeznava velka a mala pismena

### ulozeni cisla do promenne:
##############################
pocet<-30  ## to je pocet studentu zapsanych na pondelni cviceni

### vypsani hodnoty promenne na obrazovku:
##########################################
pocet

### SAMI: a) do promenne VEK ulozte svuj vek (v rocich)
###       b) vypiste promennou VEK
VEK <- 21
VEK

### prace s promennymi... jako by to byla konkretni cisla
#########################################################

XX<-13   ## pocet devcat na cvicenich
XY<-17   ## pocet kluku na cvicenich

XX+XY    ## (by se melo rovnat "poctu")

### SAMI: a) vytvorte promennou NOVA a dosadte do ni podil promennych XX a XY
###       b) vypiste promennou NOVA
###       c) spoctete rozdil mezi promennymi pocet a NOVA

NOVA <- XX/XY
NOVA
pocet - NOVA

######## dalsi dulezita vec pro nas bude prace s vektory ########
#################################################################

### vektor zadany primo
#######################

hele <- c(1, 5, 4, 9, 0)
length(hele)                ## funkce, vypise delku (dimenzi, pocet souradnic) vektoru hele

delka<-length(hele)         ## i funkcni hodnota muze byt ulozena do promenne
delka

### vektor zadany operatorem (muze se hodit)
############################################

x <- 1:7
x

y <- 2:-2
y
### vektor jako konecna posloupnost (i to se hodi)
##################################################

seq(1, 3, by=0.2)          # urcen pocatkem, koncem a velikosti kroku
seq(1, 5, length.out=4)    # urcen                  a poctem elementu

### SAMI: a) vytvorte vektor VEKT_1 s prvky -1,0,0.25,11
###       b) vytvorte vektor VEKT_2 jehoz prvky jsou cisla -2...23
###       c) kolik prvku ma (jak je dlouhy) VEKT_2?

VEKT_1 <- c(-1,0,0.25,11)
VEKT_1

VEKT_2 <- -2:23
VEKT_2
length(VEKT_2)

### prace s prvky vektoru
#########################

x<-c(0,2,4,6,8,10)
x[3]           # vypise 3. prvek

x[c(2, 4)]     # vypise 2. a 4. prvek
y<-x[c(2,4)]    # vytvori vektor z 2. a 4. prvku vektoru x
y

x[-1]          # vsechny prvky krome 1.
y<-x[-1]       # vektor, ktery vznikne z x vynechanim 1. prvku
y

x[c(2, -4)]    # zahlasi chybu, pozice prvku jsou kladna cisla
x[c(2.4, 3.54)]    # zaokrouhli index dolu!!

### SAMI:    uvazujte svuj vektor VEKT_2:
###       a) vypiste 10. prvek
###       b) sectete 13. a 18. prvek
###       c) vydelte 20. prvek prvkem 6.
###       d) do vektoru VEKT_3 ulozte 3.,11., 13. a 20. prvek vektoru VEKT_2

VEKT_2[10]
VEKT_2[13] + VEKT_2[13]
VEKT_2[20] / VEKT_2[6]

VEKT_3 <- VEKT_2[c(3, 11, 13, 20)]
VEKT_3

#uprava vektoru
x[2]<- -10     # prepise druhou souradnici

x[-c(2,4)]     # vypise vsechny prvky vektoru x BEZ 2. a 4. prvku
x[c(-2,-4)]

x<-x[-c(2,4)]  # PRIMO z promene x vymaze druhy a ctvrty element
length(x)
x
x<-NULL        # vymaze "vnitrek" promenne x

### SAMI: a) z vektoru VEKT_2 vytvorte VEKT_4 odebranim 3., 10, a 14. prvku
###       b) jak je dlouhy vektor VEKT_4?

VEKT_4 <- VEKT_2[-c(3, 10, 14)]
VEKT_4
length(VEKT_4)

### ooperace s vektory

y<-c(-3,-2,-1,0,1,2)

x+y     ## soucet po souradnicich
x*y     ## soucin po souradnicich
x-y     ## rozdil po souradnicich
x/y     ## podil po souradnicich, pozor na deleni nulou!!!!

### funkce na vektorech
#######################

length(x)   ## delka vektoru x (uz jsme si ukazali)
sum(x)      ## soucet prvku vektoru x
mean(x)     ## prumer z hodnot ulozenych v x

### spojeni vektoru
###################
novy_vektor<-c(x,y)      ## spoji vektory x a y do jednoho
novy_vektor2<-c(novy_vektor,x)  ## vytvori vektor obsahujici prvky vektoru
                         ## novy_vektor a x

### SAMI: a) vytvorte vektor VEKT_5 spojenim vektoru y a novy_vektor
          b) urcete delku VEKT_5
          c) soucet prvku vektoru VEKT_5 a jejich prumer

VEKT_5 <- c(y, novy_vektor)
VEKT_5
length(VEKT_5)
sum(VEKT_5)
mean(VEKT_5)


getError=function(f,interval,type,delta,relative){

if (type=="lower")
{
   if (relative){
   error=abs((f-interval[1])/delta)*100
   }else{
     error=abs((f-interval[1]))
   }
}
else
{  if (relative){
    error=abs((f-interval[2])/delta)*100
    }else{
     error=abs((f-interval[2]))
   }
}

return(error)

}


# read the file
x1= read.delim("E:/denboer2009-expr.txt")
rownames(x1)= x1[,1]
x3 = x1[,-1]
x= as.data.frame(t(x3))

# read the lables
y= read.delim("E:/denboer2009-pheno (2).txt")
rownames(y)= y[,1]
y= y[,-1]

# add lables to data as a column
x$sample = substr(y[,5],1,190)

#wilcox test
# creat an empty data frame
wilcoxdata = data.frame( )

# apply t test for each gene, between T-cell and B-cells
for (i in 1:22283) {
  gene_col = i
  wilcoxtest = wilcox.test(x[x$sample =="T",gene_col],x[x$sample !="T",gene_col])
  gene_name = colnames(x[gene_col])
  gene_p_value_w= wilcoxtest$p.value

  # add data to previous data frame
  wilcoxdata =rbind(wilcoxdata , data.frame(gene_name,gene_p_value_w ))
}

# sort samples forom loest p-value to highest
sort_by_pvalue_w= wilcoxdata [order(wilcoxdata$gene_p_value),]


library(igraph)

Graph1 <- graph(edges=c(1,2, 2,3, 3, 1, 4,2), n=4, directed=F)

class(Graph1)

Graph1

plot(Graph1)

WeightsGraph1<- c(4,1,1,1)

E(Graph1)$weight <- WeightsGraph1

ShortDistance<- shortest_paths(Graph1, 1,4)
ShortDistance

d1<-mean_distance(Graph1)
d1


## Function file to fit discrete Lee-Carter with Newton-Raphson
## Modified by Giancarlo Camarda 25-11-2009 for teaching purposes
## (EDSD 220)

###################################################
## Update Alpha
Update.alpha <- function(Alpha, Beta, Kappa,
                         One, Dth, Exp, D.fit){
  difD <- Dth - D.fit
  Alpha <- Alpha + difD %*% One / (D.fit %*% One)
  Eta <- Alpha %*% t(One) + Beta %*% t(Kappa)
  D.fit <- Exp * exp(Eta)
  list(Alpha = Alpha, D.fit = D.fit)
}

###################################################
## Update Beta
Update.beta <- function(Alpha, Beta, Kappa,
                        One, Dth, Exp, D.fit){
  difD <- Dth - D.fit
  Kappa2 <- Kappa * Kappa
  Beta <- Beta + difD %*% Kappa / (D.fit %*% Kappa2)
  Eta <- Alpha %*% t(One) + Beta %*% t(Kappa)
  D.fit <- Exp * exp(Eta)
  list(Beta = Beta, D.fit = D.fit)
}

###################################################
## Update Kappa
Update.kappa <- function(Alpha, Beta, Kappa,
                         One, Dth, Exp, D.fit){
  difD <- Dth - D.fit
  Beta2 <- Beta * Beta
  Kappa <- Kappa + t(difD) %*% Beta / (t(D.fit) %*% Beta2)
  Kappa <- Kappa - mean(Kappa)
  Kappa <- Kappa / sqrt(sum(Kappa * Kappa))
  Kappa <- matrix(Kappa, ncol = 1)
  Eta <- Alpha %*% t(One) + Beta %*% t(Kappa)
  D.fit <- Exp * exp(Eta)
  list(Kappa = Kappa, D.fit = D.fit)
}

###################################################
##     MAIN FUNCTION for fitting the Lee-Carter
LCpoi <- function(Dth, Exp){
  # dimensions
  m <- nrow(Dth)
  n <- ncol(Dth)
  # Initialise
  One <- matrix(1, nrow=n, ncol = 1)
  Fit.init <- log((Dth + 1)/(Exp + 2))
  Alpha <- Fit.init %*% One / n
  Beta <- matrix(1 * Alpha, ncol = 1)
  sum.Beta <- sum(Beta)
  Beta <- Beta / sum.Beta
  Kappa <- matrix(seq(n, 1, by = -1), nrow = n, ncol = 1)
  Kappa <- Kappa - mean(Kappa)
  Kappa <- Kappa / sqrt(sum(Kappa * Kappa))
  Kappa <- Kappa * sum.Beta
  # Iteration
  D.fit <- Exp * exp(Fit.init)
  for (iter in 1:50){
    Alpha.old <- Alpha
    Beta.old <- Beta
    Kappa.old <- Kappa
    #
    temp <- Update.alpha(Alpha, Beta, Kappa,
                         One, Dth, Exp, D.fit)
    D.fit <- temp$D.fit
    Alpha <- temp$Alpha
    #
    temp <- Update.beta(Alpha, Beta, Kappa,
                        One, Dth, Exp, D.fit)
    D.fit <- temp$D.fit
    Beta <- temp$Beta
    #
    temp <- Update.kappa(Alpha, Beta, Kappa,
                         One, Dth, Exp, D.fit)
    D.fit <- temp$D.fit
    Kappa <- temp$Kappa
    crit <- max(max(abs(Alpha - Alpha.old)),
                max(abs(Beta - Beta.old)),
                max(abs(Kappa - Kappa.old)))
    if(crit < 1e-04) break
  }
  # constraints
  sum.Beta <- sum(Beta)
  Beta <- Beta / sum.Beta
  Kappa <- Kappa * sum.Beta
  # output
  out <- list(Alpha=Alpha, Beta=Beta, Kappa=Kappa)
}


# 3. faza: Vizualizacija podatkov
Odstotek <- (podatki$okuzbe) / podatki$rutinsko.dnevno
Aktivne_okuzbe <- cumsum(podatki$okuzbe)
Aktivne_okuzbe[15:154] = Aktivne_okuzbe[15:154]- Aktivne_okuzbe[1:140]
CCA_aktivne_okuzbe <- cumsum((podatki$okuzbe) / podatki$rutinsko.dnevno * 1000)
CCA_aktivne_okuzbe[15:154] = CCA_aktivne_okuzbe[15:154]- CCA_aktivne_okuzbe[1:140]
US <- podatki_svet %>% filter(location=="United States")
cases_cela_Evropa <- podatki_svet %>% group_by(date )%>% filter(continent== "Europe") %>% summarise(vsota_cela_EV = sum(total_cases_per_million/51,na.rm = TRUE))
#DNEVNO STEVILO TESTIRANJ

dnevno_stevilo_testiranj_linija <- ggplot(podatki, aes(x=datum,y=rutinsko.dnevno)) +
  geom_line(col="red")+
  geom_smooth(col="red") +
  ylab("Število testov na dan")+
  ggtitle("Dnevno število testiranj v Sloveniji")

#skupno stevilo okuzenih
stevilo_okuzenih_nekonstantnovskonstantno <-
  ggplot(podatki %>% arrange(datum) %>%
           mutate(skupno.stevilo=cumsum(okuzbe),
                  stevilo.konstantno=cumsum(okuzbe / rutinsko.dnevno) * mean(rutinsko.dnevno)) %>%
           gather("tip", "stevilo", skupno.stevilo, stevilo.konstantno),
         aes(x=datum, y=stevilo, color=tip)) +
  geom_line() +
  ylab("Skupno število okuženih") +
  ggtitle("Okuženi: konstantno in realno testiranje")

#skupno stevilo testiranj
stevilo_testiranj <- ggplot(podatki %>% group_by(datum) %>%
                              summarise(stevilo=sum(rutinsko.dnevno),na.rm = TRUE) %>%
                              arrange(datum) %>%
                              mutate(skupno.stevilo=cumsum(stevilo)),
                            aes(x=datum, y=skupno.stevilo/1000)) +
  geom_col(col="yellow")+
  ylab("Skupno število testiranj v tisočih")+
  ggtitle("Skupno število testiranj v Sloveniji")

#MOŠKI VS ŽENSKE DNEVNO okuženi

dnevno_stevilo_okuzenih_moskivszenske <- ggplot(podatki_spol, aes(x=datum, y=stevilo, color=spol)) +
  geom_smooth(size=1) +
  geom_line() +
  ylab("Število okuženih")+
  ggtitle("Dnevno okuženih moški proti ženskam")

#Dnevno testiranih vikend vs delovni dan

dnevno_stevilo_testiranj_delovni_dan <- ggplot(podatki, aes(x=datum, y=rutinsko.dnevno, col = delovni.dan)) +
  geom_line() +
  geom_smooth(size=1)+
  ylab("Število testiranj")+
  ggtitle("Primerjava testiranja med delovnimi dnevi in vikendom v Sloveniji")

#procent okuzenih
procent_okuzenih_dnevno <- ggplot(podatki, aes(x=datum, y = Odstotek ))+
  geom_line(col="blue")+
  geom_smooth(fill="lightblue")+
  ggtitle("Odstotek dnevno okuženih v Sloveniji")

#Število dni okuženih 0-5, 5-10, 10-15....
frekvenca_stevila_okuzb <-ggplot(podatki, aes(x=okuzbe)) +
  geom_histogram(binwidth=5)

  #Celoten svet cases/million
  cases_cel_svet <- podatki_svet %>% group_by(date)%>% summarise(vsota_cel_svet = sum(total_cases_per_million/212,na.rm = TRUE))
  stevilo_primerov_na_svetu_na_million <- ggplot(cases_cel_svet, aes(x=date,y=vsota_cel_svet)) + geom_line(size=3,col="red")+
    ylab("Število okuženih na milijon")+
    ggtitle("Število primerov na svetu na million prebivalcev")

 #prebivalstvo Evrope po drzavah

  prebivalstvo_EU <- podatki_svet %>% filter(continent == "Europe") %>%

    transmute(location, millions=total_cases/total_cases_per_million) %>%

    filter(!is.nan(millions), !is.na(millions)) %>%

    group_by(location) %>% summarise(millions=mean(millions))
#USA vs Europe
  podatki_EU_USA <- rbind(podatki_svet %>% filter(continent == "Europe") %>%

                            group_by(date) %>% summarise(total_cases=sum(total_cases, na.rm=TRUE)) %>%

                            transmute(date, location="Europe",

                                      total_cases_per_million=total_cases/sum(prebivalstvo_EU$millions)),

                          podatki_svet %>% filter(location == "United States") %>%

                            select(date, location, total_cases_per_million))

  USAvsEU <- ggplot(podatki_EU_USA,aes(x = date,y = total_cases_per_million,col=location))+
    geom_line(size=2)+
    ylab("Število okuženih na milijon")+
    ggtitle("Primerjava okuženosti ZDA proti Evropi")

#Zemljevid
data("World")

Zemljevid_cases_per_million <- tm_shape(merge(World, podatki_svet %>% filter(date == "2020-05-05"), by.x="iso_a3", by.y="iso_code")) +
    tm_polygons("total_cases_per_million")


# Create case study figures

#########################################################################
# Pull PWT into dataframe
data("pwt9.1")

# Basic calculations
p <- pwt9.1 # copy dataframe for manipulation
p$lngdppc <- round(log(p$rgdpna) - log(p$pop),digits=2) # create log GDP per capita
p$lntfp <- log(p$rtfpna)
p$ky <- round(p$rnna/p$rgdpna,digits=2) # create K/Y ratio
p$phil <- round(p$labsh*p$rgdpna/(p$labsh*p$rgdpna+.05*p$rnna),digits=2) # create kludge cost share of labor

# Calculate growth rate of population
p <-
  p %>%
  group_by(isocode) %>%
  mutate(lag1.pop = dplyr::lag(pop, n = 1, default = NA))
p$g1.pop <- (log(p$pop) - log(p$lag1.pop))/1
p$si<- round(p$csh_i,digits=2)

# subset PWT into stable and catchup groups
usa <- p[which(p$isocode %in% c("USA")),]
deu <- p[which(p$isocode %in% c("DEU")),]
kor <- p[which(p$isocode %in% c("KOR")),]
chn <- p[which(p$isocode %in% c("CHN")),]
comp <- p[which(p$isocode %in% c("USA","CHN","KOR")),]

#########################################################################
# Simple TS regressions for fitted BGP for USA
#########################################################################
m1 <- lm(usa$lngdppc~usa$year, data=usa)
m2 <- lm(usa$lngdppc~usa$year, data=usa, subset=(year<2001))
usa$fitted <- predict(m2,usa)

fig <- plot_ly(usa, x = ~year, y = ~lngdppc, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- fig %>% add_trace(y = fitted(m1), name = 'BGP All',mode = 'lines')
fig <- fig %>% add_trace(y = ~fitted, name = 'BGP 20th',mode = 'lines')
fig <- layout(fig, title = list(text = 'Log GDP per capita for United States', x=0),
               xaxis = list(title = 'Year', tick0=1950, dtick=10),
               yaxis = list (title = 'Log GDP per capita', range=c(9,12)),
               hovermode="x unified")
api_create(fig, filename = "pwt-apply-usa")

#########################################################################
# Simple TS regressions for fitted BGP for DEU
#########################################################################
m2 <- lm(deu$lngdppc~deu$year, data=deu, subset=(year>1990))
deu$fitted <- predict(m2,deu)

fig <- plot_ly(deu, x = ~year, y = ~lngdppc, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- fig %>% add_trace(y = ~fitted, name = 'BGP',mode = 'lines')
fig <- layout(fig, title = list(text = 'Log GDP per capita for Germany', x=0),
              xaxis = list(title = 'Year', tick0=1950, dtick=10),
              yaxis = list (title = 'Log GDP per capita', range=c(7,11)),
              hovermode="x unified")
api_create(fig, filename = "pwt-apply-deu")

fig <- plot_ly(deu, x = ~year, y = ~ky, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Capital/output for Germany', x=0),
              xaxis = list(title = 'Year', tick0=1950, dtick=10),
              yaxis = list (title = 'Capital/output ratio', range=c(3,5)),
              hovermode="x unified")
api_create(fig, filename = "pwt-apply--ky-deu")

#########################################################################
# Simple TS regressions for fitted BGP for KOR
#########################################################################
m1 <- lm(kor$lngdppc~kor$year, data=kor, subset=(year<1963))
kor$fitted1 <- predict(m1,kor)
m2 <- lm(kor$lngdppc~kor$year, data=kor, subset=(year>2009))
kor$fitted2 <- predict(m2,kor)

fig <- plot_ly(kor, x = ~year, y = ~lngdppc, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- fig %>% add_trace(y = ~fitted1, name = 'BGP before',mode = 'lines')
fig <- fig %>% add_trace(y = ~fitted2, name = 'BGP after',mode = 'lines')
fig <- layout(fig, title = list(text = 'Log GDP per capita for South Korea', x=0),
              xaxis = list(title = 'Year', tick0=1950, dtick=10),
              yaxis = list (title = 'Log GDP per capita', range=c(6.5,11)),
              hovermode="x unified")
api_create(fig, filename = "pwt-apply-kor")

fig <- plot_ly(kor, x = ~year, y = ~csh_i, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Capital formation share of GDP for South Korea', x=0),
              xaxis = list(title = 'Year', tick0=1950, dtick=10),
              yaxis = list (title = 'Capital formation share of GDP', range=c(0,0.6)),
              hovermode="x unified")
api_create(fig, filename = "pwt-apply-si-kor")

fig <- plot_ly(kor, x = ~year, y = ~g1.pop, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Population growth for South Korea', x=0),
              xaxis = list(title = 'Year', tick0=1950, dtick=10),
              yaxis = list (title = 'Population growth rate', range=c(0,0.05)),
              hovermode="x unified")
api_create(fig, filename = "pwt-apply-gl-kor")

#########################################################################
# Simple TS regressions for fitted BGP for China
#########################################################################
m1 <- lm(chn$lngdppc~chn$year, data=chn, subset=(year<1970))
chn$fitted1 <- predict(m1,chn)
chn$fitted2 <- predict(m2,chn) # use Korea's current BGP as comparison

fig <- plot_ly(chn, x = ~year, y = ~lngdppc, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- fig %>% add_trace(y = ~fitted1, name = 'BGP before',mode = 'lines')
fig <- fig %>% add_trace(y = ~fitted2, name = 'S. Korea BGP',mode = 'lines')
fig <- layout(fig, title = list(text = 'Log GDP per capita for China', x=0),
              xaxis = list(title = 'Year', tick0=1950, dtick=10),
              yaxis = list (title = 'Log GDP per capita', range=c(6.5,11)),
              hovermode="x unified")
api_create(fig, filename = "pwt-apply-chn")

fig <- plot_ly(chn, x = ~year, y = ~csh_i, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Capital formation share of GDP for China', x=0),
              xaxis = list(title = 'Year', tick0=1950, dtick=10),
              yaxis = list (title = 'Capital formation share of GDP', range=c(0,0.6)),
              hovermode="x unified")
api_create(fig, filename = "pwt-apply-si-chn")

fig <- plot_ly(chn, x = ~year, y = ~g1.pop, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Population growth for China', x=0),
              xaxis = list(title = 'Year', tick0=1950, dtick=10),
              yaxis = list (title = 'Population growth rate', range=c(-.01,0.05)),
              hovermode="x unified")
api_create(fig, filename = "pwt-apply-gl-chn")

#########################################################################
# Comparison of GDP p.c. in USA, China, Korea
#########################################################################
fig <- plot_ly(comp, x = ~year, y = ~lngdppc, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Log GDP per capita ', x=0),
              xaxis = list(title = 'Year', tick0=1950, dtick=10),
              yaxis = list (title = 'Log GDP per capita', range=c(6.5,12)),
              hovermode="x unified")
api_create(fig, filename = "pwt-apply-comp")

#########################################################################
# Simple TS regressions for TFP path in China
#########################################################################
f <- p[which(p$isocode %in% c("CHN")),] # re-grab initial data
f <- f[which(f$year>1960),]

m2 <- lm(f$lntfp~f$year, data=f, subset=(year>1960 & year<2000))
m3 <- lm(f$lntfp~f$year, data=f, subset=(year>2013))
f$fitted2 <- predict(m2,f)
f$fitted3 <- predict(m3,f)

fig <- plot_ly(f, x = ~year, y = ~lntfp, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- fig %>% add_trace(y = ~fitted2, name = 'Early BGP?',mode = 'lines')
fig <- fig %>% add_trace(y = ~fitted3, name = 'New BGP?',mode = 'lines')
fig <- layout(fig, title = list(text = 'Level of productivity', x=0),
              xaxis = list(title = 'Year', tick0=1950, dtick=10),
              yaxis = list (title = 'Log productivity'),
              hovermode="x unified")
api_create(fig, filename = "pwt-apply-gtfp-chn")

#########################################################################
# Simple TS regressions for TFP path in Japan
#########################################################################
f <- p[which(p$isocode %in% c("JPN")),]
m1 <- lm(f$lntfp~f$year, data=f, subset=(year<1995))
m3 <- lm(f$lntfp~f$year, data=f, subset=(year>2000))
f$fitted1 <- predict(m1,f)
f$fitted3 <- predict(m3,f)
fig <- plot_ly(f, x = ~year, y = ~lntfp, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- fig %>% add_trace(y = ~fitted1, name = 'Pre-1995 BGP',mode = 'lines')
fig <- fig %>% add_trace(y = ~fitted3, name = 'Post-2000 BGP',mode = 'lines')
fig <- layout(fig, title = list(text = 'Level of productivity', x=0),
              xaxis = list(title = 'Year', tick0=1950, dtick=10),
              yaxis = list (title = 'Log productivity', range=c(-.75,.25)),
              hovermode="x unified")
api_create(fig, filename = "pwt-apply-gtfp-jpn")


### fimd6.R
### R code from Van Buuren, S. (2012).
###		Flexible Imputation of Missing Data.
###		CRC/Chapman & Hall, Boca Raton, FL.
### (c) 2012 Stef van Buuren, www.multiple-imputation.com
### Version 1, 14mar2012
### Version 2, 4nov2015 tested with mice 2.23
### Tested with Mac OS X 10.7.3, R2.14-2, mice 2.11

library("mice")

### Section 6.1.1 Averaging and stacking the data

imp <- mice(nhanes, print=FALSE, seed=55152)
stacked <- complete(imp, "long")
fit <- lm(chl~bmi+age,data=stacked)
coef(fit)

### Section 6.1.2 Repeated analyses

fit <- with(imp, lm(chl~bmi+age))
coef(fit$analyses[[1]])
coef(fit$analyses[[2]])

est <- pool(fit)
summary(est)

expr <- expression(freq <- table(hyp), freq[1]-freq[2])
fit <- with(imp, eval(expr))
unlist(fit$an)

### Section 6.3.5 Computation

imp <- mice(nhanes2, seed=23210, print=FALSE)
fit <- with(imp, lm(bmi~age+chl))
fit.restrict <- with(imp, lm(bmi~1))
res <- pool.compare(fit, fit.restrict)
res$pvalue

est <- pool(fit)
summary(est)

C <- matrix(c(c(0,1,-1,0),c(0,2,-1,0),c(0,0,0,1)),nrow=3,ncol=4,byrow=TRUE)
c <- c(0,0,0.1)
q <- C %*% est$qbar
u <- diag(C %*% est$ubar %*% t(C))
t <- diag(C %*% est$t %*% t(C))
C1 <- C
C1[C1!=0] <- 1
df <- C1 %*% est$df    # this needs to change to compromise df
d <- (q-c)^2/t
pvalue <- 1-pf(d, 1, df)
pvalue

### Section 6.4.2 Computation

data <- boys[boys$age>=8,-4]
imp <- mice(data, seed=28382, m=10, print=FALSE)
expr <- expression(
    f1 <- lm(tv~1),
    f2 <- step(f1, scope=list(upper=~age+hgt+wgt+hc+gen+phb+reg), lower=~1))
fit <- with(imp, expr)
formulas <- lapply(fit$an, formula)
terms <- lapply(formulas, terms)
vars <- unlist(lapply(terms, labels))
table(vars)

fit.without <- with(imp, lm(tv~age+gen+reg+phb))
fit.with <- with(imp, lm(tv~age+gen+reg+phb+hgt))
pool.compare(fit.with, fit.without)$pvalue

fit.without <- with(imp, lm(tv~age+gen+reg))
fit.with <- with(imp, lm(tv~age+gen+reg+phb))
pool.compare(fit.with, fit.without)$pvalue


#------------------------------------------------------------------------------
#Copyright (c) 2017 Tijana Vujcic

source("DBDA2E-utilities.R")

#===============================================================================

  require(rstan)
  #-----------------------------------------------------------------------------
  # THE DATA.
  myData = read.table(file="BloodDataGeneratorOutput.txt",header=T,sep=" ")
  yName = "HeartAttack"
  xName = c( "Systolic", "Diastolic", "Weight", "Cholesterol",
                      "Height", "Age" )
  y = myData[,yName]
  x = myData[,xName]
  # Do some checking that data make sense:
  if ( any( !is.finite(y) ) ) { stop("All y values must be finite.") }
  #if ( any( !is.finite(x) ) ) { stop("All x values must be finite.") }
  #Ntotal = length(y)
  # Specify the data in a list, for later shipment to JAGS:
  dataList = list(
    x = x ,
    y = y ,
    N = length(y) ,
	p  = 7,
	systolic = x[,1],
	dias = x[,2],
	weight = x[,3],
	cholesterol = x[,4],
	height = x[,5],
	age = x[,6]
  )

  #-----------------------------------------------------------------------------
  # THE MODEL.
  modelString = "
	data {
		int<lower=0> N;
		int<lower=0> p;
		int y[N];
		int<lower=0>  systolic[N];
		int<lower=0>  dias[N];
		real<lower=0> weight[N];
		int<lower=0>  cholesterol[N];
		real<lower=0> height[N];
		int<lower=0>  age[N];
	}

	parameters {
		real beta[p];
	}

	transformed parameters  {

	real<lower=0> odds[N];
	real<lower=0, upper=1> prob[N];

	for (i in 1:N) {
		odds[i] = exp(beta[1] + beta[2]*systolic[i] + beta[3]*dias[i] + beta[4]*weight[i] + beta[5]*cholesterol[i] + beta[6]*height[i] +  beta[7]*age[i]);
		prob[i] = odds[i] / (odds[i] + 1);
	}
	}

	model {
		y ~ bernoulli(prob);
	}

  " # close quote for modelString
  # Write out modelString to a text file

resStan <- stan(model_code = modelString, data = dataList,
                chains = 3, iter = 20000/3, warmup = 1000, thin = 1)


# Clear environment
rm(list = ls())

# Clear console
cat("\014")  # ctrl+L

library(devtools)
# import digest library to hash the value as sha256
library("digest")

# to use sample digest function, you can run this line:
# digest("this is an example string" ,"sha256")

# Before you start building your blockchain,
# you need to start the chain somewhere. This is done
# using a so-called Genesis Block. It contains no data and
# arbitrary values for proof and previous hash (as there is no previous block).

# Define Genesis Block (index 1 and arbitrary previous hash)
# in other words, first block(dummy node).
block_genesis <-  list(index = 1,
                       timestamp = Sys.time(),
                       data = "Genesis Block",
                       previous_hash = "0",
                       proof = 1)

#Function that creates a hashed "block"
hash_block <- function(block){
  block$new_hash <- digest(c(block$index,
                             block$timestamp,
                             block$data,
                             block$previous_hash), "sha256")
  return(block)
}

### Simple Proof of Work Algorithm
proof_of_work <- function(last_proof){
  proof <- last_proof + 1

  # Increment the proof number until a number is found that is divisable by 99 and by the proof of the previous block
  while (!(proof %% 99 == 0 & proof %% last_proof == 0 )){
    proof <- proof + 1
  }

  return(proof)
}

#A function that takes the previous block and normally some data
# (in our case the data is a string indicating which block in the chain it is)
gen_new_block <- function(previous_block){

  #Proof-of-Work
  new_proof <- proof_of_work(previous_block$proof)

  #Create new Block
  new_block <- list(index = previous_block$index + 1,
                    timestamp = Sys.time(),
                    data = paste0("this is block ", previous_block$index +1),
                    previous_hash = previous_block$new_hash,
                    proof = new_proof)

  #Hash the new Block
  new_block_hashed <- hash_block(new_block)

  return(new_block_hashed)
}

# create a list named blockchain whose first node is block_genesis
blockchain <- list(block_genesis)
previous_block <- blockchain[[1]]

# How many blocks should we add to the chain after the genesis block
num_of_blocks_to_add <- 5

# Add blocks to the chain with generated data.
for (i in 1: num_of_blocks_to_add){
  block_to_add <- gen_new_block(previous_block)
  blockchain[i+1] <- list(block_to_add)
  previous_block <- block_to_add

  print(cat(paste0("Block ", block_to_add$index, " has been added", "\n",
                   "\t", "Proof: ", block_to_add$proof, "\n",
                   "\t", "Hash: ", block_to_add$new_hash)))
}

blockchain
build("~/Desktop/adsız klasör/blockchain_R")


obrisi = function(podatki, hc = TRUE, od = 2, do = NULL) {
  n = nrow(podatki)
  if (is.null(do)) {
    do = n - 1
  }

  razdalje = dist(podatki)

  k.obrisi = tibble()
  for (k in od:do) {
    if (hc) {
      o.k = hclust(razdalje) %>%
        cutree(k) %>%
        silhouette(razdalje)
    } else {
      set.seed(42) # zato, da so rezultati ponovljivi
      o.k = kmeans(podatki, k)$cluster %>%
        silhouette(razdalje)
    }
    k.obrisi = k.obrisi %>% bind_rows(
      tibble(
        k = rep(k, n),
        obrisi = o.k[, "sil_width"]
      )
    )
  }
  k.obrisi$k = as.ordered(k.obrisi$k)

  k.obrisi
}

obrisi.povprecje = function(k.obrisi) {
  k.obrisi.povprecje = k.obrisi %>%
    group_by(k) %>%
    summarize(obrisi = mean(obrisi))
}

obrisi.k = function(k.obrisi) {
  obrisi.povprecje(k.obrisi) %>%
    filter(obrisi == max(obrisi)) %>%
    summarize(k = min(k)) %>%
    unlist() %>%
    as.character() %>%
    as.integer()
}