eBay <-read.csv("eBayAuctions.csv")
View(eBay)
str(eBay)

eBay$Duration <- as.factor(eBay$Duration)
eBay$Competitive.<-as.factor(eBay$Competitive.)

set.seed(32121391)

train.row<-sample(rownames(eBay), dim(eBay)[1]*0.6)
valid.row<-setdiff(rownames(eBay), train.row)
train.ebay<-eBay[train.row,]
valid.ebay<-eBay[valid.row,]

# a. 분류나무 minbucket=50, maxdepth=7
library(rpart)
library(rpart.plot)
class.ebay<-rpart(Competitive. ~ ., data=train.ebay,
                  control=rpart.control(minbucket = 50, maxdepth = 7), method="class")

prp(class.ebay, type=1, extra=1, varlen=0)

class.ebay.point.valid <- predict(class.ebay,valid.ebay,type = "class")
# generate confusion matrix for training data

out<-table(class.ebay.point.valid,valid.ebay$Competitive.)
# 실제값과 예측값의 분류교차표 작성

out
(out[1,1]+out[2,2])/sum(out)

#c
cv.ct <-rpart(Competitive.~., data = train.ebay, method = "class",
              cp = 0.00001, minsplit = 50, xval = 5)

control=rpart.control(minbucket = 50, maxdepth = 7)

cv.ct <-rpart(Competitive.~., data = train.ebay, method = "class",
              cp = 0.00001, minsplit = 50, xval = 5, control = rpart.control(minbucket = 50, maxdepth = 7))

printcp(cv.ct)

## 적절한 nsplit = 6

#d
pruned.ct <- prune(cv.ct, cp = cv.ct$cptable[which.min(cv.ct$cptable[,"xerror"]),"CP"])
length(pruned.ct$frame$var[pruned.ct$frame$var == "<leaf>"])
prp(pruned.ct, type = 1, extra = 1, split.font = 1, varlen = -10)

cv.ct <-rpart(Competitive.~., data = pruned.ct, method = "class",
              cp = 0.00001, minsplit = 50, xval = 5, control = rpart.control(minbucket = 50, maxdepth = 7))

printcp(cv.ct)

#e

ebay_e <- eBay[,6:8]
library(ggplot2)

ggplot(data = ebay_e, aes(x = ebay_e$OpenPrice, y = ebay_e$ClosePrice, color = ebay_e$Competitive.))+
  geom_point()

graph + geom_hline(aes(yintercept=2.65)) + geom_vline(aes(xintercept=0.8)) + geom_vline(aes(xintercept=1.75)) + geom_vline(aes(xintercept=1.35))

library(party)

tree1 <- tree(Species ~ Sepal.Width + Petal.Width, data = iris)
summary(tree1)
Classification tree:
  tree(formula = Species ~ Sepal.Width + Petal.Width, data = iris)
Number of terminal nodes:  5
Residual mean deviance:  0.204 = 29.57 / 145
Misclassification error rate: 0.03333 = 5 / 150
plot(tree1)
text(tree1)

install.packages("tree")
library(tree)
eb<-eBay
plot(eBay$OpenPrice, eBay$ClosePrice, pch=c(19,19), col=as.numeric(eb$Competitive.))
tree1 <- tree(Competitive. ~ OpenPrice + ClosePrice, data = eb)
summary(tree1)
partition.tree(tree1,label="Competetive.",add=TRUE)


#
# Exemplo 2
#

# Série de taylor que desenvolve
# a série até encontrar erro menor
# que 0.01
taylor <- function(a, x) {
    n <- 0
    tay <- 0
    valor <- exp(x)
    while (abs(valor - tay) > 0.01) {
        termo <- exp(a) / factorial(n) * (x - a)^n
        tay <- tay + termo
        n <- n + 1
    }
    cat("Taylor=", tay, "Numero de interacoes=", n, "\n")
}
# executa a série em torno de a=2 para x=1
taylor(2, 1)


#!/usr/bin/Rscript
# Task 1
#-------------------------------------------------------------------------------
# Initial data
#-------------------------------------------------------------------------------
S0=1; r=0.05; sigma=0.2; T=2; K=0.8;
#-------------------------------------------------------------------------------
Call <- function(S0,r, sigma, T, K){
  d1=(log(S0/K)+T*(r+(sigma^2)/2))/(sigma*sqrt(T))
  d2=d1-sigma*sqrt(T)
  C=S0*pnorm(d1)-K*exp(-r*T)*pnorm(d2)
  return (C)
}

ImpliedVola <- function(S0, r, T, K, C){
  vola=uniroot(function(sigma) Call(S0, r, sigma, T, K) - C, c(0,5))
  return (vola$root)
}

C=Call(S0,r,sigma,T,K)
C
ImpliedVola(S0,r,T,K,C)
#-------------------------------------------------------------------------------
Data=read.csv("data/option_values.csv",header=F,sep=";")
Maturities=as.numeric(Data[1,]/12); Interests=as.numeric(Data[2,])

S0=2890.62; K=c(2700, 2800, 2900, 3000, 3100, 3200, 3300)
vola=matrix(rep(0,42), 7, 6)
for(i in 1:7)
  for(j in 1:6)
    vola[i, j] = ImpliedVola(S0, Interests[j], Maturities[j], K[i], Data[i+2,j])

persp(K,Maturities,vola,theta=60,col="green")


# Function to visualize a number
plotImg <- function(data, row_index){
  # Obtaining the row as a numeric vector
  r <- as.numeric(data[row_index, 1:784])
  # Creating a empty matrix to use
  im <- matrix(nrow = 28, ncol = 28)
  # Filling properly the data into the matrix
  j <- 1

  for(i in 28:1){
    im[,i] <- r[j:(j+27)]
    j <- j+28
  }
  # Plotting the image with the label
  image(x = 1:28,
        y = 1:28,
        z = im,
        col=gray((0:255)/255),
        main = paste("Number:", data[row_index, 1]))
}

setwd("~/Documents/GitHub/Data-Science-Micromasters/Machine Learning Fundamentals/Week 1 - Prediction Problems")

train <- read.csv2('Files/MNIST/train.csv', stringsAsFactors = F, dec = '.')
test  <- read.csv2('Files/MNIST/test.csv', stringsAsFactors = F, dec = '.')

trainData   <- as.matrix(train[1:784])
trainLabels <- as.matrix(train[785])
testData    <- as.matrix(test[1:784])
testLabels  <- as.matrix(test[785])

plotImg(train,1)

# Computes squared Euclidean distance between two vectors.
euclideanDistance <- function(x,y){
  return (sum((x-y)^2))
}

# Finds the nearest neighbor for a vector of values
findNN <- function(x){
  distances <- c()
  for(i in 1:nrow(train)){
    distances <- c(distances,euclideanDistance(x,trainData[i,]))
  }
  return(which.min(distances))
}

# Classifies the label for NN
NNClassifier <- function(x){
  index <- findNN(x)
  return(trainLabels[index])
}

# Predict on each test data point (and time it!)
before <- Sys.time()
testPredictions <- c()
for(i in 1:nrow(test)){
  testPredictions <- c(testPredictions,NNClassifier(testData[i,]))
}
after <- Sys.time()

time <- after - before

errPredictions <- sum(!(testPredictions == testLabels)*1)
error <- errPredictions/length(testLabels)

print(paste('Model\'s Error:',error))

Machine Learning Fundamentals/Week 1 - Prediction Problems/Handwritten Digit Recognition with Nearest Neighbor.r


entropy <- function(s)
{
  if (length(s) > 1)
    return(sapply(s, entropy))

  freq <- prop.table(table(strsplit(s, '')[1]))
  ret <- -sum(freq * log(freq, base=2))

  return(ret)
}

fibwords <- function(n)
{
  if (n == 1)
    fibwords <- "1"
  else
    fibwords <- c("1", "0")

  if (n > 2)
  {
    for (i in 3:n)
      fibwords <- c(fibwords, paste(fibwords[i-1L], fibwords[i-2L], sep=""))
  }

  str <- if (n > 7) replicate(n-7, "too long") else NULL
  fibwords.print <- c(fibwords[1:min(n, 7)], str)

  ret <- data.frame(Length=nchar(fibwords), Entropy=entropy(fibwords), Fibwords=fibwords.print)
  rownames(ret) <- NULL
  return(ret)
}


library(ggplot2)
library(reshape2)
library(e1071)
#load data
train.data = read.csv("Downloads/MachineLearning-master/Example Data/SVM_Example_2.csv", stringsAsFactors = F)
test.data = read.csv("Downloads/MachineLearning-master/Example Data/SVM_Example_2_Test_data.csv", stringsAsFactors = F)
#visualize data
ggplot(train.data) + geom_line(aes(x = x, y = y, color = factor(label)))
ggplot(test.data) + geom_line(aes(x = x, y = y, color = factor(label)))
#change format of label from int to factor
train.data$label <- as.factor(train.data$label)
#train a simple model and predict
model <- svm(label~., data = train.data, kernel = "polynomial", degree = 2)
pred <- predict(model, test.data[,1:2])
table(pred, test.data[,3])
#get the best degree / cost parameter based on Mike's blog
cost <- c(0.001, 0.01, 0.1, 0.2, 0.5,1.0, 2.0, 3.0, 10.0, 100.0)
degree <- c(2, 3, 4, 5)
tuned <- tune.svm(label~., data = train.data, cost = cost, kernel = "polynomial", degree = degree)
#best performance cost and degree train a new model
new.model <- svm(label~. ,data = train.data, kernel = "polynomial", cost = 100, degree = 3)
pred <- predict(model, test.data[,1:2])
table(pred, test.data[,3])
#print the best parameter
summary(tuned)


=begin
= 代数パッケージ

2006.09.16

*Version: 0.72
*著者: 原 信一郎
*e-mail: sinara@blade.nagaokaut.ac.jp
*Home Page: ((<URL:http://blade.nagaokaut.ac.jp/~sinara/ruby/math/>))

== これは、、、

1変数あるいは多変数の多項式を計算するためのライブラリです。
数学的対象を自然に Ruby で表現可能にする事を目的にしています。
スピードはありませんが、スクリプト言語なのでアルゴリズムを見る事
ができます。

* 一変数多項式
  * 加法、乗法、商／剰余等の演算
  * 因数分解
  * Galois 群
* 多変数多項式
  * 加法、乗法等の演算
  * 因数分解
  * グレブナ基底の生成、グレブナ基底による商／剰余の演算
* 代数系
  * 商体の生成
  * 剰余環の生成
  * 行列環の生成
  * 置換群の計算
* 集合と写像

== インストール

このパッケージを利用するにはまず、オブジェクト指向スクリプト言語 Ruby
(((<URL:http://www.ruby-lang.org/>))参照) が必要です。

更に、アーカイブの展開後

  ruby install.rb

とすれば、lib ディレクトリ以下を、ロード可能なディレクトリにコピーし、
インストールが完了します。

速度の点から、有理数は標準添付の rational.rb ではなく、拡張ライブラリ
(((<URL:http://blade.nagaokaut.ac.jp/~sinara/ruby/rational/>))
を使うことを勧めます。

== 使い方・サンプル

doc ディレクトリの ((<index-ja.html|URL:index-ja.html>)) を見てください。
マニュアルやサンプルがあります。

== 参考
* D.コックス, J.リトル and D.オシー, "グレブナ基底と代数多様体入門（上・下）",
  2000,シュプリンガー・フェアラーク東京
* 児玉宏児, "Polynomial", ((<URL:http://www.math.kobe-u.ac.jp/HOME/kodama/tips-RubyPoly.html>))
* H.Anai, M.Noro and K.Yokoyama, "Computation of the splitting fields and the Galois groups of polynomials", Progres in Mathematics, 28-50, Vo.143, 1996

=end


#----------------------------------------------------------------
# test function
#----------------------------------------------------------------

library(inline)

body <- "std::cout << \"It works\" << std::endl;"
test <- cxxfunction(signature(), body=body, plugin="Rcpp")

test()

#----------------------------------------------------------------
# Estimating pi
#----------------------------------------------------------------

mcsim_pi_r <- function(n){
  r <- 0L

  for (i in 1:n){
    u <- runif(1)
    v <- runif(1)

    if (u^2 + v^2 <= 1)
      r <- r + 1
  }

  return( 4*r/n )
}

mcsim_pi_r_vectorized <- function(n){
  x <- matrix(runif(n * 2), ncol=2)
  r <- sum(rowSums(x^2) <= 1)

  return( 4*r/n )
}

library(inline)
cxx_pi <- cxxfunction(signature(n_="int"), body='
    int i, r = 0;
    int n = Rcpp::as<int >(n_);
    double u, v;

    for (i=0; i<n; i++){
      u = R::runif(0, 1);
      v = R::runif(0, 1);

      if (u*u + v*v <= 1)
        r++;
    }

    return Rcpp::wrap( (double) 4.*r/n );

  ',plugin="Rcpp"
)

mcsim_pi_r_rcpp <- function(n){
  cxx_pi(as.integer(n))
}

library(rbenchmark)

n <- 50000

benchmark(R.loops = mcsim_pi_r(n),
          R.vectorized = mcsim_pi_r_vectorized(n),
          Rcpp = mcsim_pi_r_rcpp(n),
          columns=c("test", "replications", "elapsed", "relative"))

#----------------------------------------------------------------
# Cosine similarity
#----------------------------------------------------------------

### cosine function from lsa package
cosine <- function (x, y = NULL){
   if (is.matrix(x) && is.null(y)) {
       co = array(0, c(ncol(x), ncol(x)))
       f = colnames(x)
       dimnames(co) = list(f, f)
       for (i in 2:ncol(x)) {
           for (j in 1:(i - 1)) {
               co[i, j] = cosine(x[, i], x[, j])
           }
       }
       co = co + t(co)
       diag(co) = 1
       return(as.matrix(co))
   }
   else if (is.vector(x) && is.vector(y)) {
       return(crossprod(x, y)/sqrt(crossprod(x) * crossprod(y)))
   }
   else {
       stop("argument mismatch. Either one matrix or two vectors needed as input.")
   }
}

### Improved R solution
cosine2 <- function(x){
  cp <- crossprod(x)
  dg <- diag(cp)

  co <- matrix(0.0, length(dg), length(dg))

  for (j in 2L:length(dg)){
    for (i in 1L:(j-1L)){
      co[i, j] <- cp[i, j] / sqrt(dg[i] * dg[j])
    }
  }

  co <- co + t(co)
  diag(co) <- 1.0

  return( co )
}

### Rcpp
library(inline)

fill_loop <- cxxfunction(
  signature(cp_="matrix", dg_="numeric"),
  body='
    // Shallow copies
    Rcpp::NumericMatrix cp(cp_);
    Rcpp::NumericVector dg(dg_);

    // Allocate return
    Rcpp::NumericMatrix co(cp.nrow(), cp.ncol());

    int i, j;

    for (j=0; j<co.ncol(); j++){
      for (i=0; i<co.nrow(); i++){
        if (i == j)
          co(i, j) = 1.0;
        else
          co(i, j) = cp(i, j) / std::sqrt(dg[i] * dg[j]);
      }
    }

    return co;
  ',plugin="Rcpp"
)

cosine_Rcpp <- function(x){
  cp <- crossprod(x)
  dg <- diag(cp)

  co <- fill_loop(cp, dg)

  return( co )
}

### Rcpp improved
fill_loop2 <- cxxfunction(
  signature(cp_="matrix", dg_="numeric"),
  body='

    // Shallow copies
    Rcpp::NumericMatrix cp(cp_);
    Rcpp::NumericVector dg(dg_);

    const unsigned int n = cp.nrow();

    // Allocate return
    Rcpp::NumericMatrix co(n, n);

    int i, j;

    // Fill diagonal
    for (j=0; j<n; j++)
      co(j, j) = 1.0;

    // Fill lower triangle
    for (j=0; j<n; j++){
      for (i=0; i<j; i++)
        co(i, j) = cp(i, j) / std::sqrt(dg[i] * dg[j]);
    }

    // Copy lower triangle to upper
    for (j=0; j<n; j++){
      for (i=j+1; i<n; i++)
        co(i, j) = co(j, i);
    }

    return co;
  ',plugin="Rcpp"
)

cosine_Rcpp2 <- function(x){
  cp <- crossprod(x)
  dg <- diag(cp)

  co <- fill_loop2(cp, dg)

  return( co )
}

#----------------------------------------------------------------
# RcppArmadillo
#----------------------------------------------------------------

f <- function(x) list(outer=x %*% t(x), inner=t(x) %*% x)

body <- '
  arma::mat v = Rcpp::as<arma::mat>(vs);
  arma::mat op = v * v.t();
  arma::mat ip = v.t()*v;

  return Rcpp::List::create(
    Rcpp::Named("outer")=op, Rcpp::Named("inner") = ip);
'

library(inline)
g <- cxxfunction(signature(vs="matrix"), plugin="RcppArmadillo", body=body)

x <- matrix(1:30, 10)
all.equal(f(x), g(x))

#----------------------------------------------------------------
# RcppGSL
#----------------------------------------------------------------

includes <- '
  #include <gsl/gsl_matrix.h>
  #include <gsl/gsl_blas.h>
'

body <- '
  RcppGSL::matrix<double> M = sM;
  int k = M.ncol();
  Rcpp::NumericVector n(k);

  for (int j = 0; j < k; j++) {
      RcppGSL::vector_view<double> colview = gsl_matrix_column(M, j);
      n[j] = gsl_blas_dnrm2(colview);
  }

  M.free() ;
  return n;
'

library(inline)
g <- cxxfunction(signature(sM="matrix"), plugin="RcppGSL", body=body, inc=includes)


# @lab 1

# Q1
x = vector("numeric", length=10)
x = 1:5
print(x)

# Q2
print(as.logical(x))
print(as.complex(x))

# Q3

q3_var1 = 0
q3_var2 = 1
q3_var3 = 0
q3_var4 = 6
q3_var5 = 5

vec = c(q3_var1, q3_var2, q3_var3, q3_var4, q3_var5)
vec

# Q4

identity_matrix = diag(3)
identity_matrix

# Q5

mat = matrix(c(1:12), nrow = 3)
mat

# Q6

matrow = matrix(c(1:12), nrow = 3, byrow = TRUE)
matrow

# Q7

print(matrow[3,])

# Q8

print(matrow[,2])

# Q9

print(matrow[1,1])
print(matrow[3,4])

# Q10

month_vec = c('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dev')
month_vec

# Q11

number_of_days = c(31,28,31,30,31,30,31,31,30,31,30,31)
number_of_days

# Q12

combined_matrix = cbind(month_vec, number_of_days)
combined_matrix

# Q13

q13_var1 = 4
q13_var2 = 5
q13_var3 = 6
q13_var4 = 2
q13_var5 = 9
lst = list(c(q13_var1, q13_var2, q13_var3, q13_var4, q13_var5))
lst

# Q14

x1 = c(157:164); x1
x2 = c(c(15:18),c(20:24)); x2
x3 = c(10:1); x3
x4 = c(c(-1071:-1075), c(-1074:-1071)); x4
x5 = seq(1.5,5.5,1); x5

# Q15

y1 = (10:20) * 2; y1
y2 = 105:(30 * 3); y2
y3 = 10:20*2; y3
y4 = 1 + 1:10/10; y4
y5 = 2^(0:5); y5

# Q16

z1 = c(1:6) *5; z1
z2 = c(0:15) %% 4; z2
z3 = c(1:8)/c(5:12); z3
z4 = c(1:2) * (1:10); z4

# Q17

seq(from=20, to=80, by=20)
seq(from=-10, to=5, by=0.5)
seq(from=10, to=-3, by=-2)
seq(from=0.01, to=0.09, by=0.02)

# Q18

w1 = rep(5,7); w1
w2 = rep(c(5:7), 5); w2
w3 = rep(c(10,16,71), 3); w3

# Q19

c(rep(5,4), rep(8,4), rep(-3,4), rep(0.34,4))
c(rep(-0.1,2), rep(-0.9,2), rep(-0.6,2))
rep(c(rep(1,2), rep(2,2), rep(3,2)),3)

# Q20

rep(seq(97,102), 3)
rep(seq(-5,-8,-1), each=4)
rep(seq(13,29,4), each=2, times=2)

# Q21

rep(seq(97,102), 3)
rep(seq(-5,-8,-1), each=4)
rep(seq(13,29,4), each=2, times=2)
rep(c(seq(1:3), seq(2,0,-1)), 3)


## data https://github.com/n0acar/eigenfaces
library(pixmap)

list files in a gihub directory

url <- "https://github.com/n0acar/eigenfaces/tree/master/lfw_cropped_gray_eigenfaces"

pg <- xml2::read_html(url)
library(magrittr)
library(rvest)
tst <- pg %>%  html_nodes("div") %>% html_nodes("span") %>% html_nodes("a") %>% html_text()
celebs <- tst[grep(".pgm",tst)]
base <- "https://raw.githubusercontent.com/n0acar/eigenfaces/master/lfw_cropped_gray_eigenfaces/"

for(i in 1:length(celebs)){
    download.file(paste(base, celebs[i], sep = ""), destfile  = celebs[i])
}

imgs <- list.files("./", pattern = ".pgm", full = TRUE)
pix <- lapply(imgs,read.pnm)
par(mfrow = c(4,4), mar = c(0,0,0,0), oma = c(0,0,0,0))
for(i in 1:length(pix)){
    plot(pix[[i]])
    nm <- strsplit(strsplit(imgs[i],"//")[[1]][2],"_")[[1]]
    legend("bottom", bty = "n", paste(nm[-length(nm)],  collapse = " "))
}

## names
tst <- sapply(imgs, function(x) strsplit(strsplit(x,"//")[[1]][2],"_")[[1]])
names <-  sapply(tst, function(y) paste(y[-length(y)],  collapse = " ")); names(names) <- NULL
## collapse the grey matrix
faces <- lapply(pix, function(x) c(x@grey))
## each column is a face
faces <- do.call('cbind',faces)
colnames(faces) <- names

## center around mean
mean <- apply(faces, 1, mean)
mean_face <- pixmapGrey(mean, 64, 64, bbox = c(0, 0, 64, 64))
plot(mean_face)
centered <- apply(faces, 2, function(x) x - mean)
## centered imags
par(mfrow = c(4,4), mar = c(0,0,0,0), oma = c(0,0,0,0))
for(i in 1:length(pix)){
    plot(pixmapGrey(centered[,i], 64, 64, bbox = c(0, 0, 64, 64)))
    legend("bottom", bty = "n", paste(names[i], "centered", sep = " "))
}

pca <- prcomp(centered)
library(ggbiplot)
ggbiplot(pca, alpha = 0.1) +
    theme(legend.direction = 'horizontal', legend.position = 'top')

## eigen faces
pcs <- pca$x
eigenfaces <- apply(pcs,2, function(x)  pixmapGrey(x, 64, 64, bbox = c(0, 0, 64, 64)))
par(mfrow = c(4,4), mar = c(0,0,0,0), oma = c(0,0,0,0))
for(i in 1:length(eigenfaces)){
    plot(eigenfaces[[i]])
    legend("bottom", bty = "n", paste("PC", i, sep = " "))
}

## reconstruction
## each face is a weighted (loadings) combintation of the eigen faces (PCs) above
## but how many PCs (eigenfaces) do we keep
plot(pca)
pca$rotation
## 2 PCs
n_pc <- 2

recon <- pixm <- list()
for (i in 1:length(names)){
    recon[[i]] <- rowSums(pca$x[,1:n_pc]%*%pca$rotation[i,1:n_pc])
    pixm[[i]] <- pixmapGrey(recon[[i]], 64, 64, bbox = c(0, 0, 64, 64))
}

## 2PC to reconstruct centered imags
par(mfrow = c(4,4), mar = c(0,0,0,0), oma = c(0,0,0,0))
for(i in 1:length(pixm)){
    plot(pixm[[i]])
    legend("bottom", bty = "n", paste(names[i], "2 PC", sep = " "))
}

### Hmm OK, what about 5
## 5 PCs
n_pc <- 5

recon <- pixm <- list()
for (i in 1:length(names)){
    recon[[i]] <- rowSums(pca$x[,1:n_pc]%*%pca$rotation[i,1:n_pc])
    pixm[[i]] <- pixmapGrey(recon[[i]], 64, 64, bbox = c(0, 0, 64, 64))
}

## 2PC to reconstruct centered imags
par(mfrow = c(4,4), mar = c(0,0,0,0), oma = c(0,0,0,0))
for(i in 1:length(pixm)){
    plot(pixm[[i]])
    legend("bottom", bty = "n", paste(names[i], "5 PC", sep = " "))
}

### Hmm OK, what about 10
## 10 PCs
n_pc <- 10

recon <- pixm <- list()
for (i in 1:length(names)){
    recon[[i]] <- rowSums(pca$x[,1:n_pc]%*%pca$rotation[i,1:n_pc])
    pixm[[i]] <- pixmapGrey(recon[[i]], 64, 64, bbox = c(0, 0, 64, 64))
}

## 10PC to reconstruct centered images
par(mfrow = c(4,4), mar = c(0,0,0,0), oma = c(0,0,0,0))
for(i in 1:length(pixm)){
    plot(pixm[[i]])
    legend("bottom", bty = "n", paste(names[i], "10 PC", sep = " "))
}
## remember this is the centered image, let's add the "mean face" to reconstruct the original
par(mfrow = c(4,4), mar = c(0,0,0,0), oma = c(0,0,0,0))
for(i in 1:length(recon)){
    plot(pixmapGrey(recon[[i]] + mean, 64, 64, bbox = c(0, 0, 64, 64)))
    legend("bottom", bty = "n", paste(names[i], "10 PC + mean", sep = " "))
}

## So arguabke we reduced 16 dim to 10... Not a huge achievement, but what about if we have 1000 images
zip <- "http://conradsanderson.id.au/lfwcrop/lfwcrop_grey.zip"
temp <- tempfile(fileext = ".zip")
download.file(zip,destfile = temp)
tst <- unzip(temp)
unlink(temp)
all_faces <- list.files("lfwcrop_grey/faces",pattern = ".pgm", full = TRUE)
set.seed(6666)
choose <- sample(1:length(all_faces), 1000, replace = FALSE)

face_set <- lapply(choose, function(x) read.pnm(all_faces[x]))

## names
col <- sapply(all_faces[choose], function(x) strsplit(strsplit(x,"faces/")[[1]][2],"_")[[1]])
names <-  sapply(col, function(y) paste(y[-length(y)],  collapse = " ")); names(names) <- NULL
names(face_set) <- names
face_data <- lapply(face_set, function(x) c(x@grey))
## each column is a face
face_data <- do.call('cbind',face_data)
colnames(face_data) <- names(face_set)
## center around mean
mean <- apply(face_data, 1, mean)
mean_face <- pixmapGrey(mean, 64, 64, bbox = c(0, 0, 64, 64))
plot(mean_face)

centered <- apply(face_data, 2, function(x) x - mean)
pca <- prcomp(centered)
pcs <- pca$x
eigenfaces <- apply(pcs,2, function(x)  pixmapGrey(x, 64, 64, bbox = c(0, 0, 64, 64)))
plot(eigenfaces[[1]])
legend("bottom", bty = "n", "PC 1")

n_pc <- 250
recon <- rowSums(pca$x[,1:n_pc]%*%pca$rotation[1,1:n_pc])
## add the "mean face" to reconstruct the original
par(mfrow = c(1,2), mar = c(0,0,0,0), oma = c(0,0,0,0))
## original
plot(face_set[[1]])


y1bar=1.175
y2bar=1.293
y3bar=1.328
y4bar=1.415
y5bar=1.500

alpha=0.05
q.alpha=4.158
MSError=0.0153
LSD=q.alpha*sqrt((MSError)/6)
print(LSD)

#  the 95% confidence interval for y3bar-y1bar
left_i=(y3bar-y1bar)-LSD
right_i=(y3bar-y1bar)+LSD
print("Confidence interval is")
print(left_i)
print(right_i)


#' Compute the time-shift parameter tau.
#'
#' @param t Sampling times.
#' @param omega Angular frequency.
#'
#' @return Time-shift parameter tau.
#'
#' @examples
#' tau(1:10, 2*pi)
#'
#' @export
tau <- function(t, omega) {
    # two.omega[j] = 2 * omega[j]
    two.omega <- 2 * omega
    # two.omega.t[j,i] = 2 * omega[j] * t[i]
    two.omega.t <- two.omega %o% t

    # sin.sum[j] = Sum from i=1..N of sin(two.omega.t[j,i])
    sin.sum = rowSums(sin(two.omega.t))
    # cos.sum[j] = Sum from i=1..N of cos(two.omega.t[j,i])
    cos.sum = rowSums(cos(two.omega.t))

    # Consistent with the Fortran code
    # two.omega.tau[j] = atan(sin.sum[j] / cos.sum[j])
    two.omega.tau <- atan(sin.sum / cos.sum)
#    # Consistent with the paper.
#    # two.omega.tau[j] = atan2(sin.sum[j], cos.sum[j])
#    two.omega.tau <- atan2(sin.sum, cos.sum)

    # Consistent with the Fortran code
    # two.omega.tau[j] / (2*pi)
    two.omega.tau / (2*pi)
#    # Consistent with the paper.
#    # two.omega.tau[j] / (2*omega[j])
#    two.omega.tau / two.omega

}


# ......................................................................................
# ..........Exercise 6 - Selected distributions of a continuous random variable.........
# ......................................................................................
# ......................................................................................

# If text does not display correctly, set File \Reopen with Encoding ... to UTF-8
# Use CTRL + SHIFT + O to display the contents of the script
# Use CTRL + ENTER to run commands on a single line

#  Overview of distributions and their functions ####
#
# * Introduction: Probability Density, Distribution Function and Quantile Function ####
#
# ** Probability density ####
#
# - starts with the letter **d**: p=d...(x,...)
#
# ** Distribution function ####
#
# - starts with the letter **p**: $p = P(X < x)$:p=p...(x,...)
#
# ** Quantile function ####
#
# - starts with the letter **q**: find x for the given p: $p = F(x) \rightarrow x =
# F^{-1}(p)$: x=q...(p,...)
#

# * Uniform distribution: $X \sim U(a, b)$ ####
#
# - the random variable takes on only values greater than a and less than b
#
# - all values have the same occurrence density ->the probability density is constant
# between a and b, elsewhere zero
#

# Probability density f(x)
a = 2   # from where
b = 4   # up to
x = 3
dunif(x, a, b)

# we plot the probability density
x = seq(from = 0, to = 6, by = 0.01)
f_x = dunif(x, a, b)
plot(x, f_x, cex = 0.1) # cex is the size of the markers
grid()

# Distribution function F(x)=P(X<x)
a = 2   # from where
b = 4   # where
x = 3
punif(x, a, b)

# let's draw the Distribution function
x = seq(from = 0, to = 6, by = 0.01)
F_x = punif(x, a, b)
plot(x, F_x, type = 'l')
grid()

# quantile function F ^(- 1)(p)=x: P(X<x)=p
a = 2   # from where
b = 4   # where
p = 0.75
qunif(p, a, b)

# plot - quantile function F ^(- 1)(p)=x
p = seq(from=0, to=1, by=0.01)
x = qunif(p, a, b)
plot(p, x, type = 'l')
grid()

# * Exponential distribution: $X \sim Exp(\lambda)$ ####
#
# - time to 1st event, time between events(only in the period of stable life - Poisson
# process)
#
# - the parameter $\lambda$ is the same as in the Poisson distribution
#
# - the mean value is: $E(X)=1 / \lambda$
#

# Probability density f(x)
lambda = 2
x = 1
dexp(x, lambda)

# we plot the probability density
x = seq(from = 0, to = 6, by = 0.01)
f_x = dexp(x, lambda)
plot(x, f_x, type='l')
grid()

# Distribution function F(x)=P(X<x)
lambda = 2
x = 1
pexp(x, lambda)

# let's draw the Distribution function
x = seq(from = 0, to = 6, by = 0.01)
F_x = pexp(x, lambda)
plot(x, F_x, type = 'l')
grid()

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

# plot - quantile function F ^(- 1)(p)=x
p = seq(from=0, to=1, by=0.001)
x = qexp(p, lambda)
plot(p, x, type = 'l')
grid()

# * Weibull distribution: $X \sim W(\theta,\beta)$ ####
#
# - time until the 1st event(faults)(suitable choice of β allows use in any period of
# fault intensity)
#
# - extension of exponential distribution Exp(λ)=W(Θ=1/λ, β=1)
#

# Probability density f(x)
theta = 1/2 # equivalent of 1/lambda in exp. distribution
beta = 1  # beta=1 ->exponential distribution
x = 5
dweibull(x,shape=beta, scale=theta)

# we plot the probability density
x = seq(from = 0, to = 6, by = 0.01)
f_x = dweibull(x,shape=beta, scale=theta)
plot(x, f_x, type='l')
grid()

# Distribution function F(x)=P(X<x)
theta = 3 # equivalent of 1/lambda in exp. distribution
beta = 2  # beta=1 ->exponential distribution
x = 5
pweibull(x,shape=beta, scale=theta)

# we draw the Distribution function
x = seq(from = 0, to = 6, by = 0.01)
F_x = pweibull(x,shape=beta, scale=theta)
plot(x, F_x, type = 'l')
grid()

# quantile function F ^(- 1)(p)=x: P(X<x)=p
theta = 3 # equivalent of 1/lambda in exp. distribution
beta = 2  # beta=1 ->exponential distribution
p = 0.5
qweibull(p,shape=beta, scale=theta)

# plot - quantile function F ^(- 1)(p)=x
p = seq(from=0, to=1, by=0.01)
x = qweibull(p,shape=beta, scale=theta)
plot(p, x, type = 'l')
grid()

# * Normal distribution: $X \sim N(\mu,\sigma^2)$ ####
#
# - distribution modeling eg. measurement errors, sum/average behavior of many other
# random variables
#
# - viz. Central limit theorem
#
# - $\mu$ is the average distribution value: $E(X)=\mu$
#
# - $\sigma$ is the directly standard deviation of the distribution: $D(X)=\sigma^2$
#
# - with parameters $\mu=0,\sigma=1$ is called normalized Normal distribution
#

# Probability density f(x)
mu = 2
sigma = 3
x = 4
dnorm(x, mean=mu, sd=sigma)

# we plot the probability density
x = seq(from = -5, to = 10, by = 0.01)
f_x = dnorm(x, mean=mu, sd=sigma)
plot(x, f_x, type='l')
grid()

# Distribution function F(x)=P(X<x)
mu = 2
sigma = 3
x = 4
pnorm(x, mean=mu, sd=sigma)

# let's draw the Distribution function
x = seq(from = -5, to = 10, by = 0.01)
F_x = pnorm(x, mean=mu, sd=sigma)
plot(x, F_x, type = 'l')
grid()

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

# plot - quantile function F ^(- 1)(p)=x
p = seq(from=0, to=1, by=0.01)
x = qnorm(p, mean=mu, sd=sigma)
plot(p, x, type = 'l')
grid()

#  Examples ####
#

# * Example 1. ####
#
# Height in the population of boys aged 3.5-4 years has a normal distribution with a
# mean value of 102 cm and a standard deviation of 4.5 cm. Determine what percentage of
# boys at that age are less than or equal to 93 cm in height.
#

# X... height of boys aged 3.5 to 4 years(cm)
# X~N(mu=102, sd=4.5)

mu = 102
sigma = 4.5

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

# * Example 2. ####
#
# The average life of a machine part is 30,000 hours. Assume that the component is in a
# period of stable life. Specify:
#

# X... component life(h)
# X~Exp(lambda), where E(X)=1/lambda

lambda = 1/30000

# ** a) ####
#
# probability that the component will not last more than 2,000 hours,
#

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

# ** b) ####
#
# probability that the component will last more than 35,000 hours,
#

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

# ** c) ####
#
# time until 95% of the components fail.
#

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

# * Example 3. ####
#
# The production facility fails on average once every 2000 hours. The quantity Y
# representing the time before the fault has an exponential distribution. Determine the
# time T0 so that the probability that the device will run longer than T0 is 0.99.
#

# X... fault waiting time(h)
# X~Exp(lambda), where E(X)=1/lambda
lambda = 1/2000

# P(X>t)=0.99 ->1-F(t)=0.99 ->F(t)=0.01 ->t… 1% quant.
qexp(0.01, lambda)

# * Example 4. ####
#
# The measurement results are corrupted only with a normally distributed error with zero
# mean and a standard deviation of 3 mm. What is the probability that there will be an
# error in the interval(0 mm; 2.4 mm) at least once in 3 measurements?
#

# Y measurement error size(mm)
# Y~N(mu=0, sigma=3)

mu = 0
sigma = 3

# pp… true that the measurement error will be in int. 0.0-2.4mm
pp = pnorm(2.4,mean=mu,sd=sigma) - pnorm(0,mean=mu,sd=sigma)
pp

# X… number of measurement errors in int. 0 mm -2.4 mm in 3 measures.
# X~Bi(n=3, p=pp)
n = 3
p = pp

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

# * Example 5. ####
#
# An average of 25 users per hour log on to a large computer network. Determine the
# probability that:
#
# ** a) ####
#
# no one logs in during 14:30 - 14:36,
#

# X… number of users logged in in 6 minutes
# X~Po(lt=2.5)

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

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

# ** b) ####
#
# 2-3 minutes will elapse before the next login.
#

# Y… time until next login
# Y~Exp(lambda=25/60), where E(X)=1/lambda
lambda = 25/60

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

# ** c) ####
#
# Specify the maximum length of the time interval so that the probability that no one
# will log in is at least 0.90.
#

# P(Y>t)=0.90 ->1-F(t)=0.90 ->F(t)=0.10 ->t… 10% kv.

qexp(0.10, lambda)*60

# * Example 6. ####
#
# The random variable X has a normal distribution N(µ; σ). Specify:
#
# ** a) ####
#
# P(µ - 2σ<X<µ + 2σ),
#

# P(µ - 2σ<X<µ + 2σ)=F(µ + 2σ) - F(µ - 2σ)
# X~N(µ, σ)
# it doesn't matter what values we choose
mu = -105.5447
sigma = 2.654

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

# ** b) ####
#
# smallest k ∈ Z, so that P(µ - kσ<X<µ + kσ)>0.99.
#

# normal distribution is symmetric
# P(µ - kσ<X<µ + kσ)=
# 1 -(P(X<µ - kσ) + P(X>µ + kσ))=
# 1 - 2 * P(X>µ + kσ)=0.99 ->P(X>µ + kσ)=0.005
# ->P(X<µ + kσ)=0.995

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

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

# * Example 7. ####
#
# An accompanying film about the life of the author of the exhibited works is screened
# on a tour of the exhibition. His screening begins every 20 minutes. Determine the
# probability that if you come to the screening room at random time (and you have no
# clue about screening shedule),
#

# Y… time until the start of the next projection
# Y~Ro(a=0, b=20)

a = 0
b = 20

# ** a) ####
#
# you won't have to wait more than 5 minutes for the movie to start,
#

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

# ** b) ####
#
# you will wait between 5 and 10 minutes,
#

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

# ** c) ####
#
# mean and standard deviation of the waiting time for the beginning of the movie.
#

E_X = (a + b)/2
E_X

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

sigma_X = sqrt(D_X)
sigma_X

# * Example 8. ####
#
# During quality control, we only accept the part if its dimension is in the range of
# 26-27 mm. The dimensions of the components have a normal distribution with a mean
# value of 26.4 mm and a standard deviation of 0.2 mm. What is the probability that the
# size of the part randomly selected for inspection will be within the required limits?
#

# X... part size(mm)
# X~N(mu=26.4, sigma=0.2)

mu = 26.4
sigma = 0.2

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

# * Example 9. ####
#
# The length of jumps of the athlete Jakub measured in cm has a normal distribution
# N(µ1; σ1), where µ1=690 and σ1=10. The length of jumps of the athlete Aleš measured in
# cm also has a normal distribution N(µ2; σ2), where µ2=705 and σ2=15. The one who jumps
# more than 700 cm from two jumps at least once qualifies for the races.
#

# SJ... length of Jakub's jump
# SJ~N(mu=690, sigma=10)
mu_J = 690
sigma_J = 10

# SA Ale Aleš's jump length
# SA~N(mu=705, sigma=15)
mu_A = 705
sigma_A = 15

# J... Jakub's jump is successful(longer than 700 cm)
# And... Aleš's jump is successful(longer than 700 cm)

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

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

# KJ… Jakub qualifies for races,
# P(KJ)=1-(1-P(J))(1-P(J))
P.KJ=1-(1-P.J)*(1-P.J)
P.KJ

# KA… Aleš qualifies for races,
# P(KA)=1-(1-P(A))(1-P(A))
P.KA=1-(1-P.A)*(1-P.A)
P.KA

# ** a) ####
#
# How likely are they both to qualify for the race?
#

# ada)
P.KJ*P.KA

# ** b) ####
#
# With what probability does Aleš qualify, but Jakub does not?
#

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


plot(function(x){
  return(plnorm(x,meanlog=(log(0.1)-0.5^2/2),sdlog=0.5))
},xlim=c(0,0.6))
0.1 = exp(mulog+sdlog^2/2)
log(0.1) = mulog + sdlog^2/2
mulog = log(0.1) - sdlog^2/2
log(0.1)-0.5^2/2

plot(function(x){
  return(plnorm(x,meanlog=(log(0.1)-0.6^2/2),sdlog=0.6))
},xlim=c(0,0.6),add=TRUE)

plot(function(x){
  return(pnorm(x,mean=0.1,sd=0.025))
},xlim=c(0,0.6),add=TRUE)

plot(function(x){
  return(plnorm(x,meanlog=(log(0.1)-0.25^2/2),sdlog=0.25))
},xlim=c(0,0.6),add=TRUE)

plot(function(x){
  return(plnorm(x,meanlog=(log(0.12)-0.5^2/2),sdlog=0.5))
},xlim=c(0,0.6),add=TRUE)

plot(function(x){
  return(plnorm(x,meanlog=(log(0.12)-0.6^2/2),sdlog=0.6))
},xlim=c(0,0.6),add=TRUE)

mu.1 = 0.12
mu.2 = exp(2*(log(0.12)-0.5^2/2)+0.5^2)*(exp(0.5^2)-1) + mu.1^2
mu.1^2/(mu.2)
nlminb(1, function(x) {return((mu.1^2*gamma(1+2/x)-mu.2*gamma(1+1/x)^2)^2)})
plot(function(x) {return(((mu.1^2*gamma(1+2/x)-mu.2*gamma(1+1/x)^2)^2))},
     xlim=c(1,4))
m = 1.957465
eta = 0.12/gamma(1+1/m)
plot(function(x){
  return(pweibull(x,shape=m,scale=eta))
},xlim=c(0,0.6),add=TRUE)

mu.1 = 0.12
mu.2 = exp(2*(log(0.12)-0.6^2/2)+0.6^2)*(exp(0.6^2)-1) + mu.1^2
mu.1^2/(mu.2)
nlminb(1, function(x) {return((mu.1^2*gamma(1+2/x)-mu.2*gamma(1+1/x)^2)^2)})
plot(function(x) {return(((mu.1^2*gamma(1+2/x)-mu.2*gamma(1+1/x)^2)^2))},
     xlim=c(1,4))
m = 1.551332
eta = 0.12/gamma(1+1/m)
plot(function(x){
  return(pweibull(x,shape=m,scale=eta))
},xlim=c(0,0.6),add=TRUE)


library(simecol)
library(reshape2)
library(ggplot2)

sir.cn.ode <- new("odeModel",
  main = function(time, init, parms, ...){
    with(as.list(c(init,parms)),{
      dtheta <- -beta*theta+beta*(dpsi(theta,k)/dpsi(1,k))+gamma*(1-theta)
      S <- psi(theta,k)
      I <- 1-S-R
      dR <- gamma*I
      list(c(dtheta,dR))
    })},
  equations = list(),
  parms = c(beta=0.1,gamma=0.05,k=5),
  times = c(from=0,to=125,by=0.01),
  init = c(theta=0.999,R=0),
  solver = "lsoda"
)
poisgn <- list(
  psi = function(theta,k){theta^k},
  dpsi = function(theta,k){k*theta^(k-1)},
  dpsi2 = function(theta,k){k*(k-1)*theta^(k-2)}
)
equations(sir.cn.ode) <- poisgn
sir.cn.ode <- sim(sir.cn.ode)
sir.cn.out <- out(sir.cn.ode)
sir.cn.out$S <- sir.cn.out$theta^parms(sir.cn.ode)[["k"]]
sir.cn.out$I <- 1-sir.cn.out$S-sir.cn.out$R

sir.cn.out.long <- melt(as.data.frame(sir.cn.out),"time")

# Plot
ggplot(sir.cn.out.long,aes(x=time,y=value,colour=variable,group=variable)) +
  geom_line(lwd=2) + xlab("Time")+ylab("Number")


get_data = function(){
  std <- function(v) (v-mean(v, na.rm = TRUE))/sqrt(var(v, na.rm = TRUE))
  data = purrr::map(mtcars, std) |> dplyr::bind_cols()
  data
}

fml = "mpg ~ disp + hp + wt + qsec + am"

all_standardised = FALSE
use_nls = FALSE
first_principle = FALSE
solve_lm = FALSE

if (all_standardised) {
  data = get_data()
  fit = lm(fml, data = data); fit
  fit$coefficients
  sum(abs(fit$coefficients))

  #reverse negatives
  data$hp = -mtcars$hp
  data$wt = -mtcars$wt
  fit = lm(fml, data = data); fit
  fit$coefficients
  sum(abs(fit$coefficients))
} else {
  data = get_data()
  data$mpg = mtcars$mpg
  fit = lm(fml, data = data); fit
  fit$coefficients
  sum(abs(fit$coefficients))
}

if (use_nls) {
  data = get_data()
  fit <- nls("mpg ~ a + b1 * disp + b2 * hp + b3 * wt + b4 * qsec + b5 * am",
             data = data,
             start = list(a = 0,b1 = 0.0,b2 = 0, b3 = 0, b4=0,b5=0),
             lower = c(a = 0,b1 = 0,b2 = 0, b3 = 0,b4=0,b5=0),
             upper = c(a = Inf,b1 = Inf,b2 = Inf, b3 = Inf,b4=Inf,b5=Inf),
             algorithm = "port")

  fit
}

if(first_principle){
    Boston = MASS::Boston
    y <- Boston$medv
    X <- as.matrix(Boston[-ncol(Boston)])
    int <- rep(1, length(y))
    X <- cbind(int, X)
    betas <- solve(t(X) %*% X) %*% t(X) %*% y
    betas <- round(betas, 2)
    print(betas)
}

#to do: start with intercept
if (solve_lm) {

    data = get_data()
    data$mpg = mtcars$mpg

    fit = lm(fml, data = data); fit
    summary(fit)
    ce = fit$coefficients;ce
    abs(ce[-1])/sum(abs(ce[-1]))

    target = "mpg"
    vars = c("disp", "hp", "wt", "qsec", "am")
    X = data[vars]
    int <- rep(1, nrow(X))
    X <- cbind(int, X)
    actual = dplyr::pull(data[target])
    cons_vars = c("hp", "qsec")
    cons_idx = which(vars %in% cons_vars) + 1
    cons = c(0.2, 0.2)
    obj <- function(x){
        if (
            any(abs(x[cons_idx])/sum(abs(x[-1]))>cons)
        ){
            r <- Inf
        }else{
            preds = as.numeric(as.matrix(X) %*% x)
            r = sqrt(mean((preds - actual) ^ 2, na.rm=TRUE))
        }
        return(r)
    }

    lower <- rep(-25,length(vars)+1)
    upper <- -lower

    set.seed(0)
    DEoptim::DEoptim(obj, lower, upper)

}


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

getCovMatrix <- function(dset, expectation) {
  featureTypesCount <- dim(dset)[2]
  dsetLength <- dim(dset)[1]
  cov <- matrix(0, nrow = featureTypesCount - 1, ncol = featureTypesCount - 1)

  for (i in 1:dsetLength) {
    currentFeature <- as.matrix(dset[i, 1:featureTypesCount - 1], nrow = 1)
    tmp <- t(currentFeature - expectation) %*% (currentFeature - expectation)
    cov <- cov + tmp
  }
  cov <- cov / (dsetLength - 1)

  return(cov)
}

getLikelihood <- function(point, expectation, covMatrix) {
  pointMinusMean <- t(as.matrix(point - expectation))

  covMatrixInverse <- solve(covMatrix)
  nom <- exp(-(pointMinusMean %*% covMatrixInverse %*% t(pointMinusMean)) / 2)
  denom <- sqrt((2 * pi) ^ nrow(covMatrix) * det(covMatrix))

  return(nom / denom)
}

getPlugInProbability <- function(dset, classesColumn, className, point, lambda) {
  featuresCount <- length(point)
  croppedDset <- dset[which(dset[, classesColumn] == className), ]
  dsetLength <- dim(dset)[1]

  prior <- getPriorProbabilities(dset, classesColumn)[className]

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

  # lambda = rep(1, featuresCount)
  covMatrix <- getCovMatrix(croppedDset, matrix(expectations, nrow=1))
  likelihood <- getLikelihood(point, expectations, covMatrix)

  probability <- lambda * prior * likelihood;

  return (probability)
}

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

# mu1 <- c(0, 0)
# mu2 <- c(4, 4)
# sig1 <- matrix(c(2, 0.9, 0.9, 2), 2, 2)
# sig2 <- matrix(c(0.5, 0, 0, 2), 2, 2)
# dset1 <- mvrnorm(250, mu1, sig1)
# dset2 <- mvrnorm(250, mu2, sig2)
# dset <- rbind(cbind(dset1, 1),cbind(dset2, 2))

dset = data.frame(x = double(), y = double(), class = character())

dset <- rbind(dset, data.frame(x = 0, y = 2, class = 1))
dset <- rbind(dset, data.frame(x = 2, y = 0, class = 1))
dset <- rbind(dset, data.frame(x = 2.5, y = 2.5, class = 1))
dset <- rbind(dset, data.frame(x = 2.8, y = 2.8, class = 1))

dset <- rbind(dset, data.frame(x = 2, y = 4.5, class = 2))
dset <- rbind(dset, data.frame(x = 4.5, y = 2, class = 2))
dset <- rbind(dset, data.frame(x = 6, y = 6, class = 2))
dset <- rbind(dset, data.frame(x = 6, y = 5, class = 2))
dset <- rbind(dset, data.frame(x = 5, y = 6, class = 2))
dset <- rbind(dset, data.frame(x = 3, y = 5.5, class = 2))
dset <- rbind(dset, data.frame(x = 5.5, y = 3, class = 2))

plot(dset[ ,1], dset[ ,2], pch=21, bg=c("green","blue")[dset[ ,3]])

# print(plugInClassifier(c(0, 0), dset))
# # print(getPlugInProbability(dset, 3, 1, c(0, 0), 1))

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

all <- length(xs) * length(ys)
progress = 1
for (i in xs) {
  for (j in ys) {
    cat("\rProcessing point", progress, "of", all)
    progress <- progress + 1
    result <- plugInClassifier(c(i, j), dset)
    points(i, j, col = colors[result], pch = 21)
  }
}
cat("\rDone.                      \n")


"
Последовательно выполнить операции:
sqrt(2)*sqrt(2)
(sqrt(2)*sqrt(2))-2
Объяснить полученный результат.
"

result <- sqrt(2)*sqrt(2)
print(result)
result1 <- (sqrt(2)*sqrt(2))-2
print(result1)


#Example : 1   Chapter : 2.1  Pageno : 37
#Multiplication by rows and cols dotproduct.
multiply<-function(A,x){
  b<-c()
  for(i in 1:3){
    b<-c(b,sum(A[i,]*x[,1]))
  }
  b<-matrix(b,ncol=1)
  print(paste("Multiplying matrices by dotproduct of rows and cols"))
  print(A)
  print("*")
  print(x)
  print("=")
  print(b)
}

I<-matrix(c(1,0,0,0,1,0,0,0,1),ncol=3,byrow=T)
x<-matrix(c(4,5,6),ncol=1)
A=matrix(c(1,1,1,0,0,0,0,0,0),ncol=3)
multiply(A,x)
A<-matrix(c(1,0,0,0,1,0,0,0,1),nrow=3,ncol=3,byrow=T)
multiply(A,x)


library("tidyverse")
library("ggplot2")
library("dplyr")
library("tidyr")
library("factoextra")

data <- read_csv("datatable.csv")

selected <- data %>% select(
  median_income,
  rent_burden,
  severe_burden,
  no_rent_burden,
  commuters_by_public_transportation
)

#zero mean normalize all the columns
selected <- selected %>%
  mutate_at(c("median_income"), ~(scale(.) %>% as.vector))
selected <- selected %>%
  mutate_at(c("rent_burden"), ~(scale(.) %>% as.vector))
selected <- selected %>%
  mutate_at(c("severe_burden"), ~(scale(.) %>% as.vector))
selected <- selected %>%
  mutate_at(c("no_rent_burden"), ~(scale(.) %>% as.vector))
selected <- selected %>%
  mutate_at(c("commuters_by_public_transportation"), ~(scale(.) %>% as.vector))
selected <- selected %>%
  mutate_at(c("original_total_pop"), ~(scale(.) %>% as.vector))

selected
selected <- selected %>% drop_na()

library(ggplot2)
library(ggdendro)
summary(selected)
d <- dist(selected)
hc <- hclust(d, method = "complete")
ggdendrogram(hc, rotate = TRUE, size = 1) +
  theme(axis.text.x = element_blank(),
        axis.ticks.x = element_blank(),
        axis.text.y = element_blank(),
        axis.ticks.y = element_blank()) +
  ggtitle("Dendogram H Cluster of Rent Burden, Transportation, and Population")
ggsave("./charts/hclusterdendo.jpg", width = 6.5, height = 3)
hc_10 <- cutree(hc, 10)
table(hc_10)
p <- fviz_dend(hc, k = 10, cex = 0.01, main = "Complete H-Cluster for k=10")
ggsave("./charts/Complete_H_Clusterk_10.jpg", width = 6.5, height = 3)
p

for (i in 1:20 ){
  hc_i <- cutree(hc, i)
  print(table(hc_i))
}

hc_14 <- cutree(hc, 14)
SSE(selected, hc_14)$sumWithin

# Find the elbow
number_of_clusters <- 40
sse_scores <- rep(NA, number_of_clusters)
xValue <- 2:(number_of_clusters + 1)
for (i in xValue) {
  hc_i <- cutree(hc, i)
  sse_scores[i - 1] <- SSE(selected, hc_i)$sumWithin
}
chosen_number_of_clusters <- 15
line_data <- data.frame(xValue,sse_scores)
p <- ggplot(line_data, aes(x=xValue, y=sse_scores)) +
  geom_line(size=1, alpha=0.9, linetype=1) +
  ggtitle("SSE Scores  H Clustering of Rent, Transportation, and Population") +
  xlab("Number of Clusters") +
  ylab("SSE Score") +
  geom_vline(xintercept = chosen_number_of_clusters, linetype="dashed",
             color = "red", size=1.5) +
  geom_text(aes(x=chosen_number_of_clusters, label="15 clusters",
                y=20000), colour="black", angle=90, vjust = 1.2)
p
ggsave("./charts/ElbowHcluster1.jpg", width = 6.5, height = 3)

p <- fviz_dend(hc, k = 15, cex = 0.01, main = "Complete H-Cluster for k=15")
p
ggsave("./charts/ColoredDendo.jpg", width = 6.5, height = 3)

source("./clustering_helpers.R")

# Add back the deaths
hc_15 <- cutree(hc, 15)
table(hc_15)
selected$confirmed_cases_per1000 <- data$confirmed_cases_per1000
selected$deaths_per10000 <-  data$deaths_per1000 * 10
selected$cluster <- hc_15
p <- create_cluster_profile2(selected)
p
ggsave("./charts/ColorProfileHClust.png", plot = p,  device = "png",
       scale = 1,  width = 1200,  height = 700,  units =  "px", dpi = 100)

data$cluster <- hc_15

write.csv(data, file = "cluster_h_1.csv")

print(table(hc_15))
result <- SSE(selected, hc_15)
result$sumWithin

print(table(hc_i))

## Measure Entropy
selected$case_death_class <- catagorize_deaths(selected, 10)
selected$case_class <- catagorize_cases(selected, 10)
ret <- entropy(hc_15, catagorize_cases(selected, 10))
ret$total
ret$indv
ret <- entropy(hc_15, catagorize_deaths(selected, 10))
ret$total
ret$indv

test <- purity(hc_15, catagorize_cases(selected, 10))
test
test$total

random_10 <- sample(1:10, nrow(selected), replace = TRUE)
ret <- entropy( random_10, catagorize_deaths(selected, 15))
ret$total
ret$indv
ret <- entropy( random_10, catagorize_cases(selected, 15))
ret$total
ret$indv

# Sever Rent Burden
data <- read_csv("cluster_h_1.csv")
data$cluster <- as.factor(selected$cluster)

p <- create_box_plots_per_cluster_severe_burden(data, title="Severe Rent Burden per cluster")
p
ggsave("./charts/cluster3/sevre_rent_burden_cluster.png",  plot = p,  device = "png",
       scale = 1,  width = 1200,  height = 300,  units =  "px", dpi = 100
)
p <- create_box_plots_per_cluster_no_burden(data, title="No Rent Burden per cluster")
p
ggsave("./charts/cluster3/no_rent_burden_cluster.png",  plot = p,  device = "png",
       scale = 1,  width = 1200,  height = 300,  units =  "px", dpi = 100
)
p <- create_box_plots_per_cluster_rent_burden (data, title="Rent Burden per cluster")
p
ggsave("./charts/cluster3/rent_burden_cluster.png",  plot = p,  device = "png",
       scale = 1,  width = 1200,  height = 300,  units =  "px", dpi = 100
)
p <- create_box_plots_per_cluster_commuters_by_public_transportation (data, title="Normalized commuters_by_public_transportation_cluste")
p
ggsave("./charts/cluster3/commuters_by_public_transportation_cluster.png",  plot = p,  device = "png",
       scale = 1,  width = 1200,  height = 300,  units =  "px", dpi = 100
)

p <- create_box_plots_per_cluster_median_income (data, title="Normalized median income")
p
ggsave("./charts/cluster3/income_cluster.png",  plot = p,  device = "png",
       scale = 1,  width = 1200,  height = 300,  units =  "px", dpi = 100
)


=begin
  # sample-set01.rb

  require "algebra"
  #intersection
  p Set[0, 1, 2, 4] & Set[1, 3, 5] == Set[1]
  p Set[0, 1, 2, 4] & Set[7, 3, 5] == Set.phi

  #union
  p Set[0, 1, 2, 4] | Set[1, 3, 5] == Set[0, 1, 2, 3, 4, 5]

  #membership
  p Set[1, 3, 2].has?(1)

  #inclusion
  p Set[3, 2, 1, 3] < Set[3, 1, 4, 2, 0]
((<_|CONTENTS>))
=end


 DSBEVX Example Program Results

 Number of eigenvalues found =    2

 Eigenvalues
    -2.6633  1.7511
 Selected eigenvectors
          1       2
 1  -0.6238 -0.5635
 2   0.2575  0.3896
 3   0.5900 -0.4008
 4  -0.4308  0.5581
 5  -0.1039 -0.2421


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

fast_cvloo_knn <- function() {
  maxK <- length(iris[,1]) - 1
  classes = unique(iris$Species)

  ans <- rep(x = 0, times = maxK)
  for (i in 1:length(iris[,1])) {
    # for (i in 1:10) {
    cat("\r", "Processing sample ", i, " of ", length(iris[,1]))
    dataset <- iris[-i,]
    # print(dataset)
    distance <- array(dim=c(length(dataset[,1])))
    for (j in 1:(length(dataset[,1]))) {
      distance[j] <- euclidean(dataset[j, 1:4], iris[i, 1:4])
    }
    sortedDataset <- irisSubset[order(distance),]

    classesCount <- rep(x = 0, times = length(classes))
    names(classesCount) = classes
    for (j in 1:maxK) {
      classesCount[sortedDataset$Species[j]] <- classesCount[sortedDataset$Species[j]] + 1

      classForCurrentK = names(which.max(classesCount))[1]
      if (classForCurrentK == iris$Species[i]) {
        ans[j] = ans[j] + 1
      }
    }

  }
  cat("\n")
  for (i in 1:length(ans)) {

    ans[i] = ans[i] / length(iris[,1] - 1)
  }

  return (ans)
}

stats <- fast_cvloo_knn()

print(stats)
print(paste("The best K: ", which.max(stats)))

par(mfrow=c(1,1))
plot(1:(length(iris[,1]) - 1), stats, type="l", xlab="k", ylab="Accuracy")

-1 - Fast CV LOO implementation, the best K search for 1-4 iris features/-1.r


## Author: Sergio García Prado

rm(list = ls())

## a)
####

## Asymptotic distibution of (lambda1.hat, lambda2.hat) as parameters lambda1 of Pois(lambda1) and
## lambda2 of Pois(lambda2) independent of each other.
##
## (lambda1.hat, lambda2.hat) ~ N_2( (lambda1, lambda2) , [lambda1 / n, 0;
##                                                         0, lambda2 / n] )
##

## b)
####
n1 <- 50
y1 <- 75

n2 <- 50
y2 <- 100

n <- c(n1, n2)
y <- c(y1, y2)

alpha <- 0.05

LogLikelihood <- function(lambda, y, n) {
  sum(y * log(lambda) - n * lambda)
}

NegativeLogLikelihood <- function(...) {
  - LogLikelihood(...)
}

opt <- optim(runif(2), NegativeLogLikelihood, y = y, n = n, hessian = TRUE)

(lambda.hat <- opt$par)
#

(lambda.hat.var <- solve(opt$hessian))
#
#

g.transform <- c(-2, 1)

(g.hat <- (g.transform %*% lambda.hat)[1])
#

(g.hat.var <- (g.transform %*% lambda.hat.var %*% g.transform)[1])
#

## Wald's Confidence Interval at (1 - alpha)% level.
g.hat + c(-1, 1) * qnorm(1 - alpha / 2) * sqrt(g.hat.var)
#

## b)
####
g.zero <- 0

(W <- (g.hat - g.zero) ^ 2 / g.hat.var)
#

(W.pvalue <- 1 - pchisq(W, df = 1))
#

## b)
####

LogLikelihoodHZero <- function(ll, ...) {
  LogLikelihood(c(2 * ll, ll), ...)
}

NegativeLogLikelihoodHZero <- function(...) {
  - LogLikelihoodHZero(...)
}

opt.hzero <- optim(runif(1), NegativeLogLikelihoodHZero, y = y, n = n,
                   lower = 10e-3, upper = 10e3, method = "Brent")

(LRT <- 2 * (LogLikelihood(lambda.hat, y, n) - LogLikelihoodHZero(opt.hzero$par, y, n)))
#

(LRT.pvalue <- 1 - pchisq(LRT, df = 1))
#


# Chapter 1 Conditional Flow
# Comparison of logicals
TRUE == FALSE
# FALSE

# Comparison of numerics
-6*14 != 17-101
# FALSE

# Comparison of character strings
"useR" == "user"
# FALSE

# Compare a logical with a numeric
TRUE == 1
# TRUE

# Comparison of numerics
-6*5+2 >= -10+1
# FALSE

# Comparison of character strings
"raining" <= "raining dogs"
# TRUE

# Comparison of logicals
TRUE > FALSE
# TRUE

# The linkedin and facebook vectors have already been created for you
linkedin <- c(16, 9, 13, 5, 2, 17, 14)
facebook <- c(17, 7, 5, 16, 8, 13, 14)

# Popular days
linkedin > 15
# TRUE FALSE FALSE FALSE FALSE  TRUE FALSE

# Quiet days
linkedin <= 5
# FALSE FALSE FALSE  TRUE  TRUE FALSE FALSE

# LinkedIn more popular than Facebook
linkedin > facebook
# FALSE  TRUE  TRUE FALSE FALSE  TRUE FALSE

# The social data has been created for you
linkedin <- c(16, 9, 13, 5, 2, 17, 14)
facebook <- c(17, 7, 5, 16, 8, 13, 14)
views <- matrix(c(linkedin, facebook), nrow = 2, byrow = TRUE)

# When does views equal 13?
views == 13
#       [,1]  [,2]  [,3]  [,4]  [,5]  [,6]  [,7]
# [1,] FALSE FALSE  TRUE FALSE FALSE FALSE FALSE
# [2,] FALSE FALSE FALSE FALSE FALSE  TRUE FALSE

# When is views less than or equal to 14?
views <= 14
#       [,1] [,2] [,3]  [,4] [,5]  [,6] [,7]
# [1,] FALSE TRUE TRUE  TRUE TRUE FALSE TRUE
# [2,] FALSE TRUE TRUE FALSE TRUE  TRUE TRUE

# The linkedin and last variable are already defined for you
linkedin <- c(16, 9, 13, 5, 2, 17, 14)
last <- tail(linkedin, 1)

# Is last under 5 or above 10?
last < 5 | last > 10
# TRUE

# Is last between 15 (exclusive) and 20 (inclusive)?
last > 15 & last <= 20
# FALSE

# The social data (linkedin, facebook, views) has been created for you
ls()

# linkedin exceeds 10 but facebook below 10
linkedin > 10 & facebook < 10
# FALSE FALSE  TRUE FALSE FALSE FALSE FALSE

# When were one or both visited at least 12 times?
linkedin >= 12 | facebook >= 12
# TRUE FALSE  TRUE  TRUE FALSE  TRUE  TRUE

# When is views between 11 (exclusive) and 14 (inclusive)?
views > 11 & views <= 14
#       [,1]  [,2]  [,3]  [,4]  [,5]  [,6] [,7]
# [1,] FALSE FALSE  TRUE FALSE FALSE FALSE TRUE
# [2,] FALSE FALSE FALSE FALSE FALSE  TRUE TRUE

# li_df is pre-loaded in your workspace
ls()
str(li_df)

# Select the second column, named day2, from li_df: second
second <- li_df$day2
# [1]  3 23 18 18 25 20  4  3 22 12 27 13 17 27  6 35 17  6  1 12 15 17 12  8  7
# [26] 25 15 32 29  1 22 11  5 17 12 26 13 10 37 33 19 29  8 22 10 19 27 18 15 28

# Build a logical vector, TRUE if value in second is extreme: extremes
extremes <- second > 25 | second < 5

# Count the number of TRUEs in extremes
sum(extremes)
# 16

# Variables related to your last day of recordings
medium <- "LinkedIn"
num_views <- 14

# Control structure for medium
if (medium == "LinkedIn") {
  print("Showing LinkedIn information")
} else if (medium == "Facebook") {
  # Add code to print correct string when condition is True
  print("Showing Facebook information")
} else {
  print("Unknown medium")
}

# Control structure for num_views
if (num_views > 15) {
  print("You're popular!")
} else if (num_views <= 15 & num_views > 10) {
  # Add code to print correct string when condition is TRUE
  print("Your number of views is average")
} else {
  print("Try to be more visible!")
}

# Variables related to your last day of recordings
li <- 15
fb <- 9

# Code the control-flow construct
if (li > 15 & fb > 15) {
    sms <- c(sum(li) * 2 + sum(fb) * 2)
} else if (li < 10 & fb < 10) {
    sms <- c(sum(li) / 2 + sum(fb) / 2)
} else {
    sms <- c(sum(li) + sum(fb))
}

# Print the resulting sms to the console
sms

#
#
#
#
#
# Chapter 2 Loop
# Initialize the speed variable
speed <- 64

# Code the while loop
while ( speed > 30) {
  print("Slow down!")
  speed = speed -7
}

# Extend/adapt the while loop
while (speed > 30) {
  print(paste("Your speed is",speed))
  if (speed > 48 ) {
    print("Slow down big time!")
    speed = speed - 11
  } else {
    print("Slow down!")
    speed = speed - 6
  }
}

# Initialize the speed variable
speed <- 88

while (speed > 30) {
  print(paste("Your speed is", speed))

  # Break the while loop when speed exceeds 80
  if (speed > 80) {
    break
  }

  if (speed > 48) {
    print("Slow down big time!")
    speed <- speed - 11
  } else {
    print("Slow down!")
    speed <- speed - 6
  }
}

# Initialize i as 1
i <- 1

# Code the while loop
while (i <= 10) {
  print(3 * i)
  if ((3 * i %% 8) == 0) {
    break
  }
  i <- i + 1
}

# The linkedin vector has already been defined for you
linkedin <- c(16, 9, 13, 5, 2, 17, 14)

# Loop version 1
for ( i in linkedin){
    print(i)
}

# Loop version 2
for (i in 1:length(linkedin)) {
    print(linkedin[i])
}

# The nyc list is already specified
nyc <- list(pop = 8405837,
            boroughs = c("Manhattan", "Bronx", "Brooklyn", "Queens", "Staten Island"),
            capital = FALSE)

# Loop version 1
for (i in nyc) {
    print(i)
}

# Loop version 2
for (i in 1:length(nyc)) {
    print(nyc[[i]])
}

# The tic-tac-toe matrix ttt has already been defined for you
#      [,1] [,2] [,3]
# [1,] "O"  NA   "X"
# [2,] NA   "O"  "O"
# [3,] "X"  NA   "X"

# define the double for loop
for (x in 1:nrow(ttt)){
    for (y in 1:ncol(ttt)){
        print(paste("On row ", x, " and column ", y, " the board contains ", ttt[x,y]))
    }
}

for (li in linkedin) {
  if (li > 10) {
    print("You're popular!")
  } else {
    print("Be more visible!")
  }

  # Add if statement with break
  if (li > 16){
    print("This is ridiculous, I'm outta here!")
    break
  }

  # Add if statement with next
  if (li < 5) {
    print("This is too embarrassing!")
    next
  }

  print(li)
}

# Pre-defined variables
rquote <- "r's internals are irrefutably intriguing"
chars <- strsplit(rquote, split = "")[[1]]

# Initialize rcount
rcount <- 0

# Finish the for loop
for (char in chars) {
  if (char == "r"){
    rcount <- rcount + 1
  } else if (char == "u") {
    break
  }
}

# Print out rcount
print(rcount)

#
#
#
#
#
# Chapter 3 Functions
# The linkedin and facebook vectors have already been created for you
linkedin <- c(16, 9, 13, 5, 2, 17, 14)
facebook <- c(17, 7, 5, 16, 8, 13, 14)

# Calculate the mean of the sum
avg_sum <- sum(mean(linkedin + facebook))
# 22.28571

# Calculate the trimmed mean of the sum
avg_sum_trimmed <- sum(mean(linkedin + facebook,trim = 0.2))
# 22.6

# The linkedin and facebook vectors have already been created for you
linkedin <- c(16, 9, 13, 5, NA, 17, 14)
facebook <- c(17, NA, 5, 16, 8, 13, 14)

# Basic average of linkedin
print(mean(linkedin))
# NA

# Advanced average of linkedin
print(mean(linkedin, na.rm = TRUE ))
# 12.33333

# Calculate the mean absolute deviation
print(mean(abs(linkedin - facebook),na.rm = TRUE))
# 4.8

# Create a function pow_two()
pow_two <- function(x) {
    x**2
}

# Use the function
pow_two(12)

# Create a function sum_abs()
sum_abs <- function(x, y) {
    abs(x) + abs(y)
}

# Use the function
sum_abs(-2, 3)

# Define the function hello()
hello <- function() {
    print("Hi there!")
    return(TRUE)
}

# Call the function hello()
hello()

# Define the function my_filter()
my_filter <- function(x) {
    if (x > 0) {
        return(x)
    } else {
        return(NULL)
    }
}

# Finish the pow_two() function
pow_two <- function(x, print_info = TRUE) {
  y <- x ^ 2

  # Add if construct
  if (print_info == TRUE) {
    print(paste(x, "to the power two equals", y))
  }

  return(y)
}

two_dice <- function() {
  possibilities <- 1:6
  dice1 <- sample(possibilities, size = 1)
  dice2 <- sample(possibilities, size = 1)
  dice1 + dice2
}

# The linkedin and facebook vectors have already been created for you

# Define the interpret function
interpret <- function(num_views) {
  if (num_views > 15) {
    print("You're popular!")
    return(num_views)
  } else {
    print("Try to be more visible!")
    return(0)
  }
}

# Call the interpret function twice
interpret(linkedin)
# [1] "You're popular!"
# [1] 16  9 13  5  2 17 14
interpret(facebook[2])
# [1] "Try to be more visible!"
# [1] 0

# Define the interpret_all() function
# views: vector with data to interpret
# return_sum: return total number of views on popular days?
interpret_all <- function(views, return_sum = TRUE) {
  count <- 0

  for (v in views) {
    count <- count + interpret(v)
  }

  if (return_sum) {
    return(count)
  } else {
    return(NULL)
  }
}

# Call the interpret_all() function on both linkedin and facebook
interpret_all(linkedin)
# [1] "You're popular!"
# [1] "Try to be more visible!"
# [1] "Try to be more visible!"
# [1] "Try to be more visible!"
# [1] "Try to be more visible!"
# [1] "You're popular!"
# [1] "Try to be more visible!"
# [1] 33
interpret_all(facebook)
# [1] "You're popular!"
# [1] "Try to be more visible!"
# [1] "Try to be more visible!"
# [1] "You're popular!"
# [1] "Try to be more visible!"
# [1] "Try to be more visible!"
# [1] "Try to be more visible!"
# [1] 33

# The mtcars vectors have already been prepared for you
wt <- mtcars$wt
hp <- mtcars$hp

# Request the currently attached packages
search()

# Load the ggplot2 package
library(ggplot2)

# Retry the qplot() function
qplot(wt)
qplot(hp)

# Check out the currently attached packages again
search()

#
#
#
#
#
# Chapter 4 The Apply Family
# The vector pioneers has already been created for you
pioneers <- c("GAUSS:1777", "BAYES:1702", "PASCAL:1623", "PEARSON:1857")

# Split names from birth year
split_math <- strsplit(pioneers, split = ":")
# List of 4
#  $ : chr [1:2] "GAUSS" "1777"
#  $ : chr [1:2] "BAYES" "1702"
#  $ : chr [1:2] "PASCAL" "1623"
#  $ : chr [1:2] "PEARSON" "1857"

# Convert to lowercase strings: split_low
split_low <- lapply(split_math, tolower)
# List of 4
#  $ : chr [1:2] "gauss" "1777"
#  $ : chr [1:2] "bayes" "1702"
#  $ : chr [1:2] "pascal" "1623"
#  $ : chr [1:2] "pearson" "1857"

# Write function select_first()
select_first <- function(x) {
  x[1]
}

# Apply select_first() over split_low: names
names <- lapply(split_low,select_first)
# [[1]]
# [1] "gauss"

# [[2]]
# [1] "bayes"

# [[3]]
# [1] "pascal"

# [[4]]
# [1] "pearson"

# Write function select_second()
select_second <- function(x) {
  x[2]
}

# Apply select_second() over split_low: years
years <- lapply(split_low,select_second)
# [[1]]
# [1] "1777"

# [[2]]
# [1] "1702"

# [[3]]
# [1] "1623"

# [[4]]
# [1] "1857"

# Transform: use anonymous function inside lapply
names <- lapply(split_low, function(x) {x[1]})

# Transform: use anonymous function inside lapply
years <- lapply(split_low, function(x) {x[2]})

# Generic select function
select_el <- function(x, index) {
  x[index]
}

# Use lapply() twice on split_low: names and years
names <- lapply(split_low, select_el, index = 1)
years <- lapply(split_low, select_el, index = 2)

# Use lapply() to find each day's minimum temperature
lapply(temp,min)

# Use sapply() to find each day's minimum temperature
sapply(temp,min)

# Use lapply() to find each day's maximum temperature
lapply(temp,max)

# Use sapply() to find each day's maximum temperature
sapply(temp,max)

# temp is already defined in the workspace

# Finish function definition of extremes_avg
extremes_avg <- function(x) {
  ( min(x) + max(x) ) / 2
}

# Apply extremes_avg() over temp using sapply()
sapply(temp, extremes_avg)
# 4.0 9.0 2.5 2.5 5.5 3.0 5.0

# Apply extremes_avg() over temp using lapply()
lapply(temp, extremes_avg)
# [[1]]
# [1] 4

# [[2]]
# [1] 9

# [[3]]
# [1] 2.5

# [[4]]
# [1] 2.5

# [[5]]
# [1] 5.5

# [[6]]
# [1] 3

# [[7]]
# [1] 5

# Create a function that returns min and max of a vector: extremes
extremes <- function(x) {
  c(min = min(x), max = max(x))
}

# Apply extremes() over temp with sapply()
sapply(temp, extremes)
#     [,1] [,2] [,3] [,4] [,5] [,6] [,7]
# min   -1    5   -3   -2    2   -3    1
# max    9   13    8    7    9    9    9

# Apply extremes() over temp with lapply()
lapply(temp, extremes)
# [[1]]
# min max
#  -1   9

# [[2]]
# min max
#   5  13

# [[3]]
# min max
#  -3   8

# [[4]]
# min max
#  -2   7

# [[5]]
# min max
#   2   9

# [[6]]
# min max
#  -3   9

# [[7]]
# min max
#   1   9

# Definition of below_zero()
below_zero <- function(x) {
  return(x[x < 0])
}

# Apply below_zero over temp using sapply(): freezing_s
freezing_s <- sapply(temp, below_zero)
# [[1]]
# [1] -1

# [[2]]
# numeric(0)

# [[3]]
# [1] -1 -3

# [[4]]
# [1] -2

# [[5]]
# numeric(0)

# [[6]]
# [1] -3

# [[7]]
# numeric(0)

# Apply below_zero over temp using lapply(): freezing_l
freezing_l <- lapply(temp, below_zero)
# [[1]]
# [1] -1

# [[2]]
# numeric(0)

# [[3]]
# [1] -1 -3

# [[4]]
# [1] -2

# [[5]]
# numeric(0)

# [[6]]
# [1] -3

# [[7]]
# numeric(0)

# Are freezing_s and freezing_l identical?
identical(freezing_s, freezing_l)
# TRUE

# Definition of print_info()
print_info <- function(x) {
  cat("The average temperature is", mean(x), "\n")
}

# Apply print_info() over temp using lapply()
xl <- lapply(temp, print_info)
# The average temperature is 4.8
# The average temperature is 9
# The average temperature is 2.2
# The average temperature is 2.4
# The average temperature is 5.4
# The average temperature is 4.6
# The average temperature is 4.6
# [[1]]
# NULL

# [[2]]
# NULL

# [[3]]
# NULL

# [[4]]
# NULL

# [[5]]
# NULL

# [[6]]
# NULL

# [[7]]
# NULL
# Apply print_info() over temp using sapply()
xs <- sapply(temp, print_info)
# The average temperature is 4.8
# The average temperature is 9
# The average temperature is 2.2
# The average temperature is 2.4
# The average temperature is 5.4
# The average temperature is 4.6
# The average temperature is 4.6
# [[1]]
# NULL

# [[2]]
# NULL

# [[3]]
# NULL

# [[4]]
# NULL

# [[5]]
# NULL

# [[6]]
# NULL

# [[7]]
# NULL

# Great! Notice here that, quite surprisingly,
# sapply() does not simplify the list of NULL's.
# That's because the 'vector-version' of a list of
# NULL's would simply be a NULL, which is no longer
# a vector with the same length as the input.

# Definition of basics()
basics <- function(x) {
  c(min = min(x), mean = mean(x), max = max(x))
}

# Apply basics() over temp using vapply()
vapply(temp, basics, numeric(3))
#      [,1] [,2] [,3] [,4] [,5] [,6] [,7]
# min  -1.0    5 -3.0 -2.0  2.0 -3.0  1.0
# mean  4.8    9  2.2  2.4  5.4  4.6  4.6
# max   9.0   13  8.0  7.0  9.0  9.0  9.0

# Convert to vapply() expression
sapply(temp, max)
vapply(temp, max, numeric(1))
# [1]  9 13  8  7  9  9  9

# Convert to vapply() expression
sapply(temp, function(x, y) { mean(x) > y }, y = 5)
vapply(temp, function(x, y) { mean(x) > y }, y = 5, logical(1))
# [1] FALSE  TRUE FALSE FALSE  TRUE FALSE FALSE

# work_todos and fun_todos have already been defined
work_todos <- c("Schedule call with team",
                "Fix error in Recommendation System",
                "Respond to Marc from IT")
fun_todos <- c("Sleep", "Make arrangements for summer trip")

# Create a list: todos
todos <- list(work_todos, fun_todos)

# Sort the vectors inside todos alphabetically
sapply(todos, sort)
# [[1]]
# [1] "Fix error in Recommendation System" "Respond to Marc from IT"
# [3] "Schedule call with team"

# [[2]]
# [1] "Make arrangements for summer trip" "Sleep"

#
#
#
#
#
# Chapter 5 Utilities
# abs(): calculate the absolute value.
# sum(): calculate the sum of all the values in a data structure.
# mean(): calculate the arithmetic mean.
# round(): Round the values to 0 decimal places by default.
# seq(): Generate sequences, by specifying the from, to and by arguments.
# rep(): Replicate elements of vectors and lists.
# sort(): Sort a vector in ascending order. Works on numerics, but also on character strings and logicals.
# rev(): Reverse the elements in a data structures for which reversal is defined.
# str(): Display the structure of any R object.
# append(): Merge vectors or lists.
# is.*(): Check for the class of an R object.
# as.*(): Convert an R object from one class to another.
# unlist(): Flatten (possibly embedded) lists to produce a vector.

# The errors vector has already been defined for you
errors <- c(1.9, -2.6, 4.0, -9.5, -3.4, 7.3)

# Sum of absolute rounded values of errors
round(sum(abs(errors)), digits = 0)
# 29

# The linkedin and facebook vectors have already been created for you
linkedin <- list(16, 9, 13, 5, 2, 17, 14)
facebook <- list(17, 7, 5, 16, 8, 13, 14)

# Convert linkedin and facebook to a vector: li_vec and fb_vec
li_vec <- unlist(linkedin)
fb_vec <- unlist(facebook)

# Append fb_vec to li_vec: social_vec
social_vec <- append(li_vec, fb_vec)

# Sort social_vec
sort(social_vec, decreasing = TRUE)
# [1] 17 17 16 16 14 14 13 13  9  8  7  5  5  2

# Create first sequence: seq1
seq1 <- seq(1,500,3)

# Create second sequence: seq2
seq2 <- seq(1200,900,-7)

# Calculate total sum of the sequences
sum(seq1,seq2)
# [1] 87029

# The emails vector has already been defined for you
emails <- c("john.doe@ivyleague.edu", "education@world.gov", "dalai.lama@peace.org",
            "invalid.edu", "quant@bigdatacollege.edu", "cookie.monster@sesame.tv")

# Use grepl() to match for "edu"
grepl("edu",emails)
# [1]  TRUE  TRUE FALSE  TRUE  TRUE FALSE

# Use grep() to match for "edu", save result to hits
hits <- grep("edu", emails)
# [1] 1 2 4 5

# Subset emails using hits
emails[hits]
# [1] "john.doe@ivyleague.edu"   "education@world.gov"
# [3] "invalid.edu"              "quant@bigdatacollege.edu"

# @, because a valid email must contain an at-sign.
# .*, which matches any character (.) zero or more times (*).
# Both the dot and the asterisk are metacharacters. You can use them to match any character between the at-sign and the ".edu" portion of an email address.
# \\.edu$, to match the ".edu" part of the email at the end of the string. The \\ part escapes the dot: it tells R that you want to use the . as an actual character.

# Use grepl() to match for .edu addresses more robustly
grepl("@.*\\.edu$",emails)
# [1]  TRUE FALSE FALSE FALSE  TRUE FALSE

# Use grep() to match for .edu addresses more robustly, save result to hits
hits <- grep("@.*\\.edu$",emails)

# Subset emails using hits
emails[hits]
# [1] "john.doe@ivyleague.edu"   "quant@bigdatacollege.edu"

# Use sub() to convert the email domains to datacamp.edu
sub("@.*\\.edu$","@datacamp.edu",emails)
# [1] "john.doe@datacamp.edu"    "education@world.gov"
# [3] "dalai.lama@peace.org"     "invalid.edu"
# [5] "quant@datacamp.edu"       "cookie.monster@sesame.tv"

# .*: A usual suspect! It can be read as "any character that is matched zero or more times".
# \\s: Match a space. The "s" is normally a character, escaping it (\\) makes it a metacharacter.
# [0-9]+: Match the numbers 0 to 9, at least once (+).
# ([0-9]+): The parentheses are used to make parts of the matching string available to define the replacement.
# The \\1 in the replacement argument of sub() gets set to the string that is captured by the regular expression [0-9]+.

awards <- c("Won 1 Oscar.",
  "Won 1 Oscar. Another 9 wins & 24 nominations.",
  "1 win and 2 nominations.",
  "2 wins & 3 nominations.",
  "Nominated for 2 Golden Globes. 1 more win & 2 nominations.",
  "4 wins & 1 nomination.")

sub(".*\\s([0-9]+)\\snomination.*$", "\\1", awards)

# [1] "Won 1 Oscar." "24"           "2"            "3"            "2"
# [6] "1"

# %Y: 4-digit year (1982)
# %y: 2-digit year (82)
# %m: 2-digit month (01)
# %d: 2-digit day of the month (13)
# %A: weekday (Wednesday)
# %a: abbreviated weekday (Wed)
# %B: month (January)
# %b: abbreviated month (Jan)
# Definition of character strings representing dates
str1 <- "May 23, '96"
str2 <- "2012-03-15"
str3 <- "30/January/2006"

# Convert the strings to dates: date1, date2, date3
date1 <- as.Date(str1, format = "%b %d, '%y")
date2 <- as.Date(str2, format = "%Y-%m-%d")
date3 <- as.Date(str3, format = "%d/%B/%Y")

# Convert dates to formatted strings
format(date1, "%A")
# [1] "Thursday"
format(date2, "%d")
# [1] "15"
format(date3, "%b %Y")
# [1] "Jan 2006"

# %H: hours as a decimal number (00-23)
# %M: minutes as a decimal number
# %S: seconds as a decimal number
# %T: shorthand notation for the typical format %H:%M:%S

# Definition of character strings representing times
str1 <- "May 23, '96 hours:23 minutes:01 seconds:45"
str2 <- "2012-3-12 14:23:08"

# Convert the strings to POSIXct objects: time1, time2
time1 <- as.POSIXct(str1, format = "%B %d, '%y hours:%H minutes:%M seconds:%S")
time2 <- as.POSIXct(str2, format = "%Y-%m-%d %T")

# Convert times to formatted strings
format(time1, format = "%M")
# [1] "01"
format(time2, format = "%I:%M %p" )
# [1] "02:23 PM"

# day1, day2, day3, day4 and day5 are already available in the workspace

# Difference between last and first pizza day
day5-day1
# Time difference of 11 days

# Create vector pizza
pizza <- c(day1, day2, day3, day4, day5)

# Create differences between consecutive pizza days: day_diff
day_diff <- diff(pizza)
# Time differences in days
# [1]  -5  11 -13  18

# Average period between two consecutive pizza days
mean(day_diff)
# Time difference of 2.75 days

# login and logout are already defined in the workspace
# Calculate the difference between login and logout: time_online
time_online <- logout - login

# Inspect the variable time_online
time_online
# Time differences in secs
# [1] 2305.11818   34.18472  837.18182 2397.90153 1851.30411

# Calculate the total time online
sum(time_online)
# Time difference of 7425.69 secs

# Calculate the average time online
mean(time_online)
# Time difference of 1485.138 secs

# Convert astro to vector of Date objects: astro_dates
#        spring        summer          fall        winter
# "20-Mar-2015" "25-Jun-2015" "23-Sep-2015" "22-Dec-2015"
astro_dates <- as.Date(astro, format = "%d-%b-%Y")
# [1] "2015-03-20" "2015-06-25" "2015-09-23" "2015-12-22"

# Convert meteo to vector of Date objects: meteo_dates
    #        spring            summer              fall            winter
    # "March 1, 15"      "June 1, 15" "September 1, 15"  "December 1, 15"
meteo_dates <- as.Date(meteo, format = "%B %d, %y")
# [1] "2015-03-01" "2015-06-01" "2015-09-01" "2015-12-01"

# Calculate the maximum absolute difference between astro_dates and meteo_dates
max(abs(astro_dates-meteo_dates))
# Time difference of 24 days


#Let's create 2 discrete variables
a=c(1,1,3,4,5,5,1,1,2,3,4,1,3,2,1,1,5,1,4,3,2,3,1,0,2)
b=c(1,2,3,5,5,5,2,1,1,3,4,3,3,4,1,1,4,1,4,2,2,3,0,0,1)

#I count the occurence of each couple of values. Eg : number of time a=1 and b=1, number of time a=1 and b=2 etc...
AA=xyTable(a,b)

#Now I can plot this ! I represent the dots as big as the couple occurs often
png("#5_cor_between_discrete_values.png" ,  width = 480, height = 480)
coeff_bigger=2
plot(AA$x , AA$y , cex=AA$number*coeff_bigger  , pch=16 , col=rgb(0,0,1,0.5) , xlab= "value of a" , ylab="value of b" , xlim=c(0,6) , ylim=c(0,6) )
text (AA$x , AA$y , AA$number )

#Note : It's easy to make a function that will compute this kind of plot automaticaly :
represent_discrete_variable=function(var1, var2 , coeff_bigger){
  AA=xyTable(var1,var2)
  plot(AA$x , AA$y , cex=AA$number*coeff_bigger  , pch=16 , col="chocolate1" , xlab= "value of a" , ylab="value of b" )
  text (AA$x , AA$y , AA$number )
}
dev.off()


################################################################################
# Monte Carlo Simulation and Resampling Methods for Social Science             #
# Thomas M. Carsey and Jeffrey J. Harden                                       #
# Chapter 6 File                                                               #
# Last update: 2/28/13                                                         #
################################################################################
# Set the working directory
setwd("C:/Users/jjharden/Dropbox/Research/Sim Book")

# OLS as a Probability Model
set.seed(123456) # Set the seed for reproducible results

reps <- 1000 # Set the number of repetitions at the top of the script
par.est <- matrix(NA, nrow = reps, ncol = 4) # Empty matrix to store the
                                             # estimates
b0 <- .2 # True value for the intercept
b1 <- .5 # True value for the slope
n <- 1000 # Sample size
X <- runif(n, -1, 1) # Create a sample of n observations on the
                     # independent variable X

for(i in 1:reps){ # Start the loop
Y <- rnorm(n, b0 + b1*X, 1) # The true DGP, Y ~ N(mu, sigma)
model <- lm(Y ~ X) # Estimate OLS model
vcv <- vcov(model) # Variance-covariance matrix
par.est[i, 1] <- model$coef[1] # Put the estimate for the intercept
                               # in the first column
par.est[i, 2] <- model$coef[2] # Put the estimate for the coefficient on
                               # X in the second column
par.est[i, 3] <- sqrt(diag(vcv)[1]) # SE of the intercept
par.est[i, 4] <- sqrt(diag(vcv)[2]) # SE of the coefficient on X
} # End the loop

# Logit
# Inverse Logit Function
inv.logit <- function(p){
return(exp(p)/(1 + exp(p)))
}

# CP Function
coverage <- function(b, se, true, level = .95, df = Inf){ # Estimate,
                                                          # standard error,
                                                          # true parameter,
                                                          # confidence level,
                                                          # and df
qtile <- level + (1 - level)/2 # Compute the proper quantile
lower.bound <- b - qt(qtile, df = df)*se # Lower bound
upper.bound <- b + qt(qtile, df = df)*se # Upper bound
# Is the true parameter in the confidence interval? (yes = 1)
true.in.ci <- ifelse(true >= lower.bound & true <= upper.bound, 1, 0)
cp <- mean(true.in.ci) # The coverage probability
mc.lower.bound <- cp - 1.96*sqrt((cp*(1 - cp))/length(b)) # Monte Carlo error
mc.upper.bound <- cp + 1.96*sqrt((cp*(1 - cp))/length(b))
return(list(coverage.probability = cp, # Return results
            true.in.ci = true.in.ci,
            ci = cbind(lower.bound, upper.bound),
            mc.eb = c(mc.lower.bound, mc.upper.bound)))
}

set.seed(32945) # Set the seed for reproducible results

reps <- 1000 # Set the number of repetitions at the top of the script
par.est.logit <- matrix(NA, nrow = reps, ncol = 4) # Empty matrix to store
                                                   # the estimates
b0 <- .2 # True value for the intercept
b1 <- .5 # True value for the slope
n <- 1000 # Sample size
X <- runif(n, -1, 1) # Create a sample of n observations on the
                     # independent variable X

for(i in 1:reps){ # Start the loop
Y <- rbinom(n, 1, inv.logit(b0 + b1*X)) # The true DGP, Bernoulli trials
model <- glm(Y ~ X, family = binomial (link = logit)) # Estimate logit model
vcv <- vcov(model) # Variance-covariance matrix
par.est.logit[i, 1] <- model$coef[1] # Put the estimate for the
                                     # intercept in the first column
par.est.logit[i, 2] <- model$coef[2] # Put the estimate for the coefficient
                                     # on X in the second column
par.est.logit[i, 3] <- sqrt(diag(vcv)[1]) # SE of the intercept
par.est.logit[i, 4] <- sqrt(diag(vcv)[2]) # SE of the coefficient on X
} # End the loop

cp.beta0.logit <- coverage(par.est.logit[ , 1], par.est.logit[ , 3], b0,
 df = n - model$rank)
cp.beta1.logit <- coverage(par.est.logit[ , 2], par.est.logit[ , 4], b1,
 df = n - model$rank)

pdf("logit-hist1.pdf")

par(mar = c(5, 5.25, .5, .5))
hist(par.est.logit[ , 1], breaks = 25, col = "gray50", ylim = c(0, 150),
 xlab = "", ylab = "", main = "", axes = FALSE)
axis(1, cex.axis = 1.25)
axis(2, cex.axis = 1.25, las = 2)
title(xlab = expression(hat(beta[0])), cex.lab = 1.5)
title(ylab = expression("Frequency"), line = 3.75, cex.lab = 1.5)
abline(v = b0, lwd = 4)
text(.05, 70, expression("True"~beta[0]~"= 0.20"), cex = 1.5)
box()

dev.off()

pdf("logit-hist2.pdf")

par(mar = c(5, 5.25, .5, .5))
hist(par.est.logit[ , 2], breaks = 25, xlim = c(.1, .9), col = "gray50",
 ylim = c(0, 200), xlab = "", ylab = "", main = "", axes = FALSE)
axis(1, at = seq(.1, .9, .1), cex.axis = 1.25)
axis(2, cex.axis = 1.25, las = 2)
title(xlab = expression(hat(beta)[1]), cex.lab = 1.5)
title(ylab = expression("Frequency"), line = 3.75, cex.lab = 1.5)
abline(v = b1, lwd = 4)
text(.75, 125, expression("True"~beta[1]~"= 0.50"), cex = 1.5)
box()

dev.off()

# Probit
set.seed(3295255) # Set the seed for reproducible results

reps <- 1000 # Set the number of repetitions at the top of the script
par.est.probit <- matrix(NA, nrow = reps, ncol = 4) # Empty matrix to store
                                                   # the estimates
b0 <- .2 # True value for the intercept
b1 <- .5 # True value for the slope
n <- 1000 # Sample size
X <- runif(n, -1, 1) # Create a sample of n observations on the
                     # independent variable X

for(i in 1:reps){ # Start the loop
Y <- rbinom(n, 1, pnorm(b0 + b1*X)) # The true DGP, Bernoulli trials
model <- glm(Y ~ X, family = binomial (link = probit)) # Estimate probit model
vcv <- vcov(model) # Variance-covariance matrix
par.est.probit[i, 1] <- model$coef[1] # Put the estimate for the
                                      # intercept in the first column
par.est.probit[i, 2] <- model$coef[2] # Put the estimate for the coefficient
                                      # on X in the second column
par.est.probit[i, 3] <- sqrt(diag(vcv)[1]) # SE of the intercept
par.est.probit[i, 4] <- sqrt(diag(vcv)[2]) # SE of the coefficient on X
} # End the loop

mean(par.est.probit[ , 1]) # Mean of intercept estimates
mean(par.est.probit[ , 2]) # Mean of coefficient on X estimates
# Coverage probability for the intercept
coverage(par.est.probit[ , 1], par.est.probit[ , 3], b0,
 df = n - model$rank)$coverage.probability
# Coverage probability for the coefficient on X
coverage(par.est.probit[ , 2], par.est.probit[ , 4], b1,
 df = n - model$rank)$coverage.probability

# Ordered Models
library(MASS)
set.seed(8732) # Set the seed for reproducible results

reps <- 1000 # Set the number of repetitions at the top of the script
par.est.oprobit <- matrix(NA, nrow = reps, ncol = 2) # Empty matrices to store
taus.oprobit <- matrix(NA, nrow = reps, ncol = 3)    # the estimates
b0 <- 0 # True value for the intercept
b1 <- .5 # True value for the slope
n <- 1000 # Sample size
X <- rnorm(n, 0, 1) # Create a sample of n observations on the
                    # independent variable X

XB <- b0 + b1*X # Systematic component
sd.error <- 1 # SD of the error of the unobserved Y*
# Define the true cutpoints
tau1 <- qnorm(.1, mean = mean(XB), sd = sqrt(var(XB) + sd.error^2))
tau2 <- qnorm(.5, mean = mean(XB), sd = sqrt(var(XB) + sd.error^2))
tau3 <- qnorm(.9, mean = mean(XB), sd = sqrt(var(XB) + sd.error^2))

for(i in 1:reps){ # Start the loop
Y.star <- rnorm(n, XB, sd.error) # The unobserved Y*
Y <- rep(NA, n) # Define Y as a vector of NAs with length n
Y[Y.star < tau1] <- 1 # Set Y equal to a value according to Y.star
Y[Y.star >= tau1 & Y.star < tau2] <- 2
Y[Y.star >= tau2 & Y.star < tau3] <- 3
Y[Y.star >= tau3] <- 4
# Estimate ordered model
model <- polr(as.ordered(Y) ~ X, method = "probit", Hess = TRUE)
vcv <- vcov(model) # Variance-covariance matrix
par.est.oprobit[i, 1] <- model$coef[1] # Put the estimate for the coefficient
                                       # on X in the second column
par.est.oprobit[i, 2] <- sqrt(diag(vcv)[1]) # SE of the coefficient on X
taus.oprobit[i, ] <- model$zeta
cat("Just completed iteration", i, "\n")
} # End the loop

pdf("ystar.pdf")

par(mar = c(5, 5.25, .5, .5))
plot(Y.star, Y, xlim = c(-3, 3), xlab = "", ylab = "", main = "",
 axes = FALSE, pch = 19)
axis(1, at = seq(-3, 3, 1), cex.axis = 1.25)
axis(2, at = 1:4, cex.axis = 1.25, las = 2)
title(xlab = expression("Y* (Unobserved/Continuous)"), cex.lab = 1.5)
title(ylab = expression("Y (Observed/Categorical)"), line = 3.75,
 cex.lab = 1.5)
abline(v = c(tau1, tau2, tau3), lwd = 2, lty = 3)
text(tau1 - .25, 3.5, expression(tau[1]), cex = 2)
text(tau2 - .25, 3.5, expression(tau[2]), cex = 2)
text(tau3 - .25, 3.5, expression(tau[3]), cex = 2)
box()

dev.off()

mean(par.est.oprobit[ , 1]) # Mean of coefficient on X estimates
# Compare the actual taus to the means of the tau estimates
data.frame(True = c(tau1, tau2, tau3), Estimated = apply(taus.oprobit, 2, mean))
# Coverage probability for the coefficient on X
coverage(par.est.oprobit[ , 1], par.est.oprobit[ , 2], b1,
 df = n - length(c(coef(model), model$zeta)))$coverage.probability

# Unordered Models
library(Zelig)
set.seed(45262) # Set the seed for reproducible results

reps <- 1000 # Set the number of repetitions at the top of the script
par.est.mnl <- matrix(NA, nrow = reps, ncol = 4) # Empty matrix to store
                                                 # the estimates
b0A <- .2 # True values for the intercepts
b0B <- -.2
b1A <- .5 # True values for the slopes
b1B <- .75
n <- 1000 # Sample size
X <- runif(n, -1, 1) # Create a sample of n observations on the
                     # independent variable X
# Compute the probabilities of each outcome based on the DGP
pA <- exp(b0A + b1A*X)/(1 + exp(b0A + b1A*X) + exp(b0B + b1B*X))
pB <- exp(b0B + b1B*X)/(1 + exp(b0A + b1A*X) + exp(b0B + b1B*X))
pC <- 1 - pA - pB

for(i in 1:reps){ # Start the loop
Y <- rep(NA, n) # Define Y as a vector of NAs with length n
for(j in 1:n){ # Create the dependent variable in another loop
Y[j] <- sample(c("A", "B", "C"), 1, replace = TRUE,
 prob = c(pA[j], pB[j], pC[j]))
}

# Estimate a MNL model
model <- zelig(as.factor(Y) ~ X, model = "mlogit",
 data = data.frame(Y, X), cite = FALSE)
vcv <- vcov(model) # Variance-covariance matrix
par.est.mnl[i, 1] <- coefficients(model)[3] # Coefficient on X, outcome 1
par.est.mnl[i, 2] <- coefficients(model)[4] # Coefficient on X, outcome 2
par.est.mnl[i, 3] <- sqrt(diag(vcv)[3]) # SE of coefficient on X, outcome 1
par.est.mnl[i, 4] <- sqrt(diag(vcv)[4]) # SE of coefficient on X, outcome 2
cat("Just completed iteration", i, "\n")
} # End the loop

# Mean of coefficients on X estimates
mean(par.est.mnl[ , 1]) # Outcome 1
mean(par.est.mnl[ , 2]) # Outcome 2

# Coverage probabilities for the coefficients on X
# Outcome 1
coverage(par.est.mnl[ , 1], par.est.mnl[ , 3], b1A,
 df = n - length(coef(model)))$coverage.probability
# Outcome 2
coverage(par.est.mnl[ , 2], par.est.mnl[ , 4], b1B,
 df = n - length(coef(model)))$coverage.probability

# Ordered vs. MNL
library(Zelig)
set.seed(99999)

reps <- 1000 # Set the number of repetitions at the top of the script
d.pp <- array(NA, c(4, 3, reps)) # Empty array to store
                                 # simulated change in probabilities

# Ordered logit model DGP
b0 <- 0 # True value for the intercept
b1 <- .5 # True value for the slope
n <- 1000 # Sample size
X <- runif(n, -1, 1) # Create a sample of n observations on the
                     # independent variable X

# MNL model DGP
b0A <- .2 # True values for the intercepts
b0B <- -.2
b1A <- .5 # True values for the slopes
b1B <- .75
n <- 1000 # Sample size

# Compute the probabilities of each outcome based on the DGP
pA <- exp(b0A + b1A*X)/(1 + exp(b0A + b1A*X) + exp(b0B + b1B*X))
pB <- exp(b0B + b1B*X)/(1 + exp(b0A + b1A*X) + exp(b0B + b1B*X))
pC <- 1 - pA - pB

for(i in 1:reps){
# Ordered dependent variable
Y.star <- rlogis(n, b0 + b1*X, 1) # The unobserved Y*
# Define the true cutpoints
tau1 <- quantile(Y.star, .25)
tau2 <- quantile(Y.star, .75)
Y.o <- rep(NA, n) # Define Y as a vector of NAs with length n
Y.o[Y.star < tau1] <- 1 # Set Y equal to a value according to Y.star
Y.o[Y.star >= tau1 & Y.star < tau2] <- 2
Y.o[Y.star >= tau2] <- 3
# Ordered data
o.data <- data.frame(Y.o, X) # Put the data in a data frame

# Unordered dependent variable
Y.m <- rep(NA, n) # Define Y as a vector of NAs with length n
for(j in 1:n){ # Create the dependent variable in another loop
Y.m[j] <- sample(1:3, 1, replace = TRUE, prob = c(pA[j], pB[j], pC[j]))
}
# Unordered data
m.data <- data.frame(Y.m, X) # Put the data in a data frame

# Estimate the models with the ordered dependent variable
o.correct <- zelig(as.ordered(Y.o) ~ X, model = "ologit",
 data = o.data, cite = FALSE)
m.incorrect <- zelig(as.factor(Y.o) ~ X, model = "mlogit",
 data = o.data, cite = FALSE)

# Estimate the models with the multinomial dependent variable
m.correct <- zelig(as.factor(Y.m) ~ X, model = "mlogit",
 data = m.data, cite = FALSE)
o.incorrect <- zelig(as.ordered(Y.m) ~ X, model = "ologit",
 data = m.data, cite = FALSE)

# Set X to its minimum and maximum for each model
x.oc <- setx(o.correct, X = min(X)) # For o.correct
x.oc1 <- setx(o.correct, X = max(X))

x.mi <- setx(m.incorrect, X = min(X)) # For m.incorrect
x.mi1 <- setx(m.incorrect, X = max(X))

x.mc <- setx(m.correct, X = min(X)) # For m.correct
x.mc1 <- setx(m.correct, X = max(X))

x.oi <- setx(o.incorrect, X = min(X)) # For o.incorrect
x.oi1 <- setx(o.incorrect, X = max(X))

# Compute the change in expected probabilities of falling in each category
# when moving from the minimum to the maximum of X
sim.oc <- sim(o.correct, x = x.oc, x1 = x.oc1)$qi$fd
sim.mi <- sim(m.incorrect, x = x.mi, x1 = x.mi1)$qi$fd
sim.mc <- sim(m.correct, x = x.mc, x1 = x.mc1)$qi$fd
sim.oi <- sim(o.incorrect, x = x.oi, x1 = x.oi1)$qi$fd
d.pp[1, , i] <- apply(sim.oc, 2, mean)
d.pp[2, , i] <- apply(sim.mi, 2, mean)
d.pp[3, , i] <- apply(sim.mc, 2, mean)
d.pp[4, , i] <- apply(sim.oi, 2, mean)
cat("Just completed iteration", i, "of", reps, "\n")
}

# Compute the average change in probability for each of the four models
dpp.means <- rbind(apply(d.pp[1, , ], 1, mean), apply(d.pp[2, , ], 1, mean), apply(d.pp[3, , ], 1, mean), apply(d.pp[4, , ], 1, mean))

# Compute the SD of the change in probability for each of the four models
dpp.sds <- rbind(apply(d.pp[1, , ], 1, sd), apply(d.pp[2, , ], 1, sd), apply(d.pp[3, , ], 1, sd), apply(d.pp[4, , ], 1, sd))

# LaTeX table
library(xtable)
results <- rbind(dpp.means, dpp.sds)

xtable(results, digits = 4, caption = "Means and Standard Deviations of the Change in expected probability for Each Category", label = "ord-unord-results", align = "lrrr")

# Count Models
# Poisson
set.seed(3759) # Set the seed for reproducible results

reps <- 1000 # Set the number of repetitions at the top of the script
par.est.pois <- matrix(NA, nrow = reps, ncol = 4) # Empty matrix to store the
                                                  # estimates
b0 <- .2 # True value for the intercept
b1 <- .5 # True value for the slope
n <- 1000 # Sample size
X <- runif(n, -1, 1) # Create a sample of n observations on the
                     # independent variable X

for(i in 1:reps){ # Start the loop
Y <- rpois(n, exp(b0 + b1*X)) # The true DGP
model <- glm(Y ~ X, family = "poisson") # Estimate Poisson model
vcv <- vcov(model) # Variance-covariance matrix
par.est.pois[i, 1] <- model$coef[1] # Put the estimate for the intercept
                                    # in the first column
par.est.pois[i, 2] <- model$coef[2] # Put the estimate for the coefficient on
                                    # X in the second column
par.est.pois[i, 3] <- sqrt(diag(vcv)[1]) # SE of the intercept
par.est.pois[i, 4] <- sqrt(diag(vcv)[2]) # SE of the coefficient on X
} # End the loop

# Means of the coefficient estimates
mean(par.est.pois[ , 1]) # Intercept
mean(par.est.pois[ , 2]) # Coefficient on X

# Coverage probabilities
# Intercept
coverage(par.est.pois[ , 1], par.est.pois[ , 3], b0,
 df = n - model$rank)$coverage.probability
# Coefficient on X
coverage(par.est.pois[ , 2], par.est.pois[ , 4], b1,
 df = n - model$rank)$coverage.probability

pdf("od1.pdf")

par(mar = c(5, 5.25, .5, .5))
plot(1:n, Y, ylim = c(0, 20), col = "gray50", xlab = "", ylab = "",
 main = "", axes = FALSE)
axis(1, cex.axis = 1.25)
axis(2, at = 0:20, cex.axis = 1.25, las = 2)
title(xlab = expression("Observations"), cex.lab = 1.5)
title(ylab = expression("Y"), line = 3.75, cex.lab = 1.5)
abline(h = mean(Y), lwd = 2)
abline(h = var(Y), lwd = 2, lty = 2)
box()
legend("topleft", bty = "n", c(expression("Mean of Y"),
 expression("Variance of Y")), lty = c(1, 2), lwd = 2, cex = 1.5)

dev.off()

# Poisson vs. Negative Binomial
library(MASS)
set.seed(763759) # Set the seed for reproducible results

reps <- 1000 # Set the number of repetitions at the top of the script
par.est.pnb <- matrix(NA, nrow = reps, ncol = 4) # Empty matrix to store the
                                                 # estimates
b0 <- .2 # True value for the intercept
b1 <- .5 # True value for the slope
n <- 1000 # Sample size
X <- runif(n, -1, 1) # Create a sample of n observations on the
                     # independent variable X

for(i in 1:reps){
Y <- rnbinom(n, size = .5, mu = exp(b0 + b1*X)) # Generate data with
                                                # overdispersion
model.p <- glm(Y ~ X, family = "poisson") # Estimate Poisson model
model.nb <- glm.nb(Y ~ X) # Estimate NB model
vcv.p <- vcov(model.p) # Variance-covariance matrices
vcv.nb <- vcov(model.nb)
par.est.pnb[i, 1] <- model.p$coef[2]  # Store the results
par.est.pnb[i, 2] <- model.nb$coef[2]
par.est.pnb[i, 3] <- sqrt(diag(vcv.p)[2])
par.est.pnb[i, 4] <- sqrt(diag(vcv.nb)[2])
cat("Completed", i, "of", reps, "\n")
}

# Means of the coefficient on X estimates
mean(par.est.pnb[ , 1]) # Poisson estimates
mean(par.est.pnb[ , 2]) # NB estimates

# MSE
mean((par.est.pnb[ , 1])^2) # Poisson MSE
mean((par.est.pnb[ , 2])^2) # NB MSE

# Coverage probabilities
# Poisson SEs
coverage(par.est.pnb[ , 1], par.est.pnb[ , 3], b1,
 df = n - model.p$rank)$coverage.probability
# NB SEs
coverage(par.est.pnb[ , 2], par.est.pnb[ , 4], b1,
 df = n - model.nb$rank)$coverage.probability

pdf("od2.pdf")

par(mar = c(5, 5.25, .5, .5))
plot(1:n, Y, ylim = c(0, 20), col = "gray50", xlab = "", ylab = "",
 main = "", axes = FALSE)
axis(1, cex.axis = 1.25)
axis(2, at = 0:20, cex.axis = 1.25, las = 2)
title(xlab = expression("Observations"), cex.lab = 1.5)
title(ylab = expression("Y"), line = 3.75, cex.lab = 1.5)
abline(h = mean(Y), lwd = 2)
abline(h = var(Y), lwd = 2, lty = 2)
box()
legend("topleft", bty = "n", c(expression("Mean of Y"),
 expression("Variance of Y")), lty = c(1, 2), lwd = 2, cex = 1.5)

dev.off()

# Negative Binomial vs. Zero-Inflated Negative Binomial
library(pscl)
# Zero-inflated negative binomial random number generator
rzinbinom <- function(n, mu, size, zprob){
ifelse(rbinom(n, 1, zprob) == 1, 0, rnbinom(n, size = size, mu = mu))
}

set.seed(2837) # Set the seed for reproducible results

reps <- 1000 # Set the number of repetitions at the top of the script
par.est.zinb <- matrix(NA, nrow = reps, ncol = 4) # Empty matrix to store
                                                  # the estimates
b0z <- -.8 # True value for the inflation intercept
b1z <- .3 # True value for the inflation slope
b0c <- .2 # True value for the count intercept
b1c <- .5 # True value for the count slope
n <- 1000 # Sample size
X <- runif(n, -1, 1) # Create a sample of n observations on the
                     # independent variable X
Z <- rnorm(n, X, 1) # Inflation independent variable

for(i in 1:reps){
# Generate data with a zero-inflation component
Y.zi <- rzinbinom(n, mu = exp(b0c + b1c*X), size = .5,
zprob = exp(b0z + b1z*Z)/(1 + exp(b0z + b1z*Z)))

# Generate data with no zero-inflation component
Y.nozi <- rzinbinom(n, mu = exp(b0c + b1c*X), size = .5, zprob = 0)
model.nb1 <- glm.nb(Y.zi ~ X) # Standard negative binomial
model.nb2 <- glm.nb(Y.nozi ~ X)
model.zinb1 <- zeroinfl(Y.zi ~ X | Z, dist = "negbin") # Zero-inflated model
model.zinb2 <- zeroinfl(Y.nozi ~ X | Z, dist = "negbin")

# Store the estimates of the coefficient on X (count equation)
par.est.zinb[i, 1] <- model.nb1$coef[2] # Standard NB, with ZI
par.est.zinb[i, 2] <- model.nb2$coef[2] # Standard NB, no ZI
par.est.zinb[i, 3] <- as.numeric(model.zinb1$coef$count[2]) # ZI NB, with ZI
par.est.zinb[i, 4] <- as.numeric(model.zinb2$coef$count[2]) # ZI NB, no ZI
cat("Completed", i, "of", reps, "\n")
}

pdf("zinb-zi.pdf")

par(mar = c(5, 5.25, .5, .5))
plot(density(par.est.zinb[ , 1]), xlim = c(-.5, 1.5), ylim = c(0, 3.5),
 lwd = 3, xlab = "", ylab = "", main = "", axes = FALSE)
lines(density(par.est.zinb[ , 3]), lwd = 3, lty = 2)
axis(1, cex.axis = 1.25)
axis(2, cex.axis = 1.25, las = 2)
title(xlab = expression(hat(beta[1])), cex.lab = 1.5)
title(ylab = expression("Density"), line = 3.75, cex.lab = 1.5)
abline(v = b1, lwd = 2)
text(1, 2, expression("True"~beta[1]~"= 0.50"), cex = 1.5)
box()
legend("topright", bty = "n", c(expression("Standard NB"),
 expression("ZINB")), lty = c(1, 2), lwd = 3, cex = 1.5)

dev.off()

pdf("zinb-nozi.pdf")

par(mar = c(5, 5.25, .5, .5))
plot(density(par.est.zinb[ , 2]), xlim = c(-.5, 1.5), ylim = c(0, 5),
 lwd = 3, xlab = "", ylab = "", main = "", axes = FALSE)
lines(density(par.est.zinb[ , 4]), lwd = 3, lty = 2)
axis(1, cex.axis = 1.25)
axis(2, cex.axis = 1.25, las = 2)
title(xlab = expression(hat(beta[1])), cex.lab = 1.5)
title(ylab = expression("Density"), line = 3.75, cex.lab = 1.5)
abline(v = b1, lwd = 2)
text(1, 2, expression("True"~beta[1]~"= 0.50"), cex = 1.5)
box()
legend("topright", bty = "n", c(expression("Standard NB"),
 expression("ZINB")), lty = c(1, 2), lwd = 3, cex = 1.5)

dev.off()

# Duration Models (Cox PH)
library(survival)
library(coxrobust)

set.seed(4679) # Set the seed for reproducible results

reps <- 1000 # Set the number of repetitions at the top of the script
par.est.cox <- matrix(NA, nrow = reps, ncol = 3) # Empty matrix to store
                                                 # the estimates
b1 <- .5 # True value for the slope
n <- 1000 # Sample size
X <- runif(n, -1, 1) # Create a sample of n observations on the
                     # independent variable X
Z <- runif(n, -1, 1) # Create an omitted variable

for(i in 1:reps){ # Start the loop
Y <- rexp(n, exp(b1*X + Z)) # Generate survival times
Ys <- Surv(Y, event = rep(1, n))
model.plm <- coxph(Ys ~ X, method = "breslow") # Standard PLM estimator
model.irr <- coxr(Ys ~ X, trunc = .95) # IRR, downweighting outliers (5%)
model.irr2 <- coxr(Ys ~ X, trunc = .8) # IRR, even more downweighting (20%)
par.est.cox[i, 1] <- model.plm$coef[1] # Store the estimates
par.est.cox[i, 2] <- model.irr$coef[1]
par.est.cox[i, 3] <- model.irr2$coef[1]
cat("Completed", i, "of", reps, "\n")
}

apply(par.est.cox, 2, mean)
apply(par.est.cox, 2, sd)

mean((par.est.cox[ , 1] - b1)^2)
mean((par.est.cox[ , 2] - b1)^2)
mean((par.est.cox[ , 3] - b1)^2)

pdf("cox.pdf")

par(mar = c(5, 5.25, .5, .5))
plot(density(par.est.cox[ , 1]), xlim = c(.15, .65), lwd = 3, xlab = "",
 ylab = "", main = "", axes = FALSE)
lines(density(par.est.cox[ , 2]), lwd = 3, lty = 2)
lines(density(par.est.cox[ , 3]), lwd = 3, lty = 3)
axis(1, cex.axis = 1.25)
axis(2, cex.axis = 1.25, las = 2)
title(xlab = expression(hat(beta[1])), cex.lab = 1.5)
title(ylab = expression("Density"), line = 3.75, cex.lab = 1.5)
abline(v = b1, lwd = 2)
text(.58, 6, expression("True"~beta[1]~"= 0.50"), cex = 1.5)
box()
legend("topleft", bty = "n", c(expression("PLM"), expression("IRR 5%"),
 expression("IRR 20%")), lty = c(1, 2, 3), lwd = 3, cex = 1.5)

dev.off()

# Computational Issues
source("parallel1.r")
source("parallel2.r")


dms_to_rad <- function(d, m, s) (d + m / 60 + s / 3600) * pi / 180

# Volumetric mean radius is 6371 km, see http://nssdc.gsfc.nasa.gov/planetary/factsheet/earthfact.html
# The diameter is thus 12742 km

great_circle_distance <- function(lat1, long1, lat2, long2) {
   a <- sin(0.5 * (lat2 - lat1))
   b <- sin(0.5 * (long2 - long1))
   12742 * asin(sqrt(a * a + cos(lat1) * cos(lat2) * b * b))
}

# Coordinates are found here:
#     http://www.airport-data.com/airport/BNA/
#     http://www.airport-data.com/airport/LAX/

great_circle_distance(
   dms_to_rad(36,  7, 28.10), dms_to_rad( 86, 40, 41.50),   # Nashville International Airport (BNA)
   dms_to_rad(33, 56, 32.98), dms_to_rad(118, 24, 29.05))  # Los Angeles International Airport (LAX)

# Output:  2886.327