R version 3.3.0 (2016-05-03) -- "Supposedly Educational"
Copyright (C) 2016 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64 (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

 library("klaR")
 library("caret")
 library ("stringr")

 allData <- read.table('d:/adult.txt', header = FALSE)

 str(allData)

 labels <- as.factor(allData[,15])

 allFeatures <- allData[,-c(15)]

 head(allFeatures)

 continuousFeatures <- scale(continuousFeatures)

 head(continuousFeatures)

 labels.n = rep(0,length(labels))
 labels.n[labels==" <=50K"] = -1
 labels.n[labels==" 50K"] = 1
 labels = labels.n
 rm(labels.n)

 trainingData <- createDataPartition(y=labels, p=.8, list=FALSE)

 dim(trainingData)

 remainingLabels <- labels[-trainingData]
 remainingFeatures <- continuousFeatures[-trainingData,]

 testingData <- createDataPartition(y=remainingLabels, p=.5, list=FALSE)
 testingLabels <- remainingLabels[testingData]
 testingFeatures <- remainingFeatures[testingData,]

 validationLabels <- remainingLabels[-testingData]
 validationFeatures <- remainingFeatures[-testingData,]

 getAccuracy <- function(a,b,features,labels){
     estFxn = features %*% a + b
     predictedLabels = rep(0,length(labels))
     predictedLabels [estFxn < 0] = -1
     predictedLabels [estFxn = 0] = 1

     return(sum(predictedLabels == labels) / length(labels))
 }

 numEpochs = 100
 numStepsPerEpoch = 500
 nStepsPerPlot = 30
 evalidationSetSize = 50
 c1 = 0.01
 c2 = 50

 lambda_vals = c(0.001, 0.01, 0.1, 1)
 bestAccuracy = 0

 str(lambda_vals)

 accMat <- matrix(NA, nrow = (numStepsPerEpoch/nStepsPerPlot)*numEpochs+1, ncol = length(lambda_vals))
 accMatv <- matrix(NA, nrow = (numStepsPerEpoch/nStepsPerPlot)*numEpochs+1, ncol = length(lambda_vals))

 for(i in 1:4){
  lambda = lambda_vals[i]
  accMatRow = 1
  accMatCol = i

  a = rep(0,ncol(continuousFeatures))
  b = 0

  stepIndex = 0

  for (e in 1:numEpochs){

    etrainingData <- createDataPartition(y=trainingLabels, p=(1 - evalidationSetSize/length(trainingLabels)), list=FALSE)

    etrainingFeatures <- trainingFeatures[etrainingData,]
    etrainingLabels <- trainingLabels[etrainingData]

    evalidationFeatures <- trainingFeatures[-etrainingData,]
    evalidationLabels <- trainingLabels[-etrainingData]

    steplength = 1 / (e*c1 + c2)

    for (step in 1:numStepsPerEpoch){
      stepIndex = stepIndex+1
      index = sample.int(nrow(etrainingFeatures),1)
      xk = etrainingFeatures[index,]
      yk = etrainingLabels[index]

      costfxn = yk * (a %*% xk + b)

      if(costfxn >= 1){

        a_dir = lambda * a
        a = a - steplength * a_dir

      } else {

        a_dir = (lambda * a) - (yk * xk)
        a = a - steplength * a_dir
        b_dir = -yk
        b = b - (steplength * b_dir)

      }

      if (stepIndex %>% nStepsPerPlot == 1){#30){
        accMat[accMatRow,accMatCol] = getAccuracy(a,b,evalidationFeatures,evalidationLabels)
        accMatv[accMatRow,accMatCol] = getAccuracy(a,b,validationFeatures,validationLabels)
        accMatRow = accMatRow + 1
      }

    }

  }

  tempAccuracy = getAccuracy(a,b,validationFeatures,validationLabels)
  print(str_c("tempAcc = ", tempAccuracy," and bestAcc = ", bestAccuracy) )
  if(tempAccuracy > bestAccuracy){
    bestAccuracy = tempAccuracy
    best_a = a
    best_b = b
    best_lambdaIndex = i
  }

}

 getAccuracy(best_a,best_b, testingFeatures, testingLabels)

 colors = c("red","blue","green","black")

 xaxislabel = "Step"

 yaxislabels = c("Accuracy on Randomized Epoch Validation Set","Accuracy on Validation Set")

 title="Accuracy as a Function of Step and Lambda"

 ylims=c(0,1)

 stepValues = seq(1,15000,length=500)

 mats =  list(accMat,accMatv)

 for(j in 1:length(mats)){

  mat = mats[[j]]

  for(i in 1:4){

   if(i == 1){
     plot(stepValues, mat[1:500,i], type = "l",xlim=c(0, 15000), ylim=ylims,
         col=colors[i],xlab=xaxislabel,ylab=yaxislabels[j],main=title)
    } else{
      lines(stepValues, mat[1:500,i], type = "l",xlim=c(0, 15000), ylim=ylims,
          col=colors[i],xlab=xaxislabel,ylab=yaxislabels[j],main=title)
    }
   Sys.sleep(1)
  }
  legend(x=10000,y=.5,legend=c("lambda=.001","lambda=.01","lambda=.1","lambda=1"),fill=colors)

}

Chapter 06/7Stochastic Gradient Descent - Adult Income.r


procent_014 <- procenti_poLetih %>% filter(Age_group == "0-14")
napoved_014 <- tibble(year = seq(1980,2025,5))

model014_lm <- lm(data = procent_014, percentage~year)

napoved_014$percentageLm <- predict(model014_lm, napoved_014)

model014_loess <- loess(percentage~year, procent_014, control=loess.control(surface = "direct"))

napoved_014$percentageLoess <- predict(model014_loess, napoved_014)

graf_014_napoved2 <- ggplot(procent_014, aes(x = year, y = percentage)) + geom_line() +
  geom_line(data = napoved_014, aes(y = percentageLm, color = 'pink')) +
  geom_line(data = napoved_014, aes(y = percentageLoess, color = 'steelblue')) + theme(legend.position = "none") +
  xlab("Procent") + ylab("0-14")

graf_014_napoved <- ggplotly(graf_014_napoved2)
#print(graf_014_napoved)

procent_1564 <- procenti_poLetih %>% filter(Age_group == "15-64")
napoved_1564 <- tibble(year = seq(1980,2025,5))

model1564_lm <- lm(data = procent_1564, percentage~year)
model1564_loess <- loess(percentage~year, data = procent_1564, control=loess.control(surface = "direct"))
napoved_1564$percentageLm <- predict(model1564_lm, napoved_1564)
napoved_1564$percentageLoess <- predict(model1564_loess, napoved_1564)

graf_1564_napoved1 <- ggplot(procent_1564, aes(x = year, y = percentage)) + geom_line() +
  geom_line(data = napoved_1564, aes(y = percentageLm, color = "pink")) +
  geom_line(data = napoved_1564, aes(y = percentageLoess, color = "steelblue")) +
  theme(legend.position = "none") + xlab("Procent") + ylab("15-64")
graf_1564_napoved <- ggplotly(graf_1564_napoved1)
#print(graf_1564_napoved)

procent_65 <- procenti_poLetih %>% filter(Age_group == "65+")
napoved_65 <- tibble(year  = seq(1980,2025,5))

model65_lm <- lm(data = procent_65, percentage~year)
model65_loess <- loess(percentage~year, data = procent_65, control=loess.control(surface = "direct"))
napoved_65$percentageLm <- predict(model65_lm, napoved_65)
napoved_65$percentageLoess <- predict(model65_loess, napoved_65)

graf_65_napoved1 <- ggplot(procent_65, aes(x = year, y = percentage))  + geom_line() +
  geom_line(data = napoved_65, aes(y = percentageLm, color = "pink")) +
  geom_line(data = napoved_65, aes(y = percentageLoess, color = "steelblue")) + theme(legend.position = "none") +
  xlab("Procent") + ylab("65+")
graf_65_napoved <- ggplotly(graf_65_napoved1)

napovedi <- subplot(graf_014_napoved, graf_1564_napoved, graf_65_napoved, nrows = 3, titleY = TRUE)
print(napovedi)

##CLUSTERING

#procenti starostnih skupin (ni bed)
#0 - 14
podatki_014_1980 <- StarostneStruktureProcent %>% filter(Age_group == "0-14", year == 1980)

cluster_014_1980 <- kmeans(podatki_014_1980$percentage, 5)

centri_014_1980 <- sort(cluster_014_1980$centers)

tabela_014_1980 <- data.frame(country = podatki_014_1980$country,
                         group = factor(cluster_014_1980$cluster), percentage = podatki_014_1980$percentage)
tabela_014_1980$year <- 1980

podatki_014_2015 <- StarostneStruktureProcent %>% filter(Age_group == "0-14",year == 2015)

cluster_014_2015 <- kmeans(podatki_014_2015$percentage, 5)
centri_014_2015 <- sort(cluster_014_2015$centers)

tabela_014_2015 <- tibble(country = podatki_014_2015$country,
                          group = factor(cluster_014_2015$cluster), percentage = podatki_014_2015$percentage)
tabela_014_2015$year <- 2015
tabela_014 <- rbind(tabela_014_1980, tabela_014_2015)

zemljevid_cluster_014_1980 <- tm_shape(merge(svet, tabela_014 %>% filter(year == 1980),
                                             by.x = "NAME", by.y = "country")) +
  tm_fill(col = "group",palette = "YlOrRd")

#print(zemljevid_cluster_014_1980)

zemljevid_cluster_014_2015 <- tm_shape(merge(svet, tabela_014 %>% filter(year == 2015),
                                             by.x = "NAME", by.y = "country")) + tm_fill(col = "group", palette = "YlOrRd")
#print(zemljevid_cluster_014_2015)

podatki_65_2015 <- StarostneStruktureProcent %>% filter(Age_group == "65+", year == 2015)
cluster_65_2015 <- kmeans(podatki_65_2015$percentage, 5)
tabela_65_2015 <- tibble(country = podatki_65_2015$country, group = factor(cluster_65_2015$cluster, ordered = TRUE),
                         percentage = podatki_65_2015$percentage)

zemljevid_cluster_65_2015 <- tm_shape(merge(svet, tabela_65_2015, by.x = "NAME", by.y = "country")) +
  tm_fill(col = "group", palette = "YlOrRd")

#print(zemljevid_cluster_65_2015)

#PO BDP

podatkiBdp_2015 <- bdpji %>% filter(year == 2015)

cluster_bdpPc_2015 <- kmeans(podatkiBdp_2015$bdp_pc, 5)

tabela_cluster_gdpPc <- tibble(country = podatkiBdp_2015$country,
                               group = factor(cluster_bdpPc_2015$cluster, ordered = TRUE),
                               gdp_pc = podatkiBdp_2015$bdp_pc)
zemljevid_cluster_bdpPc_2015 <- tm_shape(merge(svet, tabela_cluster_gdpPc, by.x = "NAME", by.y = "country")) +
  tm_fill(col = "group", palette = "YlOrRd")

#print(zemljevid_cluster_bdpPc_2015)


rcond_post_beta <- function(y, xm, psi, beta_prior_mean, beta_prior_var){

  mu_beta <- beta_prior_mean
  v_beta <- diag(beta_prior_var)
  v_beta_inv <- diag(1/beta_prior_var)

  xtx <- t(xm)%*%xm

  if(length(y)>0 ){

    post_cov <- chol2inv(chol( v_beta_inv + (1/psi)*xtx))
    post_mean <- post_cov %*% (v_beta_inv %*% mu_beta + (1/psi)*t(xm)%*%y )

  }else{
    post_mean <- mu_beta
    post_cov <- v_beta
  }

  draw <- mvtnorm::rmvnorm(n = 1, mean = post_mean, sigma = post_cov)
  return(draw)
}

cond_post_beta_pdp <- function(beta_vec, y, xm, beta_prior_mean, beta_prior_var){

  eta <- xm %*% beta_vec
  eta <- ifelse(eta < -30, -30, ifelse(eta>5, 5, eta))

  lk <- sum(dbinom(x = y, size = 1, prob = LaplacesDemon::invlogit(eta), log = T))
  pr <- mvtnorm::dmvnorm(x = beta_vec, beta_prior_mean, diag(beta_prior_var), log = T)

  return(lk + pr)
}

rcond_post_psi <- function(beta, y, xm, g1, b1){
  n_k <- length(y)
  if(n_k==0){
    shape_k <- g1
    rate_k <- b1
  }else{
    shape_k <- g1 + n_k/2
    rate_k <- .5*(  sum( (y - xm %*% beta)^2 ) )  + b1
  }
  draw <- invgamma::rinvgamma(n = 1, shape = shape_k, rate = rate_k)
  return(draw)
}

rcond_post_mu_x <- function(x_ck, phi_x, lambda, tau ){
  nvec_k <- length(x_ck)
  mu_mean <- (1/(1/tau + nvec_k/phi_x))*(lambda/tau + sum(x_ck)/phi_x)
  mu_sd <- sqrt( (1/tau + nvec_k/phi_x)^(-1) )
  draw <- rnorm(n = 1, mean = mu_mean, sd =  mu_sd)
  return(draw)
}

rcond_post_phi <- function(mu_x, x, g2, b2){
  n_k <- length(x)
  if(n_k==0){
    shape_k <- g2
    rate_k <- b2
  }else{
    shape_k <- g2 + n_k/2
    rate_k <- .5*(  sum( (x - mu_x )^2 ) )  + b2
  }
  phi_post <- invgamma::rinvgamma(n = 1, shape = shape_k, rate = rate_k)
  return(phi_post)
}

rcond_post_mu_trt <- function(x_ck){
  draw<-rbeta(n = 1,shape1 = 1 + sum(x_ck),
              shape2 = 1 + length(x_ck) - sum(x_ck))
  return(draw)
}

cond_post_alpha <- function(alpha, n, K, nvec){
  lik <- lgamma(alpha) - lgamma(n + alpha) + sum(lgamma(nvec + alpha/K)) - K*lgamma(alpha/K)
  pr <- invgamma::dinvgamma(x = alpha, 1, 1,log = T)
  return(lik + pr)
}

cond_post_pz <- function(gamma, y, xp,
                         gamma_prior_mean,gamma_prior_var){

  eta <- xp %*% gamma
  eta <- ifelse(eta < -10, -10, ifelse(eta>10, 10, eta))
  p <- LaplacesDemon::invlogit(eta)

  lk <- sum(dbinom(x = y, size = 1, prob = p, log = T))
  pr <- mvtnorm::dmvnorm(x = gamma, gamma_prior_mean, diag(gamma_prior_var), log = T)

  return(lk + pr)
}


 DGELSS Example Program Results

 Least squares solution
      0.6344     0.9699    -1.4403     3.3678     3.3992

 Tolerance used to estimate the rank of A
      1.00E-02
 Estimated rank of A
      4

 Singular values of A
      3.9997     2.9962     2.0001     0.9988     0.0025


library(caret)
library(kernlab)

data(spam)

# Data splitting with createDataPartition()
inTrain <- createDataPartition(y=spam$type, p=0.75, list=FALSE)

training <- spam[inTrain, ]
testing <- spam[-inTrain, ]
dim(training)

# Paritioning the dataset with 'K-fold'
set.seed(32343)
folds <- createFolds(y=spam$type, k=10, list=TRUE, returnTrain=TRUE)
sapply(folds, length)
folds[[1]][1:10]

# Paritioning the dataset with 'K-fold' and return test
set.seed(32323)
folds <- createFolds(y=spam$type, k=10, list=TRUE, returnTrain=FALSE)
sapply(folds, length)
folds[[1]][1:10]

# Paritioning the dataset with 'resampling'
set.seed(32323)
folds <- createResample(y=spam$type, times=10, list=TRUE)
sapply(folds, length)

# Paritioning a time serie dataset with Time Slices
set.seed(32323)
tme <- 1:1000
folds <- createTimeSlices(y=tme, initialWindow=20, horizon=10)
names(folds)
folds$train[[1]]
folds$test[[1]]

# Further information
# Caret tutorials:
#   - http://www.edii.uclm.es/~useR-2013/Tutorials/kuhn/user_caret_2up.pdf
#   - http://cran.r-project.org/web/packages/caret/vignettes/caret.pdf
# A paper introducing the caret package
#   - http://www.jstatsoft.org/v28/i05/paper


library(ggplot2)
library(testthat)

## Test data generated using authors' code.
N <- 10
beta <- 2/(N-1);
gamma1 <- 1;
final_size1 <- c(0.00000, 0.33333, 0.08640, 0.04908, 0.03814, 0.03638, 0.04079, 0.05256, 0.07614, 0.11862, 0.16854)

## Some more test data; extreme cases.
## What if the recovery rate is 0?
gamma2 <- 0
final_size2 <- c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1)

outbreak_size_distr <- function(N, beta, gamma) {
    ## total number of possible states
    nstates <- (N + 1) * (N + 2) / 2
    ## empty vector to store outbreak size distribution
    distr <- rep(0, N + 1)
    ## probability distribution of states
    p_states <- rep(0, nstates)
    ## Start with 1 infection event. This could be
    ## customised. Note that state 2 corresponds to
    ## state (1, 0)
    p_states[2] <- 1
    ## counter to index over states
    state <- 1
    for (z2 in 0:N) {
        distr[z2 + 1] <- p_states[state];
        state <- state + 1;
        if ((z2 + 1) > (N - 1)) {
            next
        }
        for (z1 in (z2 + 1): (N - 1)) {
            p <- 1 / ( 1 + gamma/(beta*(N - z1)))
            p_states[state + 1] <- p_states[state + 1] + p_states[state] * p
            p_states[state + N - z2] <- p_states[state + N - z2] + p_states[state] * (1 - p)
            state <- state + 1
        }
        if (z2 < N) {
            p_states[state + N - z2] <- p_states[state + N - z2] + p_states[state]
            state <- state + 1
        }

    }
    distr
}

distr <- outbreak_size_distr(N = 10, beta = 2/9, gamma = 1)
distr <- round(distr, 5)

testthat::expect_equal(distr, final_size1)

distr <- outbreak_size_distr(N = 10, beta = 2/9, gamma = 0)
distr <- round(distr, 5)

testthat::expect_equal(distr, final_size2)

N <- 100
beta <- seq(from = 10, to = 100, by = 50) / (N - 1)
gamma <- 1
final_distr <- lapply(beta, function(b) outbreak_size_distr(N, beta = b, gamma))

results <- data.frame()
for (i in seq_along(beta)) {
    results <- rbind(results, data.frame(infection_rate = rep(beta[i], N + 1),
                                         distr = final_distr[[i]]))
}
results$infection_rate <- factor(results$infection_rate)

N <- 100
beta <- 99 / (N - 1)
gamma <- beta / c(1, 100)
final_distr <- lapply(gamma, function(g) outbreak_size_distr(N, beta, gamma = g))
results <- data.frame()
for (i in seq_along(gamma)) {
    results <- rbind(results, data.frame(recovery_rate = rep(gamma[i], N + 1),
                                         distr = final_distr[[i]]))
}
results$recovery_rate <- factor(results$recovery_rate)
x <- rep(0:N, length(gamma))

# Plot
ggplot(results, aes(x, distr, fill = recovery_rate)) +
  geom_col(position = "dodge")


findfactors <- function(num) {
  x <- c()
  1stprime<- 2; 2ndprime <- 3; everyprime <- num
  while( everyprime != 1 ) {
    while( everyprime%%1stprime == 0 ) {
      x <- c(x, 1stprime)
      everyprime <- floor(everyprime/ 1stprime)
    }
    1stprime <- 2ndprime
    2ndprime <- 2ndprime + 2
  }
  x
}

print(findfactors(1027*4))


#[Network analysis](https://en.wikipedia.org/wiki/Network_theory) is a every day task in data analysis. Indeed we often need to know who is linked with who (geographical distance ? Same kind of features ?...)
#[I graph](http://igraph.org/redirect.html) is the perfect package to represent link between objects.

#Let's charge the Igraph package
library("igraph")

#Simulating Data : Mark of 9 students. 3 are known to be strong in Letters, 3 in Art and 3 in Math.
a=c(6,8,11,14,15,14,19,18,20)
b=c(20,20,19,18,18,18,2,4,8)
c=c(3,4,3,15,18,19,2,1,8)
data = matrix(c( a,a+1,a-sample(seq(1,3),9,replace=T) ,a-sample(seq(1,3),9,replace=T),
                 b,b-sample(seq(1,3),9,replace=T),b+sample(seq(1,3),9,replace=T),c,
                 c-sample(seq(1,3),9,replace=T),(b+c)/2) , 9 , 9)
colnames(data)=c("charline", "JP", "Kath", "Gary", "Conor", "Marion", "JB", "gui", "Vincent")
rownames(data)=c("french","phylo","latin","musique","art","sport","math","stat","R")

#Let's have a look to the rough data
library(xtable)
print(xtable(data , caption="rough data", digits=0 ), type = "latex", include.rownames = T ,
      comment=FALSE )

#I calculte correlation between student's Marks. I Want to see who has the same kind of Mark structure
dist=cor(data)
dist[dist<0.5]=0
diag(dist)=0

#Let's make the I-Graph. All the students with a correlation > 0.5 will be linked one to each other on the graph. Students with strong correlation will be closer. People with strong skills in letters, art and math will be Highlighted.
# First I ask to Igraph to calculate the best position of each individuals, doing iterations
g1<-graph.adjacency(dist,weighted="TRUE",mode="undirected")
lay<-layout.fruchterman.reingold(grap=g1,niter=6000)

png("#7_I_graph.png")
par(mar=c(0.5,0.5,0.5,0.5))

# Then I make the plot. I ask to show the know structure of the population
plot.igraph(g1,
            mark.shape=1 ,
            mark.groups=list(c(1:3) , c(4:6) , c(7:9) ) ,
            layout=lay,vertex.label=rownames(dist) ,
            vertex.color="green" ,
            vertex.size=0.5 ,
            edge.arrow.size=13 ,
            main="")

#Finally I add a legend
legend("bottomleft", legend = c("Letter lovers" , "art lovers" , "math lovers"),
       col = rainbow(3, alpha = 0.3) ,
       pch = 15, bty = "n",  pt.cex = 1.5, cex = 0.8 ,
       text.col = "black", horiz = FALSE, inset = c(0.1, 0.1))

#There we can see that the known structure  is relevant. Nevertheless, it looks like the student JB, who is supposed to be strong in Math, is really close to people that are strong in Art. Actually he is strong in both !


# Tutorial from https://datascienceplus.com/finding-optimal-number-of-clusters/

# Import library `readr``
library('readr')

# Set correct directory
setwd("/home/ktt/Training/data_science_plus/")

# Load data from 'data.csv' (space delimited)
StudentKnowledgeData <- read_delim('data.csv', delim=' ')

# View data
View(StudentKnowledgeData)

# Can also check data using `head`
head(df)

# Pre processing
mydata <- StudentKnowledgeData

# Transform any categorical var
mydata <- as.data.frame(unclass(mydata))

# Remove any NA's
mydataclean <- na.omit(mydata)

# Check data again
summary(mydataclean)
dim(mydataclean)

# Scale and de-mean data
scaled_data = as.matrix((scale(mydataclean)))

# Try to cluster with k=3 means
# nstart attempts multiple initial configurations
kmm = kmeans(scaled_data, 3, nstart = 50,iter.max = 15)

kmm

# (between_SS / total_SS =  29.3 %) is low
# A measure of internal cohesion, external separation
# Want to try to increase without overfitting

# Elbow method to find optimal cluster numbers
set.seed(123)

# Compute and plot for k=2 to k=15
k.max <- 15
data <- scaled_data
wss <- sapply(1:k.max, function(k){kmeans(data, k, nstart=50, iter.max=15)$tot.withinss})

wss

# Plot k vs within cluster SS
plot(1:k.max, wss, type='b', pch=19, frame=FALSE,
     xlab='Num of clusters',
     ylab='Total within cluster SS')

# Not clear what is the best choice for k

# Use Bayesian Info Criterion
library(mclust)
d_clust <- Mclust(as.matrix(scaled_data), G=1:15,
                  modelNames = mclust.options('emModelNames'))
d_clust$BIC
plot(d_clust)

library(NbClust)
nb <- NbClust(scaled_data, diss = NULL, distance='euclidean',
              min.nc = 2, max.nc = 5, method = 'kmeans',
              index = 'all', alphaBeale = 0.1)
hist(nb$Best.nc[1,], breaks = max(na.omit(nb$Best.nc[1,])))


## Nesse script vamos gerar dados segundo uma binomial negativa e
## vamos ajustar alguns modelos aos dados e criticá-los

#########
# preparação
library(rstan)
rstan_options(auto_write = TRUE)
options(mc.cores = 4)

set.seed(666)

########
# Simulando os dados
N <- 100
sfactor <- 5 ## Var(X) = sfactor * E[X]
mu <- 10
X <- rnbinom(N, size = mu/(sfactor - 1), mu = mu)
hist(X, probability = TRUE, main = "Ovos de dragão (por macho)")

mean(X)
var(X)

dragonEgg.data <- list(N = N, x = X)
##
poisson.code = "
data{
  int<lower=1> N;
  int<lower=0> x[N];
}
parameters{
  real<lower=0> lambda;
}
model{
  target += poisson_lpmf(x | lambda);
  target += gamma_lpdf(lambda | 1, 1);
}
generated quantities{
 int<lower=0> x_rep[N];
  for(i in 1:N) x_rep[i] = poisson_rng(lambda);
}
"

fit.poisson <- stan(model_code = poisson.code, data = dragonEgg.data)
poisson.replicas <- extract(fit.poisson, 'x_rep')$x_rep

par(mfrow = c(2, 1))

hist(X, probability = TRUE, col = "red", main = "Os dados")
abline(v = mean(X), lwd = 3, lty = 2)
hist(as.vector(poisson.replicas), probability = TRUE,
     main = "Replicatas \n modelo Poisson", xlab = expression(x^{rep}))
abline(v = mean(X), lwd = 3, lty = 2)

par(mfrow = c(1, 1))

# Como nosso modelo "prevê" a média?
medias.poisson <- rowMeans(poisson.replicas)
hist(medias.poisson, probability = TRUE, xlab = expression(bar(x)),  main = "Médias \n modelo Poisson")
abline(v = mean(X), lwd = 3, lty = 2)

# E a variância?

variancias.poisson <- apply(poisson.replicas, 1, var)
hist(variancias.poisson, probability = TRUE,
     main = "Variâncias \n modelo Poisson", xlab = expression(hat(v)),
     xlim = c(min(variancias.poisson), 1.5*var(X)))
abline(v = var(X), lwd = 3, lty = 2)

## Veredito: o modelo não captura corretamente a variabilidade dos dados

## Vamos tentar um modelo hierárquico, mais complexo

poissonBinomial.code = "
data{
  int<lower=1> N;
  int<lower=0> x[N];
}
parameters{
  real<lower=0, upper=1> p;
  real<lower=0> lambda;
}
model{
  target += poisson_lpmf(x | lambda * p );
  target += beta_lpdf(p | 2, 2);
  target += gamma_lpdf(lambda | 1, 1);
}
generated quantities{
 int<lower=0> M_rep[N];
 int<lower=0> x_rep[N];
  for(i in 1:N){
    M_rep[i] = poisson_rng(lambda);
  }
  for(i in 1:N){
    x_rep[i] = binomial_rng(M_rep[i], p);
  }
}
"

fit.poissonBinomial <- stan(model_code = poissonBinomial.code, data = dragonEgg.data)
print(fit.poissonBinomial, pars = c('p', 'lambda') )
poissonBinomial.replicas <- extract(fit.poissonBinomial, 'x_rep')$x_rep

par(mfrow = c(2, 1))

hist(X, probability = TRUE, col = "red", main = "Os dados")
abline(v = mean(X), lwd = 3, lty = 2)
hist(as.vector(poissonBinomial.replicas), xlab = expression(x^{rep}),
     probability = TRUE, main = "Replicatas \n modelo Poisson-binomial")
abline(v = mean(X), lwd = 3, lty = 2)

# "Previsão" da média pelo modelo Poisson-binomial

par(mfrow = c(1, 1))

medias.poissonBinomial <- rowMeans(poissonBinomial.replicas)
hist(medias.poissonBinomial, probability = TRUE,
     xlab = expression(bar(x)),  main = "Médias \n modelo Poisson-binomial")
abline(v = mean(X), lwd = 3, lty = 2)

# Mais uma vez, vamos olhar a variância

variancias.poissonBinomial <- apply(poissonBinomial.replicas, 1, var)
hist(variancias.poissonBinomial, probability = TRUE,
     main = "Variâncias \n modelo Poisson-binomial", xlab = expression(hat(v)),
     xlim = c(min(variancias.poisson), 1.5*var(X)))
abline(v = var(X), lwd = 3, lty = 2)

## Resultado: o modelo ainda é ruim.

# Vamos tentar agora um modelo com uma estrutura hierárquica diferente

poissonGamma.code = "
data{
  int<lower=1> N;
  int<lower=0> x[N];
}
parameters{
  real<lower=0> alpha;
  real<lower=0> beta;
  real<lower=0> lambda[N];
}
model{
  target += poisson_lpmf(x | lambda);
  target += gamma_lpdf(lambda | alpha, beta);
  target += exponential_lpdf(alpha | 1);
  target += exponential_lpdf(beta | 1);
}
generated quantities{
 int<lower=0> x_rep[N];
  for(i in 1:N){
    x_rep[i] = poisson_rng(lambda[i]);
  }
}
"

fit.poissonGamma <- stan(model_code = poissonGamma.code, data = dragonEgg.data)
print(fit.poissonGamma, pars = c('alpha', 'beta') )
poissonGamma.replicas <- extract(fit.poissonGamma, 'x_rep')$x_rep

par(mfrow = c(2, 1))

hist(X, probability = TRUE, col = "red", main = "Os dados")
abline(v = mean(X), lwd = 3, lty = 2)
hist(as.vector(poissonGamma.replicas), xlab = expression(x^{rep}),
     probability = TRUE, main = "Replicatas \n modelo Poisson-gama")
abline(v = mean(X), lwd = 3, lty = 2)

# "Previsão" da média pelo modelo Poisson-Gamma

par(mfrow = c(1, 1))

medias.poissonGamma <- rowMeans(poissonGamma.replicas)
hist(medias.poissonGamma, probability = TRUE,
     xlab = expression(bar(x)),  main = "Médias \n modelo Poisson-Gama")
abline(v = mean(X), lwd = 3, lty = 2)

# Mais uma vez, vamos olhar a variância

variancias.poissonGamma <- apply(poissonGamma.replicas, 1, var)
hist(variancias.poissonGamma, probability = TRUE, xlab = expression(hat(v)) ,
     main = "Variâncias \n modelo Poisson-Gama", xlim = c(min(variancias.poisson), 1.5*var(X)))
abline(v = var(X), lwd = 3, lty = 2)

# Intervalos
quantile(as.vector(poisson.replicas), probs = c(.025, .975))
quantile(as.vector(poissonBinomial.replicas), probs = c(.025, .975))
quantile(as.vector(poissonGamma.replicas), probs = c(.025, .975))
qnbinom(p =  c(.025, .975), size = mu/(sfactor - 1), mu = mu)


context("Alpha diversity")
library(mbm)

x <- matrix(c(
	0,1,0,3,10,
	0,0,0,15,0,
	2,7,3,3,1), byrow=TRUE, nrow=3)

test_that("Species richness", {
	expect_error(richness(-1 * x))
	expect_identical(richness(x), rowSums(x > 0))
})

test_that("Simpson", {
	expect_error(simpson(x))
	expect_equal(simpson(x, proportion = FALSE), c(0.56, 1, 0.28), tol=0.005)
	expect_equal(simpson(x, proportion = FALSE), simpson(x/rowSums(x), proportion = TRUE))
})

test_that("Shannon", {
	expect_warning(shannon(x))
	expect_equal(shannon(x/rowSums(x)), c(0.76, 0, 1.42), tol=0.005)
})


# Uses OECD to create a large number of figures used in Study Guide

##################################################################################
# R&D worker data
##################################################################################
work <- get_dataset("PERS_FUNC")

fte <- work
fte <- fte[which(fte$SECTPERF %in% c("_T")),] # all sectors
fte <- fte[which(fte$FUNCTION %in% c("RSE")),] # researchers
fte <- fte[which(fte$GENDER %in% c("_T")),] # both genders
fte <- fte[which(fte$MEASURE %in% c("FTE")),] # FTE measured
fte <- fte[which(fte$COUNTRY %in% c("USA","JPN","KOR","CHN","DEU","GBR")),]

fte$lnrdworker <- log(fte$obsValue) # log value

##################################################################################
# Figures for R&D workers and Log R&D workers
##################################################################################
fig <- plot_ly(fte, x = ~obsTime, y = ~obsValue, linetype = ~COUNTRY, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'R&D Workers over time', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'FTE R&D Workers'),
              hovermode="x unified")
api_create(fig, filename = "oecd-rd-fte")

fig <- plot_ly(fte, x = ~obsTime, y = ~lnrdworker, linetype = ~COUNTRY, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'R&D Workers over time', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Log FTE R&D Workers'),
              hovermode="x unified")
api_create(fig, filename = "oecd-rd-lnfte")

##################################################################################
# Japan only - for case study
##################################################################################
jpn <- fte[which(fte$COUNTRY %in% c("JPN")),]
fig <- plot_ly(jpn, x = ~obsTime, y = ~lnrdworker, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Japanese R&D Workers over time', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Log FTE R&D Workers'),
              hovermode="x unified")
api_create(fig, filename = "oecd-rd-lnfte-jpn")

##################################################################################
# Get OECD data on R&D expenditures
##################################################################################
work <- get_dataset("GERD_TOE")

gerd <- work
gerd <- gerd[which(gerd$SECTPERF %in% c("_T")),]
gerd <- gerd[which(gerd$TYPE_COST %in% c("_T")),]
gerd <- gerd[which(gerd$MEASURE %in% c("DF6")),]
gerd <- gerd[which(gerd$COUNTRY %in% c("USA","JPN","KOR","CHN","DEU","GBR")),]
gerd$lnrd <- round(log(gerd$obsValue),digits=2)

##################################################################################
# Figures for R&D expenditures
##################################################################################
fig <- plot_ly(gerd, x = ~obsTime, y = ~lnrd, linetype = ~COUNTRY, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'R&D expenditure over time', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list(title = 'Log real R&D expenditures', type='log'),
              hovermode="x unified")
api_create(fig, filename = "oecd-rd-logrd")

fig <- plot_ly(gerd, x = ~obsTime, y = ~obsValue, linetype = ~COUNTRY, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'R&D expenditure over time', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list(title = 'Real R&D expenditures'),
              hovermode="x unified")
api_create(fig, filename = "oecd-rd-levelrd")


source("Bernoulli_data.r")
###
bb.data <- list(
  N0 = N_0,
  y0 = y_0,
  c = cc,
  d = dd,
  a_0 = .4
)
get_c_a0_bernoulli <- function(y0, n0, cc, dd, a_0){
  ans <- lbeta(a_0 * y0 + cc, a_0 *(n0 -y0) + dd)
  return(ans)
}

c_a0 <- function(x) {
  get_c_a0_bernoulli(
    y0 = bb.data$y0,
    n0 = bb.data$N0,
    cc = bb.data$c,
    dd = bb.data$d,
    a_0 = x
  )
}

constant_data <- read.csv("../data/Bernoulli_logCA0.csv")

library(mgcv)
fit.gam <- gam(lc_a0 ~ s(a0), data = constant_data)

K <- 1E4
pred_a0s <- seq(0, max(constant_data$a0), length.out = K)

a0_grid <- data.frame(a0 = pred_a0s, lc_pred = predict(fit.gam, newdata = data.frame(a0 = pred_a0s)))

curve(c_a0, 0, 5, xlab = expression(a[0]), ylab = expression(log(c(a[0]))), lwd = 3, lty = 2)
points(a0_grid$a0, a0_grid$lc_pred)

get_approx_lc <- function(x, grid){
  y <- grid[, 1]
  i <- which.min(abs(x-y))
  if(i != 1){
    x1 <- grid[i, 1]
    x2 <- grid[i + 1, 1]
    y1 <- grid[i, 2]
    y2 <- grid[i + 1, 2]
    ans <- y1 + (y2-y1) * (x-x1)/(x2-x1)
  }else{
    ans <- grid[i, 2]
  }
  return(ans)
}
app_f <- function(x) get_approx_lc(x, grid = a0_grid)
app_f <- Vectorize(app_f)

curve(c_a0, 0, 5, xlab = expression(a[0]), ylab = expression(log(c(a[0]))), lwd = 3, lty = 2)
curve(app_f, 0, 5, lwd = 3, col = 2, add = TRUE)
lines(a0_grid$a0, a0_grid$lc_pred, lwd = 2, lty = 2, col = 3)


get.expectation <- function(mix.par, mu1, mu2){
#Purpose:
# compute the expected value of a mixture with
# mix proportion = mix.par
# means =  mu1 and mu2
  expected.value <- mix.par*mu1+(1-mix.par)*mu2
  return(expected.value)
}


# Simple Linear Regression

# Importing the dataset
dataset = read.csv('Salary_Data.csv')
# install.packages('caTools')
# install.packages('ggplot2')

library(caTools)
library(ggplot2)
set.seed(123)

# Splitting the dataset into training set and test set
split = sample.split(dataset$Salary, SplitRatio = 2/3)
training_set = subset(dataset, split == TRUE)
test_set = subset(dataset, split == FALSE)

# Fitting Simple Linear Regression to the Training set
regressor = lm(formula = Salary ~ YearsExperience,
               data = training_set)

# Predicting the Test results
y_pred = predict(regressor, newdata = test_set)

# Visualising the Training set results
ggplot() +
  geom_point(aes(x = training_set$YearsExperience, y = training_set$Salary),
             colour = 'red') +
  geom_line(aes(x = training_set$YearsExperience, y = predict(regressor, newdata = training_set)),
            colour = 'blue') +
  ggtitle('Salary vs Experience (Training Set)') +
  xlab('Years of Experience') +
  ylab('Salary')

ggplot() +
  geom_point(aes(x = test_set$YearsExperience, y = test_set$Salary),
             colour = 'red') +
  geom_line(aes(x = training_set$YearsExperience, y = predict(regressor, newdata = training_set)),
             colour = 'blue') +
  ggtitle('Salary vs Experience (Test Set)') +
  xlab('Years of Experience') +
  ylab('Salary')


library(R.matlab)
library(mmtsne)
library(tidyverse)
library(ggrepel)

set.seed(3141)

wa <- readMat('./data/wa1000.mat')
symwa <- p2sp(wa$P)
labels <- unlist(wa$words)
maps <- mmtsneP(symwa, no_maps=10, max_iter=3000)

idx <- sample.int(n=1000, size=100, replace=FALSE)

plots = list()

for(map in c(1:10)){
  coords <- maps$Y[,,map]
  x <-  coords[idx,1]
  y <- coords[idx,2]
  pts <- data_frame(x,y)

  plots[[map]] = ggplot(pts, aes(x,y, label=labels[idx])) +
    geom_text_repel() +
    geom_point(color='red')
}

pdf("plots.pdf")
for (i in 1:10) {
  print(plots[[i]])
}
dev.off()


rm(list = ls())
library(sandwich)
library(lmtest)
setwd("C:/Users/natty/OneDrive/Documents/Econ 143")
data <- read.csv("Final Data.csv")
head(data)
#Base Regression
firstreg <- lm(Inflation.Percentage ~ Unemployment.Difference + TB3MS, data = data)
firstregsum <- summary(firstreg)
prediction1 <- (firstregsum$coefficients[1,1] + firstregsum$coefficients[2,1]*data$Unemployment.Difference
+ firstregsum$coefficients[3,1]*data$TB3MS)
data$error1 <- (data$Inflation.Percentage - prediction1)
firstregsum
#White Test for Heteroskedasticity
white <- lm(I(error1^2) ~ Unemployment.Difference + TB3MS, data = data)
whitesum <- summary(white)
whitesum
plot(as.Date(data$ï..Date), data$error1,xlab = "Dates", ylab = "Residuals")
#Durbin-Watson Test for Autocorrelation
dwtest(firstreg)
#HAC Estimators First Regression
vcovmat <- vcovHAC(firstreg)
vcovmat
beta1t <- firstregsum$coefficients[1,1]/vcovmat[1,1]
beta1t
beta1p <- 1 - pnorm(beta1t)
beta1p
beta1SE <- sqrt(vcovmat[1,1])
beta1SE
beta2t <- firstregsum$coefficients[2,1]/vcovmat[2,2]
beta2t
beta2p <- pnorm(beta2t)
beta2p
beta2SE <- sqrt(vcovmat[2,2])
beta2SE
beta3t <- firstregsum$coefficients[3,1]/vcovmat[3,3]
beta3t
beta3p <- 1 - pnorm(beta3t)
beta3p
beta3SE <- sqrt(vcovmat[3,3])
beta3SE
#RESET Test (second regression)
secondreg <- lm(Inflation.Percentage ~ Unemployment.Difference + TB3MS + I(Unemployment.Difference^2)
                + Unemployment.Difference*TB3MS + I(TB3MS^2) , data = data)
secondregsum <- summary(secondreg)
secondregsum
#HAC estimators second regression
vcovmat2 <- vcovHAC(secondreg)
vcovmat2
beta1t2 <- secondregsum$coefficients[1,1]/vcovmat2[1,1]
beta1t2
beta1p2 <- 1 - pnorm(beta1t2)
beta1p2
beta1SE2 <- sqrt(vcovmat2[1,1])
beta1SE2
beta2t2 <- secondregsum$coefficients[2,1]/vcovmat2[2,2]
beta2t2
beta2p2 <- pnorm(beta2t2)
beta2p2
beta2SE2 <- sqrt(vcovmat2[2,2])
beta2SE2
beta3t2 <- secondregsum$coefficients[3,1]/vcovmat2[3,3]
beta3t2
beta3p2 <- 1 - pnorm(beta3t2)
beta3p2
beta3SE2 <- sqrt(vcovmat2[3,3])
beta3SE2
beta4t2 <- secondregsum$coefficients[4,1]/vcovmat2[4,4]
beta4t2
beta4p2 <- 1 - pnorm(beta4t2)
beta4p2
beta4SE2 <- sqrt(vcovmat2[4,4])
beta4SE2
beta5t2 <- secondregsum$coefficients[5,1]/vcovmat2[5,5]
beta5t2
beta5p2 <- 1 - pnorm(beta5t2)
beta5p2
beta5SE2 <- sqrt(vcovmat2[5,5])
beta5SE2
beta6t2 <- secondregsum$coefficients[6,1]/vcovmat2[6,6]
beta6t2
beta6p2 <- 1 - pnorm(beta6t2)
beta6p2
beta6SE2 <- sqrt(vcovmat2[6,6])
beta6SE2


#This is a tutorial uses R package "arules" to analyze the market basket data.

# Load the libraries

# library manuals

# https://cran.r-project.org/web/packages/arules/arules.pdf
# https://cran.r-project.org/web/packages/arulesViz/vignettes/arulesViz.pdf
# http://www.salemmarafi.com/code/market-basket-analysis-with-r/

# install.packages(arules)
# install.packages(arulesViz)
library(arules)
library(arulesViz)

# Load the dataset

groceries <- read.transactions("/Users/byu/Desktop/Data/groceries.csv", format="basket", sep="," )

# We can explore the data before we make any rules. The following script is going to create an item frequency plot for the top 20 items.
# "type" indicates whether item frequencies should be displayed relative or absolute

itemFrequencyPlot(groceries,topN=20,type="absolute")

# Mine rules with the Association Rule algorithm.
# It is required to set the minimum support and confidence values.

rules <- apriori(groceries, parameter = list(supp = 0.001, conf = 0.8))

# Show the top 5 rules, rounding with 2 digits
# From the top 5 rules, we could notice that the rule {bottled beer, soups} => {whole milk} is strong, indicating bottled beer and soups are frequently bought together with whole milk. So we would suggest to place these items close to each other.

options(digits=2)
inspect(rules[1:5])

# Get summary info about all rules

summary(rules)

# Sort rules so that we can view the most relevant rules first. For example, sort rules with "confidence":

rules<-sort(rules, by="confidence", decreasing=TRUE)

# If we want to target items to generate rules. For example, the frequently bought items with “whole milk”:
# "minlen" is to avoid empty left hand side items.

rules<-apriori(data=groceries, parameter=list(supp=0.001,conf = 0.08, minlen=2),
               appearance = list(default="lhs",rhs="whole milk"),
               control = list(verbose=F))
rules<-sort(rules, decreasing=TRUE,by='confidence')
inspect(rules[1:5])

# Likewise, we could set "whole milk" on the left hand side as well.

rules<-apriori(data=groceries, parameter=list(supp=0.001,conf = 0.15,minlen=2),
               appearance = list(default="rhs",lhs="whole milk"),
               control = list(verbose=F))
rules<-sort(rules, decreasing=TRUE,by="confidence")
inspect(rules[1:5])

# Visualize the rules
# if you encounter "tcl/tk not available" error on mac, see if this page can help you
# http://planspace.org/2013/01/17/fix-r-tcltk-dependency-problem-on-mac/

#plot(rules,method="graph",interactive=TRUE,shading=NA)

# get the top 10 rules sorted by lift

subrules2 <- head(sort(rules, by="lift"), 10)

# plot these rules

plot(subrules2, method="graph")

# plot these rules interactively

plot(subrules2, method="graph", interactive=TRUE)

Unit 3 - Association Rule Mining/groceries.r


# Adding a column to a matrix

# Construct star_wars_matrix
box_office <- c(460.998, 314.4, 290.475, 247.900, 309.306, 165.8)
region <- c("US", "non-US")
titles <- c("A New Hope",
            "The Empire Strikes Back",
            "Return of the Jedi")

star_wars_matrix <- matrix(box_office,
                      nrow = 3, byrow = TRUE,
                      dimnames = list(titles, region))

# The worldwide box office figures
worldwide_vector <- rowSums(star_wars_matrix)

# Bind the new variable worldwide_vector as a column to star_wars_matrix
all_wars_matrix <- cbind(star_wars_matrix, worldwide_vector)

# cbind(): can add a column or multiple columns to a matrix, which merges matrices and/or vectors together by column

# Total revenue for US and non-US
total_revenue_vector <- colSums(all_wars_matrix)

# Print out total_revenue_vector
total_revenue_vector


#'@title Get the trend of a given time series
#'
#'@description This function uses stl to determine a time series' trend
#'
#'@usage  tsData.tr <- getTrend(tsData)
#'
#'@param tsData  A time series object.
#'
#'@return A time series that represents the trend of the given time series.
#'
#'@export

getTrend <- function(tsData)
{

    tsObj       <- tsData
	tsObj.stl   <- stats::stl(tsObj,s.window="periodic",robust=T)
	tsObj.trend <- tsObj.stl$time.series[,"trend"]

	return (tsObj.trend)

}


##########
plot.hdr2d<-function(x,prob=c(.025,.25,.5,.75,.975),bw=c(5,5),
       cols=gray(  ((length(prob)-1):1)/length(prob)),
       xlim=range(x[,1]),ylim=range(x[,2]),...)
{

  #adapted from package hdrcde by Rob J Hyndman and Jochen Einbeck

  plot(c(0,0),xlim=xlim,ylim=ylim,type="n",...)
  add.hdr2d(x,prob,bw,cols)
}

#########

#########
add.hdr2d<-function(x,prob=c(.025,.25,.5,.75,.975),bw=c(5,5),
       cols=gray(  ((length(prob)-1):1)/length(prob)  ))
{

  require(ash)
  den <- ash2(bin2(x,nbin=round(rep(.5*sqrt(dim(x)[1]),2)) ), bw)
  fxy <- interp.2d(den$x,den$y,den$z,x[,1],x[,2])
  falpha <- quantile(sort(fxy), prob)
  index <- (fxy==max(fxy))
  mode <- c(x[index,1],x[index,2])
  .filled.contour(den$x,den$y,den$z,levels=c(falpha,1e10),col=cols )

}

##########
filledcontour<-function(x,y,z,nlevels=10,col=gray( (nlevels:0)/nlevels ),
                levels=pretty(range(z),nlevels) )
{
   .filled.contour(x,y,z,levels=c(levels,1e10),col=col )
}
##########

#########
interp.2d<- function(x, y, z, x0, y0)
{
    # Bilinear interpolation of function (x,y,z) onto (x0,y0).
    # Taken from Numerical Recipies (second edition) section 3.6.
    # Called by hdr.info.2d
    # Vectorized version of old.interp.2d.
    # Contributed by Mrigesh Kshatriya (mkshatriya@zoology.up.ac.za)

    nx <- length(x)
    ny <- length(y)
    n0 <- length(x0)
    z0 <- numeric(length = n0)
    xr <- diff(range(x))
    yr <- diff(range(y))
    xmin <- min(x)
    ymin <- min(y)
    j <- ceiling(((nx - 1) * (x0 - xmin))/xr)
    k <- ceiling(((ny - 1) * (y0 - ymin))/yr)
    j[j == 0] <- 1
    k[k == 0] <- 1
    j[j == nx] <- nx - 1
    k[k == ny] <- ny - 1
    v <- (x0 - x[j])/(x[j + 1] - x[j])
    u <- (y0 - y[k])/(y[k + 1] - y[k])
    AA <- z[cbind(j, k)]
    BB <- z[cbind(j + 1, k)]
    CC <- z[cbind(j + 1, k + 1)]
    DD <- z[cbind(j, k + 1)]
    z0 <- (1 - v)*(1 - u)*AA + v*(1 - u)*BB + v*u*CC + (1 - v)*u*DD
    return(z0)
}
#########


## From table S 8 as it matches nothing I can find in code...

psi.h <- c(.039,.001,.006,.009,.026,.04,.042,.045,.05,.074,.138,.198,.247,.414,.638,1,.873,.104,.873)
psi.ic <- c(.243,.289,.338,.389,.443,.503,.570,.653,.756,.866,.954,1,.972,.854,.645,.402,.107,.784,.107)
psi.hd <- c(.039,.037,.035,.035,.036,.039,.045,.055,.074,.107,.157,.238,.353,.502,.675,.832,1,.134,1)
psi.icd <- c(.282,.286,.291,.299,.310,.328,.353,.39,.446,.52,.604,.705,.806,.899,.969,1,.918,.519,.918)
psi.wd <- c(.091,.083,.077,.074,.074,.076,.08,.086,.093,.102,.117,.148,.211,.332,.526,.753,1,.114,1)


"
Создать десять переменных разных типов, проверить их тип с помощью функции typeof().
Проверить с помощью этой функции типы следующих констант
29, 23i, -34L, 2/3, 4/2, 0xA, 0XbL – 120L, 0XbL – 120, 0XbL * 17.
Объяснить полученные результаты.
"

#Десять переменных
print("Вывод 10 переменных разных типов")
a <- "String"
typeof(a)
b <- 1.2
typeof(b)
c1 <- c(1,2,5.3,6,-2,4)
typeof(c1)
d <- 10i
typeof(d)
e <- matrix(1:20, nrow=5,ncol=4)
typeof(e)
f <- list(name="Fred", age=5.3)
typeof(f)
g <- c(rep("male",20), rep("female", 30))
g <- factor(g)
typeof(g)
h = FALSE
print(h)
i = 0xAb
typeof(i)

#Вывод констант и их типов
print("Вывод констант и их типов")
localelist <- list(29, 23i, -34L, 2/3, 4/2, 0xA, 0XbL - 120L, 0XbL - 120, 0XbL * 17.)
for (element in localelist) {
  print(element)
  print(typeof(element))
}


 ZHETRD Example Program Results

 Diagonal and off-diagonal elements of tridiagonal form

     i         D            E
     1     -2.28000      4.33846
     2     -0.12846      2.02259
     3     -0.16659      1.80232
     4     -1.92495


# File name: mcpi_pbdr.r
# Description: Calculate pi using Monte Carlo
# Run: mpiexec -np 8 Rscript --vanilla mcpi_pbdr.r

# Load pbdMPI and initialize the communicator
library(pbdMPI, quiet = TRUE)
init()

#Load mcpi() function (on each rank)
source("mcpi.r")

# Number of total points to use
n.pts <- 1e7
# Number of points per rank
n.ranks <- comm.size()
n.pts.rank <- ceiling(n.pts / n.ranks)

comm.print(paste('running pbdMPI version with n.pts = ',n.pts,' and nranks = ',n.ranks,' (',n.pts.rank,' pts per rank) \n'))

tm.comp.st = Sys.time()

# Compute pi() on each rank
pi.rank <- mcpi(n.pts.rank)

# Use reduce() to total across ranks
pi.approx <- reduce(pi.rank, op="sum") / n.ranks

tm.comp = as.numeric(Sys.time() - tm.comp.st, units="secs")

pi.err <- abs(pi - pi.approx)/pi

# Output from RANK 0 since reduce() will dump only to 0 by default
comm.print(paste('approximate value of pi is: ',pi.approx,'\n'))
comm.print(paste('            relative error: ',pi.err,'\n'))

comm.print(paste('  computational time = ',tm.comp,'\n'))

# Wrap up
finalize()


library(Brobdingnag)

factorial <- function(n) {
  if (n <= 1)
    return(1)

  return(n * factorial(n - 1))
}

binomial_coefficient <- function(m, k) {
  return(factorial(m)/(factorial(k)*factorial(m-k)));
}

message("m")
m <- scan("stdin", nlines=1)
message("k")
k <- scan("stdin", nlines=1)

print(as.numeric(binomial_coefficient(as.brob(m), as.brob(k))))


install.packages("readxl")
library("readxl")
data <- read_excel("~/Desktop/hospital.xlsx")

dim(data)

str(data)

box_vals <- boxplot(data$`length of stay`, ylab = "length of stay")$out

outliers <- which(data$`length of stay` %in% box_vals)
data_new <- data[-outliers,]

qqnorm(data_new$`length of stay`, ylab = "length of stay",
       pch = 1, frame = FALSE)
qqline(data_new$`length of stay`, col = "red", lwd = 2)

shapiro.test(data_new$`length of stay`)

t.test(data_new$`length of stay`, mu = 9)

data_rand <- data_new[sample(nrow(data_new), ceiling(0.8*nrow(data_new))),]

dim(data_rand)

str(data_rand)

data_rand$region <- factor(data_rand$region)
data_rand$`medical school affiliation`[data_rand$
          `medical school affiliation` %in% 2] <- 0

str(data_rand)

logit <- glm(`medical school affiliation` ~ `infection risk` + region +
    `average daily census`, data = data_rand, family = binomial("logit"))

summary(logit)
confint(logit)

install.packages("aod")
library(aod)
wald.test(b = coef(logit), Sigma = vcov(logit), Terms = 2:6)


#!/usr/bin/Rscript

# R (http://www.r-project.org/) script
# from https://en.wikipedia.org/wiki/R_(programming_language)#Basic_syntax

x <- 1:6              # Create vector.
y <- x^2              # Create vector by formula.

print(y)              # Print the vector’s contents.

mean(y)               # Arithmetic mean of vector.

var(y)                # Sample variance of vector.

model <- lm(y ~ x)    # Linear regression model y = A + B * x.

print(model)          # Print the model’s results.

summary(model)        # Display an in-depth summary of the model.

png("out/model.png")  # Specify the png output file name
par(mfrow = c(2, 2))  # Create a 2 by 2 layout for figures.
plot(model)           # Plot diagnostic plots of the model.

pdf("out/model.pdf")  # Specify the pdf output file name
par(mfrow = c(2, 2))  # Create a 2 by 2 layout for figures.
plot(model)           # Plot diagnostic plots of the model.


library(animation)
n <- seq(100,50000,length.out = 30)
ntrials <- 190; p <- 0.6
x <- 80:140
par(mar = c(4.1,5.1,2,4.1))
ani.options(interval = 0.5)
saveGIF({
  for(i in 1:length(n)){
    sample <- rbinom(n[i],ntrials,p)
    denst <- dbinom(x,ntrials,p)
    f <- hist(sample,xlab = "x",ylab = "frequeny of x", main = "",freq = FALSE,
     yaxt = "n",col = "lightgrey",border = "lightgrey",
     xaxt = "n",ylim = range(denst),xlim = range(x),breaks = seq(0,max(sample)))

    lines(x,denst,lwd = 2)
axis(1,line = 1)
a <- axis(4)
mtext(4,line = 3,text = "P(X = x) for X ~ Bin(190,0.6)")
axis(2, at = seq(0,max(f$density),length.out = 7), labels = round(seq(0,max(f$counts),length.out = 7),0) )
title(main = paste("n = ",format(n[i],scientific = 999,digits = 0),sep = ""))
  }
},movie.name = "hist.gif")


 DGEQPF Example Program Results

 Least squares solution
          1       2
 1  -0.0370 -0.0044
 2   0.0647 -0.0335
 3   0.0000  0.0000
 4  -0.0515  0.0018
 5   0.0066  0.0102


# ......................................................................................
# ...........Exercise 5 - Selected distributions of a discrete 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, Cumulative Probability(Distribution) and Quantile ####
# functions
#
# ** Probability function ####
#
# - starts with the letter **d**: $p = P(X = x)$: p=d...(x,...)
#
# ** Cumulative Probability(Distribution Function) ####
#
# - starts with the letter **p**: $p = P(X \leq x)$:p=p...(x,...)
#
# - note that Cumulative probability in R is with the alternative definition $P(X \leq
# t)$
#
# - for our distribution function $F(t) = P(X<t)$: F(t)=p...(t - 1,...)
#
# ** Quantile function ####
#
# - starts with the letter **q**: $p \geq P(X \leq x)$: x=q...(p,...)
#
# - searches for the smallest $x$ for which $P(X \leq x)$ is greater than $p$
#

# * Binomial(Alternative): $X \sim Bi(n, π),X \sim A(π) = Bi(1, π)$ ####
#
# - number of successes in $n$ Bernoulli attempts(or for one attempt in the case of
# Alternative dist.)
#
# - every attempt has a chance of success $π$
#

# Probability function P(X=x)
x = 10   # value for which we are looking for a p-st function
n = 21   # selection range
p = 0.5  # probability of success
dbinom(x, n, p)

dbinom(3.2, n, p)

options(warn=-1) # this can be used to turn off warnings

dbinom(3.2, n, p)

options(warn=0) # this is switched on again

# draw a probability function
x = 0:21 # minimum 0, maximum n has a positive probability
P_x = dbinom(x, n, p)
plot(x, P_x)
grid()

# Cumulative probability function P(X<=x)
x = 10   # value for which we are looking for a value of cumulative prob function
n = 21   # selection range
p = 0.5  # probability of success
pbinom(x, n, p)

# Distribution function F(x)=P(X<x)
x = 10   # value for which we are looking for a value of cumulative prob function
n = 21   # selection range
p = 0.5  # probability of success
pbinom(x, n, p) - dbinom(x, n, p)
# or
pbinom(x - 1, n, p)

# we plot the distribution function
x = 0:21 # minimum 0, maximum n has a positive probability
P_x = dbinom(x, n, p)
F_x = cumsum(P_x)
plot(x, F_x, type='s')
grid()

# or
x = seq(0, 21, 0.01) # minimum 0, maximum n
options(warn=-1)
F_x = pbinom(x, n, p) - dbinom(x, n, p)
plot(x, F_x, cex=0.3)
grid()
options(warn=0)

# check correctness at 10
x = seq(9.9, 10.1, 0.01) # minimum 0, maximum n
options(warn=-1)
F_x = pbinom(x, n, p) - dbinom(x, n, p)
options(warn=0)
plot(x, F_x, cex=0.5)
grid()

# find x for given q: q=P(X<=x)
q = 0.7  # h
n = 21   # selection range
p = 0.5  # probability of success
qbinom(q, n, p)
pbinom(11, n, p)
pbinom(12, n, p)
pbinom(13, n, p)

# Quantile function(inversion of dist. Function): q=F(x)=P(X<x)
q = 0.7   # probability for which we are looking for a quantile
n = 21   # selection range
p = 0.5  # probability of success
qbinom(q, n, p) + 1
pbinom(12 - 1, n, p)
pbinom(13 - 1, n, p)
pbinom(14 - 1, n, p)

# * Hypergeometric: $X \sim H(N, M, n)$ ####
#
# - number of successes in $n$ dependent attempts
#
# - type dependence:
#
#     - $N$ objects,
#
#     - of which $M$ objects with specified property,
#
#     - size of the selection $n$
#
#     - **we do not return back when selecting - the probability of selecting an object
# with a given property changes with each additional selected object**
#
# - **R function takes as parameters * hyper(k, M, N - M, n)**
#
# - k is the number of successes for which we calculate the probability,
#
# - M is the number of objects with the specified property,
#
# - NM is the number of objects without the specified property,
#
# - n is the target size of the selection.
#

# Probability function P(X=x)
x = 5   # value for which we are looking for a p-st function
N = 20  # total number of objects
M = 5   # of which with specified property
n = 10  # selection size
dhyper(x, M, N - M, n)

# plot a probability function
x = 0:5 # minimum 0, maximum n or M has a positive truth.
P_x = dhyper(x, M, N - M, n)
plot(x, P_x)
grid()

# Distribution function F(x)=P(X<x)
x = 5   # value for which we are looking for dist. function
N = 20  # total number of objects
M = 5   # of which with specified property
n = 10  # selection size
phyper(x - 1, M, N - M, n)

# plot the Distribution function
x = 0:5 # minimum 0, maximum n or M has a positive truth.
P_x = dhyper(x, M, N - M, n)
F_x = cumsum(P_x)
plot(x, F_x, type='s')
grid()

# Quantile function(inversion of dist. Function): q=P(X<x)
q = 0.7 # probability for which we are looking for a quantile
N = 20  # total number of objects
M = 5   # of which with specified property
n = 10  # selection size
qhyper(q, M, N - M, n) + 1
phyper(3 - 1, M, N - M, n)
phyper(4 - 1, M, N - M, n)
phyper(5 - 1, M, N - M, n)

# * Negative binomial(Geometric): $X \sim NB(k, π), X \sim Ge(π) = NB(1, π)$ ####
#
# - number of attempts up to $k$-th success(inclusive)
#
# - Every attempt has a chance of success $π$
#
# - **Negatively binomial NV is defined in R as the number of failures before the
# success**
#
# - therefore we will send x - k as the first parameter
#

# Probability function P(X=x)
x = 15   # number of attempts for which we are looking for prob. fc
k = 5    # required number of successes
p = 0.3  # prob. of individual trials
# Note that the first argument must be the number of failures
dnbinom(x - k, k, p)

# let's plot the probability function
x = 0:40 # minimum k, maximum unlimited
P_x = dnbinom(x - k, k, p)
plot(x, P_x)
grid()
# values 0,1,2,3,4 have P(x)=0

# Distribution function F(x)=P(X<x)
x = 15   # number of attempts for which we are looking for prob. fci
k = 5    # required number of successes
p = 0.3  # true individual trials
# Note that the first argument must be the number of failures
pnbinom(x - k - 1, k, p)

# let's draw the Distribution function
x = 0:40 # minimum 0, maximum n or M has a positive prob.
P_x = dnbinom(x - k, k, p)
F_x = cumsum(P_x)
plot(x, F_x, type='s')
grid()

# Quantile function(inversion of dist. Function): q=P(X<x)
q = 0.7  # prob. for quantile
k = 5    # required number of successes
p = 0.3  # true individual trials
qnbinom(q, k, p) + k + 1
pnbinom(19 - k - 1, k, p)
pnbinom(20 - k - 1, k, p)
pnbinom(21 - k - 1, k, p)

# * Poisson: $X \sim Po(λt)$ ####
#
# - number of events in the Poisson process in a closed area(in time, area, volume)
#
# - with occurrence density $λ$
#
# - in time/area/volume of size $t$
#

# Probability function P(X=x)
x = 9       # number of attempts for which we are looking for prob. fci
lambda = 5  # density of occurrence
t = 2       # area/time/volume
lt = lambda*t
dpois(x, lt)

# draw a probability function
x = 0:25 # minimum 0, maximum unlimited
P_x = dpois(x, lt)
plot(x, P_x)
grid()

# Distribution function F(x)=P(X<x)
x = 9       # number of attempts for which we are looking for prob. fci
lambda = 5  # density of occurrence
t = 2       # time/area
lt = lambda*t
ppois(x - 1, lt)

# let's plot the Distribution function
x = 0:25 # minimum 0, maximum n or M has a positive prob.
P_x = dpois(x, lt)
F_x = cumsum(P_x)
plot(x, F_x, type='s')
grid()

# Quantile function(inversion of dist. Function): q=P(X<x)
q = 0.4     # prob. for quantile
lambda = 5  # density of occurrence
t = 2       # time/area
lt = lambda*t
qpois(q, lt) + 1
ppois(9 - 1, lt)
ppois(10 - 1, lt)
ppois(11 - 1, lt)

#  Examples ####
#
# * Example 1. ####
#
# Bridge is played with 52 bridge cards, which are dealt among 4 players. There are
# always 2 players playing together. When dealing(13 cards) you received 2 aces. What is
# the probability that your partner will have the remaining two aces?
#

# X... number of aces among 13 cards
# X~H(N=39, M=2, n=13)
# P(X=2)
M = 2
N = 39 # 52-13
n = 13
# calculation
dhyper(2, M, N - M, n) # which is dhyper(2,2,37,13)

# probability function graph
x = 0:M   # all possible implementations of NV X.
p = dhyper(x, M, N - M, n) # values of the probability function for x
plot(x, p)

# * Example 2. ####
#
# Experiments have shown that a radioactive substance emits within 7.5 s an average of
# 3.87 α-particles. Determine the probability that this substance will emit at least one
# α-particle in 1 second.
#

# X... number of radiated alpha particles during 1 s
# X~Po(lt=3.87/7.5)

lambda = 3.87/7.5 # frequency of occurrence
t = 1 # in 1 second
lt = lambda*t # Poisson distribution parameter

# P(X>=1)=P(X>0)=1 - P(X<=0)
1 - ppois(1 - 1, lt)

# probability function graph
# theoretically up to an infinite number of particles can be emitted,
# from a certain value the probability is negligible
x = 0:10
p = dpois(x, lt) # probability function values for x
plot(x, p)

# * Example 3. ####
#
# A friend sends you to the cellar to bring 4 bottled beers - two 10˚ and two 12˚. You
# don't know where to turn the light on, so you take 4 bottles blindly. How likely were
# you to comply with the requirement if you knew that there were a total of 10 10˚ and 6
# 12˚ in the base?
#

# X... number of 10 ° beers among 4 selected
# X~H(N=16, M=10, n=4)

x = 2
N = 16
M = 10
n = 4

# P(X=2)
dhyper(x, M, N - M, n)

# graph of probability function
x = 0:4    # all possible implementations of NV X.
p = dhyper(x, M, N - M, n) # values of the probability function for x
plot(x, p)

# * Example 4. ####
#
# On average, there are 15 certain microorganisms in one milliliter of a perfectly mixed
# solution. Determine the probability that there will be less than 5 of these
# micro-organisms in a test tube if a sample of 1/2 milliliter is randomly selected.
#

# X... number of microorganisms in 0.5 ml solution
# X~Po(lt=15/2)

lambda = 15
t = 1/2
lt = lambda*t   # Poisson distribution parameter

# P(X<5)=P(X<=4)
ppois(5 - 1, lt)
# or
ppois(5,lt) - dpois(5,lt)

# graph of probability function
# in theory there may be an infinite number of microorganisms in solution,
# from a certain value the probability is negligible
x = 0:20
p = dpois(x, lt) # values of the probability function for x
plot(x, p)

# * Example 5. ####
#
# Throw 15 coins on the table. What is the probability that the number of coins lying
# face up is from 8 to 15?
#

# X... number of coins that fall face up out of a total of 15 coins
# X~Bi(n=15, p=0.5)

n = 15
p = 0.5

# P(8<=X<=15)=P(X<=15) - P(X<8)=P(X<=15) - P(X<=7)
pbinom(15, n, p) - pbinom(7, n, p)

# otherwise: P(8<=X<=15)=P(X>7)=1-P(X<=7)
1 - pbinom(7, n, p)

# graph of probability function
x = 0:15    # all possible implementations of NV X.
p = dbinom(x, n, p) # values of the probability function for x
plot(x, p)

# * Example 6. ####
#
# The probability that we will call the studio of the radio station that has just
# announced a telephone competition is 0.08. What is the probability that we will manage
# to get in on the 4th attempt at the most?
#

# X... number of attempts before we call the radio studio
# X~NB(k=1, p=0.08) or G(0.08)

x = 4
k = 1
p = 0.08

# P(X<=4)
pnbinom(x - k, k, p)

# graph of probability function
# theoretically we can make infinitely many attempts,
# from a certain value the probability is negligible
x = 1:40
p = dnbinom(x - k, k, p) # probability function values for x
plot(x, p)

# * Example 7. ####
#
# In average 10% of the components produce at the factory are defective. What is the
# probability that if we select thirty components from the daily production, at least
# two will be defective?
#

# X... number of defective parts out of 30 selected
# X~Bi(n=30, p=0.1)

n = 30
p = 0.1

# P(X>=2)=1 - P(X<2)=1 - P(X<=1)
1 - pbinom(1, n, p)

# or P(X>=2) all except 0 and 1
1 - (dbinom(0, n, p) + dbinom(1, n, p))

# graph of probability function
x = 0:30            # all possible implementations of NV X.
p = dbinom(x, n, p) # values of the probability function for x
plot(x,p)

# * Example 8. ####
#
# There are 200 parts in stock. 10% of them are defective. What is the probability that
# if we select thirty parts from the warehouse, at least two will be defective?
#

# X... number of defective parts out of 30 selected from 200
# X~H(N=200, M=20, n=30)

N = 200
M = 20
n = 30

# P(X>=2)=1 - P(X<2)=1 - P(X<=1)
1 - phyper(2 - 1, M, N - M, n)

# graph of probability function
x = 0:30   # all possible implementations of NV X.
p = dhyper(x, M, N - M, n) # probability function values for x
plot(x, p)

# * Example 9. ####
#
# In a company, it was found that some illegal software was installed on 33% of
# computers. Determine the probability and distribution function of the number of
# computers with illegal software among the three computers inspected.
#

# X... number of computers with illegal software out of 3 checked
# X~Bi(n=3, p=0.33)

n = 3
p = 0.33

# probabilistic function
x = 0:3  # all possible implementations of NV X
p = dbinom(x, n, p) # probability function values for x

p = round(p, 3) # rounding probabilities to 3 des. places
p[4] = 1 - sum(p[1:3]) # completion of the last value by 1

tab = rbind(x, p) # Create probability function table
rownames(tab) = c("x", "P(x)")
tab

# probability function graph
plot(x, p)

# distribution function
cumsum(p) # simplified distribution function listing

# * Example 10. ####
#
# Sportka is a lottery game in which the bettor bets six numbers out of forty-nine,
# which he expects to fall in a future draw. To participate in the game, it is necessary
# to choose at least one combination of 6 numbers (always 6 numbers per column of 49
# numbers) and use crosses to mark picked numbers. You can bet multiple times by filling
# multiple columns. The bettor wins if he guesses at least three numbers from the drawn
# six numbers. What is the probability that in order for the bettor to win, he will have
# to fill in:
#

# First the probability that we get in one column

# Y... number of guessed numbers in 6 drawn from 49
# Y~H(N=49, M=6, n=6)

N = 49
M = 6
n = 6

# P-st guess at least 3 numbers in one column
# P(Y>=3)=1 - P(Y<3)=1 - P(Y<=2)
pp = 1 - phyper(3 - 1, M, N - M, n)
pp

# ** a) ####
#
# just three columns,
#

# X… the number of columns a bettor will have to fill in order to win
# X~NB(k=1, p=pp)

# a) P(X=3)
k = 1
p = pp

dnbinom(3 - k, k, pp)

# ** b) ####
#
# at least 5 columns,
#

# b) P(X>=5)=1 - P(X<5)=1 - P(X<=4)

1 - pnbinom(5 - k - 1, k, pp)

# ** c) ####
#
# less than 10 columns,
#

# c) P(X<10)=P(X<=9)
pnbinom(10 - k - 1, k, pp)

# * d) ####
#
# more than 5 and at most 10 columns?
#

# P(5<X<=10)=P(X<=10) - P(X<=5)
pnbinom(10 - k, k, pp)-pnbinom(5 - k, k, pp)
# or P(X<11) - P(X<6)
pnbinom(11 - k - 1, k, pp)-pnbinom(6 - k - 1, k, pp)

# * Example 11. ####
#
# The probability of throwing 6 on a 6-wall cube is 1/6. We roll until we roll six 10
# times.
#
# ** a) ####
#
# What is the mean value of the number of throws.
#

# X… rolls the dice before we roll 10 sixes
# X~NB(k=10, p=1/6)

k = 10
p = 1/6

E_X = k/p
E_X

# ** b) ####
#
# How many throws do we have to count on if we want the probability of throwing 10 sixes
# to be at least 70%.
#

# P(X<=k)>=0.7
qnbinom(0.7, k, p) + k


setwd("~/Dropbox/project/studyguide/data")
source("~/Dropbox/Tools/.Rprofile")
library(pwt10)
library(ggplot2)
library(dplyr)
library(scales)
library(tidyr)

data("pwt10.0") # extract PWT data
rm(p)
p <- pwt10.0 # save into dataframe

## Create cross-sectional plots
# Create variables of interest
p$rgdpo_pop <- p$rgdpo/p$pop # GDP per worker
p <- p[p$year>1988,] # limit to 1989 and after

p <- p %>% group_by(isocode) %>% mutate(mean_csh_i = mean(csh_i)) # avg cap formation share
p <- p[p$mean_csh_i>0 & p$mean_csh_i<.4,] # eliminate outliers on cap formation share

p <- p %>% group_by(isocode) %>% mutate(gpop = (log(pop) - log(lag(pop, n = 30, default = NA)))/30)
p <- p[p$gpop<.04,] # eliminate outliers

p <- p[p$year==2019,] # narrow to only 2019
p <- p[p$rgdpo_pop<100000 & p$rgdpo_pop>500,] # eliminate outliers

## Plot GDP per capita against capital formation share
f <- ggplot(p, aes(x = mean_csh_i, y = rgdpo_pop, label = isocode)) +
    geom_text(size=3) +
    labs(x = "Avg. capital formation share of GDP, 1989-2019", y = "GDP per capita, 2019") +
    scale_y_continuous(label=comma,breaks=c(0,1000,2000,4000,8000,16000,32000,64000),trans = scales::log_trans()) +
    scale_x_continuous(breaks=c(0.05,0.1,0.15,0.2,0.25,0.3),limits=c(0.05,0.3)) +
    geom_smooth(method='lm', se=FALSE, color="black") +
    theme_bw()

## Plot GDP per capita against population growth rate
f <- ggplot(p, aes(x = gpop, y = rgdpo_pop, label = isocode)) +
  geom_text(size=3) +
  labs(x = "Avg. growth rate of population, 1989-2019", y = "GDP per capita, 2019") +
  scale_y_continuous(label=comma,breaks=c(0,1000,2000,4000,8000,16000,32000,64000),trans = scales::log_trans()) +
  scale_x_continuous(breaks=c(-0.01,0,0.01,0.02,0.03,0.04),limits=c(-0.01,0.04)) +
  geom_smooth(method='lm', se=FALSE, color="black") +
  theme_bw()

## Create time-series plots
p <- pwt10.0 # save into dataframe
p$rgdpo_pop <- p$rgdpo/p$pop # GDP per worker
p$ln_rgdpo_pop <- log(p$rgdpo_pop)
p <- p %>% group_by(isocode) %>% mutate(lag1.pop = dplyr::lag(pop, n = 1, default = NA))
p$gpop <- (log(p$pop) - log(p$lag1.pop))/1 # population growth rate

p <- p[which(p$isocode %in% c("CHN","KOR","DEU")),] # just the necessary countries
p$country <- revalue(p$country, c("Republic of Korea" = "S. Korea"))

m <- p[which(p$isocode %in% c("KOR","DEU")),]
m1 <- lm(m$ln_rgdpo_pop~m$year, data=p, subset=(year>2004))
p$fit1 <- m1$coefficients[1] + m1$coefficients[2]*p$year

m <- p[which(p$isocode %in% c("KOR","CHN")),]
m2 <- lm(m$ln_rgdpo_pop~m$year, data=p, subset=(year<1970))
p$fit2 <- m2$coefficients[1] + m2$coefficients[2]*p$year

f <- ggplot(p, aes(x = year, y = csh_i, group=country)) +
  geom_line(aes(linetype=country)) +
  labs(x = "Year", y = "Capital formation share of GDP", linetype="Country") +
  scale_y_continuous(breaks=c(0,.1,.2,.3,.4,.5),limits=c(0,0.52)) +
  scale_x_continuous(breaks=c(1950,1960,1970,1980,1990,2000,2010,2020),limits=c(1950,2020)) +
  theme_bw()

f <- ggplot(p, aes(x = year, y = gpop, group=country)) +
  geom_line(aes(linetype=country)) +
  labs(x = "Year", y = "Population growth rate", linetype="Country") +
  scale_y_continuous(breaks=c(-0.01,0,0.01,0.02,0.03,0.04),limits=c(-0.01,0.04)) +
  scale_x_continuous(breaks=c(1950,1960,1970,1980,1990,2000,2010,2020),limits=c(1950,2020)) +
  theme_bw()

f <- ggplot(p, aes(x = year, y = ln_rgdpo_pop, group=country)) +
  geom_line(aes(x = year, y = fit1),color="gray",linetype="dashed") +
  geom_line(aes(x = year, y = fit2),color="gray",linetype="dashed") +
  geom_line(aes(linetype=country)) +
  labs(x = "Year", y = "Log GDP per capita", linetype="Country") +
  scale_x_continuous(breaks=c(1950,1960,1970,1980,1990,2000,2010,2020),limits=c(1950,2020)) +
  theme_bw()

## Convergence
p <- pwt10.0 # save into dataframe
p$rgdpo_pop <- p$rgdpo/p$pop # GDP per worker
p$ln_rgdpo_pop <- log(p$rgdpo_pop)
p <- p %>% group_by(isocode) %>% mutate(lag.ln_rgdpo_pop = dplyr::lag(ln_rgdpo_pop, n = 50, default = NA))
p$gy <- (p$ln_rgdpo_pop - p$lag.ln_rgdpo_pop)/50 # population growth rate
p <- p[p$year==2019,]
p <- subset(p,isocode!="VEN")

f <- ggplot(p, aes(x = lag.ln_rgdpo_pop, y = gy, label=isocode)) +
  geom_text(size=3) +
  scale_y_continuous(breaks=c(-0.01,0,0.01,0.02,0.03,0.04,0.05,0.06),limits=c(-0.01,0.06)) +
  scale_x_continuous(breaks=c(6,7,8,9,10),limits=c(6,10)) +
  labs(x = "Log GDP per capita, 1969", y = "Avg. growth rate 1969-2019") +
  theme_bw()

## Create conditional convergence plot
p <- pwt10.0 # save into dataframe
p$rgdpo_pop <- p$rgdpo/p$pop # GDP per worker
p$ln_rgdpo_pop <- log(p$rgdpo_pop)
p$ky <- round(p$rnna/p$rgdpna,digits=2)
p <- p[p$year>1988,] # limit to 1989 and after

p <- p %>% group_by(isocode) %>% mutate(mean_csh_i = mean(csh_i)) # avg cap formation share
p <- p[p$mean_csh_i>0 & p$mean_csh_i<.4,] # eliminate outliers on cap formation share
p <- p %>% group_by(isocode) %>% mutate(lead30.pop = dplyr::lead(pop, n = 30, default = NA))
p$gpop <- (log(p$lead30.pop) - log(p$pop))/30 # population growth rate
p <- p[p$gpop<.04,] # eliminate outliers
p <- p %>% group_by(isocode) %>% mutate(lead.ln_rgdpo_pop = dplyr::lead(ln_rgdpo_pop, n = 30, default = NA))
p$gy <- (p$lead.ln_rgdpo_pop - p$ln_rgdpo_pop)/30 # population growth rate

p$kystar <- p$mean_csh_i/(.018 + .05 + p$gpop)
p$ratio <- p$ky/p$kystar

p <- p[p$ratio<4,]
f <- ggplot(p, aes(x = ratio, y = gy, label = isocode)) +
  geom_text(size=3) +
  labs(x = "Ratio of KY to KYstar, 1989", y = "Growth rate of GDP per capita") +
  geom_smooth(method='lm', se=FALSE, color="black") +
  theme_bw()


suppressPackageStartupMessages(library(float))
set.seed(1234)

tol = 1e-6

m = 10
n = 3

s = flrnorm(m, n)
cp_s = crossprod(s)
cp_d = dbl(cp_s)

test = eigen(cp_s, symmetric=TRUE, only.values=TRUE)
truth = eigen(cp_d, symmetric=TRUE, only.values=TRUE)
stopifnot(all.equal(dbl(test$values), truth$values, tol=tol))
stopifnot(identical(test$vectors, truth$vectors)) # both NULL

test = eigen(cp_s, symmetric=TRUE, only.values=FALSE)
truth = eigen(cp_d, symmetric=TRUE, only.values=FALSE)
stopifnot(all.equal(dbl(test$values), truth$values, tol=tol))
stopifnot(all.equal(abs(dbl(test$vectors)), abs(truth$vectors), tol=tol))


#basics

max(x,na.rm=TRUE) #Find the maximum value in the vector x, exclude missing values
min(x, na.rm=TRUE)
mean(x,na.rm=TRUE)
median(x,na.rm=TRUE)
sum(x, na.rm=TRUE)
var(x,na.rm=TRUE) #produces the variance covariance matrix
sd(x,na.rm=TRUE) #standard deviation
mad(x,na.rm=TRUE) #(median absolute deviation)
fivenum(x,na.rm=TRUE) #Tukey five numbers min, lower hinge, median, upperhinge, max
table(x) #frequency counts of entries, ideally the entries are factors (although it works with integers or even reals)

abs(x) #takes the absolute value of x
log(x,base = y) #Takes the log of x with base y; if base is not specified, returns the natural log
exp(x) #returns the exponential of x
sqrt(x) #Returns the square root of x
factorial(x) #Returns the factorial of x (x!)
choose(x, y) #Returns the number of possible combinations when drawing y elements at a time from x possibilities
round(x, digits = y) #Rounds x to y places
floor(x) #rounds down to the nearest int
ceiling(x) #rounds up to the nearest int
signif(x, digits = y) #rounds to that specified number of significant digits


library(nonlinearTseries)

# C = 3.4の場合
logMap1 <- logisticMap(
  r = 3.4,
  n.sample = 100,
  start = 0.5,
  n.transient=0,
  do.plot = TRUE
)

# C = 3.5の場合
logMap2 <- logisticMap(
  r = 3.5,
  n.sample = 100,
  start = 0.5,
  n.transient=0,
  do.plot = TRUE
)

# C = 3.55の場合
logMap3 <- logisticMap(
  r = 3.55,
  n.sample = 100,
  start = 0.5,
  n.transient=0,
  do.plot = TRUE
)
# 先程定義したものからそれぞれベクトルを作成する(付けた名前自体に特に意味はない)
tsuchinoko <- c(logMap1)
sabaiteiku <- c(logMap2)
Awajishima <- c(logMap3)

#見やすさを追求しデータフレーム化を行う
sekkaku <- data.frame("3.4" <- tsuchinoko, "3.5" <- sabaiteiku,
"3.55"<- Awajishima)

sekkaku


#  James Rekow

plotDensDiff = function(doc1, doc2, titleText = NULL){

  #  ARGS: doc1 - first input doc. Regions where doc2 has a higher density than doc1 will be
  #               colored blue
  #        doc2 - second input doc. Regions where doc2 has a higher density than doc1 will be
  #               colored red.
  #        title - optional input character string to use as the title of the output plot
  #
  #  RETURNS: a plot of the difference between the 2D densities of doc1 and doc2. The plotted
  #           density is that of density(doc2) - density(doc1)

  #  import libraries
  library(MASS)
  library(reshape2)
  library(ggplot2)

  #  store default title text if none is supplied
  if(is.null(titleText)){
    titleText = "Difference in Density of OD Points"
  } #  end if

  #  calculate the common overlap and dissimilarity range
  overRng = range(c(doc1[[1]], doc2[[1]]))
  dissRng = range(c(doc1[[2]], doc2[[2]]))

  #  calculate the 2D density estimate over the common range
  d1 = kde2d(doc1[[1]], doc1[[2]], lims = c(overRng, dissRng), n = 200)
  d2 = kde2d(doc2[[1]], doc2[[2]], lims = c(overRng, dissRng), n = 200)

  #  calculate the difference between the 2D density estimates
  diff12 = d1
  diff12$z = d2$z - d1$z

  #  melt data into long format
  #  first, add row and column names (x and y grid values) to the z-value matrix
  rownames(diff12$z) = diff12$x
  colnames(diff12$z) = diff12$y

  #  now melt it to long format
  diff12m = melt(diff12$z, id.var = rownames(diff12))
  names(diff12m) = c("overlap", "dissimilarity", "densDiff")
  lims = c(-1, 1) * 10

  diff12m$densDiff[diff12m$densDiff < lims[1]] = lims[1]
  diff12m$densDiff[diff12m$densDiff > lims[2]] = lims[2]

  #  plot difference between the two densities
  p = ggplot(diff12m, aes(overlap, dissimilarity, fill = densDiff)) +
    geom_raster() +
    #stat_contour(aes(col = ..level..), binwidth = 0.1) +
    scale_fill_gradient2(low = "blue", mid = "white", high = "red", midpoint = 0, limits = lims) +
    #scale_colour_gradient2(low = "blue", mid = "white", high = "red", midpoint = 0, limits = lims) +
    coord_cartesian(xlim = overRng, ylim = dissRng, expand = c(0, 0)) #+
    #guides(colour = FALSE) +
    # ggtitle(titleText)
    #labs(title = titleText) +
    #theme(plot.title = element_text(hjust = 0.5))

  #  NOTE: the commented out lines above can be added in to modify the display, but are
  #  currently left out because they clutter the plot or add unnecessary visual detail that
  #  bloats the size of the resulting image file

  return(p)

} #  end plotDensDiff function


# load and inspect gapminder data
library(dslabs)
data(gapminder)
head(gapminder)

# compare infant mortality in Sri Lanka and Turkey
gapminder %>%
    filter(year == 2015 & country %in% c("Sri Lanka", "Turkey")) %>%
    select(country, infant_mortality)

# basic scatterplot of life expectancy versus fertility
ds_theme_set()    # set plot theme
filter(gapminder, year == 1962) %>%
    ggplot(aes(fertility, life_expectancy)) +
    geom_point()

# add color as continent
filter(gapminder, year == 1962) %>%
    ggplot(aes(fertility, life_expectancy, color = continent)) +
    geom_point()

#Faceting makes multiple side-by-side plots stratified by some variable. This is a way to ease comparisons.

# facet by continent and year
filter(gapminder, year %in% c(1962, 2012)) %>%
    ggplot(aes(fertility, life_expectancy, col = continent)) +
    geom_point() +
    facet_grid(continent ~ year)

# facet by year only
filter(gapminder, year %in% c(1962, 2012)) %>%
    ggplot(aes(fertility, life_expectancy, col = continent)) +
    geom_point() +
    facet_grid(. ~ year)

# facet by year, plots wrapped onto multiple rows
years <- c(1962, 1980, 1990, 2000, 2012)
continents <- c("Europe", "Asia")
gapminder %>%
    filter(year %in% years & continent %in% continents) %>%
    ggplot(aes(fertility, life_expectancy, col = continent)) +
    geom_point() +
    facet_wrap(~year)


compare_overlap_between_two_genesets = function ( geneset1, geneset2, background_list, granularity=10,
              color = colorRampPalette(c("#3362A5", "dodgerblue1", "deepskyblue", "gray99", "gold", "firebrick2","#A31D1D"), space="Lab")) {
  # This function finds and plots the degree of overlap between two sets of genes
  # This function outputs a filled contour graph of the relationship
  # The return value is a list that contains the odds ratio and the associated p-values
  # There two optional parameters: granularity controls the number of genes to consider at each step
  # Additionally, a color palette can be specified which will be passed on to the filled.contour
  # The input is two indices of the enriched regions table
  # The degree of overlap is quantified using Fisher's exact test
  stopifnot(is.character(geneset1), is.character(geneset2), is.character(background_list), is.numeric(granularity))

  ## TEST THE REGION BELOW
  total_overlaps = length(background_list )
  fmat = matrix ( nrow = 2, ncol = 2)
  enrichment_matrix_odds = matrix(nrow = floor( length(geneset1) / granularity ),
                                  ncol = floor( length(geneset2) / granularity ))
  enrichment_matrix_pval = matrix(nrow = floor( length(geneset1) / granularity ),
                                  ncol = floor(length(geneset2) / granularity ))

  for (k in 1: floor(length(geneset1) / granularity )) {
    for (l in 1: floor(length(geneset2) / granularity )) {
      in_both = length ( intersect (geneset1[1:(k*granularity)], geneset2[1:(l*granularity)] ) )
      in_one = length ( setdiff(geneset1[1:(k*granularity)], geneset2[1:(l*granularity)]) )
      in_two = length ( setdiff(geneset2[1:(l*granularity)], geneset1[1:(k*granularity)]) )
      neither = total_overlaps - length(union(geneset1[1:(k*granularity)], geneset2[1:(l*granularity)]))
      fmat[1,]  = c(in_both, in_one)
      fmat[2,] = c(in_two, neither)
      fisher_test = fisher.test(fmat)
      enrichment_matrix_odds[k,l] = fisher_test$estimate
      enrichment_matrix_pval[k,l] = fisher_test$p.value

    }
  }
  filled.contour(enrichment_matrix_odds, color.palette = color,
                 zlim = c(0, max(enrichment_matrix_odds)),
                 main = "Odds Ratio of Enrichment" )
  return ( list(ODDS = enrichment_matrix_odds, PVAL= enrichment_matrix_pval) )
}


#Markov Chain
# https://www.cs.princeton.edu/courses/archive/fall13/cos521/lecnotes/lec12.pdf
# quick definition: http://mathworld.wolfram.com/MarkovChain.html
# https://www.dartmouth.edu/~chance/teaching_aids/books_articles/probability_book/Chapter11.pdf

# set.seed(10204)

ncols <- 10^3 +1
nrows <- 10^3
S <- matrix(nrow = nrows, ncol = ncols)
# vector(mode = "numeric", length = n+1) #inital state
S[,1] <- 0
for(j in 1:nrows){

	for(i in 1:(ncols -1 )){
		S[j, i+1] <-  rnorm(1, mean = S[j, i], sd = 1)
	}
}

plot(S[1,])
plot(S[2,])
plot(S[122,])

v <- colMeans(S)
plot(v)
fit <-  loess(v ~ c(1:(length(v))), family = "gaussian", method = "loess")
lines(fit)

plot(v)
fit2 <-  loess(v ~ c(1:(length(v))), family = "symmetric", method = "loess")
lines(fit2)


library(ggplot2)

# read the file
x1= read.delim("E:/denboer2009-expr.txt")
rownames(x1)= x1[,1]
x3 = x1[,-1]
x= as.data.frame(t(x3))

# read the lables
y= read.delim("E:/denboer2009-pheno (2).txt")
rownames(y)= y[,1]
y= y[,-1]

# add lables to data as a column
x$sample = substr(y[,5],1,190)

# creat an empty data frame
gene_pvalue_df = data.frame( )

# apply t test for each gene, between T-cell and B-cells
for (i in 1:22283) {
  gene_col = i
  t_test = t.test(x[x$sample =="T",gene_col],x[x$sample !="T",gene_col])
  gene_name = colnames(x[gene_col])
  gene_p_value= t_test$p.value

  # add data to previous data frame
  gene_pvalue_df =rbind(gene_pvalue_df , data.frame(gene_name,gene_p_value ))
}

# sort samples forom loest p-value to highest
sort_by_pvalue= gene_pvalue_df [order(gene_pvalue_df$gene_p_value),]

# plot and save p-value histogram
jpeg("p_value histogram.jpg")
ggplot(gene_pvalue_df, aes(gene_p_value))+ geom_histogram(binwidth = 0.00001) + coord_cartesian(xlim = c(0.00, 0.0001)) +
  xlab("t test p values between T-cell & B-cell leukemia") + ylab("number of samples")
dev.off()


fibonacci_step <- function(a, b) {
    list(b, a + b)
}

gross <- 0
lst <- list(1, 2)
while (lst[[1]] < 4e6) {
    if (lst[[1]] %% 2 == 0) {
        gross <- gross + lst[[1]]
    }
    lst <- do.call(fibonacci_step, lst)
}

cat(gross, "\n")


# 4E1

# The likelihood is y_i ~ Normal(mu, sigma)

# 4E2

# There are 2 parameters

# 4E3

# Bayes' Theorem:
# p(a | b) = p(b | a) p(a) / p(b)

# Model:
# y_i ~ Normal(mu, sigma)
# mu ~ Normal(0, 10)
# sigma ~ Exponential(1)

# pr(y_i | mu, sigma) = Normal(y_i | mu, sigma)
# pr(mu) = Normal(mu | 0, 10)
# pr(sigma) = Exponential(sigma | 1)

# So:

# pr(mu, sigma | y_i ) = (pr(y_i | mu, sigma) * pr(mu) * pr(sigma))
#                        / ( integral(pr(y_i | mu, sigma)
#                          * pr(mu) * pr(sigma))d y )

# pr(mu, sigma | y_i ) = (Normal(y | mu, sigma)
#                       * Normal(mu | 0, 10) *
#                       * Exp(sigma | 1))
#            / integral(Normal(y | mu, sigma)
#             * Normal(0, 10)
#             * Exp(1)) dmu dsigma

# Yeah I don't understand this.

# 4E4

# The linear model is u_i = a + b * x_i

# 4E5

# 3 parameters, a, b, sigma in the posterior.
# The mean is defined by a and b, as such isn't a parameter.

# 4M1

# Model:
# y_i ~ Normal(mu, sigma)
# mu ~ Normal(0, 10)
# sigma ~ Exponential(1)

# Recall: The prior predictive simulation is plugging in the prior parameter
# samples into the *likelihood estimator*.

# So:

# Likelihood estimator

size <- 1e4

likelihood <- function(mu_samples, sigma_samples) {
	 rnorm(size, mu_samples, sigma_samples)
}

mu_samples <- rnorm(size, 0, 10)
sigma_samples <- rexp(size, 1)

prior_predictive_samples <- likelihood(mu_samples, sigma_samples)
dens(prior_predictive_samples)

# Note that we end up sampling through layers when doing Posterior pred sim.

# 4M4
# y_i ~ dnorm(mu, sigma)
# mu ~ dnorm(0, 10)
# sigma ~ dexp(1)

# 4M3
# y ~ Normal(mu, sigma)
# mu = a + b*x
# a ~ Normal(0, 10)
# b ~ Uniform(0, 1),
# sigma ~ Exponential(1)

# 4M4
# Measure student heights for 3 years. Linear regression: height vs year.
# h_i ~ dnorm(mu_i, sigma)
# mu_i = a + b * ( year_i - year_bar)
# a <- dnorm(100, 20)
# b <- dunif(5, 20)
# sigma <- dunif(0, 15)

# prior-pd:
plot(NULL, xlim=c(0, 3), ylim=c(50, 250), xlab="year", ylab="height")
N <- 100
year_bar <- 2
a_sample <- rnorm(N, 100, 20)
b_sample <- log_normal(N, 5, 20)
sigma_sample <- runif(N, 0, 8)

for (i in 1:N) curve(
	a[i] + b[i] * (x - year_bar),
	from=0,
	to=3,
	add=TRUE,
	col=col.alpha('black', .2)
)

# 4M7
library(rethinking)
data(Howell1); d <- Howell1; d2 <- d[ d$age >= 18, ]

m4.3_revised <- quap(
  alist(
    # likelihood
    height ~ dnorm(mu, sigma),
    # Linear predictor
    mu <- alpha + beta * ( weight),
    # priors
    alpha ~ dnorm(178, 20),
    beta ~ dlnorm(0, 1),
    sigma ~ dunif(0, 50)
  ), data=d2
)

# > vcov(m4.3_revised)
#              alpha          beta         sigma
# alpha  3.601407563 -0.0784370308  0.0093616751
# beta  -0.078437031  0.0017437116 -0.0002043995
# sigma  0.009361675 -0.0002043995  0.0365751541

# > vcov(m4.3)
#               alpha          beta         sigma
# alpha  7.306632e-02 -4.238715e-08  6.151697e-05
# beta  -4.238715e-08  1.757593e-03 -2.517741e-05
# sigma  6.151697e-05 -2.517741e-05  3.654026e-02

analyze <- m4_7analyze(model) {
	weight.seq <- seq(from=25, to=70, by=1)
	mu_revised <- link(model, data=data.frame(weight=weight.seq))
	mu_revised.mean <- apply(mu_revised, 2, mean)
	mu_revised.pi <- apply(mu_revised, 2, PI, prob=.89)

	heights <- sim(model, data=list(weight=weight.seq))
	heights.pi <- apply(heights, 2, PI, prob=.89)

	plot(
		d2$height ~ d2$weight,
		xlim=range(d2$weight),
		col=col.alpha(rangi2, .8)
	)

	lines(weight.seq, mu_revised.mean)
	shade(mu_revised.pi, weight.seq)
	shade(heights.pi, weight.seq)
}


    mb = function(i) exp(1.917564 + 0.298914*i)
    # mb = male bound in cw where i=1 when cw = ~ 9.2 mm,
    # instar 5 is bounded by mb(2) and mb(3)
    # prior to instar 5 moulting can be variable and so should not be
    # relied upon to heavily
    #  see "model.size.structure.r" for details of derivation


#
# Example R program
#

library("Rnlminb2")

# Feasible Start Solution:
start = c(10, 10)

# Objective Function: x^2 + y^2
fun <- function(x) sum(x^2)

# Bounds: -100 <= x,y <= 100
par.lower = c(-100, -100)
par.upper = c(100, 100)

# Equality Constraints: x*y = 2
eqFun <- list(
 function(x) x[1]*x[2])
eqFun.bound = 2

# Solution: x = c(sqrt(2), sqrt(2)), f(x) = 4
result <- nlminb2NLP(
  par = start,
  fun = fun,
  par.lower = par.lower,
  par.upper = par.upper,
  eqFun = eqFun,
  eqFun.bound = eqFun.bound
)

print(result)


simulate_bayesian = function(steps, phi, I0) {
  discrete_pchisq = diff(pchisq(0:steps, df=6))
  beta = function(t, tau) {
      return(phi * discrete_pchisq[tau])
  }
  # simulate a sequence of incident cases
  I = I0
  expected = I0
  expected_conditional = I0
  for (t in 2:steps) {
    I = c(I, 0) # so I[t] = 0
    expected = c(expected, 0)
    expected_conditional = c(expected_conditional, 0)
    for (tau in 1:(t - 1)) {
      I[t] = I[t] + (rpois(1, lambda=beta(t, tau)) * I[t - tau])
      expected[t] = expected[t] + beta(t, tau) * expected[t - tau]
      expected_conditional[t] = expected_conditional[t] + beta(t, tau) * I[t - tau]
    }
  }
  return(list("I"=I, "expected"=expected, "expected_conditional"=expected_conditional,
              "omega"=discrete_pchisq))
}

simulate_impartial = function(steps, beta, tau1, tau2, I0) {
  "
  Simulate Cerón's impartial model.

  Parameters
  ----------
  steps : numeric
    Number of steps in the simulation.
  beta : numeric vector
    Series where beta[t] is the expected number of people an infectious patient
    will infect in step t.
  tau1 : numeric
    Expected number of days since exposure to infection onset.
  tau2 : numeric
    Expected number of days a patient remains infectious.
  I0 : numeric
    Number of intial just-infectious cases.
  "
  # initialize simulated vectors to be returned
  E = 0
  N = I0
  I = I0
  expected_I = I0
  expected_E = 0
  expected_N = I0
  # carry out simulation and append to those vectors
  for (t in 1:(steps - 1)) {
    I = c(I, rbinom(1, size=E[t], prob=1 / tau1))
    E = c(E, E[t] - I[t + 1] + rpois(1, lambda=beta[t] * N[t]))
    N = c(N, N[t] + I[t + 1] - rbinom(1, size=N[t], prob=1 / tau2))
    # track expected values
    expected_I = c(expected_I, expected_E[t] / tau1)
    expected_E = c(expected_E, expected_E[t] - expected_I[t + 1] + expected_N[t] * beta[t])
    expected_N = c(expected_N, expected_I[t + 1] + expected_N[t] * (1 - (1 / tau2)))
  }
  # calculate theoretical values
  R = beta * tau2
  f_inc = dgeom(1:steps - 1, p=1 / tau1)
  f_inf = dgeom(1:steps - 1, p=1 / tau2)
  omega = NULL
  for (tau in 1:steps) {
    omega = c(omega, 0) # so omega[tau] = 0
    for (tau_prime in 0:(tau - 1)) {
      omega[tau] = omega[tau] +
                   pgeom(tau_prime - 1, p=1 / tau2, lower.tail=FALSE) *
                   dgeom(tau - tau_prime - 1, p=1 / tau1)
    }
  }
  omega = omega / tau2
  # alternative tau calculation
  omega_alt = rep(0, length=steps)
  prob1 = dgeom((-1):(2 * steps), p=1/tau1)
  prob2 = dgeom((-1):(2 * steps), p=1/tau2)
  for(i in 1:(steps + 1)){
    for(j in 1:(steps + 1)){
      if(i + j - 2 < steps){
        # omega_alt[i+j-1] = omega_alt[i+j-1] + dgeom(i-2, p=1/tau1) *
        #                    (dgeom(2*j - 2, p=1/tau2) + dgeom(2*j - 3, p=1/tau2))
        omega_alt[i+j-1]=omega_alt[i+j-1]+prob1[i]*(prob2[2*j]+prob2[2*j-1])
      }
    }
  }
  # supress starting 0
  omega_alt = c(omega_alt[2:steps], 0)
  return(list(
    "I"=I, "E"=E, "N"=N, "expected_I"=expected_I, "R"=R, "f_inc"=f_inc,
    "f_inf"=f_inf, "steps"=steps, "tau1"=tau1, "tau2"=tau2, "omega"=omega,
    "omega_alt"=omega_alt
  ))
}

simulate_inseparable_beta = function(steps, phi, tau0, I0) {
  t0 = floor(steps / 2)
  discrete_pchisq = diff(pchisq(0:steps, df=6))
  beta = function(t, tau) {
    if (t <= t0) {
      return(phi * discrete_pchisq[tau])
    } else {
      if (tau > tau0) {
        return(0)
      } else {
        return (phi * discrete_pchisq[tau] / pchisq(tau0, df=6))
      }
    }
  }
  omega = function(t, tau) {
    if (t <= t0) {
      return(discrete_pchisq[tau])
    } else {
      if (tau > tau0) {
        return(0)
      } else {
        return (discrete_pchisq[tau] / pchisq(tau0, df=4))
      }
    }
  }
  # simulate a sequence of incident cases
  I = I0
  expected = I0
  expected_conditional = I0
  for (t in 2:steps) {
    I = c(I, 0) # so I[t] starts at 0
    expected = c(expected, 0)
    expected_conditional = c(expected_conditional, 0)
    for (tau in 1:(t - 1)) {
      I[t] = I[t] + (rpois(1, lambda=beta(t, tau)) * I[t - tau])
      expected[t] = expected[t] + beta(t, tau) * expected[t - tau]
      expected_conditional[t] = expected_conditional[t] + beta(t, tau) * I[t - tau]
    }
  }
  return(list("I"=I, "expected"=expected, "expected_conditional"=expected_conditional,
              "omega"=omega))
}


# Reading in data

ds = read.csv('Ads_CTR.csv')

# Random sample

N = 10000
d = 10

random_reward = 0
for (n in 1:N) {
    ad = sample(1:d, 1)
    random_reward = total_reward + ds[n,ad]
}

## Thompson sampling

# Initialising
ads_selected = seq(1,10)
num_rewards_1 = ds[1,]
num_rewards_0 = 1 - num_rewards_1

total_reward = sum(num_rewards_1)

# For each round, choose the ad with the maximum theta
for (n in 2:N) {
    ad = 1
    max_theta = 0

    for (i in 1:d) {
        theta = rbeta(1, num_rewards_1[[i]], num_rewards_0[[i]])

        if (theta > max_theta){
            ad = i
            max_theta = theta
        }
    }
    ads_selected = append(ads_selected,ad)
    reward = ds[n, ad]
    sum_rewards[ad] = sum_rewards[ad] + reward
    total_reward = total_reward +  reward

    if (reward == 1) {
        num_rewards_1[ad] = num_rewards_1[ad] + 1
    }
    else{
        num_rewards_0[ad] = num_rewards_0[ad] + 1
    }
}

# Visualising results
hist(ads_selected,
     main = 'Histogram of ads selected',
     col = 'blue',
     xlab = 'Ads',
     ylab = 'Ad selection frequency density')


#' Compute the squared coherence spectrum of two timeseries.
#'
#' @param t1 Sampling times of timeseries 1.
#' @param x1 Value of timeseries 1 at each sample time.
#' @param t2 Sampling times of timeseries 2.
#' @param x2 Value of timeseries 2 at each sample time.
#' @param omega Angular frequencies to evaluate periodogram at.
#' @param demeaned Whether timeseries has already been de-meaned.
#' @param standardized Whether timeseries has already been standardized.
#'
#' @return Values of squared coherence spectrum at angular frequencies specified.
#'
#' @examples
#' squared.coherence.spectrum(1:10, sin(1:10), 1:10, cos(1:10), 2*pi/1:10, FALSE, FALSE)
#'
#' @export
squared.coherence.spectrum <- function(t1, x1, t2, x2, omega,
                                       demeaned = FALSE, standardized = FALSE) {

    ## De-mean and standardize, if not already done. ##
    if (!demeaned) {
        x1 <- x1 - mean(x1)
        x2 <- x2 - mean(x2)
    }
    if (!standardized) {
        x1 <- x1 / sd(x1)
        x2 <- x2 / sd(x2)
    }

    tau1 <- tau(t1, omega)
    tau2 <- tau(t2, omega)

    a1 <- periodogram.component(t1, x1, omega, tau1, "cos")
    a2 <- periodogram.component(t2, x2, omega, tau2, "cos")
    b1 <- periodogram.component(t1, x1, omega, tau1, "sin")
    b2 <- periodogram.component(t2, x2, omega, tau2, "sin")

    co.spectrum <- a1*a2 + b1*b2
    quad.spectrum <- a1*b2 - a2*b1

    cross.amplitude.spectrum.squared <- co.spectrum^2 + quad.spectrum^2

    power.spectrum1 <- 0.5 * (a1^2 + b1^2)
    power.spectrum2 <- 0.5 * (a2^2 + b2^2)

    cross.amplitude.spectrum.squared / (power.spectrum1 * power.spectrum2)

}