# Black-Scholes model: value function and some greeks
# Dale Roberts (c) 2010

# S = Asset price
# K = Strike price
# r = Risk-free rate
# tau = Time to maturity
# sigma = Volatility of asset price

EPS <- 1./365.

bscall.value <- function(S, K, tau, r, sigma) {
  d1 <- (log(S/K) + (r + 0.5*sigma^2)*tau)/(sigma*sqrt(tau))
  d2 <- d1 - sigma*sqrt(tau)
  if (tau < EPS) { # Small time to expiry
    return(max(S-K,0))
  } else {
    return(S*pnorm(d1) - K*exp(-r*(tau))*pnorm(d2))
  }
}

bsput.value <- function(S, K, tau, r, sigma) {
  d1 <- (log(S/K) + (r + 0.5*sigma^2)*tau)/(sigma*sqrt(tau))
  d2 <- d1 - sigma*sqrt(tau)
   if (tau < EPS) { # Small time to expiry
    return(max(K-S,0))
  } else {
    return(K*exp(-r*(tau))*pnorm(-d2) - S*pnorm(-d1))
  }
}

bscall.delta <- function(S, K, tau, r, sigma) {
  d1 <- (log(S/K) + (r + 0.5*sigma^2)*tau)/(sigma*sqrt(tau))
  if (tau < EPS) { # by hand for small time to expiry
    if (K-S < 0) {
      return(1.0)
    } else {
      return(0.0)
    }
  } else {
    return(pnorm(d1))
  }
}

bsput.delta <- function(S, K, tau, r, sigma) {
  d1 <- (log(S/K) + (r + 0.5*sigma^2)*tau)/(sigma*sqrt(tau))
  if (tau < EPS) { # by hand for small time to expiry
    if (K-S > 0) {
      return(-1.0)
    } else {
      return(0.0)
    }
  } else {
    return(pnorm(d1)-1)
  }
}

bscall.gamma <- function(S, K, tau, r, sigma) {
  d1 <- (log(S/K) + (r + 0.5*sigma^2)*tau)/(sigma*sqrt(tau))
  return(dnorm(d1)/(S*sigma*sqrt(tau)))
}

bscall.theta <- function(S, K, tau, r, sigma) {
  d1 <- (log(S/K) + (r + 0.5*sigma^2)*tau)/(sigma*sqrt(tau))
  d2 <- d1 - sigma*sqrt(tau)
  return(-S*dnorm(d1)*sigma/(2*sqrt(tau)) - r*K*exp(-r*tau)*pnorm(d2))
}

bsput.theta <- function(S, K, tau, r, sigma) {
  d1 <- (log(S/K) + (r + 0.5*sigma^2)*tau)/(sigma*sqrt(tau))
  d2 <- d1 - sigma*sqrt(tau)
  return(-S*dnorm(d1)*sigma/(2*sqrt(tau)) + r*K*exp(-r*tau)*pnorm(-d2))
}

bscall.vega <- function(S, K, tau, r, sigma) {
  d1 <- (log(S/K) + (r + 0.5*sigma^2)*tau)/(sigma*sqrt(tau))
  return(S*sqrt(tau)*dnorm(d1))
}

bscall.rho <- function(S, K, tau, r, sigma) {
  d1 <- (log(S/K) + (r + 0.5*sigma^2)*tau)/(sigma*sqrt(tau))
  d2 <- d1 - sigma*sqrt(tau)
  return(K*tau*exp(-r*tau)*pnorm(d2))
}

bsput.rho <- function(S, K, tau, r, sigma) {
  d1 <- (log(S/K) + (r + 0.5*sigma^2)*tau)/(sigma*sqrt(tau))
  d2 <- d1 - sigma*sqrt(tau)
  return(-K*tau*exp(-r*tau)*pnorm(-d2))
}


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

m<-5  #Number of risk groups
beta<-0.0016*c(0,3,10,60,100)%*%t(c(0,3,10,60,100)) #Matrix of transmission rates between to risk group i (rows) from risk group j (columns)
gamma<-rep(0.2,m) #Vector of recovery rate per risk group
n<-c(0.06,0.31,0.52,0.08,0.03) #Vector of proportion of the population that are in each risk group
x<-c(0.0,0.0,0.0,0.0,1e-5)  #Vector of initial proportions of the population that are both infectious and in each risk group
MaxTime<-30 #Number of years

sis_ode <- function(times,x,parms){
  with(as.list(c(parms,x)),{
    # ODEs
    I<-matrix(x[1:m],nrow=m,ncol=1)
    dI<-+(beta%*%I)*(n-I)-gamma*I
    list(c(dI))
  })
}

times<-seq(0,MaxTime,1)
parms<-list(beta=beta,gamma=gamma,n=n,m=m)
sis_out <- as.data.frame(lsoda(x,times,sis_ode,parms))

sis_out_long <- melt(sis_out,"time")  #Collapse dataset from "wide" to "long" format for plotting
ggplot(sis_out_long,aes(x=time,y=value,colour=variable,group=variable)) +
  geom_line(lwd=2) + labs(x="Time (Years)",y="Proportion of Population",color="Risk Group")


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


# 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


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


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.


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)


##' @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
}


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


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


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)));
}


# 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


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


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


### Copyright (c) 2013 Kendrick Boyd. This is free software. See
### LICENSE for details.

### Precision-Recall Analysis Stuff for R
###

### Precision-Recall curves
###
### positive (cases) scores (outputs, probabilities, etc.) are random
### variable Y negative (controls) scores are random variable X
###
### pi (prevalence) =  # positives / (# positives + # negatives)

######################################################################
### Binormal
### Assume scores are normally distributed.

### parameters:
### X ~ Normal(0,1)
### Y ~ Normal(pos.mean,pos.sd)

## Calculate true precision for a threshold under binormal distribution.
binormal.precision <- function(c,pi=0.5,pos.mean=1.0,pos.sd=1.0)
{
  r = (pi*pnorm(c,pos.mean,pos.sd,lower.tail=FALSE))/(pi*pnorm(c,pos.mean,pos.sd,lower.tail=FALSE) + (1-pi)*pnorm(c,mean=0,sd=1,lower.tail=FALSE))
  r[is.nan(r)] = 1 ## nan from a denominator of 0 should be precision 1
  return(r)
}

## Calculate true recall for a threshold under binormal distribution.
binormal.recall <- function(c,pi=0.5,pos.mean=1.0,pos.sd=1.0)
{
  pnorm(c,pos.mean,pos.sd,lower.tail=FALSE)
}

## Calculate true precision for a particular recall under binormal distribution.
binormal.precision.at.recall <- function(recall, pi=0.5,pos.mean=1.0,pos.sd=1.0) {
  return(binormal.precision(qnorm(recall,pos.mean,pos.sd,lower.tail=FALSE),pi=pi,pos.mean=pos.mean,pos.sd=pos.sd))
}

# Plot the true binormal PR curve.
binormal.plot <- function(pi=0.5,pos.mean=1.0,pos.sd=1.0)
{
  plot(function(x) {binormal.precision(qnorm(x,pos.mean,pos.sd,lower.tail=FALSE),pi=pi,pos.mean=pos.mean,pos.sd=pos.sd)},xlim=c(0,1),ylim=c(0,1),xlab="Recall",ylab="Precision",sub=paste("pi=",pi,", pos.mean=",pos.mean,", pos.sd=",pos.sd))
}

# Calculate true area under binormal PR curve using numeric integration.
binormal.area <- function(pi=0.5,pos.mean=1.0,pos.sd=1.0)
{
  f <- function(q) { binormal.precision(qnorm(q,pos.mean,pos.sd,lower.tail=FALSE),pi=pi,pos.mean=pos.mean,pos.sd=pos.sd) }
  ## monte carlo integration
  #mean(f(runif(samples)))

  ## integrate method of R, much faster (although might have problems with x=0)
  r = integrate(f,0,1)
  return(r$value)
}

## Generate sample from binormal distribution. When pi.exact is false,
## the number of positive examples is distributed according to
## Binomial(n,pi). If pi.exact is false, the number of positive
## examples is always pi*n.
binormal.sample <- function(n=1, pi=0.5, pos.mean=1.0, pos.sd=1.0, pi.exact = TRUE) {
  if (pi.exact) {
    num.pos = as.integer(pi*n)
  }
  else {
    num.pos = rbinom(n=1,prob=pi,size=n)
  }
  num.neg = n-num.pos

  pos.values = rnorm(num.pos,mean=pos.mean,sd=pos.sd)
  neg.values = rnorm(num.neg,mean=0,sd=1)
  return(list(pos.values=pos.values,neg.values=neg.values))
}

######################################################################
### Bibeta
### Assumes scores are from two Beta distributions.
### Y ~ Beta(pos.a,pos.b)
### X ~ Beta(neg.a,neg.b)

## Calculates true precision for a threshold under bibeta distribution.
bibeta.precision <- function(c,pi=0.5,pos.a=2,pos.b=1,neg.a=1,neg.b=1) {
  ## X ~ Beta(neg.a,neg.b), Y ~ Beta(pos.a,pos.b)
  r = (pi*pbeta(c,pos.a,pos.b,lower.tail=FALSE))/(pi*pbeta(c,pos.a,pos.b,lower.tail=FALSE) + (1-pi)*pbeta(c,neg.a,neg.b,lower.tail=FALSE))
  r[is.nan(r)] = 1 ## nan from a denominator of 0 should have precision of 1
  return(r)
}

## Calculates true recall for a threshold under bibeta distribution.
bibeta.recall <- function(c,pi=0.5,pos.a=2,pos.b=1,neg.a=1,neg.b=1) {
  pbeta(c,pos.a,pos.b,lower.tail=FALSE)
}

## Calculate true precision for a particular recall under bibeta distribution.
bibeta.precision.at.recall <- function(recall,pi=0.5,pos.a=2,pos.b=1,neg.a=1,neg.b=1) {
  return(bibeta.precision(qbeta(recall,pos.a,pos.b,lower.tail=FALSE),pi=pi,pos.a=pos.a,pos.b=pos.b,neg.a=neg.a,neg.b=neg.b))
}

## Plot the true bibeta PR curve.
bibeta.plot <- function(pi=0.5,pos.a=2,pos.b=1,neg.a=1,neg.b=1) {
  plot(function(x) {bibeta.precision(qbeta(x,pos.a,pos.b,lower.tail=FALSE),pi=pi,pos.a=pos.a,pos.b=pos.b,neg.a=neg.a,neg.b=neg.b)},
       xlim=c(0,1),
       ylim=c(0,1),
       xlab="Recall",
       ylab="Precision",
       sub=paste("pi=",pi,",X (neg) ~ Beta(",neg.a,",",neg.b,"), Y (pos) ~ Beta(",pos.a,",",pos.b,")")
       )

}

## Calculate the true area under the bibeta PR curve using numeric integration.
bibeta.area <- function(pi=0.5,pos.a=2,pos.b=1,neg.a=1,neg.b=1) {
  f <- function(q) { bibeta.precision(qbeta(q,pos.a,pos.b,lower.tail=FALSE),pi=pi,pos.a=pos.a,pos.b=pos.b,neg.a=neg.a,neg.b=neg.b) }

  ## use R's integrate method
  res = integrate(f,0,1)
  return(res$value)
}

## Generate sample from bibeta distribution. When pi.exact is false,
## the number of positive examples is distributed according to
## Binomial(n,pi). If pi.exact is false, the number of positive
## examples is always pi*n.
bibeta.sample <- function(n=1,pi=0.5,pos.a=2,pos.b=1,neg.a=1,neg.b=1,pi.exact = TRUE) {
  if (pi.exact) {
    num.pos = as.integer(pi*n)
  }
  else {
    num.pos = rbinom(n=1,prob=pi,size=n)
  }

  num.neg = n-num.pos

  ## Generates a sample of observed values for neg.values (X) ~
  ## Beta(neg.a,neg.b) and pos.values (Y) ~ Beta(pos.a,pos.b).

  pos.values = rbeta(num.pos,pos.a,pos.b)
  neg.values = rbeta(num.neg,neg.a,neg.b)

  return(list(pos.values=pos.values,neg.values=neg.values))
}

######################################################################
### Offset Uniform
### Assumes the scores are drawn from two uniform distributions
### spanning different ranges

### X ~ Uniform(0,1)
### Y ~ Uniform(a,a+b)

## Calculate true precision for a threshold under offset uniform distributions.
offsetuniform.precision <- function(c,pi=0.5,a=0.5,b=1) {
  r = (pi*punif(c,min=a,max=a+b,lower.tail=FALSE))/(pi*punif(c,min=a,max=a+b,lower.tail=FALSE) + (1-pi)*punif(c,min=0,max=1,lower.tail=FALSE))
  r[is.nan(r)] = 1 ## nan from denominator of 0 should have precision of 1
  return(r)
}

## Calculate true recall for a threshold under offset uniform distributions.
offsetuniform.recall <- function(c,pi=0.5,a=0.5,b=1) {
  punif(c,min=a,max=a+b,lower.tail=FALSE)
}

## Calculate true precision for a particular recall under offset uniform distribution.
offsetuniform.precision.at.recall <- function(recall, pi=0.5,a=0.5,b=1) {
  return(offsetuniform.precision(qunif(recall,a,a+b,lower.tail=FALSE),pi=pi,a=a,b=b))
}

## Plot the true offset uniform PR curve.
offsetuniform.plot <- function(pi=0.5,a=0.5,b=1) {
  plot(function(x) {offsetuniform.precision(qunif(x,min=a,max=a+b,lower.tail=FALSE),
                                            pi=pi,
                                            a=a,
                                            b=b)},
       xlim=c(0,1),
       ylim=c(0,1),
       xlab="Recall",
       ylab="Precision",
       sub=paste("pi=",pi," a=",a,"b=",b))
}

## Calculate true area under offset uniform PR curve using numeric integration.
offsetuniform.area <- function(pi=0.5,a=0.5,b=1) {
  f <- function(q) { offsetuniform.precision(qunif(q,min=a,max=a+b,lower.tail=FALSE),
                                             pi=pi,
                                             a=a,
                                             b=b)}
  r = integrate(f,0,1)
  return (r$value)
}

## Generate sample from offset uniform distribution. When pi.exact is false,
## the number of positive examples is distributed according to
## Binomial(n,pi). If pi.exact is false, the number of positive
## examples is always pi*n.
offsetuniform.sample <- function(n=1,pi=0.5,a=0.5,b=1,pi.exact = TRUE) {
  if (pi.exact) {
    num.pos = as.integer(pi*n)
  }
  else {
    num.pos = rbinom(n=1,prob=pi,size=n)
  }
  num.neg = n-num.pos

  ## X (neg) ~ Uniform(0,1)
  ## Y (pos) ~ Uniform(a,a+b)

  pos.values = runif(n=num.pos,min=a,max=a+b)
  neg.values = runif(n=num.neg,min=0,max=1)

  return(list(pos.values=pos.values,neg.values=neg.values))
}

aucpr.conf.int <- function(estimate,pos.values,neg.values,prcurve.estimator,conf.level=0.95,method="binomial",bootstrap.replicates=1000) {
  ## Calculates confidence interval for an AUCPR estimate.
  ## method=c("binomial","expit")
  m = match.arg(method,c("binomial","expit","bootstrap"))

  if (m=="binomial") {
    return(aucpr.conf.int.binomial(estimate,num.pos=length(pos.values),num.neg=length(neg.values),conf.level=conf.level))
  }
  else if (m=="expit") {
    return(aucpr.conf.int.expit(estimate,num.pos=length(pos.values),num.neg=length(neg.values),conf.level=conf.level))
  }
  else if (m=="bootstrap") {
    return(aucpr.conf.int.bootstrap(estimate,pos.values,neg.values,prcurve.estimator,conf.level,bootstrap.replicates))
  }
}

aucpr.conf.int.binomial <- function(estimate,num.pos,num.neg,conf.level=0.95) {
  ## Calculates confidence interval for an AUCPR estimate under
  ## binomial assumptions. Uses num.pos as the sample size (might not
  ## be best?).

  ci = estimate+qnorm(c((1-conf.level)/2,(1+conf.level)/2))*sqrt(estimate*(1-estimate)/num.pos)
  attr(ci,"conf.level") = conf.level
  attr(ci,"method") = "binomial"
  return(ci)
}

aucpr.conf.int.expit <- function(estimate,num.pos,num.neg,conf.level=0.95) {
  ## Calculates confidence interval for an AUCPR estimate using expit.

  ## convert to logit scale
  est.logit = log(estimate/(1-estimate))
  ## standard error (from Kevin Eng)
  se.logit = sqrt(estimate*(1-estimate)/num.pos)*(1/estimate + 1/(1-estimate))
  ## confidence interval in logit
  ci.logit = est.logit+qnorm(c((1-conf.level)/2,(1+conf.level)/2))*se.logit

  ## back to original scale
  ci = exp(ci.logit)/(1+exp(ci.logit))
  attr(ci,"conf.level") = conf.level
  attr(ci,"method") = "expit"
  return(ci)
}

aucpr.conf.int.bootstrap <- function(estimate,pos.values,neg.values,prcurve.estimator,conf.level=0.95,replicates=1000) {
  areas = rep(0,replicates)

  for (i in 1:replicates) {
    p.v = sample(pos.values,replace=TRUE)
    n.v = sample(neg.values,replace=TRUE)

    res = prcurve.estimator(p.v,n.v)
    areas[i] = res$area
  }

  q = quantile(areas,c((1-conf.level)/2,(1+conf.level)/2))

  ci = c(q[1],q[2])
  attr(ci,"conf.level") = conf.level
  attr(ci,"method") = "bootstrap"
  attr(ci,"median") = median(areas)
  attr(ci,"mean") = mean(areas)

  return (ci)
}

aucpr.conf.int.crossvalidation <- function(estimate,pos.values,neg.values,prcurve.estimator,conf.level=0.95,folds=10) {
  areas = rep(0,folds)

  pos = sample(pos.values)
  neg = sample(neg.values)

  pos.counts = rep(c(as.integer(length(pos.values)/folds)+1,as.integer(length(pos.values)/folds)),c(length(pos.values)%%folds,10-length(pos.values)%%folds))
  neg.counts = rep(c(as.integer(length(neg.values)/folds)+1,as.integer(length(neg.values)/folds)),c(length(neg.values)%%folds,10-length(neg.values)%%folds))

  pos.index = 1
  neg.index = 1
  for (k in 1:folds) {
    p = pos[pos.index:(pos.index+pos.counts[k]-1)]
    n = neg[neg.index:(neg.index+neg.counts[k]-1)]

    areas[k] = prcurve.estimator(p,n)$area

    pos.index = pos.index + pos.counts[k]
    neg.index = neg.index + neg.counts[k]
  }

  ## normal approximation
  ##ci = mean(areas) + qnorm(c((1-conf.level)/2,(1+conf.level)/2))*sd(areas)/sqrt(length(areas))
  ## use t-distribution
  ci = mean(areas) + qt(c((1-conf.level)/2,(1+conf.level)/2),df=length(areas)-1)*sd(areas)/sqrt(length(areas))

  attr(ci,"conf.level") = conf.level
  attr(ci,"method") = "crossvalidation, t-dist"
  attr(ci,"values") = areas
  attr(ci,"mean") = mean(areas)

  return(ci)
}

# return confusion matrix info for >= threshold
# assume labels are 0 and 1
confusion.matrix <- function(values,labels,threshold)
{
  counts=table(factor(values>=threshold,c(FALSE,TRUE)),labels)
  ## print(counts)

  TP = counts[2,2]
  TN = counts[1,1]
  FP = counts[2,1]
  FN = counts[1,2]

  if (TP+FP == 0)
    return(list(tp=TP,tn=TN,fp=FP,fn=FN,precision=NaN,sensitivity=TP/(TP+FN),specificity=TN/(TN+FP),accuracy=(TP+TN)/(TP+TN+FP+TN)))
  else
    return(c(tp=TP,tn=TN,fp=FP,fn=FP,precision=TP/(TP+FP),sensitivity=TP/(TP+FN),specificity=TN/(TN+FP),accuracy=(TP+TN)/(TP+TN+FP+TN)))
}

## Create all confusion matrices from set of pos.values and neg.values
make.confusion.matrices <- function(pos.values,neg.values) {
  ## thresholds, sorting to have increasing recall
  thresholds = sort(c(-Inf,unique(c(pos.values,neg.values)),Inf),decreasing=TRUE)

  ## 0 - negative (control)
  ## 1 - positive (case)
  labels = c(rep(1,length(pos.values)),rep(0,length(neg.values)))
  values = c(pos.values,neg.values)

  # create set of confusion matrices
  d=sapply(thresholds,function(t) { confusion.matrix(values,labels,t) })

  return(d)
}

precisions.recalls.fast <- function(pos.values,neg.values) {
  ## 0 for negative, 1 for positive
  l = rep(c(0,1),c(length(neg.values),length(pos.values)))
  v = c(neg.values,pos.values)

  ## sort by descending value
  indices = order(v,decreasing=TRUE)
  labels = l[indices]
  values = v[indices]

  tp = 0
  fp = 0

  z = 1
  precisions = rep(0,length(indices)+1)
  recalls = rep(0,length(indices)+1)

  tp = 0
  fp = 0

  for (i in 1:length(indices)) {
    if (labels[i]==1) {
      tp = tp + 1
    }
    else {
      fp = fp + 1
    }

    ## make sure not between tied values
    if (i==length(indices) || values[i]>values[i+1]) {
      ## can put a threshold

      ## if first, insert (r=0,p=1) point
      if (z==1) {
        recalls[z] = 0
        precisions[z] = 1
        z = z + 1
      }
      recalls[z] = tp/(length(pos.values))
      precisions[z] = tp/(tp+fp)
      z = z + 1
    }
  }

  ## truncate recals and precisions
  recalls = recalls[1:(z-1)]
  precisions = precisions[1:(z-1)]

  return (list(recalls=recalls,precisions=precisions))
}

# return c(v1[1],v2[1],v1[2],v2[2],...)  works with uneven vectors,
# appending the extra elements from the longer vector so return always
# has length of length(v1)+length(v2) from
# http://tolstoy.newcastle.edu.au/R/help/06/03/22717.html
interleave <- function(v1,v2) {
  ord1 <- 2*(1:length(v1))-1
  ord2 <- 2*(1:length(v2))
  c(v1,v2)[order(c(ord1,ord2))]
}

#################################################################
## Estimators
#################################################################
# Under, connects lowest precision on left side to highest precision
# on the right
prcurve.lowertrap <- function(pos.values,neg.values,conf.level=0.95,conf.int.method="binomial") {
  t = precisions.recalls.fast(pos.values,neg.values)

  recalls = t$recalls
  precisions = t$precisions

  # get max and min precision for each unique recall
  r.unique = unique(recalls)
  p.min = sapply(r.unique,function(r) { min(precisions[recalls==r])})
  p.max = sapply(r.unique,function(r) { max(precisions[recalls==r])})

  # use min on left side and max on right side of each area between known recalls
  ids=2:length(r.unique)
  area = as.double((r.unique[ids]-r.unique[ids-1]) %*% (p.max[ids] + p.min[ids-1]) / 2)

  rs = rep(r.unique,each=2)
  ps = interleave(p.max,p.min)

  ci = aucpr.conf.int(area,
    pos.values=pos.values,
    neg.values=neg.values,
    prcurve.estimator=prcurve.lowertrap,
    conf.level=conf.level,
    method=conf.int.method)

  return(list(area=area,
              x=rs,
              y=ps,
              conf.int=ci))
}

# connects highest precisions at each recall, definitely an
# over-estimate
prcurve.uppertrap <- function(pos.values,neg.values,conf.level=0.95,conf.int.method="binomial") {
  t = precisions.recalls.fast(pos.values,neg.values)

  recalls = t$recalls
  precisions = t$precisions

  # get max and min precision for each unique recall
  r.unique = unique(recalls)
  p.min = sapply(r.unique,function(r) { min(precisions[recalls==r])})
  p.max = sapply(r.unique,function(r) { max(precisions[recalls==r])})

  # use max precision for all recalls (NOT LEGITIMATE!)

  ids=2:length(r.unique)
  area = as.double((r.unique[ids]-r.unique[ids-1]) %*% (p.max[ids] + p.max[ids-1]) / 2)

  ci = aucpr.conf.int(area,
    pos.values=pos.values,
    neg.values=neg.values,
    prcurve.estimator=prcurve.uppertrap,
    conf.level=conf.level,
    method=conf.int.method)

  return(list(area=area,
              x=r.unique,
              y=p.max,
              conf.int=ci))
}

## estimate PR curve and area under PR curve using average precision
## method, mean precision at each positive example
prcurve.ap.slow <- function(pos.values, neg.values, conf.level=0.95, conf.int.method="binomial") {
  ## thresholds, sorting to have increasing recall
  ## only use thresholds for positives
  thresholds = sort(pos.values,decreasing=TRUE)

  labels = c(rep(1,length(pos.values)),rep(0,length(neg.values)))
  values = c(pos.values,neg.values)

  ## create set of confusion matrices
  d=sapply(thresholds,function(t) { confusion.matrix(values,labels,t) })
  recalls = unlist(d[6,])
  precisions = unlist(d[5,])

  area = mean(precisions)

  y = rep(precisions,each=2)
  x = c(0,rep(recalls[1:(length(recalls)-1)],each=2),recalls[length(recalls)])

  ci = aucpr.conf.int(area,
    pos.values=pos.values,
    neg.values=neg.values,
    prcurve.estimator=prcurve.ap.slow,
    conf.level=conf.level,
    method=conf.int.method)

  return (list(area=area,
               x=x,
               y=y,
               conf.int=ci))
}

prcurve.ap <- function(pos.values, neg.values, conf.level=0.95, conf.int.method="binomial") {
  ## 0 for negative, 1 for positive
  l = rep(c(0,1),c(length(neg.values),length(pos.values)))
  v = c(neg.values,pos.values)

  ## sort by descending value
  indices = order(v,decreasing=TRUE)
  labels = l[indices]
  values = v[indices]

  tp = 0
  fp = 0

  rs = rep(0,length(pos.values))
  ps = rep(0,length(pos.values))
  z = 1
  cur.tp = 0
  cur.fp = 0
  for (i in 1:length(indices)) {
    if (labels[i]==1) {
      cur.tp = cur.tp + 1
    }
    else {
      cur.fp = cur.fp + 1
    }
    ## make sure not between tied values
    if (i==length(indices) || values[i]>values[i+1]) {
      ## can put a threshold here
      tp = tp + cur.tp
      fp = fp + cur.fp

      if (cur.tp > 0) {
        for (j in 1:cur.tp) {
          rs[z] = tp/length(pos.values)
          ps[z] = tp/(tp+fp)
          z = z + 1
        }
      }
      cur.tp = 0
      cur.fp = 0
    }

  }

  if (z != length(pos.values)+1) {
    cat("WARNING: did not fill recall and precision arrays correctly (z: received=",z,", expected=",length(pos.values)+1,")\n",sep="")
  }
  area = mean(ps)

  y = rep(ps,each=2)
  x = c(0,rep((rs[1:(length(rs)-1)]),each=2),rs[length(rs)])

  ci = aucpr.conf.int(area,
    pos.values=pos.values,
    neg.values=neg.values,
    prcurve.estimator=prcurve.ap,
    conf.level=conf.level,
    method=conf.int.method)

  return (list(area=area,
               x=x,
               y=y,
               conf.int=ci))
}

## estimate PR curve and area under PR curve with MLE parameters for
## positive and negative normal distributions
prcurve.binormal <- function(pos.values,neg.values,conf.level=0.95,conf.int.method="binomial") {
  ## Assume X ~ N(0,1), i.e. negatives have standard normal distribution.
  ## So only have 2 df to calculate.

  if (length(pos.values)<=1) {
    cat("ERROR: cannot use binormal estimate with fewer than 2 positive samples\n")
  }
  if (length(neg.values)<=1) {
    cat("ERROR: cannot use binormal estimate with fewer than 2 negative samples\n")
  }
  mean.hat = (mean(pos.values)-mean(neg.values))/sd(neg.values)
  sd.hat = sd(pos.values)/sd(neg.values)

  pi = length(pos.values)/(length(pos.values)+length(neg.values))

  area = binormal.area(pi=pi,pos.mean=mean.hat,pos.sd=sd.hat)

  ci = aucpr.conf.int(area,
    pos.values=pos.values,
    neg.values=neg.values,
    prcurve.estimator=prcurve.binormal,
    conf.level=conf.level,
    method=conf.int.method)

  return(list(area=area,pi.hat=pi,pos.mean.hat=mean.hat,pos.sd.hat=sd.hat, conf.int=ci))
}

## Use linear interpolation in ROC space, translate to PR space and
## find the precision for the specified recall (r) for interpolating
## between PR points (r1,p1) and (r2,p2)
interpolate.point <- function(r1,p1,r2,p2,r) {
  res = r / (r*(1 + (1-p2)*r2/(p2*(r2-r1)) - (1-p1)*r1/(p1*(r2-r1))) + (1-p1)*r1/p1 - r1*(1-p2)*r2/(p2*(r2-r1)) + r1*(1-p1)*r1/(p1*(r2-r1)))
  res[r==0] = p2
  return(res)
## if (r==0) {
##   ## hmm, use limit which is just p2
##   return(p2)
## }
## else {
##   return(r / (r*(1 + (1-p2)*r2/(p2*(r2-r1)) - (1-p1)*r1/(p1*(r2-r1))) + (1-p1)*r1/p1 - r1*(1-p2)*r2/(p2*(r2-r1)) + r1*(1-p1)*r1/(p1*(r2-r1))))
## }
}

interpolate.curve <- function(recalls,precisions,num.samples=1000) {

  ## sort by increasing recall
  indices = order(recalls,decreasing=FALSE)
  rs = recalls[indices]
  ps = precisions[indices]

  xs = rep(0,num.samples)
  ys = rep(0,num.samples)
  ## point lies between rs[index-1] and rs[index]
  index = 1
  for (i in 1:num.samples) {
    ## evenly spaced in [0,1], including end-points
    recall = (i-1)/(num.samples-1)
    xs[i] = recall

    while (rs[index]<recall) {
      index = index + 1
    }

    if (index==1) {
      ## use (0,1) as beginning interp point (creates horizontal line
      ## from smallest (r,p) at y=p
      ys[i] = interpolate.point(0,1,rs[index],ps[index],recall)
    }
    else {
      ys[i] = interpolate.point(rs[index-1],ps[index-1],rs[index],ps[index],recall)
    }
  }
  return(list(x=xs,y=ys))
}

## Use ROC interpolation to calculate areas between PR points
## Assumes recalls has no duplicates and sorted in ascending order
## only calculates area from min(recalls) to max(recalls)
interpolate.area <- function(recalls, precisions) {
  area = 0.0

  for (i in 2:length(recalls)) {
    ## calculate area for recalls[i-1] to recalls[i]

    r1 = recalls[i-1]
    p1 = precisions[i-1]
    r2 = recalls[i]
    p2 = precisions[i]

    if (r1 == r2) {
      cat("WARNING: recalls passed to interpolate.area are not unique\n")
    }
    if (r1 > r2) {
      cat("WARNING: recalls passed to interpolate.area are not sorted ascending\n")
      cat("recalls: ",recalls,"\n")
      cat("precisions: ",precisions,"\n")
    }

    if (r1==0) {
      ## definite integral is undefined
      ## use rectangle with height p2 (as interpolate.curve creates)
      area = area + p2*(r2-r1)

    }
    else {
      ## formula between these is p' = r' / (a + b*r')
      a = (1-p1)*r1/p1 - r1*(1-p2)*r2/(p2*(r2-r1)) + r1*(1-p1)*r1/(p1*(r2-r1))
      b = 1 + (1-p2)*r2/(p2*(r2-r1)) - (1-p1)*r1/(p1*(r2-r1))

      ## indefinite integral is (bx - a log (a + bx))/b^2
      ## area contribution is definite integral from r1 to r2
      area = area + (b*r2 - a*log(a+b*r2))/(b*b) - (b*r1 - a*log(a+b*r1))/(b*b)
    }

  }
  return(area)
}

## estimate PR curve and AUCPR by interpolating between the max
## precisions for each recall
prcurve.interpolate <- function(pos.values,neg.values,conf.level=0.95,conf.int.method="binomial",aggregator = max) {
  t = precisions.recalls.fast(pos.values,neg.values)

  recalls = t$recalls
  precisions = t$precisions

  r.unique = unique(recalls)
  p.max = sapply(r.unique,function(r) { aggregator(precisions[recalls==r])})

  ## sort
  indices = order(r.unique,decreasing=FALSE)
  rs = r.unique[indices]
  ps = p.max[indices]

  area = interpolate.area(rs,ps)

  ci = aucpr.conf.int(area,
    pos.values=pos.values,
    neg.values=neg.values,
    prcurve.estimator= function(p.v,n.v,c.l,c.i.m) { prcurve.interpolate(pos.values=p.v,neg.values=n.v,conf.level=c.l,conf.int.method=c.i.m,aggregator) },
    conf.level=conf.level,
    method=conf.int.method)

  curve = interpolate.curve(rs,ps)

  return(list(area=area,x=curve$x,y=curve$y,conf.int=ci))

}

roccurve.points <- function(pos.values,neg.values) {
  ## 0 for negative, 1 for positive
  l = rep(c(0,1),c(length(neg.values),length(pos.values)))
  v = c(neg.values,pos.values)

  ## sort by descending value
  indices = order(v,decreasing=TRUE)
  labels = l[indices]
  values = v[indices]

  tp = 0
  fp = 0

  z = 1
  tprs = rep(0,length(indices)+1)
  fprs = rep(0,length(indices)+1)

  for (i in 1:length(indices)) {
    if (labels[i]==1) { tp = tp + 1 }
    else { fp = fp + 1 }

    ## make sure not between tied values
    if (i==length(indices) || values[i]>values[i+1]) {
      ## can place threshold

      ## if first, insert the all negative point (tpr=0,fpr=0)
      if (z==1) {
        tprs[z] = 0
        fprs[z] = 0
        z = z + 1
      }
      tprs[z] = tp/length(pos.values)
      fprs[z] = fp/length(neg.values)
      z = z + 1
    }
  }

  ## truncate to used indices
  tprs = tprs[1:(z-1)]
  fprs = fprs[1:(z-1)]

  return (list(tprs=tprs,fprs=fprs))
}

## Estimate PR curve by taking convex hull in ROC space, convert only
## points on convex hull in ROC to PR, then use interpolation to go
## between.
prcurve.interpolate.convex <- function(pos.values, neg.values, conf.level=0.95,conf.int.method="binomial") {
  pi = length(pos.values)/(length(pos.values)+length(neg.values))

  t = roccurve.points(pos.values,neg.values)

  ## add the point (1,0) to make convex hull calculation clean (won't
  ## pick up any worse than random points)
  points = matrix(c(t$fprs,1,t$tprs,0),ncol=2)

  hull.indices = chull(points)

  ## remove the dummy point (0,1) we added, it's always the last element
  ## with index length(points)/2
  indices = hull.indices[!hull.indices==length(points)/2]
  points = points[indices,]

  ## due to bugs in chull and just to be safe sort points ascending by
  ## recall (second column)
  points = points[order(points[,2],decreasing=FALSE),]

  ## convert to PR space
  precisions = rep(0,length(indices))
  recalls = rep(0,length(indices))
  for (i in 1:length(indices)) {
    if (points[i,1]==0 & points[i,2]==0) {
      ## all negative
      precisions[i] = 1.0
      recalls[i] = 0.0
    }
    else {
      recalls[i] = points[i,2]
      precisions[i] = pi*points[i,2]/(pi*points[i,2] + (1-pi)*points[i,1])
    }
  }

  ## remove duplicate recalls, most likely having multiple recall=1.0
  ## points coming from the y=1 horizontal line in ROC space
  recalls.unique = unique(recalls)
  precisions.unique = sapply(recalls.unique,function(r) { max(precisions[recalls==r])})

  ## check that recalls are sorted ascending, having problems with non-sorted recalls
  if (is.unsorted(recalls.unique)) {
    cat("pos.values = ",pos.values,"\n")
    cat("neg.values = ",neg.values,"\n")
    cat("recalls = ",recalls,"\n")
    cat("precisions = ",precisions,"\n")
    cat("recalls.unique = ",recalls.unique,"\n")
    cat("precisions.unique = ",precisions.unique,"\n")

  }

  area = interpolate.area(recalls.unique,precisions.unique)

  ci = aucpr.conf.int(area,
    pos.values=pos.values,
    neg.values=neg.values,
    prcurve.estimator=prcurve.interpolate.convex,
    conf.level=conf.level,
    method=conf.int.method)

  curve = interpolate.curve(recalls.unique,precisions.unique)

  return(list(area=area,x=curve$x,y=curve$y,conf.int=ci))

}

## stratified bootstrap
## resample positive and negative separately
bootstrap <- function(pos.values,neg.values,prcurve.function,replicates=1000) {
  areas = rep(0,replicates)

  for (i in 1:replicates) {
    p.v = sample(pos.values,replace=TRUE)
    n.v = sample(neg.values,replace=TRUE)

    res = prcurve.function(p.v,n.v)
    areas[i] = res$area
  }

  return(areas)
}


"
Проверить работу арифметических операторов и приоритет выполнения операций в сложных выражениях
Выполнить серию из 10 вычислений по различным самостоятельно придуманным
формулам.Использовать все операторы из таблицы 1.

Выяснить правило, по которому выполняется расчет, если в формуле используется целочисленное деление
и остаток от деления. Убедиться, что значения выражений дают предсказуемый вами результа
т."

n <- 6
k <- 4
result <- factorial(n)/factorial(n-k)
print(result)

for (n in 1:16) {
  print(paste(n, "! = ", prod(1:n), sep = ""))
}

result <- 1+3
print(result)
result <- 1-3
print(result)
result <- 1*3
print(result)
result <- 1/3
print(result)
result <- 2^3
print(result)
result <- 2%/%3
print(result)
result <- 2%%3
print(result)


#!/usr/bin/env Rscript

##########################################
### 系数矩阵 (coeffcient matrix)
##########################################
r1 = c(1, -2, 1)
r2 = c(0, 2, -8)
r3 = c(-4, 5, 9)
coe = rbind(r1, r2, r3)

rownames(coe) = paste("r", seq(1, dim(coe)[1]), sep = "")
colnames(coe) = paste("x", seq(1, dim(coe)[2]), sep = "")

##########################################
### 增广矩阵 (augmented matrix)
##########################################
b = c(0, 8, -9)
aug = cbind(coe, b)

colnames(aug)[4] <- "y"

##########################################
### 高斯消去(Gauss-Jordan elimination)
##########################################
library("pracma")
help("rref")  # reduced row echelon form
rref(aug)

A = rbind(c(0,-3,-6,4,9),
          c(-1,-2,-1,3,1),
          c(-2,-3,0,3,-1),
          c(1,4,5,-9,-7))
rref(A)

B = rbind(c(0,3,-6,6,4,-5),
          c(3,-7,8,-5,8,9),
          c(3,-9,12,-9,6,15))
rref(B)

##########################################
### 基本变量和自由变量
### 主元列--> 基本变量 (化简后列上有非0值)
### 存在自由变量 --> 有通解
### R3 坐标系中, 有通解表示解再两个平面的交线上
##########################################

##########################################
### 线性组合 (理解几何意义) ---> 很重要的一课
### 向量加法的平行四边型法则 v, u, 0, (v+u)
### 线性代数的主要思想:
### TODO: 为某一已知的向量{v1, v2, v3, ... vp}线性组合出的所有向量
### span{v1, v2, ..., vp} = all c1v1 + c2v2 + ... + cpvp  向量集合
### 组合的意义
### 组合的几何意义
### 某一向量的b --> [a1, a2, ..., an]线性组合--> 这个b应该就是span中的一个
##########################################

############################################################
### 矩阵方程Ax = b
### 向量的线性组合看作[矩阵]与[向量]的积
### 矩阵 ---> 用来线性组合的列向量的组成
### 向量 ---> 线性组合时用到的常数组成
### >>>>> 矩阵方程, 向量方程, 线性方程组 <<<<<<
############################################################

############################################################
### Test
############################################################
A = cbind(c(1,-4,-3),
          c(3,2,-2),
          c(4,-6,-7),
          c(-5, -5, 0))
rref(A)

############################################################
### 齐次方程  Ax = 0
### 非齐次    Ax = b
### 通解的几何意义
############################################################

############################################################
### 矩阵变换 一个空间--> 另一个空间 (映射像)
### Ax = b --> T(x)
### A的n列 --> T的定义域R(n) ,  A每列m个元素--> T的余定义域
### m > n --> 原像
### m < n --> 投影
### m = n --> 剪切,拉伸等变换
############################################################


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

rm(list = ls())

observed <- c(23, 18, 12, 7)

(k <- length(observed))
# 4

(n <- sum(observed))
# 60

LogLikelihood <- function(p, y) {
  (sum(y[1:(k - 1)] * dgeom(0:(k - 2), prob = p, log = TRUE)) +
     y[k] * pgeom(k - 2, prob = p, lower.tail = TRUE))
}

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

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

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

## a)

(expected <- n * c(dgeom(0:(k - 2), prob = p.hat), 1 - pgeom(k - 2, prob = p.hat)))
# 34.0809820392142 14.7224264265935 6.35984724962043 4.83674428457189

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

(pvalue <- 1 - pchisq(Q, df = (k - 1) - 1))
# 0.00579381114321054

## b)

alpha <- 0.05

(criticvalue <- qchisq(1 - alpha, df = k - 1))
# 7.81472790325118

(alternative <- n * c(dnbinom(0:(k - 2), size = 2, prob = 0.6), 1 - pnbinom(k - 2, size = 2, prob = 0.4)))
# 21.6 17.28 10.368 28.512

(null <- n * c(dgeom(0:(k - 2), prob = 0.4), 1 - pgeom(k - 2, prob = 0.4)))
# 24 14.4 8.64 12.96

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

(power <- 1 - pchisq(criticvalue, df = k - 1, ncp = Q))
# 0.973940021807995

## c)

fn <- function(n) {
  alternative <- n * c(dnbinom(0:(k - 2), size = 2, prob = 0.6), 1 - pnbinom(k - 2, size = 2, prob = 0.4))
  null <- n * c(dgeom(0:(k - 2), prob = 0.4), 1 - pgeom(k - 2, prob = 0.4))

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

  return(power)
}

(n.exact <- uniroot(function(n){ fn(n) - 0.7 }, c(1, 100))$root)
# 26.6113581747679

ceiling(n.exact)
# 27


library("plyr")
library("MASS")

################################################################################
#   a
################################################################################
colours <- terrain.colors(5)

drawDataPoints <- function (inputs) {
    classA <- inputs[inputs$class == 1, ]
    classB <- inputs[inputs$class == 0, ]

    points(classA$x, classA$y, col = colours[1], lwd = 3)
    points(classB$x, classB$y, col = colours[2], lwd = 3)
}

drawDecisionBoundaryL <- function (weights, i = 1) {
    a <- weights[1]
    b <- weights[2]
    c <- weights[3]
    plot(NA, NA, xlim=c(-2,2), ylim=c(-2,2), xlab="x", ylab="y", col = colours[i])
    abline(-(c/b), -(a/b))
}

drawDecisionBoundaryQ <- function (weights, xlim = c(-2,2), ylim = c(-2,2), length = 10) {
    f <- Vectorize(function(x,y) sum(featureQ(c(x, y)) * weights))
    x <- seq(xlim[1], xlim[2], length = length)
    y <- seq(ylim[1], ylim[2], length = length)
    z <- outer(x,y,f)
    contour(
        x = x, y = x, z = z,
        levels = 0, las = 1, drawlabels = FALSE, lwd = 3,
        xlim=xlim, ylim=ylim, xlab="x", ylab="y", add = TRUE
    )
}
drawErrors <- function (errors) {
    plot(errors, xlab="iteration", ylab="error", type="s")
}

featureL <- function (input) {
    x <- unlist(input[1])
    y <- unlist(input[2])
    return(unlist(c(x, y, 1)))
}

featureQ <- function (input) {
    x <- unlist(input[1])
    y <- unlist(input[2])
    return(unlist(c(x * x, x * y, y * y, x, y, 1)))
}

# activation function
hardlimiter <- function (n) {
    if (n > 0) {
        return(1)
    } else {
        return(0)
    }
}

sigmoid <- function (n) 1/(1 + exp(-n))

id <- function (n) n

perceptron <- function (input, weights, feature, activate) {
    return(activate(sum(feature(input) * weights)))
}

classifyA <- function (feature, activation, learningRate, iteration, inputs, weights) {
    errors <- c()
    for (j in 1:iteration) {
        numberOfErrors <- 0
        for (i in 1:nrow(inputs)) {
            input <- inputs[i, ]
            output <- perceptron(input, weights, feature, activation)
            error <- input$class - output
            correction <- error * learningRate
            weights <- weights + feature(input) * correction
            if (error != 0)
                numberOfErrors <- numberOfErrors + 1
        }
        errors <- c(errors, numberOfErrors)
    }
    return(list(
        weights = weights,
        errors = errors
        ))
}

inputs <- data.frame(
    x = c(-1, -1, 1, 1),
    y = c(-1, 1, -1, 1),
    class = c(1, 0, 0, 1))

result <- classifyA(featureQ, hardlimiter, 0.1, 100, inputs, rep(0, 6))
plot(NA, NA, xlim=c(-2,2), ylim=c(-2,2), xlab="x", ylab="y")
drawDecisionBoundaryQ(result$weights)
drawDataPoints(inputs)
title("(a) dividing XOR with quadratic perceptrons")

drawErrors(result$errors)
title("error / iteration")

################################################################################
#   b
################################################################################

plotBoundary3 <- function(weights) {
    # vectors
    l01 <- weights[, 1] - weights[, 2]
    l12 <- weights[, 2] - weights[, 3]
    l20 <- weights[, 3] - weights[, 1]

    # cross point
    x <- ((l01[2]*l12[3])/l12[2] - l01[3]) / (l01[1] - (l12[1]*l01[2])/l12[2])
    y <- ((l01[1]*l12[3])/l12[1] - l01[3]) / (l01[2] - (l12[2]*l01[1])/l12[1])

    slope01 = l01[1]/(-l01[2])
    slope12 = l12[1]/(-l12[2])
    slope20 = l20[1]/(-l20[2])
    segments(x, y, x - 100, y - slope01 * 100)
    segments(x, y, x + 100, y + slope12 * 100)
    segments(x, y, x - 100, y - slope20 * 100)
}

tagClass <- function (inputs, class) {
    return(data.frame(x = inputs[, 1], y = inputs[, 2], class = class))
}

class0 = list(
    mean = c(0, 0),
    sigma = matrix(c(1, 0, 0, 1), 2, 2))

class1 = list(
    mean = c(10, 0),
    sigma = matrix(c(1, 0, 0, 4), 2, 2))

class2 = list(
    mean = c(5, 10),
    sigma = matrix(c(4, 0, 0, 1), 2, 2))

class0raw = mvrnorm(n = 100, class0$mean, class0$sigma)
class1raw = mvrnorm(n = 100, class1$mean, class1$sigma)
class2raw = mvrnorm(n = 100, class2$mean, class2$sigma)

class0 = tagClass(class0raw, 0)
class1 = tagClass(class1raw, 1)
class2 = tagClass(class2raw, 2)

weights = matrix(0, 3, 3)
learningRate <- 0.5
iteration <- 100
errors <- c()
for (j in 1:iteration) {    # interation
    size <- nrow(class0)
    numberOfErrors <- 0
    for (i in 1:size) { # number of data
        inputs <- matrix(c(class0[i, ], class1[i, ], class2[i, ]), 3, 3)
        numberOfClasses <- 3
        for (k in 1:numberOfClasses) { # each classes
            input <- inputs[, k]
            outputs <- c(perceptron(input, weights[, 1], featureL, hardlimiter),
                perceptron(input, weights[, 2], featureL, hardlimiter),
                perceptron(input, weights[, 3], featureL, hardlimiter))

            correction <- featureL(input) * learningRate
            for (m in 1:numberOfClasses) {
                if (m == k && outputs[m] == 0) { # reinforce
                    weights[, m] <- weights[, m] + correction
                    numberOfErrors <- numberOfErrors + 1
                }

                if (m != k && outputs[m] == 1) { # punish
                    weights[, m] <- weights[, m] - correction
                    numberOfErrors <- numberOfErrors + 1
                }
            }
        }
    }
    errors <- c(errors, numberOfErrors)
}
plot(NA, NA, xlim=c(-20,20), ylim=c(-20,20), xlab="x", ylab="y")
points(class0, col = colours[1])
points(class1, col = colours[2])
points(class2, col = colours[3])

plotBoundary3(weights)
title("(b) linear multiclass perceptron with hardlimiter activation function")
drawErrors(errors)
title("error / iteration")

weights = matrix(0, 3, 3)
learningRate <- 0.5
iteration <- 100
errors <- c()
for (j in 1:iteration) {    # interation
    size <- nrow(class0)
    numberOfErrors <- 0
    for (i in 1:size) { # number of data
        inputs <- matrix(c(class0[i, ], class1[i, ], class2[i, ]), 3, 3)
        numberOfClasses <- 3
        for (k in 1:numberOfClasses) { # each classes
            input <- inputs[, k]
            outputs <- c(perceptron(input, weights[, 1], featureL, sigmoid),
                perceptron(input, weights[, 2], featureL, sigmoid),
                perceptron(input, weights[, 3], featureL, sigmoid))

            # wrong prediction, adjust all weights
            if (max(outputs) != outputs[k] || min(outputs) == outputs[k]) {
                correction <- featureL(input) * learningRate
                for (m in 1:numberOfClasses) {
                    if (m == k) {   # reinforce
                        weights[, m] <- weights[, m] + correction
                    } else {
                        weights[, m] <- weights[, m] - correction
                    }
                }
                numberOfErrors <- numberOfErrors + 1
            }
        }
    }
    errors <- c(errors, numberOfErrors)
}

plot(NA, NA, xlim=c(-20,20), ylim=c(-20,20), xlab="x", ylab="y")
points(class0, col = colours[1])
points(class1, col = colours[2])
points(class2, col = colours[3])

plotBoundary3(weights)
title("(b) linear multiclass perceptron with sigmoid activation function")

drawErrors(errors)
title("error / iteration")

################################################################################
#   c
################################################################################

class3 = list(
    mean = c(5, 5),
    sigma = matrix(c(1, 0, 0, 1), 2, 2))
class3 = tagClass(mvrnorm(n = 100, class3$mean, class3$sigma), 3)

weights = matrix(0, 6, 4)
learningRate <- 1
iteration <- 500
errors <- c()
for (j in 1:iteration) {    # interation
    size <- nrow(class0)
    numberOfErrors <- 0
    for (i in 1:size) { # number of data
        inputs <- matrix(c(class0[i, ], class1[i, ], class2[i, ], class3[i, ]), 3, 4)
        numberOfClasses <- 4
        for (k in 1:numberOfClasses) { # each classes
            input <- inputs[, k]
            outputs <- c(perceptron(input, weights[, 1], featureQ, hardlimiter),
                perceptron(input, weights[, 2], featureQ, hardlimiter),
                perceptron(input, weights[, 3], featureQ, hardlimiter),
                perceptron(input, weights[, 4], featureQ, hardlimiter))
            correction <- featureQ(input) * learningRate
            for (m in 1:numberOfClasses) {
                if (m == k && outputs[m] == 0) { # reinforce
                    weights[, m] <- weights[, m] + correction
                    numberOfErrors <- numberOfErrors + 1
                }

                if (m != k && outputs[m] == 1) { # punish
                    weights[, m] <- weights[, m] - correction
                    numberOfErrors <- numberOfErrors + 1
                }
            }
        }
    }
    errors <- c(errors, numberOfErrors)
}

plot(NA, NA, xlim=c(-20,20), ylim=c(-20,20), xlab="x", ylab="y")
points(class0, col = colours[1])
points(class1, col = colours[2])
points(class2, col = colours[3])
points(class3, col = colours[4])
drawDecisionBoundaryQ(weights[, 1], xlim = c(-20, 20), ylim = c(-20, 20), length = 100)
drawDecisionBoundaryQ(weights[, 2], xlim = c(-20, 20), ylim = c(-20, 20), length = 100)
drawDecisionBoundaryQ(weights[, 3], xlim = c(-20, 20), ylim = c(-20, 20), length = 100)
drawDecisionBoundaryQ(weights[, 4], xlim = c(-20, 20), ylim = c(-20, 20), length = 100)
title("(b) quadratic multiclass perceptron with hardlimiter activation function")

drawErrors(errors)
title("error / iteration")

weights = matrix(0.5, 6, 4)
learningRate <- 0.1
iteration <- 500
errors <- c()
for (j in 1:iteration) {    # interation
    size <- nrow(class0)
    numberOfErrors <- 0
    for (i in 1:size) { # number of data
        inputs <- matrix(c(class0[i, ], class1[i, ], class2[i, ], class3[i, ]), 3, 4)
        numberOfClasses <- 4
        for (k in 1:numberOfClasses) { # each classes
            input <- inputs[, k]
            outputs <- c(
                perceptron(input, weights[, 1], featureQ, sigmoid),
                perceptron(input, weights[, 2], featureQ, sigmoid),
                perceptron(input, weights[, 3], featureQ, sigmoid),
                perceptron(input, weights[, 4], featureQ, sigmoid))

            for (m in 1:numberOfClasses) {
                if (m == k && outputs[m] < 0.9) { # reinforce
                    correction <- featureQ(input) * learningRate * (1 - outputs[m])
                    weights[, m] <- weights[, m] + correction
                    numberOfErrors <- numberOfErrors + 1
                }

                if (m != k && outputs[m] > 0.1) { # punish
                    correction <- featureQ(input) * learningRate * (0 - outputs[m])
                    weights[, m] <- weights[, m] + correction
                    numberOfErrors <- numberOfErrors + 1
                }
            }
        }
    }
    errors <- c(errors, numberOfErrors)
}

plot(NA, NA, xlim=c(-20,20), ylim=c(-20,20), xlab="x", ylab="y")
points(class0, col = colours[1])
points(class1, col = colours[2])
points(class2, col = colours[3])
points(class3, col = colours[4])
drawDecisionBoundaryQ(weights[, 1], xlim = c(-20, 20), ylim = c(-20, 20), length = 100)
drawDecisionBoundaryQ(weights[, 2], xlim = c(-20, 20), ylim = c(-20, 20), length = 100)
drawDecisionBoundaryQ(weights[, 3], xlim = c(-20, 20), ylim = c(-20, 20), length = 100)
drawDecisionBoundaryQ(weights[, 4], xlim = c(-20, 20), ylim = c(-20, 20), length = 100)
title("(b) quadratic multiclass perceptron with sigmoid activation function")

drawErrors(errors)
title("error / iteration")