# Filename:	code.r
# Project:	/Users/shume/Developer/stat/MedicalStatisticsClass/2019/3
# Authors:	shumez <https://github.com/shumez>
# Created:	2019-10-23 16:38:57
# Modified:	2019-11-10 15:02:05
# -----
# Copyright (c) 2019 shumez

##### 医学統計勉強会18　第3回　連続変数の比較　R code #####

# 二標本問題 ##
x1 <- c(8, 17, 9, 5, 14, 13, 13, 3, 9, 0)
x2 <- c(19, 13, 13, 18, 21, 18, 11, 21, 20, 11)

boxplot(x1, x2)

t.test(x1, x2)		# Welch's t test
wilcox.test(x1, x2)	# Mann-Whitney test, Wilcoxon's rank sum test

# QQ-norm plot #

qqplot(x1)
qqline(x1)

qqplot(x2)
qqline(x2)

# Shapiro-Wilk normality test #

shapiro.test(x1)

## 分散分析 ##

# サンプルデータ #
Data <- data.frame(
	z = c(8, 16, 7, 18, 6, 11, 15, 11, 20, 7, 19, 20, 21, 19, 24),
	group = factor(c(rep(1,5), rep(2,5), rep(3,5)), label=c("placebo", "drugA", "drugB")))
print(Data)
boxplot(z ~ group, data=Data)

# One-way ANOVA #
fit.aov <- aov(z ~ group, data=Data)
summary(fit.aov)

# One-way ANOVA (not assuming equal variances) #
oneway.test(z ~ group, data=Data)

# Kruskal-Wallis rank sum test #
kruskal.test(z ~ group, data=Data)

## モデル診断 (model diagnostics) ##

par(mfrow=c(2,2))
plot(fit.aov)
par(mfrow=c(1,1))

## Box-Cox transformation ##

library(MASS)
bxcx <- boxcox(fit.aov)
lambda <- bxcx$x[which.max(bxcx$y)]

fit.aov2 <- aov((z^lambda - 1)/lambda ~ group, data=Data)
summary(fit.aov2)

par(mfrow=c(2,2))
plot(fit.aov2)
par(mfrow=c(1,1))

## 多重比較 ##

# Tukey's method #
library(MASS)
fit.mc <- TukeyHSD(fit.aov)
print(fit.mc)
plot(fit.mc)

# Dunnett's method (Dunnett post hoc test) #
install.packages("multcomp")	# 最初の一回のみ実行
library(multcomp)
fit.dunnett <- glht(fit.aov, linfct = mcp(group = "Dunnett"))
confint(fit.dunnett, level=0.95)
summary(fit.dunnett)

# William's method #
fit.williams <- glht(fit.aov, linfct = mcp(group = "Williams"))
confint(fit.williams, level=0.95)
summary(fit.williams)


# La mecánica detrás del OLS (II): matrices en R.

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

# definir x
x = matrix(
  c(1,1,1,2,7,3,2,4,6),
  nrow = 3,
  ncol = 3
  )

x

# definir y
y = matrix(
    c(3,5,7),
  nrow = 3,
  ncol = 1
)

y
###########################
# transponer x con comando "t"
###########################
t(x)

###########################
# x'x
###########################
t(x) %*% x

###########################
# inverse
###########################

## primero, encontrar determinante
# det(t(x)%*%x)
# 324

## segundo, encontrar Adjacente

# Hagamos el proceso de manera directa. Invirtamos x'x

solve(t(x)%*%x)

###########################
# Modelo
###########################

# En Matriz: b = (x'x)-1*x'y
options(scipen=99)
solve(t(x) %*% x)%*%t(x)%*%y # beta

b = round(solve(t(x) %*% x)%*%t(x)%*%y, 0)
b

# Usando el comando "lm"
data = data.frame(
        x=x[,2:3],
        y=y
        )

data

modelo = lm(y ~ x.1 + x.2, data) # "lineal model"
summary(modelo)


library(VGAM)

###############################################################################
#
# library
#
# source the plfit.r function (from http://www.santafe.edu/~aaronc/powerlaws/)
# if needed
# source("plfit.r")
#
###############################################################################
#
# example zone
#
###############################################################################
runexample <- function(){
 set.seed(123)
 x <- (1-runif(1000))^(-1/(2.5-1))
 #if plfit exist (with source("plfit.r") for example):
 #plfit(x)
 #plfit R : xmin=1.007756 alpha=2.517830 D=0.02054889
 plpva(x,1)
 #plpva R p=0.233 gof=0.02164176
}
###############################################################################
# PLPVA  calculates the p-value for the given power-law fit to some data.
#    Source: http://www.santafe.edu/~aaronc/powerlaws/
#
#    PLPVA(x, xmin) takes data x and given lower cutoff for the power-law
#    behavior xmin and computes the corresponding p-value for the
#    Kolmogorov-Smirnov test, according to the method described in
#    Clauset, Shalizi, Newman (2007).
#    PLPVA automatically detects whether x is composed of real or integer
#    values, and applies the appropriate method. For discrete data, if
#    min(x) > 1000, PLPVA uses the continuous approximation, which is
#    a reliable in this regime.
#
#    The fitting procedure works as follows:
#    1) For each possible choice of x_min, we estimate alpha via the
#       method of maximum likelihood, and calculate the Kolmogorov-Smirnov
#       goodness-of-fit statistic D.
#    2) We then select as our estimate of x_min, the value that gives the
#       minimum value D over all values of x_min.
#
#    Note that this procedure gives no estimate of the uncertainty of the
#    fitted parameters, nor of the validity of the fit.
#
#    Example:
#       x <- (1-runif(10000))^(-1/(2.5-1))
#       plpva(x,1)
#
# Version 1.0   (2012 August)
#
# Copyright (C) 2012 Laurent Dubroca (Sete, France)
# laurent - dot -dubroca - at - gmail - dot - com
# Distributed under GPL 2.0
# http://www.gnu.org/copyleft/gpl.html
# PLPVA comes with ABSOLUTELY NO WARRANTY
# Matlab to R translation based on the original code of Aaron Clauset (Santa Fe Institute)
# Source: http://www.santafe.edu/~aaronc/powerlaws/
#
# Notes:
#
# 1. In order to implement the integer-based methods in R, the numeric
#    maximization of the log-likelihood function was used. This requires
#    that we specify the range of scaling parameters considered. We set
#    this range to be seq(1.5,3.5,0.01) by default. This vector can be
#    set by the user like so,
#
#       a <- plpva(x,1,vec=seq(1.001,5,0.001))
#
# 2. plvar can be told to limit the range of values considered as estimates
#    for xmin in two ways. First, it can be instructed to sample these
#    possible values like so,
#
#       a <- plpva(x,1,"sample",100)
#
#    which uses 100 uniformly distributed values on the sorted list of
#    unique values in the data set. Alternatively, it can simply omit all
#    candidates below a hard limit, like so
#
#       a <- plpva(x,1,"limit",3.4)
#
#    In the case of discrete data, it rounds the limit to the nearest
#    integer.
#
# 3. The default number of nonparametric repetitions of the fitting
# procedure is 1000. This number can be changed like so
#
#       a <- plpva(x,Bt=10000)
#
# 4. To silence the textual output to the screen, do
#
#       a <- plpva(x,1,quiet=TRUE)
#
###############################################################################
plpva<-function(x=rpareto(1000,10,2.5),xmin=1,method="limit",value=c(),Bt=1000,quiet=FALSE,vec=seq(1.5,3.5,.01)){
   #init method value to NULL
   sampl <- c() ; limit <- c()
###########################################################################################
#
#  test and trap for bad input
#
   switch(method,
     sample = sampl <- value,
     limit = limit <- value,
     argok <- 0)

   if(exists("argok")){stop("(plvar) Unrecognized method")}

   if( !is.null(vec) && (!is.vector(vec) || min(vec)<=1 || length(vec)<=1) ){
     print(paste("(plvar) Error: ''range'' argument must contain a vector > 1; using default."))
     vec <- c()
   }
   if( !is.null(sampl) && ( !(sampl==floor(sampl)) ||  length(sampl)>1 || sampl<2 ) ){
     print(paste("(plvar) Error: ''sample'' argument must be a positive integer > 2; using default."))
     sample <- c()
   }
   if( !is.null(limit) && (length(limit)>1 || limit<1) ){
     print(paste("(plvar) Error: ''limit'' argument must be a positive >=1; using default."))
     limit <- c()
   }
   if( !is.null(Bt) && (!is.vector(Bt) || Bt<=1 || length(Bt)>1) ){
     print(paste("(plvar) Error: ''Bt'' argument must be a positive value > 1; using default."))
     vec <- c()
   }

#  select method (discrete or continuous) for fitting and test if x is a vector
   fdattype<-"unknow"
   if( is.vector(x,"numeric") ){ fdattype<-"real" }
   if( all(x==floor(x)) && is.vector(x) ){ fdattype<-"integer" }
   if( all(x==floor(x)) && min(x) > 1000 && length(x) > 100 ){ fdattype <- "real" }
   if( fdattype=="unknow" ){ stop("(plfit) Error: x must contain only reals or only integers.") }

   N   <- length(x)
   nof <- rep(0,Bt)

   if( !quiet ){
     print("Power-law Distribution, parameter error calculation")
     print("Warning: This can be a slow calculation; please be patient.")
     print(paste(" n =",N,"xmin =",xmin,"- reps =",Bt,fdattype))
   }
#
#  end test and trap for bad input
#
###########################################################################################

###########################################################################################
#
#  estimate xmin and alpha in the continuous case
#
   if( fdattype=="real" ){

     # compute D for the empirical distribution
     z     <- x[x>=xmin];     nz   <- length(z)
     y     <- x[x<xmin];      ny   <- length(y)
     alpha <- 1 + nz/sum(log(z/xmin))
     cz    <- (0:(nz-1))/nz
     cf    <- 1-(xmin/sort(z))^(alpha-1)
     gof   <- max(abs(cz-cf))
     pz    <- nz/N

     # compute distribution of gofs from semi-parametric bootstrap
     # of entire data set with fit
     for(B in 1:length(nof)){
       # semi-parametric bootstrap of data
       n1 <- sum(runif(N)>pz)
       q1 <- y[sample(ny,n1,replace=TRUE)]
       n2 <- N-n1
       q2 <- xmin*(1-runif(n2))^(-1/(alpha-1))
       q  <- sort(c(q1,q2))

       # estimate xmin and alpha via GoF-method
       qmins <- sort(unique(q))
       qmins <- qmins[-length(qmins)]
       if(!is.null(limit)){
	 qmins<-qmins[qmins<=limit]
       }
       if(!is.null(sampl)){
	 qmins <- qmins[unique(round(seq(1,length(qmins),length.out=sampl)))]
       }
       dat <-rep(0,length(qmins))
       for(qm in 1:length(qmins)){
         qmin <- qmins[qm]
         zq   <- q[q>=qmin]
         nq   <- length(zq)
         a    <- nq/sum(log(zq/qmin))
         cq   <- (0:(nq-1))/nq
         cf   <- 1-(qmin/zq)^a
         dat[qm] <- max(abs(cq-cf))
       }
       if(!quiet){
	 print(paste(B,sum(nof[1:B]>=gof)/B))
       }
       # store distribution of estimated gof values
       nof[B] <- min(dat)
     }
   }

###########################################################################################
#
#  estimate xmin and alpha in the discrete case
#
   if( fdattype=="integer" ){

     if( is.null(vec) ){ vec<-seq(1.5,3.5,.01) } # covers range of most practical scaling parameters
     zvec <- zeta(vec)

     # compute D for the empirical distribution
     z     <- x[x>=xmin];     nz   <- length(z);    xmax <- max(z)
     y     <- x[x<xmin];      ny   <- length(y)

     if(xmin==1){
       zdiff <- rep(0,length(vec))
     }else{
       zdiff <- apply(rep(t(1:(xmin-1)),length(vec))^-t(kronecker(t(array(1,xmin-1)),vec)),2,sum)
     }
     # matlab: L = -vec.*sum(log(z)) - n.*log(zvec - zdiff);
     L <- -vec*sum(log(z)) - nz*log(zvec - zdiff);
     I <- which.max(L)
     alpha <- vec[I]

     fit <- cumsum((((xmin:xmax)^-alpha))
                   / (zvec[I]
                      - (if (xmin == 1) 0 else sum((1:(xmin-1))^-alpha))))

     hist = aggregate(z, list(z), length)
     cdi = rep(0, xmax - xmin + 1)
     cdi[hist$Group.1 - xmin + 1] = hist$x / nz
     cdi = cumsum(cdi)

     gof <- max(abs( fit - cdi ))
     pz  <- nz/N

     mmax <- 20*xmax
     pdf <- c(rep(0,xmin-1),(((xmin:mmax)^-alpha))
              / (zvec[I]
                 - (if (xmin == 1) 0 else sum((1:(xmin-1))^-alpha))))
     cdf <- cbind(1:(mmax+1),c(cumsum(pdf),1))

     # compute distribution of gofs from semi-parametric bootstrap
     # of entire data set with fit
     for(B in 1:Bt){
       # semi-parametric bootstrap of data
       n1 <- sum(runif(N)>pz)
       q1 <- y[sample(ny,n1,replace=TRUE)]
       n2 <- N-n1
       # simple discrete zeta generator
       r2 <- sort(runif(n2));  d <- 1
       q2 <- rep(0,n2);        k <- 1
       for(i in xmin:(mmax+1)){
           while((d <= length(r2)) && (r2[d]<=cdf[i,2])){d <- d+1}
           if (k <= d - 1)
             q2[k:(d-1)] <- i
           k <- d
           if( k > n2 ){break}
       }
       q <-c(q1,q2)
       ########################################
       # estimate xmin and alpha via GoF-method
       qmins <- sort(unique(q))
       qmins <- qmins[-length(qmins)]
       if(!is.null(limit)){
         qmins <- qmins[qmins<=limit]
       }
       if(!is.null(sampl)){
          qmins <- qmins[sort(unique(round(seq(1,length(qmins),length.out=sampl))))]
       }
       dat   <- rep(0,length(qmins))
       qmax  <- max(q)
       zq    <- q

       if (length(qmins) > 0)
         for(qm in 1:length(qmins)){
           qmin <- qmins[qm]
           zq   <- zq[zq>=qmin]
           nq    <- length(zq)
           if(nq>1){
   	   # vectorized version of numerical calculation
             if(qmin==1){
    	     #WARNING
               #zdiff <- rep(1,length(vec))
               #correction added the 6/10/2009 (following Naoki Masuda for plfit)
               zdiff <- rep(0,length(vec))
             }else{
               zdiff <- apply(rep(t(1:(qmin-1)),length(vec))^-t(kronecker(t(array(1,qmin-1)),vec)),2,sum)
             }
             L <- -vec*sum(log(zq)) - nq*log(zvec - zdiff);
             I <- which.max(L)
             # compute KS statistic
             fit <- cumsum((((qmin:qmax)^-vec[I]))
                           / (zvec[I]
                              - (if (qmin == 1) 0 else sum((1:(qmin-1))^-vec[I]))))

             hist = aggregate(zq, list(zq), length)
             cdi = rep(0, qmax - qmin + 1)
             cdi[hist$Group.1 - qmin + 1] = hist$x / nq
             cdi = cumsum(cdi)

             dat[qm] <- max(abs( fit - cdi ))
           }else{
             dat[qm] <- -Inf
           }
         }
       if(!quiet){
         print(paste(B,"-",sum(nof[1:B]>=gof)/B))
       }
       # -- store distribution of estimated gof values
       nof[B] <- min(c(dat, Inf))

     }

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

   }
#
#  end discrete case
#
###########################################################################################
#  return p and gof in a list
   p <- sum(nof>=gof)/length(nof)
   return(list(p=p,gof=gof))
}


dgp <- rpois(100000, 12.75) # pretending we know the true distribution
mean(dgp)

#### sampling uncertainty when sample size is 16 -------------------------------
n <- 16
m <- 10000

set.seed(1)
mus <- c()
for (i in 1:m) {
  x <- sample(dgp, n, rep = T) # sampling with replacement
  mus <- c(mus, mean(x))

  if (i <= 10) {
    print(i)
    print(x)
    print(mean(x))
  }
}

hist(mus, breaks = 20)
print(quantile(mus, p = c(0.025, 0.975)))


quantile_estimation <- function (actual_quantiles, actual_values, estimate_quantiles){
  ##Overview
  #This will return the estimates for the given estimate quantile.  If there are estimates
  #that are above or below the actual data range than the last standard deviation is used
  #for the calculation.  Currently the only family of estimation supported is gaussian.

  ##inputs
  #actual_quantiles: vector of the quantiles for actual data
  #actual_values: the values associated with the actual_quantiles
  #estimate_quantiles: the quantiles to be estimated (0 < estimate_quantiles < 1)

  ##outputs
  #returns a tibble (dplyr dataframe) with estimate being the quantile estimates

  ##dependencies
  #dplyr
  #tidyr

  ##examples
  #tst <- quantile_estimation(actual_quantiles = seq(.05,.95,.05), actual_values = c(253,287,306,320,343,362,377,395,406,419,430,445,462,479,512,546,583,634,771), estimate_quantiles = seq(.01,.99, .01))

  ##load dependencies if not already loaded
  if("dplyr" %in% (.packages())){
    #already loaded
  } else{
    library(dplyr)
  }

  if("tidyr" %in% (.packages())){
    #already loaded
  } else{
    library(tidyr)
  }

  ##Gather data around actual information and information to be estimated
  actual_quantiles <- round(actual_quantiles, 5)
  estimate_quantiles <- round(estimate_quantiles, 5)

  all_quantiles <- sort(unique(c(actual_quantiles, estimate_quantiles)))

  all_sd <- qnorm(p = all_quantiles)
  all_sd_diff <- all_sd[2:length(all_sd)] - all_sd[1:(length(all_sd)-1)]

  ##tibble with only the estimate information
  df_all_estimates <- tibble(
    quantile = all_quantiles
    , sd_diff = lead(qnorm(quantile)) - qnorm(quantile)
  )

  ##tibble with only the actual information
  df_actual <- tibble(
    quantile = actual_quantiles[1:(length(actual_quantiles))]
    , start_quantile = quantile
    , end_quantile = c(actual_quantiles[2:length(actual_quantiles)],NA)
    , val = actual_values[1:(length(actual_values))]
    , end_val = c(actual_values[2:length(actual_values)],NA)
  ) %>% mutate(
    val_diff = end_val - val
    , val_sd = val_diff / (qnorm(end_quantile) - qnorm(start_quantile))
  )

  ##tibble with the actual and estimate information combined
  df_all_estimates <- df_all_estimates %>% left_join(
    df_actual
    , by = 'quantile'
  ) %>% mutate(
    source = case_when(is.na(val) ~ 'ESTIMATE', TRUE ~ 'ACTUAL')
    , group = case_when(
      !is.na(val) ~ paste0(start_quantile," - ", end_quantile)
    )
  ) %>% fill(
    val_sd
    , .direction = 'down'
  ) %>% fill(
    group
    , .direction = 'down'
  ) %>% fill(
    val_sd
    , .direction = 'up'
  ) %>% mutate(
    group = case_when(
      is.na(group) ~ paste0('0 - ', min(actual_quantiles))
      , TRUE ~ group
    )
    , sd_diff = case_when(
      quantile < min(actual_quantiles) ~ -sd_diff
      , TRUE ~ sd_diff
    )
  )

  ##rearrange the estimates that are below the actual range
  df_low_estimates <- df_all_estimates %>% filter(
    quantile < min(actual_quantiles)
  ) %>% arrange(
    desc(quantile)
  ) %>% mutate(
    sd_diff_rt = cumsum(sd_diff)
  ) %>% arrange(
    quantile
  )

  ##Combine the low estimates to the other estimates
  df_all_estimates <- bind_rows(
    df_low_estimates
    , df_all_estimates %>% filter(
      quantile >= min(actual_quantiles)
    ) %>% group_by(
      group
    ) %>% mutate(
      sd_diff_rt = cumsum(
        sd_diff
      )
    )
    )

  ##calculate the estimates
  df_all_estimates <- df_all_estimates %>% fill(
    val
    , .direction = 'down'
  ) %>% fill(
    val
    , .direction = 'up'
  ) %>% mutate(
    sd_diff_rt = case_when(
      quantile < min(actual_quantiles) ~ sd_diff_rt
      , quantile == min(actual_quantiles) ~ 0
      , TRUE ~ lag(sd_diff_rt)
    )
    #, estimate = val + sd_diff_rt * val_sd
    , estimate = case_when(
      source == 'ACTUAL' ~ val
      , TRUE ~ val + sd_diff_rt * val_sd
    )
  )

  return(df_all_estimates)
}


# Convenient functions for evaluating ising model simulators.

#####################################################################
## Functions to order Ising states.

to_binary <- function(n, n_digits, ising_state = FALSE) {
  # Convert base 10 number to base 2 number, with digits
  # stored as an n_digits-vector.
  #
  # n: the state number (start counting at 0)
  # n_digitis: the number of digits, hence of particles in the graph.
  # ising_state: if TRUE, returns a vector 1 and -1, instead of 1 and 0's.
  j = 0
  x = rep(ifelse(ising_state, -1, 0), n_digits)
  while (n > 0) {
    x[n_digits - j] = n %% 2
    if (ising_state && (x[n_digits - j] == 0)) x[n_digits - j] = ifelse(ising_state, -1, 0)
    n = as.integer(n/2)
    j = j + 1
  }
  x
}

to_decimal <- function(samples) {
  # convert samples to decimal numbers
  n_iter = nrow(samples)
  n_particles = ncol(samples)
  decimals <- rep(NA, n_iter)
  for (i in 1:n_iter) {
    decimals[i]  = 0
    for (j in 1:ncol(samples)) decimals[i] = decimals[i] +
        2^{n_particles - j} * samples[i, j] * (samples[i, j] == 1)
  }
  decimals
}

# returns the number of samples with a spin up (+1)
count_states <- function(samples, n_part) {
  0.5 * (rowSums(samples) + n_part)
}

# same as above, but for a single sample
count_states_single <- function(samples, n_part) {
  0.5 * (sum(samples) + n_part)
}

#####################################################################
## Functions to do an exact computation of the partition function.

ising_kernel <- function (beta, A, x, B = 0, log = FALSE) {
  # Returns the kernel for an ising model.
  hamiltonian = 0.5 * beta * (t(x) %*% A %*% x) + B * sum(x)
  if (log) { hamiltonian } else { exp(hamiltonian) }
}

# use this in the tempering algorithm to not double-count the beta.
raw_hamiltonian <- function (A, x) {
  0.5 * t(x) %*% A %*% x
}

potts_log_kernel <- function (beta, A, x, B = 0, n_states = 2) {
  n_particle = nrow(A)
  exp_term = 0
  Y = matrix(NA, nrow = n_particle, ncol = n_states)
  for (l in 1:n_states) {
    Y[, l] = rep(0, n_particle)
    Y[x == l, l] = 1
    exp_term = exp_term + t(Y[, l]) %*% A %*% Y[, l]
  }

  # for (j in 2:n_particle) {
  #   for (i in 1:(j - 1)) {
  #     if (x[i] == x[j]) exp_term = exp_term + A[i, j]
  #   }
  # }

  beta * exp_term
}

partition <- function (beta, A, B = 0, prob = FALSE) {
  # brute-force computes the partition function for
  # an Ising model. Useful for simple configurations
  # and unit tests.
  # If prob = TRUE, return a list which contains the
  # partition function and the probability mass for
  # each configuration.
  n_particles = nrow(A)
  x = rep(-1, n_particles)
  Z = 0
  if (prob) p = rep(NA, 2^n_particles)

  for (i in 0:((2^n_particles) - 1)) {
    # update state of the system
    x = to_binary(i, n_particles, ising_state = TRUE)
    local_kernel = ising_kernel(beta, A, x, B)
    Z = Z + local_kernel
    if (prob) p[i + 1] = local_kernel
  }

  Z = as.numeric(Z)

  if (!prob) { Z } else {
    list(Z = Z, p = p / Z)
  }
}

partition_complete <- function (beta, A, B = 0, prob = FALSE) {
  # a specialized function that computes the partition function
  # for a complete graph.
  # Remark: the probability are over the summary count space.
  n_particles = nrow(A)
  d = A[1, 2]

  # number of positive spins
  # n = 0:(floor(n_particles / 2))
  n = 0:n_particles
  length_n = length(n)
  # double_count = rep(2, length_n)
  # if (n_particles %% 2 == 0) {double_count[length_n] = 1}

  p = rep(NA, n_particles + 1)
  for (i in n) {
    j = i + 1
    p[j] = choose(n_particles, i) * exp(0.5 * beta * d *
                                        (4 * i^2 - 4 * i * n_particles +
                                        n_particles^2 - n_particles) +
                                        B * (2 * i - n_particles))
    # if (double_count[j] == 2) p[n_particles + 1 - (j - 1)] = p[j]
  }

  Z = sum(p)
  if (!prob) { Z } else {
    list(Z = Z, p = p / Z)
  }
}

count_probability <- function(p_analytical, n_particles) {
  # Returns probability over the summary count space, given
  # the exact probability for each state.
  # Useful in non-symmetric cases.

  n_states = length(p_analytical)
  # for (i in 0:n_states) {
  prob = rep(0, n_particles + 1)
  for (i in 0:(n_states - 1)) {
    index = sum(to_binary(i, n_particles, ising_state = FALSE)) + 1
    prob[index] = prob[index] + p_analytical[i + 1]
  }
  prob
}

#####################################################################
# Functions which return performance metrics, based on the
# produced samples.

summary <- function (samples, p_analytical, discard_burn_in = TRUE) {
  # Returns a few summaries statistics, including accuracy ratio
  # and variational distance.
  #
  # samples: simulated samples with x in {-1, 1}^n
  # p_analytical: a vector of probability
  # discard_burn_in: if TRUE, only use the second half of the samples.

  n_particles = ncol(samples)
  n_iter = nrow(samples)
  n_states = 2^n_particles

  # convert results to decimal numbers
  decimals = to_decimal(samples)
  if (discard_burn_in) decimals = decimals[(n_iter / 2):n_iter]

  p_empirical = rep(NA, n_states)
  for (i in 0:(n_states - 1)) p_empirical[i + 1] = sum(decimals == i)
  p_empirical = p_empirical / length(decimals)

  # p_empirical = table(decimals) / length(decimals)

  accuracy_ratio = as.vector(abs(p_empirical / p_analytical - 1))
  max_ratio = max(accuracy_ratio)
  total_distance = 0.5 * sum(abs(p_empirical - p_analytical))
  variational_distance = max(abs(p_empirical - p_analytical))

  list(decimals = decimals,
       accuracy_ratio = accuracy_ratio,
       max_ratio = max_ratio,
       total_distance = total_distance,
       variational_distance = variational_distance)
}

gen_frequency_iter <- function (decimals, n_particles) {
  # Returns a 2-array with the frequency of each state
  # after the i^th iteration.
  # WARNING: this function takes some time to run!
  # For loops in R are very inefficient.
  # FIX ME -- find a slicker way of writing this.

  n_iter = length(decimals)
  n_states = 2^n_particles

  frequency_iter = matrix(0, nrow = n_iter, ncol = 2^n_particles)

  for (j in 1:n_iter) {
    if (j %% 100 == 0) print(paste0("iteration: ", j, " / ", n_iter))
    unique_elements = sort(unique(decimals[1:j])) + 1  # adjust index
    current_frequency = table(decimals[1:j]) / j

    if (length(current_frequency) == n_states) {
      frequency_iter[j, ] = current_frequency
    } else {
      for (i in 1:length(unique_elements)) {
        frequency_iter[j, unique_elements[i]] = current_frequency[i]
      }
    }
  }

  frequency_iter
}

ttv_total <- function (samples, p_analytical, discard_burn_in = TRUE) {
  # Return the total variational distance (ttv).
  n_particles = ncol(samples)
  n_iter = nrow(samples)
  n_states = 2^n_particles

  # convert results to decimal numbers
  decimals = to_decimal(samples)
  if (discard_burn_in) decimals = decimals[(n_iter / 2):n_iter]

  p_empirical = rep(NA, n_states)
  for (i in 0:(n_states - 1)) p_empirical[i + 1] = sum(decimals == i)
  p_empirical = p_empirical / length(decimals)

  0.5 * sum(abs(p_empirical - p_analytical))
}

ttv_count <- function (samples, p_analytical, discard_burn_in = TRUE) {
  # Return the variational distance over the count space
  # (i.e. the number of up spins)

  n_particles = ncol(samples)
  n_iter = nrow(samples)
  n_states = n_particles + 1

  # convert results to spin up counts.
  if (discard_burn_in) samples = samples[(n_iter / 2):n_iter, ]
  count_sample = count_states(samples, n_particles)

  p_empirical = rep(NA, n_states)
  for (i in 0:(n_states - 1)) p_empirical[i + 1] = sum(count_sample == i)
  p_empirical = p_empirical / length(count_sample)

  0.5 * sum(abs(p_empirical - p_analytical))
}

ttv_comp <- function(samples, p_analytical, type = "total",
                     discard_burn_in = T) {
  if (type == 'total')
    return(ttv_total(samples, p_analytical, discard_burn_in))
  if (type == 'count')
    return(ttv_count(samples, p_analytical, discard_burn_in))
}

ESS <- function(gen_quant, batch_size, burn_in, n_algorithms,
                sd_gen_quant, gq_index = 1) {
  # Do multiple estimates of the generated quantity, by splitting
  # the sample into multiple batches. This allows us to estimate
  # the Monte Carlo error.
  n_sample <- dim(gen_quant)[1]
  batch <- seq(from = burn_in + 1, to = n_sample, by = batch_size)
  batch_means <- matrix(NA, nrow = length(batch), ncol = n_algorithms)
  for (b in 1:length(batch)) {
    for (i in 1:n_algorithms) {
      batch_means[b, i] =
        mean(gen_quant[batch[b]:(batch[b] + batch_size - 1), i, gq_index])
    }
  }
  mc_sd <- rep(NA, n_algorithms)
  ratio <- rep(NA, n_algorithms)
  for (i in 1:n_algorithms) {
    mc_sd[i] <- sd(batch_means[, i])
    ratio[i] <- (sd_gen_quant / mc_sd[i])^2 / 1e3
  }

  list(mc_sd = mc_sd, ratio = ratio)
}

# Compute means for sufficient statistics for an array
# of samples (whihch a n x m x p object)
monte_carlo_estimate <- function(sample_all) {
  n_replica <- dim(sample_all)[1]
  n_iter <- dim(sample_all)[2]

  M_square <- rep(NA, n_replica)
  for (i in 1:n_replica) M_square[i] <- mean(rowSums(sample_all[i, , ])^2)

  mean_log_kernel <- rep(NA, n_replica)
  log_kernel <- array(NA, c(n_replica, n_iter))
  for (i in 1:n_replica) {
    for (j in 1:n_iter) {
      log_kernel[i, j] <- ising_kernel(beta_vector[i], A,
                                       sample_all[i, j, ],
                                       log = T)
    }
    mean_log_kernel[i] <- mean(log_kernel[i, ])
  }

  list(M_square = M_square, mean_log_kernel)
}

###############################################################################
## Function to compute a multivariate normal distribution, given
# a mean vector and cholesky decomposition of the covariance matrix.
mvrnorm_cholesky <- function (n = 1, mu, L) {
  # Samples from a multivariate normal distribution, given a mean vector
  # a (lower triangular) Cholesky decomposition of the covariance matrix.
  dimension <- length(mu)
  X = matrix(NA, nrow = n, ncol = dimension)
  for (i in 1:n) {
    z = rnorm(dimension)
    X[i, ] = L %*% z + mu
  }
  X
}

###############################################################################
## Function to generate the adjancency matrix for special grids

grid_graph <- function (m, anti_corr = FALSE, ignore_degrees = FALSE) {
  # The nodes row-ordered.
  # For example:
  #  1 2 3
  #  4 5 6
  #  7 8 9
  # The nodes are connected using the "+m" and
  # "non-edge neighbor" rules.
  #
  # m: the number of column in the graph, and in the square grid setting
  # the square root of the total number of particles.
  # anti_corr: if true, then the connection is -1 instead of 1 with
  # probability 0.5.

  # FIX ME: condition sometimes fail -- numerical error?
  # if (m %% 1 != 0) stop("The number of particles must be a square!")

  n_particle = m^2
  A = matrix(0, nrow = n_particle, ncol = n_particle)
  for (i in 1:n_particle) {
    # edge neihbor rule
    if (i %% m != 0) {
      if (anti_corr) { connection = 1 - 2 * rbinom(1, 1, 0.5)
      } else { connection = 1}
      A[i + 1, i] = connection
      A[i, i + 1] = connection
    }

    # "+m" rule
    if (i + m <= n_particle) {
      if (anti_corr) { connection = 1 - 2 * rbinom(1, 1, 0.5)
      } else { connection = 1}
      A[i + m, i] = connection
      A[i, i + m] = connection
    }
  }

  degree_of_connect = mean(colSums(abs(A)))
  if (ignore_degrees) { d_divide = 1 } else
    { d_divide = degree_of_connect}
  list(A = A / d_divide, d = degree_of_connect)
}

cube_graph <- function (m, anti_corr = FALSE) {
  # The nodes are row-ordered, then column-ordered.
  # The nodes are connected by first creating the block-diagonal
  # adjacency matrix with grid connection, and then connecting
  # each to the node "in front" of it.
  #
  # m is the lattice number, hence the total number of particles
  # is m x m x m.

  # FIX ME: condition sometimes fail -- numerical error?
  # if (m %% 1 != 0) stop("The number of particles must be a cube!")

  n_particle = m^3
  A = matrix(0, nrow = n_particle, ncol = n_particle)
  for (i in 1:m) {
    grid = grid_graph(m, anti_corr, ignore_degrees = TRUE)
    cube_index = ((i - 1) * m^2 + 1):(i * m^2)
    A[cube_index, cube_index] = grid$A
  }

  for (i in 1:(n_particle - m^2)) {
    j = i + m^2
    if (anti_corr) { connection = 1 - 2 * rbinom(1, 1, 0.5)
    } else { connection = 1}
    A[i, j] = connection
    A[j, i] = connection
  }

  degree_of_connect = mean(colSums(abs(A)))
  list(A = A / degree_of_connect, d = degree_of_connect)
}

cube_graph(m = round(216^{1/3}), anti_corr = TRUE)

# Test the method
# m <- 3
# alpha <- 2
# A <- grid_graph(m)
# C <- A + alpha * diag(m^2)
# solve(C)

adjacency_graph <- function(n_part, type, anti_corr = FALSE,
                            do_round = TRUE, m_hopfield = 1) {
# n_part: number of particles
# type: complete, grid, gaussian
# anti_corr: for complete and grid, make some of the connections
#            negative.
# do_round: round the cube or square of n_part to make sure we
#           we get an integer. Useful for numerical stability.
  if (type == "complete") {
    A <- matrix(1, nrow = n_part, ncol = n_part)
    diag(A) <- 0
    A <- A / (n_part - 1)  # CHECK -- normalize?
  } else if (type == "grid") {
    lattice <- sqrt(n_part)
    if (do_round) lattice <- round(lattice)
    A <- grid_graph(lattice, anti_corr = anti_corr)$A
  } else if (type == "cube") {
    lattice <- n_part^{1/3}
    if (do_round) lattice <- round(lattice)
    A <- cube_graph(lattice, anti_corr = anti_corr)$A
  } else if (type == "gaussian") {
    A <- matrix(NA, nrow = n_part, ncol = n_part)
    for (i in 1:n_part) {
      for (j in 1:i) {
        A[i, j] = rnorm(1, 0, 1)
        if (i != j) A[j, i] = A[i, j]
      }
    }
    diag(A) <- 0
    A <- A / sqrt(n_part)
  } else if (type == "hopfield") {
    eta <- matrix(sample(c(-1, 1), n_part * m_hopfield, replace = TRUE),
                 nrow = n_part, ncol = m_hopfield)
    # CHECK: how do we normalize this?
    # A <- eta %*% t(eta) / m_hopfield
    A <- eta %*% t(eta) / max(n_part, m_hopfield)
    diag(A) <- 0
  } else {
    print("Could not recognize the type of graph.")
  }
  A
}


# install.packages("moments", repos = "http://cran.us.r-project.org")

# install.packages("ggpubr", repos = "http://cran.us.r-project.org")

library(moments)

x <- c(0, 3, 6, 7, 9, 12)

skewness(x)

kurtosis(x)


#####################
# 数据集说明：
#     data       : 剔除NOX后的全部数据，506个观测，12个自变量，1个因变量
#     datafor    : 经过变量选择后所保留的自变量和因变量
#     dataExchas : 全模型数据剔除定性变量CHAS后的数据
#
#####################
library(car)
library(lmtest)
library(MASS)

data <- read.csv('BostonHousePrice.csv')
data <- data[c(c(2:5),c(7:15))]
# 包含定性变量拟合模型，R^2为0.7406，CHAS变量不能剔除
lm <- lm(MEDV~.,data)
summary(lm)
# 不包含定性变量CHAS直接拟合模型，R^2为0.7355
dataEXchas <- data[c(c(1:3),c(5:13))]
lmEXchas <- lm(MEDV~.,dataEXchas)
summary(lmEXchas)

# 方差分析 全部通过显著性检验
anova(lm)

# 选模型
lm.for <- step(lm,direction = "backward")
#lm.for <- step(lm,direction = "forward")
#lm.for <- step(lm,direction = "both")
summary(lm.for)
datafor <- data[c(c(1:2),c(4:5),c(7:13))]

# 异方差检验
data1 <- data.frame(data)
lm1 <- lm(MEDV~.,data = data1)
e <- resid(lm1,digits = 5)
e2 <- e^2
data2 <- data.frame(datafor,e2)
lm2 <- lm(e2~.,data = data2)
an1 <- anova(lm2)

#多重共线性检验 RAD和TAX的方差扩大因子较大，相关系数0.91,RAD和TAX存在多重共线性
vif(lm.for)
cor(datafor$RAD,datafor$TAX)

#岭迹图
datas <- data.frame(scale(datafor))
ridge <- lm.ridge(MEDV~.-1,data=datas,lambda = seq(0,200,10))
beta <- coef(ridge)
beta
k <- ridge$lambda
plot(k,k,type="n",xlab="岭参数",ylab="岭回归系数",ylim=c(-0.5,0.5))
linetype <- c(1:10)
char <- c(18:27)
for (i in 1:10)
  lines(k, beta[,i], type="o", lty = linetype[i], pch = char[i], cex = 0.75)
legend(locator(1),inset = 0.5, legend = c("CRIM","ZN","CHAS","RM","DIS",
                                          "RAD","TAX","PTRATIO","B","LSTAT"),
       cex = 0.6, pch = char, lty = linetype)
# 确定加权函数的自变量
e <- resid(lm.for)
abse <- abs(e)
value <- as.null()
field <- c("CRIM","ZN","CHAS","RM","DIS","RAD","TAX","PTRATIO","B","LSTAT")
for (i in 1:length(field)){
  a <- data.frame()
  a <- cor.test(datafor[,i],abse,method = "spearman")
  print(a$estimate)
  if(is.null(value)){
    value <- a$estimate
    var <- i
  }else if(value <= a$estimate){
    value <- a$estimate
    var <- i
  }
}
# 寻找最优权函数，加权最小二乘
s <-seq(-2,2,0.2)
result1 <- vector(length = 21,mode = "list")
result2 <- vector(length = 21,mode = "list")
for (j in 1 : 21)
{
  w <- datafor[,var] ^ (-s[j])
  lm4 <- lm(MEDV~.,weights = w,data = datafor)
  result1[[j]] <- logLik(lm4)
  result2[[j]] <- summary(lm4)
}
result1
result2[9]

# DW检验
dwtest(lm.for,alternative = "two.sided")
# BOX-COX
bc <- boxcox(MEDV~.,data = datafor,lambda = seq(-2,2,0.01))
lambda <- bc$x[which.max(bc$y)]
MEDV_bc <- (datafor$MEDV^lambda-1)/lambda
lm_bc <- lm(MEDV_bc~.-MEDV,datafor)
summary(lm_bc)
abse_bc <- abs(resid(lm_bc))
for (i in 1:length(field)){
  print(cor.test(datafor[,i],abse_bc,method = "spearman"))
}

# 定性变量的回归系数相等性检验
lmQual <- lm(MEDV~.+I(CRIM*CHAS)+I(ZN*CHAS)+I(RM*CHAS)+I(DIS*CHAS)+I(RAD*CHAS)
             +I(TAX*CHAS)+I(PTRATIO*CHAS)+I(B*CHAS)+I(LSTAT*CHAS),datafor)
summary(lmQual)


=begin
  # sample-groebner01.rb

  require "algebra"
  P = MPolynomial(Rational, "xyz")
  x, y, z = P.vars("xyz")
  f1 = x**2 + y**2 + z**2 -1
  f2 = x**2 + z**2 - y
  f3 = x - z
  p Groebner.basis([f1, f2, f3])
  #=> [x - z, y - 2z^2, z^4 + 1/2z^2 - 1/4]
((<_|CONTENTS>))
=end


## Functions

dNt <- function(N0, r, K, Rclim, iter){
  N <- c()
  Nt <- N0
  for(i in 1:iter) {
    Nt <- Nt * exp(Rclim[i])  ## climate effect on growth rate
    Nt <- Nt + Nt*r*(1-Nt/K)    #discrete logistic
    if (Nt < 1) {Nt <- 1}
    N <- c(N,Nt)                #add result to vector
  }
  return(N)
}

dNtExtreme <- function(N0, r, K, Rclim, iter, severity){
  N <- c()
  Nt <- N0
  for(i in 1:iter) {
    severityPer <- severity/100 ## convert severity to percentage
    Nt <- ifelse(i == 20, Nt*severityPer, Nt)
    Nt <- Nt * exp(Rclim[i])  ## climate effect on growth rate
    Nt <- Nt + Nt*r*(1-Nt/K)    #discrete logistic
    if (Nt < 1) {Nt <- 1}
    N <- c(N,Nt)                #add result to vector
  }
  return(N)
}


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

rectKernel <- function(dist) 0.5 * (abs(dist) <= 1)
trKernel <- function(dist) (1 - abs(dist)) * (abs(dist) <= 1)
epKernel = function(dist) (3 / 4) * (1 - dist ^ 2) * (abs(dist) <= 1)
gaussKernel = function(dist) dnorm(dist) * (abs(dist) <= 1)

classify <- function (dset, point, labels, potentials, h, dist = euclidean, kernel = trKernel) {
  distances <- apply(dset, 1, dist, point)

  weights <- potentials * kernel(distances / h)
  names(weights) <- labels

  classes <- unique(labels)
  classScores <- sapply(classes, function(class, w) sum(w[names(w) == class]), weights)

  if (length(unique(classScores)) == 1) {
    return(classes[sample(1:length(classes), 1)])
  }

  return (classes[which.max(classScores)])
}

computePotentials <- function (dset, labels, h, maxError) {
  dsetLength <- dim(dset)[1]
  potentials <- integer(dsetLength)

  errorCount <- maxError + 1
  while (errorCount > maxError) {
    repeat {
      randIndex <- sample(1:dsetLength, 1)
      tmpResult <- classify(dset, dset[randIndex,], labels, potentials, h)

      cat("\rSearching...", randIndex, labels[randIndex], tmpResult)

      if (tmpResult != paste(labels[randIndex])) {
        potentials[randIndex] <- potentials[randIndex] + 1
        break
      }
    }
    cat("\n")

    errorCount <- 0
    for (i in 1:dsetLength) {
      cat("\rProcessing", i, "of", dsetLength)
      tmpResult <- classify(dset, dset[i,], labels, potentials, h, kernel = epKernel)

      if (tmpResult != paste(labels[i])) {
        errorCount <- errorCount + 1
      }
    }
    cat("\n", errorCount, potentials, "\n")
  }

  return (potentials)
}

computePotentials(iris[3:4], iris$Species, rep(1, 150), 5)

# 4Tria: 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
# 7Gaus: 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0
# 7Rect: 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
# 4Epac: 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0

3 - Potential functions method/potential-functions.r


################################## INTERPOLACAO VIA TENSOR PRODUCT #################################

#' Suavizacao De \code{curvacolina} Por Produto Tensor De P-Splines
#'
#' Funcao interna executada quando \code{metodo = "tensorprod"} em \code{interpolador}
#'
#' Esta funcao nao deve ser chamada pelo usuario diretamente na maioria dos casos
#'
#' @param colina objeto \code{curvacolina} retornado pelas funcoes de leitura
#' @param ... parametros extras para configuracao do modelo estimado. Ver Detalhes em
#'     \code{\link{interpolador}}
#'
#' @return objeto da classe \code{tensorprod} contendo a suavizacao da curva colina
#'
#' @importFrom mgcv gam te
#'
#' @export

tensorprod <- function(colina, ...) {

    args <- list(...)

    if(is.null(args$bs)) BS <- "ps" else BS <- args$bs
    if(is.null(args$k))  K  <- NA   else K  <- args$k

    mod <- gam(rend ~ te(hl, pot, k = K, bs = BS), data = colina$CC)

    new_tensorprod(mod, colina)
}

new_tensorprod <- function(mod, colina) {
    obj        <- list(superficie = mod, colina = colina)
    class(obj) <- c("tensorprod", "interpolador")
    return(obj)
}

# METODOS ------------------------------------------------------------------------------------------

#' @rdname getcolina

getcolina.tensorprod <- function(object) object$colina

#' Amostragem De Pontos Na Suavizacao
#'
#' Amostra as coordenadas especificadas via \code{pontos} na superficie suavizada
#'
#' @param object objeto da classe \code{tensorprod} retornado pela funcao homonima
#' @param pontos data.frame ou matriz contendo coordenadas \code{(hl, pot)} dos pontos onde
#'     interpolar
#' @param as.gradecolina booleano -- se \code{FALSE} (padrao) retorna apenas o vetor de rendimentos
#'     interpolados nas coordenadas \code{pontos}; se \code{TRUE} um objeto \code{gradecolina}. Veja
#'     \code{\link{gradecolina}}
#' @param ... existe somente para consistencia de metodos. Nao possui utilidade
#'
#' @return se \code{as.gradecolina = FALSE}, vetor de rendimentos interpolados, do contrario um
#'     objeto \code{\link{gradecolina}}
#'
#' @export

predict.tensorprod <- function(object, pontos, as.gradecolina = FALSE, ...) {

    pontos <- pontos[complete.cases(pontos), ]

    if(nrow(pontos) == 0) return(numeric(0))

    pontos <- as.data.frame(pontos)

    rends <- unname(predict(object$superficie, newdata = pontos))

    if(as.gradecolina) {
        out <- new_gradecolina(pontos, rends, object)
    } else {
        out <- as.numeric(rends)
    }

    return(out)
}


library(reshape2)
library(ggplot2)

sir <- function(beta, gamma, N, S0, I0, R0, tf) {
    time <- 0
    S <- S0
    I <- I0
    R <- R0
    ta <- numeric(0)
    Sa <- numeric(0)
    Ia <- numeric(0)
    Ra <- numeric(0)
    while (time < tf) {
        ta <- c(ta, time)
        Sa <- c(Sa, S)
        Ia <- c(Ia, I)
        Ra <- c(Ra, R)
        pf1 <- beta * S * I
        pf2 <- gamma * I
        pf <- pf1 + pf2
        dt <- rexp(1, rate = pf)
        time <- time + dt
        if (time > tf) {
            break
        }
        ru <- runif(1)
        if (ru < (pf1/pf)) {
            S <- S - 1
            I <- I + 1
        } else {
            I <- I - 1
            R <- R + 1
        }
        if (I == 0) {
            break
        }
    }
    results <- data.frame(time = ta, S = Sa, I = Ia, R = Ra)
    return(results)
}

set.seed(42)

sir_out <- sir(0.1/1000,0.05,1000,999,1,0,200)

if(dim(sir_out)[1]==1){
    sir_out <- sir(0.1/1000,0.05,1000,999,1,0,200)
}

head(sir_out)

sir_out_long <- melt(sir_out,"time")

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


## Illustration of Profile Likelihood Confidence Intervals and
## comparison with Wald based CI.

## From example(glm) (needs MASS to be present on the system)
counts <- c(18,17,15,20,10,20,25,13,12)
outcome <- gl(3,1,9); treatment <- gl(3,3)
glm.D93 <- glm(counts ~ outcome + treatment, family=poisson())

glm.D93$coefficients

confint(glm.D93)  # based on profile likelihood
confint.default(glm.D93)  # based on asymptotic normality


#' Skew BB1 Copula Family
#'
#' Adds a skew parameter alpha in [0,1]. Distribution function is found by
#' \code{pbb1(u/u^alpha,v,cpar)*u^alpha}.
#' @author Vincenzo Coia, Harry Joe
#' @rdname bb1sk
#' @export
pbb1sk=function(u,v,cparsk)
{ alp=cparsk[3]
  cpar=cparsk[1:2]
  ua=u^alp
  cdf=pbb1(u/ua,v,cpar)*ua
  cdf
}

#' @rdname bb1sk
#' @export
pcondbb1sk21=function(v,u,cparsk)
{ alp=cparsk[3]
  cpar=cparsk[1:2]
  ua1=u^(1-alp)
  condcdf=(1-alp)*pcondbb1(v,ua1,cpar) + alp*pbb1(ua1,v,cpar)/ua1
  condcdf
}

#' @rdname bb1sk
#' @export
pcondbb1sk <- pcondbb1sk21

#' @rdname bb1sk
#' @export
pcondbb1sk12=function(u,v,cparsk)
{ alp=cparsk[3]
  cpar=cparsk[1:2]
  ua=u^alp
  condcdf=pcondbb1(u/ua,v,cpar)*ua
  condcdf
}

#' @rdname bb1sk
#' @export
dbb1sk=function(u,v,cparsk)
{ alp=cparsk[3]
  cpar=cparsk[1:2]
  ua1=u^(1-alp)
  pdf=(1-alp)*dbb1(ua1,v,cpar) + alp*pcondbb1(ua1,v,cpar)/ua1
  pdf
}


sigma_sq <- 20^2
mu.antes <- 140
mu.depois <- 120
n <- 50

set.seed(666)
X <- rnorm(n, mean = mu.antes, sd = sqrt(sigma_sq))
Y <- rnorm(n, mean = mu.depois, sd = sqrt(sigma_sq))

plot(X, Y, xlab = "Pressão arterial antes (mmHg)",
     ylab = "Pressão arterial depois (mmHg)")

t.test(X, Y, paired = TRUE)


F <- function(n) ifelse(n == 0, 1, n - M(F(n-1)))
M <- function(n) ifelse(n == 0, 0, n - F(M(n-1)))


# Prior and proposal distributions for the parameter,
# they are all uninformative.

priorTheta <- function(x) {
  return(dnorm(x = x, mean = 1, sd = 500, log = TRUE))
}

priorRho <- function(x) {
  return(dnorm(x = x, mean = 1, sd = 500, log = TRUE))
}

priorDeltaD <- function(x) {
  if (x < 0 || x > 1) {
    return(-Inf)
  }
  return(dbeta(x = x, shape1 = 1, shape2 = 1, log = TRUE))
}

priorDeltaS <- function(x) {
  if (x < 0 || x > 1) {
    return(-Inf)
  }
  return(dbeta(x = x, shape1 = 1, shape2 = 1, log = TRUE))
}

priorLambda <- function(x) {
  if (x < 0 || x > 1) {
    return(-Inf)
  }
  return(dbeta(x = x, shape1 = 1, shape2 = 1, log = TRUE))
}

priorLambdaRight <- function(x) {
  if (x < 0 || x > 1) {
    return(-Inf)
  }
  return(dbeta(x = x, shape1 = 1, shape2 = 1, log = TRUE))
}

priorLambdaDisp <- function(x) {
  if (x < 0) {
    return(-Inf)
  }
  # 2 times since we truncate it at zero
  return(log(2) + dnorm(x = x, mean = 0, sd = 100, log = TRUE))
}

proposeTheta <- function(x = NA) {
  return(rnorm(1, mean = x, sd = proposeParameters$Theta))
}

proposeRho <- function(x = NA) {
  return(rnorm(1, mean = x, sd = proposeParameters$Rho))
}

proposeDeltaD <- function(x = NA) {
  return(rnorm(1, mean = x, sd = proposeParameters$DeltaD))
}

proposeDeltaS <- function(x = NA) {
  return(rnorm(1, mean = x, sd = proposeParameters$DeltaS))
}

proposeLambda <- function(x = NA) {
  return(rnorm(1, mean = x, sd = proposeParameters$Lambda))
}

proposeLambdaRight <- function(x = NA) {
  return(rnorm(1, mean = x, sd = proposeParameters$LambdaRight))
}

proposeLambdaDisp <- function(x = NA) {
  return(rnorm(1, mean = x, sd = proposeParameters$LambdaDisp))
}


## 1. Revisiting Common arithmetic operators ##

47L + 476L
3.20 / 4.99

## 2. Dealing with Advanced Arithmetic Operators ##

128 %/% 5
FALSE

## 3. Using Complex Arithmetic Expression ##

10.50 * 200L
21.15 * 50
3.20 * 500
10.50 * 200L + 21.15 * 50 + 3.20 * 500

## 4. Dealing with Operator Priority Rules ##

12.10 * 200L
24.90 * 50L
4.99 * 500L
12.10 * 200L + 24.90 * 50L + 4.99 * 500L

## 5. Identifying Expression's data type ##

"numeric"
"numeric"
"integer"

## 6. Dealing Variables with Naming rules ##

q_0 <- FALSE
q_1 <- FALSE
q_2 <- TRUE
q_3 <- FALSE
q_4 <- FALSE
q_5 <- FALSE

## 7. Updating variables ##

total_purchase_cost <- 10.50 * 200L + 21.15 * 50L + 3.20 * 500L
total_selling_cost <- 12.10 * 200 + 24.90 * 50 + 4.99 * 500
profit_1 <- total_selling_cost - total_purchase_cost

## 8. Identifying variables data type ##

q_1 <- class(total_purchase_cost)
q_2 <- class(total_selling_cost)
q_3 <- class(profit_1)

Data Analyst in R/Step 1 - Introduction to R/1. Introduction to Data Analysis in R/2. Arithmetic Expressions and Variables in R.r


# This plots countours for bivariate density
#x = random variable 1
#y = random variable 2
#cprob = vector of hpd values for contours; depending on how many values in cprob
#        determines the number of contour lines
#alpha = the smoothing parameter for locfit; small numbers, more jaggedy; large numbers
#          more smooth.
#xlim = the support limits of the density given as (xmin,ymin,xmax,ymax)
#gxlim = the limits of the density that are actually plotted.
#maxk = some number, the bigger it is the less likely locfit is to complain
#       (but makes it slower)

loc2plot <- function(x,y,cprob=0.5,alpha=0.5,xlim,gxlim,maxk,...)
{
	sc1 <- sqrt(var(x))
	sc2 <- sqrt(var(y))
	if(missing(maxk)) maxk <- 100
	if(missing(xlim)) fit <- locfit(~x+y,alpha=alpha,scale=c(sc1,sc2),
	maxk=maxk,mint=100,cut=0.8,maxit=100)
	else fit <- locfit(~x+y,alpha=alpha,scale=c(sc1,sc2),
	xlim=xlim,maxk=maxk,mint=100,cut=0.8,maxit=100)
	lev <- sort(fitted(fit))[floor(cprob*length(x))]
	plot(fit,lev=lev,m=100,label=paste(as.character(100*(1-cprob)),"%",sep=""),
	xlim=gxlim,...)
}

#like above, but allows for the points to be weighted - i.e. for output of ABC regression
loc2plotw <- function(x,y,cprob=0.5,alpha=0.5,xlim,gxlim,wt,maxk,...)
{
	sc1 <- sqrt(var(x))
	sc2 <- sqrt(var(y))
	if(missing(maxk)) maxk <- 100
	if(missing(xlim)) fit <- locfit(~x+y,alpha=alpha,scale=c(sc1,sc2),
	maxk=maxk,mint=100,cut=0.8,maxit=100,weight=wt)
	else fit <- locfit(~x+y,alpha=alpha,scale=c(sc1,sc2),
	xlim=xlim,maxk=maxk,mint=100,cut=0.8,maxit=100,weight=wt)
	lev <- sort(fitted(fit))[floor(cprob*length(x))]
	plot(fit,lev=lev,m=100,label=paste(as.character(100*(1-cprob)),"%",sep=""),
	xlim=gxlim,...)
}

#gives the HPD value for an observation px,py in a density constructed from x, y.
gethpdprob2 <- function(x,y,px,py,alpha=0.5,xlim,gxlim,maxk,...)
{
	sc1 <- sqrt(var(x))
	sc2 <- sqrt(var(y))
	if(missing(maxk)) maxk <- 100
	if(missing(xlim)) fit <- locfit(~x+y,alpha=alpha,scale=c(sc1,sc2),
	maxk=maxk,mint=100,cut=0.8,maxit=100)
	else fit <- locfit(~x+y,alpha=alpha,scale=c(sc1,sc2),
	xlim=xlim,maxk=maxk,mint=100,cut=0.8,maxit=100)
#	d1 <- (x-px)^2+(y-py)^2
#	best <- d1 == min(d1)
#	lev <- mean(fitted(fit)[best])
#	lev <- predict.locfit(fit,list(px,py)) #commented 2014-12-10
	lev <- predict(fit,list(px,py))        #added 2014-12-10
	slev <- sort(fitted(fit))
	indic <- slev <= lev
	sum(indic)/length(x)
}

# finds the mode for a bivariate density

loc2mode <- function(x,y,alpha=0.5,xlim,maxk,...)
{
	sc1 <- sqrt(var(x))
	sc2 <- sqrt(var(y))
	if(missing(maxk)) maxk <- 100
	if(missing(xlim)) fit <- locfit(~x+y,alpha=alpha,scale=c(sc1,sc2),
	maxk=maxk,mint=100,cut=0.8,maxit=100)
	else fit <- locfit(~x+y,alpha=alpha,scale=c(sc1,sc2),
	xlim=xlim,maxk=maxk,mint=100,cut=0.8,maxit=100)
	tt <- max(fitted(fit))
	wt <- fitted(fit) == tt
	c(x[wt][1],y[wt][1])
}

# this works for univariate data; gives a vector with
# mode (global), hpd1_low, hpd1_high, hpd2_low, hpd2_hi, etc
#The reason for multiple hpd limits is if you have multimodal data.
#prob = prob *outside* the limit; i.e for a normal distribution 0.05 is expected to give
#     the 0.025 and 0.975 quantiles.
# this won't work for weighted data, use loc1statsx instead.
# xlim is optional - use it to define the support of the density.
loc1stats <- function(x,prob,alpha=0.5,xlim,...)
{
	if(missing(xlim)){
		fit <- locfit(~x,alpha=alpha)
	}
	else {
		fit <- locfit(~x,alpha=alpha,xlim=xlim)
	}
	fx <- fitted(fit)
	x.modef <- max(fx)
	x.mode <- x[fx == x.modef]
	if(!missing(xlim)){
		if(predict(fit,xlim[1]) > x.modef){
			x.modef <- predict(fit,xlim[1])
			x.mode <- xlim[1]
		}
		if(predict(fit,xlim[2]) > x.modef){
			x.modef <- predict(fit,xlim[2])
			x.mode <- xlim[2]
		}
	}

	if(length(x.mode)>1)x.mode <- x.mode[1]
	lev <- sort(fx)[floor(prob*length(x))]
#	print("log difference from max is ")
#	print(log(x.modef)-log(lev))
	l1 <- list()
	l1[[1]] <- x.mode
	indx <- order(x)
	ii <- 2
	flip <- TRUE
	for(j in 2:length(x)){
		if(flip && fx[indx[j]] > lev){
			l1[[ii]] <- x[indx[j-1]]
			if(j==2 && !missing(xlim)){
				if(predict(fit,xlim[1]) >= lev)l1[[ii]] <- xlim[1]
			}
			flip <- FALSE
			ii <- ii+1
		}
		else if(!flip && fx[indx[j]] < lev){
			l1[[ii]] <- x[indx[j]]
			flip <- TRUE
			ii <- ii+1
		}
		if(!flip && !missing(xlim) && j == length(x)){
			l1[[ii]] <- xlim[2]
			flip <- TRUE
		}
	}
	if(!flip)stop("HPD interval not closed")
	as.numeric(l1)
}

#this does the hpd calculation in a different way. Should give similar answers
#to loc1stats. It is best to put xlim in directly. wt is a vector of weights and is optional.
#numpoint is the number of points to do interpolation - the more the better
loc1statsx <- function(x,prob,alpha=0.5,xlim,wt,numpoint=10000,...)
{
	if(missing(xlim)){
		if(min(x) < 0)x.min <- 1.1*min(x)
		else x.min <- min(x)*0.9
		if(max(x) < 0)x.max <- 0.9*max(x)
		else x.max <- 1.1*max(x)
		print(paste("putting in these xlimits from the data:",x.min,x.max))
		xlim <- c(x.min,x.max)
	}

	if(missing(wt))fit <- locfit(~x,alpha=alpha,xlim=xlim)
	else fit <- locfit(~x,alpha=alpha,xlim=xlim,weight=wt)
	xx <- seq(xlim[1],xlim[2],len=numpoint)
#	yy <- predict.locfit(fit,xx) #commented 2014-12-10
	yy <- predict(fit,xx)        #added 2014-12-10
	sum1 <- sum(yy)
	x.modef <- max(yy)
	x.mode <- xx[yy == x.modef]
	if(length(x.mode)>1)x.mode <- x.mode[1]

	yy2 <- sort(yy)
	pval <- 0
	for(j in 1:numpoint){
		pval <- pval+yy2[j]/sum1
		if(pval > prob)break
	}
	lev <- yy2[j]
#	print("log difference from max is ")
#	print(log(x.modef)-log(lev))
	l1 <- list()
	l1[[1]] <- x.mode
	ii <- 2
	flip <- TRUE
	for(j in 2:length(xx)){
		if(flip && yy[j] > lev){
			l1[[ii]] <- xx[j-1]
			flip <- FALSE
			ii <- ii+1
		}
		else if(!flip && yy[j] < lev){
			l1[[ii]] <- xx[j]
			flip <- TRUE
			ii <- ii+1
		}
		if(!flip &&  j == length(xx)){
			l1[[ii]] <- xx[j]
			flip <- TRUE
		}
	}
	if(!flip)stop("HPD interval not closed")
	as.numeric(l1)

}

#gives the HPD value for an observation px,in a univariate density constructed from x.
#uses same method as loc1statsx, so need to specify xlim. wt is optional weight.
#numpoint is the number of points to do interpolation - the more the better
gethpdprob1 <- function(x,px,alpha=0.5,xlim,wt,numpoint=10000,...)
{

	if(missing(wt))fit <- locfit(~x,alpha=alpha,xlim=xlim)
	else fit <- locfit(~x,alpha=alpha,xlim=xlim,weight=wt)
	xx <- seq(xlim[1],xlim[2],len=numpoint)
#	yy <- predict.locfit(fit,xx)  #commented 2014-12-10
#	lev <- predict.locfit(fit,px) #commented 2014-12-10
	yy <- predict(fit,xx)         #added 2014-12-10
	lev <- predict(fit,px)        #added 2014-12-10
	sum1 <- sum(yy)

	indic <- yy <= lev
	sum(yy[indic])/sum1
}

#given a function described by x,y points, this works like loc1stats.
#uses spline interpolation between points.
#numpoint is the number of points to do interpolation - the more the better
linestats <- function(x,y,prob,numpoint=10000)
{
	n <- length(x)
	minval <- x[1]
	maxval <- x[n]
	# This bit just guarantees that irrespective of what is
	# in x and y, we have numpoint *evenly* spaced (interpolated) points between
	# max and min
	res1 <- spline(x,y,numpoint,xmin=minval,xmax=maxval)
	xx <- res1$x
	yy <- res1$y
	sum1 <- sum(yy)
	x.modef <- max(yy)
	x.mode <- xx[yy == x.modef]
	if(length(x.mode)>1)x.mode <- x.mode[1]

	yy2 <- sort(yy)
	pval <- 0
	for(j in 1:numpoint){
		pval <- pval+yy2[j]/sum1
		if(pval > prob)break
	}
	lev <- yy2[j]
#	print("log difference from max is ")
#	print(log(x.modef)-log(lev))
	l1 <- list()
	l1[[1]] <- x.mode
	ii <- 2
	flip <- TRUE
	for(j in 2:length(xx)){
		if(flip && yy[j] > lev){
			l1[[ii]] <- xx[j-1]
			flip <- FALSE
			ii <- ii+1
		}
		else if(!flip && yy[j] < lev){
			l1[[ii]] <- xx[j]
			flip <- TRUE
			ii <- ii+1
		}
		if(!flip &&  j == length(xx)){
			l1[[ii]] <- xx[j]
			flip <- TRUE
		}
	}
	if(!flip)stop("HPD interval not closed")
	as.numeric(l1)
}


=begin
  # sample-divmod01.rb

  require "algebra"
  P = MPolynomial(Rational)
  x, y, z = P.vars("xyz")
  f = x**2*y + x*y**2 + y*2 + z**3
  g = x*y-z**3
  h = y*2-6*z

  P.set_ord(:lex) # lex, grlex, grevlex
  puts "(#{f}).divmod([#{g}, #{h}]) =>", "#{f.divmod(g, h).inspect}"
  #=> (x^2y + xy^2 + 2y + z^3).divmod([xy - z^3, 2y - 6z]) =>
  #   [[x + y, 1/2z^3 + 1], xz^3 + 3z^4 + z^3 + 6z]
  #   = [[Quotient1,Quotient2], Remainder]
((<_|CONTENTS>))
=end


# Logistic Regression Classification for machine learning.
#
# In statistics, logistic regression, or logit regression, or logit model is a
# regression model where the dependent variable (DV) is categorical. This project
# covers the case of a binary dependent variable—that is, where it can take
# only two values, "0" and "1", which represent outcomes such as pass/fail,
# win/lose, alive/dead or healthy/sick.
#
# The binary Logistic regression model is an example of a qualitative
# response/discrete choice model. It is used to estimate the probability of a
# binary response based on one or more predictor (or independent) variables
# (features).

# Importing the data set
dataset = read.csv('Social_Network_Ads.csv')
dataset = dataset[, 3:5]

# Splitting the Dataset into a Training set and a Test set
# install.packages('caTools')
# library(caTools)
set.seed(123) # choose random number, only same number for debugging
split = sample.split(dataset$Purchased, SplitRatio = 0.75)
training_set = subset(dataset, split==TRUE)
test_set = subset(dataset, split==FALSE)

# Feature scaling, normalize scale is important. Especially on algorithms
# involving euclidian distance. Two main feature scaling formulas are:
# Standardisation: x_stand = (x-mean(x))/(standard_deviation(x))
# Normalisation: x_norm = (x-min(x))/(max(x)-min(x))
training_set[, 1:2] = scale(training_set[, 1:2])
test_set[, 1:2] = scale(test_set[, 1:2])

# Fitting the Logistic Regression Model to the training_set
classifier = glm(formula = Purchased ~ .,
                 family = binomial,
                 data = training_set)

# Predict the test_set results by using the classifier
prob_pred = predict(classifier, type = 'response',
                    newdata = test_set[-3])
y_pred = ifelse(prob_pred>0.5, 1, 0)

# Making the Confusion Matrix
cm = table(test_set[, 3], y_pred)

# Plot the training_set results
# install.packages('ElemStatLearn')
# library(ElemStatLearn)
set = training_set
X1 = seq(min(set[, 1]) - 1, max(set[, 1]) + 1, by = 0.01)
X2 = seq(min(set[, 2]) - 1, max(set[, 2]) + 1, by = 0.01)
grid_set = expand.grid(X1, X2)
colnames(grid_set) = c('Age', 'EstimatedSalary')
prob_set = predict(classifier, type = 'response', newdata = grid_set)
y_grid = ifelse(prob_set>0.5, 1, 0)
plot(set[, -3],
     main = 'Logistic Regression (Training set)',
     xlab = 'Age', ylab = 'Estimated Salary',
     xlim = range(X1), ylim = range(X2))
contour(X1, X2, matrix(as.numeric(y_grid), length(X1), length(X2)), add = TRUE)
points(grid_set, pch = '.', col = ifelse(y_grid == 1, 'springgreen3', 'tomato'))
points(set, pch = 21, bg = ifelse(set[, 3] == 1, 'green4', 'red3'))

# Plot the test_set results
# install.packages('ElemStatLearn')
# library(ElemStatLearn)
set = test_set
X1 = seq(min(set[, 1]) - 1, max(set[, 1]) + 1, by = 0.01)
X2 = seq(min(set[, 2]) - 1, max(set[, 2]) + 1, by = 0.01)
grid_set = expand.grid(X1, X2)
colnames(grid_set) = c('Age', 'EstimatedSalary')
prob_set = predict(classifier, type = 'response', newdata = grid_set)
y_grid = ifelse(prob_set>0.5, 1, 0)
plot(set[, -3],
     main = 'Logistic Regression (testing set)',
     xlab = 'Age', ylab = 'Estimated Salary',
     xlim = range(X1), ylim = range(X2))
contour(X1, X2, matrix(as.numeric(y_grid), length(X1), length(X2)), add = TRUE)
points(grid_set, pch = '.', col = ifelse(y_grid == 1, 'springgreen3', 'tomato'))
points(set, pch = 21, bg = ifelse(set[, 3] == 1, 'green4', 'red3'))


x <- c(0,  1,  2,  3,  4,  5,  6,   7,   8,   9,   10)
y <- c(1,  6,  17, 34, 57, 86, 121, 162, 209, 262, 321)
coef(lm(y ~ x + I(x^2)))


.assign_kmeanspp <- function(x, K) {
  stopifnot(K >= 1)
  stopifnot(is.matrix(x))

  result <- list()
  result$k <- K

  center_ix <- rep(NA, K)
  center_ix[1] <- sample.int(nrow(x), 1)
  result$centers <- matrix(NA, K, ncol(x))
  result$centers[1,] <- x[center_ix[1],]

  if (K > 1) {
      for (i in 2:K) {
          min_dist_sq <- rep(NA, nrow(x))
          for (xi in 1:nrow(x)) {
              dist_sq <- rep(NA, i - 1)
              for (j in 1:(i - 1)) {
                  dist_sq[j] <- sum((x[xi,] - result$centers[j,]) ^ 2)
              }
              min_dist_sq[xi] <- min(dist_sq)
          }

          total <- sum(min_dist_sq)
          center_ix[i] <- sample.int(nrow(x), 1, prob = min_dist_sq / total)
          result$centers[i,] <- x[center_ix[i],]
      }
  }

  result$weights <- matrix(0, nrow(x), K)

  for (xi in 1:nrow(x)) {
    dist_sq <- apply(result$centers, 1, function(v) { return(sum((x[xi,] - v) ^ 2)) })
    assign_ix <- which.min(dist_sq)
    result$weights[xi, assign_ix] <- 1
  }

  result$covariances <- list()
  result$component_weights <- rep(NA, result$k)
  for (ki in 1:result$k) {
    result$component_weights[ki] <- sum(result$weights[, ki]) / nrow(x)
    weighted <- cov.wt(x, result$weights[, ki])
    if (!is.null(result$min_cov)) {
      weighted$cov <- pmax(weighted$cov, result$min_cov)
    }
    result$covariances[[ki]] <- weighted$cov
  }

  return(result)
}

.mixture_expectation_step <- function(x, fit, truncated, tdist=F, tdistdf=3) {
  log_l <- matrix(NA, nrow(x), fit$k)
  for (ki in 1:fit$k) {
    if (tdist) {
      if (truncated) {
        log_l[, ki] <- tmvtnorm::dtmvt(x, fit$centers[ki,], fit$covariances[[ki]], tdistdf,
                                          lower = fit$bounds[, 1], upper = fit$bounds[, 2], log = T) + log(fit$component_weights[ki])
      } else {
        log_l[, ki] <- mvtnorm::dmvt(x, fit$centers[ki,], fit$covariances[[ki]], tdistdf, log = T) + log(fit$component_weights[ki])
      }
    } else {
      if (truncated) {
        log_l[, ki] <- tmvtnorm::dtmvnorm(x, fit$centers[ki,], fit$covariances[[ki]],
                                lower = fit$bounds[, 1], upper = fit$bounds[, 2], log = T) + log(fit$component_weights[ki])
      } else {
        log_l[, ki] <- mvtnorm::dmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], log = T) + log(fit$component_weights[ki])
      }
    }
  }
  fit$logl <- sum(apply(log_l, 1, .logsum))

  fit$weights <- exp(log_l)
  total_weights <- apply(fit$weights, 1, sum)
  fit$weights <- fit$weights / total_weights

  return(fit)
}

.mixture_maximization_step <- function(x, fit, truncated) {
  fit$component_weights <- rep(NA, fit$k)
  for (ki in 1:fit$k) {
    fit$component_weights[ki] <- sum(fit$weights[, ki]) / nrow(x)
    weighted <- cov.wt(x, fit$weights[, ki])
    if (!is.null(fit$min_cov)) {
      weighted$cov <- pmax(weighted$cov, fit$min_cov)
    }

    if (truncated) {
      # Based on Lee and Scott 2012
      old_mu_k <- fit$centers[ki,]
      old_sigma_k <- fit$covariances[[ki]]
      correction <- tmvtnorm::mtmvnorm(sigma = old_sigma_k, lower=fit$bounds[,1] - old_mu_k, upper=fit$bounds[,2] - old_mu_k)

      # Make covariance matrices symmetric (numerical issue?)
      symmetric_correction <- (correction$tvar + t(correction$tvar))/2

      fit$centers[ki,] <- weighted$center - correction$tmean
      fit$covariances[[ki]] <- weighted$cov + old_sigma_k - symmetric_correction
    } else {
      fit$centers[ki,] <- weighted$center
      fit$covariances[[ki]] <- weighted$cov
    }
  }
  return(fit)
}

.fit.gmm.internal <- function(x, K, truncated, bounds, min_cov, epsilon, maxsteps, numkmeans=20, verbose, tdist, tdistdf = NA) {
  fit <- NULL

  for (j in 1:10) {
    if (verbose) {
      cat("Running k-means++..\n")
    }

    kmeansfits <- list()
    kmeansfits_logl <- rep(NA, numkmeans)
    for (i in 1:numkmeans) {
      fit <- .assign_kmeanspp(x, K)
      fit$bounds <- bounds
      fit$min_cov <- min_cov

      return_value <- try(fit <- .mixture_expectation_step(x, fit, truncated, tdist, tdistdf), silent = !verbose)
      if (inherits(return_value, "try-error")) {
        next
      }
      if (any(is.na(fit$weights))) {
        next
      }
      if (any(apply(fit$weights, 2, sum, na.rm=T) == 0)) {
        next
      }

      kmeansfits[[i]] <- fit
      kmeansfits_logl[i] <- fit$logl
    }

    if (sum(!is.na(kmeansfits_logl)) == 0) {
      warning("Could not find initial clustering with k-means++")
      return(NULL)
    }

    best_initial_fit <- which.max(kmeansfits_logl)
    fit <- kmeansfits[[best_initial_fit]]

    if (verbose) {
      cat("Best k-means likelihood:", kmeansfits_logl[best_initial_fit], "\n")
      cat("Starting EM..\n")
    }

    fit <- .mixture_maximization_step(x, fit, truncated)

    previous_logl <- -Inf
    singular <- F
    converged <- F
    for (i in 1:maxsteps) {
      return_value <- try(fit <- .mixture_expectation_step(x, fit, truncated, tdist, tdistdf), silent = !verbose)
      if (inherits(return_value, "try-error")) {
        singular <- T
        break
      }

      if (any(is.na(fit$weights))) {
        singular <- T
        break
      }
      if (any(apply(fit$weights, 2, sum, na.rm=T) == 0)) {
        singular <- T
        break
      }

      if (verbose) {
        cat("Log likelihood: ", fit$logl, "\n")
      }
      if (fit$logl < previous_logl) {
        # Uhhh, what?? Numerical issues maybe?
        converged <- T
        break;
      } else if (fit$logl - previous_logl < epsilon) {
        converged <- T
        break;
      } else {
        previous_logl <- fit$logl
      }

      fit <- .mixture_maximization_step(x, fit, truncated)
    }

    if (!singular) {
      break
    }
  }

  if (singular) {
    warning("singular solutions for 10 restarts")
    return(NULL)
  } else {
    if (!converged) {
      warning("Solution not converged in", maxsteps, ", returning optimal found solution")
    }
    return(fit)
  }
}

#' Fit a Gaussian mixture with a specific number of components.
#'
#' description
#' @param x Matrix or vector of samples. For matrices, rows are samples and columns are variables.
#' @param K Integer specifying the number of components of the Gaussian mixture.
#' @param epsilon For the EM algorithm, stop when the difference in log likelihood is less than this epsilon.
#' @param maxsteps Maximum number of steps to take in the EM algorithm. When the maximum number is reached, the current fit will be returned and a warning will be issued.
#' @param verbose Display the fitting progress by showing the likelihood at every iteration.
#' @export
fit.gmm <- function(x, K, epsilon = 1e-5, maxsteps = 1000, verbose = F) {
  nparam <- K * (ncol(x) + ncol(x) * (ncol(x) + 1) / 2) + K - 1
  if (nparam >= nrow(x)) {
    warning("More parameters than samples, consider lowering K")
  }

  fit <- .fit.gmm.internal(x, K, truncated = F, bounds = NA, min_cov = NULL, epsilon = epsilon, maxsteps = maxsteps, verbose = verbose, tdist = F)
  if (is.null(fit)) {
    return(NULL)
  }

  result <- list()
  result$type <- "gmm"
  result$K <- K
  result$centers <- fit$centers
  result$covariances <- fit$covariances
  result$proportions <- fit$component_weights
  result$log_likelihood <- fit$logl
  result$AIC <- 2 * nparam - 2 * fit$logl
  result$BIC <- log(nrow(x)) * nparam - 2 * fit$logl
  #result$assignment <- apply(fit$weights, 1, which.max)
  return(structure(result, class = "mvd.density"))
}

#' Fit a transformed Gaussian mixture with a specific number of components.
#'
#' description
#' @param x Matrix or vector of samples. For matrices, rows are samples and columns are variables.
#' @param K Integer specifying the number of components of the Gaussian mixture.
#' @param bounds Dx2 matrix specifying the lower and upper bound for each variable.
#' @param epsilon For the EM algorithm, stop when the difference in log likelihood is less than this epsilon.
#' @param maxsteps Maximum number of steps to take in the EM algorithm. When the maximum number is reached, the current fit will be returned and a warning will be issued.
#' @param verbose Display the fitting progress by showing the likelihood at every iteration.
#' @export
fit.gmm.transformed <- function(x, K, bounds, epsilon = 1e-5, maxsteps = 1000, verbose = F) {
  result <- list()
  result$type <- "gmm.transformed"
  result$transform.bounds <- bounds
  transformed <- mvd.transform_to_unbounded(x, bounds)
  result$gmm <- fit.gmm(transformed, K, epsilon = epsilon, maxsteps = maxsteps, verbose = verbose)
  if (is.null(result$gmm)) {
    return(NULL)
  }
  return(structure(result, class = "mvd.density"))
}

#' Fit a truncated Gaussian mixture with a specific number of components.
#'
#' description
#' @param x Matrix or vector of samples. For matrices, rows are samples and columns are variables.
#' @param K Integer specifying the number of components of the Gaussian mixture.
#' @param bounds Dx2 matrix specifying the lower and upper bound for each variable.
#' @param epsilon For the EM algorithm, stop when the difference in log likelihood is less than this epsilon.
#' @param maxsteps Maximum number of steps to take in the EM algorithm. When the maximum number is reached, the current fit will be returned and a warning will be issued.
#' @param verbose Display the fitting progress by showing the likelihood at every iteration.
#' @export
fit.gmm.truncated <- function(x, K, bounds = cbind(rep(-Inf, ncol(x)), rep(Inf, ncol(x))), min_cov = NULL, epsilon = 1e-5, maxsteps = 1000, verbose = F) {
  fit <- .fit.gmm.internal(x, K, truncated = T, bounds = bounds, min_cov = min_cov, epsilon = epsilon, maxsteps = maxsteps, verbose = verbose, tdist = F)
  if (is.null(fit)) {
    return(NULL)
  }

  result <- list()
  result$type <- "gmm.truncated"
  result$K <- K
  result$centers <- fit$centers
  result$covariances <- fit$covariances
  result$proportions <- fit$component_weights
  result$bounds <- bounds
  result$log_likelihood <- fit$logl
  nparam <- K * ncol(x) * (ncol(x) + 1) / 2 + K
  result$AIC <- 2 * nparam - 2 * fit$logl
  result$BIC <- log(nrow(x)) * nparam - 2 * fit$logl
  result$assignment <- apply(fit$weights, 1, which.max)
  return(structure(result, class = "mvd.density"))
}

#' Fit a truncated t-distribution mixture with a specific number of components.
#'
#' description
#' @param x Matrix or vector of samples. For matrices, rows are samples and columns are variables.
#' @param K Integer specifying the number of components of the mixture.
#' @param df Degrees of freedom of the t-distrubtions.
#' @param bounds Dx2 matrix specifying the lower and upper bound for each variable.
#' @param epsilon For the EM algorithm, stop when the difference in log likelihood is less than this epsilon.
#' @param maxsteps Maximum number of steps to take in the EM algorithm. When the maximum number is reached, the current fit will be returned and a warning will be issued.
#' @param verbose Display the fitting progress by showing the likelihood at every iteration.
#' @export
fit.tmixture.truncated <- function(x, K, df = 3, bounds = cbind(rep(-Inf, ncol(x)), rep(Inf, ncol(x))), min_cov = NULL, epsilon = 1e-5, maxsteps = 1000, verbose = F) {
  fit <- .fit.gmm.internal(x, K, truncated = T, bounds = bounds, min_cov = min_cov, epsilon = epsilon, maxsteps = maxsteps, verbose = verbose, tdist = T, tdistdf = df)
  if (is.null(fit)) {
    return(NULL)
  }

  result <- list()
  result$type <- "gmm.truncated"
  result$K <- K
  result$centers <- fit$centers
  result$covariances <- fit$covariances
  result$proportions <- fit$component_weights
  result$bounds <- bounds
  result$log_likelihood <- fit$logl
  nparam <- K * ncol(x) * (ncol(x) + 1) / 2 + K
  result$AIC <- 2 * nparam - 2 * fit$logl
  result$BIC <- log(nrow(x)) * nparam - 2 * fit$logl
  result$assignment <- apply(fit$weights, 1, which.max)
  return(structure(result, class = "mvd.density"))
}

#' Calculate AIC of a Gaussian mixture across a range of number of components.
#'
#' description
#' @param x Matrix or vector of samples. For matrices, rows are samples and columns are variables.
#' @param K Vector specifying the number of components to test
#' @param optimal.only If TRUE, directly return only the GMM with optimal number of components; otherwise return a structure with fits for all tested number of components
#' @param epsilon See fit.gmm
#' @param maxsteps See fit.gmm
#' @param verbose Display the fitting progress.
#' @export
gmm.AIC <- function(x, K = 1:6, optimal.only = F, epsilon = 1e-5, maxsteps = 1000, verbose = F) {
  result <- list()
  result$K <- K
  result$AIC <- rep(NA, length(K))
  result$fits <- list()
  for (k in 1:length(K)) {
    if (verbose) {
      cat("Fitting K=", K[k], "\n")
    }

    nparam <- K[k] * (ncol(x) + ncol(x) * (ncol(x) + 1) / 2) + K[k] - 1
    if (k > 1 && nparam >= nrow(x)) {
      result$fits[[k]] <- NULL
      result$AIC[k] <- NA
    } else {
      fit <- fit.gmm(x, K[k], epsilon = epsilon, maxsteps = maxsteps, verbose = verbose)
      if (!is.null(fit)) {
        result$fits[[k]] <- fit
        result$AIC[k] <- result$fits[[k]]$AIC
      }
    }
  }
  if (optimal.only) {
    if (sum(!is.na(result$AIC)) == 0) {
      return(NULL)
    } else {
      ix <- which.min(result$AIC)
      return(result$fits[[ix]])
    }
  } else {
    return(result)
  }
}

#' Calculate AIC of a transformed Gaussian mixture across a range of number of components.
#'
#' description
#' @param x Matrix or vector of samples. For matrices, rows are samples and columns are variables.
#' @param K Vector specifying the number of components to test
#' @param bounds Dx2 matrix specifying the lower and upper bound for each variable.
#' @param optimal.only If TRUE, directly return only the GMM with optimal number of components; otherwise return a structure with fits for all tested number of components
#' @param epsilon See fit.gmm.transformed
#' @param maxsteps See fit.gmm.transformed
#' @param verbose Display the fitting progress.
#' @export
gmm.transformed.AIC <- function(x, K = 1:6, bounds, optimal.only = F, epsilon = 1e-5, maxsteps = 1000, verbose = F) {
  result <- list()
  result$K <- K
  result$AIC <- rep(NA, length(K))
  result$fits <- list()
  for (k in 1:length(K)) {
    if (verbose) {
      cat("Fitting K=", K[k], "\n")
    }
    nparam <- K[k] * (ncol(x) + ncol(x) * (ncol(x) + 1) / 2) + K[k] - 1
        if (k > 1 && nparam >= nrow(x)) {
            result$fits[[k]] <- NULL
            result$AIC[k] <- NA
        } else {
            result$fits[[k]] <- fit.gmm.transformed(x, K[k], bounds, epsilon = epsilon, maxsteps = maxsteps, verbose = verbose)
            if (!is.null(result$fits[[k]])) {
              result$AIC[k] <- result$fits[[k]]$gmm$AIC
            }
        }
    }
    if (optimal.only) {
      if (sum(!is.na(result$AIC)) == 0) {
        return(NULL)
      } else {
        ix <- which.min(result$AIC)
        return(result$fits[[ix]])
      }
    } else {
        return(result)
    }
}

#' Calculate AIC of a truncated Gaussian mixture across a range of number of components
#'
#' description
#' @param x Matrix or vector of samples. For matrices, rows are samples and columns are variables.
#' @param K Vector specifying the number of components to test
#' @param bounds Dx2 matrix specifying the lower and upper bound for each variable.
#' @param optimal.only If TRUE, directly return only the GMM with optimal number of components; otherwise return a structure with fits for all tested number of components
#' @param epsilon See fit.gmm.truncated
#' @param maxsteps See fit.gmm.truncated
#' @param verbose Display the fitting progress.
#' @export
gmm.truncated.AIC <- function(x, K = 1:6, bounds = cbind(rep(-Inf, ncol(x)), rep(Inf, ncol(x))), optimal.only = F, min_cov = NULL, epsilon = 1e-5, maxsteps = 1000, verbose = F) {
    result <- list()
    result$K <- K
    result$AIC <- rep(NA, length(K))
    result$fits <- list()
    for (k in 1:length(K)) {
        if (verbose) {
            cat("Fitting K=", K[k], "\n")
        }
        nparam <- K[k] * (ncol(x) + ncol(x) * (ncol(x) + 1) / 2) + K[k] - 1
        if (k > 1 && nparam >= nrow(x)) {
            result$fits[[k]] <- NULL
            result$AIC[k] <- NA
        } else {
            result$fits[[k]] <- fit.gmm.truncated(x, K[k], bounds = bounds, min_cov = min_cov, epsilon = epsilon, maxsteps = maxsteps, verbose = verbose)
            if (!is.null(result$fits[[k]])) {
              result$AIC[k] <- result$fits[[k]]$AIC
            }
        }
    }
    if (optimal.only) {
      if (sum(!is.na(result$AIC)) == 0) {
        return(NULL)
      } else {
        ix <- which.min(result$AIC)
        return(result$fits[[ix]])
      }
    } else {
        return(result)
    }
}


#линейна регресия - проверява дали Y = Y1,..,Yn (вектор със стойности от извадка) се влияе от предиктори X = X1,..,Xn ... Z = Z1,..,Zn
#функцията lm(y~x) или lm(y~x1+x2+x3+..+xn) за определяне на коефициентите на регресионната права при съответно един или няколко предиктора
#функцията coefficients(lm(..)) изкарва много информация за регресията

#Стъки при построяване на регресионен модел (трябва да проверим за всички тези неща и да отстраним предикторите, които създават проблеми):
#1.Проверка дали някои от предикторите не са зависими помежду си -> с cor(), ако някоя стойност е много близка до 1 или -1, трябва да махнем една от величините или графично със scatterplot() (трябва да бъде заредена библиотеката car предварително library("car"))
#2.Проверка дали величините са нормално разпределени -> с qqnorm() и qqline() графично, ако някъде точките много се отдалечават от правата, значи величините не са норално разпределени и трябва да се махне от модела
#3.Проверка за outlier-и -> с boxplot() графично, ако има точки много отгоре или отдолу трябва да бъдат махнати (тези редове да трябва да бъдат махнати от всички предиктори, ако работим с матрица със предиктори по стълбовете)
#4.Построяване на регресионния моде -> lm(Y~X1+..+Xn); plot(Y); abline(lm(Y~X1+..+Xn)) трябва графично всички точки да са близо до правата
#5.Заключение дали модела е добър и дали данните са добри -> със summary(lm(..)) се гледа дали предикторите са от голямо значение (броят на звездичките), колкото по-голяма е стойността на R-squared, толкова по-добър е модела
#6.Може да се направи друг модел с други предиктори и да се провери кой е по-добър с anova

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

#01
x=c(2,-6,7)
y=c(3,4,6)

#емпирично
r=cor(x,y)
sy=sd(y)
sx=sd(x)
b1=r*(sy)/sx
y.cherta=mean(y)
x.cherta=mean(x)
b0=y.cherta - b1*x.cherta

#теоретично
b=lm(y~x)

plot(x,y)
abline(b)
#abline(b0,b1)

#02
x=c(-2,-1,0,1,2)
y=x*x

plot(x,y)
abline(lm(y~x))
m1=lm(y~x)
cov(x,y)
summary(m1)

plot(x,y)
abline(lm(y~I(x^2)))
m2=lm(y~I(x^2))
summary(m2)
cov(x^2,y)

#03
x=c(0,4,10,15,21,29,36,51,68)
y=c(66.7,71,76.3,80.6,85.7,92.9,99.4,113.6,125.1)
m=lm(y~x)
plot(x,y)
abline(m)
summary(m)

#определете интервалите на параметрите на правата
alpha= 0.05
c=coefficients(summary(m))
b0 = summary(m)$coefficients[1]
se = summary(m)$coefficients[3]
b1 = summary(m)$coefficients[2]
se1 = summary(m)$coefficients[4]

upper0 = b0 + qnorm(1-alpha/2)*se
lower0 = b0 - qnorm(1-alpha/2)*se

upper1 = b1 + qnorm(1-alpha/2)*se1
lower1 = b1 - qnorm(1-alpha/2)*se1

#04
x=c(1.5, 1.7, 2.0, 2.5, 2.5, 2.7, 2.9, 3, 3.5, 3.4, 9.5, 9.5, 3.8, 4.2, 4.3, 4.6, 4, 5.1, 5.1, 5.1, 5.2, 5.5)
y=c(3, 2.5, 3.5, 3, 3.1, 3.6, 3.2, 3.9, 4, 4, 8, 2.5, 4.2, 4.1, 4.8, 4.2, 5.1, 5.1, 5.1, 5.1, 4.8, 5.3)
plot(x,y)
m=lm(y~x)
abline(m)
summary(m)

#махаме outlier-ite
boxplot(x,y)
x.better=c(1.5, 1.7, 2.0, 2.5, 2.5, 2.7, 2.9, 3, 3.5, 3.4, 3.8, 4.2, 4.3, 4.6, 4, 5.1, 5.1, 5.1, 5.2, 5.5)
y.better=c(3, 2.5, 3.5, 3, 3.1, 3.6, 3.2, 3.9, 4, 4, 4.2, 4.1, 4.8, 4.2, 5.1, 5.1, 5.1, 5.1, 4.8, 5.3)
m.better = lm(y.better~x.better)
plot(x.better,y.better)
abline(m.better)
summary(m.better)
rstandard(m.better) #???

#05
Er_red= 630.43
Er_full = 615.62
p = 2;
sfull=1.513
fratio = (Er_red-Er_full)/(p*sfull^2)
fratio
df(3.23,2,269)

#06
#install.packages("faraway")
library(faraway)
?savings
#install.packages("car")
library(car)
scatterplotMatrix(savings)
savings
x=lm(savings$sr~savings$pop75+savings$pop15+savings$dpi+savings$ddpi)
y1=lm(savings$sr~savings$pop15+savings$dpi+savings$ddpi)
y2=lm(savings$sr~savings$pop75+savings$pop15+savings$ddpi)
summary(y1)
summary(y2)
summary(x)
anova(x)
anova(y1)
anova(y2)
predict(y2,interval='confidence')


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


## Created on Saturday, December 12, 2020 at 9:33pm EST by WeekendEditor on WeekendEditorMachine.
## Copyright (c) 2020, SomeWeekendReading.  All rights reserved.  As if you care.

library("plyr")                                        # For ddply()
toolsDir <- "../../tools"                              # Various tools available from author
source(file.path(toolsDir, "graphics-tools.r")         # Various graphics hacks

##
## Re-estimate efficacy and confidence intervals on Pfizer vaccine data.
##
## See: https://www.fda.gov/media/144245/download, especially Table 8, p 26.
##
## Also analyzed by Gary Cornell:
## https://garycornell.com/2020/12/09/statistics-in-the-pfizer-data-how-good-is-the-vaccine/
##

doit <- function(plotDir           = "../images",
                 posteriorPlotFile = "2020-12-12-pfizer-vaccine-efficacy-confidence-intervals-posterior-betas.png") {

  efficacy <- function(Ntrt, Ntrtinf, Ncnt, Ncntinf) { # Vaccine efficacy point estimate
    100.0 * (1 - (Ntrtinf / Ntrt) / (Ncntinf / Ncnt))  # 1 - Pr(inf | trt) / Pr(inf | control)
  }                                                    #

  efficacyQuantiles <- function(alphaNum, betaNum, alphaDenom, betaDenom,
                                n = 1000, probs = c(0.025, 0.500, 0.975)) {
    round(quantile(100.0 * (1 - rbeta(n, alphaNum, betaNum) / rbeta(n, alphaDenom, betaDenom)),
                   probs = probs),                     #
          digits = 1)                                  #
  }                                                    #

  ## Create table of patient counts by treatment arm & infection status, then add
  ## a point estimate of the efficacy to compare with Pfizer:
  tbl <- transform(data.frame(Subgroup = c("Overall", "16-17", "18-64", "65-74", ">= 75"),
                              Ntrt     = c(    18559,      58,   14443,    3239,     805),
                              Ntrtinf  = c(        9,       0,       8,       1,       0),
                              Ncnt     = c(    18708,      61,   14566,    3255,     812),
                              Ncntinf  = c(      169,       1,     149,      14,       5)),
                   Subgroup = factor(Subgroup,
                                     levels = c("Overall", "16-17", "18-64", "65-74", ">= 75")),
                   VE        = round(efficacy(Ntrt, Ntrtinf, Ncnt, Ncntinf), digits = 1))
  cat(sprintf("Age groups, patient counts, and point estimates of efficacy:\n"))
  print(tbl)                                           # Show the data table

  ## Make plots of the posterior Beta distributions for the probability of infection in
  ## treatment and control arms, assuming a uniform prior.  Do it for each age cohort.
  ps <- seq(from = 0.0, to = 0.05, length.out = 1000)  # Values of p (horizontal axis)n
  f  <- file.path(plotDir, posteriorPlotFile)          # Plot destination pathname
  withPNG(f, 600, 1500, FALSE, function() {            # Start file capture
    withPars(function() {                              # Save/restore graphics params
      ddply(tbl, "Subgroup", function(df) {            # Do for each age cohort
        stopifnot(nrow(df) == 1)                       # 1 row only per age cohort
        with(df, {
          pinftrts    <- dbeta(ps, shape1 = Ntrtinf + 1, shape2 = Ntrt - Ntrtinf + 1)
          pinftrtsMAP <- ps[which.max(pinftrts)]
          pinftrtsCL  <- quantile(rbeta(1000, shape1 = Ntrtinf + 1, shape2 = Ntrt - Ntrtinf + 1),
                                  probs = c(0.025, 0.975))

          pinfcnts    <- dbeta(ps, shape1 = Ncntinf + 1, shape2 = Ncnt - Ncntinf + 1)
          pinfcntsMAP <- ps[which.max(pinfcnts)]
          pinfcntsCL  <- quantile(rbeta(1000, shape1 = Ncntinf + 1, shape2 = Ncnt - Ncntinf + 1),
                                  probs = c(0.025, 0.975))

          matplot(x = ps, y = cbind(pinftrts, pinfcnts),
                  type = "l", lty = "solid", col = c("blue", "black"),
                  ylab = "Density", xlab = "p", main = sprintf("%s Cohort", as.character(Subgroup)))
          legend("topright", inset = 0.01, bg = "antiquewhite",
                 col = c("blue", "black"), lty = "solid",
                 legend = c(sprintf("Treatment MAP: %.4f [%.4f - %.4f]",
                                    pinftrtsMAP, pinftrtsCL[[1]], pinftrtsCL[[2]]),
                            sprintf("Control MAP:     %.4f [%.4f - %.4f]",
                                    pinfcntsMAP, pinfcntsCL[[1]], pinfcntsCL[[2]])))
          abline(v = c(pinftrtsCL), col = "blue",  lty = "dashed")
          abline(v = c(pinfcntsCL), col = "black", lty = "dashed")
        })                                             # Close with()
        NULL                                           # So ddply() will return nothing of interest
      })                                               # Close ddply()
    }, pty = "m",                                      # Maximal plotting area
       bg  = "transparent",                            # Transparent background
       ps  = 16,                                       # Larger type size for file capture
       mgp = c(1.7, 0.5, 0),                           # Axis title, label, tick
       mar = c(3, 3, 2, 1),                            # Pull in on margins a bit
       mfrow = c(length(levels(tbl$"Subgroup")), 1))   # 1 column of plots for each age cohort
  })                                                   # End file capture
  cat(sprintf("\n\nPosterior beta distributions plotted to %s.", f))

  foo <- subset(ddply(tbl, "Subgroup", function(df) {  # Numerically compute random ratios of
    stopifnot(nrow(df) == 1)                           #  the Beta-distributed variables, and
    with(df,                                           #  then find the 2.5% & 97.5% quantiles
         efficacyQuantiles(Ntrtinf + 1, Ntrt - Ntrtinf + 1, Ncntinf + 1, Ncnt - Ncntinf + 1))
  }), select = c("Subgroup", "2.5%", "50%", "97.5%"))  # Also report the median, because why not
  tbl <- merge(tbl, foo, by = "Subgroup", sort = FALSE)# Join onto our magic table
  cat("\n\n"); print(tbl)                              # Show the table

  cat("\n")                                            # Final newline
  invisible(tbl)                                       # Return data table, invisibly
}                                                      #


=begin
  # sample-splitting-field01.rb

  require "algebra"

  PQ = Polynomial(Rational, "x")
  x = PQ.var
  f = x**4 + 2
  p f #=> x^4 + 2
  field, modulus, facts = f.decompose
  p modulus #=> [a^4 + 2, b^2 + a^2]
  p facts #=> (x - a)(x + a)(x - b)(x + b)

  fp = Polynomial(field, "x")
  x = fp.var
  facts = Factors.new(facts.collect{|g, n| [g.evaluate(x), n]})
  p facts.pi == f.convert_to(fp) #=> true
((<_|CONTENTS>))
=end


library(MFPCA)

mfpca_train = function(multivar, argvals){

    # multivariate FPCA based on results from uPACE
    mFPCA = function(Xi, phi, p , L, I=I){

        # eigenanalysis on matrix M
        M = t(Xi)%*%Xi/(I-1)
        eigen.M = eigen(M)
        values = eigen.M$values
        pve = cumsum(values)/sum(values)
        Cms = eigen.M$vectors
        index = unlist(lapply(1:length(L), function(x) rep(x, L[x])))

        # MFPCA score
        rho = mfpca_score(Xi, Cms)

        # MFPCA eigenfunction
        psis = NULL
        for(j in 1:p){
            psi = NULL
            for(m in 1:dim(Cms)[2]){
                psi = cbind(psi, phi[[j]]%*%Cms[which(index==j),m])
            }
            psis[[j]] = psi
        }

        out = list(eigenvalue = values, Cms = Cms, pve = pve, rho = rho, psis=psis)
        return(out)
    }

    multivar = as.array(multivar)
    argvals = as.numeric(argvals)
    multivar = ifelse(multivar==0, NA, multivar)

    I = dim(multivar)[1]
    Q = dim(multivar)[3]

    # univariate FPCA via PACE
    Xi.train = L = phi.train =  NULL
    for(p in 1:Q){
        tmp.ufpca = uPACE(multivar[,,p], argvals)
        Xi.train = cbind(Xi.train, tmp.ufpca$scores) # FPC scores
        L = c(L, dim(tmp.ufpca$scores)[2])
        phi.train[[p]] = t(tmp.ufpca$functions@X) # FPC eigenfunctions
    }

    # multivariate FPCA
    mFPCA.train = mFPCA(Xi=Xi.train, phi=phi.train, p=Q, L=L ,I=I)
    rho.train = mFPCA.train$rho  #MFPC scores
    pve = mFPCA.train$pve
    Cms = mFPCA.train$Cms
    psis = mFPCA.train$psis
    psi = array(dim=c(Q,dim(psis[[1]])[1],dim(psis[[1]])[2]))
    for(p in 1:Q){
        psi[p,,] = psis[[p]]
    }

    return(list("scores"=rho.train, "Cms"=Cms, "psi"=psi))
}

mfpca_test = function(multivar.train, multivar.test, argvals, Cms, psi){
    multivar.train = as.array(multivar.train)
    multivar.test = as.array(multivar.test)
    multivar.train = ifelse(multivar.train==0, NA, multivar.train)
    multivar.test = ifelse(multivar.test==0, NA, multivar.test)
    argvals = as.numeric(argvals)
    Q = dim(multivar.test)[3]

    # univariate FPC
    Xi.test = NULL
    meanf = NULL
    for(qq in 1:Q){
        tmp.ufpca = uPACE(multivar.train[,,qq], argvals, multivar.test[,,qq])
        Xi.test = cbind(Xi.test, tmp.ufpca$scores) # dynamic FPC scores for test subjects
        meanf[[qq]] = tmp.ufpca$mu@X
    }

    # estimate MFPC scores for test subjects
    rho.test = mfpca_score(Xi.test, Cms)
    long.pred = mfpca_pred(rho.test, meanf, psi)

    return(list("scores"=rho.test, "long_pred"=long.pred))
}

# mfpc score calculation
mfpca_score = function(predXi, Cms){
    rho = matrix(NA, nrow = nrow(predXi), ncol=dim(Cms)[2])
    for(i in 1:nrow(predXi)){
        for(m in 1:dim(Cms)[2]){
            rho[i,m] = predXi[i,]%*%Cms[,m]
        }
    }
    return(rho)
}

# mfpc trajectories prediction
mfpca_pred = function(score, meanf, psi, n.rho=NULL){
    p = dim(psi)[1]
    n = nrow(score)

    if(is.null(n.rho)){
        n.rho = ncol(score)
    }

    out = NULL
    for(m in 1:p){
        out[[m]] = matrix(meanf[[m]], nrow=n, ncol=length(meanf[[m]]), byrow = T ) + score[,1:n.rho]%*%t(psi[m,,1:n.rho])
    }

    long.pred = array(data=NA, dim=c(dim(out[[1]])[1],dim(out[[1]])[2],p))
    for(m in 1:p){
        long.pred[,,m] = out[[m]]
    }
    return(long.pred)
}

# univariate FPCA via principal analysis by conditional estimation(PACE)
uPACE = function(testData, domain, predData=NULL, nbasis = 5, pve = 0.99, npc = NULL){
    tmp = funData(domain, testData)
    if(is.null(predData)){
        tmp2 = NULL
    }else{
        tmp2 = funData(domain, predData)
    }
    res = PACE(tmp, tmp2, pve=pve, npc= npc, nbasis=nbasis)
    return(res)
}


library(gRain)

F = cptable(~F, values=c(10,90),levels=val)
C = cptable(~C|F, values=c(10,90,20,80),levels=val)
E = cptable(~E|F, values=c(50,50,30,70),levels=val)
A = cptable(~A|C, values=c(50,50,70,30),levels=val)
D = cptable(~D|E, values=c(60,40,70,30),levels=val)
B = cptable(~B|A:D, values=c(60,40,70,30,20,80,10,90),levels=val)

plist = compileCPT(list(F,E,C,A,D,B))
plist

print(plist$F)
print(plist$B)

jtree = grain(plist)
jtree

querygrain(jtree, nodes=c("F"), type="marginal")
querygrain(jtree, nodes=c("C"), type="marginal")
querygrain(jtree, nodes=c("B"), type="marginal")
querygrain(jtree, nodes=c("A","B"), type="joint")
querygrain(jtree, nodes=c("A","B","C"), type="joint")

jtree2 = setEvidence(jtree, evidence=list(F="true"))
querygrain(jtree, nodes=c("F"), type="marginal")
querygrain(jtree2, nodes=c("F"), type="marginal")
querygrain(jtree, nodes=c("A"), type="marginal")
querygrain(jtree2, nodes=c("A"), type="marginal")
querygrain(jtree, nodes=c("B"), type="marginal")
querygrain(jtree2, nodes=c("B"), type="marginal")

jtree3 = setEvidence(jtree, evidence=list(F="true",A="false"))
querygrain(jtree, nodes=c("C"), type="marginal")
querygrain(jtree2, nodes=c("C"), type="marginal")
querygrain(jtree3, nodes=c("C"), type="marginal")


#Series temporais e analises preditivas - Fernando Amaral

library(forecast)
library(ggplot2)
library(seasonal)
library(seasonalview)
library(urca)

#importar dados do hotel
dados = read.csv(file.choose(),header = F)
print(dados)
ocupacao = ts(dados, start = c(2003,1), end = c(2017,12), frequency=12)

#resumo
summary(ocupacao)

#visualizar
autoplot(ocupacao)
hist(ocupacao)
boxplot(ocupacao)

#decompor
dec =   decompose(ocupacao)
autoplot(dec)

#analisar a tendência com mais cuidado
autoplot(dec$trend)
autoplot(window(dec$trend, start=c(2015,9)))

#efeito sazonal por ano
ggseasonplot(ocupacao)
ggseasonplot(window(ocupacao, start=c(2016)))

#teste de estacionariedade
est = ur.kpss(ocupacao)
print(est)
ndiffs(ocupacao)

tsdisplay(ocupacao)

modelo = auto.arima(ocupacao, trace = T,stepwise = F, approximation = F )
print(modelo)

checkresiduals(modelo)

shapiro.test(modelo$residuals)

#previsao para 2 anos
previsao = forecast(modelo,h=24)

autoplot(previsao)

Udemy/Series Temporais e Analises Preditivas/Resources/Codigo/11.1.Casopratico.r


rm(list = ls())

n <- 50
k <- 3
y <- c(8, 14)

menosLogLikelihood <- function(theta, y, n) {
  p1 <- theta[1]
  p2 <- theta[2]
  l <- sum(y * log(theta)) + (n - sum(y)) * log(1 - sum(theta))
  return(-l)
}

p.init <- c(0.3, 0.3)
opt <- optim(p.init, menosLogLikelihood, y=y, n=n, hessian = TRUE)

(emv <- opt$par)
emv.value <- opt$value

info.obs <- opt$hessian
(v.hat <- solve(info.obs))

(residual.standard <- sqrt(diag(v.hat)))

# Hipothesis H0: p2 - 2p1 = 0

p.obs <- emv[2] - 2 * emv[1]
p.0 <- 0

# WALD

wald.var <- t(c(2, -1)) %*% v.hat %*% c(2, -1)
wald.obs <- (p.obs - p.0) ^ 2 / wald.var
(wald.pvalue <- 1 - pchisq(wald.obs, 1))

# LIKELIHOOD RATIO

# TODO
likeratio.obs <- 2 * 0

(likeratio.pvalue <- 1 - chisq(likeratio.obs, 1))


=begin
  # sample-algebraic-equation02.rb

  require "algebra"

  PQ = MPolynomial(Rational)
  a, b, c = PQ.vars("abc")
  p AlgebraicEquation.minimal_polynomial(a + b + c, a**2-2, b**2-3, c**2-5)
  #=> x^8 - 40x^6 + 352x^4 - 960x^2 + 576
((<_|CONTENTS>))
=end