library(pomp)

## Fake data

N <- 500
T <- 60
steps <- 7
h <- 1 / steps
sigma <- 10

pars_true <- c(R0 = 3.0, 	# new infected people per infected person
          		r = 0.1, 	# recovery rate
          		sigma = 5,	# observation error intensity
          		I0 = 5)		# initial condition, number of infected people

B <- pars_true['R0'] * pars_true['r'] / N

odeout <- matrix(NA, nrow = (T+1), ncol = 3)
odeout[1,] <- c(N - pars_true['I0'], pars_true['I0'],0)
colnames(odeout) <- c("S", "I", "R")

S <- odeout[1,1]
I <- odeout[1,2]
R <- odeout[1,3]
R0 <- pars_true['R0']
r <- pars_true['r']

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

    dS <- - B*S*I
    dI <- B*S*I - r*I
    dR <- r*I

    S <- S + h*dS;
    I <- I + h*dI;
    R <- R + h*dR;

    if (i %% 7 == 0)
    	odeout[(i/7) + 1,] = c(S, I, R)

}

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

data <- data.frame(time = 0:T, y = infec_counts)

sir_step <- Csnippet("
	double dS = - (R0*r/500.0)*S*I;
	double dI = (R0*r/500.0)*S*I - r*I;
	double dR = r*I;
	S += dt*dS;
	I += dt*dI;
	R += dt*dR;
")

sir_init <- Csnippet("
	S = 500.0 - I0;
	I = I0;
	R = 0;
")

dmeas <- Csnippet("
  	lik = dnorm(y, I, sigma, give_log);
")

rmeas <- Csnippet("
  y = rnorm(I, sigma);
")

sir <- pomp(data = data,
            time = "time",
            t0 = 0,
            initializer = sir_init,
            rprocess = euler.sim(step.fun = sir_step,
                                 delta.t = 1.0/steps),
            dmeasure = dmeas,
            rmeasure = rmeas,
            statenames = c("S","I","R"),
            paramnames = c("R0","r","I0","sigma"))

simStates <- simulate(sir,nsim=1,params=c(R0 = 3.0, r = 0.1, I0 = 5.0, sigma = 10.0),
                      states = TRUE, obvs = TRUE, as = TRUE)

m1 <- mif2(sir,
	      Nmif = 50,
	      start = c(R0 = 3.0, r = 0.1, I0 = 5.0, sigma = 10.0),
	      rw.sd = rw.sd(R0 = 0.3, r = 0.01, I0 = 0.5, sigma = 1.0,
	      cooling.fraction.50 = 0.95,
	      Np = 1000
	      )

plot(m1)


#' @export
#'
#' @title Agresti-Coull adjustment to binomial proportion
#'
#' @description Applies the Agresti and Coull (1998) adjustment
#' to an observed number of 'successes' out of a number of 'trials'.
#'
#' @param x The number of 'successes' (an integer vector)
#'
#' @param n The number of 'trials' (an integer vector)
#'
#' @param conf Confidence interval level (a scalar between 0.5 and 1)
#'
#' @details
#' The Agresti-Coull adjusted point estimate of a binomial proportion
#' is,
#' \deqn{phat = (x+(z^2)/2) / (n+z^2)}
#' where \code{z} is the \code{(1-(1-conf)/2)} quantile of a standard
#' normal distribution.  This point estimator was actually proposed by
#' Brown et al. (2001) but named for Agresti and Coull because the latter
#' discussed performance of the confidence interval under the
#' special case of \code{conf = 0.95} (i.e., \code{z = 1.96}).
#'
#' The estimated standard error of the Agresti-Coull adjusted proportion
#' is,
#' \deqn{se = sqrt( phat*(1-phat) / (n+z^2)).}
#'
#' The Agresti-Coull confidence interval is,
#' \deqn{phat +- z*se.}
#'
#' The Agresti-Coull confidence interval has
#' excellent coverage for ratios between
#' approximately 2% and 98%. For ratios between 0% and 2% (and 98% and 100%)
#' interval coverage
#' is too high (i.e., coverage exceeds \code{conf} substantially).
#' The Agresti-Coull point estimator is biased high except when true p = 0.5.
#' Simulations by the author of this routine suggest bias
#' in the point estimate is <10% for true p's between approximately
#' 0.15 and 0.85. For ratios between 0 and 0.02 (and 0.98 and 1), bias
#' in the point estimate can exceed 100%, but these are small (and large)
#' ratios so percent bias is sensitive to small changes. The author of
#' this routine is not aware of any studies of the variance estimator.
#'
#'
#'
#'
#' @return A data frame containing the Agresti-Coull adjusted proportion,
#' standard error, and confidence limits. The data frame has the
#' following columns:
#' \enumerate{
#'   \item \code{phat} : the Agresti-Coull adjusted point estimates.
#'   \item \code{se.phat} : the Agresti-Coull estimated standard
#'   error of the point estimates \code{phat}.
#'   \item \code{ll.phat} : the lower limit of a \code{100*(1-(1-conf)/2)}%
#'   confidence interval for \code{phat}.
#'   \item \code{ul.phat} : the upper limit of a \code{100*(1-(1-conf)/2)}%
#'   confidence interval for \code{phat}.
#' }
#'
#' @author Trent McDonald
#'
#' @references
#' Agresti, A. and B. A. Coull. 1998. Approximate is Better than
#' "Exact" for Interval Estimation of Binomial Proportions.
#' The American Statistician 52: 119:126.
#'
#' Brown, L. D., T. T. Cai, and A. DasGupta. 2001. Interval Estimation
#' for a Binomial Proportion. Statistical Science 16:101-133.
#'
#' @seealso \code{\link{bayesPhat}}
#'
#' @examples
#' agrestiCoullPhat(0:5, 100)
#'
#' # Simulation: point est bias and ci coverage
#' trueP <- 0.01
#' n <- 1000
#' x <- rbinom( 1000, n, trueP)
#' agPhat <- agrestiCoullPhat( x, n )
#' muAG <- mean(agPhat$phat)
#' covAG <- mean(agPhat$ll.phat <= trueP & trueP <= agPhat$ul.phat)
#' agStats <- c(mean=muAG,
#'              relBias = abs(muAG-trueP)/trueP),
#'              coverage = covAG)
#'
agrestiCoullPhat <- function(x,n,conf=.9){
  z <- qnorm(1-(1-conf)/2,0,1)
  x <- x + z^2/2
  n <- n + z^2
  phat <- x / n

  se <- sqrt(phat*(1-phat)/n)

  ll <- phat - z*se
  ul <- phat + z*se

  data.frame(phat=phat, se.phat=se , ll.phat=ll, ul.phat=ul)
}


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

## example of gamma GLM fit
library(MASS)
types <- rbinom(100, 1, 0.6)  # create types (0 or 1)
times <- rgamma(100, 3, 0.2+0.1*types) # gamma r.v.s w/rate 0.2 (0.3 for types==1)
model.fit <- glm(times ~ types, family=Gamma())
summary(model.fit)  # show linear model for 1/mu = rate/m = rate/3
## moment estimator of m, preferred by McCullagh and Nelder
m.hat1 <- 1/summary(model.fit)$dispersion
## common estimator of m
m.hat2 <- summary(model.fit)$df.residual/summary(model.fit)$deviance
## MLE estimator of m, implemented in MASS
m.hat3 <- gamma.shape(model.fit)

## example of survival analysis
## suppose bonds mature at 15 years so times > 15 are censored
library(survival)
library(flexsurv)
defaulted <- times < 15   # TRUE => data not censored
times.censored <- pmin(times, 15)

## Fit gamma parameters
## Note that covariate coefficients are modeling rate
## anc (ancillary) parameter allows modeling shape parameter
model.fit <- flexsurvreg(Surv(times, defaulted) ~ types, dist="gamma")
model.fit  # show parameter estimates


# Regression estimation.
# This R script contains functions for the calculation of
# the regression estimation known form survey sampling in
# statistics.
# Joshua Simon, 17.02.2020.

reg_estimation <- function(N, n, xu_mean, xk_sum, yk_sum,
                  xk_squared_sum, yk_squared_sum, xk_yk_sum) {
  #' Functions takes sample values as input arguments to
  #' calculate different estimators. All results are returned
  #' as terminal output. Mean estimates and variance estimates
  #' are also returned as a matrix.
  sx_squared <- 1/(n-1) * (xk_squared_sum - n * (xk_sum/n)^2)
  sy_squared <- 1/(n-1) * (yk_squared_sum - n * (yk_sum/n)^2)
  sxy <- 1/(n-1) * (xk_yk_sum - n * (xk_sum/n) * (yk_sum/n))
  r_squared <- sxy^2/(sx_squared * sy_squared)

  # Regression estimators.
  bx <- sxy/sx_squared
  y_reg <- yk_sum/n + bx * (xu_mean - (xk_sum/n))
  t_reg <- y_reg * N
  var_y_reg <- (1/n - 1/N) * sy_squared * (1 - r_squared)

  # Difference estimators.
  y_diff <- yk_sum/n - xk_sum/n + xu_mean
  t_diff <- N * y_diff
  var_y_diff <- (1/n - 1/N) * (sx_squared + sy_squared - 2 * sxy)

  # Ratio estimators.
  y_ra <- (yk_sum/n) / (xk_sum/n) * xu_mean
  t_ra <- N * y_ra
  r_head <- (yk_sum/n) / (xk_sum/n)
  approx_var_y_ra <- (1/n - 1/N) *
    (sy_squared + r_head^2 * sx_squared - 2 * r_head * sxy)

  # Output.
  print(paste("sx_squared:", sx_squared))
  print(paste("sy_squared:", sy_squared))
  print(paste("sxy:", sxy))
  print(paste("r_squared:", r_squared))
  print("")
  print("----- Regression estimation -----")
  print(paste("bx:", bx))
  print(paste("y_reg:", y_reg))
  print(paste("t_reg:", t_reg))
  print(paste("var(y_reg):", var_y_reg))
  print("")
  print("----- Difference estimation -----")
  print(paste("y_diff:", y_diff))
  print(paste("t_diff:", t_diff))
  print(paste("var_y_diff:", var_y_diff))
  print("")
  print("----- Ratio estimation -----")
  print(paste("y_ra:", y_ra))
  print(paste("t_ra:", t_ra))
  print(paste("r_head:", r_head))
  print(paste("approx_var(y_ra):", approx_var_y_ra))

  return(matrix(c(y_reg, y_diff, y_ra,
                  var_y_reg, var_y_diff, approx_var_y_ra),
                  nrow = 3, ncol = 2))
}

ci_estimation <- function(alpha, n, y_mean, var__) {
  #' Calculates the confidence interval (CI) of given estimations.
  ci_lower <- y_mean - qt(1 - alpha/2, n) * sqrt(var__)
  ci_upper <- y_mean + qt(1 - alpha/2, n) * sqrt(var__)

  print(paste0("CI: [", ci_lower, " ,", ci_upper, "]"))
}

# ----- Main program. -----
# Set values.
N <- 5000
n <-  500
xu_mean <- 121.2
xk_sum <- 60e3
yk_sum <- 65e3
xk_squared_sum <- 8.5e6
yk_squared_sum <- 10.25e6
xk_yk_sum <- 9.1e6

# Call functions.
estimators <- reg_estimation(N, n, xu_mean, xk_sum, yk_sum,
      xk_squared_sum, yk_squared_sum, xk_yk_sum)

alpha <- 0.05
# CI for regression estimation.
ci_estimation(alpha, n, estimators[1,1], estimators[1,2])

# CI for difference estimation.
ci_estimation(alpha, n, estimators[2,1], estimators[2,2])

# CI for ratio estimation.
ci_estimation(alpha, n, estimators[3,1], estimators[3,2])


## 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.
library(Quandl)
library(xts)
library(quantmod)
library(PerformanceAnalytics)

# Example of reading in CMTs from Quandl
# Name columns so we know what each holds after joining them together
ust.tickers <- c("FRED/DGS3MO", "FRED/DGS2", "FRED/DGS10", "FRED/DGS30")
ust.raw <- Quandl(ust.tickers, type="xts")/100
colnames(ust.raw) <- c("T3M.yld", "T2Y.yld", "T10Y.yld", "T30Y.yld")

# This is a way to get approximate returns for these bonds.
# Later on, you will learn about duration and why we can do this.
ust.yieldchanges <- diff(ust.raw)
colnames(ust.yieldchanges) <- c("T3M", "T2Y", "T10Y", "T30Y")
ust <- ust.yieldchanges
ust$T3M  <- -0.25*ust.yieldchanges$T3M
ust$T2Y  <- -1.98*ust.yieldchanges$T2Y
ust$T10Y <- -8.72*ust.yieldchanges$T10Y
ust$T30Y <- -19.2*ust.yieldchanges$T30Y

# Get Eurodollar futures (settlement) prices and create log-returns.
ed1.raw <- Quandl("CHRIS/CME_ED1", type="xts")[,"Settle"]
ed1 <- diff(log(ed1.raw))
colnames(ed1) <- c("ED1")

# Get S&P 500 prices (just adjusted close); then create log-returns.
# Do similarly for the Russell 2000, and other stocks.
adj.close <- 6  # 6th field is adjusted close
spx.raw <- getSymbols("^GSPC", source="yahoo", auto.assign=FALSE, return.class="xts")[,adj.close]
colnames(spx.raw) <- c("SPX.prc")
spx <- diff(log(spx.raw))
colnames(spx) <- c("SPX")

# Join all of the datasets together: US Treasuries, Eurodollars,
# S&P 500, Russell 2000, and group 1 and group 2 stocks.
# Then trim them down so the dates are consistent.
alldata.full <- cbind(ust.raw, ust, ed1, ed24, spx.raw, spx,
                      rut.raw, rut, yourticker.raw, yourticker)
alldata <- alldata.full["20130513/20170516"]

# Calculate annual volatilities like so:
apply(alldata, 2, sd)*sqrt(250)

# skewness and kurtosis are independent of time; no need to scale them
skewness(alldata, method="moment")
kurtosis(alldata, method="moment")


# Example : 2   Chapter : 9.2     Page No: 475
# Norm of diagonal matrix
A<-matrix(c(2,0,0,3),ncol=2)
print("The norm of the diagonal matrix is its largest entry")
print(A[2,2])
print("Largest eigen value and norm are equal for this matrix")
lambdamax<-eigen(A)$values[1]
print(lambdamax)
print("Eigen vectors of this matrix are")
ev<-round(eigen(A)$vectors)
print(ev)


#ML in 180 Minutes group/self exercise...

#Download training design matrix and labels
A <- read.csv(url("https://raw.githubusercontent.com/yoninazarathy/MathematicalEngineeringDeepLearning/master/ML180Minutes/A_3vs8_matrix_train.csv"))
y <- read.csv(url("https://raw.githubusercontent.com/yoninazarathy/MathematicalEngineeringDeepLearning/master/ML180Minutes/y_3vs8_vector_train.csv"))

#Download testing design matrix (each row is an image) for the digit "3" (positive)
A3test <- read.csv(url("https://raw.githubusercontent.com/yoninazarathy/MathematicalEngineeringDeepLearning/master/ML180Minutes/A_3_test.csv"))

#Download testing design matrix (each row is an image) for the digit "8" (negative)
A8test <- read.csv(url("https://raw.githubusercontent.com/yoninazarathy/MathematicalEngineeringDeepLearning/master/ML180Minutes/A_8_test.csv"))

#Task 1: Finding the least squares beta based on A and y.
  #Taks 1a: Do this via the pseudoinverse, or GLM, or similar.
  #Task 1b: Do this via an iterative gradient descent implementation
#Task 2: Evaluate the accuracy of the estimator(s) from task 1 on the accuracy


function(dvec, zthresh = 2.0){
#This function takes a data vector and returns a logical
#vector indicating which elements have a z-score larger than
#zthresh in either direction.

zvec<-(dvec - mean(dvec))/sqrt(var(dvec)) #compute zscores for dvec
abs(zvec) > zthresh #return logical vectors with a z score larger than zthresh in either direction
}


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

rm(list = ls())

x <- c(5.2, 8.5, 9.8, 12.3, 17.1, 17.9, 23.7, 29.8)

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

y <- c(1.1, 2.3, 3.2, 6.3, 7.0, 7.2, 9.1, 15.2, 18.3, 21.1)

(n.y <- length(y))
# 1.1, 2.3, 3.2, 6.3, 7.0, 7.2, 9.1, 15.2, 18.3, 21.1

(n <- n.x + n.y)
# 18

sum(duplicated(c(y, x))) > 0
# FALSE

(W <- sum(rank(c(y, x))[1:length(y)]))
# 76

(W.mean <- n.y * (n + 1) / 2)
# 95

(W.var <- n.y * n.x * (n + 1) / 12)
# 126.67

(W.yx <- W - n.y * (n.y + 1) / 2)
# 21

(W.yx.mean <-  n.x * n.y / 2)
# 40

(W.yx.var <- n.x * n.y * (n + 1) / 12)
# 126.67

### H0: X >= Y

## Asymptotic pvalue (with continuity correction)
pnorm((W.yx + 0.5 - W.yx.mean) / sqrt(W.yx.var))
# 0.050112052808869

## Exact
pwilcox(W.yx, n.y, n.x)
# 0.0505507564331094

### Shift Parameter Estimation

a <- matrix(rep(0, n.x * n.y), n.x, n.y)
for(i in 1:n.x) {
  for(j in 1:n.y) {
    a[i, j] <- y[j] - x[i]
  }
}
median(a)
# -6.1

wilcox.test(y, x, alternative = "less", conf.int = TRUE)
# Wilcoxon rank sum test
#
# data:  y and x
# W = 21, p-value = 0.05055
# alternative hypothesis: true location shift is less than 0
# 95 percent confidence interval:
#  -Inf  0.4
# sample estimates:
# difference in location
#                   -6.1


#Data
revenue <- c(14574.49, 7606.46, 8611.41, 9175.41, 8058.65, 8105.44, 11496.28, 9766.09, 10305.32, 14379.96, 10713.97, 15433.50)

expenses <- c(12051.82, 5695.07, 12319.20, 12089.72, 8658.57, 840.20, 3285.73, 5821.12, 6976.93, 16618.61, 10054.37, 3803.96)

#Solution

#PROFIT PER MONTH
profit <- revenue - expenses
profit

#30% TAX VALUE

#Alternative function for round is signif()
#The signif function rounds a numeric input to a specified number of digits.

tax <- round(0.30 * profit, 2)
tax

#PROFIT AFTER TAX
profit.after.tax <- profit - tax
profit.after.tax

#PROFIT MARGIN IN %

#Round To 2 Decimal Points, Then Multiply By 100 To Get %

#Round function in R, rounds off the values in its first argument to the specified number of decimal places.
#Round() function in R rounds off the list of values in vector and also rounds off the column of a dataframe.
#It can also accomplished by using signif() function

profit.margin <- round(profit.after.tax / revenue, 2) * 100
profit.margin

#MEAN PROFIT AFTER TAX
#The function mean() is used to calculate mean by taking the sum of the values and dividing with the number of
#values in a data series.

mean_profit_after_tax <- mean(profit.after.tax)
mean_profit_after_tax

#GOOD MONTHS
good.months <- profit.after.tax > mean_profit_after_tax
good.months

#BAD MONTHS

#Bad month is not equall to good month
bad.months <- !good.months
bad.months

#BEST MONTH

#max() function in R Language is used to find the maximum element present in an object.
#This object can be a Vector, a list, a matrix, a data frame, etc..

best.month <- profit.after.tax == max(profit.after.tax)
best.month

#WORST MONTH

#min function in R min(), is used to calculate the minimum of vector elements or minimum of a particular
# column of a dataframe.

worst.month <- profit.after.tax == min(profit.after.tax)
worst.month

#RESULTS FOR $ VALUES NEED TO BE CALCULATED WITH $0.01 PRECISION, BUT UNITS OF $1,000 WITH NO DECIMAL POINTS.
#It can also accomplished by using signif() function

revenue.1000 <- round(revenue / 1000, 0)
expenses.1000 <- round(expenses / 1000, 0)
profit.1000 <- round(profit / 1000, 0)
profit.after.tax.1000 <- round(profit.after.tax / 1000, 0)

#cbind() and rbind() both create matrices by combining several vectors of the same
#length. cbind() combines vectors as columns, while rbind() combines them as rows.
#cbind() stands for column binding.

mtrxc <- cbind(revenue.1000,expenses.1000,profit.1000,profit.after.tax.1000,profit.margin,good.months,bad.months,best.month,worst.month)
mtrxc

#rbind() function in R Language is used to combine specified Vector, Matrix or
#Data Frame by rows. deparse.
#rbind() stands for row binding.

mtrxr <- rbind(revenue.1000,expenses.1000,profit.1000,profit.after.tax.1000,profit.margin,good.months,bad.months,best.month,worst.month)
mtrxr

#By using matrices TRUE/FALSE are changed to 1's and 0'S. therefore True = 1, False = 0.


## Author: Sergio García Prado
## Title: Exercises with Solutions 2

rm(list = ls())

lambda <- 5
mu <- 6

(W.Q <- lambda / (mu * (mu - lambda)))
# 0.833333333333333

(L.Q <- lambda * W.Q)
# 4.16666666666667

StationaryValue <- function(state, lambda, mu) {
  (1 - lambda / mu) * (lambda / mu) ^ state
}

StationaryValue(0, lambda, mu)
# 0.166666666666667

(saturated <- 1 - sum(StationaryValue(0:3, lambda, mu)))
# 0.482253086419753


#pontos
x1 = c(0,1,2,3)
y1 = c(2,-2,2,0)
plot (x1,y1,"b", main="Pontos")

#interpolacao linear
t = seq(1,4,0.01)
i = seq(1,4,1)

ww = data.frame()

#calcular pesos
for(ii in i){

    w = c()

    for(tt in t){

        if(ii-1 <= tt && tt <= ii){
            w = append(w,tt-ii+1)
        }else if(ii < tt && tt < ii+1){
            w = append(w,1+ii-tt)
        }else{
            w = append(w,0)
        }

    }

    #pesos independentes
    ww = rbind(ww,w)
    plot(t,w,type="l", col=ii+1, main=paste("Peso",ii))

}

#Todos os pesos juntos
plot(1, xlim=c(1,4), ylim=c(0,1), xlab="t", ylab="w", main="Pesos")
for(a in i){
    lines(t, ww[a,], type="l", col=a+1)
}

#Interpolacao Linear
x2 = c(x1[1]*ww[1,] + x1[2]*ww[2,] + x1[3]*ww[3,] + x1[4]*ww[4,])
y2 = c(y1[1]*ww[1,] + y1[2]*ww[2,] + y1[3]*ww[3,] + y1[4]*ww[4,])

plot(x2, y2, "l", xlab="x", ylab="y", main="Interpolação Linear")


library(dslabs)
data(murders)

# run the murders$state[1:10] to return the following:
# [1] "Alabama"              "Alaska"               "Arizona"
# [4] "Arkansas"             "California"           "Colorado"
# [7] "Connecticut"          "Delaware"             "District of Columbia"
# [10] "Florida"

# run the murders$abb[1:10] to return the following:
# [1] "AL" "AK" "AZ" "AR" "CA" "CO" "CT" "DE" "DC" "FL"

index <- order(murders$total)

# run murders$abb[index] to return the following:
# [1] "AK" "AZ" "AL" "CA" "AR"

# run max(murders$total) to return the following
# [1] 1257 which is the higest number in the murders index

i_max <- which.max(murders$total) # this will return the maximum value

# i_max to return [1] 5

# run min(murders$total) to return the following
i_min <- which.min(murders$total) # this will return the minimum value
#i_min to return [1] 2


ybar = 31.2          # sample mean
mu0 = 33            # hypothesized value
sigma = 8.4         # population standard deviation
n = 35                # sample size
z = (ybar- mu0)/(sigma/sqrt(n))
print(z) # test statistic

# We then compute the critical value at .05 significance level.
# For alpha = .05, we will reject the null hypothesis if z <= -1.645
alpha = .05
z.alpha = qnorm(1-alpha)
#  the observed value of z  is not less than -z.alpha, the test statistic does not fall in the rejection region.


data("USArrests")      # Loading the data set
df <- scale(USArrests) # Scaling the data
# View the firt 3 rows of the data
head(df, n = 3)

#x: numeric matrix, numeric data frame or a numeric vector
#centers: Possible values are the number of clusters (k) or a set of initial (distinct) cluster centers. If a number, a random set of (distinct) rows in x is chosen as the initial centers.
#iter.max: The maximum number of iterations allowed. Default value is 10.
#nstart: The number of random starting partitions when centers is a number. Trying nstart > 1 is often recommended.

kmeans(x, centers, iter.max = 10, nstart = 1)

library(factoextra)
install.packages("factoextra")

library(factoextra)
fviz_nbclust(df, kmeans, method = "wss") +
  geom_vline(xintercept = 4, linetype = 2)

# Compute k-means with k = 4
set.seed(123)
km.res <- kmeans(df, 4, nstart = 25)

# Print the results
print(km.res)

aggregate(USArrests, by=list(cluster=km.res$cluster), mean)

dd <- cbind(USArrests, cluster = km.res$cluster)
head(dd)

# Cluster number for each of the observations
km.res$cluster

head(km.res$cluster, 4)

# Cluster size
km.res$size

# Cluster means
km.res$centers

fviz_cluster(km.res, data = df)


# Roll n die-sided dice
rdice <- function (die, n)
{
  rolls <- ceiling(runif(n, min=0, max=die))
  return (rolls)
}

# Take <numbers> and find the n-highest.
combmax <- function (numbers, maxed)
{
  highestnums = c()
  for (i in 1:maxed)
  {
    maxnum = max(numbers)
    highestnums = c(highestnums, maxnum)
    for (j in 1:length(numbers))
    {
      if (numbers[j] == maxnum)
      {
        numbers <- numbers[-j]
        break
      }
    }
  }
  return (highestnums)
}

# Find the maximums of several sets of dice
multimax <- function (die, num_dice, maxed, iter)
{
  # rolls = c()
  maxrolls = array(dim = c(maxed,iter))
  for (i in 1:iter)
  {
    rolls <- rdice(die,num_dice)
    maxrolls[,i] <- combmax(rolls,maxed)
  }
  return (maxrolls)
}

# Sum a certain number of highest die rolls
summax <- function (die, num_dice, maxed)
{
  # rolls = c()
  maxrolls = array(dim = maxed)
  rolls <- rdice(die,num_dice)
  maxrolls <- combmax(rolls,maxed)
  sum_maxs <- sum(maxrolls)
  return (sum_maxs)
}

# Generate a pool of dice rolls
gendice <- function (die, num_dice, maxed, base, iter)
{
  sum_maxs = array(dim=iter)
  for (i in 1:iter)
  {
    sum_maxs[i] <- (summax(die,num_dice,maxed)+base)
  }
  return (sum_maxs)
}

# Generate a histogram of a die roll system
dicechart <- function (die, num_dice, maxed, base, iter)
{
  dierolls = gendice(die, num_dice, maxed, base, iter)
  lowest = min(dierolls)
  highest = max(dierolls)
  columns = (lowest:(highest+1))
  hist(dierolls, breaks = columns, freq = FALSE, right = FALSE)
}


SwissData <- data.frame(swiss)
str(SwissData)
summary(SwissData)

boxplot(SwissData)

R<-cor(SwissData)

plot(SwissData[,1:6])

library(leaps)
SubsetSelection <- regsubsets(Infant.Mortality~., SwissData, nvmax=5)
SumSubsetSelection<-summary(SubsetSelection)
BestSubsetAdjr2<- which.max(SumSubsetSelection$adjr2)

BestSubsetCp<- which.min(SumSubsetSelection$cp)

par(mfrow=c(1,2))
plot(SumSubsetSelection$adjr2, xlab="Variables selected", ylab="Adjusted RSq", type="l")
points(BestSubsetAdjr2, SumSubsetSelection$adjr2[BestSubsetAdjr2], col="black", cex =1, pch =20)
plot(SumSubsetSelection$cp, xlab="Variables selected", ylab="CP", type="l")
points(BestSubsetCp, SumSubsetSelection$cp[BestSubsetCp], col="black", cex =1, pch =20)

coef(SubsetSelection,2)


library(caret)
data(mtcars)
str(mtcars)
summary(mtcars)
R<-cor(mtcars)

DataSplit<-createDataPartition(y = mtcars$mpg, p = 0.7, list = FALSE)
TrainData<-mtcars[DataSplit,]
TestData<-mtcars[-DataSplit,]
LmFit1<-train(mpg~., data = TrainData, method = "lm")
summary(LmFit1)

PredictedTest<-predict(LmFit1,TestData)
ModelTest1<-data.frame(obs = TestData$mpg, pred=PredictedTest)
defaultSummary(ModelTest1)

Control1<-trainControl(method = "cv",number = 10)
LmFit2<-train(mpg ~ ., data = mtcars, method = "lm", trControl = Control1, metric="Rsquared")
summary(LmFit2)

PredictedTest2<-predict(LmFit2,mtcars)
ModelTest2<-data.frame(obs = mtcars$mpg, pred=PredictedTest2)
defaultSummary(ModelTest2)

residuals<-residuals(LmFit2)
PredictedValues2<-predict(LmFit2)

par(mfrow=c(2,1))
plot(mtcars$mpg,residuals,cex.axis=0.6,cex.lab=0.6)
abline(0,0)
plot(mtcars$mpg,PredictedValues2,xlim=c(10,35),ylim=c(10,35),cex.axis=0.6,cex.lab=0.6)
abline(0,1)

Control2<-trainControl(method="LOOCV")
LmFit3<-train(mpg ~ ., data = mtcars, method = "lm", trControl = Control2)
summary(LmFit3)

varImp(LmFit3)

plot(varImp(LmFit3),cex.axis=0.2,cex.lab=0.1)

Control3<-trainControl(method="boot", number=100)
LmFit4<-train(mpg ~ ., data = mtcars, method = "lm", trControl = Control3)
summary(LmFit4)

PredictedTest4<-predict(LmFit4,mtcars)
ModelTest4<-data.frame(obs = mtcars$mpg, pred=PredictedTest4)
defaultSummary(ModelTest4)


#' Iterator that generates all combinations of a vector taken m at a time.
#'
#' Constructs an iterator generates all combinations of a vector taken \code{m}
#' at a time. This function is similar to \code{\link[utils]{combn}}.
#'
#' By default, the combinations are **without replacement** so that elements are
#' not repeated. To generate combinations **with replacement**, set
#' \code{replacement=TRUE}.
#'
#' The function implementation is loosely based on the \code{combinations}
#' function from Python's itertools. Combinations with replacement are based on
#' \code{combinations_with_replacement} from the same Python library.
#'
#' @importFrom iterators iter nextElem
#' @export
#' @param object vector
#' @param m the length of each combination
#' @param replacement Generate combinations with replacement? Default: no.
#' @return iterator that generates all combinations of \code{object}
#'
#' @examples
#' # Combinations without replacement
#' it <- icombinations(1:4, m=2)
#'
#' iterators::nextElem(it) # c(1, 2)
#' iterators::nextElem(it) # c(1, 3)
#' iterators::nextElem(it) # c(1, 4)
#' iterators::nextElem(it) # c(2, 3)
#' iterators::nextElem(it) # c(2, 4)
#' iterators::nextElem(it) # c(3, 4)
#'
#' # Combinations without replacement
#' it <- icombinations(1:4, m=2, replacement=TRUE)
#'
#' iterators::nextElem(it) # c(1, 1)
#' iterators::nextElem(it) # c(1, 2)
#' iterators::nextElem(it) # c(1, 3)
#' iterators::nextElem(it) # c(1, 4)
#' iterators::nextElem(it) # c(2, 2)
#' iterators::nextElem(it) # c(2, 3)
#' iterators::nextElem(it) # c(2, 4)
#' iterators::nextElem(it) # c(3, 3)
#' iterators::nextElem(it) # c(3, 4)
#' iterators::nextElem(it) # c(4, 4)
#'
#' it3 <- icombinations(1:5, m=2)
#' as.list(it3)
#' utils::combn(x=1:5, m=2, simplify=FALSE)
#'
icombinations <- function(object, m, replacement=FALSE) {
  object <- as.vector(object)
  n <- length(object)
  m <- as.integer(m)

  # Traverses through all the permutations of object.
  # If the indices are sorted, then return the element.
  # This approach is similar to how Python's itertools works
  if (!replacement) {
    # Combinations without replacement
    iter_object <- itertools2::ipermutations(object, m=m)
  } else {
    # Combinations with replacement
    replicate_n <- replicate(n=m, seq_len(n), simplify=FALSE)
    iter_object <- do.call(itertools2::iproduct, replicate_n)
  }

  nextElem <- function() {
    repeat {
      indices <- unlist(iterators::nextElem(iter_object))
      if (all(sort(indices) == indices)) {
        return(object[indices])
      }
    }
  }

  it <- list(nextElem=nextElem)
  class(it) <- c("abstractiter", "iter")
  it
}


## We'll be doing these checks a lot, so let's make a function
check.sampler.graph <- function(true.values, estimated.values,
                                desc, ylab, col) {
        par(mfrow=c(1,2))
        plot( true.values, estimated.values,
              xlab='True values', ylab=ylab,
              main=paste('Parameter recovery:',desc),
              col=col)
        abline(0,1)

        plot( ecdf( true.values ), xlab=deparse(substitute(true.values)),
              main=paste('Empirical CDFs:',desc) )
        plot( ecdf( estimated.values ), col=col, lty='dashed', add=TRUE )
        legend( 'topleft', c('True values', ylab), col=c('black', col),
                lty=c('solid','dashed'), bg='white')
        ## Add in the KS test
        legend(
                'bottomright',
                paste("Kolmogorov-Smirnov p value:",
                      round( ks.test( true.values, estimated.values )$p.value, 2)),
                bg='white')
        par(mfrow=c(1,1))
}

check.sigma <- function( mcmc.conv , xylim) {
        par(mfrow=c(1,2))

        traceplot(mcmc.conv[, 'sigma.theta'],
                  smooth=TRUE, ylim=xylim,
                  main='Trace plot sig2.theta')
        abline(h=sig2.theta , col='blue')

        densplot( mcmc.conv[, 'sigma.theta'],
                  main='Density plot sig2.theta',
                  xlab='sig2.theta', xlim=xylim)
        abline(v=sig2.theta , col='blue')
        abline(v=var(theta.abl), col='purple')

        legend( "topright",
                c('true value','var(theta.abl)'),
                col=c('blue', 'purple'),
                lty='solid')
}


# list of the vectors by inserting x in s at position 0...end.
linsert <- function(x,s) lapply(0:length(s), function(k) append(s,x,k))

# list of all permutations of 1:n
perm <- function(n){
    if (n == 1) list(1)
    else unlist(lapply(perm(n-1), function(s) linsert(n,s)),
                recursive = F)}

# permutations of a vector s
permutation <- function(s) unique(lapply(perm(length(s)), function(i) s[i]))


weather <- read.table(text="
      outlook temperature humidity   wind play
   1    sunny         hot     high normal   no
   2    sunny         hot     high   high   no
   3 overcast         hot     high normal  yes
   4    rainy        mild     high normal  yes
   5    rainy        cold   normal normal  yes
   6    rainy        cold   normal   high   no
   7 overcast        cold   normal   high  yes
   8    sunny        mild     high normal   no
   9    sunny        cold   normal normal  yes
  10   rainy        mild   normal normal  yes
  11    sunny        mild   normal   high  yes
  12 overcast        mild     high   high  yes
  13 overcast         hot   normal normal  yes
  14    rainy        mild     high   high   no")

weatherc <- read.table(text="
      outlook temperature humidity   wind play
   1     sunny          27       80 normal   no
   2     sunny          28       65   high   no
   3  overcast          29       90 normal  yes
   4     rainy          21       75 normal  yes
   5     rainy          17       40 normal  yes
   6     rainy          15       25   high   no
   7  overcast          19       50   high  yes
   8     sunny          22       95 normal   no
   9     sunny          18       45 normal  yes
  10     rainy          23       30 normal  yes
  11     sunny          24       55   high  yes
  12  overcast          25       70   high  yes
  13  overcast          30       35 normal  yes
  14     rainy          26       85   high   no")
summary(weatherc)

weatherr <- read.table(text="
       outlook temperature humidity   wind playability
   1     sunny          27       80 normal        0.48
   2     sunny          28       65   high        0.46
   3  overcast          29       90 normal        0.68
   4     rainy          21       75 normal        0.52
   5     rainy          17       40 normal        0.54
   6     rainy          15       25   high        0.47
   7  overcast          19       50   high        0.74
   8     sunny          22       95 normal        0.49
   9     sunny          18       45 normal        0.64
  10     rainy          23       30 normal        0.55
  11     sunny          24       55   high        0.57
  12  overcast          25       70   high        0.68
  13  overcast          30       35 normal        0.79
  14     rainy          26       85   high        0.33")
summary(weatherr)
weathercl <- weatherc[,-5]

install.packages("/home/users/chojnar1/Desktop/STUD/MOW/Book/Packages/dmr.data_1.0.tar.gz")

data(weather, package="dmr.data")
data(weatherc, package="dmr.data")
data(weatherr, package="dmr.data")

# mean calculation
bs.mean <- function(v) {sum(v)/length(v)}

# my variant
bs.mean(weatherc$temperature)
# typical approach
mean(weatherc$temperature)

bs.weighted.mean <- function(v, w=rep(1, length(v))) { sum(w*v)/sum(w) }
# demonstration
bs.weighted.mean(weatherc$temperature, ifelse(weatherc$play=="yes",5,1))
weighted.mean(weatherc$temperature, ifelse(weatherc$play=="yes",5,1))

# Median - notice that k1 and k2 are equal if m (the dataset size) is odd.
bs.median <- function(v)
{
  k1 <- (m <- length(v))%/%2+1
  k2 <- (m+1)%/%2
  ((v <- sort(v))[k1]+v[k2])/2
}

# demonstration
bs.median(weatherc$temperature)
bs.median(weatherc$temperature[weatherc$play=="yes"])
median(weatherc$temperature)
median(weatherc$temperature[weatherc$play=="yes"])

#The rank of instance x with respect
#to attribute a on dataset S,
#is the ordinal number of x
#after sorting S nondecreasingly by a

#The R code presented below implements and demonstrates weighted median calculation.
#Since there is no equivalent standard R function, the results are verified by applying
#the median function to appropriately resampled data, simulating the effect of weighting.
#The shift.right utility function is used to shift the cumulative weight sum to the right.

weighted.median <- function(v, w=rep(1, length(v)))
{
  v <- v[ord <- order(v)]
  w <- w[ord]
  tw <- (sw <- cumsum(w))[length(sw)]
  mean(v[which(sw>=0.5*tw & tw-shift.right(sw, 0)>=0.5*tw)])
}

  # demonstration
weighted.median(weatherc$temperature, ifelse(weatherc$play=="yes", 5, 1))
median(c(weatherc$temperature[weatherc$play=="no"],
         rep(weatherc$temperature[weatherc$play=="yes"], 5)))
weighted.median(weatherc$temperature, ifelse(weatherc$play=="yes", 0.2, 1))
median(c(weatherc$temperature[weatherc$play=="yes"],
         rep(weatherc$temperature[weatherc$play=="no"], 5)))

#Rank calculation is implemented and demonstrated by the following R code
bs.rank <- function(v)
{
  r.min <- match(v, sort(v))
  r.max <- length(v)+1-match(v, rev(sort(v)))
  (r.min+r.max)/2
}

#demonstration
print(weatherr$playability)
bs.rank(weatherr$playability)
rank(weatherr$playability)

#Order statistics can be though of as an inverse of ranks
#The order statistic of attribute a is the attribute's value
#for the instance that has rank k with respect to a under
#ordinal ranking

#The R code presented below implements and demonstrates order statistic calculation
ord <- function(v, k=1:length(v))
{
  sort(v)[k]
}

# demonstration
ord(weatherr$playability, 11)
weatherr$playability[rank(weatherr$playability, ties.method="first")==11]
ord(weatherr$playability, 10:13)
weatherr$playability[rank(weatherr$playability, ties.method="first") %in% 10:13]

#Simplified reimplementation of the standard quantile
#function and demonstrates its usage

bs.quantile <- function(v, p=c(0, 0.25, 0.5, 0.75, 1))
{
  b <- 1-p
  k <- floor((ps <- p*length(v))+b)
  beta <- ps+b-k
  `names<-`((1-beta)*(v <- sort(v))[k]+beta*(ifelse(k<length(v), v[k+1], v[k])), p)
}

# demonstration
bs.quantile(weatherc$temperature)
quantile(weatherc$temperature)
bs.quantile(weatherc$temperature[weatherc$play=="yes"])
quantile(weatherc$temperature[weatherc$play=="yes"])

bs.var <- function(v) { sum((v-mean(v))^2)/(length(v)-1) }

  # demonstration
bs.var(weatherr$playability)
var(weatherr$playability)

#Standard deviation calculation is implemented and demonstrated by the following R code
bs.sd <- function(v) { sqrt(sum((v-mean(v))^2)/(length(v)-1)) }

# demonstration
bs.sd(weatherr$playability)
sd(weatherr$playability)

#calcvarcoef(weatherr$playability)ulatng and using the coefficient of variation
varcoef <- function(v) { sqrt(sum((v-(m <- mean(v)))^2)/(length(v)-1))/m }
varcoef(weatherr$playability)
varcoef(-weatherr$playability)

#single attribute value probability estimation
prob <- function(v, v1) { sum(v==v1)/length(v) }
  # demonstration
prob(weather$outlook, "rainy")

#full discrete probability distribution estimation for one or more attributes
#This is usually more convenient than estimating probabilities for a
#single value or value combination at a time
pdisc <- function(v, ...) { (count <- table(v, ..., dnn=NULL))/sum(count) }
# demonstration
pdisc(weather$outlook)
pdisc(weather$outlook, weather$temperature)


# Prof. Héctor Bahamonde.
# Ayudante: Gonzalo Barría.
# Fecha entrega: una semana de plazo desde su fecha de publicacion en uCampus (Tareas).

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

options(scipen = 100000)
# Carga la base "anscombe"
library(datasets)
data(anscombe)
# Carga la base "dat"
library(foreign)
dat = read.csv("https://github.com/hbahamonde/OLS/raw/master/Datasets/saurus.csv", header=F)

# En este ej tendras la oportunidad de trabajar en dos bases de datos ("anscombe" y "dat"). Armado/a con todo lo que tengas para analizar un modelo, quiero que veas si los cinco modelos que estimaras cumplen con los supuestos de la regresion lineal (Gauss-Markov).

# Usa todas las herramientas que TU creas convenientes!

# Interpreta los cinco modelos. Y despues, por cada uno de los modelos, deberas responder las siguientes preguntas.

# a. El error tiene promedio cero?
# b. El error tiene varianza constante?
# c. El error no esta correlacionado?
# d. El error esta normalmente distribiuido?
# e. Las X's no son invariables, es decir, las X's son variables, no constantes?

# 1. Modelos

### 1.1 Usando la base "anscombe", estima los siguientes modelos usando el comando "lm"
## modelo.1 = y1 ~ x1
modelo.1 = lm(y1 ~ x1, anscombe)
## modelo.2 = y2 ~ x1
modelo.2 = lm(y2 ~ x1, anscombe)
## modelo.3 = y3 ~ x1
modelo.3 = lm(y3 ~ x1, anscombe)
## modelo.4 = y4 ~ x4
modelo.4 = lm(y4 ~ x4, anscombe)

### 1.2 Usando la base "dat", estima el siguientee modelo usando el comando "lm"
## modelo.5 = V2 ~ V1
modelo.5 = lm(V2 ~ V1, dat)

# 2. Muestra tus resultados en una tabla.
library(texreg)
screenreg(list(modelo.1, modelo.2, modelo.3, modelo.4, modelo.5))

# 3. Post-estimation checklist:
# 3.1 El error tiene promedio cero?
mean(modelo.1$residuals) # si.
mean(modelo.2$residuals) # si.
mean(modelo.3$residuals) # si.
mean(modelo.4$residuals) # si.
mean(modelo.5$residuals) # si.

# El estudiante no solo debe concluir que el promedio es cero usando la funcion "mean" (o "summary"). Tambien debe plotear los errores. Puntos extra si el estudiante considera plotear la linea.
plot(modelo.1$fitted.values, modelo.1$residuals)
plot(modelo.2$fitted.values, modelo.2$residuals)
plot(modelo.3$fitted.values, modelo.3$residuals)
plot(modelo.4$fitted.values, modelo.4$residuals)
plot(modelo.5$fitted.values, modelo.5$residuals)

# 3.2 El error tiene varianza constante?
## Segun los graficos, debe concluir que NO tiene varianza constante.

# Otra manera es la siguiente. Sin embargo, la evidencia aqui no es conclusiva.
library(car)
crPlot(modelo.1, "x1")
crPlot(modelo.2, "x1")
crPlot(modelo.3, "x1")
crPlot(modelo.4, "x4")
crPlot(modelo.5, "V1")

# 3.3 El error no esta correlacionado?
## Segun los graficos debe concluir que claramente estan correlacionados (porque hay un patro).

# 3.4 El error esta normalmente distribiuido?
## Segun los graficos debe concluir que claramente NO estan normaomente distribuidos.

# 3.5 Las X's no son invariables, es decir, las X's son variables, no constantes?
## Las X's si varian.

# Puntos extra si el/la estudiante comprende que debe SIEMPRE plotear los residuos y las variables a regresar. No basta con correr "mean" (porque aunque de 0, siempre puede existir la posibilidad de que igual haya un patron, como es este el caso).
plot(y1 ~ x1, anscombe)
plot(y2 ~ x1, anscombe)
plot(y3 ~ x1, anscombe)
plot(y4 ~ x4, anscombe)
plot(V2 ~ V1, dat)


library(modreg) ##this is where loess is defined for R
CD4.data <- read.table("Data/cd4.data",
		       col.names=c("Time","CD4","Age","Packs",
			 "Drugs","Sex","Cesd","ID")) #READ IN DATA
attach(CD4.data) ##attach data frame, now you can use just the names

##three plots are exactly the same except for the degrees used.
postscript("Plots/plot-03-01.ps",horizontal=F)
o <- order(Time)
spans <-c(.05,.25,.75,.95)
par(mfrow=c(2,2),err=-1,oma=c(0,0,3,0)) ##err=-1 so that we get no warnings
sapply(spans,function(span){
  plot(Time,CD4,pch=".",xlab="Time since zeroconversion",ylab="CD4",main=paste("span =",span),ylim=c(0,1500))##plots CD4 vs. Time
  lines(Time[o],loess(CD4[o]~Time[o],span=span,degree=1)$fitted,col=4,lwd=2)
  })
mtext(side=3,"Degree=1",outer=T,cex=1.3,line=0)
dev.off()

postscript("Plots/plot-03-02.ps",horizontal=F)
o <- order(Time)
spans <-c(.05,.25,.75,.95)
par(mfrow=c(2,2),err=-1,oma=c(0,0,3,0)) ##err=-1 so that we get no warnings
sapply(spans,function(span){
  plot(Time,CD4,pch=".",xlab="Time since zeroconversion",ylab="CD4",main=paste("span =",span),ylim=c(0,1500))##plots CD4 vs. Time
  lines(Time[o],loess(CD4[o]~Time[o],span=span,degree=2)$fitted,col=4,lwd=2)
  })
mtext(side=3,"Degree=2, the default",outer=T,cex=1.3,line=0)
dev.off()

postscript("Plots/plot-03-03.ps",horizontal=F)
o <- order(Time)
spans <-c(.05,.25,.75,.95)
par(mfrow=c(2,2),err=-1,oma=c(0,0,3,0)) ##err=-1 so that we get no warnings
sapply(spans,function(span){
  plot(Time,CD4,pch=".",xlab="Time since zeroconversion",ylab="CD4",main=paste("span =",span),ylim=c(0,1500))##plots CD4 vs. Time
  lines(Time[o],loess(CD4[o]~Time[o],span=span,degree=0)$fitted,col=4,lwd=2)
  })
mtext(side=3,"Degree=0",outer=T,cex=1.3,line=0)
dev.off()
detach("CD4.data")

Array <- read.table("Data/microarray.dat",col.names=c("X","Y"))
attach(Array)

SPAN <- 2/3
postscript("Plots/plot-03-04.ps",horizontal=T)
par(mfrow=c(1,1))
plot(X*Y,Y/X,log="xy",pch=".")
junk <- loess(log(Y/X)~log(X*Y),span=SPAN,family="gaussian",degree=2)$fitted
o <- order(X*Y)
lines((X*Y)[o],exp(junk[o]),lwd=2,lty=2,col=3)
junk <- loess(log(Y/X)~log(X*Y),span=SPAN,family="symmetric",degree=2)$fitted
lines((X*Y)[o],exp(junk[o]),lwd=2,lty=3,col=4)
legend(10^6,0.8,c("gaussian","symmetric"),lty=c(2,3),col=c(3,4))
dev.off()

detach("Array")

diabetes <- read.table("Data/diabetes.dat",header=T)
attach(diabetes)
fit1 <- lm(log(C.Peptide)~Age+Base.Deficit)
fit2 <- loess(log(C.Peptide)~Age*Base.Deficit)

postscript("Plots/plot-03-05.ps",horizontal=F)
par(mfrow=c(1,1),mai=c(0,0,0,0))
newAge <- seq(min(Age),max(Age),len=40)
newBase <- seq(min(Base.Deficit),max(Base.Deficit),len=40)
newcov <- expand.grid(Age=newAge,Base.Deficit=newBase)
surf <- matrix(predict(fit2,newcov),40,40)
persp(newAge,newBase,surf,xlab="Age",ylab="Base Deficit",zlab="Predicted",theta=-35,phi=30,shade=.35,col=5)
dev.off()
detach(diabetes)


##' @title
##' Brier score
##'
##'
##' @description
##'
##' Brier score measures the accuracy of probabilistic predictions; the smaller
##' the Brier score, the better. The Brier score always takes on a value between
##' zero and one.
##'
##' Given N predictions, the Brier score is defined by the mean squared
##' difference between (1) the estimated probability assigned to the possible
##' outcome and (2) the actual outcome.
##'
##' Here is a few examples that help the interpretation of Brier score.
##'
##' Suppose that one is forecasting the probability P that it will rain on a
##' given day. Then the Brier score is calculated as follows:
##'
##' \itemize{
##'
##'   \item If the forecast is 100\% (P = 1) and it rains, then the Brier Score
##'   is 0, the best score achievable.
##'
##'   \item If the forecast is 100\% and it does not rain, then the Brier Score
##'   is 1, the worst score achievable.
##'
##'   \item If the forecast is 70\% (P = 0.70) and it rains, then the Brier Score
##'   is (0.70 − 1)^2 = 0.09.
##'
##'   \item If the forecast is 30\% (P = 0.30) and it rains, then the Brier Score
##'   is (0.30 − 1)^2 = 0.49.
##'
##' }
##'
##'
##'
##' @param actual \code{[numeric]} Ground truth binary numeric vector containing
##'     1 for the positive class and 0 for the negative class.
##' @param predicted \code{[numeric]} A vector of estimated probabilities.
##' @return A scalar numeric output
##' @author An Chu
##' @include helper-functions.r
##' @seealso \code{\link{mtr_log_loss}} \code{\link{mtr_mean_log_loss}}
##' @examples
##'
##' act <- c(0, 1, 1, 0)
##' pred <- c(0.1, 0.9, 0.8, 0.3)
##' mtr_brier_score(act, pred)
##'
##' @export
mtr_brier_score <- function(actual, predicted) {

    check_equal_length(actual, predicted)
    check_binary(actual)

    if (max(predicted) > 1) {
        stop("`predicted` cannot contain values greater than 1.", call. = FALSE)
    }

    if (min(predicted) < 0) {
        stop("`predicted` cannot contain values less than 0.", call. = FALSE)
    }

    n <- length(predicted)
    brier_score <- sum((actual - predicted)^2) / n

    brier_score
}


library(ggplot2)
hist(diamonds$carat, main="Carat Histogram", xlab="carat")
plot(diamonds$carat, diamonds$price)
plot(price ~ carat, data=diamonds)
boxplot(diamonds$carat)

#ggplot2

#histogram
ggplot(data=diamonds)+geom_histogram(aes(x=carat))
ggplot(data=diamonds)+geom_histogram(aes(x=carat), binwidth=.1)

#density
ggplot(data=diamonds)+geom_density(aes(x=carat))
ggplot(data=diamonds)+geom_density(aes(x=carat), fill="grey50")

#scatterplot
ggplot(diamonds, aes(x=carat, y=price))+geom_point()
g <- ggplot(diamonds, aes(x=carat, y=price))
g + geom_point()
g + geom_point(aes(color=color))
g + geom_point(aes(color=color, shape=clarity))
g + geom_point(aes(color=color, shape=cut))

ggplot(diamonds, aes(y=carat,x=1))+geom_boxplot()
ggplot(diamonds, aes(y=carat,x=cut))+geom_boxplot()
ggplot(diamonds, aes(y=carat,x=cut))+geom_violin()

g <- ggplot(diamonds, aes(y=carat,x=cut))
g + geom_point() + geom_violin()
g + geom_violin() + geom_point()
g + geom_jitter() + geom_violin()

#line plots
head(economics)
ggplot(economics, aes(x=date, y=pop)) + geom_line()

library(lubridate)
economics$year <- year(economics$date)
economics$month <- month(economics$date)
head(economics)
econ2000 <- economics[which(economics$year >= 2000),]
nrow(economics)
nrow(econ2000)
econ2000$month <- month(econ2000$date, label = TRUE)

library(scales)
g <- ggplot(econ2000, aes(x=month, y=pop))
g <- g + geom_line(aes(color=factor(year), group=year))
g <- g + scale_color_discrete(name="Year")
g <- g + scale_y_continuous(labels=comma)
g <- g + labs(title = "Population Growth", x="Month", y="Population")
g <- g + theme(axis.text.x=element_text(angle=90, hjust=1))
g

#small multiples
#faceting
g <- ggplot(diamonds, aes(x=carat, y=price))
g + geom_point(aes(color=color)) + facet_wrap(~color)
g + geom_point(aes(color=color)) + facet_grid(cut~clarity)
ggplot(diamonds, aes(x=carat)) + geom_histogram() + facet_wrap(~color)

#control colors and shapes
ggplot(diamonds, aes(x=carat, y=price, color=color, shape=cut, size=depth)) + geom_point()

#ggplot Themes
library(ggthemes)
g <- ggplot(diamonds, aes(x=carat, y=price, color=color)) + geom_point()
g
g + theme_wsj()
g + theme_economist() + scale_color_economist()
g + theme_tufte()
g + theme_excel() + scale_color_excel()
g + theme_fivethirtyeight()


qqplot_dlh <- function(x, dist, suppress='yes') {

    ## grab name of variable passed in as x
    xlabel <- deparse(substitute(x))

    ## first sort x so it increases
##    x <- sort(x)
    good <- !is.na(x)
    ord  <- order(x[good])
    x    <- x[good][ord]

    ## determine quantiles for data
    num  <- length(x)
    P    <- ppoints(num)
    if (dist == 'normal') {
        quantiles <- qnorm(P, mean = mean(x), sd = sd(x))

    } else if (dist == 'weibull') {
        ## mass::fitdistr
        ## Distributions "beta", "cauchy", "chi-squared", "exponential", "gamma", "geometric",
        ##               "log-normal", "lognormal", "logistic", "negative binomial", "normal",
        ##               "Poisson", "t" and "weibull" are recognised, case being ignored.
        out <- MASS::fitdistr(x, densfun = 'weibull')
        shape    <- out$estimate[[1]]
        scale    <- out$estimate[[2]]
        quantiles <- qweibull(P, shape = shape, scale = scale)

    } else if (dist == 'johnson') {
        library(SuppDists) # need for Johnson distribution
        jparms    <- SuppDists::JohnsonFit(x)
        quantiles <- SuppDists::qJohnson(P, jparms)

    }

    ylabel <- paste('Quantiles for', dist, 'distribution', sep=' ')
    ## plot data vs. quantiles
    ## df <- data.frame(x, quantiles)
    ## plotfit(df, x, quantiles,
    ##         main   = paste('QQ Plot for', xlabel, sep=' '),
    ##         xlabel = xlabel,
    ##         ylabel = ylabel,
    ##         interval='conf', alpha=0.05, sided=2,  # confidence intervals are wrong
    ##         suppress=suppress)
    plot(x, quantiles,
         main = paste('QQ Plot for', xlabel, sep=' '),
         xlab = xlabel,
         ylab = ylabel)
    abline(a=0, b=1, col='red')  # theoretical line fit

    ##    ## students-t for dataset
    ##    num <- length(x)
    ##    conf <- 0.05
    ##    t  <- qt(1-conf/2, num-1)
    ##    uncert    <- t * sd(x) / sqrt(num)

    ##    ## confidence limits for plot
    ##    ## following makes confidence limits but they do not match standard R and following is only for normal
    ##    ## https://stats.stackexchange.com/questions/111288/confidence-bands-for-qq-line
    ##    z    <- qnorm(P)
    ##    plot(z, x, type="p")
    ##    coef <- coef(rlm(x ~ z))
    ##    b    <- coef[1]
    ##    m    <- coef[2]
    ##    fit.value <- b + m*z
    ##    ## abline(b, m, col="red", lwd=1)
    ##    lines(z, fit.value, lty=1, lwd=1, col='red')
    ##    conf <- 0.95
    ##    zz   <- qnorm(1-(1-conf)/2)
    ##    SE   <- (m/dnorm(z))*sqrt(P*(1-P)/num)     #[WHY?]
    ##    upper <- fit.value+zz*SE
    ##    lower <- fit.value-zz*SE
    ##    lines(z,upper, lty=2, lwd=1, col="red")
    ##    lines(z,lower, lty=2, lwd=1, col="red")

    ## lines(x, lquant, col='black', lty='dashed')  # lower confidence line
    ## lines(x, uquant, col='black', lty='dashed')  # upper confidence line

}

qqplot_dlh_test <- function() {
    ## test qqplot_dlh against qualityTools::qqplot

    plotspace(2,2)

    ## normal distribution plots
    set.seed(1)
    x <- rnorm(n=1E2, mean=10, sd=1)
    qualityTools::qqPlot(x, "normal",  col='black')
    qqplot_dlh(x, 'normal')

    ## Weibull distribution plots
    set.seed(1)
    x <- rweibull(1E2, shape=10, scale=2)
    qualityTools::qqPlot(x, "Weibull", col='black')
    qqplot_dlh(x, 'weibull')

}


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

# Funkcja Eggholder function
func3d <- function(x, y)
{
  -(x+47)*sin(sqrt(abs(x/2+(y+47))))-x*sin(sqrt(abs(x-(y+47))))
}
lbound <- -512
rbound <- 512

x <- y <- seq(lbound, rbound, by=2) # generowanie wektorów od lbound to rbound co 0.1
f <- outer(x, y, func3d)
persp3D(x, y, f, theta = 50, phi = 20, col.palette = bl2gr.colors) # Perspektywa 3D funkcji

filled.contour(x, y, f, color.palette = bl2gr.colors) # Rzut z góry wykresu funkcji

fA <- function(x) -func3d(x[1], x[2])

GA <- ga(
  type = "real-valued",
  fitness = function(x) -func3d(x[1], x[2]), # (minus) - minimalizacja funkcji 3D
  lower = c(lbound, lbound), upper = c(rbound, rbound),
  popSize = 50, maxiter = 1000, run = 100
)
summary (GA)
plot(GA)

filled.contour(
  x, y, f,
  color.palette = bl2gr.colors,
  plot.axes = {
    axis(1); axis(2);
    points(
      GA@solution[,1], GA@solution[,2],
      pch = 3, cex = 2, col = "white", lwd = 2
    )
  }
)


# wahpenayo at gmail dot com
# 2018-04-16
#-----------------------------------------------------------------
if (file.exists('e:/porta/projects/taiga')) {
  setwd('e:/porta/projects/taiga')
} else {
  setwd('c:/porta/projects/taiga')
}
#source('src/scripts/r/functions.r')
#-----------------------------------------------------------------
library(quantreg)
#example(rq)
#-----------------------------------------------------------------
fit.summary <- function(y,yhat,p=0.75) {
  n <- length(yhat)
  r <- y -yhat
  rmean <- mean(r)
  rmse <- sqrt(sum(r*r/n))
  rmad <- sum(abs(r))/n
  rqr <- 2.0*sum(ifelse(r>=0,p*r,(p-1)*r))/n
  qrq <- 0.5*sum(ifelse(r>=0,r/(1-p),-r/p))/n
  list(rmean=rmean,rmse=rmse,rmad=rmad,rqr=rqr,qrq=qrq)
}
#-----------------------------------------------------------------
data(engel)
y <- engel$foodexp
x <- data.frame(income=engel$income)

affine.l2 <- lm(foodexp~income,data=engel)
yhat <- predict(affine.l2,newdata=x)
print("l2 affine")
print(affine.l2,digits=16)
print(fit.summary(y,yhat),digits=16)

affine.q50 <- rq(foodexp~income,data=engel,tau=0.5)
yhat <- predict(affine.q50,newdata=x)
print("q50 affine")
print(affine.q50,digits=16)
print(fit.summary(y=y,yhat=yhat),digits=16)

affine.q75 <- rq(foodexp~income,data=engel,tau=0.75)
yhat <- predict(affine.q75,newdata=x)
print("q75 affine")
print(affine.q75,digits=16)
print(fit.summary(y=y,yhat=yhat),digits=16)

linear.l2 <- lm(foodexp~income - 1,data=engel)
yhat <- predict(linear.l2,newdata=x)
print("l2 linear")
print(linear.l2,digits=16)
print(fit.summary(y,yhat),digits=16)

linear.q50 <- rq(foodexp~income - 1,data=engel,tau=0.5)
yhat <- predict(linear.q50,newdata=x)
print("q50 linear")
print(linear.q50,digits=16)
print(fit.summary(y,yhat),digits=16)

linear.q75 <- rq(foodexp~income - 1,data=engel,tau=0.75)
yhat <- predict(linear.q75,newdata=x)
print("q75 linear")
print(linear.q75,digits=16)
print(fit.summary(y,yhat),digits=16)

yhat <- rep_len(median(y),length(y))
print("q50 constant")
print(yhat[1],digits=16)
print(fit.summary(y,yhat),digits=16)

yhat <- rep_len(quantile(x=y,probs=0.75),length(y))
print("q75 constant")
print(yhat[1],digits=16)
print(fit.summary(y,yhat),digits=16)

yhat <- rep_len(mean(y),length(y))
print("l2 constant")
print(yhat[1],digits=16)
print(fit.summary(y,yhat),digits=16)
#-----------------------------------------------------------------
data(stackloss)
yx <- data.frame(
  stackloss=stackloss$stack.loss,
  acidconc=stackloss$Acid.Conc.,
  airflow=stackloss$Air.Flow,
  watertemp=stackloss$Water.Temp)
y <- yx$stackloss
x <- data.frame(
  acidconc=yx$acidconc,
  airflow=yx$airflow,
  watertemp=yx$watertemp)

affine.l2 <- lm(stackloss~acidconc+airflow+watertemp,data=yx)
yhat <- predict(affine.l2,newdata=x)
print("l2 affine")
print(affine.l2,digits=16)
print(fit.summary(y,yhat),digits=16)

affine.q50 <- rq(stackloss~acidconc+airflow+watertemp,data=yx,tau=0.5)
yhat <- predict(affine.q50,newdata=x)
print("q50 affine")
print(affine.q50,digits=16)
print(fit.summary(y=y,yhat=yhat),digits=16)

affine.q75 <- rq(stackloss~acidconc+airflow+watertemp,data=yx,tau=0.75)
yhat <- predict(affine.q75,newdata=x)
print("q75 affine")
print(affine.q75,digits=16)
print(fit.summary(y=y,yhat=yhat),digits=16)

linear.l2 <- lm(stackloss~acidconc+airflow+watertemp - 1,data=yx)
yhat <- predict(linear.l2,newdata=x)
print("l2 linear")
print(linear.l2,digits=16)
print(fit.summary(y,yhat),digits=16)

linear.q50 <- rq(stackloss~acidconc+airflow+watertemp - 1,data=yx,tau=0.5)
yhat <- predict(linear.q50,newdata=x)
print("q50 linear")
print(linear.q50,digits=16)
print(fit.summary(y,yhat),digits=16)

linear.q75 <- rq(stackloss~acidconc+airflow+watertemp - 1,data=yx,tau=0.75)
yhat <- predict(linear.q75,newdata=x)
print("q75 linear")
print(linear.q75,digits=16)
print(fit.summary(y,yhat),digits=16)

yhat <- rep_len(mean(y),length(y))
print("l2 constant")
print(yhat[1],digits=16)
print(fit.summary(y,yhat),digits=16)

yhat <- rep_len(median(y),length(y))
print("q50 constant")
print(yhat[1],digits=16)
print(fit.summary(y,yhat),digits=16)

yhat <- rep_len(quantile(x=y,probs=0.75),length(y))
print("q75 constant")
print(yhat[1],digits=16)
print(fit.summary(y,yhat),digits=16)
#-----------------------------------------------------------------


rm(list=ls())

library('radolc')

#--- testing ADOLC's jacobian

fr <- function(x) {
  x1 <- x[[1]]
  x2 <- x[[2]]
  #Use create list to create adouble objects
  y<-adolc_createList(2,2.0)
  #y <- c(0.0,0.0)
  y[[1]] <- 100 * (x2 - x1 * x1)* (x2 - x1 * x1) + (1 - x1)*(1 - x1)
  y[[2]] <- 100 * (x2 - x1 * x1)+ (x2 - x1 * x1) * (1 - x1)*(1 - x1)
  y[[3]] <- 100 * (x2 + x1 * x1)+ (x2 + x1 * x1) * (1 + x1)*(1 - x1)
  y}

trace_on(1)
x <- adolc_createList(2,2.0)
badouble_declareIndependent(x)
y <- fr(x)
badouble_declareDependent(y)
trace_off()

xx <- c(1.0,2.0)
vv <- c(3.0,5.5,1,1)
yy <- c(0.0,0.0)
vec_jac(1,3,2,0,xx,vv,yy);
# vec_jac(tag,m,n,repeat,x,u,z) #result z = u^TF′(x)
# tag: integer, tape identification
# m  : integer, number of dependents m
# n  : integer, number of independents n
#repeat: ID of tape to reuse. Leave at 0 for no repetition
# x[n]: independent vector x
# u[m]: vector
# z[n]: resulting Jacobian vector product

print(yy)

#Always detach the package
detach(package:radolc, unload=TRUE)


# Example : 2   Chapter : 7.3     Page No: 401
# Similar Projection Matrices
A<-matrix(c(0.5,-0.5,-0.5,0.5),ncol=2)
Aev<-eigen(A)$values
W<-matrix(c(2,0,1,1),ncol=2)
W1<-solve(W)
B<-W1%*%A%*%W
print("Matrix B = W-1 * A * W")
print(B)
Bev<-eigen(B)$values
print("A and B are similar matrices")
print(Aev)
print(Bev)


iris2 <- iris[,1:4]
kmeans.result <- kmeans(iris2,centers=3)
centers <- kmeans.result$centers[kmeans.result$cluster,]
distances <- sqrt(rowSums((iris2 - centers)^2))
outliers <- order(distances,decreasing = T)[1:5]
plot(iris2[,c("Sepal.Length","Sepal.Width")],pch="o",col=kmeans.result$cluster,cex=0.3)
points(kmeans.result$centers[,c("Sepal.Length","Sepal.Width")],col=1:3,pch=8,cex=1.5)
points(iris2[outliers, c("Sepal.Length","Sepal.Width")],pch="+",col=4,cex=1.5)


## 1. Introduction ##

library(readr)
# Heads up that the following instruction can generate a column specification warnings, you can ignore that.
# These warnings are related to that `readr` has misguidedly guessed the type of values in the column `Pool QC`.
# To avoid this warning we can manually specify the type of this column the `col_types` parameter.
houses  <-  read_tsv('AmesHousing_1.txt', col_types = cols(`Pool QC` = col_character()))

library(dplyr)
houses_per_year  <-  houses %>%
    mutate(Year = `Yr Sold`) %>%
    group_by(Year) %>%
    summarize(MeanPrice = mean(SalePrice),
              HousesSold = n() ) %>%
    arrange(HousesSold)
mean_new  <-  mean(houses_per_year$MeanPrice)
mean_original  <-  mean(houses$SalePrice)
difference  <-  mean_original - mean_new

## 2. Different Weights ##

houses_per_year  <- houses_per_year %>%
    mutate(sum_per_year = MeanPrice * HousesSold)

all_sums_together  <-  sum(houses_per_year$sum_per_year)
total_n_houses  <-  sum(houses_per_year$HousesSold)
weighted_mean  <-  all_sums_together / total_n_houses

mean_original  <-  mean(houses$SalePrice)

difference  <-  round(mean_original, digits = 10) - round(weighted_mean, digits = 10)

## 3. The Weighted Mean ##

compute_weighted_mean <- function(distribution, weights) {
    weighted_distribution  <-  distribution * weights
    sum(weighted_distribution) / sum(weights)
}

computed_weighted_mean  <-  compute_weighted_mean(houses_per_year$MeanPrice, houses_per_year$HousesSold)
weighted_mean_r  <-  weighted.mean(houses_per_year$MeanPrice, houses_per_year$HousesSold)

equal  <-  round(computed_weighted_mean, 10) == round(weighted_mean_r, 10)

## 5. The Median for Open-ended Distributions ##

distribution1  <-  c(23, 24, 22, '20 years or lower,', 23, 42, 35)
distribution2  <-  c(55, 38, 123, 40, 71)
distribution3  <-  c(45, 22, 7, '5 books or lower', 32, 65, '100 books or more')
median1  <-  23
median2  <-  55
median3  <-  32

## 6. Distributions with Even Number of Values ##

# Sort the values
rooms  <-  houses$`TotRms AbvGrd`
rooms  <-  as.numeric(stringr::str_replace(rooms, '10 or more', '10'))
rooms_sorted  <-  sort(rooms)

# Find the median
middle_indices  <-  c(length(rooms_sorted) / 2,
                      (length(rooms_sorted) / 2) + 1
                 ) # 2930 is even so we need two indices.
middle_values  <-  rooms_sorted[middle_indices]
median  <-  mean(middle_values)

## 8. Finding outliers using Boxplots ##

library(ggplot2)

ggplot(data = houses,
    aes(x = "", y = `Lot Area`)) +
    geom_boxplot() +
    xlab("Lot Area") +
    ylab("")

ggplot(data = houses,
    aes(x = "", y = SalePrice)) +
    geom_boxplot() +
    xlab("Sale Price") +
    ylab("")

lotarea_difference  <-  mean(houses$`Lot Area`) - median(houses$`Lot Area`)
saleprice_difference  <-  mean(houses$`SalePrice`) - median(houses$`SalePrice`)

## 9. The Median for Ordinal Scales ##

mean  <-  mean(houses$`Overall Cond`)
median  <-  median(houses$`Overall Cond`)

ggplot(data = houses, aes(x = `Overall Cond`)) +
    geom_histogram(bins = 9,
                   position = "identity",
                   alpha = 0.6,
                   fill='blue') +
    #geom_vline(xintercept = mean, color = 'red', size=1) +
    #geom_vline(xintercept = median, color = 'green', size=1) +
    xlab("Overall Cond") +
    ylab("Frequency")

more_representative  <-  'mean'

#Extra comment:
#The mean seems more representative and more informative because it captures the
#fact that there are more houses rated above 5 than rated under 5. Because of this,
#the mean is slightly shifted above 5.

Data Analyst in R/Step 5 - Probability and Statistics/2. Statistics Intermediate in R Averages and Variability/2. The Weighted Mean and the Median.r


sieve <- function(n) {
  if (n < 2) return(NULL)
  a <- rep(T, n)
  a[1] <- F
  for(i in seq(n)) {
    if (a[i]) {
      j <- i * i
      if (j > n) return(which(a))
      a[seq(j, n, by=i)] <- F
    }
  }
}

sieve(1000)


#' Calculate root-mean-square error metric
#'
#' @param true the true response values
#' @param pred the predicted response values
#' @export

rmse <- function (true, pred) {
  return(sqrt(mean((true - pred)^2)));
}

#' Calculate log-loss error metric
#'
#' @param true the true response values
#' @param pred the predicted response values
#' @param eps a lower bound on predicted probabilities
#' @export

logloss <- function (true, pred, eps=1e-15) {
  pred <- pmin(pmax(pred, eps), 1-eps);
  return(-mean(true * log(pred)) - mean((1 - true) * log(1 - pred)));
}

#' Calculate mean absolute error metric
#'
#' @param true the true response values
#' @param pred the predicted response values
#' @export

mae <- function (true, pred) {
  return(mean(abs(true - pred)));
}


# setup environment
library(tidyverse)

# load data
data("diamonds")

# histogram of diamond prices
ggplot(data = diamonds, aes(x = price, color = cut)) +
  geom_histogram() +
  facet_wrap( ~ color)

# scatterplot of diamond prices vs table
ggplot(data = diamonds, aes(x = table, y = price, color = cut)) +
  geom_point()

# scatterplot of diamond prices vs volume
diamonds_top99 <- subset(diamonds, price < quantile(diamonds$price, 0.99))

ggplot(data = diamonds_top99,
       aes(x = x*y*z,
           y = price,
           color = clarity)) +
  geom_point() +
  scale_x_log10()

# load pf data
pf <- read.delim("./lesson3/pseudo_facebook.tsv")

# create proportion of friendships initiated variable
pf$prob_initiated <- ifelse(
  is.nan(pf$friendships_initiated / pf$friend_count),
  0,
  pf$friendships_initiated / pf$friend_count)

# create year_joined.bucket variable
pf$year_joined <- floor(2014 - (pf$tenure / 365))
pf$year_joined.bucket <- cut(pf$year_joined, breaks = c(2004, 2009, 2011, 2012, 2014))

# line graph of median proportion of friendships initiated
ggplot(data = pf,
       aes(x = tenure, y = prob_initiated, color = year_joined.bucket)) +
  geom_line(stat = "summary", fun.y =  median) +
  geom_smooth(method = "lm")

# mean proportion of friendships initiated by > 2012 group
test <- subset(pf, year_joined > 2012)
mean(test$prob_initiated, na.rm = T)

# scatterplot of diamonds price/carat ratio
ggplot(data = diamonds,
       aes(x = cut,
           y = price/carat,
           color = color)) +
  geom_point() +
  facet_wrap(~ clarity)

# gapminder data


# Eilers and Marx (1996)
# code borrowed from http://bragqut.github.io/2016/05/24/samclifford-splines/index.html#disqus_thread

create.bspline <- function(x, K = nbasis, bdeg=degree, cyclic=FALSE, xl=min(x), xr=max(x)){
  x <- as.matrix(x,ncol=1)
  ndx <- K - bdeg

  # as outlined in Eilers and Marx (1996)
  dx <- (xr - xl) / ndx
  t <- xl + dx * (-bdeg:(ndx+bdeg))
  T <- (0 * x + 1) %*% t
  X <- x %*% (0 * t + 1)
  P <- (X - T) / dx
  B <- (T <= X) & (X < (T + dx))
  r <- c(2:length(t), 1)

  for (k in 1:bdeg){
    B <- (P * B + (k + 1 - P) * B[ ,r]) / k;
  }

  B <- B[,1:(ndx+bdeg)]

  if (cyclic == 1){
    for (i in 1:bdeg){
      B[ ,i] <- B[ ,i] + B[ ,K-bdeg+i]
    }
    B <- B[ , 1:(K-bdeg)]
  }

  return(B)
}


#X = X1,..Xn - експериментално получени случайни величини
#математическо очакване Е(X) = mean(X) (mu)
#дисперсия D(X) = var(x)  (sigma^2)
#стандартно отклонение s = sd(x)  (sigma)
x = c(74, 122, 235, 111, 292, 111, 211, 133, 156, 79)
mean(x) #очакване
var(x) #дисперсия
sd(x) #стандартно отклонение

#централна гранична теорема - когато имаме много независими еднакво разпределенислучайни величини X1,..Xn, то сумата им след нориране е стандартна нормално разпределена велинина
#Y = ( sum(Xi) - E(sum(Xi)) ) / sqrt( D(sum(xi)) ) e стандартно нормално разпределена случайна величина
#E(sum(Xi)) = sum(EXi)  -> очакването на сума е сума от очакванията
#D(sum(Xi)) = sum(DXi)  -> дисперсия на сума е сума от дисперсиите

#твърдение: Xi = N(mu, sigma^2) - Xi случайни нормално разпределени величини с очакване mu и дисперсия sigma^2
#Xn.cherta = N(mu, (sigma^2)/n ) -> Xn.cherta = sum(Xi)/n -> статистическо средно e нормално разпределено с очакване mu и дисперсия (sigma^2)/n

#хи-квадрат разпределение
#Y1,..,Yn стандартно нормално разпределени случайни величини N(0,1)
#X^2(r) = sum(Yi^2) e хи-квадрат разпределение с r степени на свобода
#функцията chisq() с префикси d,p,q,r за съответно плътност, разпределние, квантил и случайно разпределение(симулиране)

#t-разпределение
#X = X1,...,Xn n независими измервания Xi, очакване mu, извадково средно mean(x), oценка за стандартно отклонение sd(x) и неизвестно sigma
#най-добрата оценка за неизвестното sigma се дава с t-разпределение с n-1 степени на свобода
#функцията t() с префикси d,p,q,r за съответно плътност, разпределние, квантил и случайно разпределение(симулиране)

#f-разпределение - непрекъснато статистическо разпределение, получено от отношението на две хи-квадрат разпределения
#Fn,m = (X^2(n)/n) / (X^2(m)/m)
#тества дали две извадки имат еднаква дисперсия
#функцията f() с префикси d,p,q,r за съответно плътност, разпределние, квантил и случайно разпределение(симулиране)

#доверителен интервал
#имаме случайна величина X, която е с някакво разпределение, но не знаем някой параметър tita. Искаме да оценим този параметър tita с някаква вероятност на достоверност (gama = 1 - alpha). Тогава gama = 1 - alpha = P(-z* < tita < z*) -> от -z* до z* е  доверителния интервал
#нормално разпределение -> z*=qnorm(1-alpha / 2) (защото е симетрично)
#биномно разпределение, когато tita = p (не знаем каква е вероятността за успех) -> интервала е [p.shapka - z* SE, p.shapka + z* SE], където p.shapka е експериментално получената вероятност, SE = sqrt((1/n) * p.shapka * (1-p.shapka))
#биномно разпределение, когато tita = p1 - p2 (искаме да оценим разликата във вероятностите за две случайно разпределни величини с големина n и m) -> интервала е [tita - z* SE, tita + z* SE], където SE = sqrt( (p1*(1-p1)/n + (p2*(1-p2)/m ) )
#нормално разпределение, когато tita = mu (не знаем очакването, но знаем дисперсията) -> интервала е [x.cherta - z* sigma/sqrt(n), x.cherta + z* sigma/sqrt(n)], където x.cherta = sum(Xi)/n = mean(xi) (средно аритметично - експериментално очакване)
#нормално разпределение, когато tita = mu, sigma (не знаем нито очакването, нито дисперсията) -> интервала е [x.cherta - t* s/sqrt(n), x.cherta + t* s/sqrt(n)], където x.cherta = sum(Xi)/n = mean(xi), s = sd(Xi) (експериментално стандартно отклонение), t* = qt(1-alpha, df = n -1)квантил на t-разпределение с n-1 степени на свобода

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

#01
#x1=Bi(100,1/2), x2=Bi(100,1/3)
cgt.binom = function(n,p) {
    xi = rbinom(n = 100, size = n, prob = p)
    EXi = n * p #EXi = n*p -> очакване за биномно разпределени величини
    DXi = n * p * (1-p) #DXi = n*p*q = n*p*(1-p) -> дисперсия за биномно разпределени велчини
    x1.norm = (xi - EXi) / sqrt(DXi) #нормираме всички величини
    hist(x = x1.norm, probability = TRUE)
    x = rnorm(100)  #симулираме нормално разпределени величини за да сравним
    curve(dnorm(x), add = T)  #приличат си доста, значи и графично можем да кажем че е изпълнена централната гранична теорема
}
cgt.binom(100,1/2)
cgt.binom(100,1/3)

#02
temp = c(102.5, 101.7, 103.1, 100.9, 100.5, 102.2)
sd = 1.2
x=mean(temp)
alpha=1-0.95
z=qnorm(1-alpha/2)
lower=x-z*sd
upper=x+z*sd

#03
#1000 случайни нормално разпределени величини
test.mu = function(mu, sigma.sq) {
  x = rnorm(n = 1000, mean = mu, sd = sqrt(sigma.sq))
  alpha=1-0.95
  z=qnorm(1-alpha/2)
  x.cherta=mean(x)
  #N(mu,1) -> formula 11
  x.lower=x.cherta-z*1
  x.upper=x.cherta+z*1
  plot(x)
  lines(x=0:1000,y=rep(x.upper,1001), col='red')
  lines(x=0:1000,y=rep(x.lower,1001), col='blue')

  x.length=length(x[x>=x.lower&x<=x.upper]) #броят на стойностите влизащи в доверителния интервал
  print(x.length)
  print(mean(x[x>=x.lower&x<=x.upper])) #средното на броят стойностите, влизащи в интервала
  x.length/1000 #вероятността някоя от случайните величини да е вътре в доверителния интервал
}

#N(2,2)
test.mu(2,2)
#N(2,1)
test.mu(2,1)

#04
#1000 случайни нормално разпределени величини
test.mu.sigma = function(mu, sigma.sq) {
  x = rnorm(n = 1000, mean = mu, sd = sqrt(sigma.sq))
  x.cherta = mean(x)
  s = sd(x)
  gama = 0.95
  t = qt(gama, df = 1000 - 1) #квантил на t-разпределение с n-1 степени на свобода
  #N(mu,sigma^2) -> формула 12
  x.lower = x.cherta - t*s
  x.upper = x.cherta + t*s
  plot(x)
  lines(x=0:1000,y=rep(x.upper,1001), col='red')
  lines(x=0:1000,y=rep(x.lower,1001), col='blue')

  x.length=length(x[x>=x.lower&x<=x.upper]) #броят на стойностите влизащи в доверителния интервал
  print(x.length)
  print(mean(x[x>=x.lower&x<=x.upper])) #средното на броят стойностите, влизащи в интервала
  x.length/1000 #вероятността някоя от случайните величини да е вътре в доверителния интервал
}


## 3. Using Bayes' Theorem ##

p_spam <- 0.5
p_non_spam <- 0.5
p_new_message <- 0.5417
p_new_message_given_spam <- 0.75
p_new_message_given_non_spam <- 0.3334
p_spam_given_new_message <- (p_spam * p_new_message_given_spam) / p_new_message
p_non_spam_given_new_message <- (p_non_spam * p_new_message_given_non_spam) / p_new_message

classification <- "spam"

## 4. Using Proportionality ##

p_spam <- 0.5
p_non_spam <- 0.5
p_new_message_given_spam <- 0.75
p_new_message_given_non_spam <- 0.3334
p_spam_given_new_message <- p_spam * p_new_message_given_spam
p_non_spam_given_new_message <- p_non_spam * p_new_message_given_non_spam

classification <- 'spam'

## 5. Classifying One Word Messages ##

p_spam_given_secret <- 8/21
p_non_spam <- 1/3
p_secret_given_non_spam <- 1/4
p_non_spam_given_secret <- p_non_spam * p_secret_given_non_spam
classification <- 'spam'

## 6. Classifying Multiple Word Messages ##

p_spam_given_w1_w2_w3_w4 <- 64/4802
p_non_spam <- 2/4
p_w1_given_non_spam <- 2/9
p_w2_given_non_spam <- 1/9
p_w3_given_non_spam <- 2/9
p_w4_given_non_spam <- 2/9

p_non_spam_given_w1_w2_w3_w4 <- (p_non_spam *
                                p_w1_given_non_spam * p_w2_given_non_spam *
                                p_w3_given_non_spam * p_w4_given_non_spam
                               )

classification <- 'spam'

## 9. Edge Case: Words Not In Vocabulary ##

p_spam <- 2/4
p_secret_given_spam <- 4/7
p_the_given_spam <- 0/7
p_money_given_spam <- 2/7
p_spam_given_message <- (p_spam * p_secret_given_spam *
                        p_the_given_spam * p_money_given_spam)
p_non_spam <- 2/4
p_secret_given_non_spam <- 2/9
p_the_given_non_spam <- 1/9
p_money_given_non_spam <- 0/9
p_non_spam_given_message <- (p_non_spam * p_secret_given_non_spam *
                            p_the_given_non_spam * p_money_given_non_spam)

print(p_spam_given_message)
print(p_non_spam_given_message)

## 10. Additive Smoothing ##

p_spam <- 2/4
p_secret_given_spam <- (4 + 1) / (7 + 9)
p_the_given_spam <- (0 + 1) / (7 + 9)
p_money_given_spam <- (2 + 1) / (7 + 9)
p_spam_given_message <- (p_spam * p_secret_given_spam *
                        p_the_given_spam * p_money_given_spam)
p_non_spam <- 2/4
p_secret_given_non_spam <- (2 + 1) / (9 + 9)
p_the_given_non_spam <- (1 + 1) / (9 + 9)
p_money_given_non_spam <- (0 + 1) / (9 + 9)
p_non_spam_given_message <- (p_non_spam * p_secret_given_non_spam *
                            p_the_given_non_spam * p_money_given_non_spam)

classification <- 'spam'

Data Analyst in R/Step 5 - Probability and Statistics/4. Conditional Probability in R/4. The Naive Bayes Algorithm.r


#!/opt/local/bin/Rscript

input<-file('stdin')
open(input)

rows <- as.integer(readLines(input, n=1))

data <- read.table(input, sep = "", nrows = rows,
	header = F, col.names = c("math", "phys", "chem"))

#print(data)
#print(data[, c("math", "phys")])

mp <- cor(data[, c("math", "phys")], use="complete.obs", method="pearson")
pc <- cor(data[, c("phys", "chem")], use="complete.obs", method="pearson")
cm <- cor(data[, c("chem", "math")], use="complete.obs", method="pearson")

write(round(mp[2:2], 2), stdout())
write(round(pc[2:2], 2), stdout())
write(round(cm[2:2], 2), stdout())


# Imitate N=100 copies of Wiener process:
# W(t) = sum(k = 1,N; 2*sqrt(2) * (sin((2k-1)*pi*t/2) / (2k-1)*pi )

library(ggplot2)

Wiener <- function(Timeline, sigma = 1)
{
  ksi <- rnorm(n = length(Timeline), mean = 0, sd = sigma)
  coef <- c()

  k <- 1
  for(t in Timeline)
  {
    c <- sqrt(2)*(sin((k-0.5)*pi*t)/((k-0.5)*pi))
    coef <- c(coef, c)
    k <- k + 1
  }
  return(cumsum(ksi*coef))
}

Timeline <- seq(from = 0, to = 1, by = 0.001)
N <- Wiener(Timeline)

ggplot() + geom_path(aes(x = Timeline, y = N)) + ggtitle("Wiener process") + xlab('t') + ylab('N(t)')


diffData <- diff(data)
fitDn <- nlsLM(diffData~a*dnorm(1:length(diffData), mean = m, sd = sd), start=list(m=10,sd=2,a=100))

print(summary(fitDn))

l = as.list(coef(fitDn))

peak = l$m
width = l$sd
amplitude = l$a
amplitudeStdErr = summary(fitDn)$coefficients[3,2]
print("***** Deriv Results Start ******")
print('Amplitude')
print(amplitude)
print('width')
print(width)
print('peak')
print(peak)
print(peak - length(data))
print(as.Date(startDate) + peak)
print('amplitudeStdErr')
print(amplitudeStdErr)
print("***** Deriv Results End   ******")

dataDates = 1:length(diffData)
dataPerDates = cbind(dataDates, diffData)
dfData = as.data.frame(dataPerDates)

simuDates = 1:60
simu = dnorm(1:60, mean = peak, sd = width) * amplitude
simuMax = simu*(1 + amplitudeStdErr/amplitude)
simuMin = simu*(1 - amplitudeStdErr/amplitude)
simuPerDates = cbind(simuDates, simu, simuMin, simuMax)
dfSimu = as.data.frame(simuPerDates)

m <- merge(dfSimu, dfData, all.x=T, by=c(1))
m$simuDates <- as.Date(m$simuDates, origin = startDate)

#g <- ggplot(m, aes(x=simuDates))+geom_line(aes(y=simu))+geom_line(aes(y=simuMin, color = 'red'))+geom_line(aes(y=simuMax, color = 'blue'))
#g <- ggplot(m, aes(x=simuDates))+geom_point(aes(y=diffData, color='Real Data'), col="steelblue", size=2)+
#  geom_line(aes(y=simu))+
#  geom_line(aes(y=simuMin, color = 'Simu. Min.'))+
#  geom_line(aes(y=simuMax, color = 'Simu. Max.'))+scale_x_date(date_minor_breaks = "1 day", breaks = "10 day")

g <- ggplot(m, aes(x=simuDates))+geom_point(aes(y=diffData, color='Real Data'), col="steelblue", size=2)+
  geom_line(aes(y=simu))+
  geom_line(aes(y=simuMin, color = 'Simu. Min.'))+
  geom_line(aes(y=simuMax, color = 'Simu. Max.'))+
  scale_x_date(date_minor_breaks = "1 day", breaks = "7 day",
               labels = scales::date_format("%m-%d"),
               sec.axis = sec_axis(trans = ~ .,
                                   labels = scales::date_format("%m-%d")))+
  geom_vline(xintercept = as.Date(startDate)+peak, colour = "darkGrey") +
  geom_text(aes(x=as.Date(startDate)+peak, label="\nDecrease", y=1000), colour="blue", angle=90, text=element_text(size=10)) +
  geom_text(aes(x=as.Date(startDate)+peak, label="Increase\n", y=1000), colour="red", angle=90, text=element_text(size=10))

print(g)

#simu = dnorm(1:50, mean = peak, sd = width) * amplitude
#plot(simu*(1 + amplitudeStdErr/amplitude), pch = "+", type = "l")
#points(simu, pch = "o")
#points(diffData, pch = "*")
#points(simu*(1 - amplitudeStdErr/amplitude), pch = "-", type = "l")


low=c(250,750)
high=c(400,1600)
odds_ratio=(250/750)/(400/1600)
print(odds_ratio)
# We will next compute a 95% confidence interval for the odds ratio
a= log(odds_ratio)
sigma=sqrt(1/low[1]+1/low[2]+1/high[1]+1/high[2])
print(sigma)
# The 95% confidence interval for the odds ratio is obtained by first computing
error=1.96*sigma
left_i=a-error
right_i=a+error

print(left_i)
print(right_i)
print("confidence interval")
print(exp(left_i))
print(exp(right_i))


#load or install ggplot package
if(!require(ggplot2)){install.packages('ggplot2')}
library(ggplot2)

#Simulate one group
n=1000 #set sample size
x<-rnorm(n = n, mean = 100, sd = 15) #create sample from normal distribution

#plot data
ggplot(as.data.frame(x), aes(x))  +
  geom_histogram(colour="black", fill="grey", aes(y=..density..), binwidth=2) +
  stat_function(fun=dnorm, args=c(mean=100,sd=15), size=1, color="red", lty=2) +
  #  geom_density(fill=NA, colour="black", size = 1) +
  xlab("IQ") + ylab("number of people")  + ggtitle("Data") + theme_bw(base_size=20) +
  theme(panel.grid.major.x = element_blank(), axis.text.y = element_blank(), panel.grid.minor.x = element_blank()) +
  geom_vline(xintercept=mean(x), colour="gray20", linetype="dashed") +
  coord_cartesian(xlim=c(50,150)) + scale_x_continuous(breaks=c(50,60,70,80,90,100,110,120,130,140,150)) +
  annotate("text", x = mean(x), y = 0.02, label = paste("Mean = ",round(mean(x)),"\n","SD = ",round(sd(x)),sep=""), size=8)

#? Daniel Lakens, 2016.
# This work is licensed under a Creative Commons Attribution-NonCommercial-ShareAlike 4.0 International License. https://creativecommons.org/licenses/by-nc-sa/4.0/


## 2. What is a probability? ##

p_5 <- 1 / 6
p_lottery <- 1 / 350000

## 3. Outcomes vs Events ##

p_heart <- 13 / 52
p_2_or_3 <- 8 / 52

## 4. Empirical Probability ##

p_three <- 18 / 100

## 5. Repeating Experiments ##

set.seed(1)

coin_toss <- function() {
    toss <- runif(1)
    if (toss <= 0.5) {
        return("HEADS")
    } else {
        return("TAILS")
    }
}
heads <- 0
n_experiments <- 10
for (i in 1:n_experiments) {
    toss <- coin_toss()
    if (toss == "HEADS") {
        heads <- heads + 1
    }
}

experiment_one <- heads / n_experiments

n_experiments <- 100
heads_2 <- 0
for (i in 1:n_experiments) {
    toss <- coin_toss()
    if (toss == "HEADS") {
        heads_2 <- heads_2 + 1
    }
}

experiment_two <- heads_2 / n_experiments

## 6. The Law of Large Numbers ##

set.seed(1)

coin_toss <- function() {
    toss <- runif(1)
    if (toss <= 0.5) {
        return("HEADS")
    } else {
        return("TAILS")
    }
}
heads <- 0
n_experiments <- 10
for (i in 1:n_experiments) {
    toss <- coin_toss()
    if (toss == "HEADS") {
        heads <- heads + 1
    }
}

experiment_diff_one <- 0.5 - (heads / n_experiments)

n_experiments <- 100
heads_2 <- 0
for (i in 1:n_experiments) {
    toss <- coin_toss()
    if (toss == "HEADS") {
        heads_2 <- heads_2 + 1
    }
}

experiment_diff_two <- 0.5 - (heads_2 / n_experiments)

n_experiments <- 1000
heads_3 <- 0
for (i in 1:n_experiments) {
    toss <- coin_toss()
    if (toss == "HEADS") {
        heads_3 <- heads_3 + 1
    }
}

experiment_diff_three <- 0.5 - (heads_3 / n_experiments)

Data Analyst in R/Step 5 - Probability and Statistics/3. Probability Fundamentals in R/1. Estimating Probabilities.r


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

library(nlme)
Rail

################################################3

dat <- read.table("Rail.txt",head=T)
names(dat)
dat$Rail<-factor(dat$Rail)
str(dat)
head(dat)

help(Rail)

dat2<-groupedData(travel ~ 1 | Rail,dat)

plot(dat2)

fit1<-lme(travel ~ 1, data = dat2, random = ~ 1|Rail)
summary(fit1)

# test of fixed part
anova(fit1)

# test for random effect
fit2<-lm(travel ~ 1,data = dat)
anova(fit1,fit2)

help(anova.lme)

fitted(fit1)
fitted(fit2)

ranef(fit1)
fixef(fit1)

summary(fit1)

plot(fit1)

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

# Stool

ergoStool

help(ergoStool)

dat <- read.table("ergoStool.txt",head=T)
names(dat)
dat$Type<-factor(dat$Type)
dat$Subject<-factor(dat$Subject)

dat2<-groupedData(effort ~ Type | Subject,data=dat)

plot.design(dat2)

names(dat)
fit1<-lme(effort~Type, data = dat2, random = ~1|Subject)
summary(fit1)

anova(fit1)
fit2<-lm(effort~Type, data = dat)
anova(fit1,fit2)

intervals(fit1)

plot(fit1)

plot(fit1,form=resid(.,type='p')~fitted(.)|Subject,abline=0)

plot(fit1,form=resid(.,type='p')~fitted(.)|Type,abline=0)

str(dat)


# 210518_PCA_Principal_component_analysis
# vector가 갖고있는 기초통계 분산 값이 클 수록 해당 데이터 설명을 잘하는 성분으로 간주
# 위 경우 w 가중치 값을 크게 만든다.
# ex) 위 자동차 변량(핸들모양, 차의 무게) 중 차의 무게 분산 값이 가장 크다면
# 차 무게의 가중치 값을 크게 하여
# 차종에 대한(차종,차의 무게) 2차원 정보를 -> 1차원 직선으로 표기한다?

# [05_주성분분석.pdf] p3
# 행렬식 표기 Xw = T
# Var(X)가 최대가 되는 w 찾기
# x11w1 + x12w2+ .... + x1pwp = t1

# 연습
x <- data.frame(c(1,2),c(3,4))
x
w <- c(2,2)
x*w

# [05_주성분분석.pdf] p11
x1<-c(26,46,57,36,57,26,58,37,36,56,78,95,88,90,52,56)
x2<-c(35,74,73,73,62,22,67,34,22,42,65,88,90,85,46,66)
x3<-c(35,76,38,69,25,25,87,79,36,26,22,36,58,36,25,44)
x4<-c(45,89,54,55,33,45,67,89,47,36,40,56,68,45,37,56)

score <- cbind(x1,x2,x3,x4)
score
#      x1 x2 x3 x4
# [1,] 26 35 35 45
# [2,] 46 74 76 89
# [3,] 57 73 38 54
# [4,] 36 73 69 55
# [5,] 57 62 25 33
# [6,] 26 22 25 45
# [7,] 58 67 87 67
# [8,] 37 34 79 89
# [9,] 36 22 36 47
# [10,] 56 42 26 36
# [11,] 78 65 22 40
# [12,] 95 88 36 56
# [13,] 88 90 58 68
# [14,] 90 85 36 45
# [15,] 52 46 25 37
# [16,] 56 66 44 56

colnames(score) <-c("국어","영어","수학","과학")
rownames(score)<-1:16
head(score)

result <- prcomp(score)
result

# Standard deviations (1, .., p=4):
#   [1] 30.122748 27.052808  9.076140  6.152386
#
# Rotation (n x k) = (4 x 4): 가중치 w1, w2, w3, w4
#   PC1         PC2        PC3
# 국어 0.6093268 -0.39286407 -0.6126773
# 영어 0.7185749 -0.09337973  0.6200124
# 수학 0.2624323  0.73573272  0.1052861
# 과학 0.2085672  0.54372366 -0.4786711
# PC4
# 국어 -0.3146508
# 영어  0.3008572
# 수학 -0.6154198
# 과학  0.6570680

?prcomp
# Principal Components Analysis
# Performs a principal components analysis on the given data matrix and returns the results as an object of class prcomp.

summary(result)
# Importance of components:
# PC1
# Standard deviation     30.1227  # 표준편차
# Proportion of Variance  0.5157  # 분산 비율
# Cumulative Proportion   0.5157  # 설명력, 기여도, 약 52% 설명
# PC2
# Standard deviation     27.0528
# Proportion of Variance  0.4159
# Cumulative Proportion   0.9317  # 누적된 결과이므로 PC1과 PC2의 설명력
# PC3
# Standard deviation     9.07614
# Proportion of Variance 0.04682
# Cumulative Proportion  0.97849
# PC4
# Standard deviation     6.15239
# Proportion of Variance 0.02151
# Cumulative Proportion  1.00000

biplot(result)
?biplot
screeplot(result, npcs=4, type="lines", main="score")