#' @title calcKristTotalRes
#'
#' @description Calculate total ship resistance (\code{Rtot}) (kN) using the
#' Kristensen method.
#'
#' @param wettedSA Wetted hull surface area (vector of numericals, m^2) (see
#' \code{\link{calcKristWettedSA}})
#' @param Cf Frictional resistance coefficient (vector of numericals,
#' dimensionless) (see \code{\link{calcCf}})
#' @param Cr Residual resistance coefficient (vector of numericals,
#' dimensionless) (see \code{\link{calcKristCr}})
#' @param Ca Incremental hull (roughness) resistance coefficient (vector of
#' numericals, dimensionless) (see \code{\link{calcKristCa}})
#' @param Caa Air resistance coefficient (vector of numericals, dimensionless)
#' (see \code{\link{calcKristCaa}})
#' @param seawaterDensity Sea water density. Default = 1.025 (g/cm^3). Can
#' supply either a vector of numericals, a single number, or rely on the default
#' @param shipSpeed Ship actual speed (vector of numericals, m/s) (see
#' \code{\link{calcSpeedUnitConversion}})
#' @param serviceMargin A service margin to account for weather and sea effects:
#' \itemize{\item Coastal operations = 10 \item At-sea operations = 15} Can
#' supply either a vector of numericals, a single number, or rely on the default
#'
#' @details
#' Note that service margin is included here as a resistance term.
#'
#' @return \code{Rtot} (vector of numericals, kN)
#'
#' @references
#'Kristensen, H. O. and Lutzen, M. 2013. "Prediction of Resistance and Propulsion
#'Power of Ships."
#'
#'\href{https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}{Kristensen, H. O.
#'"Ship-Desmo-Tool." https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}
#'
#'@seealso \itemize{
#'\item \code{\link{calcCf}}
#'\item \code{\link{calcSpeedUnitConversion}}
#'}
#'
#' @family Kristensen Calculations
#' @family Resistance Calculations
#'
#' @examples
#' calcKristTotalRes(10714.62,0.0015,0.00043,6.46e-05,5e-05,1.025,10.8,15)
#'
#' @export

calcKristTotalRes<- function(wettedSA,Cf,Cr,Ca,Caa,seawaterDensity,shipSpeed,
                             serviceMargin){

  Rtot<- wettedSA*(Cf+Cr+Ca+Caa)*seawaterDensity*(shipSpeed^2)*0.5*(1+serviceMargin/100)
  return(Rtot)
}


# import openssl:
library(openssl)
# C equivalent: (since most algorithms have reference implementations based on the C variant)
# #include <openssl/rsa.h>

# The main function we are concerned with is rsa_keygen(), which generates a random private key of specified bits.
private_key <- rsa_keygen(bits = 1024)
# Now that we got our 1024-bit private key, we can extract the public key with the same number of bits:
public_key <- private_key$public_key

# Encryption & Decryption can be followed with rsa_encrypt() and rsa_decrypt() functions:
message <- charToRaw("Alias{Anirban166}: Raven")
ciphertext <- rsa_encrypt(message, public_key)
rawToChar(rsa_decrypt(ciphertext, private_key)) # prints out the message

# To see whats underneath, (such as the numbers use for the key) we can unfold the private key:
private_key$data
# It includes the 1024-bit prime numbers included for key generation (p,q), their product n or the Euler's totient and the private & public exponents (e,d).
# On the other hand, the public key only contains the public & private exponents (e,d) and the product of the primes (n), making it impossible to decrypt the message or find the two numbers (p,q).

# For encrypting the plaintext message into ciphertext, we need to convert it into an integer:
plain.text <- bignum(charToRaw("Alias{Anirban166}: Raven"))
# Extract the Euler's totient and the exponent e (public) from the public key:
n <- public_key$data$n
e <- public_key$data$e
# Calculate the ciphertext:
cipher.text <- (m ^ e) %% n
# To obtain the exponent d (private), we need to use the private key:
d <- private_key$data$d
# Since the value of ciphertext raised to the power of d is extremely large, we will need to use bignum_mod_exp() function in order to decrypt the ciphertext:
decrypted.message <- bignum_mod_exp(cipher.text, d, n)
# Again, we need to convert the result into characters to obtain the string we sent as a message:
rawToChar(decrypted.message) # prints out the message


inputs <- c(1, 2, 3, 2.5)
weights1 <- c(0.2, 0.8, -0.5, 1.0)
weights2 <- c(0.5, -0.91, 0.26, -0.5)
weights3 <- c(-0.26, -0.27, 0.17, 0.87)
bias1 <- 2
bias2 <- 3
bias3 <- 0.5

output <- c(inputs[1] * weights1[1] + inputs[2] * weights1[2] + inputs[3] * weights1[3] + inputs[4] * weights1[4] + bias1,
            inputs[1] * weights2[1] + inputs[2] * weights2[2] + inputs[3] * weights2[3] + inputs[4] * weights2[4] + bias2,
            inputs[1] * weights3[1] + inputs[2] * weights3[2] + inputs[3] * weights3[3] + inputs[4] * weights3[4] + bias3)
output


x=c(0.5,  0.52, 0.55, 0.57, 0.6, 0.62, 0.65, 0.68, 0.7,  0.72,  0.75, 0.78, 0.8, 0.825, 0.85, 0.87, 0.88, 0.89, 0.9)
y=c(0.25, 0.27, 0.28, 0.3,  0.3, 0.35, 0.4, 0.45, 0.52, 0.65,  0.74, 0.9, 0.99,   1,    1,    0.9,  0.75, 0.33, 0)
#fit first degree polynomial equation:
fit  <- lm(y~x)
#second degree
fit2 <- lm(y~poly(x,2,raw=TRUE))
#third degree
fit3 <- lm(y~poly(x,3,raw=TRUE))
#fourth degree
fit4 <- lm(y~poly(x,4,raw=TRUE))
#generate range of 50 numbers starting from 30 and ending at 160
xx <- seq(0,1, by=0.001)
plot(x,y,pch=19,ylim=c(-0.2,1.3), xlab="th_sim", ylab="precision")
lines(xx, predict(fit, data.frame(x=xx)), col="red")
#lines(xx, predict(fit2, data.frame(x=xx)), col="green")
lines(xx, predict(fit3, data.frame(x=xx)), col="blue")
#lines(xx, predict(fit4, data.frame(x=xx)), col="purple")


context("Bass Diffusion model")

suppressWarnings(RNGversion("3.5.0"))
set.seed(1122333)
dat <- rdiffnet(200, 20)

# ------------------------------------------------------------------------------
test_that("bass fits the right thing", {
  ans0 <- coef(fitbass(dat))

  dat <- cumulative_adopt_count(dat)["prop",]
  Times <- 1:length(dat)

  # Objective function
  objf <- function(par, Times, dat) {
    sum((dat - bass_F(Times, par[1], par[2]))^2)
  }

  # Gradient of objf
  grad <- function(par, Times, dat) {
    g   <- bass_dF(par[1], par[2], Times)
    val <- (bass_F(Times, par[1], par[2]) - dat)
    c(sum(g[1,]*val), sum(g[2,]*val))
  }

  # Fitting using optim
  ans1 <- stats::optim(
    c(p = dat[1], q = .5),
    objf, grad, method="L-BFGS-B", lower = 1e-5, Times = Times, dat = dat
    )$par

  # Expectations
  expect_equal(unname(ans1), unname(ans0), tol = .001)
})

test_that("diffnet_bass methods", {
  ans <- fitbass(dat)

  expect_silent(plot(ans))
  expect_output(print(ans), "Nonlinear")
})


v = c(2, 3, 7, 1, 5, 10, 2)
soma = 0
for(i in 1:length(v)) {
  soma = soma + v[i]*v[i]
}
print(sqrt(soma))


hoge <- read.csv("synthesized_info.csv")
dead <- subset(hoge, status == "dead")
arrive <- subset(hoge, status == "arrive")
cor(dead$lifetime, dead$commit.frequency, method = "spearman")
cor(arrive$lifetime, arrive$commit.frequency, method = "spearman")
cor(dead$lifetime, dead$co.evolution.rate, method = "spearman")
cor(arrive$lifetime, arrive$co.evolution.rate, method = "spearman")


library(plot3D) # This library will allow us to draw 3d plot
library(MASS)

source("./config.r")

Sigma <- matrix(c(10, 3, 3, 2), 2, 2)
n_samples <- 200
seed <- 5341223
X <- mvrnorm(n = n_samples, mu = rep(0, 2), Sigma = Sigma)
eps <- 0.4
mean_age <- 45
std_age <- 20
beta_mri <- c(-0.2, -0.23)
age_mri <- ((X %*% beta_mri + rnorm(n_samples) * eps) * std_age) + mean_age

beta_fmri <- c(0.2, -0.12)
age_fmri <- ((X %*% beta_fmri + rnorm(n_samples) * eps) * std_age) + mean_age

beta_meg <- c(0.24, .2)
age_meg <- ((X %*% beta_meg + rnorm(n_samples) * eps) * std_age) + mean_age
data <- data.frame(a = X[,1], b = X[,2], age = age_mri)

# Compute the linear regression (z = ax + by + d
plot_plane <- function(data, color){
  fit <- lm(age ~ a + b, data = data)

  grid.lines <- 25
  x.pred <- seq(min(data[, 'a']), max(data[, 'a']), length.out = grid.lines)
  y.pred <- seq(min(data[, 'b']), max(data[, 'b']), length.out = grid.lines)
  xy <- expand.grid(a = x.pred, b = y.pred)
  print(names(data))

  z.pred <- matrix(predict(fit, newdata = xy),
                   nrow = grid.lines, ncol = grid.lines)
  # fitted points for droplines to surface
  fitpoints <- predict(fit, data = data)
  # scatter plot with regression plane
  scatter3D(
    data$a, data$b, data$age,
    pch = 18,
    cex = 2,
    col = color,
    # theta = 20, phi = 20,
    alpha = 0.5,
    ticktype = "detailed",
    # xlab = 'MRI1',
    # ylab = 'MRI2',
    zlab = "age",
    bty = 'n',
    surf = list(
        x = x.pred, y = y.pred, z = z.pred,
        facets = NA, fit = fitpoints),
    main = "")
}

data_mri <- data.frame(a = X[, 1], b = X[, 2], age = age_mri)
data_fmri <- data.frame(a = X[, 1], b = X[, 2], age = age_fmri)
data_meg <- data.frame(a = X[, 1], b = X[, 2], age = age_meg)

pdf("./figures/elements_fig_concept_scatter_meg.pdf")
plot_plane(data = data_meg, color = color_cats[['vermillon']])
dev.off()

pdf("./figures/elements_fig_concept_scatter_mri.pdf")
plot_plane(data = data_mri, color = color_cats[['blue']])
dev.off()

pdf("./figures/elements_fig_concept_scatter_fmri.pdf")
plot_plane(data = data_fmri, color = color_cats[['violet']])
dev.off()

fake_fmri <- data.frame(matrix(rnorm(50 * 10, 0, 1), 10, 20))
fmri_corr <- cor(fake_fmri)
diag(fmri_corr) <- NA
fmri_corr[lower.tri(fmri_corr)] <- NA

library(ggplot2)
library(reshape2)
plot_data <- melt(fmri_corr, na.rm = T)

ggplot(data = plot_data, mapping = aes(x = Var1, y = Var2,
       alpha = value)) +
  geom_tile(color= 'white', fill = color_cats['violet'],
            show.legend = F) +
  # scale_fill_viridis_c(option = 'plasma') +
  theme_void()
  # scale_fill_distiller("RdPu")
ggsave("./figures/elements_fig_concept_connectivity_fmri.pdf",
       width = 5, height = 5)

psd_data <- read.csv("./viz_outputs/demo_meg_psd.csv")
psd_data$channel <- factor(psd_data$channel)

set.seed(42)
ggplot(
  # data = psd_data,
  data = subset(psd_data, channel %in% sample(unique(psd_data$channel), 40)) ,
  mapping = aes(x = freqs, y = psd, group = channel)) +
    geom_line(color = color_cats[['vermillon']], alpha = 0.1) +
    # scale_x_log10() +
    # xlim(2, 50) +
    theme_void()
ggsave("./figures/elements_fig_concept_power_meg.pdf",
       width = 5, height = 5)

#+ session_info
print(sessionInfo())


"""
К статье по метаанализам

"""

library(epiR)
library(pwr)

# Размер эффекта

# График Стандартной ошибки

SE = c()
mu = c()

for (i in seq(500)) {
  sample <- rnorm(n = i, mean = 0, sd = 3)
  SE[i] = sd(sample)/sqrt(length(sample))
  mu[i] =  mean(sample)
}

plot(mu,xlab = 'Sample size', ylab = 'Sample mean', type="l")

plot(SE,xlab = 'Sample size', ylab = 'Standard error', type="l")

# standartise demo

m1 =  abs(-6)/2
m2 = (-14)/10
sd1 = sqrt(2*(1-0.5)/n1 + (m1)/(2*n1))
sd2 = sqrt(2*(1-0.5)/n2 + (m2)/(2*n2))

sd1r = sqrt((2^2 + 2^2 - 2*(0.5 * 2*2))/n1)
sd2r = sqrt((10^2 + 16^2 - 2*(0.5 * 10*16))/n2)

n1 = 58
n2 = 82

-14 - sd2r

-m1 - 2*sd1
m2 + 2*sd2

pooled_sd = sqrt(((n1-1) * sd1^2 + (n2-1) * sd2^2)/(n1 + n2 - 2))

# Модели

# Фиксированные эффекты

SE = c()
mu = c()

for (i in seq(100)) {
  sample <- rnorm(n = i, mean = 0, sd = 3)
  SE[i] = sd(sample)/sqrt(length(sample))
  mu[i] =  mean(sample)
}

plot(mu, SE, xlab = 'Effect size', ylab = 'Standard error', xlim=c(-2,2))
abline(v=0, col='red', lwd=3)

"""
Forest plot
"""

library(meta)

data(Fleiss1993cont)

example = metacont(n.psyc, mean.psyc, sd.psyc, n.cont, mean.cont, sd.cont,
         data = Fleiss1993cont, studlab = paste(study, year),
         random = TRUE, fixed=TRUE)

forest.meta(example)

drapery(example, labels = "studlab", type = "pvalue")

"""
Effect size
"""

x <- seq(- 5, 5, by = 0.01)
y <- dt(x, df = 50)

# расчет критических значений
critical = qt(p=0.05/2, df=length(x), lower.tail=F)
critical_one_sided = qt(p=0.05, df=length(x), lower.tail=F)

plot(x,
     y,
     type = "l",
     main = " ",
     xlab="t-статистики", ylab="Плотность вероятности",
     las=1,
     col = 'blue',
     xlim=c(-5, 6)
)

lines(x + 2,
      y,
      type = "l",
      main = " ",
      xlab="t-статистики", ylab="Плотность вероятности",
      las=1,
      col = 'red'
)

"""
Funnel plot
"""

library(metafor)

### copy BCG vaccine data into 'dat'
dat <- dat.bcg

### calculate log risk ratios and corresponding sampling variances
dat <- escalc(measure="RR", ai=tpos, bi=tneg, ci=cpos, di=cneg, data=dat)

### fit random-effects model
res <- rma(yi, vi, data=dat, slab=paste(author, year, sep=", "))

### draw a standard funnel plot
funnel(res)

### note: same plot, except that reference line is centered at zero
funnel(dat$yi, dat$vi)

### the with() function can be used to avoid having to retype dat$... over and over
with(dat, funnel(yi, vi))

"""
Egger test
"""


########################Question 5########################
#read in the data
path <- system.file("mat-files", package="R.matlab")
pathname <- file.path("/Users/hellofutrue/Google Drive/Schoolwork_CU/Schoolwork Fall 2017/COMS4771 Machine Learning/HW1", "hw1data.mat")
data <- readMat(pathname)
#print(data)
X<-data$X
Y<-data$Y

#Select the features that has the top 200 variability
VAR=NULL
for (i in 1:ncol(X)){
 VAR[i]<-var(X[,i])}
VAR_ID<-cbind(c(1:ncol(X)),VAR) #ID and var of each feature
number<-VAR_ID[order(VAR_ID[,2],decreasing=T),][1:200,1]#select the features have the top 200 variability
X<-X[,number]

#normalized each features (transfer into Z score)
mu <- colMeans(X)

ZX=matrix(,ncol=ncol(X),nrow=nrow(X))
for (i in 1:ncol(X)){
  ZX[,i]<-as.matrix((X-mu)[,i]/sqrt(var(X[,i])))
}

#create the whole dataset
dat<-cbind(ZX,Y)

#split the data into training and test
splitratio<-0.8
sample <- sample.int(n = nrow(dat), size = floor(splitratio*nrow(dat)), replace = F)
train <- dat[sample, ] #8000 datapoints for training
test  <- dat[-sample, ] #2000 datapoints for testing
testx<-test[,-201]
trainx<-train[,-201]

#(i) Gaussian classfier
#splititng the training data into 10 subgroups
y0<-subset(train[which(train[,201]==0),])
y1<-subset(train[which(train[,201]==1),])
y2<-subset(train[which(train[,201]==2),])
y3<-subset(train[which(train[,201]==3),])
y4<-subset(train[which(train[,201]==4),])
y5<-subset(train[which(train[,201]==5),])
y6<-subset(train[which(train[,201]==6),])
y7<-subset(train[which(train[,201]==7),])
y8<-subset(train[which(train[,201]==8),])
y9<-subset(train[which(train[,201]==9),])

#calculate MLEs
xy0<-y0[,-201]#only the features when y=0
xy1<-y1[,-201]
xy2<-y2[,-201]
xy3<-y3[,-201]
xy4<-y4[,-201]
xy5<-y5[,-201]
xy6<-y6[,-201]
xy7<-y7[,-201]
xy8<-y8[,-201]
xy9<-y9[,-201]

#mu
mu0<-colMeans(xy0)
mu1<-colMeans(xy1)
mu2<-colMeans(xy2)
mu3<-colMeans(xy3)
mu4<-colMeans(xy4)
mu5<-colMeans(xy5)
mu6<-colMeans(xy6)
mu7<-colMeans(xy7)
mu8<-colMeans(xy8)
mu9<-colMeans(xy9)

#sigma matrices
matrices0<-list()
for (i in 1:nrow(xy0)){
  matrices0[[i]]<-t(t(xy0[i,]-mu0))%*%t(xy0[i,]-mu0)
}
sigma0<-apply(simplify2array(matrices0), 1:2, mean)

matrices1<-list()
for (i in 1:nrow(xy1)){
  matrices1[[i]]<-t(t(xy1[i,]-mu1))%*%t(xy1[i,]-mu1)
}
sigma1<-apply(simplify2array(matrices1), 1:2, mean)

matrices2<-list()
for (i in 1:nrow(xy2)){
  matrices2[[i]]<-t(t(xy2[i,]-mu2))%*%t(xy2[i,]-mu2)
}
sigma2<-apply(simplify2array(matrices2), 1:2, mean)

matrices3<-list()
for (i in 1:nrow(xy3)){
  matrices3[[i]]<-t(t(xy3[i,]-mu3))%*%t(xy3[i,]-mu3)
}
sigma3<-apply(simplify2array(matrices3), 1:2, mean)

matrices4<-list()
for (i in 1:nrow(xy4)){
  matrices4[[i]]<-t(t(xy4[i,]-mu4))%*%t(xy4[i,]-mu4)
}
sigma4<-apply(simplify2array(matrices4), 1:2, mean)

matrices5<-list()
for (i in 1:nrow(xy5)){
  matrices5[[i]]<-t(t(xy5[i,]-mu5))%*%t(xy5[i,]-mu5)
}
sigma5<-apply(simplify2array(matrices5), 1:2, mean)

matrices6<-list()
for (i in 1:nrow(xy6)){
  matrices6[[i]]<-t(t(xy6[i,]-mu6))%*%t(xy6[i,]-mu6)
}
sigma6<-apply(simplify2array(matrices6), 1:2, mean)

matrices7<-list()
for (i in 1:nrow(xy7)){
  matrices7[[i]]<-t(t(xy7[i,]-mu0))%*%t(xy7[i,]-mu7)
}
sigma7<-apply(simplify2array(matrices7), 1:2, mean)

matrices8<-list()
for (i in 1:nrow(xy8)){
  matrices8[[i]]<-t(t(xy8[i,]-mu8))%*%t(xy8[i,]-mu8)
}
sigma8<-apply(simplify2array(matrices8), 1:2, mean)

matrices9<-list()
for (i in 1:nrow(xy9)){
  matrices9[[i]]<-t(t(xy9[i,]-mu9))%*%t(xy9[i,]-mu9)
}
sigma9<-apply(simplify2array(matrices9), 1:2, mean)

#det(sigma0)

# h<-eigen(sigma0)$values[201]
# add<-h*diag(ncol(sigma0))
# sigma0new<-sigma0+add
# det(sigma0new)

#learning about class priors (y=0....9)
freq<-table(train[,201])/10000
py0<-as.numeric(freq[1])
py1<-as.numeric(freq[2])
py2<-as.numeric(freq[3])
py3<-as.numeric(freq[4])
py4<-as.numeric(freq[5])
py5<-as.numeric(freq[6])
py6<-as.numeric(freq[7])
py7<-as.numeric(freq[8])
py8<-as.numeric(freq[9])
py9<-as.numeric(freq[10])

#calculte the probablity with test data
mu0<-matrix(mu0,ncol=ncol(testx),nrow=1,byrow = T)
mu1<-matrix(mu1,ncol=ncol(testx),nrow=1,byrow = T)
mu2<-matrix(mu2,ncol=ncol(testx),nrow=1,byrow = T)
mu3<-matrix(mu3,ncol=ncol(testx),nrow=1,byrow = T)
mu4<-matrix(mu4,ncol=ncol(testx),nrow=1,byrow = T)
mu5<-matrix(mu5,ncol=ncol(testx),nrow=1,byrow = T)
mu6<-matrix(mu6,ncol=ncol(testx),nrow=1,byrow = T)
mu7<-matrix(mu7,ncol=ncol(testx),nrow=1,byrow = T)
mu8<-matrix(mu8,ncol=ncol(testx),nrow=1,byrow = T)
mu9<-matrix(mu9,ncol=ncol(testx),nrow=1,byrow = T)

p<-matrix(,ncol=10,nrow=nrow(testx)) #prepare the form of probability
for (n in 1:nrow(testx)){
  p[n,1]<-(((2*pi)^ncol(testx)*det(sigma0))^(-0.5)*(exp(-0.5*(testx[n,]-mu0)%*%solve(sigma0)%*%t(testx[n,]-mu0))))*py0
  p[n,2]<-(((2*pi)^ncol(testx)*det(sigma1))^(-0.5)*(exp(-0.5*(testx[n,]-mu1)%*%solve(sigma1)%*%t(testx[n,]-mu1))))*py1
  p[n,3]<-(((2*pi)^ncol(testx)*det(sigma2))^(-0.5)*(exp(-0.5*(testx[n,]-mu2)%*%solve(sigma2)%*%t(testx[n,]-mu2))))*py2
  p[n,4]<-(((2*pi)^ncol(testx)*det(sigma3))^(-0.5)*(exp(-0.5*(testx[n,]-mu3)%*%solve(sigma3)%*%t(testx[n,]-mu3))))*py3
  p[n,5]<-(((2*pi)^ncol(testx)*det(sigma4))^(-0.5)*(exp(-0.5*(testx[n,]-mu4)%*%solve(sigma4)%*%t(testx[n,]-mu4))))*py4
  p[n,6]<-(((2*pi)^ncol(testx)*det(sigma5))^(-0.5)*(exp(-0.5*(testx[n,]-mu5)%*%solve(sigma5)%*%t(testx[n,]-mu5))))*py5
  p[n,7]<-(((2*pi)^ncol(testx)*det(sigma6))^(-0.5)*(exp(-0.5*(testx[n,]-mu6)%*%solve(sigma6)%*%t(testx[n,]-mu6))))*py6
  p[n,8]<-(((2*pi)^ncol(testx)*det(sigma7))^(-0.5)*(exp(-0.5*(testx[n,]-mu7)%*%solve(sigma7)%*%t(testx[n,]-mu7))))*py7
  p[n,9]<-(((2*pi)^ncol(testx)*det(sigma8))^(-0.5)*(exp(-0.5*(testx[n,]-mu8)%*%solve(sigma8)%*%t(testx[n,]-mu8))))*py8
  p[n,10]<-(((2*pi)^ncol(testx)*det(sigma9))^(-0.5)*(exp(-0.5*(testx[n,]-mu9)%*%solve(sigma9)%*%t(testx[n,]-mu9))))*py9
}

#Give out prediction
colnames(p)<-c(0:9)
predi<-colnames(p)[apply(p,1,which.max)]
predi<-as.matrix(predi,ncol=1,nrow=nrow(testx))

#Calculate accuracy
accu<-cbind(predi,test[,201])
accuracy<-accu[,1]==accu[,2]
accuracyrate<-length(accuracy[accuracy==TRUE])/nrow(accu)

#K-NN classifier
#for a single test point, calculate the euclidian distance of it to all the training data
#select the nearest k points, capture the label with highest frequency, assign it to the test point

#calculate the euclidian distance from every test data to all the training data
euc<-matrix(,nrow =nrow(testx),ncol=nrow(trainx))
for (n in 1:nrow(testx)){
  x<-matrix(testx[n,],nrow=nrow(trainx),ncol=ncol(testx),byrow=T)
  d<-sqrt(rowSums((x-trainx)^2))
  euc[n,]<-d
}
colnames(euc)<-c(1:nrow(trainx))

k=3
labelpredi<-matrix(,nrow=nrow(euc),ncol=1)
  for (n in 1:nrow(euc)){
    topk<-as.numeric(names(sort(euc[n,])[1:k]))
    label<-train[topk,201]
    labelpredi[n,]<-names(sort(table(label))[length(table(label))])
  }

#Calculate accuracy
  knnaccu<-cbind(labelpredi,test[,201])
  knnaccuracy<-knnaccu[,1]==knnaccu[,2]
  knnaccuracyrate<-length(knnaccuracy[knnaccuracy==TRUE])/nrow(knnaccu)
  table<-rbind(k,knnaccuracyrate)

# (iii) compare two classifiers
compare<-function(splitratio){
  sample <- sample.int(n = nrow(dat), size = floor(splitratio*nrow(dat)), replace = F)
  train <- dat[sample, ] #8000 datapoints for training
  test  <- dat[-sample, ] #2000 datapoints for testing
  testx<-test[,-201]
  trainx<-train[,-201]

  #(i) Gaussian classfier
  #splititng the training data into 10 subgroups
  y0<-subset(train[which(train[,201]==0),])
  y1<-subset(train[which(train[,201]==1),])
  y2<-subset(train[which(train[,201]==2),])
  y3<-subset(train[which(train[,201]==3),])
  y4<-subset(train[which(train[,201]==4),])
  y5<-subset(train[which(train[,201]==5),])
  y6<-subset(train[which(train[,201]==6),])
  y7<-subset(train[which(train[,201]==7),])
  y8<-subset(train[which(train[,201]==8),])
  y9<-subset(train[which(train[,201]==9),])

  #calculate MLEs
  xy0<-y0[,-201]#only the features when y=0
  xy1<-y1[,-201]
  xy2<-y2[,-201]
  xy3<-y3[,-201]
  xy4<-y4[,-201]
  xy5<-y5[,-201]
  xy6<-y6[,-201]
  xy7<-y7[,-201]
  xy8<-y8[,-201]
  xy9<-y9[,-201]

  #mu
  mu0<-colMeans(xy0)
  mu1<-colMeans(xy1)
  mu2<-colMeans(xy2)
  mu3<-colMeans(xy3)
  mu4<-colMeans(xy4)
  mu5<-colMeans(xy5)
  mu6<-colMeans(xy6)
  mu7<-colMeans(xy7)
  mu8<-colMeans(xy8)
  mu9<-colMeans(xy9)

  #sigma matrices
  matrices0<-list()
  for (i in 1:nrow(xy0)){
    matrices0[[i]]<-t(t(xy0[i,]-mu0))%*%t(xy0[i,]-mu0)
  }
  sigma0<-apply(simplify2array(matrices0), 1:2, mean)

  matrices1<-list()
  for (i in 1:nrow(xy1)){
    matrices1[[i]]<-t(t(xy1[i,]-mu1))%*%t(xy1[i,]-mu1)
  }
  sigma1<-apply(simplify2array(matrices1), 1:2, mean)

  matrices2<-list()
  for (i in 1:nrow(xy2)){
    matrices2[[i]]<-t(t(xy2[i,]-mu2))%*%t(xy2[i,]-mu2)
  }
  sigma2<-apply(simplify2array(matrices2), 1:2, mean)

  matrices3<-list()
  for (i in 1:nrow(xy3)){
    matrices3[[i]]<-t(t(xy3[i,]-mu3))%*%t(xy3[i,]-mu3)
  }
  sigma3<-apply(simplify2array(matrices3), 1:2, mean)

  matrices4<-list()
  for (i in 1:nrow(xy4)){
    matrices4[[i]]<-t(t(xy4[i,]-mu4))%*%t(xy4[i,]-mu4)
  }
  sigma4<-apply(simplify2array(matrices4), 1:2, mean)

  matrices5<-list()
  for (i in 1:nrow(xy5)){
    matrices5[[i]]<-t(t(xy5[i,]-mu5))%*%t(xy5[i,]-mu5)
  }
  sigma5<-apply(simplify2array(matrices5), 1:2, mean)

  matrices6<-list()
  for (i in 1:nrow(xy6)){
    matrices6[[i]]<-t(t(xy6[i,]-mu6))%*%t(xy6[i,]-mu6)
  }
  sigma6<-apply(simplify2array(matrices6), 1:2, mean)

  matrices7<-list()
  for (i in 1:nrow(xy7)){
    matrices7[[i]]<-t(t(xy7[i,]-mu0))%*%t(xy7[i,]-mu7)
  }
  sigma7<-apply(simplify2array(matrices7), 1:2, mean)

  matrices8<-list()
  for (i in 1:nrow(xy8)){
    matrices8[[i]]<-t(t(xy8[i,]-mu8))%*%t(xy8[i,]-mu8)
  }
  sigma8<-apply(simplify2array(matrices8), 1:2, mean)

  matrices9<-list()
  for (i in 1:nrow(xy9)){
    matrices9[[i]]<-t(t(xy9[i,]-mu9))%*%t(xy9[i,]-mu9)
  }
  sigma9<-apply(simplify2array(matrices9), 1:2, mean)

  #det(sigma0)

  # h<-eigen(sigma0)$values[201]
  # add<-h*diag(ncol(sigma0))
  # sigma0new<-sigma0+add
  # det(sigma0new)

  #learning about class priors (y=0....9)
  freq<-table(train[,201])/10000
  py0<-as.numeric(freq[1])
  py1<-as.numeric(freq[2])
  py2<-as.numeric(freq[3])
  py3<-as.numeric(freq[4])
  py4<-as.numeric(freq[5])
  py5<-as.numeric(freq[6])
  py6<-as.numeric(freq[7])
  py7<-as.numeric(freq[8])
  py8<-as.numeric(freq[9])
  py9<-as.numeric(freq[10])

  #calculte the probablity with test data
  mu0<-matrix(mu0,ncol=ncol(testx),nrow=1,byrow = T)
  mu1<-matrix(mu1,ncol=ncol(testx),nrow=1,byrow = T)
  mu2<-matrix(mu2,ncol=ncol(testx),nrow=1,byrow = T)
  mu3<-matrix(mu3,ncol=ncol(testx),nrow=1,byrow = T)
  mu4<-matrix(mu4,ncol=ncol(testx),nrow=1,byrow = T)
  mu5<-matrix(mu5,ncol=ncol(testx),nrow=1,byrow = T)
  mu6<-matrix(mu6,ncol=ncol(testx),nrow=1,byrow = T)
  mu7<-matrix(mu7,ncol=ncol(testx),nrow=1,byrow = T)
  mu8<-matrix(mu8,ncol=ncol(testx),nrow=1,byrow = T)
  mu9<-matrix(mu9,ncol=ncol(testx),nrow=1,byrow = T)

  p<-matrix(,ncol=10,nrow=nrow(testx)) #prepare the form of probability
  for (n in 1:nrow(testx)){
    p[n,1]<-(((2*pi)^ncol(testx)*det(sigma0))^(-0.5)*(exp(-0.5*(testx[n,]-mu0)%*%solve(sigma0)%*%t(testx[n,]-mu0))))*py0
    p[n,2]<-(((2*pi)^ncol(testx)*det(sigma1))^(-0.5)*(exp(-0.5*(testx[n,]-mu1)%*%solve(sigma1)%*%t(testx[n,]-mu1))))*py1
    p[n,3]<-(((2*pi)^ncol(testx)*det(sigma2))^(-0.5)*(exp(-0.5*(testx[n,]-mu2)%*%solve(sigma2)%*%t(testx[n,]-mu2))))*py2
    p[n,4]<-(((2*pi)^ncol(testx)*det(sigma3))^(-0.5)*(exp(-0.5*(testx[n,]-mu3)%*%solve(sigma3)%*%t(testx[n,]-mu3))))*py3
    p[n,5]<-(((2*pi)^ncol(testx)*det(sigma4))^(-0.5)*(exp(-0.5*(testx[n,]-mu4)%*%solve(sigma4)%*%t(testx[n,]-mu4))))*py4
    p[n,6]<-(((2*pi)^ncol(testx)*det(sigma5))^(-0.5)*(exp(-0.5*(testx[n,]-mu5)%*%solve(sigma5)%*%t(testx[n,]-mu5))))*py5
    p[n,7]<-(((2*pi)^ncol(testx)*det(sigma6))^(-0.5)*(exp(-0.5*(testx[n,]-mu6)%*%solve(sigma6)%*%t(testx[n,]-mu6))))*py6
    p[n,8]<-(((2*pi)^ncol(testx)*det(sigma7))^(-0.5)*(exp(-0.5*(testx[n,]-mu7)%*%solve(sigma7)%*%t(testx[n,]-mu7))))*py7
    p[n,9]<-(((2*pi)^ncol(testx)*det(sigma8))^(-0.5)*(exp(-0.5*(testx[n,]-mu8)%*%solve(sigma8)%*%t(testx[n,]-mu8))))*py8
    p[n,10]<-(((2*pi)^ncol(testx)*det(sigma9))^(-0.5)*(exp(-0.5*(testx[n,]-mu9)%*%solve(sigma9)%*%t(testx[n,]-mu9))))*py9
  }

  #Give out prediction
  colnames(p)<-c(0:9)
  predi<-colnames(p)[apply(p,1,which.max)]
  predi<-as.matrix(predi,ncol=1,nrow=nrow(testx))

  #Calculate accuracy
  accu<-cbind(predi,test[,201])
  accuracy<-accu[,1]==accu[,2]
  accuracyrate<-length(accuracy[accuracy==TRUE])/nrow(accu)

  #K-NN classifier
  #calculate the euclidian distance from every test data to all the training data
  euc<-matrix(,nrow =nrow(testx),ncol=nrow(trainx))
  for (n in 1:nrow(testx)){
    x<-matrix(testx[n,],nrow=nrow(trainx),ncol=ncol(testx),byrow=T)
    d<-sqrt(rowSums((x-trainx)^2))
    euc[n,]<-d
  }
  colnames(euc)<-c(1:nrow(trainx))

  k=3
  labelpredi<-matrix(,nrow=nrow(euc),ncol=1)
  for (n in 1:nrow(euc)){
    topk<-as.numeric(names(sort(euc[n,])[1:k]))
    label<-train[topk,201]
    labelpredi[n,]<-names(sort(table(label))[length(table(label))])
  }

  #Calculate accuracy
  knnaccu<-cbind(labelpredi,test[,201])
  knnaccuracy<-knnaccu[,1]==knnaccu[,2]
  knnaccuracyrate<-length(knnaccuracy[knnaccuracy==TRUE])/nrow(knnaccu)
  table<-rbind(k,knnaccuracyrate)

  out<-c(splitratio,accuracyrate,knnaccuracyrate)

  print(splitratio)
  return(out)
}

RESULT<-NULL
for (s in (c(0.8,0.6,0.4,0.3))){
  result<-compare(s)
  RESULT<-rbind(result,RESULT)
}

ggplot(RESULT, aes(x=RESULT$splitratio)) +
  geom_line(aes(y=RESULT$Gaussian.accuracy.rate, color="Gaussian classifier")) + xlab("Percentage of training data in the whole data")+
  geom_line(aes(y=RESULT$k.nn.accuracy.rate, color="k-NN classifier, k=3"))+ ylab("Accuracy rate")

#(iv)Different distance definitions L1, L2 and L-infinite

distance<-function(splitratio){
  sample <- sample.int(n = nrow(dat), size = floor(splitratio*nrow(dat)), replace = F)
  train <- dat[sample, ] #8000 datapoints for training
  test  <- dat[-sample, ] #2000 datapoints for testing
  testx<-test[,-201]
  trainx<-train[,-201]

L1<-matrix(,nrow =nrow(testx),ncol=nrow(trainx))
L2<-matrix(,nrow =nrow(testx),ncol=nrow(trainx))
Linf<-matrix(,nrow =nrow(testx),ncol=nrow(trainx))
  for (n in 1:nrow(testx)){
    x<-matrix(testx[n,],nrow=nrow(trainx),ncol=ncol(testx),byrow=T)
    d1<-rowSums(abs(x-trainx))
    d2<-sqrt(rowSums((x-trainx)^2))
    dinf<-apply(abs(x-trainx),1,max)
    L1[n,]<-d1
    L2[n,]<-d2
    Linf[n,]<-dinf
  }
colnames(L1)<-c(1:nrow(trainx))
colnames(L2)<-c(1:nrow(trainx))
colnames(Linf)<-c(1:nrow(trainx))

k=3
labelpredi1<-matrix(,nrow=nrow(L1),ncol=1)
labelpredi2<-matrix(,nrow=nrow(L2),ncol=1)
labelpredi3<-matrix(,nrow=nrow(Linf),ncol=1)
for (n in 1:nrow(L1)){
  #predict based on L1
  topk1<-as.numeric(names(sort(L1[n,])[1:k]))
  label1<-train[topk1,201]
  labelpredi1[n,]<-names(sort(table(label1))[length(table(label1))])
  #predict based on L2
  topk2<-as.numeric(names(sort(L2[n,])[1:k]))
  label2<-train[topk2,201]
  labelpredi2[n,]<-names(sort(table(label2))[length(table(label2))])
  #predict based on Linf
  topk3<-as.numeric(names(sort(Linf[n,])[1:k]))
  label3<-train[topk3,201]
  labelpredi3[n,]<-names(sort(table(label3))[length(table(label3))])
}

#Calculate accuracy
knnaccu<-cbind(labelpredi1,labelpredi2,labelpredi3,test[,201])
L1knnaccuracy<-knnaccu[,1]==knnaccu[,4]
L1knnaccuracyrate<-length(L1knnaccuracy[L1knnaccuracy==TRUE])/nrow(knnaccu)

L2knnaccuracy<-knnaccu[,2]==knnaccu[,4]
L2knnaccuracyrate<-length(L2knnaccuracy[L2knnaccuracy==TRUE])/nrow(knnaccu)

Linfknnaccuracy<-knnaccu[,3]==knnaccu[,4]
Linfknnaccuracyrate<-length(Linfknnaccuracy[Linfknnaccuracy==TRUE])/nrow(knnaccu)

out<-rbind(splitratio,L1knnaccuracyrate,L2knnaccuracyrate,Linfknnaccuracyrate)
}

D<-NULL
for (s in (c(0.8,0.6,0.4))){
  result<-distance(s)
  D<-cbind(D,result)
}

ggplot(D, aes(x=D$splitratio)) +
  geom_line(aes(y=D$L1knnaccuracyrate, color="L1 distance")) + xlab("Percentage of training data in the whole data")+
  geom_line(aes(y=D$L2knnaccuracyrate, color="L2 distance"))+ ylab("Accuracy rate,k=3")+
  geom_line(aes(y=D$Linfknnaccuracyrate, color="L-infinite"))


#
# Exemplo 1
#

# Serie de Taylor para a exponencial de x
# em x=3 em volta do ponto x=2 até n=4
x <- 3
taylor <- exp(2) + exp(2) * (x - 2)
taylor <- taylor + exp(2) * (x - 2)^2 / factorial(2)
taylor <- taylor + exp(2) * (x - 2)^3 / factorial(3)
taylor <- taylor + exp(2) * (x - 2)^4 / factorial(4)

taylor
# valor real da exponencial de x
exp(x)


# Loading the required libraries

library(corrplot) # used for making the plot
library(tidyverse) # data reading and writing
library(RColorBrewer) # add colors to plot

# read your csv (or excel file)
metabolites <- read.csv("metabolites.csv")

# convert the data into a matrix, remove the compounds row
metabolites_df <- as.matrix(metabolites[,-1])

# convert default rownames to compounds
rownames(metabolites_df) <- metabolites$compound

# carry out the correlation
correlation_plot <- cor(t(metabolites_df))

# save the plot by initiating the device. Much more control than exporting using plot viewer
png(
  filename = "correlation_plot.png",
  width = 2000,
  height = 2000,
  units = "px"
)

# make the plot
correlation_1 <-
  corrplot(
    correlation_plot,
    type = "lower",
    order = "hclust",
    method = "color",
    col = brewer.pal(n = 8, name = "RdYlBu"),
    addgrid.col = "darkgray",
    outline = T,
    tl.cex = 1,
    tl.col = "black"
  )

# turn off the dev to finish exporting.
dev.off()


a <- c(3,5, 1, -7, 1, -1, 5,13, 3, 5, 1, -7, 1, -1, 5, 13)
b <- c(1, -1, 5 ,13, 1, -1, 5, 13, 3, 5, 1, -7, 1, -1, 5, 13)
d <- c(1, -1, 5,13, 0, 6, 3, -65, 0, -2, 1, 12,5, 8, 3, 6)
#task 1
fe <- 7*(a)-25*(b)
se <-8*((a%*%b)/(norm(a, type="2")b, type="2"))%*%d-3*(norm(a, type="2"))%*%b
te <-21*((a%*%d)/(norm(a, type="2")d, type="2"))%*%b+(4*b)*(d%*%d)-(norm(b, type="2"))%*%b
print ("first ex")
fe
print ("second ex")
se
print ("third ex")
te

#task 2
#cbind(c(cos(pi/3), sin(pi/3)), c(-sin(pi/3), cos(pi/3)))
print ("проведите путь к файлу по типу Data <- C:\\Users\\User\\Desktop\\data.xlsx")

#library("xlsx") # Для считывания данных из excel-файлов типа xlsx
#library("dplyr")
#first <- select(Data,first)
#second <-select(Data,second)
#total <- select(Data,total)
#jeez <- first+second=total
#jeez
#alternative

#print ("thats an ex 2")
#first <- c(a,b,c,d,e,26*f,g,h)
#second<- c(b,c,d,e,f,g,h,a)
#total <- c(3,5,7,9,11,163,15,9)
#jeez <- first+second=total
#jeez

#task 3
library (float)
folk <- rbind(c(19, 0, 0, 0, 0, 0, 0, 20) ,c(0, 17, 0, 0, 0, 0, 0, 0), c(0, 0, 13, 0, 0, 0, 0, 0), c(0, 0, 0, 3, 0, 0, 31, 0),c(0, 0, 0, 0, 7, 0, 0, 0), c(0, 0, 0, 0, 0, 5, 0, 0),c (0, 0, 0, 31, 0, 0, 11, 0), c(0, 0, 0, 0, 0, 0 ,0, 1))
gar <- eigen(folk)
gar <- round (gar,4)
gar

#task 4

A <- rbind (c( 26 3 7 9 -3 3 3 -47),c( 3 5 9 7 31 1 1 -19), c( 5 7 7 5 37 -1 -1 5), c( 7 9 5 3 31 -3 -3 7), c( 9 7 3 1 37 -5 -3 9), c( 7 5 1 -1 41 0 31 1), c( 5 3 -1 -3 43 1 37 3), c( 2626 1 -3 -5 47 0 41 5))
B <- rbind (c( 26 3 0 9 17 3 3 0), c( 3 5 0 7 19 1 1 0), c ( 3 5 0 7 19 1 1 0), c ( 99 9 5 3 31 -3 -3 0), c ( 9 7 3 1 -37 -5 -3 0), c( 7 5 1 -1 -41 0 31 1), c( 0 0 0 0 1 0 0 0), c( 2626 1 -3 -5 -47 0 41 5))
E <- diag (8)
total <- solve(B%*%A)
trotal <- solve(total,E)
trotal


# This is the script to represent data with basis functions
# Available basis: B-Spline and temporal basis function through SVD
source("./src/database.R")
source("./src/plot.R")
source("./src/helper.R")

require(sp)
require(gstat)
require(dplyr)
require(reshape2)
require(geoR)

coeff2Value <- function(coef, basis){
	return(basis %*% t(coef)) # return a matrix
}

SVD_basis <- function(DOdata, r){
	# r is the column vectors to keep
	DOdata <- as.matrix(DOdata)

	svdRes <- svd(DOdata %>% scale()) # Scale matrix before SVD

	basis <- svdRes$u[,1:r]
	t = nrow(basis)

	for(i in 1:r){
		splineRes <- smooth.spline(x = 1:t, y = basis[,i], df = t*0.2)
		basis[,i] <- predict(splineRes, 1:t)$y
	}

	basis <- cbind(basis,1) # add the bias term

	coef <- lsfit(x = basis, y= DOdata, intercept = FALSE)$coefficients
	DO_fit <- basis %*% coef # coef, each column is the coefficents for different basis

	print("variance explained by SVD")
	print(sum(svdRes$d[1:r]**2)/sum(svdRes$d**2))

	return(list(fit = DO_fit, coef = coef, basis = basis,varExpl = sum(svdRes$d[1:r]**2)/sum(svdRes$d**2)))
}


# DySyn_distance <- function (x, method= "hellinger"){
#
#   if (method == "ord") {
#     x_dif <- x[1,]-x[2,]
#     acum <- 0
#     aux <- 0
#     for(i in 1:length(x_dif)){
#       aux <- x_dif[i]+aux
#       acum <- acum+aux
#     }
#     return(abs(acum))
#   }
#   return(as.numeric(philentropy::distance(x, method = method, p=0.5)))
#
# }

DySyn_distance <- function (x, method= "hellinger"){

  if (method == "ord") {
    x_dif <- x[1,]-x[2,]
    acum <- 0
    aux <- 0
    for(i in 1:length(x_dif)){
      aux <- x_dif[i]+aux
      acum <- acum+aux
    }
    return(abs(acum))
  }
  if(method == "topsoe"){
    re <- 0
    for(i in 1:ncol(x))
      re <- re + ( x[1,i] * log( (2*x[1,i])/(x[1,i] + x[2,i]) ) + x[2,i]*log( (2*x[2,i])/(x[2,i] + x[1,i]) ) )

    return(re)
  }
  if(method == "jensen_difference"){
    re <- 0
    for(i in 1:ncol(x))
      re <- re + (  ((x[1,i]*log(x[1,i]) + x[2,i]*log(x[2,i]) )/2) - ((x[1,i] + x[2,i])/2 ) * log((x[1,i] + x[2,i])/2 )   )

    return(re)
  }
  if(method == "taneja"){
    re <- 0
    for(i in 1:ncol(x))
      re <- re + ( ((x[1,i] + x[2,i])/2) * log( (x[1,i] + x[2,i]) / (2 * sqrt(x[1,i] * x[2,i]) )) )
    return(re)
  }
  if(method == "hellinger"){
    re <- 0
    for(i in 1:ncol(x))
      re <- re + sqrt((x[1,i] * x[2,i]))
    return(2*sqrt(1 - re))
  }

  if(method == "prob_symm"){
    re <- 0
    for(i in 1:ncol(x))
      re <- re + ( (x[1,i] - x[2,i] )^2 / (x[1,i] +x[2,i]) )
    return(2*re)
  }

  stop("measure argument must be a valid option")
}

getHist <- function(scores, nbins){
  breaks <- seq(0,1,length.out = nbins+1)
  breaks <- c(breaks[-length(breaks)], 1.1)
  re <- rep((1/(length(breaks)-1)),length(breaks)-1)
  for(i in 2:length(breaks)){
    re[i-1] <- (re[i-1] + length(which(scores >= breaks[i-1] & scores < breaks[i])))/(length(scores)+1)
  }
  return(re)
}

TernarySearch  <- function(left, right, f, eps=1e-4){
  while(TRUE){
    if (abs(left - right) < eps) return((left + right) / 2)

    leftThird  <- left + (right - left) / 3
    rightThird <- right - (right - left) / 3

    if (f(leftThird) > f(rightThird))
      left <- leftThird
    else
      right <- rightThird
  }

}


## This file contains utilities for creating
## spatial grids of rectangles and hexagons
library(tidyverse)

## Create a grid of spatial locations determined by
## the minimum, maximum, and step size for the x and y axes.
## This grid will be replicated for all existing grouping variables
## in the data frame df.
grid.rect <- function(df=data.frame(), xmin=-600, xmax=600, xsize=10,
                      ymin=-300, ymax=300, ysize=10) {
    ## make sure we include the maxima
    if (xmax %% xsize != 0) xmax <- xmax + xsize
    if (ymax %% ysize != 0) ymax <- ymax + ysize

    df %>%
        expand(bin_x=seq(xmin, xmax, xsize),
               bin_y=seq(ymin, ymax, ysize)) %>%
        mutate(grid_idx=row_number()) %>%
        return()
}

## Create a 2D histogram of the data binned over grid.rect(...)
bin.rect <- function(df, xmin=-600, xmax=600, xsize=10,
                     ymin=-300, ymax=300, ysize=10) {
    grid <- grid.rect(df, xmin=xmin, xmax=xmax, xsize=xsize,
                      ymin=ymin, ymax=ymax, ysize=ysize)

    ## find break points from bin centers
    x_bins <- unique(grid$bin_x)
    y_bins <- unique(grid$bin_y)
    x_breaks <- x_bins[-length(x_bins)] + xsize/2
    y_breaks <- y_bins[-length(y_bins)] + ysize/2

    ## bin df according to the grid
    df %>%
        mutate(bin_x=x_bins[findInterval(CURRENT_FIX_X, x_breaks) + 1],
               bin_y=y_bins[findInterval(CURRENT_FIX_Y, y_breaks) + 1]) %>%
        group_by(bin_x, bin_y, .add=TRUE) %>%
        summarize(count=n()) %>%
        right_join(grid) %>%
        mutate(count=replace_na(count, 0)) %>%
        return()
}

## Given hexagon centers (bin_x, bin_y) and distances
## between adjacent hexagons (xsize, ysize), returns
## a dataframe with all vertices of each hexagon
vertices.hex <- function(grid_idx, bin_x, bin_y, xsize, ysize) {
    if (length(bin_x) != length(bin_y)) stop('x and y must be the same length')

    data.frame(i=1:6) %>%
        mutate(angle_deg=60*i - 30,
               angle_rad=pi/180*angle_deg) %>%
        group_by(i, angle_deg, angle_rad) %>%
        expand(nesting(grid_idx=grid_idx, bin_x=bin_x, bin_y=bin_y)) %>%
        mutate(vx=bin_x+xsize/sqrt(3)*cos(angle_rad),
               vy=bin_y+ysize*2/3*sin(angle_rad)) %>%
        group_by(grid_idx, bin_x, bin_y) %>%
        summarize(vi=list(i), vx=list(vx), vy=list(vy)) %>%
        return()
}

## Create a hexagonal grid over the domain (xmin, xmax) and
## range (ymin, ymax). xsize and ysize are the spacing between
## adjacent hexagons in each row/column.
##
## By default, ysize is set so that all hexagons are regular
grid.hex <- function(df=data.frame(), xmin=-600, xmax=600, xsize=10,
                     ymin=-300, ymax=300, ysize=xsize*sqrt(3)/2,
                     rounded=FALSE, shift_idx=c(FALSE, TRUE)) {
    grid <- grid.rect(df=df, xmin=xmin, xmax=xmax, xsize=xsize,
                      ymin=ymin, ymax=ymax, ysize=ysize)
    shift_rows <- unique(grid$bin_y)[shift_idx]

    ## add in some "missing" hexes on the left side
    if (rounded) {
        grid <- grid %>%
            bind_rows(expand(df, bin_x=xmin-xsize,
                             bin_y=shift_rows) %>%
                      mutate(grid_idx=row_number()+max(grid$grid_idx))) %>%
            arrange(bin_x, bin_y) %>%
            mutate(grid_idx=row_number())
    }

    ## shift every other row and calculate vertices
    grid %>%
        mutate(bin_x=bin_x + xsize/2*(bin_y %in% shift_rows)) %>%
        left_join(., vertices.hex(.$grid_idx, .$bin_x, .$bin_y, xsize, ysize)) %>%
        return()
}

## Calculate the squared euclidean distance between two or more points
dist_sq <- function(x1, y1, x2, y2) {
    return((x1-x2)**2 + (y1-y2)**2)
}

## Create a 2D histogram of df over the grid grid.hex(df, ...)
bin.hex <- function(df, ...) {
    grid <- grid.hex(df, ...)
    g <- grid.hex(ungroup(df), ...)

    df %>%
        rowwise() %>%
        mutate(grid_idx=g$grid_idx[which.min(dist_sq(CURRENT_FIX_X, CURRENT_FIX_Y,
                                                     g$bin_x, g$bin_y))]) %>%
        group_by(grid_idx, .add=TRUE) %>%
        summarize(count=n()) %>%
        right_join(grid) %>%
        mutate(count=replace_na(count, 0)) %>%
        return()
}


library(sqldf)
library(tidyverse)
# run these lines from chronic_illness.Rmd to get data needed
md <- src_sqlite("MelbDatathon2017.sqlite", create=FALSE)
src_tbls(md)

drug_illness <- tbl(md,"ChronicIllness") %>%
  transmute(illness=ChronicIllness, Drug_ID=as.integer(MasterProductID)) %>%
  collect(n=Inf) %>%
  mutate(illness=ifelse(illness=="Chronic Obstructive Pulmonary Disease (COPD)","COPD",illness))

patient_drug <- tbl(md,"Transactions") %>%
  count(Patient_ID, Drug_ID) %>%
  collect(n=Inf)

 patient_illness <- inner_join(ungroup(patient_drug), drug_illness, by="Drug_ID") %>%
  distinct(Patient_ID, illness)

co_illness <- rename(patient_illness, illness1=illness) %>%
  inner_join(rename(patient_illness, illness2=illness), by="Patient_ID") %>%
  count(illness1,illness2) %>% ungroup()

# For each illness estimate the marginal probability of a patient having the illness
# estimate = number of patients with illness / number of patients
illnesses = data.frame(type=unique(drug_illness$illness))
for(i in 1:nrow(illnesses)){
  illnesses$proportion[i] = (patient_illness %>% filter(illness == illnesses$type[i]) %>% nrow())/558352
}

# Assuming independence between illnesses, the joint probability of a patient with two illnesses is the product of marginals.
expected_proportions = illnesses$proportion %*% t(illnesses$proportion)
# Replace the diagonal with the marginals instead of marginals squared.
diag(expected_proportions) = illnesses$proportion
colnames(expected_proportions) = rownames(expected_proportions) = illnesses$type
# Calculate expected number of each pair = probability * number of patients
expected_cases = expected_proportions * 558352

# Add the expected number of patients for each pair of illnesses
co_illness$expected = 0
for(i in 1:nrow(co_illness)){
  co_illness$expected[i] = expected_cases[co_illness$illness1[i], co_illness$illness2[i]]
}

# See which pairs were more likely to co-exist than expected
co_illness$proportion = co_illness$n / co_illness$expected

ggplot(co_illness, aes(x=reorder(illness1,-n), y=reorder(illness2,-n), fill=proportion-1)) +
  geom_tile(color="black") + coord_fixed() +
  scale_fill_viridis(name="Association") +
  theme_minimal() + theme( axis.text.x=element_text(angle=90,vjust=0.5,hjust=1) ) +
  labs(x="",y="")


#x is Input
#n is Factorial Number
multifactorial=function(x,n){
  if(x<=n+1){
    return(x)
  }else{
    return(x*multifactorial(x-n,n))
  }
}


library(R2jags)
library(rstan)
rstan_options(auto_write = TRUE)
options(mc.cores = parallel::detectCores())
library(rjags)
library(mcmcplots)
library(truncnorm)
library(Rlab)
# Load R packages
library(edstan)
library(TAM)

## simulate the fake data
set.seed(93)
J <- 40           # number of multiple choice could take
N <- 5            # number of items in the exam
I <- 500          # number of examees

### SDT part

z = array(NA, c(J,N))    # true answer
for (j in 1:J){
    for (n in 1:N){
      this <- rbern(1,0.5)
      if (this > 0.5){
        z[j,n] <- 1
      }else{
        z[j,n] <- -1
      }
    }
}

lambda = array(NA, c(I,J))
y = array(NA, c(I,J,N))
c = array(NA, c(J,N))
delta = array(NA, c(I,J,N))
p = array(NA, c(I,J,N))

d = rlnorm(J,0,0.5)
theta = rnorm(I,0,1)
b = rnorm(J,0,2)

for (i in 1:I){
  for (j in 1:J){
    lambda[i,j] <- 1 / (1 + exp(b[j] -  theta[i]))
    for (n in 1:N){
      c[j,n] <- rnorm(n=1,(1/2)*d[j]*z[j,n],1)
      p[i,j,n] <- lambda[i,j] * (1 -pnorm(c[j,n] - d[j] * z[j,n],0,1)) + (1 - lambda[i,j]) * (1- pnorm(c[j,n],0,1))
      y[i,j,n] <- rbern(1,p[i,j,n])
    }
  }
}

obs_gpcm= c()

for (i in 1:I){
  for (j in 1:J){
    obs_gpcm =  c(obs_gpcm,as.numeric(sum(as.numeric(z[j,] == 1) == y[i,j,])))
  }
}

stan_data <- irt_data(obs_gpcm = obs_gpcm, ii = rep(1:40,500), jj = rep(1:500,rep(40,500)),I=I,J=J,N=I*J,formula = NULL)
PCM <- irt_stan(sim_pcm_list, model = "PCM.stan.stan",
                        chains = 4, iter = 1000)
#model = stan_model( "PCM.stan")
#stan_data = list("I"=I,"J"=I,"N"=I*J,"obs_gpcm"=obs_gpcm,"ii"=rep(1:40,500),"jj"=rep(1:500,rep(40,500)))
#PCM = rstan::sampling(model_name =model,data=stan_data)
saveRDS(gpcm.fit,'PCM.rds')


# https://r4ds.had.co.nz/tidy-data.html
library(tidyverse)

# which of these is tidy data

table1

table2

table3

table4a

table4b

# tidying when a column names are values of variables

table4a

tidy4a <- table4a %>%
  pivot_longer(c(`1999`, `2000`), names_to = "year", values_to = "cases")
tidy4a

tidy4b <- table4b %>%
  pivot_longer(c(`1999`, `2000`), names_to = "year", values_to = "population")
tidy4b

left_join(tidy4a, tidy4b)

# tidying when observations are accross multiple rows

table2

table2 %>%
  pivot_wider(names_from = type, values_from = count)

# tidying when multiple variables in the same row

table3

table3 %>%
  separate(rate, into = c("cases", "population"), sep = "/")


PD<-rpois(60, lambda = 5)
PD
FPD<-table(PD)

plot(FPD,cex.axis=0.6,xlab="Counts",ylab="Frequency of counts")

WPData<-as.data.frame(warpbreaks)
str(WPData)
summary(WPData)

par(mfrow = c(1, 2))
plot(breaks ~ tension, data = WPData, col = "lightgray",
     varwidth = TRUE, subset = wool == "A", main = "Wool A",ylim=c(8,72))
plot(breaks ~ tension, data = warpbreaks, col = "lightgray",
     varwidth = TRUE, subset = wool == "B", main = "Wool B",ylim=c(8,72))

WPModel1 <- glm(breaks ~ wool+tension, data = WPData, family=poisson)
WPModel1

CoefWP1<-coef(WPModel1)

CoefWP1[2]
exp(CoefWP1[2])

summary(WPModel1)

deviance(WPModel1)/df.residual(WPModel1)

WPModel2<-glm(breaks~wool*tension, data = WPData, family=poisson)
WPModel2
summary(WPModel2)

deviance(WPModel2)/df.residual(WPModel2)


# title: "hw_wk1"
# author: "Yunting Chiu"
# date: "8/28/2020"

# 1. Ans: I discussed with Sihyuan Han.
# 2. Ans: In Case Study 1.2, it has allocated two segments: male and female in the initial stage.
          #Compared to Case study 1.1, it is randomly sampled and not classified at the beginning.

# 3. Using R find numerical and graphical summaries of this data.
#Use these to describe the distribution of the starting salaries for both males and females.

# Libraies and read Data

library(readr)
library(tidyverse)
library(ggplot2)
library(mosaic)

SDE <- read_csv(file = "../data/case0102.csv")
tail(SDE)

# 3a.	Give and interpret the mean salary and standard deviation of salaries for females.
#Do this also for males.
#mean salary of female and male
SDE %>%
  filter(Sex == "Female") -> SDE_Female
mean(SDE_Female$Salary)
SDE %>%
  filter(Sex == "Male") -> SDE_Male
mean(SDE_Male$Salary)

# SD
sd(SDE_Female$Salary)  #SD for Female
sd(SDE_Male$Salary) # SD for Male

# 3b.	Give and interpret the median salary and the IQR of salaries for females.
# Do this also for males.
# find interquartile range of female in R
summary(SDE_Female$Salary)

# find interquartile range of male in R
summary(SDE_Female$Salary)

# 3c.	Give a histogram of salaries for each group.
hist(SDE_Female$Salary)
hist(SDE_Male$Salary)

# 3d.	Give side-by-side boxplots of salaries.
SDE %>%
  ggplot(mapping = aes(x = Sex, y = Salary, fill = Sex))+
  geom_boxplot()+
  theme_bw()

# 3e. Use a. to d. to describe the distribution of salaries for each group.
favstats(Salary ~ Sex, data = SDE)
histogram(~Salary | Sex, data = SDE, col = "red")

# 3f. Ans: Female group’s salaries are larger since the sample size is bigger,
      #but male’s average salaries are larger,
      #because 5956.875 (male’s mean salaries) > 5138.852 (female’s mean salaries)

# 4. Ans: No errors on my R code

# 5. Ans: There are still some other factors we should consider,
    # such as male may have had more years of previous experience.


"%gcd%" <- function(u, v) {
  ifelse(u %% v != 0, v %gcd% (u%%v), v)
}


attach(stanDat)
cAnx <- c(-.5,.5)
b <- 0
gamAnx <- 0
gamSub <- 0
betaAnx <- rep(0,p)
betaSub <- rep(0,p)
alphaAnx <- 0
alphaSub <- 0
anx <- matrix(0,N,nt)
sub <- matrix(0,N,nt)

anxInit <- function(isObsAnx,anxObs,cAnx){
  nt <- ncol(anxObs)
  N <- nrow(anxObs)
  anx <- matrix(rnorm(nt*N,0,1),N,nt)
  anx[isObsAnx==1&anxObs==1] <- cAnx[1]-.2
  anx[isObsAnx==1&anxObs==2] <- mean(cAnx)
  anx[isObsAnx==1&anxObs==3] <- cAnx[2]+.2
  anx
}

subInit <- function(isObsSub,subObs){
  nt <- ncol(subObs)
  N <- nrow(subObs)
  sub <- matrix(rnorm(nt*N,0,1),N,nt)
  sub[isObsSub==1&subObs==0] <- -.5
  sub[isObsSub==1&subObs==1] <- .5
  sub
}

initFun <- function(){
  attach(stanDat)
  on.exit(detach(stanDat))
  anxMod <- polr(ordered(anxObs[,1])~X,method='probit')
  subMod <- glm(subObs[,1]~X,family=binomial('probit'))
  list(
    b=rnorm(1,0,.5),
    gamAnx=rnorm(1,.25,.5),
    gamSub=rnorm(1,.25,.5),
    betaAnx=coef(anxMod),
    betaSub=coef(subMod)[-1],
    #alphaAnx=rnorm(1),
    alphaSub=coef(subMod)[1],
    cAnx=anxMod$zeta,
    anx=anxInit(isObsAnx,anxObs,anxMod$zeta),
    sub=subInit(isObsSub,subObs))
}

iii <- initFun()

attach(iii)

xbAnx <- X%*%betaAnx
xbSub <- X%*%betaSub

etaAnx <- matrix(NA,N,nt)
etaSub <- matrix(NA,N,nt)

  etaAnx[,1]=alphaAnx+xbAnx
etaSub[,1]=alphaSub+xbSub

for(t in 2:nt){
  etaAnx[,t]=alphaAnx+xbAnx+gamAnx*anx[,t-1];
  etaSub[,t]=alphaSub+xbSub+gamSub*sub[,t-1]+b*anx[,t-1];
}
prob <- matrix(1,N,nt)
for(i in 1:N) for(t in 1:12) if(isObsAnx[i,t]==1) prob[i,t] <- min(pnorm(anx[i,t],etaAnx[i,t],1),pnorm(anx[i,t],etaAnx[i,t],1,lower.tail=FALSE))
min(prob)


halve <- function(a) floor(a/2)
double <- function(a) a*2
iseven <- function(a) (a%%2)==0

ethiopicmult <- function(plier, plicand, tutor=FALSE) {
  if (tutor) { cat("ethiopic multiplication of", plier, "and", plicand, "\n") }
  result <- 0
  while(plier >= 1) {
    if (!iseven(plier)) { result <- result + plicand }
    if (tutor) {
      cat(plier, ", ", plicand, " ", ifelse(iseven(plier), "struck", "kept"), "\n", sep="")
    }
    plier <- halve(plier)
    plicand <- double(plicand)
  }
  result
}

print(ethiopicmult(17, 34, TRUE))


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

rm(list = ls())

x <- c(0.01, 0.02, 0.03, 0.01, 0.01, 0.01, 0.02, 0.04,
       0.05, 0.03, 0.02, 0.01, 0.06, 0.01, 0.01, 0.04)

y <- c(0.02, 0.04, 0.03, 0.01, 0.04, 0.06, 0.01, 0.01,
       0.05, 0.01, 0.04, 0.03, 0.04, 0.06, 0.03, 0.01)

(s <- (x - y)[x != y])
# -0.01 -0.02 -0.03 -0.05 0.01 0.03 0.02 -0.02 -0.02 0.02 -0.05 -0.02 0.03

(n <- length(s))
# 13

sum(duplicated(s))
# 5

(V <- sum((s > 0) * rank(abs(s))))
# 30.5

(V.mean <- n * (n + 1) / 4)
# 45.5

(V.var <- n * (n + 1) * (2 * n + 1) / 24)
# 204.75

# Asymptotic pvalue (with continuity correction, without tie correction)
2 * (1 - pnorm(abs(V + 0.5 * sign(V.mean - V) - V.mean) / sqrt(V.var)))
# 0.310896828516612

## Asymptotic pvalue (with continuity correction, with tie correction
# TODO

# Exact pvalue (not valid due to ties)
2 * (1 - psignrank(V - (V.mean < V), n, lower.tail = V.mean < V))
# 0.339599609375

wilcox.test(x, y, paired = TRUE, alternative = "two.sided", exact = FALSE)
# Wilcoxon signed rank test with continuity correction
#
# data:  x and y
# V = 49, p-value = 0.3388
# alternative hypothesis: true location shift is not equal to 0


set.seed(666)

N_0 <- 1000
true.betas <- c(-1, 1, .5, -.5)
P <- 4
X_0 <- matrix(NA, nrow = N_0, ncol = P)
for(i in 1:P) X_0[, i] <- rnorm(N_0)
sy <- 2
y_0 <- rnorm(N_0, mean = X_0%*%true.betas, sd = sy)

as <- .5
bs <- 2
vb <- 1.5

### will draw from the same process for simplicity
N <- 100
X <- matrix(NA, nrow = N, ncol = P)
for(i in 1:P) X[, i] <- rnorm(N)
y <- rnorm(N, mean = X%*%true.betas, sd = sy)

nu <- 1
eta <- 1


# Using arithmetic operators on variables
number1 <- 10
number2 <- 3

# Addition
number1 + number2

# Subtraction
number1 - number2

# Multiplication
number1 * number2

# Exponent
number1 ^ number2

# Modulus
number1 %% number2

# Integer Division
number1 %/% number2

# Using arithmetic operators on vectors
vector1 <- c(5, 10, 15)
vector2 <- c(3, 6, 9)

# Addition
vector1 + vector2

# Subtraction
vector1 - vector2

# Multiplication
vector1 * vector2

# Division
vector1 / vector2

# Exponent
vector1 ^ vector2

# Modulus
vector1 %% vector2

# Integer Division
vector1 %/% vector2

0 - Learn R from scratch/arithmetic_operators.r


# Author: Nikos Kougianos
# Date: 4/12/2020

calculateW2 <- function(x) {
    # We call mean and sd functions outside of loop for performance reasons
    mean <- mean(x)
    s <- sd(x)

    result <- c()

    tmp <- 0

    # Loop vector
    for (i in 1:length(x)) {
        if (abs((i - mean) / s) < 1) {
            tmp = 1
        } else if (abs((i - mean) / s) >= 1 &
                   abs((i - mean) / s) < 2) {
            tmp = 0.5
        } else {
            tmp = 0
        }
        result <- append(result, tmp)
    }

    return(result)

}

calculateW3 <- function(x) {
    mean <- mean(x)
    s <- sd(x)

    tmp = 1 / (s * sqrt(2 * pi))
    result = tmp * exp((-1 / (2 * s ** 2)) * ((x - mean) ** 2))

    return(result)

}

# This function is the solution of the exercise
f <- function(x) {
    # Initialize object to return
    result <- c()

    # Calculate w1
    result[[1]] <- rep(1, length(x))
    # Calculate w2
    result[[2]] <- calculateW2(x)
    # Calculate w3
    result[[3]] <- calculateW3(x)
    return(result)
}

# Call function f with a vector with values from 1 to 50
f(1:50)


rm(list=ls(all=TRUE))

n <- 45
b <- 1
sig_ep <- 1

e <- rnorm(n, mean = 0, sd = sig_ep)

x <- runif(n, min = 0, max = 1)

y <- (b*x) + e

formula <- y~x-1
plot(formula )
abline(lm(formula), col="red")

summary(lm(formula))
anova(lm(formula))
anova(lm(formula))[1,3]


#EXERCISE0
#Operation
X <- 3
Y <- 5
print(x + y)
print(x - y)
print(x * y)
print(x / y)

#Data
varA <- 5
varB <- TRUE
varC <- "string"
class(varA)
class(varB)
class(varC)

#Vector
c(1,2,3,4)

#Operation with Vector
v1 <- (1:5)
v2 <- (1:10)
v1+v2

#Exercise 1
data <- c(10.4, 5.6, 3.1, 6.4, 21.7)

mean(data)
sum(data)
median(data)
sd(data)
var(data)

#Exercise2
# List of Marvel movies (Order by Marvel Phase released)
names <- c("Iron Man","The Incredible Hulk","Iron Man 2","Thor","Captain America: The First Avenger",
           "The Avengers","Iron Man 3","Thor: The Dark World","Captain America: The Winter Soldier",
           "Guardians of the Galaxy","Avengers: Age of Ultron","Ant-Man","Captain America: Civil War",
           "Doctor Strange","Guardians of the Galaxy 2","Spider-Man: Homecoming","Thor: Ragnarok","Black Panther",
           "Avengers: Infinity War","Ant-Man and the Wasp","Captain Marvel","Avengers: Endgame",
           "Spider-Man: Far From Home","WandaVision","Falcon and the Winter Soldier","Loki","Black Widow")

# List of released year of Marvel movies
years <- c(2008,2008,2010,2011,2011,2012,2013,2013,2014,2014,2015,2015,2016,2016,
           2017,2017,2017,2017,2018,2018,2019,2019,2019,2021,2021,2021,2021)

# Or using Function
years <- c(2008,2008,2010,2011,2011,2012,rep(2013:2016,each=2),
           rep(2017,4),rep(2018,2),rep(2019,3),rep(2021,4))

#dataframe_marvel
marvel_movies <- data.frame(names,years)
marvel_movies

#The numbers of movies
length(marvel_movies)

#19th_movies
marvel_movies[19]

#most released movies ans : 2018 , 2021
table(years)


# Calculate sample average
#'
#' @importFrom stats weighted.mean
#'
wtd_mean <- function(x, w = NULL) {
  if (is.null(w)) w <- rep_len(1, length(x))
  weighted.mean(x, w)
}

# Calculate unbiased variance and standard error
#'
#' @importFrom stats sd
#'
wtd_var <- function(x,
                    w = NULL,
                    se = TRUE,
                    bootse = 0L,
                    seed = 120511L) {
  if (is.null(w)) w <- rep_len(1, length(x))
  neff <- sum(w)^2 / sum(w^2)
  wtdmu <- wtd_mean(x, w)
  wtdv <- (sum(w * (x - wtdmu)^2) / sum(w)) * (neff / (neff - 1))

  if (!se) {
    wtdv
  } else {
    if (bootse == 0L) {
      sqrt(wtdv / neff)
    } else {
      set.seed(seed)
      boot_wtdmu <- lapply(seq_len(bootse), function(i) {
        pick <- sample(length(x), size = length(x), replace = TRUE)
        bootx <- x[pick]
        bootw <- w[pick]
        wtd_mean(bootx, bootw)
      })
      sd(unlist(boot_wtdmu))
    }
  }
}

# Perform Two-Sided T-Test/Permutation Test
#'
#' @importFrom stats pt
#'
ttest <- function(y1,
                  y0,
                  w1 = NULL,
                  w0 = NULL,
                  bootse = 0L,
                  bootp = 0L,
                  seed = 120511L) {
  # number of observations
  n1 <- length(y1)
  n0 <- length(y0)

  # weights
  if (is.null(w1)) w1 <- rep_len(1, n1)
  if (is.null(w0)) w0 <- rep_len(1, n0)

  # mean
  mean1 <- wtd_mean(y1, w1)
  mean0 <- wtd_mean(y0, w0)

  # se of mean
  se1 <- wtd_var(y1, w1, bootse = bootse, seed = seed)
  se0 <- wtd_var(y0, w0, bootse = bootse, seed = seed)

  # t-test or permutation test
  if (bootp == 0L) {
    t <- abs(mean1 - mean0) / sqrt(se1^2 + se0^2)
    df <- (se1^2 + se0^2)^2 /
      (se1^4 / (n1 - 1) + se0^4 / (n0 - 1))
    p <- 2 * pt(t, df = df, lower.tail = FALSE)

    data.frame(
      mean1 = mean1,
      se1 = se1,
      n1 = n1,
      mean0 = mean0,
      se0 = se0,
      n0 = n0,
      diff = mean1 - mean0,
      t = t,
      df = df,
      pval = p,
      method = "Welch t-test"
    )
  } else {
    y <- c(y1, y0)
    w <- c(w1, w0)
    d <- rep_len(0, length(y))

    set.seed(seed)
    boot_wtdmu <- lapply(seq_len(bootp), function(i) {
      sim1 <- sample(length(y), size = n1)
      d[sim1] <- 1

      sim_y1 <- y[d == 1]
      sim_y0 <- y[d == 0]
      sim_w1 <- w[d == 1]
      sim_w0 <- w[d == 0]

      sim_mean1 <- wtd_mean(sim_y1, sim_w1)
      sim_mean0 <- wtd_mean(sim_y0, sim_w0)
      sim_mean1 - sim_mean0
    })

    p <- mean(abs(unlist(boot_wtdmu)) >= abs(mean1 - mean0))

    data.frame(
      mean1 = mean1,
      se1 = se1,
      n1 = n1,
      mean0 = mean0,
      se0 = se0,
      n0 = n0,
      diff = mean1 - mean0,
      pval = p,
      method = "Permutation test"
    )
  }

}

# T-test for Multiple Experimental Arms
#'
#' @importFrom dplyr bind_rows
#' @importFrom rlang f_lhs
#'
ttest_multi_arm <- function(baseline = NULL,
                            data = NULL,
                            treat_levels = NULL,
                            treat_labels = NULL,
                            subset = NULL,
                            weights = NULL,
                            bootse = 0L,
                            bootp = 0L,
                            seed = 120511L) {
  # clean data
  use <- clean_RCTdata(
    baseline,
    data = data,
    subset = subset,
    weights = weights,
    treat_levels = treat_levels,
    treat_labels = treat_labels,
  )

  # outcome, treatment, and weight vector
  y <- use$outcome
  d <- use$design[, -1, drop = FALSE]
  w <- use$weights

  # control arms
  ctrl <- as.logical(1 - rowSums(d))
  y0 <- y[ctrl]
  w0 <- w[ctrl]
  res1 <- ttest(y0, y0, w0, w0, bootse, bootp, seed)
  res1$arms <- treat_labels[1]

  # run t-test
  res2 <- apply(d, 2, function(x) {
    treated <- as.logical(x)
    y1 <- y[treated]
    w1 <- w[treated]
    ttest(y1, y0, w1, w0, bootse, bootp, seed)
  })

  bind_res2 <- bind_rows(res2)
  bind_res2$arms <- gsub(all.vars(baseline)[2], "", names(res2))

  bind_res <- bind_rows(res1, bind_res2)
  bind_res$outcome <- all.vars(f_lhs(baseline))
  bind_res$arms <- factor(bind_res$arms, treat_labels)
  bind_res
}

# T-Test for Multiple Experimental Arms and Multiple Outcomes
#'
#' @importFrom rlang enexpr
#' @importFrom dplyr bind_rows
#'
ttest_multi_mod_arm <- function(baseline = NULL,
                                data = NULL,
                                treat_levels = NULL,
                                treat_labels = NULL,
                                ctrl = NULL,
                                subset = NULL,
                                weights = NULL,
                                bootse = 0L,
                                bootp = 0L,
                                seed = 120511L) {
  # list of baseline model
  if (!is.list(baseline)) baseline <- list(baseline)

  # fix order of factor
  treat <- reorder_arms(treat_levels, treat_labels, ctrl)

  # capture expressions
  subset <- enexpr(subset)
  weights <- enexpr(weights)

  # run ttest_multi_arms
  res <- lapply(
    baseline,
    ttest_multi_arm,
    data,
    treat$levels,
    treat$labels,
    subset,
    weights,
    bootse,
    bootp,
    seed
  )

  bind_rows(res)
}


cube <- function(x) x^3
croot <- function(x) x^(1/3)
compose <- function(f, g) function(x){f(g(x))}

f1 <- c(sin, cos, cube)
f2 <- c(asin, acos, croot)

for (i in 1:3) {
	print (compose(f1[[i]], f2[[i]])(.5))
}


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

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

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

boxplot(x1, x2)

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

# QQ-norm plot #

qqplot(x1)
qqline(x1)

qqplot(x2)
qqline(x2)

# Shapiro-Wilk normality test #

shapiro.test(x1)

## 分散分析 ##

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

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

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

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

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

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

## Box-Cox transformation ##

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

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

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

## 多重比較 ##

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

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

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


library(mixtools)

N <- 400

X <- list(
	mvrnorm(100, c(1,1), matrix(c(1,-0.5,-0.5,1),2,2)/4),
	mvrnorm(200, c(3,3), matrix(c(2,0.5,0.5,1),2,2)/4),
	mvrnorm(300, c(5,5), matrix(c(1,-0.5,-0.5,4),2,2)/4))
x <- do.call(rbind,X)


context("Cross-validation")

x <- matrix(runif(50*5), 50, 5)
y <- x[,1] + 0.5*x[,2] + 0.1*runif(50)

## linear regression
regr <- function(x, y, xtest, ytest, reg=0) {
  C =  diag(x=reg, ncol(x))
  beta = solve(t(x) %*% x + C, t(x) %*% y)
  xtest %*% beta
}

## linear regression with own scoring function
regr.score <- function(x, y, xtest, ytest, reg=0) {
  C =  diag(x=reg, ncol(x))
  beta = solve(t(x) %*% x + C, t(x) %*% y)
  sum((xtest %*% beta - ytest)^2)
}

## linear regression with 2 scoring functions
regr.score2 <- function(x, y, xtest, ytest, reg=0) {
  C =  diag(x=reg, ncol(x))
  beta = solve(t(x) %*% x + C, t(x) %*% y)
  yhat = xtest %*% beta
  return( c(
    sqerror  = sum((yhat - ytest)^2),
    abserror = sum(abs(yhat - ytest))
  ))
}

test_that("cv.setup can be created", {
  cv <- cv.setup(x, y, score=mean_se, num_folds = 10, num_iter = 2)
  expect_equal( cv$supervised, TRUE )
  expect_equal( nrow(cv$folds), 50 )
  expect_equal( ncol(cv$folds), 2 )
})

test_that("cv.run works with regression", {
  cv <- cv.setup(x, y, score=mean_se, num_folds = 5, num_iter = 2)
  result <- cv.run(cv, regr)
  expect_equal(ncol(result$scores), cv$num_folds)
  expect_equal(nrow(result$scores), cv$num_iter)
  expect_equal(length(result$score.iter.mean), cv$num_iter)
})

test_that("1-iter cv.run works with regression", {
  cv <- cv.setup(x, y, score=mean_se, num_folds = 5, num_iter = 1)
  result <- cv.run(cv, regr)
  expect_equal(ncol(result$scores), cv$num_folds)
  expect_equal(nrow(result$scores), cv$num_iter)
  expect_equal(length(result$score.iter.mean), cv$num_iter)
})

test_that("cv.run works with regression that has 1 param", {
  cv <- cv.setup(x, y, score=mean_se, num_folds = 5, num_iter = 2)
  ## linear regression + L2 regularization
  result <- cv.run(cv, regr, reg = 2.5)
  expect_equal(ncol(result$scores), cv$num_folds)
  expect_equal(nrow(result$scores), cv$num_iter)
  expect_equal(length(result$score.iter.mean), cv$num_iter)
})

test_that("cv.run and grid_search over lambda",{
  ## linear regression + L2 regularization
  cv <- cv.setup(x, y, score=mean_se, num_folds = 3, num_iter = 2)
  regr.cv <- function(reg) cv.run(cv, regr, reg = reg)$score.mean

  ## optimize
  result <- grid_search(regr.cv, reg=c(0, 1e-2, 1e-1), maximize=FALSE)
  expect_equal(length(result$call_log$values), 3)
  expect_equal(result$stats$num_evals, 3)
})

test_that("cv.run works with multiple score functions", {
  cv <- cv.setup(x, y, score=list(mse=mean_se, mae=mean_ae), num_folds = 3, num_iter = 2)
  result <- cv.run(cv, regr)
  expect_equal(dim(result$scores), c(cv$num_iter, cv$num_folds, length(cv$score)) )
  expect_equal(length(result$score.mean), 2)
  expect_equal(length(result$score.sd), 2)
  expect_equal(dim(result$score.iter.mean), c(cv$num_iter, length(cv$score)) )

  expect_equal(names(result$score.mean), c("mse", "mae"))
})

test_that("cv.run works with user.score", {
  cv <- cv.setup(x, y, score="user.score", num_folds = 3, num_iter = 2)
  result <- cv.run(cv, regr.score)
  expect_equal(result$Nscores, 1)
  expect_equal(nrow(result$scores), cv$num_iter)
  expect_equal(ncol(result$scores), cv$num_folds)
  expect_equal(dim(result$scores)[3], 1)

  expect_equal(length(result$score.mean), 1)
  expect_equal(length(result$score.sd), 1)
  expect_equal(dim(result$score.iter.mean), c(cv$num_iter, length(cv$score)) )
})

test_that("cv.run works with 2 user.score's", {
  cv <- cv.setup(x, y, score="user.score", num_folds = 3, num_iter = 2)
  result <- cv.run(cv, regr.score2)
  expect_equal(result$Nscores, 2)
  expect_equal(nrow(result$scores), cv$num_iter)
  expect_equal(ncol(result$scores), cv$num_folds)
  expect_equal(dim(result$scores)[3], 2)

  expect_equal(length(result$score.mean), 2)
  expect_equal(length(result$score.sd), 2)
  expect_equal(dim(result$score.iter.mean), c(cv$num_iter, 2) )

  expect_equal(names(result$score.mean), c("sqerror", "abserror"))
})


#
# Create example of separable and overlapping distributions for ctmixtures paper
#
library(mixtools)
library(mvtnorm)
library(ggplot2)
library(ggthemes)
library(mmadsenr)
library(MASS)
library(cluster)

p1 <- rmvnorm(1000, c(1000, 200), matrix(c(1000^2, 220^2, 220^2, 60^2),2,2))
p1_df <- as.data.frame(p1)

p4 <- rmvnorm(1000, c(3000, 100), matrix(c(1000^2, 220^2, 220^2, 60^2),2,2))
p4_df <- as.data.frame(p4)

p3 <- rmvnorm(1000, c(2000, 150), matrix(c(1000^2, 220^2, 220^2, 60^2),2,2))
p3_df <- as.data.frame(p3)

data_1_4 <- rbind(p1_df, p4_df)
data_1_4.mat <- as.matrix(data_1_4)

data_1_3 <- rbind(p1_df, p3_df)
data_1_3.mat <- as.matrix(data_1_3)

# Finding the 75% highest density / minimum volume ellipse
fit <- cov.mve(p1, quantile.used = nrow(p1) * 0.95)
ellipse_1 <- predict(ellipsoidhull(p1[fit$best, ]))

fit2 <- cov.mve(p4, quantile.used = nrow(p4) * 0.95)
ellipse_4 <- predict(ellipsoidhull(p4[fit2$best,]))

fit3 <- cov.mve(p3, quantile.used = nrow(p3) * 0.95)
ellipse_3 <- predict(ellipsoidhull(p3[fit2$best,]))

# Plotting it
plot(data_1_4, col = rgb(0, 0, 0, alpha = 0.3))
lines(ellipse_1, col="lightgreen", lwd=3)
lines(ellipse_4, col="lightblue", lwd=3)
legend("topleft", "95%", lty = 1, lwd = 3)

plot(data_1_3, col = rgb(0,0,0,alpha = 0.3))
lines(ellipse_1, col="lightgreen", lwd=3)
lines(ellipse_3, col="lightblue", lwd=3)
legend("topleft", "95%", lty = 1, lwd = 3)


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

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

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

x

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

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

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

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

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

## segundo, encontrar Adjacente

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

solve(t(x)%*%x)

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

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

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

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

data

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


library(VGAM)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

     }

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

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


# Normalización de datos para modelo monetario de tipo de cambio
# 04 de julio de 2016

setwd("~/Documentos/tesina/datos")
rm(list=ls())
graphics.off()

# Leer los datos
library(xlsx)
df = read.xlsx("datosModelo.xlsx", sheetName="datosREG", colIndex = c(1:6), rowIndex = c(1:181))

media = numeric(length = 5)
max = numeric(length = 5)
min = numeric(length = 5)
sd = numeric(length = 5)

# Para cada columna obtener la media, y poner los datos en el rango (-1,1)
for (i in c(1:5)) {
  media[i] = mean(df[,i+1])
  max[i] = max(df[,i+1])
  min[i] = min(df[,i+1])
  sd[i] = sd(df[,i+1])

  # Convertir los datos
  df[,i+1] = (df[,i+1] - media[i]) / sd[i]
}

write.xlsx(df, file="datosNorm.xlsx", sheetName = "datosNORM")
write.xlsx(media, file="datosNorm.xlsx", sheetName = "norm", append = TRUE)
write.xlsx(max, file="datosNorm.xlsx", sheetName = "max", append = TRUE)
write.xlsx(min, file="datosNorm.xlsx", sheetName = "min", append = TRUE)


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

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

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

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

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


setwd("~/Análise de Regressão") # Setando diretório

library(readxl) ## Biblioteca para ler arquivos .xlsx
library(ggplot2) ## gráficos
library(tidyverse) ## caso necessite trabalhar a base de dados
library(ggpubr) ## plotar o modelo de regressão e temas
options(scipen = 999) ## Retirar a notação científica no R
#################################################################################################

## A tabela a seguir mostra a relação entre
#a quilometragem de um carro usado e seu respectivo
#preço de venda.

dados = read_excel("Tabelas.xlsx", col_names = T, sheet = "F") ## importando os dados

View(dados) ## visualizar a base de dados
names(dados) ## variáveis

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

x = dados$`Quilomentagem (1.000 km)` ## objeto X
y = dados$`Preço de venda (Dezena de Euros)` ## objeto Y

########################################################################
## Gráfico para análise a priori
dados %>%
  ggplot(aes(x,y)) +
  geom_point() +
  labs(x = 'Quilometragem (1000 Km)', y = 'Preço de venda (Dezenas de Euros)')

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

cor.test(y, x) ## teste de correlação para provar se há e se é significativa.

result = lm(y ~ x) ## modelo linear

summary(result) ## sumário do modelo

anova(result) ## Análise de variância

confint.lm(result) ## intervalo de confiança com 95% para B0 e B1.

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

## Gráfico final com modelo e reta traçados
dados %>%
  ggplot(aes(x,y)) +
  geom_point() +
  labs(x = 'Quilometragem (1000 Km)', y = 'Preço de venda (Dezenas de euros)') +
  geom_smooth(method = "lm", se = F) +
  stat_regline_equation(aes(x, y), label.x.npc = 0.75) ## label.x.npc (posição da formula em X)


# This program computes and outputs the Bonferroni-p outliers of a time series generated by a linear model of flux
# against a 2nd degree polynomial of time. The input format is a two column .csv (time, flux) and may include
# restrictions on the indices to use to account for jumps in flux.

# The output is placed in a .csv file with two columns (outlier_time, outlier_bonferroniP)

args = commandArgs(trailingOnly=TRUE)
file_in = args[1]
first_index = args[2]
last_index = args[3]
file_out = args[4]

data = read.csv(file_in, header=FALSE)
time = data$V1[first_index:last_index]
flux = data$V2[first_index:last_index]
time_squared = time * time

model = lm(flux ~ time + time_squared)

sink(file_out)
oTest = car::outlierTest(model, label=time)

for(i in 1:length(oTest$bonf.p)) {
	myName = names(oTest$bonf.p[i])
	myValue = unname(oTest$bonf.p[i])
	cat(myName, ",", myValue, "\n", sep="", labels="")
}


library(tidyverse)

# load dataset
trend <- read.csv("https://raw.githubusercontent.com/vera-institute/incarceration-trends/master/incarceration_trends.csv")

# Q1: Across the country, how is the proportion between black jailed population
# and total jailed population changed from 1985 to 2010? Analyze the change rate
# by comparing 1985 data and 2010 data. Store this in `black_jp_change`.
black_1985 <- trend %>%
  group_by(year) %>%
  summarise(bj_pop = sum(black_jail_pop, na.rm = TRUE)) %>%
  filter(year == 1985) %>%
  pull(bj_pop)
total_1985 <- trend %>%
  group_by(year) %>%
  summarise(tj_pop = sum(total_jail_pop, na.rm = TRUE)) %>%
  filter(year == 1985) %>%
  pull(tj_pop)
black_jp_1985 <- black_1985 / total_1985

black_2010 <- trend %>%
  group_by(year) %>%
  summarise(bj_pop = sum(black_jail_pop, na.rm = TRUE)) %>%
  filter(year == 2010) %>%
  pull(bj_pop)
total_2010 <- trend %>%
  group_by(year) %>%
  summarise(tj_pop = sum(total_jail_pop, na.rm = TRUE)) %>%
  filter(year == 2010) %>%
  pull(tj_pop)
black_jp_2010 <- black_2010 / total_2010

black_jp_change <- (black_jp_2010 - black_jp_1985) / black_jp_1985

# Q2: Across the country, how is the proportion between black population and total
# population changed from 1990 to 2010? Analyze the change rate by comparing 1990
# data and 2010 data. Store this in `black_tp_change`.
black_pop_1990 <- trend %>%
  group_by(year) %>%
  summarise(bp_pop = sum(black_pop_15to64, na.rm = TRUE)) %>%
  filter(year == 1990) %>%
  pull(bp_pop)
total_pop_1990 <- trend %>%
  group_by(year) %>%
  summarise(to_pop = sum(total_pop_15to64, na.rm = TRUE)) %>%
  filter(year == 1990) %>%
  pull(to_pop)
black_tp_1990 <- black_pop_1990 / total_pop_1990

black_pop_2010 <- trend %>%
  group_by(year) %>%
  summarise(bp_pop = sum(black_pop_15to64, na.rm = TRUE)) %>%
  filter(year == 2010) %>%
  pull(bp_pop)
total_pop_2010 <- trend %>%
  group_by(year) %>%
  summarise(to_pop = sum(total_pop_15to64, na.rm = TRUE)) %>%
  filter(year == 2010) %>%
  pull(to_pop)
black_tp_2010 <- black_pop_2010 / total_pop_2010

black_tp_change <- (black_tp_2010 - black_tp_1990) / black_tp_1990

# Q3: Across the country, how is the proportion between white jailed population
# and total jailed population changed from 1985 to 2010? Analyze the change rate
# by comparing 1985 data and 2010 data. Store this in `white_jp_change`.
white_1985 <- trend %>%
  group_by(year) %>%
  summarise(wj_pop = sum(white_jail_pop, na.rm = TRUE)) %>%
  filter(year == 1985) %>%
  pull(wj_pop)
white_jp_1985 <- white_1985 / total_1985

white_2010 <- trend %>%
  group_by(year) %>%
  summarise(wj_pop = sum(white_jail_pop, na.rm = TRUE)) %>%
  filter(year == 2010) %>%
  pull(wj_pop)
white_jp_2010 <- white_2010 / total_2010

white_jp_change <- (white_jp_2010 - white_jp_1985) / white_jp_1985

# Q4: Across the country, how is the proportion between white population and total
# population changed from 1990 to 2010? Analyze the change rate by comparing 1990
# data and 2010 data. Store this in `white_tp_change`.
white_pop_1990 <- trend %>%
  group_by(year) %>%
  summarise(wp_pop = sum(white_pop_15to64, na.rm = TRUE)) %>%
  filter(year == 1990) %>%
  pull(wp_pop)
white_tp_1990 <- white_pop_1990 / total_pop_1990

white_pop_2010 <- trend %>%
  group_by(year) %>%
  summarise(wp_pop = sum(white_pop_15to64, na.rm = TRUE)) %>%
  filter(year == 2010) %>%
  pull(wp_pop)
white_tp_2010 <- white_pop_2010 / total_pop_2010

white_tp_change <- (white_tp_2010 - white_tp_1990) / white_tp_1990

# Q5: Recently (in 2010), among these four regions ("Midwest", "Northeast", "South",
# "West"), which region has the highest black jailed population over total jailed
# population proportion? Store this in `high_region`
high_region <- trend %>%
  filter(year == 2010) %>%
  group_by(region) %>%
  summarise(bt = sum(black_jail_pop, na.rm = TRUE) / sum(total_jail_pop, na.rm = TRUE)) %>%
  filter(bt == max(bt)) %>%
  pull(region)

# time trend chart: Plot trend of jailed population proportion in south region over
# past 25 years (1985-2010), for both black and white. Store this in `prop_trend`.
prop_change <- trend %>%
  filter(region == "South") %>%
  filter(year >= 1985 & year <= 2010) %>%
  group_by(year) %>%
  summarise(
    bl_p = sum(black_jail_pop, na.rm = TRUE) / sum(total_pop_15to64, na.rm = TRUE),
    wh_p = sum(white_jail_pop, na.rm = TRUE) / sum(total_pop_15to64, na.rm = TRUE)
  ) %>%
  select(year, bl_p, wh_p)
prop_trend <- ggplot(data = prop_change) +
  geom_line(aes(y = bl_p, x = year, colour = "Black")) +
  geom_line(aes(y = wh_p, x = year, colour = "White")) +
  labs(x = "Year", y = "Proportion", title = "Black vs. White Jailed Proportion, South Region") +
  scale_color_manual(
    name = "line of",
    values = c("Black" = "darkred", "White" = "steelblue")
  )

# variable comparison chart: Plot comparison chart of white jailed population
# (y-axis) vs. total white population (x-axis) at each county. Store this in
# `comparison`.
comparison_data <- trend %>%
  filter(!is.na(white_pop_15to64)) %>%
  filter(!is.na(white_jail_pop)) %>%
  select(white_jail_pop, white_pop_15to64)
comparison <- ggplot(data = comparison_data) +
  aes(y = white_jail_pop, x = white_pop_15to64) +
  geom_point() +
  geom_smooth(method = lm) +
  labs(
    x = "White Total Population", y = "White Jailed Population",
    title = "Jailed Population vs. Total Population, White"
  )

# map: Plot a map to visualize the recent(2010) black jailed population vs.
# total black population proportion in each state; Store this in `prop_map`.
state_info <- map_data("state")
state_info <- mutate(state_info, region = state.abb[match(region, tolower(state.name))])
prop_for_map <- trend %>%
  filter(year == 2010) %>%
  group_by(state) %>%
  summarise(bl_prop = sum(black_jail_pop, na.rm = TRUE) / sum(black_pop_15to64, na.rm = TRUE)) %>%
  select(state, bl_prop)
state_bl_prop <- inner_join(state_info, prop_for_map, by = c("region" = "state"))
prop_map <- ggplot() +
  geom_polygon(
    data = state_bl_prop,
    aes(x = long, y = lat, group = group, fill = bl_prop),
    color = "white"
  ) +
  scale_fill_continuous(
    name = "proportion",
    breaks = seq(0, max(prop_for_map$bl_prop), 0.004)
  ) +
  labs(
    x = "longtitude", y = "latitude",
    title = "jailed population / total population in each state, black"
  ) +
  theme_minimal()


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

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

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

  ##dependencies
  #dplyr
  #tidyr

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

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

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

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

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

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

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

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

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

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

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

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

  return(df_all_estimates)
}