library(rstudioapi)
library(CCA)
library(ggplot2)
library(readr)
library(knitr)
this.dir <- dirname(rstudioapi::getActiveDocumentContext()$path)
setwd(this.dir)

################# 2 #################
two_markets <- read_delim("two-markets.DAT", " ", escape_double = FALSE, trim_ws = TRUE)
Bio = two_markets[,1:3]
Energy = two_markets[,4:5]
ccal<-cc(X=Bio,Y = Energy)
matcor(Bio,Energy)
ccal$cor
#Test
ev <- (1 - ccal$cor^2)
n <- dim(Bio)[1]
p <- length(Bio)
q <- length(Energy)
k <- min(p, q)
m <- n - 3/2 - (p + q)/2
w <- rev(cumprod(rev(ev)))
df = (p-1+1)*(q-1+1)
t1stat = -log(w[1])*(m)
t1critical = qchisq(1-0.05,df)

m <- n - 3/2 - (p + q)/2
t2stat = -log(w[2])*m
p = p-1;q=q-1
df = (p-1+1)*(q-1+1)
t2critical = qchisq(1-0.05,df)

colnames(ccal$xcoef) <- paste0("U", 1:2)
kable(ccal$xcoef)
colnames(ccal$ycoef) <- paste0("V", 1:2)
kable(ccal$ycoef)

rho_u_x2 <- ccal$scores$corr.Y.xscores
colnames(rho_u_x2) <- paste0("U", 1:2)
kable(rho_u_x2)

rho_v_x1 <- ccal$scores$corr.X.yscores
colnames(rho_v_x1) <- paste0("V", 1:2)
kable(rho_v_x1)
#########  3  ################
x1 = c(12, 18)
x2 = c(36, 24)
sp = matrix(c(2.4,1.7,1.7,3.4), ncol=2)
d = x1-x2
n1 = 400
n2 = 133
T2 = d%*%solve((1/n1+1/n2)*sp)%*%d # 29455.07
p = 2
critical = ((n1+n2-2)*p/(n1+n2-p-1))*qf(1-0.05,2,n1+n2-p-1)

l = t(x1-x2)%*%solve(sp)
r = 0.5*t(x1-x2)%*%solve(sp)%*%(x1+x2)
R = log((1/2)*(1/3))
RR=R+r

t(t(l))%*%c(18,24)>=RR

############  5  ##################
p = 4;n = 61
d= as.matrix(c(0.6,-8.4,-0.1,-10.7))
sd = as.matrix(rbind(c(5,0,1,0),c(0,2,-1,1),c(1,-1,4,1),c(0,1,1,4)))
T2 =n*t(d)%*%solve(sd)%*%d
qf(1-0.05, p, n-p)*(n-1)*p/(n-p)

cv = qt(1-0.05/8, 60)
#Drama
s1 = sd[1,1]
c(d[1]-cv*sqrt(s1/n),d[1]+cv*sqrt(s1/n))
#Horror
s2 = sd[2,2]
c(d[2]-cv*sqrt(s2/n),d[2]+cv*sqrt(s2/n))
#Action
s3 = sd[3,3]
c(d[3]-cv*sqrt(s3/n),d[3]+cv*sqrt(s3/n))
#Comedy
s4 = sd[4,4]
c(d[4]-cv*sqrt(s4/n),d[4]+cv*sqrt(s4/n))


# Cargar libreria forecast, fBasic, fArma, urca,
library(forecast)
library(fBasics)
library(car)
library(fArma)
library(urca)

# Entrada de datos desde un archivo de texto
(z=ts(scan("f:/udea/Economet2/ejemplo_1.txt")))

# ETAPA DE IDENTIFICACI?N
# gr?fica de la serie
plot.ts(z)
plot.ts(z, type="o")

# An?lisis de estabilidad de la varianza: Es necesario usar la
# transformaci?n Box-Cox?

# An?lisis gr?fico
par(mfrow=c(2,1))
plot.ts(z)
plot.ts(diff(z))

# Estimaci?n de la transformaci?n usando la librer?a car
(tBoxCox=powerTransform(z))
summary(tBoxCox)

# transformaci?n usando ra?z cuarta
tz=z^.25

# gr?fica de la serie original y transformada con Lambda=.25
par(mfrow=c(2,1))
plot.ts(z, type="o")
plot.ts(z^.25, type="o")

# gr?fica de la serie diferenciada original y transformada
par(mfrow=c(2,1))
plot.ts(diff(z))
plot.ts(diff(z^.25))

# se sigue el proceso de identificaci?n usando z^.25
# determinaci?n del valor de d
# gr?fica de la serie transformada
plot.ts(z^.25)
# correlogramas muestrales de la serie transformada
par(mfrow=c(2,1))
Acf(z^.25, lag.max=30, ci=0,ylim=c(-1,1))
pacf(z^.25, lag.max=30, ci=0, ylim=c(-1,1))

# La serie es no estacionaria: Qu? tipo de serie es TS o DS?
# prueba de ra?ces unitarias usando la librer?a urca
(maxlag=floor(12*(length(z)/100)^(1/4)))
ru_tz=ur.df(z^.25, type = c("trend"), lags=maxlag, selectlags = c("BIC"))
summary(ru_tz)
ru_tz=ur.df(z^.25, type = c("trend"), lags=maxlag, selectlags = c("AIC"))
summary(ru_tz)

  # validaci?n de la ecuaci?n ADF
    resid=ru_tz@testreg$residuals             # residuales del modelo ADF
    plot(ru_tz)
    auto.arima(resid, max.p=5, max.q=5)       # busqueda "autom?tica"
    cheq=Arima(resid, c(0,0,0), include.constant=TRUE)
    summary(cheq)
    tsdiag(cheq, gof.lag=15)
  # Verificacion de normalidad en los residuales
    qqnorm(resid,  xlab = "Cuantiles Te?ricos", ylab = "Cuantiles Muestrales")
    qqline(resid)
    shapiro.test(resid)                # prueba de Shapiro-Wilks
    jarqueberaTest(resid )             # prueba Jarque-Bera en libreria fBasics

# el modelo ADF satisface los supuestos b?sicos
#Conclusi?n: La serie z^.25 contiene al menos una ra?z unitaria.

# Examen de m?s ra?ces unitarias
# gr?fica de la serie diferenciada una vez
plot.ts(diff(z^.25), type="l")
# prueba de si hay ra?z unitarias en z^.25 diferenciada una vez.
ru_dif_tz=ur.df(diff(z^.25), type = c("drift"), lags=maxlag, selectlags = c("BIC"))
summary(ru_dif_tz)
# reespecificaci?n del modelo con lags=0
ru_dif_tz=ur.df(diff(z^.25), type = c("drift"), lags=0)
summary(ru_dif_tz)   # valide la ecuaci?n usada para la prueba
#Conclusi?n: La serie z^.25  diferenciada no contiene r?iz unitaria.
# Por tanto, la serie z^.25 pertenece a la clase de modelos ARIMA con deriva y d=1.

# determinaci?n de los valores de (p, q) del modelos ARMA para (1-B)z^.25
# correlogramas muestrales para z diferenciada una vez
par(mfrow=c(2,1))
Acf(diff(z^.25), lag.max=12, ci=0, ylim=c(-1,1))
pacf(diff(z^.25), lag.max=12, ci=0, ylim=c(-1,1))

# correlogramas muestrales para z^.25 diferenciada una vez con bandas
par(mfrow=c(2,1))
Acf(diff(z^.25), lag.max=12, ci=0)
pacf(diff(z^.25), lag.max=12)

# selecci?n "autom?tica" del modelo
auto.arima(z^.25, d=1, max.p=5, max.q=5, ic=c("aic"))
auto.arima(z^.25, max.p=5, max.q=5, ic=c("bic"))

# Conclusi?n: modelo seleccionado es: (1-phi1*B)(1-B)z^.25=constante+at,
# es decir, z^.25 sigue un modelo ARIMA(1,1,0) con deriva.
# la tendencia observada en la gr?fica de z^.25 es una mezcla de tendencia aleatoria y detemin?stica lineal

# ETAPA DE ESTIMACI?N
# estimaci?n ML exacta con valores iniciales dados por la estimaci?n condicional
mod1_CSS_ML=Arima(z, c(1, 1, 0), include.drift=TRUE, lambda=.25, method = c("CSS-ML"))
summary(mod1_CSS_ML)
(res1_CSS_ML=residuals(mod1_CSS_ML))

# ETAPA DE DIAGN?STICOS
# ra?ces de los polinomios
# usando la librer?a fArma
coeficAR=c(coef(mod1_CSS_ML)[1])
# vector con el coeficiente AR
armaRoots(coeficAR)                  # obtiene las ra?ces
# otra forma: usando librer?a forecast usando el inverso de las ra?ces del polinomio
plot(mod1_CSS_ML)

# An?lisis de los residuales
tsdiag(mod1_CSS_ML)

# chequeo de observaciones at?picas extremas (no es un an?lisis completo de outliers)
res1_est=res1_CSS_ML/(mod1_CSS_ML$sigma2^.5)  # estandarizaci?n de los residuales
plot.ts(res1_est, type="o")
abline(a=-3, b=0)
abline(a=3, b=0)

# n?mero de observaciones esperadas fuera de los limites (-3, 3) bajo normalidad
(Nobs_Esp=round(length(z)*2*pnorm(-3, mean = 0, sd = 1, lower.tail = TRUE)))

# detecci?n de las observaciones at?picas
ind=(abs(res1_est)>3.0)
sum(ind)
(grupo=cbind(res1_est, ind))

# chequeo de normalidad
# gr?fico cuantil-cuantil
qqnorm(res1_est,  xlab = "Cuantiles Te?ricos", ylab = "Cuantiles Muestrales",
       xlim=c(-4,4), ylim=c(-4,4))
qqline(res1_est)

# histograma, densidad kernel y gr?fico normal
plot(density(res1_est))
mu<-mean(res1_est)
sigm<-sd(res1_est)
x<-seq(-4,4,length=100)
y<-dnorm(x,mu,sigm)
hist(res1_est,prob=T,ylim=c(0,.45),xlim=c(-4,4),col="yellow")
lines(density(res1_est))
lines(x,y,lwd=2,col="blue")
# conclusi?n: No se detecta alejamiento fuerte de la normalidad

# pruebas de normalidad
shapiro.test(res1_est)               # prueba de Shapiro-Wilks
normalTest(res1_est, method=("jb"))  # En la librer?a fBasics: puede realizar otras pruebas
                                     # "ks" for the Kolmogorov-Smirnov one?sample test,
                                     # "sw" for the Shapiro-Wilk test,
                                     # "jb" for the Jarque-Bera Test,
                                     # "da" for the D'Agostino Test. The default value is "ks"
# conclusi?n: No se rechaza la normalidad.

# valores ajustados del modelo para z transformada
mod1_CSS_MLn=Arima(z^.25, c(1, 1, 0), include.drift=TRUE, method = c("CSS-ML"))
summary(mod1_CSS_ML)n)
(res1_CSS_MLn=residuals(mod1_CSS_MLn))

(ajustn=z^.25-residuals(mod1_CSS_MLn))
# gr?fico para los valores ajustados y los valores observados
ts.plot(z^.25,ajustn)   # gr?fico de las series contra el tiempo
lines(z^.25, col="black")
lines(ajustn, col="red")

plot(as.vector(z^.25),as.vector(ajustn), type="p")  # gr?fico de dispersi?n de la serie observada
abline(0,1)                                      # contra la serie ajustada

# detecci?n de observaciones at?picas
ind=(abs(res1_est)>3.0)
sum(ind)
(grupo=cbind(res1_est, ind))

# n?mero de observaciones esperadas fuera del intervalo (-3, 3)
(num_obs=length(z)*2*pnorm(-3.0, mean = 0, sd = 1, lower.tail = TRUE))

# Evaluaci?n de Pron?sticos: se contruye el modelo usando 245 datos y se dejan
# los ?ltimos 5 para evaluar la capacidad de pron?stico del modelo
# estimaci?n ML exacta con valores iniciales dados por la estimaci?n condicional
num_pron=5
(mod_Evalpron=Arima(z[1:(length(z)-num_pron)], c(1, 1, 0), include.drift=TRUE, lambda=.25, method = c("CSS-ML")))
summary(mod_Evalpron)

(z_pred<-forecast(mod_Evalpron, h=num_pron, lambda=mod1_CSS_ML$lambda, fan=TRUE))
plot(forecast(z_pred))

(z_pred<-forecast(mod_Evalpron, h=num_pron, level=c(95), lambda=mod1_CSS_ML$lambda))
plot(forecast(z_pred))

# EVALUACI?N DE LOS PRON?STICOS
(real=ts(z[(length(z)-num_pron+1):length(z)]))
cbind(real, ts(z_pred$mean))

# gr?fico de reales, pron?sticos
ts.plot(real, ts(z_pred$mean),type="o")
lines(ts(z_pred$mean), col="red")

# gr?fico de reales, pron?sticos e intervalo de predicci?n
ts.plot(real, ts(z_pred$mean), ts(z_pred$lower), ts(z_pred$upper), type="o")
lines(ts(z_pred$mean), col="red")
lines(ts(z_pred$lower), col="blue")
lines(ts(z_pred$upper), col="blue")

# C?lculo de medidas de evaluaci?n de los pron?sticos
(recm=(mean((real-ts(z_pred$mean))^2))^.5)            #  rmse
(recmp=(mean(((real-ts(z_pred$mean))/real)^2))^.5)    #  rmspe

(eam=mean(abs(real-ts(z_pred$mean))))                 #  mae
(eamp=mean(abs((real-ts(z_pred$mean))/real)))         #  mape

# descomposici?n del error cuadr?tico medio
(ecm=(mean((real-ts(z_pred$mean))^2))) # c?lculo del error cuadr?tico medio

# proporci?n de sesgo
(prop_sesgo_med=(mean(ts(z_pred$mean))-mean(real))^2/ecm)

# c?lculo de varianza sesgadas
sigmap=((length(real)-1)/length(real)*var(ts(z_pred$mean)))^.5   # c?lculo de desv. estand. de los pron?sticos
sigmar=((length(real)-1)/length(real)*var(ts(real)))^.5          # c?lculo de desv. estand. de los datos

# proporci?n de varianza
(prop_sesgo_var=(sigmap-sigmar)^2/ecm)

# proporci?n de covarianza
(prop_covar=2*(1-cor(ts(z_pred$mean), real))*sigmap*sigmar/ecm)
prop_sesgo_med+prop_sesgo_var+prop_covar                         # verificaci?n de c?lculos

# Verdaderos Pron?sticos
(z_pron<-forecast(mod1_CSS_ML, h=10, level=c(90), lambda=mod1_CSS_ML$lambda, fan=FALSE))
plot(forecast(z_pron))


ybar=33
sigma=8.4
n=35
alpha = .05
# critical value
z.alpha = qnorm(1-alpha)
z1=function(mu0){
  z=abs((ybar- mu0)/(sigma/sqrt(n)))
   b=pnorm(z.alpha-z)
   return(b)
}
muo=c(33,32,31,30,29,28,27,26,25)
beta=c(z1(33),z1(32),z1(31),z1(30),z1(29),z1(28),z1(27),z1(26),z1(25))
pwr=1-beta
rbind(muo,beta,pwr)


=begin
  # sample-m-factorize01.rb

  require "algebra"
  P = MPolynomial(Integer)
  x, y, z = P.vars("xyz")
  f = x**3 + y**3 + z**3 - 3*x*y*z
  p f.factorize #=> (x + y + z)(x^2 - xy - xz + y^2 - yz + z^2)

  PQ = MPolynomial(Rational)
  x, y, z = PQ.vars("xyz")
  f = x**3 + y**3/8 + z**3 - 3*x*y*z/2
  p f.factorize #=> (1/8)(2x + y + 2z)(4x^2 - 2xy - 4xz + y^2 - 2yz + 4z^2)
((<_|CONTENTS>))
=end


## ----author info, include=F----------------------------------------------
## Author:  Yanchang Zhao
## Email:   yanchang@RDataMining.com
## Website: http://www.RDataMining.com
## Date:    9 December 2018

## ----load libraries, include=F, echo=F-----------------------------------
## load required packages
library(dtw)
library(wavelets)
library(party)

## ------------------------------------------------------------------------
a <- ts(1:20, frequency=12, start=c(2011,3))
print(a)
str(a)
attributes(a)

## ----out.width=".85\\textwidth"------------------------------------------
plot(AirPassengers)

## ----out.width=".9\\textwidth"-------------------------------------------
apts <- ts(AirPassengers, frequency = 12)
f <- decompose(apts)
plot(f$figure, type="b") # seasonal figures

## ----out.width=".75\\textwidth"------------------------------------------
plot(f)

## ----tidy=F--------------------------------------------------------------
# build an ARIMA model
fit <- arima(AirPassengers, order=c(1,0,0),
       list(order=c(2,1,0), period=12))
fore <- predict(fit, n.ahead=24)
# error bounds at 95% confidence level
U <- fore$pred + 2*fore$se
L <- fore$pred - 2*fore$se

## ----plot-forecast, fig.show="hide", tidy=F------------------------------
ts.plot(AirPassengers, fore$pred, U, L,
        col = c(1, 2, 4, 4), lty = c(1, 1, 2, 2))
legend("topleft", col = c(1, 2, 4), lty = c(1, 1, 2),
       c("Actual", "Forecast", "Error Bounds (95% Confidence)"))

## ----echo=F, out.width="\\textwidth"-------------------------------------
ts.plot(AirPassengers, fore$pred, U, L,
        col = c(1, 2, 4, 4), lty = c(1, 1, 2, 2))
legend("topleft", col = c(1, 2, 4), lty = c(1, 1, 2),
       c("Actual", "Forecast", "Error Bounds (95% Confidence)"))

## ----fig.show="hide"-----------------------------------------------------
library(dtw)
idx <- seq(0, 2*pi, len=100)
a <- sin(idx) + runif(100)/10
b <- cos(idx)
align <- dtw(a, b, step=asymmetricP1, keep=T)
dtwPlotTwoWay(align)

## ----echo=F, out.height=".8\\textheight"---------------------------------
dtwPlotTwoWay(align)

## ----fig.show='hide', tidy=F---------------------------------------------
# read data into R
# sep="": the separator is white space, i.e., one
# or more spaces, tabs, newlines or carriage returns
sc <- read.table("./data/synthetic_control.data", header=F, sep="")
# show one sample from each class
idx <- c(1, 101, 201, 301, 401, 501)
sample1 <- t(sc[idx,])
plot.ts(sample1, main="")

## ----echo=F, out.height="\\textheight"-----------------------------------
plot.ts(sample1, main="")

## ----echo=F--------------------------------------------------------------
set.seed(17)

## ----fig.show='hide'-----------------------------------------------------
# sample n cases from every class
n <- 10
s <- sample(1:100, n)
idx <- c(s, 100+s, 200+s, 300+s, 400+s, 500+s)
sample2 <- sc[idx,]
observedLabels <- rep(1:6, each=n)
# hierarchical clustering with Euclidean distance
hc <- hclust(dist(sample2), method="ave")
plot(hc, labels=observedLabels, main="")

## ----echo=F, out.height="\\textheight"-----------------------------------
plot(hc, labels=observedLabels, main="")

## ------------------------------------------------------------------------
# cut tree to get 8 clusters
memb <- cutree(hc, k=8)
table(observedLabels, memb)

## ----fig.show='hide'-----------------------------------------------------
myDist <- dist(sample2, method="DTW")
hc <- hclust(myDist, method="average")
plot(hc, labels=observedLabels, main="")
# cut tree to get 8 clusters
memb <- cutree(hc, k=8)
table(observedLabels, memb)

## ----echo=F, out.height="\\textheight"-----------------------------------
plot(hc, labels=observedLabels, main="")

## ----tidy=F--------------------------------------------------------------
classId <- rep(as.character(1:6), each = 100)
newSc <- data.frame(cbind(classId, sc))
library(party)
ct <- ctree(classId ~ ., data = newSc,
            controls = ctree_control(minsplit = 20,
                       minbucket = 5, maxdepth = 5))

## ------------------------------------------------------------------------
pClassId <- predict(ct)
table(classId, pClassId)
# accuracy
(sum(classId==pClassId)) / nrow(sc)

## ------------------------------------------------------------------------
# extract DWT (with Haar filter) coefficients
library(wavelets)
wtData <- NULL
for (i in 1:nrow(sc)) {
  a <- t(sc[i,])
  wt <- dwt(a, filter="haar", boundary="periodic")
  wtData <- rbind(wtData,
      unlist(c(wt@W, wt@V[[wt@level]])))
}
wtData <- as.data.frame(wtData)
wtSc <- data.frame(cbind(classId, wtData))

## ----tidy=F--------------------------------------------------------------
ct <- ctree(classId ~ ., data = wtSc,
            controls = ctree_control(minsplit=20, minbucket=5,
                                     maxdepth=5))
pClassId <- predict(ct)
table(classId, pClassId)
(sum(classId==pClassId)) / nrow(wtSc)

## ----fig.width=18, fig.height=8, out.height=".85\\textheight", out.width="1.1\\textwidth"----
plot(ct, ip_args=list(pval=F), ep_args=list(digits=0))

## ----echo=F--------------------------------------------------------------
set.seed(100)

## ------------------------------------------------------------------------
k <- 20
newTS <- sc[501,] + runif(100)*15
distances <- dist(newTS, sc, method="DTW")
s <- sort(as.vector(distances), index.return=TRUE)
# class IDs of k nearest neighbours
table(classId[s$ix[1:k]])


#' The zero-truncated compund poisson-lognormal distributions mixture
#'
#' Density function and random generation for Zero-Truncated
#' Poisson Lognormal distribution with parameters `mu`, `sig`, and `theta`.
#'
#' Type 1 ZTPLN truncates zero based on Poisson-lognormal distribution and
#' type 2 ZTPLN truncates zero based on zero-truncated Poisson distribution.
#' For mathematical details, please see `vignette("ztpln")`
#'
#' @param n number of random values to return.
#' @param mu vector of mean of lognormal distribution in sample.
#' @param sig vector standard deviation of lognormal distribution in sample.
#' @param theta vector of mixture weights
#' @param x	vector of (non-negative integer) quantiles.
#' @param log logical; if TRUE, probabilities p are given as log(p).
#' @param type1 logical; if TRUE, Use type 1 ztpln else use type 2.
#' @return dztplnm gives the (log) density and rztplnm generates
#' random variates.
#' function, qpois gives the quantile function, and rpois generates random
#' deviates.
#' @seealso \code{\link{dztpln}}
#' @examples
#' rztplnm(n = 100, mu = c(0, 5), sig = c(1, 2), theta = c(0.2, 0.8))
#' dztplnm(x = 1:100, mu = c(0, 5), sig = c(1, 2), theta = c(0.2, 0.8))
#' dztplnm(x = 1:100, mu = c(0, 5), sig = c(1, 2), theta = c(0.2, 0.8), type1 = FALSE)
#' @export
dztplnm <- function(x, mu, sig, theta, log = FALSE, type1 = TRUE) {
  if (length(mu) != length(sig) |
      length(mu) != length(theta) |
      length(sig) != length(theta)) {
    stop("The length of vectors of mean,
         variance and mixture weight need to be same.")
  }
  if (sum(theta) != 1) warning("Sum of the mixture weight should be 1.")
  theta <- theta / sum(theta)
  if (type1) {
    lik <- do_dztplnm(x, mu, sig, theta)
  } else lik <- do_dztplnm2(x, mu, sig, theta)
  if (log) return(log(lik)) else return(lik)
}

#' @rdname dztplnm
#' @export
rztplnm <- function(n, mu, sig, theta, type1 = TRUE) {
  # theta: mixture weight for the first compoment
  if (length(mu) != length(sig) | length(mu) != length(theta) |
      length(sig) != length(theta)) {
    stop("The length of vectors of mean,
         variance and mixture weight need to be same.")
  }
  if (sum(theta) != 1) warning("Sum of the mixture weight should be 1.")
  z <- rmultinom(n, 1, theta)
  z2 <- as.numeric(z * seq(1, length(mu)))
  z3 <- z2[z2 > 0]
  if (type1) do_vec2_rztpln1(n, mu[z3], sig[z3]) else do_vec2_rztpln2(n, mu[z3], sig[z3])
}


# Example : 2.7A   Chapter : 2.7   Pageno : 114
# Multiplication by Permutation matrices
P<-matrix(c(0,0,1,1,0,0,0,1,0),ncol=3)
A<-matrix(c(1,4,5,4,2,6,5,6,3),ncol=3)
Q<-t(P)
PA<-P%*%A
PAQ<-PA%*%Q
print("P*A")
print(PA)
print("P*A*Q")
print(PAQ)


#' Draws a t-distribution curve and shades rejection regions
#'
#' @param df degrees of freedom.
#' @param alpha significance level
#' @param h0 null hypothesis value
#' @param sides one of: both, left, right
#' @param t_calc calculated test statistics
#' @examples
#' shade(49, 0.05, 0, t_calc=1.1)
shade <- function(df, alpha, h0 = 0, sides='both', t_calc=NULL) {
  e_alpha = alpha
  if(sides == 'both'){
    e_alpha = alpha / 2
  }
  cv = abs(qt(e_alpha, df))
  curve(dt(x, df), from = -4, to = 4, ylab='P(x)', xaxt='n')
  abline(v = 0, col = "black", lwd = 0.5)
  labels = h0
  at = 0
  if(sides == 'both' | sides == 'left'){
    x <- seq(-4, -abs(cv), len = 100)
    y <- dt(x, df)
    polygon(c(x, -abs(cv)), c(y, min(y)), col = "blue", border = NA)
    lines(c(-cv, -cv), c(0, dt(-cv, df)), col = "black", lwd = 1)
    text(-cv - (4 - cv) / 2, 0.05, e_alpha)
    labels = c(round(-cv, 3), labels)
    at = c(-cv, at)
  }
  if(sides == 'both' | sides == 'right'){
    x <- seq(abs(cv), 4, len = 100)
    y <- dt(x, df)
    polygon(c(abs(cv), x), c(min(y), y), col = "blue", border = NA)
    lines(c(cv, cv), c(0, dt(cv, df)), col = "black", lwd = 1)
    text(cv + (4 - cv) / 2, 0.05, e_alpha)
    labels = c(labels, round(cv, 3))
    at = c(at, cv)
  }
  if(is.numeric(t_calc)){
    abline(v = t_calc, col = "red", lwd = 2)
    text(t_calc + 0.5, 0.2, t_calc, col = "red")
  }
  axis(1, at=at, labels=labels)
}


## Dexter Barrows
## dbarrows.github.com
## McMaster University
## 2016

StocSIR <- function(y, pars, T, steps) {

    out <- matrix(NA, nrow = (T+1), ncol = 4)

    R0 <- pars[['R0']]
    r <- pars[['r']]
    N <- pars[['N']]
    eta <- pars[['eta']]
    berr <- pars[['berr']]

    S <- y[['S']]
    I <- y[['I']]
    R <- y[['R']]

    B0 <- R0 * r / N
    B <- B0

    out[1,] <- c(S,I,R,B)

    h <- 1 / steps

    for ( i in 1:(T*steps) ) {

        B <- exp( log(B) + eta*(log(B0) - log(B)) + rnorm(1, 0, berr) )

        BSI <- B*S*I
        rI <- r*I

        dS <- -BSI
        dI <- BSI - rI
        dR <- rI

        S <- S + h*dS
        I <- I + h*dI
        R <- R + h*dR

        if (i %% steps == 0)
            out[i/steps+1,] <- c(S,I,R,B)

    }

    return(out)

}

### Suggested parameters
#
# T       <- 60
# i_infec <- 5
# steps   <- 7
# N       <- 500
# sigma   <- 10
#
# pars <- c(R0 = 3.0,     # new infected people per infected person
#           r = 0.1,      # recovery rate
#           N = 500,      # population size
#           eta = 0.5,    # geometric random walk
#           berr = 0.5)   # Beta geometric walk noise


exp(1)             # e
pi                 # pi
sqrt(x)            # square root
log(x)             # natural logarithm
log10(x)           # base 10 logarithm
log(x, y)          # arbitrary base logarithm
exp(x)             # exponential
abs(x)             # absolute value
floor(x)           # floor
ceiling(x)         # ceiling
x^y                # power


NAME	Ackermann

MODE	REDUCTION

SORTS	NAT

SIGNATURE
	0 : -> NAT
	s : NAT -> NAT
	+ : NAT NAT -> NAT
	* : NAT NAT -> NAT
	fac : NAT -> NAT
	ack : NAT NAT -> NAT

ORDERING   KBO
        ack = 1, fac = 1, * = 1, + = 1, s = 1, 0 = 1
	ack > fac > * > + > s > 0

VARIABLES
	x,y : NAT

EQUATIONS
	+(x,0) = x
	+(x,s(y)) = s(+(x,y))
	*(x,0) = 0
	*(x,s(y)) = +(*(x,y),x)
	fac(0) = s(0)
	fac(s(x)) = *(s(x),fac(x))
	ack(0,y) = s(y)
	ack(s(x),0) = ack(x,s(0))
	ack(s(x),s(y)) = ack(x,ack(s(x),y))

CONCLUSION fac(s(s(s(s(s(0)))))) = ack(s(s(s(0))),0)
	*(ack(s(s(s(0))),0),0) = *(0,ack(s(s(s(0))),0))


#!/usr/bin/env Rscript

# sum_of_odds.r - calculate sum of odd integers

version__ = 1.1
date__ = '2021-01-14'

up_to <- 170

is_odd <- function(x)
{
  remainder <- x %% 2
  if (remainder == 0) return(FALSE)
  else                return(TRUE)
}

sum <- 0
number_of_odds <- 0
last_odd <- 0

for (i in 0:up_to)
{
  if (is_odd(i))
  {
    sum <- sum + i
    number_of_odds <- number_of_odds + 1
    last_odd <- i
  }
}

if (sum == number_of_odds ^ 2)
{
  if (number_of_odds == 0) { ; }
  else if (number_of_odds < 7) print(sum)
  else cat('1 + 3 + 5 + ... +', last_odd - 1,
           '+', last_odd, '=', sum, "\n")
} else warning('Unexpected error: ', sum)


# 1. 验证序列平稳性
library(forecast)
library(tseries)
plot.ts(hua_train)
hua_train<-as.numeric(unlist(hua_train))
ndiffs(hua_train)
dhua_train<-diff(hua_train)
plot.ts(dhua_train)
ADF<-adf.test(dhua_train)
ADF # 原假设：存在单位根（存在单位根为非平稳时间序列）；拒绝原假设：序列平稳

# 2. 模型自动定阶及拟合
fit <- auto.arima(hua_train)
fit
accuracy(fit)

pacf (dhua_train, 40, ylim=range(-1,1))
acf (dhua_train, 40, ylim=range(-1,1))
fit <- arima(hua_train,order=c(12,1,3))

# 3. 模型诊断
qqnorm(fit$residuals)
qqline(fit$residuals)
Box.test(fit$residuals,type = "Ljung-Box")

# 4. 用ARIMA进行预测
forecast(fit,1)
plot(forecast(fit,1),xlab="month",ylab="Monthly runoff")


# median for interval data
Median_calculate <- function(frequencies, intervals, sep = NULL, trim = NULL) {
  # If "sep" is specified, the function will try to create the
  #   required "intervals" matrix. "trim" removes any unwanted
  #   characters before attempting to convert the ranges to numeric.
  if (!is.null(sep)) {
    if (is.null(trim)) pattern <- ""
    else if (trim == "cut") pattern <- "\\[|\\]|\\(|\\)"
    else pattern <- trim
    intervals <- sapply(strsplit(gsub(pattern, "", intervals), sep), as.numeric)
  }

  Midpoints <- rowMeans(intervals)
  cf <- cumsum(frequencies)
  Midrow <- findInterval(max(cf)/2, cf) + 1
  L <- intervals[1, Midrow]      # lower class boundary of median class
  h <- diff(intervals[, Midrow]) # size of median class
  f <- frequencies[Midrow]       # frequency of median class
  cf2 <- cf[Midrow - 1]          # cumulative frequency class before median class
  n_2 <- max(cf)/2               # total observations divided by 2

  unname(L + (n_2 - cf2)/f * h)
}

mydataframe <- structure(list(Class_interval = c("16.25-18.75", "18.75-21.25", "21.25-23.75",
                                  "23.75-26.25", "26.25-28.75", " 28.75-31.25", " 31.25-33.75", "33.75-36.25",
                                  "36.25-38.75", " 38.75- 41.25","41.25- 43.75"), freq = c(2L, 7L, 7L, 14L,
                                                                        17L, 24L, 11L, 11L, 3L, 3L,1L)), .Names = c("class_interval", "freq"),
                  class = "data.frame", row.names = c(NA, -11L))
print(mydataframe)

Median_calculate(mydataframe$freq, mydataframe$class_interval, sep = "-")


primes <- c(2, 3, 5, 7, 11, 13)
isPrime <- function(a) {
  i <- 1
  while (a %% primes[i] > 0) {
    if (primes[i] * primes[i] > a) {
      primes <<- append(primes, a)
      return(TRUE)
    }
    i <- i + 1
  }
  FALSE
}

primeSeq <- function() {
  p0 <- 1
  i <- 0
  return(function() {
    if (p0 <= length(primes)) {
      i <<- primes[p0]
      p0 <<- p0 + 1
      return(i)
    }
    i <<- i + 2
    while (!isPrime(i)) {
      i <<- i + 2
    }
    p0 <<- p0 + 1
    return(i)
  })
}

isPalindrome <- function(s) {
  return(s == sapply(lapply(strsplit(s, ""), rev), paste, collapse=""))
}

maxPrime <- 0
nextPrime <- primeSeq()
j <- nextPrime()
while (j < 1000) {
  if (isPalindrome(toString(j))) {
    maxPrime <- j
  }
  j <- nextPrime()
}
cat(maxPrime, sep="\n")


rk4 <- function(f, x0, y0, x1, n) {
    vx <- double(n + 1)
    vy <- double(n + 1)
    vx[1] <- x <- x0
    vy[1] <- y <- y0
    h <- (x1 - x0)/n
    for(i in 1:n) {
        k1 <- h*f(x, y)
        k2 <- h*f(x + 0.5*h, y + 0.5*k1)
        k3 <- h*f(x + 0.5*h, y + 0.5*k2)
        k4 <- h*f(x + h, y + k3)
        vx[i + 1] <- x <- x0 + i*h
        vy[i + 1] <- y <- y + (k1 + k2 + k2 + k3 + k3 + k4)/6
    }
    cbind(vx, vy)
}

sol <- rk4(function(x, y) x*sqrt(y), 0, 1, 10, 100)
cbind(sol, sol[, 2] - (4 + sol[, 1]^2)^2/16)[seq(1, 101, 10), ]

      vx         vy
 [1,]  0   1.000000  0.000000e+00
 [2,]  1   1.562500 -1.457219e-07
 [3,]  2   3.999999 -9.194792e-07
 [4,]  3  10.562497 -2.909562e-06
 [5,]  4  24.999994 -6.234909e-06
 [6,]  5  52.562489 -1.081970e-05
 [7,]  6  99.999983 -1.659460e-05
 [8,]  7 175.562476 -2.351773e-05
 [9,]  8 288.999968 -3.156520e-05
[10,]  9 451.562459 -4.072316e-05
[11,] 10 675.999949 -5.098329e-05


## Author: Sergio García Prado
## Title: Exercises with Solutions 2

rm(list = ls())

Q <- matrix(c(-20,  20,   0,   0,   0,  0,
               30, -50,  20,   0,   0,  0,
                0,  60, -80,  20,   0,  0,
                0,   0,  60, -80,  20,  0,
                0,   0,   0,  60, -80,  20,
                0,   0,   0,   0,  60, -60),
              6, 6, byrow = TRUE)

(A <- cbind(Q[, 1:(nrow(Q) - 1)], rep(1, nrow(Q))))
# -20	 20	  0	  0	  0	1
#  30	-50	 20	  0	  0	1
#   0	 60	-80	 20	  0	1
#   0	  0	 60	-80	 20	1
#   0	  0	  0	 60	-80	1
#   0	  0	  0	  0	 60	1

## Should be solved via detailed balance equations...
(stationary <- solve(A)[nrow(A), ])
# 0.501030927835052 0.334020618556701 0.111340206185567
# 0.037113402061855 0.012371134020618 0.004123711340206

(r <- -Q / diag(Q))
# -1.0	1.00	0.00	0.00	0.00	0.00
#  0.6 -1.00	0.40	0.00	0.00	0.00
#  0.0  0.75 -1.00	0.25	0.00	0.00
#  0.0	0.00	0.75 -1.00	0.25	0.00
#  0.0	0.00	0.00	0.75 -1.00	0.25
#  0.0	0.00	0.00	0.00	1.00 -1.00

(not.busy <- r[4, 3])
# 0.75


## Stern-Brocot sequence
## 12/19/16 aev
SternBrocot <- function(n){
  V <- 1; k <- n/2;
  for (i in 1:k)
    { V[2*i] = V[i]; V[2*i+1] = V[i] + V[i+1];}
  return(V);
}

## Required tests:
require(pracma);
{
cat(" *** The first 15:",SternBrocot(15),"\n");
cat(" *** The first i@n:","\n");
V=SternBrocot(40);
for (i in 1:10) {j=match(i,V); cat(i,"@",j,",")}
V=SternBrocot(1200);
i=100; j=match(i,V); cat(i,"@",j,"\n");
V=SternBrocot(1000); j=1;
for (i in 2:1000) {j=j*gcd(V[i-1],V[i])}
if(j==1) {cat(" *** All GCDs=1!\n")} else {cat(" *** All GCDs!=1??\n")}
}


n = 100 #100 cards
sample(n)==(1:n) # is a vector of length n, the ith element of which equals 1 if the ith card matches its position in the deck and 0 otherwise
sum(sample(n)==(1:n)) # adds up the elements of the vector, giving us the number of matching cards
res = replicate(10^5,sum(sample(n)==(1:n))) # repeat the experiment 10^5 times, res contains the numbers of matched cards from each run of the experiment
sum(res >= 1)/10^5 # add up the number of times where there was at least one matching card, and we divide by the number of simulations
# you should get 1-1/e~0.63


#conditions
Rosenbrock <- function(x){
    x1 <- x[1]
    x2 <- x[2]
    100 * (x2 - x1 * x1)^2 + (1 - x1)^2
}

Rosenbrock_cap <- function(x){
    if (x[1] + x[2] <= 3){
        r <- Inf
    }else{
        r = Rosenbrock(x)
    }
    return(r)
}

lower <- c(-10,-10)
upper <- -lower

set.seed(1234)
DEoptim::DEoptim(Rosenbrock, lower, upper)
DEoptim::DEoptim(Rosenbrock_cap, lower, upper)

## Rosenbrock Banana function
## The function has a global minimum f(x) = 0 at the point (1,1).
## Note that the vector of parameters to be optimized must be the first
## argument of the objective function passed to DEoptim.
Rosenbrock <- function(x){
  x1 <- x[1]
  x2 <- x[2]
  100 * (x2 - x1 * x1)^2 + (1 - x1)^2
}

## DEoptim searches for minima of the objective function between
## lower and upper bounds on each parameter to be optimized. Therefore
## in the call to DEoptim we specify vectors that comprise the
## lower and upper bounds; these vectors are the same length as the
## parameter vector.
lower <- c(-10,-10)
upper <- -lower

## run DEoptim and set a seed first for replicability
set.seed(1234)
DEoptim(Rosenbrock, lower, upper)

## increase the population size
DEoptim(Rosenbrock, lower, upper, DEoptim.control(NP = 100))

## change other settings and store the output
outDEoptim <- DEoptim(Rosenbrock, lower, upper, DEoptim.control(NP = 80,
                      itermax = 400, F = 1.2, CR = 0.7))

## plot the output
plot(outDEoptim)

## 'Wild' function, global minimum at about -15.81515
Wild <- function(x)
  10 * sin(0.3 * x) * sin(1.3 * x^2) +
      0.00001 * x^4 + 0.2 * x + 80

plot(Wild, -50, 50, n = 1000, main = "'Wild function'")

outDEoptim <- DEoptim(Wild, lower = -50, upper = 50,
                      control = DEoptim.control(trace = FALSE))

plot(outDEoptim)

DEoptim(Wild, lower = -50, upper = 50,
        control = DEoptim.control(NP = 50))

## The below examples shows how the call to DEoptim can be
## parallelized.
## Note that if your objective function requires packages to be
## loaded or has arguments supplied via \code{...}, these should be
## specified using the \code{packages} and \code{parVar} arguments
## in control.

Genrose <- function(x) {
    ## One generalization of the Rosenbrock banana valley function (n parameters)
    n <- length(x)
    ## make it take some time ...
    Sys.sleep(.001)
    1.0 + sum (100 * (x[-n]^2 - x[-1])^2 + (x[-1] - 1)^2)
}

# get some run-time on simple problems
maxIt <- 250
n <- 5

oneCore <- system.time( DEoptim(fn=Genrose, lower=rep(-25, n), upper=rep(25, n),
                  control=list(NP=10*n, itermax=maxIt)))

withParallel <-  system.time( DEoptim(fn=Genrose, lower=rep(-25, n), upper=rep(25, n),
                  control=list(NP=10*n, itermax=maxIt, parallelType=1)))

## Compare timings
(oneCore)
(withParallel)


getTTestSampleSize =
function(x,
         minDetectDiffPercent,
         sigLevel=0.05,
         power=0.8,
         type="two.sample",
         alternative="two.sided") {
    # Get the required sample size for t-test
    # minDetectDiffPercent: Percent increase or decrease from the base mean you want to detect
    # type <- c("two.sample", "one.sample", "paired")
    # alternative <- c("two.sided", "less", "greater")
    # Return: pwr.t.test object with n (sample size) filled
    # Note: pooled standard deviation is approximated by the SD of x
    require(pwr)
    powerAnalysis =
        pwr.t.test(
            d=mean(x) * (minDetectDiffPercent / 100) / sd(x),
            sig.level=sigLevel,
            power=power,
            type=type,
            alternative=alternative)
    return(powerAnalysis)
}

getDetectableDiff <-
function(x,
         sampleSize,
         sigLevel=0.05,
         power=0.8,
         type="two.sample",
         alternative="two.sided") {
    # Get the detectable difference in real scale
    # sampleSize: Sample size in each group
    # type <- c("two.sample", "one.sample", "paired")
    # alternative <- c("two.sided", "less", "greater")
    # Return: pwr.t.test object with n (sample size) filled
    # Note: pooled standard deviation is approximated by the SD of x
    require(pwr)
    powerAnalysis =
        pwr.t.test(
            n=sampleSize,
            sig.level=sigLevel,
            power=power,
            type=type,
            alternative=alternative)
    detectableDiff <- powerAnalysis$d * sd(x)
    return(detectableDiff)
}


# Example : 3.2A   Chapter : 3.2     Page No: 139
# Find the Matrix having the given special solutions
s1<-c(-3,1,0,0)
s2<-c(-2,0,-6,1)
R<-diag(4)
R<-R[-4,]
#As 1st column is pivot column it is not needed to change
#As 3rd column is next pivot column , row reduced echolon form has 1 in second row of third column
R[,3]<-R[,2]
#Two free columns are modified acording to special solutions
R[,2]<-c(-1*s1[1],0,0)
R[,4]<-c(-1*s2[1],-1*s2[3],0)
print("matrix having given special solutions")
print(R)


#!/usr/bin/Rscript
# Copyright © 2016 Martin Ueding <dev@martin-ueding.de>
# Licensed under the MIT license.

orig_pdf = function(x) {
    1 / sqrt(x * (1 - x)) / pi
    # The `return` is not needed, the return value is the last expression which
    # has been evaluated.
}

bin_count = 50
samples_count = 100000

###############################################################################
#                     Method (a): Inverse Function Method                     #
###############################################################################

inverse_cdf = function(u) {
    1 - sin(1/2 * (pi - pi * u))^2
}

# Plot the original function.
x_orig = seq(0, 1, length.out=200)
y_orig = orig_pdf(x_orig)
plot(x_orig, y_orig, type='l', main='Original PDF', xlab='x', ylab='y')

# Plot the inverse function.
u_inv_cdf = seq(0, 1, length.out=100)
x_inv_cdf = inverse_cdf(u_inv_cdf)
plot(u_inv_cdf, x_inv_cdf, type='l', main='Inverse CDF', xlab='u', ylab='x')

# Sample from uniform, transform it and plot a histogram.
start = proc.time()
u = runif(samples_count)
x = inverse_cdf(u)
end = proc.time()
duration_inverse_cdf = end - start
hist(x, breaks=bin_count, freq=FALSE, main='Sampling with Inverse Function Method')
lines(x_orig, y_orig, col='red')

###############################################################################
#                          Method (b): Logistic Map                           #
###############################################################################

logistic_map = function(x) {
    4 * x * (1 - x)
}

iterapply = function(start, func, length) {
    result = numeric(length)
    result[1] = start
    for (i in 2:length) {
        result[i] = func(result[i - 1])
    }
    return(result)
}

x = seq(0, 1, length.out=200)
y = logistic_map(x)
plot(x, y, type='l', main='Logistic Map', xlab='x', ylab='y')

start = proc.time()
iterations = iterapply(pi/4 - 0.1, logistic_map, samples_count)
end = proc.time()
duration_logistic = end - start

plot(iterations[1:1000], main='Successive Applications of the Logistic Map')
hist(iterations, breaks=bin_count, freq=FALSE, main='Sampling with Logistic Map')
lines(x_orig, y_orig, col='red')

###############################################################################
#                          Method (c): Tent Function                          #
###############################################################################

tent = function(x) {
    result = numeric(length(x))
    idx1 = x <= 1/2
    idx2 = x > 1/2
    result[idx1] = 2 * x[idx1]
    result[idx2] = 2 * (1 - x[idx2])
    return(result)
}

x = seq(0, 1, length.out=200)
y = tent(x)
plot(x, y, type='l', main='Tent Function', xlab='x', ylab='y')

start = proc.time()
iterations = iterapply(pi/4 - 0.1, tent, samples_count)
end = proc.time()
duration_tent = end - start

plot(iterations[1:1000], main='Successive Applications of the Tent Function')
hist(iterations, breaks=bin_count, freq=FALSE, main='Sampling with Tent Function')
lines(x_orig, y_orig, col='red')

cat("Times; user, system, wall:\n")
cat("Inverse cdf:  ", duration_inverse_cdf, "\n")
cat("Logistic Map: ", duration_logistic, "\n")
cat("Tent:         ", duration_tent, "\n")


# introduce determinism
set.seed(123)

# global settings
sampleSize <- 100

rollingDiceSum <- function (n=10^3) {
	rowSums(replicate(2, sample(6, n, replace=T)))
}
#plotIt <- function (what) {
#    # barplot(table(factor(what, level=1:12)), xlab="outcome", ylab="abs. probability")
#    barplot(table(what)/sampleSize, col=rgb(0, 0, 0.8, alpha=0.3), xlab="outcome", ylab="rel. probability")
#}

experimentResults <- rollingDiceSum(sampleSize)
barplot(table(experimentResults)/sampleSize, col=rgb(0, 0, 0.8, alpha=0.3), xlab="outcome", ylab="rel. probability")

exactProbabilities <- c(1:6, 5:1)/36 # via Skriptum, Beispiel in section 2.3
barplot(exactProbabilities, col=rgb(0.8, 0.8, 0, alpha=0.3), add=T, xaxt="n", yaxt="n")

# w <- factor(w, level=c(1,2,3,4,5,6,7))


# Example : 1   Chapter : 2.7   Pageno : 108
# Inverses and Transposes
A<-matrix(c(1,6,0,1),ncol=2)
AT<-t(A)
A1<-solve(A)
print("The inverse and transpose of the matrix are ")
print(A1)
print(AT)
print("Transpose of A-1 is ")
print(t(A1))
print("Invere of A transpose is")
print(solve(AT))


# ......................................................................................
# .....................Cvičení 1 - Stručný úvod do R, Kombinatorika.....................
# ..................Adéla Vrtková, Michal Béreš, Martina Litschmannová..................
# ......................................................................................

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

# Nejprve si projdeme některé základy Rka a naimplementujeme si některé kombinatorické
# funkce.
#
#  Krátký úvod do R ####

# jednoduché početní operace
2+4
5/2

# POZOR na závorky! Pro počítání se používají pouze kulaté!
# Hranaté a složené mají v R jinou funkci!
(((10+2)*(340-33))-2)/3

# kombinační číslo, faktoriály
choose(10,2)
factorial(4)

# datové typy -> numeric, character, logical, (complex)
# funkcí class zjišťujeme typ objektu
a=2+3
class(a)

b="pismenko"
class(b)

c=(1>3)
class(c)

d=3+1i
class(d)

# * datové struktury v R ####
#
# - vector (rozumíme sloupcový vektor)
# - factor (speciální případ vektoru)
# - matrix (matice s rozměry n x m)
# - data.frame (datový rámec s rozměry n x p)
# - list (seznam)

# definování vektoru (sloupcový=column)
a = c(3,4,6,7)
a <- c(3,4,6,7)
a[2]

# další možnosti
rep(1,4) # vytvoří vektor se čtyřmi jedničkami

seq(1,10,2) #posloupnost od 1 do 10 s krokem 2

1:10  #posloupnost od 1 do 10 s krokem 1

b=c("A","B","C","D")
b

class(b)

#předefinování objektu na jiný typ - např. as.vector, as.matrix, as.factor,...
b=as.factor(b)
b

#práce s vektory - slučování podle sloupců/řádků
cbind(a,b)

rbind(a,b)

c(a,b)

## definování matice
A=matrix(c(3,4,6,7,3,2),nrow=2,ncol=3)
B=matrix(c(3,4,6,7,3,2),nrow=2,ncol=3,byrow=TRUE)
C=matrix(c(3,4,6,7,3,2),nrow=3,ncol=2)

B

B[1,3]

A[1,]

A[,2:3]

#diagonální matice
diag(4)

diag(4,2)

## operace s maticemi - pozor na maticové násobení -> %*%
A+B

A-B

A*B

A%*%C

# ......................................................................................
#
#  Kombinatorika ####
#
# * Variace ####
#
# V(n,k) - variace bez opakování, první argument bude celkový počet entit, druhý
# argument velikost výběru

# funkce se vytváří příkazem fucntion, je to objekt jehož jméno je dáno až proměnnou
# do které tento objekt přiřadím
variace = function(n,k) # zde zadávám počet parametrů a jejich jména
{ # celé tělo funkce je uzavřeno mezi závorkami {...}
    citatel = factorial(n)  # faktoriál v originálním Rku existuje tak jej použijeme
    jmenovatel = factorial(n-k)
    return(citatel/jmenovatel)    # to co funkce vrátí se dává do příkazu return(...)
}

# V*(n,k) - variace s opakováním

variace_opak = function(n,k)
{
  return(n^k)
}

# * Permutace ####
#
# P(n)=V(n,n) - permutace

permutace = function(n)
{
  return(variace(n,n))
}

# P*(n1,n2,n3,....,nk) - permutace s opakováním, vstup bude vektor s jednotlivými počty
# unikátních entit

permutace_opak = function(vec_n) # vec_n je vektro počtů hodnot př.: vec_n = c(2,2,2,4,3)
{
    n = sum(vec_n) # spočteme kolik máme hodnot celkem
    res_temp=factorial(n) #jejich faktoriál = hodnota v čitateli
    # jednoduchý cyklus začíná příkazem for, pak v závorkách následuje název iterátoru
    # a z jakého seznamu bude brán
    for(pocet in vec_n) # pocet je iterátor a postupně bude nabývat hodnot z vektoru vec_n
    {
        # postupně dělíme faktoriálem každého počtu unikátních entit
        res_temp=res_temp/factorial(pocet)
    }
    return(res_temp)
}

# * Kombinace ####
#
# C(n,k) - kombinace

kombinace = function(n,k)
{
  return(choose(n,k)) # funkce for kombinace už existuje v Rku a jmenuje se choose
}

# C*(n,k) - kombinace s opakováním

kombinace_opak = function(n,k)
{
  return(choose(n+k-1,k)) # použijeme známý vzorec
}

#  Úlohy na cvičení ####
#
# * Příklad 1. ####
#
# Které heslo je bezpečnější?
# * Heslo o délce osm znaků složené pouze z číslic.
# * Heslo o délce pět znaků složené pouze z písmen anglické abecedy.

# heslo 1
h1 = variace_opak(n = 10, k = 8)
# heslo 2
h2 = variace_opak(n = 26, k = 5)
h1/h2

# * Příklad 2. ####
#
# Jak dlouho by trvalo vyřešení problému obchodního cestujícího pro n = 10 měst hrubou
# silou, jestliže vyhodnocení délky každé z možných cest trvá 1 µs?

n = 10
pocet = permutace(n-1)/2
cas = pocet/1000000
cas

# * Příklad 3. ####
#
# Jak rozdělit kořist mezi 2 loupežníky, aby dostali oba věci ve stejné hodnotě
# (případně co nejbližší hodnotě). Tj. lze rozdělit N zadaných čísel do dvou skupin tak,
# aby součet čísel v obou skupinách byl stejný?
#
# **Kolik možností by bylo třeba vyzkoušet, pokud bychom úlohu řešili hrubou silou?**

N = 10
L = 4
variace_opak(n = L, k = N)

# * Příklad 4. ####
#
# Kolik anagramů slova "AUTO" můžeme vytvořit?
#
# Kolik anagramů slova "AUTOMOBILKA" můžeme vytvořit? Kolik z nich začína na "K"?

permutace(4)
vec = c(2,1,1,2,1,1,1,1,1)
sum(vec)
permutace_opak(vec)

vec = c(2,1,1,2,1,1,1,1)
sum(vec)
permutace_opak(vec)

# * Příklad 5.  ####
#
# V obchodě mají 6 druhů barevných hrníčků.
# - Kolika různými způsoby můžeme koupit 4 různě-barevné hrníčky?
# - Kolika různými možnostmi můžeme nakoupit 5 hrníčků (pokud nám nevadí více od stejné
# barvy)?
# - Jak se situace změní, pokud budou mít od každého pouze 4 kusy (a nám nevadí více
# stejné barvy)?

kombinace(6,4)
kombinace_opak(6,5)
kombinace_opak(6,5) - 6

# * Příklad 6. (sbírka kap. 1, př. 7,8) ####
#
# Z urny se třemi koulemi, dvěma červenými a jednou bílou, budou současně vybrány dvě
# koule.
# Student a učitel uzavřou sázku. Pokud budou obě koule stejné barvy, vyhraje student.
# Pokud
# budou mít koule různou barvu, vyhraje učitel.
# - Je hra férová? Jaké jsou pravděpodobnosti výhry učitele a studenta?
# - Jakou kouli je třeba přidat, aby hra byla férová?

kombinace(3,2)
kombinace(4,2)

# * Příklad 7. ####
#
# V balíčku je 5 různých párů ponožek (levá a pravá ponožka je vždy stejná).
# - Kolik různých dvojic ponožek lze vybrat?
# - Kolika různými způsoby se mohu obout? (tj. záleží na tom co je na které noze)

kombinace_opak(n = 5,k = 2)
variace_opak(n=5,k=2)
kombinace_opak(n = 5,k = 2)*2 - 5

# * Příklad 8. ####
#
#
# Mám 12 závaží o hmotnostech 1,2,...,12 kg.
# - Kolika způsoby je mohu rozdělit na 2 hromádky?
# - Kolika způsoby je mohu rozdělit na 3 hromádky?
# - Kolika způsoby je mohu rozdělit na 3 hromádky, má-li na všech být stejný počet
# závaží?
# - Kolika způsoby je mohu rozdělit na 3 hromádky o stejném počtu závaží, pokud hmotnost
# žádné z nich nesmí překročit 40 kg?

variace_opak(2,12)
variace_opak(3,12)
(variace_opak(3,12)-3)/permutace(3)+1
(variace_opak(3,12)-(variace_opak(2,12)-2)*3-3)/permutace(3)
kombinace(12,4)*kombinace(8,4)/permutace(3)
permutace(12)/(permutace(4)*permutace(4)*permutace(4)*permutace(3))
kombinace(12,4)*kombinace(8,4)/permutace(3)-kombinace(8,4)

# * Příklad 9. ####
#
# Mám 20 semínek od každého ze tří druhů zeleniny (mrkev, ředkvička, celer). Bohužel se
# pomíchala.
# - Do truhlíku zasadím 5 náhodných semínek. Jaká je pravděpodobnost, že mezi nimi budou
# alespoň tři ředkvičky?
# - Do truhlíku zasadím 5 náhodných semínek. Jaká je pravděpodobnost, že mezi nimi bude
# více mrkví než celerů?

(kombinace(20,3)*kombinace(40,2)+kombinace(20,4)*kombinace(40,1)+
   kombinace(20,5))/kombinace(60,5)


#' Two-sample t-test power calculation
#'
#' @param m1 Mean of a group 1 (e.g., the control-group)
#' @param m2 Mean of a group 2 (e.g., the experimental-group)
#' @param n1 Number of obs. in group 1 (e.g., the control-group)
#' @param n2 Number of obs. in group 2 (e.g., the control-group)
#' @param nratio Ratio of sample sizes, group 2 to group 1; default is nratio = 1, meaning equal group sizes
#' @param sd Standard deviation of each group, i.e., sd = sd1 = sd2
#' @param sd1 Standard deviation of a group 1 (e.g., the control group)
#' @param sd2 Standard deviation of a group 2 (e.g., the experimental group)
#' @param sig.level significance level; default is sig.level = 0.05
#' @param power one minus the probability of type II error; default is power = 0.8
#' @return Returns an object with all the study parameters
#' @export
#' @importFrom stats qnorm
#' @examples
#' twomeans(m1 = 12, m2 = 16, sd = 5)
twomeans <- function(m1        = NULL,
                     m2        = NULL,
                     n1        = NULL,
                     n2        = NULL,
                     nratio    = NULL,
                     sd        = NULL,
                     sd1       = NULL,
                     sd2       = NULL,
                     sig.level = 0.05,
                     power     = 0.80) {

    # Validate function
    .check.twomeans(m1,
                    m2,
                    n1,
                    n2,
                    nratio,
                    sd,
                    sd1,
                    sd2,
                    sig.level,
                    power)

    # Specify ratio
    if(is.null(nratio)) {
        nratio = 1
    }

    # Plug in sd (and sd1/sd2)
    if(!is.null(sd)) {
        sd1 = sd
        sd2 = sd
    }

    beta = 1 - power

    n1 <- (sd1^2 + (sd2^2) / nratio) *
          (qnorm(1 - sig.level / 2) + qnorm(1 - beta))^2 / ((m1 - m2)^2)

    n2 <- nratio * n1

    # Round the n's
    n1 <- ceiling(n1)
    n2 <- ceiling(n2)

    METHOD = "Two-sample t-test power calculation"
    NOTE   = paste("",
                   "m1 and m2 are the means of group 1 and 2, respectively.",
                   "n1 and n2 are the obs. of group 1 and 2, respectively.",
                   sep = "\r\n")

    structure(list(m1          = m1,
                   m2          = m2,
                   n1          = n1,
                   n2          = n2,
                   sig.level   = sig.level,
                   power       = power,
                   alternative = "two.sided",
                   method      = METHOD,
                   note        = NOTE),
                   class       = "power.htest")

}

.check.twomeans <- function(m1, m2, n1, n2, nratio, sd, sd1, sd2, sig.level, power) {

    # Non-negative standard deviation
    if(any(sd <= 0, sd1 <= 0, sd2 <= 0)) {
        stop("sd must be positive")
    }

    # Non-negative observations
    if(any(n1 <= 0, n2 <= 0, nratio <= 0)) {
        stop("n1, n2, and nratio must be positive")
    }

    # alpha and power must fall within the interval [0, 1]
    if(any(sig.level < 0, sig.level > 1, power < 0, power > 1)) {
        stop("sig.level and power must fall between 0 and 1")
    }

    # Means can't be equal
    if(m1 == m2) {
        stop("m1 and m2 cannot be equal")
    }

    # Can't specify sd and (sd1 and sd2)
    if(is.null(sd)) {
        if(any(is.null(sd1), is.null(sd2))) {
            stop("must specific either just sd or sd1 and sd2")
        }
    } else {
        if(any(!is.null(sd1), !is.null(sd2))) {
            stop("must specific either just sd or sd1 and sd2")
        }
    }
}


library(tidyverse)
library(dplyr)

setwd("/Users/naoki_atkins/Documents/Code/Classwork/dataScience/hw7")
load("myvec.RData")

acf(myvec, lag.max = 100)

my_ts <- ts(myvec, frequency = 50)
decomp <- decompose(my_ts)

plot(decomp)

# Question 3a.

dtw <- function (A, B) {
  M <- nrow(A)
  N <- nrow(B)
  Cost <- matrix(0,M,N) # Initialize with zeros
  # compute cost and fill in the matrix
  for (i in 1:M) {
    for (j in 1:N) {
      Cost[i,j] <- as.numeric((A[i,1] - B[j,1])^2 + (A[i,2] - B[j,2])^2) # distance function
    }
  }
  C <- matrix(0,M,N) # Initialize with zeros
  C[1,1] <- Cost[1,1] # Initialize top left cell
  for (i in 2:M) { # Initialize first column
    C[i,1] <- C[i-1,1] + Cost[i,1]
  }
  for (j in 2:N) { # Initialize first row
    C[1,j] <- C[1,j-1] + Cost[1,j]
  }

  # Fill in everything besides the first column and first row
  # Evaluate 3 neighbors (above, left-above, left)
  # Pick the smallest
  # Add the smallest value to ...
  # Fill in the matrix with that computed value
  for(i in 2:M) {
    for(j in 2:N) {
      C[i,j] <- min(C[i-1, j], C[i, j-1], C[i-1, j-1]) + Cost[i,j]
    }
  }
  return (C[M,N])
}

# Question 3b.
A.x <- c(2, 0, 2, 4, 5)
A.y <- c(2, 4, 6, 5, 2)

A <- matrix(data = c(A.x, A.y), nrow = 5)

B.x <- c(1, 0, 4, 5)
B.y <- c(1, 6, 4, 1)

B <- matrix(data = c(B.x, B.y), nrow = 4)

dtw(A, B)

# Question 4

tsX <- read_csv("tsX.csv")
ts2 <- read_csv("ts2.csv")
ts3 <- read_csv("ts3.csv")
ts4 <- read_csv("ts4.csv")
ts5 <- read_csv("ts5.csv")

# 44116.78
dtw(tsX, ts2)
# 18583.75
dtw(tsX, ts3)
# 13293.01
dtw(tsX, ts4)
# 3192.354
dtw(tsX, ts5)

tsX %>%
  ggplot(aes(tsX$x, tsX$y)) +
  geom_path()

ts2 %>%
  ggplot(aes(ts2$x, ts2$y)) +
  geom_path()

ts3 %>%
  ggplot(aes(ts3$x, ts3$y)) +
  geom_path()

ts4 %>%
  ggplot(aes(ts4$x, ts4$y)) +
  geom_path()

ts5 %>%
  ggplot(aes(ts5$x, ts5$y)) +
  geom_path()


# PSI function
# Reference: P395, Credit risk analytics - Measurement technique, applications and examples
# Rules of thumb
# PSI < 0.10: no significant shift (green traffic light)
# 0.10 ≤ PSI < 0.25: moderate shift (yellow traffic light)
# PSI ≥ 0.25: significant shift (red traffic light)
library(tidyverse)

# Hàm tính PSI cho từng biến

psi <- function(actual, expected){

  tbl <- list(actual = actual, expected = expected) %>%
    # map(factor, levels = lbl, labels = lbl) %>%
    map(table) %>%
    map(prop.table) %>%
    map(as.data.frame, stringsAsFactors=FALSE) %>%
    reduce(full_join, by = "Var1") %>%
    mutate(sub_psi = (Freq.x-Freq.y)*(log(Freq.x)-log(Freq.y))) %>%
    mutate(psi = sum(sub_psi)) %>%
    select(Range = Var1,
           Trainning = Freq.y,
           Actual = Freq.x,
           psi) %>%
    mutate(Trainning = paste0(round(Trainning * 100, 1), "%"),
           Actual = paste0(round(Actual * 100, 1), "%"),
           psi = round(psi, 3),
           tag = case_when(psi < 0.1 ~ "green",
                           psi < 0.25 ~ "yellow",
                           TRUE ~ "red"))

  return(tbl)
}

# Hàm tính PSI cho cả bộ dữ liệu
psi_df <- function(dat_train, dat_test, var_skip = NULL){
  same_name <- names(dat_test) %>%
    intersect(names(dat_train)) %>%
    setdiff(var_skip)

  sl <- function(x){
    psi(expected = dat_train[[x]], actual = dat_test[[x]]) %>% return()
  }

  same_name %>%
    set_names(same_name) %>%
    map_dfr(sl, .id = "Variables") %>%
    return()

}


# Barometric formula
# https://en.wikipedia.org/wiki/Barometric_formula
# Ideal law: P = rho * R/M * T
# See also:
# * https://physics.stackexchange.com/questions/532903/air-pressure-dependence-on-temperature
# * https://en.wikipedia.org/wiki/Density_of_air

g0 <- 9.80665 # m/s2 -- gravitational acceleration
R <- 8.3144598 # J/(mol·K) -- universal gas constant
M <- 0.0289644 # kg/mol -- molar mass of Earth's air
M_v <- 0.018016 # kg/mol -- molar mass of water vapor

# Constants taken from Barometric formula
# https://en.wikipedia.org/wiki/Barometric_formula
# for altitude between 0 and 11 km.

h_b <- 0 # m
P_b <- 101325.00 # Pa
T_b <- 288.15 # K
L_b <- -0.0065 # K/m
rho_b <- 1.2250 # kg/m3

# This function computes the pressure in function of altitude.
# LR stands for lapse rate: the drop in temperature in function of altitude is
# here taken into consideration. For altitude between 0 and 11 km, the drop
# in temperature is taken as a linear function: T = T_b + L_b*h.
# See: https://en.wikipedia.org/wiki/Barometric_formula#Derivation
# Other assumption here is that the air pressure is hydrostatic (i.e. "fluid" is not moving).
P.lr <- function(h.meters) {
  base <- T_b / (T_b + L_b * (h.meters - h_b))
  exp <- g0 * M / (R * L_b)
  P_b * base^exp
}

P.lr(10)

# PRESSURE
# Here I define a few pressure conversion functions.

P.cmH2O_to_Pa <- gwloggeR.data:::P.cmH2O_to_Pa

P.Pa_to_cmH2O <- gwloggeR.data:::P.Pa_to_cmH2O

P.Pa_to_cmH2O(P.lr(0))
P.Pa_to_cmH2O(P.lr(100))

# Conclusion here is that the drop in air pressure is expected to drop per 100 m:
P.Pa_to_cmH2O(P.lr(0)) - P.Pa_to_cmH2O(P.lr(100))

curve(P.Pa_to_cmH2O(P.lr(x)), xlim = c(0, 11000), xlab = 'Altitude (m)', ylab = 'Air pressure (cmH2O)')

# DENSITY
# This is the same as P.lr, but for the density.
# Not important I think.

# rho.lr <- function(h.meters) {
#   base <- T_b / (T_b + L_b * (h.meters - h_b))
#   exp <- 1 + g0 * M / (R * L_b)
#   rho_b * base^exp
# }
#
# rho.lr(0)
# rho.lr(100)
#
# curve(rho.lr(x), xlim = c(0, 11000))

# TEMPERATURE EFFECT

# This is a very naive calculation of temperature effect based on the ideal law
# because the density of air is assumed not to change in function of temperature.
P.Pa_to_cmH2O(rho_b*R/M*(T_b + 1) - rho_b*R/M*T_b)

## TEMPERATURE EFFECT ON DENSITY OF DRY AIR

# Here we focus on the following:
# https://en.wikipedia.org/wiki/Density_of_air

# This function computes the density (rho) of air based on the assumption of
# dry air.
rho_da <- function(temp.K) {
  P_b*M/(R*temp.K)
}

rho_da(T_b)
rho_da(15 + 273.15) # 15 °C
rho_da(20 + 273.15)

# Less naive calculation of temperature effect assuming dry air.
P.Pa_to_cmH2O(rho_da(T_b + 1)*R/M*(T_b + 1) - rho_da(T_b)*R/M*T_b)

## TEMPERATURE EFFECT ON DENSITY OF HUMID AIR

# Saturation vapor pressure
# See: https://en.wikipedia.org/wiki/Vapour_pressure_of_water
# The Buck equation is the best one.

P_sat.Pa <- function(temp.K, type = c('Buck', 'Tetens')) {
  type <- match.arg(type)
  temp.C <- temp.K - 273.15
  switch (type,
    'Buck' = 0.61121*exp( (18.678 - temp.C/234.5)*(temp.C/(257.14 + temp.C)) ),
    'Tetens' = 0.61078*exp(17.2*temp.C/(temp.C + 237.3))
  )
}

P_sat.Pa(T_b)
P_sat.Pa(T_b, type = 'Tetens')

# This function computes the density (rho) of air based on the assumption of
# humid air.

rho_ha <- function(temp.K, humidity.perc) {
  P_v <- humidity.perc/100 * P_sat.Pa(temp.K)
  P_d <- P_b - P_v

  (P_d*M + P_v*M_v)/(R*temp.K)
}

rho_da(T_b)
rho_ha(T_b, 0)
rho_ha(T_b, 100)

# Less naive calculation of temperature effect assuming humid air.
P.Pa_to_cmH2O(rho_ha(T_b + 1, 90)*R/M*(T_b + 1) - rho_ha(T_b, 90)*R/M*T_b)

# HUMIDITY
# The bulge during non-summer can not be explained by drop in air pressure density.
# https://nl.wikipedia.org/wiki/Relatieve_luchtvochtigheid#Relatieve_luchtvochtigheid_en_klimaat
P.Pa_to_cmH2O(rho_ha(T_b, 75)*R/M*T_b - rho_ha(T_b, 90)*R/M*T_b)


=begin
  # sample-geometry01.rb

  require 'algebra'
  R = MPolynomial(Rational)
  x,y,a1,a2,b1,b2,c1,c2 = R.vars('xya1a2b1b2c1c2')

  V = Vector(R, 2)
  X, A, B, C = V[x,y], V[a1,a2], V[b1,b2], V[c1,c2]

  D = (B + C) /2
  E = (C + A) /2
  F = (A + B) /2

  def line(p1, p2, p3)
    SquareMatrix.det([[1, *p1], [1, *p2], [1, *p3]])
  end

  l1 = line(X, A, D)
  l2 = line(X, B, E)
  l3 = line(X, C, F)
  s = line(A, B, C)

  g = Groebner.basis [l1, l2, l3, s-1] #s-1 means non degeneracy

  g.each_with_index do |f, i|
    p f
  end
  #x - 1/3a1 - 1/3b1 - 1/3c1
  #y - 1/3a2 - 1/3b2 - 1/3c2
  #a1b2 - a1c2 - a2b1 + a2c1 + b1c2 - b2c1 - 1
((<_|CONTENTS>))
=end


#autor:      Joao Sollari Lopes
#local:      INE, Lisboa
#Rversion:   3.6.1
#criado:     02.07.2017
#modificado: 06.12.2019

library("e1071")

##1. Linear SVM Classifier
#[adapted from https://www.datacamp.com/community/tutorials/support-vector-machines-r]
set.seed(12345)
n1 <- 10
y1 <- rnorm(n1,mean=0,sd=1)
x1 <- rnorm(n1,mean=0,sd=1)
n2 <- 10
y2 <- rnorm(n2,mean=0,sd=1) + 1
x2 <- rnorm(n2,mean=0,sd=1) + 1

dat1 <- data.frame(stringsAsFactors=FALSE,
  y=c(y1,y2),
  x=c(x1,x2),
  grp=c(rep("blue",n1),rep("red",n2)))

fnam <- "../images/svm_1.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
par(mar=c(3,2.5,1.5,0.5),mgp=c(1.7,0.7,0),cex=0.8)
with(dat1,plot(x,y,col=grp,pch=19))
dev.off()

modfit <- svm(grp ~ .,
              dat1,
              scale=FALSE,             #scaling stored for testing
              type="C-classification", #SVM algorithm
              kernel="linear",         #kernel type
              cost=1.0,                #C-constant (cost)
              tolerance=0.001)         #convergence epsilon

#beta_0 + beta_1*x + beta_2*y = 0
#y = -(beta_1/beta_2)*x - (beta_0/beta_2)
beta_0 = -modfit$rho
beta_1 = t(modfit$coefs)%*%dat1$x[modfit$index]
beta_2 = t(modfit$coefs)%*%dat1$y[modfit$index]

grid1 <- expand.grid(
  x = seq(min(dat1$x),max(dat1$x),length=100),
  y = seq(min(dat1$y),max(dat1$y),length=100))
grid1$grp <- as.character(predict(modfit,grid1))

fnam <- "../images/svm_2.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
par(mar=c(3,2.5,1.5,0.5),mgp=c(1.7,0.7,0),cex=0.8)
with(grid1,plot(x,y,col=grp,pch=19,cex=0.2))
with(dat1,points(x,y,col=grp,pch=19))
abline(a=-beta_0/beta_2,b=-beta_1/beta_2)
dev.off()

##2. Non-linear SVM Classifier
set.seed(12345)
n1 <- 30
rad1 <- sqrt(runif(n1,1,2))
the1 <- runif(n1,0,2*pi)
x1 <- rad1*cos(the1)
y1 <- rad1*sin(the1)
n2 <- 30
rad2 <- sqrt(runif(n2,0,1))
the2 <- runif(n2,0,2*pi)
x2 <- rad2*cos(the2)
y2 <- rad2*sin(the2)

dat1 <- data.frame(stringsAsFactors=FALSE,
  x=c(x1,x2),
  y=c(y1,y2),
  grp=c(rep("blue",n1),rep("red",n2)))

fnam <- "../images/svm_3.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
par(mar=c(3.0,3.0,1.5,1.5),mgp=c(1.7,0.7,0),cex=0.8)
with(dat1,plot(x,y,col=grp,pch=19))
dev.off()

dat1$z <- dat1$x^2 + dat1$y^2

fnam <- "../images/svm_4.tiff"
tiff(file=fnam,units="in",width=8,height=4,res=300,compression="lzw")
par(mfcol=c(1,2),mar=c(3,2.5,1.5,0.5),mgp=c(1.7,0.7,0),cex=0.8)
with(dat1,plot(x,z,col=grp,pch=19))
with(dat1,plot(y,z,col=grp,pch=19))
dev.off()

fnam <- "../images/svm_5.tiff"
tiff(file=fnam,units="in",width=8,height=4,res=300,compression="lzw")
par(mfcol=c(1,2),mar=c(3,2.5,1.5,0.5),mgp=c(1.7,0.7,0),cex=0.8)
with(dat1,plot(x,z,col=grp,pch=19))
abline(h=1)
with(dat1,plot(y,z,col=grp,pch=19))
abline(h=1)
dev.off()

fnam <- "../images/svm_6.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
par(mar=c(3.0,3.0,1.5,1.5),mgp=c(1.7,0.7,0),cex=0.8)
with(dat1,plot(x,y,col=grp,pch=19))
radius <- 1
theta <- seq(0,2*pi,length=200)
lines(x=radius*cos(theta),y=radius*sin(theta))
dev.off()

modfit <- svm(grp ~ x + y,
              dat1,
              scale=FALSE,             #scaling stored for testing
              type="C-classification", #SVM algorithm
              kernel="radial",         #kernel type
              gamma=0.5,               #kernel gamma
              cost=1.0,                #C-constant (cost)
              tolerance=0.001,         #convergence epsilon
              epsilon=0.1)             #loss-function epsilon

grid1 <- expand.grid(
  x = seq(min(dat1$x),max(dat1$x),length=100),
  y = seq(min(dat1$y),max(dat1$y),length=100))
grid1$grp <- as.character(predict(modfit,grid1))

fnam <- "../images/svm_7.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
par(mar=c(3.0,3.0,1.5,1.5),mgp=c(1.7,0.7,0),cex=0.8)
with(grid1,plot(x,y,col=grp,pch=19,cex=0.2))
with(dat1,points(x,y,col=grp,pch=19))
radius <- 1
theta <- seq(0,2*pi,length=200)
lines(x=radius*cos(theta),y=radius*sin(theta))
dev.off()

##3. Linear SVM Regression

## 2. Model Fitting
set.seed(12345)

real_a1 <- 1.5
real_a2 <- 4
x <- runif(n=30,min=0,max=10)
y <- real_a1*x + real_a2 + rnorm(n=30,mean=0,sd=1)
dat1 <- data.frame(x,y)

fnam <- "../images/svm_7.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
par(mar=c(3,2.5,1.5,0.5),mgp=c(1.7,0.7,0),cex=0.8)
with(dat1,plot(x,y,pch=19))
dev.off()

modfit <- svm(y ~ x,
              dat1,
              scale=FALSE,           #scaling stored for testing
              type="eps-regression", #SVM algorithm
              kernel="linear",       #kernel type
              tolerance=0.001,       #convergence epsilon
              epsilon=0.5)           #loss-function epsilon

#y = beta_1*x + beta_0
beta_0 = -modfit$rho
beta_1 = t(modfit$coefs)%*%dat1$x[modfit$index]

fnam <- "../images/svm_8.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
par(mar=c(3,2.5,1.5,0.5),mgp=c(1.7,0.7,0),cex=0.8)
with(dat1,plot(x,y,pch=19))
abline(a=beta_0,b=beta_1,col="blue")
abline(a=beta_0 - 0.5,b=beta_1,lty=2,col="blue")
abline(a=beta_0 + 0.5,b=beta_1,lty=2,col="blue")
dev.off()

lmfit <- lm(y ~ x,data=dat1)
a1 <- lmfit$coef[1]
a2 <- lmfit$coef[2]

fnam <- "../images/svm_9.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
par(mar=c(3,2.5,1.5,0.5),mgp=c(1.7,0.7,0),cex=0.8)
with(dat1,plot(x,y,pch=19))
abline(a=a1,b=a2,lwd=2,col="red")
abline(a=beta_0,b=beta_1,col="blue")
abline(a=beta_0 - 0.5,b=beta_1,lty=2,col="blue")
abline(a=beta_0 + 0.5,b=beta_1,lty=2,col="blue")
dev.off()


#------------------#
# Forecasting
#------------------#
rm(list=ls(all.names=TRUE))
#------------------#
library(dplyr)
library(tidyr)
install.packages("skimr")
library(skimr)
library(stats)
library(MASS)
library(ggplot2)
#------------------#
#-------------------------#
# Load data
#-------------------------#
dm <- readr::read_csv("demand_data.txt")

# Add time trend
dm <- dm %>%
  mutate(t = row_number()) %>%
  as_tibble()

# Descriptives
summary(dm)
skim(dm)
head(dm, 5)

#-------------------------#
# Visualize
#-------------------------#
hist(dm$demand)

dm %>%
  ggplot(aes(x = demand)) +
  geom_histogram()

dm %>%
  ggplot(aes(x = t, y = demand)) +
  geom_line()
#-------------------------#
# Setting
#-------------------------#
#The price is $4, the unit cost is $0.80, and the salvage value is $0.
price <- 4
cost <- 0.8
salvage <- 0

# What we know
sl<-(price - cost) / (price - salvage) # target service level
optimal_order_quantity <- as.integer(quantile(dm$demand, sl))

# Splitting the sample
dm1 <- dm[1:100,]
dm2 <- dm[101:300,] # forecast, calculate forecasting_error
dm3 <- dm[301:500,]

# Make table for summary
res_table <- data.frame(
  method = c("wo prediction",
             "moving average",
             "simple_exp_wo_tuning", "simple_exp_w_tuning",
             "holt_wo_tuning", "holt_w_tuning"),
  AvgProf = rep(0, 6)
)

dm3 %>%
  ggplot(aes(x = demand)) +
  geom_histogram()

#-------------------------#
# Find the optimal quantity using simulation with the full data
# (we can save time by using optimization methods)
#-------------------------#

# Prepare grid
stocking <- c(min(dm$demand):max(dm$demand))

# Calculate
profit <- matrix(0, nrow = nrow(dm), ncol = length(stocking))
for (i in 1:length(stocking)) { # loop for each stocking level
  q <- stocking[i]

  for (j in 1:nrow(dm)) { # loop for each realized demand
    profit[j,i] <- price * min(q, dm$demand[j]) + salvage * max(q - dm$demand[j], 0) - cost * q
  }
}
# make summary table
summary_table <- data.frame(
  stocking = stocking,
  AvgProf = apply(profit, 2, mean), # column means
  StdProf = apply(profit, 2, sd) # column sd
)
summary_table %>%
  as_tibble() %>%
  arrange(desc(AvgProf)) %>%
  head(1)

# This is going to be the (approx.) same as the following value
quantile(dm$demand, 0.80)

optimal_profit <- max(summary_table$AvgProf)
optimal_profit

optimal_stocking <- summary_table %>%
  as_tibble() %>%
  arrange(desc(AvgProf)) %>%
  head(1) %>%
  dplyr::select(stocking)
optimal_stocking

# Again, this value is going to be the (approx.) same as the following calculation
mean(price * pmin(optimal_order_quantity, dm$demand) - cost * optimal_order_quantity)

# Value of an oracle
(price - cost) * mean(dm$demand) - optimal_profit

# Safety Stock
safety_stock <- optimal_stocking - mean(dm$demand)
print(safety_stock)

#-------------------------#
# Find the optimal quantity using simulation only for df3
# (we can save time by using optimization methods)
#-------------------------#
# Prepare grid
stocking <- c(min(dm3$demand):max(dm3$demand))
# Calculate
profit <- matrix(0, nrow = nrow(dm3), ncol = length(stocking))
for (i in 1:length(stocking)) { # loop for each stocking level
  q <- stocking[i]

  for (j in 1:nrow(dm3)) { # loop for each realized demand
    profit[j,i] <- price * min(q, dm3$demand[j]) + salvage * max(q - dm3$demand[j], 0) - cost * q
  }
}
# make summary table
summary_table <- data.frame(
  stocking = stocking,
  AvgProf = apply(profit, 2, mean), # column means
  StdProf = apply(profit, 2, sd) # column sd
)
summary_table %>%
  as_tibble() %>%
  arrange(desc(AvgProf)) %>%
  head(1)

# This is going to be the (approx.) same as the following value
quantile(dm3$demand, 0.80)

optimal_profit <- max(summary_table$AvgProf)
optimal_profit

optimal_stocking <- summary_table %>%
  as_tibble() %>%
  arrange(desc(AvgProf)) %>%
  head(1) %>%
  dplyr::select(stocking) %>%
  as.numeric()

# Again, this value is going to be the (approx.) same as the following calculation
res_table$AvgProf[1] <- mean(price * pmin(optimal_stocking, dm3$demand) - cost * optimal_stocking)

# Value of an oracle
(price - cost) * mean(dm3$demand) - optimal_profit

# Safety Stock
safety_stock <- optimal_stocking - mean(dm3$demand)
print(safety_stock)

#---------------------------------------------------------------------------#
# Forecasting
#---------------------------------------------------------------------------#
# forecast for 301  --> use moving average, e.g., (D[300]+D[299]+D[298]+D[297])/4
# then, at day 301, what should be the stocking level?
# it would be: forecast + safety stock.
# then, what is the safety stock?
# Need to forecast forecasting errors:
# Forecast forecast error distribution using the forecast error from day 101 to 300
# Now, knowing the forecast error distribution --> Take the 80th percentile of the forecast error distribution.
# then: stocking = forecast + 80th_percentile of forecast_error

#-------------------------#
# method 1. moving average
#-------------------------#
# Forecast demand of df2 using df1
forecast <- c()
for (i in 1:nrow(dm2)) {
  # forecast by the last four days
  last_four_values <- c(dm$demand[(100+i-1)-3], dm$demand[(100+i-1)-2], dm$demand[(100+i-1)-1], dm$demand[(100+i-1)-0])
  forecast[i] <- mean(last_four_values)
}

# calculate stocking values using predicted forecast error in df2
forecasting_error <- dm2$demand - forecast
hist(forecasting_error)

safety_stock <- quantile(forecasting_error, 0.80)
stocking <- forecast + safety_stock

# for the remaining days 301-- 500: repeat the process
# Note that in this case, forecast changes, but safety stock remains the same
# For the third split sample: we would like to calculate the average daily profit, if we use the moving average forecasting method
forecast_301_500 <- c()
for (i in 1:nrow(dm3)) {
  # forecast by the last four days
  last_four_values <- c(dm$demand[(300+i-1)-3], dm$demand[(300+i-1)-2], dm$demand[(300+i-1)-1], dm$demand[(300+i-1)-0])
  forecast_301_500[i] <- mean(last_four_values)
}

stocking_301_500 <- forecast_301_500 + safety_stock # we use safety_stock obtained from df2

# Average profit
res_table$AvgProf[2] <- mean(price * pmin(stocking_301_500, dm3$demand) + salvage * pmax(stocking_301_500 - dm3$demand, 0) - cost * stocking_301_500)

# Oracle
(price - cost) * mean(dm3$demand)

#-------------------------#
# method 2. simple exponential smoothing
# It starts from week 101
#-------------------------#
# start from arbitrary number
alpha = 0.2

forecast_101_300 <- c()
for (i in 1:(300-101+1)) {
  if (i == 1){
    forecast_101_300[1] <- mean(dm1$demand)
  } else {
    # update the forecast with alpha
    forecast_101_300[i] <- alpha * dm$demand[100+i-1] + (1 - alpha) * forecast_101_300[i-1]
  }
}

forecast_error_simple_expo_smooth <- dm2$demand - forecast_101_300
hist(forecast_error_simple_expo_smooth)

safety_stock <- quantile(forecast_error_simple_expo_smooth, 0.80)
stocking <- forecast_101_300 + safety_stock

# for the remaining days 301-- 500: repeat the process
# Note that in this case, forecast changes, but safety stock remains the same
forecast_301_500 <- c()
for (i in 1:(300-101+1)) {
  if (i == 1){
    forecast_301_500[1] <- mean(dm$demand[1:300])
  } else {
    # update the forecast with alpha
    forecast_301_500[i] <- alpha * dm$demand[300+i-1] + (1 - alpha) * forecast_301_500[i-1]
  }
}

stocking_301_500 <- forecast_301_500 + safety_stock # we use safety_stock obtained from df2

# Average profit
res_table$AvgProf[3] <- mean(price * pmin(stocking_301_500, dm3$demand) + salvage * pmax(stocking_301_500 - dm3$demand, 0) - cost * stocking_301_500)

## finding optimal alpha
mse_simple_exponential_smoothing <- function(alpha, actual_demand) {
  forecast_101_300 <- c()
  for (i in 1:(300-101+1)) {
    if (i == 1){
      forecast_101_300[1] <- mean(dm1$demand)
    } else {
      # update the forecast with alpha
      forecast_101_300[i] <- alpha * dm$demand[100+i-1] + (1 - alpha) * forecast_101_300[i-1]
    }
  }

  mse <- sum((actual_demand - forecast_101_300)^2) / length(actual_demand)
  return(mse)
}

res <- optim(0.2, mse_simple_exponential_smoothing, method = "L-BFGS-B",
             actual_demand = dm2$demand,
             lower = c(0),
             upper = c(1))
## Note: bisection might be more appropriate here (https://urldefense.com/v3/__https://rpubs.com/aaronsc32/bisection-method-r__;!!Mih3wA!WKo4McW-7-dzrHSo51O5DuRNZsZC4YkYFqeXfDfe2Jlu5bLOewZdY1wOa_2w8g$ )
## There are many ways/solvers to do this, but I just sticked with the very basic.

# use the tuned values
alpha <- res$par

forecast_101_300_with_optim_alpha <- c()
for (i in 1:(300-101+1)) {
  if (i == 1){
    forecast_101_300_with_optim_alpha[1] <- mean(dm1$demand)
  } else {
    # update the forecast with alpha
    forecast_101_300_with_optim_alpha[i] <- alpha * dm$demand[100+i-1] + (1 - alpha) * forecast_101_300_with_optim_alpha[i-1]
  }
}

forecast_error_simple_expo_smooth <- dm2$demand - forecast_101_300_with_optim_alpha
hist(forecast_error_simple_expo_smooth)

safety_stock <- quantile(forecast_error_simple_expo_smooth, 0.80)
stocking <- forecast_101_300_with_optim_alpha + safety_stock

# for the remaining days 301-- 500: repeat the process
# Note that in this case, forecast changes, but safety stock remains the same
forecast_301_500 <- c()
for (i in 1:(500-301+1)) {
  if (i == 1){
    forecast_301_500[1] <- forecast_101_300[200]
  } else {
    # update the forecast with alpha
    forecast_301_500[i] <- alpha * dm$demand[300+i-1] + (1 - alpha) * forecast_301_500[i-1]
  }
}

stocking_301_500 <- forecast_301_500 + safety_stock # we use safety_stock obtained from df2

# Average profit
res_table$AvgProf[4] <- mean(price * pmin(stocking_301_500, dm3$demand) + salvage * pmax(stocking_301_500 - dm3$demand, 0) - cost * stocking_301_500)

# Another Objective Function (Maximizing Average profit to find tuning parameters)
#101_300: Average_profit
## finding optimal alpha
AveProf_simple_exponential_smoothing <- function(alpha, df, price, salvage, cost) {
  forecast_101_300 <- c()
  for (i in 1:(300-101+1)) {
    if (i == 1){
      forecast_101_300[1] <- mean(dm$demand[1:100])
    } else {
      # update the forecast with alpha
      forecast_101_300[i] <- alpha * dm$demand[100+i-1] + (1 - alpha) * forecast_101_300[i-1]
    }
  }

  forecast_error_simple_expo_smooth <- dm$demand[101:300] - forecast_101_300

  safety_stock <- quantile(forecast_error_simple_expo_smooth, 0.80)
  stocking_101_300 <- forecast_101_300 + safety_stock

  # Average profit
  AvgProf <- mean(price * pmin(stocking_101_300, dm$demand[101:300]) + salvage * pmax(stocking_101_300 - dm$demand[101:300], 0) - cost * stocking_101_300)

  print(-AvgProf)
  return(-AvgProf) # don't forget to put negative sign as we want to maximize.
}

res <- optim(0.5, AveProf_simple_exponential_smoothing, method = "L-BFGS-B",
             df = df,
             lower = c(0),
             upper = c(1),
             price = price,
             salvage = salvage,
             cost = cost)

res$par
#0.01822693

#-------------------------#
# method 3. Trend-Corrected Exponential Smoothing (Holt’s Model)
#-------------------------#
#Step 1. Use the data from Week1 to Week300 to estimate
#the slope “a” in time (t) and the intercept “b” from the linear regression model.

#Dt = at + b
model <- lm(dm$demand[1:300] ~ dm$t[1:300])
a <- coefficients(model)[2]
b <- coefficients(model)[1]

#Step 2. Use L0=b and T0=a from the above linear regression.
#Use alpha=0.2 and beta=0.2. Estimate the forecast from Week1 to Week 500.

#Ft+1 = Lt + Tt
#L2 = aD2 + (1-a)(L1+T1)
#t2 = b(L2 - L1)+(1-b)T1

alpha <- 0.2
beta <- 0.2
level <- b
trend <- a

forecast_1_500 <- c()
for (i in 1:500) {
  forecast_1_500[i] <- trend + level
  # update the forecast with alpha and beta
  level <- alpha * dm$demand[i] + (1 - alpha) * forecast_1_500[i]
  trend <- beta * (level - (forecast_1_500[i] - trend)) + (1 - beta) * trend
}

#Step 3. What is the stocking quantity at Week301?
forecast_error_holt <- dm$demand[101:300] - forecast_1_500[101:300]
hist(forecast_error_holt)
safety_stock <- quantile(forecast_error_holt, 0.80)

stocking_301_500 <- forecast_1_500[301:500] + safety_stock # I use safety_stock obtained from df2

stocking_301_500[1] #stocking quantity at Week301 is 3735.754

#Step 4. What is the weekly average profit from Week301 to Week500?

res_table$AvgProf[5] <- mean(price * pmin(stocking_301_500, dm3$demand) + salvage * pmax(stocking_301_500 - dm3$demand, 0) - cost * stocking_301_500)

#Do you see an improvement over simple Exponential Smoothing?
#No
#5. Use the data from Week1 to Week300 to find an “optimal” alpha and beta values.

## finding optimal alpha & beta using MSE method
a <- coefficients(model)[2]
b <- coefficients(model)[1]

mse_holt <- function(p, actual_demand) {
  alpha <- p[1]
  beta <- p[2]
  level <- b
  trend <- a

  forecast_1_500 <- c()
  for (i in 1:500) {
    forecast_1_500[i] <- trend + level
    # update the forecast with alpha and beta
    level <- alpha * dm$demand[i] + (1 - alpha) * forecast_1_500[i]
    trend <- beta * (level - (forecast_1_500[i] - trend)) + (1 - beta) * trend
  }
  mse <- sum((actual_demand - forecast_1_500[101:300])^2) / length(actual_demand)
  return(mse)
}

res <- optim(c(0.2, 0.2), mse_holt, method = "L-BFGS-B",
             actual_demand = dm$demand[101:300],
             lower = c(0, 0),
             upper = c(10, 10))
print("Optimal alpha and beta using MSE method:")
print(res$par)

# Another Objective Function (Maximizing Average profit to find tuning parameters)
#101_300: Average_profit
## finding optimal alpha and beta
AveProf_holt_smoothing <- function(p, price, salvage, cost) {
  alpha <- p[1]
  #alpha <- 0.025133018
  beta <- p[2]
  level <- b
  trend <- a
  forecast_1_500 <- c()
  for (i in 1:500) {
    forecast_1_500[i] <- trend + level
    # update the forecast with alpha and beta
    level <- alpha * dm$demand[i] + (1 - alpha) * forecast_1_500[i]
    trend <- beta * (level - (forecast_1_500[i] - trend)) + (1 - beta) * trend
  }

  #forecast_error_holt_smooth <- dm$demand[101:300] - forecast_1_500[101:300]
  forecast_error_holt_smooth <- dm$demand[1:300] - forecast_1_500[1:300]

  safety_stock <- quantile(forecast_error_holt_smooth, 0.80)

  stocking_101_300 <- forecast_1_500[101:300] + safety_stock
  # Average profit
  AvgProf <- mean(price * pmin(stocking_101_300, dm$demand[101:300]) + salvage * pmax(stocking_101_300 - dm$demand[101:300], 0) - cost * stocking_101_300)

  print(-AvgProf)
  return(-AvgProf) # don't forget to put negative sign as we want to maximize.
}

res <- optim(c(0.5,0.5), AveProf_holt_smoothing, method = "L-BFGS-B",
             lower = c(0,0),
             upper = c(10, 10),
             price = price,
             salvage = salvage,
             cost = cost)
print("Optimal alpha and beta by maximizing average profit:")
res$par

#6.  use the tuned values
alpha <- res$par[1]
beta <- res$par[2]

level <- b
trend <- a

forecast_1_500_with_optim_alpha <- c()
for (i in 1:500) {
  forecast_1_500_with_optim_alpha[i] <- trend + level
  # update the forecast with alpha and beta
  level <- alpha * dm$demand[i] + (1 - alpha) * forecast_1_500_with_optim_alpha[i]
  trend <- beta * (level - (forecast_1_500_with_optim_alpha[i] - trend)) + (1 - beta) * trend
}

forecast_error_holt_smooth <- dm2$demand - forecast_1_500_with_optim_alpha[101:300]
hist(forecast_error_holt_smooth)

safety_stock <- quantile(forecast_error_holt_smooth, 0.80)
stocking_301_500 <- forecast_1_500_with_optim_alpha[301:500] + safety_stock # we use safety_stock obtained from df2

# Average profit
res_table$AvgProf[6] <- mean(price * pmin(stocking_301_500, dm3$demand) + salvage * pmax(stocking_301_500 - dm3$demand, 0) - cost * stocking_301_500)


normAbinom <- function() { # normAbinom.r
  x <- seq(5, 50, by=5)
  p.binom <-  pbinom(x, 50, 0.5)
  p.norm <- pnorm(x, 25, sqrt(12.5))
  diff <- p.binom-p.norm
  list(p.binom = round(p.binom,4), p.norm = round(p.norm,4), diff = round(diff,4))
 } # end function

normAbinom()


##### 医学統計勉強会18第2回基本統計量　R code #####

x <- c(0.684, 1.406, -0.663, -0.124, 0.849, -0.888, -0.492, -0.044, -0.188, 0.536, 2.063, -1.379, 0.920, 0.453, 1.239)

## 数量的なデータの要約 ##

sum(x)			# x の要素の和
length(x)		# x の長さ
mean(x)			# x の平均
median(x)		# x の中央値
quantile(x)		# x の四分位点．Five numbers summary
quantile(x, 0.2)	# x の20%パーセント点
summary(x)			# Five numbers summary + 平均

var(x)			# x の分散
sd(x)			# x の標準偏差
sqrt(x)			# x の平方根
sqrt(var(x))	# x の分散の平方根 = x の標準偏差
IQR(x)			# x の四分位点間距離
quantile(x, 0.75) - quantile(x, 0.25)	# 四分位点間距離の定義の確認

## 視覚的なデータの要約 ##

x <- rnorm(100)	# ランダムなサンプルの生成

hist(x)			# ヒストグラム（頻度）
hist(x, freq=F)	# ヒストグラム（相対頻度）

boxplot(x)		# ボックスプロット

# ヒストグラムとボックスプロット #

# 二峰型 #
x1 <- rnorm(100, mean=0)
x2 <- rnorm(100, mean=4)
x <- c(x1, x2)
hist(x)
boxplot(x)

# 裾の重い分布 #
y1 <- rnorm(100, sd=1)
y2 <- rnorm(100, sd=4)
y <- c(y1, y2)
hist(y)
boxplot(y)


### Code skeleton for Series 5, Exercise 1

## Read in dataset
diabetes <-
  read.table("http://stat.ethz.ch/Teaching/Datasets/diabetes2.dat",
             header = TRUE)
reg <- diabetes[, c("Age", "C.Peptide")]
names(reg) <-     c("x",   "y")

## Sort values
reg <- reg[sort.list(reg$x), ]

###################################################
### TASK a)
###################################################

### Utility function for LOO cross-validation:

##' Calculates the LOO CV score for given data and regression prediction function
##'
##' @param reg.data: regression data; data.frame with columns 'x', 'y'
##' @param reg.fcn:  regr.prediction function; arguments:
##'                    reg.x: regression x-values
##'                    reg.y: regression y-values
##'                    x:     x-value(s) of evaluation point(s)
##'                  value: prediction at point(s) x
##' @return LOOCV score
loocv <- function(reg.data, reg.fcn)
{
  ## Help function to calculate leave-one-out regression values
  loo.reg.value <- function(i, reg.data, reg.fcn)
    return(reg.fcn(reg.data$x[-i], reg.data$y[-i], reg.data$x[i]))

  ## Calculate LOO regression values using the help function above
  n <- nrow(reg.data)
  loo.values <- sapply(seq(1:n), loo.reg.value, reg.data, reg.fcn)

  ## Calculate and return MSE
  return(mean((loo.values - reg.data$y)^2))
}

### Regression prediction function for NW kernel:
reg.fcn.nw <- function(reg.x, reg.y, x)
  ksmooth(reg.x, reg.y, x.points = x, kernel = "normal", bandwidth = 4.0)$y

### Calculation of LOO CV-score for NW kernel estimator:
(cv.nw <- loocv(reg, reg.fcn.nw))
print(cv.nw)

### Hat matrix "S.nw":
n <- nrow(reg)
Id <- diag(n)
S.nw <- matrix(0, n, n)
for (j in 1:n) {
  tmp <- rep(0, n)
  tmp[j] <- 1
  S.nw[, j] <- reg.fcn.nw(reg$x, tmp, reg$x)
}

### Degrees of freedom (cf. Formula (3.6) in the lecture notes:
(df.nw <- sum(diag(S.nw)))
print(df.nw)

###################################################
### TASKS b) to e)
###################################################

### Proceed similarly as in task a); you can reuse the utility function
### loocv from task a)

### b) have a look at ?predict.loess to define your regression function reg.fcn.lp
reg.fcn.lp <- function(reg.x, reg.y, x){
  loess.fit <- loess(reg.y ~ reg.x, enp.target = df.nw, surface = "direct")
  return(predict(loess.fit, data.frame(reg.x = x)))
}

(cv.lp <- loocv(reg, reg.fcn.lp))
print(cv.lp)

### c) have a look at ?predict.smooth.spline to define your regression function reg.fcn.ss

est.ss <- smooth.spline(reg$x, reg$y, cv = TRUE, df = df.nw)
print((est.ss$cv.crit))

reg.fcn.ss <- function(reg.x, reg.y, x){
  ss.fit <- smooth.spline(reg.x, reg.y, spar = est.ss$spar)
  return(predict(ss.fit, x)$y)
}

(cv.ss <- loocv(reg, reg.fcn.ss))
print(cv.ss)

### d)

cv.ss_int <- smooth.spline(reg$x, reg$y, cv = TRUE)$cv.crit
print(cv.ss_int)

### e)

reg.fcn.cn <- function(reg.x, reg.y, x){
  return(mean(reg.y))
}

(cv.cn <- loocv(reg, reg.fcn.cn))
print(cv.cn)


#  4/14
#
# K means analysis on Star data ---------------------------

#install.packages('foreign')
library(foreign)  # to read the data we need function read.arff() from library foreign.

#install.packages('dplyr')
library(dplyr)  #'  dplyr package provides some utility funcions for sorting data

stars <- read.arff(file = 'AstronomyTrainingData.txt')
#Filter stars for complete entries.
complete_stars <- stars %>% filter(complete.cases(.))
star_names <- levels(stars$class)

#  identify the 25 levels of star: (Column 87 holds the names.)
levels(stars$class)
barplot(summary(stars$class), horiz = TRUE, las = 1, cex.names = 0.5)

#  We could specify that there are 25 centers, and kmeans will attempt to
#  locate 25 good centers, but it may be terrible!
centers <- 25

star_km <- kmeans(complete_stars[c(-1,-dim(complete_stars)[2])], centers, iter.max = 20, nstart = 1)
found_centers <- star_km$centers

#  There are 25 centers, one for each cluster.  The center contains 85 means representing each variable.
#  Cluster membership is identified by a a number.
# View(star_km$cluster)

#Numbers of stars per cluster
table(factor(star_km$cluster))
plot(table(factor(star_km$cluster)),xlab = "Cluster Number", ylab = "Stars per Cluster")

# I can make one of these by:
#  1)  Sorting the data by star type
#  2)  taking the mean for each star type, for each variable.

# with dplyr:  group COMPLETE stars by class, then summarise with the mean across all variables.
#sum_stars <- complete_stars %>% group_by(class) %>% summarise_each(funs(mean))

# with dplyr:  group each star by class, then summarise all the variables with mean(x, rm.na)
sum_stars <- stars %>% group_by(class) %>% summarise_each(funs(mean(., na.rm=TRUE)))

#star_km$size
#star_km$centers
#star_km$tot.withinss
#table(factor(star_km$cluster), factor(unlist(star_names)))

#full_star_km  <-  kmeans(complete_stars[c(-1,-dim(complete_stars)[2])], centers = sum_stars,
 #                        iter.max = 20, nstart = 1)

# Setting our own centers ---------------------------
# We had to switch to "Lloyd" method, as "Hartigan-Wong" cannot handle size 0 clusters.
full_star_km  <-  kmeans(as.matrix(complete_stars[,c(-1,-87)]),
                         centers = as.matrix(sum_stars[,c(-1,-2)]), iter.max = 20,
                         algorithm = "Lloyd")

# Result of clustering with 25 random clusters
plot(table(star_km$cluster))
table(star_km$cluster)
# Result of clustering with 25 nonrandom clusters drawn from training.
table(full_star_km$cluster)
plot(table(full_star_km$cluster))
plot(table(stars$class))
barplot(summary(stars$class), horiz = TRUE, las = 1, cex.names = 0.5)

#algorithm = c("Hartigan-Wong", "Lloyd", "Forgy","MacQueen"), trace=FALSE)
View(as.matrix(sum_stars[1:10,c(-1,-2)]))

is.data.frame(complete_stars)
View(sum_stars)
?kmeans

View(sum_stars[,c(-1,-2,-87)])
dim(sum_stars[,c(-1,-2)])
dim(stars[,c(-1,-87)])

# An example of setting the centers ---------------------------
#  Available here:  http://stats.stackexchange.com/questions/72606/k-means-clustering-after-first-iteration

# Set the RNG seed to ensure reproducibility
set.seed(12345)

# Let's create 3 visually distinct clusters
n <- c(1000, 500, 850)
# Jeff: X var defined here for 3 clusters
classifier.1 <- c(rnorm(n[1], 10, 0.9),
                  rnorm(n[2], 25, 2),
                  rnorm(n[3], 35, 2))
# Jeff:  Y var defined here for 3 clusters.
classifier.2 <- c(rnorm(n[1], 5, 1),
                  rnorm(n[2], 10, 0.4),
                  rnorm(n[3], 2, .9))

col = c("blue", "darkgreen", "darkred")
# Run k-means with 3 clusters and random initial centroids
# to check the clusters are correctly recognized
km <- kmeans(cbind(classifier.1, classifier.2), 3)
# Plot the data, colored by cluster
plot(classifier.1, classifier.2, pch=20, col=col[km$cluster])

# Mark the final centroids
points(km$centers, pch=20, cex=2, col="orange")

# Now impose some obviously "wrong" starting centroids
start.x <- c(10, 25, 3000)
start.y <- c(10, 10, -10000)
km.2 <- kmeans(cbind(classifier.1, classifier.2),
               centers=cbind(start.x, start.y))

# Jeff:  How will this preform if we give it the right stuff?
start.x <- c(10, 25, 35)
# It still finds it even if we give pretty bad y values!
start.y <- c(0, 1, 3)
km.2 <- kmeans(cbind(classifier.1, classifier.2),
               centers=cbind(start.x, start.y))
plot(classifier.1, classifier.2, pch=20, col=col[km.2$cluster])
points(km.2$centers, pch=20, cex=2, col="orange")

View(cbind(start.x, start.y))
?kmeans

# Top 30 Vars. ---------------------------

#Select the top n variables from PCA to use.
n <- 20
n_star_names <- as.character( pca_out[1:n,1] )
#View(stars[as.character( pca_out[1:n,1] ) ])

#Sort out the complete stars.
complete_stars <- stars %>% filter(complete.cases(.))

# Create a sorted list of training stars, by type.
sum_stars <- stars %>% group_by(class) %>% summarise_each(funs(mean(., na.rm=TRUE)))

#

top_var_star_km  <-  kmeans(as.matrix(complete_stars[,n_star_names]),
                         centers = as.matrix(sum_stars[,n_star_names]), iter.max = 200,
                         algorithm = "Lloyd")

#View(top_var_star_km$cluster)
# Result of clustering using the best n variables, with means of clusters drawn from training.
#table(top_var_star_km$cluster)
plot(table(top_var_star_km$cluster))
plot(table(stars$class))

barplot(table(top_var_star_km$cluster))
barplot(table(stars$class), las = 1, cex.names = 0.5, )
barplot(table(complete_stars$class), las = 1, cex.names = 0.5, )

barplot(cbind(table(top_var_star_km$cluster), table(stars$class)), las = 1, cex.names = 0.5, beside = T, )
#barplot(summary(stars$class), horiz = TRUE, las = 1, cex.names = 0.5)

results <- as.data.frame( cbind(names = star_names, predicted = table(top_var_star_km$cluster), actual = table(stars$class)))
View(results)
barplot(as.numeric(results$actual), horiz = T, las = 1, names.arg = results$names, cex.names= 0.5, main = "Actual")
barplot(as.numeric(results$predicted), horiz = T, las = 1, names.arg = results$names, cex.names= 0.5, main = "Predicted")
barplot(summary(stars$class), horiz = TRUE, las = 1, cex.names = 0.5, main = "Training Stars")
barplot(summary(complete_stars$class), horiz = TRUE, las = 1, cex.names = 0.5, main = "Complete Stars")

# Working with the whole data ---------------------------
# The location of this file will vary for you.  I didn't upload it to github, since it is so large.
# I suppose we could upload it if we want.

all_stars <- read.arff(file = 'Z:/ST599/Project 1/data/AstronomyTestData.txt')

# Multicolinearity Analysis ---------------------------

#Is there multicolinearity?

# install.packages('faraway')
library(faraway)
#Calculate the variance inflation factors (a measure of multicolinearity)
#  (VIFS are a ratio of eigenvalues to the smallest eigenvalue)
complete_stars_noname <- complete_stars[c(-1,-dim(complete_stars)[2])]
vifs <- (vif(complete_stars_noname))
vifs
plot(vifs)
#identify(vifs)
identify(vifs, labels = names(vifs), atpen = T)
identify(vifs, labels = names(vifs))
identify(vifs)
#  Colinearity Suspects in order::
#  "eclpoly_p_pulse", "eclpoly_p_pulse_initial", "std" "stetson_j", "amplitude"

View(complete_stars)
sorted_vifcolumns <- arrange(complete_stars_noname[,c(1,18,19,83,84)],amplitude)
View(complete_stars_noname[,c(1,18,19,83,84)])

e <- eigen(t(as.matrix(complete_stars_noname))%*%as.matrix(complete_stars_noname))
signif(e$values,3)
#  There is at least one enormous colinearity.
#  It was at least 2.0e20 before correction.
var_names <-  names(complete_stars)
sort(var_names)

#  Correcting for variance inflation:
# Remove ID, Remove Name
star_low_vif <- complete_stars[c(-1,-dim(complete_stars)[2])]
star_low_vif <- star_low_vif[c(-18,-19)]

e <- eigen(t(as.matrix(star_low_vif))%*%as.matrix(star_low_vif))
signif(e$values,3)

low_vif <- (vif(star_low_vif))
plot(low_vif)
identify(low_vif)
View(star_low_vif[,c(1,81,82)])

# Sharm's Example ---------------------------

#cancerData<-read.table(file="14cancer.xtrain",sep="")
# namesCancer<-read.table(file="namesCancer.txt",sep="",header="FALSE")
#namesCancer<-read.table(file="namesCancer.txt")
#myLabels<-c('breast','prostate','lung','collorectal','lymphoma','bladder','melanoma','uterus','leukemia','renal','pancreas','ovary','meso','cns')
#names(cancerData)<-c(namesCancer)

#dim(cancerData)
#myLabels<-c('breast','prostate','lung','collorectal','lymphoma','bladder','melanoma','uterus','leukemia','renal','pancreas','ovary','meso','cns')

#digit = read.table('Digit_recog_train.txt')
#digit_no = digit[,1]
#digit_pix = digit[,-1]
#digit_no3 = digit_no[digit_no == 3]
#digit_pix3 = digit_pix[digit_no == 3,]

#sel = sample(c(0,1), length(digit_no), replace = T, prob = c(4/5,1/5))
#digit_pix = digit_pix[sel == 1,]
#digit_no = digit_no[sel==1]

#  Example, part 2

#numCenters<-5
#kmeansCancer<-kmeans(t(cancerData), numCenters, iter.max = 20, nstart = 1)

#kmeansCancer$size
#kmeansCancer$centers
#kmeansCancer$tot.withinss
#table(factor(kmeansCancer$cluster), factor(unlist(namesCancer)))
#myLabels

#numCenters = 10
#kmeansDigit = kmeans(digit_pix, numCenters, iter.max = 20, nstart = 1)
#pamDigit = pam(digit_pix, k = numCenters, metric = 'Euclidean')

#kmeansDigit$size
#kmeansDigit$centers
#kmeansDigit$tot.withinss
#table(factor(kmeansDigit$cluster), factor(digit_no))
#pamDigit$medoids
#pamDigit$objective
#table(factor(pamDigit$clustering), factor(digit_no))

#  ---------------------------


library(drat)
library(dde)
library(odin)

drat::add("mrc-ide")

sir_generator <- odin::odin({
  ## Core equations for transitions between compartments:
  update(S) <- S - n_SI
  update(I) <- I + n_SI - n_IR
  update(R) <- R + n_IR

  ## Individual probabilities of transition:
  p_SI <- 1 - exp(-beta * I / N) # S to I
  p_IR <- 1 - exp(-gamma) # I to R

  ## Draws from binomial distributions for numbers changing between
  ## compartments:
  n_SI <- rbinom(S, p_SI)
  n_IR <- rbinom(I, p_IR)

  ## Total population size
  N <- S + I + R

  ## Initial states:
  initial(S) <- S_ini
  initial(I) <- I_ini
  initial(R) <- 0

  ## User defined parameters - default in parentheses:
  S_ini <- user(1000)
  I_ini <- user(1)
  beta <- user(0.2)
  gamma <- user(0.1)

}, verbose = FALSE)

sir <- sir_generator(I_ini = 10)
sir

set.seed(1)
sir_col <- c("#8c8cd9", "#cc0044", "#999966")

res <- sir$run(0:100)
par(mar = c(4.1, 5.1, 0.5, 0.5), las = 1)
matplot(res[, 1], res[, -1], xlab = "Time", ylab = "Number of individuals",
        type = "l", col = sir_col, lty = 1)
legend("topright", lwd = 1, col = sir_col, legend = c("S", "I", "R"), bty = "n")

res_200 <- sir$run(0:100, replicate = 200)
res_200 <- sir$transform_variables(res_200)
res_200 <- cbind.data.frame(t = res_200[[1]], res_200[-1])

col <- rep(sir_col, each = 200)

par(mar = c(4.1, 5.1, 0.5, 0.5), las = 1)
matplot(res_200[, 1], res_200[, -1], xlab = "Time", ylab = "Number of individuals",
        type = "l", col = col, lty = 1)
legend("topright", lwd = 1, col = sir_col, legend = c("S", "I", "R"), bty = "n")

## x: instance of odin model
## t: time steps
## n: number of replicates
run_model <- function(x, t = 0:100, n = 1, ...) {
    res <- x$run(t, replicate = n, ...)
    res <- x$transform_variables(res)
    res <- cbind.data.frame(t = res[[1]], res[-1])
    attr(res, "n_compartments") <- length(x$names) - 1
    attr(res, "n_replicates") <- n
    attr(res, "compartments") <- x$names[-1]
    class(res) <- c("pretty_odin", class(res))
    res
}

sir_pal <- colorRampPalette(sir_col)

plot.pretty_odin <- function(x, pal = sir_pal, ...) {
    ## handle colors
    n_compartments <- attr(x, "n_compartments")
    n_replicates <- attr(x, "n_replicates")
    col_leg <- pal(n_compartments)
    alpha <- max(10 / n_replicates, 0.05)
    col <- rep(col_leg, each = n_replicates)

    ## make plot
    par(mar = c(4.1, 5.1, 0.5, 0.5), las = 1)
    matplot(x[, 1], x[, -1], xlab = "Time", ylab = "Number of individuals",
            type = "l", col = col, lty = 1, ...)
    legend("topright", lwd = 1, col = col_leg, bty = "n",
           legend = attr(x, "compartments"))
}

# Run
x <- run_model(sir, t = 0:100, n = 500)
plot(x)