# Examples 07 EM Algorithm
# ------------------------

# MLE
# ---

# This script estimates the allelic freq from genotype freq
# using Maximum Likelihood Estimation

nAA<-12
nAB<-35
nA0<-21
nBB<-15
nB0<-30
n00<-9
n<-nAA+nAB+nA0+nBB+nB0+n00

p<-(nAA+nA0/2+nAB/2)/n
q<-(nBB+nB0/2+nAB/2)/n
r<-(n00+nA0/2+nB0/2)/n
p;q;r

# EM Algorithm
# ------------

# This script estimates the allelic freq from phenotype freq
# using EM Algorithm

nA<-33  # nAA and nA0 unknown: nA=nAA+nA0
nB<-45  # nBB and nB0 unknown: nB=nBB+nB0
nAB<-35 # nAB known
n0<-9   # n00=n0 known

n<-nA+nB+nAB+n0

# STEP 1

# Parameters' vector par=(p,q). Note that r=1-p-q

# HYP 1 - Uniform Distribution
p<-1/3
q<-1/3
r<-1/3

# HYP 2 - Bernstein
p<-1-sqrt((n0+nB)/n)
q<-1-sqrt((n0+nA)/n)
r<-sqrt(n0/n)
p;q;r

# STEP 2 (E)

# Calculate approximate values for nAA, nA0, nBB, nB0
expected<-function(p,q,r){
nAA<-nA*p/(p+2*r)
nA0<-nA*2*r/(p+2*r)
nBB<-nB*q/(q+2*r)
nB0<-nB*2*r/(q+2*r)
c(nAA,nA0,nBB,nB0)
}
expected(p,q,r)

# STEP 3 (M)

# Update p, q and r
param<-function(nAA,nA0,nBB,nB0){
p<-(2*nAA+nA0+nAB)/(2*n)
q<-(2*nBB+nB0+nAB)/(2*n)
r<-(2*n0+nA0+nB0)/(2*n)
c(p,q,r)
}
param(nAA,nA0,nBB,nB0)

# STEP 4 e 5

# EM ALGORITHM - iterative procedure

i<-0
er<-1
erro<-10^(-5)

while(sum(er>=erro)>0)
{
 # Step E
 e<-expected(p,q,r)
 # Step M
 par<-param(e[1],e[2],e[3],e[4])
 # STOP criteria
 er<-abs(c(p,q,r)-c(par[1],par[2],par[3]))
 i<-i+1
 p<-par[1]; q<-par[2]; r<-par[3]
 cat(i,p,q,r,"\n") # print all the values obtained in each iterate.
}

cat("\nObtained solution after ",i," iterations:\n
p* =",p,
"\nq* =",q,
"\nr* =",r,"\n")

# Example of Application - nudge
# ------------------------------

# Download the datafiles from the web

# http://bioinf.wehi.edu.au/limma/
# go to the end of the webpage
# download the Zebrafish data - zip.file
# working directory - swirl
# Chip: 4x4 blocks, 22 rows and 24 col, each

# Change directory to folder 'Swirl'
# install and load package limma in order to read the data
source("http://bioconductor.org/biocLite.R")
biocLite("limma")
library(limma)

# Don't forget to download the data, as described previously
swirl <- readTargets("SwirlSample.txt")
swirl
RG <- read.maimages(swirl$FileName, source="spot")
RG
RG$genes <- readGAL("fish.gal")
# Get some information about the files
head(RG$genes)
RG$printer <- getLayout(RG$genes)
RG$printer
show(RG)
summary(RG$R)

# Create the data matrix
lr <- matrix(nrow=8448,ncol=4)
lr[,1] <- log2(RG$R[,1])-log2(RG$G[,1])
lr[,2] <- log2(RG$G[,2])-log2(RG$R[,2])
lr[,3] <- log2(RG$R[,3])-log2(RG$G[,3])
lr[,4] <- log2(RG$G[,4])-log2(RG$R[,4])
li <- log2(RG$R)+log2(RG$G)

# Install and load package nudge
biocLite("nudge")
library(nudge)

# Run packade nudge
result <- nudge1(logratio = lr,logintensity = li, dye.swap = T)

names(result)
result$mu
result$sigma
result$mixprob
result$a
result$b
result$iter

# Top 20 genes with the highest probability of being DE
s <- sort(result$pdiff, decreasing = T, index.return = T)
rownames(lr) <- RG$genes$Name
cbind(rownames(lr)[s$ix[1:20]], round(s$x[1:20], 2))

# number of genes with a probability of DE, greater than 0.5
thresh <- 0.5
sum(result$pdiff >= thresh)


## Fibonacci word/fractal  2/20/17 aev
## Create Fibonacci word order n
fibow <- function(n) {
  t2="0"; t1="01"; t="";
  if(n<2) {n=2}
  for (i in 2:n) {t=paste0(t1,t2); t2=t1; t1=t}
  return(t)
}
## Plot Fibonacci word/fractal:
## n - word order, w - width, h - height, d - segment size, clr - color.
pfibofractal <- function(n, w, h, d, clr) {
  dx=d; x=y=x2=y2=tx=dy=nr=0;
  if(n<2) {n=2}
  fw=fibow(n); nf=nchar(fw);
  pf = paste0("FiboFractR", n, ".png");
  ttl=paste0("Fibonacci word/fractal, n=",n);
  cat(ttl,"nf=", nf, "pf=", pf,"\n");
  plot(NA, xlim=c(0,w), ylim=c(-h,0), xlab="", ylab="", main=ttl)
  for (i in 1:nf) {
    fwi=substr(fw, i, i);
    x2=x+dx; y2=y+dy;
    segments(x, y, x2, y2, col=clr); x=x2; y=y2;
    if(fwi=="0") {tx=dx; nr=i%%2;
      if(nr==0) {dx=-dy;dy=tx} else {dx=dy;dy=-tx}}
  }
  dev.copy(png, filename=pf, width=w, height=h); # plot to png-file
  dev.off(); graphics.off();  # Cleaning
}

## Executing:
pfibofractal(23, 1000, 1000, 1, "navy")
pfibofractal(25, 2300, 1000, 1, "red")


alpha=0.025
pie=0.5
E=0.03
z.alpha=qnorm(1-alpha)
#  sample size necessary to achieve this accuracy
n=((z.alpha^2)*pie*(1-pie))/E^2
print(ceiling(n))
# 1,068 programs would need to be tested in order to be 95% confident that
#the estimate of pie is within .03 of the actual value of pie

pie=0.8
n=((z.alpha^2)*pie*(1-pie))/E^2
print(n)
#  if the designer was fairly certain that the actual value of pie was at least .80,
#then the required sample size can be greatly reduced.


# a3-using-data

# Before you get started, set your working directory using the Session menu

###################### Data Frame Manipulation (24 POINTS) #####################

# Create a vector `students` holding 1,000 values representing students
# They should have the values "Student 1", "Student 2",..., "Student 1000"
students <- paste("Student", 1:1000, " ")

# Create a vector `math_grades` that holds 1000 random values in it
# (these represent grades in a math course)
# These values should be normally distributed with a mean of 88 and a
# standard deviation of 10
math_grades <- rnorm(1000, mean = 88, sd = 10)

# Replace any values in the `math_grades vector` that are above 100 with
# the number 100
math_grades <- ifelse(math_grades > 100, 100, math_grades)
# Create a vector `spanish_grades` that holds 1000 random values in it
# (these represent grades in a spanish course)
# These values should be normally distributed with a mean of 85 and a
# standard deviation of 12
spanish_grades <- rnorm(1000, mean = 85, sd = 12 )

# Replace any values in the `spanish_grades` that are above 100 with
# the number 100
spanish_grades <- ifelse(spanish_grades > 100, 100, spanish_grades)

# Create a data.frame variable `grades` by combining
# the vectors `students`, `math_grades`, and `spanish_grades`
# Make sure to properly handle strings
grades <- data.frame(students, math_grades, spanish_grades)

# Create a variable `num_students` that contains the
# number of rows in your dataframe `grades`
num_students <- nrow(grades)
# Create a variable `num_courses` that contains the number of columns
# in your dataframe `grades` minus one (b/c of their names)
num_courses <- ncol(grades)
# Add a new column `grade_diff` to your dataframe, which is equal to
# `students$math_grades` minus `students$spanish_grades`
grades$grade_diff <- (math_grades - spanish_grades)

# Add another column `better_at_math` as a boolean (TRUE/FALSE) variable that
# indicates that a student got a better grade in math
grades$better_at_math <- math_grades > spanish_grades
# Create a variable `num_better_at_math` that is the number
# (i.e., one numeric value) of students better at math
num_better_at_math <- length(grades$better_at_math[grades$better_at_math == TRUE] )
print(num_better_at_math)
# Write your `grades` dataframe to a new .csv file inside your data/ directory
# with the filename `grades.csv`. Make sure *not* to write row names.
# (you'll need to create the `data/` directory, which you can do outside of R)
write.csv(file = "data", x = grades)

########################### Built in R Data (28 points) ########################

# In this section, you'll work with the `Titanic` data set, which
# is built into the R environment.
# This data set actually loads in a format called a *table*
# See https://cran.r-project.org/web/packages/data.table/data.table.pdf
# Use the `is.data.frame()` function to test if it is a table
is.data.frame(Titanic)

# Create a variable `titanic_df` by converting `Titanic` into a data frame;
# you can use the `data.frame()` function or `as.data.frame()`
# Be sure to **not** treat strings as factors!
titanic_df <- data.frame(Titanic, stringsAsFactors = FALSE)

# It's important to understand the _meaning_ of each column before analyzing it
# NOTE: Seek to fully understand the structure of the data before
# proceeding (Hint: How is the variable, Freq, related to the other variables?)
# Using comments below, describe what information is stored in each column
# For categorical variables, list all possible values
# Class: Describes which class of passenger is being described, (1st class is the most luxurious, 2nd is less luxurious, and 3rd is the least luxurious)
# Sex: Describes the gender of the passengers
# Age: Describes the age of the passengers
# Survived: Whether they survived the sinking of the Titanic
# Freq: How many passengers are being described for each condition

# Create a variable `children` that are the *only* the rows of the data frame
# with information about the number children on the Titanic.
children <- titanic_df[titanic_df$Age == "Child",]

# Create a variable `num_children` that is the total number of children.
# Hint: remember the `sum()` function!
num_children <- sum(children$Freq)

# Create a variable `most_lost` which has the *row* with the
# largest absolute number of losses (people who did not survive).
# Tip: if you want, you can use multiple statements (lines of code)
# if you find that helpful to create this variable.
most_lost <-  max(titanic_df$Freq)
most_lost <- titanic_df[titanic_df$Freq == most_lost,]

# Define a function called `survival_rate()` that takes in two arguments:
# - a ticket class (e.g., "1st", "2nd"), and
# - the dataframe itself (it's good practice to explicitly pass in data frames)
# This function should return the following
# sentence that states the *survival rate* (# survived / # in group)
# of adult men and "women and children" in that ticketing class.
# It should read (for example):
# Of Crew class, 87% of women and children survived and 22% of men survived.
# The approach you take to generating the sentence to return is up to you.
# A good solution will likely utilize filtering to produce the required data.
# You must round values and present them as percentages in the sentence.
##ticket_class <- c("1st", "2nd", "3rd", "Crew")
#print(ticket_class)
View(titanic_df)
survival_rate <- function(ticket_class, df){
  male_children <- subset(titanic_df, Class == ticket_class & Sex == "Male" & Age == "Child")
  women <- subset(titanic_df, Class == ticket_class & Sex == "Female")
  survived_women <- subset(women, Survived == "Yes")
  survived_male_children <- subset(male_children, Survived == "Yes")
  survived_women_and_children <- sum(survived_women$Freq, survived_male_children$Freq)
  died_male_children <- subset(male_children, Survived == "No")
  died_women <- subset(women, Survived == "No")
  died_women_and_children <- sum(died_male_children$Freq, died_women$Freq)
  total_woman_and_children <- sum(died_women_and_children, survived_women_and_children)
  percent_died_women_and_children <- round((100 * (died_women_and_children / total_woman_and_children)), digits = 0)
  percent_survived_women_and_children <- round((100 * (survived_women_and_children / total_woman_and_children)), digits = 0)
  male_adults <- subset(titanic_df, Class == ticket_class & Sex == "Male" & Age == "Adult")
  survived_male_adult <- subset(male_adults, Survived == "Yes")
  died_male_adult <- subset(male_adults, Survived == "No")
  total_male_adult <- sum(survived_male_adult$Freq, died_male_adult$Freq)
  percent_died_male_adult <- round((100 * (died_male_adult$Freq / total_male_adult)), digits = 0)
  percent_survived_male_adult <- round((100 * (survived_male_adult$Freq / total_male_adult)), digits = 0)
  final <- paste0("Of ", ticket_class, " class, ", percent_survived_women_and_children, "% of women and children survived and ", percent_survived_male_adult, "% of men survived.")
  return(final)
}

# Create variables `first_survived`, `second_survived`, `third_survived` and
# `crew_survived` by passing each class and the `titanic_df` data frame
# to your `survival_rate` function
# (`Crew`, `1st`, `2nd`, and `3rd`), passing int
first_survived <- survival_rate("1st", titanic_df)
second_survived <- survival_rate("2nd", titanic_df)
third_survived <- survival_rate("3rd", titanic_df)
crew_survived <- survival_rate("Crew", titanic_df)

# What notable differences do you observe in the survival rates across classes?
# Note at least 2 observations.
#1. As the passenger class decreased, (for example, 1st class to 3rd class), the survival rate of men
# decreased besides the third class.
#2. However, more women, children, and men survived from the Crew class than Third Class

# What notable differences do you observe in the survival rates between the
# women and children versus the men in each group?
# Note at least 2 observations.
#1. In every ticket class, more women and children survived than men.
#2. The least women and children survived in 3rd class yet more men survived in 3rd class than 2nd class

########################### Reading in Data (43 points)#########################
# In this section, you'll work with .csv data of life expectancy by country
# First, you should download a .csv file of Life Expectancy data from GapMinder:
# https://www.gapminder.org/data/
# You should save the .csv file into your `data` directory

# Before getting started, you should explore the GapMinder website to understand
# the *original* source of the data (e.g., who calculated these estimates)
# Place a brief summary of the each data source here (e.g., 1 - 2 sentences
# per data source)
# 1st Data source: Period of 1800 - 1970, based on 100 sources compiled by Mattias Lindgren. He also
# made rough predictions of sudden dips in life expectany.
# 2nd Data Source: Period of 1970 - 2016, main source: IMHE, (Institute for Health Metrics and
# Evaluation). Published September 2017, University of Washington, Seattle - IMHE uses data to prevent child deaths.
# 3rd Data Source: Period of 2017 - 2099. This data source uses UN forecasts from the World
# Population Prospects 2017. Published in a file with Annually interpolated demograpic indicators.

# Using the `read.csv` function, read the life_expectancy_years.csv file into
# a variable called `life_exp`. Makes sure not to read strings as factors
life_exp <- read.csv("life_expectancy_years.csv" , header = TRUE, stringsAsFactors = FALSE)
# Write a function `get_col_mean()` that takes in a column name and a data frame
# and returns the mean of that column. Make sure to properly handle NA values
#print(titanic_df)
get_col_mean <- function(df, column){
  mean_of_col <- mean(df[[column]], na.rm = TRUE)
  mean_of_col
}
# Create a list `col_means` that has the mean value of each column in the
# data frame (except the `Country` column). You should use your function above.
  minus_country <- names(life_exp)
  minus_country <- minus_country[minus_country != country]
  col_means <- lapply(minus_country, get_col_mean, df = life_exp)

# Create a variable `avg_diff` that holds the difference in average country life
# expectancy between 1800 and 2018?

avg_diff <- (get_col_mean(life_exp, "X2018")) - (get_col_mean(life_exp, "X1800"))

# Create a column `life_exp$change` that is the change
# in life expectancy from 2000 to 2018. Increases in life expectancy should
# be *positive*
change <- (get_col_mean(life_exp, "X2018")) - (get_col_mean(life_exp, "X2000"))
life_exp$change <- change
# Create a variable `most_improved` that is the *name* of the country
# with the largest gain in life expectancy
# Make sure to filter NA values!
most_improved_vector <- unlist(col_means)
most_improved_num <- most_improved_vector[!is.na(most_improved_vector)]
most_improved_num <- max(most_improved_num)

# Create a variable `num_small_gain` that has the *number* of countries
# whose life expectance has improved less than 1 year between 2000 and 2018
# Make sure to filter NA values!
  num_small_gains <- avg_diff < 1

# Write a function `country_change()` that takes in a country's name,
# two (numeric) years, and the `life_exp` dataframe as parameters.
# It should return the phrase:
# "Between YEAR1 and YEAR2, the life expectancy in COUNTRY went DIRECTION by
# SOME_YEARS years".
# Make sure to properly indictate the DIRECTION as "up" or "down"

country_change <- function(country_name, year1, year2, life_exp){
  selected_country <- subset(life_exp, country == country_name)
  return("Between YEAR1 and YEAR2, the life expectancy in COUNTRY went DIRECTION by SOME_YEARS")
}
tee <- country_change("Andorra", "1880", "1912", life_exp)
# Using your `country_change()` function, create a variable `sweden_change`
# that is the change in life expectancy from 1960 to 1990 in Sweden
  sweden_change <- country_change("Sweden", "X1960", "X1990", life_exp)

# Write a function `compare_change()` that takes in two country names and your
# `life_exp` data frame as parameters, and returns a sentence that describes
# their change in life expectancy from 2000 to 2018 (the `change` column)
# For example, if you passed the values "China", and "Bolivia" to you function,
# It would return this:
# "The country with the bigger change in life expectancy was China (gain=6.9),
#  whose life expectancy grew by 0.6 years more than Bolivia's (gain=6.3)."
# Make sure to round your numbers to one digit (though only after calculations!)
compare_change <- function(country1, country2, df){
  country1_values <- subset(life_exp, country == country1,)
  country2_values <- subset(life_exp, country == country2,)
  country1_values <- get_col_mean(country1_values, "X2000")
  country2_values <- get_col_mean(country2_values, "X2000")

}

# Using your `bigger_change()` function, create a variable `usa_or_france`
# that describes who had a larger gain in life expectancy (the U.S. or France)
  usa_or_france <- max(bigger_change("United States", "China", life_exp))

# Write your `life_exp` data.frame to a new .csv file to your
# data/ directory with the filename `life_exp_with_change.csv`.
# Make sure not to write row names.
write.csv(life_exp, "life_exp_with_change.csv", row.names = FALSE)


findfactors <- function(n) {
  a <- NULL
  if (n > 1) {
    while (n %% 2 == 0) {
      a <- c(a, 2)
      n <- n %/% 2
    }
    k <- 3
    while (k * k <= n) {
      while (n %% k == 0) {
        a <- c(a, k)
        n <- n %/% k
      }
      k <- k + 2
    }
    if (n > 1) a <- c(a, n)
  }
  a
}


library(glue)
library(gtools)
library(tree)
printf <- defmacro(str, expr = {print(glue(str))})

# helper functions
plot_tree <- function(tree, title, ...) {
  plot(tree, ...)
  title(title)
}

print_misclass <- function(lst, title) {
  printf("\n\n -- {title} tree settings --")
  printf("training misclass => {lst$train_misclass}")
  printf("validation misclass => {lst$valid_misclass}")
}

TPR <- function(confusion_matrix) {
  # Calculate true positive rate
  return(confusion_matrix["yes", "yes"] / sum(confusion_matrix["yes", ]))
}

FPR <- function(confusion_matrix) {
  # Calculate false positive rate
  return(confusion_matrix["no", "yes"] / sum(confusion_matrix["no", ]))
}

model_evaluation_metrics <- function(confusion_matrix) {
  # Uses a confusion matrix to calculate evaluation metrics
  lst = list()
  lst$accuracy = sum(diag(confusion_matrix)) / sum(confusion_matrix)
  lst$TPR = TPR(confusion_matrix)
  lst$recall = lst$TPR
  lst$FPR = FPR(confusion_matrix)
  lst$precision = confusion_matrix["yes", "yes"] / sum(confusion_matrix[, "yes"])
  lst$f1_score = (2 * lst$precision * lst$recall) / (lst$precision + lst$recall)
  return(lst)
}

misclass <- function(x, x1){
  return(1 - sum(diag(table(x, x1))) / length(x))
}
###

# import data and remove not relevant data column
data = read.csv("bank-full.csv", sep=";", stringsAsFactors=TRUE)
data = data[, -match(c("duration"), names(data))] # Remove duration column

# split the data 40 30 30 for train validation test
n = dim(data)[1]
set.seed(12345)
id = sample(1:n, floor(n*0.4))
train = data[id, ]
id1 = setdiff(1:n, id)
set.seed(12345)
id2 = sample(id1, floor(n*0.3))
valid = data[id2, ]
id3 = setdiff(id1, id2)
test = data[id3, ]

# Train and fit decision trees to taring data
train_decision_tree <- function(train, valid, ...) {
  tree = tree(y~., train, ...) # ... == args/kwargs in python
  train_fit = predict(tree, train, type="class")
  valid_fit = predict(tree, valid, type="class")
  train_misclass = misclass(train_fit, train$y)
  valid_misclass = misclass(valid_fit, valid$y)
  return(list(tree=tree, train_fit=train_fit, valid_fit=valid_fit,
              train_misclass=train_misclass, valid_misclass=valid_misclass))
}

# train three trees with different given parameters
default = train_decision_tree(train, valid)
minsize = train_decision_tree(train, valid, minsize=7000)
mindev = train_decision_tree(train, valid, mindev=0.0005)

print_misclass(default, title="default")
print_misclass(minsize, title="minsize = 7000")
print_misclass(mindev, title="mindev = 0.0005")

# plot trees for visual comparison
par(mfrow = c(1, 3))
plot_tree(default$tree, title="default")
plot_tree(minsize$tree, title="minsize = 7000")
plot_tree(mindev$tree, title="mindev = 0.0005")

# Prune tree to different number of leaves and calculate deviance
# for both training and test data then plot a curve.
range = 2:50 # Range of leaves to test
score = list()
for(i in range) {
  pruned = prune.tree(mindev$tree, best=i) # Prune tree to i leaves
  predicted = predict(pruned, valid, type="tree") # type="tree" => return a tree object
  score$train[i] = deviance(pruned) / length(train$y) # divide by length to scale deviance
  score$valid[i] = deviance(predicted) / length(valid$y)
}
par(mfrow = c(1, 1))
plot(range, score$train[range], type="b", col="red", ylim=c(0.55, 0.7),
     ylab="average deviance per datapoint", xlab="number of leaves")
points(range, score$valid[range], type="b", col="blue")
legend("topright", legend = c("train", "valid"), col = c("red","blue"), pch = c(1, 1))

# Choose tree with smallest validation deviance
optimal = list(tree = prune.tree(mindev$tree, best=which.min(score$valid)))
print(optimal$tree)

# perform classification using the optimal tree
optimal$fit = predict(optimal$tree, test, type="class")
optimal$confusion_matrix = table(test$y, optimal$fit)
# list concatenation => add evaluation metrics to list named optimal
optimal = c(optimal, model_evaluation_metrics(optimal$confusion_matrix))

printf("\n\n -- optimal number of leaves --")
printf("accuracy => {optimal$accuracy}")
printf("F1 score => {optimal$f1_score}") # F1 score better as we have imbalanced classes
print(optimal$confusion_matrix)

# Use formula from slides to add a loss matrix
# if p(y="no"|x) / p(y="yes"|x) > 5 => classify as "no"
loss = list(probs = predict(optimal$tree, test))
loss$fit = ifelse(loss$probs[,"no"] / loss$probs[,"yes"] > 5, "no", "yes")
loss$confusion_matrix = table(test$y, loss$fit)
loss = c(loss, model_evaluation_metrics(loss$confusion_matrix))

printf("\n\n -- custom loss matrix --")
printf("accuracy => {loss$accuracy}")
printf("F1 score => {loss$f1_score}")
print(loss$confusion_matrix)

logistic_regression_model = glm(y~., train, family="binomial")
# Get the probabilities from the logistic regression model
log = list(probs = predict(logistic_regression_model, test, type="response"))
# Take probability of yes classification from prediction
optimal$probs <- predict(optimal$tree, test)[,"yes"]
for (pi in seq(0.05, 0.95, 0.05)) {
  # Classify using => class = "yes" if p(y="yes"|x) > pi else "no"
  # Optimal tree
  classification = factor(ifelse(optimal$probs > pi, "yes", "no"), levels = c("no", "yes"))
  confusion_matrix = table(test$y, classification)
  optimal$TPR_values = append(optimal$TPR_values, TPR(confusion_matrix))
  optimal$FPR_values = append(optimal$FPR_values, FPR(confusion_matrix))
  # Logistic regression
  classification = factor(ifelse(log$probs > pi, "yes", "no"), levels = c("no", "yes"))
  confusion_matrix = table(test$y, classification)
  log$TPR_values = append(log$TPR_values, TPR(confusion_matrix))
  log$FPR_values = append(log$FPR_values, FPR(confusion_matrix))
}
# ROC curve
plot(optimal$FPR_values, optimal$TPR_values, type="b", col="red", ylim=c(0, 1),
     xlim=c(0, 1), ylab="True positive rate", xlab="False positive rate")
lines(log$FPR_values, log$TPR_values, type="b", col="blue")
abline(a=0, b=1, col="green", lty=2)
legend("bottomright", legend = c("Optimal tree", "Logistic regression", "Random guess"),
       col = c("red","blue","green"), pch = c(1, 1, 1))


# Problemas y post-estimation: multicolinealidad perfecta,
# heteroskedasticidad, no linearidad, outliers, no normalidad de residuos, auto-correlación

#################################################################
cat("\014")
rm(list=ls())
graphics.off()

#################################################################
# Motivacion
#################################################################
# (1) Los modelos lineales deben ser...bueno, "lineales." Es decir,
# OLS asume que la relacion entre "X" e "Y" puede ser representada
# por una linea recta. Podemos "desafiar" este concepto de "linea recta"?

# (2) Los modelos lineales asumen "varianza constante entre los errores".
# Como podemos checkear ese supuesto? Como lo podemos arreglar? Como lo podemos
# derivar matematicamente? Que relacion tiene con los outliers?
# Var Constante: Homoesquedasticidad.
# Var no-const: Heteroskedasticity.

# (3) Como podemos detectar outliers? Como podemos solucionar este problema?

# (4) Por que el aporte de una variable independiente en la dependiente
# podria NO SER lineal, es decir, curvilinea? Este punto es importante. Que cosas
# en la sociedad NO SON LINEALES?

#################################################################
# Linearidad y no Linearidad
#################################################################
library(car)
data(Prestige)

options(scipen = 100000)

modelo.lineal <- lm(prestige ~ income + education + women, data=Prestige)
summary(modelo.lineal)

# Plotear errores: manera "artesanal"
plot(modelo.lineal$fitted.values, modelo.lineal$residuals)

# Plotiemos los betas (uno por uno), y veamos:
## (1) Cuanto error aportan al modelo.
## (2) Cuan lineal es la relacion existe entre X e Y.

crPlot(modelo.lineal, "income") # Problema.
crPlot(modelo.lineal, "education") # no es exactamente lineal, pero es super tolerable.
crPlot(modelo.lineal, "women") # no hay relacion, pero no hay problemas con los residuos.

# (1) El "aporte" de cada variable independiente debe ser lineal, es decir, una
# linea recta. Esto es la parte del "componente" (en azul).

# (2) El error de cada parte del "componente" debe ser lineal y normalmente
# distribuido. Esta es la parte del "residuo" (en morado).

# Estimemos una regresion no lineal
modelo.no.lineal = lm(prestige ~ poly(income, 3) + poly(education, 2) + women, data = Prestige)
summary(modelo.no.lineal)

# crPlot con el polynomial
crPlot(modelo.no.lineal, "poly(income, 3)")
hist(modelo.no.lineal$residuals)
mean(modelo.no.lineal$residuals)
# Ahora ya no hay problema con esta variable. Ademas, hemos mejorado nuestro error total.

# Comparemos los errores
## (1) Que modelo tendra menos errores y por que?

# resumamos los residuos
summary(summary(modelo.lineal)$residuals)
summary(summary(modelo.no.lineal)$residuals)
# Una distribucion normal (como se supone que debieran ser los errores): media = mediana = moda = 0. Y ESTE NO ES EL CASO. (MEDIA ES DIFERENTE DE MEDIANA).

# grafiquemos los residuos
library(lattice)
xyplot(modelo.lineal$residuals ~ modelo.lineal$fitted.values, type=c("smooth", "p")) # mal.
xyplot(modelo.no.lineal$residuals ~ Prestige$prestige, type=c("smooth", "p")) # algo mejor.

# Grafiquemos el "aporte" NO LINEAL de las variables independientes
library(effects)
plot(effect("poly(income, 3)", modelo.no.lineal)) # es el menos lineal de todos
plot(effect("poly(education, 2)", modelo.no.lineal)) # es el mas lineal.

# El punto es que nuestros modelos estan disenados para ser LINEALES.
# Aunque hemos usado polinomios para calzar mejor los datos, seguimos teniendo residuos heteroesquedasticos.
# La manera en que podemos solucionar este tipo de problemas, es recurriendo
# a transformaciones.

# Nuestro problema es el siguiente: debemos estimar un modelo lineal, pero
# la relacion entre X e Y no es lineal. Entonces, como podemos estimar modelos
# lineales cuando tenemos relaciones no lineales?

#################################################################
# Linearidad y no Linearidad: Resolviendo el problema via transformaciones
#################################################################

# (1) Box-Tidwell Test
## Estimar usando este test a cuanto tenemos que elevar nuestras variables
## problematicas, en este caso ingresos (income).

boxTidwell(prestige ~ income, ~ education + women, data=Prestige)
# OK. Sugiere que debemos elevar income al "0.08073"

# estimemos un modelo nuevo, pero con "income" transformado
Prestige$income.transformado = Prestige$income^0.08073 # transformemos income

# veamos como se ve income "normal" y "transformado"
xyplot(Prestige$prestige ~ Prestige$income, type=c("smooth", "p")) # el "normal" esta mal porque no es lineal.
xyplot(Prestige$prestige ~ Prestige$income.transformado, type=c("smooth", "p")) # el transformado arregla el problema porque ahora si que tenemos una relacion lineal entre Y y X.

# OK. Ahora estimemos un nuevo modelo ocupando nuestro "income" transformado, y
# veamos si soluciona el problema de fondo (es decir, no tener varianza constante en los errores).
# Al final del dia, ese es el problema de no tener linearidad entre uno de los Xs y nuestra Y.

# modelo con "ingresos" (income) transformado
modelo.no.lineal.box.tid = lm(prestige ~ income.transformado + education + women, data=Prestige)

# interpretacion
plot(effect("income.transformado", modelo.no.lineal.box.tid)) # es el menos lineal de todos

# Hagamos un scatter entre los residuos y cada una de las x (transformada y normal)
xyplot(modelo.no.lineal.box.tid$residuals ~ modelo.no.lineal.box.tid$fitted.values, type=c("smooth", "p")) # bien.
xyplot(modelo.lineal$residuals ~ modelo.lineal$fitted.values, type=c("smooth", "p")) # mal.

# Resumen de los residuos: modelo con "income" transformado y normal.
summary(summary(modelo.no.lineal.box.tid)$residuals) # Mucho mejor residuos.
summary(summary(modelo.lineal)$residuals) # No bien.

# graficar la densidad (integral) de los residuos
library(lattice)
densityplot((modelo.no.lineal.box.tid)$residuals) # bien
densityplot((modelo.lineal)$residuals) # mas o menos no mas...

# (2) Tomar el log de la variable no lineal (en este caso, "ingresos" o "income")
Prestige$log.income = log(Prestige$income)

## veamos como se ve cada variable
library(lattice)
densityplot(Prestige$income)
densityplot(Prestige$log.income)

# modelo
modelo.log.income = lm(prestige ~ log.income + education + women, data=Prestige)

# resumen del modelo
summary(modelo.log.income)
# (1) Como interpretamos este tipo de modelos (con una X logeada)?

# Hagamos un scatter entre los residuos y cada una de las x (transformada y normal)
xyplot(modelo.log.income$residuals ~ modelo.log.income$fitted.values, type=c("smooth", "p")) # bien.
xyplot(modelo.lineal$residuals ~ modelo.lineal$fitted.values, type=c("smooth", "p")) # mal.

# Resumen de los residuos: modelo con "income" transformado y normal.
summary(summary(modelo.log.income)$residuals)
summary(summary(modelo.lineal)$residuals) # OK---hemos mejorado algo.

#################################################################
# Outliers
#################################################################

# Parte del motivo de que algunas veces tenemos varianza no constante en los
# residuos, es por la presencia de outliers ("observaciones inusuales").

# Que podemos hacer respecto a esto?
## (1) Borrar los outliers?
## (2) Como detectamos los outliers?

# Existen dos tipos de outliers: leverage e influence.

#################################################################
# Influence: observaciones que tiran la linea de regresion hacia arriba/abajo
#################################################################

# Demostrar ejemplo en la pizarra.

library(foreign) # significa "foraneo"
load(url("https://github.com/hbahamonde/OLS/raw/master/Datasets/data.rdata"))
dat = data_reg

# veamos como se ven los datos
head(dat)

# estimemos modelo 3 de la tarea # 5
m3 = lm(y3 ~ x3, dat)

# veamos como se ven los problemas de "influence"
library(lattice)
xyplot(m3$residuals ~ m3$fitted.values, type=c("smooth", "p")) # residuos no tienen varianza constante.
# Pero en especial, hay un punto con mucha "influencia"

# Una ruta es la inspeccion visual. Tratemos de hacer algo mas sistematico.
# Calculemos el "Cook's Distance" que es una medida de cuantificar cuanta "influencia"
# tiene cada punto.

options(scipen=100000000) # increases threshold for scientific notation (it's got very small numbers).

dat$cooks.d <- cooks.distance(m3)

# veamos que es el Cook's D.
dat # Por cada dato (o punto), tenemos un Cook's D. Fijate que la observacion numero 3 tiene mucho Cook's D.
# ESE ES NUESTRO OUTLIER.

# grafiquemos los Cooks'D
# install.packages("olsrr")
library(olsrr)
ols_plot_cooksd_chart(m3)

# Ver el error
dat$residuals = as.vector(m3$residuals)
dat

# El punto de quiebre es 4/n.
4/nrow(dat) # Lo que esta arriba de 0.3636364 (arriba de la linea roja, es influence).

#################################################################
# Leverage: observaciones que tiran la linea de regresion hacia el lado izq/der
#################################################################

# Demostrar ejemplo en la pizarra.

# Estimemos un modelo con leverage
autos <- lm(mpg ~ wt, data = mtcars)
summary(autos)

# ahora, grafiquemos lo que vemos vs. lo que predecimos
plot(autos$fitted, mtcars$mpg) # Donde esta el problema?

# Dado que SI tenemos un problema, nuestro error debiera seguir algun patron.
# Es decir, debieramos NO ver una nube dispersa, y la linea debiera ser curva. Veamos.
xyplot(autos$residuals ~ autos$fitted.values, type=c("smooth", "p")) # residuos no tienen varianza constante.

# Ocupemos una funcion de R para detectar observaciones con leverage.
ols_plot_resid_stud_fit(autos) # OK. Son las mismas 3 observaciones que habiamos visto (17, 18 y 20)

# armemos una base de datos, solo para ver que observaciones/marcas son...
data.frame(
        res = autos$residuals,
        marca = rownames(mtcars),
        fila = 1:nrow(mtcars)
        )

#################################################################
# Errores Estandard Inflados: Multicolinearidad ("imperfecta") y Multicolinearidad Perfecta
#################################################################

# Apagar not scient.
options(scipen = 100000)

# Inventemos las variables independientes
set.seed(2020)
x1 = rnorm(1000, 10)
x2 = rnorm(1000, 20)
x3 = (x2*x2)/1000 # x3 es una combinacion lineal de x2

# Definamos que, como debiera ser, el error tiene promedio cero.
e = rnorm(1000, 0)

# Establecer el valor real de los betas: conocemos con exactitud los valores,
# porque nosotros los creamos!
b1 = 1
b2 = -100
b3 = 500

# modelo verdadero ("true model").
y = b1*x1 + b2*x2 + b3*x3 + e

# Modelo completo
modelo.completo = lm(y ~ x1 + x2 + x3)
summary(modelo.completo)

# Modelo incompleto
modelo.incompleto = lm(y ~ x1 + x2)
summary(modelo.incompleto)

# Si Variance Inflation Factor (VIF) > 4....multicollinearity
library(car)
vif(modelo.completo)
vif(modelo.incompleto)

# Ver como se "inflan las varianzas". Y como nosotros creamos estos datos,
# sabemos que no es debido a "error de medicion". Sabemos exactamente cual es el
# problema: x3 es una combinacion lineal de x2.

# Ejemplo real: hay muchas cosas que en la sociedad estan correlacionadas, por ej?

### Ejemplo Extremo

ej.extremo = lm(y ~ x1 + x2 + x2)
summary(ej.extremo)

x2.prima = x2
ej.extremo.2 = lm(y ~ x1 + x2 + x2.prima)
summary(ej.extremo.2)


## Author: Sergio García Prado
## Title: Statistical Inference - Non parametric Tests - Exercise 14

rm(list = ls())

x <- c(9.8, 10.1, 9.7, 9.9, 10.0, 10.0, 9.8, 9.7, 9.8, 9.9)

(s.x <- (x - 10)[x != 10])
# -0.199999999999999 0.0999999999999996 -0.300000000000001 -0.0999999999999996
# -0.199999999999999 -0.300000000000001 -0.199999999999999 -0.0999999999999996

sum(duplicated(s.x))
# 4

(n.s.x <- length(s.x))
# 8

(V.x <- sum((s.x > 0) * rank(abs(s.x))))
# 2

(V.x.mean <- n.s.x * (n.s.x + 1) / 4)
# 18

(V.x.var <- n.s.x * (n.s.x + 1) * (2 * n.s.x + 1) / 24)
# 51

### H0 median == 10
### H1 median != 10

## Asymptotic pvalue (with continuity correction, without tie correction)
2 * (1 - pnorm(abs(V.x + 0.5 - V.x.mean) / sqrt(V.x.var)))
# 0.0299739735865558

## Asymptotic pvalue (with continuity correction, with tie correction
# TODO

## Exact pvalue (not valid with ties)
2 * (1 - psignrank(V.x, n.s.x, lower.tail = V.x.mean < V.x))
# 0.0234375

wilcox.test(x - 10, alternative = "two.sided", exact = FALSE)
# Wilcoxon signed rank test with continuity correction
#
# data:  x - 10
# V = 2, p-value = 0.02818
# alternative hypothesis: true location is not equal to 0

y <- c(9.83, 10.09, 9.72, 9.87, 10.04, 9.95, 9.82, 9.73, 9.79, 9.90)

(s.y <- (y - 10)[y != 10])
# -0.17 0.0899999999999999 -0.279999999999999 -0.130000000000001 0.0399999999999991
#  -0.0500000000000007 -0.18 -0.27 -0.210000000000001 -0.0999999999999996

sum(duplicated(s.y))
# 0

(n.s.y <- length(s.y))
# 10

(V.y <- sum((s.y > 0) * rank(abs(s.y))))
# 4

(V.y.mean <- n.s.y * (n.s.y + 1) / 4)
# 27.5

(V.y.var <- n.s.y * (n.s.y + 1) * (2 * n.s.y + 1) / 24)
# 96.25

### H0 median == 10
### H1 median != 10

## Asymptotic pvalue (with continuity correction)
2 * (1 - pnorm(abs(V.y + 0.5 * sign(V.y.mean - V.y) - V.y.mean) / sqrt(V.y.var)))
# 0.0190588916017305

## Exact pvalue
2 * (1 - psignrank(V.y - (V.y.mean < V.y), n.s.y, lower.tail = V.y.mean < V.y))
# 0.013671875

wilcox.test(y - 10, alternative = "two.sided", exact = TRUE)
# Wilcoxon signed rank test
#
# data:  y - 10
# V = 4, p-value = 0.01367
# alternative hypothesis: true location is not equal to 0


# 4. faza: Analiza podatkov

#Napoved spreminjanja stevila obsojenih oseb

model_polnoletni <- ggplot(stevilo_obsojenih_polnoletnih, aes(x=Leto, y=Stevilo)) + geom_point(color='violetred4', size=2)
linearni_polnoletni <- lm(data = stevilo_obsojenih_polnoletnih, Stevilo ~ Leto)
leta <- data.frame(Leto=seq(2014, 2030, 1))
napovedi_polnoletni <- mutate(leta, Stevilo=predict(linearni_polnoletni, leta))
graf_polnoletni <- model_polnoletni + geom_smooth(method='lm',fullrange=TRUE,color='blue', formula = y~x) +
  geom_point(data=napovedi_polnoletni, aes(x=Leto, y=Stevilo), color='red', size = 2) +
  ggtitle('Napoved spreminjanja števila obsojenih polnoletnih oseb \n v letih 2020 - 2030') +
  ylab('Število obsojenih polnoletnih oseb') + xlab('Leto')

model_mladoletni <- ggplot(stevilo_obsojenih_mladoletnih, aes(x=Leto, y=Stevilo)) + geom_point(color='violetred4', size=2)
linearni_mladoletni <- lm(data = stevilo_obsojenih_mladoletnih, Stevilo ~ Leto)
napovedi_mladoletni <- mutate(leta, Stevilo=predict(linearni_mladoletni, leta))
graf_mladoletni <- model_mladoletni + geom_smooth(method='lm',fullrange=TRUE,color='blue', formula = y~x) +
  geom_point(data=napovedi_mladoletni, aes(x=Leto, y=Stevilo), color='red', size = 2) +
  ggtitle('Napoved spreminjanja števila obsojenih mladoletni oseb \n v letih 2020 - 2030') +
  ylab('Število obsojenih mladoletni oseb') + xlab('Leto')

#Razporejanje regij v skupine

#tabela za skupine
podatki <- tabela4 %>% filter(Leto == 2014)
podatki$Podatek <- podatki$Stevilo %>% scale()
podatki$Leto <- NULL
zemljevid1 <- fortify(zemljevid.slika)

# graf za skupine v shiny

graf.zemljevid <- function(st){
  vrednosti <- kmeans(podatki$Podatek, st, nstart=1000)
  tabelca <- data.frame(Regija=podatki$Regija, Skupina=factor(vrednosti$cluster))
  ggplot(merge(x=zemljevid1, y=tabelca, by.x = "NAME_1", by.y = "Regija", all = TRUE)) + geom_polygon() +
    aes(x=long, y=lat, group=group, fill=Skupina) + xlab("") + ylab("") + theme_minimal()
}


#
# University: Universidad de Valladolid
# Degree: Grado en Estadística
# Subject: Análisis de Datos
# Year: 2017/18
# Teacher: Miguel Alejandro Fernández Temprano
# Author: Sergio García Prado (garciparedes.me)
# Name: Análisis de Correspondencias - Práctica 03
#
#

rm(list = ls())

library(ca)

#
# 1)  Importar los datos a R desde el fichero oscar.csv
#

N <- read.csv(
  './../../../datasets/oscar.csv',
  header=TRUE,
  row.names = 1)
N

#
# 2)  Efectuar un análisis de correspondencias múltiples con el paquete ac con
# solo las variables médicas como activas a partir de la matriz de binaria, a
# partir de la matriz de Burt y con un análisis de correspondencias conjunto y
# comparar los resultados.
#

N_medicas <- N[,-c(1,2,3,4)]
N_medicas_mca1 <- mjca(N_medicas, lambda="indicator")
N_medicas_mca2 <- mjca(N_medicas, lambda="Burt")
N_medicas_mca3 <- mjca(N_medicas, lambda="JCA")

summary(N_medicas_mca1)
summary(N_medicas_mca2)
summary(N_medicas_mca3)

plot(N_medicas)

#
# 3)  ¿Cuál es la categoría peor representada en el plano definido por los 2
# primeros factores? ¿Y cuál es la mejor representada?
#

# La categoría peor representada en todos los casos es la aparicion.subita,
# mientras que la mejor representada es vacunado.temporada.anterior

#
# 4)  Incluir las variables demográficas edad y sexo como suplementarias. Para
# ello categorizar edad en 4 categorías de la siguiente forma: 1 para menores de
# 18, 2 entre 18 y 35, 3 entre 36 y 65, 4 más de 65 años. Rehacer el análisis a
# partir de la matriz de Burt mediante correspondencias simples.
#

N_copy <- N[,-c(1,2,4)]
N_copy[N_copy[,1] < 18,1] = 1
N_copy[N_copy[,1] >= 18 & N_copy[,1] <= 35,1] = 2
N_copy[N_copy[,1] >= 36 & N_copy[,1] < 65,1] = 3
N_copy[N_copy[,1] >= 65,1] = 4
N_copy[,1]

N_copy_mca1 <- (mjca(N_copy, lambda="Burt", colsup=c(1)))
summary(N_copy_mca1)
N_copy_mca1$Burt
N_copy_mca1$sv
summary(ca(N_copy_mca1$Burt))

#
# 5)  ¿Cuánto vale la inercia recogida por las variables suplementarias en el
# primer factor?
#

#
# Las variables suplementarias no contribuyen a la generación de los factores,
# por tanto, no generan inercia en el análisis.
#

#
# 6)  Efectuar una representación conjunta de las proyecciones de filas y
# columnas e interpretar los factores y el resultado del análisis.
#

plot(N_copy_mca1, what = c("none","all"))


library(pastecs) #For creating descriptive statistic summaries
library(ggplot2) #For creating histograms with more detail than plot
library(psych) # Some useful descriptive functions
library(semTools) #For skewness and kurtosis
library(FSA) #For percentage
library(car) # For Levene's test for homogeneity of variance
library(effectsize) #To calculate effect size for t-test

setwd("~/GitHub/Masters-Classes-L-O/Applied Statistics/data_stats")
getwd()
data = read.csv("optometry_SE_AC.csv")
colnames(data)[1] = "mean sphere refractive errors (D)"
colnames(data)[2] = "anterior chamber depth (mm)"
head(data)

# (5) Get a report-ready scatter plot of mean spherical error (on the vertical axis) against  anterior chamber depth - include nice plot and axis labels etc.
scatter_plot = ggplot(data, aes(x=`mean sphere refractive errors (D)`,
                                y=`anterior chamber depth (mm)`,
                                color = 'mean sphere refractive errors (D)', show.legend = T)) + geom_point(size=2)
scatter_plot

# (6) Fit a simple linear regression model to these data with spherical error as the response. What do you conclude?
# lin_reg = (slope) * variable_name + (intercept)
lin_reg = lm(`anterior chamber depth (mm)`~`mean sphere refractive errors (D)`, data=data)
lin_reg
summary(lin_reg)

# (7) Plot the simple ls line on your scatter plot and include a suitable descriptive legend for this line.
scatter_plot_ls = scatter_plot + geom_smooth(method = "lm", se = FALSE)
scatter_plot_ls

# (8) Fit a quadratic curved line as well - is there any evidence that we need a curved line here?
scatter_plot_qc = scatter_plot +
  geom_point(size=2) +
  stat_smooth(method = "lm", formula = y ~ x + I(x^2), size = 1)
scatter_plot_qc

# (9) In any case, plot the curved line on the scatter plot and amend the legend accordingly.
# done

# (10) Save the plot as a .png image or .jpeg image for inclusion in a report.
# done


## 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.

principal.start <- 30e6  # pool principal
n.peryr <- 12  # monthly = 12 payments per year
T <- 30   # 30-year mortgage
r <- 0.0625  # 6.25%
t <- 1:(n.peryr*T)

## calculate level monthly payment
pmt.level <- principal.start*r/(n.peryr*(1-1/(1+r/n.peryr)^(n.peryr*T)))

## 100% PSA prepayment: rate up to 6% annual at 30 months
psa.speed <- 100  # 100% PSA
max.rate <- psa.speed/100*0.06
seasoned.month <- 30  # at 30 months, PSA says mortgages are seasoned
prepay.rate <- c(seq(max.rate/seasoned.month, max.rate, max.rate/seasoned.month),
                 rep(max.rate, n.peryr*T-seasoned.month))
prepay.monthly.survival <- (1-prepay.rate)^(1/n.peryr)
prepay.monthly.rate <- 1-prepay.monthly.survival

## In production code, this would be more elegant; however,
## a for loop shows the intuition better than other approaches
num.pmts <- n.peryr*T
principal.left <- c(principal.start, rep(0,num.pmts-1))
pmt.perperiod <- c(pmt.level, rep(0,num.pmts-1))
pmt.interest <- rep(0, num.pmts)
pmt.principal <- rep(0, num.pmts)
pmt.prepays <- rep(0, num.pmts)
for (i in 1:num.pmts) {
    pmt.interest[i] <- principal.left[i]*r/n.peryr
    pmt.principal[i] <- pmt.perperiod[i] - pmt.interest[i]
    if (pmt.principal[i] > principal.left[i]) {
        ## do not repay more than principal remaining
        pmt.principal[i] <- principal.left[i]
        ## stop the loop; pool is paid off!
        break
    } else {
        ## do not prepay more than principal remaining after normal payment
        pmt.prepays[i] <- (principal.left[i]-pmt.principal[i])*prepay.monthly.rate[i]
        if ((pmt.principal[i] + pmt.prepays[i]) > principal.left[i]) {
            pmt.prepays[i] <- principal.left[i] - pmt.principal[i]
            ## stop the loop; pool is paid off!
            break
        }
    }
    if (i < num.pmts) {
        principal.left[i+1] <- principal.left[i] - pmt.principal[i] - pmt.prepays[i]
        pmt.perperiod[i+1] <- pmt.perperiod[i]*prepay.monthly.survival[i]
    }
}

areaplot(t,data.frame(pmt.interest, pmt.principal, pmt.prepays),
         ylim=c(0,pmt.level+max(pmt.prepays)), col=c("red","blue","orange"),
         border=FALSE)


#' LaTeX printing
#'
#' Displaying objects of the appropriate type, typeset in
#' LaTeX.  For use with knitr/sweave.
#'
#' @param object
#' Object to print in LaTeX.
#' @param inline
#' Logical; should the latex be written inline (TRUE), i.e. you have started
#' math mode yourself, or not inline (FALSE), i.e. an \code{align*}
#' environment is set up for you.
#' @param ...
#' Additional arguments.
#' @param digits
#' Number of rounding digits
#'
#' @rdname latex
#' @name latex
#' @export
latex <- function(object, ...) UseMethod("latex")

#' @param showName
#' Logical; should the name of the matrix be printed?
#' @param asTranspose
#' Display as the transpose?
#' @param dispname
#' Optional display name.
#' @param system
#' Logical; is this a system of equations? If so, a pipe is added to
#' separate the last column as a right hand side.
#'
#' @examples
#' x <- matrix(1:25, 5)
#' latex(x)
#'
#' @rdname latex
#' @export
latex.matrix <- function(object, inline=FALSE, digits=3, showName=TRUE, asTranspose=FALSE, system=FALSE, ..., dispname)
{
  if (missing(dispname) && showName)
  {
    dispname <- deparse(substitute(object))

    if (system)
      dispname <- paste0(dispname, "|b")
  }
  else
  {
    if (!showName)
      dispname <- ""
  }

  if (asTranspose)
    object <- t(object)

  cols <- paste(rep("r", ncol(object)-1), collapse="")
  if (system)
    cols <- paste0(cols, "|", collapse="")
  cols <- paste0(cols, "r", collapse="")

  if (!inline)
  {
    cat("\\begin{align*}\n")
    sepchar <- "&"
  }
  else
    sepchar <- ""

  if (showName)
    sepchar <- paste0(sepchar, "=")

  cat(paste0(dispname, " ", sepchar, " \\left[\n\\begin{array}{", cols, "}\n"))

  for (row in 1:nrow(object))
  {
    printrow <- paste(round(object[row, ], digits=digits), "&", collapse="")
    cat(substr(printrow, start=1, stop=nchar(printrow)-2), "\\\\\n")
  }
  cat("\\end{array}\\right]")
  if (asTranspose)
    cat("^T\n")
  else
    cat("\n")

  if (!inline)
    cat("\\end{align*}")

  invisible()
}

#' @rdname latex
#' @export
latex.numeric <- function(object, inline=FALSE, digits=3, showName=TRUE, asTranspose=FALSE, ...)
{
  dispname <- deparse(substitute(object))
  object <- as.matrix(object)
  latex.matrix(object=object, inline=inline, digits=digits, showName=showName, asTranspose=asTranspose, dispname=dispname)
}

#' @rdname latex
#' @export
latex.bfs <- function(object, inline=FALSE, digits=3, ...)
{
  if (!inline)
    cat("\\begin{align*}\n")

  for (ind in 1:length(object$bfs))
  {
    Binv_b <- object$bfs[[ind]]
    if (is.character(Binv_b))
      next

    inds <- object$indices[[ind]]

    cat(paste0("B^{-1}b = [", paste0("a_", inds, collapse=", "), "]^{-1}b &= "))
    latex(Binv_b, digits=digits, inline=TRUE, showName=FALSE, asTranspose=TRUE)
    cat("\\\\\n")
    #cat(paste0("[", paste(round(Binv_b, digits=digits), collapse=" "), "]^T\\\\\n"))
  }

  if (!inline)
    cat("\\end{align*}")

  invisible()
}

#' @param coordinates
#' An integer value from 1 to the length of any ep. Restricts the
#' display (so you can throw away non-basic variables).  If missing,
#' all are displayed.
#' @param xchar
#' Character (or string I guess!) to name the solution for display purposes.
#'
#' @rdname latex
#' @export
latex.ep <- function(object, inline=FALSE, digits=3, coordinates, xchar="x", ...)
{
  if (!inline)
    cat("\\begin{align*}\n")

  if (missing(coordinates))
    coordinates <- 1:length(object[[1]])
  else
    coordinates <- 1:coordinates

  iter <- 1L

  for(ep in object)
  {
    cat(paste0("\\bf{", xchar, "}_", iter), " = ")
    iter <- iter + 1L

    cat(paste0("\\left[\\begin{array}{", paste0(rep("r", length(coordinates)), collapse=""), "}"))
    xvec <- paste(paste0("x_", coordinates), "&", collapse="")
    cat(substr(xvec, start=1, stop=nchar(xvec)-1))
    cat("\\end{array}\\right]^T\n")

    cat(" &= ")

    latex(matrix(ep[coordinates]), showName=FALSE, inline=TRUE, asTranspose=TRUE, digits=digits)
    cat("\\\\\n")
  }

  if (!inline)
    cat("\\end{align*}")

  invisible()
}

#' @rdname latex
#' @export
latex.lp_solution <- function(object, digits=3, coordinates, ...)
{
  if (missing(coordinates))
    coordinates <- length(object$soln)

  cat(paste("the", object$type, "of the linear programming problem is "))
  cat(paste0("$", round(object$optimum, digits=digits), "$, which occurs at point "))
  cat("$")
  latex(object$soln[1:coordinates], inline=TRUE, asTranspose=TRUE, showName=FALSE, digits=digits)
  cat("$")

  invisible()
}


Group1 <- c(96,79,91,85,83,91,82,87)
Group2 <- c(77,76,74,73,78,71,80)
Group3 <- c(66,73,69,66,77,73,71,70,74)

cols <- list(m=Group1, y=Group2,z=Group3)
as.data.frame(lapply(cols, `length<-`, max(sapply(cols, length))))
cols
Stacked_Groups <- stack(cols)
Stacked_Groups #shows the table Stacked_Groups

Anova_Results <- aov(values ~ ind, data = Stacked_Groups)
summary(Anova_Results) # shows Anova_Results


# ST3068/ST2054 -- tutorial -- 30 September 2016
# Question 4

game = c('car', 'goat1', 'goat2')
win = c('car')
switch = TRUE

host_strategy = function(x, w) {
  # x is the list of options for the host
  # w is the winning option in the game -- the car
  # the host has to follow the rule "never reveal the car"

  y = setdiff(x, w);
  # if y has length 1 then the host must take this option
  # otherwise the host can choose between options at random

  if (length(y) > 1) {y = sample(x, 1, replace=FALSE)};
  return(y)
}

player_strategy = function (x, y, b) {
  # b is a Boolean variable
  # if b is TRUE then y is replaced with x

  if (b) {y = x};
  return(y)
}

win_count = 0;
game_count = 1000;

for (i in 1:game_count) {

  player_choice = sample(game, 1, replace=FALSE);

  host_game = setdiff(game, player_choice);

  host_choice = host_strategy(host_game, win);

  player_game = setdiff(host_game, host_choice);

  outcome = player_strategy(player_game, player_choice, switch);

  if (outcome == win) {win_count = win_count + 1}

}

if (switch) {
print(paste('The outcome of the switch strategy:', win_count, 'wins out of', game_count, 'games.'))
} else {
print(paste('The outcome of the non-switch strategy:', win_count, 'wins out of', game_count, 'games.'))
}


#' @export
residual <- function(X, y){
    M <- orthogonal_projection_matrix(X)

    M %*% y
}

#' @export
prediction_error <- function(X, y){
    M.star <- prediction_error_tranformation_matrix(X)

    M.star %*% residual(X, y)
}

standardized_residual <- function(X, y){
    M.star <- prediction_error_tranformation_matrix(X)

    (M.star^(1/2)) %*% residual(X, y)
}

# Notations

#' @export
e.hat <- residual

#' @export
e.tilde <- prediction_error

#' @export
e.bar <- standardized_residual


# ......................................................................................
# ..................Exercise 1 - Brief introduction to R, Combinatorics.................
# ......................................................................................
# ......................................................................................

# 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

#  Combinatorics ####

# * r-permutations ####
#
# P(n, k) - r-permutations, the first argument will be the total number of entities, the
# second argument the size of the selection
#

# the function is created by the fucntion command, it is an object whose name is given by a variable
# to which I will assign this object
r_permutation = function(n,k) # here I enter the number of parameters and their names
{ # the whole body of the function is enclosed in parentheses {...}
    numerator = factorial(n)  # the factorial in the original R exists so we will use it
    denominator = factorial(n-k)
    return(numerator/denominator)    # what the function returns is given in the return(...) statement
}

# P*(n, k) - r-permutations with repetition
#

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

# * Permutation ####
#
# P(n)=P(n, n) - permutation
#

permutation = function(n)
{
  return(r_permutation(n,n))
}

# P*(n1, n2, n3,...., nk) - permutation with repetition, input will be a vector with
# individual numbers of unique entities
#

permutation_repetition = function(vec_n) # vec_n is the vector of values eg: vec_n=c(2,2,2,4,3)
{
    n = sum(vec_n) # we calculate how many values we have in total
    res_temp=factorial(n) # their factorial=value in the numerator
    # a simple loop starts with the for statement, then the iterator name follows in parentheses
    # and what list will be taken as iterable object
    for(count in vec_n) # count is an iterator and will gradually take values from the vector vec_n
    {
        # we gradually divide by the factorial of each number of unique entities
        res_temp=res_temp/factorial(count)
    }
    return(res_temp)
}

# * Combination ####
#
# C(n, k) - combination
#

combinations = function(n,k)
{
  return(choose(n,k)) # the function for combination already exists in R and is called choose
}

# C*(n, k) - combination with repetition
#

combinations_repetition = function(n,k)
{
  return(choose(n+k-1,k)) # we use a known formula
}

#  Exercise tasks ####
#
# * Example 1. ####
#
# There are three types of locks available in the store. To open the first lock, it is
# necessary to press four of the ten buttons marked with numbers 0 to 9.(The order does
# not matter - the buttons remain pressed.) The second lock will open if we press six of
# the ten buttons. To open the third lock, it is necessary to set the correct
# combination on the four discs. Which of these locks best protects against thieves?
#

z1=combinations(10,4)
z2=combinations(10,6)
z3=r_permutation_repetition(10,4)
paste("count of possible passwords: ",z1,",",z2,",",z3)
paste("probability od random opening: ",1/z1,",",1/z2,",",1/z3)

# * Example 2. ####
#
# The store offers two types of briefcase locking. The first briefcase is locked with a
# six-digit cipher. The second case is locked with two locks that open at the same time.
# The cipher of each of them consists of three digits. Determine for each briefcase the
# probability of opening by a thief on the first attempt. Which type of lock is safer?
#

z1=r_permutation_repetition(10,6);
z2=r_permutation_repetition(10,3)*r_permutation_repetition(10,3);
z2_v2=r_permutation_repetition(10,3)+r_permutation_repetition(10,3);
paste("count combinations: ",z1,",",z2,",second variant - ",z2_v2)

# * Example 3. ####
#
# There are 40 balls in the urn - 2 red and 38 white. We randomly pull 2 balls out of
# the urn. How likely are they both to be red?
#

all_combinations=combinations(40,2);
combinations_valid=combinations(2,2);
prob=combinations_valid/all_combinations;
paste("probability is: ",prob)

# * Example 4. ####
#
# The student had to prepare answers to 40 questions for the exam. He could not answer
# the two questions the examiner asked him, so he said, “I'm unlucky! These are the only
# two questions I can't answer. ”How likely is he to tell the truth?
#

# * Example 5. ####
#
# A student passes a chemistry test if he underlines the only two aldehydes on the list
# of 40 chemical compounds. What is the probability that a student who underlines the
# compounds at random will pass the test?
#

# * Example 6. ####
#
# A group of 40 tourists returned from abroad, including 2 smugglers. At the border,
# customs officer called for a personal search of two passengers and it turned out that
# both were smugglers. The remaining tourists responded: "The customs officer was really
# lucky!", "Someone reported the smugglers!",.... How to deal with these statements? Is
# there a legitimate suspicion that someone reported the smugglers?
#

# * Example 7. ####
#
# From the urn with three balls, two red and one white, two balls will be selected at
# the same time. The student and the teacher place a bet. If both balls are of the same
# color, the student wins. If the balls have different colors, the teacher wins. Is the
# game fair? What are the probabilities of a teacher and a student winning?
#

# the combn function produces combinations of the specified size - the first parameter is a vector of values, the second the size of the selection
combn(c('red','red','white'),2)

# * Example 8. ####
#
# The game described in Example 7 was not fair. What ball(red or white) do we need to
# add to the urn to make the game fair?
#

combn(c('red','red','white','white'),2)
combn(c('red','red','white', 'red'),2)

# * Example 9. ####
#
# You want to play "Man, don't be angry" (a board game requiring a dice), but all the
# dices are lost. How can a dice be replaced if you have playing cards(a deck of 32
# cards) and 4 different colored balls?
#

# * Example 10. ####
#
# You want to play Man, don't be angry, but the dice is lost. How can one replace a dice
# if he has only 3 different colored balls?
#

# * Example 11. ####
#
# They have a sales event in the Škoda car dealership in February. In addition to the
# standard equipment, they offer 3 items from the above-standard equipment free of
# charge. Extra equipment includes 7 items:
#
# - cruise control, seat heating, rear airbags, xenon headlights, sunroof, gearbox lock,
# and  special durable metallic paint.
#
# How many options does the customer have to choose 3 items from the above-standard
# equipment?
#

combinations(7,3)

# * Example 12. ####
#
# During the exam, 12 students will be sitting in the 5th row. The examiner wants to
# determine himself where every student will be sitting.
#
# - How many ways to organize those 12 students?
#
# - Student Brahý asks to be able to sit on aisle seat and leave earlier to catch the
# train. How many options are there for deploying students if the examiner wants to meet
# Brahý's request?
#
# - How many opportunities are there to organize the students if Pažout and Horáček are
# not allowed to sit next to each other?
#

# a
permutation(12)
# b
1*permutation(11)+permutation(11)*1
# c
together=permutation(11)+permutation(11)
permutation(12)-together

# * Example 13. ####
#
# How many anagrams can be created from the word STATISTICS?
#

# 3S,3T,1A,2I,1C
STATISTICS=c(3,3,1,2,1)
permutation_repetition(STATISTICS)

# * Example 14. ####
#
# They got new goods in Tesco - boys' T-shirt in 6 different colors. They have at least
# 7 pieces of each color. The mother wants to buy 4 T-shirts for her son. How many
# options are there to choose from
#
# - if they have to be all to be different?
#
# - if they can all be the same?
#

# a
combinations(6,4)
# b
combinations_repetition(6,4)

# * Example 15. ####
#
# How many passwords of length 5 can we create from alphabetic characters
#
# - if case insensitive?
#
# - if case sensitive?
#

# a
r_permutation_repetition(26,5)
# b
r_permutation_repetition(52,5)

#  Bonus Exercise tasks ####
#
# * Bonus Example 1. ####
#
# Which password is more secure?
#
# * An eight-character password consisting of numbers only.
#
# * A five-character password composed only of letters of the English alphabet.
#

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

# * Bonus Example 2. ####
#
# How long would it take to solve a business traveler's problem for n=10 cities by brute
# force if the evaluation of the length of each of the possible journeys takes 1 µs?
#

n = 10
count = permutation(n-1)/2
time = count/1000000
time

# * Bonus Example 3. ####
#
# How to divide the booty between 2 robbers to get both items of the same value(or as
# close as possible). I.e. can I divide N numbers into two groups so that the sum of the
# numbers in each group is the same?
#
# **How many options would have to be tried if we solved the problem with brute force?**
#

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

# * Bonus Example 4. ####
#
# How many anagrams of the word "AUTO" can we create? How many anagrams of the word
# "AUTOMOBILKA" can we create? How many of them start with "K"?
#

permutation(4)
vec = c(2,1,1,2,1,1,1,1,1)
sum(vec)
permutation_repetition(vec)

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

# * Bonus Example 5. ####
#
# They have 6 types of colored cups in the shop.
#
# - How many different ways can we buy 4 different-colored mugs?
#
# - How many different options can we buy 5 cups(if we don't mind more of the same
# color)?
#
# - How will the situation change if they have only 4 pieces of each(and we don't mind
# more of the same color)?
#

combinations(6,4)
combinations_repetition(6,5)
combinations_repetition(6,5) - 6

# * Bonus Example 6. ####
#
# There are 5 different pairs of socks in the package (the left and right socks are
# always the same).
#
# - How many different pairs of socks can be chosen?
#
# - How many different ways can I wear it? (i.e. it is important what sock is on which
# leg)
#

combinations_repetition(n = 5,k = 2)
r_permutation_repetition(n=5,k=2)
combinations_repetition(n = 5,k = 2)*2 - 5

# * Bonus Example 7. ####
#
# I have 12 weights weighing 1,2,..., 12 kg.
#
# - How many ways can I divide them into 2 piles?
#
# - How many ways can I divide them into 3 piles?
#
# - How many ways can I divide them into 3 piles if they all have the same number of
# weights?
#
# - How many ways can I divide them into 3 piles of the same number of weights, if the
# weight of none of the pile can exceed 40 kg?
#

r_permutation_repetition(2,12)
r_permutation_repetition(3,12)
(r_permutation_repetition(3,12)-3)/permutation(3)+1
(r_permutation_repetition(3,12)-(r_permutation_repetition(2,12)-2)*3-3)/permutation(3)
combinations(12,4)*combinations(8,4)/permutation(3)
permutation(12)/(permutation(4)*permutation(4)*permutation(4)*permutation(3))
combinations(12,4)*combinations(8,4)/permutation(3)-combinations(8,4)

# * Bonus Example 8. ####
#
# I have 20 seeds from each of the three vegetables(carrots, radishes, celery).
# Unfortunately, they are mixed up and unrecognizable from each other.
#
# - I will plant 5 random seeds in the box. What is the probability that there will be
# at least three radishes among them?
#
# - I'll plant 5 random seeds in the box. What is the probability that there will be
# more carrots than celery among them?
#

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


ybar = 390           # sample mean
mu0 = 380            # hypothesized value
sigma = 35.2        # population standard deviation
n = 50                 # sample size
z = (ybar- mu0)/(sigma/sqrt(n))
 # test statistic

p_value=1-pnorm(z)
print(p_value)
alpha=0.01
if(p_value>alpha){
  print("we fail to reject H0")
print(" data do not support the research hypothesis.")
 }else{
   print("reject H0")
     }


# From http://stats.stackexchange.com/questions/195198
require(rms)
d1 <- data.frame(cohort='one', sex='male', y=c(.476,
.84,
1.419,
0.4295,
0.083,
2.9595,
4.20125,
1.6605,
3.493,
5.57225,
0.076,
3.4585))
d2 <- data.frame(cohort='one', sex='female', y=c(4.548333,
4.591,
3.138,
2.699,
6.622,
6.8795,
5.5925,
1.6715,
4.92775,
6.68525,
4.25775,
8.677))
d3 <- data.frame(cohort='two', sex='male', y=c(7.9645,
16.252,
15.30175,
8.66325,
15.6935,
16.214,
4.056,
8.316,
17.95725,
13.644,
15.76475))
d4 <- data.frame(cohort='two', sex='female', y=c(11.2865,
22.22775,
18.00466667,
12.80925,
16.15425,
14.88133333,
12.0895,
16.5335,
17.68925,
15.00425,
12.149))
d <- rbind(d1, d2, d3, d4)
dd <- datadist(d); options(datadist='dd')

# Fit the default ordinal model (prop. odds)
f <- orm(y ~ cohort * sex, data=d)
f
anova(f)

# Show intercepts as a function of y to estimate the underlying
# conditional distribution.  Result: more uniform than Gaussian
alphas <- coef(f)[1 : num.intercepts(f)]
yunique <- f$yunique[-1]
par(mfrow=c(1,2))
plot(yunique, alphas)

# Compare to distribution of residuals
plot(ecdf(resid(ols(y ~ cohort * sex, data=d))), main='')

M <- Mean(f)
# Confidence intervals for means are approximate
# Confidence intervals for odds ratios or exceedance probabilities
# are correct for ordinal models
Predict(f, cohort, sex, fun=M)

with(d, summarize(y, llist(cohort, sex), smean.cl.normal))


#' @export
#' @title compute.oxygen.saturation
#' @description This function determines the percentage of Dissolved oxygen in solution at a given temperature and salinity given a known saturation amount. formula attributed to Weiss DSR 17, 721-735, 1970
#' @param \code{t.C} = temperature in Celsius
#' @param \code{sal.ppt} = salinity in ppt
#' @param \code{oxy.ml.l} = oxygen saturation in ml/L
#' @return \code{DO} = saturation percentage
#' @examples
#' compute.oxygen.saturation(0, 25, 8.2)
#' [1] 95.19575
#' @family physical and chemical properties
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
  compute.oxygen.saturation = function(t.C, sal.ppt, oxy.ml.l) {
    warning('MMM - 2016-06-17 - Please ensure this works correctly - I was unable to replicate values from online calculators')
    t.K = t.C + 273.15
    o.ml.l.saturated = exp( -173.4292 + 249.6339 * (100/t.K)
      + 143.3483*( log(t.K/100) )
      - 21.8492*(t.K/100)
      + sal.ppt * (-0.033096 + 0.014259 * (t.K/100) - 0.0017*(t.K/100)^2 ) )

#  o.mg.l.saturated = o.ml.l.saturated * 32/22.414

    DO = oxy.ml.l / o.ml.l.saturated * 100
    return(DO)
  }


#la media entre 2 muestras de la misma poblacion
#immer es un dataframe don y1 y y2 del rendimiento de cebada entre los a??os 1931 y 1932

#Assuming that the data in immer follows the normal distribution, find the
#95% confidence interval estimate of the difference between the mean barley
#yields between years 1931 and 1932.

#usamos t.test para obtener el intervalo estimado entra la diferencia de medias poblacionales

library(MASS)
head(immer)

t.test(immer$Y1,immer$Y2,paired = TRUE)

#Paired t-test

#data:  immer$Y1 and immer$Y2
#t = 3.324, df = 29, p-value = 0.002413
#alternative hypothesis: true difference in means is not equal to 0
#95 percent confidence interval:
#  6.121954 25.704713
#sample estimates:
#  mean of the differences
#15.91333

Parcial/3. Inferencia entre poblaciones/PopulationMeanTwoMatchedSamples.r


alpha=0.05
m=4 #comparisons
alpha_l=alpha/m
F_aplha_l_1_25=qf(1-alpha_l,df1 = 1,df2 = 25)
print(F_aplha_l_1_25)
# We would then reject H0 if SSCi/MSError >=F_alpha_l_1_25
F1 = 13.71 # computed in 9.5
F2 = 8.48
F3 = 0.24
F4 = 1.42
#  we would declare contrast l1 and l2 significantly different from 0 because their F ratios are greater than 7.24.


## ----echo=FALSE---------------------------------------------------------------
require(Hmisc)
knitrSet('survintro')

## ----fun-example,bty='l',echo=FALSE,cap='Survival function'-------------------
tt <- c(seq(.0001,.002,by=.001),seq(.002,.02,by=.001),
        seq(.02,1,by=.01))
# Note: bb,dd not stated in usual Weibull form
aa <- .5
bb <- -.5
cc <- 10
dd <- 4
cumhaz <- (aa/(bb+1))*tt^(bb + 1) + (cc/(dd+1))*tt^(dd + 1)
survival <- exp(-cumhaz)
hazard <- ifelse(tt>.001, aa*tt^bb + cc*tt^dd, NA)
plot(tt, survival, type="l", xlab=expression(t), ylab=expression(S(t)))

## ----cumhaz-example,bty='l',echo=FALSE,cap='Cumulative hazard function'-------
plot(tt, cumhaz, type="l", xlab=expression(t),
     ylab=expression(Lambda(t)))

## ----hazard-example,bty='l',echo=FALSE,cap='Hazard function'------------------
plot(tt, hazard, type="l", xlab=expression(t), ylab=expression(lambda(t)))

## ----weibull-shapes,bty='l',echo=FALSE,cap='Some Weibull hazard functions with $\\alpha=1$ and various values of $\\gamma$.'----
tt <- seq(1e-5, 1.2, length=100)
plot(tt, rep(0,100), ylim=c(0,7), type="n", xlab=expression(t), ylab="")
a <- 1
i <- 0
for(b in c(.5,1,2,4)) {
  i <- i + 1
  lines(tt, a*b*tt^(b-1), lty=i)
}
legend(.4, 6, c(".5","1","2","4"), lty=1:4, cex=.9, bty="n")

## ----km-example,bty='l',cap='Kaplan--Meier product--limit estimator with $0.95$ confidence bands.  The Altschuler--Nelson--Aalen--Fleming--Harrington estimator is depicted with the dotted lines.',scap='Kaplan--Meier and Nelson--Aalen estimates'----
require(rms)
tt <- c(1,3,3,6,8,9,10)
stat <- c(1,1,1,0,0,1,0)
S <- Surv(tt, stat)
survplot(npsurv(S ~ 1), conf="bands", n.risk=TRUE,
         xlab=expression(t))
survplot(npsurv(S ~ 1, type="fleming-harrington",
                 conf.int=FALSE), add=TRUE, lty=3)

## ----eval=FALSE---------------------------------------------------------------
## require(rms)
## units(y) <- "Month"
## # Default is "Day" - used for axis labels, etc.
## npsurv(Surv(y, event) ~ svar1 + svar2 + ... , data, subset,
##        type=c("kaplan-meier", "fleming-harrington", "fh2"),
##        error=c("greenwood", "tsiatis"), se.fit=TRUE,
##        conf.int=.95,
##        conf.type=c("log","log-log","plain","none"), ...)

## ----eval=FALSE---------------------------------------------------------------
## f <- npsurv(...)
## print(f)    # print brief summary of f
## summary(f, times, censored=FALSE)   # in survival

## ----eval=FALSE---------------------------------------------------------------
## f <- npsurv(Surv(futime, event) ~ sex)
## summary(f, seq(30, 180, by=30))

## ----eval=FALSE---------------------------------------------------------------
## units(y) <- "Year"
## f <- npsurv(Surv(y, stat) ~ treatment)
## survplot(f, ylab="Fraction Pain-Free")

## ----eval=FALSE---------------------------------------------------------------
## cph(Survobject ~ predictor)


scalingfact=70
scalingaxis=6

#f_table= f_table_ori
f_table_ori = f_table

#f_table = f_table[1:(length(f_table)-9)]
h_table<-f_table[,c(3:(length(f_table)))]
rownames (h_table) = paste (c(1:length(f_table[,1])),f_table[,2])
#h_table<-f_table[,c(3:13,16:length(f_table))]
g_table <- na.omit(h_table)
 head(g_table)
mydata.pca <- prcomp(g_table, retx= TRUE, center= TRUE, scale.=TRUE)

sd <- mydata.pca$sdev
loadings <- mydata.pca$rotation
rownames(loadings) <- colnames(g_table)
scores <- mydata.pca$x

R <- cor(g_table)
myEig <- eigen(R)
sdLONG <- sqrt(myEig$values)
loadingsLONG <- myEig$vectors
rownames(loadingsLONG) <- colnames(g_table)
 standardize <- function(x) {(x - mean(x))/sd(x)}
 X <- apply(g_table, MARGIN=2, FUN=standardize)
# transforming data to zero mean and unit variance
 scoresLONG <- X %*% loadingsLONG
# calculating scores from eigenanalysis results

 range(sd - sdLONG)
 range(loadings - loadingsLONG)
 range(scores - scoresLONG)

pdf("PCA.pdf")

#Plot PC1 and 2 info on one graph
PCA1to3 = data.frame(PCA_res$PC1,PCA_res$PC2,PCA_res$PC3,PCA_res$group)

Mean_PCA = create.mean.table(PCA1to3,levels(PCA1to3$PCA_res.group),1:2)

Mean_PCA2 = create.mean.table(PCA1to3,levels(PCA1to3$PCA_res.group),c(1,3))

 plot(scores[,1], scores[,2], xlab="PCA 1", ylab="PCA 2",
   type="n", main="distance biplot",xlim=c(-max(scores[,1:3]*scalingaxis), max(scores[,1:3]*scalingaxis)),
   ylim=c(-max(scores[,1:3]*scalingaxis), max(scores[,1:3]*scalingaxis)))
   arrows(0,0,loadings[,1]*scalingfact,loadings[,2]*scalingfact, length=0.1,
   angle=20, col="red")
# note that this scaling factor of 10 may need to be changed,
# depending on the data set
 text(loadings[,1]*scalingfact*1.2,loadings[,2]*scalingfact*1.2,
   rownames(loadings), col="red", cex=0.7)
# 1.2 scaling insures that labels are plotted just beyond
# the arrows
# text(scores[,1],scores[,2], rownames(scores), col="blue",
#   cex=0.7)

plot(PCA_res$PC2~PCA_res$PC1, type= "n")
for (i in 1:length(levels(PCA_res$group))){
	X = subset(PCA_res,PCA_res$group == levels(PCA_res$group)[i])
	points(X$PC2~ X$PC1, col=i)
	legend(list(x=-6,y=-i/2+3), legend=(levels(PCA_res$group)[i]), fill= i, bty="n")
	 #text(x+1,y-0.1, levels(PCA_res$group)[i], col=i,
#   cex=0.7)
   x=Mean_PCA$means$PCA_res.PC1[i]
y=Mean_PCA$means$PCA_res.PC2[i]
x2=Mean_PCA$ses$PCA_res.PC1[i]
y2=Mean_PCA$ses$PCA_res.PC2[i]
segments (x-x2,y,x+x2,y, col=i)
segments (x,y-y2,x,y+y2, col=i)
	}
	abline (v=0, h=0)

 plot(scores[,1], scores[,3], xlab="PCA 1", ylab="PCA 3",
   type="n", main="distance biplot",xlim=c(-max(scores[,1:3]*scalingaxis), max(scores[,1:3]*scalingaxis)),
   ylim=c(-max(scores[,1:3]*scalingaxis), max(scores[,1:3]*scalingaxis)))
 arrows(0,0,loadings[,1]*scalingfact,loadings[,3]*scalingfact, length=0.1,
   angle=20, col="red")
# note that this scaling factor of 10 may need to be changed,
# depending on the data set
 text(loadings[,1]*scalingfact*1.2,loadings[,3]*scalingfact*1.2,
   rownames(loadings), col="red", cex=0.7)
# 1.2 scaling insures that labels are plotted just beyond
# the arrows
# text(scores[,1],scores[,2], rownames(scores), col="blue",
#   cex=0.7)

plot(PCA_res$PC3~PCA_res$PC1, type= "n")
for (i in 1:length(levels(PCA_res$group))){
	X = subset(PCA_res,PCA_res$group == levels(PCA_res$group)[i])
	points(X$PC3~ X$PC1, col=i)
	legend(list(x=-6,y=-i/2+4), legend=(levels(PCA_res$group)[i]), fill= i, bty="n")
	 #text(x+1,y-0.1, levels(PCA_res$group)[i], col=i,
#   cex=0.7)
   x=Mean_PCA2$means$PCA_res.PC1[i]
y=Mean_PCA2$means$PCA_res.PC3[i]
x2=Mean_PCA2$ses$PCA_res.PC1[i]
y2=Mean_PCA2$ses$PCA_res.PC3[i]
segments (x-x2,y,x+x2,y, col=i)
segments (x,y-y2,x,y+y2, col=i)
	}
	abline (v=0, h=0)

dev.off()


# Assignment: ASSIGNMENT 5
# Name: Dickey, Eric
# Date: 2021-07-24

## Set the working directory to the root of your DSC 520 directory
setwd("/Users/ericdickey/Documents/DSC520/DSC520")

## Load the `data/r4ds/heights.csv` to
heights_df <- read.csv("data/r4ds/heights.csv")

## Using `cor()` compute correclation coefficients for
## height vs. earn
cor(heights_df$height,heights_df$earn)
___
### age vs. earn
cor(heights_df$age,heights_df$earn)
___
### ed vs. earn
cor(heights_df$ed,heights_df$earn)
___

## Spurious correlation
## The following is data on US spending on science, space, and technology in millions of today's dollars
## and Suicides by hanging strangulation and suffocation for the years 1999 to 2009
## Compute the correlation between these variables
tech_spending <- c(18079, 18594, 19753, 20734, 20831, 23029, 23597, 23584, 25525, 27731, 29449)
suicides <- c(5427, 5688, 6198, 6462, 6635, 7336, 7248, 7491, 8161, 8578, 9000)
cor(tech_spending, suicides)
___


library(reshape2)
library(Rcpp)
library(ggplot2)

cppFunction('
  List sirc(double beta, double gamma, double N, double S0, double I0, double R0, double tf){
    double t = 0;
    double S = S0;
    double I = I0;
    double R = R0;
    std::vector<double> ta;
    std::vector<double> Sa;
    std::vector<double> Ia;
    std::vector<double> Ra;
    do{
      ta.push_back(t);
      Sa.push_back(S);
      Ia.push_back(I);
      Ra.push_back(R);
      double pf1 = beta*S*I;
      double pf2 = gamma*I;
      double pf = pf1+pf2;
      double dt = rexp(1,pf)[0];
      t += dt;
      double r = runif(1)[0];
      if(r<pf1/pf){
        S--;
        I++;
      }else{
        I--;
        R++;
      }
      if(I==0){break;}
    } while (t<=tf && (I>0));
  return List::create(_["time"] = ta, _["S"] = Sa, _["I"] = Ia, _["R"]=Ra);
  }'
)

set.seed(42)

sir_out_list <- sirc(0.1/1000,0.05,1000,999,1,0,200)

sir_out <- as.data.frame(sir_out_list)

if(dim(sir_out)[1]==1){
    sir_out_list <- sirc(0.1/1000,0.05,1000,999,1,0,200)
    sir_out <- as.data.frame(sir_out_list)
}

head(sir_out)

sir_out_long <- melt(sir_out,"time")

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


#!/usr/bin/env Rscript

# eg.1 总体均值mu的区级估计
weight = scan("res/noodle.TXT")
summary(weight)
result = t.test(weight, con =.95)
print(result$con)

# eg.2 两个总体均值之差估计(mu1 - mu2)
v = read.table("res/expend.txt", header=T)
v1 = v[v[, 2] == 1, 1]
v2 = v[v[, 2] == 2, 1]

m1 = mean(v1)
m2 = mean(v2)

diff = m1 - m2
print(diff)

sd(v1)
sd(v2)

t.test(v1, con=.95)$con
t.test(v2, con=.95)$con

t.test(v1, v2, con=.90)$conf


#' @title Get the effective number of parties.
#'
#' @name calculate_nep
#'
#' @description This function returns the effective number of parties.
#'
#' @param seats \code{array}. The total of available seats.
#' @param magnitude \code{int}. The district magnitude.
#'
#' @details If you want to calculate the actual number of parties in a mayoral election,
#' the ratio must be calculated between the total number of votes received and the total
#' number of valid votes rather than the ratio between available seats and the number
#' of seats obtained.
#'
#' @return a number.
#'
#' @author Mário Dias
#'
#' @examples
#' calculate_nep(c(2, 1, 1, 1, 1, 1, 2), 9)
#'
#' @export
calculate_nep <- function(seats = c(), magnitude) {

  #creates arrays to receive the proportion and proportion squared values.
  proportion <- c()
  proportion_squared <- c()

  #creates variables to receive the summation value and the index to while loop.
  summation <- 0
  i <- 0

  #repetition structure that will iterate through the array.
  while (i <= length(seats)) {

    #generates the proportion between the seats available seats and the obtained seats and sends the results to a vector.
    proportion[i] <- seats[i] / magnitude
    #generates the squared of all proportions and sends the results to a vector.
    proportion_squared[i] <- proportion[i] ** 2
    #makes the summation of all values squared.
    summation <- sum(proportion_squared)
    #updates the index value.
    i <- i + 1

  }

  #calculates the effective number of parties.
  nep <- 1 / summation

  #returns the effective number of parties.
  return(nep)

}


> rnorm(1)    # generates 1 random number
[1] 1.072712
> rnorm(3)    # generates 3 random number
[1] -1.1383656  0.2016713 -0.4602043
> rnorm(3, mean=10, sd=2)    # provide our own mean and standard deviation
[1]  9.856933  9.024286 10.822507


## let L(D|theta) be a likelihood > 0 for all thera.
## let Y = [L(D|theta)]^2
## then the prior pi(theta) induces a measure on the space Y

### Binomial

n <- 10
x <- 3

ap <- 2
bp <- 2

p.samples <- rbeta(n = 1e6, shape1 = ap, shape2 = bp)

X <- dbinom(x = x, size = n, prob = p.samples)

hist(X, main = "Binomial")

Y <- X^2

hist(Y, main = "Binomial")

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

#### Normal, fixed variance

x <- -1
s <- .1

mu.samples <- rnorm(n = 1E6)

X <- dnorm(x = x, mean = mu.samples, sd = s)

hist(X, main = "Gaussian")

Y <- X^2

hist(Y, main = "Gaussian")

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

#### Beta with fixed shape1

psi <- .5
s1 <- 2

s2.samples <- rgamma(n = 1E6, shape = 2, rate = 1)

X <- dbeta(x = psi, shape1 = s1, shape2 = s2.samples)

hist(X, main = "Beta")

Y <- X^2

hist(Y, main = "Beta")


zeckendorf <- function(number) {

  # Get an upper limit on Fibonacci numbers needed to cover number
  indexOfFibonacciNumber <- function(n) {
    if (n < 1) {
      2
    } else {
      Phi <- (1 + sqrt(5)) / 2
      invertClosedFormula <- log(n * sqrt(5)) / log(Phi)
      ceiling(invertClosedFormula)
    }
  }

  upperLimit <- indexOfFibonacciNumber(number)

  # Return the sequence as digits, sorted descending
  fibonacciSequenceDigits <- function(n) {
    fibGenerator <- function(f, ...) { c(f[2], sum(f)) }
    fibSeq <- Reduce(fibGenerator, 1:n, c(0,1), accumulate=TRUE)

    fibNums <- unlist(lapply(fibSeq, head, n=1))

    # drop last F0 and F1 and reverse sequence
    rev(fibNums[-2:-1])
  }

  digits <- fibonacciSequenceDigits(upperLimit)

  isInNumber <- function(digit) {
    if (number >= digit) {
      number <<- number - digit
      1
    } else {
      0
    }
  }

  zeckSeq <- Map(isInNumber, digits)

  # drop leading 0 and convert to String
  gsub("^0+1", "1", paste(zeckSeq, collapse=""))
}

print(unlist(lapply(0:20, zeckendorf)))


## Author: Sergio García Prado

rm(list = ls())

y <- c(7, 6, 8, 16, 13)
k <- length(y)
n <- sum(y)

LogLikelihood <- function(p, y, k) {
  sum(y[1:(k - 1)] * log(p)) + y[k] * log(1 - sum(p))
}

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

p.hat.initial <- rep(1 / k, k - 1)
opt <- optim(p.hat.initial[1:(k - 1)], NegativeLogLikelihood, y = y, k = k, hessian = TRUE)

(p.hat <- opt$par)
# 0.139976175373378 0.120217883250931 0.159986995019396 0.319854212163691

(p.hat.var <- solve(opt$hessian))
# 0.0024070858	-0.0003370446	-0.0004477195	-0.0008948212
# -0.0003370446	0.0021183563	-0.0003852716	-0.0007700115
# -0.0004477195	-0.0003852716	0.0026874471	-0.0010228592
# -0.0008948212	-0.0007700115	-0.0010228592	0.0043497380

## a)
####

LogLikelihood1H0 <- function(theta, y, k) {
  LogLikelihood(c(theta[1], theta[1], theta[1], theta[2]), y, k)
}

NegativeLogLikelihood1H0 <- function(...) {
  - LogLikelihood1H0(...)
}

opt1.hzero <- optim(c(0.1, 0.1), NegativeLogLikelihood1H0, y = y, k = k, hessian = TRUE)

(LRT1 <-  2 * (LogLikelihood(p.hat, y, k) - LogLikelihood1H0(opt1.hzero$par, y, k)))
# 0.286670914555231

(LRT1.pvalue <- 1 - pchisq(LRT1, df = (k - 1) - 3))
# 0.59236182742952

## b)
####

g1 <- function(p) {
  c(p[1] - p[2],
    p[1] - p[3],
    p[1] + p[2] + p[3] + 2 * p[4] - 1)
}

g1.derivative <- function(p) {
  matrix(c(1, -1,  0, 0,
           1,  0, -1, 0,
           1,  1,  1, 2),
         3, 4, byrow = TRUE)
}

(g1.hat <- g1(p.hat))
# 0.0197582921224479 -0.0200108196460179 0.059889477971087

(g1.hat.var <- g1.derivative(p.hat) %*% p.hat.var %*% t(g1.derivative(p.hat)))
# 5.199531e-03	2.806578e-03	-2.333792e-05
# 2.806578e-03	5.989972e-03	2.394155e-05
# -2.333792e-05	2.394155e-05	1.152100e-02

(W1 <- t(g1.hat - rep(0, 3)) %*% solve(g1.hat.var) %*% (g1.hat - rep(0, 3)))
# 0.6002303

(W1.pvalue <- 1 - pchisq(W1, df = (k - 1) - 3))
# 0.4384902

## c)
####

LogLikelihood2H0 <- function(theta, y, k) {
  LogLikelihood(c(theta[1], 2 * theta[1], theta[2], theta[2]), y, k)
}

NegativeLogLikelihood2H0 <- function(...) {
  - LogLikelihood2H0(...)
}

opt2.hzero <- optim(c(0.1, 0.1), NegativeLogLikelihood2H0, y = y, k = k, hessian = TRUE)

(LRT2 <-  2 * (LogLikelihood(p.hat, y, k) - LogLikelihood2H0(opt2.hzero$par, y, k)))
# 5.01968859661113

(LRT2.pvalue <- 1 - pchisq(LRT2, df = (k - 1) - 2))
# 0.0812808938285899

## d)
####

g2 <- function(p) {
  c(p[2] - 2 * p[1],
    p[3] - p[4])
}

g2.derivative <- function(p) {
  matrix(c(-2, 1,  0, 0,
            0, 1, -1, 0),
            2, 4, byrow = TRUE)
}

(g2.hat <- g2(p.hat))
# -0.120217883250931 -0.159867217144294

(g2.hat.var <- g2.derivative(p.hat) %*% p.hat.var %*% t(g2.derivative(p.hat)))
# 0.013094878	0.002282278
# 0.002282278	0.005576347

(W2 <- t(g2.hat - rep(0, 2)) %*% solve(g2.hat.var) %*% (g2.hat - rep(0, 2)))
# 5.314512

(W2.pvalue <- 1 - pchisq(W2, df = (k - 1) - 2))
# 0.07014043


library(cubature)

norm_const <- function(func){

  rez  <-  cubintegrate(func, lower = -Inf, upper = Inf, method = 'pcubature')

  ifelse ( is.na(rez$integral) | rez$integral == Inf | rez$integral == -Inf | rez$integral == 0, "Functia introdusa nu are constanta de normalizare", 1/rez$integral )

}

f <- function(x) {
  if(x >= 0 && x <= 1)
    (exp(1)*(exp(-x)+exp(x)))/(exp(2)-1)
  else 0
}

g <- function(x) {
  if((x >= 0) && (x <= pi)) {sin(x)/2} else {0}
}

h <- function(x) {
  if((x >= 0) && (x <= pi)) {
    sin(x)/2
  } else {0}
}

norm_const(f)


#' Generate a damped random walk power spectrum.
#'
#' \deqn{PSD(f) = \frac{\tau^2 SF_\infty^2}{1 + (2 \pi f \tau)^2}}
#'
#' @param N Number of frequencies (must be even).
#' @param freq.max Value of largest frequency.
#' @param tau Characteristic timescale.
#' @param SF Value of structure function over long time scales.
#' @param sd Standard deviation.
#'
#' @return Frequencies and power spectral density.
#'
#' @examples
#' damped.random.walk(100)                # 100 samples with default options
#' damped.random.walk(100, freq.max = 50) # provide maximum frequency
#' damped.random.walk(100, sd = 2.0)      # provide standard deviation
#' damped.random.walk(100, tau = 2.0)     # provide characteristic timescale
#' damped.random.walk(100, SF = 2.0)      # provide value of structure function
#'
#' @export
damped.random.walk <- function(N, freq.max = 1/(2*pi),
                           tau = 1.0, SF = 1.0, sd = 1.0) {
    f <- freq(N, freq.max = freq.max)
    freq.pos <- f$freq.pos
    freq     <- f$freq

    # compute the mean values of the power spectrum's absolute value
    mean.power <- tau * SF * (1 + (2*pi * freq.pos*tau)^2)^-0.5

    # generate a noisy power spectrum in complex form
    z <- noisy.power.spectrum(mean.power, sd = sd)
    # include negative frequencies in the final spectrum, with opposite phase
    z <- mirror.complex(z)

    # return the power spectrum along with the frequencies
    rbind(freq, z)
}


# Sampling from easy distributions
# with the method of inversion
#
# author: Alberto Lumbreras
######################################
par(mfrow=c(1,1))

# demo 1: logistic distribution
# demo 2: exponential distribution
demo <- 1

# Logistic distribution
###########################
if(demo==1){

  # Plot density and cdf
  x <- seq(-10,10, by=0.1)
  plot(x, dlogis(x), type='l', lwd=3, col="black", ylim=c(0,1)) # density
  lines(x, plogis(x), lwd=3, col="red") # cdf
  title("Inverse method (Logistic distribution)")

  # Inverse CDF
  cdf_inv <- function(x, loc=0, scale=10){
    log(x/(1-x))
  }

}

# Exponential distribution
###########################
if(demo==2){

  # Plot density and cdf
  x <- seq(0,10, by=0.1)
  plot(x, dexp(x), type='l', lwd=3, col="black", ylim=c(0,1)) # density
  lines(x, pexp(x), lwd=3, col="red") # cdf
  title("Inverse method (Exponential distribution)")

  # Inverse CDF
  cdf_inv <- function(x){
    -log(1-x)
  }
}

# Sampling by the inverse method
#################################
nsamples <-100000
samples <- rep(NA,nsamples)
for (i in 1:nsamples){
  x <- runif(1)
  samples[i] <- cdf_inv(x)
}

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


library(markovchain)

set.seed(1)
States <- c("Rainy","Cloudy","Sunny")
TransMat <- matrix(c(0.30,0.50,0.20,0.25,0.4,0.35,0.1,0.2,0.70),nrow = 3, byrow = TRUE,dimnames = list(States,States))

MarkovChainModel <- new("markovchain",transitionMatrix=TransMat, states=States, byrow = TRUE, name="MarkovChainModel")
MarkovChainModel

states(MarkovChainModel)
dim(MarkovChainModel)

str(MarkovChainModel)
MarkovChainModel@transitionMatrix

library(diagram)

plot(MarkovChainModel,package="diagram")

transitionProbability(MarkovChainModel, "Sunny", "Rainy")

StartState<-c(0,0,1)

Pred3Days <- StartState * (MarkovChainModel ^ 3)
print (round(Pred3Days, 3))
Pred1Week <- StartState * (MarkovChainModel ^ 7)
print (round(Pred1Week, 3))

steadyStates(MarkovChainModel)

YearWeatherState <- rmarkovchain(n = 365, object = MarkovChainModel, t0 = "Sunny")
YearWeatherState[1:40]


# Bayesian approach:
gibbs1 = function(iters,y,alpha){
  x<-array(0,c(iters+1,3))
  beta = 0.0446
  x[1,1] = 8.625 # initial lamda value.
  x[2,2] =  (0.20 * sum(y)) # OD initial value.
  temp = c()

  # Posterior Distribution is gamma distribution for parameter lamda.
  total_probability = function(lamda,X){
    a = 0
    for (i in 1:8){
      xp = (exp(-lamda)*lamda^(X[i]))/factorial(X[i])
      a = a + xp
    }
    return(mean(a))
  }

  for (t in 2: (iters+1)){

    x[t,1] = rgamma(1, (x[t,2] + (sum(y) - x[t,2]) + alpha), 8 + beta)
    z = c(9,16,6,8,15,8,2,5) # these are the units failed in a hourly basis in the sample dataset.
    # total probability of failure occurance.
    p = total_probability(x[t,1],z)
    x[t,3] = (0.20 * p) # this gives the probability of units failed beacuse of Other Defects.
    x[t,2] = rbinom(1,69,0.20 * p)
  }

  par(mfrow=c(1,2))
  plot(1:length(x[,1]),x[,1], type='l', lty=1, xlab='t', ylab='lambda')
  plot(1:length(x[,2]),x[,2], type='l', ylim=c(0,20), lty=1, xlab='t', ylab='OD')

  return(x)
  }
set.seed(123)
y=rpois(8, 8.625)

output = gibbs1(1000, y, 1)
output

# Lamda value.
absence<-(output[,1])
absent<-(absence [101:1000])
mean(absent) # posterior estimate for lambda.
var(absent) # variance associated with lamda.
# Posterior lamda distribution graph.
par(mfrow=c(1,1))
hist(absent,
     breaks=25,
     freq=F,
     main="Total Defects",
     xlab="Rate parameter(Units failed)",
     ylab="Density")

# Number of Other Defects caused.
OD <- (output[,2])
mean(OD) # mean number of Other defect occurance.

# Probibility sample of Other Defects occurance.
other_defect <- (output[,3])
other_defect_mean <- mean(other_defect) # mean probability of Other Defects Occurance.


# -- 1/ DATA : Let's build data.
# We have 3 species : Dicoccoides / Dicoccum / Durum
# We have 2 treatments : High or Low Nitrogen
# We have 4 samples per specie per treatment.
# For each sample we measure the expression of 5 genes

sample=paste(rep("sample_",24) , seq(1,24) , sep="")
specie=c(rep("dicoccoides" , 8) , rep("dicoccum" , 8) , rep("durum" , 8))
treatment=rep(c(rep("High",4 ) , rep("Low",4)),3)
data=data.frame(sample,specie,treatment)
for (i in seq(1:5)){
  gene=sample(c(1:40) , 24 )
  data=cbind(data , gene)
  colnames(data)[ncol(data)]=paste("gene_",i,sep="")
 }
data[data$treatment=="High" , c(4:8)]=data[data$treatment=="High" , c(4:8)]+100
data[data$specie=="durum" , c(4:8)]=data[data$specie=="durum" , c(4:8)]-30
data

# -- 2/ DISTANCES : I calculate distance between each state. For example, the euclidean distance
rownames(data)=data[,1]
dist=dist(data[ , c(4:8)] , diag=TRUE)

# -- 3/ HIERARCHICAL CLUSTERING

	# PRINCIPLE : We have distances between objects. We seek the smallest distance between 2 objects. We aggregate the 2 objects in a cluster. These 2 points are replaced by theyr barycenter.
	# Then we seek the two points or cluster that have the smallest distance. We repeat until having only one cluster containing every points.
	# There are several ways to calculate the distance between 2 clusters ( using the max between 2 points of the clusters, or the mean, or the min, or ward (default) ).

	# In R, this method is implemented in the Hclust algorythm.
	hc=hclust(dist)

# -- 4/ EASY REPRESENTATION

	# Easiest representation (2 options) : It's completely different ! So I have to be carefull concerning the distance calculation method !
	png("#29_basic_dendrogram.png" , width = 480, height = 480)
	par(mar=c(3,4,2,2))
	plot(hc)
	dev.off()


library(tidyr)
library(ggplot2)
library(dplyr)
library(cowplot)
library(readr)

t <- read_csv("../processed_results/equilib_test_N100_max1.csv")
s_lst <- unique(t$sel_coef)

predict_mean_fitness <- function(Ne, L, s, eps)
{
  k <- c(0:L)
  f <- exp(-s*k^(1-eps))
  p_k <- (f^(2*Ne-2)*choose(L, k))/sum(f^(2*Ne-2)*choose(L, k))
  sum(f*p_k)
}

for (s in s_lst) {

  t %>%
    filter(sel_coef==s) %>%
    mutate(q=1-epistasis_coef) -> t_filtered

  p <- ggplot(t_filtered, aes(x=time, y=mean_fitness,color=factor(k_start)))+
    background_grid(major = c("xy"))+
    geom_line(size=1.1)+
    xlab('Time (million generations)')+
    ylab('Mean fitness')+
    scale_y_continuous(breaks=seq(0,1,0.2))+
    scale_x_continuous(breaks=seq(0,4000000,1000000),labels=c("0","1","2","3","4"))+
    coord_cartesian(ylim=c(0,1),xlim=c(0,4000000))+
    facet_grid(mu_prob ~ q)+
    theme(axis.title = element_text(size = 20),
          axis.text = element_text(size = 14),
          legend.position="none")

  save_plot(paste0("../plots/fit_v_time_s",s,"_N100_max1.png"),
            base_width=10,
            base_height=8, p)
}

t %>%
  mutate(q=1-epistasis_coef) %>%
  filter(sel_coef==0.01, q==1.45, mu_prob==0.0001)  -> t_filtered

w_ave <- predict_mean_fitness(100, 100, 0.01, 1-1.45)

p <- ggplot(t_filtered, aes(x=time, y=mean_fitness,color=factor(k_start)))+
  background_grid(major = c("xy"))+
  geom_line(size=1.1)+
  xlab('Time (million generations)')+
  ylab('Mean fitness')+
  geom_hline(yintercept=w_ave,size=1.1)+
  scale_y_continuous(breaks=seq(0,1,0.2))+
  scale_x_continuous(breaks=seq(0,4000000,1000000),labels=c("0","1","2","3","4"))+
  coord_cartesian(ylim=c(0,1),xlim=c(0,4000000))+
  theme(axis.title = element_text(size = 16),
        axis.text = element_text(size = 14),
        legend.position="none")

save_plot(paste0("../plots/one_facte_fit_v_time_s0.01_N100_max1.png"),
          base_width=6,
          base_height=6, p)


# Example : 3   Chapter : 6.6     Page No: 357
# Pascals matrix and its inverse are similar
A<-matrix(c(1,1,1,1,0,1,2,3,0,0,1,3,0,0,0,1),ncol=4)
A1<-solve(A)
Aev<-eigen(A)$values
A1ev<-eigen(A1)$values
print("Both pascal matrix and its inverse have same eigen values")
print(Aev)
print(A1ev)


#selecting and grouping data
#keeping -> selecting variables through indexes or ... %in%
#dropping -> ommitting variables through -indexes or !
mons = c("March", "April", "January", "November", "January", "September",
         "October", "September", "November", "August", "January", "November",
         "November", "February", "May", "August", "July", "December",
         "August", "August", "September", "November", "February", "April")
fmons = factor(mons, ordered = TRUE) #the labels are ordered in alphabetical order
tmons = table(fmons)
vars = names(tmons) %in% c("January", "April", "March")
tmons.new = tmons[!vars]
tmons.new2 = tmons[-c(1,5,7)]
#selection using whitch() or subset()
#appending a vector at specific index using append()
#joinning data.frames using merge()

#operations on tables
#apply(array, margin, function, ...) -> returns vector with the result of function
mat = matrix(rep(seq(4),4), ncol = 4)
sum.by.row = apply(mat, MARGIN = 1, FUN = sum) #margin = 1 means by rows
sum.by.column = apply(mat, MARGIN = 2, FUN = sum) #margin = 2 means by colums
sum.2 = apply(mat, MARGIN = 1, function(x) sum(x) + 2) #to every row sum adds two

#lapply(list, function,...) -> returns list, used when working with data.frames
mat.df = data.frame(mat)
lapply(mat.df, FUN = sum)
y = lapply(mat.df, FUN = function(x,y) sum(x) + y, y =5)
print = lapply(1:5, FUN = function(i) print(i)) #simulates loop

#tapply(array, indicies, function, ..., simplify) -> returns a vector or matrix with dimentions according to indicies
#if simplify = FALSE returns a list
x1 = runif(16) #16 random numbers between 0 and 1
cat1 = rep(1:4,4)
cat2 = c(rep(1,8), rep(2,8))
mat2.df = data.frame(x1)
mat2.df$cat1 = cat1 #adding vector cat1 to the data frame
mat2.df$cat2 = cat2 #adding vector cat2 to the data frame
tapply(mat2.df$x1, mat2.df$cat1, mean)

#agregation from data.frame
dates <- data.frame(date = as.Date("2001-01-01", format = "%Y-%M-%D")+ 0:729, data=0:729) #????
last.day <- aggregate(x = dates["date"], by = list(month = substr(dates$date, 1, 7)), FUN = max)
last.data <- aggregate(x = dates["data"], by = list(month = substr(dates$date, 1, 7)), FUN = max)

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

#02
m = 2.5
a = c(0,1.5,2)
b = c(2,0,1.5)
c = c(2,1,0.5)
mat = matrix(c(a,b,c), ncol = 3, byrow = TRUE)
apply(mat, MARGIN = 1, FUN = function(x,m) (sum(x)*m)/sum(c(m,m,m)), m = m)

#03
x2.0 = c(1/8, 1/8, 0, 0)
X2.1 = c(0, 2/8, 2/8, 0)
X2.2 = c(0, 0, 1/8, 1/8)
m = matrix(c(x2.0, X2.1, X2.2), ncol = 4, byrow = TRUE, dimnames = list(c(0,1,2), c(0,1,2,3)))
p.x1 = apply(m, MARGIN = 2, FUN = sum) #marginal probability for x1
p.x2 = apply(m, MARGIN = 1, FUN = sum) #marginal probability for x2
sum(p.x1)
sum(p.x2)
e.x1 = sum(p.x1 * as.numeric(names(p.x1)))
e.x2 = sum(p.x2 * as.numeric(names(p.x2)))
e.x1.sq = sum(p.x1 * (as.numeric(names(p.x1)))^2 )
e.x2.sq = sum(p.x2 * (as.numeric(names(p.x2)))^2)
d.x1 = e.x1.sq - e.x1^2
d.x2 = e.x2.sq - e.x2^2

EX1 = apply(m, MARGIN = 2, FUN = function(x,y) sum(x*y), y=c(0:2))
EX2 = apply(m, MARGIN = 1, FUN = function(x,y) sum(x*y), y=c(0:3))

#04
aggregate(mtcars, by=list(mtcars$cyl, mtcars$vs), FUN="mean")


set.seed(123)

bernoulli_rng <- sample.int(n=2, size=10, replace=TRUE, prob=c(0.8, 0.2)) - 1
#=> [1] 0 0 0 1 1 0 0 1 0 0

categorical_rng <- sample.int(n=5, size=10, replace=TRUE, prob=c(0.1, 0.2, 0.25, 0.35, 0.1))
#=> [1] 1 3 2 3 4 5 4 4 4 1