function medcouple(vector X):
       // X is a vector of size n

       // compute initial ingredients as for the naïve medcouple
       sort_decreasing(X)

       xm := median(X)
       xscale := 2*max(X)

       Zplus  := [(x - xm)/xscale | x in X such that x >= xm]
       Zminus := [(x - xm)/xscale | x in X such that x <= xm]

       p := size(Zplus)
       q := size(Zminus)

       function h(i,j):
           a := Zplus[i]
           b := Zminus[j]

           if a == b:
               return signum(p - 1 - i - j)
           else:
               return (a + b)/(a - b)
           endif
       endfunction

       // begin Kth pair algorithm (Johnson & Mizoguchi)

       // the initial left and right boundaries, two vectors of size p
       L := [0, 0, ..., 0]
       R := [q - 1, q - 1, ..., q - 1]

       // number of entries to the left of the left boundary
       Ltotal := 0

       // number of entries to the left of the right boundary
       Rtotal := p*q

       // since we are indexing from zero, the medcouple index is one
       // less than its rank
       medcouple_index := floor(Rtotal/2)

       // iterate while the number of entries between the boundaries is
       // greater than the number of rows in the matrix
       while Rtotal - Ltotal > p:

           // compute row medians and their associated weights, but skip
           // any rows that are already empty
           middle_idx  := [i | i in [0, 1, ..., p - 1] such that L[i] <= R[i]]
           row_medians := [h(i, floor((L[i] + R[i])/2) | i in middle_idx]
           weights := [R[i] - L[i] + 1 | i in middle_idx]

           WM := weighted median(row_medians, weights)

           // new tentative right and left boundaries
           P := greater_h(h, p, q, WM)
           Q := less_h(h, p, q, WM)

           Ptotal := sum(P) + size(P)
           Qtotal := sum(Q)

           // determine which entries to discard, or if we've found the medcouple
           if medcouple_index <= Ptotal - 1:
               R := P
               Rtotal := P
           else:
               if medcouple_index > Qtotal - 1:
                   L := Q
                   Ltotal := Qtotal
               else:
                   // found the medcouple, rank of the weighted median equals medcouple index
                   return WM
               endif
           endif

       endwhile

       // did not find the medcouple, but there are very few tentative entries remaining
       remaining := [h(i,j) | i in [0, 1, ..., p - 1],
                              j in [L[i], L[i] + 1, ..., R[i]]
                              such that L[i] <= R[i] ]

       // select the medcouple by rank amongst the remaining entries
       medcouple := select_nth(remaining, medcouple_index - Ltotal)

       return medcouple
   endfunction


#!/usr/bin/Rscript

# Author : Bhishan Poudel
# Date   : Feb 9, 2016
# Program:

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

# Start device driver to save output
#postscript(file= "Pareto_shape_parameter.eps", height = 14, width = 8)

# Estimates of Pareto shape parameter (power-law slope)
npts <- 100
alpha.MLE <- function(x) 1 / mean(log(x))
alpha.MVUE <- function(x) (1-(2/npts)) / mean(log(x))
alpha.mom <- function(x) 1 / (1-1/mean(x))
alpha.LS.EDF <- function(x) {
    lsd <- log(sort(x)) ; lseq <- log((npts:1) / npts)
    tmp <- lm(lseq~lsd)
    # plot(lsd, lseq) ; abline(tmp,col=2)
    -tmp$coef[2] }
alpha.LS.hist <- function(x) {
    hx <- hist(x, nclass=20, plot=F)
    counts <- hx$counts
    ldens <- log(hx$density[counts>0])
    lmidpts <- log(hx$mids[counts>0])
    tmp1 <- lm(ldens~lmidpts)
    # plot(lmidpts, ldens) ; abline(tmp1, col=2)
    alpha.LS.hist <- -1 - as.numeric(tmp1$coef[2])
    return(alpha.LS.hist) }
alpha.LS.hist.wt <- function(x) {
    hx <- hist(x, nclass=20, plot=F)
    counts <- hx$counts
    ldens <- log(hx$density[counts>0])
    lmidpts <- log(hx$mids[counts>0])
    tmp2 <- lm(ldens~lmidpts, weights=counts[counts>0])
    alpha.LS.hist.wt <- -1 - as.numeric(tmp2$coef[2])
    return(alpha.LS.hist.wt) }
six_alphas <- function(x) {
    out <- c(alpha.MLE(x), alpha.MVUE(x), alpha.mom(x),
             alpha.LS.EDF(x), alpha.LS.hist(x), alpha.LS.hist.wt(x))
    return(out) }

# Turn off device driver
#dev.off()


=begin
  # sample-lagrange-multiplier01.rb

  require 'algebra'
  P = MPolynomial(Rational)
  t, x, y, z = P.vars('txyz')
  f = x**3+2*x*y*z - z**2
  g = x**2 + y**2 + z**2 - 1

  fx = f.derivate(x)
  fy = f.derivate(y)
  fz = f.derivate(z)

  gx = g.derivate(x)
  gy = g.derivate(y)
  gz = g.derivate(z)

  F = [fx - t * gx, fy - t * gy, fz - t * gz, g]

  Groebner.basis(F).each do |h|
    p h.factorize
  end

  #(1/7670)(7670t - 11505x - 11505yz - 335232z^6 + 477321z^4 - 134419z^2)
  #x^2 + y^2 + z^2 - 1
  #(1/3835)(3835xy - 19584z^5 + 25987z^3 - 6403z)
  #(1/3835)(3835x + 3835yz - 1152z^4 - 1404z^2 + 2556)(z)
  #(1/3835)(3835y^3 + 3835yz^2 - 3835y - 9216z^5 + 11778z^3 - 2562z)
  #(1/3835)(3835y^2 - 6912z^4 + 10751z^2 - 3839)(z)
  #(1/118)(118y - 1152z^3 + 453z)(z)(z - 1)(z + 1)
  #(1/1152)(z)(z - 1)(3z - 2)(3z + 2)(z + 1)(128z^2 - 11)

((<_|CONTENTS>))
=end


# Cyclical mean
# 'Cyclical mean'

#' Cyclical mean
#'
#' Calculate the mean of a set of cyclical values, e.g. calendar months, day of year, angles. The code transform the cycle to cartesian vectors, calculates summed vector, and get the cycle of the sum vector.
#'
#' @param x vector of cyclical values
#' @param steps number of steps in the cycle
#'
#' @return collapsed string
#' @export
cyclicalMean = function(x, steps=360){
  radial_frac = 2*pi/steps
  x_angle = radial_frac * x
  vec_x = cos(x_angle)
  vec_y = sin(x_angle)
  vec_x_mean = mean(vec_x)
  vec_y_mean = mean(vec_y)
  a_mean = atan2(vec_y_mean, vec_x_mean)
  x_mean = steps * a_mean / (2 * pi)
  x_mean = ifelse(x_mean < 0, steps+x_mean, x_mean)
  x_mean
}


###################################
### Part 3: Plotting Data ###
###################################
##
#

# We are going to work with one of R's built-in data sets called 'iris'.
# First, let's find out more about the data:

#######################
# Complete Exercise 4 #
#######################

# Let's analyze just the petal widths of the versicolor species in 'iris'.

# We can create a new data frame by extracting a subet of all versicolor records,...
versicolor <- iris[iris$Species == 'versicolor',]
versicolor

# ...then create a numeric vector of versicolor petal widths, or...
versicolor_pw <- versicolor$Petal.Width
versicolor_pw

# ...do the same thing all in one line
versicolor_pw <- iris[iris$Species == 'versicolor', 'Petal.Width']
versicolor_pw

# As with most programming languages, there is usually more than one way to do things in R.
# Keep this in mind as you are learning the language.

### Calculating simple statistics ###

# Before we create any plots, let's get some simple statistics on the pedal widths of versicolor:

mean(versicolor_pw)
median(versicolor_pw)
var(versicolor_pw)
sd(versicolor_pw)

# We can also look at the correlation between versicolor's petal width and it's petal length.
# First let's create a vector for versicolor's petal lengths.
versicolor_pl <- iris[iris$Species == 'versicolor', 'Petal.Length']
versicolor_pl

# By default, cor() uses the Pearson method. Values range from -1 to 1. Does petal width have
# a correlation with petal length?
cor(versicolor_pw,versicolor_pl)

### Plotting Data ###

## Scatterplot ##

# Let's plot the versicolor petal lengths and widths
  plot(versicolor_pw,versicolor_pl)

  # Add a regression line
  abline(lm(versicolor_pl~versicolor_pw))

  # Change the title
  title("Versicolor Petal Width vs Length")

# What happens if we plot the whole 'iris' data set?
plot(iris)

# Calling plot() on the whole data set makes a scatterplot matrix that plots every variable
# against every other variable. What if we just want to look at one of these scatterplots?
plot(iris$Petal.Length, iris$Petal.Width)

## Boxplot ##

# Boxplot of petal length by species
boxplot(Petal.Length~Species, data = iris, main="Petal Length by Iris Species",
        ylab="Length (cm)")

## Dot Plot ##

# Take a random sample of size 40 from the iris dataset, sampling without replacement
iris_ran_subset <- iris[sample(1:nrow(iris), 40, replace=FALSE),]

# Sort the rows so that all of the same species are together
iris_ran_subset_sorted <- iris_ran_subset[order(iris_ran_subset$Species),]

# Create a new column, 'Color'
iris_ran_subset_sorted$Color="black"

# Set Color values by Species
iris_ran_subset_sorted$Color[iris_ran_subset_sorted$Species == "virginica"] = "red"
iris_ran_subset_sorted$Color[iris_ran_subset_sorted$Species == "versicolor"] = "blue"
iris_ran_subset_sorted$Color[iris_ran_subset_sorted$Species == "setosa"] = "black"

# Plot the data
dotchart(iris_ran_subset_sorted$Sepal.Width,labels=iris_ran_subset_sorted$Species,cex=.9,
         main="Comparison of Sepal Width by Iris Species",
         xlab="Sepal Width (cm)", col=iris_ran_subset_sorted$Color)

## Histogram ##

# We can also make a histogram that describes the distribution of sepal length values:
hist(iris$Sepal.Length)

# Let's give the histogram more detail by increasing the number of bins. This is done with
# the 'breaks' argument:

hist(iris$Sepal.Length, breaks = 15)

# Hmm...the x axis is a little off. Let's adjust it with the 'xlim' argument:

hist(iris$Sepal.Length, breaks = 25, xlim = c(4, 8))

#######################
# Complete Exercise 5 #
#######################

# On a side note...remember when we introduced lists earlier? A common use of lists is to
# gather different types of R objects in one container. Many functions, including hist(),
# return a list of different values. Each attribute of the returned histogram correlates
# to a specific component of the list. For example, if we assign the output of
# hist(iris$Sepal.Length) to a variable, we can capture the returned list:

sepal_hist <- hist(iris$Sepal.Length)
sepal_hist

# There are many other built-in data sets in R. To see a list...

data()


#number of trials
n<-5
#  the probability of success when one person is selected from the population is
z<-0.9
#  probability that all five heads of the households are employed
y<-5
probability_forall5employed<-(factorial(n))/(factorial(y)*factorial(n-y))*(z^y)*(1-z)^(n-y)
print(probability_forall5employed)


#Copyright (c) 2016 Riccardo Francescato
a <- c(16.85,16.40,17.21,16.35,16.52,17.04,16.96,17.15,16.59,16.57)
b <- c(16.62,16.75,17.37,17.12,16.98,16.87,17.34,17.02,17.08,17.27)
#confidency level
alpha = .05
#type of test: 0 left tail 1 double tail 2 right tail
type = 2
#calculations....
n0 = length(a)		# number of reps for sample 0
n1 = length(b)		# number of reps for sample 1
xbar0 = mean(a)		# sample 0 mean
xbar1 = mean(b)		# sample 1 mean
s0 = sd(a)			# sample 0 standard deviation
s1 = sd(b)			# sample 1 standard deviation
f = (s0^2)/(s1^2)
if(type == 0){
	fc = qf(alpha,df1=n0-1,df2=n1-1,lower.tail=F)
	cat("Results of lower tail\n")
	cat("First sample\n")
	cat(paste("# of elements: ", n0, " Mean: ", xbar0, " St Dev: ",s0))
	cat("\nSecond sample\n")
	cat(paste("# of elements: ", n1, " Mean: ", xbar1, " St Dev: ",s1))
	cat(paste("\nf: ",f))
	cat(paste("\nfalpha: ",fc))
	if(f>fc) cat("\nREJECT H0\n") else cat("\nACCEPT H0\n")
}else if(type == 1){
	fct = qf(alpha/2,df1=n0-1,df2=n1-1,lower.tail=F)
	fcb = qf(1-alpha/2,df1=n0-1,df2=n1-1,lower.tail=F)
	cat("Results of 2-tail tail\n")
	cat("First sample\n")
	cat(paste("# of elements: ", n0, " Mean: ", xbar0, " St Dev: ",s0))
	cat("\nSecond sample\n")
	cat(paste("# of elements: ", n1, " Mean: ", xbar1, " St Dev: ",s1))
	cat(paste("\nf0: ",f))
	cat(paste("\nfalpha +: ",fct))
	cat(paste("\nfalpha -: ",fcb))
	if(f<fcb || f>fct) cat("\nREJECT H0\n") else cat("\nACCEPT H0\n")

}else if(type == 2){
	fc = qf(alpha,df1=n0-1,df2=n1-1,lower.tail=F)
	cat("Results of lower tail\n")
	cat("First sample\n")
	cat(paste("# of elements: ", n0, " Mean: ", xbar0, " St Dev: ",s0))
	cat("\nSecond sample\n")
	cat(paste("# of elements: ", n1, " Mean: ", xbar1, " St Dev: ",s1))
	cat(paste("\nf: ",f))
	cat(paste("\nfalpha: ",fc))
	if(f>fc) cat("\nREJECT H0\n") else cat("\nACCEPT H0\n")
}


## Set up and plot hypothetical paths of GDP per capita

## Set up scenarios
# Each scenario has ID, alpha, sI, gL, gA, delta, KY0, A0
scenario <- c('A','B','C','D','E')
alpha <- c(.3,.3,.3,.3,.3)
sI <- c(.2,.2,.2,.1,.4)
gL <- c(.01,.01,.01,.01,.01)
gA <- c(.02,.02,.02,.02,.02)
delta <- c(.05,.05,.05,.05,.05)
KY0 <- c(2.5,1.5,4,2.5,2.5)
A0 <- c(10,10,10,10,10)
label <- c('C','B','D','E','A') # allows different label for test purposes

# Year vector gives total periods to run over
year <- c(0:40)
s <- 0 # initializes Solow vector

# Merge year and scenario data to create scenario/year dataframe
all_scenario <- data.frame(scenario,alpha,sI,gL,gA,delta,KY0,A0) # combine scenario parameters
year_scenario <- expand.grid(year,scenario) # create year/scenario combinations
names(year_scenario) <- c("year","scenario")
s <- merge(year_scenario,all_scenario,by="scenario") # add parameters to year/scenario combos

# Make calculations of various values using theory
s$conv <- 1 - (1-s$alpha)*(s$delta + s$gA + s$gL) # convergence factor
s$kystar <- s$sI/(s$gL+s$gA+s$delta) # steady state capital/output ratio
s$ky <- s$KY0*(s$conv^s$year) + (s$kystar)*(1-(s$conv)^s$year) # actual KY ratio
s$kylag <- s$KY0*(s$conv^(s$year-1)) + (s$kystar)*(1-(s$conv)^(s$year-1)) # actual KY ratio
s$lny <- (s$alpha/(1-s$alpha))*log(s$ky) + log(s$A0) + s$gA*s$year # actual log GDP p.c.
s$lnystar <-(s$alpha/(1-s$alpha))*log(s$kystar) + log(s$A0) + s$gA*s$year # BGP log GDP p.c.
s$gky <- log(s$ky) - log(s$kylag)
s$gy <- (s$alpha/(1-s$alpha))*s$gky + s$gA

# Plot figure of scenarios and their BGP's
fig <- plot_ly(s, x = ~year, y = ~lny, linetype = ~scenario, type = 'scatter', mode = 'lines')
#fig <- add_trace(fig, x = ~year, y = ~lnystar, linetype = ~scenario, type = 'scatter', mode = 'lines')
fig <- layout(fig, title = list(text = 'log GDP per capita', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Log of GDP per capita'),
              hovermode="x unified")
api_create(fig, filename = "sim-solow-lny")

fig <- plot_ly(s, x = ~year, y = ~gy, linetype = ~label, type = 'scatter', mode = 'lines')
fig <- layout(fig, title = list(text = 'Growth rates', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Growth rate of GDP per capita'),
              hovermode="x unified")
api_create(fig, filename = "sim-solow-gy")

fig <- plot_ly(s, x = ~year, y = ~ky, linetype = ~scenario, type = 'scatter', mode = 'lines')
fig <- layout(fig, title = list(text = 'Capital/output ratio', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Capital/output ratio'),
              hovermode="x unified")
api_create(fig, filename = "sim-solow-ky")


nthroot <- function(A, n, tol=sqrt(.Machine$double.eps))
{
   ifelse(A < 1, x0 <- A * n, x0 <- A / n)
   repeat
   {
      x1 <- ((n-1)*x0 + A / x0^(n-1))/n
      if(abs(x1 - x0) > tol) x0 <- x1 else break
   }
   x1
}
nthroot(7131.5^10, 10)   # 7131.5
nthroot(7, 0.5)          # 49


#'@title Get the seasonality score for a given monthly time series
#'
#'@description The seasonality score of a monthly time series is computed as its departure from a uniform distribution.
#'
#'@usage  tsData.ss <- getSeasonalityScore(tsData)
#'
#'@details
#' The degree of seasonality of a monthly time series is based on its departure from a uniform distribution.
#' If the number of cases for a given concept is uniformly distributed across all time periods (in this case, all months),
#' then its monthly prevalence (as well as proportion) would be constant.  In this case, the time series would be
#' considered "absolutely non-seasonal" and its "seasonality score" would be zero.
#' Similarly, if all the cases occur at a single point in time (that is, in a single month), such a time series would be considered
#' "absolutely seasonal" and its seasonality score would be 1.  All other time series would have
#' a seasonality score between 0 and 1.  Currently, only monthly time series are supported.
#' NB: To be able to compute a seasonality score, a time series must have a minimum of three complete years of data.
#'
#'@param tsData  A time series object.
#'
#'@return A numeric value between 0 and 1 (inclusive) representing the seasonality of a time series.
#'
#'@import dplyr
#'@export

getSeasonalityScore <- function(tsData)
{
	tsObj <- tsData
	maxDist   <- 1.83
	unifDist  <- 1/12
	minMonths <- 36

	if (frequency(tsObj) != 12)
		stop("ERROR: Only monthly time series are supported")

	tsObj <- Castor::tsCompleteYears(tsObj)

	if (length(tsObj) < minMonths)
		stop("ERROR: Time series must have a minimum of three complete years of data")

	tsObj.yrProp <- Castor::sumAcrossYears(tsObj)$PROP

	tsObj.ss <- round(sum(abs(tsObj.yrProp-unifDist))/maxDist,2)

	return (tsObj.ss)
}


# FUNCTIONS

is_prime_6k1 <- function(n) {
    if (n <= 3) {
        return(n > 1)
    } else if (n %% 2 == 0 || n %% 3 == 0) {
        return(FALSE)
    }

    i <- 5
    while (i * i <= n) {
        if (n %% i == 0 || n %% (i + 2) == 0) {
            return(FALSE)
        }
        i <- i + 6
    }

    return(TRUE)
}

# SCRIPT

i <- 1
n <- 1
while (i != 10001) {
    n <- n + 2
    i <- i + is_prime_6k1(n)
}

message(n)


## Dale W.R. Rosenthal, 2018
## You are free to distribute and use this code so long as you attribute
## it to me or cite the text.
## The legal disclaimer in _A Quantitative Primer on Investments with R_
## applies to this code.  Use or distribution without these comment lines
## is forbidden.

price.tree <- function(numsteps, under.tree, opt.payoffs,
                       rf, delta.t, ups=0, downs=0) {
    if (numsteps > 0) {
        up.value <- price.tree(numsteps-1, under.tree, opt.payoffs,
                               rf, delta.t, ups+1, downs)
        down.value <- price.tree(numsteps-1, under.tree, opt.payoffs,
                                 rf, delta.t, ups, downs+1)
    } else {
        # We have reached a leaf; return the option payoff
        return(opt.payoffs[downs+1])
    }
    under.up.value <- under.tree[downs+1,ups+1+1]
    under.down.value <- under.tree[downs+1+1,ups+1]
    H <- (up.value-down.value)/(under.up.value-under.down.value)
    B <- (under.up.value*down.value - under.down.value*up.value)/
        (under.up.value - under.down.value)*exp(-rf*delta.t)
    H*under.tree[downs+1,ups+1] + B
}

rf <- 0.03  # 3% risk-free rates
sigma <- 0.45  # 45% volatility
T <- 1.25  # 15-month option
n.steps <- 16  # number of steps total
delta.t <- T/n.steps  # interpolated time step size
u <- exp(sigma*sqrt(delta.t))  # up move
d <- exp(-sigma*sqrt(delta.t))  # down move
s0 <- 100  # initial stock price
K <- 80  # strike price

## This creates a full matrix with the tree -- and steps beyond the tree
## in the lower-right triangle of the matrix.  Since this is an easy way
## to create the tree, we will just ignore the lower-right triangle.
underlier.tree <- s0*d^(0:n.steps)%*%t(u^(0:n.steps))
option.payoffs <- pmax(s0*u^(n.steps:0)*d^(0:n.steps) - K, 0)
price.tree(numsteps=n.steps, underlier.tree, option.payoffs, rf, delta.t)


url <- "https://ww2.amstat.org/publications/jse/datasets/fruitfly.dat.txt"
data <- read.table(url)
data <- data[, c(-1, -6)]

names(data) <- c("partners", "type", "longevity", "thorax")
par(mfrow = c(3, 2))
plot(data$thorax, data$longevity, col = data$partners, pch = data$type)

data0 <- data[data$partners == 0, ]
plot(data0$thorax, data0$longevity, col = data$partners, pch = data$type)

data1 <- data[data$partners == 1, ]
plot(data1$thorax, data1$longevity, col = data$partners, pch = data$type)

data8 <- data[data$partners == 8, ]
plot(data8$thorax, data8$longevity, col = data$partners, pch = data$type)

p0 <- as.integer(data$partners == 0)
p1t0 <- as.integer(data$partners == 1 & data$type == 0)
p1t1 <- as.integer(data$partners == 1 & data$type == 1)
p8t0 <- as.integer(data$partners == 8 & data$type == 0)
p8t1 <- as.integer(data$partners == 8 & data$type == 1)

data_dummy <- cbind(data, p0, p1t0, p1t1, p8t0, p8t1)
boxplot(cbind(data_dummy[data_dummy$p0 == 1, ]$longevity,
            data_dummy[data_dummy$p1t0 == 1, ]$longevity,
            data_dummy[data_dummy$p1t1 == 1, ]$longevity,
            data_dummy[data_dummy$p8t0 == 1, ]$longevity,
            data_dummy[data_dummy$p8t1 == 1, ]$longevity)
)

# use p0 as control group
fitfull <- lm(thorax ~ p1t0 + p1t1 + p8t0 + p8t1, data_dummy)
fitintercept <- lm(thorax ~ 1, data_dummy)
# not significant, so null hypothesis: model is the same should be acc.ed
print(anova(fitintercept, firfull))

reg_wo <- lm(longevity ~ type, data1)
print(summary(reg_wo))

reg_w <- lm(longevity ~ type + thorax, data1)
print(summary(reg_w))

reg_full_fail <- lm(longevity ~ thorax
                + as.factor(partners) * as.factor(type), data)

print(summary(reg_full_fail)) # some NA here, and most var are not significant

reg_full <- lm(longevity ~ thorax + p1t0 + p1t1 + p8t0 + p8t1, data_dummy)
print(summary(reg_full))

reg_reduce <- lm(longevity ~
                thorax +
                I(p1t0 - p8t1) +
                I(p1t1 + p8t1) +
                I(p8t0 + p8t1), data_dummy)
print(summary(reg_reduce))

print(anova(reg_reduce, reg_full))


spectralClustering <- function(affinity, K, type=3) {

  ###This function implements the famous spectral clustering algorithms. There are three variants. The default one is the third type.
  ###THe inputs are as follows:

      #affinity: the similarity matrix;
      #K: the number of clusters
      # type: indicators of variants of spectral clustering

  d = rowSums(affinity)
  d[d == 0] = .Machine$double.eps
  D = diag(d)
  L = D - affinity
  if (type == 1) {
    NL = L
  } else if (type == 2) {
    Di = diag(1 / d)
    NL = Di %*% L
  } else if(type == 3) {
    Di = diag(1 / sqrt(d))
    NL = Di %*% L %*% Di
  }
  eig = eigen(NL)
  res = sort(abs(eig$values),index.return = TRUE)
  U = eig$vectors[,res$ix[1:K]]
  normalize <- function(x) x / sqrt(sum(x^2))
  if (type == 3) {
    U = t(apply(U,1,normalize))
  }
  eigDiscrete = .discretisation(U)
  eigDiscrete = eigDiscrete$discrete
  labels = apply(eigDiscrete,1,which.max)

  return(labels)
}


ex1 = function()
{
	data = read.table("D:\\Facultate\\Capitole Speciale de Inteligenta Artificiala\\homework3\\data\\alcool.dat", header=T, sep="", dec=".")

	#1
	x = data[,2]
	y = data[,3]
	plot(x, y, pch=20, main='Scatter plot alcohol',
		xlab='Median alcohol consumption',
		ylab='Hearth disease related deaths')

	#2
	#raw formula
	x_mean = mean(x)
	y_mean = mean(y)
	r = sum( (x-x_mean) * (y-y_mean) ) /
	    (sqrt(sum( (x-x_mean)^2 )) * sqrt(sum( (y-y_mean)^2 )))
	message("My formula's result: ", r)

	#r function
	message("R formula's result: ", cor(x,y))
}

ex2 = function()
{
	data = read.table("D:\\Facultate\\Capitole Speciale de Inteligenta Artificiala\\homework3\\data\\iq.dat", header=T, sep="", dec=".")

	#1
	x = data[,2]
	y = data[,3]

	plot(x, y, pch=20, main='Scatter plot IQ',
		xlab='IQ',
		ylab='Grade')

	#2
	x_mean = mean(x)
	y_mean = mean(y)
	b1 = sum( (x-x_mean) * (y-y_mean) )/sum( (x-x_mean)^2 )
	b0 = y_mean - b1*x_mean
	abline(b0, b1, lwd=3, col='red')

	message("Grade estimate for 115 IQ: ", b0 + b1*115)
	message("Grade estimate for 130 IQ: ", b0 + b1*130)
}

ex3 = function(m, a, b, xmin, xmax, sigma)
{
	x = runif(m, min=xmin, max=xmax)
	e = rnorm(m, 0, sigma)
	y = a + b*x + e
	cbind(x, y)
}

ex4 = function(obs)
{
	x = obs[,1]
	y = obs[,2]

	x_mean = mean(x)
	y_mean = mean(y)
	b = sum( (x-x_mean) * (y-y_mean) )/sum( (x-x_mean)^2 )
	a = y_mean - b*x_mean

	y_estimate = a + b*x
	sse = sum( (y - y_estimate)^2 )
	s = sqrt(sse / (length(y) - 2))
	sb = s / sqrt(sum( (x-x_mean)^2 ))
	t = qt(0.975, df=(length(x) - 2))

	blow = b - t*sb
	bhigh = b + t*sb

	sa = sb*sqrt( sum(x^2) / length(x) )
	alow = a - t*sa
	ahigh = a + t*sa

	cbind(c(a,b), c(blow, bhigh), c(alow, ahigh))
}

plot_and_save = function(m, a, b, xmin, xmax, sigma, id)
{
	pdf(file=paste("D:\\Facultate\\Capitole Speciale de Inteligenta Artificiala\\homework3\\graphs\\graph_", id, ".pdf", sep=""),
		width=8, height=8
	)

	obs = ex3(m, a, b, xmin, xmax, sigma)
	res = ex4(obs)

	plot(obs[,1], obs[,2], pch=20,
		main=paste('a: ', res[1,1], ', b: ', res[2,1], '\n',
			'CI b: [', res[1,2], ' , ', res[2,2], ']\n',
			'CI a: [', res[1,3], ' , ', res[2,3], ']', sep=""),
		xlab='x',
		ylab='y')

	abline(a, b, lwd=3, col='red')
	abline(res[1,1], res[2,1], lwd=2, col='green')

	dev.off()
}

ex5 = function()
{
	#a
	plot_and_save(100, 10, 0.8, -200, 200, 1.5, 'a')

	#b
	plot_and_save(10, 10, 0.8, -5, 5, 1, 'b')

	#c
	plot_and_save(10000, 10, 0.8, -5, 5, 1, 'c')

	#d
	plot_and_save(10, 10, 0.8, 5, 5.2, 1, 'd')

	#e
	plot_and_save(10000, 10, 0.8, 5, 5.2, 1, 'e')

	#f
	plot_and_save(10, 10, 0.8, 5, 5.2, 0.01, 'f')

	'done'
}


# Source: Mollet and Cailliet 2002. Mar Freshwater Res. Comparative population
# demography of elasmobranch using life history tables, Leslie matrices and
# stage-based matrix models

rm(list=ls(all=TRUE)) # removes all previous material from R's memory

# Define a function to compute basic demographic parameters
basic_demographic_parameters <- function(M) {

  # finite growth rate (max eigenvalue)
  vM     <- eigen(M);
  lambda <- Re(vM$values[1]);       # Real part of the first eigenvector

  # population structure, i.e., the normalized right eigenvector
  # associated to the maximum eigenvalue
  ps  <-  Re(vM$vectors[,1]);
  ps  <-  ps / sum(ps);             # normalize

  # reproductive value, i.e, the left eigenvector associated to the
  # maximum eigenvalue (it is computed as the right eigenvector of the
  # transposed matrix)
  rv  <-  Re(eigen(t(M))$vectors[,1]);
  rv  <-  rv / rv[1];               # standardize relative to 1st class

  #Sensitivity and elasticity
  sens <- outer(rv,ps) / sum(rv*ps) # sensitivity
  elas <- (sens*M) / lambda         # elasticity [%]

  return(list(lambda=lambda, ps=ps, rv=rv, elast=elas))

}

#############################################################################
# let's look first at the full matrix

# create a 10x10 matrix and assign 0 to all the elements
transM <- matrix(nrow=10, ncol=10, byrow=TRUE, data=0)

# set reproductive rate
# Only age 3 and older reproduce
for (j in 3:10) transM[1,j] <- 1.8929

# set survivals
# Fill in the sub-diagonal for ages 1-9
for (j in 1:9) transM[j+1,j] <- 0.631

#check the transition matrix
transM

#plot the transition matrix
image(1:nrow(transM), 1:ncol(transM), t(transM), ylim =c(ncol(transM)+0.5, 0.5) )

# Call our function
bdp_transM_L <- basic_demographic_parameters(transM); bdp_transM_L

sum(bdp_transM_L$ps[3:10])

image(1:nrow(bdp_transM_L$elas), 1:ncol(bdp_transM_L$elas), t(Mod(bdp_transM_L$elas)), ylim =c(ncol(transM)+0.5, 0.5))

#############################################################################
# let's now look  at the reduced matrices

reducedM <- matrix(nrow=3, ncol=3, byrow=TRUE,
  data<-c(    0,     0, 1.8929,
         0.631,     0,     0,
	         0,  0.631, 0.6272))

basic_demographic_parameters(reducedM)

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

reduced2M <- matrix(nrow=2, ncol=2, byrow=TRUE,
  data<-c(    0.4104,     1.8929,
             0.2206,     0.6272))

basic_demographic_parameters(reduced2M)

age_size/3_Mollet and Cailliet 2002. Mar Freshwater Res. Comparative.r


#R version 3.3.2

firstFibonacci <- 1

secondFibonacci <- 1

sum_of_even_fibonacci <- 0

helper <- 0

# O(n) solution
while (secondFibonacci <= 4000000) {
    helper <- firstFibonacci
    firstFibonacci <- secondFibonacci
    secondFibonacci <- firstFibonacci + helper

    if (secondFibonacci %% 2 == 0) {
        sum_of_even_fibonacci <- sum_of_even_fibonacci + secondFibonacci
    }
}

print(sum_of_even_fibonacci)


## Dale W.R. Rosenthal, 2018
## You are free to distribute and use this code so long as you attribute
## it to me or cite the text.
## The legal disclaimer in _A Quantitative Primer on Investments with R_
## applies to this code.  Use or distribution without these comment lines
## is forbidden.

alpha <- 0.05  # probability mass in the loss tail
t.df <- 5      # degrees of freedom for the t-distribution

# Calculate VaR (inverse CDF) and expected shortfall (numeric integration)
value.at.risk <- qt(alpha, df=t.df)
t5.mean.integrand <- function(x) { x*dt(x,t.df)}
ex.shortfall <- 1/alpha*integrate(t5.mean.integrand, lower=-Inf,
                                  upper=value.at.risk)[["value"]]

curve(dt(x, t.df), xlim=c(-4,4), lwd=2)  # plot the t-distribution

# Setup for drawing a filled-in area under the curve
x.seq <- seq(-5, value.at.risk, 0.01)
y.seq <- dt(x.seq, t.df)
cord.x <- c(-5, x.seq, value.at.risk)
cord.y <- c(0, y.seq, 0)
polygon(cord.x, cord.y, col="plum1")  # and draw the filled-in area

abline(v=value.at.risk, lty=2, lwd=2, col="red")  # add a vertical line at the VaR
abline(v=ex.shortfall, lty=4, lwd=2, col="deepskyblue")   # add a vertical line at the ES
abline(h=0)
text(x=-2.015, y=0.05, "5%-VaR", pos=4)  # Add text notes near...
text(x=-2.890, y=0.01, "5%-ES", pos=4)   # ...the vertical lines


#' Calculate settling velocity for a particle.
#'
#' \code{settle} calculates the settling velocity for a particle, given some parameters.
#' @param ws_mode Denotes whether to use a 'simple' equation, neglecting the shape and roundness of particles, or to use the more 'complex' formulation
#' @param D The grain size you wish to calculate settling velocity for.
#' @param constants A list of constants for calculation, need in order (g) gravitational constant, (rhos) sediment density, (rhof) fluid density, (nuu) kinematic viscosity, (csf) corey shape factor, and (PI) Powers roundness index. For the simple formulation, neglect the last two. Defaults to constants = list(g = 9.8, rhos = 2650, rhof = 1000, nuu  = 1.004e-6, csf = 0.7, PI = 3.5)
#' @return Returns a list with two values \code{$ws} and \code{$wstar} which are the settling velocity and dimensionless settling velocity, respectively.
#' @export
#' @examples
#' settle('simple', 120e-6)
#' settle('complex', 120e-6, list(g = 9.8, rhos = 2650, rhof = 1000, nuu  = 1.004e-6, csf = 0.7, PI = 3.5)

#	function to replicate two implementations of Dietrich 1982 settling velocity measurement for a given grain size and density.
#	Eric Barefoot
#	Nov 2017

#	takes constants as a list with names g, rhos, rhof, nuu, csf, PI with an option to leave off csf and PI for a simpler case

settle = function(ws_mode, D, constants) {

	if(missing(constants)) {
		g = 9.8			# m/s^2
		rhos = 2650		# assuming ~quartz sand.
		rhof = 1000		# assuming water
		nuu  = 1.004e-6	# kinematic viscocity of water at 20C in Pa s
		csf = 0.7		# given csf for grains
		PI = 3.5		# average for natural grains. Varies from 0-6.
	}
	else if (ws_mode == 'simple' & length(constants) != 4) {
		warning('incorrect number of constants; using defaults for the simple method')
		g = 9.8			# *m/s^2
		rhos = 2650		# *assuming ~quartz sand.
		rhof = 1000		# *assuming water
		nuu  = 1.004e-6}# *kinematic viscocity of water at 20C in Pa s}
	else if (ws_mode == 'complex' & length(constants) != 6) {
		warning('incorrect number of constants; using defaults for the complex method')
		g = 9.8			# m/s^2
		rhos = 2650		# assuming ~quartz sand.
		rhof = 1000		# assuming water
		nuu  = 1.004e-6	# kinematic viscocity of water at 20C in Pa s
		csf = 0.7		# given csf for grains
		PI = 3.5}		# average for natural grains. Varies from 0-6.
	else if (ws_mode == 'simple') {
		g = constants$g			# m/s^2
		rhos = constants$rhos	# assuming ~quartz sand.
		rhof = constants$rhof	# assuming water
		nuu  = constants$nuu	# kinematic viscocity of water at 20C in Pa s
	}
	else if (ws_mode == 'complex') {
		g = constants$g			# m/s^2
		rhos = constants$rhos	# assuming ~quartz sand.
		rhof = constants$rhof	# assuming water
		nuu  = constants$nuu	# kinematic viscocity of water at 20C in Pa s
		csf = constants$csf		# given csf for grains
		PI = constants$PI		# average for natural grains. Varies from 0-6.
	}

	#	calculate dimensionless grain size

	Dstar = (rhos - rhof) * ((g * D^3) / (rhof * nuu^2))

	#	simple case

	if (ws_mode == 'simple') {

		Dsl = log10(Dstar)

		R1 = -3.76715 + 1.92944*Dsl - 0.09815*Dsl^2 - 0.00575*Dsl^3 + 0.00056*Dsl^4

		wstar = 10^(R1)

	}

	if (ws_mode == 'complex') {
	#	some simplifying common terms

		Dsl = log10(Dstar)
		tantan = tanh(Dsl - 4.6)
		csf_t = 1 - csf

		#	now the other parameters for settling velocity
		#	NOTE: lynds et al neglect the other terms, so theres a switch, one with the shape factor and powers index, and one without. default is simple

		R1 = -3.76715 + 1.92944*Dsl - 0.09815*Dsl^2 - 0.00575*Dsl^3 + 0.00056*Dsl^4

		R2 = (log10(1 - (csf_t/0.85)) - csf_t^2.3*tantan + 0.3*(0.5 - csf)*csf_t^2*(Dsl - 4.6))

		R3 = (0.65 - ((csf/2.83)*tantan))^(1+(3.5-PI)/2.5)

		wstar = R3 * 10^(R1 + R2)
	}

	#	conversion back to dimensional settling velocity

	ws = (wstar * (rhos - rhof) * g * nuu / rhof)^(1/3)

	return(list(ws = ws, wstar = wstar))

}


##### Chapter 5: Classification using Decision Trees and Rules -------------------

# 트리에 다수의 명목 특징이 여러 레벨로 이루어져 있거나, 다수의 수치 특성이 있는 경우 tree overfit
# 매개 변수(parameter) 조정으로 이러한 단점을 극복할 수 있다.
# 트리 생성을 일찍 중단하거나(사전 가지치기 pre-prunning)
# 트리를 만든 후 데이터 포인터가 적은 노드를 삭제하거나 병합하는 것(사후 가지치기 post-prunning)

# 랜덤 포레스트와, 그래디언트 부스팅으로도 이러한 단점을 극복할 수 있다.

# 트리의 C5.0 알고리즘은 트리 식별 방법으로 엔트로피를 이용한다.
# 클래스가 n개인 경우 엔트로피의 범위는 0에서 log2(밑이 2)n이다.(클래스 값의 집합 내의 무작위성 또는 무질서를 정량화)

#### Part 1: Decision Trees -------------------

## Understanding Decision Trees ----
# calculate entropy of a two-class segment
-0.60 * log2(0.60) - 0.40 * log2(0.40) # 하나는 확률 0.6, 나머진 0.4인 경우

curve(-x * log2(x) - (1 - x) * log2(1 - x), # 클래스 2개일 때 모든 가능한 엔트로피 배열
      col = "red", xlab = "x", ylab = "Entropy", lwd = 4)
# 분할을 하기 위한 최적의 특징을 결정하기 위해 엔트로피를 사용하려면
# 알고리즘은, 각 특징별로, 분할로 인해 생기는 동질성의 변화를 계산한다.
# 이것이 정보 획득량이라고 하는 척도이다.
## 어떠한 특징 F의 정보 획득량은 분할 전 세그먼트 S1과 분할로 생성된 파티션들 S2의 엔트로피 차로 계산된다.
# 그런데 문제는 분할 후에 데이터가 하나 이상의 파티션으로 나뉜다
# -> S2 계산하는 함수는 모든 파티션의 전체 엔트로피 고려
# -> n개 파티션에 대해, 각 파티션의 엔트로피에 파티션이 속하는 예시 비율로 가중치 부여하여 합산.

# 정보 획득량 높음 -> 이 특징에 분할한 후 동질적 그룹을 생성하기 더 좋은 특징.
# 수치 특성에 대해 분할할 때에도 정보 획득량 사용 -> 어떠한 임계값보다 큰지 작은지로 나눈다. 그 임계값은 다양하게 테스트한다.
# 이러한 방식으로 수치적 특성을 2레벨 범주형 특성으로 나눈다.
# 그리고 분할 시 최대 정보 획득량을 산출하는 수치 절단점을 선택한다.

# 사전 가지치기를 하면, 감지하기는 힘들지만 트리가 크게 자랐다면 학습할 수도 있는 중요한 패턴을 놓칠 수도 있다.
# 그 대안으로 사후 가지치기를 한다.
# -> 먼저 overfit되는 큰 트리로 자라게 한 후, 나중에 분류 오류에 영향이 거의 없는 노드와 분기는 제거한다.
# -> 어떤 때에는 전체 분기가 위쪽으로 옮겨지거나, 좀 더 간단한 의사결정으로 대체된다.

# overfit과 underfit의 균형을 맞추는 것은 다소 기술적.
# 하지만 모델의 정확도가 필수적이라면 다양한 가지치기 옵션으로 테스트 데이터에 대해 성능 향상이 되는지 투자해야!

## Example: Identifying Risky Bank Loans ----
## Step 2: Exploring and preparing the data ----
getwd()
setwd('D:/R_LAB/MLwR/Chapter 05')

credit <- read.csv("credit.csv")
str(credit)

# look at two characteristics of the applicant
table(credit$checking_balance)
table(credit$savings_balance)

# look at two characteristics of the loan
summary(credit$months_loan_duration)
summary(credit$amount)

# look at the class variable
table(credit$default)

# create a random sample for training and test data
# use set.seed to use the same random number sequence as the tutorial
# 훈련에 데이터 90% 사용, 테스트에 10% 사용
# 임의로 정렬되어 있지 않은 데이터를 다루는 방법 -> 랜덤 샘플
set.seed(123) # 랜덤 샘플 수행하기 전에 시드값 설정
train_sample <- sample(1000, 900)

str(train_sample)

# split the data frames
credit_train <- credit[train_sample, ]
credit_test  <- credit[-train_sample, ]

# check the proportion of class variable
# 잘 나뉘었다면 각 데이터셋은 약 30%의 채무불이행 대출을 갖는다.
prop.table(table(credit_train$default)) # 잘 나뉘었다
prop.table(table(credit_test$default)) # 잘 나뉘었다

## Step 3: Training a model on the data ----
# build the simplest decision tree
if(!require(C50)) {
  install.packages("C50")
  require(C50)
}
# ?C5.0Control 명령으로 알고리즘을 정교하게 조정하는 방법에 대한 더 자세한 사항을 확인할 것

# credit_train의 17번째 열은 default 클래스 변수이므로 제외한다.
# 그리고 분류를 하기 위한 목표 팩터 벡터로 제공해야 한다.
credit_model <- C5.0(credit_train[-17], credit_train$default)

# display simple facts about the tree
credit_model # 트리 크기 57 -> 트리가 57개의 결정으로 이뤄진 깊이라는 뜻.

# display detailed information about the tree
summary(credit_model)
# 가끔 트리는 논리적으로 이해가 안 되는 결정을 만든다.
# ex) 왜 대출 이력이 좋은 신청자가 채무불이행 가능성 있지? 왜 수표 계좌 잔고를 모르면 채무불이행 가능성 없지?
# 그런 규칙들은 데이터의 실제 패턴을 반영한 결과일 수도 있고
# 단지 통계적 이상치일 수도 있다.
# 두 경우 모두, 트리의 논리가 비즈니스 용도로 합당한지 확인하기 위해
# 이런 이상한 결정을 조사해보는 것이 중요하다.

# 트리를 출력한 후 혼동 행렬을 보여준다.
# 혼동 행렬은 모델이 훈련 데이터에서 부정확하게 분류한 레코드를 보여주는 교차표다.

## Step 4: Evaluating model performance ----
# create a factor vector of predictions on test data
credit_pred <- predict(credit_model, credit_test)

# cross tabulation of predicted versus actual classes
library(gmodels)
# gmodels 패키지에 있는 CrossTable() 함수를 통해, 이 벡터와 실제 클래스 값을 비교할 수 있다.
CrossTable(credit_test$default, credit_pred,
           prop.chisq = FALSE, prop.c = FALSE, prop.r = FALSE,
           dnn = c('actual default', 'predicted default'))
# prop.c = FALSE, prop.r = FALSE 하면 표에서 열과 행 비율을 제거한다.

# 남은 백분율 prop.t는 전체 레코드 개수에서 셀의 레코드 비율을 나타낸다.

## Step 5: Improving model performance ----
# 실제 채무불이행 중 42%만 정확히 예측했다. 이는 매우 큰 비용이 될 수 있다.

## Boosting the accuracy of decision trees
# boosted decision tree with 10 trials(부스팅 팀에 사용할 독립적 트리의 갯수를 10개로 늘림)
credit_boost10 <- C5.0(credit_train[-17], credit_train$default,
                       trials = 10)
# rules = TRUE를 명시하면 분류 규칙을 이용해 모델을 생성하게 된다.

credit_boost10 # 트리의 크기가 57에서 47로 줄어들었다.
summary(credit_boost10)
# 부스팅을 추가하기 전 오류율보다 매우 줄어들었다.

# 테스트 데이터에서도 성능 향상이 될까?
credit_boost_pred10 <- predict(credit_boost10, credit_test)
CrossTable(credit_test$default, credit_boost_pred10,
           prop.chisq = FALSE, prop.c = FALSE, prop.r = FALSE,
           dnn = c('actual default', 'predicted default'))
# 오류율이 27에서 18로 줄었다. 채무불이행은 여전히 예측율이 낮다.
# 더 크게 개선되지 않은 이유
  # 1. 상대적으로 작은 훈련 데이터셋과 함수 관계
  # 2. 이 문제 자체가 원래 해결하기 어려운 문제

# 부스팅을 쓰지 않는 이유 -> 계산량 증가, 훈련 데이터에 잡음이 많으면 부스팅으로 개선되지 않음.

## Making some mistakes more costly than others

# create dimensions for a cost matrix
# 트리가 좀 더 비용이 많이 드는 실수를 하지 못하도록
# 여러 오류 유형에 페널티를 줄 수 있음.
matrix_dimensions <- list(c("no", "yes"), c("no", "yes"))
names(matrix_dimensions) <- c("predicted", "actual")
matrix_dimensions

# build the matrix
# 행렬을 채울 때 열 단위로 위에서 아래로 채우기 때문에, 특정 순서대로 값을 제공해야 한다.
# pre x act x
# pre o act x
# pre x act o
error_cost <- matrix(c(0, 1, 4, 0), nrow = 2, dimnames = matrix_dimensions)
error_cost

# apply the cost matrix to the tree
credit_cost <- C5.0(credit_train[-17], credit_train$default,
                          costs = error_cost)
credit_cost_pred <- predict(credit_cost, credit_test)

CrossTable(credit_test$default, credit_cost_pred,
           prop.chisq = FALSE, prop.c = FALSE, prop.r = FALSE,
           dnn = c('actual default', 'predicted default'))
# 거짓 긍정을 증가시킨 대가로 거짓 부정을 줄였다.
# 전체적인 실수는 증가했지만, 이렇게 하는 편이 오히려 이익이 될 수도 있다.

#### Part 2: Rule Learners -------------------

# 분류 규칙은, 클래시를 레이블이 없는 예시에 할당하는 논리적인 if-else문으로 지식을 표현한다.
# -> 이것이 발생하면, 저것이 발생한다.

# 규칙은 tree로도 생성할 수 있는데 왜 별도의 규칙 학습자 알고리즘에 신경을 쓰는가?
# -> 규칙 학습자가 규칙을 직접 찾음으로써 피할 수 있는 작업에 대해,
# 의사 결정 트리는 특정 편향을 불러오기 때문이다.

# 규칙 학습자는 일반적으로, 특징이 주로 또는 전체적으로 명목형인 문제에 적용된다.
# 희소한 사건이, 특징 값 사이에 매우 특정한 상호작용에서 발생한다 하더라도, 규칙 학습자는 희소 사건을 잘 식별함.

# 클래스 값을 식별하는 점점 더 구체적인 규칙을 생성해 데이터를 드릴 다운한다.
# 규칙이 데이터의 부분을 커버하는 것 같아 보이기 때문에, 분리 정복 알고리즘은 커버링 알고리즘이라고도 한다.

# ZeroR -> 아무 규칙도 학습하지 않는 규칙 학습자(ex. 셋 중에 하나 뽑기)
## 1R 알고리즘 -> 하나의 규칙을 선택하는 방식.
  # 각 특징에 대해 유사한 값으로 데이터를 그룹으로 분리한다.
  # 그 다음 알고리즘은 각 세그먼트에 대해 대다수 클래스를 예측한다.
  # 각 특징에 기반을 두는 규칙의 오류율을 계산하고, 최소 오류를 갖는 규칙을 단일 규칙으로 선정한다.
# 1R 알고리즘은 너무 느리고, 잡음이 섞이면 쉽게 부정확해진다.

# RIPPER 알고리즘으로 규칙 학습자를 만들자.
# RIPPER 알고리즘의 3단계
  # 1. 기르기
    # 규칙에 조건을 탐욕스럽게 추가하기 위해 분할 정복 기법 사용
    # 데이터의 부분집합을 완벽하게 분류하거나, 분할을 위한 속성이 없어질 때까지 진행
    # 정보 획득량 기준 사용 -> 규칙이 더 정교햐져도 엔트로피가 줄지 않으면, 그 규칙은 가지치기된다.
  #
# 탐욕스러운 학습자 -> 선입 선처리 기반으로 데이터 사용
  # -> 한 번에 하나의 파티션을 만들고자 함. 먼저 가장 동질적인 파티션을 찾고 난 후에 차선을 찾고
    # -> 모든 예시가 다 분류될 때까지 계속해서 찾는다.
  # 단점 : 특정 데이터셋에 최적이고, 가장 정확하고, 최소 개수로 된 규칙을 생성한다는 보장이 없음
    # -> 데이터의 한 부분집합에 대해 정확한 한 개의 규칙은 계속해서 찾아낼 수 있지만
    # -> 전체 데이터셋에 대해 더 나은 전반적인 정확도를 갖는 좀 더 섬세한 규칙들을 개발할 기회 잃게 됨.

# 트리와 규칙 모두 탐욕 학습 휴리스틱 사용. 차이는
  # 트리는 이전 결정의 이력에 의해 영원히 제한된다.
  # 규칙은 규칙의 모든 조건으로 커버되지 않는 어떤 예시든 다음 규칙에 의해 재정복 가능.

## Example: Identifying Poisonous Mushrooms ----
## Step 2: Exploring and preparing the data ----
mushrooms <- read.csv("mushrooms.csv", stringsAsFactors = TRUE)

# examine the structure of the data frame
str(mushrooms)

# drop the veil_type feature(범주인데 하나밖에 없음 ->쓸모도없다)
mushrooms$veil_type <- NULL

# examine the class distribution
table(mushrooms$type)

## Step 3: Training a model on the data ----
library(RWeka) # JAVA 설치 필요

# train OneR() on the data
mushroom_1R <- OneR(type ~ ., data = mushrooms) # 1R 만들어내는 함ㅅ
# 규칙 학습자가 type ~. 을 통해 모든 특징을 고려하도록 만듦

## Step 4: Evaluating model performance ----
mushroom_1R
summary(mushroom_1R)

## Step 5: Improving model performance ---- # RIPPER 규칙 사용
mushroom_JRip <- JRip(type ~ ., data = mushrooms)
mushroom_JRip # 전체 9개의 규칙(if-else문)을 학습함.
summary(mushroom_JRip)

# Rule Learner Using C5.0 Decision Trees (not in text)
library(C50)
mushroom_c5rules <- C5.0(type ~ odor + gill_size, data = mushrooms, rules = TRUE)
summary(mushroom_c5rules)


#' winddir
#'
#' @description Calculate meteorological wind direction from cartesian components u and v.
#'
#' @param u numeric U zonal component
#' @param v numeric V meridian component
#'
#' @references
#' Istituto di Biometeorologia Firenze Italy
#' @author  Alfonso crisci \email{a.crisci@@ibimet.cnr.it} Marco Morabito \email{m.morabito@@unifi.it}
#' @keywords Meteorological Wind direction
#'
#'
#' @export

winddir <- function(u, v) {
                    (180 / pi) * atan(u/v) + ifelse(v>0,180,ifelse(u>0,360,0))
}


library("magrittr")
a <- 0.88
b <- 1.55

costA <- function(lambda){
	return(160 + (40 * (lambda + lambda^2)))
}

costB <- function(lambda){
	return(128 + (40 * (lambda + lambda^2)))
}

ansa <- costA(a) #226.176
ansb <- costB(b) #286.1
cat(sprintf("%.3f\n", ansa))
cat(sprintf("%.3f\n", ansb))

cat(round(ansa,3),'\n')
cat(round(ansb,3))

#simulation:
n <- 10^8
asim <- rpois(n = n, lambda = a)
bsim <- rpois(n = n, lambda = b)

amax <- asim %>% max
bmax <- bsim %>% max

calc <- function(v, max){
	zeroToN = c()
	for(i in 0:max)
	{
		bool <- ifelse(v == i, 1, 0)
		proportionI <- sum(bool)/n
		zeroToN = c(zeroToN, proportionI)
	}
	return(zeroToN)
}

costa <- function(X){
	return(160 + (40 * X^2))
}
costb <- function(Y){
	return(128 + (40 * Y^2))
}

#apply cost functions to random variables x and y

acost <- sapply(X = asim, FUN = costa)
bcost <- sapply(X = bsim, FUN = costb)

sum(acost)/n
sum(bcost)/n

aans <- acost %>% sum()/n
bans <- bcost %>% sum()/n
cat(aans, "\n")
cat(bans)


require(Rdonlp2)

factors <- c(
  0.02040000,-0.08672903,0.06208421,0.08537144,
  0.08530000,0.01567469,0.08519883,0.13293438,
  0.02570000,-0.03997748,0.04657237,0.04977169,
  0.00760000,0.04163002,-0.00568537,-0.02547824,
  0.04540000,0.11255746,0.05319682,0.04129890,
  -0.01830000,0.00805313,-0.00421743,-0.05443995,
  -0.03520000,-0.08656963,-0.05054419,-0.01769600,
  0.07920000,0.16539408,0.05479713,0.06737632,
  0.03190000,0.02451794,0.02632593,0.01820807,
  0.07870000,0.05045111,0.07801389,0.09820405,
  0.02140000,0.02911620,0.00553052,0.03437993,
  0.08920000,0.16132008,0.09959438,0.09472788,
  -0.02850000,-0.02864671,-0.03634867,-0.04231819,
  0.02810000,0.02976673,0.03965725,0.04903749,
  0.08810000,0.07181523,0.07879099,0.06418204,
  0.09070000,0.11896197,0.07516213,0.11833781,
  -0.02310000,-0.07499952,-0.00807299,-0.02992491,
  0.06940000,0.09002753,0.09137129,0.09216098,
  0.02640000,0.08124712,0.02024337,0.02541702,
  -0.04460000,0.01855777,-0.04992867,-0.04843952,
  0.01530000,0.10141779,0.02720172,0.05258464,
  -0.00860000,-0.04908988,-0.00546264,-0.03273162,
  0.05120000,0.05606888,0.08323532,0.08211691,
  0.02090000,0.00249315,0.02060449,-0.00069403,
  0.05400000,0.03418127,0.05196274,0.04239199
)

factors <- matrix(data=factors, nrow=25, ncol=4, byrow=TRUE)

fund_returns <- c(
  0.07950000,
  0.11440000,
  0.04550000,
  0.01010000,
  0.03350000,
  -0.01470000,
  -0.02160000,
  0.07120000,
  0.02200000,
  0.08970000,
  0.02530000,
  0.04560000,
  -0.01980000,
  0.03100000,
  0.06020000,
  0.08530000,
  0.00640000,
  0.05500000,
  0.02920000,
  -0.02150000,
  0.00160000,
  0.00830000,
  0.04780000,
  0.02280000,
  0.04110000
)

objective <- function(weights) {

  # ASSERT: ncol(factors) == length(weights)

  # calculate the sum product of factors and weights
  sum_product <- factors %*% matrix(weights, ncol=1)
  sum_product_return <- cbind(sum_product, fund_returns)
  residuals <- sum_product_return[, 2] - sum_product_return[, 1]

  # ASSERT: nrow(factors) == length(residuals)

  # calculate (and return) the stdev of the residuals
  sd(residuals)
}

weights <- c(0.25, 0.25, 0.25, 0.25)   # start weights

# weight constraints
weights.lower <- c(0, 0, 0, 0)         # >= 0
weights.upper <- c(1, 1, 1, 1)         # <= 1

# equality constraints
eqFun <- list(
  function(x) sum(x)
)
eqFun.bound <- c(1)

# note: no need for inequality and non-linear constraints

x1 <- donlp2NLP(
  par = weights,
  par.lower = weights.lower,
  par.upper = weights.upper,
  fun = objective,
  eqFun = eqFun,
  eqFun.bound = eqFun.bound
)

#str(x1)

found_weights = x1$par

# sanity check
if (sum(found_weights) > 1.00000000000001 || sum(found_weights) < 1)
 cat('FAILED: Sum(W) = ', sum(found_weights), '\n')

if (sum(abs(found_weights)) > 1.00000000000001 || sum(abs(found_weights)) < 1)
 cat('FAILED: Sum(Abs(W)) = ', sum(abs(found_weights)), '\n')

if(any(found_weights < 0) || any(found_weights > 1))
  cat('FAILED: One or more factor weight <0 or >1\n')

# print out weights....
cat(found_weights[1], '\t', found_weights[2],'\t', found_weights[3],'\t', found_weights[4], '\n')


# R code for chapter 5 of Wood (2006) "GAMs: An Introduction with R"

## 5.1 Cherry trees again

library(mgcv)
data(trees)
ct1<-gam(Volume~s(Height)+s(Girth),
         family=Gamma(link=log),data=trees)
ct1
par(mfrow=c(1,2))
plot(ct1,residuals=TRUE)

## 5.1.1 Finer control of gam

ct2 <- gam(Volume~s(Height,bs="cr")+s(Girth,bs="cr"),
           family=Gamma(link=log),data=trees)
ct2
par(mfrow=c(2,2))
plot(ct1,residuals=TRUE)
plot(ct2,residuals=TRUE)

ct3 <- gam(Volume ~ s(Height)+s(Girth,bs="cr",k=20),
           family=Gamma(link=log),data=trees)
ct3

ct4 <- gam(Volume ~ s(Height) + s(Girth),
           family=Gamma(link=log),data=trees,gamma=1.4)
ct4
par(mfrow=c(2,2))
plot(ct1,residuals=TRUE)
plot(ct4,residuals=TRUE)

## 5.1.2 Smooths of several variables

ct5 <- gam(Volume ~ s(Height,Girth,k=25),
           family=Gamma(link=log),data=trees)
ct5
plot(ct5,too.far=0.15)

ct6 <- gam(Volume ~ te(Height,Girth,k=5),
           family=Gamma(link=log),data=trees)
ct6
plot(ct6,too.far=0.15)

## 5.1.3 Parametric model terms

gam(Volume~Height+s(Girth),family=Gamma(link=log),data=trees)
trees$Hclass <- factor(floor(trees$Height/10)-5,
                labels=c("small","medium","large"))

ct7 <- gam(Volume ~ Hclass+s(Girth),
           family=Gamma(link=log),data=trees)
par(mfrow=c(1,2))
plot(ct7,all.terms=T)

anova(ct7)
AIC(ct7)
summary(ct7)

## 5.2 Brain imaging example
## 5.2.1 Preliminary modeling
library(gamair)
data(brain)
brain

## Each row corresponds to one voxel

brain <- brain[brain$medFPQ>=3e-5,] # exclude 2 outliers
m0 <- gam(medFPQ~s(Y,X,k=100),data=brain)
gam.check(m0)

e <- residuals(m0); fv <- fitted(m0)
lm(log(e^2)~log(fv))

m1<-gam(medFPQ^.25~s(Y,X,k=100),data=brain)
gam.check(m1)

m2<-gam(medFPQ~s(Y,X,k=100),data=brain,family=Gamma(link=log),optimizer="perf")

mean(fitted(m1)^4);mean(fitted(m2));mean(brain$medFPQ)
m2

vis.gam(m2,plot.type="contour",too.far=0.03,
        color="gray",n.grid=60,zlim=c(-1,2),main="model m2 image plot and overlaid contours on scale of linear predictor")

## 5.2.2 Would an additive structure be better?
m3 <- gam(medFPQ~s(Y,k=30)+s(X,k=30),data=brain,
          family=Gamma(link=log),optimizer="perf")
m3
summary(m2)
summary(m3)
# Compare models m2 and m3
anova(m3,m2,test="F")

m4 <- gam(medFPQ~s(Y,k=30)+s(X,k=30)+s(Y,X,k=100),data=brain,
      family=Gamma(link=log),optimizer="perf")

## 5.2.3 Isotropic or tensor product smooths?

tm<-gam(medFPQ~te(Y,X,k=10),data=brain,family=Gamma(link=log),
        optimizer="perf")
tm1<-gam(medFPQ~s(Y,k=10,bs="cr")+s(X,bs="cr",k=10),
         data=brain,family=Gamma(link=log),optimizer="perf")

tm1
tm
anova(tm1,tm,test="F")

## So we plot them again
vis.gam(tm1,plot.type="contour",too.far=0.03,
        color="gray",n.grid=60,zlim=c(-1,2),main="model tm1 image plot and overlaid contours")

vis.gam(tm,plot.type="contour",too.far=0.03,
        color="gray",n.grid=60,zlim=c(-1,2),main="model tm image plot and overlaid contours")

## 5.3 Air pollution in Chicago example
library(mgcv)
library(gamair)
data(chicago)
ap0 <- gam(death~s(time,bs="cr",k=200)+pm10median+so2median+
           o3median+tmpd,data=chicago,family=poisson)
gam.check(ap0)

par(mfrow=c(2,1))
plot(ap0,n=1000)  # n increased to make plot smooth
plot(ap0,residuals=TRUE,n=1000)

chicago$death[3111:3123]

ap1<-gam(death~s(time,bs="cr",k=200)+s(pm10median,bs="cr")+
     s(so2median,bs="cr")+s(o3median,bs="cr")+s(tmpd,bs="cr"),
     data=chicago,family=poisson)
gam.check(ap1)

par(mfrow=c(3,2))
plot(ap1,n=1000)

lag.sum <- function(a,l0,l1)
## l0 is the smallest lag, l1 the largest
{ n<-length(a)
  b<-rep(0,n-l1)
  for (i in 0:(l1-l0)) b <- b + a[(i+1):(n-l1+i)]
  b
}
death<-chicago$death[4:5114]
time<-chicago$time[4:5114]
o3 <- lag.sum(chicago$o3median,0,3)
tmp <- lag.sum(chicago$tmpd,0,3)
pm10 <- lag.sum(log(chicago$pm10median+40),0,3)
so2 <- lag.sum(log(chicago$so2median+10),0,3)

ap2 <- gam(death ~ s(time,bs="cr",k=200) +
                   te(o3,tmp,pm10,k=c(8,8,6)),family=poisson)
gam.check(ap2)

ap3 <- gam(death ~ s(time,bs="cr",k=200) + te(o3,tmp,k=8) +
                   s(pm10,bs="cr",k=6),family=poisson)
par(mfrow=c(3,1))
plot(ap3)

## 5.6.1 Package 'gam' (note need to run chicago pre-proc first)

detach(package:mgcv)
library(gam)
install.packages("akima")
library(akima) # needed for plotting
bfm <- gam(death~s(time,df=140)+lo(o3,tmp,span=.1),
           family=poisson,control=gam.control(bf.maxit=150))
summary(bfm)

## 5.6.2 Package 'gss'
install.packages("gss")
library(gss)
ssm <- gssanova1(death~time+o3*tmp,family="poisson",nbasis=200)

summary(ssm)

tp <- seq(min(time),max(time),length=500)
fvt <- predict(ssm,newdata=data.frame(time=tp,
               o3=rep(mean(o3),500),tmp=rep(mean(tmp),500)),
               include=list("time"))
plot(tp,fvt,type="l",xlab="time",ylab="time effect")

m <- 40
o3m <- seq(min(o3),max(o3),length=m)
tmpm <- seq(min(tmp),max(tmp),length=m)
tmpp <- rep(tmpm,rep(m,m))
o3p <- rep(o3m,m)
pd <- data.frame(time=rep(0,m*m),o3=o3p,tmp=tmpp)
fv <- predict(ssm,newdata=pd,include=list("o3","tmp","o3:tmp"))
library(mgcv)
ind <- exclude.too.far(o3p,tmpp,o3,tmp,dist=0.04)
fv[ind] <- 0
persp(o3m,tmpm,matrix(fv,m,m),phi=30,theta=-30,zlab="o3*tmp",
      xlab="o3",ylab="tmp")

Linear Regression GLMs and GAMs with R/scripts/Ch-5-Day-4.r


#Tratamientos
A <- c(62,60,63,59)
B <- c(63,67,71,64,65,66)
C <- c(68,66,71,67,68,68)
D <- c(56,62,60,61,63,64,63,59)

#Tabla de resultados
resultado <- c(A,B,C,D)

dietas <- c(rep("A",length(A)),
            rep("B",length(B)),
            rep("C",length(C)),
            rep("D",length(D)))

misdatos <- data.frame(dietas,resultado)

boxplot(resultado~dietas,misdatos, main="Tiempo de coagulación de la sangre segun dieta", ylab="Tiempo (segundos)")

# ANOVA
anova1 <- aov(resultado~dietas,misdatos)
summary(anova1)

# global Effect and Treatment Effect
mu.est <- mean(misdatos$resultado)
mu.est
#aplicar media por grupos
mean_treatment <-  aggregate(resultado~dietas,misdatos,mean)
mean_treatment
#diferencia media por gruposy media global
effect_treatment <-  aggregate(resultado~dietas,misdatos,function(x){mean(x)-mu.est})
mu.est
effect_treatment

# Treatment Effect with a reference Level
round(coefficients(anova1),2)

# Changing Reference Level
misdatos$dietas <- relevel(misdatos$dietas,ref="B")
misdatos$dietas
anova1 <- aov(resultado~dietas,misdatos)
summary(anova1)
round(coefficients(anova1),2)

#================================================
# DBCA
#================================================
 res <- c(13,16,5,22,24,4,18,17,1,39,44,22)
 factor <- c(1,2,3,1,2,3,1,2,3,1,2,3)
 bloque <- c(1,1,1,2,2,2,3,3,3,4,4,4)

 midata <- data.frame(factor,bloque,res)

 length(res)
 length(factor)
 length(bloque)

 boxplot(res~factor,midata, main="Retardo en el crecimiento de bacterias",
         ylab="Tiempo (segundos)",
         xlab="Factor: Soluciones de lavado")
 boxplot(res~bloque,midata, main="Retardo en el crecimiento de bacterias",
         ylab="Tiempo (segundos)",
         xlab="Bloques: Días")

 # Interacciones
 interaction.plot(midata$factor,midata$bloque,midata$res,
                  xlab="Factor: Soluciones de lavado",
                  ylab="Tiempo (segundos)",
                  leg.legend="Bloque")

 #Opt1
 anova1 <- aov(res~as.factor(factor)+as.factor(bloque),midata)
 summary(anova1)

 #Opt2
 midata <- data.frame(factor=as.factor(factor),bloque=as.factor(bloque),res)
 anova1 <- aov(res~factor+bloque,midata)
 summary(anova1)

 # global Effect and Treatment Effect
 mu.est <- mean(midata$res)
 mean_treatment <-  aggregate(res~factor,midata,mean)
 effect_treatment <-  aggregate(res~factor,midata,function(x){mean(x)-mu.est})
 effect_block <-  aggregate(res~bloque,midata,function(x){mean(x)-mu.est})
 mu.est
 effect_treatment
 effect_block

 #Effects with control treatment
 round(coefficients(anova1),4)


# Rate of return data

#########################################################################
# Get CSV of return data
p <- read.csv("jstdatasetr4.csv", header=TRUE)

#########################################################################
# Calculate returns
#########################################################################
p <- # create lagged CPI
  p %>%
  group_by(iso) %>%
  mutate(lag.cpi = dplyr::lag(cpi, n = 1, default = NA))
p$inf <- (p$cpi - p$lag.cpi)/p$lag.cpi # inflation
p$housing_real <- (1+p$housing_tr)/(1+p$inf) - 1 # housing return
p$eq_real <- (1+p$eq_tr)/(1+p$inf) - 1 # equities
p$safe_real <- (1+p$safe_tr)/(1+p$inf) - 1 # safe assets
p$risky_real <- (1+p$risky_tr)/(1+p$inf) - 1 # risky assets
p$capital_real <- (1+p$capital_tr)/(1+p$inf) - 1 # capital in total

# Lagged values
p <- p %>% group_by(iso) %>% mutate(lag1.capital_real = dplyr::lag(capital_real, n = 1, default = NA))
p <- p %>% group_by(iso) %>% mutate(lag2.capital_real = dplyr::lag(capital_real, n = 2, default = NA))
p <- p %>% group_by(iso) %>% mutate(lag3.capital_real = dplyr::lag(capital_real, n = 3, default = NA))
p <- p %>% group_by(iso) %>% mutate(lag4.capital_real = dplyr::lag(capital_real, n = 4, default = NA))
p <- p %>% group_by(iso) %>% mutate(lag5.capital_real = dplyr::lag(capital_real, n = 5, default = NA))

# 5-year moving average
p$ma5.capital_real = round(((1+p$lag4.capital_real)*(1+p$lag3.capital_real)*(1+p$lag2.capital_real)*(1+p$lag1.capital_real)*(1+p$capital_real))^(1/5) - 1,digits=2)

# Subset of countries and time period
stable <- p[ which(p$iso %in% c("USA", "DEU", "JPN", "GBR", "AUS")),]
stable <- stable[which(p$year > 1949),]

#########################################################################
# Figure of 5-year rates of return
#########################################################################
fig <- plot_ly(stable, x = ~year, y = ~ma5.capital_real, linetype = ~country, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Return to capital over time', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = '5-year annualized return',range = c(-.1,.2)),
              hovermode="x unified")
api_create(fig, filename = "jst-stable-return")


x = c(-1, 0, 3, 7)
y = c(2, 0, 4, 7)

n = length(x)

num = sum(x * y) - sum(x) * sum(y) / n
den = sum(x * x) - sum(x) * sum(x) / n

B1 = num / den
B0 = (sum(y) - (B1 * sum(x))) / n

png('images/disp_diagram.png')

plot(x, y)

dev.off()

B0
B1

print('For x = 1 predicted value is')
print(B1 * 1 + B0)


# Estat�stica B�sica

# Exerc�cio

# Cuidado: A Linguagem R � case sensitive!

# Definindo a pasta de trabalho
# Substitua o caminho abaixo pela pasta no seu computador
setwd("C:/Users/dmpm/Documents/PowerBI/Cap12")
getwd()

# Carregando o dataset
notas <- read.csv("Notas.csv", fileEncoding = "windows-1252")

# Exerc�cio 1: Apresente um resumo de tipos de dados e estat�sticas do dataset.
View(notas)
str(notas)
summary(notas$TurmaA)
summary(notas$TurmaB)

# Exerc�cio 2: Qual a m�dia de cada turma?
mean(notas$TurmaA)
mean(notas$TurmaB)

# Exerc�cio 3: Qual turma apresentou maior variabilidade de notas? Justifique sua resposta.
sd(notas$TurmaA)
sd(notas$TurmaB)

# Exerc�cio 4 - Calcule o coeficiente de varia��o das 2 turmas.
media_ta <- mean(notas$TurmaA)
media_tb <- mean(notas$TurmaB)

sd_ta <- sd(notas$TurmaA)
sd_tb <- sd(notas$TurmaB)

cvA <- sd_ta / media_ta * 100
cvB <- sd_tb / media_tb * 100

cvA
cvB

# Exerc�cio 5 - Qual nota apareceu mais vezes em cada turma?
calculaModa <- function(v) {
  uniqv <- unique(v)
  uniqv[which.max(tabulate(match(v, uniqv)))]
}

calculaModa(notas$TurmaA)
calculaModa(notas$TurmaB)


 ZGELS Example Program Results

 Least squares solution
 (-0.5044,-1.2179) (-2.4281, 2.8574) ( 1.4872,-2.1955) ( 0.4537, 2.6904)

 Square root of the residual sum of squares
   6.88E-02


library(MASS)
getPriorProbabilities <- function (dset, column) {
  dsetLength <- dim(dset)[1]
  return (table(dset[, column]) / dsetLength)
}

likelihood <- function(feature, expectation, deviation) {
  return ((1 / (deviation * sqrt(2 * pi))) * exp(-((feature - expectation) ^ 2) / (2 * deviation ^ 2)))
}

# returns a probability of a given point to be in a given class
getProbability <- function(dset, classesColumn, className, point, lambda) {
  classesCount <- 0
  featuresCount <- length(point)
  dsetLength <- dim(dset)[1]

  prior <- getPriorProbabilities(dset, classesColumn)[className]
  # lambda <- 1 # rep(1, classesCount)

  expectations <- array(dim = featuresCount)
  for (i in 1:featuresCount) {
    expectations[i] <- mean(dset[which(dset[, classesColumn] == className), i])
  }

  matr <- matrix(0, featuresCount, featuresCount)
  for (i in 1:featuresCount) {
    matr[i, ] <- sum((dset[which(dset[, classesColumn] == className), i] - expectations[i]) ^ 2) / dsetLength
  }
  deviations <- array(dim = featuresCount)
  for (i in 1:featuresCount) {
    deviations[i] <- matr[i, i]
  }

  # print(log(lambda * prior))
  # print(expectations)
  # print('separator')
  # print(featuresCount)
  # print(deviations)
  # print(lambda * prior)
  # print(sum(log(likelihood(point, expectations, deviations))))

  logOfLikelihood <- sum(log(likelihood(point, expectations, deviations)))

  return (log(lambda * prior) + logOfLikelihood)
}

classify <- function(point, lambdas) {
  classes <- unique(dset[, 3])
  classesCount <- length(classes)
  scores <- array(dim = classesCount)
  for (i in 1:classesCount) {
    scores[i] <- getProbability(dset, 3, classes[i], point, lambdas[i])
  }
  return(classes[which.max(scores)])
}

mu1 <- c(0, 0)
mu2 <- c(4, 4)
sig1 <- matrix(c(2, 0.9, 0.9, 2), 2, 2)
sig2 <- matrix(c(0.5, 0, 0, 2), 2, 2)
dset1 <- mvrnorm(250, mu1, sig1)
dset2 <- mvrnorm(250, mu2, sig2)
dset <- rbind(cbind(dset1, 1),cbind(dset2, 2))
plot(dset[ ,1], dset[ ,2], pch=21, bg=c("green","blue")[dset[ ,3]])

# generating map
colors <- c("1" = "green", "2" = "blue")
xs <- seq(from = -5, to = 6.2, by = 0.1)
ys <- seq(from = -4.2, to = 8, by = 0.1)
lambdas <- runif(2, min=1, max=100)
print(lambdas)

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 <- classify(c(i, j), lambdas)
    points(i, j, col = colors[result], pch = 21)
  }
}
cat("\rDone.                      \n")

6 - Naive Bayes Classifier/naive-bayes.r


#' Numeric correlation
#'
#' @description Compute pearson, kendall and spearman correlation coefficient
#'
#' @param x numeric vector
#' @param y numeric vector
#'
#'
#' @return Numeric vector
#' @export
#'
#' @examples
#'
#' x <- rnorm(100)
#'
#' y <- rnorm(100)
#'
#' plot(x,y)
#'
#' num_corr(x,y)
#'
#'

num_corr <- function(x,y){

  if(is.numeric(x) == F){
    stop("x must be numeric")
  }

  if(is.numeric(y) == F){
    stop("y must be numeric")
  }

  out <-
  dplyr::tibble(
    pearson  =  cor.test(x,y,method = "pearson",na.rm = T)$estimate,
    kendall  =  cor.test(x,y,method = "kendall",na.rm = T)$estimate,
    spearman =  cor.test(x,y,method = "spearman",na.rm = T)$estimate
  )

  return(out)

}


##### 医学統計勉強会18　第4回　回帰分析　R code #####

install.packages("ISｗR")	# ISwRパッケージのインストール。最初の一回のみ実行
library(ISwR)

# 散布図 #
thuesen <- na.omit(thuesen)	# 欠測値を除く #
attach(thuesen)

plot(blood.glucose, short.velocity)
plot(thuesen)			# 上と同じ

# 数量的データの要約（二変量） #
cov(blood.glucose, short.velocity)		# 共分散
cov(thuesen)				# 分散共分散行列
cor(blood.glucose, short.velocity)		# 相関係数
cor(thuesen)				# 相関行列

# 単回帰分析 #
fit <- lm(short.velocity ~ blood.glucose, data=thuesen)
summary(fit)		# 回帰分析の結果表示
plot(thuesen)		# 散布図
abline(fit)			# 推定された回帰直線の描画
confint(fit)		# 回帰パラメターの信頼区間

# 回帰診断 #
par(mfrow=c(2,2))
plot(fit)
par(mfrow=c(1,1))

# 重回帰 (CPUデータ) #
library(MASS)
head(cpus, n=2)
dim(cpus)			# cpusの行と列の数を確認
?cpus				# cpusのオンラインヘルプ起動

cpus2 <- cpus[, c(8, 2:7)]
head(cpus2, n=2)

pairs(cpus2)		# cpus2の散布図行列

cpus2.lm <- lm(perf ~ syct + mmin + mmax + cach + chmin + chmax, data=cpus2)				# 回帰モデルの当てはめ
cpus2.lm <- lm(perf ~ ., data=cpus2)	# 上と同じ

summary(cpus2.lm)	# 回帰分析の結果表示
confint(cpus2.lm)	# 回帰パラメターの信頼区間

# 回帰診断 #
par(mfrow=c(2,2))	# グラフィックスウィンドウを2行2列の4つの領域に分割する
plot(cpus2.lm)
par(mfrow=c(1,1))	# グラフィックスウィンドウを元に戻す

# Box-Cox変換 #
library(MASS)
bxcx <- boxcox(perf ~ ., data=cpus2, lambda=seq(0, 0.5, .01))
lambda <- bxcx$x[which.max(bxcx$y)]
lambda

perf.new <- (cpus2$perf^lambda -1)/lambda
cpus3 <- cpus2[, -1]
cpus3 <- cbind.data.frame(perf.new, cpus3)

cpus2.bxcx.lm <- lm(perf.new ~ ., data=cpus3)
summary(cpus2.bxcx.lm)	# 回帰分析の結果表示
confint(cpus2.bxcx.lm)	# 回帰パラメターの信頼区間

# 回帰診断 #
par(mfrow=c(2,2))	# グラフィックスウィンドウを2行2列の4つの領域に分割する
plot(cpus2.bxcx.lm)
par(mfrow=c(1,1))	# グラフィックスウィンドウを元に戻す


# Dexter Barrows
#
# run: Rscript sc2-multi.r > sc2-multi.log 2>&1

library(reshape2)
library(foreach)
library(parallel)
library(doParallel)
library(rstan)

## Stochastic SIR functions
##############################################################################################

source(paste(getwd(),"../../sir-functions", "StocSIR.r", sep = "/"))
source(paste(getwd(),"../../sir-functions", "StocSIRstan.r", sep = "/"))

## Setup
##############################################################################################

set.seed(1004)

T       <- 60
i_infec <- 5
steps   <- 7
N       <- 500
sigma   <- 10
Tlim    <- T

## Generate true trajecory and synthetic data
##

pars_true <- c(R0 = 3.0,    # new infected people per infected person
          r = 0.1,      # recovery rate
          N = 500,      # population size
          eta = 0.5,    # geometric random walk
          berr = 0.5)   # Beta geometric walk noise

true_init_cond <- c(S = N - i_infec,
                    I = i_infec,
                    R = 0)

nTrials <- 10
maxTrunc <- 40
nTraj <- 200

numCores <- detectCores()
cl <- makeCluster(numCores)
registerDoParallel(cl)

## external files

# R source files
stoc_sir_file 		<- paste(getwd(),"../../sir-functions", "StocSIR.r", sep = "/")
if2_paraboot_file 	<- paste(getwd(), "if2-paraboot.r", sep = "/")
source(stoc_sir_file)
source(if2_paraboot_file)

# C++ source files
if2file 	<- paste(getwd(), "../../if2", "if2.cpp", sep="/")
if2_s_file 	<- paste(getwd(), "../../if2", "if2-s.cpp", sep="/")
hmcfile 	<- paste(getwd(), "../../hmc", "sirode_euler.stan", sep="/")

## IF2 settings

NP          <- 2500
nPasses     <- 50
coolrate    <- 0.975

## fit once to compile
##

# get raw data
sdeout_true <- StocSIR(true_init_cond, pars_true, T, steps)
colnames(sdeout_true) <- c('S','I','R','B')

infec_counts_raw <- sdeout_true[,'I'] + rnorm(T+1, 0, sigma)
infec_counts     <- ifelse(infec_counts_raw < 0, 0, infec_counts_raw)

# conform data to stan's required format
datlen <- T*7 + 1

data <- matrix(data = -1, nrow = T+1, ncol = steps)
data[,1] <- infec_counts
standata <- as.vector(t(data))[1:datlen]

#options
rstan_options(auto_write = TRUE)

stan_options <- list(   chains = 1,    		# number of chains
                        iter   = 2000, 		# iterations per chain
                        warmup = 1000, 		# warmup interations
                        thin   = 1)   		# thinning number

# data
sir_data <- list( T = datlen,       # simulation time
                  y = standata,     # infection count data
                  N = 500,          # population size
                  h = 1/steps )     # step size per day

# fit!
initialfit <- with(stan_options,
                stan(file   = hmcfile,
                    data    = sir_data,
                    chains  = chains,
                    iter    = iter,
                    warmup  = warmup,
                    thin    = thin)
                )

## Run multiple trajectories
#########################################################################################################

SSEmat <- foreach ( trunc = seq(4,maxTrunc,4), .combine = rbind, .packages = c("Rcpp","rstan","reshape2","foreach") ) %dopar% {

	Tlim <- T - trunc

	if2SSEs <- numeric(nTrials)
	hmcSSEs <- numeric(nTrials)

	for(trial in 1:nTrials) {

		# get true trajectory
	    sdeout_true <- StocSIR(true_init_cond, pars_true, T, steps)
	    colnames(sdeout_true) <- c('S','I','R','B')

	    # get full data
	    infec_counts_raw <- sdeout_true[,'I'] + rnorm(T+1, 0, sigma)
	    infec_counts     <- ifelse(infec_counts_raw < 0, 0, infec_counts_raw)

	    # truncate data
	    datapart <- c(infec_counts[1:(Tlim+1)],rep(NA,T-Tlim))

	    ## IF2
	    ##

	    # initial fit
	    sourceCpp(if2file)
	    if2time <- system.time( if2data <- if2(datapart, Tlim+1, N, NP, nPasses, coolrate) )

	    # IF2 parametric bootstrap
	    if2_paraboot_data <- if2_paraboot(if2data,
                                  T, Tlim, steps, N, nTraj,
                                  if2file, if2_s_file, stoc_sir_file,
                                  NP, nPasses, coolrate)

	    # get mean of trajectories
		parabootdata <- data.frame(if2_paraboot_data)
		countnames <- paste("counts",1:(dim(parabootdata)[2]-9), sep = "")
		countdata <- parabootdata[,countnames]
		countmeans <- colMeans(countdata)

		# get SSE, save
		truefuture  <- sdeout_true[(Tlim+2):(T+1),'I']
    	estfuture   <- countmeans[-1]
    	err <- estfuture - truefuture
    	sse <- sum(err^2)
    	if2SSEs[trial] <- sse

	    ## HMC fitting with stan
	    ##

	    datlen <- Tlim*7 + 1

	    data <- matrix(data = -1, nrow = T+1, ncol = steps)
	    data[,1] <- datapart
	    standata <- as.vector(t(data))[1:datlen]

	    sir_data <- list( T = datlen,       # simulation time
	                      y = standata,     # infection count data
	                      N = 500,          # population size
	                      h = 1/steps )     # step size per day

	    hmctime <- system.time(fit <- with(stan_options,
	                            stan( fit = initialfit,
	                                  data    = sir_data,
	                                  chains  = chains,
	                                  iter    = iter,
	                                  warmup  = warmup,
	                                  thin    = thin)
	                            )
	                )

	    exfit <- extract(fit, permuted = FALSE, inc_warmup = FALSE)

	    paramdata <- data.frame(R0 = melt(exfit[,,'R0'])$value,
	                            r = melt(exfit[,,'r'])$value,
	                            sigma = melt(exfit[,,'sigma'])$value,
	                            eta = melt(exfit[,,'eta'])$value,
	                            berr = melt(exfit[,,'berr'])$value,
	                            Sinit = melt(exfit[,,'y0[1]'])$value,
	                            Iinit = melt(exfit[,,'y0[2]'])$value,
	                            Rinit = melt(exfit[,,'y0[3]'])$value )

	    for (j in 1:datlen) {
			varname <- paste('Bnoise[', j, ']', sep = '')
			paramdata[[varname]] <- melt( exfit[,,varname] )$value
		}

	    parnames <- c("R0","r","sigma","eta","berr","Iinit")
	    parvars <- var(paramdata[parnames])
	    hmcparmeans <- colMeans(paramdata[parnames])
	    names(hmcparmeans) <- c("hmc.R0","hmc.r","hmc.sigma","hmc.eta","hmc.berr","hmc.Iinit")

	    bootstrapdata <- matrix(NA, nrow = nTraj, ncol = (T+1) )

    	pardatlen 	<- dim(paramdata)[1]
    	inds 	    <- sample.int(pardatlen,nTraj,replace = TRUE)
    	params 	    <- paramdata[inds,]

    	for (i in 1:nTraj) {

    		paramset <- params[i,]

        	init_cond <- c(S = paramset$Sinit,
        	               I = paramset$Iinit,
        	               R = paramset$Rinit)
        	pars <- c(R0 = paramset$R0,
        	          r = paramset$r,
        	          N = 500.0,
        	          eta = paramset$eta,
        	          berr = paramset$berr)

        	berrvec <- numeric(datlen)
        	for (j in 1:datlen) {
        		varname <- paste("Bnoise[", j, "]", sep = "")
        		berrvec[j] <- paramset[[varname]]
        	}

        	sdeout <- StocSIRstan(init_cond, pars, T, steps, berrvec, datlen)
        	colnames(sdeout) <- c('S','I','R','B')

        	bootstrapdata[i,] <- sdeout[,'I']

    	}

    	# in case of explosion
    	bootstrapdata <- bootstrapdata[complete.cases(bootstrapdata),]
    	goodbootsize <- dim(bootstrapdata)[1]

    	meanTraj 	<- colMeans(bootstrapdata)

    	truefuture  <- sdeout_true[(Tlim+2):(T+1),'I']
		estfuture   <- meanTraj[(Tlim+2):(T+1)]
    	err <- estfuture - truefuture
    	sse <- sum(err^2)
    	hmcSSEs[trial] <- sse

	}

	return( c(if2SSEs, hmcSSEs) )

}

stopCluster(cl)

save.image(file = "sc2-multi.RData")


# Calc connectivity clustering coeficient and path length
#
#
calc_topological_indices <- function(red.e)
{
  size.e <- vcount(red.e)
  links.e <- ecount(red.e)
  link.den <- links.e/size.e
  conn.e <- links.e/size.e^2
  cha.path.e <- average.path.length(red.e)
  clus.coef.e <- transitivity(red.e, type = "global")
  #degree.e <- degree(red.e)
  return(data.frame(Size=size.e,Links=links.e, LD=link.den,Connectance=conn.e,PathLength=cha.path.e,Clustering=clus.coef.e))
}

# Calculation of the clustering coefficients and average path for random network simulations
#
#
calc_cpl_cc <- function(size,links,CPL,CC, nsim=1000){
  redes.r <- lapply(1:nsim, function (x) erdos.renyi.game(size, links, type="gnm"))

  cha.path.r <- c()
  for (i in 1:nsim){
    cha.path.r <- c(cha.path.r,average.path.length(redes.r[[i]]))
  }

  clus.coef.r <- c()
  for (i in 1:nsim){
    clus.coef.r <- c(clus.coef.r,transitivity(redes.r[[i]], type="Global"))
  }
  qcc <- quantile(clus.coef.r,c(0.005,0.995))
  qcp <- quantile(cha.path.r,c(0.005,0.995))
  mcc <- mean(clus.coef.r)
  mcp <- mean(cha.path.r)
  gamma <- CC/clus.coef.r
  lambda <- CPL/cha.path.r
  SWness <- gamma/lambda
  qSW <- quantile(SWness,c(0.005,0.995))
  mCI <- 1+(qSW[2]-qSW[1])/2
  mSW <- CC/mcc*mcp/CPL

  return(data_frame(cha.pathMean= mcp,clus.coefMean=mcc,cha.pathLow=qcp[1],cha.pathUp=qcp[2], clus.coefLow=qcc[1],clus.coefHigh=qcc[2],SWness=mSW,SWnessCI=mCI))
}

# Generate a data.frame with all simulations
#
genrnd_cpl_cc <- function(size,links, nsim=1000){
  redes.r <- lapply(1:nsim, function (x) erdos.renyi.game(size, links, type="gnm"))

  cha.path.r <- c()
  for (i in 1:nsim){
    cha.path.r <- c(cha.path.r,average.path.length(redes.r[[i]]))
  }

  clus.coef.r <- c()
  for (i in 1:nsim){
    clus.coef.r <- c(clus.coef.r,transitivity(redes.r[[i]], type="Global"))
  }
  return(data_frame(cha.path=cha.path.r, clus.coef=clus.coef.r))
}

# Test SW in Watts Strogatz model against random
#
genWattsStrogatz_cpl_cc <- function(size,links, ratio=1.1,nsim=100){

  redes.r <- lapply(1:nsim, function (x) {
                  sw <- sample_smallworld(1,size, links/(size*runif(1,0.8,1.2)), 0.5)
                  sw <- simplify(sw,remove.loops = FALSE)})

  swr <- data_frame()

  for (i in 1:nsim){
    sw1 <- redes.r[[i]]
    swr <- bind_rows(swr, calc_cpl_cc(gorder(sw1),gsize(sw1)) %>%
      mutate(Size=gorder(sw1),Links=gsize(sw1),CPL=average.path.length(sw1),CC=transitivity(sw1,type="global")) %>%
      mutate(isInsideCPL = (CPL >= cha.pathLow*(1/ratio) & CPL<=cha.pathUp*ratio), isGreaterCC =( CC>clus.coefHigh)))
  }

  return(swr)

}


# Takes one dimensional time series, performs delay embedding
one_d <-function(data, embed_dim = 4)
{
  edata <- embed(data, embed_dim)
  return(edata)
}

#Takes time series and scales, either using max values or taking log
pre_process <- function(data, scaling_method)
{
  tmp <- data
  if (scaling_method == "max") {
    for (i in 1: ncol(tmp)) {
      tmp[,i] <- tmp[,i]/max(abs(tmp[,i]))
    }
  }
  return(tmp)
}

log_r <- function(tmp)
{
  for(i in 1:ncol(tmp)) {
    #replace each column in the data set with the log return
    #replace corresponding column in dat with new log return value
    tmp[,i] <- Delt(tmp[,i])
  }
  #Since first vale will always be N/A, remove it
  tmp <- tmp[-1,]
  return(tmp)
}

#Finds upper bound of diameter of the data
#to use for max_scale
find_diam <- function(time)
{
  dim <- ncol(time)
  diam_list = vector(length = dim)
  for (i in 1:dim) {
    high <- max(time[,i])
    low <- min(time[,i])
    diam_list[i] <- (high-low)
  }
  diam <- norm(diam_list, type = "2")
  return(diam)
}

#Takes time series and finds persistence diagrams
nd_diag <- function(time, max_scale = 0.1, K_max = 10, window = 100)
{
  tmp <- time

  #TDA
  maxdimension =1
  Diags1.rips.ls = list()
  total <- dim(tmp)[1]
  step <- 1
  spot <- seq(from=1, to=(total-window+1), by=step)

  #Persistence diagrams
  print("Computing persistence diagrams...")
  pb <- txtProgressBar(min = 0, max = length(spot), style = 3)
  for(i in 1:length(spot)){
    Diags1.rips.ls[[i]] =
      ripsDiag(tmp[spot[i]:(spot[i]+window-1), ], maxdimension=1, max_scale, library = "Dionysus")

    # update progress bar
    setTxtProgressBar(pb,i)
  }
  plot(Diags1.rips.ls[[2]]$diagram)
  return(Diags1.rips.ls)
}

#Takes the diagrams from nd_diag and calculates the norm
nd_norm <- function(diag, max_scale, K_max = 10, scaling_method = "log"){
  step <- 1
  spot <- seq(from =1, to = length(diag), by = step)

  Lands1.ls = list() # collects landscapes (in 2D) at particular date i per k
  AUC_Land.m = matrix(0,length(spot),K_max) #collects values of lambda_k at particular date i per k
  AUC_Land.v = vector(length=length(spot)) #collects values of L^1 at particular date
  #Compute L^1
  print("Computing the L1 norm of persistence landscapes...")
  pb <- txtProgressBar(min = 0, max = length(spot), style = 3)
  for (i in 1:length(spot)){
    diagram <- diag[[i]]$diagram

    # print(diagram)
    # Look at persistence diagrams on a logarithmic scale
    if(scaling_method=="log") {
      # Only take logarithm of nonzero entries
      for(j in 1:nrow(diagram)) {
        if(diagram[j,1]==1) {
          diagram[j,2] = log(diagram[j,2])
          diagram[j,3] = log(diagram[j,3])
        }
      }
    }

    minim=Inf
    maxim=-Inf
    for(j in 1:nrow(diagram)) {
      # print(diagram[j,1])
      if(diagram[j,1]==1) {
        minim = min(minim,diagram[j,2])
        maxim = max(maxim,diagram[j,3])
      }
    }
    #print(minim)
    #print(maxim)

    if(minim==Inf)  # There is no 1-dimensional homology feature in this window
    {
      AUC_Land.v[i]=0
    }
    else
    {
      tseq <- seq(minim, maxim, length=500)

      for (KK in 1:K_max){
        Lands1.ls[[i]]=landscape(diagram, dimension=1, KK, tseq)
        AUC_Land.m[i,KK]=  pk.calc.auc.all(Lands1.ls[[i]],tseq, interval=c(minim,maxim))
        AUC_Land.v[i]= AUC_Land.v[i]+AUC_Land.m[i,KK]
      }
      plot(Lands1.ls[[2]])
    }
    # update progress bar
    setTxtProgressBar(pb,i)
  }
  return(AUC_Land.v)
}

#End line method - takes multi-D time series, processes,
#and finds the norm
#Default max_scale of 0 leads to find_diam being called
analyze_nd <- function(time, scaling_method = "log", returns = FALSE,
                       max_scale = 0, K_max = 10, window = 50) {
  dates <- index(time)
  if (returns) {
    #Taking log-returns of the log of the data can lead to errors,
    #so if returns are desired, we deactivate the log scaling
    if (scaling_method =="log") {
      scaling_method <- "none"
    }
    time <- log_r(time)
  }

  data <- pre_process(time, scaling_method)
  if(max_scale == 0) {
    max_scale <- find_diam(data)
  }
  diag <- nd_diag(data, max_scale, K_max, window)
  norm <- nd_norm(diag, max_scale, K_max, scaling_method)
  new_dates <- tail(dates, length(norm))
  norm.xts <- xts(norm, order.by = new_dates)

  return(norm.xts)
}

#End line method - takes one-D time series
#finds delay embedding, calls analyze_nd
analyze_1d <- function(time, dim = 4, scaling_method = "log", max_scale = 0, K_max = 10, window = 50, returns = FALSE) {
  if (returns) {
    #Taking log-returns of the log of the data can lead to errors,
    #so if returns are desired, we deactivate the log scaling
    if (scaling_method == "log") {
      scaling_method <- "none"
    }

    time <- log_r(time)
  }
  dates <- index(time)

  delay_data <- one_d(time, dim)
  delay_data.xts <- xts(delay_data, order.by = tail(dates, length(delay_data[,1])))
  analyze_nd(delay_data.xts, scaling_method, returns = FALSE,  max_scale, K_max, window)
}

output <- function(tmp, filename , plot = "FALSE")
{
  write.zoo(tmp, file = filename)
  if (plot == "TRUE") {
    plot(tmp, type = 'l')
  }
}

get_impact_window <- function(data, index, window_length)
{
  data[index:(index+window_length-1)]
}


require(mgcv)
# first an un-penalized example - fit E(y)=a+bx subject to a>0
set.seed(0)

# Penalized example: monotonic penalized regression spline .....
n <- 100
# Generate data from a monotonic truth.
x <- runif(100) * 4 - 1
x <- sort(x)
f <- exp(4 * x) / (1 + exp(4 * x))
y <- f + rnorm(100) * 0.1
plot(x, y)
dat <- data.frame(x = x, y = y)
# Show regular spline fit (and save fitted object)
f.ug <- gam(y ~ s(x, k = 10, bs = "cr"))
lines(x, fitted(f.ug))
# Create Design matrix, constraints etc. for monotonic spline....
sm <- smoothCon(s(x, k = 10, bs = "cr"), dat, knots = NULL)[[1]]
F <- mono.con(sm$xp)
# get constraints
G <- list(X = sm$X, C = matrix(0, 0, 0), sp = f.ug$sp, p = sm$xp, y = y, w = y * 0 + 1)
G$Ain <- F$A
G$bin <- F$b
G$S <- sm$S
G$off <- 0

p <- pcls(G)
# fit spline (using s.p. from unconstrained fit)

fv <- Predict.matrix(sm, data.frame(x = x)) %*% p
lines(x, fv, col = 2)


# Mean and Standard Deviation of the Binomial Probability Distribution
#number of trials
n<-20
#  the probability of success of single event  is
z<-0.85
Mean<-n*z
print(Mean)
standard_deviation=sqrt(n*z*(1-z))
print(standard_deviation)


# Date: 2022-01-21
# Author: Gustav Collin Rasmussen
# Purpose: Definition and exploration of popular 1-repetition-maximum formulas

library(tidyverse)
library(cowplot)

epley <- function(w, r) {
    stopifnot(r > 1)
    return (w * (1 + r / 30))
}

brzycki <- function(w, r) {
    return (w * 36 / (37 - r))
}

epley_inverted <- function(one_rm, r, progression) {
    stopifnot(r > 1)
    return (log10(progression) * one_rm / (1 + r / 30))
}

brzycki_inverted <- function(one_rm, r, progression) {
    return (log10(progression) * one_rm * (37 - r) / 36)
}

###### evaluate 1rm formulas at 5 reps for varying weights ######
weight = seq(10, 60, by=10)

one_rm_constant_reps_df <- data.frame(weight = weight,
                        epley_1rm = epley(weight, 5),
                        brzycki_1rm = brzycki(weight, 5)
                        )

df1 <- one_rm_constant_reps_df %>%
  select(weight, epley_1rm, brzycki_1rm) %>%
  gather(key = "variable", value = "one_rep_max", -weight)

###### evaluate 1rm formulas at weight: 70 kg for varying reps ######
reps = 2:10
one_rm_constant_weight_df <- data.frame(reps = reps,
                                      epley_1rm = epley(70, reps),
                                      brzycki_1rm = brzycki(70, reps)
)

df2 <- one_rm_constant_weight_df %>%
  select(reps, epley_1rm, brzycki_1rm) %>%
  gather(key = "variable", value = "one_rep_max", -reps)

###### evaluate inverse 1rm formulas at 5 reps for varying weights ######
inverse_one_rm_constant_reps_df <- data.frame(weight = weight,
                        epley_inverted = epley_inverted(weight, 5, 10),
                        brzycki_inverted = brzycki_inverted(weight, 5, 10)
                        )

df3 <- inverse_one_rm_constant_reps_df %>%
  select(weight, epley_inverted, brzycki_inverted) %>%
  gather(key = "variable", value = "inverse_one_rep_max", -weight)

###### evaluate inverse 1rm formulas at weight: 70 kg for varying reps ######
inverse_one_rm_constant_weight_df <- data.frame(reps = reps,
                                      epley_inverted = epley_inverted(70, reps, 10),
                                      brzycki_inverted = brzycki_inverted(70, reps, 10)
)

df4 <- inverse_one_rm_constant_weight_df %>%
  select(reps, epley_inverted, brzycki_inverted) %>%
  gather(key = "variable", value = "inverse_one_rep_max", -reps)

################## prepare plots ##################
sp1 <- ggplot(df1, aes(weight, one_rep_max)) +
  geom_point(aes(color = variable)) +
  scale_color_manual(values = c("darkred", "steelblue"))

sp2 <- ggplot(df2, aes(reps, one_rep_max)) +
  geom_point(aes(color = variable)) +
  scale_color_manual(values = c("darkred", "steelblue"))

sp3 <- ggplot(df3, aes(weight, inverse_one_rep_max)) +
  geom_point(aes(color = variable)) +
  scale_color_manual(values = c("darkred", "steelblue"))

sp4 <- ggplot(df4, aes(reps, inverse_one_rep_max)) +
  geom_point(aes(color = variable)) +
  scale_color_manual(values = c("darkred", "steelblue"))

################## show figure ##################
plot_grid(sp1, sp2, sp3, sp4,
          labels = rep(c("constant reps (5)", "constant weight (70 kg)"), times=2),
          ncol = 2, nrow = 2)


for (n in c(3030, 1000, 500, 200, 100, 50, 10)) {
  p = dbinom(n/2, n, 0.5)
  cat(n, " : ", round(100*p, 2), " %\n")
}


#' Set outlier critical value
#'
#' Set outlier critical value using the Ljung algorithm as given in
#' Ljung, G. M. (1993). On outlier detection in time series.
#' Journal of Royal Statistical Society B 55, 559-567.
#'
#'
#' @param number_observations number of observations tested for outliers
#' @param cv_alpha alpha for critical value
#' @return outlier critical value generated by the algorithm given in Ljung (1993).
#'         The critical value in X-13 is different as it is adjusted to allow for smaller values
#'         to approximate the normal distribution.
#' @examples
#' this_critical_value <- set_critical_value(12, 0.025)
#' @export
set_critical_value <- function(number_observations, cv_alpha = 0.01) {
    # Brian Monsell Version 1.4 3/29/2021
    pmod <- 2 - sqrt(1 + cv_alpha)
    acv <- sqrt(2 * log(number_observations))
    bcv <- acv - (log(log(number_observations)) + log(2 * 2 * pi))/(2 * acv)
    xcv <- -log(-0.5 * log(pmod))
    setcvl <- (xcv/acv) + bcv
    return(setcvl)
}


# Jose.M.Pavia@uv.es
require(Hmisc)
PerCapita <- c(10, 20, 30, 20, 20, 40)
Group <- c( "A", "B", "B", "A", "A", "B")
W <- c(1.5, 2.3, 4.5, 2.6, 1.7, 3.9)

## Works
wtd.mean(PerCapita, weights=W)
wtd.quantile(PerCapita, weights=W)
wtd.mean(PerCapita[Group=="A"], weights=W[Group=="A"])
wtd.mean(PerCapita[Group=="B"], weights=W[Group=="B"])

g <- function(y) wtd.mean(y[,1],y[,2])
summarize(cbind(PerCapita, W), llist(Group), g, stat.name='y')

## davharris https://github.com/harrelfe/Hmisc/issues/69

x <- c(3.7,3.3,3.5,2.8)
wt <- c(5,  5,  4,  1)/15
wtd.mean(x, wt)
wtd.var(x, wt)


#Copyright (c) 2016 Riccardo Francescato
a <- c(108,124,124,106,115,138,163,159,134,139)
#confidency level
alpha = .01
#type of test: 0 left tail 1 double tail 2 right tail
type = 1
#calculations....
n0 = length(a)		# number of reps for sample 0
xbar0 = mean(a)		# sample 0 mean
Sigma0 = 2			# given  variance
s0 = sd(a)			# sample 0 standard deviation
X0 = ((n0-1)*s0^2)/Sigma0
if(type == 0){
	x.alpha = qchisq(1−alpha, df=n0−1)
	cat("Results of lower tail\n")
	cat("Sample\n")
	cat(paste("# of elements: ", n0, " Mean: ", xbar0, " St Dev: ",s0))
	cat(paste("\nx0: ",X0))
	cat(paste("\nxalpha: ",x.alpha))
	if(X0<x.alpha) cat("\nREJECT H0\n") else cat("\nACCEPT H0\n")
}else if(type == 1){
	x.top.alpha = qchisq(alpha/2, df=n0−1)
	x.bottom.alpha = qchisq(1-alpha/2, df=n0−1)
	cat("Results of 2-tail tail\n")
	cat("Sample\n")
	cat(paste("# of elements: ", n0, " Mean: ", xbar0, " St Dev: ",s0))
	cat(paste("\nx0: ",X0))
	cat(paste("\nxalpha +: ",x.top.alpha))
	cat(paste("\nxalpha -: ",x.bottom.alpha))
	if(X0<x.bottom.alpha || X0>x.top.alpha) cat("\nREJECT H0\n") else cat("\nACCEPT H0\n")

}else if(type == 2){
	x.alpha = qchisq(alpha, df=n0−1)
	cat("Results of upper tail\n")
	cat("Sample\n")
	cat(paste("# of elements: ", n0, " Mean: ", xbar0, " St Dev: ",s0))
	cat(paste("\nx0: ",X0))
	cat(paste("\nxalpha: ",x.alpha))
	if(X0>x.alpha) cat("\nREJECT H0\n") else cat("\nACCEPT H0\n")
}


### functions for QR or sparseQR class
qrrank<-function(QR, tol=1e-8){
  if(class(QR)=="sparseQR")
    return(sum(abs(diag(QR@R))>tol))
  else
    return(QR$rank)
}
qrRM<-function(QR){
  if(class(QR)=="sparseQR")
    return(qrR(QR))
  else
    return(qr.R(QR))
}

# invTwobyTwoSymMatrix: inverts two-by-two symmetric matrices
# M: symmetric matrix
# OUTPUT: a two-by-two symmetric matrix
invTwobyTwoSymMatrix <- function(M) {
  if(missing(M)) stop("invTwobyTwoSymMatrix: Supply M!")
  if(nrow(M) != 2 || ncol(M) != 2) stop("invTwobyTwoSymMatrix: The matrix is not 2 by 2")
  if(M[1,2] != M[2,1]) stop("invTwobyTwoSymMatrix: The matrix is not symmetric!")
  detM = M[1,1] * M[2,2] - M[1,2]^2
  Minverse = M
  Minverse[2,2] = M[1,1]
  Minverse[1,1] = M[2,2]
  Minverse[1,2] = Minverse[2,1] = -1 * M[1,2]
  return(1/detM * Minverse)
}

# quadSolver: solves the quadratic equation ax^2 + bx + c = 0
#             Can also be used to solve eigenvalues of two-by-two matrices
#             E.x. if [d,e; f,g] is the two-by-two matrix
#                  eigenvalues are defined as the solution to det( [d,e; f,g] - lambda * I) = 0
#                  Or det([d - lambda, e; f, g - lambda]) = 0
#                  Or (d-lambda) * (g -lambda) - e*f = 0
#                  Or lambda^2 - (d +g) *lambda + d*g - e*f = 0
quadSolver = function(a,b,c) {
  if(missing(a) || missing(b) || missing(c)) stop("Supply the coefficients!")
  if(length(a) != 1 || length(b) != 1 || length(c) != 1) stop("Supply only scalar values to a,b, and c")
  if(a == 0) stop("Something is wrong! Leading coefficient is zero")

  discriminant = b^2 - 4 * a * c
  if(discriminant < 0) return(c(NA,NA))
  if(discriminant == 0) return( rep(-b/(2*a),2))
  if(discriminant > 0) {
    if(a > 0) {
	  lowerRoot = -b / (2*a) - sqrt(discriminant) / (2*a)
	  upperRoot = -b / (2*a) + sqrt(discriminant) / (2*a)
	  return(c(lowerRoot,upperRoot))
	} else {
	  lowerRoot = -b / (2*a) + sqrt(discriminant) / (2*a)
	  upperRoot = -b / (2*a) - sqrt(discriminant) /(2*a)
	  return(c(lowerRoot,upperRoot))
	}
  }
}


## HF#1 Random Hex color
randHclr <- function() {
  m=255;r=g=b=0;
  r <- sample(0:m, 1, replace=TRUE);
  g <- sample(0:m, 1, replace=TRUE);
  b <- sample(0:m, 1, replace=TRUE);
  return(rgb(r,g,b,maxColorValue=m));
}
## HF#2 Metrics: Euclidean, Manhattan and Minkovski
Metric <- function(x, y, mt) {
  if(mt==1) {return(sqrt(x*x + y*y))}
  if(mt==2) {return(abs(x) + abs(y))}
  if(mt==3) {return((abs(x)^3 + abs(y)^3)^0.33333)}
}

## Plotting Voronoi diagram. aev 3/12/17
## ns - number of sites, fn - file name, ttl - plot title.
## mt - type of metric: 1 - Euclidean, 2 - Manhattan, 3 - Minkovski.
pVoronoiD <- function(ns, fn="", ttl="",mt=1) {
  cat(" *** START VD:", date(), "\n");
  if(mt<1||mt>3) {mt=1}; mts=""; if(mt>1) {mts=paste0(", mt - ",mt)};
  m=640; i=j=k=m1=m-2; x=y=d=dm=0;
  if(fn=="") {pf=paste0("VDR", mt, ns, ".png")} else {pf=paste0(fn, ".png")};
  if(ttl=="") {ttl=paste0("Voronoi diagram, sites - ", ns, mts)};
  cat(" *** Plot file -", pf, "title:", ttl, "\n");
  plot(NA, xlim=c(0,m), ylim=c(0,m), xlab="", ylab="", main=ttl);
  X=numeric(ns); Y=numeric(ns); C=numeric(ns);
  for(i in 1:ns) {
    X[i]=sample(0:m1, 1, replace=TRUE);
    Y[i]=sample(0:m1, 1, replace=TRUE);
    C[i]=randHclr();
  }
  for(i in 0:m1) {
    for(j in 0:m1) {
      dm=Metric(m1,m1,mt); k=-1;
      for(n in 1:ns) {
        d=Metric(X[n]-j,Y[n]-i, mt);
        if(d<dm) {dm=d; k=n;}
      }
      clr=C[k]; segments(j, i, j, i, col=clr);
    }
  }
  points(X, Y, pch = 19, col = "black", bg = "white")
  dev.copy(png, filename=pf, width=m, height=m);
  dev.off(); graphics.off();
  cat(" *** END VD:",date(),"\n");
}
## Executing:
pVoronoiD(150)          ## Euclidean metric
pVoronoiD(10,"","",2)   ## Manhattan metric
pVoronoiD(10,"","",3)   ## Minkovski metric


# pull out the necessary internal functions from greta
op <- .internals$nodes$constructors$op
#' @importFrom  stats var median quantile
#' @import greta
#'
#' @title compute the (normalized) root mean squared error for a greta regression model
#' @export
#'
#' @description Compute the root mean squared error of a greta model
#'
#' @param y a greta array, the response variables
#' @param pred a greta array, the linear predictor
#' @param draws a greta_mcmc_list object, posterior draws as returned from calling greta sampling algorithm (ie mcmc)
#' @param summary a logical, if TRUE (default) the function output summary statistics (mean, sd, 80% credible intervals) for the R2, if FALSE the raw values are returned
#' @param probs a vector of two numeric specifying the lower and upper limits for the credible intervals (default to 0.1, 0.9), only used if summary=TRUE
#' @param norm a logical, whether to normalize the RMSE by the mean of the response variable
#'
#' @return If summary=TRUE a 1 x C matrix is returned (C = length(probs) + 2) containing summary statistics of Bayesian R-squared values. If summary = FALSE the posterior samples of the R-squared values are returned as a numeric vector of length S (S is the number of samples)
#'
#' @details Note that when normalized RMSE (norm=TRUE), is compute as follow: nRMSE = RMSE / mean(y)
#'
#' @examples
#' \dontrun{
#' intercept <- normal(0, 1)
#' slope <- normal(0, 1)
#' sd_resid <- cauchy(0, 1, truncation = c(0, 100))
#'
#' x <- runif(100)
#' y <- as_data(rnorm(100, 1 + 2 * x, 1))
#'
#' pred <- intercept + slope * x
#' distribution(y) <- normal(pred, sd_resid)
#'
#' m <- model(intercept, slope, sd_resid)
#' drr <- mcmc(m)
#'
#' rmse(y, pred, drr)
#' }

rmse <- function(y, pred, draws, summary = TRUE, probs = c(0.1, 0.9),
                 norm = FALSE){

  # get the posterior draws for the linear predictor
  ypred <- calculate(pred, values = draws)

  # posterior residuals
  e <- -1 * sweep(as.matrix(ypred), 2, as.matrix(y))

  # calculate per posterior draws root mean squared error or
  # a normalized version of it
  if(!norm){
    post_rmse <- apply(e, 1, function(x) sqrt(mean(x ** 2)))
  }
  else{
    post_rmse <- apply(e, 1, function(x) sqrt(mean(x ** 2)) / mean(as.numeric(y)))
  }

  if(summary){
    # get summary stats
    med <- median(post_rmse)
    mad <- median(abs(post_rmse - med))
    ci <- quantile(post_rmse, probs = probs)
    out <- matrix(c(med, mad, ci),ncol = 4,
                  dimnames = list("",
                                  c("median", "mad", "low-ci", "high-ci")))
    return(out)

  } else{
    return(post_rmse)
  }
}


# ==============================================================================
# ==============================================================================
#		 SCRIPTS TO GENERATE SOME OF MY \new GRAPHICS IN R
# ==============================================================================
# ==============================================================================

# DATASETS
# 	TIME (EFFORT)
	NormalityT<-c(-69,-64,-43,-35,-30,-25,-22,-12,-9,-9,-9,-7,-3,-2,1,5,9,17,18,19,20,25,3,40,46)
	GraphicT<-c(24,24,28,28,29,30,30,30,31,33,35,38,38,44,45,46,46,46,53,58,61,70,74,90,102)
	TextualT<-c(21,23,25,29,30,30,31,32,35,36,40,40,43,44,47,50,50,55,55,55,67,74,93,93,171)
# 	FSCORE (EFFECTIVENESS)
	NormalityFS<-c(-6.95,-6.37,-5.29,-3.80,-2.53,-2.52,-2.51,-1.49,-1.41,0.82,1.39,1.46,1.71,1.73,1.80,2.51,3.91,3.92,3.94,4.42,4.95,5.10,6.62,6.96,8.43)
	GraphicFS<-c(68.66,73.17,73.81,76.92,78.65,78.65,79.12,79.49,80.41,80.43,80.46,81.08,81.32,81.58,82.98,83.33,83.78,83.87,86.02,86.60,87.23,87.23,87.80,89.16,91.67)
	TextualFS<-c(69.47,71.29,71.70,73.12,77.11,77.78,78.72,81.25,82.47,82.57,83.87,84.62,84.71,85.33,85.37,86.08,86.32,86.42,87.06,87.76,88.31,88.89,89.16,89.74,91.14)

# ==============================================================================

# DISTRIBUTION
#	TIME (EFFORT)
	qqnorm(NormalityT,main=NULL, xlab = "",ylab = "",cex = 2, pch = 1,cex.lab= 1.5, cex.axis= 1.5)
	qqline(NormalityT, col=4, lwd=2,lty=1)
#	FSCORE (EFFECTIVENESS)
	qqnorm(NormalityFS,main=NULL, xlab = "",ylab = "",cex = 2, pch = 1,cex.lab= 1.5, cex.axis= 1.5)
	qqline(NormalityFS, col=4, lwd=2,lty=1,)

# ==============================================================================

# BOXPLOT
#	TIME (EFFORT)
	boxplot(GraphicT, TextualT, col=(c("darkgreen","darkorange")), names=c("Graphical Treatment","Textual Treatment"), ylab="Time (minutes)", cex=1.5, cex.lab= 1.5, cex.axis= 1.5, outline=FALSE)
#	FSCORE (EFFECTIVENESS)
	boxplot(GraphicFS, TextualFS, col=(c("darkgreen","darkorange")), names=c("Graphical Treatment","Textual Treatment"), ylab="Percentage (%)", cex=1.5, cex.lab= 1.5, cex.axis= 1.5, outline=FALSE)

# ==============================================================================

# 	+ PLOTS
	qqnorm(NormalityT,main=NULL, xlab = "",ylab = "",cex = 2, pch = 1,cex.lab= 1.5, cex.axis= 1.5)
	qqline(NormalityT, col=4, lwd=2,lty=1)
	qqnorm(NormalityFS,main=NULL, xlab = "",ylab = "",cex = 2, pch = 1,cex.lab= 1.5, cex.axis= 1.5)
	qqline(NormalityFS, col=4, lwd=2,lty=1,)
	boxplot(GraphicT, TextualT, col=(c("darkgreen","darkorange")), names=c("Graphical Treatment","Textual Treatment"), ylab="Time (minutes)", cex=1.5, cex.lab= 1.5, cex.axis= 1.5, outline=FALSE)
	boxplot(GraphicFS, TextualFS, col=(c("darkgreen","darkorange")), names=c("Graphical Treatment","Textual Treatment"), ylab="Percentage (%)", cex=1.5, cex.lab= 1.5, cex.axis= 1.5, outline=FALSE)

# ==============================================================================

# PAIRED T TEST (DEPENDENT SAMPELS)

#	TIME (EFFORT)
	rm(list = ls())
	x1 <- c(50,30,30,32,55,74,43,40,25,31,29,171,44,47,55,21,35,55,23,36,40,50,67,93,93)
	x2 <- c(28,70,35,30,30,44,46,33,45,28,46,102,90,38,46,30,53,74,24,61,31,38,24,58,29)
	t.test(x1, x2, alternative = "two.sided", paired = TRUE, mu = 0, conf.level = 0.95)
	shapiro.test(x1)
	shapiro.test(x2)

#	FSCORE (EFFECTIVENESS)
	rm(list = ls())
	x1 <- c(87.06,71.7,87.76,89.74,83.87,77.11,88.31,85.33,84.62,82.47,86.08,91.14,86.32,78.72,84.71,86.42,77.78,85.37,69.47,71.29,88.89,81.25,89.16,73.12,82.57)
	x2 <- c(80.43,78.65,83.33,87.23,89.16,73.17,86.6,83.87,86.02,81.08,79.12,87.23,87.8,76.92,82.98,81.32,81.58,80.41,68.66,73.81,80.46,83.78,91.67,79.49,78.65)
	t.test(x1, x2, alternative = "two.sided", paired = TRUE, mu = 0, conf.level = 0.95)
	shapiro.test(x1)
	shapiro.test(x2)