#Suppose the food label on a cookie bag states that there is at most 2 grams
#of saturated fat in a single cookie. In a sample of 35 cookies, it is
#found that the mean amount of saturated fat per cookie is 2.1 grams.
#Assume that the sample standard deviation is 0.3 gram. At .05 significance
#level, can we reject the claim on food label?

xbar = 2.1
mu0 = 2

s = 0.3

n = 35

t = (xbar-mu0)/(s/(sqrt(n)))

t #1.9720

alpha = 0.05

#Valores criticos
t.alpha = qt(1-alpha,df = n-1)

#rechazamos la hipotesis
t.alpha #1.6991

pval = pt(t,df=n-1,lower.tail = FALSE)

Parcial/1. Prueba de hipotesis/UpperTailMeanUnknownVariance.r


# Declaration of variables with raw data
rawData <- c(33, 24, 17, 26)
avoidanceRawData <- c("Avoidance behaviour", "No avoidance behaviour")
parasitedRawData <- c("Unparasitised", "Parasitised")

# Creation of 2*2 matrix using rownames() and colnames()
matrixAvoidanceBehaviourRates <- matrix(rawData, ncol=2, nrow=2, byrow="TRUE")
rownames(matrixAvoidanceBehaviourRates) <- avoidanceRawData
colnames(matrixAvoidanceBehaviourRates) <- parasitedRawData

# Draw a barplot using barplot() include a legend with legend()
barplot(matrixAvoidanceBehaviourRates,
main = "Fish Parasitism and Predator Avoidance",
xlab = "Fish Parasitism",
ylab = "Number of fish",
col = c("red","blue")
)

legend('topleft',
legend = avoidanceRawData,
title = "Predator Avoidance",
fill = c("red","blue"),
bg = c("white")
)

# Carry out a chi square test for independence of data using chisq.test()
chisq <- chisq.test(matrixAvoidanceBehaviourRates)

chisq
# Pearson's Chi-squared test with Yates' continuity correction executed
# RESULT => X-squared = 2.6112, df = 1, p-value = 0.1061
# What is a null hypothesis?
# What are the assumptions behind a chi square test? Do your data meet them?
# What does the statistical test tell you?


M <- 1E6
theta.samp.1 <- rnorm(M, mean = 0, sd = sqrt(2.19))
theta.samp.2 <- rcauchy(M)

predictive.X1 <- rnorm(M, mean = theta.samp.1, sd = 1)
predictive.X2 <- rnorm(M, mean = theta.samp.2, sd = 1)

library(ggplot2)

forplot <- data.frame(x_pred = c(predictive.X1, predictive.X2),
                      prior = rep(c("Normal", "Cauchy"), each = M))

p0 <- ggplot(forplot,
                      aes(x = x_pred, colour = prior, fill = prior)) +
       geom_density(alpha = .4) +
  scale_x_continuous(expression(x[pred]), limits = c(-10, 10)) +
  scale_y_continuous("Density", expand = c(0, 0)) +
  theme_bw(base_size = 16) +
  geom_vline(xintercept = c(-4, 4), linetype = "longdash") +
  theme(legend.position = "bottom",
        legend.justification = "centre",
        legend.title = element_blank(),
        strip.background = element_blank(),
        strip.text.y = element_blank(),
        legend.margin = margin(0, 0, 0, 0),
        legend.box.margin = margin(0, 0, 0, 0))

p0

ggsave(plot = p0, filename = "../slides/figures/BC_example_326.pdf")

#### Second part: inference
## First let's generate some data

N <- 3
true_theta <- -20
X <- rnorm(n = N, mean = true_theta, sd = 1)

## Now let's fit the model under both priors
library(cmdstanr)
library(rstan)
stanfit <- function(fit) rstan::read_stan_csv(fit$output_files())

example_326  <- cmdstanr::cmdstan_model("stan/BC_example_326.stan")

stan.data <- list(N = N, x = X, prior = 1)
fit.normal <- stanfit(example_326$sample(data = stan.data, refresh = 0))
stan.data$prior <- 2
fit.cauchy <- stanfit(example_326$sample(data = stan.data, refresh = 0))

theta.df <- data.frame(
  theta = c(extract(fit.normal, 'theta')$theta,
            extract(fit.cauchy, 'theta')$theta)
)
theta.df$prior <- rep(c("Normal", "Cauchy"), each = nrow(theta.df)/2)

## Compare posteriors
p1 <- ggplot(theta.df,
             aes(x = theta, colour = prior, fill = prior)) +
  geom_density(alpha = .4) +
  scale_x_continuous(expression(theta)) +
  scale_y_continuous("Density", expand = c(0, 0)) +
  theme_bw(base_size = 16) +
  theme(legend.position = "bottom",
        legend.justification = "centre",
        legend.title = element_blank(),
        strip.background = element_blank(),
        strip.text.y = element_blank(),
        legend.margin = margin(0, 0, 0, 0),
        legend.box.margin = margin(0, 0, 0, 0))
p1

## Compare posterior predictives
pred.df <- data.frame(
  x_pred = c(as.vector(extract(fit.normal, 'x_pred')$x_pred),
             as.vector(extract(fit.cauchy, 'x_pred')$x_pred))
)
pred.df$prior <- rep(c("Normal", "Cauchy"), each = nrow(pred.df)/2)

p2 <- ggplot(pred.df,
             aes(x = x_pred, colour = prior, fill = prior)) +
  geom_density(alpha = .4) +
  scale_x_continuous(expression(x[pred])) +
  scale_y_continuous("Density", expand = c(0, 0)) +
  theme_bw(base_size = 16) +
  # geom_vline(xintercept = c(-4, 4), linetype = "longdash") +
  theme(legend.position = "bottom",
        legend.justification = "centre",
        legend.title = element_blank(),
        strip.background = element_blank(),
        strip.text.y = element_blank(),
        legend.margin = margin(0, 0, 0, 0),
        legend.box.margin = margin(0, 0, 0, 0))

p2


### lowess(example) ====================================================================

# creating noisy time series with a sinus signal
n.time.steps <- 100 # number of data
time.seq <- 1:n.time.steps # time index
n.waves <- .7 # number waves during time period
length.wave <- n.time.steps / n.waves # number of time steps for complete wave
wave <- 5 + 2 * sin(2 * pi * time.seq / length.wave) # create weave trend
wave.noisy <- rnorm(n = n.time.steps, mean = wave, sd = 1.5) # add noise

# plot the data
plot(time.seq, wave.noisy, pch = 16,
     xlab = 'Time step',
     ylab = 'My time series')
# add lowess curves with different degrees
lines(lowess(wave.noisy, f = 1), col = 'red', lwd = 2)
lines(lowess(wave.noisy, f = 1 / 3), col = 'blue', lwd = 2)
lines(lowess(wave.noisy, f = 1 / 10), col = 'green', lwd = 2)
# add a legend
legend('bottomleft',
       c('f = 1', 'f = .3', 'f = .1'),
       lty = c(1, 1, 1),
       col = c('red', 'blue', 'green'),
       bty = 'n')


# #		Question	Answer

dataframe = read.csv('BikeData.csv')

# 1.		Examining the dataset
# a)	What is the age of the 7th rider in the dataset?

dataframe[7,]['age']

# b)	How many of the first 10 riders in the dataset ride daily?

nrow(subset(dataframe[1:10,], cyc_freq == 'Daily'))

# c)	What is the speed of the first female who cycles less than one time per month (in miles/hour)?

subset(dataframe, gender == 'F' & cyc_freq == 'Less than once a month')[1,]['speed']

# 2.
# a)	What type of variable is student?

sapply(dataframe['student'], class)

#   b)	What type of variable is cyc_freq?

sapply(dataframe['cyc_freq'], class)

#   c)	What type of variable is distance?

sapply(dataframe['distance'], class)

#   3.

table(dataframe$student)

# a)	What is the name of the dataframe?

# bike

#   b)	What is the name of the variable?

# student

# 4.  student <- bike[bike$student==1,]

#   What is the role of the comma?
#   [1] It tells R to include all the variables (columns) for the riders that are students
#   [2] It tells R to include all the students (rows), beginning with the first one	- answer

#   What does "student" refer to in this line of code?:
#   table(student$cyc_freq)
#   [1] the original variable called "student"
#   [2] the new dataframe called "student" - answer

# 5.	Research Question:
# How many of the cyclists were students, how often did they ride, and what was the average distance they rode?
# Write R code to conduct analysis

# a)	Find the number of students in the dataset.
nrow(dataframe[dataframe$student==1,])

# b)	Pull out the student data into a separate dataframe for analysis.
students = dataframe[dataframe$student==1,]
students

# c)	Make a table to find how often the students ride.
table(students['cyc_freq'])

# d)	Find the average distance ridden
colMeans(students['distance'])

# 6.		Find answers for the following from the code you have executed

# a)	How many students are in the dataset?
# 14
# How many variables are in the new data frame "student"?
# 8

# b)	We want to know how often the students ride. What is the most frequently observed response?
# Daily

# How is the vector "distance" described in the workspace?
describe(students['distance'])

#   c)	How far do students ride on average?
#   7.		Conclusion
# We examined data on ------- student riders. Most of the student riders ( a total of ----- out of ------) rode their bikes -------.  On average, the students rode about -------miles on each trip.
# We examined data on 14 student riders. Most of the student riders (a total of 8 out of 14) rode their bikes Daily.  On average, the students rode about 6.25 miles on each trip.


# variable y  with normal distribution N(??, ??), where ??=70 and ?? = 13
#  the probability that a measurement will be less than 60 is given by
pnorm(60,mean =70,sd=13)
#  probability that a randomly selected vehicle will have emission levels greater than 90 ppb
pnorm(90,mean =70,sd=13,lower.tail = FALSE)
# the probability that a randomly selected vehicle will have emission levels between 60 and 90 ppb
pnorm(90,mean =70,sd=13)-pnorm(60,mean =70,sd=13)


#!/usr/bin/Rscript
# Copyright © 2016 Martin Ueding <dev@martin-ueding.de>
# Licensed under the MIT license.

pdf = function(x) {
    1 / (pi * (1 + x^2))
}

inverse_cdf = function(u) {
    tan(pi * (u - 1/2))
}

bin_count = 50
samples_count = 100000

###############################################################################
#                           Inverse Function Method                           #
###############################################################################

# Plot the original function.
x_orig = seq(-5, 5, length.out=200)
y_orig = pdf(x_orig)
plot(x_orig, y_orig, type='l', main='Original PDF', xlab='x', ylab='y')

# Plot the inverse function.
u_inv_cdf = seq(0.02, 0.98, length.out=100)
x_inv_cdf = inverse_cdf(u_inv_cdf)
plot(u_inv_cdf, x_inv_cdf, type='l', main='Inverse CDF', xlab='u', ylab='x')

# Sample from uniform and transform it.
start = proc.time()
u = runif(samples_count)
x = inverse_cdf(u)
end = proc.time()
duration_inverse_cdf = end - start
cat('Time for Inverse Function:', duration_inverse_cdf, '\n')

# There is a complication that the resulting values span the whole real
# numbers. We cannot sensibly display that in a histogram. Therefore we need to
# limit the histogram. Just using `xlim` here does not suffice; it would just
# adjust the plotting window. We want to have the bins focussed in a sensible
# interval. R would complain if the bins do not cover all the values, so we
# need to select the interesting values as well.
selection = -5 < x & x < 5
hist(x[selection], breaks=seq(-5, 5, length.out=bin_count), freq=FALSE,
     main='Sampling with Inverse Function Method')

# By not using all data points, we effectively have sampled a different pdf.
# This means that the normalization is off, we need to correct for that.
factor = samples_count / sum(selection)
lines(x_orig, y_orig * factor, col='red')

###############################################################################
#                                Ratio Method                                 #
###############################################################################

start = proc.time()
x = rnorm(samples_count)
y = rnorm(samples_count)
z = x / y
end = proc.time()
duration_inverse_cdf = end - start
cat('Time for Ratio:', duration_inverse_cdf, '\n')

selection = -5 < z & z < 5
hist(z[selection], breaks=seq(-5, 5, length.out=bin_count), freq=FALSE,
     main='Sampling with Ratio Method')

factor = samples_count / sum(selection)
lines(x_orig, y_orig * factor, col='red')


# Assign a value to the variables
var1 <- 4
var2 <- 2

var <- var1 + var2

# Check class of my_logical
class(var)

numeric_vector <- c(1, 10, 49)
character_vector <- c("a", "b", "c")

# Complete the code for boolean_vector
boolean_vector <-c(TRUE, FALSE, TRUE)

# Poker winnings from Monday to Friday
poker_vector <- c(140, -50, 20, -120, 240)

# Assign days as names of poker_vector
names(poker_vector) <- c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday")

poker_vector[2:5]
# Select poker results for Monday, Tuesday and Wednesday
poker_start <- poker_vector[c("Monday","Tuesday", "Wednesday")]

# Calculate the average of the elements in poker_start
mean(poker_start)

# Box office Star Wars (in millions!)
new_hope <- c(460.998, 314.4)
empire_strikes <- c(290.475, 247.900)
return_jedi <- c(309.306, 165.8)

# Construct matrix
star_wars_matrix <- matrix(c(new_hope, empire_strikes, return_jedi), nrow = 3, byrow = TRUE)

# Vectors region and titles, used for naming
region <- c("US", "non-US")
titles <- c("A New Hope", "The Empire Strikes Back", "Return of the Jedi")

# Name the columns with region

colnames(star_wars_matrix) <- region

# Name the rows with titles
rownames(star_wars_matrix) <- titles

# Print out star_wars_matrix
star_wars_matrix

# Construct star_wars_matrix
box_office <- c(460.998, 314.4, 290.475, 247.900, 309.306, 165.8)

star_wars_matrix <- matrix(box_office, nrow = 3, byrow = TRUE,
                           dimnames = list(c("A New Hope", "The Empire Strikes Back", "Return of the Jedi"),
                                           c("US", "non-US")))

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

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

ls()
#Just like cbind() has rbind(), colSums() has rowSums().

#Those who are familiar with matrices should note that this is not the standard matrix multiplication for which you should use %*% in R.

# Create factor_speed_vector
speed_vector <- c("medium", "slow", "slow", "medium", "fast")
factor_speed_vector <- factor(speed_vector, ordered = TRUE, levels = c("slow", "medium", "fast"))

# Factor value for second data analyst
da2 <- factor_speed_vector[2]

# Factor value for fifth data analyst
da5 <- factor_speed_vector[5]

# Definition of vectors
name <- c("Mercury", "Venus", "Earth", "Mars", "Jupiter", "Saturn", "Uranus", "Neptune")
type <- c("Terrestrial planet", "Terrestrial planet", "Terrestrial planet",
          "Terrestrial planet", "Gas giant", "Gas giant", "Gas giant", "Gas giant")

diameter <- c(0.382, 0.949, 1, 0.532, 11.209, 9.449, 4.007, 3.883)
rotation <- c(58.64, -243.02, 1, 1.03, 0.41, 0.43, -0.72, 0.67)

rings <- c(FALSE, FALSE, FALSE, FALSE, TRUE, TRUE, TRUE, TRUE)

# Create a data frame from the vectors
planets_df <- data.frame(name, type, diameter,rotation,rings)

# Play around with the order function in the console
a <- c(100, 10, 1000)
order(a)

#to reshuffle a
a[order(a)]

# Vector with numerics from 1 up to 10
my_vector <- 1:10

# Matrix with numerics from 1 up to 9
my_matrix <- matrix(1:9, ncol = 3)

# First 10 elements of the built-in data frame mtcars
my_df <- mtcars[1:10,]

# Construct list with these different elements:
my_list <- list(my_vector, my_matrix, my_df)

# Print out the vector representing the actors
 shining_list[[2]]

# Print the second element of the vector representing the actors
shining_list[[2]][2]
 here()


##### Chapter 5: Classification using Decision Trees and Rules -------------------

#### Part 1: Decision Trees -------------------

## Understanding Decision Trees ----
# calculate entropy of a two-class segment
-0.60 * log2(0.60) - 0.40 * log2(0.40)

curve(-x * log2(x) - (1 - x) * log2(1 - x),
      col = "red", xlab = "x", ylab = "Entropy", lwd = 4)

## Example: Identifying Risky Bank Loans ----
## Step 2: Exploring and preparing the data ----
credit <- read.csv("credit.csv")
str(credit)

# look at two characteristics of the applicant
table(credit$checking_balance)
table(credit$savings_balance)

# look at two characteristics of the loan
summary(credit$months_loan_duration)
summary(credit$amount)

# look at the class variable
table(credit$default)

# create a random sample for training and test data
# use set.seed to use the same random number sequence as the tutorial
set.seed(123)
train_sample <- sample(1000, 900)

str(train_sample)

# split the data frames
credit_train <- credit[train_sample, ]
credit_test  <- credit[-train_sample, ]

# check the proportion of class variable
prop.table(table(credit_train$default))
prop.table(table(credit_test$default))

## Step 3: Training a model on the data ----
# build the simplest decision tree
library(C50)
credit_model <- C5.0(credit_train[-17], credit_train$default)

# display simple facts about the tree
credit_model

# display detailed information about the tree
summary(credit_model)

## Step 4: Evaluating model performance ----
# create a factor vector of predictions on test data
credit_pred <- predict(credit_model, credit_test)

# cross tabulation of predicted versus actual classes
library(gmodels)
CrossTable(credit_test$default, credit_pred,
           prop.chisq = FALSE, prop.c = FALSE, prop.r = FALSE,
           dnn = c('actual default', 'predicted default'))

## Step 5: Improving model performance ----

## Boosting the accuracy of decision trees
# boosted decision tree with 10 trials
credit_boost10 <- C5.0(credit_train[-17], credit_train$default,
                       trials = 10)
credit_boost10
summary(credit_boost10)

credit_boost_pred10 <- predict(credit_boost10, credit_test)
CrossTable(credit_test$default, credit_boost_pred10,
           prop.chisq = FALSE, prop.c = FALSE, prop.r = FALSE,
           dnn = c('actual default', 'predicted default'))

## Making some mistakes more costly than others

# create dimensions for a cost matrix
matrix_dimensions <- list(c("no", "yes"), c("no", "yes"))
names(matrix_dimensions) <- c("predicted", "actual")
matrix_dimensions

# build the matrix
error_cost <- matrix(c(0, 1, 4, 0), nrow = 2, dimnames = matrix_dimensions)
error_cost

# apply the cost matrix to the tree
credit_cost <- C5.0(credit_train[-17], credit_train$default,
                          costs = error_cost)
credit_cost_pred <- predict(credit_cost, credit_test)

CrossTable(credit_test$default, credit_cost_pred,
           prop.chisq = FALSE, prop.c = FALSE, prop.r = FALSE,
           dnn = c('actual default', 'predicted default'))

#### Part 2: Rule Learners -------------------

## Example: Identifying Poisonous Mushrooms ----
## Step 2: Exploring and preparing the data ----
mushrooms <- read.csv("mushrooms.csv", stringsAsFactors = TRUE)

# examine the structure of the data frame
str(mushrooms)

# drop the veil_type feature
mushrooms$veil_type <- NULL

# examine the class distribution
table(mushrooms$type)

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

# train OneR() on the data
mushroom_1R <- OneR(type ~ ., data = mushrooms)

## Step 4: Evaluating model performance ----
mushroom_1R
summary(mushroom_1R)

## Step 5: Improving model performance ----
mushroom_JRip <- JRip(type ~ ., data = mushrooms)
mushroom_JRip
summary(mushroom_JRip)

# Rule Learner Using C5.0 Decision Trees (not in text)
library(C50)
mushroom_c5rules <- C5.0(type ~ odor + gill_size, data = mushrooms, rules = TRUE)
summary(mushroom_c5rules)


# Code profiling
# Profiling helps you locate the bottlenecks in your code

# A. Code profiling
# 1. Profvis in action
# Load the data set
data(movies, package = "ggplot2movies")

# Load the profvis package
library(profvis)

# Profile the following code with the profvis function
profvis ({
  # Load and select data
  comedies <- movies[movies$Comedy == 1, ]

  # Plot data of interest
  plot(comedies$year, comedies$rating)

  # Loess regression line
  model <- loess(rating ~ year, data = comedies)
  j <- order(comedies$year)

  # Add fitted line to the plot
  lines(comedies$year[j], model$fitted[j], col = "red")
})

# 2. Change the data frame to a matrix to help with performance
# Load the microbenchmark package
library(microbenchmark)

# The previous data frame solution is defined
# d() Simulates 6 dices rolls
d <- function() {
  data.frame(
    d1 = sample(1:6, 3, replace = TRUE),
    d2 = sample(1:6, 3, replace = TRUE)
  )
}

# Complete the matrix solution
m <- function() {
  matrix(sample(1:6, 6, replace = TRUE), ncol = 2)
}

# Use microbenchmark to time m() and d()
microbenchmark(
 data.frame_solution = d(),
 matrix_solution     = m()
)

# 3. Calculating row sums
# Example data
rolls

# Define the previous solution
app <- function(x) {
    apply(x, 1, sum)
}

# Define the new solution
r_sum <- function(x) {
    rowSums(x)
}

# Compare the methods
microbenchmark(
    app_sol = app(rolls),
    r_sum_sol = r_sum(rolls)
)

# 4. Use && instead of &
# The additional ampersand aims to review each logical statement as it goes. This means that if the first logical statement
# returns FALSE then the final result will always be FALSE. Whereas the single ampersand will aim to review each logical
# statement even if the first value returns FALSE
# Example data
is_double

# Define the previous solution
move <- function(is_double) {
    if (is_double[1] & is_double[2] & is_double[3]) {
        current <- 11 # Go To Jail
    }
}

# Define the improved solution
improved_move <- function(is_double) {
    if (is_double[1] && is_double[2] && is_double[3]) {
        current <- 11 # Go To Jail
    }
}

# microbenchmark both solutions
# Very occassionally the improved solution is actually a little slower
# This is just random chance
microbenchmark(move(is_double), improved_move(is_double), times = 1e5)


fact <- function(n) {
  if ( n <= 1 ) 1
  else n * fact(n-1)
}


# Assignment: ASSIGNMENT 6
# Name: Angel, Daniel
# Date: 2020-08-01

## Set the working directory to the root of your DSC 520 directory
setwd("C:/Users/Danny/Documents")

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

## Load the ggplot2 library
library(ggplot2)

## Fit a linear model using the `age` variable as the predictor and `earn` as the outcome
age_lm <-  lm(earn ~ age, data = heights_df)

## View the summary of your model using `summary()`
summary(age_lm)

## Creating predictions using `predict()`
age_predict_df <- data.frame(earn = predict(age_lm, heights_df), age= heights_df$age)

## Plot the predictions against the original data
  ggplot(data = heights_df, aes(y = earn, x = age)) +
    geom_point(color='blue')  +
    geom_line(color='red',data = age_predict_df, aes(y= earn, x= age))

mean_earn <- mean(heights_df$earn)
mean_earn
## Corrected Sum of Squares Total
sst <- sum((mean_earn - heights_df$earn)^2)
sst
## Corrected Sum of Squares for Model
ssm <- sum((mean_earn - age_predict_df$earn)^2)
ssm
## Residuals
residuals <- heights_df$earn - age_predict_df$earn
## Sum of Squares for Error
sse <- sum(residuals^2)
sse
## R Squared R^2 = SSM\SST
r_squared <- ssm/sst
r_squared
## Number of observations
n <- nrow(heights_df)
n
## Number of regression parameters
p <- 2
p
## Corrected Degrees of Freedom for Model (p-1)
dfm <- p-1
dfm
## Degrees of Freedom for Error (n-p)
dfe <- n-p
dfe
## Corrected Degrees of Freedom Total:   DFT = n - 1
dft <- n-1
dft
## Mean of Squares for Model:   MSM = SSM / DFM
msm <- ssm/dfm
msm
## Mean of Squares for Error:   MSE = SSE / DFE
mse <- sse/dfe
mse
## Mean of Squares Total:   MST = SST / DFT
mst <- sst/dft
mst
## F Statistic F = MSM/MSE
f_score <- msm/mse
f_score
## Adjusted R Squared R2 = 1 - (1 - R2)(n - 1) / (n - p)
adjusted_r_squared <- 1-((1-r_squared)*(dft)/dfe)
adjusted_r_squared
## Calculate the p-value from the F distribution
p_value <- pf(f_score, dfm, dft, lower.tail=F)
p_value


source("exact.r")

# Darwin's finches dataset
a <- c(14,13,14,10,12,2,10,1,10,11,6,2,17)  # row sums
b <- c(4,4,11,10,10,8,9,10,8,9,3,10,4,7,9,3,3)  # column sums
matrix_type <- 0  # 0: binary, 1: nonnegative integer

# Count the number of matrices with row sums a and column sums b
number <- count(a,b,matrix_type)
# (or, to specify the filenames to be used:)
# number <- count(a,b,matrix_type,'input.txt','table.bin')
cat('Number of matrices =',number,'\n')

# Draw some random samples from the uniform distribution on this set of matrices
number_of_samples <- 3
x <- sample(a,b,number_of_samples)
# (or, to specify the filenames to be used:)
# x <- sample(a,b,number_of_samples,'input.txt','table.bin','output.txt')

# Display samples
for (i in 1:number_of_samples) {
    write.table(x[,,i], row.names = FALSE, col.names = FALSE)
    cat('\n')
}


# Load dataset
dataset2 <- read.csv("dataset2.csv", quote="")
# Print summary of dataset
summary(dataset2)

# Perform MANOVA analysis
manova_results <- manova(cbind(time, error) ~ menu, data=dataset2)
print("Summary of Manova Analysis:")
# Print summary of MANOVA
summary(manova_results)
# Get the p_value of the test
p_value <- summary(manova_results)$stats[[1,6]]
print(p_value)

if (p_value < 0.05) {  # If p_value < 0.05: reject the null hypothesis
  print("p_value is less than 0.05. Hence the results are not by chance variation and the null hypothesis is rejected. There is significant effect of independent variable menu type on dependent variable access time and error.")
} else {  # Else accept the null hypothesis
  print("p_value is greater than or equal to 0.05. Hence the results could be by chance variation and we cannot reject the null hypothesis. There is no significant effect of independent variable menu type on dependent variable access time and error.")
}

# Perform ANOVA analysis
print("Perform ANOVA analysis to find out which dependent variable (time or error) does the independent variable (menu) has a significant effect on.")
anova_results <- summary.aov(manova_results)
print(anova_results)

# Analyze effect of menu on time
p_value_time <- anova_results$` Response time`$`Pr(>F)`[[1]]
print(paste("p_value time: ", p_value_time))
if (p_value_time < 0.05) {
  print("p_value of time is less than 0.05. Hence independent variable menu has significant effect on dependent variable time.")
} else {
  print("p_value of time is not less than 0.05. Hence independent variable menu does not have a significant effect on dependent variable time.")
}

# Analyze effect of menu on error
p_value_error <- anova_results$` Response error`$`Pr(>F)`[[1]]
print(paste("p_value error: ", p_value_error))
if (p_value_error < 0.05) {
  print("p_value of error is less than 0.05. Hence independent variable menu has significant effect on dependent variable error")
} else {
  print("p_value of error is not less than 0.05. Hence independent variable menu does not have a significant effect on dependent variable error")
}

# Perform pairwise t-test with dependent variable time
t_test_results <- pairwise.t.test(dataset2$time, dataset2$menu, p.adjust.method = "bonferroni", paired = TRUE)
print(t_test_results)

# One tailed t-test between toolpalette and controlmenu
toolpalette <- subset(dataset2, menu == "toolpalette")
controlmenu <- subset(dataset2, menu == "controlmenu")
t_test_result <- t.test(toolpalette$time, controlmenu$time, alternative = "greater", paired = TRUE)
p_value <- t_test_result$p.value
print(paste("p_value toolpalette-controlmenu: ", p_value))

# One tailed t-test between toolpalette and flowmenu
toolpalette <- subset(dataset2, menu == "toolpalette")
flowmenu <- subset(dataset2, menu == "flowmenu")
t_test_result <- t.test(toolpalette$time, flowmenu$time, alternative = "greater", paired = TRUE)
p_value <- t_test_result$p.value
print(paste("p_value toolpalette-flowmenu: ", p_value))

# One tailed t-test between toolpalette and toolglass
toolpalette <- subset(dataset2, menu == "toolpalette")
toolglass <- subset(dataset2, menu == "toolglass")
t_test_result <- t.test(toolpalette$time, toolglass$time, alternative = "greater", paired = TRUE)
p_value <- t_test_result$p.value
print(paste("p_value toolpalette-toolglass: ", p_value))

# Perform pairwise t-test with dependent variable error
t_test_results <- pairwise.t.test(dataset2$error, dataset2$menu, p.adjust.method = "bonferroni", paired = TRUE)
print(t_test_results)

# One tailed t-test between toolglass and controlmenu
toolglass <- subset(dataset2, menu == "toolglass")
controlmenu <- subset(dataset2, menu == "controlmenu")
t_test_result <- t.test(toolglass$error, controlmenu$error, alternative = "less", paired = TRUE)
p_value <- t_test_result$p.value
print(paste("p_value toolglass-controlmenu: ", p_value))

# One tailed t-test between toolglass and flowmenu
toolglass <- subset(dataset2, menu == "toolglass")
flowmenu <- subset(dataset2, menu == "flowmenu")
t_test_result <- t.test(toolglass$error, flowmenu$error, alternative = "less", paired = TRUE)
p_value <- t_test_result$p.value
print(paste("p_value toolglass-flowmenu: ", p_value))

# One tailed t-test between toolglass and toolpalette
toolglass <- subset(dataset2, menu == "toolglass")
toolpalette <- subset(dataset2, menu == "toolpalette")
t_test_result <- t.test(toolglass$error, toolpalette$error, alternative = "less", paired = TRUE)
p_value <- t_test_result$p.value
print(paste("p_value toolglass-toolpalette: ", p_value))

# Visualizations
boxplot(time~menu,
        data=dataset2,
        main="Different boxplots for each menu",
        xlab="Menu",
        ylab="Time",
        frame = FALSE,
        col = c("#DDEDAA", "#F4AC45", "#FFCAB1", "#92BFB1"),
        border="black"
)

boxplot(error~menu,
        data=dataset2,
        main="Different boxplots for each menu",
        xlab="Menu",
        ylab="Error",
        frame = FALSE,
        col = c("#DDEDAA", "#F4AC45", "#FFCAB1", "#92BFB1"),
        border="black"
)

# between-within plot for time
B <- anova(lm(time ~ menu, data = dataset2))$"Mean Sq"
names(B) <- c("between", "within")
barplot(B, main = "Between vs. within", xlab = "Group (Menu)", ylab = "Sum of Squares (Time)", col = c("#DDEDAA", "#F4AC45"))

# between-within plot for error
B <- anova(lm(error ~ menu, data = dataset2))$"Mean Sq"
names(B) <- c("between", "within")
barplot(B, main = "Between vs. within", xlab = "Group (Menu)", ylab = "Sum of Squares (Error)", col = c("#DDEDAA", "#F4AC45"))


# Poisson Distribution
# Poisson probability of observing y events in a unit of time or space is given by the formula
# probability_y<-((U^y)*(e^-U))/factorial(y)
# U is the average value of y
U<-2.3
# The probability that a trap contains exactly four field mice is computed
y<-4
probability_findingexactlyfour<-((U^y)*(exp(1)^-U))/factorial(y)
print(probability_findingexactlyfour)
# The probability That a trap contains atmost four feild mice is computed as
probability_findingatmost_four=(((U^0)*(exp(1)^-U))/factorial(0))+(((U^1)*(exp(1)^-U))/factorial(1))+(((U^2)*(exp(1)^-U))/factorial(2))+(((U^3)*(exp(1)^-U))/factorial(3))+(((U^4)*(exp(1)^-U))/factorial(4))
print(probability_findingatmost_four)
# The probability of finding more than four field mice
probability_findingmorethanfour=1-probability_findingatmost_four
print(probability_findingmorethanfour)


setwd ("c://R")
Printers1=read.csv ("SellingPrinters.csv", header=TRUE,sep=";")
str(Printers1)
summary(Printers1)

LinMod1 <- lm( Printers1$Price ~ Printers1$Sold.Items,data=Printers1)
LinMod1

PrintersOutlier<-data.frame(X=c("Store21","Store22"),Sold.Items=c(210,50),Price=c(47,50))
#PrintersOutlier<-data.frame(X=c("Store21","Store22","Store23","Store24","Store25"),Sold.Items=c(180,200,210,50,90),Price=c(47,46,45,49,50))
Printers2 <- rbind(Printers1,PrintersOutlier)

LinMod2 <- lm( Printers2$Price ~ Printers2$Sold.Items,data=Printers2)
LinMod2

par(mfrow=c(1, 2))
plot(Printers1$Sold.Items,Printers1$Price,xlim=c(48, 212), ylim=c(37, 62),cex.axis=0.6,cex.lab=0.6)
abline(LinMod1)
plot(Printers2$Sold.Items,Printers2$Price,xlim=c(48, 212), ylim=c(37, 62),cex.axis=0.6,cex.lab=0.6)
abline(LinMod2)


ackermann <- function(m, n) {
  if ( m == 0 ) {
    n+1
  } else if ( n == 0 ) {
    ackermann(m-1, 1)
  } else {
    ackermann(m-1, ackermann(m, n-1))
  }
}


library(deSolve)
library(ggplot2)
library(reshape2)
library(gridExtra)
library(Rcpp)
library(RColorBrewer)

SIR <- function(Time, State, Pars) {

    with(as.list(c(State, Pars)), {

        B   <- R0*r/N
        BSI <- B*S*I
        rI  <- r*I

        dS = -BSI
        dI = BSI - rI
        dR = rI

        return(list(c(dS, dI, dR)))

    })

}

StocSIR <- function(y, pars, T, steps) {

	out <- matrix(NA, nrow = (T+1), ncol = 4)

	R0 <- pars[['R0']]
	r <- pars[['r']]
	N <- pars[['N']]
	eta <- pars[['eta']]
	berr <- pars[['berr']]

	S <- y[['S']]
	I <- y[['I']]
	R <- y[['R']]

	B0 <- R0 * r / N
	B <- B0

	out[1,] <- c(S,I,R,B)

	h <- 1 / steps

	for ( i in 1:(T*steps) ) {

		B <- exp( log(B) + eta*(log(B0) - log(B)) + rnorm(1, 0, berr) )

		BSI <- B*S*I
		rI <- r*I

		dS <- -BSI
		dI <- BSI - rI
		dR <- rI

		S <- S + h*dS  #newInf
		I <- I + h*dI  #newInf - h*dR
		R <- R + h*dR  #h*dR

		if (i %% steps == 0)
			out[i/steps+1,] <- c(S,I,R,B)

	}

	return(out)

}

set.seed(50721456)

T 		<- 60
i_infec <- 5
steps 	<- 7
N 		<- 500
sigma 	<- 10
Tlim 	<- T

## Generate true trajecory and synthetic data
##

pars_true <- c(R0 = 3.0, 	# new infected people per infected person
          r = 0.1, 		# recovery rate
		  N = 500, 		# population size
		  eta = 0.5, 	# geometric random walk
		  berr = 0.3) 	# Beta geometric walk noise

true_init_cond <- c(S = N - i_infec,
					I = i_infec,
					R = 0)

sdeout_true <- StocSIR(true_init_cond, pars_true, T, steps)
colnames(sdeout_true) <- c('S','I','R','B')

#quartz()
#plot(1:(T+1), sdeout[,'B'])

infec_counts_raw <- sdeout_true[,'I'] + rnorm(T+1, 0, sigma)
infec_counts     <- ifelse(infec_counts_raw < 0, 0, infec_counts_raw)

plotdata <- data.frame(times = 0:T, true = sdeout_true[,'I'], data = infec_counts)

g <- ggplot(plotdata, aes(times)) +
        geom_line(aes(y = true, colour = "True")) +
        geom_point(aes(y = data, colour = "Data")) +
        labs(x = "Time", y = "Infection count", color = "") +
        scale_color_brewer(palette="Paired") +
        theme(panel.background = element_rect(fill = "#F0F0F0"))

if ( Sys.info()['sysname'] == 'Darwin' )
	quartz()
print(g)

#ggsave(g, filename="dataplot.pdf", height=4, width=6.5)

## Rcpp stuff
##

NP <- 30000
nPasses <- 10
coolrate <- 0.9

sourceCpp(paste(getwd(),"if2.cpp",sep="/"))

if2data <- if2(infec_counts[1:(Tlim+1)], Tlim+1, N, NP, nPasses, coolrate)

paramdata <- data.frame( if2data$paramdata )
names(paramdata) <- c("R0", "r", "sigma", "eta", "berr", "Sinit", "Iinit", "Rinit")

convergedata <- data.frame( if2data$means )
names(convergedata) <- c("R0", "r", "sigma", "eta", "berr", "Sinit", "Iinit", "Rinit")

statedata <- data.frame( if2data$statemeans )
names(statedata) <- c("S","I","R")

## last particle filter means plot
if ( Sys.info()['sysname'] == 'Darwin' )
	quartz()
qplot(1:(T+1), sdeout_true[,'I'], geom = "line", xlab = "Time", ylab = "Infection counts") +
	geom_point(aes(y = infec_counts)) +
	geom_line(aes(y = statedata[,'I']), linetype = "dashed") +
	theme_bw()

## sample from parameter distributions
##

nTraj 	<- 100
datlen 	<- dim(paramdata)[1]
inds 	<- sample.int(datlen,nTraj,replace = TRUE)
params 	<- paramdata[inds,]

bootstrapdata <- matrix(NA, nrow = nTraj, ncol = T+1)

for (i in 1:nTraj) {

	init_cond <- c(S = params$Sinit[i],
	               I = params$Iinit[i],
	               R = params$Rinit[i])
	pars <- c(R0 = params$R0[i],
	          r = params$r[i],
	          N = 500.0,
	          eta = params$eta[i],
	          berr = params$berr[i])

	sdeout <- StocSIR(init_cond, pars, T, steps)
	colnames(sdeout) <- c('S','I','R','B')

	bootstrapdata[i,] <- sdeout[,'I']

}

meanTraj 	<- colMeans(bootstrapdata)
quantTraj 	<- t(apply(bootstrapdata, 2, quantile, probs = c(0.025,0.975)))
colnames(quantTraj) <- c("025","975")

datapart <- c(infec_counts[1:(Tlim+1)],rep(NA,T-Tlim))

g <- qplot(1:(T+1), sdeout_true[,'I'], geom = "line", xlab = "Time", ylab = "Infection count") +
        geom_ribbon(aes(ymin = quantTraj[,'025'], ymax=quantTraj[,'975']), alpha=0.1) +
        geom_line(aes(y = meanTraj), linetype = "dashed") +
        geom_point(aes(y = datapart)) +
        theme_bw()

if ( Sys.info()['sysname'] == 'Darwin' )
	quartz()
print(g)

#ggsave(g, filename="if2plot.pdf", height=4, width=6.5)

f <- function(pal) brewer.pal(brewer.pal.info[pal, "maxcolors"], pal)
kcolours <- f("Paired")

trueval.R0 		<- 3.0
trueval.r 		<- 0.1
trueval.sigma 	<- 10.0
trueval.Iinit 	<- 5
trueval.eta 	<- 0.5
trueval.berr 	<- 0.3

meanval.R0 		<- mean(convergedata$R0)
meanval.r 		<- mean(convergedata$r)
meanval.sigma 	<- mean(convergedata$sigma)
meanval.Iinit 	<- mean(convergedata$Iinit)
meanval.eta 	<- mean(convergedata$eta)
meanval.berr 	<- mean(convergedata$berr)

linecolour <- "grey50"
lineweight <- 0.5

## Convergence 'kernels'
if (FALSE) {
	R0kernel <- qplot(convergedata$R0, geom = "density", xlab = expression(R[0]), ylab = "") +
	    			geom_vline(aes(xintercept=pars_true['R0']), linetype="solid", size=lineweight, color=linecolour) +
	    			geom_vline(aes(xintercept=meanval.R0), linetype="dashed", size=lineweight, color=linecolour) +
					theme_bw()

	rkernel <- qplot(convergedata$r, geom = "density", xlab = "r", ylab = "") +
	    			geom_vline(aes(xintercept=pars_true['r']), linetype="solid", size=lineweight, color=linecolour) +
	    			geom_vline(aes(xintercept=meanval.r), linetype="dashed", size=lineweight, color=linecolour) +
					theme_bw()

	sigmakernel <- qplot(convergedata$sigma, geom = "density", xlab = expression(sigma), ylab = "") +
	    			geom_vline(aes(xintercept=sigma), linetype="solid", size=lineweight, color=linecolour) +
	    			geom_vline(aes(xintercept=meanval.sigma), linetype="dashed", size=lineweight, color=linecolour) +
					theme_bw()

	infeckernel <- qplot(convergedata$Iinit, geom = "density", xlab = "Initial Infected", ylab = "") +
	    			geom_vline(aes(xintercept=i_infec), linetype="solid", size=lineweight, color=linecolour) +
	    			geom_vline(aes(xintercept=meanval.Iinit), linetype="dashed", size=lineweight, color=linecolour) +
					theme_bw()

	etakernel <- qplot(convergedata$eta, geom = "density", xlab = expression(eta), ylab = "") +
	    			geom_vline(aes(xintercept=pars_true['eta']), linetype="solid", size=lineweight, color=linecolour) +
	    			geom_vline(aes(xintercept=meanval.eta), linetype="dashed", size=lineweight, color=linecolour) +
					theme_bw()

	berrkernel <- qplot(convergedata$berr, geom = "density", xlab = expression(epsilon[proc]), ylab = "") +
	    			geom_vline(aes(xintercept=pars_true['berr']), linetype="solid", size=lineweight, color=linecolour) +
	    			geom_vline(aes(xintercept=meanval.berr), linetype="dashed", size=lineweight, color=linecolour) +
					theme_bw()

	# show grid
	if ( Sys.info()['sysname'] == 'Darwin' )
		quartz()
	grid.arrange(R0kernel, rkernel, sigmakernel, infeckernel, etakernel, berrkernel,
	             ncol = 3, nrow = 2, top = "Convergence kernels")
}

# Convergence plots

R0converge <- qplot(1:dim(convergedata)[1], convergedata$R0, geom = "line", xlab = expression(R[0]), ylab = "frequency") +
    			geom_hline(aes(yintercept=pars_true['R0']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_hline(aes(yintercept=meanval.R0), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

rconverge <- qplot(1:dim(convergedata)[1], convergedata$r, geom = "line", xlab = "r", ylab = "") +
    			geom_hline(aes(yintercept=pars_true['r']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_hline(aes(yintercept=meanval.r), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

sigmaconverge <- qplot(1:dim(convergedata)[1], convergedata$sigma, geom = "line", xlab = expression(sigma), ylab = "") +
    			geom_hline(aes(yintercept=sigma), linetype="solid", size=lineweight, color=linecolour) +
    			geom_hline(aes(yintercept=meanval.sigma), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

infecconverge <- qplot(1:dim(convergedata)[1], convergedata$Iinit, geom = "line", xlab = "Initial Infected", ylab = "frequency") +
    			geom_hline(aes(yintercept=i_infec), linetype="solid", size=lineweight, color=linecolour) +
    			geom_hline(aes(yintercept=meanval.Iinit), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

etaconverge <- qplot(1:dim(convergedata)[1], convergedata$eta, geom = "line", xlab = expression(eta), ylab = "") +
    			geom_hline(aes(yintercept=pars_true['eta']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_hline(aes(yintercept=meanval.eta), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

berrconverge <- qplot(1:dim(convergedata)[1], convergedata$berr, geom = "line", xlab = expression(epsilon[proc]), ylab = "") +
    			geom_hline(aes(yintercept=pars_true['berr']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_hline(aes(yintercept=meanval.berr), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

# show grid
if ( Sys.info()['sysname'] == 'Darwin' )
	quartz()
grid.arrange(R0converge, rconverge, sigmaconverge, infecconverge, etaconverge, berrconverge,
             ncol = 3, nrow = 2, top = "Convergence plots")

# Final swarm kernel densities

meanval.R0 		<- mean(paramdata$R0)
meanval.r 		<- mean(paramdata$r)
meanval.sigma 	<- mean(paramdata$sigma)
meanval.Iinit 	<- mean(paramdata$Iinit)
meanval.eta 	<- mean(paramdata$eta)
meanval.berr 	<- mean(paramdata$berr)

linecolour <- "grey50"
lineweight <- 0.5

R0kernel <- qplot(paramdata$R0, geom = "density", xlab = expression(R[0]), ylab = "frequency") +
    			geom_vline(aes(xintercept=pars_true['R0']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_vline(aes(xintercept=meanval.R0), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

rkernel <- qplot(paramdata$r, geom = "density", xlab = "r") +
    			geom_vline(aes(xintercept=pars_true['r']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_vline(aes(xintercept=meanval.r), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

sigmakernel <- qplot(paramdata$sigma, geom = "density", xlab = expression(sigma)) +
    			geom_vline(aes(xintercept=sigma), linetype="solid", size=lineweight, color=linecolour) +
    			geom_vline(aes(xintercept=meanval.sigma), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

infeckernel <- qplot(paramdata$Iinit, geom = "density", xlab = "Initial Infected", ylab = "frequency") +
    			geom_vline(aes(xintercept=i_infec), linetype="solid", size=lineweight, color=linecolour) +
    			geom_vline(aes(xintercept=meanval.Iinit), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

etakernel <- qplot(paramdata$eta, geom = "density", xlab = expression(eta)) +
    			geom_vline(aes(xintercept=pars_true['eta']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_vline(aes(xintercept=meanval.eta), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

berrkernel <- qplot(paramdata$berr, geom = "density", xlab = expression(epsilon[proc])) +
    			geom_vline(aes(xintercept=pars_true['berr']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_vline(aes(xintercept=meanval.berr), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

# show grid
grid.arrange(R0kernel, rkernel, sigmakernel, infeckernel, etakernel, berrkernel,
             ncol = 3, nrow = 2, top = "Swarm final density kernels")

#pdf("if2kernels.pdf", height = 6.5, width = 6.5)
#grid.arrange(R0kernel, rkernel, sigmakernel, infeckernel, ncol = 2, nrow = 2)
#dev.off()


library(mvtnorm)

rmvnorm<- function (n, mean = rep(0, nrow(sigma)), sigma = diag(length(mean)),
          method = c("eigen", "svd", "chol"), pre0.9_9994 = FALSE,seed=NULL)
{
  if (!isSymmetric(sigma, tol = sqrt(.Machine$double.eps),
                   check.attributes = FALSE)) {
    stop("sigma must be a symmetric matrix")
  }
  if (length(mean) != nrow(sigma))
    stop("mean and sigma have non-conforming size")
  method <- match.arg(method)
  R <- if (method == "eigen") {
    ev <- eigen(sigma, symmetric = TRUE)
    if (!all(ev$values >= -sqrt(.Machine$double.eps) * abs(ev$values[1]))) {
      warning("sigma is numerically not positive semidefinite")
    }
    t(ev$vectors %*% (t(ev$vectors) * sqrt(pmax(ev$values,
                                                0))))
  }
  else if (method == "svd") {
    s. <- svd(sigma)
    if (!all(s.$d >= -sqrt(.Machine$double.eps) * abs(s.$d[1]))) {
      warning("sigma is numerically not positive semidefinite")
    }
    t(s.$v %*% (t(s.$u) * sqrt(pmax(s.$d, 0))))
  }
  else if (method == "chol") {
    R <- chol(sigma, pivot = TRUE)
    R[, order(attr(R, "pivot"))]
  }
  if (is.null(seed)) set.seed(seed)
  retval <- matrix(rnorm(n * ncol(sigma)), nrow = n, byrow = !pre0.9_9994) %*% R
  retval <- sweep(retval, 2, mean, "+")
  colnames(retval) <- names(mean)
  retval
}

n=100000
use<-dim(COV)[[1]]
# use=11
a1<-rmvnorm(n=n,mean=est[1:use],sigma=COV[1:use,1:use],method="eigen",seed=1)
a2<-rmvnorm(n=n,mean=est[1:use],sigma=COV[1:use,1:use],method="svd",seed=1)
a3<-rmvnorm(n=n,mean=est[1:use],sigma=COV[1:use,1:use],method="chol",seed=1)
round(cov(a1),5)
round(cov(a2),5)
round(cov(a3),5)
round(cov(a1)/cov(a2),5) # no diffrence
round(cov(a1)/cov(a3),5) # small diffrence


## Author: Sergio García Prado
## Title: Statistical Inference - Goodness of Fit - Exercise 01

rm(list = ls())

observed <- c(967, 1008, 975, 1022, 1003, 989, 1001, 981, 1043, 1011)

(n <- sum(observed))
# 10000

(k <- length(observed))
# 10

(expected <- 1 / k * n)
# 1000

(Q <- sum((observed - expected) ^ 2 / expected))
# 4.724

(pvalue <- 1 - pchisq(Q, k - 1))
# 0.857673749486367


library(dplyr)
library(sjmisc)
library(sjPlot)
library(ggplot2)

data(iris)

###see column names of data frame
names(iris)
##create a new dataframe with only numerical values

newiris <-select(iris,c("Sepal.Length","Sepal.Width" ,
                        "Petal.Length", "Petal.Width" ))
##see new dataframe's columns
names(newiris)

##plot  a correlation matrix for all variables
sjp.corr (newiris)

##a correlation matrix table for all variables

sjt.corr(newiris)

# improved correlation matrix
library(corrplot)

corrplot(cor(newiris),
         method = "number",
         type = "upper" # show only upper side
)


# generate points on the triangle (junction configurations)

rm(list = ls()); # clear

pmax <- 0.6;
pmin <- (1-pmax)/2;
N <- 3;

p1 <- c(pmax, pmin, pmin);
p2 <- c(pmin, pmax, pmin);
p3 <- c(pmin, pmin, pmax);
p0 <- c(1/3, 1/3, 1/3);
v1 <- p1 - p3;
v2 <- p2 - p1;
a  <- sqrt(sum(v1^2));
v1 <- v1 / a;
v2 <- v2 / a;
L <- a / 2^N;

cnt <- 0;
for (i in 0:2^N) {
  for (j in 0:i) cnt <- cnt + 1;
}

pts <- matrix(0, nrow=cnt, ncol=3);
cnt <- 0;
for (i in 0:2^N) {
  for (j in 0:i) {
    cnt <- cnt + 1;
    pp <- p3 + i * L * v1 + j * L * v2;
    print(pp);
    pts[cnt, 1:3] <- pp;
  }
}

library(plot3D)
scatter3D(pts[,1], pts[,2], pts[,3],
          colvar = NULL,
          type="p",
          phi = 10, theta = 80,
          col = NULL, NAcol = "white",
          main="triangle points",
          xlim=c(0,1), ylim=c(0,1), zlim=c(0,1),
          pch=20
          );

print(paste(nrow(pts), " points", sep=""));

readline(prompt = "press enter to continue...")

# plot distances towards symmetry
d <- vector(mode="numeric", length=nrow(pts));
for (i in 1:nrow(pts)) {
  d[i] <- sqrt(sum((pts[i,]-p0)^2));
}

d <- sort(d);
plot(d, pch=20);

readline(prompt = "press enter to continue...")

clust_d <- cutree(hclust(dist(d)), h=0.06); ## possible to cluster it
plot(clust_d, pch=20)

readline(prompt = "press enter to continue...")

# plot ratios max/min
ratios <- vector(mode="numeric", length=nrow(pts));
for (i in 1:nrow(pts)) {
  ratios[i] <- max(pts[i,])/min(pts[i,]); #sqrt(sum((pts[i,]-p0)^2));
}

plot(sort(ratios), pch=20);

readline(prompt = "press enter to continue...")

vy <- p1 - (p2+p3)/2;
vy <- vy / sqrt(sum(vy^2));
vx <- p3 - (p2+p3)/2;
vx <- vx / sqrt(sum(vx^2));
x <- (pts-p0) %*% vx;
y <- (pts-p0) %*% vy;

plot(x,y, pch=20, asp=1)

readline(prompt = "press enter to continue...")
library(plot3D)
scatter2D(x, y, colvar=ratios, pch=20, xlab="", ylab="");


omedian <- function(v) {
  if ( length(v) < 1 )
    NA
  else {
    sv <- sort(v)
    l <- length(sv)
    if ( l %% 2 == 0 )
      (sv[floor(l/2)+1] + sv[floor(l/2)])/2
    else
      sv[floor(l/2)+1]
  }
}

a <- c(4.1, 5.6, 7.2, 1.7, 9.3, 4.4, 3.2)
b <- c(4.1, 7.2, 1.7, 9.3, 4.4, 3.2)

print(median(a))   # 4.4
print(omedian(a))
print(median(b))   # 4.25
print(omedian(b))


 DSPGVD Example Program Results

 Eigenvalues
       -3.5411    -0.3347     0.2983     2.2544

 Estimate of reciprocal condition number for B
        5.8E-03

 Error estimates for the eigenvalues
        1.4E-13    1.7E-14    1.6E-14    9.1E-14


#' Computes the maximum likelihood estimator for the sample covariance matrix
#' under the assumption of multivariate normality.
#'
#' For a sample matrix, `x`, we compute the sample covariance matrix of the
#' data as the maximum likelihood estimator (MLE) of the population covariance
#' matrix.
#'
#' If the `diag` option is set to `TRUE`, then we assume the population
#' covariance matrix is diagonal, and the MLE is computed under this assumption.
#' In this case, we return a vector of length `p` instead.
#'
#' @export
#' @importFrom stats var cov
#' @param x data matrix with `n` observations and `p` feature vectors
#' @param diag logical value. If TRUE, assumes the population covariance matrix
#' is diagonal. By default, we assume that `diag` is `FALSE`.
#' @return sample covariance matrix of size \eqn{p \times p}. If `diag` is
#' `TRUE`, then a vector of length `p` is returned instead.
cov_mle <- function(x, diag = FALSE) {
  x <- as.matrix(x)
  n <- nrow(x)
  if (diag) {
    (n - 1) / n * apply(x, 2, var)
  } else {
    (n - 1) / n * cov(x)
  }
}

#' Computes the pooled maximum likelihood estimator (MLE) for the common
#' covariance matrix
#'
#' For the matrix `x`, we compute the MLE for the population covariance
#' matrix under the assumption that the data are sampled from \eqn{K}
#' multivariate normal populations having equal covariance matrices.
#'
#' @export
#' @importFrom stats cov
#' @param x data matrix with `n` observations and `p` feature vectors
#' @param y class labels for observations (rows) in `x`
#' @return pooled sample covariance matrix of size \eqn{p \times p}
#' @examples
#' cov_pool(iris[, -5], iris$Species)
cov_pool <- function(x, y) {
  x <- as.matrix(x)
  y <- as.factor(y)
  n <- length(y)

  scatter_matrices <- tapply(seq_len(n), y, function(i) {
    (length(i) - 1) * cov(as.matrix(x[i, ]))
  })
  as.matrix(Reduce("+", scatter_matrices) / n)
}

#' Computes the covariance-matrix maximum likelihood estimators for each class
#' and returns a list.
#'
#' For a sample matrix, `x`, we compute the MLE for the covariance matrix
#' for each class given in the vector, `y`.
#' @export
#' @param x data matrix with `n` observations and `p` feature vectors
#' @param y class labels for observations (rows) in `x`
#' @return list of the sample covariance matrices of size \eqn{p \times p} for
#' each class given in `y`.
cov_list <- function(x, y) {
  x <- as.matrix(x)
  y <- as.factor(y)
  tapply(seq_along(y), y, function(i) {
    cov_mle(x[i, ])
  })
}

#' Computes the eigenvalue decomposition of the maximum likelihood estimators
#' (MLE) of the covariance matrices for the given data matrix
#'
#' For the classes given in the vector `y`, we compute the eigenvalue
#' (spectral) decomposition of the class sample covariance matrices (MLEs) using
#' the data matrix `x`.
#'
#' If the `fast` argument is selected, we utilize the so-called Fast
#' Singular Value Decomposition (SVD) to quickly compute the eigenvalue
#' decomposition. To compute the Fast SVD, we use the [corpcor::fast.svd()]
#' function, which employs a well-known trick for tall data (large `n`,
#' small `p`) and wide data (large `p`, small `n`) to compute the
#' SVD corresponding to the nonzero singular values. For more information about
#' the Fast SVD, see [corpcor::fast.svd()].
#'
#' @importFrom corpcor fast.svd
#' @export
#' @param x data matrix with `n` observations and `p` feature vectors
#' @param y class labels for observations (rows) in `x`
#' @param pool logical. Should the sample covariance matrices be pooled?
#' @param fast logical. Should the Fast SVD be used? See details.
#' @param tol tolerance value below which the singular values of `x` are
#' considered zero.
#' @return a list containing the eigendecomposition for each class. If
#' `pool = TRUE`, then a single list is returned.
#' @examples
#' cov_eigen(x = iris[, -5], y = iris[, 5])
#' cov_eigen(x = iris[, -5], y = iris[, 5], pool = TRUE)
#' cov_eigen(x = iris[, -5], y = iris[, 5], pool = TRUE, fast = TRUE)
#'
#' # Generates a data set having fewer observations than features.
#' # We apply the Fast SVD to compute the eigendecomposition corresponding to the
#' # nonzero eigenvalues of the covariance matrices.
#' set.seed(42)
#' n <- 5
#' p <- 20
#' num_classes <- 3
#' x <- lapply(seq_len(num_classes), function(k) {
#'   replicate(p, rnorm(n, mean = k))
#' })
#' x <- do.call(rbind, x)
#' colnames(x) <- paste0("x", 1:ncol(x))
#' y <- gl(num_classes, n)
#' cov_eigen(x = x, y = y, fast = TRUE)
#' cov_eigen(x = x, y = y, pool = TRUE, fast = TRUE)
cov_eigen <- function(x, y, pool = FALSE, fast = FALSE, tol = 1e-6) {
  x <- as.matrix(x)
  y <- as.factor(y)

  if (fast) {
    # First, we center each class.
    x_centered <- center_data(x = x, y = y)
    if (pool) {
      n <- nrow(x_centered)
      svd_out <- fast.svd(x_centered)
      eigenvals <- svd_out$d^2 / n
      # We retain only the 'q' eigenvalues greater than 'tol'. Effectively, 'q'
      # is our estimate for the rank of the covariance matrix.
      q <- sum(eigenvals > tol)
      seq_q <- seq_len(q)
      eigen_out <- list(vectors = svd_out$v[, seq_q], values = eigenvals[seq_q])
    }
    else {
      eigen_out <- tapply(seq_along(y), y, function(i) {
        n <- length(i)
        svd_out <- fast.svd(x_centered[i, ])
        eigenvals <- svd_out$d^2 / n
        # We retain only the 'q' eigenvalues greater than 'tol'. Effectively, 'q'
        # is our estimate for the rank of the covariance matrix.
        q <- sum(eigenvals > tol)
        seq_q <- seq_len(q)
        list(vectors = svd_out$v[, seq_q], values = eigenvals[seq_q])
      })
    }
  } else {
    if (pool) {
      eigen_out <- eigen(cov_pool(x = x, y = y), symmetric = TRUE)
    } else {
      eigen_out <- lapply(cov_list(x = x, y = y), eigen, symmetric = TRUE)
    }
  }
  eigen_out
}

#' Computes the observation weights for each class for the HDRDA classifier
#'
#' This function calculates the weight for each observation in the data matrix
#' `x` in order to calculate the covariance matrices employed in the HDRDA
#' classifier, implemented in [rda_high_dim()].
#'
#' @inheritParams lda_diag
#' @param y vector of class labels for each training observation
#' @param lambda the RDA pooling parameter. Must be between 0 and 1, inclusively.
#' @return list containing the observations for each class given in `y`
#'
#' @references Ramey, J. A., Stein, C. K., and Young, D. M. (2013),
#' "High-Dimensional Regularized Discriminant Analysis."
rda_weights <- function(x, y, lambda = 1) {
  x <- as.matrix(x)
  y <- as.factor(y)
  N <- length(y)
  tapply(seq_along(y), y, function(i) {
    n_k <- length(i)
    weights_k <- lambda / N + (1 - lambda) / n_k
    replace(rep(lambda / N, N), i, weights_k)
  })
}

#' Calculates the RDA covariance-matrix estimators for each class
#'
#' For the classes given in the vector `y`, this function calculates the
#' class covariance-matrix estimators employed in the HDRDA classifier,
#' implemented in [rda_high_dim()].
#'
#' @inheritParams lda_diag
#' @param y vector of class labels for each training observation
#' @param lambda the RDA pooling parameter. Must be between 0 and 1, inclusively.
#' @return list containing the RDA covariance-matrix estimators for each class
#' given in `y`
#'
#' @references Ramey, J. A., Stein, C. K., and Young, D. M. (2013),
#' "High-Dimensional Regularized Discriminant Analysis."
rda_cov <- function(x, y, lambda = 1) {
  x_centered <- center_data(x = x, y = y)
  weights <- rda_weights(x = x, y = y, lambda = lambda)
  lapply(weights, function(weights_k) {
    x_scaled <- sqrt(weights_k) * x_centered
    crossprod(x_scaled)
  })
}

#' Computes a shrunken version of the maximum likelihood estimator for the
#' sample covariance matrix under the assumption of multivariate normality.
#'
#' For a sample matrix, `x`, we compute the sample covariance matrix as the
#' maximum likelihood estimator (MLE) of the population covariance matrix and
#' shrink it towards its diagonal.
#'
#' Let \eqn{\widehat{\Sigma}} be the MLE of the covariance matrix \eqn{\Sigma}.
#' Then, we shrink the MLE towards its diagonal by computing
#' \deqn{\widehat{\Sigma}(\gamma) = \gamma \widehat{\Sigma} + (1 - \gamma)
#' \widehat{\Sigma} \circ I_p,} where \eqn{\circ} denotes the Hadamard product
#' and \eqn{\gamma \in [0,1]}.
#'
#' For \eqn{\gamma < 1}, the resulting shrunken covariance matrix estimator is
#' positive definite, and for \eqn{\gamma = 1}, we simply have the MLE, which can
#' potentially be positive semidefinite (singular).
#'
#' The estimator given here is based on Section 18.3.1 of the Hastie et
#' al. (2008) text.
#'
#' @export
#' @param x data matrix with `n` observations and `p` feature vectors
#' @param gamma the shrinkage parameter. Must be between 0 and 1, inclusively.
#' By default, the shrinkage parameter is 1, which simply yields the MLE.
#' @return shrunken sample covariance matrix of size \eqn{p \times p}
#'
#' @references Hastie, T., Tibshirani, R., and Friedman, J. (2008), "The
#' Elements of Statistical Learning: Data Mining, Inference, and Prediction,"
#' 2nd edition. \url{http://web.stanford.edu/~hastie/ElemStatLearn/}
cov_shrink_diag <- function(x, gamma = 1) {
  if (gamma < 0 || gamma > 1) {
    rlang::abort("The value of 'gamma' must be between 0 and 1, inclusively.")
  }
  cov_x <- cov_mle(x)
  gamma * cov_x + (1 - gamma) * diag(diag(cov_x))
}


## パッケージの読み込み
require(MASS)

## データの読み込み
files <- list.files(path="data/artv")
mylist <- list()
for(fn in files){ # data 内にある全ファイルを読み込む
    mylist[[fn]] <-
        read.csv(file=paste("data/artv",fn,sep="/"),
                 na.string="-")
}
## データは以下のサイトのものを利用した．(2019/09/30)
##   http://artv.info

## データの集計のための関数
myfun <- function(df){ # 1行ごとに処理
    tmp <- data.frame(t(apply(df,1,mysubfun)))
    rownames(tmp) <- df[,3]
    return(tmp)
}
mysubfun <- function(x){
    tmp <- min(which(names(x)=="平均"),
               which(is.na(x))) # データの末端
    return(as.numeric(x[c(4:6, # 初回から3回
                          floor((4+tmp)/2)+(-1:1), # 真ん中3回
                          tmp-(3:1))])) # 最終回までの3回
}
## 長さを揃えるため，初回から3回，真ん中3回，最終回前の3回を取得
## 番組によっては重複している回があるが，これらを比較して距離を定義する
## 全データを整理
mydata <- lapply(mylist,myfun)
names(mydata) <- NULL # リストの名前を削除
mydata <- do.call(rbind,mydata)

## 距離の計算，平均からの変動をマンハッタン距離で比較
dst <- dist(mydata-rowMeans(mydata),method="manhattan")

## 別の距離の例
## 前の回との差分(増減)に着目する場合
## dst <- dist(t(apply(mydata,1,diff)),method="manhattan")

## 平均視聴率が高い番組のみ使う場合
## dst <- dist((mydata-rowMeans(mydata))[rowMeans(mydata)>8,],
##             method="manhattan")

## 非計量的MDSを利用
mds <- isoMDS(dst)

## 全体図の表示: 図()
par(family="HiraMaruProN-W4")
plot(mds$points,
     xlab="axis 1", ylab="axis 2", type="n",
     main="全体図")
text(mds$points,labels=rownames(mydata),
     col=ifelse(rowMeans(mydata)>8,"red","blue"))

## 中心部の表示: 図()
plot(mds$points, xlim=c(-5,5),ylim=c(-5,5),
     xlab="axis 1", ylab="axis 2", type="n",
     main="中心部")
text(mds$points,labels=rownames(mydata),
     col=ifelse(rowMeans(mydata)>8,"red","blue"))


# ************************************************
### simon munzert
### ols and multiple regression
# ************************************************

source("packages.r")
source("functions.r")

# ************************************************
# Bivariate regression, OLS estimation -----------

# load data
data("wage1")

# inspect relationship
qplot(educ, wage, data = wage1)
plot(wage1$educ, wage1$wage)
cor(wage1$wage, wage1$educ)
with(wage1, cor(educ, wage))

# run linear model
wage_model <- lm(wage ~ educ, data = wage1)
summary(wage_model)
coef(wage_model)

# export model
stargazer(wage_model, single.row = TRUE, header = FALSE, style = "apsr", type = "html", out = "../output/wage_model_ols.html")
browseURL("../output/wage_model_ols.html")

# manual computation
covariance_xy <- with(wage1, cov(wage, educ))
variance_x <- var(wage1$educ)
covariance_xy / variance_x # beta_1
mean(wage1$wage) - (covariance_xy / variance_x)*mean(wage1$educ) # beta_0

# ************************************************
# Multiple regression, OLS estimation ------------

# run linear model
wage_model <- lm(wage ~ educ + female, data = wage1)
summary(wage_model)
coef(wage_model)

# manual computation for beta_educ

# step 1: isolate part of X that is linearly independent from Z
wage_model_xz <- lm(educ ~ female, data = wage1)
resid_xz <- residuals(wage_model_xz)

# step 2: explain Y by part of X that is independent from Z
wage_model_yx <- lm(wage1$wage ~ resid_xz)
coef(wage_model_yx)

## continue in analogy to arrive at point estimate for beta_female.

# ************************************************
# How are coefficients from simple and -----------
# multiple OLS estimates related? ----------------

wage_model <- lm(wage ~ educ, data = wage1)
coef_simple <- coef(wage_model)[2]

wage_model_mult <- lm(wage ~ educ + female, data = wage1)
coef_multiple <- coef(wage_model_mult)[2]

wage_model_zx <- lm(female ~ educ, data = wage1)
coef_simple_zx <- coef(wage_model_zx)[2]

# these two are the same:
coef_simple
coef_multiple + coef(wage_model_mult)[3]*coef(wage_model_zx)[2]

# ***************************************************
# Effects of controls on coefficients of interest ---

wage_model_1 <- lm(wage ~ educ, data = wage1)
wage_model_2 <- lm(wage ~ educ + female, data = wage1)
wage_model_3 <- lm(wage ~ educ + female + nonwhite, data = wage1)
wage_model_4 <- lm(wage ~ educ + female + nonwhite + profocc, data = wage1)

stargazer(wage_model_1, wage_model_2, wage_model_3, wage_model_4, header = FALSE, style = "apsr", type = "html", out = "../output/wage_model_multiple.html")
browseURL("../output/wage_model_multiple.html")
stargazer(wage_model_1, wage_model_2, wage_model_3, wage_model_4, header = FALSE, title = "Regressing wage on...", omit.table.layout = "dln", style = "apsr", font.size = "scriptsize", df = FALSE, report = "vcs", single.row = FALSE, no.space = TRUE, type = "latex", out = "../output/wage_model_multiple.tex")

cor(select(wage1, wage, educ, female, nonwhite, profocc))

# ************************************************
# Post-estimation bias: simulation ---------------

set.seed(42)
N <- 500
x <- rnorm(N, 0, 1)
ed <- rnorm(N, 0, .5)
d <- .8*x + ed  # d is mediator
ey <- rnorm(N, 0, .5)
y <- x + d + ey

cor(cbind(y, x, d))
plot(x, y)

# complete "true" models
summary(lm(d ~ x))
summary(lm(y ~ x))

# model with induced post-treatment bias
summary(lm(y ~ x + d))

# ************************************************
# Multicollinearity: detection -------------------

data(bwght2)
?bwght2
vars <- c("mage", "meduc", "monpre", "npvis", "fage", "feduc", "cigs", "drink", "male")
b <- paste(vars, collapse = "+")
frmla <- as.formula(paste("bwght ~ ", b, sep = ""))

# example: perfect collinearity
summary(lm(bwght ~ fwhte + fblck + foth, data = bwght2))

# full model
model_out <- lm(frmla, data = bwght2)
summary(model_out)

# inspect correlation matrix
cor(bwght2[,vars], use = "pairwise.complete.obs")

# inspect scatterplots
plot(bwght2[,vars])

# evaluate variance inflation factors
vif(model_out) # function from car package

# ************************************************
# Anscombe's quartett ----------------------------

?anscombe
summary(anscombe)

# correlation
sapply(1:4, function(x) cor(anscombe[, x], anscombe[, x+4]))

# variance
sapply(5:8, function(x) var(anscombe[, x]))

# linear regression
summary(lm(y1 ~ x1, data = anscombe))
summary(lm(y2 ~ x2, data = anscombe))
summary(lm(y3 ~ x3, data = anscombe))
summary(lm(y4 ~ x4, data = anscombe))

# plot
ff <- y ~ x
par(mfrow = c(2, 2))
for(i in 1:4) {
  ff[2:3] <- lapply(paste0(c("y","x"), i), as.name)
  plot(ff, data = anscombe, col = "red", pch = 21, bg = "orange", cex = 1.2, xlim = c(3, 19), ylim = c(3, 13))
  model_out <- lm(ff, data = anscombe)
  abline(model_out, col = "blue")
}
mtext("Anscombe's 4 regression data sets", outer = TRUE, cex = 1.5)

# ************************************************
# Functional form misspecification ---------------

N <- 500
x <- runif(N, 0, 1)
y <- log(x) + rnorm(N, 0, .3)

# look at model
summary(lm(y ~ x))
summary(lm(y ~ log(x)))

# plot relationship
par(mfrow = c(1, 3))
# misspecified
plot(x, y); abline(lm(y ~ x), col = "red")
# correctly specified
dat <- data.frame(x = sort(x), ypred = predict(lm(y ~ log(x)), newdata = data.frame(x = sort(x))))
plot(x, y); lines(dat$x, dat$ypred, col = "red")
# correctly specified
plot(log(x), y); abline(lm(y ~ log(x)), col = "red")

# RESET test
resettest(lm(y ~ x))
resettest(lm(y ~ log(x)))


## Created on Thursday, March 10, 2010 at 10:10pm EST by WeekendEditor on WeekendEditorMachine.
## Copyright (c) 2020, SomeWeekendReading.  All rights reserved.  As if you care.

##
## Pretty pictures of fractal "boundary" of convergence in Newton's method for solving a cubic
## in the complex plane.  See Strogatz's NYT column:
## http://opinionator.blogs.nytimes.com/2010/03/07/finding-your-roots/
##
## "boundary" in quotes: wherever you think 2 colors have a boundary, the 3rd interposes!
##

doit <- function(xlim = c(-1, +1), ylim = c(-1, +1), npix = 500, doExact = FALSE, ask = TRUE) {
  ## Cyclotomic cubic z^3 - 1 has 3 roots in complex z plane, to which we assign colors.
  ## Other points are colored by the speed with which Newton's algorithm converges to a root.
  ## Plot a subset of the complex plane as described by xlim & ylim, npix per side.

  roots       <- (function(angle) { complex(mod = 1, arg = angle) })(c(0, 2*pi/3, 4*pi/3))
  nearestRoot <- function(x, y) { which.min(abs(complex(real = x, imag = y) - roots)) }
  findRoot    <- function(z, nIter = 0, eps = 1.0e-3) {# Which root by Newton & num iterations
    if (Re(z) == 0 && Im(z) == 0)                      # If at origin, then step away
      z <- complex(real = Re(z) + jitter(Re(z)), imag = Im(z) + jitter(Im(z)))
    flags <- abs(z - roots) < eps                      # Diffs from roots: only 1 can converge
    if (any(flags))                                    # If any root has converged (uniquely!)
      c("rootNum" = which(flags), "nIter" = nIter)     #  then return root # and # iterations
    else                                               # Else unconverged so far
      ## Newton's method in general for finding roots of f(z) = 0:
      ##   z[i+1] = z[i] - f(z[i]) / f'(z[i])
      ## Here, f(z) = z^3 - 1, hence f'(z) = 3 z^2, so:
      ##   z[i+1] = z[i] - (z[i]^3 - 1) / (3 z[i]^2) = 2/3 z[i] + 1/(3 z[i]^2)
      findRoot(2/3 * z + 1 / (3 * z^2), nIter + 1)     # Take Newton step, bump iteration
  }                                                    #  count, and try again

  plotRootFractal <- function(df, col, wrd) {          # Plot expected/actual fractals
    oldParList <- NULL                                 # Capture graphics param changes
    tryCatch({                                         # Guarantee restoring graphics params
      oldParList <- par("mgp" = c(1.5, 0.5, 0),        # Spacing of axis title, labels, & line
                        "mar" = c(2.5, 2.5, 2.5, 1.0), # Margins: (bottom, left, top, right))
                        "ps"  = 10,                    # Point size type in labels
                        "las" = 1,                     # Always horizontal labels
                        "ask" = ask,                   # Ask before replotting
                        "pty" = "m")                   # Maximal plotting area
      image(x = sort(unique(df$"x")),                  # Color by which root a point converges
            y = sort(unique(df$"y")),                  #   to, and how fast
            z = t(matrix(df[, col], nrow = npix, ncol = npix, byrow = TRUE)),
            xlim = xlim, ylim = ylim, xlab = "Re(z)", ylab = "Im(z)",
            main = sprintf("%s Convergence of Newton's Algorithm on Cube Roots of Unity", wrd),
            col = c(rgb(red = 0:255, green = 0,     blue = 0,     maxColorValue = 255),
                    rgb(red = 0,     green = 0:255, blue = 0,     maxColorValue = 255),
                    rgb(red = 0,     green = 0,     blue = 0:255, maxColorValue = 255)))
      box(which = "plot")                              # Put it in a box with a ribbon on it
    }, finally = par(oldParList))                      # Restore graphics parameters
  }                                                    #

  ## (1) Start with skeleton of (x, y) pairs in the complex plane
  ## (2) Add on which root it converged to, and in how many iterations
  ## (3) Encode color in a funny way by root number and number of iterations
  df   <- expand.grid(x = seq(from = xlim[[1]], to = xlim[[2]], length.out = npix),
                      y = seq(from = ylim[[1]], to = ylim[[2]], length.out = npix))
  df   <- cbind(df,                                    # Adjoin onto skeleton 2 new columns:
                t(apply(df, 1, function(dfr) { findRoot(complex(real = dfr[[1]],
                                                                imag = dfr[[2]])) })))
  maxN <- max(df$"nIter")                              # Scale color by max # of iterations
  df   <- transform(df, color = rootNum - nIter/maxN)  # Clunky color encoding
  plotRootFractal(df, "color", "Actual")               # Plot the observed fractal

  if (doExact) {                                       # If also plot expectations (exact root)
    df <- transform(transform(df, exactRootNum = Vectorize(nearestRoot)(x, y)),
                    exactRootDist = abs(complex(real = x, imag = y) - roots[exactRootNum]))
    maxDist = max(df$"exactRootDist")                  # Color by distance from nearest root
    df <- transform(df, exactColor = exactRootNum - exactRootDist / maxDist)
    plotRootFractal(df, "exactColor", "Expected")      # Plot the expected "fractal"
  }                                                    #

  invisible(df)                                        # Return large dataframe, but invisibly
}                                                      #

##
## Usage
##

## > system.time(foo <- doit(npix = 10), gcFirst = TRUE)
##    user  system elapsed
##    0.05    0.01    0.07
## > system.time(foo <- doit(npix = 20), gcFirst = TRUE)
##    user  system elapsed
##    0.16    0.01    0.16
## > system.time(foo <- doit(npix = 50), gcFirst = TRUE)
##    user  system elapsed
##    0.50    0.05    0.58
## > system.time(foo <- doit(npix = 100), gcFirst = TRUE)
##    user  system elapsed
##    1.80    0.17    2.12
## > system.time(foo <- doit(npix = 200), gcFirst = TRUE)
##    user  system elapsed
##    7.49    0.76    8.69
## > system.time(foo <- doit(npix = 500), gcFirst = TRUE)
##    user  system elapsed
##   51.97    4.35   57.99
## > system.time(foo <- doit(npix = 1000), gcFirst = TRUE)
##    user  system elapsed
##  225.70   19.19  255.33

## > png(filename = "root-fractal-2000.png", width = 2200, height = 2200, bg = "transparent"); doit(npix = 2000, ask = FALSE); dev.off()

## Test our hypothesis that time required scales quadratically with npix:
##
## > data <- data.frame(n = c(10, 20, 50, 100, 200, 500, 1000), t = c(0.07, 0.16, 0.58, 2.12, 8.69, 57.99, 255.33))
##
## > model <- lm(t ~ 1 + n + I(n^2), data = data); summary(model); transform(data.frame(data, tPred = predict(model, newdata = subset(data, select = "n"))), pctDiff = 100 * (t - tPred) / t)
##
## Coefficients:
##               Estimate Std. Error t value Pr(>|t|)
## (Intercept)  9.410e-01  5.374e-01   1.751  0.15483
## n           -2.233e-02  4.068e-03  -5.490  0.00536 **
## I(n^2)       2.765e-04  4.009e-06  68.984 2.65e-07 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.9065 on 4 degrees of freedom
## Multiple R-squared: 0.9999,  Adjusted R-squared: 0.9999
## F-statistic: 3.258e+04 on 2 and 4 DF,  p-value: 3.767e-09
##
##      n      t       tPred       pctDiff
## 1   10   0.07   0.7453594 -964.79907826
## 2   20   0.16   0.6050261 -278.14134139
## 3   50   0.58   0.5158754   11.05597205
## 4  100   2.12   1.4734535   30.49747513
## 5  200   8.69   7.5367204   13.27134203
## 6  500  57.99  58.9114051   -1.58890341
## 7 1000 255.33 255.1521601    0.06965098
##
## Model p-value from F-statistic is 2 orders of magnitude better if we drop the constant term:
##
## > model2 <- lm(t ~ 0 + n + I(n^2), data = data); summary(model2); transform(data.frame(data, tPred = predict(model2, newdata = subset(data, select = "n"))), pctDiff = 100 * (t - tPred) / t)
##
## Coefficients:
##          Estimate Std. Error t value Pr(>|t|)
## n      -1.743e-02  3.508e-03  -4.968  0.00422 **
## I(n^2)  2.725e-04  3.882e-06  70.185 1.11e-08 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 1.078 on 5 degrees of freedom
## Multiple R-squared: 0.9999,  Adjusted R-squared: 0.9999
## F-statistic: 2.955e+04 on 2 and 5 DF,  p-value: 6.582e-11
##
##      n      t       tPred     pctDiff
## 1   10   0.07  -0.1470371 310.0530241
## 2   20   0.16  -0.2395803 249.7376874
## 3   50   0.58  -0.1902462 132.8010768
## 4  100   2.12   0.9818559  53.6860445
## 5  200   8.69   7.4131051  14.6938423
## 6  500  57.99  59.4032132  -2.4369946
## 7 1000 255.33 255.0412611   0.1130846
##


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

# The oneNN function categorizes points based on the 1 nearest neighbour method.
# Returns: a vector of class names for corresponding points.
# Params:
#   dataset -- a data frame, must have exactly 2 columns.
#   points -- a list of points to categorize. Each point is a vector of length 2.
#   dist -- optional. A metric function to use in the 1-NN method. Defaults to the Euclidean distance.
oneNN <- function(dataset, points, dist = euclidean) {
  answer <- data.frame()

  for (i in 1:length(points[1,])) {
    currAns <- dataset[1,]

    for (j in 1:dim(dataset)[1]) {
      if (dist(currAns[3:4], points[,i]) > dist(dataset[j, 3:4], points[,i])) {
        currAns <- dataset[j,]
      }
    }
    answer <- rbind(answer, data.frame(currAns))
  }

  return (answer)
}

colors <- c("setosa" = "blue", "virginica" = "red", "versicolor" = "green")
plot(iris[, 3:4], bg = colors[iris$Species], pch=23)

z <- array(c(runif(5, 1, 7), runif(5, 0, 2.5)), dim = c(2, 5))

print(z[1,])
print(z[2,])

result <- oneNN(iris, z)
points(z[1,], z[2,], bg = colors[result$Species], pch = 22)


# Aufgabe 7

library(ggplot2)

png(filename="Gaussian-k-sigma.png")

# Parameters
mu = 3
sigma = 3

step_size = 0.05
k = 10

# Logic
x = seq(from=mu-k*sigma, to=mu+k*sigma, by=step_size)
dens = dnorm(x, mean=mu, sd=sigma)

d <- data.frame(x=x, y=dens)
plot(d, type="lines")

for (k in k:1) {
    print(paste("k=", k, ", P(...)=",
                pnorm(mu+k*sigma, mean=mu, sd=sigma) -
                pnorm(mu-k*sigma, mean=mu, sd=sigma)))

    k1start = mu - k*sigma
    k1end = mu + k*sigma
    cord.x <- c(k1start, seq(k1start, k1end, step_size), k1end)
    cord.y <- c(0,dnorm(seq(k1start, k1end, step_size), mean=mu, sd=sigma),0)
    polygon(cord.x, cord.y, col=rainbow(3)[k])
}

dev.off()


### Author: Sergio García Prado
### Title: 2017 Final Exam

rm(list = ls())

### Exercise 1

P <- matrix(c(
  0.0, 1/2, 0.0, 1/2, 0.0, 0.0, 0.0, 0.0, 0.0,
  1/3, 0.0, 1/3, 0.0, 1/3, 0.0, 0.0, 0.0, 0.0,
  0.0, 1/2, 0.0, 0.0, 0.0, 1/2, 0.0, 0.0, 0.0,
  1/2, 0.0, 0.0, 0.0, 0.0, 0.0, 1/2, 0.0, 0.0,
  0.0, 1/3, 0.0, 0.0, 0.0, 1/3, 0.0, 1/3, 0.0,
  0.0, 0.0, 1/2, 0.0, 1/2, 0.0, 0.0, 0.0, 0.0,
  0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0,
  0.0, 0.0, 0.0, 0.0, 1/2, 0.0, 0.0, 0.0, 1/2,
  0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0
),9, 9, byrow = TRUE)

R <- P[1:8, 1:8]

g <- solve(diag(nrow(R)) - R) %*% rep(1, nrow(R))

(doors <- g[1])
# 44.5

(visits.A <- solve(diag(nrow(R)) - R)[1, 1] - 1)
# 6.5

### Exercise 2

(l.coche <- (5 / 60) ^ (-1))
# 12

(l.moto <- (10 / 60) ^ (-1))
# 6

(l.bus <- (30 / 60) ^ (-1))
# 2

### a) 2 cars and 1 motorcycle in 20 minutes.
dpois(2, lambda = l.coche / 3) * dpois(1, lambda = l.moto / 3)
# 0.0396600348266617

### b) Non-change return in 10 minutes.
dpois(0, lambda = 1 / 4 * (l.coche + l.moto + l.bus) / 6)
# 0.434598208507078

### c) 0 motorcycles from 20 vehicles.
dbinom(0, size = 20, prob = l.moto / (l.coche + l.moto + l.bus))
# 0.000797922662976119

### d) 7th car before 2th motorcycle.
pbinom(7 - 1, size = 7 + 2 - 1, prob = l.coche / (l.coche + l.moto),
       lower.tail = FALSE)
# 0.195092211553117

### Exercise 3

lambda <- 9
# 9

(mu <- 1 /(5 /60))
# 12

### a)
##
## L ~ Geometric((mu - lambda) / mu) = Geometric(1/4)

## E[L]
lambda / (mu - lambda)
# 3

### b)

## Waiting Total.
(1 / (mu - lambda))
# 0.3333333

## Waiting in queue.
(lambda / mu * (1 / (mu - lambda)))
# 0.25

### c)

## Busy period length.
(1 / (mu - lambda))
# 0.333333333333333

### d)

R <- matrix(c(
  -lambda, lambda,
  mu, -(mu + lambda)
), 2, 2, byrow = TRUE)

(g <- - solve(R) %*% rep(1, 2))
# 0.3703704
# 0.2592593

g[1]
# 0.37037037037037


#' @title data_dredge_correlation
#'
#' @description data dredge a \code{\link[base]{data.frame}} using \code{\link[stats]{cor.test}}
#'
#' @importFrom magrittr "%>%"
#' @importFrom stats cor.test
#' @export
#'
#' @param data a \code{\link[base]{data.frame}} to operate over
#' @param max_lag the maximum lag to search
#' @param max_pvalue the maximum the pvalue from \code{\link[stats]{cor.test}} can be before the result is filtered out
#' @param ... addtional parameters to pass to \code{\link[stats]{cor.test}}
#' @return
#'
#' @author Mark Newman, \email{mark@trinetteandmark.com}
#' @keywords macros
#' @family data_dredging
#'
#' @examples
#'   \dontshow{
#'     library(mndredge)}
#'   set.seed(0)
#'   y1 <- seq(-10, 10, .5) %>% as.integer()
#'   y2 <- y1 + y1 %>% length() %>% rnorm()
#'   data.frame(y1, y2) %>% data_dredge_correlation()
#'
data_dredge_correlation <- function(data, max_lag = 0, max_pvalue = 0.05, ...) {

  stopifnot(is.data.frame(data))
  stopifnot(is.numeric(max_lag))
  stopifnot(is.numeric(max_pvalue))
  stopifnot(nrow(data) >= 3)

  column_names <- data %>% colnames()
  acceptable_column <- function(x) { x == "numeric" || x == "integer" }
  good_columns <- column_names[data %>% sapply(class) %>% sapply(acceptable_column)]
  good_column_count <- good_columns %>% length()

  stopifnot(good_column_count >= 2)
  result_count = choose(good_column_count, 2) * (1 + max_lag)

  column_a <- character(length = result_count)
  column_b <- character(length = result_count)
  estimate <- numeric(length = result_count)
  p.value <- numeric(length = result_count)
  lag <- numeric(length = result_count)

  indx = 1
  for(i in 1:(good_column_count - 1)) {
    for(j in (i + 1):good_column_count) {

      a <- good_columns[i]
      b <- good_columns[j]
      t1 <- data[, c(a, b)]

      for(k in 0:max_lag) {

        t2 <- t1 %>% apply_lag(hold = a, move = b, lag = k)
        ct <- suppressWarnings(cor.test(t2[,a], t2[,b], ...))

        column_a[indx] <- a
        column_b[indx] <- b
        lag[indx] <- k
        estimate[indx] <- ct$estimate
        p.value[indx] <- ct$p.value

        indx <- indx + 1
      }}}

  res <- data.frame(
    column_a,
    column_b,
    estimate,
    p.value,
    lag,
    stringsAsFactors = F)

  filterout <- is.na(res$p.value) | res$p.value >= max_pvalue
  res <- res[!filterout,]
  rownames(res) <- NULL

  res
}


# Example : 3   Chapter : 6.7     Page No: 366
# Singular Value decomposition

A<-matrix(c(2,1,2,1),ncol=2)
print("Singular value decomposition is given by")
print(svd(A))
#The  answer may slightly vary due to  rounding off values
#The answers provided in the text book may vary because of the computation method followed.


#### 13-1 기초 통계
## 대표값과 산포(변동성)
x <- runif(50, 1, 100)
x
hist(x)
y <- c(x, 1000)
y

mean(x)
mean(y)
median(x)
median(y)
sd(x)
sd(y)
range(x)
range(y)
IQR(x)
IQR(y)

boxplot(x)
boxplot(y)

install.packages('fBasics')
library(fBasics)
require(fBasics)
skewness(x)
skewness(y)
# - 추가학습: skewness와 boxcox 변환

## 2.0 다양한 분포함수
# binorm : 이항분포
# f: f분포
# geom: 기하분포
# hyper: 초기하분포
# nbinorm: 음이항분포
# pois: 프와송 분포
# t: t분포
# unif: 균등분포
# chisq 카이제곱분포
set.seed(123)

## 분포함수 : norm에 대해
# dnorm(x, mean = 0, sd = 1, log = FALSE): density
# pnorm(q, mean = 0, sd = 1, lower.tail = TRUE, log.p = FALSE): probablilty 누적확률
## - lower.tail = T: return P(x<q)    |   lower.tail = F: return P(x>q)
## - log.p = F: return Prob           |   log.p = T: return log(Prob)
# qnorm(p, mean = 0, sd = 1, lower.tail = TRUE, log.p = FALSE): quantile
      #누적확률이 p가 될때의 X값
qnorm(pnorm(6)) #이렇게 하면 6(x값)이 나온다
# rnorm(n, mean = 0, sd = 1): random generation n samples =randn

# 평균이 0이고 표준편차가 10인 정규분포에서 100개의 난수 생성.
x <- rnorm(100, 0, 1)
hist(x, breaks=10)

plot(density(rnorm(1000000, 9, 10)))

# 평균이 0이고 표준편차가 1인 정규분포로부터:
pnorm(1)
pnorm(1, lower.tail = F)
pnorm(1, log.p = T)
exp(pnorm(1, log.p = T))

pnorm(1) - pnorm(-1)
pnorm(1.67) - pnorm(-1.67)
pnorm(1.96) - pnorm(-1.96)

pnorm(2)
pnorm(2) - pnorm(-2)

pnorm(3) - pnorm(-3)
pnorm(6) - pnorm(-6)

##- 소수점 k 자리까지의 정밀도를 1  ~ 22까지 표현가능하다. 기본값은 7.
specify_decimal <- function(x, k) trimws(format(round(x, k), nsmall=k))
specify_decimal(pnorm(6) - pnorm(-6), 10)

# density로 부터 두 값에 대한 분포확률(우도) 예측하기.
dnorm(1.1, 1.15, 1)*dnorm(1.2, 1.15, 1)
dnorm(1.1, 0.9, 1)*dnorm(1.2, 0.9, 1)

# 누적 확률이 0.9가 되는 x값을 찾아라.
q = qnorm(.9, 9, 10)
pnorm(q, 9, 10)
z = (qnorm(.9, 9, 10) - 9)/10
z
qnorm(.9, 0, 1)

(cps <- 1:9 / 10)
qs = qnorm(cps, 9, 10)
zs = (qs - 9)/10
pnorm(zs, 0, 1)

# N(9, 10) 분포에서 신뢰구간이 0.9가 되는 x를 찾아라.
tmp <- qnorm(0.05, 9, 10)
pnorm(9+9-tmp, 9, 10)
q = 18-tmp
z = (q-9)/10
pnorm(z, 0, 1)

## 프와송 분포: f(n, lambda)의 이해
# - 단위시간(단위공간)당 사건 발생 건수가 lambda일 때,
# - 단위시간 내, n번의 사건이 발생할 확률
dpois(1, 1.5) + ppois(0, 1.5)
ppois(1, 1.5)
ppois(3, 1.5)
qpois(0.9, 1.5)

dpois(3, 3)
dpois(3, 1)

# 단위시간당 1건 발생확률에서 0 ~ 5건까지 발생확률에 대한 누적합
sum = 0
for (i in 0:5){
  sum = sum + dpois(i, 1)
}
sum

# - 누적분포함수로 구하면:
ppois(5, 1)

## 이항분포
# - tv리모콘 문제: 채널 50에서 6번 눌렀을 때 채널 50.
# - 6C3 (1/2)^6
6*5*4/(3*2)*(0.5^6)
dbinom(3, 6, 0.5)  #6C3 (1/2)^6

#채널 50 이하일 경우
sum= 0
for (i in 0:3){
  sum = sum +dbinom(i,6,0.5)
}
sum
pbinom(3,6,0.5) #for문 돌린것과 동일하다

## 2.1 기초통계량
mean(1:10)
sd(1:10)
var(1:10)
# - 분산의 정의로부터: Var(x) = 1/(N-1) * sum[(x - mean(x))^2]
sum( (1:10 - mean(1:10))^2 ) / (10-1)

## 2.2 summay
# - 알고 보면 쉽게:
x <- 1:10
summary(x)
# - 알고 보면 쉽지 않다:
str(boxplot(x))
boxplot(x)$stats # data로부터

# - 왜 다를까?
c(min(x), quantile(x, 1/4), median(x), quantile(x, 3/4), max(x))

IQR(x)
quantile(x, c(1/4, 3/4))
qt <- quantile(x, c(1/4, 3/4), names = F)
qt[2] - qt[1]

## 2.3 명목형 변수에 대한 최빈값(mode)
x <- factor(c("a", "b", "c", "c", "c", "d", "d"))
x
str(x)
table(x) # named vector
str(table(x))
which.max(table(x))
str(which.max(table(x))) # named vector: https://rpubs.com/sowmya21jan/338762

names(table(x))[which.max(table(x))]

summary(x)
str(summary(x))

#### 13-2 t- 검정: 평균의 차 검정 ####

## -------------------------------------------------------------------- ##
mpg <- as.data.frame(ggplot2::mpg)

library(dplyr)
mpg_diff <- mpg %>%
  select(class, cty) %>%
  filter(class %in% c("compact", "suv"))

head(mpg_diff)
table(mpg_diff$class)

t.test(data = mpg_diff, cty ~ class, var.equal = T)

test <- aov(cty ~ class, data = mpg)
summary(test)

## -------------------------------------------------------------------- ##
mpg_diff2 <- mpg %>%
  select(fl, cty) %>%
  filter(fl %in% c("r", "p"))  # r:regular, p:premium

table(mpg_diff2$fl)

t.test(data = mpg_diff2, cty ~ fl, var.equal = T)

#### 13-3 ####

## -------------------------------------------------------------------- ##
economics <- as.data.frame(ggplot2::economics)
cor.test(economics$unemploy, economics$pce)

## -------------------------------------------------------------------- ##
head(mtcars)
car_cor <- cor(mtcars)  # 상관행렬 생성
round(car_cor, 2)       # 소수점 셋째 자리에서 반올림해서 출력

install.packages("corrplot")
library(corrplot)

corrplot(car_cor)

corrplot(car_cor, method = "number")

col <- colorRampPalette(c("#BB4444", "#EE9988", "#FFFFFF", "#77AADD", "#4477AA"))

corrplot(car_cor,
         method = "color",       # 색깔로 표현
         col = col(200),         # 색상 200개 선정
         type = "lower",         # 왼쪽 아래 행렬만 표시
         order = "hclust",       # 유사한 상관계수끼리 군집화
         addCoef.col = "black",  # 상관계수 색깔
         tl.col = "black",       # 변수명 색깔
         tl.srt = 45,            # 변수명 45도 기울임
         diag = F)               # 대각 행렬 제외


library(caret)
library(earth)
data(etitanic)
head(model.matrix(survived ~ ., data = etitanic),3)

dummies <- dummyVars(survived ~ ., data = etitanic)
head(predict(dummies, newdata = etitanic),3)

data(mdrr)
data.frame(table(mdrrDescr$nR11))

nzv <- nearZeroVar(mdrrDescr, saveMetrics = TRUE)
nzv[nzv$nzv, ][1:10, ]

dim(mdrrDescr)

nzv <- nearZeroVar(mdrrDescr)
filteredDescr <- mdrrDescr[, -nzv]
dim(filteredDescr)

descrCor <- cor(filteredDescr)
highCorr <- sum(abs(descrCor[upper.tri(descrCor)]) > 0.999)

descrCor <- cor(filteredDescr)
summary(descrCor[upper.tri(descrCor)])

highlyCorDescr <- findCorrelation(descrCor, cutoff = 0.75)
filteredDescr <- filteredDescr[, -highlyCorDescr]
descrCor2 <- cor(filteredDescr)
summary(descrCor2[upper.tri(descrCor2)])

ltfrDesign <- matrix(0, nrow = 6, ncol = 6)
ltfrDesign[, 1] <- c(1, 1, 1, 1, 1, 1)
ltfrDesign[, 2] <- c(1, 1, 1, 0, 0, 0)
ltfrDesign[, 3] <- c(0, 0, 0, 1, 1, 1)
ltfrDesign[, 4] <- c(1, 0, 0, 1, 0, 0)
ltfrDesign[, 5] <- c(0, 1, 0, 0, 1, 0)
ltfrDesign[, 6] <- c(0, 0, 1, 0, 0, 1)

comboInfo <- findLinearCombos(ltfrDesign)
comboInfo

ltfrDesign[, -comboInfo$remove]

set.seed(96)
inTrain <- sample(seq(along = mdrrClass), length(mdrrClass)/2)
training <- filteredDescr[inTrain, ]
test <- filteredDescr[-inTrain, ]
trainMDRR <- mdrrClass[inTrain]
testMDRR <- mdrrClass[-inTrain]
preProcValues <- preProcess(training, method = c("center", "scale"))
trainTransformed <- predict(preProcValues, training)
testTransformed <- predict(preProcValues, test)


sample_size=6
sw2=0.0153
y1bar=1.175
y2bar=1.293
y3bar=1.328
y4bar=1.415
y5bar=1.500
t=5
alpha=0.05
F_value=qf(1-alpha,t-1,25)

a=c(4,-1,-1,-1,-1)# for control vs agents
# test statistic
vl=sw2*((a[1]^2+a[2]^2+a[3]^2+a[4]^2+a[5]^2)/sample_size)
print(vl)
S=sqrt(vl)*sqrt((t-1)*F_value)
print(S)
# critcal value
l=abs(4*y1bar-y2bar-y3bar-y4bar-y5bar)
print(l)
if(S<l){
  print("  contrasts are significantly different from zero")

}else{
  print(" contrasts are not significantly different from zero")
}

a=c(0,1,1,-1,-1)# Biological vs. chemical
# test statistic
vl=sw2*((a[1]^2+a[2]^2+a[3]^2+a[4]^2+a[5]^2)/sample_size)
print(vl)
S=sqrt(vl)*sqrt((t-1)*F_value)
print(S)
# critcal value
l=abs(0*y1bar+y2bar+y3bar-y4bar-y5bar)
print(l)
if(S<l){
  print("  contrasts are significantly different from zero")

}else{
  print(" contrasts are not significantly different from zero")
}

a=c(0,1,-1,0,0)# Bio1 vs. Bio2
# test statistic
vl=sw2*((a[1]^2+a[2]^2+a[3]^2+a[4]^2+a[5]^2)/sample_size)
print(vl)
S=sqrt(vl)*sqrt((t-1)*F_value)
print(S)
# critcal value
l=abs(0*y1bar+y2bar-y3bar+0*y4bar+0*y5bar)
print(l)
if(S<l){
  print("  contrasts are significantly different from zero")

}else{
  print(" contrasts are not significantly different from zero")
}

a=c(0,0,0,1,-1)# Chm1 vs. Chm2
# test statistic
vl=sw2*((a[1]^2+a[2]^2+a[3]^2+a[4]^2+a[5]^2)/sample_size)
print(vl)
S=sqrt(vl)*sqrt((t-1)*F_value)
print(S)
# critcal value
l=abs(0*y1bar+0*y2bar+0*y3bar+y4bar-y5bar)
print(l)
if(S<l){
  print("  contrasts are significantly different from zero")

}else{
  print(" contrasts are not significantly different from zero")
}


# Possible growth functions:
# ---------------------------

# L(t) = Linf * f(t-t0)

# where f(t-t0) can be any of the following functions:

growthvb.f<- function(a,param.f,ssnl=0)
{   # this is the standard VB growth curve
    tf<- a<0
    a[tf]<- 0
    k<- param.f[1]
    f<- 1-exp(-k*a)
    return(f)
}

growthvblogk.f<- function(a,param.f,ssnl=0)
{   # this is the VB log k growth curve
    tf<- a<0
    a[tf]<- 0
    k1<-    param.f[1]
    k2<-    param.f[2]
    alpha<- param.f[3]
    beta<-  param.f[4]
    theta<- -(k2-k1)/beta
    d1<- 1+exp(-beta*(a-alpha))
    d2<- 1+exp(beta*alpha)
    g<-  (d1/d2)^theta
    g<-  1-exp(-k2*a)*g
    return(g)
}

growthrich.f <- function(a, param.f,ssnl=0)
{	# this is the Richard's growth curve
	#tf<- a<0
	#a[tf]<- 0
	k <- param.f[1]
	alpha <- param.f[2]
	beta <- param.f[3]
	k <- param.f[1]
	alpha <- param.f[2]
	beta <- param.f[3]
	g <- (1 + beta * exp( - k * (a - alpha)))^(-1/beta) - (1 + beta * exp(k * alpha))^
		(-1/beta)
	return(g)
}

# Seasonal growth models
#--------------------------------------------------------

growthvb.ssnl.f<- function(a,param.f,julian)
{   # this is the VB growth curve with a sinusoidal seasonal component
    # "julian" is in decimal yrs (ie. fraction of yr since Jan 1)

    tf<- a<0
    a[tf]<- 0

    k<- param.f[1]
    u<- param.f[2]
    w<- param.f[3]
    1-exp(-k*(a+u/(2*pi)*sin(2*pi*(julian-w))))
}

growthvblogk.ssnl.f<- function(a,param.f,julian)
{   # this is the VB log k growth curve
    # "julian" is in decimal yrs (ie fraction of yr since Jan 1)

    tf<- a<0
    a[tf]<- 0

    k1<-    param.f[1]
    k2<-    param.f[2]
    alpha<- param.f[3]
    beta<-  param.f[4]
    u<-     param.f[5]
    w<-     param.f[6]

    theta<- -(k2-k1)/beta
    d1<- 1+exp(-beta*(a+u/(2*pi)*sin(2*pi*(julian-w))-alpha))
    d2<- 1+exp(beta*alpha)
    g<-  (d1/d2)^theta
    g<-  1-exp(-k2*(a+u/(2*pi)*sin(2*pi*(julian-w))))*g
    return(g)
}


ftable(UCBAdmissions, col.vars="Admit")

dimnames(UCBAdmissions)

margin.table(UCBAdmissions, c(2,1))

ucb.df = data.frame(gender=rep(c("Male","Female"),c(6,6)), dept=rep(LETTERS[1:6],2), yes=c(512,353,120,138,53,22,89,17,202,131,94,24), no=c(313,207,205,279,138,351,19,8,391,244,299,317))
ucb.df

mod.form = "cbind(yes,no) ~ gender * dept"
glm.out = glm(mod.form, family=binomial(logit), data=ucb.df)

# turn off significance stars (optional)
options(show.signif.stars=F)

anova(glm.out, test="Chisq")
# This is a saturated model, meaning we have used up all our degrees of freedom, and there is no residual deviance left over at the end. Saturated models always fit the data perfectly.

summary(glm.out)
# antilog of the genderMale coefficient
exp(glm.out$coeff['genderMale'])
# All else being equal, the odds of female being admitted were 2.86 times the odds of a male being admitted.
# odss -> the ratio of two probabilities
#
#           p(one outcome)       p(success)    p
# odds = -------------------- = ----------- = ---, where q = 1 - p
#        p(the other outcome)    p(failure)    q
1/exp(glm.out$coeff['genderMale'])


x = c(7.4, 9.3, 5, 12)
y = c(-7.3, 2, 9, -4.9)

print("Vector x:")
print(x)
print("Vector y:")
print(y)

v = 2*x + 3*y + 1
print("Formula 2*x + 3*y + 1")
print(v)

print(paste("Vector length of v:", length(v)))
print(paste("Mimimum element of v:", min(v)))
print(paste("Maximum element of v:", max(v)))
print(paste("Sum of vector v:", sum(v)))
print(paste("Product of vector v:", prod(v)))
print(paste("Mean of vector v:", mean(v)))
print(paste("Standard deviation of vector v:", sd(v)))

print("Sorted vector x")
print(sort(x))

print("Sorted vector y")
print(sort(y))

sec = seq(-10, 10, 0.5)

print("Sequential vector")
print(sec)

cars = c("Acura", "Alfa Romeo", "Audi", "BMW", "Bentley", "Buick", "Cadillac", "Chevrolet")
print("Cars vector")
print(cars)

n = 10
sq1 = 1:n-1
sq2 = 1:(n-1)
print("Comparing sequence genration")
print(sq1)
print(sq2)

Curs 1 - Introduction in Machine Learning/set1.r