# ......................................................................................
# .....................Cvičení 1 - Stručný úvod do R, Kombinatorika.....................
# ..................Adéla Vrtková, Michal Béreš, Martina Litschmannová..................
# ......................................................................................

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

# Nejprve si projdeme některé základy Rka a naimplementujeme si některé kombinatorické
# funkce.
#
#  Krátký úvod do R ####

# jednoduché početní operace
2+4
5/2

# POZOR na závorky! Pro počítání se používají pouze kulaté!
# Hranaté a složené mají v R jinou funkci!
(((10+2)*(340-33))-2)/3

# kombinační číslo, faktoriály
choose(10,2)
factorial(4)

# datové typy -> numeric, character, logical, (complex)
# funkcí class zjišťujeme typ objektu
a=2+3
class(a)

b="pismenko"
class(b)

c=(1>3)
class(c)

d=3+1i
class(d)

# * datové struktury v R ####
#
# - vector (rozumíme sloupcový vektor)
# - factor (speciální případ vektoru)
# - matrix (matice s rozměry n x m)
# - data.frame (datový rámec s rozměry n x p)
# - list (seznam)

# definování vektoru (sloupcový=column)
a = c(3,4,6,7)
a <- c(3,4,6,7)
a[2]

# další možnosti
rep(1,4) # vytvoří vektor se čtyřmi jedničkami

seq(1,10,2) #posloupnost od 1 do 10 s krokem 2

1:10  #posloupnost od 1 do 10 s krokem 1

b=c("A","B","C","D")
b

class(b)

#předefinování objektu na jiný typ - např. as.vector, as.matrix, as.factor,...
b=as.factor(b)
b

#práce s vektory - slučování podle sloupců/řádků
cbind(a,b)

rbind(a,b)

c(a,b)

## definování matice
A=matrix(c(3,4,6,7,3,2),nrow=2,ncol=3)
B=matrix(c(3,4,6,7,3,2),nrow=2,ncol=3,byrow=TRUE)
C=matrix(c(3,4,6,7,3,2),nrow=3,ncol=2)

B

B[1,3]

A[1,]

A[,2:3]

#diagonální matice
diag(4)

diag(4,2)

## operace s maticemi - pozor na maticové násobení -> %*%
A+B

A-B

A*B

A%*%C

# ......................................................................................
#
#  Kombinatorika ####
#
# * Variace ####
#
# V(n,k) - variace bez opakování, první argument bude celkový počet entit, druhý
# argument velikost výběru

# funkce se vytváří příkazem fucntion, je to objekt jehož jméno je dáno až proměnnou
# do které tento objekt přiřadím
variace = function(n,k) # zde zadávám počet parametrů a jejich jména
{ # celé tělo funkce je uzavřeno mezi závorkami {...}
    citatel = factorial(n)  # faktoriál v originálním Rku existuje tak jej použijeme
    jmenovatel = factorial(n-k)
    return(citatel/jmenovatel)    # to co funkce vrátí se dává do příkazu return(...)
}

# V*(n,k) - variace s opakováním

variace_opak = function(n,k)
{
  return(n^k)
}

# * Permutace ####
#
# P(n)=V(n,n) - permutace

permutace = function(n)
{
  return(variace(n,n))
}

# P*(n1,n2,n3,....,nk) - permutace s opakováním, vstup bude vektor s jednotlivými počty
# unikátních entit

permutace_opak = function(vec_n) # vec_n je vektro počtů hodnot př.: vec_n = c(2,2,2,4,3)
{
    n = sum(vec_n) # spočteme kolik máme hodnot celkem
    res_temp=factorial(n) #jejich faktoriál = hodnota v čitateli
    # jednoduchý cyklus začíná příkazem for, pak v závorkách následuje název iterátoru
    # a z jakého seznamu bude brán
    for(pocet in vec_n) # pocet je iterátor a postupně bude nabývat hodnot z vektoru vec_n
    {
        # postupně dělíme faktoriálem každého počtu unikátních entit
        res_temp=res_temp/factorial(pocet)
    }
    return(res_temp)
}

# * Kombinace ####
#
# C(n,k) - kombinace

kombinace = function(n,k)
{
  return(choose(n,k)) # funkce for kombinace už existuje v Rku a jmenuje se choose
}

# C*(n,k) - kombinace s opakováním

kombinace_opak = function(n,k)
{
  return(choose(n+k-1,k)) # použijeme známý vzorec
}

#  Úlohy na cvičení ####
#
# * Příklad 1. ####
#
# Které heslo je bezpečnější?
# * Heslo o délce osm znaků složené pouze z číslic.
# * Heslo o délce pět znaků složené pouze z písmen anglické abecedy.

# heslo 1
h1 = variace_opak(n = 10, k = 8)
# heslo 2
h2 = variace_opak(n = 26, k = 5)
h1/h2

# * Příklad 2. ####
#
# Jak dlouho by trvalo vyřešení problému obchodního cestujícího pro n = 10 měst hrubou
# silou, jestliže vyhodnocení délky každé z možných cest trvá 1 µs?

n = 10
pocet = permutace(n-1)/2
cas = pocet/1000000
cas

# * Příklad 3. ####
#
# Jak rozdělit kořist mezi 2 loupežníky, aby dostali oba věci ve stejné hodnotě
# (případně co nejbližší hodnotě). Tj. lze rozdělit N zadaných čísel do dvou skupin tak,
# aby součet čísel v obou skupinách byl stejný?
#
# **Kolik možností by bylo třeba vyzkoušet, pokud bychom úlohu řešili hrubou silou?**

N = 10
L = 4
variace_opak(n = L, k = N)

# * Příklad 4. ####
#
# Kolik anagramů slova "AUTO" můžeme vytvořit?
#
# Kolik anagramů slova "AUTOMOBILKA" můžeme vytvořit? Kolik z nich začína na "K"?

permutace(4)
vec = c(2,1,1,2,1,1,1,1,1)
sum(vec)
permutace_opak(vec)

vec = c(2,1,1,2,1,1,1,1)
sum(vec)
permutace_opak(vec)

# * Příklad 5.  ####
#
# V obchodě mají 6 druhů barevných hrníčků.
# - Kolika různými způsoby můžeme koupit 4 různě-barevné hrníčky?
# - Kolika různými možnostmi můžeme nakoupit 5 hrníčků (pokud nám nevadí více od stejné
# barvy)?
# - Jak se situace změní, pokud budou mít od každého pouze 4 kusy (a nám nevadí více
# stejné barvy)?

kombinace(6,4)
kombinace_opak(6,5)
kombinace_opak(6,5) - 6

# * Příklad 6. (sbírka kap. 1, př. 7,8) ####
#
# Z urny se třemi koulemi, dvěma červenými a jednou bílou, budou současně vybrány dvě
# koule.
# Student a učitel uzavřou sázku. Pokud budou obě koule stejné barvy, vyhraje student.
# Pokud
# budou mít koule různou barvu, vyhraje učitel.
# - Je hra férová? Jaké jsou pravděpodobnosti výhry učitele a studenta?
# - Jakou kouli je třeba přidat, aby hra byla férová?

kombinace(3,2)
kombinace(4,2)

# * Příklad 7. ####
#
# V balíčku je 5 různých párů ponožek (levá a pravá ponožka je vždy stejná).
# - Kolik různých dvojic ponožek lze vybrat?
# - Kolika různými způsoby se mohu obout? (tj. záleží na tom co je na které noze)

kombinace_opak(n = 5,k = 2)
variace_opak(n=5,k=2)
kombinace_opak(n = 5,k = 2)*2 - 5

# * Příklad 8. ####
#
#
# Mám 12 závaží o hmotnostech 1,2,...,12 kg.
# - Kolika způsoby je mohu rozdělit na 2 hromádky?
# - Kolika způsoby je mohu rozdělit na 3 hromádky?
# - Kolika způsoby je mohu rozdělit na 3 hromádky, má-li na všech být stejný počet
# závaží?
# - Kolika způsoby je mohu rozdělit na 3 hromádky o stejném počtu závaží, pokud hmotnost
# žádné z nich nesmí překročit 40 kg?

variace_opak(2,12)
variace_opak(3,12)
(variace_opak(3,12)-3)/permutace(3)+1
(variace_opak(3,12)-(variace_opak(2,12)-2)*3-3)/permutace(3)
kombinace(12,4)*kombinace(8,4)/permutace(3)
permutace(12)/(permutace(4)*permutace(4)*permutace(4)*permutace(3))
kombinace(12,4)*kombinace(8,4)/permutace(3)-kombinace(8,4)

# * Příklad 9. ####
#
# Mám 20 semínek od každého ze tří druhů zeleniny (mrkev, ředkvička, celer). Bohužel se
# pomíchala.
# - Do truhlíku zasadím 5 náhodných semínek. Jaká je pravděpodobnost, že mezi nimi budou
# alespoň tři ředkvičky?
# - Do truhlíku zasadím 5 náhodných semínek. Jaká je pravděpodobnost, že mezi nimi bude
# více mrkví než celerů?

(kombinace(20,3)*kombinace(40,2)+kombinace(20,4)*kombinace(40,1)+
   kombinace(20,5))/kombinace(60,5)


#' Two-sample t-test power calculation
#'
#' @param m1 Mean of a group 1 (e.g., the control-group)
#' @param m2 Mean of a group 2 (e.g., the experimental-group)
#' @param n1 Number of obs. in group 1 (e.g., the control-group)
#' @param n2 Number of obs. in group 2 (e.g., the control-group)
#' @param nratio Ratio of sample sizes, group 2 to group 1; default is nratio = 1, meaning equal group sizes
#' @param sd Standard deviation of each group, i.e., sd = sd1 = sd2
#' @param sd1 Standard deviation of a group 1 (e.g., the control group)
#' @param sd2 Standard deviation of a group 2 (e.g., the experimental group)
#' @param sig.level significance level; default is sig.level = 0.05
#' @param power one minus the probability of type II error; default is power = 0.8
#' @return Returns an object with all the study parameters
#' @export
#' @importFrom stats qnorm
#' @examples
#' twomeans(m1 = 12, m2 = 16, sd = 5)
twomeans <- function(m1        = NULL,
                     m2        = NULL,
                     n1        = NULL,
                     n2        = NULL,
                     nratio    = NULL,
                     sd        = NULL,
                     sd1       = NULL,
                     sd2       = NULL,
                     sig.level = 0.05,
                     power     = 0.80) {

    # Validate function
    .check.twomeans(m1,
                    m2,
                    n1,
                    n2,
                    nratio,
                    sd,
                    sd1,
                    sd2,
                    sig.level,
                    power)

    # Specify ratio
    if(is.null(nratio)) {
        nratio = 1
    }

    # Plug in sd (and sd1/sd2)
    if(!is.null(sd)) {
        sd1 = sd
        sd2 = sd
    }

    beta = 1 - power

    n1 <- (sd1^2 + (sd2^2) / nratio) *
          (qnorm(1 - sig.level / 2) + qnorm(1 - beta))^2 / ((m1 - m2)^2)

    n2 <- nratio * n1

    # Round the n's
    n1 <- ceiling(n1)
    n2 <- ceiling(n2)

    METHOD = "Two-sample t-test power calculation"
    NOTE   = paste("",
                   "m1 and m2 are the means of group 1 and 2, respectively.",
                   "n1 and n2 are the obs. of group 1 and 2, respectively.",
                   sep = "\r\n")

    structure(list(m1          = m1,
                   m2          = m2,
                   n1          = n1,
                   n2          = n2,
                   sig.level   = sig.level,
                   power       = power,
                   alternative = "two.sided",
                   method      = METHOD,
                   note        = NOTE),
                   class       = "power.htest")

}

.check.twomeans <- function(m1, m2, n1, n2, nratio, sd, sd1, sd2, sig.level, power) {

    # Non-negative standard deviation
    if(any(sd <= 0, sd1 <= 0, sd2 <= 0)) {
        stop("sd must be positive")
    }

    # Non-negative observations
    if(any(n1 <= 0, n2 <= 0, nratio <= 0)) {
        stop("n1, n2, and nratio must be positive")
    }

    # alpha and power must fall within the interval [0, 1]
    if(any(sig.level < 0, sig.level > 1, power < 0, power > 1)) {
        stop("sig.level and power must fall between 0 and 1")
    }

    # Means can't be equal
    if(m1 == m2) {
        stop("m1 and m2 cannot be equal")
    }

    # Can't specify sd and (sd1 and sd2)
    if(is.null(sd)) {
        if(any(is.null(sd1), is.null(sd2))) {
            stop("must specific either just sd or sd1 and sd2")
        }
    } else {
        if(any(!is.null(sd1), !is.null(sd2))) {
            stop("must specific either just sd or sd1 and sd2")
        }
    }
}


library(grid)

circleColor <- "black"
insideDotColor <- rgb(0, 1, 0)
outsideDotColor <- rgb(1, 0, 0, alpha=0.2)

toPolar <- function (pt) {
  list("r"=sqrt(pt[1]^2 + pt[2]^2), "phi"=atan2(pt[2], pt[1]))
}

phis <- c()
rs <- c()

plotDots <- function (n) {
  # procedural approach
  i = 1
  png(filename="pi-circle.png")
  plot.new()
  grid.circle(0.5, 0.5, r=0.4)
  repeat {
    newPoint <- runif(2, min=-1, max=1)
    polar <- toPolar(newPoint)
    if (polar$r < 1) {
      grid.circle(newPoint[1]*0.4 + 0.5, newPoint[2]*0.4+0.5, r=0.001, gp=gpar(col=insideDotColor))
      rs <- c(rs, polar$r)
      phis <- c(phis, polar$phi)
      i = i + 1
    } else {
      grid.circle(newPoint[1]*0.4 + 0.5, newPoint[2]*0.4+0.5, r=0.001, gp=gpar(col=outsideDotColor))
    }
    if (i >= n) {
      break
    }
  }
  dev.off()
  list("rs"=rs, "phis"=phis)
}

dots <- plotDots(5000)

# histogram for radius
Sys.sleep(1)
png(filename="hist-r.png")
hist(dots$rs)
dev.off()

# histogram for phi
dots <- plotDots(10^5)
Sys.sleep(1)
png(filename="hist-phi.png")
hist(dots$phis)
dev.off()


library(rstudioapi) #
setwd(dirname(getActiveDocumentContext()$path))
#

library(readxl)
library(tidyverse)
library(dplyr)
library(ggplot2)
library(rpart)
library(rpart.plot)

weather <-data.frame(read_excel("weather.xlsx",sheet="01",skip = 0)) #

weather$temp.d <- cut(weather$temp, breaks = c(-Inf,20,26,Inf),
                        labels = c("cool","mild","hot"),include.lowest = F)

weather$humi.d <- cut(weather$humi, breaks = c(-Inf,80,Inf),
                        labels = c("normal","high"),include.lowest = F)

weather$wind.d <- cut(weather$wind, breaks = c(-Inf,20,Inf),
                        labels = c("weak","strong"),include.lowest = F)

weather$outlook <- factor(weather$outlook, levels = c("sunny","overcast","rain"))
weather$temp.d <- factor(weather$temp.d, levels = c("hot","mild","cool"))
weather$humi.d <- factor(weather$humi.d, levels = c("high","normal"))
weather$wind.d <- factor(weather$wind.d, levels = c("strong","weak"))
weather$play <- factor(weather$play, levels = c("yes","no"))

3*3*2*2

write.csv(weather,"weather01-factor.csv", row.names = FALSE)

names(weather) #

number.weather <- length(unique(weather$outlook))*length(unique(weather$temp.d))*length(unique(weather$wind.d))*length(unique(weather$play)) #
number.weather
table(weather$outlook)
table(weather$temp.d)
table(weather$humi.d)
table(weather$wind.d)

library(vtree) #https://www.infoworld.com/article/3573577/how-to-count-by-groups-in-r.html

vtree(weather, "outlook", palette = 3, sortfill = TRUE)

vtree(weather, "temp.d", palette = 3, sortfill = TRUE)

vtree(weather, "humi.d", palette = 3, sortfill = TRUE)
vtree(weather, "wind.d", palette = 3, sortfill = TRUE)
vtree(weather, "play", palette = 3, sortfill = TRUE)
vtree(weather, c("outlook", "temp.d"),horiz = FALSE)
vtree(weather, c("outlook", "play"),horiz = FALSE)
vtree(weather, c("outlook", "temp.d","humi.d"),horiz = FALSE)
vtree(weather, c("outlook", "temp.d","humi.d", "play"),horiz = FALSE)

vtree(weather, c("temp.d", "outlook","humi.d", "play"),horiz = FALSE)

library(vtree)
table(weather$play)
vtree(weather, c("play"),horiz = FALSE)
h.s = -5/14*log(5/14) - 9/14*log(9/14)
h.s

vtree(weather, c("outlook", "play"),horiz = FALSE)

weather %>%
  filter(outlook == "sunny")

h.s.sunny = -2/5*log(2/5) - 3/5*log(3/5)
h.s.sunny

weather %>%
       filter(outlook == "overcast")
h.s.overcast = -4/4*log(4/4) - 0/4*log(0.000000001/4)
h.s.overcast

weather %>%
       filter(outlook == "rain")
h.s.rain = -2/5*log(2/5) - 3/5*log(3/5)
h.s.rain

h.outlook.s <- 5/14*h.s.sunny + 4/14*h.s.overcast + 5/14*h.s.rain
h.outlook.s

vtree(weather, c("temp.d", "play"),horiz = FALSE)

weather %>%
  filter(temp.d == "cool")

h.s.cool = -3/4*log(3/4) - 1/4*log(1/4)
h.s.cool

weather %>%
  filter(temp.d == "mild")
h.s.mild = -2/6*log(2/6) - 4/6*log(4/6)
h.s.mild

weather %>%
  filter(temp.d == "hot")
h.s.hot = -2/4*log(2/4) - 2/4*log(2/4)
h.s.hot

h.temp.s <- 4/14*h.s.cool + 6/14*h.s.mild + 4/14*h.s.hot
h.temp.s

vtree(weather, c("wind.d", "play"),horiz = FALSE)

weather %>%
  filter(wind.d == "strong")

h.s.strong = -3/6*log(3/6) - 3/6*log(3/6)
h.s.strong

weather %>%
  filter(wind.d == "weak")

h.s.weak = -2/8*log(2/8) - 6/8*log(6/8)
h.s.weak

h.wind.s <- 6/14*h.s.strong + 8/14*h.s.weak
h.wind.s

vtree(weather, c("humi.d", "play"),horiz = FALSE)

weather %>%
  filter(humi.d == "high")

h.s.high = -4/7*log(4/7) - 3/7*log(3/7)
h.s.high

weather %>%
  filter(humi.d == "normal")

h.s.normal = -1/7*log(1/7) - 6/7*log(6/7)
h.s.normal

h.humi.s <- 7/14*h.s.high + 7/14*h.s.normal
h.humi.s

##
c(h.outlook.s,h.temp.s,h.wind.s,h.humi.s)

###

glimpse(weather)
str(weather)

control <- rpart.control(minsplit = 2,
                         minbucket = 1,
                         maxdepth = 4,
                         cp = 0.01)

# building the classification tree with rpart
tree <- rpart(play~ outlook + temp.d + humi.d + wind.d,
              data=weather,
              parms=list(split='information'),
              control = control,
              method = "class")
tree
rpart.plot(tree, nn=TRUE)


library(tidyverse)
library(dplyr)

setwd("/Users/naoki_atkins/Documents/Code/Classwork/dataScience/hw7")
load("myvec.RData")

acf(myvec, lag.max = 100)

my_ts <- ts(myvec, frequency = 50)
decomp <- decompose(my_ts)

plot(decomp)

# Question 3a.

dtw <- function (A, B) {
  M <- nrow(A)
  N <- nrow(B)
  Cost <- matrix(0,M,N) # Initialize with zeros
  # compute cost and fill in the matrix
  for (i in 1:M) {
    for (j in 1:N) {
      Cost[i,j] <- as.numeric((A[i,1] - B[j,1])^2 + (A[i,2] - B[j,2])^2) # distance function
    }
  }
  C <- matrix(0,M,N) # Initialize with zeros
  C[1,1] <- Cost[1,1] # Initialize top left cell
  for (i in 2:M) { # Initialize first column
    C[i,1] <- C[i-1,1] + Cost[i,1]
  }
  for (j in 2:N) { # Initialize first row
    C[1,j] <- C[1,j-1] + Cost[1,j]
  }

  # Fill in everything besides the first column and first row
  # Evaluate 3 neighbors (above, left-above, left)
  # Pick the smallest
  # Add the smallest value to ...
  # Fill in the matrix with that computed value
  for(i in 2:M) {
    for(j in 2:N) {
      C[i,j] <- min(C[i-1, j], C[i, j-1], C[i-1, j-1]) + Cost[i,j]
    }
  }
  return (C[M,N])
}

# Question 3b.
A.x <- c(2, 0, 2, 4, 5)
A.y <- c(2, 4, 6, 5, 2)

A <- matrix(data = c(A.x, A.y), nrow = 5)

B.x <- c(1, 0, 4, 5)
B.y <- c(1, 6, 4, 1)

B <- matrix(data = c(B.x, B.y), nrow = 4)

dtw(A, B)

# Question 4

tsX <- read_csv("tsX.csv")
ts2 <- read_csv("ts2.csv")
ts3 <- read_csv("ts3.csv")
ts4 <- read_csv("ts4.csv")
ts5 <- read_csv("ts5.csv")

# 44116.78
dtw(tsX, ts2)
# 18583.75
dtw(tsX, ts3)
# 13293.01
dtw(tsX, ts4)
# 3192.354
dtw(tsX, ts5)

tsX %>%
  ggplot(aes(tsX$x, tsX$y)) +
  geom_path()

ts2 %>%
  ggplot(aes(ts2$x, ts2$y)) +
  geom_path()

ts3 %>%
  ggplot(aes(ts3$x, ts3$y)) +
  geom_path()

ts4 %>%
  ggplot(aes(ts4$x, ts4$y)) +
  geom_path()

ts5 %>%
  ggplot(aes(ts5$x, ts5$y)) +
  geom_path()


# PSI function
# Reference: P395, Credit risk analytics - Measurement technique, applications and examples
# Rules of thumb
# PSI < 0.10: no significant shift (green traffic light)
# 0.10 ≤ PSI < 0.25: moderate shift (yellow traffic light)
# PSI ≥ 0.25: significant shift (red traffic light)
library(tidyverse)

# Hàm tính PSI cho từng biến

psi <- function(actual, expected){

  tbl <- list(actual = actual, expected = expected) %>%
    # map(factor, levels = lbl, labels = lbl) %>%
    map(table) %>%
    map(prop.table) %>%
    map(as.data.frame, stringsAsFactors=FALSE) %>%
    reduce(full_join, by = "Var1") %>%
    mutate(sub_psi = (Freq.x-Freq.y)*(log(Freq.x)-log(Freq.y))) %>%
    mutate(psi = sum(sub_psi)) %>%
    select(Range = Var1,
           Trainning = Freq.y,
           Actual = Freq.x,
           psi) %>%
    mutate(Trainning = paste0(round(Trainning * 100, 1), "%"),
           Actual = paste0(round(Actual * 100, 1), "%"),
           psi = round(psi, 3),
           tag = case_when(psi < 0.1 ~ "green",
                           psi < 0.25 ~ "yellow",
                           TRUE ~ "red"))

  return(tbl)
}

# Hàm tính PSI cho cả bộ dữ liệu
psi_df <- function(dat_train, dat_test, var_skip = NULL){
  same_name <- names(dat_test) %>%
    intersect(names(dat_train)) %>%
    setdiff(var_skip)

  sl <- function(x){
    psi(expected = dat_train[[x]], actual = dat_test[[x]]) %>% return()
  }

  same_name %>%
    set_names(same_name) %>%
    map_dfr(sl, .id = "Variables") %>%
    return()

}


# Barometric formula
# https://en.wikipedia.org/wiki/Barometric_formula
# Ideal law: P = rho * R/M * T
# See also:
# * https://physics.stackexchange.com/questions/532903/air-pressure-dependence-on-temperature
# * https://en.wikipedia.org/wiki/Density_of_air

g0 <- 9.80665 # m/s2 -- gravitational acceleration
R <- 8.3144598 # J/(mol·K) -- universal gas constant
M <- 0.0289644 # kg/mol -- molar mass of Earth's air
M_v <- 0.018016 # kg/mol -- molar mass of water vapor

# Constants taken from Barometric formula
# https://en.wikipedia.org/wiki/Barometric_formula
# for altitude between 0 and 11 km.

h_b <- 0 # m
P_b <- 101325.00 # Pa
T_b <- 288.15 # K
L_b <- -0.0065 # K/m
rho_b <- 1.2250 # kg/m3

# This function computes the pressure in function of altitude.
# LR stands for lapse rate: the drop in temperature in function of altitude is
# here taken into consideration. For altitude between 0 and 11 km, the drop
# in temperature is taken as a linear function: T = T_b + L_b*h.
# See: https://en.wikipedia.org/wiki/Barometric_formula#Derivation
# Other assumption here is that the air pressure is hydrostatic (i.e. "fluid" is not moving).
P.lr <- function(h.meters) {
  base <- T_b / (T_b + L_b * (h.meters - h_b))
  exp <- g0 * M / (R * L_b)
  P_b * base^exp
}

P.lr(10)

# PRESSURE
# Here I define a few pressure conversion functions.

P.cmH2O_to_Pa <- gwloggeR.data:::P.cmH2O_to_Pa

P.Pa_to_cmH2O <- gwloggeR.data:::P.Pa_to_cmH2O

P.Pa_to_cmH2O(P.lr(0))
P.Pa_to_cmH2O(P.lr(100))

# Conclusion here is that the drop in air pressure is expected to drop per 100 m:
P.Pa_to_cmH2O(P.lr(0)) - P.Pa_to_cmH2O(P.lr(100))

curve(P.Pa_to_cmH2O(P.lr(x)), xlim = c(0, 11000), xlab = 'Altitude (m)', ylab = 'Air pressure (cmH2O)')

# DENSITY
# This is the same as P.lr, but for the density.
# Not important I think.

# rho.lr <- function(h.meters) {
#   base <- T_b / (T_b + L_b * (h.meters - h_b))
#   exp <- 1 + g0 * M / (R * L_b)
#   rho_b * base^exp
# }
#
# rho.lr(0)
# rho.lr(100)
#
# curve(rho.lr(x), xlim = c(0, 11000))

# TEMPERATURE EFFECT

# This is a very naive calculation of temperature effect based on the ideal law
# because the density of air is assumed not to change in function of temperature.
P.Pa_to_cmH2O(rho_b*R/M*(T_b + 1) - rho_b*R/M*T_b)

## TEMPERATURE EFFECT ON DENSITY OF DRY AIR

# Here we focus on the following:
# https://en.wikipedia.org/wiki/Density_of_air

# This function computes the density (rho) of air based on the assumption of
# dry air.
rho_da <- function(temp.K) {
  P_b*M/(R*temp.K)
}

rho_da(T_b)
rho_da(15 + 273.15) # 15 °C
rho_da(20 + 273.15)

# Less naive calculation of temperature effect assuming dry air.
P.Pa_to_cmH2O(rho_da(T_b + 1)*R/M*(T_b + 1) - rho_da(T_b)*R/M*T_b)

## TEMPERATURE EFFECT ON DENSITY OF HUMID AIR

# Saturation vapor pressure
# See: https://en.wikipedia.org/wiki/Vapour_pressure_of_water
# The Buck equation is the best one.

P_sat.Pa <- function(temp.K, type = c('Buck', 'Tetens')) {
  type <- match.arg(type)
  temp.C <- temp.K - 273.15
  switch (type,
    'Buck' = 0.61121*exp( (18.678 - temp.C/234.5)*(temp.C/(257.14 + temp.C)) ),
    'Tetens' = 0.61078*exp(17.2*temp.C/(temp.C + 237.3))
  )
}

P_sat.Pa(T_b)
P_sat.Pa(T_b, type = 'Tetens')

# This function computes the density (rho) of air based on the assumption of
# humid air.

rho_ha <- function(temp.K, humidity.perc) {
  P_v <- humidity.perc/100 * P_sat.Pa(temp.K)
  P_d <- P_b - P_v

  (P_d*M + P_v*M_v)/(R*temp.K)
}

rho_da(T_b)
rho_ha(T_b, 0)
rho_ha(T_b, 100)

# Less naive calculation of temperature effect assuming humid air.
P.Pa_to_cmH2O(rho_ha(T_b + 1, 90)*R/M*(T_b + 1) - rho_ha(T_b, 90)*R/M*T_b)

# HUMIDITY
# The bulge during non-summer can not be explained by drop in air pressure density.
# https://nl.wikipedia.org/wiki/Relatieve_luchtvochtigheid#Relatieve_luchtvochtigheid_en_klimaat
P.Pa_to_cmH2O(rho_ha(T_b, 75)*R/M*T_b - rho_ha(T_b, 90)*R/M*T_b)


=begin
  # sample-geometry01.rb

  require 'algebra'
  R = MPolynomial(Rational)
  x,y,a1,a2,b1,b2,c1,c2 = R.vars('xya1a2b1b2c1c2')

  V = Vector(R, 2)
  X, A, B, C = V[x,y], V[a1,a2], V[b1,b2], V[c1,c2]

  D = (B + C) /2
  E = (C + A) /2
  F = (A + B) /2

  def line(p1, p2, p3)
    SquareMatrix.det([[1, *p1], [1, *p2], [1, *p3]])
  end

  l1 = line(X, A, D)
  l2 = line(X, B, E)
  l3 = line(X, C, F)
  s = line(A, B, C)

  g = Groebner.basis [l1, l2, l3, s-1] #s-1 means non degeneracy

  g.each_with_index do |f, i|
    p f
  end
  #x - 1/3a1 - 1/3b1 - 1/3c1
  #y - 1/3a2 - 1/3b2 - 1/3c2
  #a1b2 - a1c2 - a2b1 + a2c1 + b1c2 - b2c1 - 1
((<_|CONTENTS>))
=end


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

library("e1071")

##1. Linear SVM Classifier
#[adapted from https://www.datacamp.com/community/tutorials/support-vector-machines-r]
set.seed(12345)
n1 <- 10
y1 <- rnorm(n1,mean=0,sd=1)
x1 <- rnorm(n1,mean=0,sd=1)
n2 <- 10
y2 <- rnorm(n2,mean=0,sd=1) + 1
x2 <- rnorm(n2,mean=0,sd=1) + 1

dat1 <- data.frame(stringsAsFactors=FALSE,
  y=c(y1,y2),
  x=c(x1,x2),
  grp=c(rep("blue",n1),rep("red",n2)))

fnam <- "../images/svm_1.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
par(mar=c(3,2.5,1.5,0.5),mgp=c(1.7,0.7,0),cex=0.8)
with(dat1,plot(x,y,col=grp,pch=19))
dev.off()

modfit <- svm(grp ~ .,
              dat1,
              scale=FALSE,             #scaling stored for testing
              type="C-classification", #SVM algorithm
              kernel="linear",         #kernel type
              cost=1.0,                #C-constant (cost)
              tolerance=0.001)         #convergence epsilon

#beta_0 + beta_1*x + beta_2*y = 0
#y = -(beta_1/beta_2)*x - (beta_0/beta_2)
beta_0 = -modfit$rho
beta_1 = t(modfit$coefs)%*%dat1$x[modfit$index]
beta_2 = t(modfit$coefs)%*%dat1$y[modfit$index]

grid1 <- expand.grid(
  x = seq(min(dat1$x),max(dat1$x),length=100),
  y = seq(min(dat1$y),max(dat1$y),length=100))
grid1$grp <- as.character(predict(modfit,grid1))

fnam <- "../images/svm_2.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
par(mar=c(3,2.5,1.5,0.5),mgp=c(1.7,0.7,0),cex=0.8)
with(grid1,plot(x,y,col=grp,pch=19,cex=0.2))
with(dat1,points(x,y,col=grp,pch=19))
abline(a=-beta_0/beta_2,b=-beta_1/beta_2)
dev.off()

##2. Non-linear SVM Classifier
set.seed(12345)
n1 <- 30
rad1 <- sqrt(runif(n1,1,2))
the1 <- runif(n1,0,2*pi)
x1 <- rad1*cos(the1)
y1 <- rad1*sin(the1)
n2 <- 30
rad2 <- sqrt(runif(n2,0,1))
the2 <- runif(n2,0,2*pi)
x2 <- rad2*cos(the2)
y2 <- rad2*sin(the2)

dat1 <- data.frame(stringsAsFactors=FALSE,
  x=c(x1,x2),
  y=c(y1,y2),
  grp=c(rep("blue",n1),rep("red",n2)))

fnam <- "../images/svm_3.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
par(mar=c(3.0,3.0,1.5,1.5),mgp=c(1.7,0.7,0),cex=0.8)
with(dat1,plot(x,y,col=grp,pch=19))
dev.off()

dat1$z <- dat1$x^2 + dat1$y^2

fnam <- "../images/svm_4.tiff"
tiff(file=fnam,units="in",width=8,height=4,res=300,compression="lzw")
par(mfcol=c(1,2),mar=c(3,2.5,1.5,0.5),mgp=c(1.7,0.7,0),cex=0.8)
with(dat1,plot(x,z,col=grp,pch=19))
with(dat1,plot(y,z,col=grp,pch=19))
dev.off()

fnam <- "../images/svm_5.tiff"
tiff(file=fnam,units="in",width=8,height=4,res=300,compression="lzw")
par(mfcol=c(1,2),mar=c(3,2.5,1.5,0.5),mgp=c(1.7,0.7,0),cex=0.8)
with(dat1,plot(x,z,col=grp,pch=19))
abline(h=1)
with(dat1,plot(y,z,col=grp,pch=19))
abline(h=1)
dev.off()

fnam <- "../images/svm_6.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
par(mar=c(3.0,3.0,1.5,1.5),mgp=c(1.7,0.7,0),cex=0.8)
with(dat1,plot(x,y,col=grp,pch=19))
radius <- 1
theta <- seq(0,2*pi,length=200)
lines(x=radius*cos(theta),y=radius*sin(theta))
dev.off()

modfit <- svm(grp ~ x + y,
              dat1,
              scale=FALSE,             #scaling stored for testing
              type="C-classification", #SVM algorithm
              kernel="radial",         #kernel type
              gamma=0.5,               #kernel gamma
              cost=1.0,                #C-constant (cost)
              tolerance=0.001,         #convergence epsilon
              epsilon=0.1)             #loss-function epsilon

grid1 <- expand.grid(
  x = seq(min(dat1$x),max(dat1$x),length=100),
  y = seq(min(dat1$y),max(dat1$y),length=100))
grid1$grp <- as.character(predict(modfit,grid1))

fnam <- "../images/svm_7.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
par(mar=c(3.0,3.0,1.5,1.5),mgp=c(1.7,0.7,0),cex=0.8)
with(grid1,plot(x,y,col=grp,pch=19,cex=0.2))
with(dat1,points(x,y,col=grp,pch=19))
radius <- 1
theta <- seq(0,2*pi,length=200)
lines(x=radius*cos(theta),y=radius*sin(theta))
dev.off()

##3. Linear SVM Regression

## 2. Model Fitting
set.seed(12345)

real_a1 <- 1.5
real_a2 <- 4
x <- runif(n=30,min=0,max=10)
y <- real_a1*x + real_a2 + rnorm(n=30,mean=0,sd=1)
dat1 <- data.frame(x,y)

fnam <- "../images/svm_7.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
par(mar=c(3,2.5,1.5,0.5),mgp=c(1.7,0.7,0),cex=0.8)
with(dat1,plot(x,y,pch=19))
dev.off()

modfit <- svm(y ~ x,
              dat1,
              scale=FALSE,           #scaling stored for testing
              type="eps-regression", #SVM algorithm
              kernel="linear",       #kernel type
              tolerance=0.001,       #convergence epsilon
              epsilon=0.5)           #loss-function epsilon

#y = beta_1*x + beta_0
beta_0 = -modfit$rho
beta_1 = t(modfit$coefs)%*%dat1$x[modfit$index]

fnam <- "../images/svm_8.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
par(mar=c(3,2.5,1.5,0.5),mgp=c(1.7,0.7,0),cex=0.8)
with(dat1,plot(x,y,pch=19))
abline(a=beta_0,b=beta_1,col="blue")
abline(a=beta_0 - 0.5,b=beta_1,lty=2,col="blue")
abline(a=beta_0 + 0.5,b=beta_1,lty=2,col="blue")
dev.off()

lmfit <- lm(y ~ x,data=dat1)
a1 <- lmfit$coef[1]
a2 <- lmfit$coef[2]

fnam <- "../images/svm_9.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
par(mar=c(3,2.5,1.5,0.5),mgp=c(1.7,0.7,0),cex=0.8)
with(dat1,plot(x,y,pch=19))
abline(a=a1,b=a2,lwd=2,col="red")
abline(a=beta_0,b=beta_1,col="blue")
abline(a=beta_0 - 0.5,b=beta_1,lty=2,col="blue")
abline(a=beta_0 + 0.5,b=beta_1,lty=2,col="blue")
dev.off()


#------------------#
# Forecasting
#------------------#
rm(list=ls(all.names=TRUE))
#------------------#
library(dplyr)
library(tidyr)
install.packages("skimr")
library(skimr)
library(stats)
library(MASS)
library(ggplot2)
#------------------#
#-------------------------#
# Load data
#-------------------------#
dm <- readr::read_csv("demand_data.txt")

# Add time trend
dm <- dm %>%
  mutate(t = row_number()) %>%
  as_tibble()

# Descriptives
summary(dm)
skim(dm)
head(dm, 5)

#-------------------------#
# Visualize
#-------------------------#
hist(dm$demand)

dm %>%
  ggplot(aes(x = demand)) +
  geom_histogram()

dm %>%
  ggplot(aes(x = t, y = demand)) +
  geom_line()
#-------------------------#
# Setting
#-------------------------#
#The price is $4, the unit cost is $0.80, and the salvage value is $0.
price <- 4
cost <- 0.8
salvage <- 0

# What we know
sl<-(price - cost) / (price - salvage) # target service level
optimal_order_quantity <- as.integer(quantile(dm$demand, sl))

# Splitting the sample
dm1 <- dm[1:100,]
dm2 <- dm[101:300,] # forecast, calculate forecasting_error
dm3 <- dm[301:500,]

# Make table for summary
res_table <- data.frame(
  method = c("wo prediction",
             "moving average",
             "simple_exp_wo_tuning", "simple_exp_w_tuning",
             "holt_wo_tuning", "holt_w_tuning"),
  AvgProf = rep(0, 6)
)

dm3 %>%
  ggplot(aes(x = demand)) +
  geom_histogram()

#-------------------------#
# Find the optimal quantity using simulation with the full data
# (we can save time by using optimization methods)
#-------------------------#

# Prepare grid
stocking <- c(min(dm$demand):max(dm$demand))

# Calculate
profit <- matrix(0, nrow = nrow(dm), ncol = length(stocking))
for (i in 1:length(stocking)) { # loop for each stocking level
  q <- stocking[i]

  for (j in 1:nrow(dm)) { # loop for each realized demand
    profit[j,i] <- price * min(q, dm$demand[j]) + salvage * max(q - dm$demand[j], 0) - cost * q
  }
}
# make summary table
summary_table <- data.frame(
  stocking = stocking,
  AvgProf = apply(profit, 2, mean), # column means
  StdProf = apply(profit, 2, sd) # column sd
)
summary_table %>%
  as_tibble() %>%
  arrange(desc(AvgProf)) %>%
  head(1)

# This is going to be the (approx.) same as the following value
quantile(dm$demand, 0.80)

optimal_profit <- max(summary_table$AvgProf)
optimal_profit

optimal_stocking <- summary_table %>%
  as_tibble() %>%
  arrange(desc(AvgProf)) %>%
  head(1) %>%
  dplyr::select(stocking)
optimal_stocking

# Again, this value is going to be the (approx.) same as the following calculation
mean(price * pmin(optimal_order_quantity, dm$demand) - cost * optimal_order_quantity)

# Value of an oracle
(price - cost) * mean(dm$demand) - optimal_profit

# Safety Stock
safety_stock <- optimal_stocking - mean(dm$demand)
print(safety_stock)

#-------------------------#
# Find the optimal quantity using simulation only for df3
# (we can save time by using optimization methods)
#-------------------------#
# Prepare grid
stocking <- c(min(dm3$demand):max(dm3$demand))
# Calculate
profit <- matrix(0, nrow = nrow(dm3), ncol = length(stocking))
for (i in 1:length(stocking)) { # loop for each stocking level
  q <- stocking[i]

  for (j in 1:nrow(dm3)) { # loop for each realized demand
    profit[j,i] <- price * min(q, dm3$demand[j]) + salvage * max(q - dm3$demand[j], 0) - cost * q
  }
}
# make summary table
summary_table <- data.frame(
  stocking = stocking,
  AvgProf = apply(profit, 2, mean), # column means
  StdProf = apply(profit, 2, sd) # column sd
)
summary_table %>%
  as_tibble() %>%
  arrange(desc(AvgProf)) %>%
  head(1)

# This is going to be the (approx.) same as the following value
quantile(dm3$demand, 0.80)

optimal_profit <- max(summary_table$AvgProf)
optimal_profit

optimal_stocking <- summary_table %>%
  as_tibble() %>%
  arrange(desc(AvgProf)) %>%
  head(1) %>%
  dplyr::select(stocking) %>%
  as.numeric()

# Again, this value is going to be the (approx.) same as the following calculation
res_table$AvgProf[1] <- mean(price * pmin(optimal_stocking, dm3$demand) - cost * optimal_stocking)

# Value of an oracle
(price - cost) * mean(dm3$demand) - optimal_profit

# Safety Stock
safety_stock <- optimal_stocking - mean(dm3$demand)
print(safety_stock)

#---------------------------------------------------------------------------#
# Forecasting
#---------------------------------------------------------------------------#
# forecast for 301  --> use moving average, e.g., (D[300]+D[299]+D[298]+D[297])/4
# then, at day 301, what should be the stocking level?
# it would be: forecast + safety stock.
# then, what is the safety stock?
# Need to forecast forecasting errors:
# Forecast forecast error distribution using the forecast error from day 101 to 300
# Now, knowing the forecast error distribution --> Take the 80th percentile of the forecast error distribution.
# then: stocking = forecast + 80th_percentile of forecast_error

#-------------------------#
# method 1. moving average
#-------------------------#
# Forecast demand of df2 using df1
forecast <- c()
for (i in 1:nrow(dm2)) {
  # forecast by the last four days
  last_four_values <- c(dm$demand[(100+i-1)-3], dm$demand[(100+i-1)-2], dm$demand[(100+i-1)-1], dm$demand[(100+i-1)-0])
  forecast[i] <- mean(last_four_values)
}

# calculate stocking values using predicted forecast error in df2
forecasting_error <- dm2$demand - forecast
hist(forecasting_error)

safety_stock <- quantile(forecasting_error, 0.80)
stocking <- forecast + safety_stock

# for the remaining days 301-- 500: repeat the process
# Note that in this case, forecast changes, but safety stock remains the same
# For the third split sample: we would like to calculate the average daily profit, if we use the moving average forecasting method
forecast_301_500 <- c()
for (i in 1:nrow(dm3)) {
  # forecast by the last four days
  last_four_values <- c(dm$demand[(300+i-1)-3], dm$demand[(300+i-1)-2], dm$demand[(300+i-1)-1], dm$demand[(300+i-1)-0])
  forecast_301_500[i] <- mean(last_four_values)
}

stocking_301_500 <- forecast_301_500 + safety_stock # we use safety_stock obtained from df2

# Average profit
res_table$AvgProf[2] <- mean(price * pmin(stocking_301_500, dm3$demand) + salvage * pmax(stocking_301_500 - dm3$demand, 0) - cost * stocking_301_500)

# Oracle
(price - cost) * mean(dm3$demand)

#-------------------------#
# method 2. simple exponential smoothing
# It starts from week 101
#-------------------------#
# start from arbitrary number
alpha = 0.2

forecast_101_300 <- c()
for (i in 1:(300-101+1)) {
  if (i == 1){
    forecast_101_300[1] <- mean(dm1$demand)
  } else {
    # update the forecast with alpha
    forecast_101_300[i] <- alpha * dm$demand[100+i-1] + (1 - alpha) * forecast_101_300[i-1]
  }
}

forecast_error_simple_expo_smooth <- dm2$demand - forecast_101_300
hist(forecast_error_simple_expo_smooth)

safety_stock <- quantile(forecast_error_simple_expo_smooth, 0.80)
stocking <- forecast_101_300 + safety_stock

# for the remaining days 301-- 500: repeat the process
# Note that in this case, forecast changes, but safety stock remains the same
forecast_301_500 <- c()
for (i in 1:(300-101+1)) {
  if (i == 1){
    forecast_301_500[1] <- mean(dm$demand[1:300])
  } else {
    # update the forecast with alpha
    forecast_301_500[i] <- alpha * dm$demand[300+i-1] + (1 - alpha) * forecast_301_500[i-1]
  }
}

stocking_301_500 <- forecast_301_500 + safety_stock # we use safety_stock obtained from df2

# Average profit
res_table$AvgProf[3] <- mean(price * pmin(stocking_301_500, dm3$demand) + salvage * pmax(stocking_301_500 - dm3$demand, 0) - cost * stocking_301_500)

## finding optimal alpha
mse_simple_exponential_smoothing <- function(alpha, actual_demand) {
  forecast_101_300 <- c()
  for (i in 1:(300-101+1)) {
    if (i == 1){
      forecast_101_300[1] <- mean(dm1$demand)
    } else {
      # update the forecast with alpha
      forecast_101_300[i] <- alpha * dm$demand[100+i-1] + (1 - alpha) * forecast_101_300[i-1]
    }
  }

  mse <- sum((actual_demand - forecast_101_300)^2) / length(actual_demand)
  return(mse)
}

res <- optim(0.2, mse_simple_exponential_smoothing, method = "L-BFGS-B",
             actual_demand = dm2$demand,
             lower = c(0),
             upper = c(1))
## Note: bisection might be more appropriate here (https://urldefense.com/v3/__https://rpubs.com/aaronsc32/bisection-method-r__;!!Mih3wA!WKo4McW-7-dzrHSo51O5DuRNZsZC4YkYFqeXfDfe2Jlu5bLOewZdY1wOa_2w8g$ )
## There are many ways/solvers to do this, but I just sticked with the very basic.

# use the tuned values
alpha <- res$par

forecast_101_300_with_optim_alpha <- c()
for (i in 1:(300-101+1)) {
  if (i == 1){
    forecast_101_300_with_optim_alpha[1] <- mean(dm1$demand)
  } else {
    # update the forecast with alpha
    forecast_101_300_with_optim_alpha[i] <- alpha * dm$demand[100+i-1] + (1 - alpha) * forecast_101_300_with_optim_alpha[i-1]
  }
}

forecast_error_simple_expo_smooth <- dm2$demand - forecast_101_300_with_optim_alpha
hist(forecast_error_simple_expo_smooth)

safety_stock <- quantile(forecast_error_simple_expo_smooth, 0.80)
stocking <- forecast_101_300_with_optim_alpha + safety_stock

# for the remaining days 301-- 500: repeat the process
# Note that in this case, forecast changes, but safety stock remains the same
forecast_301_500 <- c()
for (i in 1:(500-301+1)) {
  if (i == 1){
    forecast_301_500[1] <- forecast_101_300[200]
  } else {
    # update the forecast with alpha
    forecast_301_500[i] <- alpha * dm$demand[300+i-1] + (1 - alpha) * forecast_301_500[i-1]
  }
}

stocking_301_500 <- forecast_301_500 + safety_stock # we use safety_stock obtained from df2

# Average profit
res_table$AvgProf[4] <- mean(price * pmin(stocking_301_500, dm3$demand) + salvage * pmax(stocking_301_500 - dm3$demand, 0) - cost * stocking_301_500)

# Another Objective Function (Maximizing Average profit to find tuning parameters)
#101_300: Average_profit
## finding optimal alpha
AveProf_simple_exponential_smoothing <- function(alpha, df, price, salvage, cost) {
  forecast_101_300 <- c()
  for (i in 1:(300-101+1)) {
    if (i == 1){
      forecast_101_300[1] <- mean(dm$demand[1:100])
    } else {
      # update the forecast with alpha
      forecast_101_300[i] <- alpha * dm$demand[100+i-1] + (1 - alpha) * forecast_101_300[i-1]
    }
  }

  forecast_error_simple_expo_smooth <- dm$demand[101:300] - forecast_101_300

  safety_stock <- quantile(forecast_error_simple_expo_smooth, 0.80)
  stocking_101_300 <- forecast_101_300 + safety_stock

  # Average profit
  AvgProf <- mean(price * pmin(stocking_101_300, dm$demand[101:300]) + salvage * pmax(stocking_101_300 - dm$demand[101:300], 0) - cost * stocking_101_300)

  print(-AvgProf)
  return(-AvgProf) # don't forget to put negative sign as we want to maximize.
}

res <- optim(0.5, AveProf_simple_exponential_smoothing, method = "L-BFGS-B",
             df = df,
             lower = c(0),
             upper = c(1),
             price = price,
             salvage = salvage,
             cost = cost)

res$par
#0.01822693

#-------------------------#
# method 3. Trend-Corrected Exponential Smoothing (Holt’s Model)
#-------------------------#
#Step 1. Use the data from Week1 to Week300 to estimate
#the slope “a” in time (t) and the intercept “b” from the linear regression model.

#Dt = at + b
model <- lm(dm$demand[1:300] ~ dm$t[1:300])
a <- coefficients(model)[2]
b <- coefficients(model)[1]

#Step 2. Use L0=b and T0=a from the above linear regression.
#Use alpha=0.2 and beta=0.2. Estimate the forecast from Week1 to Week 500.

#Ft+1 = Lt + Tt
#L2 = aD2 + (1-a)(L1+T1)
#t2 = b(L2 - L1)+(1-b)T1

alpha <- 0.2
beta <- 0.2
level <- b
trend <- a

forecast_1_500 <- c()
for (i in 1:500) {
  forecast_1_500[i] <- trend + level
  # update the forecast with alpha and beta
  level <- alpha * dm$demand[i] + (1 - alpha) * forecast_1_500[i]
  trend <- beta * (level - (forecast_1_500[i] - trend)) + (1 - beta) * trend
}

#Step 3. What is the stocking quantity at Week301?
forecast_error_holt <- dm$demand[101:300] - forecast_1_500[101:300]
hist(forecast_error_holt)
safety_stock <- quantile(forecast_error_holt, 0.80)

stocking_301_500 <- forecast_1_500[301:500] + safety_stock # I use safety_stock obtained from df2

stocking_301_500[1] #stocking quantity at Week301 is 3735.754

#Step 4. What is the weekly average profit from Week301 to Week500?

res_table$AvgProf[5] <- mean(price * pmin(stocking_301_500, dm3$demand) + salvage * pmax(stocking_301_500 - dm3$demand, 0) - cost * stocking_301_500)

#Do you see an improvement over simple Exponential Smoothing?
#No
#5. Use the data from Week1 to Week300 to find an “optimal” alpha and beta values.

## finding optimal alpha & beta using MSE method
a <- coefficients(model)[2]
b <- coefficients(model)[1]

mse_holt <- function(p, actual_demand) {
  alpha <- p[1]
  beta <- p[2]
  level <- b
  trend <- a

  forecast_1_500 <- c()
  for (i in 1:500) {
    forecast_1_500[i] <- trend + level
    # update the forecast with alpha and beta
    level <- alpha * dm$demand[i] + (1 - alpha) * forecast_1_500[i]
    trend <- beta * (level - (forecast_1_500[i] - trend)) + (1 - beta) * trend
  }
  mse <- sum((actual_demand - forecast_1_500[101:300])^2) / length(actual_demand)
  return(mse)
}

res <- optim(c(0.2, 0.2), mse_holt, method = "L-BFGS-B",
             actual_demand = dm$demand[101:300],
             lower = c(0, 0),
             upper = c(10, 10))
print("Optimal alpha and beta using MSE method:")
print(res$par)

# Another Objective Function (Maximizing Average profit to find tuning parameters)
#101_300: Average_profit
## finding optimal alpha and beta
AveProf_holt_smoothing <- function(p, price, salvage, cost) {
  alpha <- p[1]
  #alpha <- 0.025133018
  beta <- p[2]
  level <- b
  trend <- a
  forecast_1_500 <- c()
  for (i in 1:500) {
    forecast_1_500[i] <- trend + level
    # update the forecast with alpha and beta
    level <- alpha * dm$demand[i] + (1 - alpha) * forecast_1_500[i]
    trend <- beta * (level - (forecast_1_500[i] - trend)) + (1 - beta) * trend
  }

  #forecast_error_holt_smooth <- dm$demand[101:300] - forecast_1_500[101:300]
  forecast_error_holt_smooth <- dm$demand[1:300] - forecast_1_500[1:300]

  safety_stock <- quantile(forecast_error_holt_smooth, 0.80)

  stocking_101_300 <- forecast_1_500[101:300] + safety_stock
  # Average profit
  AvgProf <- mean(price * pmin(stocking_101_300, dm$demand[101:300]) + salvage * pmax(stocking_101_300 - dm$demand[101:300], 0) - cost * stocking_101_300)

  print(-AvgProf)
  return(-AvgProf) # don't forget to put negative sign as we want to maximize.
}

res <- optim(c(0.5,0.5), AveProf_holt_smoothing, method = "L-BFGS-B",
             lower = c(0,0),
             upper = c(10, 10),
             price = price,
             salvage = salvage,
             cost = cost)
print("Optimal alpha and beta by maximizing average profit:")
res$par

#6.  use the tuned values
alpha <- res$par[1]
beta <- res$par[2]

level <- b
trend <- a

forecast_1_500_with_optim_alpha <- c()
for (i in 1:500) {
  forecast_1_500_with_optim_alpha[i] <- trend + level
  # update the forecast with alpha and beta
  level <- alpha * dm$demand[i] + (1 - alpha) * forecast_1_500_with_optim_alpha[i]
  trend <- beta * (level - (forecast_1_500_with_optim_alpha[i] - trend)) + (1 - beta) * trend
}

forecast_error_holt_smooth <- dm2$demand - forecast_1_500_with_optim_alpha[101:300]
hist(forecast_error_holt_smooth)

safety_stock <- quantile(forecast_error_holt_smooth, 0.80)
stocking_301_500 <- forecast_1_500_with_optim_alpha[301:500] + safety_stock # we use safety_stock obtained from df2

# Average profit
res_table$AvgProf[6] <- mean(price * pmin(stocking_301_500, dm3$demand) + salvage * pmax(stocking_301_500 - dm3$demand, 0) - cost * stocking_301_500)


normAbinom <- function() { # normAbinom.r
  x <- seq(5, 50, by=5)
  p.binom <-  pbinom(x, 50, 0.5)
  p.norm <- pnorm(x, 25, sqrt(12.5))
  diff <- p.binom-p.norm
  list(p.binom = round(p.binom,4), p.norm = round(p.norm,4), diff = round(diff,4))
 } # end function

normAbinom()


##### 医学統計勉強会18第2回基本統計量　R code #####

x <- c(0.684, 1.406, -0.663, -0.124, 0.849, -0.888, -0.492, -0.044, -0.188, 0.536, 2.063, -1.379, 0.920, 0.453, 1.239)

## 数量的なデータの要約 ##

sum(x)			# x の要素の和
length(x)		# x の長さ
mean(x)			# x の平均
median(x)		# x の中央値
quantile(x)		# x の四分位点．Five numbers summary
quantile(x, 0.2)	# x の20%パーセント点
summary(x)			# Five numbers summary + 平均

var(x)			# x の分散
sd(x)			# x の標準偏差
sqrt(x)			# x の平方根
sqrt(var(x))	# x の分散の平方根 = x の標準偏差
IQR(x)			# x の四分位点間距離
quantile(x, 0.75) - quantile(x, 0.25)	# 四分位点間距離の定義の確認

## 視覚的なデータの要約 ##

x <- rnorm(100)	# ランダムなサンプルの生成

hist(x)			# ヒストグラム（頻度）
hist(x, freq=F)	# ヒストグラム（相対頻度）

boxplot(x)		# ボックスプロット

# ヒストグラムとボックスプロット #

# 二峰型 #
x1 <- rnorm(100, mean=0)
x2 <- rnorm(100, mean=4)
x <- c(x1, x2)
hist(x)
boxplot(x)

# 裾の重い分布 #
y1 <- rnorm(100, sd=1)
y2 <- rnorm(100, sd=4)
y <- c(y1, y2)
hist(y)
boxplot(y)


x=seq(-10,10,0.1)
y=1.9*dnorm(x,0.9,2.6)
cord.x <- c(-10,x,-10)
cord.y <- c(  0,y,0)
plot(y,xlim=c(-10,10),ylim=c(0,0.5),t='l')
polygon(cord.x,cord.y,col='grey')

cord2.x <- c(-10,x,-10)
cord2.y <- c(0,0.35*dnorm(x,-2,1)+0.65*dnorm(x,2,1),0)
#curve(         0.35*dnorm(x,-2,1)+0.65*dnorm(x,2,1),xlim=c(-10,10))
polygon(cord2.x,cord2.y,col='white')


### Code skeleton for Series 5, Exercise 1

## Read in dataset
diabetes <-
  read.table("http://stat.ethz.ch/Teaching/Datasets/diabetes2.dat",
             header = TRUE)
reg <- diabetes[, c("Age", "C.Peptide")]
names(reg) <-     c("x",   "y")

## Sort values
reg <- reg[sort.list(reg$x), ]

###################################################
### TASK a)
###################################################

### Utility function for LOO cross-validation:

##' Calculates the LOO CV score for given data and regression prediction function
##'
##' @param reg.data: regression data; data.frame with columns 'x', 'y'
##' @param reg.fcn:  regr.prediction function; arguments:
##'                    reg.x: regression x-values
##'                    reg.y: regression y-values
##'                    x:     x-value(s) of evaluation point(s)
##'                  value: prediction at point(s) x
##' @return LOOCV score
loocv <- function(reg.data, reg.fcn)
{
  ## Help function to calculate leave-one-out regression values
  loo.reg.value <- function(i, reg.data, reg.fcn)
    return(reg.fcn(reg.data$x[-i], reg.data$y[-i], reg.data$x[i]))

  ## Calculate LOO regression values using the help function above
  n <- nrow(reg.data)
  loo.values <- sapply(seq(1:n), loo.reg.value, reg.data, reg.fcn)

  ## Calculate and return MSE
  return(mean((loo.values - reg.data$y)^2))
}

### Regression prediction function for NW kernel:
reg.fcn.nw <- function(reg.x, reg.y, x)
  ksmooth(reg.x, reg.y, x.points = x, kernel = "normal", bandwidth = 4.0)$y

### Calculation of LOO CV-score for NW kernel estimator:
(cv.nw <- loocv(reg, reg.fcn.nw))
print(cv.nw)

### Hat matrix "S.nw":
n <- nrow(reg)
Id <- diag(n)
S.nw <- matrix(0, n, n)
for (j in 1:n) {
  tmp <- rep(0, n)
  tmp[j] <- 1
  S.nw[, j] <- reg.fcn.nw(reg$x, tmp, reg$x)
}

### Degrees of freedom (cf. Formula (3.6) in the lecture notes:
(df.nw <- sum(diag(S.nw)))
print(df.nw)

###################################################
### TASKS b) to e)
###################################################

### Proceed similarly as in task a); you can reuse the utility function
### loocv from task a)

### b) have a look at ?predict.loess to define your regression function reg.fcn.lp
reg.fcn.lp <- function(reg.x, reg.y, x){
  loess.fit <- loess(reg.y ~ reg.x, enp.target = df.nw, surface = "direct")
  return(predict(loess.fit, data.frame(reg.x = x)))
}

(cv.lp <- loocv(reg, reg.fcn.lp))
print(cv.lp)

### c) have a look at ?predict.smooth.spline to define your regression function reg.fcn.ss

est.ss <- smooth.spline(reg$x, reg$y, cv = TRUE, df = df.nw)
print((est.ss$cv.crit))

reg.fcn.ss <- function(reg.x, reg.y, x){
  ss.fit <- smooth.spline(reg.x, reg.y, spar = est.ss$spar)
  return(predict(ss.fit, x)$y)
}

(cv.ss <- loocv(reg, reg.fcn.ss))
print(cv.ss)

### d)

cv.ss_int <- smooth.spline(reg$x, reg$y, cv = TRUE)$cv.crit
print(cv.ss_int)

### e)

reg.fcn.cn <- function(reg.x, reg.y, x){
  return(mean(reg.y))
}

(cv.cn <- loocv(reg, reg.fcn.cn))
print(cv.cn)


polbooks <- read.delim("polbooks.dat", header = F, sep = ",")
d <- data.frame((polbooks[,1] + 1), (polbooks[,2] + 1))
n <- max(d) #No. of vertices
a <- matrix(0,n,n,dimnames = list(c(seq(1:n)),c(seq(1:n))))

#Adjacency matrix from given list
for (i in 1:nrow(d)){
  x <- d[i,1]
  y <- d[i,2]
  a[x,y] <- 1
  a[y,x] <- 1
}

#Adjacency lists
adj_list <- NULL
for (i in 1:n) {
  adj_list[[i]] <- which(a[i,]==1)
}

#BFS Naive Implementation
dist <- matrix(-1, n, n, byrow = T,dimnames = list(c(seq(1:n)),c(seq(1:n)))) #Distance array for each vertex
pred <- matrix(-1, n, n, byrow = T,dimnames = list(c(seq(1:n)),c(seq(1:n)))) #Predecessor array for shortest path between every vertex pair

for (i in 1:n) { #Running BFS n times
  d <- 0  #Initialize dist
  dist[i,i] <- 0  #Set source dist 0
  pred[i,i] <- 0

  while(length(which(dist[i,] == -1))!=0){
    o <- which(dist[i,] == d)  #vertices with dist d
    for (j in o) {
      x <- adj_list[[j]]  #neighbors of vertex with dist d
      for (k in x) {
        if(dist[i,k] == -1){
          dist[i,k] <- d + 1
          if(pred[i,k] == -1) { pred[i,k] <- j } #Creating predecessor array
        }
      }
    }
    d <- d + 1
  }
}

#Shortest path between Given vertices
a <- as.numeric(readline(prompt="Enter an vertex 1: "))
b <- as.numeric(readline(prompt="Enter an vertex 2: "))
print(b)
repeat{
  t <- pred[a,b]
  if(t==a){break}
  print(t)
  b <- t
}
print(a)


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

# Example : 3   Chapter : 2.6   Pageno : 98
# Forward Elimination
library(pracma)
A<-matrix(c(1,4,2,9),ncol=2)
b<-c(5,21)
L<-lu(A)$L
U<-lu(A)$U
c<-solve(L,b)
x<-solve(U,c)
print("The solution is ")
print(x)

# The answers may vary due to rounding off values


#  4/14
#
# K means analysis on Star data ---------------------------

#install.packages('foreign')
library(foreign)  # to read the data we need function read.arff() from library foreign.

#install.packages('dplyr')
library(dplyr)  #'  dplyr package provides some utility funcions for sorting data

stars <- read.arff(file = 'AstronomyTrainingData.txt')
#Filter stars for complete entries.
complete_stars <- stars %>% filter(complete.cases(.))
star_names <- levels(stars$class)

#  identify the 25 levels of star: (Column 87 holds the names.)
levels(stars$class)
barplot(summary(stars$class), horiz = TRUE, las = 1, cex.names = 0.5)

#  We could specify that there are 25 centers, and kmeans will attempt to
#  locate 25 good centers, but it may be terrible!
centers <- 25

star_km <- kmeans(complete_stars[c(-1,-dim(complete_stars)[2])], centers, iter.max = 20, nstart = 1)
found_centers <- star_km$centers

#  There are 25 centers, one for each cluster.  The center contains 85 means representing each variable.
#  Cluster membership is identified by a a number.
# View(star_km$cluster)

#Numbers of stars per cluster
table(factor(star_km$cluster))
plot(table(factor(star_km$cluster)),xlab = "Cluster Number", ylab = "Stars per Cluster")

# I can make one of these by:
#  1)  Sorting the data by star type
#  2)  taking the mean for each star type, for each variable.

# with dplyr:  group COMPLETE stars by class, then summarise with the mean across all variables.
#sum_stars <- complete_stars %>% group_by(class) %>% summarise_each(funs(mean))

# with dplyr:  group each star by class, then summarise all the variables with mean(x, rm.na)
sum_stars <- stars %>% group_by(class) %>% summarise_each(funs(mean(., na.rm=TRUE)))

#star_km$size
#star_km$centers
#star_km$tot.withinss
#table(factor(star_km$cluster), factor(unlist(star_names)))

#full_star_km  <-  kmeans(complete_stars[c(-1,-dim(complete_stars)[2])], centers = sum_stars,
 #                        iter.max = 20, nstart = 1)

# Setting our own centers ---------------------------
# We had to switch to "Lloyd" method, as "Hartigan-Wong" cannot handle size 0 clusters.
full_star_km  <-  kmeans(as.matrix(complete_stars[,c(-1,-87)]),
                         centers = as.matrix(sum_stars[,c(-1,-2)]), iter.max = 20,
                         algorithm = "Lloyd")

# Result of clustering with 25 random clusters
plot(table(star_km$cluster))
table(star_km$cluster)
# Result of clustering with 25 nonrandom clusters drawn from training.
table(full_star_km$cluster)
plot(table(full_star_km$cluster))
plot(table(stars$class))
barplot(summary(stars$class), horiz = TRUE, las = 1, cex.names = 0.5)

#algorithm = c("Hartigan-Wong", "Lloyd", "Forgy","MacQueen"), trace=FALSE)
View(as.matrix(sum_stars[1:10,c(-1,-2)]))

is.data.frame(complete_stars)
View(sum_stars)
?kmeans

View(sum_stars[,c(-1,-2,-87)])
dim(sum_stars[,c(-1,-2)])
dim(stars[,c(-1,-87)])

# An example of setting the centers ---------------------------
#  Available here:  http://stats.stackexchange.com/questions/72606/k-means-clustering-after-first-iteration

# Set the RNG seed to ensure reproducibility
set.seed(12345)

# Let's create 3 visually distinct clusters
n <- c(1000, 500, 850)
# Jeff: X var defined here for 3 clusters
classifier.1 <- c(rnorm(n[1], 10, 0.9),
                  rnorm(n[2], 25, 2),
                  rnorm(n[3], 35, 2))
# Jeff:  Y var defined here for 3 clusters.
classifier.2 <- c(rnorm(n[1], 5, 1),
                  rnorm(n[2], 10, 0.4),
                  rnorm(n[3], 2, .9))

col = c("blue", "darkgreen", "darkred")
# Run k-means with 3 clusters and random initial centroids
# to check the clusters are correctly recognized
km <- kmeans(cbind(classifier.1, classifier.2), 3)
# Plot the data, colored by cluster
plot(classifier.1, classifier.2, pch=20, col=col[km$cluster])

# Mark the final centroids
points(km$centers, pch=20, cex=2, col="orange")

# Now impose some obviously "wrong" starting centroids
start.x <- c(10, 25, 3000)
start.y <- c(10, 10, -10000)
km.2 <- kmeans(cbind(classifier.1, classifier.2),
               centers=cbind(start.x, start.y))

# Jeff:  How will this preform if we give it the right stuff?
start.x <- c(10, 25, 35)
# It still finds it even if we give pretty bad y values!
start.y <- c(0, 1, 3)
km.2 <- kmeans(cbind(classifier.1, classifier.2),
               centers=cbind(start.x, start.y))
plot(classifier.1, classifier.2, pch=20, col=col[km.2$cluster])
points(km.2$centers, pch=20, cex=2, col="orange")

View(cbind(start.x, start.y))
?kmeans

# Top 30 Vars. ---------------------------

#Select the top n variables from PCA to use.
n <- 20
n_star_names <- as.character( pca_out[1:n,1] )
#View(stars[as.character( pca_out[1:n,1] ) ])

#Sort out the complete stars.
complete_stars <- stars %>% filter(complete.cases(.))

# Create a sorted list of training stars, by type.
sum_stars <- stars %>% group_by(class) %>% summarise_each(funs(mean(., na.rm=TRUE)))

#

top_var_star_km  <-  kmeans(as.matrix(complete_stars[,n_star_names]),
                         centers = as.matrix(sum_stars[,n_star_names]), iter.max = 200,
                         algorithm = "Lloyd")

#View(top_var_star_km$cluster)
# Result of clustering using the best n variables, with means of clusters drawn from training.
#table(top_var_star_km$cluster)
plot(table(top_var_star_km$cluster))
plot(table(stars$class))

barplot(table(top_var_star_km$cluster))
barplot(table(stars$class), las = 1, cex.names = 0.5, )
barplot(table(complete_stars$class), las = 1, cex.names = 0.5, )

barplot(cbind(table(top_var_star_km$cluster), table(stars$class)), las = 1, cex.names = 0.5, beside = T, )
#barplot(summary(stars$class), horiz = TRUE, las = 1, cex.names = 0.5)

results <- as.data.frame( cbind(names = star_names, predicted = table(top_var_star_km$cluster), actual = table(stars$class)))
View(results)
barplot(as.numeric(results$actual), horiz = T, las = 1, names.arg = results$names, cex.names= 0.5, main = "Actual")
barplot(as.numeric(results$predicted), horiz = T, las = 1, names.arg = results$names, cex.names= 0.5, main = "Predicted")
barplot(summary(stars$class), horiz = TRUE, las = 1, cex.names = 0.5, main = "Training Stars")
barplot(summary(complete_stars$class), horiz = TRUE, las = 1, cex.names = 0.5, main = "Complete Stars")

# Working with the whole data ---------------------------
# The location of this file will vary for you.  I didn't upload it to github, since it is so large.
# I suppose we could upload it if we want.

all_stars <- read.arff(file = 'Z:/ST599/Project 1/data/AstronomyTestData.txt')

# Multicolinearity Analysis ---------------------------

#Is there multicolinearity?

# install.packages('faraway')
library(faraway)
#Calculate the variance inflation factors (a measure of multicolinearity)
#  (VIFS are a ratio of eigenvalues to the smallest eigenvalue)
complete_stars_noname <- complete_stars[c(-1,-dim(complete_stars)[2])]
vifs <- (vif(complete_stars_noname))
vifs
plot(vifs)
#identify(vifs)
identify(vifs, labels = names(vifs), atpen = T)
identify(vifs, labels = names(vifs))
identify(vifs)
#  Colinearity Suspects in order::
#  "eclpoly_p_pulse", "eclpoly_p_pulse_initial", "std" "stetson_j", "amplitude"

View(complete_stars)
sorted_vifcolumns <- arrange(complete_stars_noname[,c(1,18,19,83,84)],amplitude)
View(complete_stars_noname[,c(1,18,19,83,84)])

e <- eigen(t(as.matrix(complete_stars_noname))%*%as.matrix(complete_stars_noname))
signif(e$values,3)
#  There is at least one enormous colinearity.
#  It was at least 2.0e20 before correction.
var_names <-  names(complete_stars)
sort(var_names)

#  Correcting for variance inflation:
# Remove ID, Remove Name
star_low_vif <- complete_stars[c(-1,-dim(complete_stars)[2])]
star_low_vif <- star_low_vif[c(-18,-19)]

e <- eigen(t(as.matrix(star_low_vif))%*%as.matrix(star_low_vif))
signif(e$values,3)

low_vif <- (vif(star_low_vif))
plot(low_vif)
identify(low_vif)
View(star_low_vif[,c(1,81,82)])

# Sharm's Example ---------------------------

#cancerData<-read.table(file="14cancer.xtrain",sep="")
# namesCancer<-read.table(file="namesCancer.txt",sep="",header="FALSE")
#namesCancer<-read.table(file="namesCancer.txt")
#myLabels<-c('breast','prostate','lung','collorectal','lymphoma','bladder','melanoma','uterus','leukemia','renal','pancreas','ovary','meso','cns')
#names(cancerData)<-c(namesCancer)

#dim(cancerData)
#myLabels<-c('breast','prostate','lung','collorectal','lymphoma','bladder','melanoma','uterus','leukemia','renal','pancreas','ovary','meso','cns')

#digit = read.table('Digit_recog_train.txt')
#digit_no = digit[,1]
#digit_pix = digit[,-1]
#digit_no3 = digit_no[digit_no == 3]
#digit_pix3 = digit_pix[digit_no == 3,]

#sel = sample(c(0,1), length(digit_no), replace = T, prob = c(4/5,1/5))
#digit_pix = digit_pix[sel == 1,]
#digit_no = digit_no[sel==1]

#  Example, part 2

#numCenters<-5
#kmeansCancer<-kmeans(t(cancerData), numCenters, iter.max = 20, nstart = 1)

#kmeansCancer$size
#kmeansCancer$centers
#kmeansCancer$tot.withinss
#table(factor(kmeansCancer$cluster), factor(unlist(namesCancer)))
#myLabels

#numCenters = 10
#kmeansDigit = kmeans(digit_pix, numCenters, iter.max = 20, nstart = 1)
#pamDigit = pam(digit_pix, k = numCenters, metric = 'Euclidean')

#kmeansDigit$size
#kmeansDigit$centers
#kmeansDigit$tot.withinss
#table(factor(kmeansDigit$cluster), factor(digit_no))
#pamDigit$medoids
#pamDigit$objective
#table(factor(pamDigit$clustering), factor(digit_no))

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


#### Iris Dataset ####

# Import data table
library(data.table)

# the Edgar Anderson Iris Data is pre-loaded
iris
dt <- data.table(iris) # convert to data table - helpful for big data
df <- data.frame(iris) # data frames are built-in to R

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

# Show the first 3 rows of the data
df[1:3,]

# Show the first 10 rows if species = versicolor
#attempt 1
df[1:10,]$Species == 'versicolor'

#attempt 2
require(data.table)
versspecies <- df$species=='versicolor'
d <- data.table(iris)
d[, head(.SD, 10), by=versspecies]

#attempt 3
library(dplyr)
top_n(df, 10, Species=='versicolor')

# What is the standard deviation of petal length of each species?
aggregate(df$Petal.Length, by = list(df$Species), sd)

# What is the maximum petal width of each species?
aggregate(df$Petal.Length, by = list(df$Species), max)

# What is the average petal length of each species?
aggregate(df$Petal.Length, by = list(df$Species), mean)

# What is the average petal width to average sepal width ratio for each species?
aggregate(df$Petal.Width/df$Sepal.Width, by = list(df$Species), mean)

# Create a histogram of petal length. Include a title and x-label
hist(df$Petal.Length, col='gray', main = 'Histogram of Iris Petal Length', xlab = 'Petal Length')

# Create a box of petal width. Include a title and x-label
boxplot(df$Petal.Width, col='gray', main='Boxplot of Iris Petal Width', xlab = 'Petal Length', ylab = 'Petal Length')


library(drat)
library(dde)
library(odin)

drat::add("mrc-ide")

sir_generator <- odin::odin({
  ## Core equations for transitions between compartments:
  update(S) <- S - n_SI
  update(I) <- I + n_SI - n_IR
  update(R) <- R + n_IR

  ## Individual probabilities of transition:
  p_SI <- 1 - exp(-beta * I / N) # S to I
  p_IR <- 1 - exp(-gamma) # I to R

  ## Draws from binomial distributions for numbers changing between
  ## compartments:
  n_SI <- rbinom(S, p_SI)
  n_IR <- rbinom(I, p_IR)

  ## Total population size
  N <- S + I + R

  ## Initial states:
  initial(S) <- S_ini
  initial(I) <- I_ini
  initial(R) <- 0

  ## User defined parameters - default in parentheses:
  S_ini <- user(1000)
  I_ini <- user(1)
  beta <- user(0.2)
  gamma <- user(0.1)

}, verbose = FALSE)

sir <- sir_generator(I_ini = 10)
sir

set.seed(1)
sir_col <- c("#8c8cd9", "#cc0044", "#999966")

res <- sir$run(0:100)
par(mar = c(4.1, 5.1, 0.5, 0.5), las = 1)
matplot(res[, 1], res[, -1], xlab = "Time", ylab = "Number of individuals",
        type = "l", col = sir_col, lty = 1)
legend("topright", lwd = 1, col = sir_col, legend = c("S", "I", "R"), bty = "n")

res_200 <- sir$run(0:100, replicate = 200)
res_200 <- sir$transform_variables(res_200)
res_200 <- cbind.data.frame(t = res_200[[1]], res_200[-1])

col <- rep(sir_col, each = 200)

par(mar = c(4.1, 5.1, 0.5, 0.5), las = 1)
matplot(res_200[, 1], res_200[, -1], xlab = "Time", ylab = "Number of individuals",
        type = "l", col = col, lty = 1)
legend("topright", lwd = 1, col = sir_col, legend = c("S", "I", "R"), bty = "n")

## x: instance of odin model
## t: time steps
## n: number of replicates
run_model <- function(x, t = 0:100, n = 1, ...) {
    res <- x$run(t, replicate = n, ...)
    res <- x$transform_variables(res)
    res <- cbind.data.frame(t = res[[1]], res[-1])
    attr(res, "n_compartments") <- length(x$names) - 1
    attr(res, "n_replicates") <- n
    attr(res, "compartments") <- x$names[-1]
    class(res) <- c("pretty_odin", class(res))
    res
}

sir_pal <- colorRampPalette(sir_col)

plot.pretty_odin <- function(x, pal = sir_pal, ...) {
    ## handle colors
    n_compartments <- attr(x, "n_compartments")
    n_replicates <- attr(x, "n_replicates")
    col_leg <- pal(n_compartments)
    alpha <- max(10 / n_replicates, 0.05)
    col <- rep(col_leg, each = n_replicates)

    ## make plot
    par(mar = c(4.1, 5.1, 0.5, 0.5), las = 1)
    matplot(x[, 1], x[, -1], xlab = "Time", ylab = "Number of individuals",
            type = "l", col = col, lty = 1, ...)
    legend("topright", lwd = 1, col = col_leg, bty = "n",
           legend = attr(x, "compartments"))
}

# Run
x <- run_model(sir, t = 0:100, n = 500)
plot(x)


################################################################
### Code for replication study:
### "A New Approach to Estimating the Production Function for Housing"
### by Dennis Epple, Brett Gordon, and Holger Sieg, forthcoming AER.
###
### This code is used to estimate the production function.
###
###
################################################################

## ----Load-Libraries------
library(MASS)
library(splines)
## library(odesolve) - This function is no longer maintained by CRAN
library(deSolve)
library(lokern)
source("./Notes/Gradient_Descent_001.R")

## ----read-the-data----
getwd()
# Just pland, v, and lotarea
#data = read.csv("./Data/Pittsburgh_post1995.txt", header=TRUE)
data = read.csv("Pittsburgh_post1995.txt", header=TRUE)
N = dim(data)[1]

v = data$v
pland = data$pland
lotarea = data$lotarea
muni = data$muni
tcog = data$tcog

sorted = sort(v,index.return=TRUE, method="quick")
pland = pland[sorted$ix]
lotarea = lotarea[sorted$ix]
muni = muni[sorted$ix]
tcog = tcog[sorted$ix]
v = sorted$x

v.full = v
pland.full = pland

#Calculate 1 and 99 percentile for v
percentile <- quantile(data$v, probs = c(0.01,0.99))

# The 99 percentile = 144.4683 and 1 percentile = 0.923818
goodv = (((v.full < percentile[2])*(v > percentile[1])) == 1)
v = v.full[goodv]
pland = pland.full[goodv]
lotarea = lotarea[goodv]
muni = muni[goodv]

N = length(v)
logpland = log(pland)
logv = log(v)
v2 = v^2
v3 = v^3
v4 = v^4

v.sd = sqrt(var(v))
logv.sd = sqrt(var(logv))

remove(data)

plot(logv, logpland, main="Value per Unit Land vs. Land Value per Unit Land\nBaltimore City Residential Properties",
     xlab="log(v)", ylab="log(pland)") #,xlim=c(-2,5), ylim=c(-3,3.5))

## ----- Estimate-the-regressions ------

### Basic regressions

lm.loglin = lm(logpland ~ logv)
lm.lin = lm(pland ~ v - 1)
lm.quad = lm(pland ~ v + v2 - 1)
lm.cub = lm(pland ~ v + v2 + v3 - 1)
lm.quart = lm(pland ~ v + v2 + v3 + v4 - 1)
#Linear model using Gaussian Generalized Linear Model
glm.lin = glm(pland ~ v - 1)

#Log Linear model using Gaussian Generalized Linear Model
glm.loglin = glm(logpland ~ logv)

#Log Linear model with a different Gradient Descent Loss Function
#thetaValues = gradientDescentLinearModel(logv, logpland, 0.1, 1000)

## ---Create-Coefficient-Table

# table<- data.frame(matrix(ncol=7,nrow = 6))
# namesOfColumn <- c("Coefficients","Log_Linear","Linear","Quadratic","Cubic",
#                    "Gaussian_Generalized_Linear_Model",
#                    "Gaussian_Generalized_Log_Linear_Model",
#                    "Gradient_Descent_Log_Linear_Model")
# colnames(table) <- namesOfColumn
# table$Coefficients <- c("v", "v^2", "v^3", "constant", "log(v)", "N")
# table[4,2] <- round(lm.loglin$coefficients[1],2)
# table[5,2] <- round(lm.loglin$coefficients[2],2)
# table[1,3] <- round(lm.lin$coefficients[1],2)
# table[1,4] <- round(lm.quad$coefficients[1],2)
# table[2,4] <- round(lm.quad$coefficients[2],5)
# table[1,5] <- round(lm.cub$coefficients[1],2)
# table[2,5] <- round(lm.cub$coefficients[2],5)
# table[3,5] <- round(lm.cub$coefficients[3],2)
# table[1,6] <- round(glm.lin$coefficients[1],2)
# table[4,7] <- round(glm.loglin$coefficients[1],2)
# table[5,7] <- round(glm.loglin$coefficients[2],2)
# #table[4,8] <- round(thetaValues[1],2)
# #table[5,8] <- round(thetaValues[2],2)
# table[6,2:7] <- as.numeric(N)
# View(table)

stargazer(lm.loglin, lm.lin, lm.quad, lm.cub, glm.lin, glm.loglin, summary=FALSE, out = "file.out", type = "text")
?stargazer
# colnames(table) = gsub("_", " ", colnames(table))
# table[is.na(table)]<- " "

# table %>%
#   stargazer(type ='text', summary = FALSE,
#             digits =2,
#             title = "Table 1 - Descriptive statistics of Residential data")

### Non-parametric estimation of r(v)

gkern.deriv = glkerns(v, pland, deriv=1,n.out=300, hetero=TRUE,bandwidth=v.sd*1.1)
gkern = glkerns(v, pland, deriv=0,n.out=500, hetero=TRUE,bandwidth=v.sd*1.1)
gkern.interp = interpSpline(gkern$x.out,gkern$est,na.action=na.omit,bSpline=TRUE)

gkern.log = glkerns(logv, logpland, deriv=0,n.out=300, hetero=TRUE)
gkern.log.interp = interpSpline(gkern.log$x.out,gkern.log$est,na.action=na.omit,bSpline=TRUE)
gkern.log.fitted = predict(gkern.log.interp, logv) ## ??

par(mfrow=c(1,2))
plot(gkern.deriv$x.out,gkern.deriv$est, type="l")
plot(gkern.log$x.out,gkern.log$est, type="l", col="red")
plot(gkern$x.out,gkern$est, type="l")  ## ??

### Plot the regressions
par(mfrow=c(1,2))
plot(logv, lm.loglin$fitted.values, type="l",xlim=c(-2,5), ylim=c(-3,3.5))
lines(logv, lm.loglin$fitted.values, col="red")
lines(logv, log(lm.lin$fitted.values), col="blue")
lines(logv, log(lm.quad$fitted.values), col="green")
lines(logv, log(lm.cub$fitted.values), col="orange")

#Plot to add line generated by Gaussian Generalized Linear Model
lines(logv, glm.loglin$fitted.values, col = '#009E73')

#Plot to add line using Log linear model with Gradient Descent Loss Function
#abline(coef=thetaValues, col = '#F0E442')

#Calculate the predicted values from using Log linear model with Gradient Descent Loss Function
#predictedValuesGD <- calculatePredictionValues(logv, logpland, thetaValues[2], thetaValues[1])

#Added two new model prediction
#1) Gaussian Generalized Log Linear Model: Gaus.LLM
#2) Gradient Descent Log Linear Model: GradDes.LLM

regs = data.frame("Log-Linear"=lm.loglin$fitted.values, "Linear"=log(lm.lin$fitted.values),"Quadratic"=log(lm.quad$fitted.values),
                  "Cubic"=log(lm.cub$fitted.values), "Log Kernel"=gkern.log.fitted$y, 'Gaus.LLM'=glm.loglin$fitted.values)

regs_table2 = data.frame("Log-Linear" = summary(lm.loglin)$coeff)

matplot(cbind(logv,logv,logv,logv,logv,logv), regs, col=1:ncol(regs), lty=1:ncol(regs),lwd=c(2,2,2,2), type="l",
        main="Fitted Regressions for r(v)", xlab="v", ylab="p_l", xlim=c(-0.5,5), ylim=c(-2.2,3.5))
legend(3.9, 0.5, names(regs), col=1:ncol(regs), lty=1:ncol(regs), cex = 0.5 )

## -----Derive-supply-functions-for-each-model-----

vseq.n = 1000
vseq = seq(1,100,length.out=vseq.n)

### Calculate supply functions for quad and cubic cases
r = lm.quad$coefficients
p.quad = (vseq^r[1])*exp(2*r[2]*(vseq-1))
s.quad = vseq/p.quad

r = lm.cub$coefficients
c = 2*r[2] + 1.5*r[3]
p.cub = (vseq^r[1])*exp(2*r[2]*(vseq-1) + 1.5*r[3]*(vseq^2 - 1))
s.cub = vseq/p.cub

# Now create price grid given this upperbound
lb = min(range(p.quad)[1],range(p.cub)[1])
ub = min(range(p.quad)[2],range(p.cub)[2])
pgrid = seq(lb,ub,length.out=vseq.n)

### Calculate supply functions for linear and log-linear cases

alpha = as.numeric(exp(lm.loglin$coefficients[1])*lm.loglin$coefficients[2])
beta = as.numeric(lm.loglin$coefficients[2] - 1)

### Calculate supply function for GLM Log-linear case

alpha_glm = as.numeric(exp(glm.loglin$coefficients[1])*glm.loglin$coefficients[2])
beta_glm = as.numeric(glm.loglin$coefficients[2] - 1)

# Determine upper bound on p, since beta < 0 implies (c+log(p)) < 0
### For log-linear model
ec = exp(-alpha/beta)

### FOr GLM Log-linear model
ec_glm = exp(-alpha_glm/beta_glm)

### Linear case
k = lm.lin$coefficients[1]
s.lin = pgrid^((1-k)/k)

### Log-linear case
s.loglin = (1/pgrid)*((1 + (beta/alpha)*log(pgrid))^(1/beta))

### GLM Log-Linear case
sglm.loglin = (1/pgrid)*((1 + (beta_glm/alpha_glm)*log(pgrid))^(1/beta_glm))

### Solve ODE for kernel supply function

rprime = interpSpline(gkern.deriv$x.out,gkern.deriv$est,na.action=na.omit,bSpline=TRUE)

## calc.supply.deriv = function(t,y, params) list((y/t)*((1/(predict(rprime,y*t))$y)-1))
calc.supply.deriv = function(pgrid.kern,xstart, params) list((xstart/pgrid.kern)*((1/(predict(rprime,xstart*pgrid.kern))$x)-1))
##dd = function(pgrid.kern,xstart, params)  ## ??

## list((xstart/pgrid.kern)*((1/(predict(rprime,xstart*pgrid.kern))$x)-1)) ## ??

xstart = c(1)
pgrid.kern = c(1, seq(1.001,ub,length.out=vseq.n-1))

ode.out = lsoda(xstart, pgrid.kern, calc.supply.deriv, parms=1, rtol=1e-5, atol=1e-7)
s.kern = data.frame(s=ode.out[,2],p=ode.out[,1])

### Plot all the supply functions

s.funcs = data.frame("Log-Linear"=s.loglin,"Linear"=s.lin,"Quadratic"=s.quad,
                     "Cubic"=s.cub, "Kernel"=s.kern$s, "GLM Log-Linear" = sglm.loglin)
p.grids = cbind(pgrid,pgrid,p.quad,p.cub,s.kern$p,pgrid)

s.lin.range = range(s.lin*pgrid)
s.loglin.range = range(s.loglin*pgrid)
s.quad.range = range(s.quad*p.quad)
s.cub.range = range(s.cub*p.cub)
s.kern.range = range(s.kern$s*s.kern$p)
sglm.loglin.range = range(sglm.loglin*pgrid)

matplot(s.funcs,p.grids,col=1:ncol(s.funcs), lty=1:ncol(s.funcs),lwd=c(2,2,2,2), type="l",
        main="Supply Functions", xlab="Supply", ylab="Price",xlim=c(0,39))
legend(20, 1.5, names(s.funcs), col=1:ncol(s.funcs), lty=1:ncol(s.funcs))

## ----Production-Function-Estimation------

v.lin.hat = s.lin*pgrid
v.loglin.hat = s.loglin*pgrid
v.quad.hat = s.quad*p.quad
v.cub.hat = s.cub*p.cub
v.kernel = s.kern$p*s.kern$s
v.glmloglin.hat = sglm.loglin*pgrid

lm.lin.fitted = lm.lin$coefficients[1]*v.lin.hat
lm.loglin.fitted = exp(lm.loglin$coefficients[1] + lm.loglin$coefficients[2]*log(v.loglin.hat))
lm.quad.fitted = lm.quad$coefficients[1]*v.quad.hat + lm.quad$coefficients[2]*v.quad.hat^2
lm.cub.fitted = lm.cub$coefficients[1]*v.cub.hat + lm.cub$coefficients[2]*v.cub.hat^2 + lm.cub$coefficients[3]*v.cub.hat^3
kernel.fitted = predict(gkern.interp,v.kernel)$y
glm.loglin.fitted = exp(glm.loglin$coefficients[1] + glm.loglin$coefficients[2]*log(v.glmloglin.hat))

m.lin = v.lin.hat-lm.lin.fitted
m.loglin = v.loglin.hat-lm.loglin.fitted
m.quad = v.quad.hat-lm.quad.fitted
m.cub = v.cub.hat-lm.cub.fitted
m.kernel = v.kernel - kernel.fitted
m.glmloglin = v.glmloglin.hat-glm.loglin.fitted

##Normalize the production function for the kernel case
m.kernel = m.kernel + (1-m.kernel[1])

prod.funcs = data.frame("Log-Linear"=s.loglin,"Linear"=s.lin,"Quadratic"=s.quad, "Cubic"=s.cub, "Kernel"=s.kern$s)

m.grids = cbind(m.loglin, m.lin, m.quad, m.cub,m.kernel)

matplot(m.grids,prod.funcs, col=1:ncol(prod.funcs), lty=1:ncol(prod.funcs),lwd=c(2,2,2,2), type="l",
        main="Production Functions", xlab="m = (M/L)", ylab="Output", xlim=c(0,80), ylim=c(0,42))
legend(60, 12, names(prod.funcs), col=1:ncol(prod.funcs), lty=1:ncol(prod.funcs))

## ----Calculate-supply-elasticities----

## Missing definition of 'calc.elas' and 'fdiff' function. Added the defintion of 'calc.elas' and 'fdiff'

fdiff <- function(x, fun, h=NULL, order=1, accur=4, ...) {
  macheps <- .Machine$double.eps

  if (order==1) {
    if(is.null(h)) h <- macheps^(1/3)* abs(x)
    ifelse (accur==2, w <- c(-1/2,1/2), w <- c(1/12,-2/3, 2/3,-1/12))
    ifelse (accur==2, xd <- x + h*c(-1,1), xd <- x + h*c(-2,-1,1,2))
    return(sum(w*fun(xd,...))/h)
  }
  else if (order==2) {
    if(is.null(h)) h <- macheps^(1/4)* abs(x)
    ifelse (accur==2, w <- c(1,-2,1), w <- c(-1/12,4/3,-5/2,4/3,-1/12))
    ifelse (accur==2, xd <- x + h*c(-1,0,1), xd <- x + h*c(-2,-1,0,1,2))
    return(sum(w*fun(xd,...))/h^2)
  }
}
calc.elas = function(grid,sfunc,bspline=TRUE){
  require(splines)
  s.interp = interpSpline(grid,sfunc,na.action=na.omit,bSpline=bspline)
  s.elas = rep(NA,length(grid))
  for(i in 1:length(grid)){
    s.elas[i] = (fdiff(grid[i],function(x){(predict(s.interp,x))$y}))*(grid[i]/sfunc[i])
  }
  return(s.elas)
}

## Usual Code
require(splines)
s.loglin.elas = calc.elas(pgrid,s.loglin)
s.lin.elas = calc.elas(pgrid,s.lin)
s.quad.elas = calc.elas(pgrid,s.quad)
s.cub.elas = calc.elas(pgrid,s.cub)
s.kern.elas = calc.elas(s.kern$p,s.kern$s)
sglm.loglin.elas = calc.elas(pgrid,sglm.loglin)

s.elas = list("Linear"=s.lin.elas, "Log-linear"=s.loglin.elas, "Quad"=s.quad.elas,
              "Cubic"=s.cub.elas, "Kernel"=s.kern.elas, "GLM-Log-Linear" = sglm.loglin.elas)
sapply(s.elas,mean)
sapply(s.elas,range)
sapply(s.elas,sd)

### Calculate demand elasticities

p.inv = function(v,s.interp){
  pstar = rep(NA,length(v))
  s.inv = function(p,v,sfunc){ ((predict(sfunc,p))$y*p - v) }
  for(i in 1:length(v)){
    pstar[i] = (uniroot(s.inv,c(0.0001,100),v=v[i],sfunc=s.interp))$root
  }
  return(pstar)
}

s.lin.interp = interpSpline(pgrid,s.lin,na.action=na.omit,bSpline=TRUE)
s.loglin.interp = interpSpline(pgrid,s.loglin,na.action=na.omit,bSpline=TRUE)
s.quad.interp = interpSpline(p.quad,s.quad,na.action=na.omit,bSpline=TRUE)
s.cub.interp = interpSpline(p.cub,s.cub,na.action=na.omit,bSpline=TRUE)
s.kern.interp = interpSpline(s.kern$p,s.kern$s,na.action=na.omit,bSpline=TRUE)
sglm.loglin.interp = interpSpline(pgrid,sglm.loglin,na.action=na.omit,bSpline=TRUE)

p.lin.inv = p.inv(v,s.lin.interp)
p.loglin.inv = p.inv(v,s.loglin.interp)
p.quad.inv = p.inv(v,s.quad.interp)
p.cub.inv = p.inv(v,s.cub.interp)
p.kern.inv = p.inv(v,s.kern.interp)
p.glmloglin.inv = p.inv(v,sglm.loglin.interp)

elas.lin = calc.average.elas(p.lin.inv,s.lin.interp)
elas.loglin = calc.average.elas(p.loglin.inv,s.loglin.interp)
elas.quad = calc.average.elas(p.quad.inv,s.quad.interp)
elas.cub = calc.average.elas(p.cub.inv,s.cub.interp)
elas.kern = calc.average.elas(p.kern.inv,s.kern.interp)
elas.glmloglin = calc.average.elas(p.glmloglin.inv,sglm.loglin.interp)

p.loglin.inv.median = p.inv(median(v),s.loglin.interp)
elas.loglin.median = calc.average.elas(p.loglin.inv.median,s.loglin.interp)

p.glmloglin.inv.median = p.inv(median(v),sglm.loglin.interp)
elas.glmloglin.median = calc.average.elas(p.glmloglin.inv.median,sglm.loglin.interp)

## ----Calculate-the-elasticity-of-substitution-for-land-vs-non-land-inputs-----

n = 50
L = lotarea
m = v - exp(lm.loglin$coefficients[1] + lm.loglin$coefficients[2]*log(v))
M = m*L
Lseq = seq(min(L),max(L),length.out=n)
Mseq = seq(min(M),max(M),length.out=n)

n = 50
L = lotarea
m_glm = v - exp(glm.loglin$coefficients[1] + glm.loglin$coefficients[2]*log(v))
M_glm = m_glm*L
Lseq_glm = seq(min(L),max(L),length.out=n)
Mseq_glm = seq(min(M_glm),max(M_glm),length.out=n)

## ----Decclare-Functions----

pfunc.CD = function(k,Lseq,Mseq){
  Q = matrix(NA,nrow=length(Lseq),ncol=length(Mseq))
  A = 1/((1-k)^(1-k))
  for(i in 1:(length(Lseq))){ for(k in 1:(length(Mseq))){
    Q[i,k] = A*(Lseq[i]^k)*(Mseq[k]^(1-k))
  }}
  return(Q)
}

Q.CD = pfunc.CD(lm.lin$coefficients[1],Lseq,Mseq)
persp(Lseq,Mseq,Q.CD,theta=-20,phi=45,xlim=c(500000,1200000),ylim=c(20000,300000))

pfunc.full = function(Lseq,Mseq,prod.interp){
  Q = matrix(NA,nrow=length(Lseq),ncol=length(Mseq))
  for(i in 1:(length(Lseq))){
    Q[i,] = pfunc.full2(Lseq[i],Mseq,prod.interp)
  }
  return(Q)
}

pfunc.full2 = function(lval,mval,prod.interp){
  return(lval*(predict(prod.interp,mval/lval)$y))
}

pfunc.full.L = function(lval, mval,prod.interp, ord = 1){
  temp = function(x,mval){ return(pfunc.full2(x,mval,prod.interp))}
  return(fdiff(lval, temp, h=NULL, order=ord, accur=4, mval))
}

pfunc.full.M = function(mval,lval,prod.interp, ord = 1){
  temp = function(x,lval){ return( pfunc.full2(lval,x,prod.interp))}
  return(fdiff(mval, temp, h=NULL, order=ord, accur=4, lval))
}

pfunc.full.LM = function(Lval, Mval, prod.interp){
  h = (.Machine$double.eps)^(1/3)*abs(min(Lval,Mval))

  f.xy = pfunc.full2(Lval+h, Mval+h, prod.interp)
  f.x_y = pfunc.full2(Lval+h, Mval-h, prod.interp)
  f._xy = pfunc.full2(Lval-h, Mval+h, prod.interp)
  f._x_y = pfunc.full2(Lval-h, Mval-h, prod.interp)

  return(((f.xy-f.x_y)-(f._xy-f._x_y))/(4*h^2))
}

calc.elas.sub = function(Lseq, Mseq, prod.interp){
  n.L = length(Lseq)
  n.M = length(Mseq)
  Q.elas.sub = matrix(NA,nrow=n.L, ncol=n.M)
  for(i in 1:n.L){
    for(k in 1:n.M){
      F.L = pfunc.full.L(Lseq[i],Mseq[k],prod.interp, ord=1)
      F.M = pfunc.full.M(Mseq[k],Lseq[i],prod.interp, ord=1)
      F.LL = pfunc.full.L(Lseq[i],Mseq[k],prod.interp, ord=2)
      F.MM = pfunc.full.M(Mseq[k],Lseq[i],prod.interp, ord=2)
      F.LM = pfunc.full.LM(Lseq[i],Mseq[k],prod.interp)

      numer = F.L*F.M*(F.L*Lseq[i] + F.M*Mseq[k])
      denom = Lseq[i]*Mseq[k]*((2*F.L*F.M*F.LM)  - ((F.L^2)*F.MM) - ((F.M^2)*F.LL))

      Q.elas.sub[i,k] = numer/denom
    }
  }
  return(Q.elas.sub)
}

# A function to compute highly accurate first- and second-order derivatives
# From Fornberg and Sloan (Acta Numerica, 1994, p. 203-267; Table 1, page 213)
fdiff <- function(x, fun, h=NULL, order=1, accur=4, ...) {
  macheps <- .Machine$double.eps

  if (order==1) {
    if(is.null(h)) h <- macheps^(1/3)* abs(x)
    ifelse (accur==2, w <- c(-1/2,1/2), w <- c(1/12,-2/3, 2/3,-1/12))
    ifelse (accur==2, xd <- x + h*c(-1,1), xd <- x + h*c(-2,-1,1,2))
    return(sum(w*fun(xd,...))/h)
  }
  else if (order==2) {
    if(is.null(h)) h <- macheps^(1/4)* abs(x)
    ifelse (accur==2, w <- c(1,-2,1), w <- c(-1/12,4/3,-5/2,4/3,-1/12))
    ifelse (accur==2, xd <- x + h*c(-1,0,1), xd <- x + h*c(-2,-1,0,1,2))
    return(sum(w*fun(xd,...))/h^2)
  }
}

# y is a data frame, x is a matrix
plot.with.legend = function(x,y,col=1:ncol(x),lty=1:ncol(x),xlim=NULL,ylim=NULL,
                            titles=names(y),lposx=(max(x)-max(x)/4),lposy=max(y)/3,main="",xl="",yl="",...){
  matplot(x,as.matrix(y),col=col, lty=lty,lwd=c(2,2,2,2), type="l",
          main=main,xlab=xl,ylab=yl,xlim=xlim,ylim=ylim, ...)
  legend(lposx,lposy, titles, col=col, lty=lty)
}

### Calculate the derivative of a function over a given range of values
calc.deriv = function(grid,fun,interp.obj=NULL,high.density=FALSE){
  require(splines)
  fun.interp = NULL
  if(! is.null(interp.obj)){
    fun.interp = interp.obj
  }
  else if(!high.density && length(grid)>200){
    interp.grid = rep(NA,200)
    interp.grid[1] = grid[1]
    interp.grid[200] = grid[200]
    interp.grid = sample(grid,198)
    fun.grid = fun[interp.grid]
    fun.interp = interpSpline(interp.grid,fun.grid,na.action=na.omit,bSpline=FALSE)
  }
  else{
    fun.interp = interpSpline(grid,fun,na.action=na.omit,bSpline=FALSE)
  }
  d = rep(NA,length(grid))
  for(i in 1:length(grid)){
    d[i] = fdiff(grid[i],function(x){(predict(fun.interp,x))$y})
  }
  return(list(x=grid,d=d))
}

calc.elas = function(grid,sfunc,bspline=TRUE){
  require(splines)
  s.interp = interpSpline(grid,sfunc,na.action=na.omit,bSpline=bspline)
  s.elas = rep(NA,length(grid))
  for(i in 1:length(grid)){
    s.elas[i] = (fdiff(grid[i],function(x){(predict(s.interp,x))$y}))*(grid[i]/sfunc[i])
  }
  return(s.elas)
}

### pa - actual set of prices corresponding to the data
### s - supply function
calc.average.elas = function(pa,s.interp,bspline=TRUE){
  require(splines)
  s.pred = predict(s.interp,pa)
  s.elas = rep(NA,length(pa))
  for(i in 1:length(pa)){
    s.elas[i] = (fdiff(pa[i],function(x){(predict(s.interp,x))$y}))*(pa[i]/s.pred$y[i])
  }
  return(s.elas)
}
## ----Simulate-supply-and-production-functions-to-calcalate-standard-errors-----
require(splines)
prod.lin.interp = interpSpline(m.lin,s.lin,na.action=na.omit,bSpline=TRUE)
prod.loglin.interp = interpSpline(m.loglin,s.loglin,na.action=na.omit,bSpline=TRUE)
prod.quad.interp = interpSpline(m.quad,s.quad,na.action=na.omit,bSpline=TRUE)
prod.cub.interp = interpSpline(m.cub,s.cub,na.action=na.omit,bSpline=TRUE)
prod.glmloglin.interp = interpSpline(m.glmloglin,sglm.loglin,na.action=na.omit,bSpline=TRUE)

require(R.basic)

Q = pfunc.full(Lseq, Mseq,prod.loglin.interp)
Q.vec = as.vector(Q)
L.vec = as.vector(rep(Lseq,n))
M.vec = rep(NA, length(Q.vec))
for(i in 1:n){ for(k in 1:n){
  M.vec[(i-1)*n + k] = Mseq[i]
}}
plot3d(L.vec,M.vec,Q.vec)

Q_glm = pfunc.full(Lseq_glm, Mseq_glm,prod.glmloglin.interp)
Q.vec.glm = as.vector(Q_glm)
L.vec.glm = as.vector(rep(Lseq_glm,n))
M.vec.glm = rep(NA, length(Q.vec.glm))
for(i in 1:n){ for(k in 1:n){
  M.vec.glm[(i-1)*n + k] = Mseq_glm[i]
}}
plot3d(L.vec.glm,M.vec.glm,Q.vec.glm)

Q.elas.loglin = calc.elas.sub(Lseq, Mseq, prod.loglin.interp)
Q.elas.lin = calc.elas.sub(Lseq, Mseq, prod.lin.interp)
Q.elas.quad = calc.elas.sub(Lseq, Mseq, prod.quad.interp)
Q.elas.cub = calc.elas.sub(Lseq, Mseq, prod.cub.interp)
Q.elas.glmloglin = calc.elas.sub(Lseq_glm, Mseq_glm, prod.glmloglin.interp)

sup.loglin = function(grid,parms){
  alpha = as.numeric(exp(parms[1])*parms[2])
  beta = as.numeric(parms[2] - 1)
  return((1/grid)*((1 + (beta/alpha)*log(grid))^(1/beta)))
}

sup.glmloglin = function(grid,parms){
  alpha = as.numeric(exp(parms[1])*parms[2])
  beta = as.numeric(parms[2] - 1)
  return((1/grid)*((1 + (beta/alpha)*log(grid))^(1/beta)))
}

prod.loglin = function(q,s){
  v.hat = s.loglin*pgrid
  lm.loglin.fitted = exp(lm.loglin$coefficients[1] + lm.loglin$coefficients[2]*log(v.hat))
  m.loglin = v.hat-lm.loglin.fitted
  return(list(m=m.loglin,q=s))
}

prod.glmloglin = function(q,s){
  v.hat = sglm.loglin*pgrid
  glm.loglin.fitted = exp(glm.loglin$coefficients[1] + glm.loglin$coefficients[2]*log(v.hat))
  m.loglin = v.hat-glm.loglin.fitted
  return(list(m=m.loglin,q=s))
}

sim.sup.prod = function(mod,grid,sfunc,pfunc,nsim){
  r = mod$coefficients[,"Estimate"]
  sd = mod$coefficients[,"Std. Error"]
  r.sim = matrix(NA,nrow=nsim,ncol=length(r))
  for(i in 1:length(r)){
    r.sim[,i] = rnorm(nsim,mean=r[i],sd=sd[i])
  }

  s.sd = rep(NA,length(grid))
  s.mat = matrix(NA,nrow=length(grid),ncol=nsim)
  for(k in 1:length(grid)){
    for(i in 1:nsim){
      s.mat[k,i] = sfunc(grid[k],r.sim[i,])
    }
    s.sd[k] = sd(s.mat[k,])
  }

  p.sd = rep(NA,length(grid))
  p.mat = matrix(NA,nrow=length(grid),ncol=nsim)
  for(i in 1:nsim){
    ## Calculate the prod function for this supply function
    pfunc.temp = pfunc(grid,s.mat[,i])
    p.mat[,i] = pfunc.temp$q
  }
  for(k in 1:length(grid)) p.sd[k] = sd(p.mat[k,])

  return(list(s.sd=s.sd,p.sd=p.sd))
}

sim.funcs = sim.sup.prod(summary(lm.loglin),pgrid,sup.loglin,prod.loglin,100)

s.loglin.ub = s.loglin + 2*sim.funcs$s.sd
s.loglin.lb = s.loglin - 2*sim.funcs$s.sd
prod.loglin.lb = s.loglin - 2*sim.funcs$p.sd
prod.loglin.ub = s.loglin + 2*sim.funcs$p.sd

# Supply and production plots
plot(s.loglin,pgrid,type="l",main="Loglin Supply Function with \n 95% Confidence Band",xlab="Supply",ylab="Price", xlim=c(0,40))
lines(s.loglin.lb,pgrid,col="red",lty=2)
lines(s.loglin.ub,pgrid,col="red",lty=2)

plot(m.loglin,s.loglin, type="l",main="Loglin Production Function with \n 95% Confidence Band",xlab="m",ylab="q", xlim=c(0,80))
lines(m.loglin, prod.loglin.ub, col="red",lty=2)
lines(m.loglin, prod.loglin.lb, col="red",lty=2)

# Supply and production plots in log-log scale
plot(log(s.loglin),log(pgrid),type="l",main="Log-linear Supply Function with \n 95% Confidence Band",
     xlab="log(Supply)",ylab="log(Price)", xlim=c(0,log(40)), lwd=2)
lines(log(s.loglin.lb),log(pgrid),col="black",lty=2)
lines(log(s.loglin.ub),log(pgrid),col="black",lty=2)

plot(log(m.loglin),log(s.loglin), type="l",main="Log-linear Production Function with \n 95% Confidence Band",
     xlab="log(m)",ylab="log(q)", xlim=c(0,log(80)), lwd=2)
lines(log(m.loglin), log(prod.loglin.ub), col="black",lty=2)
lines(log(m.loglin), log(prod.loglin.lb), col="black",lty=2)

# Supply and production plots in GLM log-log scale
sim.glmfuncs = sim.sup.prod(summary(glm.loglin),pgrid,sup.glmloglin,prod.glmloglin,100)

s.glmloglin.ub = sglm.loglin + 2*sim.glmfuncs$s.sd
s.glmloglin.lb = sglm.loglin - 2*sim.glmfuncs$s.sd
prod.glmloglin.lb = sglm.loglin - 2*sim.glmfuncs$p.sd
prod.glmloglin.ub = sglm.loglin + 2*sim.glmfuncs$p.sd

# Supply and production plots
plot(sglm.loglin,pgrid,type="l",main="GLM-Loglin Supply Function with \n 95% Confidence Band",xlab="Supply",ylab="Price", xlim=c(0,40))
lines(s.glmloglin.lb,pgrid,col="red",lty=2)
lines(s.glmloglin.ub,pgrid,col="red",lty=2)

plot(m.glmloglin,sglm.loglin, type="l",main="GLM-Loglin Production Function with \n 95% Confidence Band",xlab="m",ylab="q", xlim=c(0,80))
lines(m.glmloglin, prod.glmloglin.ub, col="red",lty=2)
lines(m.glmloglin, prod.glmloglin.lb, col="red",lty=2)

# Supply and production plots in log-log scale
plot(log(sglm.loglin),log(pgrid),type="l",main="GLM-Log-linear Supply Function with \n 95% Confidence Band",
     xlab="log(Supply)",ylab="log(Price)", xlim=c(0,log(40)), lwd=2)
lines(log(s.glmloglin.lb),log(pgrid),col="black",lty=2)
lines(log(s.glmloglin.ub),log(pgrid),col="black",lty=2)

plot(log(m.glmloglin),log(sglm.loglin), type="l",main="GLM-Log-linear Production Function with \n 95% Confidence Band",
     xlab="log(m)",ylab="log(q)", xlim=c(0,log(80)), lwd=2)
lines(log(m.glmloglin), log(prod.glmloglin.ub), col="black",lty=2)
lines(log(m.glmloglin), log(prod.glmloglin.lb), col="black",lty=2)

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


#Copyright (c) 2016 Riccardo Francescato
#insert a vector for eache experiment repetition
RawData0 = c(130,34,20,
			150,136,25,
			138,174,96)
RawData1 = c(155,40,70,
			188,122,70,
			110,120,104)
RawData2 = c(74,80,82,
			159,106,58,
			168,150,82)
RawData3 = c(180,75,58,
			126,115,45,
			160,139,60)

RawData = c(RawData0,RawData1,RawData2,RawData3)

a = 3 # numer of treatments A (columns)
b = 3 # numer of treatments B (rows)
n = 4 # numer of repetitions
N = a*b*n
alpha = .05
SRawData = RawData0+RawData1+RawData2+RawData3
SRawMatrix = matrix(SRawData,ncol=a,byrow = TRUE)
RawMatrix = matrix(RawData,ncol=a,byrow = TRUE)

# ANOVA
sum(SRawMatrix[1,])

SSt <- sum(RawData^2) - sum(RawData)^2/N
SSa = 0
for (i in 1:b){
	SSa=SSa+sum(SRawMatrix[i,])^2
}
SSa=(1/(b*n))*SSa-sum(RawData)^2/N

SSb = 0
for (i in 1:a){
	SSb=SSb+sum(SRawMatrix[,i])^2
}
SSb=(1/(a*n))*SSb-sum(RawData)^2/N

SSab = (1/n)*sum(SRawMatrix^2) - sum(RawData)^2/N - SSa - SSb

SSe = SSt - SSab - SSa - SSb

MSa	= SSa/(a-1)
MSb = SSb/(b-1)
MSab = SSab/((a-1)*(b-1))
MSe = SSe/(a*b*(n-1))
F0a = MSa/MSe
F0b = MSb/MSe
F0ab = MSab/MSe
Fa = qf(alpha,df1=(a-1),df2=(a*b*(n-1)),lower.tail=F)
Fb = qf(alpha,df1=(b-1),df2=(a*b*(n-1)),lower.tail=F)
Fab = qf(alpha,df1=((a-1)*(b-1)),df2=(a*b*(n-1)),lower.tail=F)
cat(paste0(" Treatment A  SS: ",SSa," Df: ", a-1 ," MS: ",MSa, " F0a: ",F0a," Fa crit: ",Fa,
		"\n Treatment B  SS: ",SSb," Df: ", b-1 ," MS: ",MSb," F0b: ",F0b," Fb crit: ",Fb,
		"\n Interaction AB  SS: ",SSab," Df: ", (a-1)*(b-1) ," MS: ",MSab," F0ab: ",F0ab," Fab crit: ",Fab,
		"\n Error   SS: ",SSe," Df: ",a*b*(n-1) ," MS: ",MSe,
		"\n Total  SS: ",SSt," Df: ", (a*b*n)-1,
		"\n Fcrit: ", Fa))


################
#---PACKAGES---#
################
require(ggplot2)
require(reshape2)

###################################
#---BINOMIAL LIKELIHOOD EXAMPLE---#
###################################
myBlue = rgb(r = 86, g = 110, b = 126, maxColorValue = 250)

like <- function(theta, k = 8, n = 10) {
  return(dbinom(k, n, theta))
}

# 900 x 600
theta <- seq(from = 0, to = 1, by = 0.01)
plot(theta, like(theta), type = "l", col = myBlue, lwd = 3)

points(0.8, like(0.8), pch = 19, col = myBlue, cex = 1.5)

######################
#---NEWTON RAPHSON---#
######################
myBlue = rgb(r = 86, g = 110, b = 126, maxColorValue = 250)

f <- function(x) {
  f = exp(x)/(1 + exp(x))^2
  fx = exp(x)/(1 + exp(x))^2 - 2*exp(2*x)/(1 + exp(x))^3
  fxx = 6 * exp(x)/(1 + exp(x))^4 - 6*exp(2*x)/(1 + exp(x))^3 + exp(x)/(1+exp(x))^2
  return( data.frame(f = f, fx = fx, fxx = fxx ) )
}

x = seq(-10, 10, length.out = 100)
plot(x, f(x)[,1], type = "l", col = myBlue, lwd = 3)

newtonRaphson <- function(f, x0, tol = 1/10^9, maxIter = 100) {

      x  = x0
      fx = f(x)
      i  = 0

      cat(paste(c("i", "x", "f(x)", "\n"), sep = "\t"))
      while ( (abs(fx[, 2]) > tol) ) {

      if(i < maxIter) {

             x  = x - fx[, 2] / fx[, 3]
             fx = f(x)

             points(x, fx[,1], pch = 19, col = myBlue, cex = 1.5)
             cat(paste(c(i, x, fx[,1], "\n"), sep = "\t"))
             Sys.sleep(0.5)

             i  = i + 1

      } else {
      break;
      }#END: maxIter check
  }#END: tolerance loop

  return(x)
}

x.star <- newtonRaphson(f, 5)
# f(x.star)


# Programming in `R`
# Thanks to Sina Rasooli!

# How to run script?!

## Sum
3 + 4

## Subtract
2 - 5

## Multiply
1.2 * 6.8

## Divide
(123 + 321) / 2

## Exponentiation
3^5

## Modulo
37%%9

## Assign Variable
x <- 42
z <- "salam"
y = 32
23 -> x

## Print
x
y

## Arithmatic with Variables
x + y
x - y
x * y
x^y
x / y
x %% y

## Arithmatic and Assignment
z = x + y
z

## Variable Types
### Numerics
x = 1.2
x = 3
### Logical
y = FALSE # `F` or `FALSE`
y = T # `T` or `TRUE`
### Character
z = "salam"

## Determine Class
class(x)
class(y)
class(z)

## R Help
?mean
help(lm)
??mean
example("median")

## Vectors
x = vector()
x
x = c(1, 2, 3)
x
y = c("a","b","c")
y
z = c(T,F,F)
z

## Vectors: What if Mixed?
x = c(3,T)
x
class(x)
typeof(x)
x = c(4,"a")
x
x = c(5, F, "b")
x

## Attributes: name
x_sleep = c(6.5, 7.5, 7, 8, 6)
x_names = c("Saturday", "Sunday", "Monday", "Tuesday", "Wednesday")
names(x_sleep) = x_names
x_sleep
x_sleep["Monday"] = 2
x_sleep["Shanbe"] = 4
x_sleep
x_sleep[1]

## Vector Summation
x = c(1,2,3)
y = c(4,5,6)
x+y

## Vector Simple Functions
x = c(1.2,3.4,5.6)
sum(x)
mean(x)
median(x)
sd(x)

## Vector: Indexing
x_sleep = c(6.5, 7.5, 7, 8, 6)
x_names = c("Saturday", "Sunday", "Monday", "Tuesday", "Wednesday")
x_sleep[2]
x_sleep[-2]
names(x_sleep) = x_names
x_sleep["Tuesday"]

## Vector Slicing
x = 1:10
x
x_sleep[c(2,3,4)]
x_sleep["Sunday":"Tuesday"]
y = c(4,3,1)
x_sleep[y]
x_sleep[c("Sunday","Tuesday")]
x_sleep[c(T,T,T,F,T)]
x_sleep
x_sleep[-c(1,2)]

## Vector Selection
?sleep
sleep
x = sleep$extra
x
sleep$ID
x_selection = x > 1.1
x_selection
y = x[ x_selection ]
y

## Matrices
matrix( data = 1:10, byrow = T, nrow = 5 )

## Matrics: from Vectors
x = c( 460.998, 314.4 )
y = c( 290.475, 247.9 )
z = c( 309.306, 165.8 )
w = c( x, y, z )
m = matrix( data = w, byrow = T, nrow = 3 )

## Matrics: Attributes
m
colnames(m) = c("A","B")
rownames(m) = c("gozashte", "haal","aayande")

## Matrices: Slicing
m[2,]
m["haal",]
m["gozashte",1]
m[c("aayande","gozashte"),"A"]

## Matrices: simple Functions
rowSums(m)
colSums(m)
colMeans(m)
rowMeans(m)

## Matrices: rbind, cbind
cbind( m, rowSums(m) )
rbind( m, colSums(m) )

## Matrices: scalar arithmatics
m + 1000
m - 1000
m * 2
m / 5
m %% 3

## Matrices: multiply by vector
m * c(10,100,1000)
m * c(1, 0)

## Matrices: Matrix Multiplications
m %*% c(1,0)
c(1,0,0) %*% m
t(m) %*% m
m %*% t(m)

## Factors
x = c("m","f","f","m","m")
x = factor(x)
x
class(x)
## Factors: Ordered
x = c("a","a","c","b","c","a")
y = factor( x, ordered = T, levels = c("c","b","a") )
x = c(1,2,3,2,3)
x
x = factor(x)
x

## Factors: Levels
levels(y) = c("A","B","C")
y

## Factors: summary
summary(x)
summary(y)

## Factors: comparison
y[3] > y[1]

## DataFrames: example
class(mtcars)
typeof(mtcars)
help("mtcars")

## DataFrames: head
?mtcars
View(mtcars)
head(mtcars)
tail(mtcars)
dim(mtcars)
nrow(mtcars)
ncol(mtcars)

## DataFrames: str
str(mtcars)

## DataFrames: summary
summary(mtcars)

## DataFrames: constructor
names = c("Yashar","Sina","Hoda","Maryam")
ages = c(22,24,22,21)
row_ids = c(1,1,2,2)
class_df = data.frame(names, ages, row_ids)
class_df

## DataFrames: slicing
class_df[1,1]
class_df[2,]
class_df[,3]
class_df[1:2,2:3]
class_df[,1]
class_df$names
class_df[,"row_ids"]
class_df$ages < 23
class_df[class_df$ages < 23 ,]

## DataFrames: subset
subset( class_df, subset = ( ages < 23 ) )

## DataFrames: order
a = c(3,1,4,5,2)
order(a)
a[ order(a) ]

class_df[order(class_df$ages), ]

## Lists: construction
a = 1:10
b = matrix(1:10, byrow = T, nrow = 5)
c = mtcars[1:10,]
my_list = list( a,b,c )
my_list

## Lists: names
my_list = list( W = a, U = b, V = c )
my_list

names(my_list) = c("A","B","C")
my_list

## Lists: slicing
my_list$A
my_list[[3]]