subroutine triar(x0,y0,x1,y1,x2,y2,area)

# Calculate the area of a triangle with given
# vertices, in anti clockwise direction.
# Called by delout.

implicit double precision(a-h,o-z)
half = 0.5d0

area = half*((x1-x0)*(y2-y0)-(x2-x0)*(y1-y0))
return
end


# Goodness of fit (r2), predicción.
#################################################################
cat("\014")
rm(list=ls())
graphics.off()

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

# Sabemos interpretar los coeficientes, sabemos cuando los coeficientes
# son significativos (estadisticamente hablando). Lo que no hemos
# hablado hasta el momento, es como evaluamos distintos modelos: como podemos
# saber que modelo interpreta mejor la realidad?

# Matematicamente, queremos saber cuan bien nuestra linea se acerca/aleja
# de nuestros datos. Mientras nuestra linea de regresion se acerque mas,
# mejor nuestro modelo.

# DEMOSTRAR EN LA PIZARRA.

# El estadistico que ocupamos para tener una idea de cuan bien nuestro
# modelo interpreta la realidad, es el r-cuadrado, o r2.

#################################################################
# r2: Definicion y Significado
#################################################################

# El r-cuadrado es un porcentaje, que obviamente va de 0 a 1. Mientras
# mas cercano a 1, nuestro modelo mejora.

# Usualmente, se interpreta como el % de la varianza que es explicada
# por nuestro modelo. Por ej., un "r2 = 0.3" significa que nuestras variables
# explican el 30% de nuestros datos.

# (1) Es eso "suficientemente bueno"?
# (2) Que % nos da la "tranquilidad" de que tenemos un buen modelo?

# Por que es importante el r2? Bueno, asi podemos comparar que modelo
# explica mas la realidad. Imaginate que tenemos dos modelos, m1 y m2.
# Si r2(m1) > r2(m2), debieramos quedarnos con el m1. Por que?
# Porque el set de variables de m1 explica mas varianza (mas datos)
# al compararlo con el m2.

#################################################################
# r2: Viendo el r2
#################################################################

# 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/obama.dta")

# Base
head(dat) # Base sobre preferencias politicas: Obama.

#
dat$Obamafav <- as.numeric(jitter(dat$Obamafav, factor=2, amount = 1))
dat$ideology <- as.numeric(jitter(dat$ideology, factor=2, amount = 1))

# Modelo 1
options(scipen = 1000000) # apagar notacion cientifica.
modelo.entero = lm(Obamafav ~ income + education + age + sex + ideology, dat)
summary(modelo.entero)

# obtener el r2 de "modelo.entero"
summary(modelo.entero)$r.squared # Atencion: al summary le podemos pedir una parte especifica usando "$".

# Modelo 2
modelo.parcial = lm(Obamafav ~ ideology, dat)
summary(modelo.parcial)

# obtener el r2 de "modelo.parcial"
summary(modelo.parcial)$r.squared

# Modelo 3: este es un "mal" modelo
modelo.mediocre = lm(Obamafav ~ age, dat)
summary(modelo.mediocre)
summary(modelo.mediocre)$r.squared # Pesimo...

# (1) Que podemos concluir de los r2 respectivos de "modelo.entero" y "modelo.parcial"?
# (2) Con que modelo nos quedamos? Costo-beneficio, teniendo en cuenta la parsimonia.
# (*) Este es el tipo de decisiones que podemos tomar usando el estadiatico r2.

# Graficos
## Grafiquemos nuestro "fit", es decir, cuan "en forma" esta nuestro modelo.

layout(matrix(1:3, nrow = 1)) # modifiquemos el plano donde graficamos.
# Aqui le decimos a R que "haga espacio" para 3 graficos, y que los ordene
# en una sola fila. Asi podremos poner tres graficos, uno por cada modelo.

# Los siguientes graficos, pondran en el eje-X el "fitted" es decir, el predicho.
# El eje-y tendra el observado.

plot(dat$Obamafav, fitted(modelo.entero), col = "gray", main = "Modelo Entero"); curve((x), col = "blue", add = TRUE)
plot(dat$Obamafav, fitted(modelo.parcial), col = "gray", main = "Modelo Parcial"); curve((x), col = "blue", add = TRUE)
plot(dat$Obamafav, fitted(modelo.mediocre), col = "gray", main = "Modelo Mediocre"); curve((x), col = "blue", add = TRUE)

# (1) Notar que puse ";" en la misma linea.
# (2) Que podemos concluir de esto?

#################################################################
# r2: Formula Estadistica
#################################################################

# Hablemos de la formula del r2.
# r2 = 1- (Errores Cuadrados del Residuo / Errores Cuadrados Totales)

# Errores Cuadrados del Residuo: Por cada fila, tomamos la diferencia entre
# predicho y observado. Eso al cuadrado, y despues sumamos todo. Despues, eso
# lo dividimos por los errores (o variabilidad) de la variable dependiente.
# Piensa que el valor esperado de "y" es su promedio. Entonces, el "error" en
# este caso es cuanto se aleja cada fila (observacion) del promedio de "y". Y
# finalmente, restamos 1 a ese numero final.

#################################################################
# r2: Matrices
#################################################################
options(scipen = 1000000) # apagar notacion cientifica.

# Saquemos el r2 del modelo.entero.

# Recuerda, este era nuestro modelo
#modelo.entero = lm(Obamafav ~ income + education + age + sex + ideology, dat)
summary(modelo.entero) # resumen
summary(modelo.entero)$r.squared # r2

# Formula del r2 en Matrices

## 1. Calcular los errores del modelo

## (a) Extraer "y" observado.
y.observado = dat$Obamafav

## (b) Extraer "y" predicho.
y.predicho = modelo.entero$fitted.values

## Calcular los errores del modelo
e.m = y.observado - y.predicho

### BONUS: Comparalo con el que esta dentro del objeto del modelo.
table(round(as.numeric(modelo.entero$residuals),8) == round(as.numeric(e.m), 8))

## 2. Calcular los errores de la variable dependiente (Errores del vector y)
y.m = y.observado - mean(y.observado) # round(mean(y, trim = 0.5), 3)

## Calcular r2
### 1- e'e/y'y
1 - t(e.m) %*% e.m / t(y.m) %*% y.m # Vemos que es igual a la tabla

# Ahora hagamos lo mismo, pero usando algebra "normal", no de matrices.

# Formula Estadistica
y_fit <- modelo.entero$fitted.values # Fitted es lo que predecimos

# Sum Square Error
SSE <- sum((y_fit - y.observado)^2) # Aqui restamos lo que predecimos ("y_fit") menos lo que observamos ("y), y despues sacamos el cuadrado de esos numeros, y despues sumamos todas esas diferencias cuadradas. Esta cantidad se llama "Sum Square Error", y es eso: la suma de todos los errores cuadrados.

# Sum Square Total
SST <- sum((y.observado - mean(y.observado))^2) # Despues calculamos el "Sum Square Total". Estos son los "errores" o desviaciones que tiene nuestra matriz "y", y tiene que ver con cuanto cada elemento en "y" se desvia del promedio de "y".

# r2
1-SSE/SST  # R^2, que es 1 menos SSE/SST
summary(modelo.entero)$r.squared # r2// Y que es esto mismo.

#################################################################
# r2: "Ajustado"
#################################################################

# Como dice King, el r2 es una funcion de los parametros (variables independientes).
# Mientras mas variables (o x's), mejor nuestro r2. Es por esto que
# es muy comun "mentir" en estadisticas: pones un monton de x's, y mejoras
# tu r2. Esto se ha llamado "kitchen-sink regression".

# Una manera de "arreglar" esto, es no mirar el r2, si no que el r2-ajustado.
# Este estadistico nos dice lo mismo que el r2, pero "ajusta" por el numero
# de x's que calculamos. En otras palabras, por cada parametro que calculamos,
# existe un "castigo".

# Recordemos nuestros r2's
summary(modelo.entero)$r.squared
summary(modelo.parcial)$r.squared
summary(modelo.mediocre)$r.squared

# Ahora calculemos el r(2)-ajustado
summary(modelo.entero)$adj.r.squared
summary(modelo.parcial)$adj.r.squared
summary(modelo.mediocre)$adj.r.squared

# Como ven, dice casi lo mismo, y el penalty es muy pequeno.

#################################################################
# Criticas al r2
#################################################################

# Sin embargo, pensemos por un momento en el r2 perfecto, y lo que
# tendriamos que hacer para lograrlo.

# (1) Que tendriamos que hacer para lograr un r2 = 1?
# (2) Es realmente bueno/posible?
# (3) Si no es el r2, que otra alternativa tenemos (paper de King)?


library(markovchain)

age<-seq(from = 30,  to = 50, by=1)
ProbA2U<-seq(0.0006,0.0060,length.out = 21)
ProbA2D<-seq(0.0005,0.0020,length.out = 21)
ProbA2A<-1-(ProbA2U+ProbA2D)
ProbU2A<-seq(0,0,length.out = 21)
ProbU2D<-seq(0.1219,0.1879,length.out = 21)
ProbU2U<-1-(ProbU2A+ProbU2D)
ProbD2A<-seq(0,0,length.out = 21)
ProbD2U<-seq(0,0,length.out = 21)
ProbD2D<-1-(ProbD2A+ProbD2U)
DecrementsTable<- data.frame(age,ProbA2A,ProbA2U,ProbA2D,ProbU2A,ProbU2U,ProbU2D,ProbD2A,ProbD2U,ProbD2D)

str(DecrementsTable)
summary(DecrementsTable)
head(DecrementsTable)

WorkesStates<-c("Active","Unable","Dead")

TransMatrix35<-matrix(as.numeric(DecrementsTable[DecrementsTable$age==35,2:10]),nrow = 3,ncol = 3, byrow = TRUE,
                      dimnames = list(WorkesStates, WorkesStates))

MCModel35<-new("markovchain", transitionMatrix = TransMatrix35, states = WorkesStates, name="MCModel35")

MCModel35

states(MCModel35)
dim(MCModel35)
str(MCModel35)
MCModel35@transitionMatrix
absorbingStates(MCModel35)

set.seed(5)

WorkerStatePred35<- rmarkovchain(n = 1000, object = MCModel35, t0 ="Active")
table(WorkerStatePred35)

TransMatrix50<-matrix(as.numeric(DecrementsTable[DecrementsTable$age==50,2:10]),nrow = 3,ncol = 3, byrow = TRUE,
                      dimnames = list(WorkesStates, WorkesStates))
MCModel50<-new("markovchain", transitionMatrix = TransMatrix50, states = WorkesStates, name="MCModel50")

WorkerStatePred50<- rmarkovchain(n = 1000, object = MCModel50, t0 ="Active")
table(WorkerStatePred50)

MCModelsList=list()
j=1
for(i in 30:50){
  TransMatrix<-matrix(as.numeric(DecrementsTable[DecrementsTable$age==i,2:10]),nrow = 3,ncol = 3, byrow = TRUE,
                           dimnames = list(WorkesStates, WorkesStates))

  MCModelsList[[j]]<-new("markovchain", transitionMatrix = TransMatrix, states = WorkesStates)
  j=j+1
}

MCList30to50<-new("markovchainList", markovchains = MCModelsList,name="MCList30to50")

StatesSequence<-rmarkovchain(n=10000, object=MCList30to50,t0="Active")
str(StatesSequence)
StatesOccurences<-table(StatesSequence$value)
ExpectedUnableOccurence<-StatesOccurences[3]/nrow(StatesSequence)
ExpectedUnableOccurence


library(nloptr)

fit = function(cases, window=7, lags=7, omega) {
  #Contructs de R with thompson method... (Cori et al)
  priorRate=2
  priorShape=1
  initialVector=cases[1:lags]

  omega_matrix=matrix(0,length(cases)-lags,lags)
  for(i in 1:length(cases)-lags){
    for(j in 1:lags){
      omega_matrix[i,j] = omega(i, j)
    }
  }

  infectPotential_T=matrix(0,length(cases)-lags,1)
  for(i in 1:dim(infectPotential_T)[1]){
    infectPotential_T[i]=sum(cases[i:(i+lags-1)]*rev(omega_matrix[i,]))
  }
  #Seriel interval times observed cases, there are lags values
  # computing denominatortofequation 4?
  casesMatrix=matrix(0,length(infectPotential_T)-(window-1),window)
  for(i in 1:dim(casesMatrix)[1]){
    casesMatrix[i,]=infectPotential_T[i:(i+window-1)]
  }
  #doble suma ecuacion 7
  infectPotential=casesMatrix%*%matrix(1,window,1)

  #Generate observation Matrix
  postcasesMatrix=matrix(0,length(cases)-(window-1),window)
  for(i in 1:dim(postcasesMatrix)[1]){
    postcasesMatrix[i,]=cases[i:(i+window-1)]
  }

  #suma iw(t) se supone esto es Poisson
  infectObservados=postcasesMatrix%*%matrix(1,window,1)

  betaParameteres=cbind(priorShape, priorRate)

  for(i in 1:dim(casesMatrix)[1]){
    shape1=priorShape+infectObservados[i]
    rate1=priorRate+infectPotential[i]
    betaParameteres=rbind(betaParameteres,cbind(shape1, rate1))
  }
  shape1=betaParameteres[-1,1]
  rate1=betaParameteres[-1,2]

  lb=qgamma(0.05, shape=shape1, rate=rate1)
  ub=qgamma(0.95, shape=shape1, rate=rate1)
  beta=((shape1-1)/rate1)
  for(i in 1:window){
    lb=c(lb[1],lb)
    ub=c(ub[1],ub)
    beta=c(beta[1],beta)
  }

  data=cbind(lb, beta,ub)
  data=as.data.frame(data)
  data$day=1:length(lb)
  print(data$beta)
  data$R=data$beta*sum(omega_matrix[1,])
  data$Rlb=data$lb*sum(omega_matrix[1,])
  data$Rub=data$ub*sum(omega_matrix[1,])

  #R_Caso
  lb=data$lb
  ub=data$ub
  beta=data$beta
  longCaseslb=c(rep(lb[1], length=lags-1),lb)
  longCasesub=c(rep(ub[1], length=lags-1),ub)
  longCasesbeta=c(rep(beta[1], length=lags-1),beta)

  data$R_c=data$beta*sum(omega_matrix[1,])
  data$R_clb=data$lb*sum(omega_matrix[1,])
  data$R_cub=data$ub*sum(omega_matrix[1,])

  for(i in 1:length(lb)){
    data$R_c[i]=sum(longCasesbeta[i:(i+lags-1)]*omega_matrix[1,])
    data$R_clb[i]=sum(longCaseslb[i:(i+lags-1)]*omega_matrix[1,])
    data$R_cub[i]=sum(longCasesub[i:(i+lags-1)]*omega_matrix[1,])
  }
  return(data)
}

fit2 = function(I, window=7, prior_shape, prior_rate, omega) {
  "
  Unvectorized model fitting.
  "
  steps = length(I)
  mode = rep(NaN, window + 1)
  lb = rep(NaN, window + 1)
  ub = rep(NaN, window + 1)
  for (t in (window + 1):steps) {
    shape = prior_shape + sum(I[(t - window):t])
    # solve rate iteratively
    rate = prior_rate
    for (t_prime in (t - window):t) {
      for (tau in 1:(t_prime - 1)) {
        rate = rate + (omega[tau] * I[t_prime - tau])
      }
    }
    mode = c(mode, (shape - 1)/rate)
    lb = c(lb, qgamma(0.05, shape=shape, rate=rate))
    ub = c(ub, qgamma(0.95, shape=shape, rate=rate))
  }
  R = list("mode"=mode, "lb"=lb, "ub"=ub)
  return(R)
}

fit3 = function(I, window=7, prior_shape, prior_rate, omega) {
  "
  Like fit2, but omega is a function of (t, tau).
  "
  steps = length(I)
  mode = rep(NaN, window)
  for (t in window:steps) {
    shape = prior_shape + sum(I[(t - window):t])
    # solve rate iteratively
    rate = prior_rate
    for (t_prime in (t - window):t) {
      for (tau in 1:(t_prime - 1)) {
        rate = rate + (omega(t, tau) * I[t_prime - tau])
      }
    }
    mode = c(mode, (shape - 1)/rate)
  }
  R = list("mode"=mode)
  return(R)
}


#' Calculates the match value of an input to a category.
#'
#' This function returns a value which represents the amount of match
#' between the given input and the given category.
#' @title ART_Calculate_Match
#' @param input Vector of size NumFeatures that contains the input signal into the network
#' @param weightVector Matrix of size NumFeatures which holds the weights of the network for a given category
#' @return Measure of the degree of match between the input and the current category
#' @details The length of the INPUT vector must equal the length of the WEIGHTVECTOR.
#'
ART_Calculate_Match = function(input, weightVector)
{
  # Initialize the local variables.
  match = 0;
  numFeatures = length(input);

  # Make sure the weight vector is appropriate for the input.
  if(numFeatures != length(weightVector))
  {
    stop('The input and weight vector lengths do not match.');
  }

  # Calculate the match between the given input and weight vector.
  # This is done according to the following equation:
  #       Match = |Input^WeightVector| / |Input|
  matchVector = pmin(input, weightVector);
  inputLength = sum(input);
  if(inputLength == 0)
  {
    match = 0;
  }
  else
  {
    match = sum(matchVector) / inputLength;
  }
  return (match);
}


#' Yang's network tomography data
#'
#' Simulated traffic counts on Yang's (1995) network. The aim is to sample the corresponding origin-destination traffic volumes that are consistent with those counts.
#' The dataset appears as a list prepared for that purpose.
#' Components of the list are A (the configuration matrix, which in this case is the link-path incidence matrix); y (observed traffic counts); lambda (assumed mean origin-destination traffic volumes);
#' and MarkovBasis (a matrix with columns corresponding to the vectors in full Markov basis for the resampling problem).
#'
#' @references Yang, H. (1995). Heuristic algorithms for the bilevel origin-destination matrix estimation problem. Transportation Research Part B: Methodological, 29(4), 231-242.
#'
#' @docType data
#'
#' @usage data(YangNetwork)
#' @export
#' @examples
#' data(YangNetwork)
#' Xsampler(A=YangNetwork$A,y=YangNetwork$y,lambda=YangNetwork$lambda,Model="Poisson",Method="Gibbs",tune.par=0.5,combine=TRUE)
"YangNetwork"


#RESUMEN R

#CLASE 9
#EJEMPLO DISEÑO WEB

diseweb <- read.csv("C:/Users/Milagros/Desktop/exp numerica/datos_ejemplo_disenoweb.csv")
head(diseweb)
# ANOVA es para comparar igualdad de medias para 2 o mas grupos
# antes que nada  se realiza barlett para comparar  la igualdad de varianzas
# porque ANOVA necesita igualdad de varianzas
# Cuando las varianzas son distintas se utiliza Kruskal para comparar medianas
# Sin embargo como son  muestras relacionadas kruskal no nos da buenos resultados para poder
# concluir diferencia en las medianas, Kruskal sirve para muestras independientes.
kruskal.test(puntuacion~tipodiseno,diseweb)
# entonces utilizamos friedman
friedman.test(puntuacion~tipodiseno|jurado,diseweb)

#EJERCICIO CAFE

f <- read.csv(choose.files())
f
head(f)
#hipotesis

# h0= las medianas de los distintos tipos de cafe son iguales
# h1= al menos una de las medianas es diferente
# quito la columna de expertos que solo es numeros
f<-f[,-1]
f
#creo una columna de expertos con etiquetas mas entendibles
paste0("Experto_", rownames(f));
#transformo el set de datos  para que sea una matriz  que pueda recibir el test
f2 <-reshape(f,ids=rownames(f),times=(names(f)),timevar="tipocafe",varying=list(names(f)),direction="long")
head(f2)
names(f2)<-c("tipocafe","puntuacion","experto")
#realizamos el test
friedman.test(puntuacion~tipocafe|experto,f2)
# conclusion:
# Como el p value es menor que el nivel de significancia (alpha)
# se rechaza la hipotesis nula
# podemos concluir que a un nivel de confianza de 0.95 se puede afirmar que al menos uno de los
# tipos de cafe tiene una puntuacion mediana diferente

#CAPITULO 11

# ejercicio Relajacion muscular

# diseño experimental: completamente al azar (DCA)
# unidad Experimental: Un paciente
# variable respuesta: tiempo de la duracion de la relajacion muscular
# factor en estudio: las distintas drogas
# niveles del factor: sin droga, innovar, droperidol, fentayl
# tratamientos:sin droga, innovar, droperidol, fentayl
# Factores: de bloqueo
# Covariable: No existe

# EJERCICIO DIETAS ANIMALES coagulacion
A <- c(62,60,63,59)
B <- c(63,67,71,64,65,66)
C <- c(68,66,71,67,68,68)
D <- c(56,62,60,61,63,64,63,59)

resultado <- c(A,B,C,D)
dietas <- c(rep("A",length(A)),
            rep("B",length(B)),
            rep("C",length(C)),
            rep("D",length(D)))

misdatos <- data.frame(dietas,resultado)
# un pequeño grafico
boxplot(resultado~dietas,misdatos, main="Tiempo de coagulaciÃ³n de la sangre segun dieta", ylab="Tiempo (segundos)")

# ANOVA Siempre se usa
anova1 <- aov(resultado~dietas,misdatos)
summary(anova1)
# se rechaza la hipotesis nula y acepto h1, entonces concluimos que almenos una tiene media diferente
# media general
mu.est <- mean(misdatos$resultado)
#aplicar media por grupos
mean_treatment <-  aggregate(resultado~dietas,misdatos,mean)
#diferencia media por grupos y media global
effect_treatment <-  aggregate(resultado~dietas,misdatos,function(x){mean(x)-mu.est})
mu.est
effect_treatment

# Treatment Effect with a reference Level
# mide los efectos respecto a un nivel, en este caso el nivel A
round(coefficients(anova1),2)

# Changing Reference Level
# en este caso el nivel B
misdatos$dietas <- relevel(misdatos$dietas,ref="B")
anova1 <- aov(resultado~dietas,misdatos)
summary(anova1)
round(coefficients(anova1),2)
# como se puede ver la media de tiempos del nivel a respecto al B es 5 minutos menos
# la media del nivel C es 2 minutos mas y la media del nivel D es 5 minutos menos

#EJERCICIO BACTERIA
res <- c(13,16,5,22,24,4,18,17,1,39,44,22)
factor <- c(1,2,3,1,2,3,1,2,3,1,2,3)
bloque <- c(1,1,1,2,2,2,3,3,3,4,4,4)

midata <- data.frame(factor,bloque,res)

#graficos
boxplot(res~factor,midata, main="Retardo en el crecimiento de bacterias",
        ylab="Tiempo (segundos)",
        xlab="Factor: Soluciones de lavado")
boxplot(res~bloque,midata, main="Retardo en el crecimiento de bacterias",
        ylab="Tiempo (segundos)",
        xlab="Bloques: Dias")

#graficos
interaction.plot(midata$factor,midata$bloque,midata$res,
                 xlab="Factor: Soluciones de lavado",
                 ylab="Tiempo (segundos)",
                 leg.legend="Bloque")

#Annova
anova3 <- aov(res~as.factor(factor)+as.factor(bloque),midata)
summary(anova3)

#reformulo la data con dos factores
midata <- data.frame(factor=as.factor(factor),bloque=as.factor(bloque),res)
anova1 <- aov(res~factor+bloque,midata)
summary(anova1)

# global Effect and Treatment Effect
#Ver diferencia de medias entre cada factor
mu.est <- mean(midata$res)
mean_treatment <-  aggregate(res~factor,midata,mean)
effect_treatment <-  aggregate(res~factor,midata,function(x){mean(x)-mu.est})
effect_block <-  aggregate(res~bloque,midata,function(x){mean(x)-mu.est})
mu.est
effect_treatment
effect_block

#Effects with control treatment
#Ver diferencias de medias respecto un nivel
round(coefficients(anova1),4)

#EJERCICIO GASOLINA
# h0 : T1=t2=T3=t4=t5=0
# h1 : al menos un Ti <>0

data5 <- read.csv(choose.files())
data5

anova4 <- aov(res~as.factor(factor)+as.factor(bloque),data5)
summary(anova4)

#Con un nivel de confianza del 95% se puede concluir que al menos
#un tipo de gasolina tienen un efecto distinto en el rendimiento del carro

#CAPITULO 12

#Ejercicio Voltaje

midata <- read.csv("C:/Users/Milagros/Desktop/exp numerica/datos_voltaje.csv")
midata$Temperatura <- as.factor(midata$Temperatura)
midata$material <- as.factor(midata$material)
anova <- aov(voltaje~Temperatura+material+Temperatura*material,midata)
summary(anova)

interaction.plot(midata$Temperatura,midata$material,midata$voltaje,
                 xlab="Factor: Temperatura",
                 ylab="Voltaje",
                 leg.legend="Material")

# Medias
tapply(midata$voltaje,midata$Temperatura, mean)
tapply(midata$voltaje,midata$material, mean)

#Estimacion
mean(midata$voltaje)
tapply(midata$voltaje,midata$Temperatura, mean) - mean(midata$voltaje)
tapply(midata$voltaje,midata$material, mean) - mean(midata$voltaje)

#combino medias--> las medias de la combinacion material temperatura
combinacion<-aggregate(voltaje~Temperatura+material,midata,mean)

unique(midata$Temperatura)
unique(midata$material)

dataframe <-data.frame()
for(i in unique(midata$Temperatura)){
  for(j in unique(midata$material)){
    media_ij <- mean(midata$voltaje[midata$Temperatura%in%c(i) & midata$material%in%c(j)])
    media_i <- mean(midata$voltaje[midata$Temperatura%in%c(i)])
    media_j <- mean(midata$voltaje[midata$material%in%c(j)])
    media_global <- mean(midata$voltaje)

    eff_ij <- media_ij - media_i - media_j + media_global

    dataframe <- rbind(dataframe,data.frame(i,j,eff_ij))

  }
}


##' Estimate parameters of a circle using Hough Circle Transform
##'
##' Uses a portion of the canny algorithm to find candidate edge points
##' and the direction of the gradient at those points, then uses
##' Hough Circle Transform to estimate circle parameters.
##'
##' @param im The image to find a circle in (a modulation estimate is best)
##' @param fw Size of Gaussian blur to smooth image
##' @param qt Threshold to accept strong edge candidate
##' @param excl Number of pixels to exclude around edge of frame as candidates
##' @param rmin Minimum circle radius
##' @param rmax Maximum circle radius
##' @param rstep step size in constructing lookup table
##' @param dtheta_max maximum assumed error in gradient direction
##' @param dtheta_step increment for dtheta
##' @param number of nearest neighbors for alternate calculation
##' @param plots plot?
##' @param details Return extra details?
##'
##' @details
##' The Hough transform section first creates a lookup table of candidate
##' radii and center points, then for each candidate edge point calculates
##' potential centers along a fan of rays near the gradient direction.
##' An inner join then finds matches in the lookup table and increments
##' an accumulator vector. Highest vote at the end wins.
##'
##' @return If details is FALSE a named list with the circle parameters
##'
##' @note
##' This is experimental and can be very slow. A good guess for the radius is very helpful.
##' Experimental feature: find the nn nearest neighbors of the selected trio of parameters
##' and calculate a vote weighted mean. This is returned as \code{rxy_alt} if details is TRUE.
##'
##' @seealso [circle.pars()], [pupil.pars()]
##'
##' @examples
##' example("psifit", package="zernike", ask=FALSE)
##' X11()
##' cp2 <- circle.hough(tfit$mod, rmin=round(tfit$cp$rx)-10, rmax=round(tfit$cp$rx)+10)
circle.hough <- function(im, fw=2, qt=0.995, excl=5,
                         rmin=min(dim(im))/4, rmax=min(dim(im))/2, rstep=1,
                         dtheta_max = 0.5, dtheta_step=0.05,
                         nn=7, plots=TRUE, details=FALSE) {
  require(data.table)
  nr <- nrow(im)
  nc <- ncol(im)
  if (fw > 0) {
    im <- gblur(im, fw)
  }
  if (excl < 1) {
    excl <- 1
  }
  kern.sobel <- rbind(c(-1,-2,-1),c(0,0,0),c(1,2,1))
  gx <- convolve2d(im, kern.sobel)
  gy <- convolve2d(im, t(kern.sobel))
  modg <- sqrt(gx^2+gy^2)
  modg <- modg/max(modg)
  dirg <- atan2(gy, gx)

  # round off directions to 45 degrees

  dir <- dirg
  dir[abs(dirg) < 7*pi/8] <- (round(dirg[abs(dirg) < 7*pi/8]*4/pi))
  dir[abs(dirg) >= 7*pi/8] <- 0
  dir[dir < 0] <- 4+dir[dir<0]

  # find local maxima

  maxima <- NULL

  for (i in 0:3) {
    ptsi <- which(dir==i, arr.ind=TRUE)
    ed <- which(ptsi[,1] <= excl)
    ed <- c(ed, which(ptsi[,1] >= nr-excl+1))
    ed <- c(ed, which(ptsi[,2] <= excl))
    ed <- c(ed, which(ptsi[,2] >= nc-excl+1))
    if (length(ed) > 0) {
      ptsi <- ptsi[-ed,]
    }
    nb <- switch(i+1, c(1,0), c(1,1), c(0,1), c(1, -1))
    ptsp <- t(t(ptsi)+nb)
    ptsm <- t(t(ptsi)-nb)
    lm <- which((modg[ptsi] > modg[ptsp]) & (modg[ptsi] > modg[ptsm]))
    maxima <- rbind(maxima, ptsi[lm,])
  }

  # the thinned edges consist of the local maxima in the direction of gradient

  thin <- matrix(0, nr, nc)
  thin[maxima] <- modg[maxima]
  ec <- which(modg[maxima] >= quantile(modg[maxima], probs=qt))
  maxima <- maxima[ec,]
  dir_edges <- dirg[maxima]

  if (plots) {
    image(1:nr, 1:nc, thin, col=grey256, asp=1, xlab="X", ylab="Y", useRaster=TRUE)
    points(maxima[,1], maxima[,2], pch=20, col='green')
  }

  # Hough circle transform

  xc_min <- rmin
  xc_max <- nr-rmin
  yc_min <- rmin
  yc_max <- nc-rmin

  r_cand <- seq(rmin, rmax, by=rstep)
  xc_cand <- seq(xc_min, xc_max, by=rstep)
  yc_cand <- seq(yc_min, yc_max, by=rstep)
  rxy <- data.table(expand.grid(r_cand, xc_cand, yc_cand))
  rxy <- cbind(index=1:nrow(rxy), rxy)
  names(rxy) <- c("index", "r", "xc", "yc")
  dtheta <- seq(-dtheta_max, dtheta_max, by=dtheta_step)
  lt <- length(dtheta)
  acc <- numeric(nrow(rxy))

  for (i in 1:nrow(maxima)) {
    xc <- maxima[i,1] - as.vector(outer(r_cand, dir_edges[i]+dtheta, function(X,Y) X * cos(Y)))
    xc <- rstep * round(xc/rstep)
    yc <- maxima[i,2] - as.vector(outer(r_cand, dir_edges[i]+dtheta, function(X,Y) X * sin(Y)))
    yc <- rstep * round(yc/rstep)
    circles <- data.table(r=rep(r_cand, lt), xc=xc, yc=yc)
    matches <- dplyr::inner_join(rxy, circles, by=c("r", "xc", "yc"))
    acc[matches$index] = acc[matches$index] + 1
  }
  rxy_best <- rxy[which.max(acc),]
  cp <- list(xc = rxy_best$xc, yc=rxy_best$yc, rx=rxy_best$r, ry=rxy_best$r, obstruct=0)

  wtmean <- function(x, wt) sum(wt*x)/sum(wt)

  gets_vote <- as.vector(nabor::knn(rxy[,-1],rxy_best[,-1], k=nn)$nn.idx)
  rxy_alt <- list(r=wtmean(rxy$r[gets_vote],acc[gets_vote]), xc=wtmean(rxy$xc[gets_vote],acc[gets_vote]),
                  yc=wtmean(rxy$yc[gets_vote],acc[gets_vote]))

  if (plots) {
    points(rxy_best$xc, rxy_best$yc, col="red", pch=20)
    symbols(rxy_best$xc, rxy_best$yc, circles=rxy_best$r, inches=FALSE, add=TRUE, fg="red")
  }
  if (details) {
    list(cp=cp, thin=thin, maxima=maxima, dir_edges=dir_edges,
         rxy=rxy, acc=acc, rxy_best=rxy_best, rxy_alt=rxy_alt)
  } else {
    cp
  }
}


###################################
########## 군 집 분 석 ############
###################################
# install.packages("caret")
# install.packages("fastcluster")
library(caret)
library(fastcluster)

# 표준화
training_data <- scale(iris[ ,-5]) #Species 데이터 제거(숫자형변수x)
summary(training_data)

# 군집수 결정
## 패키지 사용 (최적의 combination을 통해 선택)
# install.packages("NbClust")
# library(NbClust)
#
# nc <- NbClust(training_data, min.nc=2, max.nc=15, method="kmeans")
# barplot(table(nc$Best.n[1,]),  xlab="Numer of Clusters", ylab="Number of Criteria", main="Number of Clusters Chosen")

## sum of squares 제일 작아 지는 지점 탐색
# wss <- NULL
# for(i in 1:7){
#   wss[i] = kmeans(training_data, centers=i)$tot.withinss
# }
# i=1:7
# plot(i,wss);lines(i,wss);

set.seed(100)
##### k-means (비계층적) 군집분석 ######
# 모델링 (군집개수-3개분류)
iris_kmeans <- kmeans(training_data, centers=3, iter.max=10000)
iris_kmeans$cluster <- as.factor(iris_kmeans$cluster) #Rownumber별 군집 매핑 값

table(iris_kmeans$cluster)
table(iris$Species, iris_kmeans$cluster) #virginica는 잘 분류해 내지만, 그 외는 변별력 약함.

plot(iris[c("Sepal.Length", "Sepal.Width")], col=iris_kmeans$cluster)

set.seed(0)
##### Hierarchical - hcluster (계층적) 군집분석 ######
# 모델링
hc <- hclust(dist(training_data), method="ave") #Row간 거리 계산

# plot(hc, hang=-1, labels=iris$Species)
# rect.hclust(hc, k=3)  #3개의 클러스터 표현

groups <- cutree(hc, k=3) #3개의 클러스터로 표현
table(groups)

table(iris$Species, groups) #setosa는 잘 분류해 내지만, 그 외는 변별력 약함.

###################################
########## D-TREE 분 석 ###########
###################################
# install.packages("party")
library(party)

set.seed(2)
# train / test 분할
ind <- sample(2, nrow(iris), replace=TRUE, prob=c(0.7,0.3))
trainData <- iris[ind==1, ]
testData <- iris[ind==2, ]

# 모델링
formula <- Species ~ Sepal.Length + Sepal.Width + Petal.Length + Petal.Width
iris_ctree <- ctree(formula, data=trainData)

plot(iris_ctree)

# test 예측
ctreepred <- predict(iris_ctree, newdata=testData)
table(testData$Species, ctreepred)

###################################
##### 로 지 스 틱 회 귀 분 석 #####
###################################
# install.packages("glm2")
library(glm2)

# target 변수 2개 범주로만 선택 (범주형변수로변환)
adj_iris <- iris
adj_iris$Species <- as.character(adj_iris$Species)
adj_iris <- subset(adj_iris, Species %in% c('versicolor', 'virginica'))
adj_iris$Species <- as.factor(adj_iris$Species)

set.seed(10)
# train / test 분할
ind <- sample(2, nrow(adj_iris), replace=TRUE, prob=c(0.7,0.3))
trainData <- adj_iris[ind==1, ]
testData <- adj_iris[ind==2, ]

# 모델링
formula <- Species ~ Sepal.Length + Sepal.Width + Petal.Length + Petal.Width
iris_logit <- glm(formula, data=trainData, family=binomial())
#일반선형모형(GLM)이 아닌 로지스틱 회귀를 실행하기 위해, R 프로그램에 family=binomial 이란 옵션을 설정해야 하는 것

# test 예측
#data.frame(adj_iris$Species, as.numeric(adj_iris$Species)-1) #versicolor=0, virginica=1

logitpred_a <- predict(iris_logit, newdata=testData, type="response")
logitpred <- ifelse(logitpred_a>=0.5, "virginica", "versicolor")

table(testData$Species , logitpred)

###################################
##### H2O Deeplearning 분 석 ######
###################################
# install.packages("h2o")
library(h2o)

h2o.init()

set.seed(4)
iris.hex <- as.h2o(iris)

# 모델링
iris_dl <- h2o.deeplearning(x = 1:4, y = 5, training_frame = iris.hex, activation = "Tanh", hidden = c(10, 10)) #x:인풋변수, y:타겟변수

# 예측
predictions <- h2o.predict(iris_dl, iris.hex)
predictions <- as.data.frame(predictions)

table(iris$Species, predictions$predict)

# ###################################
# ##### ANN (인공신경망) 분 석 ######
# ###################################
# # install.packages("nnet")
# library(nnet)
#
# set.seed(3)
# # train / test 분할
# ind <- sample(2, nrow(iris), replace=TRUE, prob=c(0.7,0.3))
# trainData <- iris[ind==1, ]
# testData <- iris[ind==2, ]
#
# # 모델링
# formula <- Species ~ Sepal.Length + Sepal.Width + Petal.Length + Petal.Width
# iris_nnet <- nnet(formula, data=trainData, size=3) #size : hidden layer
#
# # test 예측
# nnetpred <- predict(iris_nnet, newdata=testData, type="class")


## Created on Wednesday, October  6, 2021 at 9:52pm EDT by Weekend Editor on WeekendEditorMachine.
## Copyright (c) 2021, SomeWeekendReading.blog.  All rights reserved.  As if you care.

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

library("hypergeo")                                    # For hypergeo() and genhypergeo()

##
## Compare with the example Julian Saffer plots on his GitHub repository:
## https://github.com/jsaffer/beta_quotient_distribution
## - Numerator beta distribution: alpha1 = 3, beta1 = 6
## - Denominator beta distribution: alpha2 = 12, beta2 = 7
##
## This comparison is "naive" in the sense that I'm just using the hypergeo library functions
## without any caution for large values of the hypergeometric function's parameters.  E.g., for
## the Moderna/Pfizer COVID-19 vaccine clinical trials, those could be O(10k-20k).  We almost
## certainly need some recurrence relation or other to help out with that.
##
## But Saffer's example is doable with naive numerics.
##
## IWBNI we also did the Monte Carlo version for comparison: take pairs of random draws from the
## numerator and denominator distributions, calculate a ratio, and histogram the probability
## density of the ratio.  Compare with theoretical distribution by something like a
## Kolmogorov-Smirnov test?
##

doit <- function(alpha1 =  3, beta1 = 6,               # Numerator beta distribution
                 alpha2 = 12, beta2 = 7,               # Denominator beta distribution
                 nPoints  = 1000,                      # Number of points on each curve
                 xmax     = 2.0,                       # Limit on horizontal axis from Saffer
                 ymax     = 3.75,                      # Limit on vertical axis from Saffer
                 alpha    = 0.40,                      # Transparency level of fill colors (0 to 1)
                 cols     = c(numerator   = "blue",    # Colors for various curves
                              denominator = "orange",  #  and the fill for them inside
                              ratio       = "green",   #  their 90% credible intervals
                              ratioCDF    = "red"),    # Finally, destination for plot
                 plotFile = "2021-09-13-beta-ratios-naive-comparison-vs-saffer.png") {

  dBetaRatio <- function(alpha1, beta1, alpha2, beta2, R) {
    ## Beta ratio PDF
    ## NB: this WILL NOT WORK when alpha, beta ~ O(10^4), as for Pfizer & Moderna clinical trial!
    stopifnot(is.numeric(R) && R >= 0)                 # Don't be ridiculous
    if (R <= 1)                                        # Small values of R
      beta(alpha1 + alpha2, beta2) / (beta(alpha1, beta1) * beta(alpha2, beta2)) *
        R^(alpha1 - 1) *                               #
        hypergeo(alpha1 + alpha2, 1 - beta1, alpha1 + alpha2 + beta2, R)
    else                                               # Large values of R
      beta(alpha1 + alpha2, beta1) / (beta(alpha1, beta1) * beta(alpha2, beta2)) *
        R^(-(alpha2+1)) *                              #
        hypergeo(alpha1 + alpha2, 1 - beta2, alpha1 + alpha2 + beta1, 1 / R)
  }                                                    #

  pBetaRatio <- function(alpha1, beta1, alpha2, beta2, R) {
    ## Beta ratio CDF
    ## NB: this WILL NOT WORK when alpha, beta ~ O(10^4), as for Pfizer & Moderna clinical trial!
    stopifnot(is.numeric(R) && R >= 0)                 # Don't be ridiculous
    if (R <= 1)                                        # Small values of R
      beta(alpha1 + alpha2, beta2) / (beta(alpha1, beta1) * beta(alpha2, beta2)) *
        R^alpha1 / alpha1 *                            #
        genhypergeo(c(alpha1, alpha1 + alpha2, 1 - beta1), c(alpha1 + 1, alpha1 + alpha2 + beta2),
                    R)                                 #
    else                                               # Large values of R
     1 - beta(alpha1 + alpha2, beta1) / (beta(alpha1, beta1) * beta(alpha2, beta2)) *
       1 / (alpha2 * R^alpha2) *                       #
       genhypergeo(c(alpha2, alpha1 + alpha2, 1 - beta2), c(alpha2 + 1, alpha1 + alpha2 + beta1),
                   1 / R)                              #
  }                                                    #

  qBetaRatio <- function(alpha1, beta1, alpha2, beta2, q, minR = 0, maxR = 10) {
    ## Beta ratio quantile (numeric solution via CDF)
    ## NB: this WILL NOT WORK when alpha, beta ~ O(10^4), as for Pfizer & Moderna clinical trial!
    stopifnot(is.numeric(q) && is.numeric(minR) && is.numeric(maxR))
    stopifnot(0 <= q && q <= 1.0)                      # Don't be ridiculous
    stopifnot(0 <= minR && 0 <= maxR && minR < maxR)   # Really: don't be ridiculous
    uniroot(function(R) {q - pBetaRatio(alpha1, beta1, alpha2, beta2, R)}, c(minR, maxR))$"root"
  }                                                    #

  medianBetaRatio <- function(alpha1, beta1, alpha2, beta2, minR = 0, maxR = 10) {
    ## NB: this WILL NOT WORK when alpha, beta ~ O(10^4), as for Pfizer & Moderna clinical trial!
    qBetaRatio(alpha1, beta1, alpha2, beta2, 0.50, minR, maxR)
  }                                                    # Analytic version uses incomplete Beta func

  meanBetaRatio <- function(alpha1, beta1, alpha2, beta2) {
    alpha1 * (alpha2 + beta2 - 1) / ((alpha1 + beta1) * (alpha2 - 1))
  }                                                    # Mean has simple closed form

  meanBeta <- function(alpha, beta) { alpha / (alpha + beta) }

  colorCI <- function(col, alpha, xvals, yvals, x05, x95) {
    col <- col2rgb(col)                                # Base color to make transparent
    col <- rgb(col[[1]], col[[2]], col[[3]], max = 255, alpha = alpha * 255)
    foo <- subset(data.frame(x = xvals, pdf = yvals), subset = x05 <= x & x <= x95)
    polygon(x = c(rev(foo$"x"),                   foo$"x"),
            y = c(rep(0, length.out = nrow(foo)), foo$"pdf"),
            border = NA, col = col)                    # Filled in 90% credible interval
  }                                                    #

  ## Values where we numerically evaluate the distributions
  xvals    <- seq(from = 0, to = xmax, length.out = nPoints)

  ## Numerator beta distribution
  numPDF   <- dbeta(x = xvals, shape1 = alpha1, shape2 = beta1)
  numMean  <- meanBeta(alpha1, beta1)                  # Mean of numerator beta distribution
  num05    <- qbeta(p = 0.05, shape1 = alpha1, shape2 = beta1)
  num95    <- qbeta(p = 0.95, shape1 = alpha1, shape2 = beta1)

  ## Denominator bea distribution
  denomPDF  <- dbeta(x = xvals, shape1 = alpha2, shape2 = beta2)
  denomMean <- meanBeta(alpha2, beta2)                 # Mean of denominator beta distribution
  denom05   <- qbeta(p = 0.05, shape1 = alpha2, shape2 = beta2)
  denom95   <- qbeta(p = 0.95, shape1 = alpha2, shape2 = beta2)

  ## Ratiodistribution
  ratioPDF  <- sapply(xvals, function(R) { dBetaRatio(alpha1, beta1, alpha2, beta2, R) })
  ratioCDF  <- sapply(xvals, function(R) { pBetaRatio(alpha1, beta1, alpha2, beta2, R) })
  ratioMean <- meanBetaRatio(alpha1, beta1, alpha2, beta2)
  ratio05   <- qBetaRatio(alpha1, beta1, alpha2, beta2, 0.05)
  ratio95   <- qBetaRatio(alpha1, beta1, alpha2, beta2, 0.95)

  ## Saffer: 1152 x 648 --> us: 400 x 225
  withPNG(file.path(".", plotFile), 400, 225, FALSE, function() {
    withPars(function() {                              # Save/restore graphics parameters

      matplot(x    = xvals,                            # Plot PDFs and ratio CDF
              y    = matrix(data = c(numPDF, denomPDF, ratioPDF, ratioCDF), nrow = nPoints),
              lty  = c("solid", "solid", "solid", "dotted"),
              col  = c(cols[["numerator"]], cols[["denominator"]],
                       cols[["ratio"]],     cols[["ratioCDF"]]),
              type = "l", lwd = 2,                     #
              xlim = c(0, xmax), ylim = c(0, ymax),    #
              xlab = "X", ylab = "Pr(X) or Pr(> X)",   #
              main = "Saffer's Example Beta Ratio")    #

      colorCI(cols[["numerator"]],   alpha, xvals, numPDF,   num05,   num95)
      colorCI(cols[["denominator"]], alpha, xvals, denomPDF, denom05, denom95)
      colorCI(cols[["ratio"]],       alpha, xvals, ratioPDF, ratio05, ratio95)

      abline(v   = c(numMean, denomMean, ratioMean),   # Vertical dashed lines at means
             col = c(cols[["numerator"]], cols[["denominator"]], cols[["ratio"]]),
             lty = "dashed", lwd = 2)                  #

      ## Grid lines
      abline(h = seq(from = 0, to = 3.5, by = 0.5), col = "gray")
      abline(v = seq(from = 0, to = 2.0, by = 0.5), col = "gray")

    }, pty = "m",                                      # Maximal plotting area
       bg  = "white",                                  # White background
       mar = c(3, 3, 2, 1),                            # Pull in on margins a bit
       mgp = c(1.7, 0.5, 0),                           # Axis title, labels, ticks
       las = 1,                                        # Always horizontal axis labels
       ps  = 16)                                       # Larger type size for file capture
  })                                                   #

  invisible(NA)                                        # Return nothing of interest, invisibly
}                                                      #


##################################### FUNCOES PARA INTERPOLACAO ####################################

#' Modelo Para Interpolacao De Curva Colina
#'
#' Funcao para estimacao de diferentes interpoladores de curva colina
#'
#' \code{interpolador} serve como uma interface comum para estimacao de diversas formas atraves das
#' quais interpolar a colina original. Atualmente ha tres abordagens implementadas:
#'
#' \itemize{
#' \item{\code{\link{triangulacao}}}
#' \item{\code{\link{thinplate}}}
#' \item{\code{\link{tensorprod}}}
#' }
#'
#' Se \code{metodo = "triangulacao"}, a colina fornecida e projetada no plano hl x pot e entao
#' tesselada atraves da triangulacao de Delaunay. Interpolacao de um ponto em objetos de
#' triangulacao se da atraves de transformacao para coordenadas baricentricas e subsequente media
#' ponderada dos rendimentos nos vertices do triangulo que o contem.
#'
#' Quando \code{metodo = "thinplate"} ou \code{metodo = "tensorprod"}, a colina e suavizada atraves
#' de splines, cujo tipo depende do \code{metodo} passado: \code{"thinplate"} corresponde a
#' suavizacao por splines homonimas e \code{"tensorprod"} ao produto tensor de splines. A
#' interpolacao nesse caso consiste simplesmente da consulta a curva suavizada em pontos
#' selecionados.
#'
#' O argumento \code{...} permite passar os argumentos opcionais aos metodos especificos. As paginas
#' de ajuda dos interpoladores proveem mais informacao a respeito destes argumentos extras.
#'
#' \bold{Interpoladores Multiplos}:
#'
#' Existe a possibilidade de estimar um interpolador combinando mais de um metodo. Isto pode ser
#' feito passando um vetor de duas posicoes em \code{metodo} indicando os dois metodos a serem
#' usados conjuntamente com o argumento \code{quebra}, um numero indicando o rendimento da curva
#' a partir da qual o segundo metodo deve ser utilizado.
#'
#' Nestes casos, o objeto retornado tera classe \code{"interpolador"} e subclasse
#' \code{"interpoladorM"}, com todos os mesmos metodos disponivies.
#'
#' @param colina objeto da classe \code{curvacolina} (retornado pelas funcoes de leitura)
#' @param metodo um ou dois de \code{c("triangulacao", "thinplate", "tensorpro")}. Ver Detalhes
#' @param quebra opcional, numerico indicando o rendimento da curva a partir da qual chavear
#'     metodos. Ver Detalhes
#' @param ... demais parametros que possam ser passados as funcoes de ajuste de cada \code{metodo}.
#'     Ver Detalhes
#'
#' @examples
#'
#' # usando dado dummy contido no pacote
#' interp_tri <- interpolador(colinadummy, "triangulacao")
#'
#' # interpolando uma grade 20x20 no dominio da colina
#' pontos <- coordgrade(colinadummy, 20, 20)
#' grade <- predict(interp_tri, pontos)
#'
#' \dontrun{
#' # visualizacao 3d e 2d do resultado
#' plot(grade)
#' plot(grade, "2d")
#' }
#'
#' # INTERPOLADOR MULTIPLO
#' interp_mult <- interpolador(colinadummy[rend > 92], c("thinplate", "triangulacao"), 95.5)
#'
#' # interpolando uma grade 20x20 no dominio da colina
#' pontos <- coordgrade(colinadummy, 20, 20)
#' grade <- predict(interp_mult, pontos)
#'
#' \dontrun{
#' # visualizacao 3d e 2d do resultado
#' plot(grade)
#' plot(grade, "2d")
#' }
#'
#' @return objeto da classe \code{interpolador} e subclasse \code{metodo}, isto e, um modelo com o
#'     qual se realizar previsoes e, assim, interpolar o dado original
#'
#' @family interpolador
#'
#' @export

interpolador <- function(colina, metodo, quebra, ...) {

    rend <- NULL

    if(missing(quebra)) {
        interp_func <- match.call()
        interp_func[[1]] <- as.name(metodo)
        interp_func$metodo <- NULL

        interp <- eval(interp_func, envir = parent.frame())

        return(interp)
    } else {

        if(length(metodo) != 2) stop("Quando 'quebra' e fornecido, 'metodos' deve ter tamanho 2")

        colinas <- list(colina[rend <= quebra], colina[rend >= quebra])

        interp_func <- match.call()
        interp <- mapply(metodo, colinas, FUN = function(m, c) {
            interp_func[[1]] <- as.name(m)
            interp_func$colina <- c
            interp_func$metodo <- NULL

            eval(interp_func, envir = parent.frame())
        }, SIMPLIFY = FALSE)

        new_interpoladorM(interp, quebra)
    }
}

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

#' @rdname getcolina

getcolina.interpolador <- function(object) stop(paste0("Implemente metodo 'getcolina' do modelo: ", class(object)[1]))

#' Previsao Com Modelos Interpoladores
#'
#' Metodo para interpolar curva colina a partir de um objeto gerado por \code{interpolador}
#'
#' O argumento \code{as.gradecolina} permite alterar a saida da interpolacao. Se
#' \code{as.gradecolina = FALSE}, o padrao, apenas o vetor de rendimentos interpolados sera
#' retornado. Caso \code{as.gradecolina = TRUE}, a saida sera um objeto \code{\link{gradecolina}}.
#'
#' @param object objeto da classe \code{interpolador} retornado pela funcao homonima
#' @param pontos data.frame ou matriz contendo pontos nos quais amostrar o rendimento
#' @param as.gradecolina booleano indicando o nivel de detalhe na saida da funcao. Ver Detalhes
#' @param ... demais parametros que possam ser passados aos metodos de \code{predict} especificos
#'
#' @return vetor de rendimentos nas coordenadas especificadas em \code{pontos}
#'
#' @family interpolador
#'
#' @export

predict.interpolador <- function(object, pontos, as.gradecolina, ...) {
    stop(paste0("Implemente metodo 'predict' do modelo: ", class(object)[1]))
}


############################################################
# For owl monkey project, last revised 04.18
# Plots and statistical tests for Figure 1 and Figure S2
# in owl monkey paper.
#
# Gregg Thomas
############################################################

library(ggplot2)
this.dir <- dirname(parent.frame(2)$ofile)
setwd(this.dir)
cat("----------\n")

figs2_opt = T
# CHANGE TO TRUE TO GENERATE FIG. S2

####################
## Estimating model parameters using Kong (2012) data
human_dm0 = 34; human_df = 31; human_num_f = 14.2; human_haploid = 2630000000; human_diploid = human_haploid * 2;
# Parameters observed from Drost & Lee (1995) and Kong (2012)

human_mu_c = (human_num_f / human_df)
cat("mu_c estimated from Kong params: ", human_mu_c, "\n")
human_mu_c = human_mu_c / human_haploid
cat("mu_c per site estimated from Kong params: ", human_mu_c, "\n")
# Estimating mu_c

# Calculate spermatogenic proportion and expected number of spermatogenic divisions
# per year using human (Kong) observations.
human_sc = 16
human_dy1 = ((2.01 / human_haploid) / human_mu_c)
human_sp = human_dy1 / (365/16)
cat("Human expected # of spermatogenic cycles/year: ", human_dy1, "\n")
cat("Human spermatogenic cell proportion given a cycle length of 16 days: ", human_sp, "\n")
cat("----------\n")
# Estimating the expected number of spermatogenic cycles per year

# 2.01 is the slope of the Kong line -- mutations per year in males after puberty.
# We can calculate the expected number of spermatogenic cycles per year (human_dy1) based on mu_c.
# Then, we can estimate the proportion of cells undergoing spermatogenesis at any given time (human_sp)
####################

####################
## Owl monkey prediction (purple dashed) using Kong parameters
om_puberty = 1; om_sc = 10.2;
om_dy1 = (365/om_sc) * human_sp
cat("Owl monkey expected # of spermatogenic cycles/year: ", om_dy1, "\n")
# Estimate the expected number of spermatogenic cycles per year in owl monkeys using the human proportion
# of cells actively dividing (human_sp).

age_range = seq(om_puberty, 15, by=0.1)
rep_long = age_range - om_puberty
# The owl monkey age of puberty set at 1 year and a range of paternal ages

om_mu_g = ((human_df * human_mu_c) + ((human_dm0 * human_mu_c) + (om_dy1 * rep_long * human_mu_c))) / 2
# Calculating the mutation rate (Equation 9 in paper)

om_pred = data.frame(om_mu_g, age_range)
names(om_pred) = c("Mutation.rate", "Parental.age")
om_pred_reg = lm(om_mu_g ~ age_range)
cat("----------\n")
####################

####################
## Owl monkey observed data (purple solid)
in_data = read.csv("data/owl-monkey-filters.csv", header=TRUE)

if(figs2_opt) {
  cur_filter = subset(in_data, Min.DP==20 & Max.DP==60 & Min.AB==0.3 & Max.AB==0.7)
}else{
  cur_filter = subset(in_data, Min.DP==20 & Max.DP==60 & Min.AB==0.4 & Max.AB==0.6)
}
om_obs = cur_filter$MVs.corrected.for.FN
om_gt = cur_filter$Paternal.GT
om_callable = (cur_filter$Sites - cur_filter$Uncallable.SNP.sites) * 2
om_mu = om_obs / om_callable
cur_filter$CpG.rate = cur_filter$CpG.MVs / om_callable
om_obs_reg = lm(om_mu ~ om_gt)
# Read data and define current filter

cat("PREDICTED SLOPE (d_ym1)\n")
cat(coef(om_pred_reg)[2], " mutations per site per year\n")
cat(coef(om_pred_reg)[2] * human_haploid * 2, " mutations per year\n")
cat("OBSERVED SLOPE (dy_m1)\n")
cat(coef(om_obs_reg)[2], " mutations per site per year\n")
cat(coef(om_obs_reg)[2] * (mean(om_callable)), " mutations per year\n")
cat("----------\n")
# Predicted vs observed slopes (d_ym1)
####################

####################
## The plot for Fig. 1
fig1 = ggplot(cur_filter, aes(x=Paternal.GT, y=Mutation.rate.corrected.for.FN)) +
  geom_smooth(method='glm', color='#b66dff', fill="#f2e6ff", fullrange=T) +
  geom_point(color='#b66dff', size=3) +
  geom_smooth(aes(x=Paternal.GT, y=CpG.rate), method='glm', color="#6db6ff", fill=NA, fullrange=T) +
  geom_point(aes(x=Paternal.GT, y=CpG.rate), color="#6db6ff", size=3) +
  scale_x_continuous(breaks = seq(1, 60, by=2)) +
  scale_y_continuous(breaks = seq(0, 1.8e-8, by=0.4e-8)) +
  geom_line(data=om_pred, aes(x=Parental.age, y=Mutation.rate), linetype=2, size=0.75, color="purple") +
  geom_vline(xintercept=1, linetype=3, color="grey", size=0.75) +
  labs(x="Age of father at conception (y)",y="Mutation rate per site\nper generation") +
  theme_classic() +
  theme(axis.text=element_text(size=14),
        axis.title=element_text(size=20),
        axis.title.y=element_text(margin=margin(t=0,r=20,b=0,l=0),color="black"),
        axis.title.x=element_text(margin=margin(t=20,r=0,b=0,l=0),color="black"),
        axis.line=element_line(colour='#595959',size=0.75),
        axis.ticks=element_line(colour="#595959",size = 1),
        axis.ticks.length=unit(0.2,"cm")
        )
print(fig1)
if(figs2_opt) {
  ggsave(filename="figS1C.pdf", fig1, width=6, height=5, units="in")
}else{
  ggsave(filename="fig1.pdf", fig1, width=6, height=5, units="in")
}
cat("--Regression summary for observed points--\n")
print(summary(om_obs_reg))
cat("----------\n")
####################

####################
## The F test for Fig. 1
pred_actual = coef(om_pred_reg)[1] + om_gt * coef(om_pred_reg)[2]
pred_resids = om_mu - pred_actual
#plot(age_range,om_mu_g, type='l',ylim=c(min(om_mu),max(om_mu)))
#points(om_gt, om_mu)
#segments(x0=om_gt,y0=om_mu,x1=om_gt,y1=om_mu-pred_resids)
#abline(om_obs_reg, lty=2)
#segments(x0=om_gt,y0=om_mu,x1=om_gt,y1=om_mu-resid(om_obs_reg),lty=2)
cat("--F test for differences between residuals of the predicted and observed lines--")
print(var.test(resid(om_obs_reg), pred_resids, alternative="two.sided"))
cat("----------\n")
####################
stop()
####################
## Paternal (orange) vs. Maternal (teal) mutations
pat_df = data.frame(cur_filter$Paternal.MVs[cur_filter$Paternal.MVs!=0], cur_filter$Paternal.GT[cur_filter$Paternal.MVs!=0])
names(pat_df) = c("Paternal.MVs", "Paternal.GT")
mat_df = data.frame(cur_filter$Maternal.MVs[cur_filter$Maternal.MVs!=0], cur_filter$Maternal.GT[cur_filter$Maternal.MVs!=0])
names(mat_df) = c("Maternal.MVs", "Maternal.GT")

p = ggplot(pat_df, aes(x=Paternal.GT, y=Paternal.MVs)) +
  geom_smooth(method='glm', color='#db6d00', fill='#ffe6cc', fullrange=T) +
  geom_point(color='#db6d00', size=3) +
  geom_vline(xintercept=1, linetype=3, color="grey", size=0.75) +
  geom_smooth(data=mat_df, aes(x=Maternal.GT, y=Maternal.MVs), method='glm', color='#009292', fill='#ccffff', fullrange=T) +
  geom_point(data=mat_df, aes(x=Maternal.GT, y=Maternal.MVs), color='#009292', size=3) +
  #scale_y_continuous(limits=c(0,16)) +
  labs(x="Age of parent at conception (y)",y="Mutation rate per site") +
  theme_classic() +
  theme(axis.text=element_text(size=14),
        axis.title=element_text(size=20),
        axis.title.y=element_text(margin=margin(t=0,r=20,b=0,l=0),color="black"),
        axis.title.x=element_text(margin=margin(t=20,r=0,b=0,l=0),color="black"),
        axis.line=element_line(colour='#595959',size=0.75),
        axis.ticks=element_line(colour="#595959",size = 1),
        axis.ticks.length=unit(0.2,"cm")
  )
#print(p)
pat_reg = lm(pat_df$Paternal.MVs ~ pat_df$Paternal.GT)
cat("--Regression summary for paternal mutations--\n")
print(summary(pat_reg))
cat("--Regression summary for maternal mutations--\n")
mat_reg = lm(mat_df$Maternal.MVs ~ mat_df$Maternal.GT)
print(summary(mat_reg))
####################


#' Mixing Layer Depth
#'
#' Identification of the mixing layer depth (e.g. thermocline, pycnocline)
#'   using a modified version of the Maximum Angle Method.
#'
#' @param z Vector of depths, or 2-column dataframe containing depths in first
#'   column and variable of interest (e.g. temperature, salinity) in second
#'   column.
#' @param x Vector containing variable of interest (e.g. temperature, salinity)
#'   of same length as \code{z}.
#' @param np Number of points to use in linear regressions (see 'details').
#' @param min.range The minimum range in the value of \code{x} in order
#'   for a mixing layer to be detectable.
#' @param max.z Maximum value of \code{z} to use when searching for mixing
#'   layer depth.
#' @param return.index If TRUE, return the index of \code{z} corresponding to
#'   the mixing layer depth. Otherwise, return the depth.
#' @return either the mixing layer depth or the element index of z associated
#'   with said depth, depending on the value of \code{return.type}.
#'
#' @details The Maximum Angle Method is modified to better handle the
#'   identification of the mixing layer depth when the surface layer is
#'   poorly-mixed and to provide some flexibility in the linear regression, but
#'   may be less stable as a result. The modifications force the dual linear
#'   regressions to share the last/first data point and allow the user to
#'   specify the number of points used in the regressions.
#'
#' @references Chu, Peter C., and Chenwu Fan. "Maximum angle method for
#'   determining mixed layer depth from seaglider data." Journal of
#'   oceanography 67.2 (2011): 219-230.
#'
#' @examples
#' data(ctd)
#' zt = subset(ctd, date == date[1] & dist == dist[1])[c("depth", "ta")]
#' mld(zt)
#' mld(zt, return.index = TRUE)
#'
#' #' @seealso \code{\link{blt}}
#' @export
mld = function(z, x = NULL, np = 2, min.range = 0, max.z = NULL,
  return.index = FALSE){
  if(is.null(x)){
    x = z[, 2]
    z = z[, 1]
  }
  if(!is.null(max.z)){
    x = x[z <= max.z]
    z = z[z <= max.z]
  }
  if(np > floor(0.5*length(z)))
      stop("Argument 'np' is too large.")
  minx = min(x)
  maxx = max(x)
  rangex = maxx - minx
  # return NA if range of variable is too small
  if(rangex < min.range)
    return(NA)
  minz = z[min(which(x == min(x)))]
  maxz = z[max(which(x == max(x)))]
  rangez = maxz - minz
  if(minz != min(z) | maxz != max(z))
    warning("Data is noisy")
  m = np - 1
  j = np - 1
  K = length(z)
  tantheta = 0
  clinek = 1
  for(k in seq(j + 1, K - m)){
#   Gtop = lm(x ~ z, data.frame(z = z[seq(k - j, k)],
#     x = x[seq(k - j, k)]))$coefficients[[2]]
#   Gbot = lm(x ~ z, data.frame(z = z[seq(k, k + m)],
#     x = x[seq(k, k + m)]))$coefficients[[2]]
    # slope of line z ~ x is defined as cor(x, z)*sd(x)/sd(z)
    topmask = seq(k - j, k)
    botmask = seq(k, k + m)
    Gtop = cor(z[topmask], x[topmask])*sd(x[topmask])/sd(z[topmask])
    Gbot = cor(z[botmask], x[botmask])*sd(x[botmask])/sd(z[botmask])
    newtantheta = abs((Gbot - Gtop)/(1 + Gbot*Gtop))
    if(!is.na(newtantheta) & newtantheta > tantheta){
      clinek = k
      tantheta = newtantheta
    }
  }
  if(return.index)
    clinek
  else
    z[clinek]
}

#' Barrier Layer Thickness
#'
#' Calculate the thickness of the barrier layer.
#'
#' @param z Vector of depths, or 3-column dataframe containing depths in first
#'   column, temperatures in the second column and salinities in the third
#'   column.
#' @param t Vector of temperatures of same length as \code{z}.
#' @param s Vector of salinities of same length as \code{z}.
#' @param ... Other arguments passed to \code{mld}. Note that
#'   \code{return.index = FALSE} is fixed.
#' @return The thickness of the barrier layer.
##'
#' @details The 'Barrier Layer' is the region between the pycnocline and
#'   thermocline. This function identifies the thermocline and pycnocline
#'   depths using \code{mld} and calculates the thickness of the barrier as the
#'   difference the two depths.
#'
#' @references Chu, Peter C., and Chenwu Fan. "Maximum angle method for
#'   determining mixed layer depth from seaglider data." Journal of
#'   oceanography 67.2 (2011): 219-230.
#'
#' @seealso \code{\link{mld}}
#' @export
blt = function(z, t, s, ...){
  if(is.missing(t) | is.missing(s)){
    s = z[, 3]
    t = z[, 2]
    z = z[,1]
  }
  thermocline = mld(z, t, return.index = FALSE, ...)
  pycnocline = mld(z, s, return.index = FALSE, ...)
  abs(thermocline - pycnocline)
}

#' Stratify by a Variable
#'
#' Stratify data into zones using specified midpoints.
#'
#' @param x Vector of values.
#' @param midpoints Vector of midpoints or cut points to stratify \code{x} by.
#'   \code{min(x)} and \code{max(x)} are automatically included.
#' @param ... Other arguments to pass to \code{cut()}.
#'
#' @details This function is basically a wrapper for \code{cut()}, but requires
#'   the cuts be directly specified and that \code{include.lowest = TRUE}.
#'   Every element of \code{x} is therefore guaranteed to be included in one
#'   interval.
stratify = function(x, midpoints, ...){
  minx = min(x)
  maxx = max(x)
  if(any(midpoints >= maxx) | any(midpoints <= minx))
    stop("Midpoints must be within range (min(x), max(x))")
  cut(x, unique(c(minx, sort(midpoints), maxx)), include.lowest = TRUE, ...)
}


iterate.until.escape <- function(z, c, trans, cond, max=50, response=dwell) {
  #we iterate all active points in the same array operation,
  #and keeping track of which points are still iterating.
  active <- seq_along(z)
  dwell <- z
  dwell[] <- 0
  for (i in 1:max) {
    z[active] <- trans(z[active], c[active]);
    survived <- cond(z[active])
    dwell[active[!survived]] <- i
    active <- active[survived]
    if (length(active) == 0) break
  }
  eval(substitute(response))
}

re = seq(-2, 1, len=500)
im = seq(-1.5, 1.5, len=500)
c <- outer(re, im, function(x,y) complex(real=x, imaginary=y))
x <- iterate.until.escape(array(0, dim(c)), c,
                          function(z,c)z^2+c, function(z)abs(z) <= 2,
                          max=100)
image(x)


# V and beta supplied via graph.py script

V <- structure(c(3.19826308e-06, -1.28332733e-02,  1.28734322e+01, -1.28332733e-02,  5.14946331e+01, -5.16559253e+04, 1.28734322e+01, -5.16559253e+04,  5.18178740e+07
), .Dim = c(3L, 3L), .Dimnames = list(c("a0", "a1", "a2"), c("a0",
"a1", "a2")))

beta <- c(1.93057366e+05, -1.95738445e+02,  4.96009134e-02)
x <- seq(1993, 2100, by = 1)
X <- cbind(1, x, x ^ 2)
mu <- X %*% beta
# e <- sqrt( rowSums(X * (X %*% V)) )
# n <- 978
# lo <- mu + e * qt(0.025, n - 3)
# up <- mu - e * qt(0.025, n - 3)
# print(qnorm(.99999))

# e <-  1.644*(mu/sqrt(978))
# e <- qnorm(.95) *(mu/sqrt(978))
e <- 10 *(mu/sqrt(978))

lo <- mu + e
up <- mu - e

print(e)
print(n - 3)
print(mu)
print(lo)
print(up)
matplot(x, cbind(mu, lo, up), type = "l", col = 1, lty = c(1,2,2))
# matplot(x, cbind(mu), type = "l", col = 1, lty = c(1,2,2))


addfit <- function(xx, yy, col='black', interval='conf', alpha=0.05, sided=2, pch=1, vlines=NULL) {
    ## plot points
    points(xx, yy, pch=pch, col=col)

    ## put points in dataframe and remove any pairs that do not have values
    df <- na.omit( data.frame(xx,yy) )

    ## write points back out to xx and yy
    xx <- df$xx
    yy <- df$yy

    ## perform fit
    fit <- lm(yy~xx)
    intercept <- fit$coefficients[[1]]
    slope     <- fit$coefficients[[2]]

    ## add vertical lines to plot
    if ( !is.null(vlines[1]) & !is.na(vlines[1]) ) abline(v=vlines, lty=3, col=col)

    ## add prediction to plot
    if ( !is.null(vlines[1]) & !is.na(vlines[1]) ) {
        ## restrict fit to within vlines
        new.xx <- seq(min(vlines, na.rm=TRUE), max(vlines, na.rm=TRUE), len=100)
    } else {
        ## extend data to range of data
        new.xx <- seq(min(xx, na.rm=TRUE), max(xx, na.rm=TRUE), len=100)
    }
    if (interval == 'mean') {
        lines(new.xx, slope * new.xx + intercept, lwd=2, col=col)
    } else if (interval == 'line') {
        newdf <- data.frame(xx,yy)
        newdf <- newdf[order(newdf$xx),]
        xx <- newdf$xx
        yy <- newdf$yy
        lines(xx, yy, lwd=2, col=col)
    } else {
        pred   <- predict(fit, new=data.frame(xx=new.xx), interval=interval, level=1-alpha/sided)
        lines(new.xx, pred[,"fit"], lwd=2, col=col)
        lines(new.xx, pred[,"lwr"], lty=3, col=col)
        lines(new.xx, pred[,"upr"], lty=3, col=col)
    }

    ## print results of fit
    ## estbound(fit)

    ## calculate rise of fit over range bounds if supplied,
    ## otherwise calculate rise over range of data
    if ( !is.null(vlines[1]) & !is.na(vlines[1]) ) {
        rise <- (vlines[2] - vlines[1]) * slope
    } else {
        rise <- (max(xx) - min(xx)) * slope
    }
    equation = paste0("y = ", signif(intercept,4), " + ", signif(slope,4), " * x; ",
                      expression(Delta), " = ", signif(rise,4))
    return(list(equation=equation, slope=slope, intercept=intercept, rise=rise))

}


#ANALIZA

#MODEL LOESS ZA NAPOVED EARNINGOV

morningstar_izbran<- filter(morningstar,Podatki=="Earnings Per Share USD")%>%
  select(Leto,Vrednost)
model_earning <-loess(dat=morningstar_izbran,
                      Vrednost~Leto,control=loess.control(surface="direct"))

loe_ear <- function(zeljena_leta){
  prihodnost_dobicek_na_delnico <- data.frame(Leto=c(zeljena_leta))
  napoved_dobicek_na_delnico <- prihodnost_dobicek_na_delnico %>%
    mutate(Vrednost=predict(model_earning,.))

  dobicek_na_delnico_graf <- ggplot(data=morningstar_izbran,
                                    aes(x=Leto,y=Vrednost,color="Dobiček na delnico"))+
    geom_smooth(method = "loess",formula = y~x,se=F) +
    geom_point(aes(color="Točne vrdednosti"))+
    geom_point(data=napoved_dobicek_na_delnico,
               aes(x=Leto,y=Vrednost,color="Napoved dobička za naprej"),size=3)+
    scale_colour_manual(name="LEGENDA",values=c("red","green","black"))+
    labs(title="Graf dobička na delnico po metodi loess")+
    scale_x_continuous(name = "Leto", breaks = seq(2011,2025,1))+
    scale_y_continuous(name = "Dobiček na delnico (USD)", breaks = seq(0,5,0.2))+
    theme(legend.position = c(0.3, 0.8),
          panel.grid.minor = element_blank(),
          plot.title = element_text(hjust = 0.5))
  return(dobicek_na_delnico_graf)}

#MODEL NAPOVEDI EARNINGOV REGRESIJA

model_dobicek <- lm(data=morningstar_izbran,Vrednost ~ Leto) #ce klices ta model na fukcijo reg_pov ali opt_pov moras leta vnesti kot data frame

reg_ear<- function(zeljena_leta){
  prihodnost_dobicek <- data.frame(Leto=c(zeljena_leta))
  napoved_dobicek <- prihodnost_dobicek%>%
    mutate(Vrednost=predict(model_dobicek, .))

  premica_dobicek<-ggplot(morningstar_izbran,aes(x=Leto,y=Vrednost,
                                          color="Dobiček na delnico"))+
    geom_point(aes(color="Točne vrdednosti"))+
    geom_smooth(method = lm,formula = y~x,se=F,fullrange=TRUE)+
    geom_point(data = napoved_dobicek,aes(x=Leto,y=Vrednost,
                                          color="Napoved dobička za naprej"),size=3)+
    scale_colour_manual(name="LEGENDA",values=c("red","green","black"))+
    labs(title="Graf dobička na delnico s pomočjo linearne regresije")+
    scale_x_continuous(name = "Leto", breaks = seq(2011,2025,1))+
    scale_y_continuous(name = "Dobiček na delnico (USD)", breaks = seq(0,5,0.2))+
    theme(legend.position = c(0.3, 0.8),
          panel.grid.minor = element_blank(),
          plot.title = element_text(hjust = 0.5))
  return(premica_dobicek)}

#REGRESIJA ZA POVEZAVO MED EARNINGI IN CENO

yah.mor <- right_join(morningstar_izbran,yahoo)
reg_pov <- function(prihodnost_dobicek_na_delnico,vrsta_modela){
  model_odvisnost1 <- lm(data=yah.mor,Najvisja_cena~Vrednost)
  prihodnost_povezava1 <- data.frame(Vrednost=c(predict(vrsta_modela,prihodnost_dobicek_na_delnico)))
  napoved_povezava1 <- prihodnost_povezava1%>%
    mutate(Najvisja_cena=predict(model_odvisnost1, .))

  premica_odvisnost<-ggplot(yah.mor,aes(x=Vrednost,y=Najvisja_cena,
                                        color="Približek za naše podatke"))+
    geom_point(aes(color="Točne vrednosti"))+
    geom_smooth(method = lm,formula = y~x,se=F,fullrange=TRUE)+
    geom_point(data = napoved_povezava1,
               aes(x=Vrednost,y=Najvisja_cena,
                   color="Napoved cene preko dobička"),size=3)+
    scale_colour_manual(name="LEGENDA",values=c("green","red","black"))+
    labs(title="Napoved cene preko dobička s pomočjo linearne regresije")+
    scale_x_continuous(name = "Dobiček na delnico (USD)", breaks = seq(0,5,0.2))+
    scale_y_continuous(name = "Cena (USD)", breaks = seq(0,140,10))+
    theme(legend.position = c(0.3, 0.8),
          panel.grid.minor = element_blank(),
          plot.title = element_text(hjust = 0.5))
  return(premica_odvisnost)}

#SKUPINE

cena.earning <- select(yah.mor,Vrednost,Najvisja_cena)
standardizacija <-as.matrix(cena.earning)%>%scale()
D <- dist(standardizacija)
model22 <- hclust(D)
cena.earning<-mutate(cena.earning,skupina=cutree(model22,k=2))

#OPT

opt_pov <- function(prihodnost_dobicek_na_delnico,vrsta_modela){
  model_opt <- lm(data=filter(cena.earning,skupina==1),
                  Najvisja_cena~Vrednost)
  prihodnost_opt <- data.frame(Vrednost=c(predict(vrsta_modela,prihodnost_dobicek_na_delnico)))
  napoved_opt<- prihodnost_opt%>%mutate(Najvisja_cena=predict(model_opt,.))

  premica_odvisnost_opt <- ggplot(filter(cena.earning,skupina==1),
                                  aes(x=Vrednost,y=Najvisja_cena,
                                      color="Izboljšan približek"))+
    geom_smooth(method = lm,formula = y~x,se=F,fullrange=TRUE)+
    geom_point(aes(color="Točne vrdednosti"))+
    geom_point(data = napoved_opt,
               aes(x=Vrednost,y=Najvisja_cena,
                   color="Izboljšana napoved cene"),size=3)+
    scale_colour_manual(name="LEGENDA",values=c("red","green","black"))+
    labs(title="Izboljšana napoved cene preko dobička s pomočjo linearne regresije")+
    scale_x_continuous(name = "Dobiček na delnico (USD)", breaks = seq(0,5,0.2))+
    scale_y_continuous(name = "Cena delnice (USD)", breaks = seq(0,110,5))+
    theme(legend.position = c(0.3, 0.8),
          panel.grid.minor = element_blank(),
          plot.title = element_text(hjust = 0.5))
  return(premica_odvisnost_opt)}


### fimd2.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, 7mar2012
### Version 2, 4nov2015
### Tested with Mac OS X 10.7.3, R2.14-2, mice 2.11

### Chapter 2 Multiple imputation

library("mice")
library("lattice")
library("MASS")

### Section 2.1.3 The expanding literature on multiple imputation
### Figure 2.1

cit  <- c(     2010, 37, 182, NA,
               2009, 36, 129, NA,
               2008, 27, 111, NA,
               2007, 35, 136, NA,
               2006, 18, 80, NA,
               2005, 20, 76, NA,
               2004,  6, 56, NA,
               2003, 17, 42, NA,
               2002, 14, 40, NA,
               2001, 13, 36, 57,
               2000,  8, 21, 33,
               1999,  6, 25, 47,
               1998, 6, 13, 22,
               1997, 6, 18, 29,
               1996, 4, 12, 28,
               1995, 3, 5, 20,
               1994, 2, 5, 34,
               1993, 2, 6, 15,
               1991, 2, 4, 19,
               1990, 1, 2, 15,
               1989, NA, NA, 11,
               1988, 1, NA, 13,
               1987, NA, NA, 10,
               1986, NA, NA, 5,
               1985, NA, NA, 1,
               1984, NA, NA, 2,
               1983, NA, NA, 5,
               1982, NA, NA, 2,
               1981, NA, NA, 1,
               1980, NA, NA, 5,
               1979, NA, NA, 2,
               1978, NA, NA, 1,
               1977, NA, NA, 2)
cit <- matrix(cit, nr=2010-1977, nc=4, byrow=TRUE)
cit <- as.data.frame(cit)
names(cit) <- c("Year","Title","Abstract","All")
par(mfrow=c(1,1))
par(cex=0.7, lwd=0.5)
plot(x=cit$Year, y=cit$Abstract, type="o",log="y",
     xlim=c(1975,2010),ylim=c(1,200),
     ylab="Number of publications (log)", xlab="Year", pch=2,
     axes=FALSE)
axis(1, lwd=par("lwd"))
axis(2, lwd=par("lwd"), las=1)
# box(lwd=0.5)
lines(x=cit$Year, y=cit$Title, pch=15, type="o")
lines(x=cit$Year, y=cit$All, pch=16, type="o")
legend(x=1975,y=200,legend=c("early publications",
                            "'multiple imputation' in abstract",
                            "'multiple imputation' in title"),
       pch=c(16,2,15), bty="n")

### Section 2.2.4 MCAR, MAR and MNAR again

logistic <- function(x) exp(x)/(1+exp(x))
set.seed(80122)
n <- 300
y <- mvrnorm(n=n,mu=c(0,0),Sigma=matrix(c(1,0.5,0.5,1),nrow=2))
y1 <- y[,1]
y2 <- y[,2]
r2.mcar <- 1-rbinom(n, 1, 0.5)
r2.mar  <- 1-rbinom(n, 1, logistic(y1))
r2.mnar <- 1-rbinom(n, 1, logistic(y2))

### Figure 2.2

y3 <- rbind(y,y,y)
r2 <- c(r2.mcar,r2.mar,r2.mnar)
r2 <- factor(r2, labels=c("Ymis","Yobs"))
typ <- factor(rep(3:1,each=n),labels=c("MNAR","MAR","MCAR"))
d <- data.frame(y1=y3[,1],y2=y3[,2],r2=r2,typ=typ)
trellis.par.set(box.rectangle=list(col=c(mdc(2),mdc(1)),lwd=1.2))
trellis.par.set(box.umbrella=list(col=c(mdc(2),mdc(1)),lwd=1.2))
trellis.par.set(plot.symbol=list(col=mdc(3),lwd=1))
tp <- bwplot(r2~y2|typ, data=d,
             horizontal=TRUE, layout=c(1,3),
             xlab=expression(Y^2),
             col=c(mdc(2),mdc(1)),strip=FALSE, xlim=c(-3,3),
             strip.left = strip.custom(bg="grey95"))
print(tp)

### Section 2.3.7 Numerical example
options(digits=3)
imp <- mice(nhanes, print=FALSE, m=10, seed=24415)
fit <- with(imp, lm(bmi~age))
est <- pool(fit)
names(est)
attach(est)
(r+2/(df+3))/(r+1)
(df+1)/(df+3)*lambda+2/(df+3)
detach(est)


# Assignment 4 - PCA

This document does a PCA (Principal component analysis) on the Heart Failure Prediction dataset

# Let us load libraries and data

```{r results='hide', message=FALSE, warning=FALSE}
# clear environment
rm(list = ls())

# defining libraries

library(ggplot2)
library(dplyr)
library(PerformanceAnalytics)
library(data.table)
library(sqldf)
library(nortest)
library(tidyverse)
library(MASS)
library(rpart)
library(class)
library(ISLR)
library(scales)
library(ClustOfVar)
library(GGally)
library(reticulate)
library(ggthemes)
library(RColorBrewer)
library(gridExtra)
library(kableExtra)
library(Hmisc)
library(corrplot)
library(energy)
library(nnet)
library(Hotelling)
library(car)
library(devtools)
library(ggbiplot)
library(factoextra)
library(rgl)
library(FactoMineR)

```

```{r}
# reading data
data <- read.csv('/Users/mac/Downloads/heart_failure_clinical_records_dataset.csv')
str(data)
```

\
We check to see if we have categorical variables \
However we see all our variables are numeric \
Even the categorical ones are binary and already have 1/0 as values \

# Let's quickly revise our correlation plot
```{r}
# Correlation plot
M<-cor(data)
head(round(M,2))
corrplot(M, method="color")
```
\
Since most of the correlations are low (Pearson's r < 0.25) ),
we don't particularly see a need for PCA \
                                        We use PCA to reduce the dimensionality of the dataset as
                                        PCA accomplishes this by capturing the variance in the dataset.
                                        It get the components such that the are in the direction of the highest variance. \
                                        We also saw from EDA in last exercise that our VIF was quite low
                                        indicating absence of multi-collinearity. \
                                        So, reducing dimensionality may lead to loss of variance for our project.
                                        However, for exposition, we will try PCA and analyse results \

                                        # Let us perform PCA on our dataset

                                        ```{r}
                                        pca <- prcomp(data[,1:12],scale=TRUE)
                                        summary(pca)
                                        ```
                                        \
                                        Here, we see that we need 8 components to get cumulative proportion of
                                        variance equivalent to 0.78. \
                                        For convention, we would consider as many components as required
                                        to get in the range of 0.75-0.95 \
                                        Let us then consider 10 components (Cum prop. ~90%) instead of 12 reducing our dimensions
                                        from 12 to 10 \

                                        # Let's plot the Scree diagrams
                                        ```{r}
                                        plot(pca, type="lines", main = "Scree diagram")
                                        fviz_eig(pca)
                                        ```

                                        # We can also see a cumulative plot
                                        ```{r}
                                        std_dev <- pca$sdev
                                        pr_var <- std_dev^2
                                        prop_varex <- pr_var/sum(pr_var)
                                        plot(cumsum(prop_varex), xlab = "Principal Component",
                                             ylab = "Cumulative Proportion of Variance Explained",
                                             type = "b")
                                        ```
                                        \
                                        Both of the above plots (variance and cum. variance) show  that we need atleast 10 components for 90% variance
                                        and since we don't see a taper down in graph of cum. variance or a steep decline in scree diagram, we can note that this isnt ideal. \

# Plotting PCA

```{r}
# bi-plot which will use PC1 and PC2
ggbiplot(pca)
```
\
Here, we can tell that ejection_fraction, diabetes, platelets all
contribute to PC1 with higher values in these features moving the samples
to the right \
Similarly we can tell that age, serum_creatinine contributes more towards PC2 \
In PC1, we can see sex, smoking towards negative side of PC1 \
In PC2, we can time towards negative side of PC2 \

```{r}
# We can also tell which patients are similar to one other
# by adding rownames
# Let's use each row as a patient identifier, then,

                                        ggbiplot(pca, labels=rownames(data))
                                        ```
                                        \
                                        This tells us that patient IDs-16,32,56 are similar as they cluster together
                                        This would ideally be helpful with more meaningful identifiers \

                                        # Let's also look at contribution by variables
                                        ```{r}
                                        fviz_pca_var(pca,
                                                     col.var = "contrib", # Color by contributions to the PC
                                                     gradient.cols = c("#00AFBB", "#E7B800", "#FC4E07"),
                                                     repel = TRUE     # Avoid text overlapping
                                        )
                                        ```
                                        \
                                        We see that age, sex, smoking contribute more to PC1 and PC2
                                        so we can try and visualize this in more detail by bi-plots with these groups. \

                                        # Let's plot the bi-plot with gender
                                        ```{r}
                                        ggbiplot(pca,ellipse=TRUE, var.axes=FALSE, labels=rownames(data), groups=data$sex)
                                        ```
                                        \
                                        A clear indicator that males indicated by 1 have more breadth
                                        in PC1 as opposed to Females indicated by 0 which are more
                                        narrow along with that we see +ve indication for females
                                        along PC1 and negative for males \

                                        # Let's plot the bi-plot with smoking
                                        ```{r}
                                        ggbiplot(pca,ellipse=TRUE, var.axes=FALSE, labels=rownames(data), groups=data$smoking)
                                        ```
                                        \
                                        A clear indicator that smokers indicated by 1 have less breadth
                                        in PC1 as opposed to non-smokers indicated by 0 which are more
                                        wider and to the positive side along with that we see +ve
                                        indication for non-smokers for PC1 and negative for smokers \

                                        # We will create an age range variable and do the same as well
                                        ```{r}
                                        data$age_tr[data$age < 50 & data$age >= 40]="40-50"
                                        data$age_tr[data$age < 60 & data$age >= 50]="50-60"
                                        data$age_tr[data$age < 70 & data$age >= 60]="60-70"
                                        data$age_tr[data$age < 80 & data$age >= 70]="70-80"
                                        data$age_tr[data$age < 90 & data$age >= 80]="80-90"
                                        data$age_tr[data$age < 100 & data$age >= 90]="90-100"
                                        ```

                                        # And then plot the same result with
                                        ```{r}
                                        ggbiplot(pca,ellipse=TRUE, var.axes=FALSE, labels=rownames(data), groups=data$age_tr)
                                        ```
                                        \
                                        Not much indication here other than higher age groups
                                        tend to be more spread out in PC2 \

                                        # We can also look at PC3 and PC4
                                        ```{r}
                                        ggbiplot(pca,ellipse=TRUE,choices=c(3,4), labels=rownames(data))
                                        ```
                                        \
                                        serum_creatinine, diabetes more towards PC3 \
                                        Platelets, creatinine_phosphokinase, and high bp more towards PC4 \

                                        # By gender
                                        ```{r}
                                        ggbiplot(pca,ellipse=TRUE, var.axes=FALSE,choices=c(3,4), labels=rownames(data), groups=data$sex)
                                        ```
                                        \
                                        We note even spread in PC3, PC4 for gender \

                                        # By smoking
                                        ```{r}
                                        ggbiplot(pca,ellipse=TRUE, var.axes=FALSE,choices=c(3,4), labels=rownames(data), groups=data$sex)
                                        ```
                                        \
                                        We note even spread in PC3, PC4 for smoking \

                                        # By age groups
                                        ```{r}
                                        ggbiplot(pca,ellipse=TRUE, var.axes=FALSE, choices=c(3,4), labels=rownames(data), groups=data$age_tr)

                                        ```
                                        \
                                        We note age group 40-50 with most spread in PC4 \

                                        \newpage

                                        # Let us do a visualizations to see how much of each variable is present in each component
                                        ### We use factoextra and factominer for this ###

                                        ```{r}
                                        pca_viz <- PCA(data[,1:12], graph = FALSE,ncp =12)
                                        var <- get_pca_var(pca_viz)

                                        # We can now use the contrib function to get contribution of each variable
                                        # to the PCs
                                        var$contrib

                                        ```

                                        # Let's plot this -
                                        ```{r}
                                        corrplot(var$contrib, is.corr=FALSE, method="pie")
                                        ```

                                        ### Key Observations ###

                                        1. Sex and Smoking are dominant in PC1 \
                                        2. Age and time are dominant in PC2 \
                                        3. Serum_Sodium is dominant in PC3 \
                                        4. Platelets and creatinine_phosphokinase are dominant in PC4 \
                                        5. creatinine_phosphokinase is dominant in PC5 \
                                        6. Platelets and ejection_fraction are dominant in PC6 \
                                        7. Anaemia is dominant in PC7 \
                                        8. Diabetes is dominant in PC8 \
                                        9. Age is dominant in PC9 \
                                        10. Serum_Sodium, Serum_creatinine is dominant in PC10 \
                                        11. Time, anaemia is dominant in PC11 \
                                        12. Sex and smoking are dominant in PC12 \

                                        ### Note ###
                                        \
                                        We don't see a good combination of variables in any component and
PC12 is redundant as PC1 and gives same information \

# Let us now combine the pca with dataset
```{r}
data_pca <- cbind(data,pca$x)
```
\
The new dataset now has 26 variables with PC1-PC12 added \

# Now Let us check the means by death events
```{r}
meansPC <- aggregate(data_pca[,15:26],by=list(DEATH_EVENT=data$DEATH_EVENT),mean)
meansPC
```
# Let us check stddev by death events
```{r}
sdsPC <- aggregate(data_pca[,15:26],by=list(DEATH_EVENT=data$DEATH_EVENT),sd)
sdsPC
```
\
We notice a clear difference in means (note the different signs) however not much in std. deviation \
This may indicate that PCs aren't doing a good job in
                                        segregating the death events from non-death events \

                                        # Let us perform t-tests
                                        ```{r}
                                        t.test(PC1~data_pca$DEATH_EVENT,data=data_pca)
                                        t.test(PC2~data_pca$DEATH_EVENT,data=data_pca)
                                        t.test(PC3~data_pca$DEATH_EVENT,data=data_pca)
                                        t.test(PC4~data_pca$DEATH_EVENT,data=data_pca)
                                        t.test(PC5~data_pca$DEATH_EVENT,data=data_pca)
                                        t.test(PC6~data_pca$DEATH_EVENT,data=data_pca)
                                        t.test(PC7~data_pca$DEATH_EVENT,data=data_pca)
                                        t.test(PC8~data_pca$DEATH_EVENT,data=data_pca)
                                        t.test(PC9~data_pca$DEATH_EVENT,data=data_pca)
                                        t.test(PC10~data_pca$DEATH_EVENT,data=data_pca)
                                        t.test(PC11~data_pca$DEATH_EVENT,data=data_pca)
                                        t.test(PC12~data_pca$DEATH_EVENT,data=data_pca)
                                        ```
                                        \
                                        We notice signifcant results in PC2, PC3, PC4, and PC11 at alpha=0.5 \

                                        # Let us also perform F-ratio tests
                                        ```{r}
                                        var.test(PC1~data_pca$DEATH_EVENT,data=data_pca)
                                        var.test(PC2~data_pca$DEATH_EVENT,data=data_pca)
                                        var.test(PC3~data_pca$DEATH_EVENT,data=data_pca)
                                        var.test(PC4~data_pca$DEATH_EVENT,data=data_pca)
                                        var.test(PC5~data_pca$DEATH_EVENT,data=data_pca)
                                        var.test(PC6~data_pca$DEATH_EVENT,data=data_pca)
                                        var.test(PC7~data_pca$DEATH_EVENT,data=data_pca)
                                        var.test(PC8~data_pca$DEATH_EVENT,data=data_pca)
                                        var.test(PC9~data_pca$DEATH_EVENT,data=data_pca)
                                        var.test(PC10~data_pca$DEATH_EVENT,data=data_pca)
                                        var.test(PC11~data_pca$DEATH_EVENT,data=data_pca)
                                        var.test(PC12~data_pca$DEATH_EVENT,data=data_pca)
                                        ```
                                        \
                                        We notice signifcant results in PC2, PC4, PC5, PC6, PC8, PC9, and PC10 \

                                        # Plotting the scores for the first and second components
                                        ```{r}
                                        plot(data_pca$PC1, data_pca$PC2,
                                             pch=ifelse(data_pca$DEATH_EVENT == "1",1,16),xlab="PC1", ylab="PC2",col="dark blue",
                                             main="Heart disease patient against values for PC1 & PC2")
                                        abline(h=0)
                                        abline(v=0)
                                        legend("bottomleft", legend=c("Death_Event=1","Death_Event=0") ,col="dark blue", pch=c(1,16))

                                        ```
                                        \
                                        We do note that survivors seem to be closer to average than those who died \
                                        Also recall the definition of PC1 and PC2 - \
                                        PC1 was sex, smoking dominant \
                                        PC2 was age, time dominant \
                                        This also tells us that non-survivors were on the extremes of ages and follow-up
                                        period\

                                        # PCA - prediction

                                        # We can try a prediction with pca by splitting our data into train and test and finding the PCs on train and validating on test data

                                        ```{r}
                                        data <- read.csv('/Users/mac/Downloads/heart_failure_clinical_records_dataset.csv')
                                        # Split data into 2 parts for pca training (75%) and prediction (25%)
                                        set.seed(1)
                                        samp <- sample(nrow(data), nrow(data)*0.75)
                                        data.train <- data[samp,]
                                        data.valid <- data[-samp,]
                                        dim(data.train)
                                        dim(data.valid)
                                        ```
                                        \
                                        We split our data into 224 rows, and 75 rows into sets of train and valid.\

                                        # conduct PCA on training dataset
                                        ```{r}
                                        pca <- prcomp(data.train[,1:12], retx=TRUE, center=TRUE, scale=TRUE)
                                        expl.var <- round(pca$sdev^2/sum(pca$sdev^2)*100) # percent explained variance
                                        expl.var
                                        ```
                                        \
                                        The explained variance in components is same as before \

                                        # prediction of PCs for validation dataset
                                        ```{r}
                                        pred <- predict(pca, newdata=data.valid[,1:12])
                                        head(pred,5)
                                        ```
                                        \
                                        We print the first 5 rows to see the predicted values in our validation set. \

                                        # Let us take first 10 components that explain 90% variance in data and do the same

                                        ```{r}
                                        train.data <- data.frame(DEATH_EVENT=data.train$DEATH_EVENT, pca$x)
                                        train.data <- train.data[,1:11]

                                        test.data <- predict(pca, newdata = data.valid)
                                        test.data <- as.data.frame(test.data)
                                        test.data <- test.data[,1:10]
                                        head(test.data,5)
                                        ```
                                        \
                                        This finally gives us the test data with PC1-10 \
                                        Our final conclusion however remains the same that PCA isn't ideal
for modeling purpose in our project \

### This concludes our analysis of PCA in our dataset


##Umbrales=group
##Imagen=raster
##Banda=number 1
##Mascara= output raster
##ImagenUmbral= output raster
##showplots
rango <- range(na.omit(c(Imagen[[Banda]][]))) #Encontrar el rango de los datos
#levels <- 100 #Definir el número de niveles posibles
breaks <- seq(rango[1], rango[2], length.out = 100 + 1) #Número de "breaks" basado en niveles y rangos
h <- hist.default(na.omit(c(Imagen[[Banda]][])), breaks = breaks, plot = FALSE) #Crear histograma de datos
counts <- as.double(h$counts) #Observaciones por nivel
mids <- as.double(h$mids) #Media por break
len <- length(counts) #Número total de observaciones
w1 <- cumsum(counts) #Suma acumulada
w2 <- w1[len] + counts - w1 #
cm <- counts * mids
m1 <- cumsum(cm)
m2 <- m1[len] + cm - m1
var <- w1 * w2 * (m2/w2 - m1/w1)^2
maxi <- which(var == max(var, na.rm = TRUE))
otsu <- (mids[maxi[1]] + mids[maxi[length(maxi)]])/2

print(otsu)

hist(as.matrix(na.omit(Imagen[[Banda]])),
     xlab=names(Imagen[[Banda]]),
     ylab="Frecuencia",
     col="red",
main=paste("Distribución ",
           names(Imagen[[Banda]]),
           sep=""))
abline(v=otsu,
       col="black",
       lwd=1, lty=2)
box()
grid(lwd=1)

Mascara <- Imagen[[Banda]] >= otsu
ImagenUmbral <- Mascara * Imagen[[Banda]]