# ......................................................................................
# ................Exercise 9. Confidence Interval estimates (one sample) ...............
# ................Michal Béreš, Martina Litschmannová, Veronika Kubíčková...............
# ......................................................................................

# 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

#  Demonstration - what is interval estimation? ####
#
# Consider a random variable following the normal distribution with a mean value of
# $\mu$ and a standard deviation of $\sigma$. We will work with selections from this
# random variable and using them we try to estimate the mean value of the
# distribution(here we know its true value, but in practice its value is unknown).

n = 30        # selection size
mu = 100      # mean value
sigma = 10    # st. deviation

# simulation of random selection from a given random variable
sample = rnorm(n = n, mean = mu, sd = sigma)

X = mean(sample) # sampling average as a point estimate
S = sd(sample)   # st. dev. of the sample
X
S

# For clarity, we can visualize the selection.
#

hist(sample)
boxplot(sample)

# ** The construction of the confidence interval estimation using a selection ####
# characteristic
#
# We will use this selection characteristic:(we assume that we do not know any real
# parameters of the distribution, only that it is following the normal distribution)
#
# $Y=\frac{\bar X - \mu}{S}\sqrt{n} \sim t_{n-1}$Since we know the distribution of
# Y, we are able to compute $a$ a $b$ in the following expression:$P(a<Y<b)\geq 1 -
# \alpha$
#
# - $\alpha$ is called the significance level(the probability that the searched value is
# outside our range)
# - $1-\alpha$ is called the interval estimation reliability

# we pick $a$ a $b$ so that they are symmetric in probability, ie:
#
# - $P(Y<a)\leq \alpha / 2 \rightarrow a=t_{\alpha / 2;n-1}$
#
# - $P(b<Y)\leq \alpha / 2 \rightarrow P(Y\leq b)\geq 1 - \alpha / 2 \rightarrow
# b=t_{1-\alpha / 2;n-1}$
#

# maximum probability with which we allow
# observations to lay outside the constructed interval
alpha = 0.05

# relevant quantiles of the student's distribution
t_low = qt(alpha/2, df = n-1)
t_high = qt(1 - alpha/2, df = n-1)

t_low
t_high

# Next we just add to the expression and modify:
#
# $P(t_{\alpha / 2;n-1}<\frac{\bar X - \mu}{S}\sqrt{n}<t_{1-\alpha / 2;n-1})\geq 1 -
# \alpha$
#
# $P(\bar X - t_{1-\alpha / 2;n-1}\frac{S}{\sqrt{n}}<\mu<\bar X - t_{\alpha /
# 2;n-1}\frac{S}{\sqrt{n}})\geq 1 - \alpha$

I_lower = X - t_high*S/sqrt(n)
I_upper = X - t_low*S/sqrt(n)
paste("P(", I_lower, " < µ < ", I_upper, ") ≥ ", 1-alpha)

# This particular estimate can also be obtained using the R function t.test:

t.test(sample, alternative = 'two.sided', conf.level = 1-alpha)$conf.int

# ** Testing confidence intervals on multiple samples ####
# We demonstrate what confidence level means.

n_selections = 100 # number of selections

n = 30             # selection size
mu = 100           # mean value
sigma = 10         # guided. deviation.

alpha = 0.05        # significance level

# relevant quantiles of the student's distribution
t_low = qt(alpha/2, df = n-1)
t_high = qt(1 - alpha/2, df = n-1)

# plot of the actual mean value
plot(c(1, n_selections), c(mu, mu), type = 'l', ylim = c(90,110))

count_failed = 0
# cycle through individual selections
for(i in 1:n_selections){
    vyber = rnorm(n = n, mean = mu, sd = sigma)
    X = mean(vyber)
    S = sd(vyber)
    I_lower = X - t_high*S/sqrt(n)
    I_upper = X - t_low*S/sqrt(n)

    # select the plot color, depending on whether the CI contains the mean
    if( I_lower<mu & mu<I_upper){color = "blue"}
    else{color = "red"
         count_failed = count_failed + 1}
    # plot the CI as a vertical line
    lines(c(i, i), c(I_lower, I_upper), col=color)
}
paste('alpha = ', alpha, ', ratio of failures of CI = ',
      count_failed/n_selections)

#  Types of interval estimates ####
#
# Examples of estimating the mean value of data from a normal distribution.
#
# * Bottom/Left IC ####
#
# - $P(M_D^* < \mu) = 1-\alpha$
# - in R **alternative="greater"**

sample = rnorm(n = 30, mean = 100, sd = 10)
alpha = 0.05
t.test(sample, alternative = 'greater', conf.level = 1-alpha)$conf.int

# * Top/Right IO ####
#
# - $P(\mu < M_H^*) = 1-\alpha$
# - in R **alternative="less"**

sample = rnorm(n = 30, mean = 100, sd = 10)
alpha = 0.05
t.test(sample, alternative = 'less', conf.level = 1-alpha)$conf.int

# * Double-sided IC ####
#
# - $P(M_D < \mu < M_H) = 1-\alpha$
# - in R **alternative="two.sided"**

sample = rnorm(n = 30, mean = 100, sd = 10)
alpha = 0.05
t.test(sample, alternative = 'two.sided', conf.level = 1-alpha)$conf.int

#  Overview of selection parameters and their point/interval estimates ####
#
# We usually have more CI constructions(functions in R that will do this for us), but
# each construction has different data requirements and produces different "quality"(in
# terms of IO size) estimates. We will always select the "best quality" CI that **has
# met** the prerequisites for use.
#
# The order of the various CIs below will always be from "best" to most robust.
#
# * Position measures of one selection ####
#
# By position measures we mean measures that determines the position of the data. For
# data from the normal distribution we can estimate the mean value, for others the
# median.
#
# *** a) student's CI using t-test ####
#
# - we estimate the mean value - the point estimate is the sample average
# - the data must come from a normal distribution
# - exploratory: skewness and sharpness lie in(-2,2)
# - exploratory: The QQ graph has points approximately on the line
# - exact: using a statistical test, eg Shapiro-Wilk test(shapiro.test(data))

sample = rnorm(n = 30, mean = 100, sd = 10)
alpha = 0.05

# exploratory normality test
# library(moments) - we can avoid this by calling moments ::
# it's safer - we're sure we're calling a feature from this package
moments::skewness(sample)
moments::kurtosis(sample) - 3
qqnorm(sample)
qqline(sample)

# exact data normality test
shapiro.test(sample)$p.value
# the resulting p-value must be greater than significance level(eg 0.05)

# point estimate
mean(sample)
# IO
t.test(sample, alternative = 'two.sided', conf.level = 1-alpha)$conf.int

# *** b) Wilcoxn CI test ####
#
# - we estimate the median - the point estimate is the sample median
# - the data must come from a symmetric distribution
# - exploratory: the skewness lies in(-2,2)
# - exploratory: the histogram looks approximately symmetrical
# - function in Rk requires additional parameter(conf.int=TRUE)

sample = runif(n = 30, min = 80, max = 120)
alpha = 0.05

# exploratory
moments::skewness(sample)
hist(sample, breaks = 6)

# point estimate
quantile(sample, probs = 0.5)
# or median(sample)
# IO
wilcox.test(sample, alternative = 'two.sided', conf.level = 1-alpha,
            conf.int = TRUE)$conf.int

# *** c) sign test IO test ####
#
# - we estimate the median - the point estimate is the sample median
# - if we cannot use previous tests (no normality, no symmetry)
# - function in R requires additional parameter(conf.int=TRUE)
# - requires "BSDA" library
# - as the most robust test, it can also be used for discontinuous data - eg order in a
# list

sample = rexp(n = 30, rate = 1/100)
alpha = 0.05

# true median
qexp(p = 0.5, rate = 1/100)

# point estimate
# quantile(select, probs=0.5)
median(sample)
# IO
# install.packages("BSDA")
BSDA::SIGN.test(sample, alternative = 'two.sided', conf.level = 1-alpha,
          conf.int = TRUE)$conf.int

# * Measures of variability of one selection ####
#
# By measures of variability we mean measures determining the dispersion/variability of
# the data. For data from the normal distribution, we can estimate the standard
# deviation.
#
# *** IO standard deviations ####
#
# - we estimate the standard deviation - the point estimate is the sample standard
# deviation
# - the data must come from a normal distribution
# - exploratory: skewness and kurtosis lie in(-2,2)
# - exploratory: The QQ graph has points approximately on the line
# - exactly: using a statistical test, eg Shapiro-Wilk test(shapiro.test(data))
# - requires "EnvStats" package
# - function in R, gives the calculation of variance - the square root of the result is
# necessary

sample = rnorm(n = 30, mean = 100, sd = 10)
alpha = 0.05

# exploratory normality test
moments::skewness(sample)
moments::kurtosis(sample) - 3
qqnorm(sample)
qqline(sample)

# exact data normality test
shapiro.test(sample)$p.value
# the resulting p-value must be greater than (eg 0.05)

# point estimate
sd(sample)
# CI
# install.packages("EnvStats")
result = EnvStats::varTest(sample, alternative = 'two.sided', conf.level = 1-alpha)$conf.int
sqrt(result)

# * Probability of occurrence with one selection ####
#
# *** CI probability ####
#
# - we estimate the probability - the point estimate is the relative frequency
# - we need enough data: $n>\frac{9}{p(1-p)}$
# - we have a lot of different options:
#     - Clopper - Pearson estimate(binom.test) **preferred one**
#         - does not take data as a parameter, but the number of successes and the
# number of observations
#     - Wald's - from selection characteristics using normal distribution

pi = 0.3
n = 60
alpha = 0.05
sample = runif(n = n, min = 0, max = 1) < pi

# verification of assumptions
p = mean(sample)
p
9/(p*(1-p))

# point estimate
p
# Clopper - Pearson interval estimation
sample_size = length(sample)
n_successes = sum(sample)
binom.test(x = n_successes, n = sample_size, alternative = 'two.sided',
           conf.level = 1 - alpha)$conf.int

# Wald's interval estimation
dol_q = qnorm(alpha/2)
hor_q = qnorm(1-alpha/2)

p - hor_q*sqrt(p*(1-p)/n)   # lower IO limit
p - dol_q*sqrt(p*(1-p)/n)       # upper IO limit

# Calculation of the 11 most frequently used confidence intervals param. bin. distribution
# using binom package
# install.packages("binom")
binom::binom.confint(n = sample_size, x = n_successes)

#  Examples ####

# we may need theese
library(dplyr)
library(rstatix)

#
# * Example 1. ####
#
# During control tests of 16 light bulbs, an estimate of the mean value of $\bar
# x$=3,000 hours and the standard deviation s=20 hours of their service life were
# determined. Assuming that the lamp life has a normal distribution, determine a 90%
# interval estimate for the mean value µ.
#

# We estimate the mean value of the lamp life
# Part of the input is information about data normality

n = 16         # sample size
x.bar = 3000   # hours.... average(point estimate of mean value)
s = 20         # hours.... sample standard deviation(point estimate of standard deviation)
alpha = 0.1    # significance level(reliability 1-alpha=0.9)

# two sided interval estimate of the mean
dol_q = qt(alpha/2,n-1)
hor_q = qt(1 - alpha/2,n-1)

x.bar - hor_q*s/sqrt(n)   # lower limit of IO
x.bar - dol_q*s/sqrt(n)   # upper limit of IO

# * Example 2. ####
#
# The depth of the sea is measured with an instrument whose systematic error is zero and
# the random errors have a normal distribution with a standard deviation of 20 m. How
# many measurements do we need to take if we need 95% confidence interval of maximum
# size 20m = $<\overline{X}-10,\overline{X}+10>$.
#

# Remember:
#
# Confidence interval have the form of: $P(\bar X - z_{1-\alpha /
# 2}\frac{S}{\sqrt{n}}<\mu<\bar X - z_{\alpha / 2}\frac{S}{\sqrt{n}})\geq 1 - \alpha$

# We determine the estimate of the required selection range(number of required measurements)

# We assume data normality, with known variance(according to assignment)

sigma = 20   # meters.... known standard deviation
alpha = 0.05 # significance level(reliability 1-alpha=0.95)
delta = 10   # meters... permissible measurement error

# Estimate selection range
# we need to find n such z*S/sqrt(n)>10,
# where z is 1-alpha/2 quantile of the normal distribution
z_alpha = qnorm(1 - alpha/2,0,1)
(z_alpha*sigma/delta)^2

# * Example 3. ####
#
# Suppose that in a random selection of 200 young men, 120 of them have higher than
# recommended serum cholesterol levels. Determine a 95% confidence interval for the
# percentage of young men with higher cholesterol levels in the population.
#

# We estimate the proportion of men with higher cholesterol levels in the entire population,
# ie the probability that a randomly selected man will have a higher cholesterol level

n = 200  # file range
x = 120  # number of "successes"
p = x/n  # relative frequency(probability point estimate)
p
alpha = 0.05 # significance level(reliability 1-alpha=0.95)

# Verification of assumptions
9/(p*(1-p))

# two sided Clopper - Pearson(exact) int. Estimate param. binom. distribution
binom.test(x,n,alternative="two.sided",conf.level=0.95)$conf.int

# * Example 4. ####
#
# In a research study, we are working with a random selection of 70 women from the Czech
# population. Hemoglobin was measured in each of the women with an accuracy of 0.1 g/100
# ml. The measured values are listed in the Hemoglobin.xls file. Find 95% interval
# estimates of standard deviation and mean hemoglobin in the population of Czech
# women.(Check the normality based on the exploration graphs.)
#

# We estimate the mean and standard deviation of hemoglobin in serum

# Read data from xlsx file(using readxl package)
hem = readxl::read_excel("data/intervalove_odhady.xlsx",
                  sheet = "Hemoglobin")
head(hem)

# lets rename the column for easier work
colnames(hem) = "value"

# Exploratory analysis
boxplot(hem$value)
# no outliers

# Verification of normality - exploratory
qqnorm(hem$value)
qqline(hem$value)

moments::skewness(hem$value)
moments::kurtosis(hem$value) - 3
# Both skew and sharpness meet the standards. distribution.

# normality verification: exact - normality test.
# Shapirs. Wilk's test.
shapiro.test(hem$value)$p.value
# we cannot reject normality at significance 0.05

# 95% two sided interval estimate of the mean
mean(hem$value)
t.test(hem$value, altarnative="two.sided", conf.level=0.95)$conf.int

# # 95% two-way interval standard deviation estimate
sd(hem$value)
sqrt(EnvStats::varTest(hem$value, alternative = "two.sided", conf.level = 0.95)$conf.int)

# * Example 5. ####
#
# In the data file pr7.xlsx you will find the measurement of noise caused by the
# computer fan [dB]. Calculate the 95% interval estimate of the average noise and the
# 95% interval estimate of the noise variability.
#

# read data
data = readxl::read_excel("data/pr7.xlsx")
head(data)

# visualization
boxplot(data$dB)
# there is an outlier!!

# removal of OP
outliers = data %>% identify_outliers(dB)
outliers

data$dB_no_outliar = ifelse(data$ID %in% outliers$ID,NA,data$dB)

boxplot(data$dB_no_outliar)

# data normality test exploratory
moments::skewness(data$dB_no_outliar, na.rm = TRUE)
moments::kurtosis(data$dB_no_outliar, na.rm = TRUE) - 3

qqnorm(data$dB_no_outliar)
qqline(data$dB_no_outliar)

# normality test exactly
shapiro.test(data$dB_no_outliar)$p.value

# point and interval estimation of the mean
mean(data$dB_no_outliar, na.rm = TRUE)

t.test(data$dB_no_outliar, alternative = "two.sided", conf.level = 0.95)$conf.int

# point and interval estimation of the standard deviation
sd(data$dB_no_outliar, na.rm = TRUE)

res = EnvStats::varTest(data$dB_no_outliar,alternative = "two.sided", conf.level = 0.95)
sqrt(res$conf.int)

# * Example 6. ####
#
# In the data file pr8.xlsx you will find the measurement of the time to failure of the
# electrical component [h]. Calculate the 99% interval estimate of the average life of a
# given component type.
#

# read data
data = readxl::read_excel("data/pr8.xlsx")
head(data)

# visualization and verification of OP
boxplot(data$cas_h)
# there is an outliar, but is it really "bad" value?
# cannot we assume that the data came from exponential dist.?

hist(data$cas_h)
# looks very likeli as exponential distr.
# we keep the outliar as its not really outliar
# we already know we dont have normality and symmetry

# data normality test exploratory
moments::skewness(data$cas_h)
moments::kurtosis(data$cas_h) - 3

qqnorm(data$cas_h)
qqline(data$cas_h)

# median point and interval estimation
median(data$cas_h)
# IO
# install.packages("BSDA")
alpha = 0.01
BSDA::SIGN.test(data$cas_h, alternative = 'two.sided', conf.level = 1-alpha,
          conf.int = TRUE)$conf.int

# * Example from slides - 2 ####
# Company FactoryX produces packages with cocoa. The weight (in grams) of a randomly
# chosen packages is recorded in the dataset (cocoa.csv). Perform EDA and the two-sided
# 95% confidence interval for the mean weight of the packages from the whole production
# (or for median if necessary).

data = read.csv2("data/cocoa.csv")
head(data)

boxplot(data$weight)

shapiro.test(data$weight)

t.test(data$weight, alternative = "two.sided")

# * Example from slides - 3 ####
# Let's assume, that 30 out of 100 asked students in our university are smokers. What is
# the two-sided 95% confidence interval of the proportion of smokers among all
# university students? (The source data are also available in smokers.csv.)

data = read.csv2("data/smokers.csv")
head(data)

tab = table(data$Smokers)
tab

n = sum(tab)
n
x = tab['Y']
x

p = x/n
p
9/(p*(1-p))

binom.test(x,n,alternative="two.sided",conf.level=0.95)

# * Example from slides - 4 ####
# The hospital observed 50 patients with lung cancer and recorded their survival time in
# years (time.csv). Find the left-sided 95% confidence interval for the mean time of
# survival (or for median if necessary).

data = read.csv2("data/time.csv")
head(data)

boxplot(data$values)

shapiro.test(data$values)

moments::skewness(data$values)
hist(data$values)
# no normality, but we can assume symmetry

median(data$values)
wilcox.test(data$values,alternative = "greater",conf.int = TRUE, conf.level = 0.95)$conf.int


# Example : 3   Chapter : 7.3     Page No: 402
# Polar Decomposition
A<-matrix(c(2,-1,2,1),ncol=2)
Q<-round(svd(A)$u)%*%t(svd(A)$v)
H<-t(Q)%*%A
print("Polar Decomposition A=QH")
print("Q is ")
print(Q)
print("H is ")
print(H)
#The  answer may slightly vary due to  rounding off values
#The answers provided in the text book may vary because of the computation method followed.


set.seed(21)
x <- seq(1, 40, 1)
rep = 100
slope <- c(rep)
for (i in 1:rep) {
    y   <- 2 * x + 1 + 5 * rnorm(length(x))
    reg <- lm(y ~ x)
    slope[i] <- summary(reg)$coefficients[2, 1]
}

par(mfrow=c(1,2))

hist(slope, freq =FALSE)
x_app <- cbind(rep(1, 40), x)
sd_beta <- sqrt(solve(t(x_app) %*% x_app)[2, 2] * 25)
print(sd_beta)
lines(seq(1.7,2.3,by=0.01),dnorm(seq(1.7,2.3,by=0.01),mean=2.,sd=sd_beta))

mean_slope <- mean(slope)
std_slope <- sd(slope)
print(mean_slope)
print(std_slope)

for (i in 1:rep) {
    y   <- 2 * x + 1 + 5 * (1-rchisq(length(x), df=1))/sqrt(2)
    reg <- lm(y ~ x)
    slope[i] <- summary(reg)$coefficients[2, 1]
}

hist(slope, freq =FALSE)
x_app <- cbind(rep(1, 40), x)
sd_beta <- sqrt(solve(t(x_app) %*% x_app)[2, 2] * 25)
print(sd_beta)
lines(seq(1.7,2.3,by=0.01),dnorm(seq(1.7,2.3,by=0.01),mean=2.,sd=sd_beta))

mean_slope <- mean(slope)
std_slope <- sd(slope)
print(mean_slope)
print(std_slope)


## Plotting Ulam spiral (for primes) 2/12/17 aev
## plotulamspirR(n, clr, fn, ttl, psz=600), where: n - initial size;
## clr - color; fn - file name; ttl - plot title; psz - picture size.
##
require(numbers);
plotulamspirR <- function(n, clr, fn, ttl, psz=600) {
  cat(" *** START:", date(), "n=",n, "clr=",clr, "psz=", psz, "\n");
  if (n%%2==0) {n=n+1}; n2=n*n;
  x=y=floor(n/2); xmx=ymx=cnt=1; dir="R";
  ttl= paste(c(ttl, n,"x",n," matrix."), sep="", collapse="");
  cat(" ***", ttl, "\n");
  M <- matrix(c(0), ncol=n, nrow=n, byrow=TRUE);
  for (i in 1:n2) {
    if(isPrime(i)) {M[x,y]=1};
    if(dir=="R") {if(xmx>0) {x=x+1;xmx=xmx-1}
                  else {dir="U";ymx=cnt;y=y-1;ymx=ymx-1}; next};
    if(dir=="U") {if(ymx>0) {y=y-1;ymx=ymx-1}
                  else {dir="L";cnt=cnt+1;xmx=cnt;x=x-1;xmx=xmx-1}; next};
    if(dir=="L") {if(xmx>0) {x=x-1;xmx=xmx-1}
                  else {dir="D";ymx=cnt;y=y+1;ymx=ymx-1}; next};
    if(dir=="D") {if(ymx>0) {y=y+1;ymx=ymx-1}
                  else {dir="R";cnt=cnt+1;xmx=cnt;x=x+1;xmx=xmx-1}; next};
  };
  plotmat(M, fn, clr, ttl,,psz);
  cat(" *** END:",date(),"\n");
}

## Executing:
plotulamspirR(100, "red", "UlamSpiralR1", "Ulam Spiral: ");
plotulamspirR(200, "red", "UlamSpiralR2", "Ulam Spiral: ",1240);


weights=c(501.4, 498.0, 498.6 ,499.2, 495.2 ,501.4 ,509.5 ,494.9 ,498.6, 497.6,
          505.5 ,505.1 ,499.8 ,502.4, 497.0 ,504.3 ,499.7 ,497.9 ,496.5, 498.9,
          504.9 ,503.2 ,503.0 ,502.6 ,496.8 ,498.2, 500.1 ,497.9 ,502.2, 503.2)
n=length(weights)
ybar=mean(weights)
s=sd(weights)
# The upper-tail chi-square value
XU=qchisq(.995, df=29)
# The lower-tail chi-square value
XL=qchisq(.005, df=29)
# The 99% confidence interval for standard deviation
right_i=sqrt((n-1)*(s^2)/(XL))
left_i=sqrt((n-1)*(s^2)/(XU))
print(left_i)
print(right_i)
# The 99% confidence interval for mean
margin <- qnorm(0.995)*s/sqrt(n)
left_interval_mean=ybar-margin
right_interval_mean=ybar+margin
print(left_interval_mean)
print(right_interval_mean)


#########################################
# A toy example of Metropolis- Hastings
# (a Markov Chain Monte Carlo method)
# author: Alberto Lumbreras
#########################################
library(mvtnorm) # multivariate normal
library(coda) # MCMC checks
par(mfrow=c(1,1))

# demo 1: A mixture of Gammas (unidimensional)
# demo 2: A mixture of Gaussians (bi-dimensional)
demo <- 2

if(demo==1){

  # Target distribution
  dugly <- function(x) {
    0.5*dgamma(x, shape=15) + 0.5*dgamma(x, shape=30)
  }

  x <- seq(-10,75, by=0.1)
  plot(x, dugly(x), type='l', lwd=3)
  title("Metropolis-Hastings samplings")

  # Proposal distribution
  # (propose jumps to another state in the Markov Chain)
  rproposal <- function(jump){
    rnorm(1, 0, jump)
  }

  # Metropolis-Hastings
  ###########################
  nsamples <-10000
  samples <- matrix(NA,nsamples, 1)
  jump <- 5
  samples[1] <- 200 # init
  for (i in 2:nsamples){
    candidate <- samples[i-1] + rproposal(jump) # hence the "Markov Chain"!

    # take it or leave it !
    p.acceptance <- dugly(candidate)/dugly(samples[i-1])
    if (runif(1) > p.acceptance){
      samples[i] <- samples[i-1]
    }
    else{
      samples[i] <- candidate
    }
  }

  hist(samples, breaks=100, add=TRUE, probability = TRUE)

  # The Coda package allows to plot results,
  # perform convergence checks, etc
  plot(mcmc(samples))
}

# 2-D demo for the sake of beauty
# (and because we will be able to visalize the )
if(demo==2){
  par(mfrow=c(1,1))

  # Target distribution
  dugly <- function(xy) {
    x <- xy[1]
    y <- xy[2]
    covariance1 <- matrix(c(1, 0, 0, 100), nrow=2)
    covariance2 <- matrix(c(100,0, 0, 1), nrow=2)
    res <- (1/3)*mvtnorm::dmvnorm(c(x,y), mean = c(-5,0), sigma=covariance1) +
           (1/3)*mvtnorm::dmvnorm(c(x,y), mean = c(+0,0), sigma=covariance2) +
           (1/3)*mvtnorm::dmvnorm(c(x,y), mean = c(+5,0), sigma=covariance1)
    res
  }

  # Plot target distribution
  x <- seq(-20, 20, length.out=100)
  y <- seq(-20, 20, length.out=100)
  z <- matrix(NA, nrow=100, ncol=100)
  i <- 1
  for (n in 1:length(x)){
    for(m in 1:length(y)){
      z[n,m] <- dugly(c(x[n],y[m]))
      i <- i+1
    }
  }
  contour(x,y,z)
  title("Metropolis-Hastings sampling")

  # Proposal distribution
  # (propose jumps to another state in the Markov Chain)
  rproposal <- function(jump){
    covariance <- matrix(c(1, 0, 0, 1), nrow=2)
    mvtnorm::rmvnorm(1, mean = c(0,0), sigma=covariance*jump)
  }

  # Metropolis-Hastings
  ###########################
  nsamples <- 10000
  samples <- matrix(NA,nsamples, 2)
  jump <- 20 # Play with it to get around a 20-30% of acceptance rate
  samples[1,] <-c(20,20) # init
  for (i in 2:nsamples){
    candidate <- samples[i-1,] + rproposal(jump) # hence the "Markov Chain"!

    # take it or leave it !
    p.acceptance <- dugly(candidate)/dugly(samples[i-1,])
    if (runif(1) > p.acceptance){
      samples[i,] <- samples[i-1,]
    }
    else{
      samples[i,] <- candidate
    }
  }
}

# Plot samples
lines(samples, col='yellow')
points(samples, col='red', pch=19, cex=0.2)

# The Coda package allow to plot results,
# perform convergence checks, etc
plot(mcmc(samples))

# Check that the acceptance rate (after burn-in) is good (20-30%)
burn <- nsamples*0.5 # drop the first half of the chain
acceptance <- 100-mean(duplicated(samples[-(1:burn),]))*100
cat ("Acceptance ratio (recommended 30%):", acceptance, "%")


library(tidyverse)
library(stringr)
library(purrr)
library(lubridate)
library(readr)

setwd("C:/Users/Ghozy Haqqoni/Documents/!Kuliah/Semester 5 - DS/Time Series/datas/")
data("EuStockMarkets")
eu_stocks <- EuStockMarkets

####SCATTER PLOT####

####Asset prices vs. asset returns####
# Plot eu_stocks
plot(eu_stocks)
# Use this code to convert prices to returns
returns <- eu_stocks[-1,] / eu_stocks[-1860,] - 1
# Convert returns to ts
returns <- ts(returns, start = c(1991, 130), frequency = 260)
# Plot returns
plot(returns)
# Use this code to convert prices to log returns
logreturns <- diff(log(eu_stocks))
# Plot logreturns
plot(logreturns)
####

####Characteristics of financial time series####
library(data.table)

# Generate means from eu_percentreturns
colMeans(eu_percentreturns)
# Use apply to calculate sample variance from eu_percentreturns
apply(eu_percentreturns, MARGIN = 2, FUN = var)
# Use apply to calculate standard deviation from eu_percentreturns
apply(eu_percentreturns, MARGIN = 2, FUN = sd)
# Display a histogram of percent returns for each index
par(mfrow = c(2,2))
apply(eu_percentreturns, MARGIN = 2, FUN = hist, main = "", xlab = "Percentage Return")
# Display normal quantile plots of percent returns for each index
par(mfrow = c(2,2))
apply(eu_percentreturns, MARGIN = 2, FUN = qqnorm, main = "")
qqline(eu_percentreturns)
####

####Plotting pairs of data####
# Make a scatterplot of DAX and FTSE
plot(DAX, FTSE)
# Make a scatterplot matrix of eu_stocks
pairs(eu_stocks)
# Convert eu_stocks to log returns
logreturns <- diff(log(eu_stocks))
# Plot logreturns
plot(logreturns)
# Make a scatterplot matrix of logreturns
pairs(logreturns)
####

####COVARIANCE AND CORRELATION####

####Calculating sample covariances and correlations####
# Use cov() with DAX_logreturns and FTSE_logreturns
cov(DAX_logreturns, FTSE_logreturns)
# Use cov() with logreturns
cov(logreturns)
# Use cor() with DAX_logreturns and FTSE_logreturns
cor(DAX_logreturns, FTSE_logreturns)
# Use cor() with logreturns
cor(logreturns)
####

####AUTOCORRELATION####

####Calculating autocorrelations####
# Define x_t0 as x[-1]
x_t0 <- x[-1]
# Define x_t1 as x[-n] #n=150
x_t1 <- x[-n]
# Confirm that x_t0 and x_t1 are (x[t], x[t-1]) pairs
head(cbind(x_t0, x_t1))
# Plot x_t0 and x_t1
plot(x_t0, x_t1)
# View the correlation between x_t0 and x_t1
cor(x_t0, x_t1)
# Use acf with x
acf(x, lag.max = 1, plot = FALSE)
# Confirm that difference factor is (n-1)/n
cor(x_t1, x_t0) * (n-1)/n
####

####The autocorrelation function####
# Generate ACF estimates for x up to lag-10
acf(x, lag.max = 10, plot = FALSE)
# Type the ACF estimate at lag-10
#0.100
# Type the ACF estimate at lag-5
#0.198
####

####Visualizing the autocorrelation function####
# View the ACF of x
acf(x)
# View the ACF of y
acf(y)
# View the ACF of z
acf(z)
####


# y denote the number of successes in the n sample trials,
# sample proportion
y=43
n=50
pie=y/n
sigma=sqrt((pie*(1-pie))/n)
alpha=0.025
z.alpha=qnorm(1-alpha)
error=z.alpha*sigma
#  95% confidence interval
left_i=pie-error
right_i=pie+error
print(" Wald  95 % confidence interval")
print(left_i)
print(right_i)

# Using the WAC confidence interval, we need to compute:
ybar = y + 0.5*(z.alpha^2)
nbar = n + (z.alpha^2)
pie_bar=ybar/nbar

sigma_bar=sqrt((pie_bar*(1-pie_bar))/nbar)
error_bar=z.alpha*sigma_bar
left=pie_bar-error_bar
right=pie_bar+error_bar
print(" WAC 95% confidence interval")
print(left)
print(right)


#
# Shipment of 100 packets; shipment is denied if more than 5 packets are wrong.
# K is number of packets to check (randomly) in shipment = sample.
# Shipment is accepted if no wrong packets are found in the sample.
# Find K where P(bad shipment is accepted) < 0.1
#
for (k in c(2:100)){
  p <- choose(6, 0)*choose(94, k)/choose(100, k)
  if ( p <= 0.1){
    print(paste("k:", k, " and p:", p))
    break
  }
}

# Now shipment is accepted if there is at most 1 wrong packet in the sample
for (k in c(2:100)){
  p <- choose(6, 1)*choose(94, k-1)/choose(100, k)
  if ( p <= 0.1){
    print(paste("k:", k, " and p:", p))
    break
  }
}

#
# Let the number of chocolate chips in a certain type of cookie have a Poisson distribution.
# Probability that a randomly chosen cookie has at least 2 chocolate chips > 0.99
# Find the possible values of mean in 6,7,8 or 9 to assure that.
for (lambda in c(6,7,8,9)){
  p <- 1 - lambda^0 * exp(-lambda) / factorial(0) - lambda^1 * exp(-lambda) / factorial(1)
  print(paste("lambda: ",lambda, " p:", p))
}

# Another way
for (lambda in c(6,7,8,9)){
  p <- ppois(1, lambda = lambda, lower = FALSE)
  print(paste("lambda: ",lambda, " p:", p))
}


install.packages("fpp", repos = "http://cran.us.r-project.org", dependencies = TRUE)
library(fpp)

data1 = read.table("transcoding_measurement.tsv",header=TRUE)
plot(data1$size ~ data1$duration,  xlab = "Duration of video", ylab = "Size of the video")
fit = lm(data1$size ~ data1$duration ) ; abline(fit) #Add straight lines through the current plot
summary(fit)
# We verify by the plot that the duration of a video does affect the size of it.
# Typically, we can see the the duration and the size of a video are connected with a linear relationship.
# The Multiple R-squared error is 0.1738, meaning that the x-y variables are a bit connected.
# We can see that the line intersects for sure many observations,
# although the data1-set is too big and we can not see distinct it so much.
# They(x-y) could be less connected(we tested previously another set with an R-squared error of 0.004!)

# Also, the estimated regression line is : \hat y = 2513851.4 + 78589.4x

## Residual plots

res = residuals(fit) # Calculate residuals from the modeling function 'lm'
plot(res ~ data1$duration, ylab = "Residuals", xlab = "Duration of video", ylim = c(-5.0e+08,5.0e+08)); abline(0,0)
# Seeing the plot, we can understand that most of the residuals are between the
# -5.0e+08 and the +5.03e+08 values(0e+00 and 1e+08 value specifically,if we add the ylim parameter in the plot),
# with most of the observations having values 0 and 3000 about the duration of the video.
# So, yes, there is a pattern since the values are not so scattered around.

## Forecasting with regression
fitted(fit)[1]
newdata = data.frame(data1$duration)

fcast <- forecast(fit,newdata[1] > 130.3567)#=data.frame(duration>30))
# It will take a while due to the large size of the data(see global env)

plot(fcast, xlab="Duration of video", ylab="Size of video")
# This will plot us the result of the forecasting method for the the videos(data) that have duration larger thatn 130.3567 time units

## P-value
summary(fit)$coef # We calculate the probability of obtaining a value of  β^1
                  # as large as we have calculated if the null hypothesis were true

## Confidence intervals
confint(fit, level = 0.95) # Provide an interval estimate for β^1 in the fitted model

### Non-linear functional forms
# Simply transforming variables y and/or x and then estimating a regression model
# using the transformed variables is the simplest way of obtaining a non-linear specification.
# We are going to use the log-log functional form

par(mfrow=c(1,2), mar=c(9,4,0,2)+0.1)
fit2 <- lm(log(data1$size) ~ log(data1$duration)) # Do the fit for : log(y_i) = β_0 + β_1*log(x_i) + ε_i

plot(data1$size ~ data1$duration,  xlab = "Duration of video", ylab = "Size of the video") # Plot standard x-y form
lines(1:25000, exp(fit2$coef[1]+fit2$coef[2]*log(1:25000)))

plot(log(data1$size) ~ log(data1$duration),  xlab = "log Duration of video ", ylab = "log Size of the video") # log-log functional form
abline(fit2) # Draw a line through our second fitting model
# See that in this log-log form, the regression is much better since it gets through a lot more points

## Residuals in log-log functional form

res = residuals(fit2)
plot( res ~ data1$duration, xlab = "log(Duration)", ylab= "Residuals")
# We see that most residuals are between -2 and +3 while most log(Duration) points is between 0 and 3000
# Oh, and there is our lonely value right there with log(Duration) = ~25000

## Regression with time series data

# We are going to replace our x variable with 'utime' now.
# utime = total transcoding time for transcoding
# We are trying to impersonate utime with 'time' in this series of data, for the sake of simplicity.
# So, we can give as input a "future" 'utime' value and we will 'scenario-based' forecast the size of the video,
# after we do the regression.
#
# Warning: It would be better to replace the 'utime' variable with a 'Year' variable. As said, we do not want to change
# the data only because of this example!

par(mfrow=c(1,2)) # Change parameters for plot

fit.ex3 <- lm(data1$size ~ data1$utime) # Linear Model Fit for size ~ utime
plot(data1$size ~ data1$utime, ylab="% change in consumption and income", type="single", col=1:2, xlab="utime") #plot

legend("topright", legend=c("Size","utime"), lty=1, col=c(1,2), cex=.9)

plot(data1$size ~ data1$utime, ylab="% change in size", xlab="% change in utime")

abline(fit.ex3)
summary(fit.ex3)$coef

# The scatter plot includes the estimated regression line \hat{C} = 21760322.7 + 325380.9i

## Linear trend

# A common feature of time series data is a trend. Using regression we can model and
# forecast the trend in time series data by including  t=1,…,T,t=1,…,T,  as a predictor variable:
# y_t = β_0 + β_1*t + ε_t
library('forecast')

y=ts(data1[15], frequency = 5) # Take column No.11-size for each video- and make it a Time-Series object
fit.ex4 <- tslm(y ~ trend) # Do Linear Modeling Fit for y ~ trend
f <- forecast(fit.ex4, h=5,level=c(80,95)) # And do the forecast
plot(f, ylab="Size of video", xlab="t")

lines(fitted(fit.ex4),col="blue")
summary(fit.ex4)$coef

## Residual autocorrelation

par(mfrow=c(2,2))
res3 <- ts(resid(fit.ex3),s=1970.25,f=4) # Create time-series object using the residuals of 'fit.ex3' variable
plot.ts(res3,ylab="res (utime)", xlab = "utime units(instead of Time)")
abline(0,0)

acf(res3) # autocorrelation function for the model res3 (utime residuals)

## Same thing for 'fit.ex4' variable
res4 <- resid(fit.ex4)
plot(res4,ylab="res (size)")
abline(0,0)
acf(res4)

#################################################
par(mfrow=c(2,2))
res3 <- ts(resid(fit.ex3),s=1970.25,f=4)
plot.ts(res3,ylab="res (size) ")
abline(0,0)
acf(res3)

res4 <- resid(fit.ex4)
plot(res4,ylab="res (size)")
abline(0,0)
acf(res4)


library(tidyverse)
library(astsa)
library(xts)
library(tseries)

####CHAPTER 1

####Data Play####
data("AirPassengers")
# Plot AirPassengers
plot(AirPassengers)
# Plot the DJIA daily closings
plot(djia$Close)
# Plot the Southern Oscillation Index
plot(soi)
####

####Differencing####
# Plot detrended y (trend stationary)
plot(diff(y))
# Plot detrended x (random walk)
plot(diff(x))
####

####Detrending Data####
# Plot globtemp and detrended globtemp
par(mfrow = c(2,1))
plot(globtemp)
plot(diff(globtemp))
# Plot cmort and detrended cmort
par(mfrow = c(2,1))
plot(cmort)
plot(diff(cmort))
####

####Dealing with Trend and Heteroscedasticity####
# astsa and xts are preloaded
# Plot GNP series (gnp) and its growth rate
par(mfrow = c(3,1))
plot(gnp)
plot(diff(gnp))
plot(diff(log(gnp)))
# Plot DJIA closings (djia$Close) and its returns
par(mfrow = c(3,1))
plot(djia$Close)
plot(diff(djia$Close))
plot(diff(log(djia$Close)))
####

####Simulating ARMA Models####
#arima.sim(n = 63, list(ar = c(0.8897, -0.4858), ma = c(-0.2279, 0.2488)), rand.gen = function(n, ...) sqrt(0.1796) * rt(n, df = 5))
# Generate and plot white noise
WN <- arima.sim(model = list(order = c(0,0,0)), n=200)
plot(WN)
# Generate and plot an MA(1) with parameter .9
MA <- arima.sim(model = list(order = c(0,0,1), ma = .9) ,n=200)
plot(MA)
# Generate and plot an AR(2) with parameters 1.5 and -.75
AR <- arima.sim(model = list(order = c(2,0,0), ar = c(1.5,-.75)), n=200)
plot(AR)
####

####CHAPTER 2

####Fitting an AR(1) Model####
# Generate 100 observations from the AR(1) model
x <- arima.sim(model = list(order = c(1, 0, 0), ar = .9), n = 100)
# Plot the generated data
plot(x)
# Plot the sample P/ACF pair
plot(acf2(x))
# Fit an AR(1) to the data and examine the t-table
sarima(x, 1, 0, 0)
####

####Fitting an AR(2) Model####
# astsa is preloaded
# Plot x
plot(x)
# Plot the sample P/ACF of x
plot(acf2(x))
# Fit an AR(2) to the data and examine the t-table
sarima(x,2,0,0)
####

####Fitting an MA(1) Model####
# astsa is preloaded
# Plot x
plot(x)
# Plot the sample P/ACF of x
plot(acf2(x))
# Fit an MA(1) to the data and examine the t-table
sarima(x,0,0,1)
####

####Fitting an ARMA model####
# astsa is preloaded
# Plot x
plot(x)
# Plot the sample P/ACF of x
plot(acf2(x))
# Fit an ARMA(2,1) to the data and examine the t-table
sarima(x,2,0,1)
####

####Model Choice - I####
# Fit an MA(1) to dl_varve.
dl_varve <- diff(log(varve))
sarima(dl_varve, 0,0,1)
# Fit an MA(2) to dl_varve. Improvement?
sarima(dl_varve, 0,0,2)
# Fit an ARMA(1,1) to dl_varve. Improvement?
sarima(dl_varve, 1,0,1)
####

####Residual Analysis - I####
# Fit an MA(1) to dl_varve. Examine the residuals
sarima(dl_varve,0,0,1)
# Fit an ARMA(1,1) to dl_varve. Examine the residuals
sarima(dl_varve,1,0,1)
####

####ARMA get in####
# Calculate approximate oil returns
oil_returns <- diff(log(oil))
# Plot oil_returns. Notice the outliers
plot(oil_returns)
# Plot the P/ACF pair for oil_returns
plot(acf2(oil_returns))
# Assuming both P/ACF are tailing, fit a model to oil_returns
#sarima(oil_returns,_,_,_)
sarima(oil_returns,1,0,1)
####


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

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

#Degree
degree <- function(x){return(as.numeric(rowSums(a)[x]))}

#Global clustering coefficient
T <- 0 #number of triples
for (i in 1:n) {
  k <- degree(i)
  t <- (k * (k - 1))/2
  T <- t + T
}
tr <- sum(diag(a %*% a %*% a))/6 #number of triangles

C_gcc <-(tr/T) *3 #Global clust. coeff.
cat(sprintf("Global clustering coefficient is : %f \n",C_gcc))

#Degree assortativity
c <- sum(rowSums(a))/n   #Avg degree
m <- (n*c)/2  #No. of edges
R1 <- NULL
R2 <- NULL
for (i in 1:n) {
  for (j in 1:n) {
    if(i == j){d = 1} #Kronecker delta
    if(i != j){d = 0}
    r1 <- (a[i,j] - (degree(i)*degree(j))/(2*m))*(degree(i)*degree(j))
    r2 <- ((degree(i)*d) - (degree(i)*degree(j))/(2*m))*(degree(i)*degree(j))
    R1 <- c(r1, R1)
    R2 <- c(r2, R2)
  }
}
r <- sum(R1)/sum(R2)  #Degree assort.
cat(sprintf("Degree assortativity coefficient is : %f \n",r))


png("#44_adjust_a_polynom.png" , width = 480, height = 480 )
par(mar=c(4,4,1,1))

# We create 2 vectors x and y
x <- runif(300,  min=-10, max=10)
y <- 0.1*x^3 - 0.5 * x^2 - x + 10 + rnorm(length(x),0,8)

# plot of x and y :
plot(x,y,col=rgb(0.4,0.4,0.8,0.6),pch=16 , cex=1.3)

# Can we find a polynome that fit this function ?
model=lm(y ~ x + I(x^2) + I(x^3))

#I can get the features of this model :
summary(model)
model$coefficients
summary(model)$adj.r.squared

#For each value of x, I can get the value of y estimated by the model, and add it to the current plot !
myPredict <- predict( model )
ix <- sort(x,index.return=T)$ix
lines(x[ix], myPredict[ix], col=2, lwd=2 )
coeff=round(model$coefficients , 2)
text(3,-70 , paste("Model : ",coeff[1] , " + " , coeff[2] , "*x"  , "+" , coeff[3] , "*x^2" , "+" , coeff[4] , "*x^3" , "\n\n" , "P-value adjusted = ",round(summary(model)$adj.r.squared,2)))


library(tidyverse)
library(ggplot2)

# Set for reproducibility
set.seed(777)
sampleSize <- 10000

# Normal Distribution
dataN1 <- tibble(Outcome = rnorm(sampleSize, mean = 0, sd = 1), distribution = "N(0,1)")
dataN2 <- tibble(Outcome = rnorm(sampleSize, mean = 0, sd = 3), distribution = "N(0,3)")
dataN3 <- tibble(Outcome = rnorm(sampleSize, mean = 2, sd = 5), distribution = "N(2,5)")
dataN4 <- tibble(Outcome = rnorm(sampleSize, mean = 5, sd = 10), distribution = "N(5,10)")
dataN5 <- tibble(Outcome = rnorm(sampleSize, mean = 10, sd = 2), distribution = "N(10,2)")

data <- bind_rows(dataN1, dataN2, dataN3, dataN4, dataN5)

ggplot(data, aes(x = Outcome, fill = distribution)) +
  geom_density(aes(group = distribution), alpha = 0.25) +
  labs(
    title = "Sampling from normal distributions",
    subtitle = "10,000 samples"
  )

# chi-squared
dataChiSq1 <- tibble(Outcome = rchisq(sampleSize, df = 1), distribution = "Chi(1)")
dataChiSq2 <- tibble(Outcome = rchisq(sampleSize, df = 2), distribution = "Chi(2)")
dataChiSq3 <- tibble(Outcome = rchisq(sampleSize, df = 5), distribution = "Chi(5)")
dataChiSq4 <- tibble(Outcome = rchisq(sampleSize, df = 10), distribution = "Chi(10)")
dataChiSq5 <- tibble(Outcome = rchisq(sampleSize, df = 20), distribution = "Chi(20)")

data <- bind_rows(dataChiSq1, dataChiSq2, dataChiSq3, dataChiSq4, dataChiSq5)

ggplot(data, aes(x = Outcome, fill = distribution)) +
  geom_density(aes(group = distribution), alpha = 0.25) +
  labs(
    title = "Sampling from chi-squared distributions",
    subtitle = "10,000 samples"
  )

# f-distribution
dataF1 <- tibble(Outcome = rf(sampleSize, df1 = 1, df2 = 1), distribution = "F(1,1)")
dataF2 <- tibble(Outcome = rf(sampleSize, df1 = 5, df2 = 5), distribution = "F(5,5)")
dataF3 <- tibble(Outcome = rf(sampleSize, df1 = 10, df2 = 20), distribution = "F(10,20)")
dataF4 <- tibble(Outcome = rf(sampleSize, df1 = 30, df2 = 5), distribution = "F(30,5)")
dataF5 <- tibble(Outcome = rf(sampleSize, df1 = 15, df2 = 30), distribution = "F(15, 30)")

data <- bind_rows(dataF1, dataF2, dataF3, dataF4, dataF5)

ggplot(data, aes(x = Outcome, fill = distribution)) +
  geom_density(aes(group = distribution), alpha = 0.25) +
  labs(
    title = "Sampling from F-distributions",
    subtitle = "10,000 samples. Removed curves after x=15"
  ) +
  xlim(0, 15)

# Exponential
dataExp1 <- tibble(Outcome = rexp(sampleSize, rate = 1), distribution = "Exp(1)")
dataExp2 <- tibble(Outcome = rexp(sampleSize, rate = .1), distribution = "Exp(0.1)")
dataExp3 <- tibble(Outcome = rexp(sampleSize, rate = .2), distribution = "Exp(0.2)")
dataExp4 <- tibble(Outcome = rexp(sampleSize, rate = .5), distribution = "Exp(0.5)")
dataExp5 <- tibble(Outcome = rexp(sampleSize, rate = .8), distribution = "Exp(0.8)")

data <- bind_rows(dataExp1, dataExp2, dataExp3, dataExp4, dataExp5)

ggplot(data, aes(x = Outcome, fill = distribution)) +
  geom_density(aes(group = distribution), alpha = 0.25) +
  labs(
    title = "Sampling from Exponential distributions",
    subtitle = "10,000 samples"
  )

# Cauchy
dataCauchy1 <- tibble(Outcome = rcauchy(sampleSize, location = 0, scale = 1), distribution = "Cauchy(0,1)")
dataCauchy2 <- tibble(Outcome = rcauchy(sampleSize, location = 0, scale = 2), distribution = "Cauchy(0,2)")
dataCauchy3 <- tibble(Outcome = rcauchy(sampleSize, location = 0, scale = 0.5), distribution = "Cauchy(0,0.5)")
dataCauchy4 <- tibble(Outcome = rcauchy(sampleSize, location = -1, scale = 5), distribution = "Cauchy(-1,5)")
dataCauchy5 <- tibble(Outcome = rcauchy(sampleSize, location = -5, scale = 1), distribution = "Cauchy(-5,1)")

data <- bind_rows(dataCauchy1, dataCauchy2, dataCauchy3, dataCauchy4, dataCauchy5)

ggplot(data, aes(x = Outcome, fill = distribution)) +
  geom_density(aes(group = distribution), alpha = 0.25) +
  labs(
    title = "Sampling from Cauchy distributions",
    subtitle = "10,000 samples"
  ) +
  xlim(-10,10)

# Gamma
dataGamma1 <-tibble(Outcome = rgamma(sampleSize, shape = 1, rate = 1), distribution = "Gamma(1,1)")
dataGamma2 <- tibble(Outcome = rgamma(sampleSize, shape = 2, rate = 1), distribution = "Gamma(2,1)")
dataGamma3 <- tibble(Outcome = rgamma(sampleSize, shape = 3, rate = 1), distribution = "Gamma(3,1)")
dataGamma4 <- tibble(Outcome = rgamma(sampleSize, shape = 1, rate = 5), distribution = "Gamma(1,5)")
dataGamma5 <- tibble(Outcome = rgamma(sampleSize, shape = 3, rate = 5), distribution = "Gamma(3,5)")

data <- bind_rows(dataGamma1, dataGamma2, dataGamma3, dataGamma4, dataGamma5)

ggplot(data, aes(x = Outcome, fill = distribution)) +
  geom_density(aes(group = distribution), alpha = 0.25) +
  labs(
    title = "Sampling from Gamma distributions",
    subtitle = "10,000 samples. 1st parameter = shape, 2nd parameter = rate"
  ) +
  xlim(0, 8)

# Beta
dataBeta1 <-tibble(Outcome = rbeta(sampleSize, shape1 = .5, shape2 = .5), distribution = "Beta(0.5,0.5)")
dataBeta2 <- tibble(Outcome = rbeta(sampleSize, shape1 = 2, shape2 = 1), distribution = "Beta(2,1)")
dataBeta3 <- tibble(Outcome = rbeta(sampleSize, shape1 = 3, shape2 = 1), distribution = "Beta(3,1)")
dataBeta4 <- tibble(Outcome = rbeta(sampleSize, shape1 = 1, shape2 = 5), distribution = "Beta(1,5)")
dataBeta5 <- tibble(Outcome = rbeta(sampleSize, shape1 = 3, shape2 = 5), distribution = "Beta(3,5)")

data <- bind_rows(dataBeta1, dataBeta2, dataBeta3, dataBeta4, dataBeta5)

ggplot(data, aes(x = Outcome, fill = distribution)) +
  geom_density(aes(group = distribution), alpha = 0.25) +
  labs(
    title = "Sampling from Beta distributions",
    subtitle = "10,000 samples. 1st parameter = shape 1, 2nd parameter = shape 2"
  )

?rnorm


# simple varaince and standard deviation
ClassInterval <- c("16.25-18.75", "18.75-21.25", "21.25-23.75","23.75-26.25", "26.25-28.75", " 28.75-31.25", " 31.25-33.75", "33.75-36.25","36.25-38.75", " 38.75- 41.25","41.25- 43.75")
freq <- c( 2,7,7,14,17,24,11,11,3,3,1)
mid_interval<- c(17.5,20.0,22.5,25.0,27.5,30.0,32.5,35.0,37.5,40.0,42.5)
fmi<-freq*mid_interval

mean_y<-sum(fmi)/sum(freq)
sample_variance <-(sum(freq*((mid_interval-mean_y)^2)/(sum(freq)-1)))
print(sample_variance)
standard_deviation <-sqrt(sample_variance)
print(standard_deviation)


# https://fivethirtyeight.com/features/pick-a-card-any-card/
# From a shuffled deck of 100 cards that are numbered 1 to 100,
# you are dealt 10 cards face down. You turn the cards over one by one.
# After each card, you must decide whether to end the game.
# If you end the game on the highest card in the hand you were dealt, you win;
# otherwise, you lose.
# What is the strategy that optimizes your chances of winning?
# How does the strategy change as the sizes of the deck and the hand are changed?

# Libraries
library(tidyverse)

# Input
no_cards <- 100
no_turns <-  10

#Code
cards <- no_cards:1
turns <- no_turns:1

# If current card is not your high card then continue picking
# Otherwise if current card is your high card:

y <- matrix(NA, nrow = max(turns), ncol = max(cards))
for (i in cards) {
  x <- numeric(max(turns))
  for (j in turns) {
    lwr <- i - (max(turns) - j)
    tot <- max(cards) - (max(turns) - j)
    a <- pmax(0, (lwr - 1):(lwr - j))
    b <- (tot - 1):(tot - j)
    x[(max(turns) - j + 1)] <- tail(cumprod(a / b), 1)
  }
  y[, (max(cards) - i + 1)] <- x
}

xval <- yval <- numeric(nrow(y))
for (i in 1:nrow(y)) {
  xval[i] <- i
  yval[i] <- max(cards) - max(which(y[i, ] > 0.5))
}
yval <- c(yval[2:max(turns)], max(turns))
line <- tibble(x = xval, y = yval)

colnames(y) <- max(cards):1
y <- as_tibble(y) %>%
  mutate(turn = 1:max(turns)) %>%
  gather(max(cards):1, key = card, value = prob) %>%
  mutate(card = as.numeric(card))

# Output
ggplot(y, aes(turn, card)) +
  geom_tile(aes(fill = prob)) +
  scale_fill_gradient(low = "white", high = "steelblue") +
  theme_minimal() +
  layer(geom = "line", stat = "identity",
        position = "identity", data = line,
        aes(x, y))
as_tibble(paste0("For turn ", xval, " stop if card >= ", yval))


#Copyright (c) 2016 Riccardo Francescato
X = c(10,20,50,100,150,200)
Y = c(9.4,9.2,9.0,8.5,8.1,7.4)

alpha = .05
SigmaX =  sum( (X - mean(X) )^2 )
SigmaY = sum( (Y - mean(Y) )^2 )
CovXY = cov(X,Y)
CorXY = cor(X,Y)
Beta1 = sum((Y - mean(Y))*(X - mean(X) ))/SigmaX
Beta0 = mean(Y)-mean(X)*Beta1
Sigma2 = (SigmaY-(SigmaX*Beta1^2))/(length(X)-2)
Ystim = Y-(Beta0+Beta1*X)
Errors = Y-Ystim
SSR = sum((Ystim-mean(Y))^2)
SSE = sum(Errors^2)
SST = sum((Y-mean(Y))^2)
MSR = SSR/1
MSE = SSE/(length(X)-2)
MST = SST/(length(X)-1)
F0 = MSR/MSE
Fa = qf(alpha,df1=1,df2=(length(X)-2),lower.tail=F)

if(F0 > Fa) print(paste0(" reject H0 ", F0)) else print(paste0(" Accept H0 ", F0))
cat(paste0(" Regression  SS: ",SSR," Df: ", 1 ," MS: ",MSR, " F0: ",F0,
		"\n Error  SS: ",SSE," Df: ", (length(X)-2) ," MS: ",MSE,
		"\n Total  SS: ",SST," Df: ", (length(X)-1)))

mydata = data.frame(
  y = c(2256,2340,2426,2293,2330,2368,2250,2409,2364,2379,2440,2364,2404,2317,2309,2328),
  x1 = c(80,93,100,82,90,99,81,96,94,93,97,95,100,85,86,87),
  x2 = c(8,9,10,12,11,8,8,10,12,11,13,11,8,12,9,12)
)
# Multiple Linear Regression Example
fit <- lm(y ~ x1 + x2, data=mydata)
summary(fit) # show results
# Other useful functions
coefficients(fit) # model coefficients
confint(fit, level=0.95) # CIs for model parameters
fitted(fit) # predicted values
residuals(fit) # residuals
anova(fit) # anova table
vcov(fit) # covariance matrix for model parameters
influence(fit) # regression diagnostics


data <- read.csv('Oil_Prices.csv')
library(ggplot2)
WTI_ts <- ts(data$WTI, frequency=12, start=c(1999,9))
Brent_ts <- ts(data$Brent, frequency=12, start=c(1999,9))

library(forecast)
hist(WTI_ts, breaks=20, freq=FALSE, col='blue')
lines(density(WTI_ts) , col='red', lwd=3)

monthplot(WTI_ts,col.base='red')
seasonplot(WTI_ts,col=1:20, year.labels=TRUE)
# We can determine a slight seasonal pattern. We see demand increases in the end
#of the year months,however these are not strong enough to determine seasonality.

t0 = c(1999,9)
t1 = c(2018,12)
t2 = c(2019,7)
WTI_train <- window(WTI_ts, start=t0, end=t1)
WTI_test <- window(WTI_ts, start=t2)

#Univariate Case
library(urca)
WTI_ADF_none <- ur.df(WTI_train, type="none", lags=12, selectlags = "AIC")
summary(WTI_ADF_none)

WTI_ADF_drift <- ur.df(WTI_train, type="drift", lags=12, selectlags = "AIC")
summary(WTI_ADF_drift)

WTI_ADF_trend <- ur.df(WTI_train, type="trend", lags=12, selectlags = "AIC")
summary(WTI_ADF_trend)
# We fail to reject null for all test. This means WTI is not a stationary process
# for all test.
# You cannot reject the no drift null. You do not need a drift coefficient.
# You do not need to include a drift nor trend in our data

DWTI <-diff(WTI_train)
DWTI_ADF_none <- ur.df(DWTI, type="none", lags=12, selectlags = "AIC")
summary(DWTI_ADF_none)
DWTI_ADF_drift <- ur.df(DWTI, type="drift", lags=12, selectlags = "AIC")
summary(DWTI_ADF_drift)
DWTI_ADF_trend <- ur.df(DWTI, type="trend", lags=12, selectlags = "AIC")
summary(DWTI_ADF_trend)
# The best version is the no drift and no trend. Based on this we say it
# is stationary integrated order 1.

WTIarimaA <- auto.arima(DWTI, d=0, max.p=5, max.q=5, max.order=10,
seasonal=FALSE, stepwise=FALSE, ic='aic')
WTIarimaB <- auto.arima(DWTI, d=0, max.p=5, max.q=5, max.order=10,
seasonal=FALSE, stepwise=FALSE, ic='bic')

WTIarimaA
WTIarimaB

future= forecast(WTIarimaA, h = 20)
plot(future)

# Bivariate Case

library(vars)
Brent_train <- window(Brent_ts, start=t0, end=t1)
Brent_test <- window(Brent_ts, start=t2)
df_level <-data.frame(WTI_train, Brent_train)

vecm <- ca.jo(df_level, type = 'eigen', ecdet = 'const', K=2,spec='transitory')
summary(vecm)
# The null r=0 is rejected so there is atleast 1 cointegration factor. The
# second test is not rejected therefore there is only one cointegration factor.

vecm.rls <- cajorls(vecm, r = 1)
error <- vecm.rls$rlm$model['ect1']
tsdisplay(error$ect1)
error_ADF <- ur.df(error$ect1, type="none", lags=12, selectlags = "AIC")
summary(error_ADF)
# The error correction term is stationary and is not a white noise process.

cajorls(vecm)
coef(summary(cajorls(vecm)$rlm))
# At 5% significance WTI responds most to our error correction term

var.model = vec2var(vecm)
H = 12
fc <- predict(var.model, n.ahead=H)

WTI_forecast <- ts(fc$fcst$WTI_train[1:H,1], frequency=12, start=t2)
Brent_forecast <- ts(fc$fcst$Brent_train[1:H,1], frequency=12, start=t2)

print('WTI error')
x = accuracy(WTI_forecast,WTI_test)
cat('RMSE:',x[1,'RMSE'], '\n')
cat('MAE:',x[1,'MAE'], '\n')

print('Brent error')
y = accuracy(Brent_forecast,Brent_test)
cat('RMSE:',y[1,'RMSE'], '\n')
cat('MAE:',y[1,'MAE'], '\n')

WTI_forecast
Brent_forecast

plot(fc)


crime_rate=c(876,578,718,388,562,971,698,298,673,537,642,856,376,508,529,393,354,735,811,504,807,719,464,410,491,557,771,685,448,571,189,661,877,563,647,447,336,526,624,605,496,296,628,481,224,868,804,210,421,435,291,393,605,341,352,374,267,684,685,460,466,498,562,739,562,817,690,720,758,731,480,559,505,703,809,706,631,626,639,585,570,928,516,885,751,561,1020,592,814,843)

median(crime_rate)
lower_quartile=quantile(crime_rate,0.25)
lower_quartile
upper_quartile=quantile(crime_rate,0.75)
upper_quartile
IQR(crime_rate)
# book answer will vary because median is calculated wrong in book.


install.packages("mvtnorm")
install.packages("Rfast")
library(Rfast)

library(mvtnorm)

rdag <- function(n, p, s, a = 0, m = NULL, A = NULL, seed = FALSE) {
  ## n in the sample size
  ## p is the number of (nodes or) variables
  ## s is the success probability of the binomial distribution
  ## a is the percentage of outliers, is set to zero by default
  ## a number between 0 and 1
  ## m is the mean vector which is used only if you want outliers, i.e. if a > 0
  ## A is an adjancey matrix given by the user
  if ( is.null(A) ) { ## no adjacency matrix is given
    if ( s > 1 || s < 0 )  s <- 0.5
    if ( a > 1 || a < 0 )  a <- 0
    if ( seed )  set.seed(1234567)
    A <- matrix( 0, p, p )
    nu <- 0.5 * p * (p - 1)
    A[ lower.tri(A) ] <- rbinom(nu, 1, s)
    A[ A == 1 ] <- runif( sum(A), 0.1, 1 )
  } else {
    A <- A
    p <- ncol(A)
  }

  Ip <- diag(p)
  sigma <- solve( Ip - A )
  sigma <- tcrossprod( sigma )
  nout <- 0
  if ( seed )  set.seed(1234567)

  if (a > 0) {
    y <- mvtnorm::rmvnorm( n - nout, numeric(p), sigma)
    nout <- round( a * n )
    yout <- mvtnorm::rmvnorm(nout, m, sigma)
    x <- rbind(y, yout)
  } else  x <- mvtnorm::rmvnorm(n, numeric(p), sigma)

  G <- t( A )
  G[ G > 0 ] <- 2
  ind <- which( t(G) == 2 )
  G[ind] <- 3

  V <- colnames(A)
  if ( is.null(V) )   V <- paste("X", 1:p, sep = "")
  colnames(x) <- V
  colnames(G) <- rownames(G) <- V
  colnames(A) <- rownames(A) <- V
  list(nout = nout, G = G, A = A, x = x)
}

library(dplyr)
A <- matrix(c(
	0,0,0,
	1,0,0,
	0,1,0
), 3) %>% t

A <- matrix(c(
	0,0,0,0,
	0.1,0,0,0,
	0,0.5,0,0,
	0,0,0.5,0
), 4) %>% t

A <- matrix(c(
0,0,0,0,0,0,
0,0,0,0,0,0,
0,0,0,0,0,0,
1,0,0,0,0,0,
0,1,0,1,0,0,
0,0,1,0,1,0
),6,6) %>% t

(Ip - A) %>% solve %>% tcrossprod

t(A) %*% A

crossprod(A)

o <- rdag(10000, A=A)
dim(o)
x <- o$x

apply(x, 2, var)
cor(x)^2

x <- rmvnorm(10000, numeric(3), matrix(c(1, 0.5, 0.25,
0.5, 1, 0.5,
0.25, 0.5, 1), 3,3))

library(pcalg)


### 線形回帰分析の例
### - Ashenfelter's Wine Equation

## パッケージの読み込み
require(tidyverse)
require(ggfortify)
require(GGally)

## データの読み込み("wine.csv"を用いる)
scan(file="data/wine.txt", what=character(), sep=";") # データの説明の表示
wine <- read.csv(file="data/wine.csv", row.names=1)  # データの読み込み

## データの内容を確認
print(wine) # データの表示

## データのプロット
ggpairs(wine,
        lower=list(continuous=wrap("smooth_loess",colour="blue"))) +
    theme(axis.title.x=element_text(size=8),
          axis.title.y=element_text(size=8)) # 文字の大きさを調整

## ボルドーワインの価格(質)を冬の降雨量(WRAIN)，育成期平均気温(DEGREES)，
## 収穫期降雨量(HRAIN)，年数(TIME_SV)で回帰する
model <- lm(LPRICE2 ~ ., data=wine)
summary(model)
round(coef(model), digits=6) # 係数を確認する

## 診断プロット
autoplot(model)
## autoplot(model, which=1) # res vs fit
## autoplot(model, which=2) # qq plot
## autoplot(model, which=4) # Cook's dist
## autoplot(model, which=1:6)

## 回帰による予測結果を比較
year <- rownames(wine)
price <- exp(wine$LPRICE2)
predict <- exp(predict(model, newdata=wine, interval="prediction"))
mydat <- data.frame(year=year, price=price, predict)

## 実測値と予測値の比較
ggplot(mydat, aes(price, fit, label=year)) +
    geom_text(na.rm=TRUE) + # text で表示
    scale_x_log10() + scale_y_log10() + # log-log plot
    labs(title="Bordeaux Wine Price (log)", x="Price", y="Prediction")

## 各年の比較
ggplot(mydat, aes(year, price, group=1)) +
    geom_ribbon(aes(ymin=lwr, ymax=upr),
                fill="red", alpha=.1, na.rm=TRUE) +
    geom_path(aes(y=price, colour="Price"), na.rm=TRUE) +
    geom_path(aes(y=fit, colour="Predict"), na.rm=TRUE) +
    theme(axis.text.x=element_text(angle = 90, hjust=1, vjust=.5),
          legend.position=c(.9,.9)) + # 文字の向きと凡例の位置を調整
    labs(title="Bordeaux Wine Price", x="Year")

### 専門家の評価が高かったのは1986年だが，予測では凡庸
### その後1989/1990年の気温(かなり高い)を用いて予測した内容が話題となる


library(repr) ; options(repr.plot.width = 4, repr.plot.height = 4) # Change plot sizes (in cm)

rm(list = ls())
graphics.off()

S_data <- seq(1,50,5)
S_data

V_data <- ((12.5 * S_data)/(7.1 + S_data))
plot(S_data, V_data)

set.seed(1456) # To get the same random fluctuations in the "data" every time
V_data <- V_data + rnorm(10,0,1) # Add 10 random fluctuations  with standard deviation of 0.5 to emulate error
plot(S_data, V_data)

MM_model <- nls(V_data ~ V_max * S_data / (K_M + S_data))

plot(S_data,V_data, xlab = "Substrate Concentration", ylab = "Reaction Rate")  # first plot the data
lines(S_data,predict(MM_model),lty=1,col="blue",lwd=2) # now overlay the fitted model

coef(MM_model) # check the coefficients

Substrate2Plot <- seq(min(S_data), max(S_data),len=200) # generate some new x-axis values just for plotting

Predict2Plot <- coef(MM_model)["V_max"] * Substrate2Plot / (coef(MM_model)["K_M"] + Substrate2Plot) # calculate the predicted values by plugging the fitted coefficients into the model equation

plot(S_data,V_data, xlab = "Substrate Concentration", ylab = "Reaction Rate")  # first plot the data
lines(Substrate2Plot, Predict2Plot, lty=1,col="blue",lwd=2) # now overlay the fitted model

summary(MM_model)

confint(MM_model)

MM_model2 <- nls(V_data ~ V_max * S_data / (K_M + S_data), start = list(V_max = 12, K_M = 7))

coef(MM_model)
coef(MM_model2)

MM_model3 <- nls(V_data ~ V_max * S_data / (K_M + S_data), start = list(V_max = .01, K_M = 20))

coef(MM_model)
coef(MM_model2)
coef(MM_model3)

plot(S_data,V_data)  # first plot the data
lines(S_data,predict(MM_model),lty=1,col="blue",lwd=2) # overlay the original model fit
lines(S_data,predict(MM_model3),lty=1,col="red",lwd=2) # overlay the latest model fit

nls(V_data ~ V_max * S_data / (K_M + S_data), start = list(V_max = 0, K_M = 0.1))

nls(V_data ~ V_max * S_data / (K_M + S_data), start = list(V_max = -0.1, K_M = 100))

MM_model4 <- nls(V_data ~ V_max * S_data / (K_M + S_data), start = list(V_max = 12.96, K_M = 10.61))

coef(MM_model)
coef(MM_model4)

require("minpack.lm")

MM_model5 <- nlsLM(V_data ~ V_max * S_data / (K_M + S_data), start = list(V_max = 2, K_M = 2))

coef(MM_model2)
coef(MM_model5)

MM_model6 <- nlsLM(V_data ~ V_max * S_data / (K_M + S_data), start = list(V_max = .01, K_M = 20))

MM_model7 <- nlsLM(V_data ~ V_max * S_data / (K_M + S_data), start = list(V_max = 0, K_M = 0.1))

MM_model8 <- nlsLM(V_data ~ V_max * S_data / (K_M + S_data), start = list(V_max = -0.1, K_M = 100))

coef(MM_model6)
coef(MM_model7)
coef(MM_model8)

nlsLM(V_data ~ V_max * S_data / (K_M + S_data), start = list(V_max = -10, K_M = -100))

nlsLM(V_data ~ V_max * S_data / (K_M + S_data), start = list(V_max = 0.1, K_M = 0.1))

nlsLM(V_data ~ V_max * S_data / (K_M + S_data), start = list(V_max = 0.1, K_M = 0.1), lower=c(0.4,0.4), upper=c(100,100))

nlsLM(V_data ~ V_max * S_data / (K_M + S_data), start =  list(V_max = 0.5, K_M = 0.5), lower=c(0.4,0.4), upper=c(20,20))

hist(residuals(MM_model6))

MyData <- read.csv("../data/GenomeSize.csv") # using relative path assuming that your working directory is "code"

head(MyData)

Data2Fit <- subset(MyData,Suborder == "Anisoptera")

Data2Fit <- Data2Fit[!is.na(Data2Fit$TotalLength),] # remove NA's

plot(Data2Fit$TotalLength, Data2Fit$BodyWeight, xlab = "Body Length", ylab = "Body Weight")

library("ggplot2")

ggplot(Data2Fit, aes(x = TotalLength, y = BodyWeight)) +
geom_point(size = (3),color="red") + theme_bw() +
labs(y="Body mass (mg)", x = "Wing length (mm)")

nrow(Data2Fit)

PowFit <- nlsLM(BodyWeight ~ a * TotalLength^b, data = Data2Fit, start = list(a = .1, b = .1))

powMod <- function(x, a, b) {
 return(a * x^b)
}

PowFit <- nlsLM(BodyWeight ~ powMod(TotalLength,a,b), data = Data2Fit, start = list(a = .1, b = .1))

Lengths <- seq(min(Data2Fit$TotalLength),max(Data2Fit$TotalLength),len=200)

coef(PowFit)["a"]
coef(PowFit)["b"]

Predic2PlotPow <- powMod(Lengths,coef(PowFit)["a"],coef(PowFit)["b"])

plot(Data2Fit$TotalLength, Data2Fit$BodyWeight)
lines(Lengths, Predic2PlotPow, col = 'blue', lwd = 2.5)

summary(PowFit)

print(confint(PowFit))

hist(residuals(PowFit))

QuaFit <- lm(BodyWeight ~ poly(TotalLength,2), data = Data2Fit)

Predic2PlotQua <- predict.lm(QuaFit, data.frame(TotalLength = Lengths))

plot(Data2Fit$TotalLength, Data2Fit$BodyWeight)
lines(Lengths, Predic2PlotPow, col = 'blue', lwd = 2.5)
lines(Lengths, Predic2PlotQua, col = 'red', lwd = 2.5)

RSS_Pow <- sum(residuals(PowFit)^2) # Residual sum of squares
TSS_Pow <- sum((Data2Fit$BodyWeight - mean(Data2Fit$BodyWeight))^2) # Total sum of squares
RSq_Pow <- 1 - (RSS_Pow/TSS_Pow) # R-squared value

RSS_Qua <- sum(residuals(QuaFit)^2) # Residual sum of squares
TSS_Qua <- sum((Data2Fit$BodyWeight - mean(Data2Fit$BodyWeight))^2) # Total sum of squares
RSq_Qua <- 1 - (RSS_Qua/TSS_Qua) # R-squared value

RSq_Pow
RSq_Qua

n <- nrow(Data2Fit) #set sample size
pPow <- length(coef(PowFit)) # get number of parameters in power law model
pQua <- length(coef(QuaFit)) # get number of parameters in quadratic model

AIC_Pow <- n + 2 + n * log((2 * pi) / n) + n * log(RSS_Pow) + 2 * pPow
AIC_Qua <- n + 2 + n * log((2 * pi) / n) + n * log(RSS_Qua) + 2 * pQua
AIC_Pow - AIC_Qua

AIC(PowFit) - AIC(QuaFit)

alb <- read.csv(file="../data/albatross_grow.csv")
alb <- subset(x=alb, !is.na(alb$wt))
plot(alb$age, alb$wt, xlab="age (days)", ylab="weight (g)", xlim=c(0, 100))

logistic1 <- function(t, r, K, N0){
 N0 * K * exp(r * t)/(K+N0 * (exp(r * t)-1))
}

vonbert.w <- function(t, Winf, c, K){
 Winf * (1 - exp(-K * t) + c * exp(-K * t))^3
}

scale <- 4000

alb.lin <- lm(wt/scale ~ age, data = alb)

alb.log <- nlsLM(wt/scale~logistic1(age, r, K, N0), start=list(K=1, r=0.1, N0=0.1), data=alb)

alb.vb <- nlsLM(wt/scale~vonbert.w(age, Winf, c, K), start=list(Winf=0.75, c=0.01, K=0.01), data=alb)

ages <- seq(0, 100, length=1000)

pred.lin <- predict(alb.lin, newdata = list(age=ages)) * scale

pred.log <- predict(alb.log, newdata = list(age=ages)) * scale

pred.vb <- predict(alb.vb, newdata = list(age=ages)) * scale

plot(alb$age, alb$wt, xlab="age (days)", ylab="weight (g)", xlim=c(0,100))
lines(ages, pred.lin, col=2, lwd=2)
lines(ages, pred.log, col=3, lwd=2)
lines(ages, pred.vb, col=4, lwd=2)

legend("topleft", legend = c("linear", "logistic", "Von Bert"), lwd=2, lty=1, col=2:4)

par(mfrow=c(3,1), bty="n")
plot(alb$age, resid(alb.lin), main="LM resids", xlim=c(0,100))
plot(alb$age, resid(alb.log), main="Logisitic resids", xlim=c(0,100))
plot(alb$age, resid(alb.vb), main="VB resids", xlim=c(0,100))

n <- length(alb$wt)
list(lin=signif(sum(resid(alb.lin)^2)/(n-2 * 2), 3),
 log= signif(sum(resid(alb.log)^2)/(n-2 * 3), 3),
 vb= signif(sum(resid(alb.vb)^2)/(n-2 * 3), 3))

aedes <- read.csv(file="../data/aedes_fecund.csv")

plot(aedes$T, aedes$EFD, xlab="temperature (C)", ylab="Eggs/day")

quad1 <- function(T, T0, Tm, c){
 c * (T-T0) * (T-Tm) * as.numeric(T<Tm) * as.numeric(T>T0)
}

briere <- function(T, T0, Tm, c){
 c * T * (T-T0) * (abs(Tm-T)^(1/2)) * as.numeric(T<Tm) * as.numeric(T>T0)
}

scale <- 20

aed.lin <- lm(EFD/scale ~ T, data=aedes)

aed.quad <- nlsLM(EFD/scale~quad1(T, T0, Tm, c), start=list(T0=10, Tm=40, c=0.01), data=aedes)

aed.br <- nlsLM(EFD/scale~briere(T, T0, Tm, c), start=list(T0=10, Tm=40, c=0.1), data=aedes)

t <- seq(0, 22, 2)
N <- c(32500, 33000, 38000, 105000, 445000, 1430000, 3020000, 4720000, 5670000, 5870000, 5930000, 5940000)

set.seed(1234) # To ensure we always get the same random sequence in this example "dataset"

data <- data.frame(t, N * (1 + rnorm(length(t), sd = 0.1))) # add some random error

names(data) <- c("Time", "N")

head(data)

ggplot(data, aes(x = Time, y = N)) +
 geom_point(size = 3) +
 labs(x = "Time (Hours)", y = "Population size (cells)")

data$LogN <- log(data$N)

# visualise
ggplot(data, aes(x = t, y = LogN)) +
 geom_point(size = 3) +
 labs(x = "Time (Hours)", y = "log(cell number)")

(data[data$Time == 10,]$LogN - data[data$Time == 6,]$LogN)/(10-6)

diff(data$LogN)

max(diff(data$LogN))/2 # 2 is the difference in any successive pair of timepoints

lm_growth <- lm(LogN ~ Time, data = data[data$Time > 2 & data$Time < 12,])
summary(lm_growth)

logistic_model <- function(t, r_max, K, N_0){ # The classic logistic equation
 return(N_0 * K * exp(r_max * t)/(K + N_0 * (exp(r_max * t) - 1)))
}

# first we need some starting parameters for the model
N_0_start <- min(data$N) # lowest population size
K_start <- max(data$N) # highest population size
r_max_start <- 0.62 # use our estimate from the OLS fitting from above

fit_logistic <- nlsLM(N ~ logistic_model(t = Time, r_max, K, N_0), data,
      list(r_max=r_max_start, N_0 = N_0_start, K = K_start))

summary(fit_logistic)

timepoints <- seq(0, 22, 0.1)

logistic_points <- logistic_model(t = timepoints,
         r_max = coef(fit_logistic)["r_max"],
         K = coef(fit_logistic)["K"],
         N_0 = coef(fit_logistic)["N_0"])
df1 <- data.frame(timepoints, logistic_points)
df1$model <- "Logistic equation"
names(df1) <- c("Time", "N", "model")

ggplot(data, aes(x = Time, y = N)) +
 geom_point(size = 3) +
 geom_line(data = df1, aes(x = Time, y = N, col = model), size = 1) +
 theme(aspect.ratio=1)+ # make the plot square
 labs(x = "Time", y = "Cell number")

ggplot(data, aes(x = Time, y = LogN)) +
 geom_point(size = 3) +
 geom_line(data = df1, aes(x = Time, y = log(N), col = model), size = 1) +
 theme(aspect.ratio=1)+
 labs(x = "Time", y = "log(Cell number)")

ggplot(data, aes(x = N, y = LogN)) +
 geom_point(size = 3) +
 theme(aspect.ratio = 1)+
 labs(x = "N", y = "log(N)")

gompertz_model <- function(t, r_max, K, N_0, t_lag){ # Modified gompertz growth model (Zwietering 1990)
 return(N_0 + (K - N_0) * exp(-exp(r_max * exp(1) * (t_lag - t)/((K - N_0) * log(10)) + 1)))
}

N_0_start <- min(data$LogN) # lowest population size, note log scale
K_start <- max(data$LogN) # highest population size, note log scale
r_max_start <- 0.62 # use our previous estimate from the OLS fitting from above
t_lag_start <- data$Time[which.max(diff(diff(data$LogN)))] # find last timepoint of lag phase

diff(data$LogN) # same as what we did above - get differentials

diff(diff(data$LogN)) # get the differentials of the differentials (approx 2nd order derivatives)

which.max(diff(diff(data$LogN))) # find the timepoint where this 2nd order derivative really takes off

data$Time[which.max(diff(diff(data$LogN)))] # This then is a good guess for the last timepoint of the lag phase

fit_gompertz <- nlsLM(LogN ~ gompertz_model(t = Time, r_max, K, N_0, t_lag), data,
      list(t_lag=t_lag_start, r_max=r_max_start, N_0 = N_0_start, K = K_start))

summary(fit_gompertz)

timepoints <- seq(0, 24, 0.1)

logistic_points <- log(logistic_model(t = timepoints,
          r_max = coef(fit_logistic)["r_max"],
          K = coef(fit_logistic)["K"],
          N_0 = coef(fit_logistic)["N_0"]))

gompertz_points <- gompertz_model(t = timepoints,
         r_max = coef(fit_gompertz)["r_max"],
         K = coef(fit_gompertz)["K"],
         N_0 = coef(fit_gompertz)["N_0"],
         t_lag = coef(fit_gompertz)["t_lag"])

df1 <- data.frame(timepoints, logistic_points)
df1$model <- "Logistic model"
names(df1) <- c("Time", "LogN", "model")

df2 <- data.frame(timepoints, gompertz_points)
df2$model <- "Gompertz model"
names(df2) <- c("Time", "LogN", "model")

model_frame <- rbind(df1, df2)

ggplot(data, aes(x = Time, y = LogN)) +
 geom_point(size = 3) +
 geom_line(data = model_frame, aes(x = Time, y = LogN, col = model), size = 1) +
 theme_bw() + # make the background white
 theme(aspect.ratio=1)+ # make the plot square
 labs(x = "Time", y = "log(Abundance)")


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

sirforcedode <- new("odeModel",
  main = function(time, init, parms, ...){
    with(as.list(c(init,parms)),{
      # ODEs
      N <- S+I+R
      dS <- mu*N-beta(beta0,beta1,omega,time)*S*I/N-mu*S
      dI <- beta(beta0,beta1,omega,time)*S*I/N-gamma*I-mu*I
      dR <- gamma*I-mu*R
      list(c(dS,dI,dR))
    })},
  equations = list(
    beta = function(beta0,beta1,omega,time){beta0*(1+beta1*sin(omega*time))}
  ),
  parms = c(beta0=10./7,beta1=0.05,omega=2*pi/365,gamma=1./7,mu=1./(70*365)),
  times = c(from=0,to=100*365,by=1),
  init = c(S=99999,I=1,R=0),
  solver = "lsoda"
)

# Simulate until equilibrium
sirforcedode <- sim(sirforcedode)
# Reset initial values
init(sirforcedode) <- unlist(out(sirforcedode)[100*365,2:4])
# Look at 10 years
times(sirforcedode) <- c(from=0,to=10*365,by=1)
# Simulate
sirforcedode <- sim(sirforcedode)

sirforced_out <- out(sirforcedode)
sirforced_out_long <- melt(sirforced_out,"time")

# Plot
ggplot(sirforced_out_long[sirforced_out_long$variable=="I",],aes(x=time,y=value,colour=variable,group=variable)) +
  geom_line(lwd=2) + xlab("Time")+ylab("Number") + theme(legend.position="none")


## 2. Fitting a Bivariate Linear Regression Model ##

library(readr)
williamsburg_north <- suppressMessages(read_csv("williamsburg_north.csv"))
condos_lm_fit <- lm(sale_price ~ gross_square_feet, data = williamsburg_north)
summary(condos_lm_fit)

## 3. Estimating the Slope ##

slope <- function(predictor, response){
  mean_predictor <- mean(predictor)
  mean_response <- mean(response)
  numerator <- sum((predictor - mean_predictor) * (response - mean_response))
  denominator <- sum((predictor - mean_predictor)^2)
  beta_1 <- numerator / denominator
  beta_1
}

condos_slope <- slope(predictor = williamsburg_north$gross_square_feet,
                      response = williamsburg_north$sale_price)

slope_equal <- dplyr::near(condos_slope, coef(condos_lm_fit)[[2]])

## 4. Estimating the Intercept ##

condos_slope <- slope(predictor = williamsburg_north$gross_square_feet,
                      response = williamsburg_north$sale_price)
intercept <- function(predictor, response, slope){
  beta_0 <- mean(response) - (slope * mean(predictor))
  beta_0
}

condos_intercept <- intercept(predictor = williamsburg_north$gross_square_feet,
                              response = williamsburg_north$sale_price,
                              slope = condos_slope)

intercept_equal <- dplyr::near(condos_intercept, coef(condos_lm_fit)[[1]])

## 5. Visualizing Model Fit ##

library(ggplot2)
ggplot(data = williamsburg_north,
       aes(x = gross_square_feet, y = sale_price)) +
  geom_point() +
  scale_y_continuous(labels = scales::comma) +
  geom_smooth(method = "lm", se = FALSE) +
  geom_abline(aes(intercept = coef(condos_lm_fit)[[1]],
                  slope = coef(condos_lm_fit)[[2]]),
              color = "black",
              linetype = "dashed",
              size = 1)

## 6. Estimating the Predictions ##

library(dplyr)
condos_lm_fit <- lm(sale_price ~ gross_square_feet, data = williamsburg_north)

williamsburg_north <- williamsburg_north %>%
  mutate(predictions = coef(condos_lm_fit)[[1]] +
           coef(condos_lm_fit)[[2]] * gross_square_feet)

near <- dplyr::near(williamsburg_north$predictions, fitted(condos_lm_fit))

## 7. Estimating the Residuals ##

williamsburg_north <- williamsburg_north %>%
  mutate(residuals = sale_price - predictions)

near <- dplyr::near(williamsburg_north$residuals, resid(condos_lm_fit))

## 8. Estimating the Residual Sum of Squares ##

williamsburg_north <- williamsburg_north %>%
  mutate(resid_squared = residuals^2)

RSS <- williamsburg_north %>%
  summarise(RSS = sum(resid_squared)) %>%
  pull()

RSS_from_lm <- deviance(condos_lm_fit)

Data Analyst in R/Step 6 - Predictive Modeling and Machine Learning in R/1. Linear Regression Modeling in R/3. Estimating the Coefficients and Fitting Linear Models.r


### クラスタ分析の例
### - Violent Crime Rates by US State

## データの読み込み ("datasets::USArrests"を用いる)
data(USArrests) # データの読み込み

## データの内容を確認
help(USArrests)     # 内容の詳細を表示
## print(USArrests)    # 全データの表示
head(USArrests,n=5) # 最初の5個を表示
## tail(USArrests,n=5) # 最後の5個を表示

## 距離の計算
d <- dist(USArrests) # 標準はユークリッド距離
class(d)             # オブジェクトクラスの確認
## print(d)             # 計算した距離行列の表示
## dist class から行列への変換
dmat <- as.matrix(d)
dmat[1:5,1:5] # 一部のみ表示
## 行列から dist class への変換 (下三角行列)
as.dist(dmat[1:5,1:5])

## マンハッタン距離の計算
dm <- dist(USArrests,method='manhattan')
as.matrix(dm)[1:5,1:5]

## 正規化(平均0,分散1)したユークリッド距離の計算
ds <- dist(scale(USArrests))
as.matrix(ds)[1:5,1:5]

## 最長距離法による階層的クラスタリング: 図(a)
hc <- hclust(ds) # クラスタリング
par(family="HiraMaruProN-W4") # 日本語フォントの指定
plot(hc,main="最長距離法によるデンドログラム") # デンドログラムの表示
## デンドログラムの表示変更: 図(b)
plot(hc,hang=-1,main="表示の変更")

## ウォード法による階層的クラスタリング: 図(c)
hc <- hclust(ds,method="ward.D2") # method の指定
plot(hc,hang=-1,main="ウォード法によるデンドログラム")
## デンドログラムに基づくグループ分け
rect.hclust(hc,k=10,border='red') # 10個のグループに分ける
(grp <- cutree(hc, k=10))         # 各データの属するグループ

## グループごとのデンドログラム: 図(d)
cl <- NULL # 空の配列を用意する
for(k in 1:10){
    cl <- rbind(cl, colMeans(scale(USArrests)[grp==k,,drop=F]))
}
cl         # 10グループのデータ(平均値)にまとめたもの
plot(hclust(dist(cl),method="ward.D2",
            members=table(grp))) # グループ内の個数を指定


#simulate some data
set.seed(1)
x<-seq(0,100,1)
y<-((runif(1,10,20)*x)/(runif(1,0,10)+x))+rnorm(51,0,1)

#***** Simple Linear Regression ********

l_model <- lm( y ~ x )
l_pred <- predict(l_model)

#get some estimation of goodness of fit
cor(y , l_pred)

#***** Non - Linear Regression ********
## Using nls function

nonlin_model <-nls(y~a*x/(b+x))

#get some estimation of goodness of fit
cor(y,predict(nonlin_model))
### Non-Linear is a better fit:

# Lets plot it:
plot(x,y)
lines(x,predict(nonlin_model),lty=2,col="red",lwd=3)
lines(x,predict(l_model) , lty=2, col="blue" , lwd=2)


#' Linear correlated data generator
#'
#' @description Simulates linear correlated data
#'
#' @param n number of observations
#' @param p_sim pearson linear correlation coefficient
#' @param tol tolerance between the simulated and estimated correlation
#'
#' @return data.frame with 2 numeric correlated series and both the simulated and estimated pearson linear coefficient
#' @export
#'
#' @examples
#'
#' df <- r_pearson(n = 100, p_sim = .8, mean = 3)
#'
#' head(df)
#'
#' plot(df)
#'

r_pearson <-
  function(
    n = 25,
    p_sim = 0.50,
    tol = 0.10,
    ...){

  if(!is.numeric(n)){
    stop("n must be numeric.")
  }

  if(!is.numeric(p_sim)){
    stop("p_sim must be numeric.")
  }

  if(!is.numeric(tol)){
    stop("tol must be numeric.")
  }

  if(n <= 0){
    stop("n must be > 0.")
  }

  if((n%%1)!= 0 ){
    stop("n must be a integer.")
  }

  if((tol <= 0) | (tol >= 1)){
    stop("tol must be (0,1).")
  }

  if((tol > 0) & (tol < .05)){
    warning("A low tolerance may cause a infinite loop or a long loading time.")
  }

  if((p_sim > 1) | (p_sim < -1)){
    stop("p_sim must be [-1;1].")
  }

  p_stop <- 1

  while (p_stop > tol) {

    x <- rnorm(n,...)

    y <- rnorm(length(x), p_sim*x, sqrt(1-p_sim^2))

    p_est <- cor(x,y)

    p_stop <- abs(p_sim - p_est)

  }

  out <-
    dplyr::tibble(
      x = x,
      y = y,
      p_sim = p_sim,
      p_est = p_est
      )

  return(out)

}


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

library(png)
library(jpeg)
library(grid)
library(NNLM)
library(tidyverse)

# Change WD respectivly:
# setwd("...")

### For training of the algorithms change to training dataset!
### Right now training and testing is done on the same picture since training dataset can not be provided in this repository.

### Hyperparameters are not fix and can be played around with. Examples of different results can be found in the "Graphics" folder.

####### Creating separated matrix for every RGB color channel #######

photo <- readJPEG("University.jpg")

r <- photo[,,1]
g <- photo[,,2]
b <- photo[,,3]

vComp = c(10,25,100,150)

####### Compression by PCA #######

start_time <- Sys.time()

  r.pca <- prcomp(r, center = F, scale = F)
  g.pca <- prcomp(g, center = F, scale = F)
  b.pca <- prcomp(b, center = F, scale = F)

  rgb.pca <- list(r.pca, g.pca, b.pca)

  for (i in vComp) {

    pca.img <- sapply(rgb.pca, function(j) {compressed.img <- j$x[,1:i] %*% t(j$rotation[,1:i])}, simplify = 'array')

    writeJPEG(pca.img,paste('PCA_photo_',i, '_components.jpg', sep = ''))
  }

end_time <- Sys.time()
end_time - start_time

####### Compression by Non-negative matrix factorization #######

start_time <- Sys.time()

  for (i in vComp) {
    for (j in c(1,5,25,100)){

      cat(paste("Computing Red for",i,"Atoms and",j,"as Lambda"),"\n")
      r.nnmf <- nnmf(r, k=i, beta=c(0,0,j), n.threads = 4) # Change amount of cores based on used processor
      cat(paste("Computing Green for",i,"Atoms and",j,"as Lambda"),"\n")
      g.nnmf <- nnmf(g, k=i, beta=c(0,0,j), n.threads = 4)
      cat(paste("Computing Blue for",i,"Atoms and",j,"as Lambda"),"\n")
      b.nnmf <- nnmf(b, k=i, beta=c(0,0,j), n.threads = 4)

      rgb.nnmf <- list(r.nnmf, g.nnmf, b.nnmf)

      nnmf.img <- sapply(rgb.nnmf, function(v) {compressed.img <- v$W %*% v$H}, simplify = 'array')

      writeJPEG(nnmf.img, paste('NNMF_photo_',i, '_atoms_',j,'_lambda.jpg', sep = ''))
    }
}

end_time <- Sys.time()
end_time - start_time

####### Compression by Non-negative matrix factorization with Overcomplete Dictionary #######

# Not in Report

photoSmall <- readJPEG("UniversitySmall.jpg")

r.small <- photoSmall[,,1]
g.small <- photoSmall[,,2]
b.small <- photoSmall[,,3]

start_time <- Sys.time()

  r.nnmf.small <- nnmf(r.small, k=2000, beta=c(0,0,10), n.threads = 4, max.iter = 1000)
  g.nnmf.small <- nnmf(g.small, k=2000, beta=c(0,0,10), n.threads = 4, max.iter = 1000)
  b.nnmf.small <- nnmf(b.small, k=2000, beta=c(0,0,10), n.threads = 4, max.iter = 1000)

  rgb.nnmf.small <- list(r.nnmf.small, g.nnmf.small, b.nnmf.small)

  nnmf.img.small <- sapply(rgb.nnmf.small, function(v) {compressed.img <- v$W %*% v$H}, simplify = 'array')

end_time <- Sys.time()
end_time - start_time

writeJPEG(nnmf.img.small, paste('NNMF_Overcomplete_',2000, '_atoms_',10,'_lambda.jpg', sep = ''))

####### Denoising by Non-negative matrix factorization #######

photo.bw <- readJPEG("LenaSmall.jpg")

bar<- photo.bw[,,1] + photo.bw[,,2] + photo.bw[,,3]

photo.bw <- bar/max(bar)

start_time <- Sys.time()

  bw.nnmf <- nnmf(photo.bw, k=100, beta=c(0,0,70), n.threads = 4, max.iter = 500)

  nnmf.img.bw <- bw.nnmf$W %*% bw.nnmf$H

end_time <- Sys.time()
end_time - start_time

par(mfrow = c(1,2))
image(t(photo.bw[nrow(photo.bw):1,]),useRaster=TRUE, axes=FALSE , col = grey(seq(0, 1, length = 256)))
image(t(nnmf.img.bw[nrow(nnmf.img.bw):1,]),useRaster=TRUE, axes=FALSE , col = grey(seq(0, 1, length = 256)))

writeJPEG(nnmf.img.bw, paste('NNMF_photo_BW_Denoising.jpg', sep = ''))

####### Denoising by PCA #######

k = 25

start_time <- Sys.time()

  bw.pca <- prcomp(photo.bw, center = F, scale = F)

  pca.img.bw <- bw.pca$x[,1:k] %*% t(bw.pca$rotation[,1:k])

end_time <- Sys.time()
end_time - start_time

par(mfrow = c(1,3))
image(t(photo.bw[nrow(photo.bw):1,]),useRaster=TRUE, axes=FALSE , col = grey(seq(0, 1, length = 256)))
image(t(pca.img.bw[nrow(nnmf.img.bw):1,]),useRaster=TRUE, axes=FALSE , col = grey(seq(0, 1, length = 256)))
image(t(nnmf.img.bw[nrow(nnmf.img.bw):1,]),useRaster=TRUE, axes=FALSE , col = grey(seq(0, 1, length = 256)))

writeJPEG(pca.img.bw, paste('pca_photo_BW_Denoising.jpg', sep = ''))

####### Denoising by Non-negative matrix factorization and Overcompletion #######

photo.bw.small <- readJPEG("LenaSmallEyes.jpg")

bar <- photo.bw.small[,,1] + photo.bw.small[,,2] + photo.bw.small[,,3]

photo.bw.small <- bar/max(bar)

start_time <- Sys.time()

  bw.nnmf.small <- nnmf(photo.bw.small, k=2000, beta=c(0,0,25), n.threads = 4, max.iter = 1000)

  nnmf.img.bw.small <- bw.nnmf.small$W %*% bw.nnmf.small$H

end_time <- Sys.time()
end_time - start_time

par(mfrow = c(1,2))
image(t(photo.bw.small[nrow(photo.bw.small):1,]),useRaster=TRUE, axes=FALSE , col = grey(seq(0, 1, length = 256)))
image(t(nnmf.img.bw.small[nrow(nnmf.img.bw.small):1,]),useRaster=TRUE, axes=FALSE , col = grey(seq(0, 1, length = 256)))

writeJPEG(nnmf.img.bw, paste('NNMF_Overcomplete_BW_Denoising.jpg', sep = ''))


###########
# Punto 1 #
###########

# En el punto 1 todos son falsos.

###########
# Punto 2 #
###########

library(rstudioapi)
filename = "taller4.r"
filepath = rstudioapi::getActiveDocumentContext()$path
dir = substr(filepath, 1, nchar(filepath)-nchar(filename))
setwd(dir)
database <- read.table(file = "EP.txt", header = TRUE)

baja <- database$emision[ database$altitud == 0 ]
alta <- database$emision[ database$altitud == 1 ]

n_baja <- length(baja)
xbar_baja <- mean(baja)
n_alta <- length(alta)
xbar_alta <- mean(alta)

summary(baja)
summary(alta)

# Calculos baja
# s2_baja <- sum((baja - xbar_baja)^2)/(n_baja-1)
# s_baja <- sqrt(s2_baja)
s_baja <- sd(baja)
s_alta <- sd(alta)

# Coeficiente de variación
cv_baja <- s_baja/xbar_baja
cv_alta <- s_alta/xbar_alta

###############
#   PUNTO 3   #
###############

lim_inf = c(0.064,5.405,8.780,12.417,16.384,21.619,28.526,40.342,65.536,131.072)
lim_sup = c(5.405,8.780,12.417,16.384,21.619,28.526,40.342,65.536,131.072,8388.608)

# marcas de clase
x = (lim_inf+lim_sup)/2

# frecuencias absolutas
nj <- c(305,294,331,286,306,273,334,326,290,323)
n <- sum(nj)

# frecuencias relativas
hj <- nj/n

# frecuencias absolutas acumulada
Nj <- cumsum(nj)
# frecuencua relativa acumulada
Hj <- cumsum(hj)

# media
xbar <- sum(x*nj)/n

# indice primer intervalo > 50% k =6
k <- 6
# mediana
mediana <- lim_inf[k] + (lim_sup[k] - lim_inf[k])*((0.5*n - Nj[k-1])/nj[k])

# indice intervalo con mayor frecuencia
k = 7
# moda
moda <- lim_inf[k] + (lim_sup[k] - lim_inf[k]) * ((nj[k]- nj[k-1])/(2*nj[k] - nj[k-1] - nj[k+1]))

# varianza
varianza = sum(nj*(x-xbar)^2)/(n-1)
abs(sqrt(varianza)/media)*100
# Desviación estandar
s = sqrt(varianza)
# Coeficiente de variacion
cv = s/xbar


###############
## Section 3 ##
###############

library(MASS)

setwd("C:\\dc_book\\Replication_Files_Element")

ITN.data <- read.csv("ITN_data.csv", header=TRUE)

###############
## Table 3.1 ##
###############

ITN.logit <- glm(useditn ~  malariamessage+education+richest+poorest+pregnant+altitude, family=binomial(link="logit"), data=ITN.data, x=TRUE)
beta <- ITN.logit$coefficients
covmat.beta <- vcov(ITN.logit)
ndraws <- 1000
betadraw <- mvrnorm(ndraws, beta, covmat.beta)

baseline.x <- apply(ITN.logit$x, 2, min)
baseline.x["altitude"] <- median(ITN.data$altitude)
baseline.x["education"] <- median(ITN.data$education)
baseline.x["poorest"] <- 1

hypo.case.A0 <- baseline.x
simprob.A0 <- plogis(betadraw%*%hypo.case.A0)

hypo.case.B0 <- baseline.x
hypo.case.B0["malariamessage"] <- 1
simprob.B0 <- plogis(betadraw%*%hypo.case.B0)

simprob.diff0 <- simprob.B0 - simprob.A0

## Varying Altitude, Rural = 1

hypo.case.A1 <- hypo.case.A0
hypo.case.A1["poorest"] <- 0
hypo.case.A1["richest"] <- 1
simprob.A1 <- plogis(betadraw%*%hypo.case.A1)

hypo.case.B1 <- hypo.case.B0
hypo.case.B1["poorest"] <- 0
hypo.case.B1["richest"] <- 1
simprob.B1 <- plogis(betadraw%*%hypo.case.B1)

simprob.diff1 <- simprob.B1 - simprob.A1

## Difference in Differences

simprob.dd <- simprob.diff1 - simprob.diff0

## summarize results

results.A0 <- append(quantile(simprob.A0, probs=c(0.5, 0.025, 0.975)), sd(simprob.A0))
results.B0 <- append(quantile(simprob.B0, probs=c(0.5, 0.025, 0.975)), sd(simprob.B0))
results.diff0 <- append(quantile(simprob.diff0, probs=c(0.5, 0.025, 0.975)), sd(simprob.diff0))

results.A1 <- append(quantile(simprob.A1, probs=c(0.5, 0.025, 0.975)), sd(simprob.A1))
results.B1 <- append(quantile(simprob.B1, probs=c(0.5, 0.025, 0.975)), sd(simprob.B1))
results.diff1 <- append(quantile(simprob.diff1, probs=c(0.5, 0.025, 0.975)), sd(simprob.diff1))

results.dd <- append(quantile(simprob.dd, probs=c(0.5, 0.025, 0.975)), sd(simprob.dd))

first.differences <- rbind(results.A0, results.B0, results.diff0, results.A1, results.B1, results.diff1, results.dd)
colnames(first.differences) <- c("Median", "2.5%", "97.5%", "(se)")
rownames(first.differences) <- c("No Message:Poor", "Message:Poor", "Difference:Poor", "No Message:Rich", "Message:Rich", "Difference:Rich", "Difference:(Rich-Poor)")
print(round(first.differences, digits=3))

################
## Figure 3.1 ##
################

beta <- ITN.logit$coefficients
covmat.beta <- vcov(ITN.logit)
ndraws <- 1000
betadraw <- mvrnorm(ndraws, beta, covmat.beta)

altitude <- seq(0,2.5,0.01)

mean.x <- colMeans(ITN.logit$x)
simcoef.mean <- matrix(NA, length(altitude), 4)
simprob.all <- matrix(NA, ndraws, length(altitude))

for (i in 1:length(altitude)) {
	mean.x["altitude"] <- altitude[i]
	simprob <- plogis(betadraw%*%mean.x)
	simcoef.mean[i,] <- append(altitude[i], quantile(simprob, probs=c(0.025, 0.5, 0.975)))
	simprob.all[,i] <- simprob
}

ci.bottom <- cbind(simcoef.mean[,1], simcoef.mean[,2])
ci.top <- cbind(simcoef.mean[,1], simcoef.mean[,4])
ci.top <- ci.top[order(ci.top[,1], decreasing=TRUE),]
ci <- rbind(ci.bottom, ci.top)

pdf("fig31a.pdf")
par(mar=c(5.1, 4.1, 4.1, 3.1), mgp=c(2.5, 1, 0), cex.lab=1.5)
plot(simcoef.mean[,3]~simcoef.mean[,1], xlim=c(0.5,2.1), ylim=c(0.5,1), type="n", xlab="Altitude (1000s of meters)", ylab="Probability", xaxt="n", las=1)
axis(1, at=c(0.5, 1, 1.5, 2))
polygon(ci[,1], ci[,2], col="grey75", border=NA)
lines(simcoef.mean[,3]~simcoef.mean[,1], lwd=2, lty=1)
box(lty=1)
dev.off()

pdf("fig31b.pdf")
par(mar=c(5.1, 4.1, 4.1, 3.1), mgp=c(2.5, 1, 0), cex.lab=1.5)
plot(simcoef.mean[,3]~simcoef.mean[,1], xlim=c(0.5,2.1), ylim=c(0.5,1), type="n", xlab="Altitude (1000s of meters)", ylab="Probability", xaxt="n", las=1)
axis(1, at=c(0.5, 1, 1.5, 2))
for (i in 1:length(altitude)){
	points(simprob.all[i,] ~ altitude, type="l", col=rgb(0,0,0,alpha=0.2), lwd=1)
}
dev.off()

###############
## Table 3.2 ##
###############

## aggregate shares

one <- 1
Xall <- as.data.frame(na.omit(cbind(one, subset(ITN.data, select=c(malariamessage, education, richest, poorest, pregnant, altitude, sample_weight, useditn)))))
X <- subset(Xall, select=c(one, malariamessage, education, richest, poorest, pregnant, altitude))
y <- Xall$useditn
w <- 1/Xall$sample_weight

X2 <- X
X2$malariamessage <- 1

beta <- ITN.logit$coefficients
covmat.beta <- vcov(ITN.logit)

ndraws <- 1000
betadraw <- mvrnorm(ndraws, beta, covmat.beta)

aggdraw <- matrix(NA,ndraws,1)
aggdraw2 <- matrix(NA,ndraws,1)

for (j in 1:ndraws) {
  proby1 <- plogis(betadraw[j,]%*%t(X))
  aggshare <- sum(proby1*w)/sum(w)
  aggdraw[j] <- aggshare*100
  proby1.2 <- plogis(betadraw[j,]%*%t(X2))
  aggshare2 <- sum(proby1.2*w)/sum(w)
  aggdraw2[j] <- aggshare2*100
  }

aggdraw.diff <- aggdraw2 - aggdraw

summary.aggshare <- append(quantile(aggdraw, probs=c(0.5, 0.025, 0.975)), sd(aggdraw))
summary.aggshare2 <- append(quantile(aggdraw2, probs=c(0.5, 0.025, 0.975)), sd(aggdraw2))
summary.aggshare.diff <- append(quantile(aggdraw.diff, probs=c(0.5, 0.025, 0.975)), sd(aggdraw.diff))

aggregate.prediction <- rbind(summary.aggshare, summary.aggshare2, summary.aggshare.diff)
colnames(aggregate.prediction) <- c("Median", "2.5%", "97.5%", "(se)")
rownames(aggregate.prediction) <- c("Current Message", "Complete Message", "Difference")
print(round(aggregate.prediction, digits=3))

###############
## Table 3.3 ##
###############

beta <- ITN.logit$coefficients
covmat.beta <- vcov(ITN.logit)
ndraws <- 1000
betadraw <- mvrnorm(ndraws, beta, covmat.beta)

w <- ITN.data$sample_weight

# AME

predprobs <- plogis(betadraw %*% t(ITN.logit$x))

marginal.ame.matrix <- predprobs * (1 - predprobs) * betadraw[,"altitude"]

marginal.ame <- apply(marginal.ame.matrix, 1, function(x) {sum(x * w)/sum(w)})

elasticity.ame.matrix <- marginal.ame.matrix * t(ITN.logit$x[,"altitude"] / t(predprobs))

elasticity.ame <- apply(elasticity.ame.matrix, 1, function(x) {sum(x * w)/sum(w)})

# MEM

mean.x <- colMeans(ITN.logit$x)
beta <- ITN.logit$coefficients
covmat.beta <- vcov(ITN.logit)

ndraws <- 1000

betadraw <- mvrnorm(ndraws, beta, covmat.beta)

predprob <- plogis(betadraw%*%mean.x)

marginal.mem <- predprob * (1 - predprob) * betadraw[,"altitude"]

elasticity.mem <- marginal.mem * (mean.x["altitude"] / predprob)

## combine results

summary.marginal.ame <- append(quantile(marginal.ame, probs=c(0.5, 0.025, 0.975)), sd(marginal.ame))
summary.marginal.mem <- append(quantile(marginal.mem, probs=c(0.5, 0.025, 0.975)), sd(marginal.mem))
summary.elasticity.ame <- append(quantile(elasticity.ame, probs=c(0.5, 0.025, 0.975)), sd(elasticity.ame))
summary.elasticity.mem <- append(quantile(elasticity.mem, probs=c(0.5, 0.025, 0.975)), sd(elasticity.mem))

marginal.effects.elasticities <- rbind(summary.marginal.ame, summary.marginal.mem, summary.elasticity.ame, summary.elasticity.mem)
colnames(marginal.effects.elasticities) <- c("Median", "2.5%", "97.5%", "(se)")
rownames(marginal.effects.elasticities) <- c("Marginal Effect (AME)", "Marginal Effect (MEM)", "Elasticity (AME)", "Elasticity (MEM)")
print(round(marginal.effects.elasticities, digits=3))

## additional example: MEM by brute force --- note this is actually a first difference

mean.x2 <- mean.x
mean.x2["altitude"] <- mean.x2["altitude"] + 0.0001
probs1 <- plogis(betadraw %*% mean.x)
probs2 <- plogis(betadraw %*% mean.x2)
probs.diff <- (probs2 - probs1) * 10000   # for a 1-unit change
quantile(probs.diff, probs=c(0.5, 0.025, 0.975))

## Elasticity at the mean by brute force
elast.mem <- probs.diff * (mean.x2["altitude"] / probs1)
quantile(elast.mem, probs=c(0.5, 0.025, 0.975))

## coefficient ratios

malariamessage.altitude.ratio <- betadraw[,"malariamessage"]/betadraw[,"altitude"]
ratio.results <- quantile(malariamessage.altitude.ratio, probs=c(0.5, 0.025, 0.975))
print(ratio.results)

###############
## Table 3.4 ##
###############

N <- length(ITN.logit$fitted.values)

beta <- ITN.logit$coefficients
covmat.beta <- vcov(ITN.logit)
ndraws <- 1000

# calculating confidence intervals and standard error via simulation

betadraw <- mvrnorm(ndraws, beta, covmat.beta)
exp.betadraw <- exp(betadraw)
quantiles <- apply(exp.betadraw, 2, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sds <- apply(exp.betadraw, 2, sd)
odds.ratios <- cbind(t(quantiles), sds)
colnames(odds.ratios) <- c("Median", "2.5%", "97.5%", "(se)")
rownames(odds.ratios) <- names(beta)
print(round(odds.ratios, digits=3))
print(N)

# alternative calculation exponentiating endpoints of coefficient CI and using delta method for standard errors

beta.OR <- exp(ITN.logit$coefficients)
se.OR <- exp(ITN.logit$coefficients) * sqrt(diag(vcov(ITN.logit)))
CI.OR <- exp(confint.default(ITN.logit, level=0.95))

ITN.logit.results.OR <- cbind(beta.OR, CI.OR, se.OR)
N <- length(ITN.logit$fitted.values)
colnames(ITN.logit.results.OR) <- c("Coeff", "2.5%", "97.5%", "(se)")
print((round(ITN.logit.results.OR, digits=3)))


#' Tong et al. (2012)'s Lindley-type Shrunken Mean Estimator
#'
#' An implementation of the Lindley-type shrunken mean estimator utilized in
#' shrinkage-mean-based diagonal linear discriminant analysis (SmDLDA).
#'
#' @export
#' @importFrom stats var
#' @references Tong, T., Chen, L., and Zhao, H. (2012), "Improved Mean
#' Estimation and Its Application to Diagonal Discriminant Analysis,"
#' Bioinformatics, 28, 4, 531-537.
#' \url{http://bioinformatics.oxfordjournals.org/content/28/4/531.long}
#' @param x a matrix with `n` rows and `p` columns.
#' @param r_opt the shrinkage coefficient. If `NULL` (default), we calculate
#' the shrinkage coefficient with the formula given just above Equation 5 on page
#' 533 and denoted by \eqn{\hat{r}_{opt}}. We allow the user to specify an
#' alternative value to investigate better approximations.
#' @return vector of length `p` with the shrunken mean estimator
tong_mean_shrinkage <- function(x, r_opt = NULL) {
  n <- nrow(x)
  p <- ncol(x)

  # Here, we calculate the approximate "optimal" shrinkage coefficient, r.
  # The formula is given just above Equation 5 and is denoted \hat{r}_{opt}.
  if (is.null(r_opt)) {
    r_opt <- (n - 1) * (p - 2) / n / (n - 3)
  } else {
    r_opt <- as.numeric(r_opt)
  }

  # The sample means of each feature vector.
  xbar <- colMeans(x)

  # Tong et al. calculate the mean of the entire matrix, x.
  grand_mean <- mean(x)

  # The authors then center the sample mean for each feature vector.
  centered_xbars <- xbar - grand_mean

  # The MLE of the covariance matrix under the assumpton of a multivariate
  # normal population with a diagonal covariance matrix.
  diag_S <- (n - 1) / n * apply(x, 2, var)

  # The term in Equation (6) denoted by:
  # || \bar{x} - \bar{x}_{\dot\dot} ||^2_S
  shrinkage_norm <- sum(centered_xbars^2 / diag_S)

  # Finally, we calculate the shrunken mean given in Equation 6.
  if (shrinkage_norm == 0) {
    shrunken_mean <- xbar
  } else {
    shrunken_mean <- grand_mean + (1 - r_opt / shrinkage_norm) * centered_xbars
  }

  shrunken_mean
}


#' Generates data from `K` multivariate normal data populations, where each
#' population (class) has an intraclass covariance matrix.
#'
#' This function generates `K` multivariate normal data sets, where each
#' class is generated with a constant mean vector and an intraclass covariance
#' matrix. The data are returned as a single matrix `x` along with a vector
#' of class labels `y` that indicates class membership.
#'
#' For simplicity, we assume that a class mean vector is constant for each
#' feature. That is, we assume that the mean vector of the \eqn{k}th class is
#' \eqn{c_k * j_p}, where \eqn{j_p} is a \eqn{p \times 1} vector of ones and
#' \eqn{c_k} is a real scalar.
#'
#' The intraclass covariance matrix for the \eqn{k}th class is defined as:
#' \deqn{\sigma_k^2 * (\rho_k * J_p + (1 - \rho_k) * I_p),}
#' where \eqn{J_p} is the \eqn{p \times p} matrix of ones and \eqn{I_p} is the
#' \eqn{p \times p} identity matrix.
#'
#' By default, with \eqn{\sigma_k^2 = 1}, the diagonal elements of the intraclass
#' covariance matrix are all 1, while the off-diagonal elements of the matrix
#' are all `rho`.
#'
#' The values of `rho` must be between \eqn{1 / (1 - p)} and 1,
#' exclusively, to ensure that the covariance matrix is positive definite.
#'
#' The number of classes `K` is determined with lazy evaluation as the
#' length of `n`.
#'
#' @importFrom mvtnorm rmvnorm
#' @export
#' @param n vector of the sample sizes of each class. The length of `n`
#' determines the number of classes `K`.
#' @param p the number of features (variables) in the data
#' @param rho vector of the values of the off-diagonal elements for each
#' intraclass covariance matrix. Must equal the length of `n`.
#' @param mu vector containing the mean for each class. Must equal the length of
#' `n` (i.e., equal to `K`).
#' @param sigma2 vector of variances for each class. Must equal the length of
#' `n`. Default is 1 for each class.
#' @return named list with elements:
#' \itemize{
#'   \item `x`: matrix of observations with `n` rows and `p`
#' columns
#'   \item `y`: vector of class labels that indicates class membership for
#' each observation (row) in `x`.
#' }
#' @examples
#' # Generates data from K = 3 classes.
#' data <- generate_intraclass(n = 3:5, p = 5, rho = seq(.1, .9, length = 3),
#'                             mu = c(0, 3, -2))
#' data$x
#' data$y
#'
#' # Generates data from K = 4 classes. Notice that we use specify a variance.
#' data <- generate_intraclass(n = 3:6, p = 4, rho = seq(0, .9, length = 4),
#'                             mu = c(0, 3, -2, 6), sigma2 = 1:4)
#' data$x
#' data$y
generate_intraclass <- function(n, p, rho, mu, sigma2 = rep(1, K)) {
  p <- as.integer(p)
  rho <- as.numeric(rho)
  n <- as.integer(n)
  mu <- as.numeric(mu)

  K <- length(n)

  if (length(rho) != K) {
    rlang::abort("The length of 'rho' must equal the length of 'n'.")
  } else if(length(mu) != K) {
    rlang::abort("The length of 'mu' must equal the length of 'n'.")
  } else if(length(sigma2) != K) {
    rlang::abort("The length of 'sigma2' must equal the length of 'n'.")
  }

  x <- lapply(seq_len(K), function(k) {
    rmvnorm(n = n[k], mean = rep(mu[k], p),
            sigma = cov_intraclass(p = p, rho = rho[k], sigma2 = sigma2[k]))
  })
  x <- do.call(rbind, x)
  y <- factor(rep(seq_along(n), n))

  list(x = x, y = y)
}

#' Generates a \eqn{p \times p} intraclass covariance matrix
#'
#' This function generates a \eqn{p \times p} intraclass covariance matrix with
#' correlation `rho`. The variance `sigma2` is constant for each
#' feature and defaulted to 1.
#'
#' The intraclass covariance matrix is defined as:
#' \deqn{\sigma^2 * (\rho * J_p + (1 - \rho) * I_p),}
#' where \eqn{J_p} is the \eqn{p \times p} matrix of ones and \eqn{I_p} is the
#' \eqn{p \times p} identity matrix.
#'
#' By default, with `sigma2 = 1`, the diagonal elements of the intraclass
#' covariance matrix are all 1, while the off-diagonal elements of the matrix
#' are all `rho`.
#'
#' The value of `rho` must be between \eqn{1 / (1 - p)} and 1,
#' exclusively, to ensure that the covariance matrix is positive definite.
#'
#' @param p the size of the covariance matrix
#' @param rho the value of the off-diagonal elements
#' @param sigma2 the variance of each feature
#' @return intraclass covariance matrix
cov_intraclass <- function(p, rho, sigma2 = 1) {
  p <- as.integer(p)
  rho <- as.numeric(rho)

  if (rho <= (1 - p)^(-1) || rho >= 1) {
    rlang::abort("The value of 'rho' must be between (1 - p)^(-1) and 1, exclusively.")
  }
  if (sigma2 <= 0) {
    rlang::abort("The value of 'sigma2' must be positive.")
  }
  sigma2 * (rho * matrix(1, nrow = p,  ncol = p) + (1 - rho) * diag(p))
}