# Altitude analysis in continuation with v08. Here we seek out the difference
# between barometric formula height and real height.

source('./drifts/analysis_08.r', encoding = 'UTF-8')
source('./drifts/analysis_15.r', encoding = 'UTF-8')

df.altitude <- data.table::data.table('logger' = names(altitude.m.bf), altitude.m.bf)

location <- function(logger.name) {
  sub('[^/]*/([^_]+).*', '\\1', logger.name)
}

df.altitude[, location := location(logger)]

df.altitude <- merge(
  x = df.altitude,
  y = read.csv('./../../data/meta/inbo/baro_height_dtm.csv',
               dec = ',', sep = ';', na.strings = 'NULL', stringsAsFactors = FALSE)[, c('Peilpunt', 'RASTERVALU')],
  by.x = 'location', by.y = 'Peilpunt', all = TRUE
)

hist(df.altitude$altitude.m.bf - df.altitude$RASTERVALU, breaks = 100, main = '',
     xlab = 'Differences between barometric altitude (m) and TAW')
plot(df.altitude$RASTERVALU, df.altitude$altitude.m.bf, xlab = 'TAW (m)', ylab = 'Barometric altitude (m)')
summary(fit.lm <- lm(formula = altitude.m.bf ~ RASTERVALU, data = df.altitude))
summary(fit.qr <- quantreg::rq(formula = altitude.m.bf ~ RASTERVALU, data = df.altitude))

ggplot2::ggplot(data = df.altitude, mapping = ggplot2::aes(x = RASTERVALU, y = altitude.m.bf)) +
  ggplot2::geom_point() +
  #ggplot2::geom_smooth(method = 'lm', formula = y ~ x, col = 'yellow', size = 1.2, alpha = 0.9) +
  ggplot2::geom_quantile(quantiles = 0.5, formula = y ~ x, col = 'blue', size = 1.2, alpha = 0.9) +
  ggplot2::theme_light() +
  ggplot2::xlab('TAW (m)') +
  ggplot2::ylab('Barometric altitude (m)')

df.altitude[, 'altitude.m.pred' := predict(fit.qr, newdata = data.frame('RASTERVALU' = RASTERVALU))]
df.altitude[, 'altitude.m.diff' := abs(altitude.m.bf - altitude.m.pred)]
df.altitude[, 'N' := vapply(logger, function(name) NROW(df.list[[name]]), 1)]
df.altitude[, 'n.obs' :=  round(x = N, digits = -1L)]
df.altitude[order(altitude.m.diff, decreasing = TRUE), ]

df.altitude <- merge(x = df.altitude, y = stats, by = 'n.obs', all = TRUE)
df.altitude[n.obs > max(stats$n.obs), sd := min(stats$sd)]
df.altitude[, altitude.m.e_err := 2*sd*2 * 100/12]
df.altitude[, altitude.m.rel_err := altitude.m.diff/altitude.m.e_err]
df.altitude[order(altitude.m.rel_err, decreasing = TRUE), ]

ggplot2::ggplot(data = df.altitude, mapping = ggplot2::aes(x = RASTERVALU, y = altitude.m.bf, color = altitude.m.rel_err)) +
  ggplot2::geom_point() +
  ggplot2::scale_color_gradient(low="green", high="red") +
  #ggplot2::geom_smooth(method = 'lm', formula = y ~ x, col = 'yellow', size = 1.2, alpha = 0.9) +
  ggplot2::geom_quantile(quantiles = 0.5, formula = y ~ x, col = 'blue', size = 1.2, alpha = 0.9) +
  ggplot2::theme_light() +
  ggplot2::xlab('TAW (m)') +
  ggplot2::ylab('Barometric altitude (m)')

ggplot2::ggsave('./drifts/analysis_16/baro_altitudes_bf_vs_taw.png', width = 1280/96, height = 720/96, dpi = 96)

write.csv(df.altitude[order(altitude.m.rel_err, decreasing = TRUE), ],
          file = './drifts/analysis_16/baro_altitudes_calculations.csv', row.names = FALSE)


library(corrplot)

source("C:\\Work\\movieProject\\MovieProjectShikha\\code\\helperFunction.r")
dataPath <- "C:\\Work\\movieProject\\MovieProjectShikha\\data\\dataExtract\\movie_data.csv"
#### Factor Model
allData = loadData(dataPath)

genreRoiAll = getGenreData(allData)
genreRoi = genreRoiAll[(!genreRoiAll$ROI=='NA'),][, list(Med_ROI=median(ROI),Med_NetProfit=median(NetProfit), numMovies=length(ROI)), by = Genre]
plotRoiAll = getPlotData(allData)
plotTable = plotRoiAll[(!plotRoiAll$ROI=='NA'),][, list(Med_ROI=median(ROI),Med_NetProfit=median(NetProfit),numMovies=length(ROI)), by = Plot]

### Prepare Data For Regression
RegPrep = allData[(!allData$ROI=='NA'),c('movie_title','ROI','NetProfit','director_facebook_likes','actor_1_facebook_likes','actor_2_facebook_likes','actor_3_facebook_likes','cast_total_facebook_likes','duration','genres','plot_keywords')]
colnames(RegPrep) = c('movie','ROI','NetProfit','DirectorFb','actor1Fb','actor2Fb','actor3Fb','castTotalFb','duration','genres','plot')
topGenresNP = tail(genreRoi[order(genreRoi$Med_NetProfit)])
for(g in tail(topGenresNP,5)$Genre) {
  RegPrep[,paste('is',g,sep='')]= apply(RegPrep, 1, function(x) as.numeric(is.element(g,strsplit(x[10],'\\|')[[1]])) )
}
### Creating the unified genreRank
RegPrep[,'genreRank'] = apply(RegPrep, 1, function(x) genreRank(genreRoi,x[10]) )
#### Creating the unified plotRank
RegPrep[,'plotRank'] = apply(RegPrep, 1, function(x) plotRank(plotTable,x[11]) )

regData = RegPrep[,c('ROI','NetProfit', 'DirectorFb', 'actor1Fb', 'actor2Fb', 'actor3Fb', 'castTotalFb', 'isMusic', 'isFantasy', 'isHorror', 'isAnimation', 'isFamily','duration','genreRank', 'plotRank')]
regData = sapply(regData,as.double)
regData[is.na(regData)]=0

## Bound the Data for reducing the impact of outliers
columnsToBound = c('ROI','NetProfit','DirectorFb','actor1Fb','castTotalFb','genreRank','plotRank')
bndPercentile=0.95
for(n in columnsToBound) {
  print(n)
  bnd = as.double(quantile(abs(regData[,n]),bndPercentile,na.rm = TRUE))
  regData[abs(regData[,n])>bnd,n] = sign(regData[abs(regData[,n])>bnd,n])*bnd
}
regData = as.data.frame(regData)

#### Correlation Analysis: Before we go ahead with regression we do a basic correlation analysis
png(filename = 'results\\preProcessGraphs\\factorCorr.png')
respCor = cor(regData)
corrplot(respCor,type='upper',mar = c(5,0,5,0))
dev.off()
#### We see FB Likes are highly correlated

##### ROI Regression :
#### Regression Model 1 : ROI ~ DirectorFb+castTotalFb+isMusic+isFantasy+isHorror+isAnimation+isFamily+duration+genreRank+plotRank
reg1 = lm(formula = ROI ~ DirectorFb +castTotalFb+isMusic+isFantasy+isHorror+isAnimation+isFamily+duration+genreRank+plotRank, data = regData)
summary(reg1)
#After t-stat based factor selection
#### Regression Model 2 : ROI ~ DirectorFb+isMusic+isFantasy+isHorror+plotRank
reg2 = lm(formula = ROI ~ DirectorFb+isMusic+isFantasy+isHorror+plotRank, data = regData)
summary(reg2)
##### Note F-stat jumps
plot(regData$DirectorFb,regData$ROI,col='blue')
regData$plotRank2 = regData$plotRank*regData$plotRank
## Post regression analysis
plot(regData$ROI,fitted(reg2), col='blue')
plot(reg2)

##### NetProfit Regression :
#### Regression Model 3 : NetProfit ~ DirectorFb +castTotalFb+isMusic+isFantasy+isHorror+isAnimation+isFamily+genreRank+plotRank
reg3 = lm(formula = NetProfit ~ DirectorFb +castTotalFb+isMusic+isFantasy+isHorror+isAnimation+isFamily+duration+genreRank+plotRank, data = regData)
summary(reg3)
#After t-stat based factor selection ## Note that different factors are getting selected.
#### Regression Model 4 : NetProfit ~ DirectorFb +castTotalFb+isMusic+isFantasy+isHorror+isAnimation+isFamily+genreRank+plotRank
reg4 = lm(formula = NetProfit ~ DirectorFb +castTotalFb+isHorror+isFamily+genreRank+plotRank, data = regData)
summary(reg4)
#### As expected there is considerable improvement in F-stat
#### Post regression analysis


#' Catch 4 panel plots by fleet
#'
#' Shows observed and predicted catch regular and log scale, residuals over time, and resid histogram.
#' @param asap name of the variable that read in the asap.rdat file
#' @param fleet.names names of fleets
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @param liz.palette color definitions
#' @export

PlotCatch4Panel <- function(asap,fleet.names,save.plots,od,plotf,liz.palette){
  par(mar=c(4,4,3,2), oma=c(1,1,1,1), mfrow=c(2,2)  )
  for (i in 1:asap$parms$nfleets) {
    catch.yrs = which(asap$catch.obs[i,]>0)
    x.yrs = as.numeric(names(catch.yrs))
    plot(x.yrs, asap$catch.obs[i,catch.yrs] ,
         type='p', col=liz.palette[i], pch=1, xlab="Year", ylab="Total Catch",
         ylim=c(0, 1.1*max(asap$catch.obs[i,catch.yrs] )) )
    lines(x.yrs, asap$catch.pred[i,catch.yrs], col=liz.palette[i], lwd=2)

    sigma <- sqrt(log(asap$control.parms$catch.tot.cv[catch.yrs,i]^2+1.0))
    log.ob.min <- log(asap$catch.obs[i,catch.yrs])-1.96*sigma
    log.ob.max <- log(asap$catch.obs[i,catch.yrs])+1.96*sigma
    plot(x.yrs, log(asap$catch.obs[i,catch.yrs]) ,
         type='p', col=liz.palette[i], pch=1, xlab="Year", ylab="Ln(Total Catch)",
         ylim=c(min(log.ob.min,log(asap$catch.pred[i,catch.yrs])),
                1.1*max(log.ob.max,log(asap$catch.pred[i,catch.yrs]))) )
    lines(x.yrs, log(asap$catch.pred[i,catch.yrs]), col=liz.palette[i], lwd=2)
    arrows(x.yrs, log.ob.min, x.yrs, log.ob.max, length=0)
    title (paste0("Fleet ",i, " Catch  (", fleet.names[i], ")"), outer=T, line=-1 )

    c.resid <- rep(NA, length(catch.yrs))
    c.resid <- asap$catch.std.resid[i, catch.yrs]
    plot(x.yrs, c.resid, type='h', lwd=2, col=liz.palette[i],
         xlab="Year", ylab="Log-scale Std. Residual")
    abline(h=0)

    hist(c.resid, plot=T, xlab="Std. Residual", ylab="Probability Density", freq=F, main=NULL)
    if (save.plots) savePlot(paste0(od, "Catch.4panel.",i,".",plotf), type=plotf)
  } #end loop nfleets
  par(mfrow=c(1,1))
}


#Copyright 2016 Lingjiao Chen, Arun Kumar, Jeffrey Naughton, and Jignesh M. Patel, Version 0.8.
#All rights reserved.
#
#Licensed under the Apache License, Version 2.0 (the "License");
#you may not use this file except in compliance with the License.
#You may obtain a copy of the License at
#
#    http://www.apache.org/licenses/LICENSE-2.0
#
#Unless required by applicable law or agreed to in writing, software
#distributed under the License is distributed on an "AS IS" BASIS,
#WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
#See the License for the specific language governing permissions and
#limitations under the License.

LogisticRegression <- function(Data,Max_Iter, winit, gamma0, Target )
{
	w = winit;
	for( k in 1: Max_Iter )
	{
		w = w - gamma0 * (t(Data) %*% (Target/(1+exp(Data%*%w))) );
	}
	return(list(w));
}


cache <- vector("integer", 0)
cache[1] <- 1
cache[2] <- 1

Q <- function(n) {
  if (is.na(cache[n])) {
    value <- Q(n-Q(n-1)) + Q(n-Q(n-2))
    cache[n] <<- value
  }
  cache[n]
}

for (i in 1:1e5) {
  Q(i)
}

for (i in 1:10) {
  cat(Q(i)," ",sep = "")
}
cat("\n")
cat(Q(1000),"\n")

count <- 0
for (i in 2:1e5) {
  if (Q(i) < Q(i-1)) count <- count + 1
}
cat(count,"terms is less than its preceding term\n")


library(infotheo)
ordenado <- sort(iris$Sepal.Width,decreasing = FALSE)

# Se hace el bining y en bin_eq_freq van a quedar los nros de bin numerados del 1 al 5
bin_eq_freq <- discretize(ordenado,"equalfreq", 5)

# Creo una columna con los valores de Sepal.Width para poder calcular la media
bin_eq_freq$Sepal.Width = sort(iris$Sepal.Width,decreasing = FALSE)

# Creo un colunma mas llamada media y la inicializo en cero
bin_eq_freq$media = rep(0,nrow(bin_eq_freq))

# Ahora para cada bin calculo la media y la asigno a la columna "media"
for(bin in 1:5){
  # Calculo la media del bin haciendo un filtro
  media.del.bin = mean(bin_eq_freq[bin_eq_freq$X == bin,]$Sepal.Width )

  # asigno el valor de la media del bin
  bin_eq_freq[bin_eq_freq$X == bin,]$media = media.del.bin
}

# grafico Sepal.Width ordenado de menor a mayor
plot(sort(iris$Sepal.Width,decreasing = FALSE) , type = "l", col="red", ylab = "Sepal.Width")
# Agrego la serie de la variable media
lines(bin_eq_freq$media,type = "l", col="blue")


#Install and load the kknn package
#install.packages("kknn")
library(kknn)

# assign data to df called "ccdata"
ccdata <- data

# split dataset into training, validation, and testing sets comprising 70%, 15%, and 15% of ccdata respectively
splitSample <- sample(1:3, size=nrow(ccdata), prob=c(0.70,0.15,0.15), replace = TRUE)
train <- ccdata[splitSample==1,]
valid <- ccdata[splitSample==2,]
test <- ccdata[splitSample==3,]

### Set up knn
ccdata_kknn <- kknn(formula = formula(R1~.), train, test, na.action = na.omit(), k=3, distance = 12, kernel = "optimal", scale=TRUE)
ccdata_kknn
kknn.dist(train, test, k=10, distance=2)

#view predictions
pred_kknn <- predict(ccdata_kknn,ccdata[,1:10])
pred_kknn

# get model accuracy
pred_knn <- rep(0, (nrow(ccdata)))
pred_knn[i] <- as.integer(fitted(CCmodel_knn)+0.5)
sum(pred_knn == ccdata$R1)/nrow(ccdata)

# Find best K value
accuracy=numeric()
n<-nrow(data)
for(kvalue in 1:20)
{
  predicted <- rep(0, nrow(data))
  for(i in 1:n){
    model = kknn(R1~.,data[-i,], data[i,],k=kvalue, scale=TRUE)
    # Get result
    predicted[i] <-as.integer(fitted(model)+0.5)
    print(predicted)
  }

  accuracy = c(accuracy,sum(predicted==data[,11])/nrow(data))

}

accuracy
bestaccuracy <- max(accuracy)
bestaccuracy

bestk <- which.max(accuracy)
bestk

kmax <- 20
accuracy_cv <- rep(0,kmax)

#kfold validation
for (k in 1:kmax){
  kmodel <- cv.kknn(R1~.,data,kcv=10, k=k, scale=TRUE)
  predicted <- as.integer(kmodel[[1]][,2] + 0.5) #print yhat and convert to 0 or 1
  accuracy_cv[k]= sum(predicted == data$R1)
}

#kmodel
accuracy_cv
max(accuracy_cv)
which.max(accuracy_cv)

# split dataset into training, validation, and testing sets comprising 70%, 15%, and 15% of ccdata respectively
splitSample <- sample(1:3, size=nrow(ccdata), prob=c(0.70,0.15,0.15), replace = TRUE)
training <- ccdata[splitSample==1,]
validation <- ccdata[splitSample==2,]
testing <- ccdata[splitSample==3,]

#HW code
kknn_model <- kknn(formula = formula(training), training, testing, na.action = na.omit(),
                   k = 22, distance = 2, kernel = "optimal", ykernel = NULL, scale=TRUE,
                   contrasts = c('unordered' = "contr.dummy", ordered = "contr.ordinal"))
fit = fitted(model)

#build model
kknn(formula = formula(R1~.), training, testing, na.action = na.omit(), k=5, distance = 2, kernel = "optimal", scale=TRUE)
#Build cross validation
cv.kknn(validation, testing, kcv=10, distance=2)

#view predictions
pred_kknn <- predict(ccdata_kknn,ccdata[,1:10])
pred_kknn

# get model accuracy
pred_knn <- rep(0, (nrow(ccdata)))
pred_knn[i] <- as.integer(fitted(CCmodel_knn)+0.5)
sum(pred_knn == ccdata$R1)/nrow(ccdata)

# cross validation
m<-nrow(data)

#set 2 model based on different kernel, kmax and 2 different destination values
kknn1<-train.kknn(R1 ~ ., data=training, kernel = c("rectangular", "epanechnikov", "triangular", "optimal"), distance=1, kmax= 100, scale=TRUE)
kknn2<-train.kknn(R1 ~ ., data=training, kernel = c("rectangular", "epanechnikov", "triangular", "optimal"), distance=2, kmax= 100, scale=TRUE)

kknn1
#kknn1
#Type of response variable: continuous
#minimal mean absolute error: 0.1834061
#Minimal mean squared error: 0.1018426
#Best kernel: triangular
#Best k: 34

kknn2
#kknn2
#Type of response variable: continuous
#minimal mean absolute error: 0.1746725
#Minimal mean squared error: 0.1011238
#Best kernel: triangular
#Best k: 48

#choose model based on kknn2 specification above
bestmodel<-kknn(R1 ~ ., validation, testing, k=48, kernel ="triangular", distance=2, scale=TRUE)

modelPred <- as.integer(bestmodel$fitted.values +0.5)
accuracy2 = sum(modelPred == d.test2[,11]) / nrow(d.test2)
accuracy2

#> accuracy2
#[1] 0.8061224
#best K=48


suppressPackageStartupMessages(library(float))

x = matrix(1:30, 10)
y = matrix(1:9, 3)

x_y = x %*% y

xs = fl(x)
ys = fl(y)

test = dbl(xs %*% ys)
stopifnot(all.equal(test, x_y))

test = dbl(xs %*% y)
stopifnot(all.equal(test, x_y))

test = dbl(x %*% ys)
stopifnot(all.equal(test, x_y))

storage.mode(x) = "double"
storage.mode(y) = "double"

test = xs %*% y
stopifnot(all.equal(test, x_y))

test = x %*% ys
stopifnot(all.equal(test, x_y))


# Function that adjusts the prevalence
# estimates for test sensitivity and specificity
# in classical way
# We require a specific version of GJRM:
# remotes::install_version("GJRM", "0.2-2")
library(GJRM)

adjust_prev_test_chars <- function(prev_object, sensitivity = 1, specificity = 1) {

	# Debug: prev_object <- prev(out.basic.iga_g_m.param$fit, type = "naive", delta = T); sensitivity = 0.99; specificity = 0.98

	if(!is.na(prev_object$sim.prev)) {

		stop("Test quality adjustment is available only for delta method-computed prevalence confidence intervals")

	}

	# Extract SEs from CI bounds
	point_est <- prev_object$res[2]
	lb <- prev_object$res[1]
	qz <- qnorm(prev_object$prob.lev/2, lower.tail = F)

	sv <- (point_est - lb)/qz

	# Adjust point estimates and SEs for test characteristics
	point_est_adj <- (point_est + specificity - 1)/(sensitivity + specificity - 1)

	sv_adj <- sv/(sensitivity + specificity - 1)

	# Calculate new upper/lower b
	lb_adj <- point_est_adj - qz * sv_adj
	ub_adj <- point_est_adj + qz * sv_adj

	# Output
	res <- c(lb_adj, point_est_adj, ub_adj)
	out <- list(res = res, sv = sv_adj, prob.lev = prev_object$prob.lev, sim.prev = NA, sensitivity = sensitivity, specificity = specificity)
	class(out) <- "prev"
	out

}


library('lattice')
train.data <- data.set$training
train.data[,1:41] <- data.matrix(train.data[,1:41])
pca <- prcomp(train.data[,c(2,3,4,5,6,12,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41)],
              retx=TRUE, center=TRUE, scale=TRUE)
new.train.data = predict(pca, train.data[,c(2,3,4,5,6,12,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41)])
km = kmeans(new.train.data, centers=10)
cluster = km$cluster
new.train.data = cbind(new.train.data, cluster)
new.train.data = as.data.frame(new.train.data)
xyplot(PC1 ~ PC2, group=cluster, data=new.train.data)


unique_transactions = "unique_transactions.txt"
first_digit = "first_digit.txt"
DKl_file = "Dkl.txt"
Q_file = "Q.txt"
P_file = "P.txt"
final_data = "final.txt"

obligation_col = 3 #total obligation isin  column 3
id_col = 2 #recipient id is in column 2

#read in the transactions as table
lines = readLines(file_path)
transactions = read.table(text = lines, sep = ",")

#replace the obligation column with the first digit of the total obligation
transactions[,obligation_col] = substring(chunk[,obligation_col],1L,1L)

transactions = transactions[,id_col:obligation_col] #get only recipient id and total obligation
colnames(transactions) = c("recipient_id","first_digit") #assign column names

transactions = na.omit(transactions) #ignore the cases starts with -
transactions = transactions[-which(transactions$first_digit==0),] #ignore the cases starts with 0
cont_table = table(transactions$recipient_id,transactions$first_digit) #get the contigency table of the count of 1-9 for each agency

#write the number of times 1-9 appear as the first digit for each agency to the first_digit file
write.table(cont_table, first_digit, sep = ",", quote = FALSE)

#exclude recipients that have fewer than 100 transactions and write it to the final_data file for final analysis
meaningful = cont_table[which(rowSums(cont_table)>100,),]
write.table(meaningful,final_data,sep = ",",quote = FALSE)

#get P,Q,Dkl
P = prop.table(meaningful)
Q = prop.table(colSums(meaningful))
Dkl = rowSums(P*log(P/Q))

write.table(P,P_file,sep = ",",quote = FALSE)
write.table(Q,Q_file,sep = ",",quote = FALSE)
write.table(Dkl, DKl_file, sep = ",", quote = FALSE)


# b
set.seed(79)
num_rep <- 200
bandwidths <- c(as.list(2^seq(-5, 1, 0.2)), "sj")
results_mat <- matrix(nrow = 32, ncol = num_rep)

xpts <- seq(-1, 5, 0.1)
dmix <- 0.2 * dnorm(xpts, mean = 0, sd = sqrt(0.01)) + 0.8 * dnorm(xpts, mean = 2, sd = 1)

rmix <- function(n) {
    data <- ifelse(runif(n, min = 0, max = 1) < 0.2,
    rnorm(n, mean = 0, sd = sqrt(0.01)),
    rnorm(n, mean = 2, sd = 1))
}

for (rep in 1:num_rep) {
    data <- rmix(100)
    for (idx_bw in seq_along(bandwidths)) {
        ke <- density(data, bw = bandwidths[[idx_bw]],
        kernel = "gaussian", n = 61, from = -1, to = 5)

        results_mat[idx_bw, rep] <- mean((ke$y - dmix)^2)
    }
}

print(apply(results_mat, 1, mean))

for (idx_bw in 1:32) {
    for (rep in 1:num_rep) {
        for (i in 1:100) {
            p <- runif(1, min = 0, max = 1)
            if (p < 0.2) {
                data[i] <- rnorm(1, mean = 0, sd = sqrt(0.01))
            } else {
                data[i] <- rnorm(1, mean = 2, sd = 1)
            }
        }
        ke <- density(data, bw = bandwidths[[idx_bw]]
        , n = 61, from = -1, to = 5, kernel = "epanechnikov")

        results_mat[idx_bw, rep] <- mean((ke$y - dmix)^2)
    }
}

print(rowMeans(results_mat))

# for llh, use new data
for (idx_bw in 1:31) {
    for (rep in 1:num_rep) {
        for (i in 1:100) {
            p <- runif(1, min = 0, max = 1)
            if (p < 0.2) {
                data[i] <- rnorm(1, mean = 0, sd = sqrt(0.01))
            } else {
                data[i] <- rnorm(1, mean = 2, sd = 1)
            }
        }
        ke <- density(data, bw = bandwidths[[idx_bw]]
        , n = 61, from = -1, to = 5)

        for (i in 1:100) {
            p <- runif(1, min = 0, max = 1)
            if (p < 0.2) {
                data[i] <- rnorm(1, mean = 0, sd = sqrt(0.01))
            } else {
                data[i] <- rnorm(1, mean = 2, sd = 1)
            }
        }
        estidens <- approxfun(ke$x, ke$y, rule = 2, method = "linear")
        # it matters to set rule=2 and method="linear"
        results_mat[idx_bw, rep] <- mean(log(estidens(data) + 1e-7))
    }
}

print(rowMeans(results_mat))

for (idx_bw in 1:31) {
    for (rep in 1:num_rep) {
        for (i in 1:100) {
            p <- runif(1, min = 0, max = 1)
            if (p < 0.2) {
                data[i] <- rnorm(1, mean = 0, sd = sqrt(0.01))
            } else {
                data[i] <- rnorm(1, mean = 2, sd = 1)
            }
        }
        ke <- density(data, bw = bandwidths[[idx_bw]]
        , n = 61, from = -1, to = 5, kernel = "epanechnikov")

        results_mat[idx_bw, rep] <- mean(dmix * log(ke$y))
    }
}

print(rowMeans(results_mat))


# Ternary Diagram // треугольные диаграммы
# ЧАСТЬ 1: вчитываем таблицу. делаем data.frame. удаляем NA
MDF <- read.csv("Morphology.csv", header=TRUE, sep = ",")
MDF <- na.omit(MDF)
row.has.na <- apply(MDF, 1, function(x){any(is.na(x))})
sum(row.has.na)
head(MDF)

MDTt = melt(setDT(MDF), measure = patterns("^plate"), value.name = c("tectonics"))
head(MDTt)
levels(MDTt$variable) = c("Philippine" , "Pacific", "Mariana", "Caroline")
Plates<- c("Philippine" , "Pacific", "Mariana", "Caroline")

# ЧАСТЬ 2: чертим треугольную диаграмму Марианского желоба пакетом ggtern
library(ggtern)

# вариант-1. по тектонике (4 плиты)
MDTer <- data.frame(
			x = MDTt$igneous_volc,
			y = MDTt$tectonics,
			z = MDTt$slope_angle,
			Value = MDTt$slope_angle,
			Group = as.factor(MDTt$variable))

MT1<- ggtern(data= MDTer,aes(x,y,z,color = Group)) +
	theme_rgbw() +
	geom_point() +
#	geom_path() +
	scale_color_manual(values = c("green" , "red", "orange", "blue")) +
	labs(x="Igneous \nVolcanos",y="Tectonics",z="Slope \nAngle",
  		title="Mariana Trench",
  		subtitle="Ternary Diagram: Tectonic Plates") +
  geom_Tline(Tintercept=.5,arrow=arrow(), colour='red') +
  geom_Lline(Lintercept=.2, colour='magenta') +
  geom_Rline(Rintercept=.1, colour='blue') +
  geom_confidence_tern()
MT1

# вариант-2. по классам морфология

levels(MDTt$morph_class) = c("Strong Slope", "Very Strong Slope", "Steep Slope", "Extreme Slope")
MDTM <- data.frame(
			x = MDTt$Min,
			y = MDTt$aspect_degree,
			z = MDTt$slope_angle,
			Value = MDTt$slope_angle,
			Group = as.factor(MDTt$morph_class))

MT2<- ggtern(data= MDTM,aes(x,y,z,color=Group), show.legend=TRUE) +
	theme_rgbw() +
	geom_point() +
	geom_path() +
	labs(x="Max \nDepth",y="Aspect Degree",z="Slope\nAngle",
  		title="Mariana Trench",
  		subtitle="Ternary Diagram: Slope Morphology Class") +
  geom_Tline(Tintercept=.5,arrow=arrow(), colour='red') +
  geom_Lline(Lintercept=.2, colour='magenta') +
  geom_Rline(Rintercept=.1, colour='blue') +
  geom_confidence_tern() +
  geom_Tisoprop(value=0.5) +
  geom_Lisoprop(value=0.5) +
  geom_Risoprop(value=0.5)
MT2

# вариант-3 по аспекту - разворот угла
MDTAs <- data.frame(
			x = MDTt$slope_angle,
			y = MDTt$aspect_degree,
			z = MDTt$Min,
			Value = MDTt$aspect_degree,
			Group = as.factor(MDTt$aspect_class))

MT3<- ggtern(data = MDTAs,aes(x,y,z,color = Group)) +
	theme_rgbw() +
	geom_point() +
	scale_color_manual(values = c("green", "red", "orange", "blue", "yellow" , "brown", "grey", "cyan")) +
	labs(x="Slope \nAngle", size = 1, y="Aspect \nDegree", z="Max \nDepth",
  		title="Mariana Trench",
  		subtitle="Ternary Diagram: Aspect Class") +
  geom_Tline(Tintercept=.5,arrow=arrow(), colour='red') +
  geom_Lline(Lintercept=.2, colour='magenta') +
  geom_Rline(Rintercept=.1, colour='blue') +
  geom_confidence_tern() +
  geom_Tisoprop(value=0.5) +
  geom_Lisoprop(value=0.5) +
  geom_Risoprop(value=0.5)
MT3

plot<- grid.arrange(MT1, MT2, MT3, newpage = TRUE, nrow = 1, ncol = 3, top="Mariana Trench")

# вариант-4. по толщине мор. отложений / седиментология
MD4 <- data.frame(
			x = MDTt$igneous_volc,
			y = MDTt$sedim_thick,
			z = MDTt$slope_angle,
			Value = MDTt$slope_angle)

MT4<- ggtern(data = MD4,aes(x,y,z), show.legend=TRUE) +
	theme_rgbw() +
	geom_point() +
#	geom_path(alpha = .5, lwd = 0.2) +
	labs(x="Igneous \nVolcanos", size = 0.5,y="Sedimental \nThickness",z="Slope \nAngle",
  		title="Mariana Trench",
  		subtitle="Ternary Diagram: Sedimental Thickness") +
  geom_Tline(Tintercept=.5,arrow=arrow(), colour='deeppink') +
  geom_Lline(Lintercept=.2, colour='magenta') +
  geom_Rline(Rintercept=.1, colour='springgreen') +
  geom_confidence_tern() +
  geom_smooth_tern(method = 'loess', size = .4, color = "yellow1") +
  geom_mean_ellipse (size = .5, color = "cyan")
MT4

figure <-plot_grid(MT1, MT2, MT3, MT4, labels = c("1", "2", "3", "4"), ncol = 2, nrow = 2)


sum_ <- 0
for(i in 1:999)
{
  if(i%%3==0||i%%5==0)
  {
    sum_ <- sum_+i
  }
}

print(sum_)


library(ggplot2)
source("date.r")

# Inflation ------------------------------------------------------

cpi <- read.csv("finances-cpi-west.csv")
cpi <- rbind(cpi,
  data.frame(year = 2008, month = 11, cpi = cpi$cpi[nrow(cpi)]))
cpi <- subset(cpi, (year == 2003 & month >= 4) | year > 2003)
cpi$ratio <- cpi$cpi / cpi$cpi[1]

qplot(year + month / 12, ratio, data = cpi, geom = "line", ylab = "Inflation") + xlab(NULL)
ggsave(file = "beautiful-data/graphics/daily-cpi.pdf", width = 8, height = 4)

# Interest rates -------------------------------------------------------------
# downloaded from http://research.stlouisfed.org/fred2/

mprime <- read.csv("finances-mprime.csv", stringsAsFactors = FALSE)
names(mprime) <- c("date", "mprime")
mprime$date <- as.Date(mprime$date)

fedfunds <- read.csv("finances-fedfunds.csv", stringsAsFactors = FALSE)
names(fedfunds) <- c("date", "fedfunds")
fedfunds$date <- as.Date(fedfunds$date)

irates <- subset(merge(mprime, fedfunds, by = "date"), date > as.Date("2003-03-01"))

qplot(mprime, fedfunds, data = irates)
with(irates, cor(mprime, fedfunds)) # 0.998 correlation

irates$month <- month(irates$date)
irates$year <- year(irates$date)


=begin
[((<index-ja|URL:index-ja.html>))]
= 多項式環相互変換ユーティリティー

Polynomial <-> MPolynomial の相互変換ユーティリティーです。

== ファイル名:
* ((|polyomimial-converter.rb|))

== メソッド

--- Algebra::Polynomial.convert_to(ring)
    ((<Algebra::MPolynomial|URL:m-polynomial-ja.html>)) である ((|ring|))
    に変換します。

--- Algebra::Polynomial#value_on(ring)
    ((<Algebra::MPolynomial|URL:m-polynomial-ja.html>)) である ((|ring|))
    における値を返します。

    例:
        require "m-polynomial"
        require "polynomial"

        P = Algebra::Polynomial(Integer, "x", "y", "z")
        x, y, z = P.vars
        f = x**2 + y**2 + z**2 - x*y - y*z - z*x

        MP = P.convert_to(Algebra::MPolynomial)
        p f = f.value_on(MP) #=> z^2 - zy - zx + y^2 - yx + x^2
        x, y, z = MP.vars
        p f == x**2 + y**2 + z**2 - x*y - y*z - z*x #=> true

--- Algebra::MPolynomial.convert_to(ring)
    ((<Algebra::Polynomial|URL:m-polynomial-ja.html>)) である ((|ring|))
    に変換します。

--- Algebra::MPolynomial#value_on(ring)
    ((<Algebra::Polynomial|URL:m-polynomial-ja.html>)) である ((|ring|))
    における値を返します。

    例:
        require "m-polynomial"
        require "polynomial"

        MP = Algebra::MPolynomial(Integer, "x", "y", "z")
        x, y, z = MP.vars
        f = x**2 + y**2 + z**2 - x*y - y*z - z*x

        P = MP.convert_to(Algebra::Polynomial)
        p f = f.value_on(P) #=> x^2 + (-y - z)x + y^2 - zy + z^2
        x, y, z = P.vars
        p f == x**2 + y**2 + z**2 - x*y - y*z - z*x #=> ture

=end


library(imager)

file <- system.file('extdata/parrots.png',package='imager')
parrots <- load.image(file)
parrots
#width(parrots)
#height(parrots)

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

# Original Image
plot(parrots)

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

# Simple grayscale
plot(grayscale(parrots))

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

#Blurry parrots ...
plot(isoblur(parrots,10))

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

#Edge detector along x-axis ...
plot(deriche(parrots,2,order=2,axis="x"))

#Chain operations using the pipe operator (from magrittr)
deriche(parrots,2,order=2,axis="x") %>% deriche(2,order=2,axis="y") %>% plot

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

#Histogramms
imrow(R(parrots),10) %>% plot(main="Red channel along 10th row",type="l")
imcol(R(parrots),10) %>% plot(main="Red channel along 10th line",type="l")

grayscale(parrots) %>% hist(main="Luminance values in parrots picture",breaks = 256)

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

library(ggplot2)
library(dplyr)

bdf <- as.data.frame(parrots)
bdf <- mutate(bdf,channel=factor(cc,labels=c('R','G','B')))
ggplot(bdf,aes(value,col=channel))+geom_histogram(bins=30)+facet_wrap(~ channel)


distcheck <- function(fn, repetitions=1e4, delta=3)
{
   if(is.character(fn))
   {
      fn <- get(fn)
   }
   if(!is.function(fn))
   {
      stop("fn is not a function")
   }
   samp <- fn(n=repetitions)
   counts <- table(samp)
   expected <- repetitions/length(counts)
   lbound <- expected * (1 - 0.01*delta)
   ubound <- expected * (1 + 0.01*delta)
   status <- ifelse(counts < lbound, "under",
      ifelse(counts > ubound, "over", "okay"))
   data.frame(value=names(counts), counts=as.vector(counts), status=status)
}
distcheck(dice7.vec)


#simulate some data with just core, plot and site intercepts.
#2 sites, 2 plots per site, 10 cores per plot = 40 obs
rm(list = ls())

mat <- c(rep(2,10),rep(4,10), rep(6,10), rep(8,10))
map <- c(rep(400,20), rep(200,20))
core <- (data.frame(mat,map))
core$y <- mat*0.5 + map*-0.01 + rnorm(40,2)
core$plot <- c(rep('a1',10),rep('a2',10), rep('b1',10), rep('b2',10))
core$site <- c(rep('a',20), rep('b',20))
core$intercept <- rep(1, nrow(core))
core_plot <- as.factor(core$plot)
core_site <- as.factor(core$site)
plot_plot <- as.factor(unique(core$plot))
site_site <- as.factor(unique(core$site))
y <- as.matrix(core$y)

site <- as.matrix(c(400,200))
plot <- as.matrix(c(2,4,6,8))
#mat is at the plot level
#map is at the site level
summary(lm(y ~ mat + map, data = core))

#specify JAGS model. This is general for any linear combination of x's.
jags.model = "
model {
###priors for each species*predictor*hierarchical-level
#y uncertainty prior
tau <- pow(sigma, -2)
sigma ~ dunif(0, 100)

for(j in 1:N.spp){
for(a in 1:N.core.preds){core.m[a,j] ~ dnorm(0, 1.0E-4)} #core level priors
for(b in 1:N.plot.preds){plot.m[b,j] ~ dnorm(0, 1.0E-4)} #plot level priors
for(c in 1:N.site.preds){site.m[c,j] ~ dnorm(0, 1.0E-4)} #site level priors
}

###predictor (x) values drawn from distributions.
#core values
#for(j in 1:N.core.preds){
#for(i in 1:N.core){
#core[i,j] ~ dnorm(core_mu[i,j], core_precision[i,j])
#}
#}
#plot values
#for(j in 1:N.plot.preds){
#for(i in 1:N.plot){
#plot[i,j] ~ dnorm(plot_mu[i,j], plot_precision[i,j])
#}
#}
#site values
#for(j in 1:N.site.preds){
#for(i in 1:N.site){
#site[i,j] ~ dnorm(site_mu[i,j], site_precision[i,j])
#}
#}

#combine predictors and parameters.
for(j in 1:N.spp){
for(i in 1:N.core){core.level[i,j] <- inprod(core.m[,j], core[i,])           } #core level
for(p in 1:N.plot){plot.level[p,j] <- inprod(plot.m[,j], plot[plot_plot[p],])} #plot level
for(s in 1:N.site){site.level[s,j] <- inprod(site.m[,j], site[site_site[s],])} #site level
}

#go ahead and fit means of species abundances as a linear combination of predictors and parameters.
for(i in 1:N.core){
    #log link a0 for dirlichet
    for(j in 1:N.spp){
        a0[i,j] <- core.level[i,j] + plot.level[core_plot[i],j] + site.level[core_site[i],j]
    }
  #y[i,1:N.spp] ~ ddirch(a0[i,1:N.spp])
   y[i,1:N.spp] ~dnorm(a0[i,1:N.spp], tau)
}

} #close model loop.
"

jags.data <- list(N.core = nrow(core), N.plot = length(plot_plot), N.site = length(site_site), N.spp = 1,
                  N.core.preds = 1, N.plot.preds = 1, N.site.preds = 1,
                  core = as.matrix(core$intercept), plot = plot, site = site,
                  core_plot = core_plot, core_site = core_site, plot_plot = plot_plot, site_site = site_site,
                  y = y)
                  #core_precision = core_precision, plot_precision = plot_precision, site_precision = site_precision,

jags.out <- run.jags(jags.model,
                     data=jags.data,
                     adapt = 200,
                     burnin = 1000,
                     sample = 2000,
                     n.chains=3,
                     method = 'rjags',
                     monitor = c('core.m','plot.m','site.m'))
summary(jags.out)

testing_development/dmnorm_development/hierarchical normal model core-plot-site JAGS.r


## function to create titre and efficacy profiles

draw <- function(mu_ab_d1 = mu_ab_d1, mu_ab_d2 = mu_ab_d2, mu_ab_d3, std10 = std10, ab_50 = ab_50, ab_50_severe,
                 dr_s = dr_s, dr_l = dr_l, period_s = period_s, t = t, t_d2 = t_d2, t_d3, k = k){

  # decay rates over time
  ## simple biphasic decay on natural log scale

  denom=log(exp(dr_l*period_s)+exp(dr_s*period_s))
  cum_dr_vec=log(exp(dr_s*t+dr_l*period_s)+exp(dr_l*t+dr_s*period_s))-denom
  dr_vec=c(0,diff(cum_dr_vec,1))

 # dr_vec_sub <- c(rep(dr_s, round(period_s)-1),
 #                 seq(dr_s, dr_l, length.out = round(t_period_l)-round(period_s)+1),
 #                 rep(dr_l, length(t) - round(t_period_l)))

 # dr_vec <- rep(0, length(t))
 # dr_vec[2:t_d2] <- dr_vec_sub[1:(t_d2-1)]
 # dr_vec[(2+t_d2):(t_d3+t_d2)] <- dr_vec_sub[1:((t_d3+t_d2)-(t_d2+1))]
 # dr_vec[(2+t_d2+t_d3):length(t)] <- dr_vec_sub[1:(length(t) - (t_d2+t_d3+1)) ]

  # nab titre distribution for a given vaccine product: draw from a log-normal distribution
  # here the first titre is dependent on the second but I suppose could do it the other way around

  z2 <- rnorm(1, log10(mu_ab_d2), std10)
  z3 <- log10(10^z2 * (mu_ab_d3/mu_ab_d2))
  z1 <- log10(10^z2 * (mu_ab_d1/mu_ab_d2))

  # initiate titre vector
  nt <- rep(0, length(t))
  nt[1] <- log(10^z1)
  nt[t_d2+1] <- log(10^z2)
  nt[t_d2+t_d3+1] <- log(10^z3)

  # decay antibodies over time on natural log scale
  for (i in (2:t_d2)){
    nt[i] <- nt[i-1] + dr_vec[i]
  }
  for (i in ((t_d2+2):(t_d2+t_d3))){
    nt[i] <- nt[i-1] + dr_vec[i-t_d2-1]
  }
  for (i in ((t_d2+t_d3+2):length(t))){
    nt[i] <- nt[i-1] + dr_vec[i-t_d3-1]
  }

  nt <- exp(nt) # return to linear scale

  # relate titre to efficacy over time - using log-10 parameters
  ef_infection <- 1 / (1 + exp(-k * (log10(nt) - log10(ab_50))))
  ef_severe <- 1 / (1 + exp(-k * (log10(nt) - log10(ab_50_severe))))

  # output list containing titre and vaccine efficacy
  ret <- list(titre = nt, VE = ef_infection, VE_severe = ef_severe)
  return(ret)
}

0_antibody_model_fitting/Plotting and Table Code/R/create_profile.r


multiples <- function(s) {
  c <- s[1] - floor(s[1] * 2^(-log2(s[2]))) * 2^log2(s[2])
  if (c > 0) {
    s[1] - c + s[2]
  } else {
    s[1]
  }
}

cat(sapply(lapply(strsplit(readLines(tail(commandArgs(), n=1)), ","), as.integer), multiples), sep="\n")


stdin <- file("stdin")
open(stdin)

invisible(readLines(stdin, n = 1, warn = FALSE)) # Consumes line to ignore `n`
v <- as.integer(strsplit(trimws(
  readLines(stdin, n = 1, warn = FALSE), which = "both"), " ")[[1]])
f <- as.integer(strsplit(trimws(
  readLines(stdin, n = 1, warn = FALSE), which = "both"), " ")[[1]])

close(stdin)

quartiles <- function(x) {
  y <- sort(x)
  if (length(y) %% 2 == 0) {
    return(c(
      median(y[1:(length(y) / 2)]),
      median(y),
      median(y[(length(y) / 2 + 1):length(y)])
    ))
  } else {
    return(c(
      median(y[1:(length(y) / 2)]),
      median(y),
      median(y[(length(y) / 2 + 1):length(y) + 1])
    ))
  }
}
inter_quartile <- function(v, f) {
  s <- c()
  for (i in seq_len(length(v))) {
    s <- c(s, rep(v[i], f[i]))
  }
  q <- quartiles(s)
  return(q[3] - q[1])
}
cat(sprintf("%.1f", inter_quartile(v, f)), "\n")


source("5-GISandR.r")
library(sp)
library(raster)
library(adehabitatHR)
library(tmap)

####

#
tm_shape(OA.Census) +
  tm_fill("Qualification", palette = "Reds", style = "quantile", title = "% Qualification") + tm_borders(alpha=.4) +
  tm_shape(House.Points) +
  tm_bubbles(size = "Price", col = "Price", palette = "Blues", style = "quantile", legend.size.show = FALSE, title.col = "Price Paid (£)", border.col = "black", border.lwd = 0.1, border.alpha = 0.1) +
  tm_layout(legend.text.size = 0.8, legend.title.size = 1.1, frame = FALSE)

## how many points in a polygon

library(GISTools)

house.count <- poly.counts(House.Points, OA.Census)

choropleth(OA.Census,house.count/poly.areas(OA.Census))

head(house.count)

names(house.count)

### calculating area

## change to sf

library(sf)

OA.Census.sf <- st_as_sf(OA.Census)
House.Points.sf <- st_as_sf(House.Points)

poly.areas(OA.Census) #  sp
st_area(OA.Census.sf) # sf

### KDE
kde.output <- kernelUD(House.Points, h="href", grid = 1000)
plot(kde.output)

## Raster KDE

kde <- raster(kde.output)
# sets projection to British National Grid
projection(kde) <- CRS("+init=EPSG:27700")

# density map and raster, ud is the parameter of kde
tm_shape(kde) + tm_raster("ud")

bounding_box <- bbox(Output.Areas) # zoom in an area using box
tm_shape(kde, bbox = bounding_box) +
  tm_raster("ud") #plotting the density

# add raster kde on targettted area
masked_kde <- mask(kde, Output.Areas)

# mapping kde, then add polygon layer
tm_shape(masked_kde, bbox = bounding_box) +
  tm_raster("ud", style = "quantile", n = 100, legend.show = FALSE, palette = "YlGnBu") +
  tm_shape(Output.Areas) + tm_borders(alpha=.3, col = "white") +
  tm_layout(frame = FALSE)

# compute homeranges for 75%, 50%, 25% of points, objects are returned as spatial polygon data frames
range75 <- getverticeshr(kde.output, percent = 75)
range50 <- getverticeshr(kde.output, percent = 50)
range25 <- getverticeshr(kde.output, percent = 25)

# the code below creates a map of several layers using tmap
tm_shape(Output.Areas) +
  tm_fill(col = "#f0f0f0") +
  tm_borders(alpha=.8, col = "white") +
  tm_shape(House.Points) +
  tm_dots(col = "blue") +
  tm_shape(range75) +
  tm_borders(alpha=.7, col = "#fb6a4a", lwd = 2) +
  tm_fill(alpha=.1, col = "#fb6a4a") +
  tm_shape(range50) +
  tm_borders(alpha=.7, col = "#de2d26", lwd = 2) +
  tm_fill(alpha=.1, col = "#de2d26") +
  tm_shape(range25) +
  tm_borders(alpha=.7, col = "#a50f15", lwd = 2) + tm_fill(alpha=.1, col = "#a50f15") +
  tm_layout(frame = FALSE)

##writeRaster(masked_kde, filename = "kernel_density.grd")


# Simple gmm to see how much ARI do we get in iris dataset
##########################################################
# Check lower and upper bounds for my dataset
library(mclust)
data(iris)
data <- read.csv('./iris/data_users_50.csv', sep='\t')
z_true <- data$z

A <- data[,2:5]
res <- Mclust(A)
z <- res$classification
pairs(A, col=z)
ari <- adjustedRandIndex(z_true, z)
cat("ARI with A+b:", ari)
# ARI: 0.86 ! :)
# ARI 1

A <- data[,2:4]
res <- Mclust(A)
z <- res$classification
pairs(A, col=z)
ari <- adjustedRandIndex(z_true, z)
cat("ARI with A:", ari)
# ARI: 0.5 :)
# ARI: 0.68

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

# Make the fourth dimension more separated so that it helps to find 3 clusters!
# (for the paper)
#data[data$z==0,]$b <- mean(data[data$z==0,]$b)
#data[data$z==1,]$b <- mean(data[data$z==1,]$b)
#data[data$z==2,]$b <- mean(data[data$z==2,]$b)


png("#53_blue_feathers.png", width = 480, height = 480)

# generate pairs of x-y values
x1 = c(seq(0, pi, length = 50), seq(pi, 2*pi, length = 50))
y1 = cos(x1) / sin(x1)
x2 = seq(1.02 * 2 * pi + pi/2, 4*pi + pi/2, length = 50)
y2 = tan(x2)

# set graphical parameters
op = par(bg="black", mar=rep(.5,4))

# plot
plot(c(x1, x2), c(y1, y2), type = "n", ylim = c(-11, 11))
for (i in seq(-10, 10, length = 100))
{
  lines(x1, y1 + i, col = hsv(runif(1,.65,.7), 1, 1, runif(1,.7)),
        lwd = 4 * runif(1, 0.3))
  lines(x2, y2 + i, col = hsv(runif(1,.65,.7), 1, 1, runif(1,.7)),
        lwd = 4 * runif(1, 0.3))
}
# signature
legend("bottomright", legend = "© Gaston Sanchez", bty = "n", text.col = "gray70")

dev.off()


# Packages used  : pracma
# To install pracma,type following in command line while connected to internet
# install.packages("pracma")
# package can be included by command " library(pracma) "
# for more information about pracma visit https://cran.r-project.org/web/packages/pracma/index.html

# Example : 5   Chapter : 2.5   Pageno : 86
# Inverse of Lower traingular matrix is also a lower traingular matrix
library(pracma)
L<-matrix(c(1,3,4,0,1,5,0,0,1),ncol=3)
I<-eye(3)
LI<-cbind(L,I)
R<-rref(LI)
L1<-R[,c(4:6)]
print("Inverse of L is")
print(L1)


# install.packages("vars", repos = "http://cran.us.r-project.org")
library(vars)

data <- read.csv('data.csv', header = TRUE)

# y1 and y5 are cointegrated

y1 <- data$y1
y5 <- data$y5

v1 <- cbind(y1, y5)
colnames(v1) <- cbind('y1', 'y5')

Model1 <- VAR(v1, p = 1, type = "const", season = NULL, exog = NULL)
summary(Model1)

# y2 and y3 are cointegrated

y2 <- data$y2
y3 <- data$y3

v2 <- cbind(y2, y3)
colnames(v2) <- cbind('y2', 'y3')

Model2 <- VAR(v2, p = 1, type = "const", season = NULL, exog = NULL)
summary(Model2)

# y4 and y10 are cointegrated

y4 <- data$y4
y10 <- data$y10

v3 <- cbind(y4, y10)
colnames(v3) <- cbind('y4', 'y10')

Model3 <- VAR(v3, p = 1, type = "const", season = NULL, exog = NULL)
summary(Model3)

# y6 and y10 are cointegrated

y6 <- data$y6
y9 <- data$y9

v4 <- cbind(y6, y9)
colnames(v4) <- cbind('y6', 'y9')

Model4 <- VAR(v4, p = 1, type = "const", season = NULL, exog = NULL)
summary(Model4)

# y1 = y1.l1 + y5.l1 + const
# y1.l1 = -0.066, y5.l1 = 0.481, const = 0.476

# y5 = y1.l1 + y5.l1 + const
# y1.l1 = -0.058, y5.l1 = 0.473, const = 0.056

# y1(t) = y1.l1 * y1(t-1) + y5.l1 * y2(t-1) + const
# y2(t) = y1.l1 * y1(t-1) + y5.l1 * y2(t-1) + const

#### HERE WE BUILD VAR MODEL FOR COINTEGRATED TIME SERIES Y1 and Y5

minX <- 1
maxX <- 290
xPointsForDates <- minX:maxX
l11 <- -0.066
l12 <- 0.481
c1 <- 0.476
l21 <- -0.058
l22 <- 0.473
c2 <- 0.056

y1_var = c(y1[300])
y5_var = c(y5[300])

index <- 2

for (i in (minX + 1):(maxX)) {
  y1_var[index] = l11 * y1_var[index - 1] + l12 * y5_var[index - 1] + c1
  y5_var[index] = l21 * y1_var[index - 1] + l22 * y5_var[index - 1] + c2
  index = index + 1
}

pdfName <- 'y1_and_y5_var_model.pdf'
# Open a pdf file
pdf(pdfName)
# Create a plot
plot(x = xPointsForDates, y = y1_var,
     type='l',
     pch = 16, frame = FALSE,
     xlab = '290 additional dates (after 300 previous ones)', ylab = 'y', col = '#2E9FDF')
lines(x = xPointsForDates, y = y5_var, col = '#Df2E7E', pch = 16)
# Close the pdf file
dev.off()
# Print that PDF is generated
print(sprintf('PDF %s with charts for VAR Model (y1 and y5) is generated', pdfName))

pngName <- 'y1_and_y5_var_model.png'
# Open a pdf file
png(pngName)
# Create a plot
plot(x = xPointsForDates, y = y1_var,
     type='l',
     pch = 16, frame = FALSE,
     xlab = '290 additional dates (after 300 previous ones)', ylab = 'y', col = '#2E9FDF')
lines(x = xPointsForDates, y = y5_var, col = '#Df2E7E', pch = 16)
# Close the pdf file
dev.off()
# Print that PDF is generated
print(sprintf('PNG %s with charts for VAR Model (y1 and y5) is generated', pdfName))

#### HERE WE BUILD VAR MODEL FOR COINTEGRATED TIME SERIES Y2 and Y3

minX <- 1
maxX <- 290
xPointsForDates <- minX:maxX
l11 <- -0.313
l12 <- 3.503
c1 <- 3.417
l21 <- -0.272
l22 <- 3.492
c2 <- 0.229

y2_var = c(y2[300])
y3_var = c(y3[300])

index <- 2

for (i in (minX + 1):(maxX)) {
  y2_var[index] = l11 * y2_var[index - 1] + l12 * y3_var[index - 1] + c1
  y3_var[index] = l21 * y2_var[index - 1] + l22 * y3_var[index - 1] + c2
  index = index + 1
}

pdfName <- 'y2_and_y3_var_model.pdf'
# Open a pdf file
pdf(pdfName)
# Create a plot
plot(x = xPointsForDates, y = y2_var,
     type='l',
     pch = 16, frame = FALSE,
     xlab = '290 additional dates (after 300 previous ones)', ylab = 'y', col = '#2E9FDF')
lines(x = xPointsForDates, y = y3_var, col = '#Df2E7E', pch = 16)
# Close the pdf file
dev.off()
# Print that PDF is generated
print(sprintf('PDF %s with charts for VAR Model (y2 and y3) is generated', pdfName))

#### LET'S COMPARE WITH NOT COINTEGRATED Y1 and Y6

minX <- 1
maxX <- 290
xPointsForDates <- minX:maxX
l11 <- 157.317
l12 <- -3.957
c1 <- 3.452
l21 <- 2.398
l22 <- 161.639
c2 <- 0.243

y1_var = c(y1[300])
y6_var = c(y6[300])

index <- 2

for (i in (minX + 1):(maxX)) {
  y1_var[index] = l11 * y1_var[index - 1] + l12 * y6_var[index - 1] + c1
  y6_var[index] = l21 * y1_var[index - 1] + l22 * y6_var[index - 1] + c2
  index = index + 1
}

pdfName <- 'y1_and_y6_var_model.pdf'
# Open a pdf file
pdf(pdfName)
# Create a plot
plot(x = xPointsForDates, y = y1_var,
     type='l',
     pch = 16, frame = FALSE,
     xlab = '290 additional dates (after 300 previous ones)', ylab = 'y', col = '#2E9FDF')
lines(x = xPointsForDates, y = y6_var, col = '#Df2E7E', pch = 16)
# Close the pdf file
dev.off()
# Print that PDF is generated
print(sprintf('PDF %s with charts for VAR Model (y1 and y6) is generated', pdfName))


funkSVD <- function(R, k, lr = 0.01, reg = 0.5, miter = 2) {
	global_mean <- mean(as.matrix(R), na.rm = TRUE)
	bu <- rep(0, nrow(R))
	bi <- rep(0, ncol(R))
	P <- matrix(0.1, nrow = nrow(R), ncol = k)
	Q <- matrix(0.1, nrow = ncol(R), ncol = k)
	K <- which(!is.na(R), arr.ind = TRUE)
	for(f in sample(k)) {
		for(l in 1:miter) {
			for(j in 1:nrow(K)){
      			u <- K[j,1]
      			i <- K[j,2]
      			r_ui <- R[u,i]
      			if(!is.na(r_ui)){
         			pred <- global_mean + bu[u] + bi[i] + P[u, ] %*% Q[i, ]
         			e_ui <- r_ui - pred
					bu[u] <- bu[u] + lr * e_ui
					bi[i] <- bi[i] + lr * e_ui
         			temp_uf <- P[u,f]
         			P[u,f] <- P[u,f] + lr * (e_ui * Q[i,f] - reg * P[u,f])
			       	Q[i,f] <- Q[i,f] + lr * (e_ui * temp_uf - reg * Q[i,f])
      			}
   			}
		}
	}
	return(list(bu = bu, bi = bi, P = P, Q = Q))
}


rm(list = ls())
clc <- function() cat(rep("\n", 50))
clc()
rm(list = ls())

library(quantmod)
library(fPortfolio)
library(tidyverse)
library(knitr)
library(lubridate)
library(PortfolioAnalytics)

# setwd("./")
# source("./Utility/utility.R")

# environmentSettings()
start.date = as.Date("2017-09-09")
end.date = as.Date("2018-09-09")

# mystocks <- new.env(hash=TRUE)
# result <- getSymbols(myTitles,src="yahoo", auto.assign = TRUE, env=mystocks)
getTitles <- function(myTitle,source){

  numberTitles <- ncol(myTitles)

  getSymbols(myTitles, src=source, from="2017-09-09", to="2018-09-09")

  #ClosePrices <- do.call(merge, lapply(myTitles, function(x) Cl(get(x))))
  #OpenPrices <- do.call(merge, lapply(myTitles, function(x) Op(get(x))))
  #Volumes <- do.call(merge, lapply(myTitles, function(x) Vo(get(x))))
  portfolioPrices <- do.call(merge, lapply(myTitles, function(x) Ad(get(x))))

  # result <- as.data.frame(portfolioPrices)

  #Remove NA from the Portfolio Prices (some titles can have NA on columns)
  portfolioPrices <- portfolioPrices[apply(portfolioPrices,1,function(x) all(!is.na(x))),]

  #Add the correct names to the dataframe
  colnames(portfolioPrices) <- myTitle

  return(portfolioPrices)

}

getDailyResults <- function(my_titles_dataframe){

  # result <- sapply(my_titles_dataframe, function(x) dailyReturn(x) )

  result <- data.frame()

  for(i in 1:ncol(my_titles_dataframe)){

    temp_result <- dailyReturn(my_titles_dataframe[,i])

    result <- cbind(result,temp_result)

  }

  titleNames <- colnames(my_titles_dataframe)
  colnames(result) <- myTitles

  return(result)
}

adjustDataframes <- function(daily_results_dataframe){

  #TODO: calc the mean and variance for every column and create a list of means and variances

  # meanReturns <- colmean(daily_results_dataframe)*100
  # varianceReturns <- colvar(daily_results_dataframe)

  meanReturns <- apply(daily_results_dataframe, 2, mean)*100
  varianceReturns <- apply(daily_results_dataframe, 2, var) *100
  stDevReturns <- apply(daily_results_dataframe,2,stdev) *100

  # meanReturns <- daily_results_dataframe@statistics$mean * 100
  # varianceReturns <- daily_results_dataframe@statistics$Cov * 100

  result <- data.frame()

  result <- rbind(meanReturns,varianceReturns,stDevReturns)

  return(result)

}

covarianceMatrixTimeSeries <- function(timeseries_dataframe){

  #Create the time series object
  assetsSeries <- as.timeSeries(timeseries_dataframe)
  adjusted_dataframe <- portfolioData(data = assetsSeries)

  mv <- tibble(Asset = adjusted_dataframe@data$names,
               R = adjusted_dataframe@statistics$mean*100,
               S = sqrt(diag(adjusted_dataframe@statistics$Cov)*100))

  mv <- kable(mv,
              caption = "I rendimenti medi (R) e le volatilità mensili (S) in percentuale",
              format.args = list(decimal.mark =",", digits = 2))

  #Create the Covariance Matrix
  covMatrix <- kable((round(adjusted_dataframe@statistics$Cov, digits = 5)),
                     row.names = TRUE,
                     caption = "La matrice varianza/covarianza",
                     format.args = list(decimal.mark =",",
                                        digits = 4, nsmall = 4,
                                        scientific=FALSE))

  CovMatrix_Plot <- assetsCorImagePlot(assetsSeries)

  print(CovMatrix_Plot)

  return(covMatrix)

}

covarianceMatrix <- function(adjusted_dataframe){

  mean_dataframe <- adjusted_dataframe[1,]
  var_dataframe <- adjusted_dataframe[2,]
  stdev_dataframe <- adjusted_dataframe[3,]

  covMatrix <- cov(adjusted_dataframe, y = NULL, use = "everything", method = c("pearson"))

  covCorMatrix <- cov2cor(covMatrix)

  print(covCorMatrix)

  result <- list(covMatrix,covCorMatrix)

  names(result) <- c("covariance matrix","correlation matrix")

  return(result)
}

groupReturns <- function(input_dataset, type=null){
  #input_dataset = dataset with returns and date
  #type = flag to group = if month [m] or year [y]

  result <- data.frame()

  if(type == "m"){

    for(i in 1:ncol(input_dataset)){

      temp_result <- na.omit(monthlyReturn(na.omit(input_dataset[,i])))

      result <- cbind(result,temp_result)

    }

    titleNames <- colnames(input_dataset)
    colnames(result) <- myTitles

  }
  else if (type == "y"){

    for(i in 1:ncol(input_dataset)){

      temp_result <- yearlyReturn(na.omit(input_dataset[,i]))

      result <- cbind(result,temp_result)

    }

    titleNames <- colnames(input_dataset)
    colnames(result) <- myTitles

  }

  else{

    print("please specify a tipe of a group: m = month or y = year")
  }

  return(result)

}

portfolioOptimization <- function(input_dataframe){

  print("Start creating portfolio and max portfolio")

  #Generate Portfolio object
  port <- portfolio.spec(assets = colnames(input_dataframe))

  #Box
  # port <- add.constraint(montlyReturns, type = "box", min = 0.05, max = 0.8)
  port <- add.constraint(port, type = "box")

  #Leverage
  port <- add.constraint(portfolio = port, type = "full_investment")

  #Generate random portfolios
  rportfolios <- random_portfolios(port, permutations = 5000, rp_method = "sample")

  #Get minimum variance portfolio
  minvar.port <- add.objective(port, type = "Risk", name = "var")

  # Generate maximum return portfolio
  maxret.port <- add.objective(port, type = "return", name = "mean")

  # Optimize
  maxret.opt <- optimize.portfolio(dailyResults, maxret.port, optimize_method = "random",
                                   rp = rportfolios)

  result <- maxret.opt

  return(result)

}

#################################################
############### TEST FUNCTIONS ##################

myTitles <- c("GOOG","AAPL","MSFT","AMZN","INTC")
source = "yahoo"

titles <- getTitles(myTitles,source)
dailyResults <- getDailyResults(titles)

adjustedDailyResults <- adjustDataframes(dailyResults)

result <- covarianceMatrix(dailyResults)

# t <- covarianceMatrixTimeSeries(dailyResults)

#1) calcolare rendimenti mensili per i titoli
montlyReturns <- groupReturns(dailyResults,"m")
print(montlyReturns)

#2) calcolare rendimento del portafoglio
optMaxRet <- portfolioOptimization(dailyResults)

#3) calcolare excess return (rendimento portafoglio - risk free)
#4) calcolare sharpe ratio manualmente

#TODO: Non so cosa fare ora

meanReturns <- colMeans(dailyResults)

minret <- 0.06/100
maxret <- optMaxRet$weights %*% meanReturns

vec <- seq(minret, maxret, length.out = 100)

eff.frontier <- data.frame(Risk = rep(NA, length(vec)),
                           Return = rep(NA, length(vec)),
                           SharpeRatio = rep(NA, length(vec)))

# Method 1: use the Return.excess function from PerformanceAnalytics,
# then calculate the Sharpe Ratio manually.
# portfolio_excess_returns <- Return.excess(portfolio_monthly_returns, Rf = .0003)
#
# sharpe_ratio_manual <- round(mean(portfolio_excess_returns)/StdDev(portfolio_excess_returns), 4)

# If we wanted to use the original, 1966 formulation of the Sharpe Ratio, there is one small
# change to the code in Method 1.
# sharpe_ratio_manual <- round(mean(portfolio_excess_returns)/StdDev(portfolio_monthly_returns), 4)

# Method 2: use the built in SharpeRatio function in PerformanceAnalytics.
# sharpe_ratio <- round(SharpeRatio(portfolio_monthly_returns, Rf = .0003), 4)

#media <- average(nomedataframe$nomecolonna)
#media <- mean(nomedataframe[,numerocolonna])

#TODO FINAL: correlation matrix between titles (variance, covariance)
#TODO: Pesi del portafoglio (di tangenza)


 DGELSD Example Program Results

 Least squares solution
      1.5938    -0.1180    -3.1501     0.1554     2.5529    -1.6730

 Tolerance used to estimate the rank of A
      1.00E-02
 Estimated rank of A
      4

 Singular values of A
      3.9997     2.9962     2.0001     0.9988     0.0025


# K-Spectrum Centroid Clustering

# Compute K-SC Clustering for a set of time series.
# A: a set of time series. Each row vector A[i,] corresponds to each time series
# K: Number of clusters
# mem represents membership for each time series (mem[i] is the cluster index that time series i belongs to
# cent is a set of cluster centroids. Each row vector cent[i, :] corresponds to each cluster centroids.
ksc_toy <- function(A, K){
	m = nrow(A)
	mem <- round(sample(1:K,m, replace=T))
	cent <- matrix(0, nrow = K, ncol = ncol(A))
	D <- matrix(0,nrow = m, ncol=K)
	for(iter in 1:100) {
		prev_mem <- mem
		for(k in 1:K) {
			cent[k, ] = ksc_center(mem, A, k, cent[k, ])
		}
		for(i in 1:m) {
			x = matrix(A[i, ], nrow=1)
			for (j in 1:K) {
				y = matrix(cent[j, ], nrow=1)
				dist = dhat_shift(x, y)
				D[i, j] = dist$dist
			}
		}
		val = apply(D, 1, min)
		mem = apply(D, 1, function(x) which(x==min(x)))
		if(norm(prev_mem-mem, type="2") == 0) {
			break
		}
	}
	return(list(mem = mem, cent = cent))
}


#setwd("~/rolling_int_uptake_speed5")

get_rates <- function(data_set){
  rates <- NULL
  start <- NULL
  for(i in 1:ncol(data_set)){
    x = seq(0, nrow(data_set) - 1, by = 1)
    y = data_set[,i]
    mod = lm(y ~ x)
    rates[i] <- mod[[1]][2]
    start[i] <- mod[[1]][1]
  }
  return(data.frame(rates,start))
}

r_data_all = read.csv(paste("rolling_int_uptake_speed5_",1,".csv",sep=""),header = FALSE)
colnames(r_data_all)=paste(1,colnames(r_data_all),sep="")

for(i in 2:15){
  r_data_i = read.csv(paste("rolling_int_uptake_speed5_",i,".csv",sep=""),header = FALSE)
  colnames(r_data_i)=paste(i,colnames(r_data_i),sep="")
  r_data_all = cbind(r_data_all,r_data_i)
}

nr_data_all = read.csv(paste("norolling_int_uptake_speed5_",1,".csv",sep=""),header = FALSE)
colnames(nr_data_all)=paste(1,colnames(nr_data_all),sep="")

for(i in 2:15){
  nr_data_i = read.csv(paste("norolling_int_uptake_speed5_",i,".csv",sep=""),header = FALSE)
  colnames(nr_data_i)=paste(i,colnames(nr_data_i),sep="")
  nr_data_all = cbind(nr_data_all,nr_data_i)
}

hist(conc,breaks = seq(0,80,by=4),xlim=c(0,70),main="Non-Rolling",xlab="cumulative intake")
hist(concI,breaks = seq(0,80,by=4),xlim=c(0,70),main="Rolling",xlab="cumulative intake")

list <- list(c(nr_data_all[500,]),c(r_data_all[500,]))
conc <- c(as.numeric(nr_data_all[500,]))
concI <- c(as.numeric(r_data_all[500,]))
var.test(conc,concI)


# Importing dataset from project

library("saber")

library("dplyr")
library("saber")
library("nnet")
library("caret")
library("parallel")

# Data loading ----------------------------------------------------------

# data("SB11_20111") # 31707
data("SB11_20112")

table(SB11_20112$ECON_SN_INTERNET)

# SB11_20112 %>% names()

iterations <- 38
sample_size <- 27

plot(
mean(SB11_20112$MATEMATICAS_PUNT),
sd(SB11_20112$MATEMATICAS_PUNT),
pch = 20,
cex = 4,
col = "white"
)

for(i in seq_len(iterations)){
points(
  mean(sample(SB11_20112$MATEMATICAS_PUNT, sample_size)),
  sd(sample(SB11_20112$MATEMATICAS_PUNT, sample_size)),
  pch = 20

)
}

points(
  mean(SB11_20112$MATEMATICAS_PUNT),
  sd(SB11_20112$MATEMATICAS_PUNT),
  pch = 20,
  cex = 4,
  col = 2
)

# tidy approach -----------------------------------------------------------

library("dplyr")
library("ggplot2")
library("purrr")

colors_platzi <- c("#78D92A", "#002E4E", "#058ECD", "#ED2B05", "#F4F7F4")

tibble(
  samples = replicate(iterations, sample(SB11_20112[["MATEMATICAS_PUNT"]], sample_size), simplify = FALSE),
  mean_value = map_dbl(samples, mean),
  desv = map_dbl(samples, sd),
) %>% ggplot +
  geom_point(aes(x = medias, y = desv)) +
  annotate(
    geom = "point",
    x = mean(SB11_20112[["MATEMATICAS_PUNT"]]),
    y = sd(SB11_20112[["MATEMATICAS_PUNT"]]),
    size = 4,
    colour = colores_platzi[4]) +
  theme_minimal()

# Correlation amid academic results and internet access

library("saber")

data("SB11_20112")

table(SB11_20112$ECON_SN_INTERNET)

# intervalos de confianza de la media -------------------------------------

sample_size <- 30
iterations <- 100

pobla_A <- SB11_20112$FISICA_PUNT[SB11_20112$ECON_SN_INTERNET == 0]
pobla_B <- SB11_20112$FISICA_PUNT[SB11_20112$ECON_SN_INTERNET == 1]
mean_pob_A <- mean(pobla_A, na.rm = TRUE)
mean_pob_B <- mean(pobla_B, na.rm = TRUE)

plot(mean_pob_A, mean_pob_B, col = 4, pch = 20)
abline(0,1)

for(i in seq_len(iterations)){

  samples <- sample(seq_len(nrow(SB11_20112)), sample_size)

  some_A <- seq_len(nrow(SB11_20112)) %in% sample & SB11_20112$ECON_SN_INTERNET == 0
  sample_A <- SB11_20112$FISICA_PUNT[some_A]

  some_B <- seq_len(nrow(SB11_20112)) %in% sample & SB11_20112$ECON_SN_INTERNET == 1
  sample_B <- SB11_20112$FISICA_PUNT[some_B]

  mean_sample_A <- mean(sample_A, na.rm = TRUE)
  t_test_A <- t.test(sample_A)
  interval_A <- t_test_A$conf.int
  LI_A <- min(interval_A)
  LS_A <- max(interval_A)

  mean_sample_B <- mean(sample_B, na.rm = TRUE)
  t_test_B <- t.test(sample_B, na.rm = TRUE)
  interval_B <- t_test_B$conf.int
  LI_B <- min(interval_B)
  LS_B <- max(interval_B)

  # points(media_muestra_A, media_muestra_B, col = 2, pch = 20)
  rect(LI_A, LI_B, LS_A, LS_B)

}

points(mean_pob_A, mean_pob_B, col = 4, pch = 20, cex = 2)

# Tidy approach -----------------------------------------------------------

library("dplyr")
library("purrr")
library("magrittr")
library("ggplot2")
library("LaCroixColoR")

colors <- lacroix_palette("Pamplemousse")

sample_size <- 30

tibble(
  sample = replicate(iterations, sample_n(SB11_20112, sample_size), simplify = FALSE),
  sample_A = map(sample, filter, ECON_SN_INTERNET == 0) %>% map(extract2, "FISICA_PUNT"),
  mean_sample_A = map_dbl(samĺpe_A, mean),
  t_test_A = map(sample_A, t.test),
  interval_A = map(t_test_A, extract2, "conf.int"),
  LI_A = map_dbl(interval_A, min),
  LS_A = map_dbl(interval_A, max),
  sample_B = map(sample, filter, ECON_SN_INTERNET == 1) %>% map(extract2, "FISICA_PUNT"),
  mean_sample_B = map_dbl(sample_B, mean),
  t_test_B = map(sample_B, t.test),
  interval_B = map(t_test_B, extract2, "conf.int"),
  LI_B = map_dbl(interval_B, min),
  LS_B = map_dbl(interval_B, max)
) -> analysis

mean_pob_A <- mean(pobla_A, na.rm = TRUE)

mean_pob_B <- mean(pobla_B, na.rm = TRUE)

analysis %>%
  ggplot +
  geom_rect(aes(xmin = LI_A, xmax = LS_A, ymin = LI_B, ymax = LS_B), alpha = 0.2, fill = colores[6]) +

  annotate("point", mean_pob_A, mean_pob_B, colour = colors[4], size = 5) +
  geom_abline(intercept = 0, slope = 1, colour = colors[4], size = 1) +

  theme_minimal()

# Forecasting Neural Network

sample_size <- 2000

c(
  "ECON_PERSONAS_HOGAR",
  "ECON_CUARTOS",
  "ECON_SN_LAVADORA",
  "ECON_SN_NEVERA",
  "ECON_SN_HORNO",
  "ECON_SN_DVD",
  "ECON_SN_MICROHONDAS",
  "ECON_SN_AUTOMOVIL",
  "MATEMATICAS_PUNT"
) -> variables

sample_index <- seq_len(nrow(SB11_20112)) %in% sample(seq_len(nrow(SB11_20112)), sample_size)

sample <- subset(SB11_20112, subset = sample_index, select = variables)
sample <- na.omit(sample)

neuronal_network <- nnet(MATEMATICAS_PUNT ~., data = sample, size = 10, linout = TRUE)

plot(sample$MATEMATICAS_PUNT ~ predict(neuronal_network))
lines(1:100, col = 2, lwd = 2)

# Cross Validation

rmse_fold <- function(pliegue, form, datos,  nn_size){
  pliegue_logic <- seq_len(nrow(datos)) %in% pliegue
  entrena <- subset(datos, !pliegue_logic)
  prueba <- subset(datos, pliegue_logic)
  model <- nnet(form, data = datos, size = nn_size, linout = TRUE, trace = FALSE)
  response_name <- setdiff(names(datos), modelo$coefnames)
  Y_pronosticado <- predict(modelo, newdata = prueba)
  rmse <- RMSE(Y_pronosticado, prueba[[response_name]])
  rmse
}

# Neuronal Network  ------------------------------------------------------------

sample_size <- 5000
neurons <- 10
n_folds <- 10

c(
  "ECON_PERSONAS_HOGAR",
  "ECON_CUARTOS",
  "ECON_SN_LAVADORA",
  "ECON_SN_NEVERA",
  "ECON_SN_HORNO",
  "ECON_SN_DVD",
  "ECON_SN_MICROHONDAS",
  "ECON_SN_AUTOMOVIL",
  "MATEMATICAS_PUNT"
) -> variables

sample_indexes <- seq_len(nrow(SB11_20112)) %in% sample(seq_len(nrow(SB11_20112)), sample_size)

samople <- subset(SB11_20112, subset = sample_indexes, select = variables)
sample <- na.omit(sample)

createFolds(sample$MATEMATICAS_PUNT, k = n_folds) -> folds

mclapply(
  folds,
  rmse_fold,
  MATEMATICAS_PUNT ~.,
  sample,
  nn_size = neurons,
  mc.cores = floor(detectCores()*0.8)
) -> rmse_folds

rmse_folds <- unlist(rmse_folds)
mean(rmse_folds)

plot(rmse_folds, ylim = c(0, 12))
abline(h = mean(rmse_folds), col = 2, lwd = 2)

# Tidy approach -----------------------------------------------------------

library("dplyr")
library("magrittr")

sample_size <- 5000
neurons <- 10
n_folds <- 10

tibble(
  foldss = createFolds(sample$MATEMATICAS_PUNT, k = n_folds),
  rmse_folds = mclapply(
    folds,
    rmse_fold,
    MATEMATICAS_PUNT ~.,
    sample,
    nn_size = neurons,
    mc.cores = floor(detectCores()*0.8)
  ) %>% unlist,
  sample_names = names(folds)
) -> validation

validation %$% mean(rmse_folds)

ggplot(validation) +
  geom_vline(aes(xintercept = 0), size = 1.5) +
  geom_segment(aes(x = 0, y = names, xend = rmse_folds, yend = names), colour = "grey75") +
  geom_point(aes(x = rmse_folds, y = names), size = 4) +
  theme_minimal()


# Euler1 in R

#Set recursion limit
options(expressions = 150)

euler1 <- function (L) {
    len = length(L)
    piv = ceiling(len / 2)
    l = L[piv]

    pre = ifelse( 1 <= piv-1, euler1( na.omit(L[1:piv-1]) ), 0)
    post = ifelse( piv+1 <= len, euler1( na.omit(L[piv+1:len])), 0 )
    i = ifelse( l%%3==0 || l%%5==0, l, 0 )

    pre + post + i
}

euler1( 1:999 )


#Factorial de un número
factorial<-function(n)
 {
 f<-1
 if(n>1)
 for(i in 1:n)
 f<-f*i
 return(f)
 }
factorial(3)


###############################################################################
# "Infection Rate Models for COVID-19:
#  Model Risk and Public Health News Sentiment Exposure Adjustments"
#
#  Ioannis Chalkiadakis, Kevin Hongxuan Yan, Gareth W. Peters, Pavel V. Shevchenko
#
#  Kevin Hongxuan Yan
#  March 2021
###############################################################################

rm(list=ls(all=TRUE))

library(methods)
library(rstan)

cat("Stan version:", stan_version(), "\n")
stanmodelcode <- "

#### define GP function
functions {

real normal_generalized_poisson_log(int y, real theta, real lambda, real sigob) {
    return (log(theta)
           + (y - 1) * log(theta + y * lambda)
           - lgamma(y + 1)
           - y * lambda
           - theta)*(y<=200)
           +(normal_lpdf(y|theta,sigob))*(y>200);
		  ## +log(1-normal_cdf(0.08*u,u,0.01))*(b0>0.08*u)
		  ## +log(normal_cdf((0.515+0.125*u),u,0.01))*(b2>(0.515+0.125*u));    #### +log(b0>0.08*u); (b0>0.08*u)
  }

}

#### define our data, integer value
data {
int<lower=0> N;
int y[N];
real E[N];
}

#### define parameters
parameters {

real lambda;
real u;
real b0;
real b1;
real b2;
real<lower=0> sig2;
vector[N] e;
real sigob;
}

#### define some parameters which is the function of other parameters
transformed parameters {
vector[N] mu;

### define the mean function
#mu[1] <- exp(u*exp(-b0)+e[1]);

mu[1] <- y[1];  ## not tested

  for (n in 2:N) {

      mu[n] <- mu[n-1]*exp(u*exp(-b0*n)+b1*(mu[n-1]^b2)+e[n]);

	  }

}

##### define piror and likelihood function
model {
lambda~uniform(-1,1);
u ~ normal(0.13,0.1);
b0 ~ normal(0.025,0.01);
b1 ~ normal(-0.00000006,0.00000001);
b2 ~ normal(0.1,0.1);
sig2 ~  gamma(1,1);
e~normal(0,sig2);
sigob ~ uniform(100,1100);

for (j in 1:N) {

y[j] ~ normal_generalized_poisson( mu[j]*E[j], lambda, sigob);
}

}

#### calculate DIC
generated quantities {
vector[N] log_lik;
real dev; // deviance

  for (n in 1:N){
    log_lik[n] <- normal_generalized_poisson_log (y[n],mu[n]*E[n], lambda, sigob);
  }

  dev <- 0;
        for ( n in 1:N ) {
            dev <- dev + (-2) * normal_generalized_poisson_log (y[n],mu[n]*E[n], lambda, sigob);
        }

}

"

######

####### read new data Y
setwd("./covid19modelrisk/data/covid19_infected")

  y=read.csv("COVID-19_confirmed__Germany.csv")
##  y=read.csv("COVID-19_confirmed__Italy.csv")
##  y=read.csv("COVID-19_confirmed__Japan.csv")
##  y=read.csv("COVID-19_confirmed__Spain.csv")
##  y=read.csv("COVID-19_confirmed__United Kingdom.csv")
##  y=read.csv("COVID-19_confirmed__US.csv")
##  y=read.csv("COVID-19_confirmed_Australia.csv")

y=y[,2]

E=rep(1,length(y))

N=length(y)
dat <- list(N = N, y = y,E=E)

#### initial values
inits =list(list(lambda=0,u=0.1,b0=0.025,b1=-0.00000006, b2=0.1,sig2=0.0005,e=rep(0.01,N),sigob=1000),
list(lambda=0,u=0.2,b0=0.025,b1=-0.00000006, b2=0.1,sig2=0.0005,e=rep(0.01,N),sigob=1000),
list(lambda=0,u=0.15,b0=0.025,b1=-0.00000006, b2=0.1,sig2=0.0005,e=rep(0.01,N),sigob=1000),
list(lambda=0,u=0.25,b0=0.025,b1=-0.00000006, b2=0.1,sig2=0.0005,e=rep(0.01,N),sigob=1000),
list(lambda=0,u=0.2,b0=0.05,b1=-0.00000006, b2=0.1,sig2=0.0005,e=rep(0.01,N),sigob=1000),
list(lambda=0,u=0.2,b0=0.01,b1=-0.00000006, b2=0.1,sig2=0.0005,e=rep(0.01,N),sigob=1000),
list(lambda=0,u=0.2,b0=0.01,b1=-0.0000001, b2=0.1,sig2=0.0005,e=rep(0.01,N),sigob=1000),
list(lambda=0,u=0.2,b0=0.01,b1=-0.00000001, b2=0.1,sig2=0.0005,e=rep(0.01,N),sigob=1000))

fit <- stan(model_code = stanmodelcode, model_name = "example",init =inits,
data = dat, warmup=10000,iter = 100000, chains = 8, seed=999,thin=1)
print(fit,digits = 4)

####################  trace plot

library(methods)
library(rstan)

name=c("Germany","Italy","Japan","Spain","U.K.","U.S.","Australia")
abn=c("GM","IT","JP","SP","UK","US","AU")

k=1

pdf(paste("M8_",abn[k],"_p1.pdf",sep=""), width = 16.5, height = 8.50)

traceplot(fit, pars=c("u","b0","b1","b2"), inc_warmup = T,  nrow = 4, ncol = 1, window = NULL, include = TRUE)

dev.off()

pdf(paste("M8_",abn[k],"_p2.pdf",sep=""), width = 16.5, height = 8.50)

traceplot(fit, pars=c("sigob","sig2","lambda"), inc_warmup = T,  nrow = 3, ncol = 1, window = NULL, include = TRUE)
dev.off()

##################   plot 30/45/60/   length(y)

Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(8+N):(7+2*N)] , 2 , mean )

Epars_5 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(8+N):(7+2*N)] , 2 , quantile, probs=0.05 )

Epars_9 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(8+N):(7+2*N)] , 2 , quantile, probs=0.95 )

pdf(paste("M8_",abn[k],"_30.pdf",sep=""), width = 16.5, height = 8.50)

m=30

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),lwd = 2)

dev.off()

pdf(paste("M8_",abn[k],"_45.pdf",sep=""), width = 16.5, height = 8.50)

m=45

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),lwd = 2)

dev.off()

pdf(paste("M8_",abn[k],"_60.pdf",sep=""), width = 16.5, height = 8.50)

m=60

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),lwd = 2)

dev.off()

pdf(paste("M8_",abn[k],"_all.pdf",sep=""), width = 16.5, height = 8.50)

m=length(y)

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),lwd = 2)

dev.off()

########    log plot          ####################################################

k=1

name=c("Germany","Italy","Japan","Spain","U.K.","U.S.","Australia")
abn=c("GM","IT","JP","SP","UK","US","AU")

Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(8+N):(7+2*N)] , 2 , mean )

Epars_5 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(8+N):(7+2*N)] , 2 , quantile, probs=0.05 )

Epars_9 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(8+N):(7+2*N)] , 2 , quantile, probs=0.95 )

y=log(y)
Epars_m=log(Epars_m)
Epars_9=log(Epars_9)
Epars_5=log(Epars_5)

setwd("./covid19modelrisk/output/plot")

pdf(paste("M8_",abn[k],"_log.pdf",sep=""), width = 16.5, height = 8.50)

m=length(y)

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),lwd = 2)

dev.off()

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

mean(y)
median(y)

n=length(y)

u=0.13
b0=0.025
b1=-0.00000006
b2=0.1

x=c()
x[1]=100
for (i in 1:(n-1) ){

x[i+1]=x[i]*exp(u*exp(-b0*i)+b1*(x[i]^b2))
}
x=round(x)
x

plot(y,ylim=c(min(y,x),max(y,x)))
par(new=TRUE)
plot(x,col="red",ylim=c(min(y,x),max(y,x)))

#############################################################
##### GM

u=0.2
b0=0.025
b1=-0.00000006
b2=0.1

##### IT

u=0.2
b0=0.025
b1=-0.00000006
b2=0.1

##### JP

u=0.15
b0=0.025
b1=-0.00000006
b2=0.1

##### SP

u=0.2
b0=0.025
b1=-0.00000006
b2=0.1

##### UK

u=0.2
b0=0.025
b1=-0.00000006
b2=0.1

##### US

u=0.27
b0=0.025
b1=-0.00000006
b2=0.1

##### AU

u=0.13
b0=0.025
b1=-0.00000006
b2=0.1


#####################################################################
# CS671: Machine Learning
# Copyright 2015 Pejman Ghorbanzade <pejman@ghorbanzade.com>
# More info: https://github.com/ghorbanzade/beacon
#####################################################################

# clear workspace
rm(list = ls())

# enable traceback on error messages
options(error=traceback)

# remove all plots if there are any
if (!is.null(dev.list())) trash <- dev.off()

args = commandArgs(trailingOnly=TRUE)
if (0 == length(args)) {
  stop("expected path to root directory of course", call.=FALSE)
}
pngdir <- args[1]
courseNameFull <- "umb-cs671-2015s"

# loading dataset from csv file
training_set <- read.csv("dat/dataset_training.csv", header=TRUE, sep=",")

# plot training dataset
png(filename=file.path(pngdir, paste(courseNameFull, "-f01-01", ".png", sep="")),
	height=768, width=1024, res=150, units="px", bg="white")

plot(0:10, 0:10, type = "n", ann=FALSE, axes=FALSE, xaxs="i", yaxs="i")
for (i in 1:dim(training_set)[1]) {
  if(training_set[i,3]=="true")
    points(training_set[i,1],training_set[i,2],pch=21,col="black",bg="black")
  else
    points(training_set[i,1],training_set[i,2],pch=21,col="black",bg="white")
}
axis(1, 1:10, at=1:10)
axis(2, 1:10, at=1:10)

grid(10, 10)
box()
title(xlab="X-Axis")
title(ylab="Y-Axis")
title(main="Training Dataset", font.main=1)
trash <- dev.off()

# building classifiers
library("kernlab")

# Build a classifer using a linear kernel function
kernels <- c("vanilladot", "rbfdot", "polydot", "anovadot", "besseldot", "laplacedot", "splinedot", "tanhdot")
training_error <- matrix(0,1,length(kernels))
exec_time <- matrix(0,length(kernels),5)
for (i in 1:length(kernels)) {
  ptm <- proc.time()
  classifier <- ksvm(value~., data=training_set, kernel=kernels[i])
  training_error[i] <- classifier@error
  exec_time[i,1:5] <- proc.time() - ptm
}
exec_time <- exec_time[,1:3]

# plot training_error for classifiers
png(filename=file.path(pngdir, paste(courseNameFull, "-f01-02", ".png", sep="")),
	height=768, width=1024, res=150, units="px", bg="white")

plot(1:length(kernels), training_error, type="o", col="blue", ann=F, axes=F)
plot.window(ylim=c(min(training_error),max(training_error)),xlim=c(1,8))
points(1:length(kernels), training_error,pch=21,col="blue",bg="white")
axis(1, at=1:length(kernels), lab=kernels, cex.axis=0.8)
axis(2, las=1)

grid()
box()
title(xlab="Kernel")
title(ylab="Error Rate")
title(main="Training Error for Different Kernels", font.main=1)
trash <- dev.off()

# plot execution time of classifiers
png(filename=file.path(pngdir, paste(courseNameFull, "-f01-03", ".png", sep="")),
	height=768, width=1024, res=150, units="px", bg="white")

plot(1:length(kernels), exec_time[,1], type="o", col="blue", ann=F, axes=F)
points(1:length(kernels), exec_time[,1],pch=21,col="blue",bg="white")
axis(1, at=1:length(kernels), lab=kernels, cex.axis=0.8)
axis(2, las=1)

grid()
box()
title(xlab="Kernel")
title(ylab="Execution Time")
title(main="Execution Time of Constructing Different Kernels", font.main=1)
trash <- dev.off()

# plot execution time based on training error
png(filename=file.path(pngdir, paste(courseNameFull, "-f01-04", ".png", sep="")),
	height=768, width=1024, res=150, units="px", bg="white")

plot(training_error, exec_time[,1], type="o", col="blue", ann=F, axes=F)
points(training_error,exec_time[,1],pch=21,col="blue",bg="white")
axis(1, )
axis(2, las=1)

grid()
box()
title(xlab="Training Error")
title(ylab="Execution Time")
title(main="Execution Time Based on Training Errors", font.main=1)
trash <- dev.off()


#' Check if matrix is diagonal
#'
#' This function indicates whether the matrix supplied is diagonal.
#' @param A Matrix to be tested
#' @return Logical value indicating whether matrix is diagonal
#' @keywords diagonal matrix
#' @examples
#' A <- cbind(c(1,1),c(0,1)
#' is_matrix(A)
#' @export

is_diag <- function(A){
	if (!is.matrix(A)) return(FALSE)
  	cd <- dim(A)
  	if (cd[1] != cd[2]) return(FALSE)
	if ( all(A==diag(diag(A))) ) return(TRUE)
}


#==========================================================
#Script da análise de resultados
#----------------------------------------------------------

print('==========================================================================')
print('Análise descritiva')
print('==========================================================================')

#Leitura de dados
result0 = read.csv("result0.csv", header = FALSE, sep = "\t")
result1 = read.csv("result1.csv", header = FALSE, sep = "\t")
result2 = read.csv("result2.csv", header = FALSE, sep = "\t")
result3 = read.csv("result3.csv", header = FALSE, sep = "\t")

#Tabela descritiva dos resultados
summary(result0)
summary(result1)
summary(result2)
summary(result3)

print('==========================================================================')
print('Teste ANOVA e suas premissas')
print('==========================================================================')

#Preparação da tabela ANOVA
##Cria vetor com a medida UB, no caso V2 (você pode fazer o mesmo com o tempo ou LB)
Medida=c(result0$V2, result1$V2, result2$V2, result3$V2)
##Cada modelo Mi tem 80 réplicas de instâncias
Modelo=c(rep("M0",80), rep("M1",80), rep("M2",55), rep("M3",80))
TabelaMedida=data.frame(Medida, Modelo)
##Salva TabelaMedida em csv
write.table(TabelaMedida, file='arquivo.csv', sep='\t', dec='.', row.names=FALSE)

#Teste de homocedasticidade
library(car)
leveneTest(Medida~Modelo,data=TabelaMedida)

#ANOVA com interação
analise1 <- aov(Medida~Modelo,data=TabelaMedida)
anova(analise1)

##Gráficos relacionados
par(mfrow=c(2,2)) #divide a janela gráfica
plot(analise1)

#Normalidade dos resíduos
shapiro.test(residuals(analise1))

#Se o teste não satisfaz as premissas de normalidade
#dos resíduos ou homocedasticidade
print('==========================================================================')
print("Testes não paramétricos: Kruskal Wallis e Welch's ANOVA")
print('==========================================================================')

kruskal.test(Medida~Modelo,data=TabelaMedida)
oneway.test(Medida~Modelo,data=TabelaMedida, na.action=na.omit, var.equal=FALSE)
## lsmeans pode ser uma outra opção
#model = lm(Medida~Modelo,data=TabelaMedida)
#library(emmeans)
#lsmeans(model, pairwise ~ Modelo, adjust="tukey")

#Gráficos
plot(TabelaMedida$Modelo,TabelaMedida$Medida,xlab="modelo",ylab="UB")
print('==========================================================================')
print("Testes de multiplas comparações com todos os métodos de ajuste de p-valor")
print('==========================================================================')

#Multiplas comparações "holm", "hochberg", "hommel", "bonferroni", "BH", "BY", "fdr", "none"
#https://stat.ethz.ch/R-manual/R-devel/library/stats/html/p.adjust.html
#Este pairwise não é o pareado que necessita de réplicas correlacionadas entre
#os níveis. Este teste compara os possiveis pares de níveis.
pairwise.wilcox.test(TabelaMedida$Medida,TabelaMedida$Modelo, p.adjust.method = "holm")
pairwise.wilcox.test(TabelaMedida$Medida,TabelaMedida$Modelo, p.adjust.method = "hochberg")
pairwise.wilcox.test(TabelaMedida$Medida,TabelaMedida$Modelo, p.adjust.method = "hommel")
pairwise.wilcox.test(TabelaMedida$Medida,TabelaMedida$Modelo, p.adjust.method = "bonferroni") #reduz a chance de erro tipo 1
pairwise.wilcox.test(TabelaMedida$Medida,TabelaMedida$Modelo, p.adjust.method = "BH")
pairwise.wilcox.test(TabelaMedida$Medida,TabelaMedida$Modelo, p.adjust.method = "BY")
pairwise.wilcox.test(TabelaMedida$Medida,TabelaMedida$Modelo, p.adjust.method = "fdr")
pairwise.wilcox.test(TabelaMedida$Medida,TabelaMedida$Modelo, p.adjust.method = "none")

TukeyHSD(analise1, ordered = TRUE)


# Explore bike data to see if there is relationship between weather and ridership.

library(tidyverse)

df <- read_csv("data/daily_bike_data.csv")

df

ggplot(df) +
  geom_line(aes(x = as.Date(dteday), y = cnt))

##You can specificy data set in each individual layer so you can pull layers from multiple data sets.

ggplot(data = df, aes( x= temp, y= cnt))+
  geom_point() +
  geom_smooth()

#What is weather sit variable? Looks like  a categorical variable, we went to source
#nots and found the weather categories.
summary(df$weathersit)
unique(df$weathersit)

#Then use dplyr to transform this variable

df2 <- df %>%
    dplyr::mutate(
      weather_fac = factor(weathersit,
                           levels=c(1,2,3,4),
                           labels=c("Clear", "Cloudy", "Rainy", "Heavy Rain"))
    )

#Then we can use dplyr to select the specific columns we're interested in
#Select function selects columsn filter selects rows.
df2 %>%
 dplyr::select(dteday, weathersit, weather_fac)

df2 %>%
  dplyr::filter(weather_fac == "Rainy") %>%
  ggplot(aes(x= temp, y= cnt))+
  geom_point()+
  geom_smooth()

## Notes ##
#for dplyr::select you can use the negative and drop variables

df3 <- df2 %>%
  dplyr::select(-weathersit)

#can also use select to make character lists
keep_vars <- c("dteday", "weather_fac", "temp", "cnt")

df4 <- df2 %>%
  select( all_of(keep_vars))

#other ways of filters
df2 %>% dplyr::filter(weather_fac %in% c("Rainy", "Cloudy"))
df2 %>% dplyr::filter(!(weather_fac  %in% c("Rainy", "Cloudy")))

#Also summarize, dplyr::summarize function, lets you create a new variable based on the output
df2 %>%
  dplyr::group_by(season, weather_fac) %>%
  dplyr::summarize(
    cnt_mean = mean(cnt)
  )

 ### Transforming data format from long to wide or vice-versa,
#Transform our tidy data frame to a wide form, separate temp variable columsn for each month

df_wide <- df2 %>%
  dplyr::select(mnth, temp, season)%>%
  dplyr::group_by(mnth, season)%>%
  dplyr::summarize(temp_mean=mean(temp))%>%
  dplyr::select(-season)%>%
  tidyr::pivot_wider(names_prefix= "temp_", names_from= mnth, values_from= temp)

##Still issues with pivoting because we have two records in same months, so add in year
months <-c( "January", "February",  "March", "April" ,"May"
            ,"June", "July", "August", "September", "October"
            ,"November", "December")
df_wide <- df2 %>%
  dplyr::mutate(mnth=factor(mnth,levels=months,labels=months))%>%
  dplyr::rename(year=yr)%>%
  dplyr::select(year, mnth, temp)%>%
  dplyr::group_by(year, mnth)%>%
  dplyr::summarize(temp_mean=mean(temp))%>%
  tidyr::pivot_wider(names_prefix= "temp_", names_from= mnth, values_from= temp_mean)

##Pivoting Longer

df_long <- df2 %>%
  tidyr::pivot_longer(cols=c(temp, atemp, hum, windspeed),
                      values_to="value", names_to = "variable")

##and then you can use pivot_wider to go back

df_wide2 <- df_long %>%
  tidyr::pivot_wider(names_prefix="v_", names_from= variable, values_from=value)

## Another example with smaller subset of data

df%>%
  group_by(weekday) %>%
  summarize (mean_temp =mean(temp))%>%
  pivot_wider(names_from = weekday,
              values_from=mean_temp)

## Plotting with long form data and or facet wraps

ggplot(data=df2, aes(temp,cnt))+
  geom_point(shape=21, color="orangered")+
  geom_smooth(method="lm", formula= y~poly(x,2), color="steelblue", se= FALSE)+
  facet_wrap(~weather_fac, scales="free_y")+
  labs(x="Temperature", y= "Ridership Count")+
  ggtitle("Relationship Between Temp and Ridership")+
  theme_linedraw()


library(ggplot2)

d <- data.frame(a=c(1:12),  b = 5* sin(c(1:12)),  c1=c(rep(c("Odd","Even"),times=6)))

d

#qplot(x=a, y=b,data=d)

points <- qplot(x=a, y=b, data=d, xlab="x-", ylab="y-", colour=c1, facets = c1~., geom=c("bar","path","point"))

print(points)

print(d$c1)


#' Rotation of polygon
#' @param mat Two-column numeric matrix. Coordinates of the polygon.
#' @param origin Numeric vector of length two. Origin.
#' @param alpha Numeric scalar. Rotation degree in radians.
#' @export
rotate <- function(mat, origin, alpha) {
  R <- matrix(
    c(cos(alpha), -sin(alpha), sin(alpha), cos(alpha)),
    nrow = 2, byrow = TRUE)

  origin <- matrix(c(origin[1], origin[2]), ncol=2, nrow = nrow(mat), byrow = TRUE)
  t(R %*% t(mat - origin)) + origin
}


 F02EKJ Example Program Results

Iteration Limit=  500
 Arnoldi basis vectors used:  20
 The following Ritz values (mu) are related to the
 true eigenvalues (lambda) by lambda = sigma + 1/mu

 Iteration number    1
 Ritz values converged so far (   2) and their Ritz estimates:
     1 (  5.69917E-01,  8.80810E-01)   1.30081E-20
     2 (  5.69917E-01, -8.80810E-01)   1.30081E-20
 Next (unconverged) Ritz value:
     3 (  6.07774E-01,  0.00000E+00)

 The    5 Ritz values of closest to   5.50000E+00 are:
        1     (   6.01781E+00 ,  -8.00277E-01 )
        2     (   6.01781E+00 ,   8.00277E-01 )
        3     (   4.34309E+00 ,  -1.94557E+00 )
        4     (   4.34309E+00 ,   1.94557E+00 )
        5     (   7.14535E+00 ,   0.00000E+00 )


require(datasets)
require(stats)
require(RCUrl)
require(ggplot2)
require(ggthemes)
require(scales)
require(tidyverse)
require(gridExtra)
require(rstudioapi)

rm(list = ls())
setwd(dirname(getActiveDocumentContext()$path ))
#print( getwd() )
source("./covid19_functions.r")

#select countries to plot, support only two countries
#countries <- c ("US", "Italy", "Germany", "Spain")
countries <- c ("India", "Brazil", "Russia", "China")
#countries <- c("India", "Singapore", "Malaysia", "Japan", "Thailand")

#download the data file
df_confirmed <- build_dataframe("time_series_covid19_confirmed_global.csv", countries)
df_recovered <- build_dataframe("time_series_covid19_recovered_global.csv", countries)
df_deaths <- build_dataframe("time_series_covid19_deaths_global.csv", countries)

#Calculate active cases and add date row
d_sums <- df_confirmed - df_recovered - df_deaths
dates <- seq(c(as.Date("1970/3/1")), by = "day", length.out = ncol(d_sums))
d_sums <- rbind(date=as.Date(dates), d_sums[1:length(countries),])
d_sums <- data.frame(t(d_sums))

#Create a dataframe for rate of change by skiping date
d_trend <- ma(d_sums[-1,-1]/d_sums[-nrow(d_sums),-1],5)[-1:-5,]
colnames(d_trend) <- colnames(d_sums)[-1]
#add date in trend dataframe
d_trend <- data.frame(t(d_trend))
d_trend <- rbind(date=as.Date(tail(dates,-5)), d_trend[1:length(countries),])
d_trend <- data.frame(t(d_trend))

#create a line plot for active cases
yMarker <- 10^ceiling(log10(max(d_sums[-1])))/80
p1 <- get_base_plot(d_sums, "Active cases") +
  scale_y_continuous(breaks = round(seq(0, max(d_sums[-1]), by = yMarker),1)) +
  geom_line(size=0.6) +
  geom_point(size=0.75)

#create a smoothen line plot for growth rate multiplier moving average
p2 <- get_base_plot(d_trend, "(5 day moving average) growth multiplier") +
  geom_smooth(method="loess", formula = y ~ x, se = FALSE, size=0.6)

grid.arrange(p1, p2, nrow = 2, top = "COVID-19 : Active cases and growth rate (Data Source- Johns Hopkins JHU CCSE)")


setwd("C:/Users/Aluno/Downloads/baleias")

imgnames = dir()
imgnames

#package
library(jpeg)

#read jpeg

for(k in 2:16){
img = readJPEG(imgnames[k])

#plot(c(0,1),c(0,1),col=0)
#rasterImage(img,0,0,1,1)

#Grid Split
deltax = 250
deltay = 250
r = 1
for(i in 1:trunc(dim(img)[1]/deltax)){
  for(j in 1:trunc(dim(img)[2]/deltay)){
    x = img[(deltax*(i-1)+1):(i*deltax),(deltay*(j-1)+1):(j*deltay),]
    writeJPEG(x,paste("p",r,imgnames[k],sep = ""))
    r = r + 1
    #print(r)
  }
}
}
#Baleia Sample

setwd("C:/Users/Aluno/Downloads/baleias/baleia")
whalesname = dir()

whal = readJPEG(whalesname[1])
plot(c(0,1),c(0,1),col=0)
rasterImage(whal,0,0,1,1)

DATAw = data.frame(R = c(whal[,,1]), G = c(whal[,,2]), B = c(whal[,,3]))

par(mfrow=c(1,3))
hist(DATAw[,1],col="red")
hist(DATAw[,2],col="green")
hist(DATAw[,3],col="blue")

pairs(DATAw)

#Parameters Estimation
library(mixsmsn)
modsn = smsn.mmix(DATAw, g=1, family = "Skew.normal")


library(tidyverse)

data('mtcars')

glimpse(mtcars)

select(mtcars, mpg, cyl)

select(mtcars, -mpg)

filter(mtcars, carb %in% c(1,4))

summarise(mtcars, wtmean=mean(wt), wtmedian=median(wt))

summarise_at(mtcars, vars(hp, wt, qsec), funs(n(),mean, median))

summarise_at(mtcars, vars(hp, wt, qsec), funs(missing=sum(is.na(.))))

summarise_at(mtcars, vars(hp, wt, qsec), funs(missing=sum(!is.na(.))))

summarise_at(mtcars, vars(hp, wt, qsec), function(x)var(x-mean(x)))

summarise_all(mtcars, funs(n(), mean, median))

summarise_if(mtcars, is.numeric, funs(n(), mean, median))

mdata = iris[sapply(iris, is.numeric)]

summarise_all(mdata, funs(n(), mean, median))

arrange(iris, Sepal.Length)

arrange(iris, Sepal.Length, Sepal.Width)

arrange(iris, desc(Sepal.Length), Sepal.Width)

iris %>% select(Sepal.Length, Sepal.Width) %>% sample_n(3)

mtcars %>% group_by(cyl) %>% summarise_at(vars(disp), funs(mean))

mtcars %>% filter(cyl%in% c(4,8)) %>% arrange(desc(disp)) %>% group_by(cyl) %>%do(head(.,2))

mtcars %>% filter(cyl%in% c(4,8)) %>% arrange(desc(disp)) %>% group_by(cyl) %>% filter(min_rank(desc(disp))==1)

min_rank(mtcars$disp)

mtcars %>% select(mpg, cyl) %>% mutate(newvar=mpg*cyl)

mtcars %>% mutate_all(funs('newvar'=.*100))

mtcars %>% mutate_at(vars(mpg,cyl),funs('newvar'=.*100))

df1 = data.frame(ID=c(1,2,3,4,5), w=c('a','b','c','d','e'), x = c(1,1,0,0,1),y = rnorm(5), z = letters[1:5])
df2 = data.frame(ID=c(1,7,3,6,8), w=c('z','b','k','d','l'), x = c(1,2,3,0,4),y = rnorm(5), z = letters[2:6])

inner_join(df1,df2, by='ID')

inner_join(df1,df2, by=c('ID','ID'))

right_join(df1,df2, by='ID')

left_join(df1,df2, by='ID')

df = data.frame(x=c(1:100))

df %>% mutate(evenodd=if_else(x%%2==0,'EVEN','ODD'))

df %>% mutate(pass=case_when(
    x<35~'Fail',
    x>75~'Grade A',
    x>60~'Grade B',
    x>50~'Grade C',
    TRUE~'Pass'
))

mtcars %>% rowwise() %>% mutate(add=sum(cyl, disp,hp)) %>% select(c(cyl, disp, hp, add))

select_if(iris, is.factor)

select_if(iris, is.numeric)

mutate_if(iris, is.numeric, funs('new'=.*100))

newfun = function(x, N=5){
    x %>% arrange(desc(disp)) %>% head(N)
}

mtcars %>% group_by(cyl) %>% do(newfun(.,3))

library(ggplot2)

data()
data(iris)

plot(iris)

plot(iris$Petal.Length, iris$Sepal.Width)

ggplot(iris, aes(x = Petal.Length, y=Sepal.Width)) + geom_point()

ggplot(iris, aes(x = Petal.Length, y=Sepal.Width, col=Species)) + geom_point()

ggplot(iris, aes(x = Petal.Length, y=Sepal.Width, col=Species,
                 size=Petal.Width)) + geom_point()

ggplot(iris, aes(x = Petal.Length, y=Sepal.Width, col=Species,
                 size=Petal.Width, shape=Species)) + geom_point()

ggplot(iris, aes(x = Petal.Length, y=Sepal.Width, col=Species,
                 size=Petal.Width, shape=Species,
                 alpha=Sepal.Length)) + geom_point()

ggplot(iris, aes(Species, Sepal.Length)) + geom_bar(stat='summary', fun.y='mean')

ggplot(iris, aes(Species, Sepal.Length,
                 fill=Species)) + geom_bar(stat='summary', fun.y='mean')

ggplot(iris, aes(Species, Sepal.Length))+ geom_bar(stat='summary',
                                                   fun.y='mean', fill='blue')

ggplot(iris, aes(Species, Sepal.Length))+ geom_bar(stat='summary',
                                                   fun.y='mean', fill='#ff0080',
                                                  col='black') + geom_point()

myplot = ggplot(iris, aes(Species, Sepal.Length))+ geom_bar(stat='summary',
                                                   fun.y='mean',
                                                   fill='#ff0080',
                                                  col='black'
                                                  ) + geom_point(
    position = position_jitter(0.2), size=3, shape=21 )

myplot + theme(panel.grid = element_blank(),
               panel.background = element_rect(fill='blue'),
               panel.border=element_rect(colour="black", fill=NA, size=0.2))

?theme

myplot + theme_bw()

myplot + theme_dark()

myplot + theme_gray()

myplot + theme_minimal()

myplot + theme_linedraw() + theme(
               panel.background = element_rect(fill='blue'))

ggplot(iris, aes(Species, Sepal.Length)) + geom_boxplot(fill='blue',col='black')

ggplot(iris, aes(Species, Sepal.Length)) + geom_boxplot(
    fill='blue',col='black', notch=TRUE)

myplot + theme_bw() +
    labs(x = "", y="Sepal length(nm)") + ggtitle("Sepal length by iris species")+
    theme(plot.title = element_text(hjust=0.5))

#setwd("~/Documents")
ggsave("Graph 1.png", width=8, height=5)


#' K-Means++ initialization to K-means
#'
#' INPUTS:
#' x: The data formatted as a matrix.
#' k: The number of clusters desired. \code{k < nrows(x)}
#'
#'
#' REFERENCE:
#' Arthur, David and Vassilvitskii, Sergei k-means++: The Advantages of Careful Seeding
#'

kmpp <- function(x,k=2){

la2 <- function(a,b){
        m1 <- matrix(as.numeric(a),nrow=dim(b)[1],ncol=dim(b)[2], byrow=TRUE)

        if(all(dim(m1) == dim(b))){
            dif <- apply((m1-b)^2,1,sum)
        return(dif)
        } else {
            stop("Wrong dimensions!")}
        }

### Step 1a
#set.seed(2^13)
s1 <- cp <- sample(nrow(x),1)

ind <- c(cp)

centers <- list()

centers[[1]] <- x[s1,]

p <- la2(x[s1,],x)
P <- p/sum(p) ## P = D(x')^2/( ∑_x\inX  D(x)^2)

### Step 1b-c
for( i in 2:k ) {
    #set.seed(2^13)
    cp <- sample(nrow(x),1,prob=P) ## c'
    centers[[i]] <-x[cp,]
    ind <- c(ind,cp)

    p <- apply(cbind(la2(x[cp,],x),p),1,min) #apply(cbind(p,ds[,cp]),1,min)
    P <- p/sum(p)
    }

Ctrs <- Reduce('rbind',centers)

kObj <- kmeans(x, centers=Ctrs)

return(kObj)
} ### END FUNCTION

bhkmpp <- function(x,blevels){
    require(data.table)

    k0 <- kmpp(x,2)
    L <- data.table(lv1=k0$cluster)

    for(y in 2:blevels){ L[[y]] <- 0L }
    colnames(L) <- paste0("lv", 1:blevels)

    for(j in 1:(blevels-1)){
    for(i in sort(unique(L[[j]]))){
        ## Set seed to keep cluster labels somewhat consistant
        set.seed(13)
        kv <- kmpp(x[L[[j]] == i,], k = 2)
        if(i != 1){kv$cluster <- as.integer(kv$cluster + 2*(i-1))}
        L[L[[j]]==i,][[j+1]] <- kv$cluster
        }
    }
    return(L)
}


volumes <- c(25, 45, 28, 79, 74, 61, 12, 68, 93, 39, 100)
soma <- sum(volumes)

# Soma de todos vetores
print(soma)


multiplier <- function(n1,n2) { (function(m){n1*n2*m}) }
x  = 2.0
xi = 0.5
y  = 4.0
yi = 0.25
z  = x + y
zi = 1.0 / ( x + y )
num = c(x,y,z)
inv = c(xi,yi,zi)

multiplier(num,inv)(0.5)

Output
[1] 0.5 0.5 0.5