## 1. Simplifying Data ##

library(readr)
library(tidyr)
wnba <- read_csv("wnba.csv")

## 2. Frequency Distribution Tables ##

library(dplyr)
freq_dist_pos <- wnba %>%
  group_by(Pos) %>%
  summarize(Freq = n())

freq_dist_height <- wnba %>%
  group_by(Height) %>%
  summarize(Freq = n())

## 3. Arranging Frequency Distribution Tables ##

age_ascending <- wnba %>%
  group_by(Age) %>%
  summarize(Freq = n())

age_descending <- wnba %>%
  group_by(Age) %>%
  summarize(Freq = n()) %>%
  arrange(desc(Age))

## 4. Sorting Tables for Ordinal Variables ##

points_levels <- c("well below average", "below average", "average points", "above average", "well above average")

points_ordinal <- wnba %>%
  group_by(Points_labels) %>%
  summarize(Freq = n()) %>%
  arrange(factor(Points_labels,
                 levels = points_levels))

## 5. Proportions and Percentages ##

age_25 <- wnba %>%
  filter(Age == 25) %>%
  summarize(Freq = n()) %>%
  mutate(Prop = Freq / nrow(wnba)) %>%
  mutate(Percentage = Freq / nrow(wnba) * 100)

age_23_or_under <- wnba %>%
  filter(Age <= 23) %>%
  summarize(Freq = n()) %>%
  mutate(Prop = Freq / nrow(wnba)) %>%
  mutate(Percentage = Freq / nrow(wnba) * 100)

age_30_or_older <- wnba %>%
  filter(Age >= 30) %>%
  summarize(Freq = n()) %>%
  mutate(Prop = Freq / nrow(wnba)) %>%
  mutate(Percentage = Freq / nrow(wnba) * 100)

## 6. Percentiles and Percentile Ranks ##

percentile_50_or_less <- mean(wnba$Games_Played <= 17) * 100
percentile_above_50 <- mean(wnba$Games_Played > 17) * 100

## 7. Finding Percentiles with R ##

age_upper_quartile <- quantile(wnba$Age, probs = 0.75)
age_middle_quartile <- quantile(wnba$Age, probs = 0.50)
age_95th_percentile <- quantile(wnba$Age, probs = 0.95)

wnba_age_percentiles <- wnba %>%
  mutate(cume_dist_age = cume_dist(Age)) %>%
  select(Name, Age, cume_dist_age) %>%
  arrange(Age)

## 8. Grouped Frequency Distribution Tables ##

wnba <- wnba %>%
  mutate(points_categories = cut(PTS, breaks = 10, dig.lab = 4))

pts_freq_table <- wnba %>%
  group_by(PTS) %>%
  summarize(Freq = n())

pts_grouped_freq_table <- wnba %>%
  group_by(points_categories) %>%
  summarize(Freq = n()) %>%
  mutate(Percentage = Freq / nrow(wnba) * 100) %>%
  arrange(desc(points_categories))

## 10. Readability for Grouped Frequency Tables ##

wnba <- wnba %>%
  mutate(min_categories =
           cut(MIN,
               breaks = c(0, 150, 300, 450, 600, 750, 900, 1050),
               dig.lab = 4))

min_grouped_freq_table <- wnba %>%
  group_by(min_categories) %>%
  summarize(Freq = n()) %>%
  mutate(Percentage = Freq / nrow(wnba) * 100)

Data Analyst in R/Step 5 - Probability and Statistics/1. Statistics Fundamentals in R/4. Frequency Distributions.r


x = c(7.4, 9.3, 5, 12)
y = c(-7.3, 2, 9, -4.9)
v = 2*x + 3*y + 1

print("Vector x:")
print(x)
print("Vector y:")
print(y)
print("Vector v:")
print(v)

lv = x == 8
print("Logical vector comparing elements of x with 8:")
print(lv)

z = y[y > 0]
print("Positive elements of y:")
print(z)

v3 = v[3]
print("Third element of v:")
print(v3)

x13 = x[1:3]
print("First 3 elements of x:")
print(x13)

x3n = x[-(1:3)]
print("Elements of x starting with position 3:")
print(x3n)

yn <- y
yn[yn < 0] <- 0
print("Vector y replacing negative values with 0:")
print(yn)

clothes.types = c("Hoodie", "Cardigan", "Dress", "Hat")
clothes.prices = c(29.99, 42.15, 20.99, 16.45)
clothes.chosen = c("Hoodie", "Hat")
cost = sum(clothes.prices[clothes.types %in% clothes.chosen])
print("Price for Hoodie and Hat:")
print(cost)

Curs 1 - Introduction in Machine Learning/set2.r


flights = data.frame(
    distance = c(365,1462,1285,1096,517,1686,932,1160),
    time = c(1.167,2.333,2.250,2.083,2.250,2.833,1.917,2.167)
)
model = lm(time ~ distance, data = flights)
print(model)


orderBalancedTree <- Vectorize(function(r, h) {
  #  computes the number of vertices in a balanced tree of breadth "r" and height "h"
  #
  #  Args:
  #     r:  The breadth (branching factor) of the balanced tree
  #     h:  The height of the balanced tree
  #
  #  Returns:
  #     The number of vertices in a balanced tree
  #

  total <- 0
  hseq <- seq.int(0, h)
  total <- sum(r ^ hseq)

  return(total)
})


pdf('Sample_1.junctionSaturation_plot.pdf')
x=c(5,10,15,20,25,30,35,40,45,50,55,60,65,70,75,80,85,90,95,100)
y=c(1084,2096,3048,3948,4744,5486,6227,6911,7551,8200,8795,9315,9791,10271,10730,11137,11549,11887,12238,12567)
z=c(3112,5715,8073,10292,12323,14237,16177,17979,19741,21440,23101,24609,26100,27560,28955,30301,31564,32723,33907,35067)
w=c(2028,3619,5025,6344,7579,8751,9950,11068,12190,13240,14306,15294,16309,17289,18225,19164,20015,20836,21669,22500)
m=max(12,35,22)
n=min(1,3,2)
plot(x,z/1000,xlab='percent of total reads',ylab='Number of splicing junctions (x1000)',type='o',col='blue',ylim=c(n,m))
points(x,y/1000,type='o',col='red')
points(x,w/1000,type='o',col='green')
legend(5,35, legend=c("All junctions","known junctions", "novel junctions"),col=c("blue","red","green"),lwd=1,pch=1)
dev.off()


# Regression Template

# Libraries
library(ggplot2)

# Importing dataset
dataset = read.csv('')
dataset = dataset[]

# Fitting Regression model to the dataset
# Create your regressor
regressor

# Predicting a new result with Polynomial Regression
y_pred = predict(regressor, data.frame( = ))

# Visualising the Regression model results
ggplot() +
  geom_point(x = , y = , colour = 'red') +
  geom_line(aes(x = , y = predict(regressor, newdata = )),
            colour = 'blue') +
  ggtitle('') +
  xlab('') +
  ylab('')

# Visualising the Regression Model Results (for higher resultions and smoother curve)
x_grid = seq(min(), max(), 0.1)
ggplot() +
  geom_point(x = , y = , colour = 'red') +
  geom_line(aes(x = x_grid, y = predict(regressor, newdata = data.frame(? = x_grid))),
            colour = 'blue') +
  ggtitle('') +
  xlab('') +
  ylab('')


library(lattice)
d = data.frame(iris)
d

xyplot(Rural.Male~Rural.Female,data=d)
splom(iris[1:3],data=d)
cloud(d$Sepal.Length~d$Sepal.Width*d$Petal.Length|Species, data=iris)
dotplot(d$Sepal.Length~d$Sepal.Width,data=iris)
histogram(d$Sepal.Length~d$Sepal.Width,data=iris,col=rainbow(55:10))


library(psych)

df_bfi <- bfi

head(df_bfi)
help(bfi)

prop.table(table(bfi$A1))

df_bfi <- df_bfi[complete.cases(df_bfi),] #Elimina los NA

mcbfi <- cor(df_bfi)

#Factor analysis
?fa()
factores <- fa(r = mcbfi, nfactors = 6)
factores

fa.diagram(factores)


Dragon<-function(Iters){
  Rotation<-matrix(c(0,-1,1,0),ncol=2,byrow=T) ########Rotation multiplication matrix
  Iteration<-list() ###################################Set up list for segment matrices for 1st
  Iteration[[1]] <- matrix(rep(0,16), ncol = 4)
  Iteration[[1]][1,]<-c(0,0,1,0)
  Iteration[[1]][2,]<-c(1,0,1,-1)
  Moveposition<-rep(0,Iters) ##########################Which point should be shifted to origin
  Moveposition[1]<-4
  if(Iters > 1){#########################################where to move to get to origin
    for(l in 2:Iters){#####################################only if >1, because 1 set before for loop
      Moveposition[l]<-(Moveposition[l-1]*2)-2#############sets vector of all positions in matrix where last point is
    }}
  Move<-list() ########################################vector to add to all points to shift start at origin
for (i in 1:Iters){
half<-dim(Iteration[[i]])[1]/2
half<-1:half
for(j in half){########################################Rotate all points 90 degrees clockwise
  Iteration[[i]][j+length(half),]<-c(Iteration[[i]][j,1:2]%*%Rotation,Iteration[[i]][j,3:4]%*%Rotation)
}
Move[[i]]<-matrix(rep(0,4),ncol=4)
Move[[i]][1,1:2]<-Move[[i]][1,3:4]<-(Iteration[[i]][Moveposition[i],c(3,4)]*-1)
Iteration[[i+1]]<-matrix(rep(0,2*dim(Iteration[[i]])[1]*4),ncol=4)##########move the dragon, set next Iteration's matrix
for(k in 1:dim(Iteration[[i]])[1]){#########################################move dragon by shifting all previous iterations point
  Iteration[[i+1]][k,]<-Iteration[[i]][k,]+Move[[i]]###so the start is at the origin
}
xlimits<-c(min(Iteration[[i]][,3])-2,max(Iteration[[i]][,3]+2))#Plot
ylimits<-c(min(Iteration[[i]][,4])-2,max(Iteration[[i]][,4]+2))
plot(0,0,type='n',axes=FALSE,xlab="",ylab="",xlim=xlimits,ylim=ylimits)
s<-dim(Iteration[[i]])[1]
s<-1:s
segments(Iteration[[i]][s,1], Iteration[[i]][s,2], Iteration[[i]][s,3], Iteration[[i]][s,4], col= 'red')
}}#########################################################################


#Constants
dsize = 8

Gval_per_s <- function(value,time){
	return (value / (time * 1e9))
}

dgemm_flops <- function(M, N, K){
	return (M * K * (2 * N + 1))
}

dgemm_bytes <- function(M, N, K){
	return ((M * K + K * N + M * N * 2)*dsize)
}

dgemv_flops <- function(M, N){
	return (M * (2 * N + 1))
}

colMax <- function(data) sapply(data, max, na.rm = TRUE)


# CREATE A NEW COLUMN OF INDEX
# FROM 0 TO THE SIZE OF THE MATRIX MINUS 1

error1$index<-seq.int(0, nrow(error1)-1, 1)

#COMPARE THE COLUMNS
#AND CREATE A NEW COLUMN
#PUTTING A 0 IF ARE EQUAL
#PUTTING A 1 IF ARE DIFFERENT

error1$order <- ifelse(error1$V6 == error1$index,0,1)

#COUNT THE NUMBER OF ZERO IN A MATRIX
#REMEMBER THAT ZEROS ARE EQUAL

colSums(error1 == 0)

#AS A FUNCTION - SUM ALL THAT ALL ROWS WITH ZERO

library(plyr)
nonzero <- function(x) sum(x == 0)
numcolwise(nonzero)(error1)

#USING A TABLE
zeros<-error1$order
a <- table(zeros)
a

#WHICH
numero_zeros<-length(which(zeros==0))
percent_disorder<-(numero_zeros*100)/2001


#' SVD
#'
#' SVD factorization.
#'
#' @details
#' The factorization is performed by the LAPACK routine \code{sgesdd()}.
#'
#' @param x
#' A float matrix.
#' @param nu,nv
#' The number of left/right singular vectors to return.
#' @param LINPACK
#' Ignored
#'
#' @examples
#' library(float)
#'
#' x = flrunif(10, 3)
#' svd(x)
#'
#' @useDynLib float R_svd_spm
#' @name svd
#' @rdname svd
NULL

utils::globalVariables(c("n", "p"))

La.svd_float32 = function(x, nu=min(n, p), nv=min(n, p))
{
  n = NROW(x)
  p = NCOL(x)

  if (n == 0 || p == 0)
    stop("a dimension is zero")

  nu = as.integer(nu)
  if (is.na(nu) || nu < 0)
    stop("argument must be coercible to non-negative integer")

  nv = as.integer(nv)
  if (is.na(nv) || nv < 0)
    stop("argument must be coercible to non-negative integer")

  ret = .Call(R_svd_spm, DATA(x), min(n, nu), min(p, nv))

  ret$d = float32(ret$d)
  if (nu)
    ret$u = float32(ret$u)
  if (nv)
    ret$vt = float32(ret$vt)

  ret
}

svd_float32 = function(x, nu=min(n, p), nv=min(n, p), LINPACK=FALSE)
{
  n = NROW(x)
  p = NCOL(x)

  ret = La.svd_float32(x, nu, nv)
  if (nv)
  {
    ret$v = t(ret$vt)
    ret$vt = NULL
  }

  ret
}

#' @rdname svd
#' @export
setMethod("La.svd", signature(x="float32"), La.svd_float32)

#' @rdname svd
#' @export
setMethod("svd", signature(x="float32"), svd_float32)


require(lmtest)

problem_data <- function() {
    mer <- c(4.0, 4.0, 5.0, 0.5, 3.0, 5.0, 6.0, 2.0, 4.0, 4.0, 4.5, 4.0, 3.5, 2.0, 3.0, 2.5, 4.0, 6.5, 4.5, 4.0, 4.0, 4.0, 3.5, 2.0, 4.0)
    rtd <- c(2.6, 2.8, 5.0, 0.0, 2.4, 6.4, 6.4, 2.3, 4.2, 4.0, 3.3, 1.4, 1.8, -1.9, -7.6, 3.1, 5.0, 6.6, 2.7, 6.3, 0.0, 0.4, 0.6, -4.0, -6.3)
    dif <- abs(mer - rtd)

    days <- c('D1', 'D2', 'D3', 'D4', 'D5')
    all_days <- c(rep(days, 5))
    silo <- c(rep('A', 5), rep('B', 5), rep('C', 5), rep('D', 5), rep('E', 5))

    return(data.frame(silo, days, mer, rtd, dif))
}

box_plot <- function(x, df, label) {
    title <- 'Box-plot de las medias diarias'
    png(paste('images/box-', label, '-ByBlock.png', sep = ''))
    boxplot(
        x ~ df$days,
        ylab=paste('Medida - ', label, sep=''),
        xlab='Días',
        main=title
    )
    dev.off()

    title2 <- 'Box-plot de las medias por silo'
    png(paste('images/box-', label, '-ByFactor.png', sep = ''))
    boxplot(
        x ~ df$silo,
        ylab=paste('Medida - ', label, sep=''),
        xlab='Silo',
        main=title2
    )
    dev.off()
}

qq_plot <- function(residuals, label) {
    png(paste('images/qq-', label, '.png', sep=''))
    qqnorm(residuals)
    qqline(residuals)
    dev.off()
}

hist_plot <- function(residuals, label) {
    png(paste('images/hist-', label, '.png', sep=''))
    hist(residuals)
    dev.off()
}

std_plot <- function(anova, label) {
    png(paste('images/std-', label, '.png', sep=''))
    plot(
        anova$fitted.values,
        rstudent(anova),
        ylab='Residuals',
        xlab='Predictions',
        main='Anova Residuals'
    )
    abline(h = 0, lty = 2)
    dev.off()
}

plot_assumptions <- function(anova, label) {
    png(paste('images/all-', label, '.png', sep=''))
    layout(matrix(c(1,2,3,4), 2, 2, byrow=T))
    plot(
        anova$fitted.values,
        rstudent(anova),
        ylab='Residuals',
        xlab='Predictions',
        main='Anova Residuals'
    )
    abline(h = 0, lty = 2)
    residuals <- anova$residuals
    hist(residuals)
    qqnorm(residuals)
    qqline(residuals)
    dev.off()
}

test_assumptions <- function(anova, df) {
    print("    ++ Shapiro ++     ")
    print(shapiro.test(anova$residuals))

    print("    ++ Bartlett ++     ")
    print(bartlett.test(anova$residuals, df$silo))

    print("    ++ Durbin-Watson ++     ")
    print(dwtest(anova))
}

make_model <- function(df, x, label) {
    # Box Plot
    box_plot(x, df, label)

    # Anova analysis
    anova <- aov(x ~ df$silo + df$days)
    res <- anova$residuals

    print(paste('---------', label, '---------'))
    print('    ++ Anova ++    ')
    print(summary(anova))

    # Check anova residual assumptions
    # Test
    test_assumptions(anova, df)

    # Plots
    plot_assumptions(anova, label)
    # Plot in separated images
    std_plot(anova, label)
    hist_plot(res, label)
    qq_plot(res, label)

    return()
}

main <- function() {
    df <- problem_data()

    make_model(df, df$mer, 'Mer')
    make_model(df, df$rtd, 'Rtd')
    make_model(df, df$dif, 'Diferencia')

    return()
}

main()


# 準備（p.127） ----------------------------------------------------------------------
install.packages("tidyverse")
library(tidyverse)

# 新しいキャンバスの用意（p.128） -------------------------------------------------------------
g <- ggplot()

# 図4.2（p.129）-----------------------------------------------------
## 左図
ggplot() +
  geom_histogram(data = mpg, mapping = aes(x = displ))

## 右図
ggplot() +
  geom_density(data = mpg, mapping = aes(x = displ))

# 図4.3（p.130） -----------------------------------------------------
ggplot() +
  geom_point(data = mpg, mapping = aes(x = displ, y = cty))

# 図4.4（p.131） -----------------------------------------------------
ggplot() +
  geom_point(data = mpg, mapping = aes(x = displ, y = cty)) +
  geom_smooth(data = mpg, mapping = aes(x = displ, y = cty), method = "lm")

## 別の方法
ggplot(data = mpg, mapping = aes(x = displ, y = cty)) +
  geom_point() +
  geom_smooth(method = "lm")

# 図4.5（p.132） -----------------------------------------------------
mpg1999 <- filter(mpg, year == 1999)
mpg2008 <- filter(mpg, year == 2008)

ggplot(mapping = aes(x = displ, y = cty)) +
  geom_point(data = mpg1999) +
  geom_point(data = mpg2008)

# 図4.6（p.133） -----------------------------------------------------
## 左図
ggplot(data = mpg, mapping = aes(x = displ, y = cty, group = cyl, colour = cyl)) +
  geom_point()

## 右図
ggplot(data = mpg, mapping = aes(x = displ, y = cty, group = factor(cyl), colour = factor(cyl))) +
  geom_point()

# 図4.7（p.133-134） -----------------------------------------------------
## 左図
ggplot(data = mpg, mapping = aes(x = displ, y = cty)) +
  geom_point() +
  geom_smooth(mapping = aes(group = factor(cyl), colour = factor(cyl)), method = "lm")

## 右図
ggplot(data = mpg, mapping = aes(x = displ, y = cty)) +
  geom_point() +
  geom_smooth(mapping = aes(group = factor(cyl)), method = "lm")

# 図4.8（p.134） -----------------------------------------------------
## 左図
ggplot(data = mpg, mapping = aes(x = displ, y = cty)) +
  geom_point(mapping = aes(colour = factor(cyl), shape = factor(cyl)))

## 右図
ggplot(data = mpg, mapping = aes(x = displ, y = cty)) +
  geom_point() +
  geom_smooth(mapping = aes(colour = factor(year), linetype = factor(year)), method = "lm")

# 図4.9（p.135） -----------------------------------------------------
## 左図
ggplot(data = mpg, mapping = aes(x = displ, y = cty, colour = factor(cyl))) +
  geom_point(shape = 17, size = 4, alpha = 0.4)

## 右図
ggplot(data = mpg, mapping = aes(x = displ, y = cty)) +
  geom_point(colour = "chocolate", shape = 35, size = 10) +
  geom_smooth(method = "lm", linetype = "dashed", se = FALSE)

# 図4.10（p.136） -----------------------------------------------------
add_x <- c(2.5, 3, 3.5)
add_y <- c(25, 27.5, 30)

## 右図
ggplot(data = mpg, mapping = aes(x = displ, y = cty)) +
  geom_point() +
  annotate(geom = "point", x = add_x, y = add_y, colour = "red") +
  annotate(geom = "text", x = c(5, 5), y = c(30, 25), label = c("要チェック！", "赤色のデータを追加"))

# 図4.11（p.137） -----------------------------------------------------
## 左図
ggplot(data = mpg, mapping = aes(x = displ, y = cty)) +
  geom_point() +
  facet_wrap(~ cyl)

## 中央
ggplot(data = mpg, mapping = aes(x = displ, y = cty)) +
  geom_point() +
  facet_grid(. ~ cyl)

## 右図
ggplot(data = mpg, mapping = aes(x = displ, y = cty)) +
  geom_point() +
  facet_grid(cyl ~ .)

# 図4.12（p.137-138） -----------------------------------------------------
## 左図
ggplot(data = mpg, mapping = aes(x = displ, y = cty)) +
  geom_point() +
  facet_wrap(year ~ cyl)

## 右図
ggplot(data = mpg, mapping = aes(x = displ, y = cty)) +
  geom_point() +
  facet_grid(year ~ cyl)

# 図4.13（p.138-140） -----------------------------------------------------
mean_cty <- mpg %>%
  group_by(class) %>%
  summarise(cty = mean(cty))

ggplot(data = mean_cty, mapping = aes(x = class, y = cty)) +
  geom_bar(stat = "identity")

## 別の方法1
ggplot(data = mpg, mapping = aes(x = class, y = cty)) +
  geom_bar(stat = "summary", fun.y = "mean")

## 別の方法2
ggplot(data = mpg, mapping = aes(x = class, y = cty)) +
  stat_summary(geom = "bar", fun.y = "mean")

# 図4.14（p.140-141） -----------------------------------------------------
ggplot(data = mpg, mapping = aes(x = class, y = cty)) +
  stat_summary(geom = "pointrange", fun.y = "mean", fun.ymax = "max", fun.ymin = "min")

# 図4.15（p.141-142） -----------------------------------------------------
ggplot(data = mpg, mapping = aes(x = class, y = cty)) +
  stat_summary(geom = "bar", fun.y = "mean", fill = "grey") +
  stat_summary(geom = "pointrange", fun.data = "mean_se")

# 図4.16（p.142-143） -----------------------------------------------------
ggplot(data = mpg, mapping = aes(x = factor(year), y = displ)) +
  stat_summary(fun.y = "mean", geom = "line", group = 1)

# 図4.17（p.144） -----------------------------------------------------
## 左図
ggplot(data = mpg, mapping = aes(x = class, y = cty)) +
  stat_summary(geom = "bar", fun.y = "mean") +
  geom_point(mapping = aes(colour = class), show.legend = FALSE)

## 右図
ggplot(data = mpg, mapping = aes(x = class, y = cty)) +
  geom_violin(scale = "count") +
  geom_point(mapping = aes(colour = class), show.legend = FALSE)

# 図4.18（p.145） -----------------------------------------------------
## 左図
ggplot(data = mpg, mapping = aes(x = class, y = cty)) +
  stat_summary(geom = "bar", fun.y = "mean") +
  geom_jitter(mapping = aes(colour = class), show.legend = FALSE)

## 右図
ggplot(data = mpg, mapping = aes(x = class, y = cty)) +
  stat_summary(geom = "bar", fun.y = "mean") +
  geom_jitter(mapping = aes(colour = class), width = 0.4, height = 0, show.legend = FALSE)

# 図4.19（p.146） -----------------------------------------------------
## 左図
ggplot(data = mpg, mapping = aes(x = class, y = cty, fill = factor(year)))+
  stat_summary(geom = "bar", fun.y = "mean")+
  stat_summary(fun.data = "mean_se")

## 中央
ggplot(data = mpg, mapping = aes(x = class, y = cty, fill = factor(year)))+
  geom_bar(stat = "summary", fun.y = "mean")+
  stat_summary(fun.data = "mean_se")

## 右図
ggplot(data = mpg, mapping = aes(x = class, y = cty, fill = factor(year)))+
  stat_summary(geom = "bar", fun.y = "mean", position = position_dodge())+
  stat_summary(fun.data = "mean_se", position = position_dodge(width = 0.9))

# 図4.20（p.147-148） -----------------------------------------------------
## 左図
ggplot(data = mpg, mapping = aes(x = displ, y = cty)) +
  geom_point() +
  geom_vline(xintercept = 4) +
  geom_hline(yintercept = 15) +
  geom_smooth(method = "lm", se = FALSE)

## 右図
ggplot(data = mpg, mapping = aes(x = displ, y = cty)) +
  geom_point() +
  xlim(1.5, 4.5) +
  ylim(10, 35) +
  geom_vline(xintercept = 4) +
  geom_hline(yintercept = 15) +
  geom_smooth(method = "lm", se = FALSE)

# 図4.21（p.148-149） -----------------------------------------------------
## 左図
ggplot(data = mpg, mapping = aes(x = displ, y = cty)) +
  geom_point() +
  geom_vline(xintercept = 4) +
  geom_hline(yintercept = 15) +
  geom_smooth(method = "lm", se = FALSE)

## 右図
ggplot(data = mpg, mapping = aes(x = displ, y = cty)) +
  geom_point() +
  coord_cartesian(xlim = c(1.5, 4.5), ylim = c(10, 35)) +
  geom_vline(xintercept = 4) +
  geom_hline(yintercept = 15) +
  geom_smooth(method = "lm", se = FALSE)

# 図4.22（p.149-150） -----------------------------------------------------
## 左図
ggplot(data = mpg, mapping = aes(x = drv, y = cty)) +
  geom_violin() +
  stat_summary(fun.data = "mean_se")

## 右図
ggplot(data = mpg, mapping = aes(x = drv, y = cty)) +
  geom_violin() +
  stat_summary(fun.data = "mean_se") +
  coord_flip()

# グラフの保存（p.151） -----------------------------------------------------
g <- ggplot(data = mpg, mapping = aes(x = class, y = cty)) +
  stat_summary(geom = "bar", fun.y = mean)

ggsave(plot = g, filename = "cty_class.png",
       dpi = 300, height = 20, width = 20, units = "cm")

# 図4.24（p.152） -----------------------------------------------------
## 左図
ggplot(data = mpg, mapping = aes(x = displ, y = cty)) +
  theme_classic() +
  geom_point()

## 右図
ggplot(data = mpg, mapping = aes(x = displ, y = cty)) +
  theme_bw() +
  geom_point()

# 図4.25（p.152-153） -----------------------------------------------------
## 左図
ggplot(data = mpg, mapping = aes(x = displ, y = cty)) +
  theme_classic() +
  geom_point()

## 右図
ggplot(data = mpg, mapping = aes(x = displ, y = cty)) +
  theme_classic(base_size = 25, base_family = "serif") +
  geom_point()

# 図4.26（p.154） -----------------------------------------------------
## 左図
ggplot(data = mpg, mapping = aes(x = class, y = cty)) +
  geom_boxplot() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))

## 右図
theme_set(theme_bw() + theme(axis.text.x = element_text(angle = 45, hjust = 1)))
ggplot(data = mpg, mapping = aes(x = class, y = cty)) +
  geom_boxplot()

# 図4.27（p.155） -----------------------------------------------------
## 左図
ggplot(data = mpg, mapping = aes(x = drv, y = cty, fill = drv)) +
  geom_boxplot()

## 右図
ggplot(data = mpg, mapping = aes(x = drv, y = cty, fill = drv)) +
  geom_boxplot() +
  scale_fill_manual(values = c("4" = "black", "f" = "grey", "r" = "#ffffff"))

# 図4.28（p.155-156） -----------------------------------------------------
## 左図
ggplot(data = mpg, mapping = aes(x = drv, y = cty, fill = drv)) +
  geom_boxplot() +
  scale_fill_grey(start = 0.4, end = 0.9)

## 右図
ggplot(data = mpg, mapping = aes(x = drv, y = cty, fill = drv)) +
  geom_boxplot() +
  scale_fill_grey(start = 1, end = 0)

# 図4.29（p.156-157） -----------------------------------------------------
install.packages("RColorBrewer")
library(RColorBrewer)

display.brewer.all()

# 図4.30（p.157-158） -----------------------------------------------------
## 左図
ggplot(data = mpg, mapping = aes(x = drv, y = cty, fill = drv)) +
  geom_boxplot() +
  scale_fill_brewer(palette = "Greys")

## 右図
ggplot(data = mpg, mapping = aes(x = drv, y = cty, fill = drv)) +
  geom_boxplot() +
  scale_fill_brewer(palette = "Paired")

# 図4.31（p.158-159） -----------------------------------------------------
install.packages("viridis")
library(viridis)

## 左図
ggplot(data = mpg, mapping = aes(x = displ, y = cty, colour = cyl)) +
  geom_point() +
  scale_colour_viridis()

## 右図
ggplot(data = mpg, mapping = aes(x = class, y = cty, fill = class)) +
  geom_boxplot(show.legend = FALSE) +
  scale_fill_viridis(discrete = TRUE)

# 図4.32（p.159-160） -----------------------------------------------------
install.packages("ggthemes")
library(ggthemes)
ggthemes_data$colorblind

ggplot(data = mpg, mapping = aes(x = class, y = cty, fill = class)) +
  geom_boxplot(show.legend = FALSE) +
  scale_fill_colorblind()

# 図4.33（p.160-161） -----------------------------------------------------
## 左図
ggplot(data = mpg, mapping = aes(x = displ, y = cty, group = factor(cyl), colour = factor(cyl))) +
  geom_point()

## 右図
ggplot(data = mpg, mapping = aes(x = displ, y = cty, group = factor(cyl), colour = factor(cyl))) +
  geom_point() +
  labs(title = "エンジンの大きさと市街地における燃費の関係",
       subtitle = "1999年と2008年のデータを用いて",
       caption = "出典：xxx",
       x = "エンジンの大きさ（L）",
       y = "市街地における燃費（mpg）",
       colour = "シリンダー数")

# 図4.34-35（p.162-163） -----------------------------------------------------
install.packages("ggplotgui")
library(ggplotgui)

ggplot_shiny(dataset = mpg)

install.packages("plotly")
library(plotly)

g <- ggplot(data = mpg, mapping = aes(x = class, y = displ, colour = class)) +
  theme_bw() +
  geom_violin() +
  geom_jitter(size = 1, alpha = 0.5, width = 0.25, colour = "black")

ggplotly(p = g)

# 図4.36（p.163-164） -----------------------------------------------------
install.packages("ggpubr")
library(ggpubr)

g1 <- ggplot(data = mpg, mapping = aes(x = displ, y = cty)) +
  theme_classic() +
  geom_point(colour = "seagreen")

g2 <- ggplot(data = mpg, mapping = aes(x = displ, y = hwy)) +
  theme_classic() +
  geom_point(colour = "lightskyblue")

ggarrange(g1, g2, labels = c("市街地", "高速道路"), ncol = 2, hjust = -1.5)

# 図4.37（p.164-165） -----------------------------------------------------
weight_change <- data.frame(time = c("pre", "post_2days", "post_10days", "post_20days"),
                            weight = c(60, 60, 57, 55))

## 左図
ggplot(data = weight_change, mapping = aes(x = time, y = weight)) +
  geom_point() +
  geom_line(group = 1) +
  coord_cartesian(ylim = c(50, 65))

## 右図
weight_change$time <- fct_relevel(weight_change$time, "pre", "post_2days")
#またはweight_change$time <- fct_inorder(weight_change$time)

ggplot(data = weight_change, mapping = aes(x = time, y = weight)) +
  geom_point() +
  geom_line(group = 1) +
  coord_cartesian(ylim = c(50, 65))


library(rjstat)
library(ggplot2)
library(dplyr)

(fromJSONstat("thldata.json")[[1]] %>% filter(!is.na(value))
    %>% transmute(date=as.Date(dateweek2020010120201231),
                  dn=as.integer(value))
    %>% arrange(date)
    %>% mutate(n=cumsum(dn),
               days=as.double(date - date[1], units="days"))) -> thl.all

#d.new <- "2020-03-12"
d.new <- "2020-03-28"
thl.new <-  filter(thl.all, date >= d.new)
thl.lm <- lm(log10(n) ~ days, thl.new)
thl.lm10 <- 10^(thl.lm$coefficients)
thl.lm2 <- lm(n ~ days, thl.new)

pdf("thl.pdf", title="THL")
print(qplot(days, n, data=thl.all)
      + scale_y_log10() + annotation_logticks(sides="l")
      + geom_abline(slope=log10(1.1), intercept=0)
      + geom_abline(slope=log10(1.15), intercept=0, col="blue")
      + geom_abline(slope=log10(1.3), intercept=0, col="red")
      + geom_vline(xintercept=difftime(d.new, thl.all$date[1], units="d"),
                   linetype="dotted")
      + ggtitle("Lähde: THL",
                subtitle=paste("Kasvusuorat 10, 15 ja 30 % / d.  Alkaa ",
                               thl.all$date[1], ", raja ",
                               d.new, ", uusin ", thl.all$date[nrow(thl.all)],
                               sep="")))
print(qplot(days, n, data=thl.new)
      + scale_y_log10() + annotation_logticks(sides="l")
      + geom_abline(slope=thl.lm$coefficients[2],
                    intercept=thl.lm$coefficients[1])
      + ggtitle(paste("Kasvu", 100 * (thl.lm10["days"] - 1),
                      "% / d alkaen", d.new)))
print(qplot(date, n, data=thl.new)
      + geom_smooth(method="lm")
      + ggtitle(paste("Kasvu", thl.lm2$coefficients["days"], "/ d")))
dev.off()

summary(thl.lm)
summary(thl.lm2)


library(caret)
library(mlbench)

data(BreastCancer)
summary(BreastCancer) #Summary of Dataset

df <- BreastCancer
# convert input values to numeric
for(i in 2:10) {
  df[,i] <- as.numeric(as.character(df[,i]))
}

# split the data into train and test and perform preprocessing
trainIndex <- createDataPartition(df$Class, p = .8,
                                  list = FALSE,
                                  times = 1)
df_train <- df[ trainIndex,]
df_test  <- df[-trainIndex,]
preProcValues <- preProcess(df_train, method = c("center", "scale", "medianImpute"))
df_train_transformed <- predict(preProcValues, df_train)

# train a model on df_train
fitControl <- trainControl(## 10-fold CV
  method = "repeatedcv",
  number = 10,
  ## repeated ten times
  repeats = 10,
  ## Estimate class probabilities
  classProbs = TRUE,
  ## Evaluate performance using
  ## the following function
  summaryFunction = twoClassSummary)

set.seed(825)
gbmFit <- train(Class ~ ., data = df_train_transformed[,2:11],
                method = "gbm",
                trControl = fitControl,
                ## This last option is actually one
                ## for gbm() that passes through
                verbose = FALSE,
                metric = "ROC")
gbmFit

saveRDS(preProcValues, file = './preProcessor.rds')
saveRDS(gbmFit, file = './gbm_model.rds')
saveRDS(df_test[,1:10], file = './breast_cancer_test_data.rds')


# http://rpubs.com/sinhrks/plot_pca
library(readr)
iris <- read_csv("~/Desenvolvimento/posgraduacao/iris.data",
                 col_names = TRUE)
library(ggfortify)
df <- iris[c(1, 2, 3, 4)]
autoplot(prcomp(df))
autoplot(prcomp(df), data = iris, colour = 'class')
autoplot(prcomp(df), data = iris, colour = 'class', shape = FALSE, label.size = 3)
df2 <- iris[c(1,2)]
autoplot(prcomp(df2), data = iris, colour = 'class')
df3 <- iris[c(3,4)]
autoplot(prcomp(df3), data = iris, colour = 'class')

library(ggplot2)
ggplot(data=iris, aes(x=sepal_length, y=sepal_width, color=class)) +
  geom_point() +
  guides(fill=TRUE)+
  ggtitle("Gráficos de conexões")


rm(list=ls())

library('radolc')

#--- testing ADOLC's hessian
fr <- function(x) {   ## Rosenbrock Banana function
  x1 <- x[1]
  x2 <- x[2]
  y <- 100 * (x2 - x1 * x1)* (x2 - x1 * x1) + (1 - x1)*(1 - x1)
  y }

trace_on(1)
x <- adolc_createList(2,2.0)
badouble_declareIndependent(x)
y <- fr(x)
badouble_declareDependent(y)
trace_off()

xx <- c(1.0,2.0)
yy <- matrix(rep(0.0,4), nrow = 2, ncol = 2)
hessian(1,2,xx,yy);
#hessian(tag,n,x,H)
# tag: integer, tape identification
# n  : integer, number of independents n and m = 1
# x[n]: independent vector x
# double H[n][n]: resulting Hessian matrix \nabla^2F(x)
print(yy)

#Always detach the package
detach(package:radolc, unload=TRUE)


#' Loads the necessary libraries, which are: huge, MASS, thav.glasso, scalreg, igraph, matrixcalc, genscore, scio, stargazer, glasso
#'
#' @export
load_libraries <- function()
{
  libraries <- c("huge", "MASS", "thav.glasso", "scalreg", "igraph", "matrixcalc", "genscore", "scio", "stargazer", "glasso")
  lapply(libraries, library, character.only=TRUE)
}

#' Turns a covariance matrix into the correlation matrix
#'
#' @param theta Covariance matrix
#' @return Correlation matrix
#' @export
normalize_theta <- function(theta)
{
  for(j in 1:dim(theta)[1])
  {
    for(i in 1:dim(theta)[1])
    {
      theta[i,j] <- theta[i,j] / (sqrt(theta[i,i]) * sqrt(theta[j, j]))
    }
  }
  return(theta)
}

#' Computes the adaptive validation graphical lasso
#'
#' @param data Data matrix of size n x d
#' @param C constant C that is used to calibrate the AV regularization parameter
#' @return The selected regularization parameter
#' @return The resulting graphical lasso estimate
#' @examples
#' theta <- generateGraph(d=100)[[1]]
#' Sigma <- solve(theta)
#' data <- scale(mvrnorm(n=200, mu=rep(0, 100), Sigma=Sigma))
#' av <- av_glasso(data)
#' av_tp <- av$TuningParameter
#' av_est <- av$Thetahat
#' @export
av_glasso <- function(data, C=0.7)
{
  empvar <- var(data)

  # Automatically set max(seq_r) <- tp that sets all offdiagonal entries to zero
  max_r <- max( abs(empvar[upper.tri(empvar)]))
  seq_r <- seq(0.05, max_r, length.out = 40)

  r <- max(seq_r)
  estimates <- list()

  #calculate glasso[max(r)] and setup the warm start
  glasso <- glasso(empvar, rho=r, penalize.diagonal=FALSE)
  warm <- list(glasso$wi, glasso$w)
  estimates[[length(seq_r)]] <- normalize_theta(warm[[1]]) #warm[[1]] #

  counter_r <- length(seq_r) #used to fill the list estimates with corresponding estimates
  while(r > min(seq_r))
  {
    #compute glasso[r] using a warm start
    counter_r <- counter_r - 1
    r <- seq_r[counter_r]
    newwarm <- glasso(empvar, rho=r, penalize.diagonal=FALSE, start="warm", wi.init=warm[[1]], w.init=warm[[2]])
    estimates[[counter_r]] <- normalize_theta(newwarm$wi)
    warm <- list(newwarm$wi, newwarm$w)

    counter_r_dash <- length(seq_r)
    r_dash <- seq_r[counter_r_dash]
    while(r_dash > r)
    {
      #if l(...) > Cr_dash + Cr
      if(avtest(estimates, seq_r, counter_r, counter_r_dash, C))
      {
        return(list(TuningParameter=seq_r[counter_r + 1], Thetahat=estimates[[counter_r + 1]]))
      }
      counter_r_dash <- counter_r_dash - 1
      r_dash <- seq_r[counter_r_dash]
    }
  }
  estimates[[1]] <- normalize_theta(glasso(empvar, rho=min(seq_r), penalize.diagonal=FALSE, start="warm", wi.init=warm[[1]], w.init=warm[[2]])$wi)
  return(list(TuningParameter=seq_r[1], Thetahat=estimates[[1]]))
}

#' Computes the test that is used in the AV calibration scheme
#'
#' @param estimates List of the graphical lasso estimators so far
#' @param seq_r List of possible regularization paraeters
#' @param counter_r position of the current r in r_seq (see algorithm)
#' @param counter_r_dash position of the current r_dash in seq_r (see algorithm)
#' @param C constant C that is used for the AV calibration
#' @return TRUE if l(...) > Cr_dash + Cr, else FALSE
#' @export
avtest <- function(estimates, seq_r, counter_r, counter_r_dash, C)
{
  infloss(estimates[[counter_r]], estimates[[counter_r_dash]]) > C * (seq_r[counter_r] + seq_r[counter_r_dash])
}

#' Thresholds the AV estimator
#'
#' @param av List AV containing the regularization parameter and the estimator, which is obtained by applying the av_glasso function
#' @param C Constant C that was used to calibrate the AV
#' @param lambda Threshold factor lambda: We threshold the AV solution by lambda*C*av$TuningParameter
#' @return The thresholded AV estimator
#' @export
threshold <- function( av, C=0.7, lambda=1)
{
  return( apply( av$Thetahat, c(1,2), function(x) if( abs(x) <= lambda*C*av$TuningParameter){ return(0)} else{ return(x)}))
}

#' Computes the thAV estimator
#'
#' @param data Data matrix of size n x d
#' @param C constant C that is used to calibrate the AV regularization parameter
#' @param lambda Threshold factor lambda: We threshold the AV solution by lambda*C*av$TuningParameter
#' @param mute If FALSE, the method prints the selected AV regularization parameter. The default value is TRUE.
#' @return The thresholded AV estimator
#' @examples
#' theta <- generateGraph(d=100)[[1]]
#' Sigma <- solve(theta)
#' data <- scale(mvrnorm(n=200, mu=rep(0, 100), Sigma=Sigma))
#' thav <- thAV.estimator(data)
#' @export
thAV.estimator <- function( data, C=0.7, lambda=1, mute=TRUE)
{
  av <- av_glasso(data, C)

  if(!mute)
  {
    print(paste0("Selected Regularization Parameter: ", round(av$TuningParameter,2)))
  }
  return( threshold(av, C, lambda))
}

#' Computes the rSME via eBIC
#'
#' @param data Data matrix of size n x d
#' @param gamma Parameter that is used in the eBIC criterion. Usually gamma=0.5 or gamma=1. The default value is set to 1.
#' @return rSME estimator that is tuned via eBIC
#' @export
score_ebic <- function(data, gamma=1)
{
  d <- dim(data)[2]
  domain <- make_domain("R", p=d)
  elts <- get_elts(NULL, data, "gaussian", domain)
  max_r <- lambda_max(elts, "symmetric")
  seq_r <- seq(0.05, max_r, length.out = 40)
  best_eBIC <- 10^5
  for(j in 1:length(seq_r))
  {
    result <- get_results(elts, "symmetric", seq_r[j])
    if(eBIC(result, elts, gammas=gamma)[1] < best_eBIC)
    {
      ebic_est <- result$K
      best_eBIC <- eBIC(result, elts, gammas=gamma)[1]
    }
  }
  return(ebic_est)
}

#' Computes the adaptive validation regularized score matching estimator rSME (AV)
#'
#' @param data Data matrix of size n x d
#' @param C constant C that is used to calibrate the AV regularization parameter
#' @return The selected regularization parameter
#' @return The resulting AV regularized score matching estimator rSME (AV)
#' @export
av_rsme <- function(data, C=2)
{
  empvar <- var(data)
  seq_r <- seq(5e-4, 0.3, length.out = 40)
  #initialization
  r <- max(seq_r)

  domain <- make_domain("R", p=dim(empvar)[1])
  estimates <- estimate(data, "gaussian", domain, scale="sd", return_raw=TRUE, lambda1s=seq_r,
                        verbose=FALSE, verbosetext=FALSE)$raw_estimate
  estimates <- rev(estimates) # genscore implementation returns a list of estimates
                              # where the first entry corresponds to the largest TP estimate
  # normalize each theta
  for(j in 1:40)
  {
    estimates[[j]] <- normalize_theta(estimates[[j]])
  }
  counter_r <- length(seq_r) #used to fill the list estimates with corresponding estimates
  while(r != min(seq_r))
  {
    counter_r <- counter_r - 1
    r <- seq_r[counter_r]

    counter_r_dash <- length(seq_r)
    r_dash <- seq_r[counter_r_dash]
    while(r_dash > r)
    {
      #if l(...) > Cr_dash + Cr
      if(avtest(estimates, seq_r, counter_r, counter_r_dash, C))
      {
        return(list(TuningParameter=seq_r[counter_r + 1], Thetahat=estimates[[counter_r + 1]]))
      }
      counter_r_dash <- counter_r_dash - 1
      r_dash <- seq_r[counter_r_dash]
    }
  }
  return(list(TuningParameter=seq_r[1], Thetahat=estimates[[1]]))
}

#' Computes the trace of a matrix
#'
#' @param matrix Matrix
#' @return Trace of matrix
#' @export
tr <- function(matrix)
{
  return(sum(diag(matrix)))
}

#' Computation of the Bregman loss as defined in "Weidong Liu, Xi Luo, Fast and adaptive sparse precision matrix estimation in high dimensions, Journal of Multivariate Analysis, Volume 135, 2015, Pages 153-162"
#'
#' @param sigma Covariance matrix Sigma
#' @param theta Precision matrix Theta
#' @return Bregman loss
bregman_loss <- function(sigma, theta)
{
  return(tr(sigma %*% theta) - log(det(theta)))
}

#' Computation of the Sparse Columnwise Inverse Operator (SCIO) estimator tuned via the Bregman loss: We pick the regularization parameter that minimizes the Bregman loss.
#'
#' @param data Data matrix of size n x d
#' @return SCIO estimator
#' @export
scio_bregman <- function(data)
{
  empvar <- var(data)
  seq_r <- seq(0.05, max(abs(empvar[upper.tri(empvar)])), length.out = 40)

  bregman <- rep(0, length(seq_r))
  for(j in 1:length(seq_r))
  {
    bregman[j] <- bregman_loss(empvar, scio(empvar, lambda=seq_r[j])$w)
  }
  best_r <- seq_r[which.min(bregman)]
  return(scio(empvar, lambda=best_r)$w)
}

#' Computation of the adaptive validation SCIO
#'
#' @param data Data matrix of size n x d
#' @param C constant C that is used to calibrate the AV regularization parameter
#' @return The selected regularization parameter
#' @return The resulting AV-SCIO estimate
#' @export
av_scio <- function(data, C=0.7)
{
  empvar <- var(data)
  max_r <- max(abs(empvar[upper.tri(empvar)]))
  seq_r <- seq(0.05, max_r, length.out = 40)
  #initialization
  r <- max(seq_r)
  estimates <- list()

  estimates[[length(seq_r)]] <- normalize_theta(scio(empvar, lambda=r)$w)

  counter_r <- length(seq_r) #used to fill the list estimates with corresponding estimates
  while(r != min(seq_r))
  {
    counter_r <- counter_r - 1
    r <- seq_r[counter_r]
    estimates[[counter_r]] <- normalize_theta(scio(empvar, lambda=r)$w)

    counter_r_dash <- length(seq_r)
    r_dash <- seq_r[counter_r_dash]
    while(r_dash > r)
    {
      #if l(...) > Cr_dash + Cr
      if(avtest(estimates, seq_r, counter_r, counter_r_dash, C))
      {
        return(list(TuningParameter=seq_r[counter_r + 1], Thetahat=estimates[[counter_r + 1]]))
      }
      counter_r_dash <- counter_r_dash - 1
      r_dash <- seq_r[counter_r_dash]
    }
  }
  return(list(TuningParameter=seq_r[1], Thetahat=estimates[[1]]))
}

#' Computes the reweighted l1 regularization to compute the graphical lasso with power law regularization (Liu & Ihler(2011)).
#'
#' @param est Estimation of Theta from the previous iteration
#' @param alpha Regularization parameter
#' @return The reweighted penalties as a dxd matrix.
#' @export
penalty_matrix <- function(est, alpha)
{
  d <- dim(est)[1]
  eps <- diag(est)
  lambda <- matrix(rep(0, d*d), ncol=d)
  for(j in 1:(d-1))
  {
    for(i in j:d)
    {
      if(i==j)
      {
        lambda[i, i] <- 0
      }
      else
      {
        lambda[i, j] <- lambda[j, i] <- alpha * ( 1/(sum(abs(est[i, ])) + eps[i]) + 1/(sum(abs(est[j, ])) + eps[j]))
      }
    }
  }
  return(lambda)
}

#' Computes the graphical lasso with power law regularization sf_glasso (Liu & Ihler(2011)).
#'
#' @param data Data matrix of size n x d
#' @param alpha Regularization parameter
#' @return Graphical lasso with power law regularization
#' @export
sf_glasso <- function(data, alpha)
{
  d <- dim(data)[2]
  est <- diag(d)
  empvar <- var(data)
  for(j in 1:3)
  {
    rho <- penalty_matrix(est, alpha)
    est <- glasso(empvar, rho=rho)$wi
  }
  return(est)
}

#' Computes the graphical lasso with power law regularization and regularization parameter tuned via adaptive validation sf_glasso (AV).
#'
#' @param data Data matrix of size n x d
#' @param C Constant C used to tune the thAV. Default value is 1.5
#' @return Graphical lasso with power law regularization and regularization parameter tuned via adaptive validation
#' @export
av_sf_glasso <- function(data, C=1.5)
{
  empvar <- var(data)
  max_r <- 0.8#max(abs(empvar[upper.tri(empvar)]))
  seq_r <- seq(0.01, max_r, length.out = 40)
  #initialization
  r <- max(seq_r)
  estimates <- list()

  estimates[[length(seq_r)]] <- normalize_theta(sf_glasso(data, r))

  counter_r <- length(seq_r) #used to fill the list estimates with corresponding estimates
  while(r != min(seq_r))
  {
    counter_r <- counter_r - 1
    r <- seq_r[counter_r]
    estimates[[counter_r]] <- normalize_theta(sf_glasso(data, r))

    counter_r_dash <- length(seq_r)
    r_dash <- seq_r[counter_r_dash]
    while(r_dash > r)
    {
      #if l(...) > Cr_dash + Cr
      if(avtest(estimates, seq_r, counter_r, counter_r_dash, C))
      {
        return(list(TuningParameter=seq_r[counter_r + 1], Thetahat=estimates[[counter_r + 1]]))
      }
      counter_r_dash <- counter_r_dash - 1
      r_dash <- seq_r[counter_r_dash]
    }
  }
  return(list(TuningParameter=seq_r[1], Thetahat=estimates[[1]]))
}


suppressMessages(library(cop))
comm.set.seed(1234, diff=TRUE)

getR = function(x) qr.R(qr(x, LAPACK=TRUE))

m = 100
n = 5
x = getR(matrix(rnorm(m*n), m, n))

R_ar = qr_reduce(x)

op = function(a, b) getR(rbind(a, b))
R_ar_cop = cop_allreduce(x, op, commutative=TRUE)

if (comm.rank() == 0){
  test = all.equal(abs(R_ar), abs(R_ar_cop))
  print(test)
}

x_g = gather(x)
if (comm.rank() == 0){
  R_i = x_g[[1]]
  for (i in seq.int(comm.size()-1)+1){
    R_i = op(R_i, x_g[[i]])
  }
  test = all.equal(abs(R_ar), abs(R_i))
  print(test)

  x_all = do.call(rbind, x_g)
  R = getR(x_all)
  test = all.equal(abs(R_ar), abs(R))
  print(test)
}

finalize()


# Generates artificial threads with models of Gomez 2010 and Gomez 2013
# author: Alberto Lumbreras
################################

library(igraph)
library(dplyr)
source('R/plotting.r')

gen.thread.Gomez2011 <- function(n=100, alpha.root=1, alpha.c = 1, beta.root = 1){
  # Generate synthetic thread according to Gomez 2011
  # Args:
  #    n: number of posts
  #    alpha:  preferential attachement exponent
  #    beta: root bias
  g <- graph.empty(n=1)

  # First post has no choice
  g <- add_vertices(g, 1)
  g <- add_edges(g, c(2,1))

  for (i in 3:n){
    alphas <- c(alpha.root, rep(alpha.c, i-2))
    betas <- c(beta.root, rep(1, i-2))
    popularities <- 1 + degree(g, mode="in")

    # Probability of choosing every node (only one is chosen)
    probs <- (betas*popularities)^alphas
    probs <- probs/sum(probs)
    j <- sample(1:length(probs), 1, prob=probs)

    # Add new vertex attached to the chosen node
    g <- add_vertices(g, 1)
    g <- add_edges(g, c(i,j))
  }
  g
}

gen.thread.Gomez2013 <- function(n=100, alpha=1, beta = 1, tau=0.75){
  # Generate synthetic thread according to Gomez 2011
  # Args:
  #    n: number of posts
  #    alpha:  preferential attachement exponent
  #    beta: root bias
  g <- graph.empty(n=1)

  # First post has no choice
  g <- add_vertices(g, 1)
  g <- add_edges(g, c(2,1))

  for (i in 3:n){
    betas <- c(beta, rep(0, i-2))
    lags <- (i-1):1
    popularities <- 1 + degree(g, mode="in") # even root starts with degree 1

    # Probability of choosing every node (only one is chosen)
    probs <- alpha*popularities + betas + tau^lags
    probs <- probs/sum(probs)
    j <- sample(1:length(probs), 1, prob=probs)

    # Add new vertex attached to the chosen node
    g <- add_vertices(g, 1)
    g <- add_edges(g, c(i,j))
  }
  V(g)$user <- 1 # for compatibility with Lumbreras
  g
}

gen.thread.Lumbreras2016 <- function(n=100, z=c(1,2,3), alphas = c(1,2,3), betas = c(1,2,3), taus = c(0.25, 0.5, 0.75)){
  # Generate threads like in Gomez 2013 but from a mixture model where users
  # in one component have different parameters (alpha, beta, tau)  than users in the
  # other component
  # then for each post chose a random user and then pick the parameters of its group
  # Args:
  #    n: number of posts
  #    alpha:  preferential attachement exponent
  #    beta: root bias
  nusers <- length(z)
  g <- graph.empty(n=1)

  # First post has no choice
  g <- add_vertices(g, 1)
  g <- add_edges(g, c(2,1))

  # the user of the two first posts is irrelevant for us
  V(g)$user <- 1

  for (i in 3:n){
    # choose random user
    u <- sample(nusers, 1)
    cluster <- z[u]
    alpha <- alphas[cluster]
    beta <- betas[cluster]
    tau <- taus[cluster]

    bs <- c(beta, rep(0, i-2))
    lags <- (i-1):1
    popularities <- 1 + degree(g, mode="in") # even root starts with degree 1

    # Probability of choosing every node (only one is chosen)
    probs <- alpha*popularities + bs + tau^lags
    probs <- probs/sum(probs)

    j <- sample(1:length(probs), 1, prob=probs)

    # Add new vertex attached to the chosen node
    g <- add_vertices(g, 1, attr=list('user'= u))
    g <- add_edges(g, c(i,j))
  }
  g
}

tree.to.data <- function(g, thread=0){
  # Creates a dataframe with a row per post
  # and columns "degree of parent", "is_parent_root", "lag to parent", and "t"
  # With the model parameters, the three first columns are used to compute the numerator the likelihood
  # and 't' to compute the denominator of the likelihood
  parents <- get.edgelist(g)[,2] # parents vector without the first two posts
  authors <- V(g)$user[-1] # remove first post
  popularities <- c(1,sapply(2:length(parents), function(t) 1 + sum(parents[1:(t-1)]==parents[t])))
  #popularities[parents==1] <- popularities[parents==1]-1 # the root node has no parent
  posts <- 2:(length(parents)+1)
  data <- data.frame(thread = rep(thread, length(posts)),
                     user = authors,
                     post = posts,
                     t = 1:(length(parents)),
                     parent = parents,
                     popularity = popularities)

  data <- mutate(data, lag=t-parent+1)
  data
}

# Generate a synthetic dataset of trees
#######################################
if(FALSE){
  n <- 100

  alpha.root <- 0.734
  alpha.c <- 0.683
  beta.root <- 1.302
  trees <- replicate(n,  gen.thread.Gomez2011(n=20, alpha.root=alpha.root, alpha.c=alpha.c, beta.root=beta.root), simplify = FALSE)

  alpha <- 1
  beta <- 0.68
  tau <- 0.75
  trees <- replicate(100, gen.thread.Gomez2013(n=100, alpha=alpha, beta=beta, tau=tau), simplify = FALSE)

  # Synthetic trees for Lumbreras 2016
  set.seed(1)
  alphas <- c(1,2,3)
  betas <- c(1,2,3)
  taus <- c(0.25, 0.5, 0.75)
  z <- c(1,2,3,1,2,3,1,2,3,1,2,3)
  trees <- replicate(1000,  gen.thread.Lumbreras2016(n=100, z=z, alphas=alphas, betas=betas, taus=taus), simplify = FALSE)

  # Very simple synthetic trees for Lumbreras 2016
  set.seed(1)
  alphas <- c(0.1,0.5)
  betas <- c(0.1,0.5)
  taus <- c(0.1, 0.5)
  z <- c(1,2)

  set.seed(1)
  alphas <- c(0.1, 0.5, 1)
  betas <- c(1, 5, 10)
  taus <- c(0.1, 0.5, 0.99)
  z <- do.call(c, lapply(1:length(alphas), function(x) rep(x,10000)))

  # the parallel way
  library(parallel)
  cl <- makeCluster(detectCores()-2)
  clusterEvalQ(cl, {library(igraph); source('thread_generator.r')})
  clusterExport(cl, c("alphas", "betas", "taus", "z"))
  trees <- parLapply(cl, 1:20000, function(i) gen.thread.Lumbreras2016(n=25, z=z, alphas=alphas, betas=betas, taus=taus) )
  stopCluster(cl)

  save(trees, file='trees.Rda')

  # Create dataframe from a set of trees
  ############################################################
  # Prepare all the information needed into a nice dataframe
  library(parallel)
  ncores <- detectCores() - 2
  cl<-makeCluster(ncores, outfile="", port=11439)
  clusterEvalQ(cl, {library(igraph); library(dplyr)})
  data.parlapply <- parLapply(cl, trees, tree.to.data)
  stopCluster(cl)

  # join results adding thread id
  for (i in 1:length(data.parlapply)){
    data.parlapply[[i]]$thread <- i
  }
  data.parlapply <- rbindlist(data.parlapply)
  df.trees <- data.frame(thread = data.parlapply$thread,
                         user = data.parlapply$user,
                         post = data.parlapply$post,
                         t = data.parlapply$t,
                         parent = data.parlapply$parent,
                         popularity = data.parlapply$popularity,
                         lag = data.parlapply$lag)

  save(df.trees, file='df.trees.Rda')

}

# Generate and plot some synthetic tree
########################################
TEST <- FALSE
if(TEST){
  # Values reported in Gomze 2010 (Table 2)
  # Slashdot:
  alpha.root <- 0.734
  alpha.c <- 0.683
  beta.root <- 1.302

  # Barrapunto
  alpha.root <- 0.665
  alpha.c <- -0.116
  beta.root <- 0.781

  # Meneame
  alpha.root <- 0.856
  alpha.c <- 0.196
  beta.root <- 1.588

  # Wikipedia
  alpha.root <- 0.884
  alpha.c <- -1.684
  beta.root <- 0.794

  trees <- replicate(4,  gen.thread.Gomez2011(n=100, alpha.root=alpha.root, alpha.c=alpha.c, beta.root=beta.root), simplify = FALSE)

  alpha <- 1
  beta <- 0.68
  tau <- 0.75
  trees <- replicate(4,  gen.thread.Gomez2013(n=100, alpha=alpha, beta=beta, tau=tau), simplify = FALSE)

  trees <- replicate(4,  gen.thread.Lumbreras2016(n=100), simplify = FALSE)

  par(mfrow=c(2,2))
  for (i in 1:length(trees)){
    g <- trees[[i]]
    root = which(degree(g, mode='out')==0)
    V(g)$color <- 'black'
    V(g)$color[root] <- 'red'
    V(g)$size <- 1
    V(g)$size[root] <- 3
    g.un <- as.undirected(g)
    la = layout_with_fr(g.un)
    plot(g.un, layout = la, vertex.label = NA, edge.arrow.size=0.6)
  }
}


# A quick demo on using R code directly:
# >> stats_class :my_obj
# => MyObj
# >> MyObj.call 49,6
# => 13983816.0
my_obj <- function(n,k) choose(n, k)


library(readr)
library(data.table)
library(xgboost)
variance <- function(x) var(x)*(length(x)-1)/length(x)
stddev <- function(x) sqrt(variance(score))
mlogloss <- function(actual,pred){
	actual <- as.integer(as.factor(actual))
	probs <- rep(0,length(actual))
	for(i in 1:length(actual)) { probs[i] <- pred[i,actual[i]]}
	probs <- as.numeric(probs)
	probs[which(probs>1-1e-15)] <- 1-1e-15
	probs[which(probs<1e-15)] <- 1e-15
	return(-(1/length(actual))*sum(log(probs)))
}

path <- "../Data/"
train <- fread(paste0(path,"train_tfidf.csv"))
train <- as.data.frame(train)
train$id <- NULL
tSNE <- fread(paste0(path,"tfidf_train_tsne.csv"))
tSNE <- as.data.frame(tSNE)
train <- cbind(train,tSNE)

y <- train$target
y <- gsub('Class_','',y)
y <- as.integer(y)-1 #xgboost take features in [0,numOfClass)
train$target <- NULL
train$target <- y

for(i in 1:(ncol(train)-1)) { train[,i] <- as.numeric(train[,i])}

param <- list("objective" = "multi:softprob",
              "eval_metric" = "mlogloss",
              "num_class" = 9,
			  "max_depth" = 12,
			  "eta" = 0.01, # 0.002
			  "min_child_weight" = 10, # default 1; 4 ,gbm: 10
			  "subsample" =  0.9, # default 1, 0.9
			  "colsample_bytree" = 0.8 # default 1 0.8
			  )
cv.nround <- 10000
gc(TRUE)
set.seed(131)
bst <- xgb.cv(param=param, data=data.matrix(train[,c(-ncol(train))]), label=train$target,
nrounds=cv.nround, nfold=5, early.stop.round=10)
print(tmp <- min(bst$test.mlogloss.mean))
(minNum <- which.min(bst$test.mlogloss.mean))

# eta 0.01: 2327, 0.464444
# eta 0.025: 979, 0.465486
# eta 0.1: 225, 0.471174

set.seed(131)
bst <- xgboost(param=param, data=data.matrix(train[,c(-ncol(train))]),
label=train$target, nrounds=minNum)

test  <- fread(paste0(path,"test_tfidf.csv"))
test <- as.data.frame(test)
tSNE <- fread(paste0(path,"tfidf_test_tsne.csv"))
tSNE <- as.data.frame(tSNE)
test <- cbind(test,tSNE)

id <- test$id
test$id <- NULL

for(i in 1:ncol(test)) { test[,i] <- as.numeric(test[,i])}
pred <- predict(bst,data.matrix(test))
pred <- matrix(pred,9,length(pred)/9)
pred <- t(pred)
submission <- data.frame(id,pred)
names(submission) <- c('id', paste0('Class_',1:9))
write_csv(submission,paste0(path,"xgb_tfidf.csv"))

# retrain
rm(pred)
library(cvTools)
NAME <- paste0('Class_',1:9)
tmp <- matrix(rep(NA,9),nrow(train),9)
tmp <- as.data.frame(tmp)
colnames(tmp) <- NAME
submission <- cbind(id=1:nrow(train),tmp)
nfold <- 5
cv.folds <- cvFolds(nrow(train),nfold)
cvs <- cv.folds$which
id <- 1:nrow(train)
score <- rep(0,nfold)

for(NUMCV in 1:nfold){
test.x <- train[which(cvs==NUMCV),-ncol(train)]
test.y <- train[which(cvs==NUMCV),ncol(train)]
train.x <- train[which(cvs!=NUMCV),-ncol(train)]
train.y <- train[which(cvs!=NUMCV),ncol(train)]

set.seed(131)
bst <- xgboost(param=param, data=data.matrix(train.x), label=train.y, nrounds=minNum)
pred <- predict(bst,data.matrix(test.x))
pred <- matrix(pred,9,length(pred)/9)
submission[which(cvs==NUMCV),2:10] <- t(pred)
print(score[NUMCV] <- mlogloss(test.y,as.data.frame(t(pred))))
}
sprintf("mean: %s, stddev: %s", mean(score), stddev(score))

for(i in 1:ncol(submission)) { submission[,i] <- as.character(submission[,i])}
write_csv(submission,paste0(path,"xgb_tfidf_retrain.csv"))

# eta 0.01, nfold 5: "mean: 0.463530922400871, stddev: 0.00154293768677079"
# eta 0.025, nfold 10: "mean: 0.45832260734072, stddev: 0.00886914421281806"
# eta 0.025, nfold 5: "mean: 0.464373214332066, stddev: 0.00147590469750059"
# nfold 5: "mean: 0.470238490824427, stddev: 0.00150969970537236"

imp<-xgb.importance(names(train[,-ncol(train)]),model=bst)
print(imp)
xgb.plot.importance(imp)

#xgb.plot.tree(feature_names=names(train[,-ncol(train)]),model=bst, n_first_tree=2)


# Reading in data
ds = read.csv('Mall_Customers.csv')
X = ds[4:5]

# Finding k
wcss = vector()
for (i in 1:10)
    wcss[i] =sum(kmeans(X, i)$withinss)

plot(1:10, wcss, type = 'b', main=paste("Elbow method"), xlab = 'number clusters' )

# Clustering
kmeans = kmeans(X, 5)
y_kmeans = kmeans$cluster

# Visualising the clusters
plot(X, col = y_kmeans)
points(kmeans$center,col=1:2,pch=8,cex=1)


### The idea is to get score residuals from the score vector ###

# a function to get score residiuals from the fitted model
# (the code are taking directly from `orm.fit`)
func_score <- function(fit){

  # coefficients
  coef <- fit$coefficients

  # convert y to ordered category
  y <- match(fit$y, fit$yunique)
  # x
  x <- fit$x

  # some useful numbers
  kint <- length(fit$yunique) - 1L
  nx <- dim(x)[2L]
  n <- length(y)
  p <- as.integer(kint + nx)

  # store results - matrix
  u <- matrix(0, nrow = n, ncol=p)

  # functions
  f   <- fit$trans$cumprob
  fp  <- fit$trans$deriv

  xb <- fit$x %*% coef[-(1L : kint)]
  ints <- c(1e100, coef[1:kint], -1e100)
  xby <- xb + ints[y]; xby1 <- xb + ints[y + 1L]
  fa <- f(xby)
  fb <- f(xby1)
  P <- fa - fb
  fpa  <- fp(xby,   fa)
  fpb  <- fp(xby1,  fb)

  # score for alpha
  for(m in 1:kint){
    for(j in 1:n){
      u[j, m] <-  (fpa[j]*(y[j]-1==m) - fpb[j]*(y[j]==m)) / P[j]
    }
  }

  # score for beta
  for(m in (kint+1):p){
    for(j in 1:n){
      u[j, m] <- (fpa[j] - fpb[j]) * x[j,m-kint] / P[j]
    }
  }

  return(u)

}

func_robcov <- function(fit, cluster){
  var   <- vcov(fit, intercepts='all')
  vname <- dimnames(var)[[1]]

  # X <- as.matrix(residuals(fit, type="score"))
  X <- func_score(fit) # get score residuals

  n <- nrow(X)

  cluster <- as.factor(cluster)

  p <- ncol(var)
  j <- is.na(X %*% rep(1, ncol(X)))
  if(any(j)) {
    X       <- X[! j,, drop=FALSE]
    cluster <- cluster[! j, drop=TRUE]
    n       <- length(cluster)
  }

  j <- order(cluster)
  X <- X[j, , drop=FALSE]
  clus.size  <- table(cluster)
  # if(length(clusterInfo)) clusterInfo$n <- length(clus.size)
  clus.start <- c(1, 1 + cumsum(clus.size))
  nc <- length(levels(cluster))
  clus.start <- clus.start[- (nc + 1)]
  storage.mode(clus.start) <- "integer"

  # dyn.load("robcovf.so")
  W <- matrix(.Fortran("robcovf", n, p, nc, clus.start, clus.size, X,
                       double(p), double(p * p), w=double(p * p))$w, nrow=p)

  ##The following has a small bug but comes close to reproducing what robcovf does
  # W <- tapply(X,list(cluster[row(X)],col(X)),sum)
  # W <- t(W) %*% W

  #The following logic will also do it, also at great cost in CPU time
  # W <- matrix(0, p, p)
  # for(j in levels(cluster)){
  #   s <- cluster==j
  #   if(sum(s)==1){
  #     sx <- X[s,,drop=F]
  #   }else {sx <- apply(X[s,,drop=F], 2, sum); dim(sx) <- c(1,p)}
  #   W <- W + t(sx) %*% sx
  # }

  adjvar <- var %*% W %*% var

  return(adjvar)
}

### test ###
if(FALSE) {
# generate longitudinal data
library(mvtnorm)
library(rms)
data_gen <- function(n=100, m=10, b=beta, a0=0.7){
  # correlation matrix - exchangeable structure
  G <- matrix(rep(a0, m*m), nrow=m)
  diag(G) <- 1

  stdevs <- rep(1,m)
  e <- rmvnorm(n, mean = rep(0,m),
               sigma = G * matrix(outer(stdevs, stdevs), nrow=m, byrow=TRUE))

  # x1: gender (0: female, 1: male)
  x1 <- rep(c(rep(0,round(n/2)), rep(1,n-round(n/2))), m)

  # x2: time
  x2 <- rep(c(1:m), each=n)

  y <- b[1] + b[2] * x1 + b[3] * x2 + e

  dat <- data.frame(y=c(y),
                    x1=c(x1),
                    x2=c(x2),
                    id=rep(1:n, m))

  return(dat)
}

# data
dat <- data_gen(n=50, m=10, b=beta, a0=0.7)
# model
mod_orm <- orm(y ~ x1 + x2,
               data = dat,
               x=T, y=T)
# robcov
rob.cov <- robcov(fit = mod_orm,
                  cluster = dat$id)
rob.cov
}


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

library("rpart")

trainset <- read.csv("../data/golf.csv",header=TRUE)
testset <- read.csv("../data/golf-testset.csv",header=TRUE)

#Perform Decision Trees fit
mod <- rpart(Play ~.,                  #model design
             trainset,                 #training set
             method="class",           #Categorical Tree
             parms=list(split="gini"), #Metric "Gini Impurity"
             control=rpart.control(
               minsplit=4,             #minimal size for split
               minbucket=2,            #minimal leaf size
               cp=0.1,                 #minimal gain
               maxdepth=20))           #maximal depth

#Plot model
plot(mod,uniform=TRUE,branch=0.5,margin=0.05,main="Classification Tree")
text(mod,use.n=TRUE,all=TRUE,cex=0.8,fancy=TRUE,pretty=0)

#Test model
res <- predict(mod,                    #model
               testset,                #testing set
               type="class")           #returns classification/probabilities

#Confusion Matrix
conf_mat <- table(testset[,"Play"],res)
conf_mat

#Error rate
err_rt <- 100*(sum(conf_mat) - sum(diag(conf_mat)))/sum(conf_mat)
err_rt


# Source: https://www.datacamp.com/community/tutorials/detect-anomalies-anomalize-r
# Author: Nishant Singh - https://www.datacamp.com/profile/NishantKumarSingh
# See https://cran.r-project.org/web/packages/purrr/index.html

library(tidyverse)
library(anomalize)

# Using data package provided in the anomalize package and taking single time series of package purrr
purrr_package = tidyverse_cran_downloads%>%
  filter(package == "purrr")%>%
  ungroup()

# Decompose
purrr_anomaly  = purrr_package %>%
  time_decompose(count)

purrr_anomaly%>% glimpse()

# Lower and upper bound transformation
purrr_anomaly = purrr_anomaly%>%
  time_recompose()

purrr_anomaly%>% glimpse()

# Plot anomalies
purrr_anomaly%>%
  plot_anomaly_decomposition()+
  ggtitle("Plotting Anomalies")

# Adjusting parameters of decomposition
purrr_package %>%
  time_decompose(count, frequency = "auto", trend = "2 weeks")%>%
  anomalize(remainder)%>%
  plot_anomaly_decomposition()+
  ggtitle("Trend = 2 Weeks / Frequency = auto ")

purrr_package%>%
  time_decompose(count)%>%
  anomalize(remainder, alpha = 0.025)%>%
  time_recompose()%>%
  plot_anomalies(time_recompose = T)+
  ggtitle("alpha = 0.025")

# Set max_anoms
purrr_package%>%
  time_decompose(count)%>%
  anomalize(remainder, alpha = 0.2, max_anoms = 0.2)%>%
  time_recompose()%>%
  plot_anomalies(time_recompose = T)+
  ggtitle("20% anomaly Allowed")

purrr_package%>%
  time_decompose(count)%>%
  anomalize(remainder, alpha = 0.2, max_anoms = 0.05)%>%
  time_recompose()%>%
  plot_anomalies(time_recompose = T)+
  ggtitle("5% anomaly Allowed")


 DPTSV Example Program Results

 Solution
      2.5000     2.0000     1.0000    -1.0000     3.0000

 Diagonal elements of the diagonal matrix D
      4.0000     9.0000    25.0000    16.0000     1.0000

 Subdiagonal elements of the Cholesky factor L
     -0.5000    -0.6667     0.6000     0.5000


closestPair<-function(x,y)
  {
  distancev <- function(pointsv)
    {
    x1 <- pointsv[1]
    y1 <- pointsv[2]
    x2 <- pointsv[3]
    y2 <- pointsv[4]
    sqrt((x1 - x2)^2 + (y1 - y2)^2)
    }
  pairstocompare <- t(combn(length(x),2))
  pointsv <- cbind(x[pairstocompare[,1]],y[pairstocompare[,1]],x[pairstocompare[,2]],y[pairstocompare[,2]])
  pairstocompare <- cbind(pairstocompare,apply(pointsv,1,distancev))
  minrow <- pairstocompare[pairstocompare[,3] == min(pairstocompare[,3])]
  if (!is.null(nrow(minrow))) {print("More than one point at this distance!"); minrow <- minrow[1,]}
  cat("The closest pair is:\n\tPoint 1: ",x[minrow[1]],", ",y[minrow[1]],
                          "\n\tPoint 2: ",x[minrow[2]],", ",y[minrow[2]],
                          "\n\tDistance: ",minrow[3],"\n",sep="")
  c(distance=minrow[3],x1.x=x[minrow[1]],y1.y=y[minrow[1]],x2.x=x[minrow[2]],y2.y=y[minrow[2]])
  }


###########################################################################
#Correlation
#This will load our input files into variables so we can run the correlation.
###########################################################################

Correlation.loader <- function(
	input.filename,
	output.file="Correlation",
	correlation.by = "",
	correlation.method = ""
)
{
	######################################################
	library(Cairo)
	######################################################

	#To be precise I take it this means the significance probability,
	#that is the chance of getting a value of the correlation as far
	#from zero in absolute value or more so as the one you got...

	cor.pvalue <- function(X,method="pearson", use="complete" )
	{
		dfr = nrow(X) - 2
		R <- cor(X,method=method, use= use)
		above <- row(R) < col(R)
		r2 <- R[above]^2
		Fstat <- r2 * dfr / (1 - r2)
		R[above] <- 1 - pf(Fstat, 1, dfr)
		R
	}

	######################################################
	#Read the correlation data.
	line.data<-read.delim(input.filename,header=T)

	#This is the name of the output file for the correlation.
	correlationResultsFile <- "Correlation.txt"

	if(correlation.by == "subject")
	{
		write.table(format(cor(line.data,method = correlation.method),digits=3),correlationResultsFile,quote=F,sep="\t",row.names=F,col.names=T)
	}

	if(correlation.by == "variable")
	{
		write.table(format(cor.pvalue(line.data,method = correlation.method),digits=5),correlationResultsFile,quote=F,sep="\t",row.names=F,col.names=T)

		#Put (absolute) correlations on the upper panels,
		#with size proportional to the correlations.
		panel.cor <- function(x, y, digits=2, prefix="", cex.cor, ...)
		{
			usr <- par("usr"); on.exit(par(usr))
			par(usr = c(0, 1, 0, 1))
			r <- abs(cor(x, y, method = correlation.method))
			txt <- format(c(r, 0.123456789), digits=digits)[1]
			txt <- paste(prefix, txt, sep="")
			if(missing(cex.cor)) cex.cor <- 0.8/strwidth(txt)
			text(0.5, 0.5, txt, cex = cex.cor * r)
		}

		#Put histograms on the diagonal
		panel.hist <- function(x, ...)
		{
			usr <- par("usr"); on.exit(par(usr))
			par(usr = c(usr[1:2], 0, 1.5) )
			h <- hist(x, plot = FALSE)
			breaks <- h$breaks; nB <- length(breaks)
			y <- h$counts; y <- y/max(y)
			rect(breaks[-nB], 0, breaks[-1], y, col="skyblue", ...)
		}

		#Put a scatter plot with a fitted line on the bottom left.
		panel.lm <- function(x, y, digits=2, prefix="", ...)
		{
			usr <- par("usr"); on.exit(par(usr))
			par(usr = c(0, 1, 0, 1))
			par(new = TRUE)
			plot(y~x,pch=20)
			title(font.main=10,font.sub=9)
			abline(lm(y~x))
		}

		#This is the name of the output image file.
		imageFileName <- paste(output.file,".png",sep="")

		#This initializes our image capture object.
		CairoPNG(file=imageFileName, width=1200, height=600,units = "px")

		#Generate the image.
		pairs(line.data,upper.panel=panel.cor,diag.panel=panel.hist,lower.panel=panel.lm)

		#Turn of the graphics device to save the image.
		dev.off()

	}

	######################################################
}


library(lubridate); library(tidyverse); library(shiny); library(nycflights13); library(ggthemes)

ui <- bootstrapPage( ## Define the UI
  sliderInput(inputId = 'hr', label = 'Scheduled departure hour: ', min = 0, max = 23, value = 12),
  sliderInput(inputId = 'min', label = 'Scheduled departure minute: ', min = 0, max = 59, value = 30),
  plotOutput('plot')
)

server <- function(input, output) { ## Define the server code
    output$plot <- renderPlot({
    plot(x = rep(round(input$hr * 100 +input$min, 1), 3),
         y = c(100/(1+exp(-(0.279603750 - (0.001999519 - 0.0000148) * abs(input$hr * 60 + input$min - (19 * 60 + 35))))),
               100/(1+exp(-(0.279603750 - 0.001999519 * abs(input$hr * 60 + input$min - (19 * 60 + 35))))),
               100/(1+exp(-(0.279603750 - (0.001999519 + 0.0000148) * abs(input$hr * 60 + input$min - (19 * 60 + 35)))))),
         xlim = range(input$hr * 100 +input$min - 15, input$hr * 100 + input$min + 15),
         type = 'b',
         lwd = 3,
         lty = 2,
         width = 0,
         tck = .02,
         xlab = 'Scheduled departure time',
         ylab = 'Percent chance of delay',
         pch = 3,
         main = paste('Plan around a chance of delay of ', round(100/(1+exp(-(0.279603750 - (0.001999519) * abs(input$hr * 60 + input$min - (19 * 60 + 35)))))), '%'))

  })
}

shinyApp(ui = ui, server = server) ## Return a Shiny app object


library('MASS')
x_train_n = data.matrix(x_train)
x_test_n = data.matrix(x_test)
# u [44461 * 41]
u = svd(x_train_n)$u
# p_c = [20 * 41]
prominent_component = u[1:20,]
# invp [41 * 20]
invp = ginv(prominent_component)
# x_train_n = [44461 * 41]
x_train_n_pca = x_train_n %*% invp
x_test_n_pca =  x_test_n %*% invp
y_hat = knn(x_train_n_pca, x_test_n_pca, y_train, use.all = FALSE, k=1)


conv <- function(a, b) {
	p <- length(a)
	q <- length(b)
	n <- p + q - 1
	r <- nextn(n, f=2)
	y <- fft(fft(c(a, rep(0, r-p))) * fft(c(b, rep(0, r-q))), inverse=TRUE)/r
	y[1:n]
}

deconv <- function(a, b) {
	p <- length(a)
	q <- length(b)
	n <- p - q + 1
	r <- nextn(max(p, q), f=2)
	y <- fft(fft(c(a, rep(0, r-p))) / fft(c(b, rep(0, r-q))), inverse=TRUE)/r
	return(y[1:n])
}


#!/usr/bin/env r

library(Rcpp)
library(rbenchmark)

piR <- function(N) {
    x <- runif(N)
    y <- runif(N)
    d <- sqrt(x^2 + y^2)
    return(4 * sum(d < 1.0) / N)
}

sourceCpp("piSugar.cpp")

N <- 1e6

set.seed(42)
resR <- piR(N)

set.seed(42)
resCpp <- piSugar(N)

## important: check results are identical with RNG seeded
stopifnot(identical(resR, resCpp))

res <- benchmark(piR(N), piSugar(N), order="relative")

print(res[,1:4])


#' Bootstrap Methods
#'
#' @param x numeric vector.
#' @param weights numeric vector of weight
#' @param boot how many bootstrap sample is generated?
#' @param alpha significant value to construct confidential interval
#' @param seed seed value
#' @param bca logical. use bias corrected and accelerated (BCa) bootstrap
#'   to construct confidential intervals.
#'
#' @importFrom stats na.omit
#' @importFrom stats sd
#' @importFrom stats quantile
#' @importFrom stats qnorm
#' @importFrom stats pnorm
#' @examples
#' \dontrun{
#' x <- rnorm(100)
#' bootstrap(x, boot = 1000)
#' }
#'
bootstrap <- function(x,
                      weights,
                      boot = 100,
                      alpha = 0.05,
                      seed = 120511,
                      bca = FALSE) {
  # output list
  output <- list()
  # observation information
  x <- na.omit(x)
  n <- length(x)
  output$n <- n
  if (missing(weights)) weights <- rep(1, n)
  output$mu <- mean(x * weights) / mean(weights)

  # bootstrap
  set.seed(seed)
  bootmu <- lapply(seq_len(boot), function(i) {
    pick <- sample(seq_len(n), size = n, replace = TRUE)
    bx <- x[pick]
    bw <- weights[pick]
    mean(bx * bw) / mean(bw)
  })
  bootmu <- unlist(bootmu)
  output$boot$distribution <- bootmu

  # bootstrap standard error
  output$boot$se <- sd(bootmu)

  # bootstrap CI
  output$boot$ci$alpha <- alpha
  if (!bca) {
    # quantile bootstrap
    output$boot$ci$method <- "quantile"
    output$boot$ci$interval <- quantile(
      bootmu, probs = c(alpha / 2, 1 - alpha / 2)
    )
  } else {
    # Bias corrected and accelerated (BCa) bootstrap
    # reference: https://www.erikdrysdale.com/bca_python/
    output$boot$ci$method <- "BCa"

    # bias-correction factor
    z0 <- qnorm(mean(bootmu < output$mu), lower.tail = TRUE)

    # acceleration factor by jackknife
    jack <- lapply(seq_len(n), function(i) mean(x[-i]))
    jack <- unlist(jack)
    jack_mean <- mean(jack)
    a <- sum((jack_mean - jack)^3) / (6 * sum((jack_mean - jack)^2)^(3 / 2))

    # quantile point of normal distribution
    za1 <- qnorm(alpha, lower.tail = TRUE)
    za2 <- qnorm(1 - alpha, lower.tail = TRUE)
    # bias corrected quantile point
    a1 <- pnorm(
      z0 + (z0 + za1) / (1 - a * (z0 + za1))
    )
    a2 <- pnorm(
      z0 + (z0 + za2) / (1 - a * (z0 + za2))
    )

    output$boot$ci$correction.factor <- z0
    output$boot$ci$acceleration.factor <- a
    output$boot$ci$interval <- quantile(bootmu, probs = c(a1, a2))
  }
  output
}

#' Permutation test
#'
#' @param y numeric vector of outcome
#' @param d numeric vector of treatment indicator (contain 1 and 0 only)
#' @param weights numeric vector of weights
#' @param boot how many re-randomization are generated
#' @param seed seed value
#'
#' @examples
#' \dontrun{
#' y1 <- 2 + rnorm(20, sd = 4)
#' y0 <- rnorm(20, sd = 4)
#' d <- sample(c(1, 0), replace = TRUE, size = 40)
#' y <- ifelse(d == 1, y1, y0)
#' permutation(y, d, boot = 200)
#' }
#'
permutation <- function(y,
                        d,
                        weights,
                        boot = 100,
                        seed = 120511) {
  # check same length of outcome and treatment vector
  if (length(y) != length(d)) stop("Same length of y and d")

  # check binary treatment indicator
  if (!(all(unique(d) %in% c(1, 0)))) {
    stop("d must be binary indicator of treated.")
  }

  # create weight vector if missing
  weights <- rep(1, length(y))

  # check missing values
  na_y <- !is.na(y)
  na_d <- !is.na(d)
  na_w <- !is.na(weights)
  keep <- na_y & na_d & na_w

  # use vector
  y <- y[keep]
  w <- weights[keep]
  d <- d[keep]

  y1 <- y[d == 1]
  y0 <- y[d == 0]
  w1 <- w[d == 1]
  w0 <- w[d == 0]

  # output list
  output <- list()

  # information
  n1 <- sum(d == 1)
  n0 <- sum(d == 0)
  output$treat$N <- n1
  output$control$N <- n0

  mean_y1 <- mean(y1 * w1) / mean(w1)
  mean_y0 <- mean(y0 * w0) / mean(w0)
  obs_diff_mean <- mean_y1 - mean_y0

  output$treat$mean <- mean_y1
  output$control$mean <- mean_y0
  output$ate$estimate <- obs_diff_mean

  # re-randomization
  output$ate$method <- "permutation test"
  set.seed(seed)
  bootdiff <- lapply(seq_len(boot), function(i) {
    sim_treated <- sample(seq_len(n1 + n0), size = n1)
    simd <- rep(0, n1 + n0)
    simd[sim_treated] <- 1

    simy1 <- y[simd == 1]
    simy0 <- y[simd == 0]
    simw1 <- w[simd == 1]
    simw0 <- w[simd == 0]

    sim_mean_y1 <- mean(simy1 * simw1) / mean(simw1)
    sim_mean_y0 <- mean(simy0 * simw0) / mean(simw0)
    sim_mean_y1 - sim_mean_y0
  })
  bootdiff <- unlist(bootdiff)
  output$ate$re.random <- bootdiff

  # exact test
  pval <- mean(abs(bootdiff) >= abs(obs_diff_mean))
  output$ate$p.value <- pval

  output
}


# Reading in Data
ds = read.csv('Social_Network_Ads.csv')
ds = ds[, 3:5]

# Scaling and splitting
library(caTools)
ds[,1:2] = scale(ds[,1:2])

split = sample.split(ds$Purchased, SplitRatio = 0.75)
train = subset(ds, split == TRUE)
test = subset(ds, split == FALSE)

#SVM
library(e1071)

# k-Fold Cross Validation

library(caret)
folds = createFolds(train$Purchased, k = 10)
cv = lapply(folds, function(x) {
    train_fold = train[-x, ]
    test_fold = train[x, ]

    clf = svm(Purchased ~ .,
              data = train,
              kernel = 'radial',
              type = 'C-classification')

    y_pred = predict(clf, type = 'response', newdata = test_fold)
    cm = table(test_fold[, 3], y_pred)
    acc = (cm[1,1] + cm[2,2])/sum(cm)
})

accuracy = mean(as.numeric(cv))

plot(clf, data = train)


# ......................................................................................
# ................Cvičení 6 - Vybraná rozdělení spojité náhodné veličiny................
# ..................Martina Litschmannová, Adéla Vrtková, Michal Béreš..................
# ......................................................................................

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

#  Přehled rozdělení a jejich funkcí ####
# * Úvod: Hustota pravděpodobnosti, Distribuční funkce a Kvantilová funkce ####
# ** Hustota pravděpodobnosti ####
# - začíná písmenkem **d**: p = d...(x, ...)
#
# ** Distribuční funkce ####
# - začíná písmenkem **p**: $p = P(X < x)$: p = p...(x, ...)
#
# ** Kvantilová funkce ####
# - začíná písmenkem **q**:  najdi x pro zadané p: $p = F(x) \rightarrow x = F^{-1}(p)$:
# x = q...(p, ...)

# * Rovnoměrné rozdělení: $X \sim Ro(a, b)$ ####
# - náhodná veličina nabývá pouze hodnot větších než a a menších než b
# - všechny hodnoty mají stejnou hustotu výskytu -> hustota pravděpodobnosti je
# konstantní mezi a a b, jinde nulová

# Hustota pravděpodobnosti f(x)
a = 2   # odkud
b = 4   # kam
x = 3
dunif(x, a, b)

# vykreslíme si Hustotu pravděpodobnosti
x = seq(from = 0, to = 6, by = 0.01)
f_x = dunif(x, a, b)
plot(x, f_x, cex = 0.1) # cex je velikost markerů
grid()

# Distribuční funkce F(x) = P(X < x)
a = 2   # odkud
b = 4   # kam
x = 3
punif(x, a, b)

# vykreslíme si Distribuční funkci
x = seq(from = 0, to = 6, by = 0.01)
F_x = punif(x, a, b)
plot(x, F_x, type = 'l')
grid()

# kvantilová funkce F^(-1)(p) = x: P(X<x)=p
a = 2   # odkud
b = 4   # kam
p = 0.75
qunif(p, a, b)

# vykreslení - kvantilová funkce F^(-1)(p) = x
p = seq(from=0, to=1, by=0.01)
x = qunif(p, a, b)
plot(p, x, type = 'l')
grid()

# * Exponenciální rozdělení: $X \sim Exp(\lambda)$ ####
# - doba do 1. události, doba mezi událostmi (pouze v období stabilního života -
# Poissonův proces)
# - parametr $\lambda$ je tentýž co v Poissonově rozdělení
# - střední hodnota je: $E(X)=1 / \lambda$

# Hustota pravděpodobnosti f(x)
lambda = 2
x = 1
dexp(x, lambda)

# vykreslíme si Hustotu pravděpodobnosti
x = seq(from = 0, to = 6, by = 0.01)
f_x = dexp(x, lambda)
plot(x, f_x, type='l')
grid()

# Distribuční funkce F(x) = P(X < x)
lambda = 2
x = 1
pexp(x, lambda)

# vykreslíme si Distribuční funkci
x = seq(from = 0, to = 6, by = 0.01)
F_x = pexp(x, lambda)
plot(x, F_x, type = 'l')
grid()

# kvantilová funkce F^(-1)(p) = x: P(X<x)=p
lambda = 2
p = 0.5
qexp(p, a, b)

# vykreslení - kvantilová funkce F^(-1)(p) = x
p = seq(from=0, to=1, by=0.001)
x = qexp(p, lambda)
plot(p, x, type = 'l')
grid()

# * Weibullovo rozdělení: $X \sim W(\theta,\beta)$ ####
# - doba do 1. události (poruchy)(vhodná volba β umožuje použití v libovolném období
# intenzity poruch)
# - rozšíření exponenciálního rozdělení Exp(λ) = W(Θ=1/λ, β=1)

# Hustota pravděpodobnosti f(x)
theta = 1/2 # ekvivalent 1/lambda u exp. rozdělení
beta = 1  # beta = 1 -> exponenciální rozdělení
x = 5
dweibull(x,shape=beta, scale=theta)

# vykreslíme si Hustotu pravděpodobnosti
x = seq(from = 0, to = 6, by = 0.01)
f_x = dweibull(x,shape=beta, scale=theta)
plot(x, f_x, type='l')
grid()

# Distribuční funkce F(x) = P(X < x)
theta = 3 # ekvivalent 1/lambda u exp. rozdělení
beta = 2  # beta = 1 -> exponenciální rozdělení
x = 5
pweibull(x,shape=beta, scale=theta)

# vykreslíme si Distribuční funkci
x = seq(from = 0, to = 6, by = 0.01)
F_x = pweibull(x,shape=beta, scale=theta)
plot(x, F_x, type = 'l')
grid()

# kvantilová funkce F^(-1)(p) = x: P(X<x)=p
theta = 3 # ekvivalent 1/lambda u exp. rozdělení
beta = 2  # beta = 1 -> exponenciální rozdělení
p = 0.5
qweibull(p,shape=beta, scale=theta)

# vykreslení - kvantilová funkce F^(-1)(p) = x
p = seq(from=0, to=1, by=0.01)
x = qweibull(p,shape=beta, scale=theta)
plot(p, x, type = 'l')
grid()

# * Normální rozdělení: $X \sim N(\mu,\sigma^2)$ ####
# - rozdělení modelující např. chyby měření, chování součtu/průměru mnoha jiných
# náhodných veličin
# - viz. Centrální limitní věta
# - $\mu$ je přímo střední hodnota rozdělení: $E(X)=\mu$
# - $\sigma$ je přímo směrodatná odchyla rozdělení: $D(X)=\sigma^2$
# - s parametry $\mu=0,\sigma=1$ se nazývá normované Normální rozdělení

# Hustota pravděpodobnosti f(x)
mu = 2
sigma = 3
x = 4
dnorm(x, mean=mu, sd=sigma)

# vykreslíme si Hustotu pravděpodobnosti
x = seq(from = -5, to = 10, by = 0.01)
f_x = dnorm(x, mean=mu, sd=sigma)
plot(x, f_x, type='l')
grid()

# Distribuční funkce F(x) = P(X < x)
mu = 2
sigma = 3
x = 4
pnorm(x, mean=mu, sd=sigma)

# vykreslíme si Distribuční funkci
x = seq(from = -5, to = 10, by = 0.01)
F_x = pnorm(x, mean=mu, sd=sigma)
plot(x, F_x, type = 'l')
grid()

# kvantilová funkce F^(-1)(p) = x: P(X<x)=p
mu = 2
sigma = 3
p = 0.5
qnorm(p, mean=mu, sd=sigma)

# vykreslení - kvantilová funkce F^(-1)(p) = x
p = seq(from=0, to=1, by=0.01)
x = qnorm(p, mean=mu, sd=sigma)
plot(p, x, type = 'l')
grid()

#  Příklady ####

# * Příklad 1. ####
# Výška v populaci chlapců ve věku 3,5-4 roky má normální rozdělení se střední hodnotou
# 102 cm a směrodatnou odchylkou 4,5 cm. Určete, jaké procento chlapců v uvedeném věku
# má výšku menší nebo rovnou 93 cm.

# X ... výška chlapců ve věku 3.5 až 4 roky (cm)
# X ~ N(mu = 102, sd = 4.5)

mu = 102
sigma = 4.5

# P(X<=93)=F(93)
pnorm(93, mean=mu, sd=sigma)

# * Příklad 2. ####
# Průměrná životnost strojní součástky je 30 000 hodin. Předpokládejme, že součástka je
# v období
# stabilního života. Určete:

# X ... životnost součástky (h)
# X ~ Exp(lambda), kde E(X)=1/lambda

lambda = 1/30000

# ** a) ####
# pravděpodobnost, že součástka nevydrží více než 2 000 hodin,

#a) P(X<2000)=F(2000)
pexp(2000, lambda)

# ** b) ####
# pravděpodobnost, že součástka vydrží více než 35 000 hodin,

#b) P(X>35000)=1-F(35000)
1 - pexp(35000, lambda)

# ** c) ####
#  dobu, do níž se porouchá 95 % součástek.

#c) P(X<t)=0,95 -> F(t)=0,95 -> t… 95% kvantil
qexp(0.95, lambda)

# * Příklad 3. ####
# Výrobní zařízení má poruchu v průměru jednou za 2000 hodin. Veličina Y představující
# dobu čekání na poruchu má exponenciální rozdělení. Určete dobu T0 tak, aby
# pravděpodobnost, že přístroj bude pracovat delší dobu než T0, byla 0,99.

# X ... doba čekání na poruchu (h)
# X ~ Exp(lambda), kde E(X)=1/lambda
lambda = 1/2000

#P(X>t)=0,99 -> 1-F(t)=0,99 -> F(t)=0,01 -> t… 1% kvant.
qexp(0.01, lambda)

# * Příklad 4. ####
# Výsledky měření jsou zatíženy jen normálně rozdělenou chybou s nulovou střední
# hodnotou a se směrodatnou odchylkou 3 mm. Jaká je pravděpodobnost, že při 3 měřeních
# bude alespoň jednou chyba v intervalu (0 mm; 2,4mm)?

# Y… velikost chyby měření (mm)
# Y ~ N(mu = 0,sigma = 3)

mu = 0
sigma = 3

# pp… pravd., že chyba měření bude v int. 0,0-2,4mm
pp = pnorm(2.4,mean=mu,sd=sigma) - pnorm(0,mean=mu,sd=sigma)
pp

# X … počet chyb měření v int. 0 mm -2,4 mm ve 3 měř.
# X ~ Bi(n = 3,p = pp)
n = 3
p = pp

# P(X>=1)=1-P(X=0)
1 - dbinom(0, n, p)

# * Příklad 5. ####
# Ve velké počítačové síti se průměrně přihlašuje 25 uživatelů za hodinu. Určete
# pravděpodobnost,
# že:
# ** a)  ####
# se nikdo nepřihlásí během 14:30 - 14:36,

# X … počet uživatelů přihlášených za 6 minut
# X ~ Po(lt = 2.5)

lambda = 25/60
t = 6
lt = lambda*t

# P(X=0)
dpois(0, lt)

# ** b)  ####
# do dalšího přihlášení uběhnou 2-3 minuty.

# Y … doba do dalšího přihlášení
# Y ~ Exp(lambda = 25/60), kde E(X)=1/lambda
lambda = 25/60

# P(2<Y<3)=F(3)-F(2)
pexp(3, lambda) - pexp(2, lambda)

# ** c) ####
# Určete maximální délku časového intervalu tak, aby pravděpodobnost, že se nikdo
# nepřihlásí byla alespoň 0,90.

# P(Y>t)=0,90 -> 1-F(t)=0,90 -> F(t)=0,10 -> t…10% kv.

qexp(0.10, lambda)*60

# * Příklad 6. ####
# Náhodná veličina X má normální rozdělení N(µ; σ). Určete:
# ** a) ####
# P(µ − 2σ < X < µ + 2σ),

# P(µ − 2σ < X < µ + 2σ) = F(µ + 2σ) - F(µ - 2σ)
# X~N(µ,σ)
# je jedno jaké hodnoty zvolíme
mu = -105.5447
sigma = 2.654

pnorm(mu + 2*sigma, mean=mu, sd=sigma) -
pnorm(mu - 2*sigma, mean=mu, sd=sigma)

# ** b) ####
# nejmenší k ∈ Z, tak, aby P(µ − kσ < X < µ + kσ) > 0,99.

# normální rozdělení je symetrické
# P(µ − kσ < X < µ + kσ) =
# = 1 - (P(X < µ − kσ ) + P(X > µ + kσ)) =
# = 1 - 2*P(X > µ + kσ) = 0.99 -> P(X > µ + kσ) = 0.005
# -> P(X < µ + kσ) = 0.995

# x = µ + kσ
x = qnorm(0.995, mean=mu, sd=sigma)
(x - mu)/sigma

for(k in 1:5){
    p = pnorm(mu + k*sigma, mean=mu, sd=sigma) -
        pnorm(mu - k*sigma, mean=mu, sd=sigma)
    print(paste0(k,":",p))
}

# * Příklad 7. ####
# Na prohlídce výstavy je promítán doprovodný film o životě autora vystavovaných děl.
# Jeho projekce začíná každých 20 minut. Určete pravděpodobnost, že pokud náhodně
# přijdete do promítacího sálu,

# Y … doba do začátku další projekce
# Y ~ Ro(a=0, b=20)

a = 0
b = 20

# ** a) ####
# nebudete na začátek filmu čekat víc než 5 minut,

# P(X<5)
punif(5, a, b)

# ** b) ####
# budete čekat mezi 5 a 10 minutami,

# P(5<X<10)
punif(10, a, b) - punif(5, a, b)

# ** c) ####
# střední hodnotu a směrodatnou odchylku doby čekání na začátek filmu.

E_X = (a + b)/2
E_X

D_X = (a - b)^2/12
D_X

sigma_X = sqrt(D_X)
sigma_X

# * Příklad 8. ####
# Při kontrole jakosti přebíráme součástku pouze tehdy, jestliže se její rozměr pohybuje
# v mezích 26-27 mm. Rozměry součástek mají normální rozdělení se střední hodnotou 26,4
# mm a směrodatnou odchylkou 0,2 mm. Jaká je pravděpodobnost, že rozměr součástky
# náhodně vybrané ke kontrole bude v požadovaných mezích?

# X ... rozměr součástky (mm)
# X ~ N(mu =  26.4,sigma = 0.2)

mu = 26.4
sigma = 0.2

#P(26<X<27)=F(27)-F(26)
pnorm(27, mean=mu, sd=sigma) - pnorm(26, mean=mu, sd=sigma)

# * Příklad 9. ####
# Délka skoků sportovce Jakuba měřená v cm má normální rozdělení N(µ1; σ1), kde µ1 = 690
# a σ1 = 10. Délka skoků sportovce Aleše měřená v cm má také normální rozdělení N(µ2;
# σ2), kde µ2 = 705 a σ2 = 15. Na závody se kvalifikuje ten, kdo ze dvou skoků alespoň
# jednou skočí více než 700 cm.

# SJ ... délka skoku Jakuba
# SJ ~ N(mu = 690,sigma = 10)
mu_J = 690
sigma_J = 10

# SA … délka skoku Aleše
# SA ~ N(mu = 705,sigma = 15)
mu_A = 705
sigma_A = 15

# J...Jakubův skok je úspěšný (delší než 700 cm)
# A...Alešův skok je úspěšný (delší než 700 cm)

# P(J)=P(SJ>700)=1-F(700)
P.J = 1-pnorm(700,mean=mu_J,sd=sigma_J)
P.J

# P(A)=P(SA>700)=1-F(700)
P.A = 1-pnorm(700,mean=mu_A, sd=sigma_A)
P.A

# KJ … Jakub se kvalifikuje na závody,
# P(KJ) = 1-(1-P(J))(1-P(J))
P.KJ=1-(1-P.J)*(1-P.J)
P.KJ

# KA … Aleš se kvalifikuje na závody,
# P(KA) = 1-(1-P(A))(1-P(A))
P.KA=1-(1-P.A)*(1-P.A)
P.KA

# ** a) ####
# S jakou pravděpodobností se oba dva kvalifikují na závody?

# ada)
P.KJ*P.KA

# ** b) ####
# S jakou pravděpodobností se kvalifikuje Aleš, ale Jakub ne?

# adb)
(1-P.KJ)*P.KA


weightConstructionIncubacionInfeccion=function(lags=7, par1_inf=24.206087, par2_inf=2.984198, distribucion_inf ){
  texto=paste0("p",distribucion_inf,"(1:lags, par1_inf, par2_inf, lower.tail = FALSE)")
  omegaLag=rev(eval(parse(text = texto)))
  omegaLag <- omegaLag / (sum(omegaLag) * par2_inf)
  return(omegaLag)
}

R_caso=function(betas, omegas){
  lags=length(omegas)-1
  initialCases=as.matrix(rep(betas[1], lags))
  cases=betas
  initialVector=initialCases

  #Generate expectation Matrix
  longCases=c(initialVector,cases)
  casesMatrix_T=matrix(0,length(longCases)-lags,lags+1)
  for(i in 1:dim(casesMatrix_T)[1]){
    casesMatrix_T[i,]=longCases[i:(i+lags)]
  }
  t=as.vector(casesMatrix_T%*%omegas)
  return(t)
}


require(TDA)

args <- commandArgs(trailingOnly=TRUE)

# Input the scale parameter of the Rips filtration and the maximum dimension of homological features
# from the command line.
epsilon <- as.numeric(args[1])
maxDimension <- as.numeric(args[2])
path <- args[3]
fileName <- args[4]
label <- args[5]
tdaType <- args[6]
fullPath <- paste(path,fileName,".csv", sep="")
# Read the data set from the disk.
data <- read.csv(fullPath, header = FALSE)

# Create a text file in which the runtimes, complex sizes and stability measures will be written.
sink(file = paste(path,"agg_results.csv",sep=""), append = TRUE)
cat(epsilon)
cat(',')

sink()
sink(file = paste(path,"r_temp.txt",sep=""), append = FALSE)
cat(system.time(Diag <- ripsDiag(X = data, maxDimension, epsilon,
                                   library = tdaType, printProgress = TRUE))["elapsed"])
#cat(',')
sink()

# Write the output of persistent homology from the original data set to a csv file on disk.
write.table(Diag[["diagram"]], file = paste(path,fileName,tdaType,"_Output.csv",sep=""), quote = FALSE,
            sep = ",", row.names = FALSE)

# Plot the output of persistent homology from the original data set on a pdf file.
pdf(file = paste(path,"RPlot_",fileName,"_",tdaType,".pdf",sep=""), width = 11, height = 8.50)
plot(data, main = paste(label,tdaType))
plot(Diag[["diagram"]], main = paste("Persistence Diagram\n",label,tdaType))
plot(Diag[["diagram"]], barcode = TRUE, main = paste("Barcodes from\n",label,tdaType))

sink(file = paste(path,"r_temp.txt",sep=""), append = TRUE)

originalData <- read.csv(paste(path,"0.0_Reduction",tdaType,"_Output.csv",sep=""), header = TRUE)
originalData <- as.matrix(originalData)

bottleneckDist <- vector()
wassersteinDist <- vector()
for(j in 0:maxDimension) {
#Compute the stability measures for each dimension.
	bottleneckDist[j+1] <- bottleneck(originalData, Diag[["diagram"]], dimension = j)
	wassersteinDist[j+1] <- wasserstein(originalData, Diag[["diagram"]], p = 2, dimension = j)
	cat(',')
	cat(bottleneckDist[j+1])
	cat(',')
	cat(wassersteinDist[j+1])
}

sink()

dev.off()


##################################################
## Project: Iris Data Set
## Script purpose: Study
## Date: 09/01/2019
## Author: Eduardo Sant' Anna Martins
##################################################

main <- function(){

  dataset.test <- read.csv("dataset/iris.data", sep=",", header=F)

  colnames(dataset.test) <- c("sepal.length", "sepal.width", "petal.length", "petal.width", "class")

  folder <- "plots"

  for (class.name in c("Iris-versicolor", "Iris-setosa", "Iris-virginica")){

    dataset.iris <- dataset.test[dataset.test$class == class.name, ]

    x <- dataset.iris$sepal.length

    y <- dataset.iris$sepal.width

    f.name <- file.path(folder, paste("scatter-", class.name,  ".pdf", sep = ""))

    myscatter.plot(x, y, file.name=f.name, m="Dispertion Graphic", x.lab="Sepal Length", y.lab="Sepal Width")

    f.name <- file.path(folder, paste("bell-sepal-length", class.name,  ".pdf", sep = ""))

    mybell.plot(x, file.name=f.name, m="Bell curve Graphic", x.lab="Sepal Length")

    #f.name <- file.path(folder, paste("bell-sepal-width", class.name,  ".pdf", sep = ""))

    #mybell.plot(y, file.name=f.name, m="Bell Curve Graphic", x.lab="Sepal width")

  }

}

myscatter.plot <- function(x, y, file.name = "plot.pdf", m = NA, x.lab = NA, y.lab = NA){

  #print(paste(x, y, file.name, m, x.lab, y.lab, sep = ", "))

  pdf(file.name)

  plot(x, y, main=m, xlab=x.lab, ylab=y.lab, pch=19)

  abline(lm(x~y), col="red")

  lines(lowess(x, y), col="blue")

  dev.off()

}

mybell.plot <- function(value, file.name = "plot.pdf", m = NA, x.lab = NA){

  #print(paste(x, y, file.name, m, x.lab, y.lab, sep = ", "))

  pdf(file.name)

  hist(value, col = "red", freq = F, xlim = 10 + c(-5, 5))

  #curve(dnorm(value, mean = mean(value), sd = sd(value)))#, 5, 15, add = T, col = "blue")

  dev.off()

}

print(main())


library(keras)
mnist <- dataset_mnist()
x_train <- mnist$train$x
y_train <- mnist$train$y
x_test <- mnist$test$x
y_test <- mnist$test$y

# reshape
x_train <- array_reshape(x_train, c(nrow(x_train), 784))
x_test <- array_reshape(x_test, c(nrow(x_test), 784))
# rescale
x_train <- x_train / 255
x_test <- x_test / 255

y_train <- to_categorical(y_train, 10)
y_test <- to_categorical(y_test, 10)

model <- keras_model_sequential()
model %>%
  layer_dense(units = 1024, activation = 'relu', input_shape = c(784)) %>%
  layer_dropout(rate = 0.4) %>%
  layer_dense(units = 512, activation = 'relu') %>%
  layer_dropout(rate = 0.3) %>%
  layer_dense(units = 256, activation = 'relu') %>%
  layer_dropout(rate = 0.2) %>%
  layer_dense(units = 128, activation = 'relu') %>%
  layer_dropout(rate = 0.2) %>%
  layer_dense(units = 10, activation = 'softmax')

summary(model)

model %>% compile(
  loss = 'categorical_crossentropy',
  optimizer = optimizer_rmsprop(),
  metrics = c('accuracy')
)

history <- model %>% fit(
  x_train, y_train,
  epochs = 30, batch_size = 128,
  validation_split = 0.2
)

plot(history)


queens <- function(n) {
  a <- seq(n)
  u <- rep(T, 2 * n - 1)
  v <- rep(T, 2 * n - 1)
  m <- NULL
  aux <- function(i) {
    if (i > n) {
      m <<- cbind(m, a)
    } else {
      for (j in seq(i, n)) {
        k <- a[[j]]
        p <- i - k + n
        q <- i + k - 1
        if (u[[p]] && v[[q]]) {
          u[[p]] <<- v[[q]] <<- F
          a[[j]] <<- a[[i]]
          a[[i]] <<- k
          aux(i + 1)
          u[[p]] <<- v[[q]] <<- T
          a[[i]] <<- a[[j]]
          a[[j]] <<- k
        }
      }
    }
  }
  aux(1)
  m
}