lg=function(mu, n, ybar)
{
  mu2=mu^2
  n*(ybar*mu-mu2/2)-log(1+mu2)
}

mu_now=10
cand_sd=5

mh<-function(mu_now,type_MH,cand_sd)
{
m=1000

y=c(1.2,1.4,???0.5,0.3,0.9,2.3,1.0,0.1,1.3,1.9)
n=length(y)
ybar=mean(y)
mu_storage<-c()
mu_storage<-c(mu_storage,mu_now)
acceptance_count=0

for (i in 1:m)
{
  if (type_MH=='randomwalk')
  {
  mu_cand = rnorm(n=1, mean=mu_now, sd=cand_sd)
  }
  else
  {
    if(type_MH=='independent')
    {mu_cand = rnorm(n=1, mean=3, sd=cand_sd)}
    else
    {print("woring type of MH")
      break}

  }

  lg_alpha=lg(mu_cand,n=n,ybar = ybar)-lg(mu_now,n=n,ybar=ybar)
  alpha=exp(lg_alpha)
  if(alpha>1)
    {mu_now=mu_cand
    mu_storage<-c(mu_storage,mu_cand)
    acceptance_count=acceptance_count+1}
  else
    {random_p=runif(1)
    if(alpha>random_p)
      {mu_now=mu_cand
      acceptance_count=acceptance_count+1}
    else
      {mu_now=mu_now}
    }

}

list(mu=mu_storage,accpt=acceptance_count/m)

#mu_storage_keep<-mu_storage[-c(1:10)]
#hist(mu_storage_keep,freq = FALSE,breaks=100)
}

tt_0<-mh(mu_now=5,type_MH='randomwalk',cand_sd=10)
plot.ts(tt_0$mu)
tt_0$accpt

tt_1<-mh(mu_now=5,type_MH='randomwalk',cand_sd=0.005)
plot.ts(tt_1$mu)
tt_1$accpt

tt_2<-mh(mu_now=5,type_MH='randomwalk',cand_sd=0.5)
plot.ts(tt_2$mu)
tt_2$accpt

mu_keep<-tt_2$mu[-c(1:2)]
plot(density(mu_keep),xlim=c(-3,6))
curve(dt(x,df=1),lty=2,add = TRUE,col="red")
legend("topright",legend=c("Prior t-distribution pdf", "Posterior pdf"), col=c("red","black"), lty=1, bty="n")
points(ybar,0,pch=20)
legend(1,1, legend="The black dot is the mean of y",bty="n")

tt_3<-mh(mu_now=5,type_MH='independent',cand_sd=0.5)
plot.ts(tt_3$mu)
tt_3$accpt

tt_4<-mh(mu_now=5,type_MH='hello',cand_sd=0.5)
tt_4


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)


library(ggplot2)

load('../../afg.data')
data <- afg.data$data

# c(69.1628, 34.5311) kabul location
# let's subset a very rough area around Kabul
kabul = subset(data,Latitude>34 & Latitude < 35 & Longitude >69 & Longitude <70)

start = as.Date('2004-01-01')
stop = as.Date('2005-01-01')
#kabul = subset(kabul,DateOccurred < stop & DateOccurred > start)

# find the number of events in each week
events_in_week <- function(week_index){
    date_lower = start + (7*(week_index-1))
    date_upper = date_lower + 7
    nrow(subset(kabul, DateOccurred < date_upper & DateOccurred > date_lower))
}

num_weeks = round(as.integer(stop-start)/7)
df = data.frame(
    num_events_per_week=sapply(seq(num_weeks),events_in_week)
)

p <- ggplot(df, aes(x=num_events_per_week))
# look at a per-week histogram
p <- p + geom_histogram(binwidth = 1)
p <- p + xlab("number of events per week in Kabul in 2004")+ylab("Count")
ggsave("images/histogram.png",dpi=72,width=8,height=6)

# 1 sample some data from a Poisson process using the maximum likelihood estimate
# of lambda (it's easy to sound hardcore when playing with Poissons)
n = 100
lambda = mean(df['num_events_per_week'])
data = data.frame(
    number_of_events = rpois(n=n,lambda=lambda)
)
# 2 evaluate the likelihood Poisson process
x = seq(max(df['num_events_per_week']))
l = data.frame(
    x = x,
    likelihood = sapply(x,dpois,lambda=lambda)
)
# 4 draw the likelihood
p <- ggplot(l, aes(x=x,y=likelihood))
p <- p + geom_line() + geom_point(size=4)
p <- p + xlab('number of events per week in Kabul in 2004') + ylab('count')
ggsave("images/distribution.png",dpi=72,width=8,height=6)
# 5 draw both
p <- ggplot(df,aes(x=num_events_per_week))
p <- p + geom_density(colour="red")
p <- p + geom_point(data=l, aes(x=x,y=likelihood), size=4)
p <- p + xlab('number of events per week in Kabul in 2004') + ylab('probability of seeing n events')
ggsave("images/density_estimate.png",dpi=72,width=8,height=6)


#!/usr/bin/env Rscript

# Author  : Bhishan Poudel
# Date    : Jan 8, 2016
# Program :

# Setting working directory
this.dir <- dirname(parent.frame(2)$ofile)
setwd(this.dir)

data <- c(5.28, 14.64, 37.25, 78.9, 44.92, 8.96, 19.22, 34.81,
          33.89, 24.28, 6.5, 4.32, 2.77, 17.6, 33.26, 52.78,
          5.98, 22.48, 20.11, 65.74, 35.73, 56.95, 30.61, 29.82)

hist(
    data,
    breaks = seq(0, 80, l = 6),
    freq = FALSE,
    col = "orange",
    main = "Histogram",
    xlab = "x",
    ylab = "f(x)",
    yaxs = "i",
    xaxs = "i"
)

# method 2
plot(cut(data, breaks = 4))

# method 3
number_of_bins = 4
hist(
    data,
    breaks = seq(min(data), max(data), l = number_of_bins + 1),
    freq = FALSE,
    col = "orange",
    main = "Histogram",
    xlab = "x",
    ylab = "f(x)",
    yaxs = "i",
    xaxs = "i"
)

# method 4 using ggplot2

library(ggplot2)
data <- data.frame(x = data)

ggplot(data, aes(x = x)) +
    geom_histogram(binwidth = 18,
                   color = "green",
                   fill = "grey") +
    scale_x_continuous(breaks = c(0, 20, 40, 60, 80))


#' Generate Cutoff Table
#'
#' This function makes a cutoff table from a numerical vector and returns a table of cutoff points, with the percentage of observations from the vector that fall above / below the cutoff.
#'
#' @param input A numerical vector
#' @param decimals A specified amount of decimals at which to make the cutoffs. E.g., setting decimals to 1 makes cutoffs at .1, .2, .3, etc.
#' @return A table of cutoffs and the percentage of observations from the vector that are above / below the cutoff.
#' @export
generate_cutoff_table <- function(input, decimals = 1){
  input_min = min(input)
  input_max = max(input)
  input_range = input_max - input_min
  input_range_step = (1 / (10^decimals))
  floor_dec <- function(x, level=1) round(x - 5*10^(-level-1), level)
  ceiling_dec <- function(x, level=1) round(x + 5*10^(-level-1), level)
  cutoff  = seq(from = floor_dec(input_min, level=decimals), to = ceiling_dec(input_max, level =decimals), by = input_range_step)
  output = data.frame(cutoff)
  output$n_small_than_cutoff <- lapply(output$cutoff, function(x) sum(input < x))
  output$n_equal_or_greater_than_cutoff <- lapply(output$cutoff, function(x) sum(input >= x))
  output$n_equal_or_greater_than_cutoff <- unlist(output$n_equal_or_greater_than_cutoff)
  output$total_n <- length(input)
  output$fraction_equal_or_greater_than_cutoff <-  output$n_equal_or_greater_than_cutoff / output$total_n
  output$fraction_smaller_than_cutoff <-  1 - (output$n_equal_or_greater_than_cutoff / output$total_n)
  output <- output[sum(output$fraction_equal_or_greater_than_cutoff == 1) :nrow(output),]
  output <- output[1:which(output$n_equal_or_greater_than_cutoff == 0)[1],]
  output <- output[ , -which(names(output) %in% c("total_n"))]
  return(output)
}


=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


require("ggplot2")

spi_all <- read.csv("https://raw.githubusercontent.com/climdata/drought2019/master/csv/spi_1500_2xxx.csv", sep=",")

spi.jan <- subset(spi_all, spi_all$month == 1)
spi.apr <- subset(spi_all, spi_all$month == 4)   # w
spi.jul <- subset(spi_all, spi_all$month == 7)
spi.oct <- subset(spi_all, spi_all$month == 10)  # s

mp <- ggplot()
mp + geom_line(aes(y=spi.apr$spi6, x=spi.apr$year), color="blue") +
  geom_line(aes(y=spi.oct$spi6, x=spi.oct$year), color="red")

filterYears = 5.0   #filter 5y
#filterYears = 50
#FFT for HDI
pic <- spi.apr$spi6
len <- length(pic)
## mirror pic
pic <- append(pic, pic)
for(i in 1:len) {
  pic[i+len] <- pic[1+len-i]
}
frq <- fft(pic, inverse = FALSE)
frq1 <- frq
start = round(len/(1*filterYears)) ## yearly
stop  = round(2*len-start)
frq1[start:stop] <- 0.0
pic1 <- Re(fft(frq1, inverse = TRUE)/length(frq1))
pic1 <- pic1[1:len]
spi.apr$spi6.5y <- pic1

pic <- spi.oct$spi6
len <- length(pic)
## mirror pic
pic <- append(pic, pic)
for(i in 1:len) {
  pic[i+len] <- pic[1+len-i]
}
frq <- fft(pic, inverse = FALSE)
frq1 <- frq
start = round(len/(1*filterYears)) ## yearly
stop  = round(2*len-start)
frq1[start:stop] <- 0.0
pic1 <- Re(fft(frq1, inverse = TRUE)/length(frq1))
pic1 <- pic1[1:len]
spi.oct$spi6.5y <- pic1

mp <- ggplot()
mp + geom_line(aes(y=spi.apr$spi6.5y, x=spi.apr$year), color="blue") +
  geom_line(aes(y=spi.oct$spi6.5y, x=spi.oct$year), color="red")

#22, 58, 37
apr.ts <- ts(spi.apr$spi6, frequency=58, start=c(1500,1))
apr.comp <- decompose(apr.ts)
plot(apr.comp)

oct.ts <- ts(spi.oct$spi6, frequency=58, start=c(1500,1))
oct.comp <- decompose(oct.ts)
plot(oct.comp)

## low-pass
apr.ts <- ts(spi.apr$spi6.5y, frequency=58, start=c(1500,1))
apr.comp <- decompose(apr.ts)
plot(apr.comp)

oct.ts <- ts(spi.oct$spi6.5y, frequency=58, start=c(1500,1))
oct.comp <- decompose(oct.ts)
plot(oct.comp)


data(swiss)
str(swiss)

pairs(swiss)

library(ggplot2)
ggplot(swiss, aes(x = Examination, y = Education))+
  geom_point()+
  theme(axis.text = element_text(size = 25),
        axis.title =element_text(size = 25, face = 'bold'))

library(ggplot2)
ggplot(swiss, aes(x = Examination, y = Education))+
  geom_point()+
  theme(axis.text = element_text(size = 25),
        axis.title =element_text(size = 25, face = 'bold'))+
  geom_smooth(method = 'lm')

ggplot(swiss, aes(x=log(Education)))+
  geom_histogram()

ggplot(swiss, aes(x=Examination))+
  geom_histogram()

# trouble №1
my_vector <- c(0.027, 0.079, 0.307, 0.098, 0.021, 0.091, 0.322, 0.211, 0.069, 0.261, 0.241, 0.166, 0.283, 0.041, 0.369, 0.167, 0.001, 0.053, 0.262, 0.033, 0.457, 0.166, 0.344, 0.139, 0.162, 0.152, 0.107, 0.255, 0.037, 0.005, 0.042, 0.220, 0.283, 0.050, 0.194, 0.018, 0.291, 0.037, 0.085, 0.004, 0.265, 0.218, 0.071, 0.213, 0.232, 0.024, 0.049, 0.431, 0.061, 0.523)
my_vector <- 1/my_vector
shapiro.test(my_vector)

# trouble №2

my_vector <- c(0.027, 0.079, 0.307, 0.098, 0.021, 0.091, 0.322, 0.211, 0.069, 0.261, 0.241, 0.166, 0.283, 0.041, 0.369, 0.167, 0.001, 0.053, 0.262, 0.033, 0.457, 0.166, 0.344, 0.139, 0.162, 0.152, 0.107, 0.255, 0.037, 0.005, 0.042, 0.220, 0.283, 0.050, 0.194, 0.018, 0.291, 0.037, 0.085, 0.004, 0.265, 0.218, 0.071, 0.213, 0.232, 0.024, 0.049, 0.431, 0.061, 0.523)
sdf <- scale(mtcars[,c(1,3)])
mean(sdf)
sdf
ssdf <- lm(sdf[,1]~sdf[,2])
ssdf$coefficients

beta.coef <- function(x){
  sdf <- scale(x)
  ssdf <- lm(sdf[,1]~sdf[,2])
  return(ssdf$coefficients)
}

beta.coef(mtcars[,c(1,3)])

library(psych)
lm.beta(lm(x[,1]~x[,2], x))

# trouble №3
str(mtcars)
t <- shapiro.test(mtcars[,1])
sdd <- append(t$p.value)

for(i in 1:ncol(mtcars[,1:6])){
  sdd <- vector(mode = "numeric")
  t <- shapiro.test(mtcars[,i])
  append(sdd,t$p.value)
}
labels(iris)

normality.test  <- function(x){
  sdd <- vector()
  for(i in 1:ncol(x)){
    t <- shapiro.test(x[,i])
    sdd <- c(sdd,t$p.value)
  }
  labx <- labels(x)
  names(sdd) <- as.vector(labx[[2]])
  return(sdd)
}

normality.test(iris[,-5])
normality.test(mtcars[,1:6])


## ----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]])


## Load some packages that will be useful
library(mgcv) # load the MGCV package with Simon Wood's gam() functions
library(readr) # Hadley Wickham's package for reading in data easily
library(ggplot2) # for plotting with ggplot
library(ggfortify) # for autoplot

##################################################################################################
## We'll first examine the bias-variance tradeoff in a simplified form with a small exercise.
## If you remember, this tradeoff is one of the concepts behind finding the optimal amount of smoothing.
## We'll fit linear regressions to parts of the data, increasing the number of parts from 1 to 10.
##################################################################################################

# First, read in the bioluminescence data.
# Sources is the number of bioluminescent plankton seen in each water sample
# SampleDepth is the depth of the water sample, in m
# Station is the ID of the location at which multiple water samples were taken
ISIT <- read_tsv(url('https://github.com/aeda2021/2021_master/raw/main/raw-data/ISIT.txt')) # tsv for tab-separated values

# Subset it to one station. This is what we'll work with for now.
ISITsub <- subset(ISIT, Station == 8)

# Plot the data
ggplot(ISITsub, aes(x=SampleDepth, y=Sources)) +
	geom_point()

# Now you can fit a linear regression to the ISITsub dataset, with Sources as the response and SampleDepth as the explanatory variable
# Please call the output "mod1", as I've started to fill in for you
mod1 <- lm(ISITsub$Sources ~ ISITsub$SampleDepth)

# Q1: What was your code for fitting a linear regression of Sources vs. SampleDepth?
# A: mod1 <- lm(ISITsub$Sources ~ ISITsub$SampleDepth)

# We'll predict the mean response and confidence intervals from this model and save the output
ISITsub$mod1 <- predict(mod1)
ISITsub$mod1lwr <- predict(mod1, interval='confidence', level=0.95)[,'lwr']
ISITsub$mod1upr <- predict(mod1, interval='confidence', level=0.95)[,'upr']

# Now plot the linear model fit to the full dataset on top of the data
ggplot(ISITsub, aes(x=SampleDepth, y=Sources)) +
	geom_point() +
	geom_line(aes(y=mod1)) +
	geom_ribbon(aes(ymin=mod1lwr, ymax=mod1upr), alpha=0.3)

# Q2: Use your skills from earlier in this course and evaluate this linear model (autoplot may be useful here). How does this fit look to you? Does a linear regression look reasonable? Any well-justified answer is appropriate.
# A2: No, this does not look like a valid linear regression. There is a clear pattern in the residulas (Residuals vs Fitted graph), and some of the larger residuals have disproportionately hig leverage (residuals vs leverage graph)

# For comparison, let's fit linear models to two halves of the data. This involves a fair bit of coding in R, so please ask for help understanding the code where things are confusing.
# First, we have to find the halves of the data
quants2 <- quantile(ISITsub$SampleDepth, probs=seq(0, 1, by=0.5)) # define the ends and the half-way point in the data with the quantile function
ISITsub$split2 <- cut(ISITsub$SampleDepth, breaks=quants2, include.lowest=TRUE, labels=1:2)

# Q3: In your own words, what does the cut() function do? How are we using it here?
# A3: the cut() function dividies a data range into parts (two parts here) and defines each value according to the part of the range in which it falls
# Here we use it to create a new column assigning rows in a dataframe to either side of the split

# Next, let's fit a linear model to each subset (half) of the data. We do this in a loop to make it easier.
mod2s <- vector('list', length=2) # A list to hold each of our models in a single, convenient object
ISITsub$mod2 <- ISITsub$mod2lwr <- ISITsub$mod2upr <- NA # Initialize the variables we'll use and fill with NA
for(i in 1:length(mod2s)){ # Loop through each model
	mod2s[[i]] <- lm(Sources ~ SampleDepth, data=ISITsub[ISITsub$split2==i,]) # Fit a linear regression to the appropriate subset of the data. Now see why we made the split2 vector?
	ISITsub$mod2[ISITsub$split2==i] <- predict(mod2s[[i]]) # Now predict from that model. Notice we're only predicting for part of the data.
	ISITsub$mod2lwr[ISITsub$split2==i] <- predict(mod2s[[i]], interval='confidence', level=0.95)[,'lwr'] # Same for the confidence intervals
	ISITsub$mod2upr[ISITsub$split2==i] <- predict(mod2s[[i]], interval='confidence', level=0.95)[,'upr']
}

# Plot the data, the 1-model fit, and the 2-model fit
# There will be an odd 3rd line segment connecting the end of the first model fit to the beginning of the second model fit. Just pretend it's not there.
ggplot(ISITsub, aes(x=SampleDepth, y=Sources)) +
	geom_point() +
	geom_line(aes(y=mod1)) +
	geom_ribbon(aes(ymin=mod1lwr, ymax=mod1upr), alpha=0.3) +
	geom_line(aes(y=mod2, color='red')) +
	geom_ribbon(aes(ymin=mod2lwr, ymax=mod2upr), alpha=0.3, fill='red')

# Q4: Has the fit between the model and the data improved? What's the downside of continuing the split the data into finer and finer chunks and fitting more models?
# A4: The fit looks much better. However, by fitting two models instead of one we halved the sample size, and also are no longer able to say anything about the relationship
# between the predictor and the response across the whole data set.

# Now, it's your turn. Please fit 10 linear regression models. I'd recommend using the 2-model code above as a guide and tweaking it.
quants10 <- quantile(ISITsub$SampleDepth, probs=seq(0, 1, by=0.1))
ISITsub$split10 <- cut(ISITsub$SampleDepth, breaks=quants10, include.lowest=TRUE, labels = 1:10)
mod10s <- vector('list', length=10) # A list to hold each of our models in a single, convenient object
ISITsub$mod10 <- ISITsub$mod10lwr <- ISITsub$mod10upr <- NA # Initialize the variables we'll use and fill with NA
for(i in 1:length(mod10s)){ # Loop through each model
  mod10s[[i]] <- lm(Sources ~ SampleDepth, data=ISITsub[ISITsub$split10==i,]) # Fit a linear regression to the appropriate subset of the data. Now see why we made the split2 vector?
  ISITsub$mod10[ISITsub$split10==i] <- predict(mod10s[[i]]) # Now predict from that model. Notice we're only predicting for part of the data.
  ISITsub$mod10lwr[ISITsub$split10==i] <- predict(mod10s[[i]], interval='confidence', level=0.95)[,'lwr'] # Same for the confidence intervals
  ISITsub$mod10upr[ISITsub$split10==i] <- predict(mod10s[[i]], interval='confidence', level=0.95)[,'upr']
}

# Now plot the 10 models on top of the data and on top of the 1- and 2-model fits. The plot with the data, 1-model, and 2-model fit is probably a useful guide here.

ggplot(ISITsub, aes(x=SampleDepth, y=Sources)) +
  geom_point() +
  geom_line(aes(y=mod1)) +
  geom_ribbon(aes(ymin=mod1lwr, ymax=mod1upr), alpha=0.3) +
  geom_line(aes(y=mod2, color='red')) +
  geom_ribbon(aes(ymin=mod2lwr, ymax=mod2upr), alpha=0.3, fill='red') +
  geom_line(aes(y=mod10, color='blue')) +
  geom_ribbon(aes(ymin=mod10lwr, ymax=mod10upr), alpha=0.3, fill='blue') +
  theme(legend.position = "none")

# Q5: Compare your 10-model fit to the 1-model fit. Which model's predictions are furthest from the observed data? Which model has the widest confidence bounds? How does this (or does this not) illustrate the bias-variance tradeoff?
# A5: The 10 model fit has the widest confidence bounds, especially for the intermediate depths. Since the number of observations is so low, the confidence bounds widen. However, the observed data are all within the confidence bounds.
# By decreasing the bias (adding more models), we have increased the variance so far as to make the model (probably) useless.

####################################################
## Now you'll fit some GAMs and evaluate your models
####################################################
#install.packages("maps") # if needed
library(maps) # has map data in it

# load the data
spdata <- readRDS(url('https://github.com/aeda2021/2021_master/raw/main/raw-data/gadusmorhua.rds')) # load the spdata data.frame with abundance and environmental data from cod surveys
spdata$presfit01 <- as.numeric(spdata$presfit) # make a vector that's nice for plotting
spdata <- spdata[order(spdata$presfit01),] # order the data from absent to present for ease of plotting

# examine the data
head(spdata) # look at the dataset
summary(spdata)

# make a map of the data
world <- map_data('world')

ggplot() +
	geom_polygon(data=world, aes(x=long, y=lat, group=group), color='black', fill=NA) + # the map
	xlim(-100, -45) +
	ylim(23, 62) +
	geom_point(data=spdata, aes(x=lon, y=lat, color=presfit, alpha=0.1), size=0.01) # the data points. note that because the dataframe is sorted from absent to present, the presences are plotted on top of the absences

# Q6: Based on the map, do you think cod prefer warmer or cooler waters? Why do you think that?
# A6: Based on the map, cod seem to prefer cooler waters. They are mostly present in the Gulf of Maine and Canada, and absent further south

# Q7: Plot cod presence/absence (the presfit vector) vs. the bottom temperature (SBT.actual). At what range of temperatures have cod been observed?
ggplot() +
  geom_boxplot(data=spdata,aes(x=presfit,y=SBT.actual))
range(spdata$SBT.actual[spdata$presfit==TRUE])
#A7: Cod have been observed from -1.8 to 18.3 degrees (presumably Celsius?)

# Q8: Fit a GAM for presfit against SBT.actual. Check the model. Does it look like the assumptions have been met? Why or why not?
library(mgcv)
gam1 <- gam(spdata$presfit ~ s(spdata$SBT.actual))
#Some assumptions do not appear to be met. The residual histogram is more bimodal than normal, the residuals vs. linear predictor plot is clearly structured, and the
#response vs. fitted values plot reflects the fact that the response variable is binomial.

# Q9: Fit a new GAM with a more appropriate error structure and save it as "mod2". The gam() function takes the same family= argument as does glm(). Which error structure and link function did you choose?
mod2 <-gam(presfit ~s(SBT.actual),data=spdata,family='binomial')
#We chose the binomial family and the logit() link

# Q10: Check your mod2 GAM. Does it look like the assumptions have been met? Make sure to read the text output as well as look at the graphs. If something doesn't look right, what would you do to fix it?
gam.check(mod2)
# A10: It's definitely better, but still not perfect.  The Q/Q plot looks okay, the residuals vs. linear
#predictors plot is problematic, the residuals are still slightly bimodal.

# Q11: Interpret your mod2 GAM (summary function). How much deviance is explained? Is the SBT.actual term significant at alpha=0.05? How wiggly do you expect the smooth fit to be?
# A11: The model explains about 26.5% of deviance, and the SBT.actual term is significant at the alpha = 0.05 level. With 8.96 estimated degrees of freedom, I would expect the fit to be fairly
# Now let's make predictions from our last model (mod2) and plot them.
nd <- data.frame(SBT.actual = seq(-5,30, by=0.5)) # make a data.frame of new explanatory variables
nd$mod2 <- predict(mod2, newdata=nd, type='response') # predict on the scale of the response
nd$mod2se <- predict(mod2, newdata=nd, type='response', se.fit=TRUE)$se.fit # get the standard errors of the fit

ggplot(spdata, aes(x=SBT.actual, y=presfit01)) +
	geom_point() +
	geom_line(data=nd, aes(x=SBT.actual, y=mod2, color='red')) +
	geom_ribbon(data=nd, aes(x=SBT.actual, ymin=mod2-mod2se, ymax=mod2+mod2se), alpha=0.3, fill='red', inherit.aes=FALSE)

# Q12: Does the fit look realistic? Why or why not? Does it look overfit? Why or why not?
# A12: To me, the model looks overfit.

# Q13: This dataset is actually a concatenation of seven different surveys which each have slightly different abilities to catch cod. Fit a new GAM that includes a categorical predictor for survey (the region vector). Based on AIC, which model would you choose? How confident would you be?
gam3 <- gam(presfit ~s(SBT.actual) + as.factor(region),data=spdata,family='binomial')
AIC(mod2)
AIC(gam3)
# A13: By AIC, the model including region is definitely better. The adjusted R^2 is also higher (0.33 vs 0.26). With a deltaAIC of more than 800, I would be confident in choosing the model including region over the model excluding region.


###############################################################################
#------------------------------------------------------------------------------
# Cluster Analysis
#------------------------------------------------------------------------------
# Based on
# https://www.datacamp.com/courses/introduction-to-machine-learning-with-r
###############################################################################

#------------------------------------------------------------------------------
# Prepare Data
#------------------------------------------------------------------------------
mydata <- na.omit(mydata) # listwise deletion of missing
mydata <- scale(mydata) # standardize variables

#------------------------------------------------------------------------------
# K-means clustering
#------------------------------------------------------------------------------

# Determine number of clusters
wss <- (nrow(mydata)-1)*sum(apply(mydata,2,var))
for (i in 2:15) wss[i] <- sum(kmeans(mydata,
  	centers=i)$withinss)
plot(1:15, wss, type="b", xlab="Number of Clusters",
  ylab="Within groups sum of squares")

# K-Means Cluster Analysis
fit <- kmeans(mydata, 5) # 5 cluster solution
# get cluster means
aggregate(mydata,by=list(fit$cluster),FUN=mean)
# append cluster assignment
mydata <- data.frame(mydata, fit$cluster)

# A robust version of K-means based on mediods can be invoked by using
# pam( ) instead of kmeans( ). The function pamk( ) in the fpc package is a
# wrapper for pam that also prints the suggested number of clusters based on
# optimum average silhouette width.

#------------------------------------------------------------------------------
# Hierarchical Agglomerative
#------------------------------------------------------------------------------
# There are a wide range of hierarchical clustering approaches. I have had
# good luck with Ward's method described below.

# Ward Hierarchical Clustering
d <- dist(mydata, method = "euclidean") # distance matrix
fit <- hclust(d, method="ward")
plot(fit) # display dendogram
groups <- cutree(fit, k=5) # cut tree into 5 clusters
# draw dendogram with red borders around the 5 clusters
rect.hclust(fit, k=5, border="red")

# The pvclust( ) function in the pvclust package provides p-values for
# hierarchical clustering based on multiscale bootstrap resampling. Clusters
# that are highly supported by the data will have large p values.
# Interpretation details are provided Suzuki. Be aware that pvclust clusters
# columns, not rows. Transpose your data before using.

# Ward Hierarchical Clustering with Bootstrapped p values
library(pvclust)
fit <- pvclust(mydata, method.hclust="ward",
   method.dist="euclidean")
plot(fit) # dendogram with p values
# add rectangles around groups highly supported by the data
pvrect(fit, alpha=.95)

#------------------------------------------------------------------------------
# Model Based (BIC and EM)
#------------------------------------------------------------------------------
# Model based approaches assume a variety of data models and apply maximum
# likelihood estimation and Bayes criteria to identify the most likely model
# and number of clusters.

library(mclust)
fit <- Mclust(mydata)
plot(fit) # plot results
summary(fit) # display the best model

#------------------------------------------------------------------------------
# Plotting Cluster Solutions
#------------------------------------------------------------------------------
# K-Means Clustering with 5 clusters
fit <- kmeans(mydata, 5)

# Cluster Plot against 1st 2 principal components

# vary parameters for most readable graph
library(cluster)
clusplot(mydata, fit$cluster, color=TRUE, shade=TRUE,
  	labels=2, lines=0)

# Centroid Plot against 1st 2 discriminant functions
library(fpc)
plotcluster(mydata, fit$cluster)

#------------------------------------------------------------------------------
# Validating cluster solutions
#------------------------------------------------------------------------------
# The function cluster.stats() in the fpc package provides a mechanism for
# comparing the similarity of two cluster solutions using a variety of
# validation criteria (Hubert's gamma coefficient, the Dunn index and the
# corrected rand index)

library(fpc)
cluster.stats(d, fit1$cluster, fit2$cluster)


#################################### INTERPOLACAO VIA THIN PLATE ###################################

#' Suavizacao De \code{curvacolina} Thin Plate Regression Splines
#'
#' Funcao interna executada quando \code{metodo = "thinplate"} em \code{interpolador}
#'
#' Esta funcao nao deve ser chamada pelo usuario diretamente na maioria dos casos
#'
#' @param colina objeto \code{curvacolina} retornado pelas funcoes de leitura
#' @param taxa_reducao inteiro indicando reducao do tamanho do historico em \code{taxa_reducao}
#'     vezes. Ver Detalhes
#' @param ... nao possui funcao, so existe para compatibilizacao com a chamada generica de
#'     \code{\link{interpolador}}
#'
#' @return objeto da classe \code{thinplate} contendo a suavizacao da curva colina
#'
#' @importFrom fields Tps
#'
#' @export

thinplate <- function(colina, taxa_reducao = 1, ...) {

    hl <- pot <- rend <- NULL

    colina_reduzida <- reduzcolina(colina, taxa_reducao)

    mod <- Tps(colina_reduzida$CC[, list(hl, pot)], colina_reduzida$CC$rend, lambda = 0)

    new_thinplate(mod, colina)
}

new_thinplate <- function(mod, colina) {
    obj        <- list(superficie = mod, colina = colina)
    class(obj) <- c("thinplate", "interpolador")
    return(obj)
}

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

#' @rdname getcolina

getcolina.thinplate <- function(object) object$colina

#' Amostragem De Pontos Na Suavizacao
#'
#' Amostra as coordenadas especificadas via \code{pontos} na superficie suavizada
#'
#' @param object objeto da classe \code{thinplate} retornado pela funcao homonima
#' @param pontos data.frame ou matriz contendo coordenadas \code{(hl, pot)} dos pontos onde
#'     interpolar
#' @param as.gradecolina booleano -- se \code{FALSE} (padrao) retorna apenas o vetor de rendimentos
#'     interpolados nas coordenadas \code{pontos}; se \code{TRUE} um objeto \code{gradecolina}. Veja
#'     \code{\link{gradecolina}}
#' @param ... existe somente para consistencia de metodos. Nao possui utilidade
#'
#' @return se \code{as.gradecolina = FALSE}, vetor de rendimentos interpolados, do contrario um
#'     objeto \code{\link{gradecolina}}
#'
#' @export

predict.thinplate <- function(object, pontos, as.gradecolina = FALSE, ...) {

    pontos <- pontos[complete.cases(pontos), ]

    if(nrow(pontos) == 0) return(numeric(0))

    pontos <- as.data.frame(pontos)

    rends <- unname(predict(object$superficie, x = pontos))

    if(as.gradecolina) {
        out <- new_gradecolina(pontos, rends, object)
    } else {
        out <- as.numeric(rends)
    }

    return(out)
}


#' 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])
}


ds = read.csv("Position_Salaries.csv")
ds = ds[, 2:3]

# Fitting and predicting
lin_reg = lm(Salary ~.,
             data = ds)

poly_reg = lm(Salary ~ poly(Level, 4),
              data = ds)
y_pred = predict(poly_reg, data.frame(Level =6.5))

# Plotting
X_grid = seq(min(ds$Level), max(ds$Level), 0.1)

library(ggplot2)
ggplot() +
    geom_point(aes(x= ds$Level, y = ds$Salary),
               colour = 'red') +
    geom_line(aes(x=ds$Level, y = predict(lin_reg, new_data = X_grid)),
              colour = 'blue') +
    geom_line(aes(x = X_grid, y = predict(poly_reg, newdata = data.frame(Level = X_grid))),
              colour = 'black') +
    ggtitle("Polynomial regression salary progression") +
    xlab("Position") +
    ylab("Salary")


# Exercise 1

# The following command creates a vector of 100 random numbers between 1 and 1000:

my_vector <- c(sample(1:1000, 100))

# Answer the following questions about the vector:

# 1) Extract the third through the sixth elements from the vector:

# Answer: my_vector[3:6]
# 644 431 354 221

# 2) Check to see if the numbers 99, 66, and 287 exist in this vector:

# Answer: match(c(99, 66, 287), my_vector)
# Results vary
# 85 NA 94

# 3) How many elements are greater than 500?

# Answer:
# length(my_vector[my_vector > 500])
# Results vary
# 46


# 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)


#install.packages("plotly")
library(plotly)
#install.packages("Rpdb")
library(Rpdb)
library(datasets)

#Read PDB File
#filename<-readline(prompt = "Enter File Name: ")
filename<-"3ptb.pdb"
#filename<-"4x0l.pdb"
textMat<-read.pdb(filename, ATOM = TRUE, HETATM = TRUE)

#Make Datasets
d <- data.frame(textMat$atoms$x1,textMat$atoms$x2,textMat$atoms$x3)

#Testing for Cluster Size 5
c <- kmeans(d,5)
d2 <- data.frame(textMat$atoms$x1,textMat$atoms$x2,textMat$atoms$x3,c$cluster)
plot_ly(d2, x = ~textMat.atoms.x1, y = ~textMat.atoms.x2, z = ~textMat.atoms.x3, color = ~c.cluster)

#WSS to determine optimum clusters
maxClusters <- 50
wss <- numeric(maxClusters)
#Squaring WSS values to get sharper changes
for (i in 2:maxClusters){wss[i] <- sum(kmeans(d,i)$withinss)*sum(kmeans(d,i)$withinss)}
plot(1:maxClusters, wss, type = "b")
optClusters <- 15

#Plot K-Means for Optimum Clusters
c <- kmeans(d,optClusters)
d2 <- data.frame(textMat$atoms$x1,textMat$atoms$x2,textMat$atoms$x3,c$cluster)
plot_ly(d2, x = ~textMat.atoms.x1, y = ~textMat.atoms.x2, z = ~textMat.atoms.x3, color = ~c.cluster)


#' 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")


##########################
#PREDICTING SALES ON EBAY#
##########################

# PROBLEM 1 - LOADING THE DATA
load("eBay.Rdata")
str(eBay)
# What proportion of all shoes were sold?
sum(eBay$sold)/nrow(eBay)

# PROBLEM 2 - MISSING VALUES
# Which of the numerical variables has at least one missing value?
summary(eBay)

# PROBLEM 3 - MOST COMMON SHOE SIZE
# What is the most common shoe size in the dataset?
which.max(table(eBay$size))

# PROBLEM 4 - CONVERTING VARIABLES TO FACTORS
eBay$sold <- as.factor(eBay$sold)
eBay$condition <- as.factor(eBay$condition)
eBay$heel <- as.factor(eBay$heel)
eBay$style <- as.factor(eBay$style)
eBay$color <- as.factor(eBay$color)
eBay$material <- as.factor(eBay$material)
# Which of the following methods requires the dependent variable be stored as a factor variable
# when training a model for classification?
# Read article on CART and Random Forest models

# PROBLEM 5 - SPLITTING INTO A TRAINING AND TESTING SET
set.seed(144)

library(caTools)

spl = sample.split(eBay$sold, 0.7)
training <- subset(eBay, spl==T)
testing <- subset(eBay, spl==F)
# Why do we use the sample.split() function to split into a training and testing set?
# Think about this: we want to obtain a balanced data based on the dependant variable

# PROBLEM 6 - TRAINING A LOGISTIC REGRESSION MODEL
logFit <- glm(sold ~ biddable + startprice + condition + heel + style + color + material, data=training, family=binomial)
# Which of the following characteristics of a shoe are statistically significantly
# (p < 0.05, aka at least a * in the regression summary) associated with a lower chance of an item being sold?
summary(logFit)
# Read the coeffients and their p value to answer the question

# PROBLEM 7 - PREDICTING USING A LOGISTIC REGRESSION MODEL
# What is the predicted probability that this shoe (dummy) will be sold according to the
# logistic regression model?
dummy <-  data.frame(biddable=0, startprice=100, condition="Pre-owned", heel="High", style="Open Toe", color="Black", material="Satin")
predict(logFit, newdata=dummy, type="response")

# PROBLEM 8 - INTERPRETING MODEL COEFFICIENTS
# What is the meaning of the coefficient labeled "styleStiletto" in the logistic regression summary output?
# Read the information related to styleStiletto in the summary to answer the question. Remember
# this is a logistic model, so we need to convert it back to normal by using exp()

# PROBLEM 9 - OBTAINING TEST SET PREDICTIONS
# On how many test set observations does your logistic regression model make a different prediction
# than the prediction the naive baseline model would make?
logTestPredicts <- predict(logFit, newdata=testing, method="response")
table(testing$sold)
which.max(table(training$sold))

# PROBLEM 10 - COMPUTING TEST-SET AUC
library(ROCR)
# What is the test-set AUC of the logistic regression model?
logPred <- prediction(logTestPredicts, testing$sold)
as.numeric(performance(logPred,"auc")@y.values)

# PROBLEM 11 - COMPUTING TEST-SET AUC
# What is the meaning of the AUC?
# Read article on AUC and try to relate it with the context of this test to answer to the question.

# PROBLEM 12 - ROC CURVES
# Which logistic regression threshold is associated with the upper-right corner of the ROC plot
# (true positive rate 1 and false positive rate 1)?
# Read article on receiver operating characteristic (ROC) to answer the question

# PROBLEM 13 - ROC CURVES
# At roughly which logistic regression cutoff does the model achieve a true positive rate of 80%
# and a false positive rate of 50%?
logicPerf <- performance(logPred,"tpr","fpr")
plot(logicPerf, colorize=TRUE)
abline(v=0.5,h=0.8)

# PROBLEM 14 - CROSS-VALIDATION TO SELECT PARAMETERS
# Which of the following best describes how 10-fold cross-validation works when selecting
# between 3 different parameter values?
# In 10-fold cross validation, the model with each parameter setting will be trained on 10 90%
# subsets of the training set.

# PROBLEM 15 - CROSS-VALIDATION FOR A CART MODEL
# What cp value maximizes the cross-validation accuracy?
set.seed(144)
library(caret)
numFolds <- trainControl(method = "cv", number = 10)
grid <- expand.grid(.cp = seq(0.001,0.05, 0.001))
train(sold ~ biddable + startprice + condition + heel + style + color + material,
      data=training, method="rpart", trControl=numFolds, tuneGrid=grid)

# PROBLEM 16 - TRAIN CART MODEL
# Build and plot the CART model trained with the parameter identified in Problem 15
# What variable is used most frequently as a split in the tree?
cart <- rpart(sold ~ biddable + startprice + condition + heel + style + color + material,
              data=training, method="class", cp=0.005)
library(rpart.plot)
prp(cart)

# PROBLEM 17 - BUILDING A CORPUS FROM ITEM DESCRIPTIONS
# Build a corpus called "corpus" using the "description" variable from the full data frame "eBay"
library(tm)
library(stringr)

newDescriptions <- str_replace_all(eBay$description,"[^[:graph:]]", " ")
corpus <- Corpus(VectorSource(newDescriptions))
corpus <- tm_map(corpus, tolower)
corpus <- tm_map(corpus, PlainTextDocument)
corpus <- tm_map(corpus, removePunctuation)
corpus <- tm_map(corpus, removeWords, stopwords("english"))
corpus <- tm_map(corpus, stemDocument)
# Build a document-term matrix called "dtm" from the preprocessed corpus.
dtm <- DocumentTermMatrix(corpus)
# How many unique word stems are in dtm?
dtm

# PROBLEM 18 - REMOVING SPARSE TERMS
# Remove all terms that don't appear in at least 10% of documents in the corpus,
# storing the result in a new document term matrix called spdtm.
spdtm <- removeSparseTerms(dtm, 0.9)
# How many unique terms are in spdtm?
spdtm

# PROBLEM 19 - EVALUATING WORD FREQUENCIES IN A CORPUS
# Convert spdtm to a data frame called descriptionText. Which word stem appears
# the most frequently across all descriptions?
descriptionText <- as.data.frame(as.matrix(spdtm))
which.max(colSums(descriptionText))

# PROBLEM 20 - ADDING DATA FROM ORIGINAL DATA FRAME
names(descriptionText) = paste0("D", names(descriptionText))

descriptionText$sold <- eBay$sold
descriptionText$biddable <- eBay$biddable
descriptionText$startprice <- eBay$startprice
descriptionText$condition <- eBay$condition
descriptionText$heel <- eBay$heel
descriptionText$style <- eBay$style
descriptionText$color <- eBay$color
descriptionText$material <- eBay$material
set.seed(144)
spl <- sample.split(descriptionText$sold, SplitRatio=.7)
testText <- subset(descriptionText, spl==F)
trainText <- subset(descriptionText, spl==T)
str(testText)

# PROBLEM 21 - TRAINING ANOTHER LOGISTIC REGRESSION MODEL
# Using trainText, train a logistic regression model called glmText to predict the dependent variable
# using all other variables in the data frame.
glmText <- glm(sold ~., data=trainText, family=binomial)
# How many of the word frequencies from the description text (variables beginning with the letter "D")
# are significant at or below the p=0.05 level?
summary(glmText)

# PROBLEM 22 - TEST SET AUC OF NEW LOGISTIC REGRESSION MODEL
# What is the training-set AUC of the new logistic regression model?
trainPred <- predict(glmText)
trainPredictions <- prediction(trainPred, trainText$sold)
logicTrainPerf <- performance(trainPredictions,"auc")@y.values
# What is the test-set AUC of the new logistic regression model?
testPred <- predict(glmText, newdata= testText)
testPredictions <- prediction(testPred, testText$sold)
logicTestPerf <- performance(testPredictions, "auc")@y.values

# PROBLEM 23 - ASSESSING OVERFITTING OF NEW MODEL
# What is the most accurate description of the new logistic regression model?
# What does it mean for AUC of a training set to be bigger than that of a testing set and What
# do we often do to solve this issue? This is the key to the answer


#!/usr/bin/Rscript

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

box_muller_alternative_2 = function() {
    # Sample from the exponential distribution until a suitable `y2` has been
    # found.
    repeat {
        y1 = rexp(1)
        y2 = rexp(1)

        if (y2 > (1 - y1)^2 / 2) {
            break;
        }
    }

    # Randomly determine the sign and return that value.
    u = runif(1)
    x = sign(2 * u - 1) * y1
    return(x)
}

# Draw a bunch of samples
samples = replicate(10000, box_muller_alternative_2())

# Make a quantile-quantile plot which the actual against the theoretical
# quantiles. That should quickly tell whether the resulting numbers are sampled
# from a normal distribution.
qqnorm(samples)
lines(c(-4, 4), c(-4, 4))
grid()


context("Metabolism Functions")
library("NSmetabolism")

test_that("Pressure is computed right from elevation", {
	expect_equal(pressureFromElevation(0), 1013.25, tol=0.01)
	expect_equal(pressureFromElevation(500), 954.6, tol=0.01)
	expect_equal(pressureFromElevation(1000), 898.75, tol=0.01)
	expect_equal(pressureFromElevation(2000), 794.95, tol=0.01)
	expect_equal(pressureFromElevation(6000), 471.81, tol=0.01)
})

test_that("Conversion to atm works", {
	expect_equal(hPaToAtm(1013.25), 1, tol = 0.01)
})

test_that("Pressure conversion", {
	pr_meas = c(1000, 1100)
	elev_meas = c(100, 200)
	elev_out = 1000

	# errors
	expect_error(pressureCorrection(pr_meas, elev_meas[1], elev_out), regex = "length")

	# sigle point should work fine
	expect_error(one <- pressureCorrection(pr_meas[1], elev_meas[1], elev_out), regex=NA)
	expect_equal(length(one), 1)
	expect_true(one > 875 & one < 900)

	# multiple pts
	expect_error(two <- pressureCorrection(pr_meas, elev_meas, elev_out), regex = NA)
	expect_equal(length(two), length(pr_meas))
	expect_true(all(two < pr_meas))

	# same elevation yields same pressure
	expect_error(same <- pressureCorrection(pr_meas[1], elev_meas[1], elev_meas[1]), regex=NA)
	expect_equal(same, pr_meas[1])
})


# 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 = "-")


#!/usr/bin/env Rscript
args <- commandArgs(trailingOnly = TRUE)
file = read.csv(args[1], check.names=FALSE)
window = strtoi(args[2])
file_output = args[3]

# x: the vector
# n: the number of samples
# centered: if FALSE, then average current sample and previous (n-1) samples
#           if TRUE, then average symmetrically in past and future. (If n is even, use one more sample from future.)
movingAverage <- function(x, n, centered) {

  if (centered) {
    before <- floor  ((n-1)/2)
    after  <- ceiling((n-1)/2)
  } else {
    before <- n-1
    after  <- 0
  }

  # Track the sum and count of number of non-NA items
  s     <- rep(0, length(x))
  count <- rep(0, length(x))

  # Add the centered data
  new <- x
  # Add to count list wherever there isn't a
  count <- count + !is.na(new)
  # Now replace NA_s with 0_s and add to total
  new[is.na(new)] <- 0
  s <- s + new

  # Add the data from before
  i <- 1
  while (i <= before) {
    # This is the vector with offset values to add
    new   <- c(rep(NA, i), x[1:(length(x)-i)])

    count <- count + !is.na(new)
    new[is.na(new)] <- 0
    s <- s + new

    i <- i+1
  }

  # Add the data from after
  i <- 1
  while (i <= after) {
    # This is the vector with offset values to add
    new   <- c(x[(i+1):length(x)], rep(NA, i))

    count <- count + !is.na(new)
    new[is.na(new)] <- 0
    s <- s + new

    i <- i+1
  }

  # return sum divided by count
  s/count
}

filtered_file <- mapply(movingAverage, file, window, TRUE)

if("timestamp" %in% colnames(filtered_file)){
  filtered_file[,"timestamp"] <- file$timestamp
}
if("Core_1CPU" %in% colnames(filtered_file)){
  filtered_file[,"Core_1CPU"] <- file$Core_1CPU
}
if("Core_2CPU" %in% colnames(filtered_file)){
  filtered_file[,"Core_2CPU"] <- file$Core_2CPU
}
if("numSockets" %in% colnames(filtered_file)){
  filtered_file[,"numSockets"] <- file$numSockets
}
write.csv(filtered_file, file = file_output ,row.names=FALSE)

#UU <- data.frame(apply(training, 2, movingAverage))
#x <- 1:nrow(training)
#plot(x, training$cpu_idle, type="l", col=grey(.5))
#grid()
#lines(x, UU$cpu_idle, col="green", lwd=2)


fibo <- function(n) round(((5 + sqrt(5)) / 10) * (( 1 + sqrt(5)) / 2) ** (n - 1))

for (i in seq(30*10)){
  xlimit = 100*i
  ylimit = c(0,10000)
  png(paste("./complexity.functions.",sprintf("%05d", i),".png", sep=""))
  plot(sapply(1:xlimit,function(x){x}), type='l', xlab="x", ylab="y", col="blue", ylim = ylimit)
  grid (10,10, lty = 6, col = "cornsilk2")
  lines(sapply(1:xlimit,function(x){x**2}), type='l', xlab="x", ylab="y", col="red")
  lines(sapply(1:xlimit,function(x){x*log(x)}), type='l', xlab="x", ylab="y", col="green")
  lines(sapply(1:xlimit,function(x){factorial(x)}), type='l', xlab="x", ylab="y", col="yellow")
  lines(sapply(1:xlimit,function(x){log(x)}), type='l', xlab="x", ylab="y", col="grey")
  lines(sapply(1:xlimit,function(x){fibo(x)}), type='l', xlab="x", ylab="y", col="pink")
  legend('topright', c("x","x**2","x*log(x)","x!","log(x)","fibo(x)"), lty=1, col=c('blue', 'red','green',"yellow","grey","pink"), bty='n', cex=.75)
  dev.off()
}


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


rm(list=ls())

pl <- data.frame(r=seq(1,100,0.1))

pl$L<- 0.4*pl$r^-1.3

pl$logL <-log(pl$L)

pl$logr <-log(pl$r)

lm(logL~log(r),data=pl)

cumPowerL <- function(x) {
  sum(pl[pl$r <=x,]$L)

}

pl$cumL <- sapply(pl$r,cumPowerL)

plot(log(cumL)~logr,data=pl)

lm <- lm(log(cumL)~logr,data=pl)

summary(lm)

pl1 <- pl[pl$logr>=3,]

lm1 <- lm(log(cumL)~logr,data=pl1)

summary(lm1)

abline(lm)

abline(lm1,col="red")

pl1 <- pl[pl$logr<2,]

lm1 <- lm(log(cumL)~logr,data=pl1)

summary(lm1)

abline(lm1,col="blue")

# Example Rescaled Range Analysis

bebado <- c(1,2,4,3,8,2,0,1,9)

m_bebado <- mean(bebado)

sum(bebado[1:3] - m_bebado)

sum(bebado[4:6] - m_bebado)

sum(bebado[7:9] - m_bebado)

sdx <- c(sum(bebado[1:3] - m_bebado),sum(bebado[4:6] - m_bebado),
         sum(bebado[7:9] - m_bebado) )

max(sdx)-min(sdx)/sqrt(sum((sdx - m_bebado)^2))


## 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")}
}


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

## ----po-assumpts-support,h=3.5,w=3.5,ps=7,cap='Checking PO assumption separately for a series of predictors.  The circle, triangle, and plus sign correspond to $Y \\geq 1, 2, 3$, respectively.  PO is checked by examining the vertical constancy of distances between any two of these three symbols.  Response variable is the severe functional disability scale \\co{sfdm2} from the $1000$-patient SUPPORT dataset, with the last two categories combined because of low frequency of coma/intubation.',scap='Simple method for checking PO assumption using stratification'----
require(Hmisc)
getHdata(support)
sfdm <- as.integer(support$sfdm2) - 1
sf <- function(y)
  c('Y>=1'=qlogis(mean(y >= 1)), 'Y>=2'=qlogis(mean(y >= 2)),
    'Y>=3'=qlogis(mean(y >= 3)))
s <- summary(sfdm ~ adlsc + sex + age + meanbp, fun=sf,
             data=support)
plot(s, which=1:3, pch=1:3, xlab='logit', vnames='names',
     main='', width.factor=1.5)   # Figure (*\ref{fig:tordinal-po-assumpts-support}*)

## ----glyhb,h=3.25,w=6.5,cap='Transformed empirical cumulative distribution functions stratified by body frame in the \\co{diabetes} dataset.  Left panel: checking all assumptions of the parametric ANOVA.  Right panel: checking all assumptions of the PO model (here, Kruskal--Wallis test).',scap='Checking assumptions of PO and parametric model'----
getHdata(diabetes)
a <- Ecdf(~ log(glyhb), group=frame, fun=qnorm,
       xlab='log(HbA1c)', label.curves=FALSE, data=diabetes,
       ylab=expression(paste(Phi^-1, (F[n](x))))) # Fig. (*\ref{fig:tordinal-glyhb}*)
b <- Ecdf(~ log(glyhb), group=frame, fun=qlogis,
          xlab='log(HbA1c)', label.curves=list(keys='lines'),
          data=diabetes, ylab=expression(logit(F[n](x))))
print(a, more=TRUE, split=c(1,1,2,1))
print(b, split=c(2,1,2,1))

## ----eval=FALSE---------------------------------------------------------------
## y ~ cohort + X1 + X2 + X3 + ...

## ----eval=FALSE---------------------------------------------------------------
## y ~ cohort*(X1 + X2) + X3

## ----eval=FALSE---------------------------------------------------------------
## u <- cr.setup(Y)         # Y=original ordinal response
## attach(mydata[u$subs,])  # mydata is the original dataset
##                          # mydata[i,] subscripts input data,
##                          # using duplicate values of i for
##                          # repeats
## y      <- u$y            # constructed binary responses
## cohort <- u$cohort       # cohort or risk set categories
## f <- lrm(y ~ cohort*age + sex)


#
# Don't complain; just work harder! Dan Stanford
#
# Our responsibility is to do what we can, learn what we can, improve the solutions, and pass them on. RF
#
# @author: me@andreagirardi.it
# @since: Wed Jan 22 17:29:30 CET 2020
# @project: RExercises
# @module: ggplot2 samples
# @desc:
#
# @prerequisite
#   install.packages('ggplot2')
#   library(ggplot2)
#   library(ggthemes)
#   mtcars

> library(ggplot2)
> library(dplyr)

# Import data
> setwd('BootcampWithR/MoneyBall')
> batting <- read.csv('Batting.csv')
> salaries <- read.csv('Salaries.csv')

# Use head() to check out the batting
> head(batting)

# Use str() to check the structure.
> str(batting)

# Call the head() of the first five rows of AB (At Bats) column
> head(batting[,'AB'])

# Call the head of the doubles (X2B) column
> head(batting[,'X2B'])

# ### Feature Engineering ###

# Create a new column called BA and add it to our data frame with Batting Average (Hits / AtBat)
> batting$BA <- batting$H / batting$AB

# Check the last 5 entries of the BA column of your data frame and it should look like this
> tail(batting$BA,5)

# Select TOP 100
> select(batting, playerID, yearID, H, AB, BA) %>% filter(BA > 0 & BA < 1) %>% arrange(desc(BA)) %>% head(100)

# onBase percentage (H + BB + HBP) / (AB + BB + HBP + SF)
> batting$OBP <- (batting$H + batting$BB + batting$HBP) / (batting$AB + batting$BB + batting$HBP + batting$SF)

# Select TOP 5
> select(batting, playerID, yearID, H, AB, BA, OBP) %>% filter(OBP > 0 & OBP < 1) %>% arrange(desc(OBP)) %>% head(5)

# Create X1B (Singles)
# Subtracting doubles,triples, and home runs from total hits (H): 1B = H-2B-3B-HR
> batting$X1B <- (batting$H - batting$X2B - batting$X3B - batting$HR)

# Create Slugging Average (SLG) : Slugging percentage represents the total number of bases a player records per at-bat.
# Forumula:  (1B + 2Bx2 + 3Bx3 + HRx4)/AB
> batting$SLG <- (batting$X1B + ( batting$X2B * 2) + ( batting$X3B * 3) + (batting$HR * 4) ) / batting$AB

# Select TOP 5
> select(batting, playerID, yearID, H, AB, BA, OBP, SLG) %>% filter(SLG > 0 & SLG < 1) %>% arrange(desc(SLG)) %>% head(5)

# Merging Salary Data with Batting Data
> select(salaries, playerID, teamID, yearID, salary) %>% arrange(desc(salary)) %>% head(5)

# reassign batting to only contain data from 1985 and onwards
> salaries <- subset(salaries, yearID >= 1985)
> batting <- subset(batting, yearID >= 1985)

# Merge the batting and sal data frames by c('playerID','yearID')
> combo <- merge(batting, salaries, by = c('playerID', 'yearID'))

# Analyzing the Lost Players
# Use the subset() function to get a data frame called lost_players from the combo data frame consisting of those 3 players.
# Hint: Try to figure out how to use %in% to avoid a bunch of or statements!
> lostPlayer <- subset(combo, playerID %in% c('giambja01', 'saenzol01', 'damonjo01'))

# Use subset again to only grab the rows where the yearID was 2001.
> lostPlayer <- subset(lostPlayer, yearID %in% c('2001'))
> lostPlayer <- select(lostPlayer, playerID, H, X2B, X3B, HR, OBP, SLG, BA, AB)

# Altenrnative
# lostPlayer <- lostPlayer[, c('playerID', 'H', 'X2B', 'X3B', 'HR', 'OBP', 'SLG', 'BA', 'AB')]

# Replacement Players
# Find Replacement Players for the key three players we lost! However, you have three constraints:
# The total combined salary of the three players can not exceed 15 million dollars.
# Their combined number of At Bats (AB) needs to be equal to or greater than the lost players.
# Their mean OBP had to equal to or greater than the mean OBP of the lost players
# Use the combo dataframe you previously created as the source of information! Remember to just use the 2001 subset of that dataframe.
# There's lost of different ways you can do this, so be creative! It should be relatively simple to find 3 players that satisfy the requirements,
# note that there are many correct combinations available!
#
# Requirements:
#       1469 AB         486 each
#       AVG 0.365 OBP
#       15 millions
#
#        playerID   H X2B X3B HR       OBP       SLG        BA  AB
# 5141  damonjo01 165  34   4  9 0.3235294 0.3633540 0.2562112 644
# 7878  giambja01 178  47   2 38 0.4769001 0.6596154 0.3423077 520
# 20114 saenzol01  67  21   1  9 0.2911765 0.3836066 0.2196721 305
#
> combo <- subset(combo, yearID == '2001')

> ggplot(combo, aes(x=OBP, y=salary)) + geom_point(size = 10)

# Remove not relevalt or too high payrol (i.e. peopble went on base 0% or 100%)
> combo <- subset(combo, salary < 8000000 & OBP > 0 &  AB >= 450)

# Find replace players
> select(combo, playerID, OBP, AB) %>% arrange(desc(OBP)) %>% head(10)


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)


#' Title
#'
#' @param p numeric
#' @param r numeric
#' @param t numeric
#'
#' @return numeric
#' @export
#'
#' @examples
#' compounding_interest(6, 0.0425, 6) # 1283.68
compounding_interest <- function(p, r, t) {
  p*((1+r/100)^t) # Enter Rate of Interest(r) in Percentage Form
  #not in decimals.
}


#factorization of data - factor() usefull when working with vector of strings, because each string is represented only once
data = c(1,2,2,3,1,2,3,3,1,2,3,3,1)
fdata = factor(data)
levels(fdata) #returns vector of the different values in the factor -> always as string

#defining the lables changes the whole factor
rdata = factor(data, labels = c("I", "II", "III"))
#changing the levels of an existing factor changes the whole factor
levels(fdata) = c("a", "b", "c")

mons = c("March", "April", "January", "November", "January", "September",
         "October", "September", "November", "August", "January", "November",
         "November", "February", "May", "August", "July", "December",
         "August", "August", "September", "November", "February", "April")
fmons = factor(mons, ordered = TRUE) #the labels are ordered in alphabetical order
tmons = table(fmons) #table showing each label how many times can be found in the factor

fert = c(10, 20, 20, 50, 10, 20, 10, 50, 20)
ffert = factor(fert, levels = c(10, 20, 50), ordered = TRUE)
mean(as.numeric(ffert)) #error - wrong mean
mean(as.numeric(levels(ffert)[ffert])) #correct mean

prop.table(tmons) #probability each month to be found in the table of factored mons

#lists - vectors that can have different type and length, can and should have labels for access (a = ,b = , c = )
mylist = list(a = 1:5, b = "Hi there!", c = function(x) x * sin(x))

#accessing
mylist[1] #returns list of the first vector (the firts element of the list)
mylist[[1]] #returns vector using index
mylist[["b"]] #returns vector using the label
mylist$b #returns vector using the label -> easier and more commonly used
mylist$a[3] #returns the element from the vector with this label
length(mylist) #length of the list
length(mylist$b) #length of the firts element of the list
mylist$d = "new item" #appending new elements
mylist$b = NULL #deleting an element
unlist(mylist) #deleting the list

#data frames - list with equal length of all vectors
n = c(2,3,5)
s = c("aa", "bb", "cc")
b = c(TRUE, FALSE, TRUE)
df = data.frame(n,s,b) #creating the data frame -> every vector is a new column with n rows

#access like a list
df$s #returns a factor???
df[2] #returns a vector(column) ???
df[2,2] #returns the element in row 2 column 2 (but as factor???)
head(df, n = 2) #returns the first n rows from the data frame (default n = 6)
tail(df, n = 2) #returns the last n rows from the data frame (default n = 6)

#reading data
#read.table("url address or apth to file") -> when the file is organised like a table
#read.csv("url address or apth to file") or read.csv2() -> redaing a csv file

#graphics
#plot() -> normal xy graphic (use ?plot in console for details)
#barplot() -> barplot with veritcal or horizontal lines (use ?barplot in console for details)
#pie() -> pie chart (use ?pie in console for details)
#boxplot() -> used for finding median, quantil or outliers

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

#01
x1 = list(1,2,3,4) #list with 4 elements each of with an integer
x2 = list(1:4) #list with one element - vector of integers from 1 to 4
x1[1] #firts element of the list wich is a vector with length one having the integer 1
x1[[1]] #first element of the first element of the list

#02
# 1. all cars with 7 cyl -> different ways to get the same answer
res1 = mtcars[which(mtcars$cyl == 8),]
res2 = mtcars[mtcars$cyl == 8,]
res3 = subset(mtcars, mtcars$cyl == 8)
# 2. average mpg for cars with 5 gears -> different ways to get the same answer
res1.2 = mean(mtcars[mtcars$gear == 5,]$mpg)
res2.2 = mean(mtcars$mpg[mtcars$gear == 5])

#03
library("MASS")
barplot(table(survey$Sex, survey$Smoke), beside = TRUE, legend = levels(survey$Sex))
boxplot(survey$Height~survey$Sex)
hist(survey$Pulse)


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)
}


# Set Random Seed
set.seed(123)
# Create Time Index
t <- 1:(length(SPY)-1)
# Tradable Capital Vector
Vt <- c(rep(10000, length(t)))
# Benchmark Return Series
Rb <- rep(NA, length(t))
for(i in 2:length(t)) { Rb[i] <- (SPY[i] / SPY[i - 1]) - 1 }

# Benchmark Equity Curve
Eb <- rep(NA, length(t))
Eb[1] <- Vt[1]
for(i in 2:length(t)) { Eb[i] <- Eb[i-1] * (1 + Rb[i]) }
# Randomly Simulated Return Series 1
Rt <- rep(NA, length(t))
for(i in 2:length(t)){
Rt[i] <- Rb[i] + rnorm(n = 1,
mean = 0.24/length(t),
sd = 2.5 * sd(Rb, na.rm = TRUE))
}
# Randomly Simulated Return Series 2
Rt2 <- rep(NA, length(t))
for(i in 2:length(t)){
Rt2[i] <- Rb[i] + rnorm(n = 1,
mean = 0.02/length(t),
sd = .75 * sd(Rb, na.rm = TRUE))
}
# Randomly Simulated Equity Curve 1
Et <- rep(NA, length(t))
Et <- Vt[1]
for(i in 2:length(t)) { Et[i] <- Et[i-1] * (1 + Rt[i]) }
# Randomly Simulated Equity Curve 2
Et2 <- rep(NA, length(t))
Et2 <- Vt[1]
for(i in 2:length(t)) { Et2[i] <- Et2[i-1] * (1 + Rt2[i]) }
# Plot of Et1 against the SPY Portfolio
plot(y = Et, x = t, type = "l", col = 1,
xlab = "Time",
ylab= "Equity ($)",
main = "Figure 1–3: Randomly Generated Equity Curves")
grid()
abline(h = 10000)
lines(y = Et2, x = t, col = 2)
lines(y = Eb, x = t, col = 8)
legend(x = "topleft", col = c(1,2,8), lwd = 2, legend = c("Curve 1",
"Curve 2",
"SPY"))


# 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)


require(PerformanceAnalytics)
charts.PerformanceSummary(cbind(bmkReturns,myReturns))

Performance <- function(x) {

	cumRetx = Return.cumulative(x)
	annRetx = Return.annualized(x, scale=252)
	sharpex = SharpeRatio.annualized(x, scale=252)
	winpctx = length(x[x > 0])/length(x[x != 0])
	annSDx = sd.annualized(x, scale=252)

	DDs <- findDrawdowns(x)
	maxDDx = min(DDs$return)
	maxLx = max(DDs$length)

	Perf = c(cumRetx, annRetx, sharpex, winpctx, annSDx, maxDDx, maxLx)
	names(Perf) = c("Cumulative Return", "Annual Return","Annualized Sharpe Ratio",
		"Win %", "Annualized Volatility", "Maximum Drawdown", "Max Length Drawdown")
	return(Perf)
}
cbind(Me=Performance(myReturns),SP500=Performance(bmkReturns))

rprojectSPL/BackTest/200DaysHigh/2. Assess Peformance.R .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))