rsvd.checkargs <- function(x, k, q, retu, retvt)
{
  assert.type(retu, "logical")
  assert.type(retvt, "logical")

  assert.natnum(k)
  if (k > nrow(x))
    comm.stop("'k' must be no greater than nrow(x)")

  assert.natnum(q)

  ### TODO check for NA, NaN, Inf

  invisible(TRUE)
}

#' Random SVD
#'
#' @param x
#' The input data matrix.
#' @param k
#' The number of singular values and/or left/right singular vectors
#' to estimate.
#' @param q
#' An integer exponent, say 1, 2, or 3.  See the paper for details.
#' @param retu
#' Logical; should the left singular vectors ("U") be returned?
#' @param retvt
#' Logical; should the transposed right singular vectors ("VT") be returned?
#'
#' @return
#' A list cotaining the singular values, and, if requested, the
#' left and/or right singular vectors.
#'
#' @references
#' Halko, Martinsson, and Tropp. 2011. Finding structure with
#' randomness: probabilistic algorithms for constructing approximate
#' matrix decompositions. SIAM Review 53 217-288.
#'
#' @author
#' George Ostrouchov and Drew Schmidt
#'
#' @examples
#' \dontrun{
#' x <- matrix(rnorm(30), 10)
#'
#' rsvd(x)
#' }
#'
#' @keywords SVD PCA
#' @name rsvd
#' @rdname rsvd
#' @export
rsvd <- function(x, k=1, q=3, retu=TRUE, retvt=TRUE)
{
  rsvd.checkargs(x=x, k=k, q=q, retu=retu, retvt=retvt)

  if (class(x) != "ddmatrix")
    x <- as.matrix(x)

  k <- as.integer(k)
  q <- as.integer(q)

  ### Stage A from the paper
  n <- ncol(x)

  if (class(x) == "matrix")
    Omega <- matrix(runif(n*2L*k), nrow=n, ncol=2L*k)
  else if (class(x) == "ddmatrix")
    Omega <- ddmatrix("runif", nrow=n, ncol=2L*k, bldim=x@bldim, ICTXT=x@ICTXT)

  Y <- x %*% Omega
  Q <- qr.Q(qr(Y))

  for (i in 1:q)
  {
    Y <- crossprod(x, Q)
    Q <- qr.Q(qr(Y))
    Y <- x %*% Q
    Q <- qr.Q(qr(Y))
  }

  ### Stage B
  B <- crossprod(Q, x)

  if (!retu)
    nu <- 0
  else
    nu <- min(nrow(B), ncol(B))

  if (!retvt)
    nv <- 0
  else
    nv <- min(nrow(B), ncol(B))

  svd.B <- La.svd(x=B, nu=nu, nv=nv)

  d <- svd.B$d
  d <- d[1L:k]

  # Produce u/vt as desired
  if (retu)
  {
    u <- svd.B$u
    u <- Q %*% u

    u <- u[, 1L:k, drop=FALSE]
  }

  if (retvt)
  {
    vt <- svd.B$vt[1L:k, , drop=FALSE]
  }

  # wrangle return
  if (retu)
  {
    if (retvt)
      svd <- list(d=d, u=u, vt=vt)
    else
      svd <- list(d=d, u=u)
  }
  else
  {
    if (retvt)
      svd <- list(d=d, vt=vt)
    else
      svd <- list(d=d)
  }

  return( svd )
}


# Example : 2   Chapter : 8.1     Page No: 414
# Find movements , tensions, elongations of spring
K1<-matrix(c(2,-1,0,-1,2,-1,0,-1,1),ncol=3)
K11<-solve(K1)
f<-c(1,1,1)
u<-K11%*%f
print("Movements are given by mg/c * u and u  is")
print(u)
A<-matrix(c(1,-1,0,0,1,-1,0,0,1),ncol=3)
e<-A%*%u
print("Elongations are given by mg/c * e and e is")
print(e)
y<-solve(t(A))%*%f
print("Tensions are given by mg * y and y is")
print(y)


#' @export
#' @title bufferCircle
#' @description This function buffers a point by a specified radius \code{n}.
#' @param \code{lonlat} = the position to buffer
#' @param \code{radius} = the radius in kilometers to buffer
#' @param \code{npoints} = number of discrete points to create (default is 100)
#' @return data.frame of 101 indivual points of $lat and $lon
#' @examples
#' bufferCircle(c(-64.15,44.75),100)
#' @author  Adam Cook, \email{Adam.Cook@@dfo-mpo.gc.ca}
#' @export
bufferCircle <- function(lonlat, radius, npoints=100) {
	#//**radius must be in km, this treats the globe as a sphere**

		 Rearth <- 6378.137
	     Dd <- rep(radius / Rearth,npoints+1)

	     Cc <- seq(0, 2*pi, by=2*pi/npoints) #turning direction

	         lata <- lonlat[2] * (pi/180) #convert to radians
	         lona <- lonlat[1] * (pi/180)

	     latb <- asin(cos(Cc) * cos(lata) * sin(Dd) + sin(lata) * cos(Dd))
	     dlon <- atan2(cos(Dd) - sin(lata) * sin(latb), sin(Cc) * sin(Dd) * cos(lata))
	     lonb <- lona - dlon + pi/2

	     lonb[lonb >  pi] <- lonb[lonb >  pi] - 2 * pi
	     lonb[lonb < -pi] <- lonb[lonb < -pi] + 2 * pi

	     latb <- latb * (180 / pi) #back to lat lon
	     lonb <- lonb * (180 / pi)

	     out <- data.frame(lon = lonb, lat = latb)
	     return(out)
     }


# Since R is a vector based language that penalizes for loops, we will avoid
#     for-loops, instead using "apply" statement variants (like "map" in other
#     functional languages).

set.seed(19771025)   # set the seed to set the same results as this code
N <- 10000  # trials
true_answers <- sample(1:3, N, replace=TRUE)

# We can assme that the contestant always choose door 1 without any loss of
#    generality, by equivalence.  That is, we can always relabel the doors
#    to make the user-chosen door into door 1.
# Thus, the host opens door '2' unless door 2 has the prize, in which case
#    the host opens door 3.

host_opens <- 2 + (true_answers == 2)
other_door <- 2 + (true_answers != 2)

## if always switch
summary( other_door == true_answers )
## if we never switch
summary( true_answers == 1)
## if we randomly switch
random_switch <- other_door
random_switch[runif(N) >= .5] <- 1
summary(random_switch == true_answers)

## To go with the exact parameters of the Rosetta challenge, complicating matters....
##  Note that the player may initially choose any of the three doors (not just Door 1),
##     that the host opens a different door revealing a goat (not necessarily Door 3), and
##     that he gives the player a second choice between the two remaining unopened doors.

N <- 10000  #trials
true_answers <- sample(1:3, N, replace=TRUE)
user_choice <- sample(1:3, N, replace=TRUE)
## the host_choice is more complicated
host_chooser <- function(user_prize) {
    # this could be cleaner
    bad_choices <- unique(user_prize)
    # in R, the x[-vector] form implies, choose the indices in x not in vector
    choices <- c(1:3)[-bad_choices]
    # if the first arg to sample is an int, it treats it as the number of choices
    if (length(choices) == 1) {  return(choices)}
    else { return(sample(choices,1))}
}

host_choice <- apply( X=cbind(true_answers,user_choice), FUN=host_chooser,MARGIN=1)
not_door <- function(x){ return( (1:3)[-x]) }  # we could also define this
                                                # directly at the FUN argument following
other_door  <- apply( X = cbind(user_choice,host_choice), FUN=not_door, MARGIN=1)

## if always switch
summary( other_door == true_answers )
## if we never switch
summary( true_answers == user_choice)
## if we randomly switch
random_switch <- user_choice
change <- runif(N) >= .5
random_switch[change] <- other_door[change]
summary(random_switch == true_answers)


#loading the data
df = as.matrix(read.table('/home/smith/Downloads/nci.data.txt', header = FALSE , sep = "", dec = "."))
df2 = as.matrix(read.table('/home/smith/Downloads/label.txt', header = FALSE , sep = "", dec = "."))
scaled_data = scale(t(df))
r =nrow(scaled_data)
c = nrow(scaled_data)
#computing the pairwise differences
pair_diff = matrix(Inf ,nrow = r , ncol= c)
for (i in 1:r){
    for (j in 1:c){
        if(i!=j){
            pair_diff[i,j] = sqrt(sum((scaled_data[i,] - scaled_data[j,])^2))
        }
    }
}
upper_tri = upper.tri(pair_diff)
pair_diff[upper_tri] = Inf   #making the reapeated distances infinity

cluster_matrix = matrix(ncol =nrow(scaled_data), nrow = nrow(scaled_data))
cluster_matrix[,1] = 1:64  #cluster matrix has all the cluster assignments from n to 1 cluster
sl_pair_diff = pair_diff
branch_length = vector(length = r-1)
#This for loop find the cluster assignments for single-linkage
for(m in 2:r){
    cluster_matrix[,m] = cluster_matrix[,m-1]
    min_diff = min(sl_pair_diff)
    r_min = which(sl_pair_diff ==min_diff , arr.ind =TRUE)[1,1]
    c_min = which(sl_pair_diff == min_diff, arr.ind =TRUE)[1,2]
    while(cluster_matrix[c_min,m] == cluster_matrix[r_min,m]){
        sl_pair_diff[r_min,c_min] = Inf
        min_diff = min(sl_pair_diff)
        r_min = which(sl_pair_diff ==min_diff , arr.ind =TRUE)[1,1]
        c_min = which(sl_pair_diff == min_diff, arr.ind =TRUE)[1,2]
    }
    branch_length[m-1] = min_diff
    sl_pair_diff[r_min,c_min] = Inf
    cluster_matrix[,m][cluster_matrix[,m] == cluster_matrix[r_min,m]] = cluster_matrix[c_min,m]
    cluster_matrix[,m] = as.numeric(factor(cluster_matrix[,m]))

}
sl_cluster_matrix = cluster_matrix
print(sl_cluster_matrix)  #This is all cluster assignments at each level
print(branch_length)   #This is the height at each of N-1 steps

#The next part is for implementaion of Compllete Linkage
# computing pair-wise distance again, this time using NaN value for unneeded redundancies
pair_diff = matrix(NaN ,nrow = r , ncol= c)
for (i in 1:r){
    for (j in 1:c){
        if(i!=j){
            pair_diff[i,j] = sqrt(sum((scaled_data[i,] - scaled_data[j,])^2))
        }
    }
}
cluster_matrix = matrix(ncol =nrow(scaled_data), nrow = nrow(scaled_data))
cluster_matrix[,1] = 1:64
branch_length = vector(length = r-1)
cl_pair_diff = pair_diff
#This for loop find the cluster assignments for complete-linkage
for (m in 2:r){
    cluster_labels = as.data.frame(table(cluster_matrix[,m-1]))
    already_clustered = cluster_labels[,1]
    for(l in 1:length(already_clustered)){
        for(k in 1:length(already_clustered)){
            if(l!=k){
               cluster_value_1 = which(cluster_matrix[,m-1]==already_clustered[l])
               cluster_value_2 = which(cluster_matrix[,m-1]==already_clustered[k])
               comp_var =c(cluster_value_1,cluster_value_2)
               temp = max(cl_pair_diff[comp_var,comp_var], na.rm =TRUE)
               index = which(pair_diff ==temp,arr.ind =TRUE)
               cl_pair_diff[comp_var,comp_var] = NaN
               cl_pair_diff[index[1],index[2]]= temp
            }
        }
    }

    cluster_matrix[,m] = cluster_matrix[,m-1]
    min_diff = min(cl_pair_diff, na.rm =TRUE)
    r_min = which(cl_pair_diff ==min_diff , arr.ind =TRUE)[1,1]
    c_min = which(cl_pair_diff == min_diff, arr.ind =TRUE)[1,2]
    branch_length[m-1] = min_diff
    cl_pair_diff[r_min,c_min] = NaN
    cl_pair_diff[c_min,r_min] = NaN
    cluster_matrix[,m][cluster_matrix[,m] == cluster_matrix[r_min,m]] = cluster_matrix[c_min,m]
    cluster_matrix[,m] = as.numeric(factor(cluster_matrix[,m]))

}
cl_cluster_matrix = cluster_matrix
print(cl_cluster_matrix)  #This is all cluster assignments at each level
print(branch_length)   #This is the height at each of N-1 steps

#The next part is for implementaion of Average Linkage

branch_length = vector(length = r-1)
cl_pair_diff = pair_diff
#This is an optional step of making redundant values zero,however, the loop already take cares of these values
upper_tri = upper.tri(cl_pair_diff)
cl_pair_diff[upper_tri] = NaN
#This for loop find the cluster assignments for average-linkage
for (m in 2:r){
    cluster_labels = as.data.frame(table(cluster_matrix[,m-1]))
    already_clustered = cluster_labels[,1]
    for(l in 1:length(already_clustered)){
        for(k in 1:length(already_clustered)){
            if(l!=k){
               cluster_value_1 = which(cluster_matrix[,m-1]==already_clustered[l])
               cluster_value_2 = which(cluster_matrix[,m-1]==already_clustered[k])
               cl_pair_diff[cluster_value_1,cluster_value_1] =NaN
               cl_pair_diff[cluster_value_2,cluster_value_2] =NaN
               comp_var =c(cluster_value_1,cluster_value_2)
               temp = (sum(cl_pair_diff[comp_var,comp_var], na.rm =TRUE))/(length(cluster_value_1)*length(cluster_value_2))
               #temp = temp/(length(cluster_value_1)*length(cluster_value_2))
               cl_pair_diff[comp_var,comp_var] = NaN
               cl_pair_diff[cluster_value_1,cluster_value_2] = temp
            }
        }
    }
    cluster_matrix[,m] = cluster_matrix[,m-1]
    min_diff = min(cl_pair_diff, na.rm =TRUE)
    r_min = which(cl_pair_diff ==min_diff , arr.ind =TRUE)[1,1]
    c_min = which(cl_pair_diff == min_diff, arr.ind =TRUE)[1,2]

    branch_length[m-1] = min_diff
    cl_pair_diff[r_min,c_min] = NaN
    cluster_matrix[,m][cluster_matrix[,m] == cluster_matrix[r_min,m]] = cluster_matrix[c_min,m]
    cluster_matrix[,m] = as.numeric(factor(cluster_matrix[,m]))
}
al_cluster_matrix = cluster_matrix
print(al_cluster_matrix)  #This is all cluster assignments at each level
print(branch_length)   #This is the height at each of N-1 steps

#The next part is for implementaion of Centroid Linkage
#function to calculate distance
mydist<- function(scaled_data){
    r =nrow(scaled_data)
    c = nrow(scaled_data)
    pair_diff = matrix(NaN ,nrow = r , ncol= c)
    for (i in 1:r){
     for (j in 1:c){
        if(i!=j){
            pair_diff[i,j] = sqrt(sum((scaled_data[i,] - scaled_data[j,])^2 ,na.rm=TRUE))
        }
    }
}
    return(pair_diff)
}

#Next for loop find the cluster assignments for centroid-linkage
centroid_data = scaled_data
nullified = matrix(FALSE,r,c)  #This boolean matrix will keep track of the distances already used
for (m in 2:r){
    all_distance = mydist(centroid_data)
    diag(all_distance)= NaN
    upper_tri = upper.tri(all_distance)
    all_distance[upper_tri] = NaN
    all_distance[nullified] = NaN

    cluster_matrix[,m] = cluster_matrix[,m-1]
    min_diff = min(all_distance, na.rm = TRUE)
    r_min = which(all_distance ==min_diff , arr.ind =TRUE)[1,1]
    c_min = which(all_distance == min_diff, arr.ind =TRUE)[1,2]

    while(cluster_matrix[c_min,m] == cluster_matrix[r_min,m]){
        all_distance[r_min,c_min] = NaN
        min_diff = min(all_distance, na.rm = TRUE)
        r_min = which(all_distance == min_diff , arr.ind =TRUE)[1,1]
        c_min = which(all_distance == min_diff, arr.ind =TRUE)[1,2]
    }
    branch_length[m-1] = min_diff
    all_distance[r_min,c_min] = NaN
    cluster_matrix[,m][cluster_matrix[,m] == cluster_matrix[r_min,m]] = cluster_matrix[c_min,m]
    cluster_matrix[,m] = as.numeric(factor(cluster_matrix[,m]))
    nullified = is.nan(all_distance)

    cluster_labels = as.data.frame(table(cluster_matrix[,m-1]))
    already_clustered = as.numeric(as.matrix(cluster_labels[,1][cluster_labels[,2]>1]))

    for(l in 1:length(already_clustered)){
        cluster_value = which(cluster_matrix[,m-1]==already_clustered[l])
        if(length(cluster_value)>1)
        {
        total = colSums(scaled_data[cluster_value,])
        temp = total/length(cluster_value)
        centroid_data[cluster_value,] = temp
        }

    }

}

cent_cluster_matrix = cluster_matrix
print(cent_cluster_matrix)  #This is all cluster assignments at each level
print(branch_length)   #This is the height at each of N-1 steps

#applying K-means to our dataset
km_out = kmeans(scaled_data , 3 , nstart = 20)
table(df2 , km_out$cluster)

km_out = kmeans(scaled_data , 4 , nstart = 20)
table(df2 , km_out$cluster)
km_out = kmeans(scaled_data , 5 , nstart = 20)
table(df2 , km_out$cluster)
km_out = kmeans(scaled_data , 6 , nstart = 20)
table(df2 , km_out$cluster)
km_out = kmeans(scaled_data , 7 , nstart = 20)
table(df2 , km_out$cluster)
km_out = kmeans(scaled_data , 15 , nstart = 20)
table(df2 , km_out$cluster)

#comparing complete linkage and K-means both with clusters = 5
km_out = kmeans(scaled_data , 4, nstart = 20)
km_cluster = km_out$cluster
hc_cluster = cl_cluster_matrix[,61]
table(km_cluster, hc_cluster)


#' Calculate Standard Error of Mean
#'
#' @param x a numerical vector
#' @param na.rm a logical value whether we remove N/A value
#'
#' @return a numeric which is a statndard error of mean
#'
#' @importFrom stats na.omit
#' @importFrom stats var
#'
#' @export
#+
se <- function(x, na.rm = FALSE) {

  # na.rm = TRUE, we remove NA using na.omit()
  if (na.rm) x <- na.omit(x)

  # calculate and return se
  sqrt(var(x) / length(x))
}

#' Summary table of variables
#'
#' @description This is alternative method of `summary()`
#'     for countable or continuous vairbales.
#'     Since this function returns a data frame,
#'     you can pass some output format function (e.g. `kable`) easily.
#'
#' @param data a `data.frame` object.
#' @param vars a character vector of variables.
#' @param stat a character vector of statisics.
#'     "mean" is an average, "se" is its standard errors,
#'     "sd" is a standard error, "min" is minimum, "max" is maximum,
#'     "q25" is a first quantile, "median" is median, "q75" is a third quantile.
#'     "sum" is a sum of variable, and "N" is sample size.
#'
#' @return an object whose class is `data.frame`
#'
#' @importFrom dplyr summarize_at
#' @importFrom dplyr mutate
#' @importFrom dplyr select
#' @importFrom tidyr pivot_longer
#' @importFrom tidyselect everything
#' @importFrom magrittr %>%
#'
#' @export
#+
statvars <- function(
    data, vars,
    stat = c(
        "mean", "se", "sd", "min", "q25", "median", "q75", "max", "sum", "N"
    )
) {

  tab <- data %>%
    summarize_at(
      vars,
      list(
        mean = ~mean(., na.rm = TRUE),
        se = ~se(., na.rm = TRUE),
        sd = ~sd(., na.rm = TRUE),
        min = ~min(., na.rm = TRUE),
        q25 = ~quantile(., prob = .25, na.rm = TRUE),
        median = ~median(., na.rm = TRUE),
        q75 = ~quantile(., prob = .75, na.rm = TRUE),
        max = ~max(., na.rm = TRUE),
        sum = ~sum(., na.rm = TRUE),
        N = ~sum(!is.na(.))
      )
    )

    if (length(vars) == 1) {

        tab <- tab %>%
          mutate(vars = vars) %>%
          select(c("vars", stat))

    } else {

        pattern <- "(.*)_(mean|se|sd|min|q25|median|q75|max|sum|N)"

        tab <- tab %>%
          pivot_longer(
            everything(),
            names_to = c("vars", ".value"),
            names_pattern = pattern
          ) %>%
          select(c("vars", stat))

    }

    return(tab)

}


# Preliminaries
#-------------------------------------------------
#install.packages('perm')
library(perm)
rm(list = ls())

# Fisher
#-------------------------------------------------

#permutations in a matrix
perms <- chooseMatrix(8, 4)
#observed values in treated [0,1,0,0,0,1,1,1]
A <- matrix(c(0.462, 0.731, 0.571, 0.923, 0.333, 0.750, 0.893, 0.692), nrow=8, ncol=1, byrow=TRUE)
treatment_avg <- (1/4)*perms%*%A
control_avg <- (1/4)*(1-perms)%*%A
test_statistic <- abs(treatment_avg-control_avg)
rownumber <- apply(apply(perms, 1,
                         function(x) (x == c(0, 1, 0, 0, 0, 1, 1, 1))),
                   2, sum)
rownumber <- (rownumber == 8)
observed_test <- test_statistic[rownumber == TRUE]

#number of test statistics greater or equal the statistic observed
larger_than_observed <- (test_statistic >= observed_test)
sum(larger_than_observed)

df <- data.frame(perms, control_avg, treatment_avg, test_statistic)

# Fisher, large number (simulation by random instead of permutation)
#-------------------------------------------------
simul_stat <- as.vector(NULL)
schools <- read.csv('teachers_final.csv')
set.seed(1001)
for(i in 1:1000) {
  print(i)
  schools$rand <- runif(100,min=0,max=1)
  schools$treatment_rand <- as.numeric(rank(schools$rand)<=49)
  schools$control_rand = 1-schools$treatment_rand
  simul_stat <-append(simul_stat,
            sum(schools$treatment_rand*schools$open)/sum(schools$treatment_rand)
            - sum(schools$control_rand*schools$open)/sum(schools$control_rand))
}

schools$control = 1-schools$treatment
actual_stat <- sum(schools$treatment*schools$open)/sum(schools$treatment) - sum(schools$control*schools$open)/sum(schools$control)
sum(abs(simul_stat) >= actual_stat)/NROW(simul_stat)
#the result it's near to zero, so we need Neyman's

# Neyman
#---------------------------------------------------
#Printing the ATE
ate <- actual_stat
ate

control_mean <- sum(schools$control*schools$open)/sum(schools$control)
treatment_mean <- sum(schools$treatment*schools$open)/sum(schools$treatment)

#sample variances for treatment and control
s_c <- (1/(sum(schools$control)-1))*sum(((schools$open-control_mean)*schools$control)^2)
s_t <- (1/(sum(schools$treatment)-1))*sum(((schools$open-treatment_mean)*schools$treatment)^2)

#formula to get neyman variance
Vneyman <- (s_c/sum(schools$control) + s_t/sum(schools$treatment))
print(sqrt(Vneyman))

#t-statistic
print(actual_stat/sqrt(Vneyman))
t_stat <- actual_stat/sqrt(Vneyman)

#p-value
print(2 * (1 - pnorm(t_stat))) #near to zero

#confident interval for 95%
print(actual_stat-1.96*sqrt(Vneyman))
print(actual_stat+1.96*sqrt(Vneyman))

### Plotting Kernel Regression ###
# (using np, ggplot doesn't have kernel regression)
#install.packages('np')
library(np)
bw_004 = npreg(xdat=schools$open, ydat=schools$pctpostwritten, bws = 0.04)
plot(bw_004)
bw_0001 = npreg(xdat=schools$open, ydat=schools$pctpostwritten, bws = 0.001)
plot(bw_0001)
bw_1 = npreg(xdat=schools$open, ydat=schools$pctpostwritten, bws = 1)
plot(bw_1)
bw_20 = npreg(xdat=schools$open, ydat=schools$pctpostwritten, bws = 20)
plot(bw_20)

### Plotting CDFs to know FSD ###
#CDF: cumulative density function
#FSD: first stochastic dominate
library(tidyverse)

#Incorrect way
cdf_treatment = ecdf(schools$treatment*schools$teacherscore)
cdf_control = ecdf(schools$control*schools$teacherscore)
#plot(cdf_treatment, col='blue')
plot.ecdf(schools$treatment*schools$teacherscore, col='blue')
lines(cdf_control, col='red')

#Correct way
schools$group[schools$treatment==1] <-"T"
schools$group[schools$treatment==0] <-"C"
ggplot(schools, aes(pctpostwritten,colour = group)) + stat_ecdf()


# Moving (rolling) averages: SMA, WMA, EMA in R

install.packages("quantmod") # instalujemy biblioteke
library(quantmod) # uruchamiamy ^ biblioteke

# przyklad 1 dla Idea Bank SA

start <- as.Date("2019-01-01") # data, od ktorej pobieramy dane; YYYY-MM-DD
end <- as.Date("2019-05-01") # data, do ktorej pobieramy dane; YYYY-MM-DD

getSymbols("IDA.WA", src = "yahoo", from = start, to = end) # pobieramy dane nt. Idea Bank SA z Yahoo Finance (symbol w Yahoo Finance: IDA.WA; https://is.gd/Q82Ck2); wartosci w PLN

head(IDA.WA) # sprawdzamy czy zaciagnelismy dobre dane

candleChart(IDA.WA, up.col = "green", dn.col = "red", theme = "white", name = "Idea Bank SA") # rysujemy wykres swiecowy
addSMA(n = 14, col = "blue") # rysujemy SMA z ostatnich 14 dni, kolor linii niebieski
addWMA(n = 14, col = "black") # rysujemy WMA z ostatnich 14 dni, kolor linii czarny
addEMA(n = 14, col = "orange") # rysujemy EMA z ostatnich 14 dni, kolor linii pomaranczowy

SMA(IDA.WA[,-c(1,2,3,5,6)], n = 14) # obliczenie SMA; wykluczamy wszystkie kolumny oprocz tej z danymi, ktore nas interesuja tj. 4: IDA.WA.Close

# przyklad 2 dla IBM

start <- as.Date("2009-01-01")
end <- as.Date("2019-01-01")

getSymbols("IBM", src = "yahoo", from = start, to = end) # wartosci w USD

candleChart(IBM, up.col = "green", dn.col = "red", theme = "white")
addSMA(n = 90, col = "blue") # rysujemy SMA z ostatnich 90 dni
addWMA(n = 90, col = "black")
addEMA(n = 90, col = "orange")

EMA(IBM[,-c(1,2,3,5,6)], n = 90) # EMA z ostatnich 90 dni


# GLAJENJE ČASOVNIH VRST
# Finančni praktikum 2020/21
# Mitja Mandić

#PRVA NALOGA

#uvoz in obdelava podatkov
platina <- read.csv("cetrta_naloga/platina20.csv")

platina_zakljuceni <- platina$Close

platina_zakljuceni <- gsub(",", "", platina_zakljuceni)
platina_zakljuceni <- gsub("\\$", "", platina_zakljuceni)

#podatki do sredine maja 2020

dolzina <- 129

platina_zakljuceni <- as.numeric(rev(platina_zakljuceni[1:dolzina]))

graf_platina <- ts.plot(platina_zakljuceni, ylab = "Cena")
title("Platina")

#DRUGA NALOGA

#druga a
G <- function(vrsta, k) {

  glajene_vr <- c()
  #seštevamo delne vsote časovne vrste in jih delimo s k
  for (i in k:length(vrsta)) {
    glajene_vr[i] <- (1/k) * sum(vrsta[(i-k+1):i])
  }

  return(ts(glajene_vr))
}

#glajenje reda 7, k = 7

glajena.7 <- G(platina_zakljuceni, 7)

naslednji_dan <- glajena[length(glajena)]

ts.plot(platina_zakljuceni,glajena.7, ylab = "Cena", col = c("black", "red"))
title("Glajenje reda 7")

#druga d

#standardna kvadratična napaka
MSE.7 <- sum((platina_zakljuceni[8:dolzina-1]-glajena.7[8:dolzina-1]) ^ 2) / (dolzina - 7)

#postopek ponovljen še za reda k = 14 in k = 30
#k = 14
glajena.14 <- G(platina_zakljuceni,14)

ts.plot(platina_zakljuceni, glajena.14, ylab = "Cena", col = c("black", "red"))
title("Glajenje reda 14")
glajena.14.graf <- recordPlot

MSE.14 <- sum((platina_zakljuceni[15:dolzina-1]-glajena.14[15:dolzina-1]) ^ 2) / (dolzina - 14)

#k = 30
glajena.30 <- G(platina_zakljuceni,30)

ts.plot(platina_zakljuceni, glajena.30, ylab = "Cena", col = c("black", "red"))
title("Glajenje reda 30")
glajena.30.graf <- recordPlot()

MSE.30 <- sum((platina_zakljuceni[31:dolzina-1]-glajena.14[31:dolzina-1]) ^ 2) / (dolzina - 31)

par(mfrow = c(2,2))
ts.plot(platina_zakljuceni,glajena.7, ylab = "Cena", col = c("black", "red"))
title("Glajenje reda 7")
ts.plot(platina_zakljuceni, glajena.14, ylab = "Cena", col = c("black", "red"))
title("Glajenje reda 14")
ts.plot(platina_zakljuceni, glajena.30, ylab = "Cena", col = c("black", "red"))
title("Glajenje reda 30")

#TRETJA NALOGA

#eksponentno glajenje

EG <- function(vrsta, alpha){
  l <- c()
  #začetna vrednost se ujema s prvo vrednostjo iz časovne vrste
  l[1] <- vrsta[1]
  for (i in 2:length(vrsta)){
    #rekurzivna formula za računanje naprej
    l[i] <- alpha * vrsta[i] + (1-alpha) * l[i-1]
  }
  return(ts(l))
}

#izbral sem vrednost 0.2, izračunal eksponentno glajeno vrsto.
EG.02 <- EG(platina_zakljuceni, 0.2)

ts.plot(EG.02, platina_zakljuceni, col = c("red", "black"), ylab = "Cena")
title("Eskponentno glajenje")


int2str <- function(x, b) {
	if(x==0) return("0")
	if(x<0) return(paste0("-", base(-x,b)))

	map <- c(as.character(0:9), letters)
	res <- ""
	while (x>0) {
		res <- c(map[x %% b + 1], res)
		x <- x %/% b
	}
	return(paste(res, collapse=""))
}

str2int <- function(s, b) {
	map <- c(as.character(0:9), letters)
	s <- strsplit(s,"")[[1]]
	res <- sapply(s, function(x) which(map==x))
	res <- as.vector((res-1) %*% b^((length(res)-1):0))
	return(res)
}

## example: convert 255 to hex (ff):
int2str(255, 16)

## example: convert "1a" in base 16 to integer (26):
str2int("1a", 16)


## Table 11.5, DeGroot (4th ed.)
boiling.pt <- read.csv(file = "dados_ponto_fervura.csv")
head(boiling.pt)

## Ajustando o modelo
linmod <- lm(pressao ~ pt_fervura, data = boiling.pt)
summary(linmod)

### plotting code taken from https://rstudio-pubs-static.s3.amazonaws.com/71339_d0b8346f41314979bc394448c5d60d86.html
temp_var <- predict(linmod, interval = "prediction")
new_df <- cbind(boiling.pt, temp_var)

library(ggplot2)
p0 <- ggplot(new_df, aes(pt_fervura, pressao))+
  geom_point() +
  scale_x_continuous("Ponto de fervura da água (ºF)") +
  scale_y_continuous("Pressão atmosférica (inHG)")  +
  theme_bw(base_size = 16)
p0

p1 <- p0 +
  geom_line(aes(y = lwr), color = "red", linetype = "dashed")+
  geom_line(aes(y = upr), color = "red", linetype = "dashed")+
  geom_smooth(method=lm, se = TRUE) +
  theme_bw(base_size = 16)

p1


# Example : 3   Chapter : 4.1     Page No: 197
# Rows of given matrix are perpendicular to the vector in nullspace
A<-matrix(c(1,5,3,2,4,7),nrow=2)
x<-c(1,1,-1)
for(i in 1:nrow(A)){
  dot_product<-sum(A[i,]*x)
  if(dot_product==0){
    print(paste("Row ",i,"is perpendicular to x"))
  }
}


## Bayesian online change point detection and offline learning

## Inference in joint Gaussian distribution
## Get P(X1|X2=x2) where P(X1,X2) is jointly Gaussian
## returns the conditional mean and coviance matrix of P(x_1|x_2)
##
##
## x2; numeric, an sample of X2, satisfying length(x2)<D, D is the joint dimension.
## mu: numeric, length D mean vector. mu=c(mu_X1,mu_X2)
## Precision: DxD precision matrix, satisfying Precision = inverse(Sigma). At least one of Sigma and Precision should be non-NULL
## Sigma: DxD covariance matrix. At least one of Sigma and Precision should be non-NULL.
##    Sigma = | sigma1   sigma_12 |
##            | sigma_21 sigma2   |
##
## Examples:
## tmp <- matrix(runif(100),20,5)
## S <- crossprod(tmp)                 #some synthetic covariance matrix
## P <- solve(S)
## m <- runif(5)
## x2 <- runif(3)
## inferenceJointGaussian(x2 = x2,mu = m,Precision = P)
##
inferenceJointGaussian <- function(x2,mu,Precision=NULL,Sigma=NULL){
    if(is.null(Sigma) & is.null(Precision)) stop("Error in inferenceJointGaussian(): At least one of Sigma and Precision should be non-NULL")
    if(is.null(Precision)) Precision <- solve(Sigma)
    ## get the dimensions of x_1 and x_2
    D <- nrow(Precision)
    if(D!=length(mu)) stop("Error in inferenceJointGaussian(): Dimension doesn't mathc! nrow(Precision) != length(mu)")
    D1 <- D-length(x2)                  #dimension of X1
    if(D1<=0) stop("Error in inferenceJointGaussian(): length(mu2) should be strictly smaller than D")

    P11 <- Precision[1:D1,1:D1,drop=FALSE]
    P12 <- Precision[1:D1,(D1+1):D,drop=FALSE]

    Sigma12 <- solve(P11)
    mu12 <- as.vector(mu[1:D1] - Sigma12%*%P12%*%(x2-mu[(D1+1):D]))

    list(mu12=mu12,Sigma12=Sigma12)
}

## Gaussian posterior distribution (NIW prior)
## Get P(theta|X) where X is Gaussian observations and P(theta) is NIW (Normal-Inverse-Wishart) with prior parameter m0,k0,v0,S0
## returns the posterior parameter mN,kN,vN,SN
##
## x: observation matrix, or the ones that can be converted to matrix
## w: sample weights, default NULL
## m0,k0,v0,S0: prior Inverse-Whishart parameters
##
posteriorGaussian <- function(x,w=NULL,m0,k0,v0,S0){
    x <- as.matrix(x)
    if(is.null(w)) w <- rep(1,nrow(x))
    N <- sum(w)                         #effective number of samples

    ## sample sufficient statistics
    mu <- colSums(x*w)/N                #sample mean
    x <- sweep(x,2,mu,`-`)
    S <- t(w*x)%*%x                     #sample scatter matrix centered on sample mean

    ## posterior parameters
    kN <- k0+N
    mN <- (k0*m0+N*mu)/kN
    vN <- v0+N
    SN <- S0+S+k0*N/(kN)*(mu-m0)%*%t(mu-m0)

    list(mN=mN,kN=kN,vN=vN,SN=SN,N=N)
}

## Gaussian MAP esitmate (NIW prior)
## Get theta_MAP from NIW(theta),where theta_MAP = mod(NIW(theta))
## return the MAP estimates of mu and Sigma
##
##
## m,k,v,S: NIW parameters
mapGaussian <- function(m,k,v,S){
    D <- length(m)                      #dimension
    list(muMAP=m,
         sigmaMAP=S/(v+D+2))
}

## base::det() doesn't support scalar values, so write a wrapper around it
## this function is called in marginalLikelihoodGaussian_byPosterior()
det <- function(m){
    if(is.matrix(m)){
        base::det(m)
    }else if(is.vector(m)){
        base::prod(m)
    }
}

## Marginal likelihood of Gaussian observations (NIW prior)
## return the log marginal likelihood log P(x|model)
##
## x: observation matrix, or the ones that can be converted to matrix. each row of x is an observation
##
## Examples:
## m <- c(1,2,3)
## k <- 3
## v <- 3
## S <- matrix(c(2,0.1,0.2,0.1,2,0.3,0.2,0.3,2),3,3)
## x <- mvtnorm::rmvnorm(200,mean = c(2,3,2))
## marginalLikelihoodGaussian(x = x,m0=m,k0=k,v0=v,S0=S)
##
marginalLikelihoodGaussian <- function(x,m0,k0,v0,S0,LOG=TRUE){
    x <- as.matrix(x)
    ## get the posterior parameters and sample size
    post <- posteriorGaussian(x=x,m0=m0,k0=k0,v0=v0,S0=S0)
    ## put the posteriors into marginalLikelihoodGaussian_byPosterior()
    marginalLikelihoodGaussian_byPosterior(N=post$N,
                                           mN=post$mN,
                                           kN=post$kN,
                                           vN=post$vN,
                                           SN=post$SN,
                                           m0,k0,v0,S0,LOG=LOG)
}
## Marginal likelihood of Gaussian observations (NIW prior)
## same as marginalLikelihoodGaussian(), difference is the input x is replaced by it's posteriors
marginalLikelihoodGaussian_byPosterior <- function(N,mN,kN,vN,SN,m0,k0,v0,S0,LOG=TRUE){
    ## tested, stable
    p <- length(mN)                     #dimension

    ## method 1 use the equation
    logp <- -N*p/2*log(pi) + p/2*log(k0/kN) + v0/2*log(det(S0)) - vN/2*log(det(SN)) + lmvgamma(vN/2,p) - lmvgamma(v0/2,p)
    if(!LOG) logp <- exp(logp)

    ## method 2 use the t distribution
    ## ---to be completed---

    logp
}

## calculate the weighted scatter matrix
## copied from myTools.r
scatterMatrix <- function(x,w=1,mu=NULL){
    x <- as.matrix(x)
    if(length(w)==1L) w <- rep(w,nrow(x))
    if(!is.null(mu)){
        if(length(mu)!=ncol(x)) stop("Error in scatterMatrix(): mu must be the same length of observation dimensions")
        x <- sweep(x,2,mu,`-`)
    }
    t(w*x)%*%x
}

## function wrapper for setting a weakly informed (empirical) prior
## copied from myTools.r
priorNormal <- function(x){
    x <- as.matrix(x)
    D <- ncol(x)
    list(
        m0=colMeans(x),
        k0=0.001,                       #when k=0 the MAP of mu is the MLE of mu, but k=0 will result in a Inf in dNIW(), so use a small positive number instead of 0
        v0=ncol(x)+2,
        S0=diag(diag(scatterMatrix(x=x,w=1,mu=colMeans(x)))/nrow(x),nrow = D,ncol = D))
}

## log(sum(exp(l)))
## X: a logged matrix, nrow(X) = number of samples, ncol(X) = data dimension.
## return the log-sum-exp of each row of X
logsumexp <- function(X){
    X <- as.matrix(X)
    a <- apply(X,1,max)
    log(rowSums(exp(X-a)))+a
}

## log Multivariate Gamma Function
## Reference: https://en.wikipedia.org/wiki/Multivariate_gamma_function
##
## a: numeric vector
## p: integer, the dimension
##
lmvgamma <- function(a,p){
    sapply(a,function(ai){
        p*(p-1)/4*log(pi)+ sum(lgamma(ai+(1-(1:p))/2))
    },simplify = TRUE)
}

## log P(x_t | r_t, x^{(r_t)})
## return 1. the posterior parameters for
##     univariate normal: m and S
##     multivariate normal: m and S
##     ...
## and 2. the prediction probability
##     log P(x_t | r_t, x^{(r_t)})
##
## x: numeric matrix, or an object that can be coerced to a matrix. Observation sequence, each row of x is a TRANSPOSE of an observation
## prior: prior parameters, if model = "univariate-normal" or "multivariate-gaussian", prior should be a named list: list(m0,k0,v0,S0)
##                          if model = "poisson" or "exponential", prior should be a be a named list: list(scale)
##                          if model = "gamma" or "weibull", prior should be a named list:  list(shape,scale)
##                          if model = ...
##
## Example
## x <- rnorm(1000,mean = 10,sd = 5)
## out <- bcpPrediction(x=x,model = "univariate-normal",prior = list(m0=0,k0=1.2,v0=1.1,S0=2))
## names(out)
bcpPrediction <- function(x,model=c("univariate-gaussian","multivariate-gaussian"),prior=list(m0=NULL,k0=NULL,v0=NULL,S0=NULL)){
    model <- match.arg(model)
    ## generate the posterior parameters for all data
    x <- as.matrix(x)
    nPars <- 1L:nrow(x)             #number of cache parameters per time point
    D <- ncol(x)                    #dimension
    if(model=="univariate-gaussian"){
        m0 <- prior$m0
        k0 <- prior$k0
        v0 <- prior$v0
        S0 <- prior$S0
        out <- list(m=lapply(nPars,FUN = function(l){rep(0,l)}),
                    S=lapply(nPars,FUN = function(l){rep(0,l)}),
                    logS=lapply(nPars,FUN = function(l){rep(0,l)}),
                    p=lapply(nPars,FUN = function(l){rep(0,l)}))
        k <- 1:nrow(x)+k0             #place holder for k
        v <- 1:nrow(x)+v0             #place holder for v
        out$m[[1]] <- (m0*k0 + x[1])/k[1]
        out$S[[1]] <- S0+ x[1]^2+ k0*(m0^2) - k[1]*(out$m[[1]]^2)
        out$logS[[1]] <- log(out$S[[1]])                                  #temporary variable, log(S) is used in calculating the predicted probability
        logs0 <- log(S0)                                                  #constant number log(S0)
        d2logpi <- -D/2 * log(pi)                                         #constant number -D/2 * log(pi)
        logkii <- D/2 * log(c(k0,k[1L:(nrow(x)-1L)])/k)                   #constant vector D/2 * log(k_{i-1}/k_i)
        vi2 <- c(v0,v[1L:(nrow(x)-1L)])/2                                 #constant vector v_{i-1}/2
        v2 <- v/2                                                         #constant vector v_i/2
        loggammavii <- lgamma(v2) -lgamma(vi2)                            #constant vector lmvGamma(v_i/2) - lmvGamma(v_{i-1}/2)
        out$p[[1]] <- d2logpi + logkii[1] + vi2[1] * logs0 - v2[1]*out$logS[[1]] + loggammavii[1]
        if(nrow(x)>=2){
            for(i in nPars[-1L]){
                out$m[[i]] <- c((m0*k0 + x[i])/k[1],
                (out$m[[i-1]]*k[1L:(i-1L)] + x[i]) / k[2L:i])
                out$S[[i]] <- c(S0+ x[i]^2+ k0*(m0^2) - k[1]*(out$m[[i]][1]^2),
                                out$S[[i-1]]+ x[i]^2+ k[1L:(i-1L)]*(out$m[[i-1]]^2) - k[2L:i] * (out$m[[i]][-1]^2))
                out$logS[[i]] <- log(out$S[[i]])
                ## -D/2 log(pi) + D/2 log(k_{i-1}/k_i) + v_{i-1}/2 log(|S_{i-1}|) - v_i/2 log(|S_i|) + lmvGamma(v_i/2) - lmvGamma(v_{i-1}/2)
                out$p[[i]] <- d2logpi + logkii[1L:i] + vi2[1L:i] * c(logs0,out$logS[[i-1]]) - v2[1L:i]*out$logS[[i]] + loggammavii[1L:i]
            }
        }
    }else if(model=="multivariate-gaussian"){
        ## out <- list(m=lapply(nPars,FUN = function(l){matrix(0,l,D)}),
        ##             S=lapply(nPars,FUN = function(l){array(0,dim = c(l,D,D))}))
        stop("multivariate-gaussian observation not supported yet")
    }

    return(out)
}

## loglikelihood for Left Truncated and Right Censored data
## return:
##  log P(q+1|q) = log S(q+1) - log S(q)  and
##  log P(0|q) = log f(q+1) - log S(q)
##  as an nx2 matrix, n is the number of inputs, the first column is log P(q+1|q), second column is log P(0|q)
## q: numeric vector
## model.pars: parameters for the selected model
##             weibull: shape parameter and scale parameter()
##
## Example
## logLTRC(1:10,shape = 2,scale = 10)
logLTRC <- function(q,cpt_model=c("weibull","gamma","exponential"),shape=NULL,scale=NULL){
    cpt_model <- match.arg(cpt_model)
    if(cpt_model=="weibull"){
        ## lower.tail=FALSE is the survival function

        ## ## when assuming p(0|i) is dead at time t+1
        ## matrix(c(pweibull(q+1,shape=shape,scale=scale,lower.tail = FALSE,log.p = TRUE),dweibull(q+1,shape=shape,scale=scale,log = TRUE))-
        ##        pweibull(q,shape=shape,scale=scale,lower.tail = FALSE,log.p = TRUE),ncol = 2)

        ## ## when assuming p(0|i) is dead at time (t,t+1]
        out <- matrix(0,nrow = length(q),ncol = 2)
        out[,1] <- pweibull(q+1,shape=shape,scale=scale,lower.tail = FALSE,log.p = TRUE)-pweibull(q,shape=shape,scale=scale,lower.tail = FALSE,log.p = TRUE)
        out[,2] <- log(-expm1(out[,1])) #IMPORTANT if use log(1-exp(out[,1])) will result in log(0) in some of the parameter settings, to avoid underflow, use expm1(x) to replace exp(x)-1
        out
    }else if(cpt_model=="gamma"){
       stop("In LTRC(): ",cpt_model," not supported yet!")
    }else if(cpt_model=="exponential"){
        stop("In LTRC(): ",cpt_model," not supported yet!")
    }else{
        stop("In LTRC(): ",cpt_model," not supported yet!")
    }
}

## generate random shape and scale sample, for the change point distribution
## when cpt_model = "weibull"
##      gamma distribution with prior parameter shape and scale for inverse-scale parameter
##      uniform distribution with prior start and end for shape parameter
## other cpt_model are not yet supported
rcpt <- function(cpt_model=c("weibull","gamma","exponential"),cpt_prior=list()){
    cpt_model <- match.arg(cpt_model)
    if(cpt_model=="weibull"){
        shape=runif(1,cpt_prior$start,cpt_prior$end)
        scale = 1/rgamma(1,cpt_prior$shape,cpt_prior$scale) #since gamma is for inverse-scale, now I need to inverse it back
        c(shape,scale)
    }else{
        stop("In rcpt(): ",cpt_model," not supported yet!")
    }
}

## constructor of a "bcp" object, used in offline learning
## use S3 with environment to achieve "pass by reference"
##
## x: numeric matrix, or an object that can be coerced to a matrix. Observation sequence, each row of x is a TRANSPOSE of an observation
## breaks: the ending index of each segments. breaks = NULL is equivalent to breaks = nrow(x)
## cpt_model: name of the change point distribution
## obs_model: name of the observation distribution
## obs_prior: prior parameters for observation model
##                  if obs_model = "univariate-normal" or "multivariate-gaussian", prior should be a named list: list(m0,k0,v0,S0)
##                  if obs_model = "poisson" or "exponential", prior should be a be a named list: list(scale)
##                  if obs_model = "gamma" or "weibull", prior should be a named list:  list(shape,scale)
##                  if obs_model = ...
## shape: initial shape parameter for change point distribution, no need to specify
## scale: initial scale parameter for change point distribution, no need to specify
bcp <- function(x=NULL,breaks=NULL,cpt_model=c("weibull","gamma","exponential"),obs_model=c("univariate-gaussian","multivariate-gaussian","multinomial","poisson","exponential","gamma","linear"),obs_prior=list(),cpt_prior=list(),shape=NULL,scale=NULL){

    cpt_model <- match.arg(cpt_model)
    obs_model <- match.arg(obs_model)

    object <- new.env(parent=globalenv())

    x <- as.matrix(x)
    object$x <- x

    if(is.null(breaks)){
        object$breaks <- c(0,nrow(x))
        object$Nsegs <- 1               #number of segments
        object$segLengths <- nrow(x)    #length of each segment
    }else{
        if(any(breaks<=0 | breaks > nrow(x)) | is.unsorted(breaks)) stop("Error in bcp(): values in 'breaks' has to be ordered and range between [1,nrow(x))")
        object$breaks <- c(0,breaks)
        object$Nsegs <- length(object$breaks)-1
        object$segLengths <- diff(object$breaks)
    }

    object$nPars <- numeric(0)             #number of unique run-lengths per time point
    for(i in 1:object$Nsegs)
        object$nPars <- c(object$nPars,1:object$segLengths[i])
    object$D <- ncol(x)                    #dimension
    object$T <- nrow(x)

    object$maxRun <- max(diff(object$breaks)) #maximum run length

    if(is.null(shape) & is.null(scale)){
        ss <- rcpt(cpt_model = cpt_model,cpt_prior = cpt_prior)
        object$shape <- ss[1]
        object$scale <- ss[2]
    }else if(!is.null(shape) & !is.null(scale)){
        object$shape <- shape
        object$scale <- scale
    }else{
        stop("Error in bcp(): shape and scale should both be NULL of non-NULL")
    }
    object$cpt_model <- cpt_model
    object$obs_model <- obs_model
    object$obs_prior <- obs_prior
    object$cpt_prior <- cpt_prior

    ## generate lower/upper search bound for L-BFGS-B algorithm
    if(cpt_model=="weibull"){
        object$lower <- c(cpt_prior$start,1e-7)
        object$upper <- c(cpt_prior$end,qgamma(0.99999999,shape = cpt_prior$shape,scale=cpt_prior$scale))
        ## object$upper <- c(cpt_prior$end,500)
    }else{
        stop("In bcp(): ",cpt_model," not supported yet!")
    }

    class(object) <- 'bcp'

    return(object)

}

## offline forward filtering
## x: numeric matrix, or an object that can be coerced to a matrix. Observation sequence, each row of x is a TRANSPOSE of an observation
## cpt_model: name of the change point distribution
## shape: shape parameter for change point distribution
## scale: scale parameter for change point distribution
## obs_model: name of the observation distribution
## obs_prior: prior parameters for observation model
##                  if obs_model = "univariate-normal" or "multivariate-gaussian", prior should be a named list: list(m0,k0,v0,S0)
##                  if obs_model = "poisson" or "exponential", prior should be a be a named list: list(scale)
##                  if obs_model = "gamma" or "weibull", prior should be a named list:  list(shape,scale)
##                  if obs_model = ...
bcpFiltering <- function(bcpObj,...) UseMethod("bcpFiltering")
bcpFiltering.bcp <- function(bcpObj){
    ## if(nrow(bcpObj$x)<2) stop("Error in bcpFiltering(): there should be at least 2 observations")

    bcpObj$a <- lapply(bcpObj$nPars,FUN = function(l){rep(0,l)}) #place holder for filtered result
    ## generate the transition matrix
    ## first column: P(q+1|q), second column: P(0|q)
    bcpObj$transition <- logLTRC(0L:(bcpObj$maxRun-1L),cpt_model = bcpObj$cpt_model,shape = bcpObj$shape,scale=bcpObj$scale)
    bcpObj$transition <- exp(bcpObj$transition)

    ## generate the prediction probability: log P(x_t | r_t, x^{(r_t)})
    bcpObj$pxr <- list()
    for(s in 1:bcpObj$Nsegs){
        bcpObj$pxr <- c(bcpObj$pxr,bcpPrediction(x=bcpObj$x[(bcpObj$breaks[s]+1):bcpObj$breaks[s+1],,drop=FALSE],model = bcpObj$obs_model,prior = bcpObj$obs_prior)$p) #only log probability is needed, so append a "$p" at the end
    }
    bcpObj$pxr_exp <- lapply(bcpObj$pxr,exp) #not log version

    tmp <- 0                            #temporary variable
    LL <- 0
    start <- 0                          #starting location of each segment
    for(s in 1:bcpObj$Nsegs){
        start <- bcpObj$breaks[s]
        bcpObj$a[[start+1]] <- 1
        LL <- LL+ bcpObj$pxr[[start+1]]               #observed data log likelihood
        for(i in 2:bcpObj$segLengths[s]){
            bcpObj$a[[start+i]] <- log(c(sum(bcpObj$transition[1:(i-1),2]*bcpObj$a[[start+i-1]]),bcpObj$transition[1:(i-1),1]*bcpObj$a[[start+i-1]]))+
                bcpObj$pxr[[start+i]]
            tmp <- logsumexp(matrix(bcpObj$a[[start+i]],nrow = 1)) #normalizing constant of the filtering process, which happens to be log P(x_t|x_1:t-1)
            LL <- LL+tmp
            bcpObj$a[[start+i]] <- bcpObj$a[[start+i]]-tmp
            bcpObj$a[[start+i]] <- exp(bcpObj$a[[start+i]])
        }
    }

    ## add prior likelihood
    if(bcpObj$cpt_model=="weibull"){
        logprior <- dunif(bcpObj$shape,min = bcpObj$cpt_prior$start,max = bcpObj$cpt_prior$end,log = TRUE)+
            dgamma(bcpObj$scale,shape = bcpObj$cpt_prior$shape,scale = bcpObj$cpt_prior$scale,log = TRUE)
    }else{
        stop("In bcpEM.bcp().obj(): ",bcpObj$cpt_model," not supported yet!")
    }

    LL <- LL+logprior

    ## append resuts to bcp object
    bcpObj$LL <- LL
}

## offline forward filtering and backward smoothing
bcpSmoothing <- function(bcpObj,...) UseMethod("bcpSmoothing")
bcpSmoothing.bcp <- function(bcpObj){
    ## ----------------first part same as bcpFiltering----------------
    ## ---forward filtering---
    bcpFiltering(bcpObj)

    ## ---backward smoother---
    bcpObj$b <- lapply(bcpObj$nPars,FUN = function(l){rep(0,l)}) #place holder for backward result
    bcpObj$g <- lapply(bcpObj$nPars,FUN = function(l){rep(0,l)}) #place holder for smoothed result
    ## invisible(gc)
    start <- 0                          #starting location of each segment
    for(s in 1:bcpObj$Nsegs){
        start <- bcpObj$breaks[s]
        ## end <- bcpObj$breaks[s+1]
        bcpObj$b[[bcpObj$breaks[s+1]]] <- rep(1,bcpObj$segLengths[s])
        bcpObj$g[[bcpObj$breaks[s+1]]] <- bcpObj$a[[bcpObj$breaks[s+1]]]
        for(i in (bcpObj$segLengths[s]-1):1){
            ## transition: first column: P(q+1|q), second column: P(0|q)
            bcpObj$b[[start+i]] <- bcpObj$transition[1:i,1] * bcpObj$pxr_exp[[start+i+1]][-1] * bcpObj$b[[start+i+1]][-1]+
                bcpObj$transition[1:i,2] * bcpObj$pxr_exp[[start+i+1]][1]  * bcpObj$b[[start+i+1]][1]
            bcpObj$b[[start+i]] <- bcpObj$b[[start+i]]/sum(bcpObj$b[[start+i]])    #normalize to make sure it won't underflow
            bcpObj$g[[start+i]] <- bcpObj$b[[start+i]]*bcpObj$a[[start+i]]
            bcpObj$g[[start+i]] <- bcpObj$g[[start+i]]/sum(bcpObj$g[[start+i]])
        }
    }
}

## Two slice likelihoods, and filtered and smoothed
bcpTwoslice <- function(bcpObj,...) UseMethod("bcpTwoslice")
bcpTwoslice.bcp <- function(bcpObj){
    bcpSmoothing(bcpObj)

    ## can be see as a aparse version of the twoslice matrix
    ## because t in 1:T-1, so run length are in 0:T-2, i.e. T-1 unique different run lengths
    bcpObj$pii <- matrix(0,nrow = bcpObj$maxRun-1,ncol=2) #place holder for transition counts
    for(s in 1:bcpObj$Nsegs){
        start <- bcpObj$breaks[s]
        for(i in 1:(bcpObj$segLengths[s]-1)){
            ## tansition: first column: P(q+1|q), second column: P(0|q)
            tmp <- bcpObj$transition[1:i,,drop=FALSE] * bcpObj$a[[start+i]]
            tmp[,1] <- tmp[,1] * bcpObj$b[[start+i+1]][-1] * bcpObj$pxr_exp[[start+i+1]][-1]
            tmp[,2] <- tmp[,2] * bcpObj$b[[start+i+1]][1] * bcpObj$pxr_exp[[start+i+1]][1]
            tmp <- tmp/sum(tmp) #normalize
            bcpObj$pii[1:i,] <- bcpObj$pii[1:i,] + tmp     #the transition counts
        }
    }

}

## Offline learning with exact method
## use generalized EM algorithm
##
## nstart: number of random restarts
## maxit: maximum number of EM iterations for each (re)start
## deps: converge if LL-previousLL<deps
##
bcpEM <- function(bcpObj,maxit=100,deps=1e-4,nstart=10L) UseMethod("bcpEM")
bcpEM.bcp <- function(bcpObj,maxit=100,deps=1e-4,nstart=10L){
    obj <- function(ss){
        if(bcpObj$cpt_model=="weibull"){
            logprior <- dunif(ss[1],min = bcpObj$cpt_prior$start,max = bcpObj$cpt_prior$end,log = TRUE)+
                dgamma(ss[2],shape = bcpObj$cpt_prior$shape,scale = bcpObj$cpt_prior$scale,log = TRUE)
        }else{
            stop("In bcpEM.bcp().obj(): ",bcpObj$cpt_model," not supported yet!")
        }
        ## optim is to minimize, so add an minus sign
        -sum(bcpObj$pii*logLTRC(0L:(bcpObj$maxRun-2L),cpt_model = bcpObj$cpt_model,shape = ss[1],scale=ss[2]))-logprior
    }

    maxLL <- -Inf                       #overall maximum likelihood
    LLs <- rep(0,nstart)
    bcpObj$MAP <- rep(0,0)                     #place holder for MAP shape and scale
    for(start in 1L:nstart){
        ## reset starting values since the second round(first round aleady has a starting value)
        if(start>=2){
            ss <- rcpt(cpt_model = bcpObj$cpt_model,cpt_prior = bcpObj$cpt_prior)
            bcpObj$shape <- ss[1]
            bcpObj$scale <- ss[2]
        }

        ## main EM loop start --------------------------------
        it <- 0
        maxLLit <- -Inf                 #current maximum likelihood/postori
        while(it <= maxit){
            ## 1. E step-------------------------------
            ## filter, smoother and twoslice
            bcpTwoslice(bcpObj)
            ## if(bcpObj$LL-maxLLit< -deps){
            if(bcpObj$LL < maxLLit){
                cat("diff",bcpObj$LL-maxLLit,"\n")
                stop("decreasing likelihood, LL: ",bcpObj$LL) #some numerical error is irreducible
            }
            else if(bcpObj$LL-maxLLit<deps) break
            else maxLLit <- bcpObj$LL
            ## 2. M step------------------------------
            ## objective
            newSS <- optim(par = c(bcpObj$shape,bcpObj$scale),fn = obj,method = "L-BFGS-B",lower = bcpObj$lower,upper = bcpObj$upper)$par
            cat("iteration:",it,"  LL:",bcpObj$LL,"\n")
            cat("shape:",bcpObj$shape,"  scale:",bcpObj$scale,"\n")
            bcpObj$shape <- newSS[1]
            bcpObj$scale <- newSS[2]
            it <- it+1
        }
        ## main EM loop end --------------------------------

        if(maxLLit > maxLL){
            maxLL <- maxLLit
            bcpObj$MAP <- c(bcpObj$shape,bcpObj$scale) #get the best MAP estimate
        }
    }

}

bcpMCMC <- function(bcpObj,burnin=100,nSample=5000) UseMethod("bcpMCMC")
bcpMCMC.bcp <- function(bcpObj,burnin=100,nSample=5000){
}

## constructor of a "bcpo" object, used in online filtering
## use S3 with environment to achieve "pass by reference"
##
## cpt_model: name of the change point distribution
## shape: shape parameter for change point distribution
## scale: scale parameter for change point distribution
## obs_model: name of the observation distribution
## obs_prior: prior parameters for observation model
##                  if obs_model = "univariate-normal" or "multivariate-gaussian", prior should be a named list: list(m0,k0,v0,S0)
##                  if obs_model = "poisson" or "exponential", prior should be a be a named list: list(scale)
##                  if obs_model = "gamma" or "weibull", prior should be a named list:  list(shape,scale)
##                  if obs_model = ...
## l: inference lag, bcpOline will perform online filtering when when l=0, smoothing when l = Inf, fixed lag smoothing when 0<l<Inf. Default 0, filtering.
##
bcpo <- function(shape=NULL,scale=NULL,cpt_model=c("weibull","gamma","exponential"),obs_model=c("univariate-gaussian","multivariate-gaussian","multinomial","poisson","exponential","gamma","linear"),obs_prior=list(),cpt_prior=list(),l=0){

    cpt_model <- match.arg(cpt_model)
    obs_model <- match.arg(obs_model)

    object <- new.env(parent=globalenv())

    if(is.null(shape) & is.null(scale)){
        ss <- rcpt(cpt_model = cpt_model,cpt_prior = cpt_prior)
        object$shape <- ss[1]
        object$scale <- ss[2]
    }else if(!is.null(shape) & !is.null(scale)){
        object$shape <- shape
        object$scale <- scale
    }else{
        stop("Error in bcpo(): shape and scale should both be NULL of non-NULL")
    }
    object$cpt_model <- cpt_model
    object$obs_model <- obs_model
    object$obs_prior <- obs_prior
    object$cpt_prior <- cpt_prior

    object$x <- NULL
    object$T <- 0L

    ## place holder for filtered/smoothing result and evidence likelihood
    object$a <- list()
    object$pxr <- list()
    object$pxr_exp <- list()

    ## place holder for changepoint probability
    object$pCPT <- numeric()

    ## place holder for changepoint indicator
    object$isCPT <- numeric()

    ## most recent posteriors
    if(obs_model %in% c("univariate-gaussian","multivariate-gaussian")){
        object$prePost <- list(m=list(obs_prior$m0),
                               k=obs_prior$k0,
                               v=obs_prior$v0,
                               S=list(obs_prior$S0))
    }else{
        stop("In bcpo(): ",obs_model," not supported yet!")
    }

    ## generate lower/upper search bound for L-BFGS-B algorithm
    if(cpt_model=="weibull"){
        object$lower <- c(cpt_prior$start,1e-7)
        object$upper <- c(cpt_prior$end,qgamma(0.99999999,shape = cpt_prior$shape,scale=cpt_prior$scale))
        ## object$upper <- c(cpt_prior$end,500)
    }else{
        stop("In bcpo(): ",cpt_model," not supported yet!")
    }

    object$l <- as.integer(l)                       #inference lag

    ## tracker for most recent filter/smoother index
    ## bcpOnline will only calculate the filter status between filterTracker and T
    ## bcpOnline will only calculate the (fixed-lag)smoother status between smootherTracker and T-l
    object$filterTracker <- 0L
    object$smootherTracker <- 0L

    object$transition <- matrix(numeric(),ncol = 2)

    class(object) <- 'bcpo'

    return(object)

}

## attach new observation(s) to an bcpo object
## newObs: numeric matrix of at least 1 row, or an object that can be coerced to a matrix.
## bcpoObj: an bcpo object
bcpoAttach <- function(bcpoObj,newObs) UseMethod("bcpoAttach")
bcpoAttach.bcpo <- function(bcpoObj,newObs){
    newObs <- as.matrix(newObs)

    if(is.null(bcpoObj$x)){
        bcpoObj$x <- newObs
    }else{
        bcpoObj$x <- rbind(bcpoObj$x,newObs)
    }

    currentMaxRun <- bcpoObj$T+nrow(newObs)-1L
    ## transition matrix P(r_i | r_{i-1})
    bcpoObj$transition <- rbind(bcpoObj$transition,
                                exp(logLTRC(bcpoObj$T:currentMaxRun,cpt_model = bcpoObj$cpt_model,shape = bcpoObj$shape,scale=bcpoObj$scale)))
    bcpoObj$T <- currentMaxRun+1L

    ## prediction probability log P(x_t | r_t, x^{(r_t)})
    ## and update posteriors
    if(bcpoObj$obs_model %in% c("univariate-gaussian","multivariate-gaussian")){
        for(i in 1:nrow(newObs)){                   #for each obs
            m <- list()
            S <- list()
            px <- numeric(length(bcpoObj$prePost$k))
            for(j in 1:length(bcpoObj$prePost$k)){                          #for each prior combination
                tmp <- posteriorGaussian(x=newObs[i,,drop=FALSE],m0=bcpoObj$prePost$m[[j]],k0=bcpoObj$prePost$k[[j]],v0=bcpoObj$prePost$v[[j]],S0=bcpoObj$prePost$S[[j]])
                m[[j]] <- tmp$mN
                S[[j]] <- tmp$SN
                px[j] <- marginalLikelihoodGaussian_byPosterior(N=tmp$N,
                              mN = tmp$mN,kN = tmp$kN,vN = tmp$vN,SN = tmp$SN,
                              m0 = bcpoObj$prePost$m[[j]],k0 = bcpoObj$prePost$k[[j]],v0 = bcpoObj$prePost$v[[j]],S0=bcpoObj$prePost$S[[j]],LOG = TRUE)
            }
            bcpoObj$prePost$k <- c(bcpoObj$obs_prior$k0,bcpoObj$prePost$k+1)
            bcpoObj$prePost$v <- c(bcpoObj$obs_prior$v0,bcpoObj$prePost$v+1)
            bcpoObj$prePost$m <- c(list(bcpoObj$obs_prior$m0),m)
            bcpoObj$prePost$S <- c(list(bcpoObj$obs_prior$S0),S)
            bcpoObj$pxr <- c(bcpoObj$pxr,list(px))
            bcpoObj$pxr_exp <- c(bcpoObj$pxr_exp,list(exp(px)))
        }
    }

}

## Online change point detection
##
## bcpoObj: an object of class "bcpo"
## newObs: an new observation, must be a matrix of at least one row, or anything that be converted to a matrix.
##
## attach the probability of change point bcpoObj$pCPT and the change point indicator bcpoObj$isCPT of each time index to bcpoObj
bcpOnline <- function(bcpoObj,newObs) UseMethod("bcpOnline")
bcpOnline.bcpo <- function(bcpoObj,newObs){
    newObs <- as.matrix(newObs)
    bcpoAttach(bcpoObj,newObs)           #attach new observation
    ## online filter ----------------------------------------
    magneticHead <- 0
    while(bcpoObj$T > bcpoObj$filterTracker){
        magneticHead <- bcpoObj$filterTracker+1L
        if(magneticHead==1){
            bcpoObj$a[[1]] <- 1
            bcpoObj$filterTracker <- magneticHead
            bcpoObj$pCPT <- 1
            bcpoObj$isCPT <- TRUE
            next
        }
        bcpoObj$a[[magneticHead]] <- log(c(sum(bcpoObj$transition[1:(magneticHead-1),2]*bcpoObj$a[[magneticHead-1]]),bcpoObj$transition[1:(magneticHead-1),1]*bcpoObj$a[[magneticHead-1]])) + bcpoObj$pxr[[magneticHead]]
        bcpoObj$a[[magneticHead]] <- bcpoObj$a[[magneticHead]]-logsumexp(matrix(bcpoObj$a[[magneticHead]],nrow = 1)) #minus the logsumexp to normalize
        bcpoObj$a[[magneticHead]] <- exp(bcpoObj$a[[magneticHead]])
        bcpoObj$filterTracker <- magneticHead
        bcpoObj$pCPT <- c(bcpoObj$pCPT,bcpoObj$a[[magneticHead]][1]) #attach change point probability
        bcpoObj$isCPT <- c(bcpoObj$isCPT,which.max(bcpoObj$a[[magneticHead]])==1)
    }

    ## online fixed-lag smoother ----------------------------
    magneticHead <- 0
    magneticEnd <- 0
    while(bcpoObj$smootherTracker < (bcpoObj$T-bcpoObj$l) & bcpoObj$l > 0L){
        magneticHead <- bcpoObj$smootherTracker+1L
        magneticEnd <- bcpoObj$smootherTracker+1L+bcpoObj$l
        bPre <- rep(1,magneticEnd)       #the last backward info
        ## pass backward info
        for(i in (magneticEnd-1L):magneticHead){
            b <- bcpoObj$transition[1:i,1] * bcpoObj$pxr_exp[[i+1]][-1] * bPre[-1]+
                bcpoObj$transition[1:i,2] * bcpoObj$pxr_exp[[i+1]][1]  * bPre[1]
            b <- b/sum(b)    #normalize to make sure it won't underflow
            bPre <- b
        }
        ## merge with forward info
        bcpoObj$a[[magneticHead]] <- b*bcpoObj$a[[magneticHead]] #merge backward info into a
        bcpoObj$a[[magneticHead]] <- bcpoObj$a[[magneticHead]]/sum(bcpoObj$a[[magneticHead]])
        bcpoObj$smootherTracker <- magneticHead
        bcpoObj$pCPT[magneticHead] <- bcpoObj$a[[magneticHead]][1] #update the believe of the lagged change point probability
        bcpoObj$isCPT[magneticHead] <- which.max(bcpoObj$a[[magneticHead]])==1 #update the changepoint ideicator
    }

}


# If we list all the natural numbers below 10 that are multiples of 3 or 5,
# we get 3, 5, 6 and 9. The sum of these multiples is 23.

# Find the sum of all the multiples of 3 or 5 below 1000.

# Gives remainder when x is divided by y
rem <- function(x, y) {
  a <- (x / y)
  b <- floor(a)
  diff <- a - b
  return(diff* y)
}

# Takes two numbers and returns true if x is a multiple of y
mo <- function(x, y) {
  r <- rem(x, y)
  return(r == 0)
}

nums <- 1:999
fun1 <- function(x) { return (mo(x,3) || mo(x,5)) }
indexes <- sapply(nums, fun1)
sum(nums[indexes])


d1<- function(S,K,t,r,sig) {
  ans <- (log(S/K) + (r + sig^2/2)*t) / (sig*sqrt(t))
  return(ans)
}

d2 <- function(S,K,t,r,sig) {
  return(d1(S,K,t,r,sig) - sig*sqrt(t))
}

Call <- function(S,K,t,r,sig) {
  d_1 <- d1(S,K,t,r,sig)
  d_2 <- d2(S,K,t,r,sig)
  return(S*pnorm(d_1) - K*exp(-r*t)*pnorm(d_2))
}

print(d1(300,250,1,0.03,0.15))
microbenchmark::microbenchmark(Call(300,250,1,0.03,0.15))


# 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 : 3.4C   Chapter : 3.4     Page No: 162
# Find the Complete solution of the given system

library(pracma)
completesolution <- function(A,b){
  R<-rref(A)
  m<-nrow(A)
  n<-ncol(A)
  pivotcol<-c() #vector to store the column numbers of pivot columns
  freecol<-c()  #vector to store the column numbers of free columns
  i<-1
  j<-1

  # to find which columns are pivot and which are free
  while(i<=m & j<=n){
    if(R[i,j]==1){
      pivotcol<-c(pivotcol,j)
      i<-i+1
      j<-j+1
    }
    else{
      j<-j+1
    }
  }
  y<-length(pivotcol)
  freecol<-c(1:n)
  freecol<-freecol[!freecol%in%pivotcol]
  x<-length(freecol)
  N<-c()
  #find the basis for null space based on Row reduced echelon form of given matrix
  if(y==n){
    N<-c()
  }
  for(i in 1:x){
    temp<-c(1:n)
    for(j in 1:x){
      temp[freecol[j]]<-0
    }
    temp[freecol[i]]<-1
    temp[freecol[i]]
    for(j in 1:y){
      temp[pivotcol[j]]<-R[j,freecol[i]]*-1
    }
    N<-c(N,temp)
  }
  N<-matrix(N,nrow=n,ncol=x)
  s<-N
  Ab<-cbind(A,b)
  Rd<-rref(Ab)
  temp<-Rd[,n+1]
  p<-c(1:n)
  for(i in 1:length(freecol)){
    p[freecol[i]]<-0
  }
  for(i in 1:length(pivotcol)){
    p[pivotcol[i]]<-temp[i]
  }
  print("The special solution is")
  print(s)
  print("The particular solution is")
  print(p)
  print("Complete solution = particular solution + Special solution")
}
A<-matrix(c(1,2,4,2,4,8,1,4,6,0,8,8),nrow=3)
b<-c(4,2,10)
completesolution(A,b)


=begin
  # sample-galois-group01.rb

  require "algebra/rational"
  require "algebra/polynomial"

  P = Algebra.Polynomial(Rational, "x")
  x = P.var

  (x**3 - 3*x + 1).galois_group.each do |g|
    p g
  end
  #=> [0, 1, 2]
  #   [1, 2, 0]
  #   [2, 0, 1]]

  (x**3 - x + 1).galois_group.each do |g|
    p g
  end
  #=> [0, 1, 2]
  #   [1, 0, 2]
  #   [2, 0, 1]
  #   [0, 2, 1]
  #   [1, 2, 0]
  #   [2, 1, 0]
((<_|CONTENTS>))
=end


# Above Ground Biomass estimation
#
# Estimate above ground biomass following Chave et al. (2005)
#
# Chave, J. et al. 2005. Tree allometry and improved estimation of carbon
#   stocks and balance in tropical forests. - Oecologia 145: 87–99.
#

estbiomass <- function(ro, h=NULL, dhb=NULL, chb=NULL, type=NULL){

  if (is.null(chb) & is.null(dhb)) { stop("chb or dhb must be defined\n") }
  if (!is.null(chb) & is.null(dhb)) { dhb <- chb/pi }
  if (missing(ro)) { stop("ro must be defined\n") }
  if (!(type %in% c("dry","moist","mangrove","wet"))){
    stop("type must be defined as: 'dry', 'moist', 'mangrove' or 'wet'\n")
  }

  if (!is.null(h)){
    out <- switch(type,
                  dry =  exp(-2.187 + 0.916 * log(ro * (dhb^2) * h)),
                  moist = exp(-2.977 + log(ro * (dhb^2) * h)),
                  mangrove = exp(-2.977 + log(ro * (dhb ^ 2) * h)),
                  wet = exp(-2.557 + 0.940 * log(ro * (dhb^2) * h)))
  } else {
    out <- switch(type,
                  dry =  (ro * exp(-0.667 + (1.784 * log(dhb)) + (0.207 * (log(dhb) ^ 2)) - (0.0281 * (log(dhb) ^ 3)))),
                  moist = (ro * exp(-1.449 + (2.148 * log(dhb)) + (0.207 * (log(dhb) ^ 2)) - (0.0281 * (log(dhb) ^ 3)))),
                  mangrove = (ro * exp(-1.349 + (1.980 * log(dhb)) + (0.207 * (log(dhb) ^ 2)) - (0.0281 * (log(dhb) ^ 3)))),
                  wet = (ro * exp(-1.239 + (1.980 * log(dhb)) + (0.207 * (log(dhb) ^ 2)) - (0.0281 * (log(dhb) ^ 3)))))
  }

  return(out)
}


euclidean <- function(a, b) sqrt(sum((a - b) ^ 2))

rectKernel <- function(dist, h) if (dist <= h) 0.5 else 0

trKernel <- function(dist, h) if (dist <= h) (h - dist) / h else 0

epKernel <- function(dist, h) if (dist <= h) (1 - dist ^ 2) * 0.75 else 0

gaussKernel <- function(dist, h) exp(sqrt(h / pi * 0.5) * -0.5 * (dist * h) ^ 2)

kvKernel <-function(dist, h) if (dist <= h) 15 / 16 * (1 - (dist / h) ^ 2) ^ 2 else 0

parzen <- function(dset, labels, point, h, kernel, dist = euclidean) {
  dsetLength <- length(dset[,1])
  distances <- array(dim = c(dsetLength))

  uLabels <- unique(labels)
  # print("LABBB")
  # print(apply(uLabels, 1, paste))
  classScores <- array(0L, dim = c(length(uLabels)))
  names(classScores) = uLabels;
  classScores["undefined"] <- 0.000001

  for (i in 1:dsetLength) {
    classScores[labels[i]] <- classScores[labels[i]] + kernel(dist(point, dset[i,]), h)
  }

  return(names(which.max(classScores)))
}

generateMaps <- function() {
  xs <- seq(from = 0.5, to = 7.5, by = 0.1)
  ys <- seq(from = -1, to = 3.5, by = 0.1)

  colors <- c("setosa" = "blue", "virginica" = "red", "versicolor" = "green", "undefined" = "grey")

  kernels <- c("rect" = rectKernel, "tr" = trKernel, "ep" = epKernel, "gauss" = gaussKernel, "kv" = kvKernel)

  # par(mfrow = c(length(kernels) / 2, 2), pty="s", mar=c(1,1,1,1))

  index <- 1
  for (kernelName in names(kernels)) {
    kernel <- kernels[[kernelName]]
    png(sprintf("plot-%03d.png", index), width = 1024, height = 700, unit = "px", pointsize = 20)
    cat("Kernel:", kernelName, index, "of", length(kernels), "\n")
    index <- index + 1
    plot(iris[, 3:4], col = colors[paste(iris$Species)], pch=16, asp=1)

    all <- length(xs) * length(ys)
    progress = 1
    for (i in xs) {
      for (j in ys) {
        cat("\rProcessing point", progress, "of", all)
        progress <- progress + 1
        result <- parzen(iris[3:4], paste(iris$Species), c(i, j), 0.4, kernel)
        points(i, j, col = colors[result], pch = 21)
      }
    }
    cat("\rDone.                      \n")
    dev.off()
  }
}

parzen_loo <- function (dset, labels, kernel, hs) {
  dsetLen <- dim(dset)[1]
  hLen <- length(hs)
  ans <- array(0L, dim = c(hLen))

  for (i in 1:hLen) {
    cat("h:", hs[i], "index:", i, "of", hLen, "\n")
    for (j in 1:dsetLen) {
      cat("\rProcessing sample", j, "of", dsetLen)
      tmpRes <- parzen(dset[-j,], labels[-j], dset[j,], hs[i], kernel)
      if (tmpRes != paste(labels[j])) {
        ans[i] <- ans[i] + 1
      }
    }
    print(ans)
  }

  ans <- ans / dsetLen
  return (ans)
}

generateLoos <- function() {
  kernels <- c("tr" = trKernel, "ep" = epKernel, "gauss" = gaussKernel, "kv" = kvKernel)
  hs <- seq(from = 0, to = 6, by = 0.2)

  index <- 1
  for (kernelName in names(kernels)) {
    kernel <- kernels[[kernelName]]
    png(sprintf("loo-%03d.png", index), width = 1324, height = 700, unit = "px", pointsize = 20)
    cat("Kernel:", kernelName, index, "of", length(kernels), "\n")
    index <- index + 1

    loo <- parzen_loo(iris[3:4], iris$Species, kernel, hs)
    plot(hs, loo, type="l", xlab="h", ylab="LOO")
    points(hs[which.min(loo)], loo[which.min(loo)], pch = 19, col = "red")
    text(hs[which.min(loo)], loo[which.min(loo)] + 0.05, paste("best:", hs[which.min(loo)]))

    cat("\rDone.                      \n")
    dev.off()
  }
}

# generateLoos()
generateMaps()

#parzen(iris[3:4], paste(iris$Species), c(4, 1), 0.4, rectKernel)


# Master Thesis Project - Extreme Value Theory
# We assume that the stock prices follow a geometric
# Brownian motion (Black-Scholes model). We plot the
# empirical stock price data as well as the simulated
# geometric Brownian motions associated to them.
# Killian Martin--Horgassan
# 08-06-2015

# Clear the environment
rm(list=ls())

# Close all already open graphic windows
graphics.off()

# Sourcing the auxiliary files
source("loadStockData_plain.r")
source("firstElement.r")
source("computeApproximateGradient.r")
source("meanAndVariance.r")
source("Visualisation_StockPriceVariations.r")

# Remark : the csv uses the metastock data format
#          7 columns : - Ticker (identifier of the stock
#                       and stockmarket on which it is listed)
#					   - Date (yyyymmdd)
#					   - Open
#					   - High
#					   - Low
#					   - Close
#					   - Volume
# By default, the highest price is used i.e. column 3.
CHOICE <- 3

# Loading the original data for the LVMHH and Total
# stocks and getting the indexes where to cut the
# data.
df_plain <- loadStockData_plain(CHOICE)
indexes <- Visualisation_StockPriceVariations()
index_lvmh <- indexes[1]-1
index_total <- indexes[2]-1

S_lvmh <- df_plain[[3]]
S_total <- df_plain[[5]]

S_lvmh <- S_lvmh[1:index_lvmh]
S_total <- S_total[1:index_total]

LS_lvmh <- log(S_lvmh)
LS_total <- log(S_total)

LR_lvmh <- diff(LS_lvmh)
LR_total <- diff(LS_total)

index_lvmh <- length(LR_lvmh)
index_total <- length(LR_total)

m_lvmh <- mean(LR_lvmh)
s2_lvmh <- var(LR_lvmh)

m_total <- mean(LR_total)
s2_total <- var(LR_total)

# Building the Geometric Brownian motions
B_lvmh1 <- rnorm(index_lvmh,0,1)
B_lvmh1 <- S_lvmh[1]*exp(cumsum((m_lvmh + 0.5*s2_lvmh) + sqrt(s2_lvmh)*B_lvmh1))

B_lvmh2 <- rnorm(index_lvmh,0,1)
B_lvmh2 <-  S_lvmh[1]*exp(cumsum((m_lvmh + 0.5*s2_lvmh) + sqrt(s2_lvmh)*B_lvmh2))

B_lvmh3 <- rnorm(index_lvmh,0,1)
B_lvmh3 <-  S_lvmh[1]*exp(cumsum((m_lvmh + 0.5*s2_lvmh) + sqrt(s2_lvmh)*B_lvmh3))

B_lvmh4 <- rnorm(index_lvmh,0,1)
B_lvmh4 <-  S_lvmh[1]*exp(cumsum((m_lvmh + 0.5*s2_lvmh) + sqrt(s2_lvmh)*B_lvmh4))

B_lvmh5 <- rnorm(index_lvmh,0,1)
B_lvmh5 <-  S_lvmh[1]*exp(cumsum((m_lvmh + 0.5*s2_lvmh) + sqrt(s2_lvmh)*B_lvmh5))

minima_lvmh <- min(c(B_lvmh1, B_lvmh2, B_lvmh3, B_lvmh4, B_lvmh5))
maxima_lvmh <- max(c(B_lvmh1, B_lvmh2, B_lvmh3, B_lvmh4, B_lvmh5))

B_total1 <- rnorm(index_total,0,1)
B_total1 <- S_total[1]*exp(cumsum((m_total + 0.5*s2_total) + sqrt(s2_total)*B_total1))

B_total2 <- rnorm(index_total,0,1)
B_total2 <- S_total[1]*exp(cumsum((m_total + 0.5*s2_total) + sqrt(s2_total)*B_total2))

B_total3 <- rnorm(index_total,0,1)
B_total3 <- S_total[1]*exp(cumsum((m_total + 0.5*s2_total) + sqrt(s2_total)*B_total3))

B_total4 <- rnorm(index_total,0,1)
B_total4 <- S_total[1]*exp(cumsum((m_total + 0.5*s2_total) + sqrt(s2_total)*B_total4))

B_total5 <- rnorm(index_total,0,1)
B_total5 <- S_total[1]*exp(cumsum((m_total + 0.5*s2_total) + sqrt(s2_total)*B_total5))

minima_total <- min(c(B_total1, B_total2, B_total3, B_total4, B_total5))
maxima_total <- max(c(B_total1, B_total2, B_total3, B_total4, B_total5))

quartz()
dev.new(width = 7, heigth = 7)
png(file = "cleanedLVMH.png")
plot(1:index_lvmh, S_lvmh[1:index_lvmh], col = 'grey', lwd = 2,
	type = 'l', main = 'LVMH Stock actual & simulated', xlab =
    'Time steps in weeks', ylab = 'Stock prices', ylim =
    c(minima_lvmh, maxima_lvmh))
lines(1:index_lvmh, B_lvmh1, col = 'red')
lines(1:index_lvmh, B_lvmh2, col = 'blue')
lines(1:index_lvmh, B_lvmh3, col = 'green')
lines(1:index_lvmh, B_lvmh4, col = 'yellow')
lines(1:index_lvmh, B_lvmh5, col = 'purple')
dev.off()
graphics.off()

quartz()
dev.new(width = 7, heigth = 7)
png(file = "cleanedTotal.png")
plot(1:index_total, S_total[1:index_total], col = 'grey', lwd = 2,
	type = 'l', main = 'Total Stock actual & simulated', xlab =
    'Time steps in weeks', ylab = 'Stock prices', ylim =
    c(minima_total, maxima_total))
lines(1:index_total, B_total1, col = 'red')
lines(1:index_total, B_total2, col = 'blue')
lines(1:index_total, B_total3, col = 'green')
lines(1:index_total, B_total4, col = 'yellow')
lines(1:index_total, B_total5, col = 'purple')
dev.off()
graphics.off()

B_totalBeta1 <- rnorm(6*index_total,0,1/sqrt(6))
B_totalBeta1 <- S_total[1]*exp(cumsum((m_total + 0.5*s2_total) + sqrt(s2_total)*B_totalBeta1))

B_totalBeta2 <- rnorm(6*index_total,0,1/sqrt(6))
B_totalBeta2 <- S_total[1]*exp(cumsum((m_total + 0.5*s2_total) + sqrt(s2_total)*B_totalBeta2))

minima_total_Beta <- min(c(B_totalBeta1, B_totalBeta2))
maxima_total_Beta <- max(c(B_totalBeta1, B_totalBeta2))

quartz()
dev.new(width = 7, heigth = 7)
png(file = "cleanedTotal_better_simulation.png")
plot(1:index_total, S_total[1:index_total], col = 'grey', lwd = 2,
	type = 'l', main = 'Total Stock actual [weekly increment] & \n simulated [daily increment]', xlab =
    'Time steps in weeks', ylab = 'Stock prices')#, ylim =
    #c(minima_total_Beta, maxima_total_Beta))
lines(1:(6*index_total), B_totalBeta1, col = 'purple')
lines(1:(6*index_total), B_totalBeta2, col = 'blue')

dev.off()
graphics.off()

B_lvmhBeta1 <- rnorm(6*index_lvmh,0,1/sqrt(6))
B_lvmhBeta1 <- S_lvmh[1]*exp(cumsum((m_lvmh + 0.5*s2_lvmh) + sqrt(s2_lvmh)*B_lvmhBeta1))

B_lvmhBeta2 <- rnorm(6*index_lvmh,0,1/sqrt(6))
B_lvmhBeta2 <- S_lvmh[1]*exp(cumsum((m_lvmh + 0.5*s2_lvmh) + sqrt(s2_lvmh)*B_lvmhBeta2))

minima_lvmh_Beta <- min(c(B_lvmhBeta1, B_lvmhBeta2))
maxima_lvmh_Beta <- max(c(B_lvmhBeta1, B_lvmhBeta2))

quartz()
dev.new(width = 7, heigth = 7)
png(file = "cleanedLVMH_better_simulation.png")
plot(1:index_lvmh, S_lvmh[1:index_lvmh], col = 'grey', lwd = 2,
	type = 'l', main = 'LVMH Stock actual [weekly increment] & \n simulated [daily increment]', xlab =
    'Time steps in weeks', ylab = 'Stock prices')#, ylim =
    #c(minima_total_Beta, maxima_total_Beta))
lines(1:(6*index_lvmh), B_lvmhBeta1, col = 'purple')
lines(1:(6*index_lvmh), B_lvmhBeta2, col = 'blue')

dev.off()
graphics.off()


## https://israeldi.github.io/bookdown/_book/monte-carlo-simulation-of-stock-portfolio-in-r-matlab-and-python.html

source('/home/dlhjel/GitHub_repos/R-setup/setup.r')

##-----------------------------------------------------------------------------
## Determine mean for each asset and covariance matrix
data <- '
    Date           AAPL           GOOG           FB
11/15/17       166.5791        1020.91       177.95
11/16/17       168.5693        1032.50       179.59
11/17/17       167.6333        1019.09       179.00
11/20/17       167.4658        1018.38       178.74
11/21/17       170.5791        1034.49       181.86
11/22/17       172.3721        1035.96       180.87
11/24/17       172.3820        1040.61       182.78
11/27/17       171.5150        1054.21       183.03
11/28/17       170.5101        1047.41       182.42
11/29/17       166.9732        1021.66       175.13
'
history <- as_tibble(readall(data))
history$Date <- as.Date(history$Date, "%m/%d/%Y")
increment <- (max(history$Date) - min(history$Date)) / nrow(history)
# alternately, I could grab the most common increment
# increment <- mode(diff(history$Date))
price <- history[2:ncol(history)]

# This function returns the first differences of a t x q df of data
returns = function(df){
  rows  <- nrow(df)
  return <- df[2:rows, ] / df[1:rows-1, ] - 1
}

# Get the asset returns
return <- returns(price)

## calculate mean return for each asset
means = colMeans(return)

## Get the Variance Covariance Matrix of Stock Returns
pairs(return)
coVarMat = cov(return)
print(coVarMat)

## Lower Triangular Matrix from Choleski Factorization, L where L * t(L) = CoVarMat
## needed for R_i = mean_i + L_ij * Z_ji
L = t( chol(coVarMat) )
print(L)

##-----------------------------------------------------------------------------
## SET PARAMETERS FOR MONTE CARLO SIMULATIONS

# Set number of Monte Carlo Simulations
mc_rep = 1000
# Set number of days for the simulation
sim_days = 30
# Set simulation start date
sim_start <- Sys.Date()
# Calculate simulation end date
sim_end <- sim_start + increment * sim_days
# Set date vector for simulation (length should be sim_days + 1)
Date <- seq(sim_start, sim_end, increment)

# Suppose we invest our money evenly among all three assets
# We use today's Price 11/14/2018 to find the number of shares each stock
# that we buy
weights <- c(1/3, 1/3, 1/3)
print(weights)

##-----------------------------------------------------------------------------
## START MONTE CARLO SIMULATION

## initialize sim_return matrix
## row for each simulation date
## column for each monte carlo simulation
cum_sim_m = matrix(0, sim_days, mc_rep)

## Extend means vector to a matrix
## one row for each account (or investment column) repeated in columns for each simulation
means_matrix = matrix(rep(means, sim_days), nrow = ncol(return))

## set seed if want to repeat exactly
set.seed(200)
for (i in 1:mc_rep) {
    ## do following for each monte carlo simulation

    ## obtain random z values for each account (rows) for each date increment (columns)
    Z <- matrix( rnorm( ncol(return) * sim_days ), ncol = sim_days)

    ## simulate returns for each increment forward in time (assumed same as whatever data was)
    sim_return <- means_matrix + L %*% Z
    ## to view as a dataframe
    ## dfsim <- as_tibble(as.data.frame(t(sim_return)))

    ## Calculate vector of portfolio returns
    cum_sim_i = cumprod( weights %*% sim_return + 1 )

    ## Add it to the monte-carlo matrix
    cum_sim_m[,i] = cum_sim_i;
}
# put results into dataframe
cum_sim_df <- as_tibble(as.data.frame(cum_sim_m))
# add row for starting value
ones <- rep(1, ncol(cum_sim_df))
cum_sim_df <- rbind(ones, cum_sim_df)

##-----------------------------------------------------------------------------
## DISPLAY RESULTS

# plot results
# first establish plot area
ylim <- range(cum_sim_df)
plot(Date, cum_sim_df$V1, type='n',
     ylab='Simulation Returns',
     ylim=ylim)
for (i in 2:ncol(cum_sim_df)) {
  lines(Date, t(cum_sim_df[i]), type='l')
}

# Porfolio Returns statistics at end of simulation
cum_final <- as.numeric( cum_sim_df[nrow(cum_sim_df),] )
cum_final_stats <- data.frame(mean   = mean(cum_final),
                        median = median(cum_final),
                        sd     = sd(cum_final))
print(cum_final_stats)

## Construct Confidential Intervals for returns
## first define function
ci <- function(df, conf) {
    # calculate confidence limit for specified confidence level
    # note specified conf = 1 - alpha
    # i.e., if want alpha=0.05 to get 95% conf limit, specify 0.95
    apply(df, 1, function(x) quantile(x, conf))
}
## create dataframe of confidence intervals
df <- cum_sim_df
cis <- as_tibble( data.frame(Date,
                  conf_99.9_upper_percent = ci(df, 0.999),
                  conf_99.0_upper_percent = ci(df, 0.99),
                  conf_95.0_upper_percent = ci(df, 0.95),
                  conf_50.0_percent       = ci(df, 0.5),
                  conf_95.0_lower_percent = ci(df, 0.05),
                  conf_99.0_lower_percent = ci(df, 0.01),
                  conf_99.9_lower_percent = ci(df, 0.001)) )

## plot confidence intervals on simulation
lines(cis$Date, cis$conf_99.9_upper_percent, lwd=4, lty=2, col='red')
lines(cis$Date, cis$conf_50.0_percent      , lwd=4,        col='red')
lines(cis$Date, cis$conf_99.9_lower_percent, lwd=4, lty=2, col='red')


marginOfError =
function(prob,  # sample probability (or response rate)
         n,  # sample size
         N=NULL,
         conf.level=0.95  # Confidence interval
         ) {
    z <- qnorm(p=1.0 - (1.0 - conf.level) * 0.5)
    B <- prob * (1 - prob)
    moe <- z * sqrt(B / n)

    if (!is.null(N)) {
        # tmp <- z ^ 2 * (prob * (1 - prob)) / moe^2
        # n <- tmp / (1 + tmp / N)
        # n + n/N * tmp <- tmp
        # n <- tmp * (1 - n/N)
        fpcf <- sqrt((N - n) / (N - 1))
        moe <-  moe * fpcf
    }
    return(moe)
}

sampleSize =
function(prob,
         moe,  # Margin of error
         N=NULL,  # Population size
         conf.level=0.95
         ) {
    z <- qnorm(p=1.0 - (1.0 - conf.level) * 0.5)
    B <- prob * (1 - prob)
    n <- z ^ 2 * B / moe^2
    if (!is.null(N)) {
        n <- n * N / (n + N - 1)
    }
    return(n)
}

binom.test =
function() {
    prob <- 0.15
    moe <- 0.025
    N <- 1000
    n <- sampleSize(prob=prob, moe=moe, N=N)
    message(n)
    message("Expected margin of error: ", moe)
    moe <- marginOfError(prob=prob, n=n, N=N)
    message(moe)
}


next.perm <- function(p) {
	n <- length(p)
	i <- n - 1
	r = TRUE
	for(i in (n-1):1) {
		if(p[i] < p[i+1]) {
			r = FALSE
			break
		}
	}

	j <- i + 1
	k <- n
	while(j < k) {
		x <- p[j]
		p[j] <- p[k]
		p[k] <- x
		j <- j + 1
		k <- k - 1
	}

	if(r) return(NULL)

	j <- n
	while(p[j] > p[i]) j <- j - 1
	j <- j + 1

	x <- p[i]
	p[i] <- p[j]
	p[j] <- x
	return(p)
}

print.perms <- function(n) {
	p <- 1:n
	while(!is.null(p)) {
		cat(p,"\n")
		p <- next.perm(p)
	}
}

print.perms(3)
# 1 2 3
# 1 3 2
# 2 1 3
# 2 3 1
# 3 1 2
# 3 2 1


#' @title plot3AgeComparisons
#' @description plot triplets of age readings on a hexagon to compare 3 age readers or to compare 3 aging methods
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
plot3AgeComparisons = function(triplets,color="grey60",offset=.20){

# triplets is a matrix with number of rows equal to number of fish aged, and 3 columns.
# Each column contains the age readings obtained from one reader (or one aging method).
# The object is to compare the columns to see how the readers may differ.

# color sets the darkness of the grid of reference points. What you see on the screen may differ from
# what your printer gives you.

# offset determines how close to the reference point the number of observations is printed.

# makes use of the function regpolygon()

# This function will implement the graphing procedure described by Evans,
# G.T. and J.M. Hoenig.  1998.  Viewing and Testing Symmetry in Contingency
# Tables, with Application to Fish Ages.  Biometrics 54:620-629.

# Programmed by J. Hoenig, Virginia Institute of Marine Science, hoenig@vims.edu

# First, test if the matrix triplets is numeric.

 if(!is.numeric(triplets)) {return("matrix is not numeric")}

# determine if there are NAs and, if so, eliminate them and alert the user.

test = complete.cases(triplets)
warn = sum(!test)
if (warn > 0) cat("warning: there are ",warn," records with missing values")
triplets = triplets[test,]

# now, subtract the lowest value in each row of triplets from each entry in the row

rowmins = apply(triplets,1,min)
triplets = triplets - rowmins
maxdif = max(triplets)

# draw a regular hexagon

 hexagon = regpolygon(lenside=maxdif)
 xvalues = hexagon$x
 yvalues = hexagon$y

 par(fin=c(5,5.62))

 plot(xvalues,yvalues,ylab="",xlab="",type="l",xlim=c(-maxdif,maxdif),
    ylim=c(-maxdif,maxdif),xaxt="n",yaxt="n")

# now add radii
  for (i in 1:6) {
    lines(x=c(0,xvalues[i]),y=c(0,yvalues[i]))
  }

# now add a grid of plotting nodes
x = matrix(NA,nrow=2*maxdif+1,ncol=2*maxdif+1)
y = matrix(NA,nrow=2*maxdif+1,ncol=2*maxdif+1)

for (i in 1:(2*maxdif+1)){
  for (j in 1:(maxdif+1)) {
    x[i,j] = i-maxdif-1-(j-1)*cos(pi/3)
    y[i,j] = (j-1)*sin(pi/3)
  }
}

for (i in 1:maxdif){
  for (j in (i+1):(maxdif+1)) {
    x[i,j] = NA
    y[i,j] = NA
  }
}

for (i in 1:(2*maxdif+1)){
  for (j in 1:(maxdif+1)) {
    points(x[i,j],y[i,j],pch=20,col=color)
    points(x[i,j],-y[i,j],pch=20,col=color)
  }
}

# now count how many observations there are at each plotting point

numcells = (maxdif + 1)^3
count = rep(NA,numcells)
dim(count) = c((maxdif+1),(maxdif+1),(maxdif+1))
xcoord = rep(NA,numcells)
dim(xcoord) = c((maxdif+1),(maxdif+1),(maxdif+1))
ycoord = rep(NA,numcells)
dim(ycoord) = c((maxdif+1),(maxdif+1),(maxdif+1))

for (i in 1:dim(triplets)[1]) {
   if (is.na(count[(triplets[i,1]+1),(triplets[i,2]+1),(triplets[i,3]+1)])) {
       count[(triplets[i,1]+1),(triplets[i,2]+1),(triplets[i,3]+1)] = 0 }
   count[(triplets[i,1]+1),(triplets[i,2]+1),(triplets[i,3]+1)] =
       count[(triplets[i,1]+1),(triplets[i,2]+1),(triplets[i,3]+1)] + 1
}
for (i in 1:(maxdif+1)) {
   for (j in 1:(maxdif+1)) {
     for (k in 1:(maxdif+1)) {
       # compute the x & y coordinates for the plotting location
       xcoord[i,j,k] = i - j*cos(pi/3) - k*cos(pi/3)
       ycoord[i,j,k] = j*sin(pi/3) - k*sin(pi/3)
     }
   }
}

# now plot the data

for (i in 1:(maxdif+1)){
   for (j in 1:(maxdif+1)){
      for (k in 1:(maxdif+1)){
        if(!is.na(count[i,j,k])) points((xcoord[i,j,k]+offset),ycoord[i,j,k],pch=as.character(count[i,j,k]))
      }
   }
}

text(4.06,.45,"A")
text(-2.3,3.8,"B")
text(-2.3,-3.8,"c")

 return(list(triplets=triplets,x=x,y=y,count=count,xcoord=xcoord,ycoord=ycoord))

}

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

# regpolygon: compute (x,y) pairs that define the locations of the vertices of a regular polygon
# CJG, Aug. 7, 1995    modified by JM Hoenig June 2007 to run in R

regpolygon <- function(n=6,lenside=1,startang=0){

  # n        : the number of sides
  # lenside  : the length of each vertex to the center of the regular polygon
  # startang : the angle (degrees) of the first point on the polygon
  #            w.r.t. the x-axis

  startang <- startang*(pi/180)  # convert to radians

  vertices <- seq(startang, startang+(2*pi), length=(n+1) )
  x <- cos(vertices)
  y <- sin(vertices)

  x <- x*lenside
  y <- y*lenside

  return(list(x=x,y=y))

}


## beta via MLE in R

#' Title
#'
#' @param fmu formula object
#' @param method character string
#' @param data dataset
#' @param brange vector
#'
#' @export
#'
betamle <-function(fmu,method='BFGS', data, brange){

    #attach(data, warn.conflicts=FALSE)

    Fmu <- terms(fmu, data=data)
    X.vars <- as.character(attr(Fmu, "variables"))[c(-1, -2)]
    X.data <- model.matrix(fmu)

    Y.var <- as.character(attr(Fmu, "variables"))[2]
    Y.data <- model.frame(fmu)[,1]

    setrange <- function(z, brange) {
      t <- (z-brange[1])/(brange[2]-brange[1])
      t[which(t == 0)] <- .001
      t[which(t == 1)] <- .999
      t
    }

    dv <- setrange(Y.data, brange)
    nx <- ncol(X.data)

    neglnl<-function(theta){
	    nu <- theta[1:nx]
	    omega <- theta[(nx+1):(2*nx)]

	    X <- X.data

	    p1 <-exp(as.vector(X%*%nu))
	    p2 <- exp(as.vector(X%*%omega))

	    -sum(lgamma(p1 + p2) + (p1-1)*log(dv) + (p2-1)*log(1-dv) - lgamma(p1) - lgamma(p2) )
	   }

    result <- optim(rep(0,2*nx), neglnl, hessian=T, method="BFGS")

    coef<-result$par
    coef_nu <- coef[1:nx]
    coef_omega <- coef[(nx+1):(2*nx)]
    var<-solve(result$hessian)
    var_nu <- var[1:nx]
    var_omega <- var[(nx+1):(2*nx)]
    se<-sqrt(diag(var))
    se_nu <- se[1:nx]
    se_omega <- se[(nx+1):(2*nx)]
    zscore<-coef/se
    zscore_nu <- zscore[1:nx]
    zscore_omega <- zscore[(nx+1):(2*nx)]
    pvalue<-2.0*(1.0-pnorm(abs(zscore)))
    pscore_nu <- pvalue[1:nx]
    pscore_omega <- pvalue[(1+nx):(2*nx)]

    res <- cbind(coef_nu, se_nu, zscore_nu, pscore_nu,
                 coef_omega, se_omega, zscore_omega, pscore_omega)
	  colnames(res) <- c("Nu Coef.","Nu SE","Nu Z","Nu p", "Omega Coef", "Omega SE", "Omega Z", "Omega p")
	  rownames(res) <- c("constant",X.vars)

    cat("\n",paste("Beta MLE Model of",Y.var),"\n")

	  print(round(res,2))
    if (print(result$convergence==0))
	    cat("\nLikelihood:",-result$value,"\n")
    else
	    cat("\nDid NOT converge\n")

	  rval <- list("coef"=coef,
	               "coef_nu"=coef_nu,
	               "coef_omega"=coef_omega,
	               "var"=var,
	               "var_nu"=var_nu,
	               "var_omega"=var_omega,
	               "results" = res,
	               "Likelihood"=-result$value)
	  rval
  }


library(MASS)

f <- function(n) {
  factorial(n)
}

dispn <- function(n, m) {
  f(n)/f(n-m)
}

stirling <- function(n) {
  n*log(n) - n + (1/2)*log(2*pi*n)
}

# ESERCIZIO 1

white <- 4
red <- 3
green <- 4

# formule

permutazioni_es1 <- f(white+red+green)/(f(white)*(f(green)*(f(red))))

print(permutazioni_es1)

# ESERCIZIO 2
consonanti <- 9
vocali <- 5

consonanti_parola <- 6
vocali_parola <- 4

# formule

disp_cons <- choose(consonanti, consonanti_parola)
disp_voca <- choose(vocali, vocali_parola)
permutazioni_es2 <- f(consonanti_parola+vocali_parola)
parole <- disp_cons * disp_voca * permutazioni_es2
parole_log <- log(parole)
print(parole_log)

# ESERCIZIO 3
n_terzo <- 1548
print(stirling(n_terzo), digits=22)


#   __      _____             _              __        _
# <(o )___ |  _  |___ ___ ___| |_ ___ ___   |  |   ___| |_ ___
# ( ._> /  |   __|  _| -_|_ -|  _| -_|_ -|  |  |__| .'| . |_ -|
#  `---'   |__|  |_| |___|___|_| |___|___|  |_____|__,|___|___|
#==============================================================================
# Outlier Treatment
#==============================================================================
# Title          : Outlier treatment.r
# Description    : Outlier Treatment
# Author         : Isaias V. Prestes <isaias.prestes@gmail.com>
# Date           : 20170822
# Version        : 0.0.2
# Usage          : Run in R 3.4
# Notes          : Source r-statistics.co by Selva Prabhakaran
# R version      : 3.4
#==============================================================================
# install.packages('car')
# install.packages('outliers')

#==============================================================================
# LIBRARY DEPENDENCE
#==============================================================================
library(car)
library(outliers)

#==============================================================================
# Data
#==============================================================================

# Inject outliers into data.
cars1 <- cars[1:30, ]  # original data
cars_outliers <- data.frame(
	speed=c(19,19,20,20,20),
	dist=c(190, 186, 210, 220, 218))  # introduce outliers.
cars2 <- rbind(cars1, cars_outliers)  # data with outliers.

# Plot of data with outliers.
par(mfrow=c(1, 2))
plot(cars2$speed, cars2$dist, xlim=c(0, 28), ylim=c(0, 230),
	main="With Outliers", xlab="speed", ylab="dist", pch="*", col="red", cex=2)
abline(lm(dist ~ speed, data=cars2), col="blue", lwd=3, lty=2)

# Plot of original data without outliers. Note the change in slope (angle) of
# best fit line.
plot(cars1$speed, cars1$dist, xlim=c(0, 28), ylim=c(0, 230),
	main="Outliers removed \n A much better fit!", xlab="speed", ylab="dist",
	pch="*", col="red", cex=2)
abline(lm(dist ~ speed, data=cars1), col="blue", lwd=3, lty=2)

#==============================================================================
# Detect outliers
#==============================================================================

#------------------------------------------------------------------------------
# Univariate approach ----------------------------------------------------------
#------------------------------------------------------------------------------
url <- "http://rstatistics.net/wp-content/uploads/2015/09/ozone.csv"
inputData <- read.csv(url)  # import data

outlier_values <- boxplot.stats(inputData$pressure_height)$out  # outlier values.
boxplot(inputData$pressure_height, main="Pressure Height", boxwex=0.1)
mtext(paste("Outliers: ", paste(outlier_values, collapse=", ")), cex=0.6)

#------------------------------------------------------------------------------
# Bivariate approach ----------------------------------------------------------
#------------------------------------------------------------------------------
ozone <- read.csv(url)
# For categorical variable
boxplot(ozone_reading ~ Month, data=ozone,
	main="Ozone reading across months")  # clear pattern is noticeable.
boxplot(ozone_reading ~ Day_of_week, data=ozone,
	main="Ozone reading for days of week")
	# this may not be significant, as day of week variable is a subset of the
	# month var.

# For continuous variable (convert to categorical if needed.)
boxplot(ozone_reading ~ pressure_height, data=ozone,
	main="Boxplot for Pressure height (continuos var) vs Ozone")
boxplot(ozone_reading ~ cut(pressure_height,
	pretty(inputData$pressure_height)), data=ozone,
	main="Boxplot for Pressure height (categorial) vs Ozone", cex.axis=0.5)

#------------------------------------------------------------------------------
# Multivariate approach -------------------------------------------------------
#------------------------------------------------------------------------------

# Cooks Distance --------------------------------------------------------------
# https://onlinecourses.science.psu.edu/stat501/node/340

mod <- lm(ozone_reading ~ ., data=ozone)
cooksd <- cooks.distance(mod)

# In general use, those observations that have a cook’s distance greater than
# 4 times the mean may be classified as influential. This is not a hard
# boundary.

# plot cook's distance
plot(cooksd, pch="*", cex=2, main="Influential Obs by Cooks distance")
abline(h = 4*mean(cooksd, na.rm=T), col="red")  # add cutoff line
text(x=1:length(cooksd)+1, y=cooksd,
	labels=ifelse(cooksd>4*mean(cooksd, na.rm=T),
	names(cooksd),""), col="red")  # add labels
# influential row numbers
influential <- as.numeric(names(cooksd)[(cooksd > 4*mean(cooksd, na.rm=T))])
head(ozone[influential, ])  # influential observations.

#==============================================================================
# Outliers Test
#==============================================================================
car::outlierTest(mod)

# outliers package ------------------------------------------------------------
set.seed(666)
y=rnorm(100)
outlier(y)
outlier(y,opposite=TRUE)
dim(y) <- c(20,5)  # convert it to a matrix
outlier(y)
outlier(y,opposite=TRUE)

set.seed(666)
x = rnorm(10)
scores(x)  # z-scores => (x-mean)/sd
scores(x, type="chisq")  # chi-sq scores => (x - mean(x))^2/var(x)
scores(x, type="t")  # t scores
scores(x, type="chisq", prob=0.9)  # beyond 90th %ile based on chi-sq
scores(x, type="chisq", prob=0.95)  # beyond 95th %ile
scores(x, type="z", prob=0.95)  # beyond 95th %ile based on z-scores
scores(x, type="t", prob=0.95)  # beyond 95th %ile based on t-scores

#==============================================================================
# Treating the outliers
#==============================================================================
# 1. Imputation
# 2. Capping
#     For missing values that lie outside the 1.5*IQR limits, we could cap it
#     by replacing those observations outside the lower limit with the value of
#     5th-ile and those that lie above the upper limit, with the value of 95th
#     -ile. Below is a sample code that achieves this.
# 3. Prediction

x <- ozone$pressure_height
qnt <- quantile(x, probs=c(.25, .75), na.rm = T)
caps <- quantile(x, probs=c(.05, .95), na.rm = T)
H <- 1.5 * IQR(x, na.rm = T)
x[x < (qnt[1] - H)] <- caps[1]
x[x > (qnt[2] + H)] <- caps[2]


confidenceInterval <- function(x, confidenceLevel=0.95){
N <- length(x)
alpha <- 1-confidenceLevel
if (N<30)
  stat <- qt(1-alpha/2, N-1)
else
  stat <- qnorm(1-alpha/2)
interval <- stat * sd(x) / sqrt(N)
mean_value <- mean(x)
result <- c(mean_value-interval, mean_value+interval)
names(result) <- c("lower", "upper")
result
}


#install.packages("GA")
library(GA)

# Funkcja przykładowa z dokumentacji
# f <- function(x) (x^2+x)*cos(x) # Badana funkcja
# lbound <- -10 # Dolne ograniczenie funkcji
# rbound <- 10 # Górne ogranicznie funkcji

f <- function(x) x*sin(10*pi*x)+1

fitnessF <- function(x)
{
  f <- f(x)

  penalty1 <- 0
  if (x <= -1) {
    penalty1 <- -x-1
  }

  penalty2 <- 0
  if (x >= 2) {
    penalty2 <- x - 2
  }

  f + penalty1 + penalty2
}

lbound <- -1000
rbound <- 1000

fA <- function(x) -fitnessF(x) # Funkcja odwrotna do badanej, ponieważ minimalizujemy funkcję

# Genetic algorithm
GA <- ga(
   type = "real-valued",
   fitness = fA,
   lower = c(th = lbound), upper = rbound,
   popSize = 50, maxiter = 100000, run = 1000
)
summary(GA)
plot(GA)

curve(f, from = lbound, to = rbound, 200) # rysowanie wykresy funkcji
#points(GA@solution, GA@fitnessValue, col = 2, pch = 19) # ozaczanie punktu na wykresie / tutaj szukanego ekstremum w zakresie
points(GA@solution, fitnessF(GA@solution), col = 2, pch = 19) # Musimy uzyskać wartość z funkcji wyjściowej, gdyż badamy funkcje odwrotną


# independent.test.equal.var.r
  x <- c(21.6,20.8,17.6,20.1,20.1,21.9,20.6,19.4,21.5,26.1)
  y <- c(20.6,20.4,20.2,20.2,18.0,19.8,20.9,19.7,20.3,19.7,22.7)
  mx <- mean(x); my <- mean(y)
  sdx <- sd(x); sdy <- sd(y)
  sp <- sqrt( (9*sdx^2+10*sdy^2)/(10+11-2) )
  t0 <- (mx-my)/(sp*sqrt(1/10+1/11))
  t0
  1-pt(t0, 19)
  lbd <- (mx-my) - qt(0.995, 19)*sp*sqrt(1/10+1/11)
  lbd
  ubd <- (mx-my) + qt(0.995, 19)*sp*sqrt(1/10+1/11)
  ubd


if(FALSE){
"Time series is a series of data points in which each data point is associated with a timestamp.
A simple example is the price of a stock in the stock market at different points of time on a given day.
Another example is the amount of rainfall in a region at different months of the year.
R language uses many functions to create, manipulate and plot the time series data.
The data for the time series is stored in an R object called time-series object.
It is also a R data object like a vector or data frame."

#The time series object is created by using the ts() function
#timeseries.object.name <-  ts(data, start, end, frequency)
"data is a vector or matrix containing the values used in the time series.
start specifies the start time for the first observation in time series.
end specifies the end time for the last observation in time series.
frequency specifies the number of observations per unit time."

}
function1 <- function(){
#We create an R time series object for a period of 12 months and plot it.
# Get the data points in form of a R vector.
rainfall <- c(799,1174.8,865.1,1334.6,635.4,918.5,685.5,998.6,784.2,985,882.8,1071)

# Convert it to a time series object.
rainfall.timeseries <- ts(rainfall,start = c(2012,1),frequency = 12)

# Print the timeseries data.
print(rainfall.timeseries)

# Give the chart file a name.
png(file = "rainfall.png")

# Plot a graph of the time series.
plot(rainfall.timeseries)

# Save the file.
dev.off()
}
# function1()

if(FALSE){
"The value of the frequency parameter in the ts() function decides the time intervals
at which the data points are measured"
"frequency = 12 pegs the data points for every month of a year.
frequency = 4 pegs the data points for every quarter of a year.
frequency = 6 pegs the data points for every 10 minutes of an hour.
frequency = 24*6 pegs the data points for every 10 minutes of a day."
}

function2 <- function(){
# Get the data points in form of a R vector.
rainfall1 <- c(799,1174.8,865.1,1334.6,635.4,918.5,685.5,998.6,784.2,985,882.8,1071)
rainfall2 <-
           c(655,1306.9,1323.4,1172.2,562.2,824,822.4,1265.5,799.6,1105.6,1106.7,1337.8)

# Convert them to a matrix.
combined.rainfall <-  matrix(c(rainfall1,rainfall2),nrow = 12)

# Convert it to a time series object.
rainfall.timeseries <- ts(combined.rainfall,start = c(2012,1),frequency = 12)

# Print the timeseries data.
print(rainfall.timeseries)

# Give the chart file a name.
png(file = "rainfall_combined.png")

# Plot a graph of the time series.
plot(rainfall.timeseries, main = "Multiple Time Series")

# Save the file.
dev.off()
}
function2()