# Binomial logistic regression simulation code

# Raymond Viviano
# rayviviano@gmail.com
# March 23, 2020

#' Inverse Logit Function
inv.logit <- function(p){
    return(exp(p)/(1+exp(p)))
}

#' Coverage Probability, i.e., the probability that the confidence interval (ci)
#' for a parameter will contain the true value
#' Inputs:
#'          b       - Estimate
#'          se      - Standard Error of the Estimate
#'          true    - True value of parameter for data-generating process
#'          cl      - Confidence level
#'          dof     - Degrees of Freedom
#' Output:
#'          List containing coverage probability, vect
coverage.prob <- function(b, se, true, cl=.95, dof=Inf){
    # Compute quantile based on confidence level
    coverage.quantile <- cl + (1-cl)/2

    # Compute confidence interval upper and lower bounds
    ci.lower <- b - qt(coverage.quantile, df=dof)*se
    ci.upper <- b + qt(coverage.quantile, df=dof)*se

    # For each ci generated for each b/se pair, eval if true param is in ci
    ci.contain.true <- ifelse(true>=ci.lower & true<=ci.upper, 1, 0)

    # Calculate coverage probability
    cp <- mean(ci.contain.true)

    # Calculate Monte Carlo Error
    mc.err.lower <- cp - 1.96*sqrt((cp*(1-cp))/length(b))
    mc.err.upper <- cp + 1.96*sqrt((cp*(1-cp))/length(b))

    # Return coverage probability and error
    return(list(cp=cp, ci=cbind(mc.err.lower, mc.err.upper)))
}

#' Power to detect any effect at various alpha levels
#' Takes a vector of p-values and calculates the proportion of modell where the
#' p-val for the effect of interest was < .5, .01, and .001.
power.detect.effect <- function(p.val.vec){
    less.than.05 <- ifelse(p.val.vec < .05, 1, 0)
    prop.05 <- sum(less.than.05)/length(less.than.05)

    less.than.01 <- ifelse(p.val.vec < .01, 1, 0)
    prop.01 <- sum(less.than.01)/length(less.than.01)

    less.than.001 <- ifelse(p.val.vec < .001, 1, 0)
    prop.001 <- sum(less.than.001)/length(less.than.001)

    cat(paste0('Power to detect effect at .05: ', prop.05, '\n'))
    cat(paste0('Power to detect effect at .01: ', prop.01, '\n'))
    cat(paste0('Power to detect effect at .001: ', prop.001, '\n'))
}

# Ensure reproducible results
set.seed(10000)

# Set logistic regression parameters (Can be calculated as log(oddsRatio))
b0 <- .2        # Set Logistic Regression Intercept True Value
b1 <- .5        # Set Logistic Regression Slope True Value

# Define sample size
n <- 16000

# Define number of simulations
nsims <- 20

# Define matrix to hold simulation data (estimates, std.errors, and pvals)
sim.prms <- matrix(NA, nrow=nsims, ncol=6)

# Loop through simulations
for(i in 1:nsims){
    # Generate independant variable data, uniform random between -1 and 1
    x <- runif(n, -1, 1)

    # Generate true data-generation-process Bernoulli trials
    y <- rbinom(n, 1, inv.logit(b0 + b1*x))

    # Estimate logit model
    model <- glm(y~x, family=binomial(link=logit))

    # Get variance-covariance matrix
    var.covar <- vcov(model)

    # Put model paramters in simulation matrix
    sim.prms[i,1] <- model$coef[1]             # Estimate for b0
    sim.prms[i,2] <- model$coef[2]             # Estimate for b1
    sim.prms[i,3] <- sqrt(diag(var.covar)[1])  # b0 standard error
    sim.prms[i,4] <- sqrt(diag(var.covar)[2])  # b1 standard error
    sim.prms[i,5] <- summary(model)$coefficients[,4][1] # b0 pvalue
    sim.prms[i,6] <- summary(model)$coefficients[,4][2] # b1 pvalue
}

# Get Covarage probabilities for the parameters
b0.coverage <- coverage.prob(sim.prms[,1], sim.prms[,3], b0, .95, n-model$rank)
b1.coverage <- coverage.prob(sim.prms[,2], sim.prms[,4], b1, .95, n-model$rank)

# Print intercept coverage probability and 95% confidence interval
print("Coverage Probability for b0")
print(b0.coverage)

# Print coefficent on x coverage probability and 95% confidence interval
print("Coverage Probability for b1")
print(b1.coverage)

# Power for intercept
cat("Power to detect b0\n")
power.detect.effect(sim.prms[,5])

cat("\nPower to detect b1\n")
# Power for coefficient on x
power.detect.effect(sim.prms[,6])


var_moving_avg=function(song,segment){
# song is a vector of 0's and 1's that represents the hits (0) and
#   misses (1) of the notes in order
# segment is the number of values to use in the moving average.

  var(filter(song,filter = rep(1/segment,segment)),na.rm=T)

  # It is recommended to use the R help menu help(filter) to use the uses of the filter function.
  # Note that using rep(1/segment,segment) uses equal weights of the values involved in the moving average.
}

# Hypothesis test based on the variance of the moving average method
var_moving_avg_test = function(song,segment,B=1000){
    # song is a vector of 0's and 1's that represents the hits (0)
	# and misses (1) of the notes in order
	# B is the number of new samples to generate

	test_stat = var_moving_avg(song,segment)
	n = length(song)
	tstar_b = numeric(B)
	for(b in 1:B){
		song_tmp = sample(song)  # for permutation test
#		song_tmp = sample(song,replace=T) # for non-parametric bootstrap
#		song_tmp = rbinom(n,1,mean(song)) # for parametric bootstrap
		tstar_b[b] = var_moving_avg(song_tmp,segment)
	}

	# calculate the two-sided p-value from the sampling distribution
	pval = 2*min(sum(tstar_b >= test_stat),sum(tstar_b <= test_stat))/B
		# calculate a one sided p-value
#	pval = sum(tstar_b >= test_stat)/B
	return(pval)
}

# Examples using Songs A and B from Table 1

songA = c(1,0,0,0,0,0,1,0,1,0,0,1,0,0,0,0,1,0,0,0)
var_moving_avg(songA,floor(sqrt(length(songA))))
var_moving_avg_test(songA,floor(sqrt(length(songA))),5000)

songB = c(0,0,0,1,0,0,0,0,0,0,0,1,1,1,1,0,0)
var_moving_avg(songB,floor(sqrt(length(songA))))
var_moving_avg_test(songB,floor(sqrt(length(songA))),5000)


library(DescTools)
x = c(0.90, 0.37, 1.63, 0.83, 0.95, 0.78, 0.86, 0.61, 0.38, 1.97)
y = c(1.46, 1.45, 1.76 ,1.44, 1.11 ,3.07 ,0.98 ,1.27 ,2.56 ,1.32)

cbind(c(x,y),rank(c(x,y)))

a <- wilcox.test(x,y,correct=FALSE,conf.int = TRUE)
n1 <- length(x)
a$statistic <- a$statistic + n1*(n1+1)/2
names(a$statistic) <- "T.W"
a
# T<83 so  we reject H0 and conclude there is significant evidence that the placebo population has smaller reaction times than the population of alcohol consumers
# p value calculated in book is wrong
# confidence interval for delta (-1.08, -0.25)

#  95% confidence interval   for the placebo population median
MedianCI(x,conf.level = 0.95,na.rm = FALSE, method = "exact",R = 10000)
# #  95% confidence interval   for the alcohol population median
MedianCI(y,conf.level = 0.95,na.rm = FALSE, method = "exact",R = 10000)


library(repr); options(repr.plot.res = 100, repr.plot.width = 6, repr.plot.height = 6) # Change plot sizes (in cm) - this bit of code is only relevant if you are using a jupyter notebook - ignore otherwise

mammals <- read.csv('../data/MammalData.csv', stringsAsFactors = T)
str(mammals)

summary(mammals)

plot(meanCvalue ~ TrophicLevel, data = mammals)

mammals$logCvalue <- log(mammals$meanCvalue)

seMean <- function(x){ # get standard error of the mean from a set of values (x)
    x <- na.omit(x) # get rid of missing values

    se <- sqrt(var(x)/length(x)) # calculate the standard error

    return(se)  # tell the function to return the standard error
}

trophMeans <- tapply(mammals$logCvalue, mammals$TrophicLevel, FUN = mean, na.rm = TRUE)

print(trophMeans)

trophSE <- tapply(mammals$logCvalue, mammals$TrophicLevel, FUN = seMean)

print(trophSE)

# get the upper and lower limits of the error bars
upperSE <- trophMeans + trophSE
lowerSE <- trophMeans - trophSE

# get a barplot
# - this function can report where the middle of the bars are on the x-axis
# - set the y axis limits to contain the error bars

barMids <- barplot(trophMeans, ylim=c(0, max(upperSE)), ylab = 'log C value (pg)')

# Now use the function to add error bars
# - draws arrows between the points (x0,y0) and (x1,y1)
# - arrow heads at each end (code=3) and at 90 degree angles

arrows(barMids, upperSE, barMids, lowerSE, ang=90, code=3)

#Load the gplots package
library(gplots)

# Get plots of group means and standard errors
par(mfrow=c(1,2))
plotmeans(logCvalue ~ TrophicLevel, data=mammals, p=0.95, connect=FALSE)
plotmeans(logCvalue ~ GroundDwelling, data=mammals, p=0.95, connect=FALSE)

trophicLM <- lm(logCvalue ~ TrophicLevel, data=mammals)

anova(trophicLM)

summary(trophicLM)

TukeyTroph <- TukeyHSD(aov(trophicLM))
print(TukeyTroph)

library(repr) ; options(repr.plot.res = 100, repr.plot.width = 5, repr.plot.height = 5) # Change plot size

par(las=1, mar=c(4,10,3,1))
# las= 1 turns labels horizontal
# mar makes the left margin wider (bottom, left, top, right)
plot(TukeyTroph)

factorTable <- table(mammals$GroundDwelling, mammals$TrophicLevel)
print(factorTable)

chisq.test(factorTable)

save(mammals, file='../data/mammals.Rdata')


########################
# R Script for Class 6 #
########################

# t distribution
x <- seq(-4, 4, length=100)
hx <- dnorm(x)

degf <- c(1, 3, 8, 30)
colors <- c("red", "blue", "darkgreen", "gold", "black")
labels <- c("t df=1", "t df=3", "t df=8", "t df=30", "normal")

plot(x, hx, type="l", lty=2, xlab="x value",
     ylab="Density", main="Comparison of t and normal Distributions")

for (i in 1:4){
  lines(x, dt(x,degf[i]), lwd=2, col=colors[i])
}

legend("topright",
       labels, lwd=2, lty=c(1, 1, 1, 1, 2), col=colors)

# checking p-values
1-pnorm(1.96)
1-pt(1.96, 15)

# loading data
D = read.csv2('shoesize.csv')
D

# exploring height
D$Height
mean(D$Height)
sd(D$Height)
quantile(D$Height)
hist(D$Height)
plot(density(D$Height))

sd(D$Height)/sqrt(408)

# Assumming this data is a random sample of the full school populatio, what is our best estimate of the mean height of all students at this university? Provide a point estimate and 95% confidence interval.

# Assumming this data is a random sample of the full school populatio, what is our best estimate of the mean shoe sizeght of all students at this university? Provide a point estimate and 95% confidence interval.

hist(D$Size)
mean(D$Size)
sd(D$Size)

mean(D$Size)+(2*(sd(D$Size)/sqrt(408)))
mean(D$Size)-(2*(sd(D$Size)/sqrt(408)))

# What is the relationship between height and shoe size?

plot(D$Height, D$Size)
cor(D$Height, D$Size)

M = lm(D$Height~D$Size)
summary(M)

M = lm(D$Height~D$Size+D$Gender)
summary(M)

M = lm(D$Height~D$Size+D$Gender + D$Size*D$Gender )
summary(M)

# family planning data
library(foreign)
library(calibrate)

D = read.dta('effort.dta')
head(D)

plot(change~effort, data=D, ylab="CBR change", xlab="program effort", pch=20, col="#000099dd", cex=2)

M = lm(change~effort, data=D)
summary(M)

M = lm(change~effort+setting, data=D)
summary(M)


w1 <- c(3,4,4,5)
print(typeof(w1))
w2 <- c(4, 1)
print(typeof(w2))
w3 <- w1 + w2
print(w3)

x <- c(1, 0, 0, 2) # вектор x
y <- c(0, 1, 1, 2) # вектор y
z <- x + y # прибавляем к каждому элементу x элемент y
print(z)

w3 <- c(Inf, NULL, NA, FALSE, 18, NaN)
print(typeof(w3))
w4 <- c(Inf, NULL, NA, FALSE, 18L, NaN)
print(typeof(w4))
w5 <- c(Inf, NULL, NA, FALSE, '18', NaN)
print(typeof(w5))
w6 <- c(NULL)
print(typeof(w6))

#Если требуется вектор-заготовка для хранения данных определенного типа и определенного размера,
#вызывают функцию vector() с заданием нужных параметров:
z <- vector()
z2 <- vector(mode='numeric', length=129)
z3 <- vector(mode='logical', length=22)
z4 <- vector(mode='integer', length=34)
z5 <- vector(mode='character', length=0)
z6 <- vector(mode='double', length=19)

z6 <- vector(length=19, mode='double')
z7 <-vector(length=19) # тип данных задается по умолчанию
z8 <- vector(mode='double') # длина вектора задается по умолчанию

z2 <- numeric(length=129)
z3 <- logical(length=22)
z4 <- integer(length=34)
z5 <- character(length=0)

w <- c(10:3)
w <- c(1:20, 3)
w <- c(10:5, 5:10, 15:18)

w <- rep(с(0, -1, 1:3), times = 3)
print(w)
w <- rep(с(0, -1, 1:3), each = 3)
print(w)
w <- rep(с(0, -1, 1:3), each = 3, times = 2)
print(w)

w <- seq(4, from=12, length.out = 10)
print(w)

#Задание.
#Приведите пример создания вектора через вызов функции seq() в случае одновременного использования параметров by и length.out. Объясните правило формирования вектора в этом случае.
w <- seq(from = -40, by = 3.5, length.out = 50)
print(w)

#Самостоятельно исследуйте параметры и поведение seq_len() и объясните
# в каком случае вызов seq() приведет к вызову и исполнению seq_len().
w1 <- seq_len(100)
print(w1)

w2 <- seq(from = 0, by = 0.5, length.out = 20)
print(w2)

min(w2)
max(w2)


                                ############################
                                #FORECASTING AIRLINE DELAYS#
                                ############################
# PROBLEM 1 - LOADING THE DATA
Airlines <- read.csv("AirlineDelay.csv")
set.seed(15071)

spl = sample(nrow(Airlines), 0.7*nrow(Airlines))

AirlinesTrain = Airlines[spl,]

AirlinesTest = Airlines[-spl,]
# How many observations are in the training set AirlinesTrain?
str(AirlinesTrain)
# How many observations are in the testing set AirlinesTest?
str(AirlinesTest)

# PROBLEM 2 - METHOD OF SPLITTING THE DATA
# In this class, we have frequently used the sample.split function to randomly split our data.
#                             Why do we use a different approach here?
# Review help(sample.split) of caTools package to find the answer

# PROBLEM 3 - A LINEAR REGRESSION MODEL
# Build a linear regression model to predict "TotalDelay"
linFit <- lm(TotalDelay ~ ., data=AirlinesTrain)
# What is the model's R-squared?
summary(linFit)

#PROBLEM 4 - CHECKING FOR SIGNIFICANCE
# In your linear regression model, which of the independent variables are significant at the
#                             p=0.05 level (at least one star)?
summary(linFit)

# PROBLEM 5 - CORRELATIONS
# What is the correlation between NumPrevFlights and PrevFlightGap in the training set?
cor(AirlinesTrain$NumPrevFlights,AirlinesTrain$PrevFlightGap)
# What is the correlation between OriginAvgWind and OriginWindGust in the training set?
cor(AirlinesTrain$OriginAvgWind,AirlinesTrain$OriginWindGust)

# PROBLEM 6 - IMPORTANCE OF CORRELATIONS
# Why is it imporant to check for correlations between independent variables? Select all that apply.
# Read article on "multicollinearity" to answer the quiz

# PROBLEM 7 - COEFFICIENTS
# In the model with all of the available independent variables, what is the coefficient for HistoricallyLate?
coef(linFit)

# PROBLEM 8 - UNDERSTANDING THE COEFFICIENTS
# The coefficient for NumPrevFlights is 1.56. What is the interpretation of this coefficient?
# Read article on "Coefficient of determination" to answer the quiz

# PROBLEM 9 - UNDERSTANDING THE MODEL
# In the linear regression model, given two flights that are otherwise identical, what is the absolute
# difference in predicted total delay given that
# -one flight is on Thursday and the other is on Sunday?
# -one flight is on Saturday and the other is on Sunday?
# The absolute difference between the coefficients of two dates is the predicted delay

# PROBLEM 10 - PREDICTIONS ON THE TEST SET
# What is the Sum of Squared Errors (SSE) on the test set?
predictions <- predict(linFit, newdata=AirlinesTest)
# What is the Total Sum of Squares (SST) on the test set?
SSE <- sum((AirlinesTest$TotalDelay - predictions)^2)
# What is the R-squared on the test set?
SST <- sum((AirlinesTest$TotalDelay - mean(AirlinesTrain$TotalDelay))^2)
1-SSE/SST

# PROBLEM 11 - EVALUATING THE MODEL
# Given what you have seen about this model (the R-squared on the training and test sets, the
# significance of the coefficients, etc.), which of the following are true?
# Eliminate wrong choices. Read article on "R-squared" to answer the question

# PROBLEM 12 - A CLASSIFICATION PROBLEM
Airlines$DelayClass = factor(ifelse(Airlines$TotalDelay == 0, "No Delay", ifelse
                                    (Airlines$TotalDelay >= 30, "Major Delay", "Minor Delay")))
# How many flights in the dataset Airlines had no delay, minor delay, major delay respectively?
summary(Airlines$DelayClass)
Airlines$TotalDelay = NULL
# Prepare necessary data for CART model
library(caTools)
set.seed(15071)
split <- sample.split(Airlines$DelayClass, SplitRatio=0.7)
AirlinesNewTrain <- subset(Airlines, split==T)
AirlinesNewTest <- subset(Airlines, split==F)

# PROBLEM 13 - A CART MODEL
library(rpart)
library(rpart.plot)
cart <- rpart(DelayClass ~., data=AirlinesNewTrain, method="class")
# How many split are in the resulting tree?
prp(cart)

# PROBLEM 14 - UNDERSTANDING THE MODEL
# The CART model you just built never predicts one of the three outcomes. Which one?
prp(cart)

# PROBLEM 15 - TRAINING SET ACCURACY
library(caret)
# Make predictions on the training set, and then create a confusion matrix.
# What is the overall accuracy of the model?
cartTrainPredicts <- predict(cart, AirlinesNewTrain, type="class")
confusionMatrix(AirlinesNewTrain$DelayClass, cartTrainPredicts)

# PROBLEM 16 - A BASELINE MODEL
# What is the accuracy on the training set of a baseline model that predicts the most
# frequent outcome (No Delay) for all observations?
obs <- max(table(AirlinesNewTrain$DelayClass))
obs/nrow(AirlinesNewTrain)

# PROBLEM 17 - TESTING SET ACCURACY
# Make predictions on the testing set, and then create a confusion matrix. What is the
# overall accuracy of the model on the testing set?
cartTestPredicts <- predict(cart, newdata=AirlinesNewTest, type="class")
confusionMatrix(AirlinesNewTest$DelayClass, cartTestPredicts)


#install.packages("GA")
library(GA)

# https://cran.r-project.org/web/packages/GA/vignettes/GA.html#constrained-optimisation
# Townsend function (modified)
# https://en.wikipedia.org/wiki/Test_functions_for_optimization
func3d <- function(x)
{
  -(cos((x[1]-0.1)*x[2]))^2-x[1]*sin(3*x+x[2])
}

c1 <- function(x)
{
  t <- atan2(x[1], x[2])
  x[1]^2+x[2]^2-(2*cos(t)-1/2*cos(2*t)-1/4*cos(3*t)-1/8*cos(4*t))^2-(2*sin(t))^2
}

x1LBound <- -2.25
x1RBound <- 2.25
x2LBound <- -2.5
x2RBound <- 1.75

ngrid <- 20 # 250
nLevels <- 5
x1 <- seq(x1LBound, x1RBound, length = ngrid)
x2 <- seq(x2LBound, x2RBound, length = ngrid)
x12 <- expand.grid(x1, x2)
col <- adjustcolor(bl2gr.colors(4)[2:3], alpha = 0.2)
plot(x1, x2, type = "n", xaxs = "i", yaxs = "i")
image(x1, x2, matrix(ifelse(apply(x12, 1, c1) <= 0, 0, NA), ngrid, ngrid), col = col[1], add = TRUE)
contour(x1, x2, matrix(apply(x12, 1, func3d), ngrid, ngrid), nlevels = nLevels, add = TRUE)

fitness <- function(x)
{
  f <- -func3d(x)                    # we need to maximise -func3d(x)
  pen <- sqrt(.Machine$double.xmax)  # penalty term
  penalty1 <- max(c1(x),0)*pen       # penalisation for 1st inequality constraint
  f - penalty1                       # fitness function value
}

GA <- ga("real-valued", fitness = fitness,
         lower = c(x1LBound, x2LBound), upper = c(x1RBound, x2RBound),
         # selection = GA:::gareal_lsSelection_R,
         maxiter = 10000, run = 5000) # seed = 123)
summary(GA)
plot(GA)

fitness(GA@solution)
func3d(GA@solution)
c1(GA@solution)

plot(x1, x2, type = "n", xaxs = "i", yaxs = "i")
image(x1, x2, matrix(ifelse(apply(x12, 1, c1) <= 0, 0, NA), ngrid, ngrid), col = col[1], add = TRUE)
contour(x1, x2, matrix(apply(x12, 1, func3d), ngrid, ngrid), nlevels = nLevels, add = TRUE)
points(GA@solution[1], GA@solution[2], col = "dodgerblue3", pch = 3)  # GA solution


######################################################################
# Ratfor program to display emirps
######################################################################

######### Test if a number is prime #########
logical function prime(n)
    integer n  # Number to test

    # Deal with numbers <= 3
    if (n < 1) goto 200
    if (n == 2 | n == 3) goto 100

    # Check if divisible by 2 or 3
    if (mod(n,2) == 0) goto 200
    if (mod(n,3) == 0) goto 200

    # See if divisible by 5, 7, ..., up to approx sqrt(n)
    for (i = 5; i < 1000000; i = i + 2) {
        if (I*I > n) goto 100
        if (mod(n,i) == 0) goto 200
    }

 100  prime = .true.
      return
 200  prime = .false.
      return
end

######### Reverse an integer's digits #########
integer function revrse(n)
    integer n  # Number to reverse
    integer m  # Copy of n from which we take digits
    integer r  # Reversed digits
    m = n
    r = 0
    while (m >= 1) {
        # Take last digit from m and append to r
        r = r * 10
        r = r + mod(m, 10)
        m = m / 10
    }
    revrse = r
    return
end

######### Test if an integer is an emirp #########
logical function emirp(n)
    integer n       # Number to test
    integer revrse  # External function
    logical prime   # External function
    integer r       # Reversed digits of n
    r = revrse(n)
    emirp = .false.
    # n and r must both be prime and not the same value
    if (n .ne. r & prime(n) & prime(r)) {
        emirp = .true.
    }
    return
end

######### Display an integer #########
subroutine show(n)
    integer n
    write(6,50) n
50  format(i10)
    return
end

######### Show first 20 emirps #########
subroutine test1
    logical emirp   # External function
    integer i       # Count of emirps found
    integer n       # Number to test
    n = 0
    for (i = 1; i <= 20; i = i + 1) {
        repeat {
            n = n + 1
        } until (emirp(n))
        call show(n)
    }
    return
end

######### Show emirps between 7,700 and 8,000 #########
subroutine test2
    logical emirp   # External function
    integer n       # Number to test
    for (n = 7700; n <= 8000; n = n + 1) {
        if (emirp(n)) {
            call show(n)
        }
    }
    return
end

######### Show 10,000th emirp #########
subroutine test3
    logical emirp   # External function
    integer i       # Count of emirps found
    integer n       # Number to test
    n = 0
    for (i = 1; i <= 10000; i = i + 1) {
        repeat {
            n = n + 1
        } until (emirp(n))
    }
    call show(n)
    return
end

######### Main entry point #########
call test1
call test2
call test3
stop
end


### 線形判別分析(2値判別)の例
### - Biopsy Data on Breast Cancer Patients

## データの読み込み ("MASS::biopsy"を用いる)
require(MASS) # パッケージの読み込み (lda/biopsy)
require(tidyverse)
require(ggfortify)
require(GGally)
require(plotROC)

## データの内容を表示
help(biopsy)  # 内容の詳細を表示
## print(biopsy) # データの表示
head(biopsy)  # 最初の6個を表示
tail(biopsy)  # 最後の6個を表示

## データの散布図: 図(a)
mydata <- na.omit(biopsy)[-1] # NA，および患者のIDを除く
ggpairs(mydata, lower=list(mapping=aes(colour=class)))
## ## ggscatmat でも似たことはできるが数値データの散布図のみ
## ggscatmat(mydata, color="class", alpha=.8) # colour ではない

## 主成分分析による2次元表示: 図(b)
autoplot(prcomp(mydata[-10]), data=mydata, colour="class") +
    theme(legend.position=c(.9,.9))

## 判別分析 (ランダムに選んだ300個のサンプルで分析)
## set.seed(1234) # 実験の再現性を求める場合
idx <- sample(nrow(mydata),300)
train <- mydata[idx,] # 学習に用いるデータを選択
model <- lda(class ~ .,data=train)
print(model) # モデルの概要を表示

## 線形判別関数の値の分布をクラス毎に表示
predict.tr <- predict(model) # 学習データの予測
res.tr <- data.frame(x=as.vector(predict.tr$x), # 学習データの評価用
                    class=train$class,
                    d=c(benign=0,malignant=1)[train$class])
## 判別関数の値の分布 (学習データ): 図(c)
ggplot(res.tr, aes(x)) + xlim(-3,8) + # 値の範囲を指定
    geom_histogram(aes(fill=class)) +
    facet_grid(class ~ .) + theme(legend.position="none")

## AUC (学習データ): 図(d)
gg <- ggplot(res.tr, aes(m=x, d=d)) + geom_roc(colour="red")
gg + annotate("text", x=.9, y=.1,
              label=paste("AUC =", round(calc_auc(gg)$AUC,3)))

## 上記の結果を用いて残りのサンプルを予測
test <- mydata[-idx,] # 予測対象のデータを選択
predict.te <- predict(model,newdata=test[,-10])
table(true=test$class,est=predict.te$class) # 判別結果を表示

## 線形判別関数の値の分布をクラス毎に表示
res.te <- data.frame(x=as.vector(predict.te$x), # 試験データの評価用
                    class=test$class,
                    d=c(benign=0,malignant=1)[test$class])
## 判別関数の値の分布 (試験データ): 図(e)
ggplot(res.te, aes(x)) + xlim(-3,8) + # 値の範囲を指定
    geom_histogram(aes(fill=class)) +
    facet_grid(class ~ .) + theme(legend.position="none")

## AUC (試験データ): 図(f)
gg <- ggplot(res.te, aes(m=x, d=d)) + geom_roc(colour="red")
gg + annotate("text", x=.9, y=.1,
              label=paste("AUC =", round(calc_auc(gg)$AUC,3)))


library(astsa)

# read data to R variable
birth.data<-read.csv("daily-total-female-births-in-cal.csv")

# pull out number of births column
number_of_births<-birth.data$Daily.total.female.births.in.California..1959

# use date format for dates
birth.data$Date <- as.Date(birth.data$Date, "%m/%d/%Y")

plot.ts(number_of_births,main='Daily total female births in california, 1959', ylab = 'Number of births')

# Test for correlation
Box.test(number_of_births, lag = log(length(number_of_births)))

# Plot the differenced data
plot.ts(diff(number_of_births), main='Differenced series', ylab = '')

# Test for correlation in the differenced data
Box.test(diff(number_of_births), lag = log(length(diff(number_of_births))))

# acf and pacf of the differenced data

acf(diff(number_of_births), main='ACF of differenced data', 50)
pacf(diff(number_of_births), main='PACF of differenced data', 50)

# Fit various ARIMA models

model1<-arima(number_of_births, order=c(0,1,1))
SSE1<-sum(model1$residuals^2)
model1.test<-Box.test(model1$residuals, lag = log(length(model1$residuals)))

model2<-arima(number_of_births, order=c(0,1,2))
SSE2<-sum(model2$residuals^2)
model2.test<-Box.test(model2$residuals, lag = log(length(model2$residuals)))

model3<-arima(number_of_births, order=c(7,1,1))
SSE3<-sum(model3$residuals^2)
model3.test<-Box.test(model3$residuals, lag = log(length(model3$residuals)))

model4<-arima(number_of_births, order=c(7,1,2))
SSE4<-sum(model4$residuals^2)
model4.test<-Box.test(model4$residuals, lag = log(length(model4$residuals)))

df<-data.frame(row.names=c('AIC', 'SSE', 'p-value'), c(model1$aic, SSE1, model1.test$p.value),
               c(model2$aic, SSE2, model2.test$p.value), c(model3$aic, SSE3, model3.test$p.value),
               c(model4$aic, SSE4, model4.test$p.value))
colnames(df)<-c('Arima(0,1,1)','Arima(0,1,2)', 'Arima(7,1,1)', 'Arima(7,1,2)')

format(df, scientific=FALSE)

# Fit a SARIMA model

sarima(number_of_births, 0,1,2,0,0,0)


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

rm(list = ls())

observed <- c(9, 11, 4, 6)

(k <- length(observed))
# 4

(n <- sum(observed))
# 30

## test F(x) is poisson(lambda)

LogLikelihood <- function(lambda, y, k) {
  (sum(y[1:(k - 1)] * dpois(0:(k - 2), lambda = lambda, log = TRUE)) +
    y[k] * ppois(k - 2, lambda = lambda, lower.tail = FALSE, log = TRUE))
}

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

opt <- optim(1, NegativeLogLikelihood, y = observed, k = k,
             lower = 10e-4, method = 'L-BFGS-B')

(lambda.hat <- opt$par)
# 1.31334181246836

(expected1 <- n * c(dpois(0:(k-2), lambda = lambda.hat), 1 - ppois(k - 2, lambda = lambda.hat)))
# 8.06759619945891 10.5955114148602 6.9577640828109 4.37912830286995

(Q1 <- sum((observed - expected1) ^ 2 / expected1))
# 1.98049899014501

1 - pchisq(Q1, df = (k - 1) - 1)
# 0.371483996032531

## test F(x) is poisson(1.2)
(expected2 <- n * c(dpois(0:(k-2), lambda = 1.2), 1 - ppois(k - 2, lambda = 1.2)))
# 9.03582635736606 10.8429916288393 6.50579497730357 3.61538703649109

(Q2 <- sum((observed - expected2) ^ 2 / expected2))
# 2.54038357961436

1 - pchisq(Q2, df = (k - 1))
# 0.468037053437737

## power:

(null <- n * c(dpois(0:(k-2), lambda = 1.2), 1 - ppois(k - 2, lambda = 1.2)))
# 9.03582635736606 10.8429916288393 6.50579497730357 3.61538703649109

(alternative <- n * c(dnbinom(0:(k-2),size = 2, prob = 2 / 3), 1 - pnbinom(k - 2,size = 2, prob = 2 / 3)))
# 13.3333333333333 8.88888888888889 4.44444444444445 3.33333333333333

(Q <- sum((alternative - null) ^ 2 / alternative))
# 2.79465432822941

(power <- 1 - pchisq(qchisq(0.95, df = k - 1), df = k - 1, Q))
# 0.257468163480735

## sample size power >= 0.8

fn <- function(n) {
  null <- n * c(dpois(0:(k-2), lambda = 1.2), 1 - ppois(k - 2, lambda = 1.2))
  alternative <- n * c(dnbinom(0:(k-2),size = 2, prob = 2 / 3), 1 - pnbinom(k - 2,size = 2, prob = 2 / 3))

  Q <- sum((alternative - null) ^ 2 / alternative)
  power <- 1 - pchisq(qchisq(0.95, df = k - 1), df = k - 1, Q)
}

(n.exact <- uniroot(function(n) {fn(n) - 0.8}, c(1, 500))$root)
# 117.036620884611

ceiling(n.exact)
# 118


N <- 1e6
b <- 10

X <- runif(n = N, min = 0, max = b)
Y <- runif(n = N, min = 0, max = b)

U <- (X-b/2)^2
V <- (Y-b/2)^2
W <- U + V

ecc <- ecdf(W)

hist(W)

F_T <- function(t){
  b <- b + 0i
  t <- t + 0i
  Re(
    (b*sqrt(4*t-b^2) - 4*t*atan(sqrt(4*t-b^2)/b) + 2*pi*t)/(2*b^2)
  )
}

r <- runif(1, 0, b/2)
ecc(r^2)
F_T(r^2)
(pi*r^2)/b^2

thN <- sample(1:N, min(1000, N), replace = FALSE)
plot(X[thN], Y[thN], col = as.numeric(W[thN] <= r^2) + 1)
plotrix::draw.circle(x = b/2, y = b/2, radius = r, lwd = 4)

var_delta <- function(A, u, n){
  sapply(A, function(x) {
    x*(u^2-x)/n
  })
}
# var_delta <- Vectorize(var_delta)
uu <- 1
curve(var_delta(x, u = uu, n = 10), 0, pi*uu^2/4, lwd = 3,
      ylab = expression(Var(delta[1])), xlab = expression(A))
curve(var_delta(x, u = uu, n = 30), 0, pi*uu^2/4,
      lty = 2, lwd = 3, add = TRUE)
curve(var_delta(x, u = uu, n = 100), 0, pi*uu^2/4,
      lwd = 3, lty = 4, add = TRUE)
abline(v = uu^2/2, lwd = 2, lty = 5)
legend(x = "topleft",
       legend = c("n=10", "n=30", "n=100"),
       lwd = 2, lty = 1:4, col = 1, bty = 'n')


#install.packages("GA")
library(GA)

# https://cran.r-project.org/web/packages/GA/vignettes/GA.html#constrained-optimisation
  # Simionescu function
# https://en.wikipedia.org/wiki/Test_functions_for_optimization
func3d <- function(x)
{
  0.1*x[1]*x[2]
}

c1 <- function(x)
{
  r_t <- 1
  r_s <- 0.2
  n <- 8
  x[1]^2+x[2]^2-(r_t+r_s*cos(n*atan(x[1]/x[2])))^2
}

x1LBound <- -1.25
x1RBound <- 1.25
x2LBound <- -1.25
x2RBound <- 1.25

ngrid <- 250 # 250
nLevels <- 21
x1 <- seq(x1LBound, x1RBound, length = ngrid)
x2 <- seq(x2LBound, x2RBound, length = ngrid)
x12 <- expand.grid(x1, x2)
col <- adjustcolor(bl2gr.colors(4)[2:3], alpha = 0.2)
plot(x1, x2, type = "n", xaxs = "i", yaxs = "i")
image(x1, x2, matrix(ifelse(apply(x12, 1, c1) <= 0, 0, NA), ngrid, ngrid), col = col[1], add = TRUE)
contour(x1, x2, matrix(apply(x12, 1, func3d), ngrid, ngrid), nlevels = nLevels, add = TRUE)

fitness <- function(x)
{
  f <- -func3d(x)                    # we need to maximise -func3d(x)
  pen <- sqrt(.Machine$double.xmax)  # penalty term
  penalty1 <- max(c1(x),0)*pen       # penalisation for 1st inequality constraint
  f - penalty1                       # fitness function value
}

GA <- ga("real-valued", fitness = fitness,
         lower = c(x1LBound, x2LBound), upper = c(x1RBound, x2RBound),
         # selection = GA:::gareal_lsSelection_R,
         maxiter = 10000, run = 1000) # seed = 123)
summary(GA)
plot(GA)

fitness(GA@solution)
func3d(GA@solution)
c1(GA@solution)

plot(x1, x2, type = "n", xaxs = "i", yaxs = "i")
image(x1, x2, matrix(ifelse(apply(x12, 1, c1) <= 0, 0, NA), ngrid, ngrid), col = col[1], add = TRUE)
contour(x1, x2, matrix(apply(x12, 1, func3d), ngrid, ngrid), nlevels = nLevels, add = TRUE)
points(GA@solution[1], GA@solution[2], col = "dodgerblue3", pch = 3)  # GA solution


library(rstudioapi)
library(ellipse)
library(ggplot2)
library(readr)
library(psych)
library(nFactors)
library(polycor)
this.dir <- dirname(rstudioapi::getActiveDocumentContext()$path)
setwd(this.dir)

####### 9.28 ##########
e8_18 <- read_delim("e8_18.txt", " ", escape_double = FALSE, trim_ws = TRUE)
nation = e8_18[,1]
X = as.matrix(e8_18[,2:8])
R = cor(X)
S = cov(X)
# Number of Factor for covariance
ev <- eigen(S) # get eigenvalues
ap <- parallel(subject=nrow(X),var=ncol(X),
               rep=100,cent=.05)
nS <- nScree(x=ev$values, aparallel=ap$eigen$qevpea)
plotnScree(nS)

# Number of Factor for correlation
ev <- eigen(R) # get eigenvalues
ap <- parallel(subject=nrow(X),var=ncol(X),
               rep=100,cent=.05)
nS <- nScree(x=ev$values, aparallel=ap$eigen$qevpea)
plotnScree(nS)

## Unrotated PC Analysis with S
fit1 <- principal(S, nfactors=2, rotate="none",scores = TRUE,covar = TRUE)
fit1

## Varimax Rotation PC Analysis with S
fit2 <- principal(S, nfactors=2, rotate="varimax",scores = TRUE,covar = TRUE)
fit2

## Unrotated PC Analysis with R
fit3 <- principal(R, nfactors=2, rotate="none",scores = TRUE,covar = TRUE)
fit3
score <- factor.scores(X,fit3)
score$weights
## Varimax Rotation PC Analysis with R
fit4 <- principal(R, nfactors=2, rotate="varimax",scores = TRUE,covar = TRUE)
fit4
score <- factor.scores(X,fit4)
score$weights
## Outlier
score <- factor.scores(X,fit4)
plotscore = as.data.frame(score$scores)
ggplot(data = plotscore, aes(x = RC1, y = RC2)) + geom_point()+ggtitle("Scatterplot of Factor Score of PC")+
  geom_text(aes(label=nation),hjust=0, vjust=0)
## ML Unrotated PC Analysis with R
fit5 <- factanal(X, 2, rotation="none")
fit5
## ML Varimax Rotation PC Analysis with R
fit6 <- factanal(X, 2, rotation="varimax")
fit6
score <- factor.scores(X,fit6)
score$weights
## Outlier
score <- factor.scores(X,fit6)
plotscore = as.data.frame(score$scores)
ggplot(data = plotscore, aes(x = Factor1, y = Factor2)) + geom_point()+ggtitle("Scatterplot of Factor Score of Maximum Likelihood")+
  geom_text(aes(label=nation),hjust=0, vjust=0)

####### 9.34 ##########
T7_7 <- read_delim("T7-7.dat", "\t", escape_double = FALSE, col_names = FALSE, trim_ws = TRUE)
X = T7_7[1:62,1:4]
colnames(X) = c("BL","EM","SF","BS")
X = as.matrix(X)
R = cor(X)
S = cov(X)

# Number of Factor for covariance
ev <- eigen(S) # get eigenvalues
ap <- parallel(subject=nrow(X),var=ncol(X),
               rep=100,cent=.05)
nS <- nScree(x=ev$values, aparallel=ap$eigen$qevpea)
plotnScree(nS)

# Number of Factor for correlation
ev <- eigen(R) # get eigenvalues
ap <- parallel(subject=nrow(X),var=ncol(X),
               rep=100,cent=.05)
nS <- nScree(x=ev$values, aparallel=ap$eigen$qevpea)
plotnScree(nS)
## Unrotated PC Analysis with S
fit1 <- principal(S, nfactors=1, rotate="none",scores = TRUE,covar = TRUE)
fit1

fit2 <- principal(R, nfactors=1, rotate="none",scores = TRUE,covar = TRUE)
fit2

fit3 <- factanal(X, 1, rotation="none")
fit3

fit4 <- principal(R, nfactors=2, rotate="varimax",scores = TRUE,covar = TRUE)
fit4
score <- factor.scores(X,fit4)
score$weights
## Outlier
score <- factor.scores(X,fit4)
plotscore = as.data.frame(score$scores)
ggplot(data = plotscore, aes(x = RC1, y = RC2)) + geom_point()+ggtitle("Scatterplot of Factor Score of PC")+
  geom_text(aes(label=c(1:62)),hjust=0, vjust=0)

####### 9.35 ##########
X = T7_7[1:62,5:8]
colnames(X) = c("AFL","LFF","FFF","ZST")
X = as.matrix(X)
R = cor(X)
S = cov(X)

# Number of Factor for covariance
ev <- eigen(S) # get eigenvalues
ap <- parallel(subject=nrow(X),var=ncol(X),
               rep=100,cent=.05)
nS <- nScree(x=ev$values, aparallel=ap$eigen$qevpea)
plotnScree(nS)

# Number of Factor for correlation
ev <- eigen(R) # get eigenvalues
ap <- parallel(subject=nrow(X),var=ncol(X),
               rep=100,cent=.05)
nS <- nScree(x=ev$values, aparallel=ap$eigen$qevpea)
plotnScree(nS)

## Unrotated PC Analysis with S
fit1 <- principal(S, nfactors=1, rotate="none",scores = TRUE,covar = TRUE)
fit1

fit2 <- principal(R, nfactors=1, rotate="none",scores = TRUE,covar = TRUE)
fit2

fit3 <- factanal(X, 1, rotation="none")
fit3

fit4 <- principal(R, nfactors=2, rotate="varimax",scores = TRUE,covar = TRUE)
fit4
score <- factor.scores(X,fit4)
score$weights
## Outlier
score <- factor.scores(X,fit4)
plotscore = as.data.frame(score$scores)
ggplot(data = plotscore, aes(x = RC1, y = RC2)) + geom_point()+ggtitle("Scatterplot of Factor Score of PC")+
  geom_text(aes(label=c(1:62)),hjust=0, vjust=0)


library(deSolve)
library(rstan)
library(shinystan)
library(ggplot2)
library(RColorBrewer)
library(reshape2)
library(gridExtra)

# NOTE: to save plots, uncomment the ggsave lines

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(B0) + eta*(log(B) - log(B0)) + 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(1001)

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

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

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

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

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

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

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

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"))

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

datlen <- T*7 + 1

data <- matrix(data = -1, nrow = T+1, ncol = steps)
data[,1] <- infec_counts
standata <- as.vector(t(data))[1:datlen]

sir_data <- list( T = datlen,   	# simulation time
                  y = standata, 	# infection count data
                  N = 500,      	# population size
                  h = 1/steps )   	# step size per day

rstan_options(auto_write = TRUE)
options(mc.cores = parallel::detectCores())

stan_options <- list(   chains = 1,    		# number of chains
                        iter   = 5000, 		# iterations per chain
                        warmup = 1000, 		# warmup interations
                        thin   = 10,   		# thinning number
                        verbose = TRUE,
                        refresh = 50)

fit <- with(stan_options,
            stan(file  	= "sirode_euler.stan",
	            data    = sir_data,
	            chains  = chains,
	            iter    = iter,
	            warmup  = warmup,
	            thin    = thin,
	            verbose = verbose,
	            refresh = refresh )
        	)

# traceplots
if (stan_options$chains > 1) {

	exfit <- extract(fit, permuted = FALSE, inc_warmup = FALSE)
	plotdata <- melt(exfit[,,'R0'])
	tracefitR0 <- ggplot() +
	              geom_line(data = plotdata,
	                        aes(x = iterations,
	                        y = value,
	                        color = factor(chains, labels = 1:stan_options$chains))) +
	              labs(x = "Sample", y = expression(R[0]), color = "Chain") +
	              scale_color_brewer(palette="Paired") +
	              theme(panel.background = element_rect(fill = "#F0F0F0"))

	quartz()
	print(tracefitR0)
	#ggsave(tracefitR0, filename="traceplotR0.pdf", height=4, width=6.5)

	exfit <- extract(fit, permuted = FALSE, inc_warmup = TRUE)
	plotdata <- melt(exfit[,,2])
	tracefitR0 <- ggplot() +
	              geom_line(data = plotdata,
	                        aes(x = iterations,
	                        y = value,
	                        color = factor(chains, labels = 1:stan_options$chains))) +
	              labs(x = "Sample", y = expression(R[0]), color = "Chain") +
	              scale_color_brewer(palette="Paired") +
	              theme(panel.background = element_rect(fill = "#F0F0F0"))

	quartz()
	print(tracefitR0)
	#ggsave(tracefitR0, filename="traceplotR0_inc.pdf", height=4, width=6.5)

}

exfit <- extract(fit, permuted = FALSE, inc_warmup = FALSE)
paramdata <- data.frame(R0 = melt(exfit[,,'R0'])$value,
               			r = melt(exfit[,,'r'])$value,
               			sigma = melt(exfit[,,'sigma'])$value,
               			eta = melt(exfit[,,'eta'])$value,
               			berr = melt(exfit[,,'berr'])$value,
               			Sinit = melt(exfit[,,4])$value,
               			Iinit = melt(exfit[,,5])$value,
               			Rinit = melt(exfit[,,6])$value )

# sample from parameter distributions
sdeout_true <- sdeout

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 	<- apply(bootstrapdata, 2, quantile, probs = c(0.025,0.975))

plotdata <- data.frame(times=0:T,true=sdeout_true[,'I'],est=meanTraj,quants=t(quantTraj),datapart=datapart)

g <- ggplot(plotdata, aes(times)) +
		geom_ribbon(aes(ymin = quants.2.5., ymax=quants.97.5.), alpha=0.1) +
        geom_line(aes(y = true, colour = "True")) +
        geom_line(aes(y = est, colour = "IF2")) +
        geom_point(aes(y = datapart, color = "Data")) +
        labs(x = "Time", y = "Infection count", color = "") +
        scale_color_brewer(palette="Paired") +
        theme(panel.background = element_rect(fill = "#F0F0F0"))

quartz()
print(g)

# kernel plots

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

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

kerdataR0 <- data.frame(R0points = paramdata$R0)
R0kernel <- ggplot(kerdataR0, aes(x = R0points, y = ..scaled..)) +
                geom_density(color = kcolours[1], fill = kcolours[1]) +
                theme(panel.background = element_rect(fill = "#F0F0F0")) +
                scale_color_brewer(palette="Paired") +
                labs(x = expression(R[0]), y = "Density", color = "") +
                geom_vline(aes(xintercept=trueval.R0), linetype="solid", size=lineweight, color=linecolour) +
                geom_vline(aes(xintercept=meanval.R0), linetype="dashed", size=lineweight, color=linecolour)

kerdatar <- data.frame(rpoints = paramdata$r)
rkernel <- ggplot(kerdatar, aes(x = rpoints, y = ..scaled..)) +
                geom_density(color = kcolours[2], fill = kcolours[2]) +
                theme(panel.background = element_rect(fill = "#F0F0F0")) +
                scale_color_brewer(palette="Paired") +
                labs(x = "r", y = "", color = "") +
                geom_vline(aes(xintercept=trueval.r), linetype="solid", size=lineweight, color=linecolour) +
                geom_vline(aes(xintercept=meanval.r), linetype="dashed", size=lineweight, color=linecolour)

kerdatasigma <- data.frame(sigmapoints = paramdata$sigma)
sigmakernel <- ggplot(kerdatasigma, aes(x = sigmapoints, y = ..scaled..)) +
                geom_density(color = kcolours[3], fill = kcolours[3]) +
                theme(panel.background = element_rect(fill = "#F0F0F0")) +
                scale_color_brewer(palette="Paired") +
                labs(x = expression(sigma), y = "Density", color = "") +
                geom_vline(aes(xintercept=trueval.sigma), linetype="solid", size=lineweight, color=linecolour) +
                geom_vline(aes(xintercept=meanval.sigma), linetype="dashed", size=lineweight, color=linecolour)

kerdatainfec <- data.frame(infecpoints = paramdata$Iinit)
infeckernel <- ggplot(kerdatainfec, aes(x = infecpoints, y = ..scaled..)) +
                geom_density(color = kcolours[4], fill = kcolours[4]) +
                theme(panel.background = element_rect(fill = "#F0F0F0")) +
                scale_color_brewer(palette="Paired") +
                labs(x = "Initial infected", y = "", color = "") +
                geom_vline(aes(xintercept=trueval.Iinit), linetype="solid", size=lineweight, color=linecolour) +
                geom_vline(aes(xintercept=meanval.Iinit), linetype="dashed", size=lineweight, color=linecolour)

kerdataeta <- data.frame(etapoints = paramdata$eta)
etakernel <- ggplot(kerdataeta, aes(x = etapoints, y = ..scaled..)) +
                geom_density(color = kcolours[5], fill = kcolours[5]) +
                theme(panel.background = element_rect(fill = "#F0F0F0")) +
                scale_color_brewer(palette="Paired") +
                labs(x = expression(eta), y = "", color = "") +
                geom_vline(aes(xintercept=trueval.eta), linetype="solid", size=lineweight, color=linecolour) +
                geom_vline(aes(xintercept=meanval.eta), linetype="dashed", size=lineweight, color=linecolour)

kerdataberr <- data.frame(berrpoints = paramdata$berr)
berrkernel <- ggplot(kerdataberr, aes(x = berrpoints, y = ..scaled..)) +
                geom_density(color = kcolours[6], fill = kcolours[6]) +
                theme(panel.background = element_rect(fill = "#F0F0F0")) +
                scale_color_brewer(palette="Paired") +
                labs(x = expression(beta[err]), y = "", color = "") +
                geom_vline(aes(xintercept=trueval.berr), linetype="solid", size=lineweight, color=linecolour) +
                geom_vline(aes(xintercept=meanval.berr), linetype="dashed", size=lineweight, color=linecolour)

# show grid
quartz()
grid.arrange(R0kernel, rkernel, sigmakernel, infeckernel, etakernel, berrkernel, ncol = 3, nrow = 2)

# Shiny Stan!!!

sso <- as.shinystan(fit)
sso <- launch_shinystan(sso)


# Refer my jupyter notebook for more details:
# http://nbviewer.jupyter.org/github/ajhalthor/statistical-learning-with-R/blob/master/Chapter%202/notebooks/question%209.ipynb
Auto = read.csv("Datasets/Auto.csv", header=TRUE, na.strings="?")
head(Auto)

print(paste("Total Number of Sample cars = ", dim(Auto)[1]))
Auto=na.omit(Auto)
print(paste("Number of sample cars after deleting incomplete sample data = ", dim(Auto)[1]))

n_occur = data.frame(table(Auto$name)) # This is a Frequency Distribution Table
n_occur[n_occur$Freq > 1,] #Get only duplicate entries

car_names = Auto[,ncol(Auto)] #Store Car Names for later use
Auto = Auto[,-ncol(Auto)] #Remove the names column
head(Auto)

variable = c("mpg", "displacement", "horsepower", "weight", "acceleration", "year")
minimum = c(min(Auto$mpg), min(Auto$displacement), min(Auto$horsepower), min(Auto$weight), min(Auto$acceleration), min(Auto$year))
maximum = c(max(Auto$mpg), max(Auto$displacement), max(Auto$horsepower), max(Auto$weight), max(Auto$acceleration), max(Auto$year))
tab = data.frame(variable, minimum, maximum)
tab

range(Auto$mpg)
range(Auto$displacement)
range(Auto$horsepower)
range(Auto$weight)
range(Auto$acceleration)
range(Auto$year)

summary(Auto)

mean = c(mean(Auto$mpg), mean(Auto$displacement), mean(Auto$horsepower), mean(Auto$weight), mean(Auto$acceleration), mean(Auto$year))
sd = c(sd(Auto$mpg), sd(Auto$displacement), sd(Auto$horsepower), sd(Auto$weight), sd(Auto$acceleration), sd(Auto$year))
tab = data.frame(variable, mean, sd)
tab

sub_Auto = Auto[-c(10:85),] #Remove 10th to 85th row, keep all columns

minimum = c(min(sub_Auto$mpg), min(sub_Auto$displacement), min(sub_Auto$horsepower), min(sub_Auto$weight), min(sub_Auto$acceleration), min(sub_Auto$year))
maximum = c(max(sub_Auto$mpg), max(sub_Auto$displacement), max(sub_Auto$horsepower), max(sub_Auto$weight), max(sub_Auto$acceleration), max(sub_Auto$year))
mean = c(mean(sub_Auto$mpg), mean(sub_Auto$displacement), mean(sub_Auto$horsepower), mean(sub_Auto$weight), mean(sub_Auto$acceleration), mean(sub_Auto$year))
sd = c(sd(sub_Auto$mpg), sd(sub_Auto$displacement), sd(sub_Auto$horsepower), sd(sub_Auto$weight), sd(sub_Auto$acceleration), sd(sub_Auto$year))
tab = data.frame(variable, minimum, maximum, mean, sd)
tab

pairs(c(Auto['mpg'], Auto['displacement'], Auto['horsepower'], Auto['weight'], Auto['acceleration'], Auto['year']))


## L(D|theta)^a_0 pi(theta)

alpha <- 10
beta <- 10
yy <- 20
NN <- 50
a_0 <- 0
###########################

power_post <- function(p, y, N, a0){
  lp <- a0 * ( y* log(p) + (N-y) * log(1-p) ) + dbeta(x = p, shape1 = alpha, shape2 = beta, log = TRUE)
  return(exp(lp))
}
power_post <- Vectorize(power_post)

curve(power_post(p = x, y = yy, N = NN, a0 = a_0))

log_sq_lik <- function(p, y, N){
  ( y* log(p) + (N-y) * log(1-p) )^2
}
curve(log_sq_lik(p = x, y = yy, N = NN))

expect <- function(p, y, N, a0){
  ans <- power_post(p = p, y = y, N = N, a0 = a0) * log_sq_lik(p = p, y = y, N = N)
  return(ans)
}
expect <- Vectorize(expect)
curve(expect(p = x, y = yy, N = NN, a0 = a_0))
integrate(function(x) expect(p = x, y = yy, N = NN, a0 = a_0), 0, 1)

## 1/X^2
one_over_x_sq <- function(p, y, N){
  exp(
    - 2*(y* log(p) + (N-y) * log(1-p))
  )
}
## test that code for 1/L(D|theta)^2 is correct
# pp <- .2
# L <- pp^yy * (1-pp)^{NN-yy}
# 1/L^2
# one_over_x_sq(p = pp, y = yy, N = NN)

expect2 <- function(p, y, N, a0){
  ans <- power_post(p = p, y = y, N = N, a0 = a0) * one_over_x_sq(p = p, y = y, N = N)
  return(ans)
}
expect2 <- Vectorize(expect2)

curve(expect2(p = x, y = yy, N = NN, a0 = a_0))

integrate(function(x) expect2(p = x, y = yy, N = NN, a0 = a_0), 0, 1)

## -log(X)/X

minus_logX_over_X <- function(p, y, N){
  logX <- y* log(p) + (N-y) * log(1-p)
  return(
    -logX/exp(logX)
  )
}

expect3 <- function(p, y, N, a0){
  ans <- power_post(p = p, y = y, N = N, a0 = a0) * minus_logX_over_X(p = p, y = y, N = N)
  return(ans)
}
expect3 <- Vectorize(expect3)

curve(expect3(p = x, y = yy, N = NN, a0 = a_0))

integrate(function(x) expect3(p = x, y = yy, N = NN, a0 = a_0), 0, 1)


#02. 포아송분포(Poisson distribution) : 램덤하게 선택한 일정단위시간(시, 분, 초)나 공간 등 내에 발생하는 사건의 개수를 설명
  # 보통 단위시간 당 도착에 대한 모델이 많이 사용되므로 시간이 주로 사용 / 하루 사고 건수, 10분간 민원 전화 건수 등
  # <=> 지수분포 : 도착에 따른 시간 측정에 활용 : 건과 건 사이의 시간

# 확률밀도함수: d~
# 누적분포함수(점수): p~
# 누적분포함수(확률): q~

# 포아송분포 확률밀도함수
# dpois(발생건수, lambda(단위시간당 평균발생 건수)
# 서비스센터 사례
# 서비스 센터에서 단위 시간 당(시간은 임의로 정하는 것) 평균발생건수: 1.5회
# P(X = a) 확률 계산
dpois(x=0, lambda = 1.5)
dpois(x=1, lambda = 1.5)
dpois(x=2, lambda = 1.5)
dpois(x=3, lambda = 1.5)
dpois(x=4, lambda = 1.5)
dpois(x=5, lambda = 1.5)

# 포아송분포 확률밀도함수 graph
plot(dpois(x=c(0:10), lambda = 1.5), # 평균을 기준으로 가장 높고 평균을 넘어가면 확률이 낮아지는 개념
     type='h',
     lwd=10,
     col="red",
     xlab="성공확률 X",
     main = "포아송분포")

# 포아송분포 누적확률계산 - 사건을 알때 확률 계산
# 이하 : P(X <= a) lower.tail = TRUE
# 초과: P(X > a) lower.tail = FALSE
# 2회이상(x>=2) 받을 확률: P(X > 1) 확률 계산 -> R에서는 이상이 없으니까 초과 개념으로 해서 2회 이상이면 1을 입력한다.
ppois(q=1, lambda = 1.5, lower.tail = FALSE)

# 포아송분포 누적확률 graph
plot(ppois(0:10, lambda = 1.5),
     type='h',
     lwd=10,
     col="red",
     main = "누적포아송분포")

## 퀴즈 K 서비스 센터 10분에 평균 2회 전화, 10분 동안 2회 이하로 전화 받을 확률?

# P(X <= 2)이하로 받을 확률
ppois(q=2, lambda = 2, lower.tail = TRUE)


#Mann-Whitney-Wilcoxon
#Si dos muestras son independientes, entonces
#provenen de poblaciones distintas y no se afectan entre si

#Usando Mann-White-Wilcoxon, podemos decidir si las
#distribuciones poblacionales son identicas sin asumir una distribucion
#normal

#Without assuming the data to have normal distribution, decide at .05 significance level if the gas mileage data of manual and automatic transmissions in mtcars have identical data distribution.

wilcox.test(mpg ~ am,data=mtcars)

'''
	Wilcoxon rank sum test with continuity
	correction

data:  mpg by am
W = 42, p-value = 0.001871
alternative hypothesis: true location shift is not equal to 0
'''

Parcial/5. Metodos no parametricos/MannWhitneyWilcoxon.r


#  Mergesort implementation in R
#  Author: Carlos Abraham Hernandez
#  github.com/abranhe

merge <- function(x, start, middle, end){

  x.left <- c(x[start:middle], Inf)
  x.right <- c(x[(middle+1):end], Inf)

  index.left <- 1
  index.right <- 1

  for(index.x in start:end){
    if(x.left[index.left] <= x.right[index.right]){
      x[index.x] <- x.left[index.left]
      index.left <- index.left + 1
    }
    else{
      x[index.x] <- x.right[index.right]
      index.right <- index.right + 1
    }
  }

  return(x)
}

mergeSort <- function(x, start, end){

  if(start < end){
    middle <- floor((start + end)/2)
    x <- mergeSort(x, start, middle)
    x <- mergeSort(x, middle+1, end)
    x <- merge(x, start, middle, end)
  }

  return(x)
}

x <- c(7,19,3,15,22,4,9,100)

print(x)
print(mergeSort(x, 1, length(x)))


library(quaternions)

q <- Q(1, 2, 3, 4)
q1 <- Q(2, 3, 4, 5)
q2 <- Q(3, 4, 5, 6)
r <- 7.0

display <- function(x){
  e <- deparse(substitute(x))
  res <- if(class(x) == "Q") paste(x$r, "+", x$i, "i+", x$j, "j+", x$k, "k", sep = "") else x
  cat(noquote(paste(c(e, " = ", res, "\n"), collapse="")))
  invisible(res)
}

display(norm(q))
display(-q)
display(Conj(q))
display(r + q)
display(q1 + q2)
display(r*q)
display(q*r)
if(display(q1*q2) == display(q2*q1)) cat("q1*q2 == q2*q1\n") else cat("q1*q2 != q2*q1\n")

## norm(q) = 5.47722557505166
## -q = -1+-2i+-3j+-4k
## Conj(q) = 1+-2i+-3j+-4k
## r + q = 8+2i+3j+4k
## q1 + q2 = 5+7i+9j+11k
## r * q = 7+14i+21j+28k
## q * r = 7+14i+21j+28k
## q1 * q2 = -56+16i+24j+26k
## q2 * q1 = -56+18i+20j+28k
## q1*q2 != q2*q1


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

## No prepayments
principal <- 300000  # mortgage principal
n.peryr <- 12  # monthly = 12 payments per year
T <- 30   # 30-year mortgage
r <- 0.0625  # 6.25%
t <- 1:(n.peryr*T)
pmt.level <- principal*r/(n.peryr*(1-1/(1+r/n.peryr)^(n.peryr*T)))
pmt.principal <- pmt.level/(1+r/n.peryr)^(n.peryr*T-t+1)
pmt.interest <- pmt.level-pmt.principal

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

## With prepayments
principal.start <- 300e3  # mortgage principal
n.peryr <- 12  # monthly = 12 payments per year
T <- 30   # 30-year mortgage
r <- 0.0625  # 6.25%
t <- 1:(n.peryr*T)
## calculate level monthly payment
pmt.level <- principal.start*r/(n.peryr*(1-1/(1+r/n.peryr)^(n.peryr*T)))

## Prepay an extra 5\% each payment
pmt.prepay.plan <- 0.05*pmt.level

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

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


# two tailed test
ybar = 178.2            # sample mean
mu0 = 190             # hypothesized value
sigma = 45.3          # population standard deviation
n = 100                 # sample size
# We  compute the critical value at .025 significance level.
alpha = .05
z.half.alpha = qnorm(1-alpha/2)
# critical values
lr=mu0-(z.half.alpha*sigma)/sqrt(n)
ur=mu0+(z.half.alpha*sigma)/sqrt(n)
paste0(" lower rejection = ",lr)
paste0("upper rejection = ",ur)
z = (ybar- mu0)/(sigma/sqrt(n))
print(z) # test statistic

 print("The test statistic doesnot lies between the critical values(i.e. |z|>critical value). Hence, at .025 significance level, we  reject the null hypothesis")


# 기본함수
n <- 6
r <- 3
factorial(n)
factorial(n)/factorial(n-r)
choose(n,r)

# 패키지 이용
install.packages("gtools")
library(gtools)

nrow(permutations(6,3))
nrow(combinations(6,3))

# 야구경기 (9명-9개)
factorial(9)

# 집배원(4군데)
factorial(4)

# 12명중 8개
nrow(permutations(12,8))

n <- 12
r <- 8
factorial(n)/factorial(n-r)

# 20명중 2명씩 짝
choose(20,2)

# 45개 숫자중 6개 고름
choose(45,6)

# 1등 당첨확률
# 지수표기법 환원 1.2e+10->0.00000000012
options("scipen" = 20) # 통계치 유의확률 0.05
lot <- choose(45,6)
1/lot

# 5등 당첨확률(3개만)
options("scipen" = 20)
lot5 <- (choose(6,3)*choose(39,3))
lot5/lot


x <- c(12,7,3,4.2,18,2,54,-21,8,-5)
result.mean <- mean(x)
print(result.mean)
result.mean <-  mean(x,trim = 0.3)
print(result.mean)
x = 1:15
print("New vector using : operator-")
print(x)
print("New vector using seq() function-")
y = seq(1, 3, by=0.3)
print(y)
a <- array(seq(from = 50, length.out = 15, by = 2), c(5, 3))
print(a)
m1 = matrix(c(1, 2, 3, 4, 5, 6), nrow = 2)
print(m1)
m2 = matrix(c(0, 1, 2, 3, 0, 2), nrow = 2)
print(m2)
result = m1 + m2
print(result)
result = m1-m2
print(result)
result = m1 * m2
print(result)
result = m1 / m2
print(result)
M = matrix(c(1:16), nrow = 4, byrow = TRUE, dimnames = list(row_names, col_names))
result1 = result[result[,3] > 7,]
print(result1)
result=m1+m2
result1 = result[result[,3] > 7,]
print(result1)
row_names = c("row1", "row2", "row3", "row4")
col_names = c("col1", "col2", "col3", "col4")
M = matrix(c(1:16), nrow = 4, byrow = TRUE, dimnames = list(row_names, col_names))
print(M)
result = M[M[,3] > 7,]
print(result)


# Load the data
heart_disease <- read.csv("datasets/heart_disease_patients.csv")

# Print the first ten rows
head(heart_disease, 10)

# Evidence that the data should be scaled?
summary(heart_disease)

# Remove id
heart_disease <- heart_disease[ , !(colnames(heart_disease) %in% c("id"))]

# Scaling data and saving as a data frame
scaled <- scale(heart_disease)

# What do the data look like now?
summary(scaled)

# Set the seed so that results are reproducible
seed_val  <- 10
set.seed(seed_val)

# Select a number of clusters
k <- 5

# Run the k-means algorithm
first_clust = kmeans(scaled, centers = k, nstart = 1)

first_clust

# How many patients are in each cluster?
first_clust$size

# Set the seed
seed_val <- 38
set.seed(seed_val)

# Select a number of clusters and run the k-means algorithm
k2 <- 5
second_clust = kmeans(scaled, centers = k2, nstart = 1)

# How many patients are in each cluster?
second_clust$size

# Add cluster assignments to the data
heart_disease["first_clust"] <- first_clust$cluster
heart_disease["second_clust"] <- second_clust$cluster

# Load ggplot2
library(ggplot2)

# Create and print the plot of age and chol for the first clustering algorithm
plot_one  <- ggplot(heart_disease, aes(x = age, y = chol, color = as.factor(first_clust))) +
   geom_point()
plot_one

# Create and print the plot of age and chol for the second clustering algorithm
plot_two <- ggplot(heart_disease, aes(x = age, y = chol, color = as.factor(second_clust))) +
   geom_point()
plot_two

# Execute hierarchical clustering with complete linkage
hier_clust_1 <- hclust(dist(scaled), method = "complete")

# Print the dendrogram
plot(hier_clust_1)

# Get cluster assignments based on number of selected clusters
hc_1_assign <- cutree(hier_clust_1, k = 5)

hc_1_assign

# Execute hierarchical clustering with single linkage
hier_clust_2 <- hclust(dist(scaled), method = "single")

# Print the dendrogram
plot(hier_clust_2)

# Get cluster assignments based on number of selected clusters
hc_2_assign <- cutree(hier_clust_2, k = 5)

hc_2_assign

# Add assignment of chosen hierarchical linkage
heart_disease["hc_clust"] <- hc_1_assign

# Remove the sex, first_clust, and second_clust variables
hd_simple <- heart_disease[, !colnames(heart_disease) %in% c("sex", "first_clust", "second_clust")]

# Get the mean and standard deviation summary statistics
clust_summary <- do.call(data.frame, aggregate(. ~ hc_clust, data = hd_simple, function(x) c(avg = mean(x), sd = sd(x))))
clust_summary

# Plot age and chol
plot_one <- ggplot(hd_simple, aes(x = age, y = chol, color = as.factor(hc_clust))) +
  geom_point()
plot_one

# Plot oldpeak and trestbps
plot_two <- ggplot(hd_simple, aes(x = oldpeak, y = trestbps, color = as.factor(hc_clust))) +
  geom_point()
plot_two

# Add TRUE if the algorithm shows promise, add FALSE if it does not
explore_kmeans <- FALSE
explore_hierarch_complete <- TRUE
explore_hierarch_single <- FALSE

05. Clustering Heart Disease Patient Data.r


paint_data=c(28, 35, 27, 21,21, 36, 25 ,18,26, 38, 27, 17,16, 25, 22, 18)
ybar=sum(paint_data)/length(paint_data)
print(ybar)
# total sum of squares
TSS=0
i=1
while(i<=length(paint_data)){
  TSS=TSS+(paint_data[i]-ybar)^2
  i=i+1
}
print(TSS)
# between treatment sum of squares

yi=c(mean(paint_data[1:4]),mean(paint_data[5:8]),mean(paint_data[9:12]),mean(paint_data[13:16]))

SST=0
j=1
while(j<=length(paint_data)/4){
  SST=SST+4*((yi[j]-ybar)^2)
  j=j+1
}
print(SST)
#  sum of squares for error
SSE=TSS-SST
print(SSE)


#Q4. The following iterative sequence is defined for the set of positive integers:
#n → n/2 (n is even)
#n → 3n + 1 (n is odd)

#Using the rule above and starting with 13, we generate the following sequence:
#13 → 40 → 20 → 10 → 5 → 16 → 8 → 4 → 2 → 1
#It can be seen that this sequence (starting at 13 and finishing at 1) contains 10 terms. Although it has not been proved yet (Collatz Problem), it is thought that all starting numbers finish at 1.
#Which starting number, under one thousand, produces the longest chain?

collatz.length <- vector(length = 1E6)
collatz.length[1] <- 0
for (n in 2:1E6) {
    x <- n
    count <- 0
    while (x != 1 & x >= n) {
        if (x %% 2 == 0) {
            x <- x / 2
            count <- count + 1
        }
        else {
            x <- (3 * x + 1) / 2
            count <- count + 2
        }
    }
    count <- count + collatz.length[x]
    collatz.length[n] <- count
}
answer <- which.max(collatz.length)
print(answer)


library(tidyverse)

##########################
######### T-test #########
##########################

# Two-tailed t-test (unpaired)
# assumptions: independent, normally distributed, homogeneous variance

treatment1 <- PlantGrowth[PlantGrowth$group == 'trt1',]$weight
treatment2 <- PlantGrowth[PlantGrowth$group == 'trt2',]$weight

shapiro.test(treatment1)
shapiro.test(treatment2)

# check if variances are equal
var.test(treatment1, treatment2)

t.test(
  treatment1,
  treatment2,
  alternative = "two.sided",
  var.equal = FALSE
)

# Two-tailed t-test (paired)

age5 <- Loblolly[Loblolly$age == 5,]$height
age20 <- Loblolly[Loblolly$age == 20,]$height
age25 <- Loblolly[Loblolly$age == 25,]$height

shapiro.test(age20)
shapiro.test(age25)

# near equal variance
var.test(age20, age25)

t.test(
  age20,
  age25,
  alternative = "two.sided",
  paired = TRUE
)

# change alternative to "less" or "greater" for one-tailed test

##########################
######### F-test #########
##########################

var.test(
  age20,
  age25,
  ratio = 1,
  conf.level = 0.95,
  alternative = "two.sided"
)

#########################
######### ANOVA #########
#########################
mtcars

lm1 <- lm(mpg ~ hp , mtcars)
lm2 <- lm(mpg ~ hp + gear, mtcars)

summary(lm1)
summary(lm2)

anova(lm1, lm2)


n <- 10
p0 <- 1/2
alpha0 <- 0.2

# c(p0)
# delta_c é um teste de tamanho alpha0=0.05

tamanho_c <- function(c){
  ## Pr(Y >= c | p = p0)
  res <-  1- sum(dbinom(0:(c-1), n, p0))
  return(res)
}
tamanho_c <- Vectorize(tamanho_c)

# Agora vamos plotar para tentar achar c* tal que Pr(Y >= c | p = p0) <= alpha0

curve(tamanho_c, 1, n, lwd = 2, xlab = expression(c))
abline(h = alpha0, lty = 2)

## Agora vamos expressar o poder como função da probabilidade postulada p0

Y <- 5

poder_p <- function(p){
  res <- 1- sum(dbinom(0:(Y-1), n, p))
  return(res)
}
poder_p <- Vectorize(poder_p)

curve(poder_p, xlab = expression(p[0]))
abline(h = alpha0, lty = 2)

# LRT: razão de verossimilhanças

Lambda <- function(y, log = FALSE){
  l1 <- y * (log(n*p0)-log(y))
  if(y==0) l1 <- 0
  l2 <- (n-y)*(log(n*(1-p0))-log(n-y))
  if(y==n) l2 <- 0
  ans <- l1 + l2
  if(!log) ans <- exp(ans)
  return(ans)
}
Lambda <- Vectorize(Lambda)

tabProb <- data.frame(y = 0:n, Lambda = Lambda(0:n), Pr = dbinom(x = 0:n, size = n, prob = p0))
round(tabProb, 3)
plot(0:n, Lambda(0:n), xlab = expression(y), ylab = expression(Lambda(y)))

findSet <- function(tab, level = alpha0){
  K <- nrow(tab)
  set <- NA
  accpr <- 0
  for(i in 1:K){
    accpr.tent <- accpr + tab$Pr[i]
    if(accpr.tent < level){
      accpr <- accpr.tent
      set <- c(set, tab$y[i])
    }else{
      next
    }
  }
  set <- na.omit(set)
  return(
    list(
      confidence_set = as.vector(set),
      test_size = accpr
    )
  )
}
findSet(tab = tabProb)


dist <- "beta"

## Beta
alpha <- 3
beta <- 2

## Log-normal
mu <- 0
sigma <- 2

if(dist == "ln"){
  EX <- exp(mu + sigma^2/2)
}else{
  EX <- alpha / (alpha + beta)
}

computa_media <- function(n){
  if(dist == "ln"){
    mean(rlnorm(n = n, meanlog = mu, sdlog = sigma))
  }else{
    mean(rbeta(n = n, shape1 = alpha, shape2 = beta))
  }
}
ns <- seq(2, 1E5, by = 500)
medias <- sapply(ns, computa_media)

library(ggplot2)

forplot <- data.frame(n = ns, x_bar = medias)

ggplot(forplot, aes(x = n, y = x_bar))+
  geom_line() +
  scale_x_continuous("Tamanho de amostra", expand = c(0, 0)) +
  scale_y_continuous(expression(bar(X[n])), expand = c(0, 0)) +
  geom_hline(yintercept = EX, linetype = "longdash", size = 2) +
  theme_bw(base_size = 16)


#Copyright (c) 2016 Riccardo Francescato
a <- c(16.85,16.40,17.21,16.35,16.52,17.04,16.96,17.15,16.59,16.57)
b <- c(16.62,16.75,17.37,17.12,16.98,16.87,17.34,17.02,17.08,17.27)
#confidency level
alpha = .05
#type of test: 0 left tail 1 double tail 2 right tail
type = 1
#calculations....
n0 = length(a)		# number of reps for sample 0
n1 = length(b)		# number of reps for sample 1
xbar0 = mean(a)		# sample 0 mean
xbar1 = mean(b)		# sample 1 mean
s0 = sd(a)			# sample 0 standard deviation
s1 = sd(b)			# sample 1 standard deviation
sp2 = ((n0-1)*s0^2 + (n1-1)*s1^2)/(n0+n1-2)
t = (xbar0−xbar1)/(sqrt(sp2)*sqrt((1/n0) + (1/n1)))
if(type == 0){
	t.alpha = qt(1−alpha, df=n0−1)
	pval = pt(t, df=n0−1)
	cat("Results of lower tail\n")
	cat("First sample\n")
	cat(paste("# of elements: ", n0, " Mean: ", xbar0, " St Dev: ",s0))
	cat("\nSecond sample\n")
	cat(paste("# of elements: ", n1, " Mean: ", xbar1, " St Dev: ",s1))
	cat(paste("\nEstimate of common variance Sp: ",sqrt(sp2)))
	cat(paste("\nt0: ",t))
	cat(paste("\ntalpha: ",−t.alpha))
	cat(paste("\np-value: ",pval))
	if(t<−t.alpha) cat("\nREJECT H0\n") else cat("\nACCEPT H0\n")
}else if(type == 1){
	t.half.alpha = qt(1−alpha/2, df=n0−1)
	pval = 2 * pt(t, df=n0−1)
	cat("Results of 2-tail tail\n")
	cat("First sample\n")
	cat(paste("# of elements: ", n0, " Mean: ", xbar0, " St Dev: ",s0))
	cat("\nSecond sample\n")
	cat(paste("# of elements: ", n1, " Mean: ", xbar1, " St Dev: ",s1))
	cat(paste("\nEstimate of common variance Sp: ",sqrt(sp2)))
	cat(paste("\nt0: ",t))
	cat(paste("\ntalpha +: ",t.half.alpha))
	cat(paste("\ntalpha -: ",-t.half.alpha))
	cat(paste("\np-value: ",pval))
	if(t<-t.half.alpha || t>t.half.alpha) cat("\nREJECT H0\n") else cat("\nACCEPT H0\n")

}else if(type == 2){
	t.alpha = qt(1−alpha, df=n0−1)
	pval = pt(t, df=n0−1, lower.tail=FALSE)
	cat("Results of upper tail\n")
	cat("First sample\n")
	cat(paste("# of elements: ", n0, " Mean: ", xbar0, " St Dev: ",s0))
	cat("\nSecond sample\n")
	cat(paste("# of elements: ", n1, " Mean: ", xbar1, " St Dev: ",s1))
	cat(paste("\nEstimate of common variance Sp: ",sqrt(sp2)))
	cat(paste("\nt0: ",t))
	cat(paste("\ntalpha: ",t.alpha))
	cat(paste("\np-value: ",pval))
	if(t>t.alpha) cat("\nREJECT H0\n") else cat("\nACCEPT H0\n")
}


readings=c(203.1, 184.5, 206.8 ,211.0 ,218.3, 174.2, 193.2 ,201.9 ,199.9 ,194.3,
           199.4, 193.6, 194.6 ,187.2 ,197.8 ,184.3, 196.1, 196.4 ,197.5 ,187.9)
n=length(readings)
ybar=mean(readings)
s=sd(readings)
muo=5
# test static
X=(n-1)*(s^2)/(muo^2)
print(X)
#critical value
alpha=0.05
X.alpha=qchisq(1-0.05,df=19)

# the null hypothesis, H0 is rejected if the value of the X is greater than X.alpha
#Since the computed value of the X., 74.61, is greater than the
# critical value 30.14, there is sufficient evidence to reject H0
# The upper-tail chi-square value
XU=qchisq(.975, df=19)
# The lower-tail chi-square value
XL=qchisq(1-.975, df=19)
# The 95% confidence interval for standard deviation
right_i=sqrt((n-1)*(s^2)/(XL))
left_i=sqrt((n-1)*(s^2)/(XU))
print(left_i)
print(right_i)


library(ISLR)
set.seed(1)
train=sample (392,196)

lm.fit=lm(mpg~horsepower ,data=Auto,subset=train)

mean((Auto$mpg - predict(lm.fit, Auto))[-train]^2)

library(boot)
glm.fit=glm(mpg∼horsepower ,data=Auto)
cv.err=cv.glm(Auto ,glm.fit)
cv.err$delta

#LOOCV test
cv.error=rep(0,5)
for (i in 1:5){
  glm.fit=glm(mpg∼poly(horsepower ,i),data=Auto)
  cv.error[i]=cv.glm(Auto,glm.fit)$delta[1]
}
cv.error

#10-fold CV test
set.seed(17)
cv.error.10=rep(0,10)
for (i in 1:10){
  glm.fit=glm(mpg ~ poly(horsepower ,i),data=Auto)
  cv.error.10[i]=cv.glm(Auto,glm.fit,K=10)$delta[1]
}
cv.error.10

#bootstrap
alpha.fn=function (data,index){
  X=data$X[index]
  Y=data$Y[index]
  return((var(Y)-cov(X,Y))/(var(X)+var(Y)-2*cov(X,Y)))
}

alpha.fn(Portfolio ,1:100)
set.seed(1)
alpha.fn(Portfolio ,sample (100,100, replace=T))

boot(Portfolio, alpha.fn, R=1000)

#bootstrap for linear regression coefficients
boot.fn=function (data ,index) return(coef(lm(mpg ~ horsepower ,data=data,subset=index)))
boot.fn(Auto ,1:392)

set.seed(1)
boot.fn(Auto ,sample (392,392, replace=T))
boot(Auto ,boot.fn, 1000)

boot.fn=function (data ,index) coefficients(lm(mpg~horsepower +I(horsepower ^2),data=data ,                   subset=index))
set.seed(1)
boot(Auto ,boot.fn,1000)


#' rsvd
#'
#' Randomized singular value decomposition.
#'
#' @details
#' A randomized SVD is an approximate method for computing using random
#' projections to estimate singular values/vectors. It is usually faster than
#' a full SVD (say via \code{svd()}) when only the first few singular
#' values/vectors are needed.
#'
#' @section Communication:
#' The operation is completely local except for forming the crossproduct, which
#' is an \code{allreduce()} call, quadratic on the number of columns.
#'
#' @param x
#' The input data matrix.
#' @param k
#' The number of singular values and/or left/right singular vectors
#' to estimate.
#' @param q
#' An integer exponent, say 1, 2, or 3.  See the paper for details.
#' @param retu
#' Logical; should the left singular vectors ("U") be returned?
#' @param retv
#' Logical; should the right singular vectors ("V") be returned?
#'
#' @return
#' A list of elements \code{d}, \code{u}, and \code{v}, as with R's own
#' \code{svd()}.  The elements are, respectively, a regular vector, a shaq, and
#' a regular matrix.
#'
#' @examples
#' \dontrun{
#' library(kazaam)
#' x = ranshaq(runif, 10, 3)
#'
#' svd = rsvd(x)
#' comm.print(svd$d) # a globally owned vector
#' svd$u # a shaq
#' comm.print(svd$v) # a globally owned matrix
#'
#' finalize()
#' }
#'
#' @references
#' Halko, Martinsson, and Tropp. 2011. Finding structure with randomness:
#' probabilistic algorithms for constructing approximate matrix decompositions.
#' SIAM Review 53 217-288.
#'
#' @export
rsvd <- function(x, k=1, q=2, retu=TRUE, retv=TRUE)
{
  if (!is.shaq(x))
    comm.stop("input 'x' must be a shaq")

  ### Stage A from the paper
  n = ncol(x)
  Omega = runif(n * 2*k) # nx(2k)
  dim(Omega) = c(n, 2*k)

  Y = x %*% Omega # mx(2k)
  Q = qr_Q(Y) # mx(2k)

  for (i in 1:q)
  {
    Y = crossprod(x, Q) # nx(2k)
    Q = qr.Q(qr(Y)) # nx(2k)
    Y = x %*% Q # mx(2k)
    Q = qr_Q(Y) # mx(2k)
  }

  ### Stage B
  B = crossprod(Q, x) # (2k)xn

  if (!retu)
    nu = 0
  else
    nu = min(dim(B))

  if (!retv)
    nv = 0
  else
    nv = min(dim(B))

  svd.B = svd(B, nu, nv)

  ind = 1L:k
  d = (svd.B$d)[ind]

  # Produce u/v as desired
  if (retu)
  {
    u = Q %*% svd.B$u
    u = u[, ind]
  }

  if (retv)
    v = svd.B$v[, ind, drop=FALSE]

  # wrangle return
  if (retu)
  {
    if (retv)
      svd <- list(d=d, u=u, v=v)
    else
      svd <- list(d=d, u=u)
  }
  else
  {
    if (retv)
      svd <- list(d=d, v=v)
    else
      svd <- list(d=d)
  }

  svd
}


# Example : 2   Chapter : 6.1     Page No: 285
# Eigen values and eigen vectors of Projection matrix
A<-matrix(c(0.5,0.5,0.5,0.5),ncol=2)
sol<-eigen(A)
lambda<-sol$values
x<-sol$vectors #These are normalised eigen vectors
#to get eigen vectors in text book multiply them with scalars
x[,1]<-x[,1]*(1/x[1,1])
x[,2]<-x[,2]*(1/x[1,2])
print("The eigen values of the matrix are")
print(lambda)
print("The eigen vectors of the matrix are")
print(x)


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

# Example : 3.3A   Chapter : 3.3     Page No: 149
# Find the row reduced echelon form, rank and special solution for given matrix

library(pracma)
solution <- function(A){
  R<-rref(A)
  m<-nrow(A)
  n<-ncol(A)
  pivotcol<-c() #vector to store the column numbers of pivot columns
  freecol<-c()  #vector to store the column numbers of free columns
  i<-1
  j<-1

  # to find which columns are pivot and which are free
  while(i<=m & j<=n){
    if(R[i,j]==1){
      pivotcol<-c(pivotcol,j)
      i<-i+1
      j<-j+1
    }
    else{
      j<-j+1
    }
  }
  y<-length(pivotcol)
  freecol<-c(1:n)
  freecol<-freecol[!freecol%in%pivotcol]
  x<-length(freecol)
  N<-c()
  #find the basis for null space based on Row reduced echelon form of given matrix
  if(y==n){
    N<-c()
  }
  else{
  for(i in 1:x){
    temp<-c(1:n)
    for(j in 1:x){
      temp[freecol[j]]<-0
    }
    temp[freecol[i]]<-1
    temp[freecol[i]]
    for(j in 1:y){
      temp[pivotcol[j]]<-R[j,freecol[i]]*-1
    }
    N<-c(N,temp)
  }
  N<-matrix(N,nrow=n,ncol=x)
  }
  print("Row reduced echelon form is")
  print(R)
  print("Rank of the Matrix is")
  print(y)
  print("Special solutions for given matrix are given by")
  print(N)
}

A<-matrix(c(1,-1,0,0,-1,2,-1,0,0,-1,2,-1,0,0,-1,1),nrow=4)
solution(A)


catch=c(3.6,.8,2.5,2.9,1.4,.9,3.2,2.7,2.2,5.9,3.3,2.9,3.6,2.4,.9,2.0,1.9,3.1,2.6,3.4)
residence=c(92.2,86.7,80.2,87.2,64.9,90.1,60.7,50.9,86.1,90.0,80.4,75.0,70.0,64.6,50.0,50.0,51.2,40.1,45.0,50.0)
size=c(.21,.30,.31,.40,.44,.56,.78,1.21,.34,.40,.52,.66,.78,.91,1.10,1.24,1.47,2.21,2.46,2.80)
access=c(0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1)
structures=c(81,26,52,64,40,22,80,60,30,90,74,50,61,40,22,50,37,61,39,53)
relation = lm(catch~residence+size+access+structures)
print(summary(relation))
anova(relation)

# for reduced model
print(" for reduced model")
relation = lm(catch~residence+size)
print(summary(relation))
anova(relation)
# complete linear regression model :  -2.78 + .0268x1 + .504x2 + .743x3 + .0511x4
# reduced model : -.87 + .0394x1 + .828x2
# test statistic
SSregression_complete=24.0624
SSregression_reduced=2.913
Ssresidual_complete=2.2756
n=20
a=(SSregression_complete-SSregression_reduced)/2
b=(Ssresidual_complete)/(n-5)
F=a/b
print(F)
fvalue=qf(1-.01,2,15)
print(fvalue)
#  The value of the test statistic is much larger than the tabled value, so we have conclusive evidence that the access and structure variables add predictive value


##Correlation tests of local instability, island size and degree of NNI graph

##number of areas vs island size
areas <- c(4, 6, 6, 8, 9)
islandSize <- c(18, 72, 90, 216, 486)
areaBySize <- as.data.frame(cbind(areas,islandSize))
cor.test(areaBySize$areas, areaBySize$islandSize, method = "pearson")
#r=0.9053, pval=0.0345

##number of possible topologies vs island size
topol <- c(3^4, 3^6, 3^6, 3^8, 3^9)
islandSize <- c(18, 72, 90, 216, 486)
topolBySize <- as.data.frame(cbind(topol,islandSize))
cor.test(topolBySize$topol, topolBySize$islandSize, method = "pearson")
#r=0.9925, pval=0.0008

##number of areas of instability vs degree
areas <- c(4, 6, 6, 8, 9)
degree <- c(4.33,6.33,6.33,7.67,9.00)
areaByDegree <- as.data.frame(cbind(areas,degree))
cor.test(areaByDegree$areas, areaByDegree$degree, method = "pearson")
#r=0.9936, pval=0.000615

##island size vs degree
islandSize <- c(18, 72, 90, 216, 486)
degree <- c(4.33,6.33,6.33,7.67,9.00)
islandByDegree <- as.data.frame(cbind(islandSize,degree))
cor.test(islandByDegree$islandSize, islandByDegree$degree, method = "pearson")
#r=0.9158, pval=0.02895


## ch04. 기술통계분석(수치형)

## 산술평균 ####

## 데이터 가져오기

wgt <- read.csv("0401.wgt.csv",
                header = T,
                na.strings = ".")
str(wgt)

wgt$sex <- factor(wgt$sex,
                  levels = c(1,2),
                  labels = c("남자","여자"))
str(wgt)

str(wgt$sex)

attach(wgt)

# 기본함수 이용
# na.rm = TRUE 결측값을 통계 분석 시 제외(미포함) 실제로 이 옵션을 붙여서 활용한다.

mean(weight)
mean(weight, na.rm=T)
median(weight)
summary(wgt)

# 절단평균(Trimmed Mean, pshych) 양옆의 일정비율을 삭제하고 통계 계산
# median, mean 의 경향을 확인하고 파악

mean(weight)
mean(weight, trim = 0.1) # 양쪽을 0.05씩 떼주어라.

detach(wgt)

# 가중평균 #### 각 항의 수치에 그 중요도에 비례하는 계수를 곱한다음 산출

class <- c("A","B","C")
class.n <- c(10, 50, 40)
class.avg <- c(60,70,80)
class.t <- data.frame("학급"=class, "학생수"=class.n, "학급평균"=class.avg)

View(class.t)

mean(class.avg)
weighted.mean(class.avg, class.n) #학급에 10명, 50명, 40명이 있으니, 가중치를 주는 것

# 기하평균 ####
  # 곱의 형태로 변화하는 자료 (비율의 평균계산 - 물가상승률, 인구변동률, 연평균 성장률(CAGR))
  # 증가율은 전년도 대비임. 원년대비가 아님 / 평균의 의미 매년 똑같이 증가한다는 의미

table <- data.frame("연도"=c(2010:2014),
                    "수익"=c(635,998,1265,1701,2362),
                    "증가율"=c(0,0.572,0.268,0.345,0.389))
)

# 식으로 계산

(2363/635)^(1/4) -1

# 비율로 계산(각각의 증가율로 계산)

cagr <- c(1.5716, 1.2675, 1.3446, 1.3885)

# cagr1 <- c((998/635), (1265/998), (1701/1265), (2362/1701)) , 괄호를 해도되고 안해도 됨

prod(cagr)^(1/length(cagr))-1 #각각의 항목을 모두 곱한 다음(prod), 곱한 만큼 나누어주고, 자신을 뺀다.

# psych 통계 패키지 사용

# install.packages("psych")
library(psych)

# geometric.mean 함수 사용 : 입력은 비율자료이어야 함
  # 비율만 알때 사용하기 좋은 방식 - 위의 것이 복잡하기 때문에 실제로는 아래방식으로 사용할 것을 추천(원데이터 알면 상관없지만..)

cagr <- c(1.5716, 1.2675, 1.3446, 1.3885)
geometric.mean(cagr) - 1

# 조화평균 ####
 # 속도 등과 같이 여러 단위가 결합되어 있을 때에 계산 (속도와 시간의 결합 등 km/h) harmonic mean

 # 질문 : 서울-> 부산 갈때 400km, 1시간 / 올때, 부산 -> 서울 100km, 4시간 = 평균 시속은?

hm <- c(400,100)
1/mean(1/hm)

 # 패키지이용(psych)

harmonic.mean(hm)

# 분포 ####
  # 4분위 : 자료를 동일한 비율로 4등분  box plot에서 활용
  # 표준편차, 분산, 왜도, 첨도 등
attach(wgt)

# 기본변수 R 사용하여 확인하는 법

min(weight)
max(weight)
diff(range(weight)) # 최소값과 최대값의 차이
quantile(weight, c(0.25, 0.5, 0.75, 1.0))
var(weight)
sd(weight)
skew(weight) 왜도 (오른쪽으로 길다)
kurtosi(weight) 첨도

# 표준화 ####
 # 측정단위 등과 관계없이 자료를 표준화시킨 값 : 절대 비교가 가능 / 평균에서 멀어진 정도

wgt <- transform(wgt,
                 weight.z = scale(weight)) #scale 표준화하라는 명령어

wgt

detach(wgt)

# 기술통계 패키지 활용법 ####

attach(wgt)

summary(weight)

library(psych)

describe(weight)

?describe

detach(wgt)

# 이상치 제거 ####

boxplot(wgt$weight)

attach(wgt)

boxplot(weight)

# 80Kg 이상인 데이터 제거

wgt <- wgt[!(weight > 80),] # ! 아닌거 => 80kg 아닌 거 골라서 다시 집어 넣어라
describe(weight) # 패키지 psych 읽고나서 사용

 # 이러면 수치가 바뀌어야 하는데, 수정되지 않은 것을 볼 수 있다.
 # attcah를 사용하고 나서 데이터 프레임 수정후에는 반드시 detach 하고 다시 프레임을 읽어와야 한다. (매우 중요)

detach(wgt)

attach(wgt)

describe(weight)

detach(wgt)

# 그룹간 연속변수 특성비교 ####

attach(wgt)

tapply(weight, sex, mean)
tapply(weight, sex, summary)
library(psych)
describeBy(wgt[c("weight")], sex, mat=TRUE) # mat = TRUE, mat = FALSE 동시에 묶어서 보여줄 것인가? 구분해서 보여줄 것인가?
describeBy(wgt[c("weight")], sex, mat=FALSE)

detach(wgt)

ch04 - 기술통계/기술통계분석.r

ch04 - 기술통계/기술통계분석.r

ch04 - 기술통계/기술통계분석.r


norvig 	<- c(2, 6, 3, 8, 8, 6)
hinton 	<- c(6, 4, 4, 2, 7, 8)
navarro <- c(6, 4, 4, 0, 8, 4)
ullman 	<- c(4, 6, 8, 5, 9, 8)
aho 	<- c(5, 8, 8, 8, 10, 9)
carmack <- c(6, 7, 8, 4, 7, 8)

# A function to plot both points and linear regression line
plot_pearson <- function(x, y, xname, yname) {
	xparse <- strsplit(xname, " ")
	xlname <- xparse[[1]][length(xparse[[1]])]

	yparse <- strsplit(yname, " ")
	ylname <- yparse[[1]][length(yparse[[1]])]

	title = paste("Comparing the ratings given by", xlname, "and", ylname)
	plot(x, y, pch=16, cex=1.3, col="blue", main=title, xlab=xname, ylab=yname)
	abline(lm(y ~ x), col="red", lty=2)
}

# The positive correlation example
positive <- function() {

	x <- ullman
	y <- carmack

	xname <- "Jeffrey Ullman"
	yname <- "John Carmack"

	plot_pearson(x, y, xname, yname)

}

# The negative correlation example
negative <- function() {

	x <- navarro
	y <- norvig

	xname <- "Gonzalo Navarro"
	yname <- "Peter Norvig"

	plot_pearson(x, y, xname, yname)
}

# The almost-zero correlation example
zero <- function() {

	x <- navarro
	y <- aho

	xname <- "Gonzalo Navarro"
	yname <- "Alfred Aho"

	plot_pearson(x, y, xname, yname)
}


# Q.1 -> Q1. The prime factors of 13195 are 5, 7, 13 and 29. What is the largest prime factor of the number?

euler <- function(n) {
  if (n==1) return(NULL)
  if (n==2) return(n)
  l <- 2:n
  i <- 1
  p <- 2
  while (p^2<=n) {
    l <- l[l==p | l%%p!=0]
    i <- i+1
    p <- l[i]
  }
  return(l)
}

prime.factors <- function (n) {
  factors <- c()
  primes <- esieve(floor(sqrt(n)))
  d <- which(n%%primes == 0)
  if (length(d) == 0)
    return(n)
  for (q in primes[d]) {
    while (n%%q == 0) {
      factors <- c(factors, q)
      n <- n/q } }
  if (n > 1) factors <- c(factors, n)
  return(factors)
}

print(max(prime.factors(13195)))


# script for demonstrate the concept of population and sample
# load rio package
library(rio)

# vector with three sample sizes
sizes <<- c(50,100,1000)

# number of samples
samples <<- 1:10

# base file name
base_name <<- 'sample_size_'

# loading population datafile
population <<-  import('population.csv')

# computing population parameter
p_mean <-  mean(population$salary)
p_var <-  var(population$salary)

par(mfrow=c(3,1))
print('-------------Population parameter ------------')
print(paste('Population mean    :',p_mean))
print(paste('Population variance:',p_var))
print('----------------------------------------------')

# Running a loop for every sample file in the directory session 3
for( size in sizes) {
  print(paste('-------Sample size:',size,' ----------'))

  # Create an empty vector to store sample mean
  all_sample_mean <- c()

  for (sample in samples) {
    print(paste('   sample:',sample))

    # forming the sample file name
    file_name <-  paste(base_name,size,'_',sample,'.csv',sep='')
    print(file_name)

    # loading the sample file
    sample_file <-  import(file_name)

    # computing the sample characteristic
    sample_mean <- mean(sample_file$salary)
    sample_var <- var(sample_file$salary)

    # printing the mean and variance of the sample
    print(paste('     mean    :',sample_mean))
    print(paste('     variance:',sample_var))

    # adding the sample mean to the vector for later processing
    all_sample_mean <- append(all_sample_mean,sample_mean)

  }

  title <- paste('Means of all sample of size ',size)

  plot(all_sample_mean,main=title,xlab='sample number',ylab='salary mean',col='red',pch=19)
  abline(h=p_mean, col='blue')
  # compute the mean of vector containing all means of sample of same size
  print(paste('  ============= Mean of sample means    :',mean(all_sample_mean)))
  print(paste('  ============= Variance of sample means:',var(all_sample_mean)))
  print('-----------------------------------------------')
  print('')
}


#' @export
identity_matrix <- function(X=NULL, n=NULL){
    if (is.null(n)) {
        n <- dim(X)[1]
    }
    return(diag(n))
}

#' @export
projection_matrix <- function(X){
    P <- X %*% solve(t(X) %*% X) %*% t(X)
    return(P)
}

#' @export
orthogonal_projection_matrix <- function(X){
    M <- I(X) - P(X)
    return(M)
}

#' @export
prediction_error_tranformation_matrix <- function(X){
    M_star <- diag((1-leverage_values(X))^(-1))
    return(M_star)
}

# Notations

#' @export
I <- identity_matrix

#' @export
P <- projection_matrix

#' @export
M <- orthogonal_projection_matrix

#' @export
M_star <- prediction_error_tranformation_matrix


# ......................................................................................
# ...............................Exercise 2 - Probability...............................
#  code presented in this excercise is not required on homeworks or exams, its only to show what is possible in R an to complement the excercise with nice graphs.**
# ......................................................................................

# If text does not display correctly, set File \Reopen with Encoding ... to UTF-8
# Use CTRL + SHIFT + O to display the contents of the script
# Use CTRL + ENTER to run commands on a single line

# In this exercise, we will go through an introduction to probability. We assume you are
# familiar with the terms: **definition of probability, conditional probability, total
# probability theorem, Bayes' theorem**.
#
#  Auxiliary functions ####
#
# * Total probability ####
#
# $P(A)=\sum_{i=1}^{n}P(B_i)P(A|B_i)$
#

# probability calculation P(A) - total probability theorem
total_probability = function(P_B, P_AB)
{   # we consider P_B as a vector of values P(B_i) and P_AB as a vector of values P(A|B_i)
    P_A = 0
    for (i in 1:length(P_B))
    {
        P_A = P_A + P_B[i]*P_AB[i]
    }
    return(P_A)
}

# * Bayes' theorem ####
#
# $P(B_k|A)=\frac{P(B_k)P(A|B_k)}{\sum_{i=1}^{n}P(B_i)P(A|B_i)}$
#

# calculation of conditional probability P(B_k|A) - Bayes' theorem
bayes = function(P_B, P_AB, k)
{   # we consider P_B as a vector of values P(B_i), P_AB as a vector of values P(A|B_i) and k as and index in P(B_k|A)
    P_A = total_probability(P_B, P_AB)
    P_BkA = P_B[k]*P_AB[k]/P_A
    return(P_BkA)
}

# **We will add functions from the last exercise for computing combinatorial selections,
# they are in the combinatorics script.R**
#

source('combinatorics.R')

#  Examples ####
#
# * Example 1. ####
#
# Determine the probability that a number greater than 14 will fall on a 20-wall fair
# dice roll.
#

omega = 1:20
A = c(15,16,17,18,19,20)
# probability as a proportion favorable to all
length(A)/length(omega)

# * Example 2. ####
#
# Determine the probability that a number greater than 14 will fall on a 20-wall dice
# roll, if you know that even numbers fall twice as often as odd numbers.
#

p_odd = 1/(20+10)
p_even = 2*p_odd
probability = c(p_odd, p_even, p_odd, p_even, p_odd, p_even, p_odd, p_even, p_odd, p_even,
                p_odd, p_even, p_odd, p_even, p_odd, p_even, p_odd, p_even, p_odd, p_even)
probability
# probability is
sum(probability[15:20])

# * Example 3. ####
#
# Determine the probability that you will guess exactly 4 numbers in the lottery.(6
# numbers out of 49 are drawn)
#

(combinations(6,4)*combinations(43,2))/combinations(49,6)

# * Example 4. ####
#
# From the alphabetical list of students enrolled in the exercise, the teacher selects
# the first 12 and offers them a bet: “If each of you was born in a different zodiac
# sign, I will give each of you CZK 100. However, if there are at least two students
# among you who were born in the same sign, each of you will give me 100 CZK. ”Is it
# worthwhile for students to accept a bet? How likely are students to win?
#

permutation(12)/r_permutation_repetition(12,12)

# * Example 5. ####
#
# Calculate the probability that an electric current will flow from point 1 to point 2
# if part of the el. circuit, including the probability of failure of individual
# components is indicated in the following figure.(The failures of the individual
# components are independent of each other.) </br>
#  ![Image.png](attachment:image.png)
#

# divided into blocks I=(A, B) and II=(C, D, E)
PI = 1 - (1 - 0.1)*(1 - 0.3)
PI
PII = 0.2*0.3*0.2
PII
# result
(1 - PI)*(1-PII)

# * Example 6. ####
#
# The patient is suspected of having one of four mutually exclusive diseases - N1, N2,
# N3, N4 with a probability of occurrence of P(N1)=0.1; P(N2)=0.2; P(N3)=0.4; P(N4)=0.3.
# Laboratory test A is positive in the case of the first disease in 50% of cases, in the
# second disease in 75% of cases, in the third disease in 15% of cases and in the fourth
# in 20% of cases. What is the probability that the result of the laboratory test will
# be positive?
#

# total probability theorem
P_N = c(0.1,0.2,0.4,0.3) # P(N1), P(N2),...
P_PN = c(0.5,0.75,0.15,0.2) # P(P|N1), P(P|N2),...
P_P = total_probability(P_B = P_N, P_AB = P_PN) # P(P)
P_P

# * Example 7. ####
#
# Telegraphic characters consist of "dot" and "comma" signals. It is statistically found
# that 25% of "dot" messages and 20% of "comma" signals are distorted. It is also known
# that signals are used in a 3: 2 ratio. Determine the probability that the signal was
# received correctly if a "dot" signal was received.
#

# Bayes' theorem
P_O = c(0.6, 0.4)   # P(O.), P(O-)
P_PO = c(0.75, 0.2) # P(P.|O.), P(P.|O-)
bayes(P_B = P_O, P_AB = P_PO, k = 1) # k=1 because correctly=O.

# * Example 8. ####
#
# 85% of green taxis and 15% of blue taxis run in one city. The witness of the traffic
# accident testified that the accident was caused by the driver of the blue taxi, who
# then left. Tests carried out under similar lighting conditions showed that the witness
# identified the color of the taxi well in 80% of cases and was wrong in 20% of cases.
#
# - What is the probability that the culprit of the accident actually drove a blue taxi?
#
# - Subsequently, another independent witness was found who also claims that the taxi
# was blue. What is the probability that the culprit of the accident actually drove a
# blue taxi now?
#
# - Does the probability that the perpetrator of the accident actually drove a blue taxi
# affect whether the two witnesses mentioned above testified gradually or
# simultaneously?
#

# a) again Bayes' theorem
P_B = c(0.85, 0.15)  # P(Z), P(M)
P_SB = c(0.20, 0.80) # P(SM|Z), P(SM|M)
bayes(P_B = P_B, P_AB = P_SB, k = 2) # blue is second

# b) first option - second pass through Bayes
P_M = bayes(P_B = P_B, P_AB = P_SB, k = 2)
P_B = c(1 - P_M, P_M)  # P(Z), P(M)
P_SB = c(0.20, 0.80)   # P(S2M|Z), P(S2M|M)
bayes(P_B = P_B, P_AB = P_SB, k = 2)

# c) or answered at once
P_B = c(0.85, 0.15)      # P(Z), P(M)
P_SB = c(0.20^2, 0.80^2) # P(S1M & S2M|Z), P(S1M & S2M|M)
bayes(P_B = P_B, P_AB = P_SB, k = 2)

# * Example 9. ####
#
# We need to find out the answer to a sensitive question. How to estimate what
# percentage of respondents will answer YES to the question and at the same time
# guarantee complete anonymity to all respondents? One of the solutions is the so-called
# double-anonymous survey:
#
# We will let the respondents throw the coin A and the coin B.
# - Those who got head on coin A will write the answer(YES/NO) to the sensitive question
# on teir card.
# - Those who got tail on coin A will write YES = if coin B landed on head or NO = if
# coin B landed on tail.
#
# How do we determine the proportion of students who answered YES to a sensitive
# question?
#
# Assume that respondents were asked if they were cheating on an exam. From the
# questionnaires, it was found that 120 respondents answered "YES" and 200 respondents
# answered "NO". What percentage of students cheated at the exam?
#

# total probability theorem
# P(YES)=P(A_YES) * P(YES|A_YES) + P(A_NO) * P(B_YES|A_NO)
# equation 120/320=0.5 * x + 0.5 * 0.5
(120/320-0.5^2)/0.5

# * Bonus - Monty Hall Problem ####
#
# You are winner of the TV competition. You are presented with three doors. Behind one
# is the crown prize and behind twe there is nothing. You have to pick one door. Then
# the moderator opens one of the two doors left (the ones you did not pick) and the
# doors without a prize (as the moderator knows where the prize is, he will always pick
# empty doors).
#
# Now the Question, will you stick with your original choice of the door, or you will
# switch to the other one still not opened?


MiniBatchGradientDescent <- function(X, Y, alpha=0.1, max.iter=1000, precision=0.0001, batchRate=0.5, seed=1){
  if (is.null(n <- nrow(X))) stop("'X' must be a matrix")

  if(n == 0L) stop("0 (non-NA) cases")

  p <- ncol(X)

  if(p == 0L) {
    return(list(
      x = X,
      y = Y,
      coefficients = numeric(),
      residuals = Y,
      fitted.values = 0 * Y
    ))
  }

  if(NROW(Y) != n) {
    stop("incompatible dimensions")
  }

  # Initial value of coefficients
  B <- rep(0, ncol(X))
  # batch size
  batchSize <- ceiling(n * batchRate)
  # Recorded for loss vs iteration
  loss_iter <- data.frame(
    loss = numeric(),
    iter = integer()
  )
  for(iter in 1:max.iter){
    B.prev <- B

    for(i in seq(1, n, batchSize)){
      indexes <- i:min((i+batchSize), n)
      Xtemp <- X[indexes,,drop=FALSE]
      Ytemp <- Y[indexes,drop=FALSE]

      yhat <- Xtemp %*% B
      B <- B + (alpha / length(indexes)) * t(Xtemp) %*% (Ytemp - yhat)
    }

    loss <- Y - X %*% B
    loss_iter <- rbind(loss_iter, c(sqrt(mean(loss^2)), iter))

    if(any(is.na(B)) ||
       !any(abs(B.prev - B) > precision * B)){
      break
    }
  }

  names(B) <- colnames(X)
  fv <- X %*% B
  rs <- Y - fv
  coef <- as.vector(B)
  names(coef) <- rownames(B)
  colnames(loss_iter) <- c('loss', 'iter')

  z <- structure(list(
    x=X,
    y=Y,
    coefficients = coef,
    fitted.values = fv,
    residuals = rs,
    loss_iter = loss_iter
  ),
  class = c("rlm", "rlmmodel"))

  z
}


## Zernike coefficients for a conic

zconic <- function(D, rc, b = -1, lambda = 632.8, nmax = 6) {
    if ((nmax %%2) != 0) stop("nmax must be even")
    nterms <- nmax/2+1
    sa <- zc <- zs <- numeric(0)
    cz <- matrix(0, nterms, nterms)

    sd <- D/2
    na <- (sd/rc)^2
    sa[1] <- sa[2] <- 0
## 4th order conic term
    zs[3] <- (sd/rc)^3*sd*1e6/8/lambda
    zc[3] <- (1+b)*zs[3]
    sa[3] <- zc[3]-zs[3]
## binomial expansion of conic
    if (nterms >= 4) {
        for (k in 4:nterms) {
            mult <- (1-3/(2*(k-1)))*na
            zc[k] <- mult*(1+b)*zc[k-1]
            zs[k] <- mult*zs[k-1]
            sa[k] <- zc[k]-zs[k]
        }
    }
## recurrence relation for coefficients of radial zernikes
    cz[1,] <- (-1)^(0:(nterms-1))
    cz[2,2] <- 2
    for (j in 3:nterms) {
        for (i in 2:j) {
            n <- 2*(j-1)
            cz[i, j] <- (4*(n-1)*cz[i-1, j-1]-2*(n-1)*cz[i,j-1]-(n-2)*cz[i,j-2])/n
        }
    }
    for (j in 1:nterms) {
        n <- 2*(j-1)
        cz[,j] <- cz[,j]*sqrt(n+1)
    }
    solve(cz,sa)[-(1:2)]
}

## Zernike coefficients of Wavefront error due to testing a conic at center of curvature
## this should be more accurate for numerical nulling than twice the height difference as in zconic

sconic <- function(D, rc, b = -1, eps = 0., lambda = 632.8, nmax = 6) {

    if ((nmax %%2) != 0) stop("nmax must be even")
    nz <- (nmax-2)/2
    zc <- numeric(nz)

    na <- D/2/rc
    p <- function(rho, na, b) {
        (rho*na)^2*(1 - 2/(1 + sqrt(1 - (1+b)*(rho*na)^2)) +
        (rho*na)^2/(1 + sqrt(1 - (1+b)*(rho*na)^2))^2)
    }
    q <- function(rho, na, b) 1 - sqrt(1 + p(rho, na, b))
    f <- function(rho, na, b, n) q(rho, na, b)*rzernike(sqrt((rho^2-eps^2)/(1-eps^2)), n, 0)*rho
    for (i in 1:nz) {
        n <- 2 + 2*i
        int <- integrate(f, lower=eps, upper=1, na=na, b=b, n=n)
        zc[i] <- 4 * rc * sqrt(n+1) * int$value * 1.e6/lambda/(1-eps^2)
        if (int$message != "OK") warning("coefficient may be inaccurate")
    }
    zc
}

## returns cosine and sine components of Bath astigmatism

##
# D = diameter
# rc = radius of curvature
# s = beam separation
# lambda = source wavelength
# phi = angle from horizontal (degrees)
##

astig.bath <- function(D, rc, s, lambda=632.8, phi=0) {
    astig.tot <- D^2 * s^2/(32 * sqrt(6) * lambda* 1.e-6 * rc^3)
    astig.tot*c(cos(pi*phi/90), sin(pi*phi/90))
}


# Imitate Poisson process built on the exponential random variables and plot its trajectories

library(ggplot2)

Poisson <- function(seed_n, seed_rate)
{
  # function to generate values of the Poisson process contructed on exponential random variables
  return(c(0,cumsum(rexp(n = seed_n, rate = seed_rate))))
}

DrawTrajectory <- function(numInst,
                           timeline,
                           N,
                           inRate)
{
  # function drawing <numInst> trajectories of the Poisson process over <timeline>
  # <N> and <inRate> used to generate Poisson process instances within function

  plot <- ggplot() + ggtitle("Trajectories of Poisson process") + labs(x = 't', y = 'N(t)')
  for(i in 1:numInst)
  {
    plot <- plot + geom_path(aes(x = T, y = Poisson(N, inRate)))
  }
  plot
}

## input parameters
lambda <- 1.0
tMax <- 10 * lambda
num <- tMax
T <- 0:10
# call example
DrawTrajectory(10, T, num, lambda)


### 5.2-1

p <- 0.29
nSamples <- 83
pHat <- 17

z <- (pHat - p*nSamples) / (sqrt(nSamples * p * (1 - p)))
print(z)

### 1 - alpha / 2 = 1 - 0.025 = 0.975
zCrit <- qnorm(0.975, mean=0, sd=1, lower.tail = TRUE, log.p = FALSE)
print(zCrit)

### z = -1.710221  ->  H0 is accepted (mu = 29%)