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


 DGEQRT Example Program Results

 Least squares solution(s)
             1          2
 1      1.5339    -1.5753
 2      1.8707     0.5559
 3     -1.5241     1.3119
 4      0.0392     2.9585

 Square root(s) of the residual sum(s) of squares
        2.22E-02   1.38E-02


# 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


library(tidyverse)
library(StableEstim)
library(stabledist)

zt <- read.csv('euro_in_sterling.csv')$zt
yt <- 100 * log(zt[2:length(zt)] / zt[1:(length(zt) - 1)])

# Fit stable distribution to data, using a MLE method
fitML <- Estim('ML', yt, ComputeCov = TRUE)
smpls <- rstable(1e7, fitML@par['alpha'], fitML@par['beta'], fitML@par['gamma'], fitML@par['delta'])

smpls <- smpls[(smpls > -2) & (smpls < 2)]

ggplot(data=tibble(it=1:length(yt), yt=yt),
       aes(x=yt)) +
  geom_histogram(aes(y = ..density..), bins = 40, alpha=0.4) +
  geom_histogram(data = tibble(smpls), aes(x = smpls, y = ..density..), bins = 40, fill='red', alpha=0.2) +
  scale_colour_discrete(labels = c("Data", "Simulated"))


nonsqr <- function(n) n + floor(1/2 + sqrt(n))
nonsqr(1:22)


library(Sleuth3) # Load the Sleuth3 package.
help(package=Sleuth3)
case0102

hist(case0102$Salary)
with(case0102,hist(Salary))
with(case0102,hist(Salary[Sex=="Male"]))
with(case0102,hist(Salary[Sex=="Female"]))
with(case0102,hist(Salary[Sex=="Female"],
                   breaks=c(3800,4200,4600,5000,5400,5800,6200,6600)))
help(hist)

# Install ggplot2 before loading it into the library, if needed.
library(ggplot2)
qplot(Sex,Salary,data=case0102,geom="boxplot")
qplot(Sex,Salary,geom="boxplot",data=case0102)
qplot(Salary,Sex,data=case0102,geom="boxplot")

ggplot(case0102,aes(x=Sex,y=Salary)) + geom_boxplot(aes(fill=Sex))
ggplot(case0102,aes(x=Sex,y=Salary)) + geom_boxplot(aes(fill=Sex))+ ggtitle("Starting Salaries")

with(case0102,boxplot(Salary~Sex))

with(case0102,(stem(Salary[Sex=="Male"])))

with(case0102,summary(Salary[Sex=="Female"]))

with(case0102,is.factor(Sex))
with(case0102,summary(Sex))

with(case0102,(sd(Salary[Sex=="Female"])))
t.test(Salary~Sex,alternative="less",data=case0102,var.equal=TRUE)


# # # # # Predicting with tree on iris dataset
data(iris); library(ISLR); library(ggplot2); library(caret); library(gridExtra); library(splines);
names(iris)

inTrain <- createDataPartition(y=iris$Species,p=0.7, list=FALSE)
training <- iris[inTrain,]
testing <- iris[-inTrain,]
dim(training); dim(testing)

qplot(Petal.Width,Sepal.Width,colour=Species,data=training)

library(caret)
modFit <- train(Species ~ .,method="rpart",data=training)
print(modFit$finalModel)

plot(modFit$finalModel, uniform=TRUE, main="Classification Tree")
text(modFit$finalModel, use.n=TRUE, all=TRUE, cex=.8)

library(rattle)
fancyRpartPlot(modFit$finalModel)

predict(modFit,newdata=testing)

# # # # # Bagging
library(ElemStatLearn); data(ozone,package="ElemStatLearn")
ozone <- ozone[order(ozone$ozone),]
head(ozone)

ll <- matrix(NA,nrow=10,ncol=155)
for(i in 1:10){
  ss <- sample(1:din(ozone)[1],replace=T)
  ozone0 <- ozone[ss,]; ozone0 <- ozone0[order(ozone$ozone),]
  loess0 <- loess(temperature ~ ozone,data=ozone0,span=0.2)
  ll[i,] <- predict(loess0,newdata=data.frame(ozone=1:155))
}

plot(ozone$ozone,ozone$temperature,pch=19,cex=0.5)
for(i in 1:10){lines(1:155,ll[i,],col="grey",lwd=2)}
lines(1:155,apply(ll,2,mean),col="red",lwd=2)

predictors = data.frame(ozone=ozone$ozone)
temperature = ozone$temperature
treebag <- bag(predictors, temperature, B = 10,
                  bagControl = bagControl(fit = ctreeBag$fit,
                                          predict = ctreeBag$pred,
                                          aggregate = ctreeBag$aggregate))

plot(ozone$ozone,temperature,col='lightgrey',pch=19)
points(ozone$ozone,predict(treebag$fits[[1]]$fit,predictors),pch=19,col="red")
points(ozone$ozone,predict(treebag,predictors),pch=19,col="blue")

ctreeBag$fit

function (x, y, ...)
{
  library(party)
  data <- as.data.frame(x)
  data$y <- y
  ctree(y ~., data = data)
}

<environment: namespace:caret>

# other functions that follow, but will not include

# # # # # Random forests on iris dataset
# data(iris); library(ggplot2)
# inTrain <- createDataPartition(y=iris$Species,p=0.7, list=FALSE)
# training <- iris[inTrain,]
# testing <- iris[-inTrain,]

library(caret)
modFit <- train(Species~ .,data=training,method="rf",prox=TRUE)
modFit

getTree(modFit$finalModel,k=2)

irisP <- classCenter(training[,c(3,4)], training$Species, modFit$finalModel$prox)
irisP <- as.data.frame(irisP); irisP$Species <- rownames(irisP)
p <- qplot(Petal.Width, Petal.Length, col=Species,data=training)
p + geom_point(aes(x=Petal.Width,y=Petal.Length,col=Species),size=5,shape=4,data=irisP)

pred <- predict(modFit,testing); testing$predRight <- pred==testing$Species
table(pred,testing$Species)

qplot(Petal.Width,Petal.Length,colour=predRight, data=testing,main="newdata Predictions")

# # # # # Boosting
library(ISLR); data(Wage); library(ggplot2); library(caret);
Wage <- subset(Wage,select=-c(logwage))
inTrain <- createDataPartition(y=Wage$wage,p=07,list=FALSE)
training <- Wage[inTrain,]; testing <- Wage[-inTrain,]

modFit <- train(wage ~ ., method="gbm",data=training,verbose=FALSE)
print(modFit)

qplot(predict(modFit,testing),wage,data=testing)

# # # # # Model Based Prediction
# data(iris); library(ggplot2)
# names(iris)

# inTrain <- createDataPartition(y=iris$Species,p=0.7, list=FALSE)
# training <- iris[inTrain,]
# testing <- iris[-inTrain,]
# dim(training); dim(testing)

modlda = train(Species ~ .,data=training,method="lda")
modnb = train(Species ~ ., data=training,method="nb")
plda = predict(modlda,testing); pnb = predict(modnb,testing)
table(plda,pnb)

equalPredictions = (plda==pnb)
qplot(Petal.Width,Sepal.Width,colour=equalPredictions,data=testing)


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


# Create an artificial population for sampling.
library(rgdal)
library(maptools)
data.Set4.2Yield96raw <- read.csv("Set4\\Set4.296wheatyield.csv", header = TRUE)
coordinates(data.Set4.2Yield96raw) <- c("Easting", "Northing")
proj4string(data.Set4.2Yield96raw) <- CRS("+proj=utm +zone=10 +ellps=WGS84")

# Interpolate to a 5 meter grid
library(gstat)
Left <- 592102.5
Right <- 592817.5
Top <- 4267857.5
Bottom <- 4267502.5
cell.size <- 5
grid.xy <- expand.grid(x = seq(Left,Right,cell.size),
  y = seq(Top,Bottom,-cell.size))
coordinates(grid.xy) <- ~x + y
gridded(grid.xy) = TRUE
proj4string(grid.xy) <- CRS("+proj=utm +zone=10 +ellps=WGS84")
yield.idw <- krige(Yield ~ 1, data.Set4.2Yield96raw, grid.xy)
pop.data <- data.frame(yield.idw@data$var1.pred)
grid.xy <- expand.grid(Easting = seq(Left,Right,cell.size),
  Northing = seq(Top,Bottom,-cell.size))
coordinates(pop.data) <- grid.xy
names(pop.data) <- "Yield"
proj4string(pop.data) <- CRS("+proj=utm +zone=10 +ellps=WGS84")
greys <- grey(0:200 / 255)
spplot(pop.data, zcol = "Yield", col.regions = greys,
  xlim = c(Left,Right), scales = list(draw = TRUE),
  xlab = "Easting", ylab = "Northing",
  main = "Field 4.2 1996 Artificial Yield Population") # Fig. 5.1a

# Create a figure of original and interpolated data points
data.Pop <- spRbind(pop.data,data.Set4.2Yield96raw[,2])
spplot(data.Pop, zcol = "Yield", col.regions = greys,
  xlim = c(592500,592550), ylim = c(4267750,4267800),
  scales = list(draw = TRUE),  # Fig. 5.1b
  xlab = "Easting", ylab = "Northing",
  main = "Actual Yield and Artificial Population")

print(pop.mean <- mean(pop.data$Yield), digits = 5)
print(pop.sd <- sd(pop.data$Yield), digits = 5)

par(mai = c(1,1,1,1))
hist(pop.data$Yield, 100, plot = TRUE,
   main = "Histogram of Artificial Population",
   xlab = "Yield, kg/ha", font.lab = 2, cex.main = 2,
   cex.lab = 1.5)  # Fig. 5.2

# Note: The file name cannot have the character "."
writePointsShape(pop.data, "Created\\Set42pop")

# Create the sample boundary
W <- bbox(pop.data)[1,1]
E <- bbox(pop.data)[1,2]
S <- bbox(pop.data)[2,1]
N <- bbox(pop.data)[2,2]
N - S
E - W
N <- N + 2.5
S <- S - 2.5
E <- E + 2.5
W <- W - 2.5
coords.mat <- matrix(c(W,E,E,W,W,N,N,S,S,N), ncol = 2)
library(maptools)
sampbdry.vec <- vector(mode="list", length=1)
sampbdry.vec[[1]] <- Polygons(list(Polygon(coords.mat)), ID="1")
sampbdry.sp <- SpatialPolygons(sampbdry.vec,
   proj4string = CRS("+proj=utm +zone=10 +ellps=WGS84"))


# Source: https://towardsdatascience.com/tidy-anomaly-detection-using-r-82a0c776d523
# Author: AbdulMajedRaja RS - https://towardsdatascience.com/@amrwrites
# See https://github.com/amrrs/anomaly_detection_tidy_way/

library(anomalize) #tidy anomaly detectiom
library(tidyverse) #tidyverse packages like dplyr, ggplot, tidyr
library(coindeskr) #bitcoin price extraction from coindesk

btc <- get_historic_price(start = "2017-01-01")

#Convert to time series
btc_ts <- btc %>% rownames_to_column() %>% as_tibble() %>%
  mutate(date = as.Date(rowname)) %>% select(-one_of('rowname'))
head(btc_ts)

#Decompose time series
btc_ts %>%
  time_decompose(Price, method = "stl", frequency = "auto", trend = "auto") %>%
  anomalize(remainder, method = "gesd", alpha = 0.05, max_anoms = 0.2) %>%
  plot_anomaly_decomposition()

# Detect anomalies
btc_ts %>%
  time_decompose(Price) %>%
  anomalize(remainder) %>%
  time_recompose() %>%
  plot_anomalies(time_recomposed = TRUE, ncol = 3, alpha_dots = 0.5)

# Extract anomaly obervations
btc_ts %>%
  time_decompose(Price) %>%
  anomalize(remainder) %>%
  time_recompose() %>%
  filter(anomaly == 'Yes')


=begin
[((<index|URL:index.html>))]
((<Algebra::MatrixAlgebraTriplet>))
/
((<Algebra::MatrixAlgebraQuint>))

= Algebra::MatrixAlgebraTriplet

((*(Class of Triplet of matrices)*))

This is the class of the matrix and the records of the right and
left elementary diformations on it. There is a subclass of the quintet
of matrices (((<Algebra::MatrixAlgebraQuint>))).

== File Name:
* ((|matrix-algebra-triplet.rb|))

== SuperClass:

* ((|Object|))

== Included Modules:
* ((|GaussianElimination|))
* ((|ElementaryDivisor|))

=== Class Methods:

--- :new(matrix[, left[, right]])
    Creates the triplet object of ((|matrix|)) as the body,
    ((|left|)) as the record of the left(row) deformation and
    ((|right|)) as the record ofthe right(column) deformation.

== Methods:

--- body
    Returns the body.

--- left
    Returns ((|left|)) as the record of the left(row) deformation.

--- right
    Returns ((|right|)) as the record ofthe right(column) deformation.

--- to_a
    Retruns the array of (({[body, left, right]})).

--- to_ary
    Same as ((<to_a>)).

--- dup
    Returns the duplicate of ((|self|)).

--- transpose
    Returns the transpose of ((|self|)). Same as

      [type.new(body.transpose, right.transpose, left.transpose].

--- replace(other)
    Replaces ((|self|)) to ((|other|)).

--- display
    Displays ((|self|))

--- [](i, j)
    Returns the componetnt of (({(i, j)})).

--- rsize
    Returns the row size.

--- csize
    Return the column size.

--- each_i
    Iterates for the row index.

--- each_j
    Iterates for the column index.

--- row!(i)
    Retunrs the ((|i|)) -th row.

--- sswap_r!(i, j)

--- swap_r!(i, j)

--- swap_c!(i, j)

--- multiply_r!(i, c)

--- multiply_c!(j, c)

--- divide_r!(i, c)

--- divide_c!(j, c)

--- mix_r!(i, j[, c])

--- mix_c!(i, j[, c])

--- left_eliminate!
    Refer ((<Algebra::GauusianElimination|URL:matrix-algebra.html#label:96>)).

= Algebra::MatrixAlgebraQuint

((*(Class of Quintet of matrices)*))

This is the class of the matrix and the records of the right and
left elementary diformations on it and the reverses of them.
There is a superclass of the triplet
of matrices (((<Algebra::MatrixAlgebraTriplet>))).

== SuperClass:

* ((|Algebra:MatrixAlgebraTriplet|))

== Methods:

--- lefti
    Returns the inverse of ((<left>)).

--- righti
    Returns the inverse of ((<right>)).

--- to_a
    Reutrns (({[body, left, right, lefti, righti]})).

=end


burial.KWL= read.delim("burials_Kiwulan.csv", header=T, sep=",")
u.burial.KWL= read.delim("upperburials_Kiwulan.csv", header=T, sep=",")
l.burial.KWL= read.delim("Lowerburials_Kiwulan.csv", header=T, sep=",")
u.burial.KWL= read.delim("upperburials_Kiwulan.csv", header=T, sep=",")
attach(u.burial.KWL)
attach(burial.KWL)
u.burials= na.omit(u.burial.KWL[13:29])
par(las=2,mar=c(6,4,4,2))
boxplot(u.burials, main= " burial goods", xlab=" Elements")
# log the original data
burials.log= sapply(u.burials, log)
par(las=2,mar=c(6,4,4,2))
boxplot(burials.log, main="burial goods", xlab="Logged Elements")
# standarize the original data
mean.elements= sapply(u.burials, mean)
sd.elements= sapply(u.burials, sd)
burials.z = t( (t(u.burials)- mean.elements)/sd.elements)
par(las=2,mar=c(6,4,4,2))
boxplot(burials.z, main="burial goods", xlab="Standarized Elements")

# correlation matrix
options('digits')
options(digits= 3)
R= cor(burials.z, use="complete.obs")
R
library("psych")
cortest.bartlett(R)
PCA= prcomp(burials.z)
summary(PCA)
eigenvalues= PCA$sdev^2
plot(1:length(eigenvalues), eigenvalues, main="Scree plot",
     xlab="Components", ylab=" Eigenvalues",type="l", col="red")
axis(1, at= 1:length(eigenvalues))
loadings= PCA$rotation^2
loadings
#byplot of pc1 and pc2(gender)
plot(PCA$x[,1], PCA$x[,2], pch=".",xlab="PC1", ylab="PC2", main="Pottery - PC1 .vs. PC2")
labels= factor(gender)
text(PCA$x[,1], PCA$x[,2], labels, cex=0.7)
abline(h=0, v=0, lty=2, col="red")

#bylot of pc1 and pc2(age)
plot(PCA$x[,1], PCA$x[,2], pch=".",xlab="PC1", ylab="PC2", main="Pottery - PC1 .vs. PC2")
labels= factor(age)
text(PCA$x[,1], PCA$x[,2], labels, cex=0.7)
abline(h=0, v=0, lty=2, col="red")

#byplot of pc1 and pc3(gender)
plot(PCA$x[,1], PCA$x[,3], pch=".",xlab="PC1", ylab="PC3", main="Pottery - PC1 .vs. PC3")
labels= factor(gender)
text(PCA$x[,1], PCA$x[,3], labels, cex=0.7)
abline(h=0, v=0, lty=2, col="red")

#bylot of pc1 and pc3(age)
plot(PCA$x[,1], PCA$x[,3], pch=".",xlab="PC1", ylab="PC3", main="Pottery - PC1 .vs. PC3")
labels= factor(age)
text(PCA$x[,1], PCA$x[,3], labels, cex=0.7)
abline(h=0, v=0, lty=3, col="red")

#byplot of pc1 and pc4(gender)
plot(PCA$x[,1], PCA$x[,4], pch=".",xlab="PC1", ylab="PC4", main="Pottery - PC1 .vs. PC4")
labels= factor(gender)
text(PCA$x[,1], PCA$x[,4], labels, cex=0.7)
abline(h=0, v=0, lty=2, col="red")

#bylot of pc1 and pc4(age)
plot(PCA$x[,1], PCA$x[,4], pch=".",xlab="PC1", ylab="PC4", main="Pottery - PC1 .vs. PC4")
labels= factor(age)
text(PCA$x[,1], PCA$x[,4], labels, cex=0.7)
abline(h=0, v=0, lty=3, col="red")

#byplot of pc1 and pc5(gender)
plot(PCA$x[,1], PCA$x[,5], pch=".",xlab="PC1", ylab="PC5", main="Pottery - PC1 .vs. PC5")
labels= factor(gender)
text(PCA$x[,1], PCA$x[,5], labels, cex=0.7)
abline(h=0, v=0, lty=2, col="red")

#bylot of pc1 and pc5(age)
plot(PCA$x[,1], PCA$x[,5], pch=".",xlab="PC1", ylab="PC5", main="Pottery - PC1 .vs. PC5")
labels= factor(age)
text(PCA$x[,1], PCA$x[,5], labels, cex=0.7)
abline(h=0, v=0, lty=3, col="red")

# cluster analysis
mydata = na.omit(u.burials)
mydata = scale(u.burials)
wss <- (nrow(u.burials)-1)*sum(apply(u.burials,2,var))
for (i in 1:17)
  wss[i] <- sum(kmeans(mydata, centers=i)$withinss)
plot(1:17, wss, type="b", xlab="Number of Clusters", ylab="Within groups sum of squares")

# K-Means Cluster Analysis
fit <- kmeans(mydata, 5)
aggregate(mydata,by=list(fit$cluster),FUN=mean)
# append cluster assignment
mydata <- data.frame(mydata, fit$cluster)

# Ward Hierarchical Clustering
d <- dist(mydata, method = "euclidean")
fit <- hclust(d, method="ward")
plot(fit) # display dendogram
groups <- cutree(fit, k=5) # cut tree into 5 clusters
rect.hclust(fit, k=5, border="red")


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


fisheryatesshuffle <- function(n)
{
  pool <- seq_len(n)
  a <- c()
  while(length(pool) > 0)
  {
     k <- sample.int(length(pool), 1)
     a <- c(a, pool[k])
     pool <- pool[-k]
  }
  a
}


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


 ZGEQP3 Example Program Results

 Tolerance used to estimate the rank of A
      1.00E-02
 Estimated rank of A
        3

 Least squares solution(s)
                    1                 2
 1  ( 0.0000, 0.0000) ( 0.0000, 0.0000)
 2  ( 2.7020, 8.0911) (-2.2682,-2.9884)
 3  ( 2.8888, 2.5012) ( 0.9779, 1.3565)
 4  ( 2.7100, 0.4791) (-1.3734, 0.2212)

 Square root(s) of the residual sum(s) of squares
      2.51E-01   8.10E-02


#' Using ggplot2 to plot matrix of correlations
#'
#' Lightly modified from
#' \href{https://groups.google.com/forum/#!searchin/ggplot2/ggcorplot/ggplot2/odaZVAyKvE4/lsFIE86pUVoJ}{a
#' post by Mike Lawrence}.
#'
#' \code{ggcorplot} takes a data frame or matrix, strips numeric variables, and
#' makes a "splom" style correlation plot, with significance values. Useful for
#' exploratory data analysis.
#'
#' @param data Data frame or matrix to be plotted.
#' @param var_text_size Variable text size.
#'
#' @keywords plotting
#' @export
#' @examples
#' ## using iris data
#' ggcorplot(iris)
#'
#' @seealso \code{\link[ggplot2]{qplot}}
ggcorplot <- function(data,
                      var_text_size = 5) {

  # munge data ----------------------------

  # drop non-numeric columns
  nums <- sapply(data, is.numeric)
  data <- data[,nums]

  # reshape
  data <- as.data.frame(scale(data)) # scale

  # obtain new data frame
  # this should be easy to make functional (but I haven't figured it out)
  z <- data.frame()
  i <- 1
  j <- i
  while (i <= length(data)) {
    if (j > length(data)) {
      i <- i + 1
      j <- i
    } else {
      x <- data[,i]
      y <- data[,j]
      temp <- as.data.frame(cbind(x, y))
      temp <- cbind(temp, names(data)[i], names(data)[j])
      z <- rbind(z, temp)
      j <- j + 1
    }
  }

  names(z) <- c("x", "y", "x_lab", "y_lab")
  z$x_lab <- ezLev(factor(z$x_lab), names(data))
  z$y_lab <- ezLev(factor(z$y_lab), names(data))
  z <- z[z$x_lab != z$y_lab,]

  # obtain correlation values
  z_cor <- data.frame()
  i <- 1
  j <- i
  while (i <= length(data)) {
    if (j > length(data)) {
      i <- i + 1
      j <- i
    } else {
      x <- data[,i]
      y <- data[,j]
      x_mid <- min(x) + diff(range(x)) / 2
      y_mid <- min(y) + diff(range(y)) / 2
      this_cor <- stats::cor(x,y)
      this_cor.test <- 0
      this_cor.test <- stats::cor.test(x, y)
      this_col <- ifelse(this_cor.test$p.value < .05, "<.05", ">.05")
      this_size <- (this_cor) ^ 2
      cor_text <- ifelse(this_cor > 0,
                         substr(format(c(this_cor, .123456789),
                                       digits = 2)[1], 2, 4),
                         paste("-", substr(format(c(this_cor, .123456789),
                                                  digits = 2)[1], 3, 5),
                               sep = "")
      )
      b <- as.data.frame(cor_text)
      b <- cbind(b, x_mid, y_mid, this_col, this_size, names(data)[j],
                 names(data)[i])
      z_cor <- rbind(z_cor, b)
      j <- j + 1
    }
  }
  names(z_cor) <- c("cor", "x_mid", "y_mid", "p", "rsq", "x_lab", "y_lab")
  z_cor$x_lab <- ezLev(factor(z_cor$x_lab), names(data))
  z_cor$y_lab <- ezLev(factor(z_cor$y_lab), names(data))
  diag <- z_cor[z_cor$x_lab == z_cor$y_lab,]
  z_cor <- z_cor[z_cor$x_lab != z_cor$y_lab,]

  # ggplot 2 layers ----------------------------
  # used to be jitter, but this obscures data structure if used naively
  points_layer <- ggplot2::geom_point(mapping = ggplot2::aes(x = x, y = y),
                                      data = z)

  lm_line_layer <- ggplot2::geom_smooth(mapping = ggplot2::aes(x = x, y = y),
                                        data = z,
                                        stat = "smooth",
                                        method = "lm",
                                        colour = "red")

  lm_ribbon_layer <- ggplot2::geom_ribbon(mapping = ggplot2::aes(x = x, y = y),
                                          data = z,
                                          stat = "smooth",
                                          method = "lm",
                                          fill = "green",
                                          alpha = .5)

  cor_text <- ggplot2::geom_text(mapping = ggplot2::aes_string(x = "y_mid",
                                                               y = "x_mid",
                                                               label = "cor",
                                                               size = "rsq",
                                                               colour = "p"),
                                 data = z_cor)

  var_text <- ggplot2::geom_text(mapping = ggplot2::aes_string(x = "y_mid",
                                                               y = "x_mid",
                                                               label = "x_lab"),
                                 data = diag,
                                 size = var_text_size)

  ggplot2::ggplot() +
    points_layer +
    lm_ribbon_layer + lm_line_layer +
    var_text + cor_text +
    ggplot2::facet_grid(y_lab ~ x_lab, scales = "free") +
    ggplot2::theme_bw() +
    ggplot2::theme(panel.grid.minor = ggplot2::element_blank(),
                   panel.grid.major = ggplot2::element_blank(),
                   axis.ticks = ggplot2::element_blank(),
                   axis.text.y = ggplot2::element_blank(),
                   axis.text.x = ggplot2::element_blank(),
                   axis.title.y = ggplot2::element_blank(),
                   axis.title.x = ggplot2::element_blank(),
                   legend.position = "none") +
    ggplot2::scale_size(limits = c(0, 1))
}

#' Helper function for levels, from the ez package
#'
#' @param x factor
#' @param new_order The order you want them in
#'
#' @keywords factors
#' @export
#' @examples
#' x <- factor(c("A", "B", "C"))
#' ezLev(x, c(3,1,2))
ezLev <- function(x, new_order){
  for (i in rev(new_order)) {
    x <- stats::relevel(x, ref = i)
  }
  return(x)
}


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


# File:   Histograms.R
# Course: R: An Introduction (with RStudio)

# LOAD PACKAGES ############################################

library(datasets)

# In a histogram we look for if that data i.e. is it symmetrical or skewed, bi-modal, uni-model etc.
# We also look for gaps or big empty spaces in distribution. Also for outliers.
# We also look for symmetry whether we have same number of high or low scores, or we need
# to do some sort of scaling to the distribution.

# LOAD DATA ################################################
?iris
head(iris)

# Basic Histograms
hist(iris$Sepal.Length)
hist(iris$Sepal.Width)
hist(iris$Petal.Length)
hist(iris$Petal.Width)

# HISTOGRAM BY GROUP #######################################

# Put graphs in 3 rows and 1 column
par(mfrow = c(3, 1))

# Histograms for each species using options
hist(iris$Petal.Width [iris$Species == "setosa"],
	 xlim = c(0, 3),
	 breaks = 9,
	 main = "Petal Width for Setosa",
	 xlab = "",
	 col = "red")

hist(iris$Petal.Width [iris$Species == "versicolor"],
	 xlim = c(0, 3),
	 breaks = 9,
	 main = "Petal Width for Versicolor",
	 xlab = "",
	 col = "purple")

hist(iris$Petal.Width [iris$Species == "virginica"],
	 xlim = c(0, 3),
	 breaks = 9,
	 main = "Petal Width for Virginica",
	 xlab = "",
	 col = "blue")

# Restore graphic parameter
par(mfrow=c(1, 1))

# CLEAN UP #################################################

# Clear packages
detach("package:datasets", unload = TRUE)  # For base

# Clear plots
dev.off()  # But only if there IS a plot

# Clear console
cat("\014")  # ctrl+L

# Clear mind :)


# This file contains the r code to create the example graphs in the seminararbeit

poisson_lambda <- function(k) {
  lambda = 80
  #erwartete Ereignishaeufigkeit in Zeitraum (zum Beispiel ein Jahr)
  (lambda^k/factorial(k))*exp(1)^(-lambda)
}
#((poisson_lambda(170)))/log(exp(1))

poisson_illustration <- data.frame(counted_token=1:165, probability=mapply(poisson_lambda,1:165))
library(ggplot2)
ggplot(poisson_illustration, aes(x=counted_token, y=probability )) +
  geom_point (size=1) +
  geom_line(aes(x=80), colour='red') +
  xlab("Frequence of token 'Flugzeug'") +
  ggtitle("Poisson illustration for example word 'Flugzeug' on 25.03.2015" ) +
  theme(plot.title = element_text(lineheight=.8, face="bold"))

poisson_lambda_log <- function(k) {
  #erwartete Ereignishaeufigkeit in Zeitraum (zum Beispiel ein Jahr)
  lambda <- 80
  -log((lambda^k/factorial(k))*exp(1)^(-lambda))
}
poisson_illustration2 <- data.frame(counted_token=1:165, log_probability=mapply(poisson_lambda_log,1:165))
library(ggplot2)
ggplot(poisson_illustration2, aes(x=counted_token, y=log_probability )) +
  geom_point (size=1) +
  geom_line(aes(x=80), colour='red') +
  xlab("Frequence of token 'Flugzeug'") +
  ylab("= log(poisson measure)") +
  ggtitle("-log poisson illustration for example word 'Flugzeug' on 25.03.2015" ) +
  theme(plot.title = element_text(lineheight=.8, face="bold"))

poisson_lambda_measure <- function(k) {
  #erwartete Ereignishaeufigkeit in Zeitraum (zum Beispiel ein Jahr)
  lambda <- 80
  (k*(log(k)-log(lambda)-1))/log(2220601)
  #-log((lambda^k/factorial(k))*exp(1)^(-lambda))
}
poisson_illustration2 <- data.frame(counted_token=1:500, log_probability=mapply(poisson_lambda_measure,1:500))
library(ggplot2)
ggplot(poisson_illustration2, aes(x=counted_token, y=log_probability )) +
  geom_point (size=0.5) +
  geom_line(aes(x=80), colour='red') +
  geom_line(aes(y=0), colour='red') +
  xlab("Frequence of token 'Flugzeug'") +
  ylab("Poisson measure") +
  ggtitle("Poisson measure illustration for example word 'Flugzeug' on 25.03.2015" ) +
  theme(plot.title = element_text(lineheight=.8, face="bold"))

# Im Jahr 568 000 000 Wörter
# Flugzeug 2014 20366
# 25.3.2015
# daily words  2 220 601
# freq "Flugzeug" 535 w_id=1491
relative_example <- function(freq) {
  (freq/2220601)/(20366/568000000)
}
relfreq_illustration <- data.frame(counted_token=1:165, relative_freq=mapply(relative_example,1:165))
ggplot(relfreq_illustration, aes(x=counted_token, y=relative_freq )) +
  geom_point (size=1) +
  geom_line(aes(y=1), colour='red') +
  geom_line(aes(x=80), colour='red') +
  xlab("Frequence of token 'Flugzeug'") +
  ylab("Relative frequency") +
  ggtitle("Relative frequency illustration for example word 'Flugzeug' on 25.03.2015" ) +
  theme(plot.title = element_text(lineheight=.8, face="bold"))

#TFIDF Illustration
max freq am Tag 58873
Gemessene Tage im Jahr
Flugzeug Dokumente
w_id 2014 7543
relative document frequency 0.997238
example_tf_idf100 <- function(k) {(k/60000)*log(1/1)}
example_tf_idf10 <- function(k) {(k/60000)*log(1/0.1)}
example_tf_idf1 <- function(k) {(k/60000)*log(1/0.01)}
example_tf_idf01 <- function(k) {(k/60000)*log(1/0.001)}
example_tf_idfmax <- function(k) {(k/60000)*log(365/1)}
example_tf_idf(500)
tfidf_illustration <- data.frame(counted_token=1:165,
                                 measure100=mapply(example_tf_idf100,1:165),
                                 measure10=mapply(example_tf_idf10,1:165),
                                 measure1=mapply(example_tf_idf1,1:165),
                                 measure01=mapply(example_tf_idf01,1:165),
                                 measuremax=mapply(example_tf_idfmax,1:165)
                                 )
ggplot(tfidf_illustration, aes(x=counted_token, y=measure100)) +
  geom_line (colour='red') +
  geom_line(aes(y=measure10), colour='yellow') +
  geom_line(aes(y=measure1), colour='orange') +
  geom_line(aes(y=measure01), colour='green') +
  geom_line(aes(y=measuremax), colour='grey') +
  xlab("Frequence of fictive example token") +
  ylab("tf-idf measure") +
  ggtitle("TF-IDF illustration for fictive example word (tf:100%, 10%, 1%, 2,7%, 0.1%)") +
  theme(plot.title = element_text(lineheight=.8, face="bold"))

log(365/133)
1/365
1/(365/133)
poisson_mass <- function(k, lambda) {
  (k*(log(k)-log(lambda)-1))#/log(100000)
}
poisson_mass(170,10)
exp(1)
factorial(10)
log(exp(1))
log(exp(-100))
??data.frame
w_id <- c(1,2,3,4)
tv <- c(6,5,5,5)
tvtcwr <- c(1,1,1,1)
tvtcwr_new <- c(2,3,2,3)
testdata <- data.frame(w_id=w_id, test_value=tv, test_value_to_change_with_r=tvtcwr)
testdata <- data.frame(w_id=w_id, test_value_to_change_with_r=tvtcwr_new)


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


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

rm(list = ls())

CummulativeFunction <- function(x) {
  ifelse(x < 0,
    0,
  ifelse(1 < x,
    1,
  (x ^ 2) * (3 - 2 * x)))
}

observed <- c(95, 80, 40, 52, 60, 80, 82, 58, 65, 50)

test <- ks.test(observed, CummulativeFunction)

(pvalue <- test$p.value)
# 4.1223072733132e-09


# install.packages("corrplot")
# install.packages("JWileymisc")

setwd("/home/alf/alf_github/matrixcorr_questio")

library(XLConnect)
library(MASS)
library(corrplot)
library(Hmisc)
library(xtable)
#library(JWileymisc)
library(sjPlot)

#########################################################################################################
# x is a matrix containing the data
# method : correlation method. "pearson"" or "spearman"" is supported
# removeTriangle : remove upper or lower triangle
# results :  if "html" or "latex"
  # the results will be displayed in html or latex format

corstars <-function(x, method=c("pearson", "spearman"), removeTriangle=c("upper", "lower"),
                     result=c("none", "html", "latex")){
    #Compute correlation matrix
    require(Hmisc)
    x <- as.matrix(x)
    correlation_matrix<-rcorr(x, type=method[1])
    R <- correlation_matrix$r # Matrix of correlation coeficients
    p <- correlation_matrix$P # Matrix of p-value

    ## Define notions for significance levels; spacing is important.
    mystars <- ifelse(p < .0001, "****", ifelse(p < .001, "*** ", ifelse(p < .01, "**  ", ifelse(p < .05, "*   ", "    "))))

    ## trunctuate the correlation matrix to two decimal
    R <- format(round(cbind(rep(-1.11, ncol(x)), R), 2))[,-1]

    ## build a new matrix that includes the correlations with their apropriate stars
    Rnew <- matrix(paste(R, mystars, sep=""), ncol=ncol(x))
    diag(Rnew) <- paste(diag(R), " ", sep="")
    rownames(Rnew) <- colnames(x)
    colnames(Rnew) <- paste(colnames(x), "", sep="")

    ## remove upper triangle of correlation matrix
    if(removeTriangle[1]=="upper"){
      Rnew <- as.matrix(Rnew)
      Rnew[upper.tri(Rnew, diag = TRUE)] <- ""
      Rnew <- as.data.frame(Rnew)
    }

    ## remove lower triangle of correlation matrix
    else if(removeTriangle[1]=="lower"){
      Rnew <- as.matrix(Rnew)
      Rnew[lower.tri(Rnew, diag = TRUE)] <- ""
      Rnew <- as.data.frame(Rnew)
    }

    ## remove last column and return the correlation matrix
    Rnew <- cbind(Rnew[1:length(Rnew)-1])
    if (result[1]=="none") return(Rnew)
    else{
      if(result[1]=="html") print(xtable(Rnew), type="html")
      else print(xtable(Rnew), type="latex")
    }
}
#########################################################################################################

#wb = loadWorkbook("mat_zab.xlsx")
#df = readWorksheet(wb, sheet = "Foglio1")
#mat_zab$Score_VG_TXT=NULL
#mat_zab$ID=NULL
#saveRDS(mat_zab,"mat_zab.rds")
#########################################################################################################

mat_zab=readRDS("mat_zab.rds")
mat_zab$Q44bis=ifelse(mat_zab$Q44>1,0,mat_zab$Q44)
NA_risk_obj=which(is.na(mat_zab$RISCHIO.OGGETTIVO))
nozero_NA_Q11=which(mat_zab$Q11>0)

esp_mat_zab=mat_zab[nozero_NA_Q11,c(2:10,12:length(names(mat_zab)))]
esp_mat_zab$Q44=NULL
noesp_mat_zab=mat_zab[,2:11]

###########################################################################################################àààà

corstars(noesp_mat_zab,"spearman","upper","none")
corstars(noesp_mat_zab,"pearson","upper","none")
capture.output(corstars(noesp_mat_zab,"spearman","upper","latex"), file = "matcorr_noesp.tex")
capture.output(corstars(noesp_mat_zab,"spearman","upper","html"), file = "matcorr_noesp.html")

corstars(esp_mat_zab,"spearman","upper","none")
corstars(esp_mat_zab,"pearson","upper","none")
capture.output(corstars(esp_mat_zab,"spearman","upper","latex"), file = "matcorr_esp.tex")
capture.output(corstars(esp_mat_zab,"spearman","upper","html"), file = "matcorr_esp.html")

###########################################################################################################àààà

# modello totale

tot=glm(SCORE_VG~.,data=noesp_mat_zab)
summary(tot)
sjt.glm(tot,show.aic = TRUE, show.family = TRUE, show.r2 = TRUE,file="tot_noesp.html")
capture.output(xtable(tot), file = "tot_model_noexp.tex")

# modello anagrafico

anagrafico=glm(SCORE_VG~Q1+Q2+Q3,data=noesp_mat_zab)
summary(anagrafico)
sjt.glm(anagrafico,show.aic = TRUE, show.family = TRUE, show.r2 = TRUE,file="anagrafico_noesp.html")
capture.output(xtable(anagrafico), file = "anagrafico_model_noexp.tex")

casa=glm(SCORE_VG~Q6+Q7+Q8N+Q9N+Q10,data=noesp_mat_zab)
summary(casa)
sjt.glm(casa,show.aic = TRUE, show.family = TRUE, show.r2 = TRUE,file="casa_noesp.html")
capture.output(xtable(casa), file = "casa_model_noexp.tex")

esperienza=glm(SCORE_VG~Q44bis+Q13N+Q14A+Q15N,data=esp_mat_zab)
summary(esperienza)
sjt.glm(esperienza,show.aic = TRUE, show.family = TRUE, show.r2 = TRUE,file="esperienza_noesp.html")
capture.output(xtable(esperienza), file = "esperienza_model_noexp.tex")

######################################################################################################
# [1] http://www.sthda.com/english/wiki/elegant-correlation-table-using-xtable-r-package


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)


# --- Part Two ---
# The Elves in accounting are thankful for your help; one of them even offers
# you a starfish coin they had left over from a past vacation. They offer you a
# second one if you can find three numbers in your expense report that meet the
# same criteria.
#
# Using the above example again, the three entries that sum to 2020 are 979,
# 366, and 675. Multiplying them together produces the answer, 241861950.
#
# In your expense report, what is the product of the three entries that sum to
# 2020?

x <- scan("input.txt", 0)
for (i in seq(along = x)) {
  for (j in seq(from = i + 1, to = length(x))) {
    k <- which(x[i] + x[j] + x == 2020)
    if (length(k) > 0) {
      print(x[i] * x[j] * x[k])
      quit()
    }
  }
}


#!/usr/bin/env Rscript
args <- commandArgs(trailingOnly = TRUE)

library(rminer)
results <- read.csv(file=args[1],head=TRUE,sep=",")
x=results$Pactual
y=results$Ppredicted

cat("Correlation =", mmetric(y,x,"COR"), "\n")
cat("R^2 =", mmetric(y,x,"R2"), "\n")
cat("MAE =", mmetric(y,x,"MAE"), "\n")
cat("RMSE =", mmetric(y,x,"RMSE"), "\n")
cat("RAE =", mmetric(y,x,"RAE"), "\n")
cat("MAPE =",mmetric(y,x,"MAPE"), "\n")


# Weights Function - generates random weight vector with weights that sum to 1

wts<-function(nC,runs)
{
  nJ = length(tw)

  ## constraints for weight restrictions
  # w > 0
  lower.w = rep(0,nJ)

  At = matrix(0,nrow=nJ,ncol=nJ)
  diag(At) = 1
  A = rbind(-At)

  d = rep("<=", nJ)
  userConstr = list(constr=A, rhs=-lower.w, dir=d)

  # ordinal
  if(nC>0){
    c1 = ordinalConstraint(nJ, 2, 1)
    for(j2 in 3:nJ){
      c2 = ordinalConstraint(nJ, j2, 1)
      c1 = mergeConstraints(c1,c2)
    }

    if(nC>1){
      for(j1 in 2:nC){
        for(j2 in (j1+1):nJ){
          c2 = ordinalConstraint(nJ, j2, j1)
          c1 = mergeConstraints(c1,c2)
        }
      }
    }

    c1 = eliminateRedundant(c1)

    userConstr = mergeConstraints(userConstr,c1)

  }

  transform = simplex.createTransform(nJ)
  constr = simplex.createConstraints(transform, userConstr)
  seedPoint = createSeedPoint(constr, homogeneous=TRUE)
  samples = har(seedPoint, constr, N=runs*thin.f, thin=thin.f, homogeneous=TRUE, transform=transform)$samples
  return(samples)
}

# weights standardized to sum to 1
wts2<-function(num){
  q=runif(num+1,0,1)
  q[1]=0
  q[num+1]=1
  q=sort(q)
  w=rep(0,num)
  for (i in 1:num){	w[i]=q[i+1]-q[i] }
  w
}


library(tidyverse)

d = read_csv('../02_data/data_raw.csv') %>%
  # fix typo in column head
  rename(situation_number = sitation_number) %>%
  # remove incomplete answer
  filter(response != "some|some|")

## semantics of expressions ----

evaluate_quantifier = function(quantifier, bool_vector) {
  case_when(
    quantifier == "all"  ~ sum(bool_vector) == length(bool_vector),
    quantifier == "some" ~ sum(bool_vector) >= 1,
    quantifier == "many" ~ sum(bool_vector) > 0.3 * length(bool_vector),
    quantifier == "most" ~ sum(bool_vector) > 0.5 * length(bool_vector),
    quantifier == "none" ~ sum(bool_vector) == 0,
    quantifier == "few"  ~ sum(bool_vector) <= 0.3 * length(bool_vector)
  )
}

evaluate_predicate = function(resp, stimulus){
  if (resp[3] == "wrong") {
    return(1 - stimulus)
  }
  else {
    return(stimulus)
  }
}

evaluate_truth = function(resp, stimulus) {
  resp = resp %>% str_split("\\|", simplify = F) %>% unlist()
  stimulus = evaluate_predicate(resp, stimulus)
  stimulus = map_dbl(
    1:nrow(stimulus),
    function(i) {
      evaluate_quantifier(resp[2], stimulus[i,])
    }
  )
  evaluate_quantifier(resp[1], stimulus)
}

# calculate the probability that a single quantifier
# statement is true for a given bias and number of observations
calculate_probability_quantifier = function(quantifier, bias, n_observations) {
  case_when(
    quantifier == "all"  ~ dbinom(x= n_observations, size = n_observations, prob = bias) %>% sum,
    quantifier == "some" ~ dbinom(x= 1:n_observations, size = n_observations, prob = bias) %>% sum,
    quantifier == "many" ~ dbinom(x= ceiling(0.3*n_observations):n_observations, size = n_observations, prob = bias) %>% sum,
    quantifier == "most" ~ dbinom(x= ceiling(0.5*n_observations):n_observations, size = n_observations, prob = bias) %>% sum,
    quantifier == "none" ~ dbinom(x= 0, size = n_observations, prob = bias) %>% sum,
    quantifier == "few"  ~ dbinom(x= 0:ceiling(0.3*n_observations), size = n_observations, prob = bias) %>% sum
  )
}

# calculate the probability P(sentence|H) analytically
# for a given bias (=hypothesis)
calculate_probability = function(resp, bias) {
  #unpack sentence
  resp = resp %>% str_split("\\|", simplify = F) %>% unlist()
  # reverse success probability if predicate is "wrong"
  bias = ifelse(resp[3] == "wrong", 1-bias, bias)
  # get probability of inner quantifier being true or a single itm
  inner_prob = calculate_probability_quantifier(resp[2], bias, 12)
  # get probability of outer quantifier statement
  calculate_probability_quantifier(resp[1], inner_prob, 5)
}

calculate_probability("all|all|right", 0.8)
calculate_probability("some|all|right", 0.8)

get_truth_value = function(example_index) {

  resp     = d$response[example_index]
  stimulus = d$stimulus[example_index] %>% str_split("\\|", simplify = F) %>% unlist()

  if (length(stimulus) <= d$column_number[example_index]) {
    return(NA)
  }
  else {
    stimulus = stimulus %>% as.numeric() %>% matrix(byrow = T, ncol = d$column_number[example_index])
    stimulus = 1 - stimulus
  }

  evaluate_truth(resp, stimulus)

}

truth = map_lgl(1:nrow(d), function(i){
  get_truth_value(i)
})

d$truth = truth

counts =  d %>%
  filter(truth == TRUE) %>%
  group_by(condition, response) %>%
  tally() %>%
  pivot_wider(
    names_from = condition,
    values_from = n
  )

counts %>% arrange(- high) %>% head()
counts %>% arrange(- low) %>% head()

d %>% group_by(situation_number, condition) %>%
  summarise(
    mean_true = mean(truth, na.rm = T)
  ) %>% show()

d %>% group_by(condition) %>%
  summarise(
    mean_true = mean(truth, na.rm = T)
  ) %>% show()

# calculate argumentative strength for a given bias
get_argument_strength = function(bias) {
  out = expand_grid(
    outer = c("all", "some", "most", "none", "many", "few"),
    inner = c("all", "some", "most", "none", "many", "few"),
    predicate = c("right", "wrong"),
    bias = bias
  ) %>%
    group_by(outer, inner, predicate) %>%
    mutate(
      sentence = paste0(outer, "|", inner, "|", predicate),
      bias = bias,
      probability = calculate_probability(sentence, bias)
    )
  out
}

# get_argument_strength(0.8)

arg_strength = rbind(get_argument_strength(0.2), get_argument_strength(0.8)) %>%
  pivot_wider(
    names_from = bias,
    names_prefix = "bias_",
    values_from = probability
  ) %>%
  mutate(
    arg_str = log(bias_0.8) - log(bias_0.2)
  ) %>%
  ungroup() %>%
  select(sentence, arg_str, bias_0.2, bias_0.8) %>%
  rename(response = sentence)

plot_data = counts %>% ungroup() %>%
  pivot_longer(
    -response,
    names_to = "condition",
    values_to = "count"
  ) %>%
  full_join(arg_strength) %>%
  mutate(
    arg_str = ifelse(condition == "high", arg_str, -arg_str)
  )

plot_data %>%
  filter(count > 5 ) %>%
  ggplot(aes(y = count, x = (arg_str), color = condition)) +
  geom_point() +
  geom_smooth(method = "lm") +
  ggrepel::geom_text_repel(aes(label = response))

max_count = max(plot_data$count,na.rm = T)
min_count_to_show = 0
plot_data_high = filter(plot_data, condition == "high", count >= min_count_to_show)
plot_data_low = filter(plot_data, condition == "low", count >= min_count_to_show) %>%
  mutate(count = - count)

plot_data %>%
  # filter(count > 0) %>%
  ggplot(
    mapping = aes(
      x = fct_reorder(response, arg_str),
      y = count,
      group = condition,
      fill = condition
    )
  ) +
  geom_col(data = plot_data_low, fill = "darkorange") +
  geom_col(data = plot_data_high, fill = "darkgreen") +
  coord_flip() +
  ylim(c(-max_count, max_count)) +
  labs(
    x = ""
  )

# ---- get a semantics table ----

sentences <- expand.grid(
  outer = c("all", "some", "most", "none"),
  inner = c("all", "some", "most", "none"),
  predicate = c("wrong", "right")
) %>%
  mutate(
    compact = str_c(outer, "|", inner, "|", predicate)
  ) %>% pull(compact)

situations <- d %>%
  select(situation_number, stimulus) %>%
  unique %>%
  arrange(situation_number)

get_truth_value_2 = Vectorize(function(sentence, stimulus) {
  resp     = sentence
  stimulus = stimulus %>% str_split("\\|", simplify = F) %>% unlist()
  stimulus = stimulus %>% as.numeric() %>% matrix(byrow = T, ncol = 12)
  # stimulus = 1 - stimulus
  evaluate_truth(resp, stimulus)
})

combined <-
  expand.grid(
    situation_number = 1:20,
    sentence = sentences
  ) %>%
  full_join(situations, by = "situation_number") %>%
  as_tibble() %>%
  mutate(
    truth_value = get_truth_value_2(sentence, stimulus)
  )


F=5.96 # computed from 9.3
alpha=0.05
MSError=.0153
F_value=qf(1-alpha,df1=4,df2 = 25)
# as the F >F_value
print(" we reject H0 and conclude that at least one of the population means differs from the rest")
t.alpha=qt(1-alpha/2,df=25)
LSD=t.alpha*(sqrt((2*MSError)/6))
print(LSD)


coef(lm(y ~ poly(x, 2, raw=T)))


library(fpp2)
library(forecast)
library(expsmooth)
library(ggplot2)
library(seasonal)
library(prophet)
library(dplyr)
#source("R.utils")

setwd("~/Comcast/EBI Analytics - Finance Exec Flex - Documents/2020 Projects/Projects/04_29_20 HSD Usage (Loyack)")
#write.csv(elecequip,file = "elecequip.csv",row.names = FALSE)

df = read.csv("hsd_usage_rosetta_total.csv")[,1]

#length_test_set = 16
#length_test_set_real = 4
h = 12

#data = ts(df[1:(length(df)-length_test_set_real)],start = c(2018,1),frequency = h)
data = ts(df[1:26],start = c(2018,1),frequency = h)
#train_data = ts(df[1:22],start = c(2018,1), frequency = h)
data
#throwing a bunch of forecasts
autoplot(data) +
  #autolayer(meanf(train_data, h=h),
  #          series = "Mean", PI=FALSE) +
  autolayer(naive(data, h=5),
            series = "Naive", PI=FALSE) +
  autolayer(snaive(data, h=5),
            series = "Seasonal naive", PI=FALSE) +
  autolayer(forecast(data, h=5),
            series = "Forecast", PI=FALSE) +
  autolayer(rwf(data, h=5, drift=TRUE),
            series = "Random", PI=FALSE) +
  autolayer(forecast(auto.arima(data, seasonal=TRUE), h=5),
            series = "SARIMA", PI=FALSE) +
  guides(colour=guide_legend(title='Forecast'))

#sarima
sarima_model <- forecast(auto.arima(data, seasonal=TRUE), h=5)
summary(sarima_model)
autoplot(sarima_model)
autoplot(data)
accuracy(sarima_model, data)
rs <- residuals(sarima_model)
checkresiduals(rs)

write.csv(summary(sarima_model),file = "elecequip.csv",row.names = FALSE)

#prophet (Facebook)
df_prophet = read.csv("video_connects_prophet.csv")
df_prophet <- dplyr::slice(df_prophet,1:94)
m <- prophet(df_prophet,seasonality.mode = 'multiplicative')
future <- make_future_dataframe(m, periods = 12, freq = 'month')
fcst <- predict(m, future)
plot(m, fcst)
tail(fcst)

data_real= ts(df,start = c(2011,1),frequency = h)
train_data_real = ts(df[1:(length(df)-length_test_set_real)],start = c(2011,1), frequency = h)

############################################# EXPLORATION
autoplot(train_data_real) +
  ggtitle("Video Connects") +
  xlab("Year") + ylab("New Connects")
# non-linear trend, cycles, clear seasonality

ggseasonplot(train_data_real, year.labels=TRUE, year.labels.left=TRUE) + ylab("New Connects") +
  ggtitle("Seasonal plot: video connects")

ggseasonplot(train_data_real, polar=TRUE) + ylab("New Connects") +
  ggtitle("Polar seasonal plot: video connects")

ggsubseriesplot(train_data_real)  + ylab("New Connects") +
  ggtitle("Seasonal subseries plot: video connects")

ggAcf(train_data_real)

pacf(train_data_real)

# Decomposition
fit = stl(train_data_real,t.window=13, s.window="periodic", robust=TRUE)
autoplot(fit)

#sarima
sarima_model <- forecast(auto.arima(train_data_real, seasonal=TRUE), h=4)
summary(sarima_model)
autoplot(sarima_model)
autoplot(data_real)
accuracy(sarima_model, data_real)
rs <- residuals(sarima_model)
checkresiduals(rs)

autoplot(data_real) +
  autolayer(forecast(auto.arima(train_data_real, seasonal=TRUE), h=4),
            series = "SARIMA", PI=FALSE) +
  guides(colour=guide_legend(title='Forecast'))


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


# install package by  writing install.packages("DunnettTests") command in console
# install package by writing install.packages(mvtnorm") command in console
library(DunnettTests)
library(mvtnorm)
alpha=0.05
k=4
v=25
n=6

 cvSUDT(k=4,alpha=0.05,alternative="U",df = 25,corr = .5)
 # max value of critical value is taken
critical_value=2.28 # approx
sw2=0.0153
# test statistic
D=critical_value*sqrt((2*sw2)/n)
print(D)
# conclusion
yi=c(1.293,1.328,1.415,1.500)
yc=1.175
i=1
while (i<5) {
  if((yi[i]-yc)<D){
    print("Not greater than control")
  }
  else{
    print("greater than control")
  }
  i=i+1
}


##Key points

   # Use intersect to find the overlap between two vectors.
   # To make boxplots where grouped variables are adjacaent, color the boxplot by a factor instead of faceting by that factor. This is a way to ease comparisons.
   # The data suggest that the income gap between rich and poor countries has narrowed, not expanded.

# load and inspect gapminder data
library(dslabs)
data(gapminder)
head(gapminder)

# Histogram of income in West versus developing world, 1970 and 2010
# add dollars per day variable and define past year
gapminder <- gapminder %>%
    mutate(dollars_per_day = gdp/population/365)
past_year <- 1970

# define Western countries
west <- c("Western Europe", "Northern Europe", "Southern Europe", "Northern America", "Australia and New Zealand")

# facet by West vs devloping
gapminder %>%
    filter(year == past_year & !is.na(gdp)) %>%
    mutate(group = ifelse(region %in% west, "West", "Developing")) %>%
    ggplot(aes(dollars_per_day)) +
    geom_histogram(binwidth = 1, color = "black") +
    scale_x_continuous(trans = "log2") +
    facet_grid(. ~ group)

# facet by West/developing and year
present_year <- 2010
gapminder %>%
    filter(year %in% c(past_year, present_year) & !is.na(gdp)) %>%
    mutate(group = ifelse(region %in% west, "West", "Developing")) %>%
    ggplot(aes(dollars_per_day)) +
    geom_histogram(binwidth = 1, color = "black") +
    scale_x_continuous(trans = "log2") +
    facet_grid(year ~ group)

# Income distribution of West versus developing world, only countries with data
# define countries that have data available in both years
country_list_1 <- gapminder %>%
    filter(year == past_year & !is.na(dollars_per_day)) %>% .$country
country_list_2 <- gapminder %>%
    filter(year == present_year & !is.na(dollars_per_day)) %>% .$country
country_list <- intersect(country_list_1, country_list_2)

# make histogram including only countries with data available in both years
gapminder %>%
    filter(year %in% c(past_year, present_year) & country %in% country_list) %>%    # keep only selected countries
    mutate(group = ifelse(region %in% west, "West", "Developing")) %>%
    ggplot(aes(dollars_per_day)) +
    geom_histogram(binwidth = 1, color = "black") +
    scale_x_continuous(trans = "log2") +
    facet_grid(year ~ group)
# Boxplots of income in West versus developing world, 1970 and 2010

p <- gapminder %>%
    filter(year %in% c(past_year, present_year) & country %in% country_list) %>%
    mutate(region = reorder(region, dollars_per_day, FUN = median)) %>%
    ggplot() +
    theme(axis.text.x = element_text(angle = 90, hjust = 1)) +
    xlab("") + scale_y_continuous(trans = "log2")
p + geom_boxplot(aes(region, dollars_per_day, fill = continent)) +
    facet_grid(year ~ .)

# arrange matching boxplots next to each other, colored by year
p + geom_boxplot(aes(region, dollars_per_day, fill = factor(year)))


install.packages("plotly")
library("plotly")

install.packages("shiny")
library("shiny")

?plotly
valX=c(10:14)
valY=c(14,52,98,23,68)
df=data.frame(valX,valY)

plot_ly(df,x=valX,y=valY,mode="lines")

#bubble chart
plot_ly(Orange,x=~age,y=~circumference,mode="markers",type = "scatter",marker=list(size=30,opacity=0.10))

#heat
heatmap(volcano)

#area chart
plot_ly(Orange,x=~age,y=~circumference,mode="markers",type = "scatter",fill="tozeroy")

#boxplot : boxplot is major of how well data is distributed in a dataset, it devide the dataset into 3 queartis
#         the graph represent min,max,mdian,1st quairties ,3rd quaritise in dataset. it is useful in comparing distribution of data across data set
#         for base graphinc boxplot() is used.
#1st atrr : vector (formula)
#2nd attr ; is data (dataf frame)
#3rd attr : noch (logical value) set TRUE if draw the nach
#varbuilr is logical value, it is set to true to draw build of the box proposenate to sample size
#names : are the grop lable which will be printed under each box plot
#main is used to set title.#

#mtcars adatset construct boxplot to show the relation between mpg and cyl

dfmtcars=data.frame(mtcars)

boxplot(mtcars$mpg~mtcars$cyl,mtcars,main="boxplot")

install.packages("tidyverse")
library("tidyverse")

install.packages("ggplot2")
library("ggplot2")

?ggplot2

ggplot(mtcars,aes(mpg,cyl,color="red"))+geom_point()+geom_smooth()

diamonds

#diamonds price between 2000 to 4000

ggplot(filter(diamonds,price<4000 & price>2000),aes(depth,price,colour=color))+geom_point()+geom_smooth()

ggplot(diamonds)+geom_point(aes(x=depth,y=price,colour=color))+geom_smooth(aes(x=carat,y=price,colour=color))

ggplot(diamonds,aes(x=carat,y=price))+geom_point(aes(colour=color))+geom_smooth()

ggplot(filter(diamonds,price<4000 & price>2000),aes(depth,price,colour=color))+geom_boxplot()

ggplot(filter(diamonds,price<4000 & price>2000),aes(depth,price,colour=color))+geom_area()

ggplot(filter(diamonds,price<4000 & price>2000),aes(price,colour=color))+geom_bar()

ggplot(filter(diamonds,price<4000 & price>2000),aes(price,colour=color))+geom_histogram()

#Explain Tidyverse and ggplot2


x <- 2
y <- 3
print(x+y)
install.packages("swirL")
install.packages("swirl")
install.packages("rafalib")
install.packages("downloader")
library(rafalib)
library(downloader)
getwd()
ls
setwd("~/repos/RLifeSciences")
savehistory("~/repos/RLifeSciences/worklog3.r")
ls
library(devtools)
install_github("genomicsclass/GSE5859Subset")
library(GSE5859Subset)
data(GSE5859Subset) # Loads the three tables
dim(geneExpression)
dim(SampleInfo)
dim(sampleInfo)
head(sampleInfo)
sampleInfo$group
match(sampleInfo$filename,colnames(geneExpression))
dim(geneAnnotation)
head(geneAnnotation)
head(match(geneAnnotation$PROBEID,rownames(geneExpression)))
2*(1-pnorm(Z))
read.csv("femaleControlsPopulation.csv"))
read.csv("femaleControlsPopulation.csv"))
read.csv("femaleControlsPopulation.csv"))
read.csv("femaleControlsPopulation.csv")
set.seed(1)
population = unlist(read.csv("femaleControlsPopulation.csv"))
N <- 12
B <- 10000
pvals <- replicate(B,{})
pvals <- replicate(B,{
control = sample(population,N)
treatment = sample(population,N)
t.test(treatment,control)$p.val
})
hist(pvals)
# Thousands of Tests
g <- sampleInfo$group
g
e <- geneExpression[25,]
library(rafalib)
mypar(1,2)
qqnorm(e[g==1])
qqline(e[g==1])
qqnorm(w[g==0])
qqnorm(e[g==0])
qqline(e[g==0])
t.test(e[g==1],e[g==0])$p.value
myttest <- function(x)
t.test(x[g==1],x[g==0],var.equal=TRUE)$p.value
pvals <- apply(geneExpression,1,myttest)
sum(pvals<0.05)
# performing 8000 ttest on data where the null hypothesis is true
set.seed(1)
m <- nrow(geneExpression)
n <- ncol(geneExpression)
randomData <- matrix(rnorm(n*m),m,n)
nullpvals <- aplly(randomData,1,mytest)
nullpvals <- apply(randomData,1,mytest)
nullpvals <- apply(randomData,1,myttest)
sum(nullpvals<0.05)
# More efficient ttest implementation
install_bioc("genefilter")
install_bioc("genefilter")
# Procedures
# response to Multiple Testing Problem
# Define a Procedure then estimate or Control an informative Error Rate
# Guarantee an error rate below a predefined value
# Procedures have flexibility through parameters and cutoffs that let us control specificity and sensitivity
# Error rates
sum(pvals<0.05)
set.seed(1)
population = unlist(read.csv("femaleControlPopulation.csv"))
population = unlist(read.csv("femaleControlsPopulation.csv"))
alpha <- 0.05
N <- 12
m <- 10000
pvals <- replicate(m,{
control = sample(population,N)
treatment = sample(population,N)
t.test(treatment,control)$p.value})
sum(pvals<0.05)
alpha <- 0.05
N <- 12
m <- 10000
p0 <- 0.90 #10% of diests work, 90% don't
m0 <- m*p0
m1 <- m-m0
nullHypothesis <- c(rep(TRUE,m0),rep(FALSE,m1))
delta  <- 3
set.seed(1)
calls <- sapply(1:m, function(i){
control <- sample(population,N)
treatment <- sample(population,N)
if(!nullHypothesis[i]) treatment <- treatment+ delta
ifelse(t.test(treatment,control)$p.value < alpha, "Called Significant", "Not Called Significant")})
null_hypothesis <- factor(nullHypothesis, levels=c("TRUE","FALSE"))
table(null_hypothesis,calls)
B <- 10 ##number of simulations
VandS <- replicate(B,{
calls <- sapply(1:m, function(i){
control <- sample(population,N)
treatment <- sample(population,N)
if(!nullHypothesis[i]) treatment <- treatment + delta
t.test(treatment,control)$p.val < alpha})
cat("V =",sum(nullHypothesis & calls), "S =",sum(!nullHypothesis & calls), "\n")
c(sum(nullHypothesis & calls), sum(!nullHypothesis & calls))
})
## this is used to motivate the Family Wise Error Rate
## Leading to
# The Bonferroni Correction
B <- 10000
minpval <- replicate(B,min(runif(10000,0,1))<0.01)
mean(minpval>=1)
set.seed(1)
pvals <- sapply(1:m,function(i){
control <- sample(population,N)
treatment <- sample(population,N)
if(!nullHypothesis[i]) treatment <- treatment + delta
t.test(treatment,control)$p.value})
sum(pvals < 0.05/10000)
# False Discovery Rate
savehistory("~/repos/RLifeSciences/worklog3.r")
head(population)
population <- unlist(read.csv("femaleControlsPopulation.csv"))
set.seed(1)
pvals <- sapply(1:m, function(i){
control  <- sample(population,6)
treatment <- sample(population,6)
if(!nullHypothesis[i]) treatment <- treatment + delta
t.test(treatment,control)$p.value
})
m <- 10000
N <- 12
p0 <- 0.90
m0 <- m*p0
m1 <- m-m0
delta <- 3
nullHypothesis <- c(rep(TRUE,m0), rep(FALSE,m1))
set.seed(1)
pvals <- sapply ( 1 : m , function ( i ){
control <- sample ( population , 6 )
treatment <- sample ( population , 6 )
if ( ! nullHypothesis [ i ]) treatment <- treatment + delta
t.test ( treatment , control ) $ p.value
})
sum(pvals < 0.05/10000)
library(genefilter) ##rowtests is here
library(rafalib)
install.packages(genefilter)
source("https://bioconductor.org/biocLite.R")
biocLite("genefilter")
library(genefilter)
set.seed(1)
## Define groups to be used with rowttests
g <- factor( c(rep(0,N),rep(1,N)) )
B <- 1000 # number of simulations
Qs <- replicate(B,{
## matrix with control data (rows are tests, columns are mice)
controls <- matrix(sample(population, N*m, replace=TRUE),nrow=m)
## matrix with control data (rows are tests, columns are mice)
treatments <- matrix(sample(population, N*m, replace=TRUE),nrow=m)
## add effect to 10% of them
treatments[which(!nullHypothesis),] <- treatments[which(!nullHypothesis),]+delta
## combine to form one matrix
dat <- cbind(controls,treatments)
calls <- rowttests(dat,g)$p.value < alpha
R=sum(calls)
Q=ifelse(R>0,sum(nullHypothesis & calls)/R,0)
return(Q)
})
savehistory("~/repos/RLifeSciences/worklog3.r")
library(rafalib)
mypar(1,1)
hist(Qs) ## Q is a random variable, this is its distribution
FDR=mean(Qs)
print(FDR)
set.seed(1)
savehistory("~/repos/RLifeSciences/worklog3.r")


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


 # levene.r
 x <- c(21.6,20.8,17.6,20.1,20.1,21.9,20.6,19.4,21.5,26.1)
 y <- c(20.6,20.4,20.2,20.2,18.0,19.8,20.9,19.7,20.3,19.7,22.7)
 mx <- mean(x); my <- mean(y)
 z1 <- abs(x-mx); z2 <- abs(y-my)
 mz1 <- mean(z1); mz2 <- mean(z2)
 sdz1 <- sd(z1); sdz2 <- sd(z2)
 sp <- sqrt( (9*sdz1^2+10*sdz2^2)/(10+11-2) )
 t0 <- (mz1-mz2)/(sp*sqrt(1/10+1/11))
 F0 <- t0^2
 1 - pf(F0, 1, 19)


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


#' f_init
#'
#' Construct an initial for $\beta$ by minimizing least square criteria
#'
#' @param v_y   vector of y
#' @param v_x   vector of x
#' @param m_sigma   $K_1K_2 \times K_1K_2 \Sigma$ diagonal block matix.
#' @param n1    $n \times K_1$ spline matrix for the first covariate,
#' @param v_k0  vector of internal knots for covariates
#' @param v_m   vector of orders for covariates
#' @param s     $K_1K_2 \times K_1K_2$ $S$ matrix
#'
#' @import mgcv
#'
#' @return an initial for $\beta$
#'
#' @examples
#' \dontrun{
#' devtools::load_all()
#' set.seed(202104)
#' k1 <- 4; k2 <- 4; m1 <- 4; m2 <- 4; n <- 400
#' v_x <- runif(n); v_y <- log(v_x); sigma <- 0.4 * (0.5 + v_x)
#' v_y <- v_y + rnorm(n, mean = rep(0, n), sd = sigma)
#' n1 <- f_n1(v_x, k1, m1)
#' m_sigma <- f_sigma(k1 + m1, k2 + m2
#' m_s <- f_mats(k1 + m1, k2 + m2, rep(10, 3))
#' f_init(v_y, v_x, m_sigma, n1, c(k1, k2), c(m1, m2), m_s)
#' }
#'
f_init <- function(v_y, v_x, m_sigma, n1, v_k0, v_m, s) {
    #Define dimensions
    k1 <- v_k0[2]; ktau <- v_k0[1]; m1 <- v_m[2]; mtau <- v_m[1]

    #1. Estimate the conditional probability
    v_taus <- cond_pr(v_x, v_y)
    m_ntau <- f_ntau(v_taus, ktau, mtau)
    #2. Construct Design matrix
    m_design <- mgcv::tensor.prod.model.matrix(list(m_ntau, n1)) %*% m_sigma

    #3. Construct Constraints
    v_idx <- seq_len(k1 + m1)
    a_in <- diag(prod(v_k0 + v_m)) * length(v_y)
    a_in <- a_in[-v_idx, ]
    b_in <- rep(0, nrow(a_in))

    l_pcls <- list(X     = m_design,
                    C    = matrix(0, 0, 0),
                    sp   = 1,
                    p    = rep(1, ncol(a_in)),
                    off  = 0,
                    S    = list(s),
                    Ain  = a_in,
                    bin  = b_in,
                    y    = v_y,
                    w    = v_y * 0 + 1)
    mgcv::pcls(l_pcls)
}


# 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


#
# PROCESSER.R
# Author: Yusuf Saib
# Date: Jul 18, 2017
# Copyright © 2017 CECL. All rights reserved.
#

# Function: process_pad
process_pad <- function(x, n) {
    len.diff <- n - length(x)
    as.matrix(c(rep(NA, len.diff), x))
}

# Function: process log nature with matrix[n,m], but except column 1
process_log_nature_frame <- function(input_xy) {
    result <- apply(input_xy[-1], 2, function(x) log(x))
    return (result)
}

# Function: process log nature with matrix [n, 1],
process_log_nature_matrix_y <- function(input_y) {
    result <- apply(input_y, 2, function(x) log(x))
    return (as.matrix(result))
}

# Function: process_logarithm:
# parmas @base_y: a column vector
# parmas @input_y: a maxtrix [n, 1], same number of rows with base_y
# return: a frame = [base_y, calculated of input_y]
process_logarithm <- function(base_y, input_y) {

    # length of input
    length_input <- length(input_y)

    # names
    name_input <- colnames(input_y)
    name_d_input <- paste("d", name_input, sep = "")
    name_ln_input <- paste("ln", name_input, sep = "")
    name_dln_input <- paste("dln", name_input, sep = "")
    name_d4_input <- paste("d4", name_input, sep = "")
    name_dln4_input <- paste("dln4", name_input, sep = "")

    # log/diff input_y
    d_input <-  process_pad(diff(input_y), n = length_input)
    ln_input <- process_log_nature_matrix_y(input_y)
    dln_input <-  process_pad(diff(ln_input), n = length_input)
    d4_input <- process_pad(diff(input_y, lag = 4), n = length_input)
    dln4_input <-  process_pad(diff(ln_input, lag = 4), n = length_input)

    # change column names
    colnames(d_input) <- c(name_d_input)
    colnames(ln_input) <- c(name_ln_input)
    colnames(dln_input) <- c(name_dln_input)
    colnames(d4_input) <- c(name_d4_input)
    colnames(dln4_input) <- c(name_dln4_input)

    # combine frames
    cbind(base_y, input_y, d_input, ln_input, dln_input, d4_input, dln4_input)
}

# Function: process_final:
# parmas @input_xy: a maxtrix [x,y]
# parmas @cindex: apply at column index
# return: a final matrix with omited NAs
process_final <- function(input_xy, cindex) {
    names <- colnames(input_xy)
    input_xy <- input_xy[complete.cases(input_xy[, cindex]), ]
    colnames(input_xy) <- names
    rownames(input_xy) <- NULL
    return (input_xy)
}