##### Chapter 7: Neural Networks and Support Vector Machines -------------------

##### Part 1: Neural Networks -------------------
## Example: Modeling the Strength of Concrete  ----

## Step 2: Exploring and preparing the data ----
# read in data and examine structure
concrete <- read.csv("concrete.csv")
str(concrete)

# custom normalization function
normalize <- function(x) {
  return((x - min(x)) / (max(x) - min(x)))
}

# apply normalization to entire data frame
concrete_norm <- as.data.frame(lapply(concrete, normalize))

# confirm that the range is now between zero and one
summary(concrete_norm$strength)

# compared to the original minimum and maximum
summary(concrete$strength)

# create training and test data
concrete_train <- concrete_norm[1:773, ]
concrete_test <- concrete_norm[774:1030, ]

## Step 3: Training a model on the data ----
# train the neuralnet model
library(neuralnet)

# simple ANN with only a single hidden neuron
set.seed(12345) # to guarantee repeatable results
concrete_model <- neuralnet(formula = strength ~ cement + slag +
                              ash + water + superplastic +
                              coarseagg + fineagg + age,
                              data = concrete_train)

# visualize the network topology
plot(concrete_model)

## Step 4: Evaluating model performance ----
# obtain model results
model_results <- compute(concrete_model, concrete_test[1:8])
# obtain predicted strength values
predicted_strength <- model_results$net.result
# examine the correlation between predicted and actual values
cor(predicted_strength, concrete_test$strength)

## Step 5: Improving model performance ----
# a more complex neural network topology with 5 hidden neurons
set.seed(12345) # to guarantee repeatable results
concrete_model2 <- neuralnet(strength ~ cement + slag +
                               ash + water + superplastic +
                               coarseagg + fineagg + age,
                               data = concrete_train, hidden = 5)

# plot the network
plot(concrete_model2)

# evaluate the results as we did before
model_results2 <- compute(concrete_model2, concrete_test[1:8])
predicted_strength2 <- model_results2$net.result
cor(predicted_strength2, concrete_test$strength)

##### Part 2: Support Vector Machines -------------------
## Example: Optical Character Recognition ----

## Step 2: Exploring and preparing the data ----
# read in data and examine structure
letters <- read.csv("letterdata.csv")
str(letters)

# divide into training and test data
letters_train <- letters[1:16000, ]
letters_test  <- letters[16001:20000, ]

## Step 3: Training a model on the data ----
# begin by training a simple linear SVM
library(kernlab)
letter_classifier <- ksvm(letter ~ ., data = letters_train,
                          kernel = "vanilladot")

# look at basic information about the model
letter_classifier

## Step 4: Evaluating model performance ----
# predictions on testing dataset
letter_predictions <- predict(letter_classifier, letters_test)

head(letter_predictions)

table(letter_predictions, letters_test$letter)

# look only at agreement vs. non-agreement
# construct a vector of TRUE/FALSE indicating correct/incorrect predictions
agreement <- letter_predictions == letters_test$letter
table(agreement)
prop.table(table(agreement))

## Step 5: Improving model performance ----
set.seed(12345)
letter_classifier_rbf <- ksvm(letter ~ ., data = letters_train, kernel = "rbfdot")
letter_predictions_rbf <- predict(letter_classifier_rbf, letters_test)

agreement_rbf <- letter_predictions_rbf == letters_test$letter
table(agreement_rbf)
prop.table(table(agreement_rbf))


#1. Load neccessary dataset and libraaries

#loads the library using library()
library(ggplot2)
data(ToothGrowth) #data() loads the dataset of toothgrowth which is already available in R

#2. basic summay and structurrre of dataset

head(ToothGrowth) # head() displays head of dataset
str(ToothGrowth) #str(): tells overall structure of dataset
summary(ToothGrowth) #summary(): gives the summay of the complete dataset
dim(ToothGrowth) #dim(): tells the dimension of dataset_ number of rows and columns

#3. Basic exploratory Analysis
g<- ggplot(data=ToothGrowth, aes(x=paste(supp,dose), y=len, fill=factor(dose)))
g<- g+geom_boxplot()
g<- g+labs(title="Tooth growth of 60 guinea pigs by dosage and delivery method of vitamin C",x="Dose in milligrams/day",y="Tooth Length")
g<-g+ scale_fill_discrete(name="doasage_type")
g<- g+theme(plot.title=element_text(hjust=0.5))
print(g)

#4. Data manipulation to separate data by dosage
data_0.5<- subset(ToothGrowth, dose==0.5)
data_1<- subset(ToothGrowth, dose==1)
data_2<- subset(ToothGrowth, dose==2)

#5.Performing T test to Accept or Reject Hypothesis
t1<- t.test(len~supp, data=data_0.5)
t2<-t.test(len~supp, data=data_1)
t3<-t.test(len~supp, data=data_2)

#6. Creating DataFrame to analyze the result
Conclusion<-data.frame("p-value"=c(t1$p.value,t2$p.value,t3$p.value),
                       "Low-Confidence"=c(t1$conf.int[1],t2$conf.int[1],t3$conf.int[1]),
                       "High-Confidence"=c(t1$conf.int[2],t2$conf.int[2],t3$conf.int[2]),
                       "OJ mean" = c(t1$estimate[1],t2$estimate[1],t3$estimate[1]),
                       "VC mean" = c(t1$estimate[2],t2$estimate[2],t3$estimate[2]),
                       row.names = c("Dosage_.5","Dosage_1","Dosage_2"))

Conclusion


rm(swiss)

swiss <- data.frame(swiss)

fit_full <- lm(Fertility ~ . , data = swiss)
summary(fit_full)

fit_reduced1 <- lm(Fertility ~ Infant.Mortality + Examination + Catholic + Education, data = swiss)
summary(fit_reduced1)

anova(fit_full, fit_reduced1)

fit_reduced2 <- lm(Fertility ~ Infant.Mortality + Agriculture + Catholic + Education, data = swiss)
summary(fit_reduced1)

anova(fit_full, fit_reduced2)

library(psych)
optimal_fit <- step(fit_full, direction = 'backward')
summary(optimal_fit)
optimal_fit$coefficients

# trouble №1,2

model_full <- lm(rating ~ ., data = attitude)

model_null <- lm(rating ~ 1, data = attitude)

step(model_full,direction = 'backward')

model_opt <- lm(formula = rating ~ complaints + learning, data = attitude)

anova(model_full,model_opt)

# trouble №3
lm(sr~(.)^2,data=LifeCycleSavings)


# Chapter 3 Lab: Linear Regression

library(MASS)
library(ISLR)

# Simple Linear Regression

fix(Boston)
names(Boston)
lm.fit=lm(medv~lstat)
lm.fit=lm(medv~lstat,data=Boston)
attach(Boston)
lm.fit=lm(medv~lstat)
lm.fit
summary(lm.fit)
names(lm.fit)
coef(lm.fit)
confint(lm.fit)
predict(lm.fit,data.frame(lstat=(c(5,10,15))), interval="confidence")
predict(lm.fit,data.frame(lstat=(c(5,10,15))), interval="prediction")
plot(lstat,medv)
abline(lm.fit)
abline(lm.fit,lwd=3)
abline(lm.fit,lwd=3,col="red")
plot(lstat,medv,col="red")
plot(lstat,medv,pch=20)
plot(lstat,medv,pch="+")
plot(1:20,1:20,pch=1:20)
par(mfrow=c(2,2))
plot(lm.fit)
plot(predict(lm.fit), residuals(lm.fit))
plot(predict(lm.fit), rstudent(lm.fit))
plot(hatvalues(lm.fit))
which.max(hatvalues(lm.fit))

# Multiple Linear Regression

lm.fit=lm(medv~lstat+age,data=Boston)
summary(lm.fit)
lm.fit=lm(medv~.,data=Boston)
summary(lm.fit)
library(car)
vif(lm.fit)
lm.fit1=lm(medv~.-age,data=Boston)
summary(lm.fit1)
lm.fit1=update(lm.fit, ~.-age)

# Interaction Terms

summary(lm(medv~lstat*age,data=Boston))

# Non-linear Transformations of the Predictors

lm.fit2=lm(medv~lstat+I(lstat^2))
summary(lm.fit2)
lm.fit=lm(medv~lstat)
anova(lm.fit,lm.fit2)
par(mfrow=c(2,2))
plot(lm.fit2)
lm.fit5=lm(medv~poly(lstat,5))
summary(lm.fit5)
summary(lm(medv~log(rm),data=Boston))

# Qualitative Predictors

fix(Carseats)
names(Carseats)
lm.fit=lm(Sales~.+Income:Advertising+Price:Age,data=Carseats)
summary(lm.fit)
attach(Carseats)
contrasts(ShelveLoc)

# Writing Functions

LoadLibraries
LoadLibraries()
LoadLibraries=function(){
 library(ISLR)
 library(MASS)
 print("The libraries have been loaded.")
 }
LoadLibraries
LoadLibraries()


library(igraph)
g1 <- graph( edges=c(1,2, 2,3, 3, 1), n=3, directed=F )
plot(g1)

g2 <- graph( edges=c(1,2, 2,3, 3, 1), n=10 )

plot(g2)

g3 <- graph( c("John", "Jim", "Jim", "Jill", "Jill", "John")) # named vertices

# When the edge list has vertex names, the number of nodes is not needed

plot(g3)

g4 <- graph( c("John", "Jim", "Jim", "Jack", "Jim", "Jack", "John", "John"),

             isolates=c("Jesse", "Janis", "Jennifer", "Justin") )

# In named graphs we can specify isolates by providing a list of their names.

plot(g4, edge.arrow.size=.5, vertex.color="gold", vertex.size=15,

     vertex.frame.color="gray", vertex.label.color="black",

     vertex.label.cex=0.8, vertex.label.dist=2, edge.curved=0.5)

plot(graph_from_literal(a---b, b---c)) # the number of dashes doesn't matter

plot(graph_from_literal(a--+b, b+--c))

plot(graph_from_literal(a+-+b, b+-+c))

plot(graph_from_literal(a:b:c---c:d:e))

gl <- graph_from_literal(a-b-c-d-e-f, a-g-h-b, h-e:f:i, j)

plot(gl)

E(g4)

V(g4)

g4[]

g4[1,]

V(g4)$name

V(g4)$gender <- c("male", "male", "male", "male", "female", "female", "male")

E(g4)$type <- "email"

E(g4)$weight <- 10    # Edge weight, setting all existing edges to 10
E(g4)

E(g4)

g4 <- set_graph_attr(g4, "name", "Email Network")

g4 <- set_graph_attr(g4, "something", "A thing")

graph_attr_names(g4)

graph_attr(g4, "name")

graph_attr(g4)

g4 <- delete_graph_attr(g4, "something")

graph_attr(g4)

plot(g4, edge.arrow.size=.5, vertex.label.color="black", vertex.label.dist=1.5,

     vertex.color=c( "pink", "skyblue")[1+(V(g4)$gender=="male")] )

g4s <- simplify( g4, remove.multiple = T, remove.loops = F,

                 edge.attr.comb=c(weight="sum", type="ignore") )

plot(g4s, vertex.label.dist=1.5)

eg <- make_empty_graph(40)

plot(eg, vertex.size=10, vertex.label=NA)

fg <- make_full_graph(40)

plot(fg, vertex.size=10, vertex.label=NA)

st <- make_star(40)

plot(st, vertex.size=10, vertex.label=NA)

tr <- make_tree(40, children = 3, mode = "undirected")

plot(tr, vertex.size=10, vertex.label=NA)

rn <- make_ring(40)

plot(rn, vertex.size=10, vertex.label=NA)

er <- sample_gnm(n=100, m=40)

plot(er, vertex.size=6, vertex.label=NA)

sw <- sample_smallworld(dim=2, size=10, nei=1, p=0.1)

plot(sw, vertex.size=6, vertex.label=NA, layout=layout_in_circle)

ba <-  sample_pa(n=100, power=1, m=1,  directed=F)

plot(ba, vertex.size=6, vertex.label=NA)

## Example

transport <- graph( edges=c(1,2,
                            1,3,
                            1,4,
                            2,5,
                            2,6,
                            3,6,
                            4,6,
                            4,7,
                            4,9,
                            5,8,
                            5,9,
                            5,6,
                            6,9,
                            7,9,
                            7,10,
                            8,11,
                            9,11,
                            9,12,
                            10,11,
                            10,12,
                            11,12))
plot(transport)

topo_sort(transport)

L3 <- LETTERS[1:8]
d <- data.frame(start = sample(L3, 16, replace = T), end = sample(L3, 16, replace = T),
                weight = c(20,40,20,30,50,60,20,30,20,40,20,30,50,60,20,30))

g <- graph.data.frame(d, directed = T)

V(g)$name
E(g)$weight

ideg <- degree(g, mode = "in", loops = F)
ideg
col=rainbow(12) # For edge colors

plot.igraph(g,
            vertex.label = V(g)$name, vertex.label.color = "gray20",
            vertex.size = ideg*25 + 40, vertex.size2 = 30,
            vertex.color = "gray90", vertex.frame.color = "gray20",
            vertex.shape = "rectangle",
            edge.arrow.size=0.5, edge.color=col, edge.width = E(g)$weight / 10,
            edge.curved = T,
            layout = layout.reingold.tilford)

l <-layout.reingold.tilford(g)
l
plot.igraph(g,
             vertex.label = V(g)$name, vertex.label.color = "gray20",
             vertex.size = ideg*25 + 40, vertex.size2 = 30,
             vertex.color = "gray90", vertex.frame.color = "gray20",
             vertex.shape = "rectangle",
             edge.arrow.size=0.5, edge.color=col, edge.width = E(g)$weight / 10,
             edge.curved = T,
             layout = l)

igraph_options(plot.layout=layout_as_tree)

plot(make_tree(20, 2))
plot(make_tree(50, 3), vertex.size=3, vertex.label=NA)
tkplot(make_tree(50, 2, mode="undirected"), vertex.size=10,
       vertex.color="green")
plot(transport)

G <- graph( c(1,2,1,3,1,4,3,4,3,5,5,6,6,7,7,8,8,9,3,8,5,8), directed = FALSE )
# visualization
plot(G, layout = layout.fruchterman.reingold,
     vertex.size = 25,
     vertex.color="red",
     vertex.frame.color= "white",
     vertex.label.color = "white",
     vertex.label.family = "sans",
     edge.width=2,
     edge.color="black")

data <- matrix(sample(0:1, 100, replace=TRUE, prob=c(0.8,0.2)), nc=10)
data
network <- graph_from_adjacency_matrix(data , mode='undirected', diag=F )
plot(network)


# Hypothesis Testing or  one-tailed test

ybar = 573            # sample mean
 mu0 = 520              # hypothesized value
 sigma = 124           # population standard deviation
 n = 36                 # sample size
 z = (ybar- mu0)/(sigma/sqrt(n))
 print(z) # test statistic

 # We then compute the critical value at .025 significance level.
 #  For alpha= .025, reject the null hypothesis if lies more than 1.96
  alpha = .025
 z.alpha = qnorm(1-alpha)
  print(z.alpha)


library(MASS)

white <- 10
red <- 4
green <- 7

total <- green + red + white
pr_total <- choose(total, 3)

# Richiesta 1: tre rosse

trerosse <- fractions(choose(red, 3)/pr_total)
print(trerosse)

# Richiesta 2: tre bianche

trebianche <- fractions(choose(white, 3)/pr_total)
print(trebianche)

# Richiesta 3: 2 rosse e 1 bianca

duerosseunabianca <- fractions((choose(red, 2)*choose(white, 1))/pr_total)
print(duerosseunabianca)

# Richiesta 4: almeno una sia bianca

almenounabianca <- fractions(1 - choose(red+green, 3)/pr_total)
print(almenounabianca)

# Richiesta 5: tutte di colori diversi

trecolori <- fractions((red*green*white)/pr_total)
print(trecolori)

# Richiesta 6: ordine rosso, bianco, verde

final <- fractions(red/total * white/(total-1) * green/(total-2))
print(final)


 library(cluster)

 food.energycontent <- read.table("d:/foodstuffs.txt", header=T)
 head(food.energycontent)
  Food Energy Protein Fat Calcium Iron
1   BB    340      20  28       9  2.6
2   HR    245      21  17       9  2.7
3   BR    420      15  39       7  2.0
4   BS    375      19  32       9  2.5
5   BC    180      22  10      17  3.7
6   CB    115      20   3       8  1.4

 str(food.energycontent)

 standard.deviation <- apply(food.energycontent[,-1], 2, sd)
 standard.deviation

 foodergycnt.stddev <- sweep(food.energycontent[,-1],2,standard.deviation,FUN="/")
 foodergycnt.stddev

 food.5cluster <- kmeans(foodergycnt.stddev, centers=5, iter.max=100, nstart=25)
 food.5cluster

 food.4cluster <- kmeans(foodergycnt.stddev, centers=4, iter.max=100, nstart=25)
 food.4cluster

 food.4cluster$cluster

 food.4cluster.clust <- lapply(1:4, function(nc) protein[food.4cluster$cluster==nc])
 food.4cluster.clust

 pairs(food.energycontent[,-1], panel=function(x,y) text(x,y,food.4cluster$cluster))

 food.pc <- princomp(food.energycontent[,-1],cor=T)
 my.color.vector <- rep("green", times=nrow(food.energycontent))
 my.color.vector[food.4cluster$cluster==2] <- "blue"
 my.color.vector[food.4cluster$cluster==3] <- "red"
 my.color.vector[food.4cluster$cluster==4] <- "orange"
 par(pty="s")
 plot(food.pc$scores[,1], food.pc$scores[,2], ylim=range(food.pc$scores[,1]),
      xlab="PC 1", ylab="PC 2", type ='n', lwd=2)
 text(food.pc$scores[,1], food.pc$scores[,2], labels=Food, cex=0.7, lwd=2,
      col=my.color.vector)

Chapter 03/6K-means clustering - Foodstuff.r


# ......................................................................................
# ........Exercise 10. Introduction to the hypothesis testing, one-sample tests ........
# ..........................Michal Béreš, Martina Litschmannová.........................
# ......................................................................................

# 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

#  From interval estimates to hypothesis tests ####
#
# * What is a statistical hypothesis test? ####
#
# Let's have the following:
#
# - random variable X (for example men's height)
# - selection from a random variable (height measurement of 30 men)
#
# Statistical testing of hypotheses decides the validity of statistical statement
# (hypothesis) based on the data obtained:
#
# - $H_0$ - null hypotheses
# - $H_A$ - alternative hypotheses
#
# For example:
#
# $H_0$: $\mu_X = 175$
#
# $H_A$: $\mu_X > 175$
#
# Since this is a statistical decision, it will always be tied to some level of
# significance $\alpha$. We can always reach only 2 different decisions:
#
# - I reject $H_0$ in favor of $H_A$
#     - this means that I claim that $H_0$ does not apply
#     - this decision is with the maximum error $\alpha$(significance level, type I
# error) - this means that we are able to influence the size of this error
# - I don't reject $H_0$
#     - this means that I claim that due to the obtained data(selection) it is not
# possible to reject $H_0$
#     - this decision is with error $\beta$(type II error), this error is not directly
# controllable and depends on the type of test used
#
# How hypothesis tests relate to interval estimates and how the level of significance
# enters them will be shown in the next section.

# * Interval estimation and significance level ####
#

data = readxl::read_excel("data/uvod.xlsx")
head(data)

options(repr.plot.width = 12) # width of graphs in Jupyter
par(mfrow = c(1, 2))          # graph graph matrices 1x2

boxplot(data$data)
hist(data$data)

moments::skewness(data$data)       # oblique
moments::kurtosis(data$data) - 3   # sharpness

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

length(data$data)
mean(data$data)
sd(data$data)

# We make a 95% interval estimate of the mean using a t-test:
#

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

# Now imagine that we want to test the hypothesis:$H_0$: $\mu = 100$$H_A$: $\mu
# \neq 100$What would be the decision with respect to the calculated IO and so the
# significance level $\alpha = 0.05$?
#
# Well, confidence interval covers the value 100 with maximal error of 5% (confidence
# 95%). Therefore, we can say we cannot reject this hypothesis at significance value 5%.

# Let's further imagine that we want to test the hypothesis:$H_0$: $\mu =
# 105$$H_A$: $\mu \neq 105$What would be the decision with respect to the
# calculated IO and so the significance level $\alpha = 0.05$?
#
# Well, now its a different case: confidence interval does not cover the value 105 with
# maximal error of 5% (confidence 95%). Therefore, we can say we can reject this
# hypothesis at significance value 5%.

# **What we just did is called a classic test.**
#
# We will show you more classic tests for one-sided alternatives.$H_0$: $\mu =
# 105$$H_A$: $\mu > 105$
#

t.test(data$data, alternative = "greater", conf.level = 0.95)$conf.int

# $H_0$: $\mu = 105$$H_A$: $\mu < 105$
#

t.test(data$data, alternative = "less", conf.level = 0.95)$conf.int

# Note that the first of these one-sided alternatives led to a "rejection" of $H_0$.
# This is because of the comparison of the unlikely $H_0$ with the even less likely
# $H_A$.
#
# *** P-values and connection with CI ####
#
# An alternative to the classical test(where we create CI) is the so-called pure
# significance test:

# H_0: mu=105
# H_A: mu<>105
t.test(data$data, mu = 105, alternative = "two.sided")

t.test(data$data, mu = 105, alternative = "two.sided")$p.value

# The pure significance test results in a p-value. Based on it, we decide whether or not
# to reject $H_0$.
#
# p-value can be understood as the highest possible level of significance, such that our
# decision is - I do not reject. Thus, the CI/field of acceptance would contain the
# examined value:

# H_0: mu=105
# H_A: mu<>105

p.hod = t.test(data$data, mu = 105, alternative = "two.sided")$p.value
p.hod

t.test(data$data, alternative = "two.sided", conf.level = 1 - p.hod)$conf.int

# H_0: mu=105
# H_A: mu>105

p.hod = t.test(data$data, mu = 105, alternative = "greater")$p.value
p.hod

t.test(data$data, alternative = "greater", conf.level = 1 - p.hod)$conf.int

# H_0: mu=105
# H_A: mu<105

p.hod = t.test(data$data, mu = 105, alternative = "less")$p.value
p.hod

t.test(data$data, alternative = "less", conf.level = 1 - p.hod)$conf.int

# * Overwiev of tests for one sample ####
#
# ** Position measures ####
#
# By position measures we mean the data 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 t-test ####
#
# - we test the mean value
# - 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))

# H_0: mu=100
# H_A: mu<>100
t.test(data$data, mu = 100, alternative = 'two.sided')$p.value

# H_0: mu=100
# H_A: mu>100
t.test(data$data, mu = 100, alternative = 'greater')$p.value

# H_0: mu=100
# H_A: mu<100
t.test(data$data, mu = 100, alternative = 'less')$p.value

# *** b) Wilcoxn test ####
#
# - we test the median
# - the data must come from a symmetric distribution
# - exploratory: skewness lies in(-2,2)
# - exploratory: histogram looks approximately symmetrical

# H_0: X_0.5=100
# H_A: X_0.5<>100
wilcox.test(data$data, mu = 100, alternative = 'two.sided')$p.value

# H_0: X_0.5=100
# H_A: X_0.5>100
wilcox.test(data$data, mu = 100, alternative = 'greater')$p.value

# H_0: X_0.5=100
# H_A: X_0.5<100
wilcox.test(data$data, mu = 100, alternative = 'less')$p.value

# *** c) sign test test ####
#
# - we test the median
# - larger range selection(>10)
# - requires "BSDA" library
# - as the most robust test, it can also be used for discontinuous data

# H_0: X_0.5=100
# H_A: X_0.5<>100
BSDA::SIGN.test(data$data, md = 100, alternative = 'two.sided')$p.value

# H_0: X_0.5=100
# H_A: X_0.5>100
BSDA::SIGN.test(data$data, md = 100, alternative = 'greater')$p.value

# H_0: X_0.5=100
# H_A: X_0.5<100
BSDA::SIGN.test(data$data, md = 100, alternative = 'less')$p.value

# ** Variability measures ####
#
# By measures of variability we mean the data determining the dispersion/variability of
# the data. For data from the normal distribution, we can estimate the standard
# deviation.
#
# *** standard deviation test ####
#
# - we test the standard deviation
# - the data must come from a normal distribution
# - exploratory: skewness and kurtosis lie in(-2,2)
# - Explosive: The QQ graph has points approximately on the line
# - exact: using a statistical test, eg Shapiro-Wilk test(shapiro.test(data))
# - requires "EnvStats" package
# - function in R, compares variance !!!

# H_0: sigma=10
# H_A: sigma<>10
EnvStats::varTest(data$data, sigma.squared = 10*10,
                  alternative = 'two.sided')$p.value

# H_0: sigma=10
# H_A: sigma>10
EnvStats::varTest(data$data, sigma.squared = 10*10,
                  alternative = 'greater')$p.value

# H_0: sigma=10
# H_A: sigma<10
EnvStats::varTest(data$data, sigma.squared = 10*10,
                  alternative = 'less')$p.value

# * Probability ####
#
# *** Test of probability ####
#
# - We test the probability
# - We require sufficient data: $n>\frac{9}{p(1-p)}$
# - Clopper's - Pearson's estimate(binom.test)
# - does not take data as a parameter, but the number of successes and the number of
# observation

pi = 0.3
data_bin = runif(n = 100, min = 0, max = 1) < pi

n = length(data_bin)
x = sum(data_bin)
n
x

# H_0: pi=0.2
# H_A: pi<>0.2
binom.test(x = x, n = n, p = 0.2, alternative = 'two.sided')$p.value

# H_0: pi=0.2
# H_A: pi>0.2
binom.test(x = x, n = n, p = 0.2, alternative = 'greater')$p.value

# H_0: pi=0.2
# H_A: pi<0.2
binom.test(x = x, n = n, p = 0.2, alternative = 'less')$p.value

#  Examples ####

library(dplyr)
library(rstatix)

#
# * Example 1. ####
#
# We have a selection of 216 patients and we measured their protein serum(file
# testy_jednovyberove.xlsx sheet bilk_serum). Verify that the average protein
# serum(Albumin) of all patients of this type(population average µ) differs
# statistically significantly from 35 g/l.

# Reading data from xlsx file(using readxl package)
albumin = readxl::read_excel("data/testy_jednovyberove.xlsx",
                             sheet = "bilk_serum")
head(albumin)

colnames(albumin)="value"

# Exploratory analysis
boxplot(albumin$value)
summary(albumin$value)

length(albumin$value) # sd is rounded to 3 valid digits
sd(albumin$value)     # sd and position measures are rounded to the nearest thousandth

# **Position measurement test**
#

# Verification of normality - exploratory
moments::skewness(albumin$value)    # skew
moments::kurtosis(albumin$value)-3  # sharpness

options(repr.plot.width = 12) # width of graphs in Jupyter
par(mfrow = c(1, 2))          # matrix of 1x2 graphs

qqnorm(albumin$value)
qqline(albumin$value)
hist(albumin$value)

# We will use the normality test for the final decision on data normality.

# The presumption of normality is verified by the Shapir - Wilk test.
# H0: Data is a selection from the normal distribution.
# Ha: Data is not a selection from the normal distribution.
shapiro.test(albumin$value)
# p-value>0.05 ->Na hl. significance of 0.05, the assumption of normality cannot be rejected.

# normal OK ->t.test

# H0: mu=35 g/l
# Ha: mu<>35 g/l

t.test(albumin$value, mu=35, alternative = "two.sided")

# p-value<0.05 ->at significance level of 0.05 we reject the null hypothesis
# in favor of the alternative hypothesis
# The mean albumin value differs statistically significantly from 35 g/l.

# * Example 2. ####
#
# Survival times for 100 lung cancer patients treated with the new drug are listed in
# the tests_jednovyberove.xlsx sheet "preziti". It is known from previous studies that
# the average survival of such patients without the administration of a new drug is 22.2
# months. Can these data suggest that the new drug prolongs survival?
#

# Reading data from xlsx file(using readxl package)
preziti = readxl::read_excel("data/testy_jednovyberove.xlsx",
                             sheet = "preziti")
head(preziti)

colnames(preziti)="value"

# # Exploratory analysis
par(mfrow = c(1, 2))          # graph matrix 1x2

boxplot(preziti$value)
hist(preziti$value)

# **Data contains outliars -> we can delete them. Or note that this is probably an
# exponential distribution and the outliars are not actually there(the distribution
# simply behaves this way.)**
#

# Data contains outliars. We can list them with the help of f-ce boxplot.
preziti$ID = seq(1,length(preziti$value))
outliers = preziti %>% identify_outliers(value)
outliers
# if we decided to remove outliers, then
preziti$value_no_outliars = ifelse(preziti$ID %in% outliers$ID,NA,preziti$value)

# Exploratory analysis for data without remote observations
boxplot(preziti$value_no_outliars)

length(na.omit(preziti$value_no_outliars))   # sd is rounded to 3 valid digits
sd(preziti$value_no_outliars,na.rm=TRUE)     # sd and position measurements round. to tenths

# **Position measure(mean/median) test**
#

# Verification of normality - exploratory
moments::skewness(preziti$value_no_outliars,na.rm=TRUE)
moments::kurtosis(preziti$value_no_outliars,na.rm=TRUE)-3

par(mfrow = c(1, 2))          # graph matrix 1x2

qqnorm(preziti$value_no_outliars)
qqline(preziti$value_no_outliars)
hist(preziti$value_no_outliars)

# QQ - graph and history show that the choice of truth. is not a choice of standards. distribution.
# Slanting and pointing corresponds to standards. distribution.
# we will use the normality test.

# We verify the assumption of normality by the Shapirs. Wilkov's test.
shapiro.test(preziti$value_no_outliars)
# p-value<0.05 ->at significance 0.05, we reject the assumption of normality

# exploratory assessment of symmetry - exponential distribution - no symmetry

# normality rejected ->symmetry rejected ->Sign. test
# H0: median=22.2 months
# Ha: median>22.2 months

BSDA::SIGN.test(preziti$value_no_outliars, md=22.2,
                alternative="greater")

# p-value>0.05 -> at significance of 0.05, the null hypothesis cannot be rejected
# Median survival time is not statistically significantly greater than 22.2 months.

median(preziti$value_no_outliars, na.rm = TRUE)

# * Example 3. ####
#
# The machine produces piston rings of a given diameter. The manufacturer states that
# the standard deviation of the ring diameter is 0.05 mm. To verify this information, 80
# rings were randomly selected and their diameter was measured(file
# testy_jednovyberove.xlsx sheet krouzky). Can the results obtained be considered
# statistically significant in terms of improving the quality of production?

# Reading data from xlsx file(using readxl package)
krouzky = readxl::read_excel("data/testy_jednovyberove.xlsx",
                             sheet = "krouzky")
head(krouzky)

colnames(krouzky)="value"

# # Exploratory analysis
boxplot(krouzky$value)

# Data contains outliars. We can list them with the help of f-ce boxplot.
krouzky$ID = seq(1,length(krouzky$value))
outliers = krouzky %>% identify_outliers(value)
outliers
# if we decided to remove outliers, then
krouzky$value_no_outliars = ifelse(krouzky$ID %in% outliers$ID,NA,krouzky$value)

# Exploratory analysis for data without remote observations
summary(krouzky$value_no_outliars,na.rm=TRUE)
boxplot(krouzky$value_no_outliars)

length(na.omit(krouzky$value_no_outliars))# sd is rounded to 3 valid digits
sd(krouzky$value_no_outliars,na.rm=TRUE)  # sd and position measures round. per thousandths

# Verification of normality - exploratory
moments::skewness(krouzky$value_no_outliars,na.rm=TRUE)
moments::kurtosis(krouzky$value_no_outliars,na.rm=TRUE)-3

par(mfrow = c(1, 2))          # matrix of 1x2 graphs

qqnorm(krouzky$value_no_outliars)
qqline(krouzky$value_no_outliars)
hist(krouzky$value_no_outliars)
# Both skew and sharpness comply with standards. distribution.
# We will use for the final decision on data normality

# normality test.
# We verify the assumption of normality by the Shapirs. Wilkov's test.
shapiro.test(krouzky$value_no_outliars)
# p-value>0.05 ->Na hl. significance of 0.05 cannot be assumed norms. reject

# variability test ->variance test

# H0: sigma=0.05 mm
# Ha: sigma<0.05 mm
EnvStats::varTest(krouzky$value_no_outliars, sigma.squared = 0.05^2,
                  alternative = "less")

# p-value<0.05 ->At the significance level of 0.05 we reject H0 in favor of Ha

# How to find a 95% interval standard deviation estimate?
pom = EnvStats::varTest(krouzky$value_no_outliars,sigma.squared = 0.05^2,
                        alternative = "less", conf.level=0.95)

sqrt(pom$conf.int)

# * Example 4. ####
#
# TT states that 1% of their resistors do not meet the required criteria. 15 unsuitable
# resistors were found in the tested delivery of 1000 pieces. Is this result with
# agreement with TT's assertion or can we reject it?

n = 1000   # selection range
x = 15     # number of "successes"
p = x/n    # relative frequency(probability point estimate)
p

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

# Clopper - Pearson(exact) test
# H0: pi=0.01
# Ha: pi<>0.01

binom.test(x = x, n= n, p = 0.01, alternative="two.sided")


# R demo deta_analysis
#
iris

# summary of Sepal.Length feature
summary(iris$Sepal.Length)
sprintf("Variance is %f", var(iris$Sepal.Length))

# summary of Sepal.Width
summary(iris$Sepal.Width)
sprintf("Variance is %f", var(iris$Sepal.Width))

# summary of Petal.Length
summary(iris$Petal.Length)
sprintf("Variance is %f", var(iris$Petal.Length))

# summary of Petal.Width
summary(iris$Petal.Width)
sprintf("Variance is %f", var(iris$Petal.Width))

# Histgram of Sepel.Length
hist(iris$Sepal.Length)

# Histgram of Petal Length
hist(iris$Petal.Length)

#
library(lattice)
# Histgram of Sepal.Length with Species
histogram(~iris$Sepal.Length | iris$Species)

# Histgram of Petal.Lenght with Speiceis
histogram(~iris$Petal.Length | iris$Species)

#
xyplot(iris$Sepal.Length ~ iris$Sepal.Width, ps=20)

#
splom(~ iris[,1:4], groups=iris$Species)
#
#plot(iris)


(1-0.7*0.7)^2
0.1*0.51*0.51*0.1
1-0.9*0.9*(1-0.2601)

f = function(x){return(6*x-x^2)}
dolniMez = 0
horniMez = 6
1/integrate(f, dolniMez, horniMez)$value

x = 6
3*x^2-x^3/3
x = 0
3*x^2-x^3/3
1/36

f.dens = function(x){
    res = 1/36*(6*x-x^2) # 1/4(6*x+8)
    res[x < 0] = 0
    res[x > 6] = 0
    return(res)
}

F.dist = function(x){
    res = 1/36*(3*x^2-x^3/3)
    res[x < 0] = 0
    res[x > 6] = 1
    return(res)
}

x = seq(from = -1, to = 7, by = 0.01)
fx = f.dens(x)
plot(x, fx, cex = 0.2, main="Graf hustoty")

FX = cumsum(fx)
FX = F.dist(x)
plot(x, FX, cex = 0.2, main="Distribuční funkce")

1-F.dist(2)

data_xlsx = readxl::read_excel("./ZK1/data_123.xlsx",
                  sheet = "Vysledky mereni",
                  skip = 0)

data = data_xlsx[,-1]
colnames(data) = c("prez","dist","typ")

boxplot(data$prez~data$typ)
zaokr = data %>% group_by(typ) %>%
    summarise  (pocet = sum(!is.na(prez)),
                prumer = round(mean(prez, na.rm = TRUE),0),
                smer.odch = ceiling(sd(prez, na.rm = TRUE)*100)/100)
colnames(zaokr) = c('Výrobce','Počet záznamů','Průměr','Směrodatná odchylka')
zaokr %>% print.data.frame()

normSymet = data %>% group_by(typ) %>%
    summarise(  sikmost=round(moments::skewness(prez, na.rm=TRUE),1),
                spicatost=round(moments::kurtosis(prez, na.rm=TRUE)-3,1),
                SW=round(shapiro.test(prez)$p.value,3),
                symetrie=round(lawstat::symmetry.test(prez, boot=FALSE)$p.value,3))
colnames(normSymet) = c('Výrobce','Šikmost','Špičatost','Shapirův-Wilkův test (p-hodnota)','Test symetrie (p-hodnota)')
normSymet %>% print.data.frame()

odhady = data %>% group_by(typ) %>%
    summarise(  median = round(median(prez, na.rm=TRUE),2),
                smer.odch = round(mean(prez, na.rm = TRUE)*100)/100,
                interval = paste0('(',
                    floor(wilcox.test(prez, alternative = 'greater',conf.int=T,conf.level=0.93)$conf.int[1]*10)/10, " ; ",
                    ceiling(wilcox.test(prez, alternative = 'greater',conf.int=T,conf.level=0.93)$conf.int[2]*10)/10
                    ,')'),
                denni.ztrata = round(t.test(prez,mu=8,alternative="greater",conf.level=0.90)$p.value,3),

    )
colnames(odhady) = c('Typ','Bodový odhad (median)','Bodový odhad (str. hodnota)','93% intervalový odhad levostrany (wilcox)', 'denni ztrata')
odhady %>% print.data.frame()

wilcox.test(data$prez, alternative = 'less',conf.int=T)$conf.int

wilcox.test(data$prez[data$typ=="ekonomicky"], mu = 35, alternative = 'greater',conf.level=0.93)$p.value

wilcox.test(x = data$prez[data$typ=="technicky"], y = data$prez[data$typ=="ekonomicky"], alternative = "two.sided",
            conf.level=0.93, conf.int = TRUE)

round(kruskal.test(data$dist ~ data$typ)$p.value,3)

dunn.test::dunn.test(data$dist, data$typ, method="bonferroni",altp=TRUE)
# seřadit podle efektů

# počítání efektů
# průměry ve skupinách
efekty = data %>% group_by(typ) %>%
    summarize(median_skup = median(dist, na.rm=T))

# efekty
efekty$efekt = efekty$median_skup - median(data$dist, na.rm=T)# celkový průměr

# vypsat setřízené
efekty %>% arrange(desc(efekt)) %>% print.data.frame()

# NEZAPOMENOUT NA TEORETICKOU ČÁST


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

# Example : 1   Chapter : 6.5     Page No: 344
# Tests for positive definitenes
library(pracma)
A<-matrix(c(2,-1,0,-1,2,-1,0,-1,2),ncol=3)
u<-lu(A)$U
pivots<-c(u[1,1],u[2,2],u[3,3])
upper_left_deteminants<-c(A[1,1],det(A[-3,-3]),det(A))
eigenvalues<-eigen(A)$values
print("All pivots, upper left determinants and eigen values are positive")
print(pivots)
print(upper_left_deteminants)
print(eigenvalues)


histplus <- function(x, breaks=NULL, distribution='normal', sided=2, alpha=0.05, pvalue=0.95, nsigma=2) {
    ## plot histogram and normal distribution
    ## distribution = normal or Weibull
    ## sided  = -1 (lower), 1 (upper), or 2 sided interval
    ## alpha  = 1 - confidence (used in confidence, prediction, and tolerance intervals)
    confidence <- 1-alpha
    ## pvalue = % of data to be covered (used in tolerance interval)
    ## nsigma = number of standard deviations for mean +/- nsigma * standard deviation

    #### debug
    ## x <- mtcars$mpg
    ## distribution <- 'normal'
    ## sided  <- 2
    ## alpha  <- 0.05
    ## confidence <- 1-alpha
    ## pvalue <- 0.95
    ## nsigma <- 2
    ## breaks <- NULL

    ## calculate limits
    if (distribution=='Weibull') {
        ## not sure how to figure out other intervals for Weibull since mean and sd do not make sense
        tol_out <-  exttol.int(x, alpha = alpha, P=pvalue, side=abs(sided))
        shape <- tol_out$'shape.1'
        scale <- tol_out$'shape.2'
        if (sided==-1) {
            lower_conf_limit      <- NA   # not sure how to do this
            lower_sigma           <- NA   # N/A
            lower_pred_limit      <- NA   # not sure how to do this
            lower_tolerance_limit <- tol_out$'1-sided.lower'
            upper_conf_limit      <- NA   # N/A
            upper_sigma           <- NA   # N/A
            upper_pred_limit      <- NA   # N/A
            upper_tolerance_limit <- NA   # N/A
        } else if (sided==1) {
            lower_conf_limit      <- NA   # N/A
            lower_sigma           <- NA   # N/A
            lower_pred_limit      <- NA   # N/A
            lower_tolerance_limit <- NA   # N/A
            upper_conf_limit      <- NA   # not sure how to do this
            upper_sigma           <- NA   # N/A
            upper_pred_limit      <- NA   # not sure how to do this
            upper_tolerance_limit <- tol_out$'1-sided.upper'
        } else {
            lower_conf_limit      <- NA   # not sure how to do this
            lower_sigma           <- NA   # N/A
            lower_pred_limit      <- NA   # not sure how to do this
            lower_tolerance_limit <- tol_out$'2-sided.lower'
            upper_conf_limit      <- NA   # not sure how to do this
            upper_sigma           <- NA   # N/A
            upper_pred_limit      <- NA   # not sure how to do this
            upper_tolerance_limit <- tol_out$'2-sided.upper'
        }
    } else {  # normal distribution (default)
        xmean <- mean(x)
        xsd   <- sd(x)
        tol_out <- normtol.int(x, alpha = alpha, P=pvalue, side=abs(sided))
        if (sided==-1) {
            student_t <- abs(qt(alpha, length(x)-1))
            lower_conf_limit      <- xmean - student_t*xsd*(  1/length(x))^0.5
            lower_sigma           <- xmean -    nsigma*xsd
            lower_pred_limit      <- xmean - student_t*xsd*(1+1/length(x))^0.5
            lower_tolerance_limit <- tol_out$'1-sided.lower'
            upper_conf_limit      <- NA
            upper_sigma           <- NA
            upper_pred_limit      <- NA
            upper_tolerance_limit <- NA
        } else if (sided==1) {
            student_t <- abs(qt(alpha, length(x)-1))
            lower_conf_limit      <- NA
            lower_sigma           <- NA
            lower_pred_limit      <- NA
            lower_tolerance_limit <- NA
            upper_conf_limit      <- xmean + student_t*xsd*(  1/length(x))^0.5
            upper_sigma           <- xmean +    nsigma*xsd
            upper_pred_limit      <- xmean + student_t*xsd*(1+1/length(x))^0.5
            upper_tolerance_limit <- tol_out$'1-sided.upper'
        } else {
            student_t <- abs(qt(alpha/2, length(x)-1))
            lower_conf_limit      <- xmean - student_t*xsd*(  1/length(x))^0.5
            lower_sigma           <- xmean -    nsigma*xsd
            lower_pred_limit      <- xmean - student_t*xsd*(1+1/length(x))^0.5
            lower_tolerance_limit <- tol_out$'2-sided.lower'
            upper_conf_limit      <- xmean + student_t*xsd*(  1/length(x))^0.5
            upper_sigma           <- xmean +    nsigma*xsd
            upper_pred_limit      <- xmean + student_t*xsd*(1+1/length(x))^0.5
            upper_tolerance_limit <- tol_out$'2-sided.upper'
        }
    }

    ## generate distribution
    xmin <- min(x,lower_sigma,lower_pred_limit,lower_tolerance_limit, na.rm=TRUE)
    xmax <- max(x,upper_sigma,upper_pred_limit,upper_tolerance_limit, na.rm=TRUE)
    chuncks <- (xmax-xmin)/1000
    xhist   <- seq(xmin,xmax,by=chuncks)
    if (distribution=='Weibull') {
        xdensity <- dweibull(xhist,shape=shape,scale=scale)
    } else {
        xdensity <- dnorm(xhist,xmean,xsd)
    }
    xdensitymax <- max(xdensity)

    ## make histogram
    if (is.null(breaks)) {
        ##  hist(x, xlim=c(xmin,xmax), freq=FALSE)  # specifying xlim messes up axes
        hist(x,                freq=FALSE)
    } else {
        hist(x, breaks=breaks, freq=FALSE)
    }
    ## add distribution
    lines(x=xhist, y=xdensity, col='red', lty=1)
    ## add lines for mean and limits
    if (distribution=='normal') abline(v=xmean,col="red")
    abline(v=lower_conf_limit          ,col="blue")
    abline(v=lower_sigma               ,col="darkviolet", lty=2)
    abline(v=lower_pred_limit          ,col="darkviolet")
    abline(v=lower_tolerance_limit     ,col="black")
    abline(v=upper_conf_limit          ,col="blue")
    abline(v=upper_sigma               ,col="darkviolet", lty=2)
    abline(v=upper_pred_limit          ,col="darkviolet")
    abline(v=upper_tolerance_limit     ,col="black")
    cat(sided,"sided", distribution,"distribution intervals\n")
    cat("nsigma                 =",nsigma,"\n")
    cat("confidence = 1 - alpha =",confidence,"\n")
    cat("coverage   = pvalue    =",pvalue,"\n")
    if (distribution=='Weibull') {
        cat("shape =",shape,"\n")
        cat("scale =",scale,"\n")
        interval <- c("confidence", "prediction", "tolerance")
        df <- data.frame(interval)
        df$lower <- c(lower_conf_limit, lower_pred_limit, lower_tolerance_limit)
        df$upper <- c(upper_conf_limit, upper_pred_limit, upper_tolerance_limit)
    } else {     # assume normal
        cat("mean                   =",xmean,"\n")
        cat("standard deviation     =",xsd,"\n")
        interval <- c("confidence", "mean +/- nsigma * sd", "prediction", "tolerance")
        df <- data.frame(interval)
        df$lower <- c(lower_conf_limit, lower_sigma, lower_pred_limit, lower_tolerance_limit)
        df$upper <- c(upper_conf_limit, upper_sigma, upper_pred_limit, upper_tolerance_limit)
        ##    cat("mean                                      =", xmean, "\n")
        ##    cat(sided,  "sided upper", confidence, "confidence limit       =", upper_conf_limit,"\n")
        ##    cat(nsigma, "sigma upper limit                       =", upper_sigma     , "\n")
        ##    cat(sided,  "sided", confidence,"upper prediction limit       =", upper_pred_limit, "\n")
        ##    cat(sided,  "sided", confidence,"/",pvalue,"upper tolerance limit =", upper_tolerance_limit, "\n")
    }
    print(df)
}
# histplus(mtcars$mpg)

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


# Define the global variables
# p represents π
# a represents the counter in the Nilakantha Series
# s determines whether to add or subtract
p <- 3
a <- 2
s <- 1

# Define the iteration function
iterate <- function() {
  # I had to use the <<- assignment operator since it is a global variable
  p <<- p + s * (4 / (a * (a * (a + 3) + 2)))
  a <<- a + 2
  s <<- -s
}

# Define counter variable
i <- 0
# Begin while loop
while(i < 150000) {
  # Iterate Nilakantha Series
  iterate()
  # Increment counter variable
  i <<- i + 1
}

# I could have done a repeat loop, but while is easier.
# What the repeat loop would be like:
"
repeat {
  iterate()
  if(i >= 150000) {
    break
  }
  i <<- i + 1
}
"

# Print result
print ( paste("pi =", p))


## list images
## pics <- list.files("images",full = TRUE)
## read in rgb values of
## rgbs <- lapply(pics, jpeg::readJPEG)

load("duck_rgbs.RData")
library(ggplot2)
library(patchwork)
m <- reshape2::melt(t(apply(duck_rgbs[[1]][,,1],2,rev)))
r <- ggplot(m, aes(x = Var1, y = Var2, fill = value)) +
    geom_tile() + scale_fill_distiller(palette = "Reds", direction = 1) +
    theme_void() + theme(legend.position = "none")
m <- reshape2::melt(t(apply(duck_rgbs[[1]][,,2],2,rev)))
g <- ggplot(m, aes(x = Var1, y = Var2, fill = value)) +
    geom_tile() + scale_fill_distiller(palette = "Greens", direction = 1) +
    theme_void() + theme(legend.position = "none")
m <- reshape2::melt(t(apply(duck_rgbs[[1]][,,3],2,rev)))
b <- ggplot(m, aes(x = Var1, y = Var2, fill = value)) +
    geom_tile() + scale_fill_distiller(palette = "Blues", direction = 1) +
    theme_void() + theme(legend.position = "none")

r + g + b

cluster_ducks <- data.frame(attire  = stringr::str_match(names(duck_rgbs),"(.*?)-")[,2],
                            av_red = sapply(duck_rgbs, function(x) mean(c(x[,,1]))),
                            av_green = sapply(duck_rgbs, function(x) mean(c(x[,,2]))),
                            av_blue = sapply(duck_rgbs, function(x) mean(c(x[,,3]))))

prop.max <- function(x){
    ## matrix of index of max RGB values of x
    mat_max <- apply(x,c(1,2),which.max)
    ## table of collapsed values
    tab <- table(c(mat_max))
    ## proportion of red
    prop_red <- tab[1]/sum(tab)
    prop_green <- tab[2]/sum(tab)
    prop_blue <- tab[3]/sum(tab)
    return(c(prop_red,prop_green,prop_blue))
}
## proportion of r, g, b in each image
prop <- do.call('rbind',lapply(duck_rgbs,prop.max))
cluster_ducks$prop_red <- prop[,1]
cluster_ducks$prop_green <- prop[,2]
cluster_ducks$prop_blue <- prop[,3]

library(ggplot2)
ggplot(cluster_ducks, aes(x = av_red, y = av_green, color = attire)) +
    geom_point() + scale_colour_brewer(type = "qual")

ggplot(cluster_ducks, aes(x = av_red, y = av_blue, color = attire)) +
    geom_point()  + scale_colour_brewer(type = "qual")

ggplot(cluster_ducks, aes(x = prop_blue, y = prop_red, color = attire)) +
    geom_point() + scale_colour_brewer(type = "qual")

ggplot(cluster_ducks, aes(x = prop_blue, y = prop_green, color = attire)) +
    geom_point() + scale_colour_brewer(type = "qual")

ggplot(cluster_ducks, aes(x = prop_red, y = prop_green, color = attire)) +
    geom_point() + scale_colour_brewer(type = "qual")

devtools::install_github("AckerDWM/gg3D")

library("gg3D")

ggplot(cluster_ducks, aes(x = prop_red, y = prop_green, z = prop_blue, color = attire)) +
    axes_3D() +
    stat_3D()

x11()
ggplot(cluster_ducks, aes(x = av_red, y = av_green, z = av_blue, color = attire)) +
    axes_3D() +
    stat_3D()

library(plotly)

plot_ly(x = cluster_ducks$prop_red, y = cluster_ducks$prop_green, z = cluster_ducks$prop_blue,
        type = "scatter3d", mode = "markers", color = cluster_ducks$attire)

plot_ly(x = cluster_ducks$av_red, y = cluster_ducks$av_green, z = cluster_ducks$av_blue,
        type = "scatter3d", mode = "markers", color = cluster_ducks$attire)
## k means clustering
library(factoextra)
df <- cluster_ducks[,2:7];rownames(df) <- stringr::str_match(pics,"images/(.*?).jp")[,2]
distance <- get_dist(df)
fviz_dist(distance, gradient = list(low = "#00AFBB", mid = "white", high = "#FC4E07"))

k2 <- kmeans(df, centers = 6, nstart = 25)

fviz_cluster(k2, data = df)


# Goal: Joint distributions, marginal distributions, useful tables.

# First let me invent some fake data
set.seed(102)                           # This yields a good illustration.
x <- sample(1:3, 15, replace=TRUE)
education <- factor(x, labels=c("None", "School", "College"))
x <- sample(1:2, 15, replace=TRUE)
gender <- factor(x, labels=c("Male", "Female"))
age <- runif(15, min=20,max=60)

D <- data.frame(age, gender, education)
rm(x,age,gender,education)
print(D)

# Table about education
table(D$education)

# Table about education and gender --
table(D$gender, D$education)
# Joint distribution of education and gender --
table(D$gender, D$education)/nrow(D)

# Add in the marginal distributions also
addmargins(table(D$gender, D$education))
addmargins(table(D$gender, D$education))/nrow(D)

# Generate a good LaTeX table out of it --
library(xtable)
xtable(addmargins(table(D$gender, D$education))/nrow(D),
       digits=c(0,2,2,2,2))             # You have to do | and \hline manually.

# Study age by education category
by(D$age, D$gender, mean)
by(D$age, D$gender, sd)
by(D$age, D$gender, summary)

# Two-way table showing average age depending on education & gender
a <- matrix(by(D$age, list(D$gender, D$education), mean), nrow=2)
rownames(a) <- levels(D$gender)
colnames(a) <- levels(D$education)
print(a)
# or, of course,
print(xtable(a))

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/p5.r


library(RUnit)
errMsg <- function(err) print(err)
load('ex2-tests.rda')

# Implement the function "simpleNormSim". This function should generate several
# simulations of samples from a specified normal distribution. The number of
# variables sampled should be constant across simulations. The variables in
# each simulation should have equal variance but may have different means. Your
# function should take the following arguments:
#
# <sim.size>: a numeric constant indicating the number of samples in each
#   simulations.
# <means>: a numeric vector indicating the mean for each each simulation.
# <var>: a numeric constant indicating the variance of the random
#   variables in each simulation.
#
# Your function should return:
#
# <simulation>: a **list** that has the same length as <means>. The jth entry of
#   this list should be a sample of <sim.size> random normal variables with
#   variance given by <var> and mean given by the jth entry of <means>.

simpleNormSim <- function(means, sim.size=50, var=1) {

    # your code here
}

set.seed(47)
tryCatch(checkIdentical(simple.norm.sim.t, simpleNormSim(c(25, 50, 75))),
         error=function(err) errMsg(err))

# Implement the function "advancedNormSim". This function should generate several
# simulations of samples from a specified normal distribution. The number of
# samples, mean, and variance should all be allowed to vary accross each
# simulation. Your function should take the following arguments:
#
# <sim.sizes>: a numeric vector whose length is equal to the number of
#   simulations that will be performed. The entries give the number of samples
#   drawn in the corresponding simulation.
# <means>: a numeric vector whose length corresponds to the number of
#   simulations that will be performed. The entries give the means of the normal
#   distribution in the corresponding simulation.
# <vars>: a numeric vector whose length corresponds to the number of simulations
#   that will be performed. The entries give the variances of the normal
#   distributions in the corresponding simulation.
#
# Your function should return the following:
#
# <simulations>: a **list** whose length corresponds to the number of
#   simulations performed. The jth entry of this list should be a samples obtained
#   from rnorm with parameters n, mean, and sd given by the jth entries of the
#   corresponding arguments.

advancedNormSim <- function(sim.sizes, means, vars) {

    stopifnot(all.equal(length(sim.sizes), length(means), length(vars)))
    # your code here
}

sizes.t <- c(25, 50, 25, 50)
means.t <- c(0, 5, 5, 0)
vars.t <- c(1, 2, 1, 2)

set.seed(47)
tryCatch(checkIdentical(advanced.norm.sim.t, advancedNormSim(sizes.t, means.t,
                                                             vars.t)),
         error=function(err) errMsg(err))


rm(list=ls())
library(ggplot2)
library(tidyr)
library(dict)
library(tidyverse)

############################################
# Defining all functions I need later
############################################

f <- function(x, z){
  value <- x**(z-1)*exp(-x)
  return(value)
}

intf <- function(z){
  if (z != 0){
    value <- integrate(f, lower=0,upper=Inf, z=z)$value
  }else{
    value <- integrate(f, lower=1e-3,upper=Inf, z=z)$value
  }

  return(value)
}

psi <- function(j, d){

  if (d<0){
    upper <- j**(-d-1)
    lower <- intf(abs(d))
  }else{
    upper <- j**(d-1)
    lower <- intf(d)
  }

  value <- upper/lower
  return(value)
}

get_data <- function(overall_length, d_list){
  y <- matrix(nrow=overall_length, ncol=length(d_list))
  for (i in seq_along(d_list)){
    res <- rep(NA, length(overall_length))

    for (t in seq_len(overall_length)){
      val <- 0
      for (j in seq_len(t-1)){
        tmp <- psi(j,d_list[i]) * et[t-j]
        val <- val + tmp
      }
      res[t] <- sum(val)
    }

    y[,i] <- res
  }
  return(y)
}

get_gamma0 <- function(data, d_list, d){

  pos <- which(d_list==d)
  sigma2 <- var(data[,pos])
  upper <- intf(1-2*d)
  lower <- intf(1-d)**2

  final <- sigma2*(upper/lower)
  return(final)
}

get_corrs <- function(data, laglength, d_list){

  sto = dict()
  for (i in seq_along(d_list)){
    lagframe <- data.frame()

    gamma0 <- get_gamma0(data, d_list, d_list[i])
    lagframe <- cbind(0, gamma0)

    for (h in seq(laglength)){
      pre <- (h-1+d_list[i])/(h-d_list[i])
      gammah <- pre * lagframe[h,2]

      lagframe <- rbind(lagframe, cbind(h, gammah))
    }

    lagframe[,2] <- lagframe[,2]/lagframe[1,2]
    colnames(lagframe) <- c("h", 'real')

    estimated <- acf(data[,i], lag.max=laglength,
                     plot=FALSE, demean = FALSE)$acf
    final <- cbind(lagframe, estimated)
    sto[[toString(i)]] <- data.frame(final)
  }

  return(sto)
}

prepplot <- function(data){
  df_plot <- pivot_longer(data, -h, names_to = 'type', values_to = 'values')
  return(df_plot)
}
############################################
############################################
############################################

M <- 2000
TS <- 1000
overall_length <- M+TS
et <- rnorm(M+TS)

d_list <- c(-0.45, -0.25, 0, 0.25, 0.45)

y <- get_data(overall_length, d_list)
yshort <- y[M:(TS+M), ]

yshort <- load(file="y_short.Rda")
# Dictionary with 5 dataframes for each d
a <- get_corrs(yshort, 25, d_list)

d_list <- c(-0.45, -0.25, 0, 0.25, 0.45)
yshort <- read.csv2("yshort.csv")
a <- get_corrs(yshort, 25, d_list)

cbPalette <- c("#000000", "#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#CC79A7")
for (key in a$keys()){
  df <- prepplot(a[[key]])
  spec <- as.numeric(key)

  d_spec <- d_list[spec]
  name <- ("Autocorrelations with d=")

  p <- ggplot(data=df, aes(x=h, y=values, fill=type)) +
    geom_col(position="dodge") +
    scale_colour_manual(values = cbPalette) +
    ggtitle(paste(name, d_spec, sep=""))
  plot(p)
}

df_y <- data.frame(yshort)
colnames(df_y) <- c("X", "d=-0.45", "d=-0.25", "d=0", "d=0.25", "d=0.45")
df_y_plot <- pivot_longer(df_y, -X, names_to = 'type', values_to = 'values')

for (key in a$keys()){
  spec <- as.numeric(key)

  d_spec <- d_list[spec]
  namehighl <- ("d=")
  name <- ("Time series of y with d=")

  highl <- paste(namehighl, d_spec, sep="")

  z <- mutate(df_y_plot, highlight=ifelse(type==highl, highl, "Other"))
  p2 <- ggplot(data=z, aes(x=X, y=values, group=type, color=highlight)) +
    geom_line() +
    scale_color_manual(values = c("#009E73", "lightgrey")) +
    scale_size_manual(values=c(1.5,0.02)) +
    theme(legend.position="none") +
    ggtitle(paste(name, d_spec, sep=""))
  plot(p2)
}

d_spec <- d_list[1]
namehighl <- ("d=")
highl <- paste(namehighl, d_spec, sep="")
highl


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

oz.per.year <- 10000
rf <- 0.03  # 3% interest rates
wacc <- 0.08  # 8% weighted average cost of capital
num.sims <- 100000 # 100,000 simulations
s0 <- 1300  # gold price at t=0
K <- 1000  # cost of extraction
sigma <- 0.3  # volatility of gold log-returns
lambda <- 1  # rate of mean reversion; 1 => half-life = ln(2) = 0.69 years

## Annual extraction decisions at start of each year (t=0,...,9)
T.list <- 1:9  # 1--9 year options; years 2:8 are 1 year fwd
s.bar.list <- c(1300, rep(1200, 8))  # 1300/oz, then 1200/oz

# gold price follows geometric Brownian motion
sum.val <- (s0-K)/(1+wacc)  # time t=0 decision
for (i in 1:9) {
    T <- T.list[i]
    z <- rnorm(num.sims) # simulated Z_T values
    s.sim <- s0*exp((rf-sigma^2/2)*T+sigma*sqrt(T)*z)
    if (T>1) s.sim <- s.sim*s.bar.list[i]/s0
    opt.terminal.val.sim <- pmax(s.sim - K, 0)
    opt.value <- mean(opt.terminal.val.sim)*exp(-rf*T)
    sum.val <- sum.val + opt.value/(1+wacc)
}
print(sum.val*oz.per.year)

## gold price follows Ornstein-Uhlenbeck mean reversion
sum.val <- (s0-K)/(1+wacc)
for (i in 1:9) {
    T <- T.list[i]
    s.bar <- s.bar.list[i]
    s.meanrevert.sim <- s.bar + exp(-lambda*T)*(s0-s.bar) + sigma*s0*
        sqrt((1-exp(-2*lambda*T))/(2*lambda))*z
    opt.terminal.val.meanrevert.sim <- pmax(s.meanrevert.sim - K, 0)
    opt.meanrevert.value <- mean(opt.terminal.val.meanrevert.sim)*
        exp(-rf*T)
    sum.val <- sum.val + opt.meanrevert.value/(1+wacc)
}
print(sum.val*oz.per.year)

## Quarterly extract decisions at start of each quarter
T.list <- (1:39)/4 # 1--39 quarter options
s.bar.list <- c(rep(1300, 4), 1275, 1250, 1225, rep(1200, 32))

# gold price follows geometric Brownian motion
sum.val <- (s0-K)/(1+wacc)^0.25
for (i in 1:39) {
    T <- T.list[i]
    z <- rnorm(num.sims) # simulated Z_T values
    s.sim <- s0*exp(sigma*sqrt(T)*z)
    opt.terminal.val.sim <- pmax(s.sim - K, 0)
    opt.value <- mean(opt.terminal.val.sim)*exp(-rf*T)
    sum.val <- sum.val + opt.value/(1+wacc)^0.25
}
print(sum.val*oz.per.year/4)

# gold price follows Ornstein-Uhlenbeck mean reversion
sum.val <- (s0-K)/(1+wacc)^0.25
for (i in 1:39) {
    T <- T.list[i]
    s.bar <- s.bar.list[i]
    s.meanrevert.sim <- s.bar + exp(-lambda*T)*(s0-s.bar) + sigma*s0*
        sqrt((1-exp(-2*lambda*T))/(2*lambda))*z
    opt.terminal.val.meanrevert.sim <- pmax(s.meanrevert.sim - K, 0)
    opt.meanrevert.value <- mean(opt.terminal.val.meanrevert.sim)*exp(-rf*T)
    sum.val <- sum.val + opt.meanrevert.value/(1+wacc)^0.25
}
print(sum.val*oz.per.year/4)


# Make QQ Plots from the rareCADD summary data

library(gap) # Install this package if it's not already installed

# Load data
eur <- read.csv("SUMMARY_EUR_rareCADD_collapse_risk_pval.csv",header=T,as.is=T,comment.char="")
mex <- read.csv("SUMMARY_MEX_rareCADD_collapse_risk_pval.csv",header=T,as.is=T,comment.char="")

print ("EUR Lambda 1")
# Calculate GC Lambda value
# Method 1: gcontrol2 function
lambda.eur.1 <- gcontrol2(eur$pVal)$lambda

print ("EUR Lambda 2")
# Method 2: calculate by hand
getLambda <- function(p) {
  chi <- qchisq(p,df=1,lower.tail=F)
  g <- median(chi,na.rm=TRUE)
  lambda <- round(g/0.456,digits=4)
  return(lambda)
}
lambda.eur.2 <- getLambda(eur$pVal)

print ("MEX Lambda 1")
# Calculate GC Lambda value
# Method 1: gcontrol2 function
lambda.mex.1 <- gcontrol2(mex$pVal)$lambda

print ("MEX Lambda 2")
# Method 2: calculate by hand
getLambda <- function(p) {
  chi <- qchisq(p,df=1,lower.tail=F)
  g <- median(chi,na.rm=TRUE)
  lambda <- round(g/0.456,digits=4)
  return(lambda)
}
lambda.mex.2 <- getLambda(mex$pVal)

# The two numbers are slightly different, but that's likely just due to rounding digits
# Ideally, the GC Lambda value should be near 1, with >1 representing inflation and <1 deflation
# Both values above are about 2.05, which is quite high, but this may be expected to some extent
# since we're likely to have some overcounting in the controls.

# Make plots
png("SUMMARY_EUR_rareCADD_collapse_risk_qqplot.png")
qqunif(eur$pVal, main="EUR Results")
dev.off()

png("SUMMARY_MEX_rareCADD_collapse_risk_qqplot.png")
qqunif(mex$pVal, main="MEX Results")
dev.off()

# Zoomed in plot
png("SUMMARY_EUR_rareCADD_collapse_risk_qqplot_zoom.png")
qqunif(eur$pVal, main="EUR Results", xlim=c(0,4), ylim=c(0,4))
dev.off()

# Zoomed in plot
png("SUMMARY_MEX_rareCADD_collapse_risk_qqplot_zoom.png")
qqunif(eur$pVal, main="MEX Results", xlim=c(0,4), ylim=c(0,4))
dev.off()

# Zooming in here was a good idea, since the large top p-values stretched the y-axis to hide
# what's going on closer to the diagonal line.
# Running this on different gene sets may provide different patterns.


eggs=c(27,32,39,48,59,67,71,65,73,67,78,72,81,74,83,75,84,77,83,76,82,75,78,77,75,73,71,70,68,65)
weight=c(2.1,2.3,2.4,2.5,2.9,3.1,3.2,3.3,3.4,3.4,3.5,3.5,3.5,3.6,3.6,3.6,3.6,3.7,3.7,3.7,3.8,3.9,4.0,4.3,4.4,4.7,4.8,4.9,5.0,5.1)
 plot(weight,eggs)
 #  correlation coefficient
 cor(eggs,weight)


hours = c(23,1,10,17)
mins = c(45,15,55,30)
labels = c("black","black","gray","gray")
labs = c(1,1,0,0)

sins = sin(pi*2*(hours*60+mins)/(24*60))
coss = cos(pi*2*(hours*60+mins)/(24*60))

data = data.frame(sin=sins, cos=coss, labels=labels)

png("circle_abline.png", width = 5.5, height = 5.5, units = "in", res = 300)

plot(sins,coss, asp=1, col=labels,
     xlim=c(-1,1), ylim=c(-1,1),
     xlab="cos", ylab = "sin")
abline(v=0)
abline(h=0)
symbols(x=0, y=0, circles=c(1), add=T, inches=F)

g=glm(labs~coss+sins,family=binomial)

slope <- coef(g)[2]/(-coef(g)[3])
intercept <- coef(g)[1]/(-coef(g)[3])
abline(intercept, slope)

dev.off()

png("min_hour.png", width = 5.5, height = 5.5, units = "in", res = 300)

plot(hours, mins, col=labels,
     xlim=c(0, 25), ylim=c(0, 59),
     xlab="hours", ylab = "minutes")

dev.off()


nm <- 1
temp <- 1
sum <- 0

while (nm < 4000000) {
    tp <- nm
    nm <- nm + temp
    temp <- tp
    if (nm %% 2 == 0) {
        sum <- nm + sum
    }
}

print(sum)


# Synthetic Data Project
# Laplace probability functions

# Author:
# Version:  5/14/2017

# Copyright 2017

# Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
# associated documentation files (the "Software"), to deal in the Software without restriction, including
# without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the
# following conditions:

# The above copyright notice and this permission notice shall be included in all copies or substantial
# portions of the Software.

# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT
# LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
# IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
# SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

# density
dlaplace <- function(x, m, lambda, log=F)
  # evaluate Laplace density (double-sided exponential)
  # f(x, m, lambda) =
  # x<m:   lambda/2 * exp[-lambda*(m-x)]
  # x>=m:  lambda/2 * exp[-lambda*(x-m)]
  # note that, by custom, 1/lambda is used in the pdf definition
  if(!log) {
    exp(-abs(x-m)/lambda)/2/lambda
  } else {
    -log(2*lambda)-abs(x-m)/lambda
  }

# cumulative density
plaplace <- function(x, m, lambda) {
  # evaluate Laplace cumulative density (double-sided exponential)
  # F(x, m, lambda) =
  # x<m:   [1-Fexp(m-x, lambda)]/2 = (1-1+exp[-lambda*(m-x)])/2 = exp[-lambda*(m-x)]/2
  # x>=m:  1/2+Fexp(m-x, lambda)/2 = 1/2+(1-exp[-lambda*(x-m)])/2
  #        = 1/2*(1+1-exp[-lambda*(x-m)]) = (2-exp[-lambda*(x-m)])/2
  # note that, by custom, 1/lambda is used in the pdf definition
  i <- ifelse(x<m, 1, -1)
  ((1-i) + i*exp(i/lambda*(x-m)))/2
}

# inverse cdf, Finv(p, m, lambda)
qlaplace <- function(p, m, lambda) {
  # evaluate Laplace quantile (double-sided exponential)
  # Finverse(p, m, lambda) =
  # x<m:   ln(2p)/lambda+m
  # x>=m:  -ln(2-2p)/lambda+m
  # note that, by custom, 1/lambda is used in the pdf definition
  i <- ifelse(p<.5, 1, -1)
  i*log(1-i+i*2*p)*lambda+m
}

# random Laplace quantiles
rlaplace <- function(n, m, lambda)
  qlaplace(runif(n), m, lambda)


# Normal Approximation to the Binomial
# number of trails
n<-1000
# probability of success of single event
z<-0.5
Mean<-n*z
s<-sqrt(n*z*(1-z))
 #  the probability of observing 460 or fewer
pnorm(460,mean=Mean,sd=s)


# Goal : Terse version of estimating the beta of Sun Microsystems
#        using weekly returns and data from Yahoo finance.
#        By Gabor Grothendieck.

library(tseries)

getstock <- function(x)
   c(get.hist.quote(x, quote = "Adj", start = "2003-01-01", compress = "w"))
r <- diff(log(cbind(sp500 = getstock("^gspc"), sunw = getstock("sunw"))))

mm <- lm(sunw ~ ., r)
print(summary(mm))

range <- range(r, -r)
plot(r[,1], r[,2], xlim = range, ylim = range,
     xlab = "S&P 500 weekly returns (%)", ylab = "SUNW weekly returns (%)")
grid()
abline(mm, h = 0, v = 0, col = "blue")

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/o6.r


par(mar=c(5.1, 4.1, 4.1, 7),xpd=TRUE)

plot(0,type="n",

     xlim=c(0,100),ylim=c(0,0.15),ann=FALSE)

p=c(0.1,0.3,0.5,0.7,0.9)

for (i in 1:length(p))

{

  x=1:100

  y=dbinom(x,100,p[i])

  points(x,y,type="l",col=rainbow(length(p))[i])

}

title(main="PMF of binom",xlab="x",ylab="p(x)",cex.main=2,cex.lab=1.2)

box("outer",col="gray")

legend("topright",inset=c(-0.23,0), legend=paste("p=",p),col=rainbow(length(p)),lty=1)


#####
# plots exponential decay curves
# for the number of new child speakers of Mongolian
# over the next 5 generations,
# contrasting the observed rate of shift in the data
# against a hypothetical faster rate
# takes no inputs: data is coded into script
####

rm(list=ls())
library(ggplot2)

# exponential decay constant λ
# where p is the proportional decline per unit of time
# p is positive
lambda <- function(p){-log(1-p)}

# exponential decay function
# where t is time (generations)
decay <- function(p,t){exp(-lambda(p)*t)}

# set two possible values for p:
# observed p(B1,C2|B1) = 0.165
    # this comes from the actual data analysis
# counterfactual p(B1,C2|B1) = 0.423
    # this comes from a hypothetical fake dataset
    # see Puthuval (2017) for explanation
lowball <- function(x){decay(0.165, x)} # observed
highball <- function(x){decay(0.423, x)} # counterfactual

# plot the curves
baseplot <-
  ggplot(data.frame(x=c(0,6)), aes(x=x)) +
  	stat_function(fun=lowball, geom="path", size=1.5) +
  ylim(0, 1) + xlim(0,5) +
  labs(x="Generations", y="New child speakers of Mongolian") +
  ggtitle(paste0("Decline in new child speakers over five generations,",
                 "\nassuming a constant rate of shift"))
# stat_function calculates at 101 points along x range by default

one <- baseplot +
  annotate("text", x=3, y=.75, label="Rate of shift = 0.165", size=5)

two <- baseplot +
  stat_function(
    fun=highball, geom="path", size=1.5, linetype="dotdash") +
  annotate("text", x=3, y=.75,
  	label="Observed rate = 0.165", size=5) +
  annotate("text", x=2.5, y=.07,
  	label="Counterfactual rate = 0.423", size=5)

plots <- c("one", "two")
prefix <- "figures/expdecay_"
l <- mget(plots)

invisible(mapply(ggsave,
	file=paste0(prefix, names(l), ".pdf"),
	width=6, height=4, units="in", plot=l))
invisible(mapply(ggsave,
	file=paste0(prefix, names(l), ".jpg"),
	width=6, height=4, units="in", plot=l))


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

## empirical
alpha <- 0.05  # probability mass in the loss tail
# sort the data; grab the lowest alpha fraction of the data
sorted.x.obs <- sort(x.obs)
frac.idx <- length(sorted.x.obs)*alpha
left.idx <- floor(frac.idx)

# VaR is linearly interpolated between points
rfrac <- 1-(frac.idx-left.idx)
VaR.emp <- sorted.x.obs[left.idx:(left.idx+1)] %*% c(1-rfrac, rfrac)

# ES is just the average of the observed data in the tail
es.emp <- mean(sorted.x.obs[1:left.idx])

## parametric
VaR.norm <- mean.obs + sqrt(var.obs)*qnorm(alpha)
es.norm <- mean.obs - sqrt(var.obs)*dnorm(qnorm(alpha))/alpha

## from kernel density estimate
# create the kernel density estimate
kde <- density(x.obs, kernel="gaussian", bw="SJ")

# now create numerical CDF
int.kde <- cumsum(kde$y)/sum(kde$y)

# Find where alpha is in loss tail
left.idx <- findInterval(alpha, int.kde)

# linearly interpolate to find VaR
rfrac <- (alpha-int.kde[left.idx])/(int.kde[left.idx+1]-int.kde[left.idx])
VaR.kde <- kde$x[left.idx:(left.idx+1)] %*% c(1-rfrac, rfrac)

# numerically integrate kernel density estimate to get ES (a bit hacky)
es.kde <- kde$x[1:left.idx] %*% kde$y[1:left.idx]/sum(kde$y)/alpha

## from Edgeworth expansion - exact
# this function returns the "CDF" of the Edgeworth expansion
int.left.edge <- function(q, mu, sigma, skew=0, exkurt=0) {
  z <- (q-mu)/sigma
  pnorm(z) - dnorm(z)*(skew*(z^2+1)/6 + exkurt*(z^3-3*z)/24
                                      + skew^2*(z^5-10*z^3+15*z)/72)
}

# returns the "conditional expectation" of the Edgeworth expansion
exp.left.edge <- function(q, mu, sigma, skew=0, exkurt=0) {
  z <- (q-mu)/sigma
  mu - sigma/alpha*dnorm(z)*(1 + skew*(z^3)/6 + exkurt*(z^4-2*z^2-1)/24
                               + skew^2*(z^6-9*z^4+9*z^2+3)/72)
}

# Find the point where the area under the left tail equals alpha
# Do this by shifting the integral down by alpha to find where it
# crosses zero (i.e. where the integral equals alpha)
int.left.edge.shifted <- function(q) {
  int.left.edge(q, mean.obs, sqrt(var.obs), skew.obs, exkurt.obs) - alpha
}
find.VaR <- uniroot(int.left.edge.shifted, check.conv = TRUE,
                    lower=-1, upper=mean.obs)

# The VaR is that point; the ES is the integral up to that point
VaR.edge.exact <-find.VaR$root
es.edge.exact <- exp.left.edge(VaR.edge.exact, mean.obs, sqrt(var.obs),
                               skew.obs, exkurt.obs)

## from Edgeworth expansion - numeric
# Alternately, just use numeric integration on the Edgeworth
# expansion points we got from the moments

# create numeric "CDF"
int.edge <- cumsum(edge.expand$approx)/sum(edge.expand$approx)

# linearly interpolate to find VaR
left.idx <- which(int.edge>alpha)[1] - 1
rfrac <- (alpha-int.edge[left.idx])/(int.edge[left.idx+1]-int.edge[left.idx])
VaR.edge.num <- edge.expand$y[left.idx:(left.idx+1)] %*% c(1-rfrac, rfrac)

# numerically integrate Edgeworth expansion to get ES
es.edge.num <- edge.expand$y[1:left.idx] %*% edge.expand$approx[1:left.idx]/
    sum(edge.expand$approx)/alpha

## from Cornish-Fisher expansion
VaR.cornfish <- VaR(x.obs, p=0.05, method="modified", mu=mean.obs, sigma=var.obs,
                    m3=skew.obs, m4=exkurt.obs)
es.cornfish <- ES(x.obs, p=0.05, method="modified", mu=mean.obs, sigma=var.obs,
                  m3=skew.obs, m4=exkurt.obs)

## from EVT
library(evir)

#evir package looks at upper tail, so flip returns
x.neg.obs <- -x.obs

# First, work with the generalized extreme value distribution
gev.model <- gev(x.neg.obs, block=23)
q.gev <- function(p) {
  -1*qgev(1-p, xi=gev.model$par.ests[["xi"]],
               mu=gev.model$par.ests[["mu"]],
               sigma=gev.model$par.ests[["sigma"]])
}
VaR.gev <- q.gev(alpha)  # use evir function
# a bit hacky: numerically integrate CDF to get ES
es.gev <- mean(q.gev(seq(0.001, alpha, 0.001)))

# Next, work with the generalized Pareto distribution
gpd.model <- gpd(x.neg.obs, nextremes=5)
riskmeasures(gpd.model, c(0.95))

## comparison
# now create the exact CDF
t.df <- 5
p.t <- function(q) {
  z1 <- (q+0.05)/desired.sd*t5.sd
  z2 <- (q-0.05)/desired.sd*t5.sd
  pt(z1, df=5)*3/5 + pt(z2, df=5)*2/5
}

# shift CDF down to find the point where alpha is in the loss tail
p.t.quantile <- uniroot(function(q) p.t(q)-alpha, check.conv=TRUE,
                        lower=-1, upper=mean.obs)
VaR.true <- p.t.quantile$root

# function finds ES for a t-distribution to left of quantile q
es.t <- function(q) {
  -dt(qt(q, df=t.df), df=t.df)/q*(t.df-2+qt(q, df=t.df)^2)/(t.df-1)
}

# ES calculation is crusty: we found point for alpha in loss tail.
# Now find ES for both t-distributions; then find average of them
q1 <- pt((VaR.true+0.05)/desired.sd*t5.sd, df=t.df)
q2 <- pt((VaR.true-0.05)/desired.sd*t5.sd, df=t.df)
es.true <- (3/5*es.t(q1) + 2/5*es.t(q2))*desired.sd/t5.sd - 0.01


library(gmp)

left_factorial <- function(n) {
	if (n == 0) return(0)
	result <- as.bigz(0)

	adder <- as.bigz(1)
	for (k in 1:n) {
		result <- result + adder
		adder <- adder * k
	}
	result
}

digit_count <- function(n) {
	nchar(as.character(n))
}

for (n in 0:10) {
	cat("!",n," = ",sep = "")
	cat(as.character(left_factorial(n)))
	cat("\n")
}
for (n in seq(20,110,10)) {
	cat("!",n," = ",sep = "")
	cat(as.character(left_factorial(n)))
	cat("\n")
}
for (n in seq(1000,10000,1000)) {
  cat("!",n," has ",digit_count(left_factorial(n))," digits\n", sep = "")
}


library(deSolve)
library(reshape2)
library(ggplot2)
library(scales)

#Anderson and May (1978) Model F eqn (19)-(21)
HPL_ode <- function(times,init,parms){
  with(as.list(c(parms,init)), {
  # ODEs
  dH=(a-b)*H - alpha*P
  dP=(beta*L*H) - (mu+alpha+b)*P - (alpha*((P^2)/H)*((k+1)/k))
  dL=(lambda*P) - (gamma*L) - (beta*L*H)

  list(c(dH,dP,dL))
  })
}

# L= number of free-living (infective) stages (e.g. larvae)
# H = number of hosts
# P = number of parasites
# a = host birth rate
# b = host death rate
# alpha = parasite impact on host mortality
# beta*l = rate at which hosts pick up infecting stages
# mu = parasite death rate
# k = aggregation parameter
# lambda*P = rate of production of new free-living stages (i.e. parasite fertility)
# gamma = death rate of free-living stages

parms <-c(b=1.05,a=1.4,alpha=0.0003,beta=0.01,mu=0.5,k=0.1,lambda=10.0,gamma=10.0)

init <- c(H=100,P=10,L=10)
times <- seq(0,30,length.out=2001)
HPL_out <- lsoda(init,times,HPL_ode,parms)

HPL_out_long <- melt(as.data.frame(HPL_out),"time")

#Visualisation
ggplot(HPL_out_long,aes(x=time,y=value,colour=variable,group=variable)) +
  geom_line(lwd=2) + xlab("Time") + ylab("Number") + scale_y_log10(breaks = trans_breaks("log10", function(x) 10^x),
              labels = trans_format("log10", math_format(10^.x)))


data <- mtcars[, c ("mpg" , "disp", "hp")]
head (data)

model <- lm(mpg~disp + hp, data = data)
summary (model)

predict (model, newdata = data.frame (disp =140, hp = 80))
predict (model, newdata = data.frame (disp =160, hp = 70))

plot (model)


#----------------------------------------------------------------------------
# frmAmpCorr -- Formant Amplitude Correction
#
# The amplitude of a resonator is proportional to both its frequency and
# bandwidth. This function is designed to calculate a scaling factor that
# will compensate both frequency and bandwidth factors to result in unit
# amplitude at the resonator center frequency (i.e. amplitude = 1.0 at
# the resonator characteristic frequency).
#
# The amplitude at the resonant frequency is inversely proportional to the
# bandwidth plus a constant offset that is a nonlinear function of the
# bandwidth. The latter function is approximated here via a 4th order
# polynomial.
#
# See also: function formant() that calculates the discrete spectrum of the
# resonator impulse response given the resonator frequency and bandwidth as
# well as the bandwidth of the spectrum and the number of discrete spectral
# bins. The formant function now also includes a scale argument that
# defaults to FALSE for compatibility with previous versions of the function.
# If scale=TRUE, the amplitude spectrum is scaled to have unit gain at the
# resonator frequency.
#
# 12/23/19 -- htb
#---------------------------------------------------------------------------
#
frmAmpCorr <- function(freq, band) {
  coe <- c(-1.683882e-03,4.234928e-04,-1.231765e-07,2.421068e-11,-2.066097e-15)
  m <- 1.0 / band
  b <- coe[1] + coe[2]*band + coe[3]*band^2 + coe[4]*band^3 + coe[5]*band^4
#  cat(paste0("m = ",m,"; b = ",b,"\n"))
  amp <- m*freq + b
  return(amp)
}


#' puntomedio() calcula el punto medio entre 2 puntos
#'
#' @param a vector
#' @param b vector
#'
#' @return vector
#' @export
#'
#' @examples
#' puntomedio(c(1,1),c(2,2))
#' # [1] 1,5 1,5
#'
puntomedio <- function(a,b){
  pmedio <- vector("numeric",2)
  pmedio[1] <- (a[1]+b[1])/2
  pmedio[2] <- (a[2]+b[2])/2
  pmedio
}


##### 医学統計勉強会15第一回基本統計量　R code #####

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

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

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

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

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

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

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

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

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

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

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

## 二標本問題 ##
x1 <- c(8, 17, 9, 5, 14, 13, 13, 3, 9, 0)
x2 <- c(19, 13, 13, 18, 21, 18, 11, 21, 20, 11)

boxplot(x1, x2)

t.test(x1, x2)		# Welch's t test
wilcox.test(x1, x2)	# Mann-Whitney test, Wilcoxon’s rank sum test

## 分散分析 ##

# サンプルデータ #
Data <- data.frame(
  z = c(8, 16, 7, 18, 6, 11, 15, 11, 20, 7, 19, 20, 21, 19, 24),
  group = factor(c(rep(1,5), rep(2,5), rep(3,5)), label=c("placebo", "drugA", "drugB")))
print(Data)
boxplot(z ~ group, data=Data)

# ANOVA #
fit.aov <- aov(z ~ group, data=Data)
summary(fit.aov)

# Kruskal-Wallis rank sum test #
kruskal.test(z ~ group, data=Data)

## 多重比較 ##

# Tukey's method #
library(MASS)
fit.mc <- TukeyHSD(fit.aov)
print(fit.mc)
plot(fit.mc)

# Dunnett's method (Dunnett post hoc test) #
install.packages("multcomp")	# 最初の一回のみ実行
library(multcomp)
fit.dunnett <- glht(fit.aov, linfct = mcp(group = "Dunnett"))
confint(fit.dunnett, level=0.95)
summary(fit.dunnett)

# William's method #
fit.williams <- glht(fit.aov, linfct = mcp(group = "Williams"))
confint(fit.williams, level=0.95)
summary(fit.williams)


setwd("C:\\Users\\Ashish Arora\\Desktop\\Time series Case Study")

#Loading the data file
mydata<-read.csv("data.csv")
View(mydata)

myts   <- ts(mydata[,-c(1,2)], start=c(1996, 1), end=c(2005, 4), frequency=4)
plot(myts)

#After looking at the graph it is observed that Rest.of.World is a patternless data rest all follow a multiplicative form
#so subsetting the data separately.

myts_ireland   <- ts(mydata$Ireland, start=c(1996, 1), end=c(2005, 4), frequency=4)
myts_Other.EU   <- ts(mydata$Other.EU, start=c(1996, 1), end=c(2005, 4), frequency=4)
myts_Rest.of.Europe   <- ts(mydata$Rest.of.Europe, start=c(1996, 1), end=c(2005, 4), frequency=4)
myts_Total  <- ts(mydata$Total, start=c(1996, 1), end=c(2005, 4), frequency=4)

myts_Rest.of..World  <- ts(mydata$Rest.of..World, start=c(1996, 1), end=c(2005, 4), frequency=4)

# plot series
plot(myts_ireland)
plot(myts_Other.EU)
plot(myts_Rest.of.Europe)
plot(myts_Total)
plot(myts_Rest.of..World)#this is an non-seasonal patternless data so we can implement an exponential smoothening techniques

fit<- decompose(myts_ireland, type = c("multiplicative"))
ls(fit)
forecast(fit$x, 4,level=c(90,95))
accuracy(forecast(fit$x, 4))#The MAPE value of 2.428393 for Ireland predicted values
#FORECASTING AND PLOTTING VALUES FOR NEXT QUATER(2006)
final<-forecast(fit$x, 4,level=c(90,95))
plot(final)

fit1<- decompose(myts_Other.EU, type = c("multiplicative"))
forecast(fit1$x, 4,level=c(90,95))
accuracy(forecast(fit1$x, 4))#The MAPE value of 2.279375 for Other EU predicted values
final1<-forecast(fit1$x, 4,level=c(90,95))
plot(final1)

fit2<- decompose(myts_Rest.of.Europe, type = c("multiplicative"))
forecast(fit2$x, 4,level=c(90,95))
accuracy(forecast(fit2$x, 4))#The MAPE value of 2.871732 for Rest of Europe predicted values
final2<-forecast(fit1$x, 4,level=c(90,95))
plot(final2)

fit3<- decompose(myts_Total, type = c("multiplicative"))
forecast(fit3$x, 4,level=c(90,95))
accuracy(forecast(fit3$x, 4))#The MAPE value of 1.948733 for Total predicted values
final3<-forecast(fit1$x, 4,level=c(90,95))
plot(final3)
####NoW for Rest of world data####
fit4.1 <- HoltWinters(myts_Rest.of..World, beta=FALSE, gamma=FALSE)
ls(fit4.1)
require(forecast)
accuracy(fit4.1$fitted, myts_Rest.of..World)

# double exponential - models level and trend
fit4.2 <- HoltWinters(myts_Rest.of..World, gamma=FALSE)
accuracy(fit4.2$fitted, myts_Rest.of..World)
# triple exponential - models level, trend, and seasonal components
fit4.3 <- HoltWinters(myts_Rest.of..World)
accuracy(fit4.3$fitted, myts_Rest.of..World)

#ETS- Exponential method
fit5<-ets(myts_Rest.of..World)
accuracy(fit5$fitted, myts_Rest.of..World)
summary(fit5)
final5<-forecast(fit5, 4 ,level = c(90,95))
plot(final5)
#Thus for rest of world the lowest MAPE is for ETS method thus we use that to predict the next quaters' values.

##All The final graphs
attach(mtcars)
par(mfrow=c(3,2))
plot(final)
plot(final1)
plot(final2)
plot(final3)
plot(final5)

#The predicted results are stored in final,final1, final2,final3, final5


library(optparse)
library(lattice)
library(ggplot2)
library(caret)

parse.path <- function(path) {
    if (is.null(path)){
        print_help(opt_parser)
        stop("path is a mandatory argument", call.=FALSE)
    }
    return(path)
}

parse.target <- function(target) {
    if (is.null(target)){
        print_help(opt_parser)
        stop("target is a mandatory argument", call.=FALSE)
    }
    return(target)
}

load.data <- function(type, path, target) {
    x <- read.csv(paste(path, "/features_", type, ".csv", sep = ""))
    y <- read.csv(paste(path, "/labels_", type, ".csv", sep = ""))

    data = x
    data[length(x) + 1] = y

    #data[[target]] = as.factor(data[[target]])
    data = as.data.frame(data)
    return(data)
}

option_list = list(
    make_option(c("-p", "--path"), type="character", default=NULL, help="path to features and labels files", metavar="character"),
    make_option(c("-t", "--target"), type="character", default=NULL, help="target feature", metavar="character")
)

opt_parser = OptionParser(option_list=option_list)
opt = parse_args(opt_parser)

path = parse.path(opt$path)
target = parse.target(opt$target)

train = load.data("train", path, target)
test = load.data("test", path, target)

common <- intersect(names(train), names(test))
for (p in common) {
    if (class(train[[p]]) == "factor") {
        levels(test[[p]]) <- levels(train[[p]])
    }
}

#lr <- lm(    formula(paste(target, "~.")),    data=train)
#prediction <- predict(lr, test)
#summary = summary(prediction)
#rss <- c(crossprod(lr$residuals))
#mse <- rss / length(lr$residuals)
#rmse <- sqrt(mse)
#result <- paste("rmse:", rmse, ":max_error:", summary["Max."], sep = "")
#cat(result)

modelLR<- lm ( formula(paste(target, "~.")), data = train)
predictionsLR <- predict(modelLR, newdata = test)
test$lr = predictionsLR
rmseLR = sqrt(mean((as.numeric(test$lr)-as.numeric(test[[target]]))^2))
maxerrorLR = max(as.numeric(test$lr)-as.numeric(test[[target]]))

y_true = as.numeric(test[[target]])
rss = sum((predictionsLR - y_true) ^ 2)
tss = sum((y_true - mean(y_true)) ^ 2)
rsq = 1 - rss / tss

result <- paste("rmse:", rmseLR, ":r2_score:", rsq, ":max_error:", maxerrorLR, sep = "")
#result <- paste("a:", test[[target]][1], ":b:", test$lr[1], sep = "")
cat(result)


# Comandos básicos ----

# Ejecución de comandos e impresión
pi*3
log(234)

# La función de impresión
print(pi*3); print(pi*3, digits = 4) # El ; nos permite separar dos líneas
print(log(234), digits = 10)

# Controlar la salida de tablas
print(as.table(matrix(c(5:0,1,0,0), 3, 3)))
print(as.table(matrix(c(5:0,1,0,0), 3, 3)), zero.print = ".")

# La función cat para imprimit vectores
cat("Juan tiene", 17*pi, "años", "....\n")

# Asignando resultados a simbolos
set.seed(23)
edad <- round(rnorm(5, 25, 5), 2)
print(edad)

# Vector de nombres
nom <- c("Juan", "Pedro", "Ana", "Sol", "Juliana")

sink("names_output.txt")
# Usamos la funcipon cat para imprimir
for(i in 1:length(nom)) cat("La edad de", nom[i], "es", edad[i], "...\n")
sink()
# Listado del workspace
ls()

# Listado con caracteristicas
ls.str()

#rm(list=ls())
#rm(list=sedfiff(ls(), c("edad", "nom)))

# Borrando en workspace
#ls(); rm(edad) ls()

## Reportes ----

dta <- data.frame(edad, nom, gen=c(rep("Hombres",2), rep("Mujeres",3)))
resul <- tapply(dta$edad, dta$gen, mean)

sink("reporte1.txt")

print(resul)

summary(dta)
cat("Conclusión: La mayor media de edad se presenta en",
    names(resul[resul==max(resul)]),"(", max(resul), ")",
    ", mientras que la menor edad en",
    names(resul[resul==min(resul)]),"(", min(resul), ")")
sink()

write.csv(dta, file="datosEdad.csv", row.names=FALSE)

# Leyendo datos ----
dta2 <- read.csv("datosEdad.csv", header=T)
edad2 <- read.table("names_output.txt")
dta2;edad2

# Leyendo datos desde la una URL ----
url <- "https://raw.githubusercontent.com/Ciespinosa/datos_practicas/master/AMEBIASIS_LOJA.csv"

dtaAm <- read.csv2(url, header = TRUE, sep = ",")

head(dtaAm, 5)

write.csv(dtaAm, "./amebiasis.csv", row.names=T)

# Instalar paquetes ----
# install.packages("xlsx")

# Cargar paquete a memoria activa ----
library(xlsx)


#' @title estimParamsFromCI
#' @description unknown
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
    estimParamsFromCI = function( CL, probs=c(0.025, 0.975), distribution="gamma", method="L-BFGS-B", plot=FALSE) {
      # CL  is estimated/approximate 95% confidence bounds
      # probs = associated quantiles
      # pm0 = stating guess for parameters
      # theoreticalCI is theoretical probabilty function
      # pm are the parameters of the distributional function

      distrib =  paste('^',distribution, sep="" )

      if ( grepl( distrib, "normal", ignore.case=TRUE ) )  {
        CIoptim = function( pm, CL, probs) {
          theoreticalCI = pnorm( CL, mean=pm[1], sd = pm[2], log.p=TRUE )
          llik = ( theoreticalCI[1] - log( probs[1] ) )^2 + ( theoreticalCI[2] - log( probs[2] ) )^2
          return( llik )
        }
        pm0 = c( mean(CL), (CL[2]-CL[1])/3 )
        lower = c( -Inf, 1e-09 )
        resnames = c("mean", "sd")
        resdefault = c( 0, 1e5 )
        plotfn = function(x) dnorm(x, res[["mean"]], res[["sd"]])
        plot.range = CL + c( - pm0[2], + pm0[2] )
      }

      if ( grepl( distrib, "lognormal", ignore.case=TRUE ) )  {
        CIoptim = function( pm, CL, probs) {
          theoreticalCI =  plnorm( CL, meanlog=pm[1], sdlog=pm[2], log.p=TRUE  )
          llik = ( theoreticalCI[1] - log( probs[1] ) )^2 + ( theoreticalCI[2] - log( probs[2] ) )^2
          return( llik )
        }
        pm0 =  c( mean(log(CL)), log(CL[2])-log(CL[1])/3 )
        lower = c( -Inf, 1e-9 )
        resnames = c("meanlog", "sdlog")
        resdefault = c( 1e-3, 2 )
        plotfn =  function(x) dlnorm(x, res[["meanlog"]], res[["sdlog"]])
        plot.range = CL * c( 0.01, 1.5 )
      }

      if ( grepl( distrib, "gamma", ignore.case=TRUE ) )  {
        CIoptim = function( pm, CL, probs) {
          theoreticalCI = pgamma( CL, shape=pm[1], rate=pm[2], log.p=TRUE  )
          llik = ( theoreticalCI[1] - log( probs[1] ) )^2 + ( theoreticalCI[2] - log( probs[2] ) )^2
          return( llik )
        }
        pm0 = c( 0.5, 1/mean( CL ))
        lower = c( 1e-9, 1e-9 )
        resnames = c("shape", "rate")
        resdefault = c( 0.1, 0.01 )
        plotfn = function(x) dgamma(x, res[["shape"]], res[["rate"]])
        plot.range = CL * c( 0.01, 1.5 )
      }

      res = optim( pm0, CIoptim, CL=CL, probs=probs, lower=lower, method=method)
      if (res$convergence==0) {
        res = res$par
      } else {
        res= resdefault
      }

      names(res) = resnames

      if (plot) {
        curve( plotfn, plot.range[1], plot.range[2] )
        abline( v=CL[1], lty="dotted" )
        abline( v=CL[2], lty="dotted" )
      }

      return(res)

      # ----------
      debug = FALSE
      if (debug) {
        CL = c(0.5, 10) # initial guess of 95% CI
        estimParamsFromCI( CL, pm0=c(0.1, 0.1) , distribution="gamma", plot=T)
        #  E(X) = shape * scale = shape / rate = res[["shape"]] / res[["rate"]] = 3.69
        #  Var(X) = shape*scale^2 = shape / (rate^2) = res[["shape"]] / res[["rate"]] ^2 =  6.32
        qgamma( 0.025, res[["shape"]], res[["rate"]] )  # = 0.5
        qgamma( 0.975, res[["shape"]], res[["rate"]] )  # = 9.99
        curve( dgamma(x, res[["shape"]], res[["rate"]]), 0.0005, 100)

      }
    }


library(tidyverse)
library(reshape2)

housing = read.csv('./housing.csv')

head(housing)

summary(housing)

colnames(housing)

par(mfrow=c(2,5))

ggplot(data = melt(housing), mapping = aes(x = value)) +
    geom_histogram(bins = 30) + facet_wrap(~variable, scales = 'free_x')

housing$total_bedrooms[is.na(housing$total_bedrooms)] = median(housing$total_bedrooms , na.rm = TRUE)

housing$mean_bedrooms = housing$total_bedrooms/housing$households
housing$mean_rooms = housing$total_rooms/housing$households

drops = c('total_bedrooms', 'total_rooms')

housing = housing[ , !(names(housing) %in% drops)]

head(housing)

categories = unique(housing$ocean_proximity)
#split the categories off
cat_housing = data.frame(ocean_proximity = housing$ocean_proximity)

for(cat in categories){
    cat_housing[,cat] = rep(0, times= nrow(cat_housing))
}
head(cat_housing) #see the new columns on the right

for(i in 1:length(cat_housing$ocean_proximity)){
    cat = as.character(cat_housing$ocean_proximity[i])
    cat_housing[,cat][i] = 1
}

head(cat_housing)

cat_columns = names(cat_housing)
keep_columns = cat_columns[cat_columns != 'ocean_proximity']
cat_housing = select(cat_housing,one_of(keep_columns))

tail(cat_housing)

head(cat_housing)

colnames(housing)

drops = c('ocean_proximity','median_house_value')
housing_num =  housing[ , !(names(housing) %in% drops)]

head(housing_num)

scaled_housing_num = scale(housing_num)

head(scaled_housing_num)

head(housing_num)

cleaned_housing = cbind(cat_housing, scaled_housing_num, median_house_value=housing$median_house_value)

head(cleaned_housing)

?sample.int

set.seed(19) # Set a random seed so that same sample can be reproduced in future runs

sample = sample.int(n = nrow(cleaned_housing), size = floor(.8*nrow(cleaned_housing)), replace = F)
train = cleaned_housing[sample, ] #just the samples
test  = cleaned_housing[-sample, ] #everything but the samples

head(train)

nrow(train) + nrow(test) == nrow(cleaned_housing)

library('boot')

?cv.glm # note the K option for K fold cross validation

glm_house = glm(median_house_value~median_income+mean_rooms+population, data=cleaned_housing)
k_fold_cv_error = cv.glm(cleaned_housing , glm_house, K=5)

k_fold_cv_error$delta

glm_cv_rmse = sqrt(k_fold_cv_error$delta)[1]
glm_cv_rmse #off by about $83,000... it is a start

names(glm_house) #what parts of the model are callable?

glm_house$coefficients

library('randomForest')

?randomForest

names(train)

set.seed(1738)

train_y = train[,'median_house_value']
train_x = train[, names(train) !='median_house_value']

head(train_y)
head(train_x)

#some people like weird r format like this... I find it causes headaches
#rf_model = randomForest(median_house_value~. , data = train, ntree =500, importance = TRUE)

#I find this more clear
rf_model = randomForest(train_x, y = train_y , ntree = 500, importance = TRUE)

names(rf_model) #these are all the different things you can call from the model.

importance_dat = rf_model$importance
importance_dat

sorted_predictors = sort(importance_dat[,1], decreasing=TRUE)
sorted_predictors

oob_prediction = predict(rf_model) #leaving out a data source forces OOB predictions

#you may have noticed that this is avaliable using the $mse in the model options.
#but this way we learn stuff!
train_mse = mean(as.numeric((oob_prediction - train_y)^2))
oob_rmse = sqrt(train_mse)
oob_rmse

test_y = test[,'median_house_value']
test_x = test[, names(test) !='median_house_value']

y_pred = predict(rf_model , test_x)
test_mse = mean(((y_pred - test_y)^2))
test_rmse = sqrt(test_mse)
test_rmse


## Author: Sergio García Prado

rm(list = ls())

## a)
####

##
## Asymptotic distibution of p.hat as parameter p of Bin(n, p)
## p.hat ~ N(p, p * (1 - p) / n)
##

## b)
####

n <- 100
y <- 15
alpha <- 0.05

LogLikelihood <- function(p, y, n) {
  y * log(p) + (n - y) * log(1 - p)
}

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

opt <- optim(runif(1), NegativeLogLikelihood, y = y, n = n, hessian = TRUE,
             method = "Brent", lower=10e-3, upper = 1 - 10e-3)

(p.hat <- opt$par)
# 0.149999999993663

(p.hat.var <- 1 / opt$hessian[1])
# 0.001274903

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

## c)
####
p.zero <- 1 / 3

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

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

## d)

(LRT <- 2 * (LogLikelihood(p.hat, y, n) - LogLikelihood(p.zero, y, n)))
# 17.345619477233

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


#COIN
p = seq(0,1,0.01)
P10T = function(p) {11 * (1-p)^10}
#  11 to normalize to a density
plot(p, P10T(p),"l")
#
integrate(P10T, lower=0, upper=1)
#
# for the mean
pP10T = function(p)  11 * p * (1-p)^10
integrate(pP10T, lower=0, upper=1) #0.08333333 (1/12)
points(c(0, 0),c(0, 11), pch=16, col="red")
points(c(1/12, 1/12),c(0,  P10T(1/12)),pch=16,col="green")
# for the median
integrate(P10T, lower=0, upper=0.061069081)  #0.50000
points(c(0.061069081, 0.061069081),
     c(0,  P10T(0.061069081)), pch=16, col="blue")
legend(0.6,10, #location
      c("Mode","Mean","Median"), #labels
      cex= 1, #size
      pch=c(16,16,16), #filled circle
      col=c("red","green","blue")) #color


library(fda)
rangeval=c(0,1)
nbasis=5
# basisobj=create.monomial.basis(rangeval,nbasis)
#order 4
norder=4
#degree 3
#knots 9 (0,0,0,0,0.5,1,1,1,1) boundary point #knots=#order (typically)
breaks=c(0,0.5,1)
#breakpoints 3, 1 interior breakpoint
#single nodes per breakpoints
# basis functions = order + #interior knots 5
basisobj=create.bspline.basis(rangeval,nbasis,norder,breaks)
splinebasis=create.bspline.basis(c(0,10),13)
plot(splinebasis,xlab='t',ylab='Bspline basis functions B(t)',las=1,lwd=2)
# to make use of nth order derivatives, the order of spline basis need at least to be n+2
# evaluate the basis
eval.basis(1:0.1:10,splinebasis)
eval.basis(1:0.1:10,splinebasis,1)
##function creating
tempfd=fd(coefmat,daybasis65)
thatvec=eval.fd(tvec,thawfd)
D2thatvec=eval.fd(tvec,thawfd,2)
# linear differential operator
harmaccelLfd=vec2Lfd(c(0,omegaˆ2,0),c(0,365))
D2tempfd=deriv.fd(tempfd,2)
heightcoef=lsfit(basismat,heightmat,intercept=FALSE)$coef
# another way by smooth
heightList=smooth.basis(age,heightmat,heightbasis12)
##smoothing splines
#Rmatrix
Rmat=eval.penalty(tempbasis,harmaccelLfd)
#
norder=6
nbasis=length(age)+norder-2
heightbasis=create.bspline.basis(c(1,18),nbasis,norder,age)
heightfdPar=fdPar(heightbasis,4,0.01)
heightfd=smooth.basis(age,heightmat,heightfdPar)$fd
#constraint: positive
VanPrecPos=smooth.pos(day.5,VanPrec,WfdParobj)
#constraint: monotone
result=smooth.monotone(day,tib,WfdPar)
#constraint: probability density function
densityList=density.fd(RegPrec,WfdPar)
#statistics
meanlogprec=mean(logprec.fd)
stddevlogprec=std.fd(logprec.fd)
logprecvar.bifd=var.fd(logprec.fd)#eval.bifd

#functional pca
pca.fd(fdobj,nharm=2,harmfdPar=fdPar(fdobj),centerfns=TRUE)
#varmx simplify the expression reduce number of nonzero weight
logprec.rotpcalist=varmx.pca.fd(logprec.pcalist)
#functional canonical correlation
ccalist=cca.fd(temp.fd,logprec.fd,ncon,ccafdPar,ccafdPar)

#functional linear model (can also answer traditional correlation questions)
## scalar ~ Function
fRegressList=fRegress(annualprec,templist,betalist)
## Response as function: fANOVA or Fregresion {Concurrent model or more}
CVi=fRegress.CV(birdRegress,xfdlist,betalisti)#cross validation for lambda choice
## Fregresion beyond Concurrent model
linmodSmooth=linmod(NextYear,LastYear,betaList)
## t test on statistics (permutation)
tperm.fd(hgtmfd,hgtffd)
## F test on statistics (permutation)
F.res=Fperm.fd(temp36fd,regionList,betaList)
# principal differential analysis
pdaList=pda.fd(lipfd,bwtlist)


p_1calf=0.83
p_2calf=0.02
p_0calf=0.15

# event A=  dams gives birth to no healthy progeny ,1 healthy progeny,2 healthy progeny(n1=1,n2=1,n3=1)

P_eventA=(factorial(3)*(p_0calf^1*p_1calf^1*p_2calf^1))/(factorial(1)*factorial(1)*factorial(1))
print(P_eventA)
 # event B= 3 dams give birth to 1 healthy progeny(n1=0,n2=3,n3=0)
P_eventB=(factorial(3)*(p_0calf^0*p_1calf^3*p_2calf^0))/(factorial(0)*factorial(3)*factorial(0))
print(P_eventB)
#  the probability of obtaining exactly three healthy progeny from three dams
p=P_eventA+P_eventB
print(p)