cache <- vector("integer", 0)
cache[1] <- 1
cache[2] <- 1

Q <- function(n) {
  if (is.na(cache[n])) {
    value <- Q(n-Q(n-1)) + Q(n-Q(n-2))
    cache[n] <<- value
  }
  cache[n]
}

for (i in 1:1e5) {
  Q(i)
}

for (i in 1:10) {
  cat(Q(i)," ",sep = "")
}
cat("\n")
cat(Q(1000),"\n")

count <- 0
for (i in 2:1e5) {
  if (Q(i) < Q(i-1)) count <- count + 1
}
cat(count,"terms is less than its preceding term\n")


# Ternary Diagram // треугольные диаграммы
# ЧАСТЬ 1: вчитываем таблицу. делаем data.frame. удаляем NA
MDF <- read.csv("Morphology.csv", header=TRUE, sep = ",")
MDF <- na.omit(MDF)
row.has.na <- apply(MDF, 1, function(x){any(is.na(x))})
sum(row.has.na)
head(MDF)

MDTt = melt(setDT(MDF), measure = patterns("^plate"), value.name = c("tectonics"))
head(MDTt)
levels(MDTt$variable) = c("Philippine" , "Pacific", "Mariana", "Caroline")
Plates<- c("Philippine" , "Pacific", "Mariana", "Caroline")

# ЧАСТЬ 2: чертим треугольную диаграмму Марианского желоба пакетом ggtern
library(ggtern)

# вариант-1. по тектонике (4 плиты)
MDTer <- data.frame(
			x = MDTt$igneous_volc,
			y = MDTt$tectonics,
			z = MDTt$slope_angle,
			Value = MDTt$slope_angle,
			Group = as.factor(MDTt$variable))

MT1<- ggtern(data= MDTer,aes(x,y,z,color = Group)) +
	theme_rgbw() +
	geom_point() +
#	geom_path() +
	scale_color_manual(values = c("green" , "red", "orange", "blue")) +
	labs(x="Igneous \nVolcanos",y="Tectonics",z="Slope \nAngle",
  		title="Mariana Trench",
  		subtitle="Ternary Diagram: Tectonic Plates") +
  geom_Tline(Tintercept=.5,arrow=arrow(), colour='red') +
  geom_Lline(Lintercept=.2, colour='magenta') +
  geom_Rline(Rintercept=.1, colour='blue') +
  geom_confidence_tern()
MT1

# вариант-2. по классам морфология

levels(MDTt$morph_class) = c("Strong Slope", "Very Strong Slope", "Steep Slope", "Extreme Slope")
MDTM <- data.frame(
			x = MDTt$Min,
			y = MDTt$aspect_degree,
			z = MDTt$slope_angle,
			Value = MDTt$slope_angle,
			Group = as.factor(MDTt$morph_class))

MT2<- ggtern(data= MDTM,aes(x,y,z,color=Group), show.legend=TRUE) +
	theme_rgbw() +
	geom_point() +
	geom_path() +
	labs(x="Max \nDepth",y="Aspect Degree",z="Slope\nAngle",
  		title="Mariana Trench",
  		subtitle="Ternary Diagram: Slope Morphology Class") +
  geom_Tline(Tintercept=.5,arrow=arrow(), colour='red') +
  geom_Lline(Lintercept=.2, colour='magenta') +
  geom_Rline(Rintercept=.1, colour='blue') +
  geom_confidence_tern() +
  geom_Tisoprop(value=0.5) +
  geom_Lisoprop(value=0.5) +
  geom_Risoprop(value=0.5)
MT2

# вариант-3 по аспекту - разворот угла
MDTAs <- data.frame(
			x = MDTt$slope_angle,
			y = MDTt$aspect_degree,
			z = MDTt$Min,
			Value = MDTt$aspect_degree,
			Group = as.factor(MDTt$aspect_class))

MT3<- ggtern(data = MDTAs,aes(x,y,z,color = Group)) +
	theme_rgbw() +
	geom_point() +
	scale_color_manual(values = c("green", "red", "orange", "blue", "yellow" , "brown", "grey", "cyan")) +
	labs(x="Slope \nAngle", size = 1, y="Aspect \nDegree", z="Max \nDepth",
  		title="Mariana Trench",
  		subtitle="Ternary Diagram: Aspect Class") +
  geom_Tline(Tintercept=.5,arrow=arrow(), colour='red') +
  geom_Lline(Lintercept=.2, colour='magenta') +
  geom_Rline(Rintercept=.1, colour='blue') +
  geom_confidence_tern() +
  geom_Tisoprop(value=0.5) +
  geom_Lisoprop(value=0.5) +
  geom_Risoprop(value=0.5)
MT3

plot<- grid.arrange(MT1, MT2, MT3, newpage = TRUE, nrow = 1, ncol = 3, top="Mariana Trench")

# вариант-4. по толщине мор. отложений / седиментология
MD4 <- data.frame(
			x = MDTt$igneous_volc,
			y = MDTt$sedim_thick,
			z = MDTt$slope_angle,
			Value = MDTt$slope_angle)

MT4<- ggtern(data = MD4,aes(x,y,z), show.legend=TRUE) +
	theme_rgbw() +
	geom_point() +
#	geom_path(alpha = .5, lwd = 0.2) +
	labs(x="Igneous \nVolcanos", size = 0.5,y="Sedimental \nThickness",z="Slope \nAngle",
  		title="Mariana Trench",
  		subtitle="Ternary Diagram: Sedimental Thickness") +
  geom_Tline(Tintercept=.5,arrow=arrow(), colour='deeppink') +
  geom_Lline(Lintercept=.2, colour='magenta') +
  geom_Rline(Rintercept=.1, colour='springgreen') +
  geom_confidence_tern() +
  geom_smooth_tern(method = 'loess', size = .4, color = "yellow1") +
  geom_mean_ellipse (size = .5, color = "cyan")
MT4

figure <-plot_grid(MT1, MT2, MT3, MT4, labels = c("1", "2", "3", "4"), ncol = 2, nrow = 2)


## function to create titre and efficacy profiles

draw <- function(mu_ab_d1 = mu_ab_d1, mu_ab_d2 = mu_ab_d2, mu_ab_d3, std10 = std10, ab_50 = ab_50, ab_50_severe,
                 dr_s = dr_s, dr_l = dr_l, period_s = period_s, t = t, t_d2 = t_d2, t_d3, k = k){

  # decay rates over time
  ## simple biphasic decay on natural log scale

  denom=log(exp(dr_l*period_s)+exp(dr_s*period_s))
  cum_dr_vec=log(exp(dr_s*t+dr_l*period_s)+exp(dr_l*t+dr_s*period_s))-denom
  dr_vec=c(0,diff(cum_dr_vec,1))

 # dr_vec_sub <- c(rep(dr_s, round(period_s)-1),
 #                 seq(dr_s, dr_l, length.out = round(t_period_l)-round(period_s)+1),
 #                 rep(dr_l, length(t) - round(t_period_l)))

 # dr_vec <- rep(0, length(t))
 # dr_vec[2:t_d2] <- dr_vec_sub[1:(t_d2-1)]
 # dr_vec[(2+t_d2):(t_d3+t_d2)] <- dr_vec_sub[1:((t_d3+t_d2)-(t_d2+1))]
 # dr_vec[(2+t_d2+t_d3):length(t)] <- dr_vec_sub[1:(length(t) - (t_d2+t_d3+1)) ]

  # nab titre distribution for a given vaccine product: draw from a log-normal distribution
  # here the first titre is dependent on the second but I suppose could do it the other way around

  z2 <- rnorm(1, log10(mu_ab_d2), std10)
  z3 <- log10(10^z2 * (mu_ab_d3/mu_ab_d2))
  z1 <- log10(10^z2 * (mu_ab_d1/mu_ab_d2))

  # initiate titre vector
  nt <- rep(0, length(t))
  nt[1] <- log(10^z1)
  nt[t_d2+1] <- log(10^z2)
  nt[t_d2+t_d3+1] <- log(10^z3)

  # decay antibodies over time on natural log scale
  for (i in (2:t_d2)){
    nt[i] <- nt[i-1] + dr_vec[i]
  }
  for (i in ((t_d2+2):(t_d2+t_d3))){
    nt[i] <- nt[i-1] + dr_vec[i-t_d2-1]
  }
  for (i in ((t_d2+t_d3+2):length(t))){
    nt[i] <- nt[i-1] + dr_vec[i-t_d3-1]
  }

  nt <- exp(nt) # return to linear scale

  # relate titre to efficacy over time - using log-10 parameters
  ef_infection <- 1 / (1 + exp(-k * (log10(nt) - log10(ab_50))))
  ef_severe <- 1 / (1 + exp(-k * (log10(nt) - log10(ab_50_severe))))

  # output list containing titre and vaccine efficacy
  ret <- list(titre = nt, VE = ef_infection, VE_severe = ef_severe)
  return(ret)
}

0_antibody_model_fitting/Plotting and Table Code/R/create_profile.r


stdin <- file("stdin")
open(stdin)

invisible(readLines(stdin, n = 1, warn = FALSE)) # Consumes line to ignore `n`
v <- as.integer(strsplit(trimws(
  readLines(stdin, n = 1, warn = FALSE), which = "both"), " ")[[1]])
f <- as.integer(strsplit(trimws(
  readLines(stdin, n = 1, warn = FALSE), which = "both"), " ")[[1]])

close(stdin)

quartiles <- function(x) {
  y <- sort(x)
  if (length(y) %% 2 == 0) {
    return(c(
      median(y[1:(length(y) / 2)]),
      median(y),
      median(y[(length(y) / 2 + 1):length(y)])
    ))
  } else {
    return(c(
      median(y[1:(length(y) / 2)]),
      median(y),
      median(y[(length(y) / 2 + 1):length(y) + 1])
    ))
  }
}
inter_quartile <- function(v, f) {
  s <- c()
  for (i in seq_len(length(v))) {
    s <- c(s, rep(v[i], f[i]))
  }
  q <- quartiles(s)
  return(q[3] - q[1])
}
cat(sprintf("%.1f", inter_quartile(v, f)), "\n")


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

data <- read.csv('data.csv', header = TRUE)

# y1 and y5 are cointegrated

y1 <- data$y1
y5 <- data$y5

v1 <- cbind(y1, y5)
colnames(v1) <- cbind('y1', 'y5')

Model1 <- VAR(v1, p = 1, type = "const", season = NULL, exog = NULL)
summary(Model1)

# y2 and y3 are cointegrated

y2 <- data$y2
y3 <- data$y3

v2 <- cbind(y2, y3)
colnames(v2) <- cbind('y2', 'y3')

Model2 <- VAR(v2, p = 1, type = "const", season = NULL, exog = NULL)
summary(Model2)

# y4 and y10 are cointegrated

y4 <- data$y4
y10 <- data$y10

v3 <- cbind(y4, y10)
colnames(v3) <- cbind('y4', 'y10')

Model3 <- VAR(v3, p = 1, type = "const", season = NULL, exog = NULL)
summary(Model3)

# y6 and y10 are cointegrated

y6 <- data$y6
y9 <- data$y9

v4 <- cbind(y6, y9)
colnames(v4) <- cbind('y6', 'y9')

Model4 <- VAR(v4, p = 1, type = "const", season = NULL, exog = NULL)
summary(Model4)

# y1 = y1.l1 + y5.l1 + const
# y1.l1 = -0.066, y5.l1 = 0.481, const = 0.476

# y5 = y1.l1 + y5.l1 + const
# y1.l1 = -0.058, y5.l1 = 0.473, const = 0.056

# y1(t) = y1.l1 * y1(t-1) + y5.l1 * y2(t-1) + const
# y2(t) = y1.l1 * y1(t-1) + y5.l1 * y2(t-1) + const

#### HERE WE BUILD VAR MODEL FOR COINTEGRATED TIME SERIES Y1 and Y5

minX <- 1
maxX <- 290
xPointsForDates <- minX:maxX
l11 <- -0.066
l12 <- 0.481
c1 <- 0.476
l21 <- -0.058
l22 <- 0.473
c2 <- 0.056

y1_var = c(y1[300])
y5_var = c(y5[300])

index <- 2

for (i in (minX + 1):(maxX)) {
  y1_var[index] = l11 * y1_var[index - 1] + l12 * y5_var[index - 1] + c1
  y5_var[index] = l21 * y1_var[index - 1] + l22 * y5_var[index - 1] + c2
  index = index + 1
}

pdfName <- 'y1_and_y5_var_model.pdf'
# Open a pdf file
pdf(pdfName)
# Create a plot
plot(x = xPointsForDates, y = y1_var,
     type='l',
     pch = 16, frame = FALSE,
     xlab = '290 additional dates (after 300 previous ones)', ylab = 'y', col = '#2E9FDF')
lines(x = xPointsForDates, y = y5_var, col = '#Df2E7E', pch = 16)
# Close the pdf file
dev.off()
# Print that PDF is generated
print(sprintf('PDF %s with charts for VAR Model (y1 and y5) is generated', pdfName))

pngName <- 'y1_and_y5_var_model.png'
# Open a pdf file
png(pngName)
# Create a plot
plot(x = xPointsForDates, y = y1_var,
     type='l',
     pch = 16, frame = FALSE,
     xlab = '290 additional dates (after 300 previous ones)', ylab = 'y', col = '#2E9FDF')
lines(x = xPointsForDates, y = y5_var, col = '#Df2E7E', pch = 16)
# Close the pdf file
dev.off()
# Print that PDF is generated
print(sprintf('PNG %s with charts for VAR Model (y1 and y5) is generated', pdfName))

#### HERE WE BUILD VAR MODEL FOR COINTEGRATED TIME SERIES Y2 and Y3

minX <- 1
maxX <- 290
xPointsForDates <- minX:maxX
l11 <- -0.313
l12 <- 3.503
c1 <- 3.417
l21 <- -0.272
l22 <- 3.492
c2 <- 0.229

y2_var = c(y2[300])
y3_var = c(y3[300])

index <- 2

for (i in (minX + 1):(maxX)) {
  y2_var[index] = l11 * y2_var[index - 1] + l12 * y3_var[index - 1] + c1
  y3_var[index] = l21 * y2_var[index - 1] + l22 * y3_var[index - 1] + c2
  index = index + 1
}

pdfName <- 'y2_and_y3_var_model.pdf'
# Open a pdf file
pdf(pdfName)
# Create a plot
plot(x = xPointsForDates, y = y2_var,
     type='l',
     pch = 16, frame = FALSE,
     xlab = '290 additional dates (after 300 previous ones)', ylab = 'y', col = '#2E9FDF')
lines(x = xPointsForDates, y = y3_var, col = '#Df2E7E', pch = 16)
# Close the pdf file
dev.off()
# Print that PDF is generated
print(sprintf('PDF %s with charts for VAR Model (y2 and y3) is generated', pdfName))

#### LET'S COMPARE WITH NOT COINTEGRATED Y1 and Y6

minX <- 1
maxX <- 290
xPointsForDates <- minX:maxX
l11 <- 157.317
l12 <- -3.957
c1 <- 3.452
l21 <- 2.398
l22 <- 161.639
c2 <- 0.243

y1_var = c(y1[300])
y6_var = c(y6[300])

index <- 2

for (i in (minX + 1):(maxX)) {
  y1_var[index] = l11 * y1_var[index - 1] + l12 * y6_var[index - 1] + c1
  y6_var[index] = l21 * y1_var[index - 1] + l22 * y6_var[index - 1] + c2
  index = index + 1
}

pdfName <- 'y1_and_y6_var_model.pdf'
# Open a pdf file
pdf(pdfName)
# Create a plot
plot(x = xPointsForDates, y = y1_var,
     type='l',
     pch = 16, frame = FALSE,
     xlab = '290 additional dates (after 300 previous ones)', ylab = 'y', col = '#2E9FDF')
lines(x = xPointsForDates, y = y6_var, col = '#Df2E7E', pch = 16)
# Close the pdf file
dev.off()
# Print that PDF is generated
print(sprintf('PDF %s with charts for VAR Model (y1 and y6) is generated', pdfName))


funkSVD <- function(R, k, lr = 0.01, reg = 0.5, miter = 2) {
	global_mean <- mean(as.matrix(R), na.rm = TRUE)
	bu <- rep(0, nrow(R))
	bi <- rep(0, ncol(R))
	P <- matrix(0.1, nrow = nrow(R), ncol = k)
	Q <- matrix(0.1, nrow = ncol(R), ncol = k)
	K <- which(!is.na(R), arr.ind = TRUE)
	for(f in sample(k)) {
		for(l in 1:miter) {
			for(j in 1:nrow(K)){
      			u <- K[j,1]
      			i <- K[j,2]
      			r_ui <- R[u,i]
      			if(!is.na(r_ui)){
         			pred <- global_mean + bu[u] + bi[i] + P[u, ] %*% Q[i, ]
         			e_ui <- r_ui - pred
					bu[u] <- bu[u] + lr * e_ui
					bi[i] <- bi[i] + lr * e_ui
         			temp_uf <- P[u,f]
         			P[u,f] <- P[u,f] + lr * (e_ui * Q[i,f] - reg * P[u,f])
			       	Q[i,f] <- Q[i,f] + lr * (e_ui * temp_uf - reg * Q[i,f])
      			}
   			}
		}
	}
	return(list(bu = bu, bi = bi, P = P, Q = Q))
}


###############################################################################
# "Infection Rate Models for COVID-19:
#  Model Risk and Public Health News Sentiment Exposure Adjustments"
#
#  Ioannis Chalkiadakis, Kevin Hongxuan Yan, Gareth W. Peters, Pavel V. Shevchenko
#
#  Kevin Hongxuan Yan
#  March 2021
###############################################################################

rm(list=ls(all=TRUE))

library(methods)
library(rstan)

cat("Stan version:", stan_version(), "\n")
stanmodelcode <- "

#### define GP function
functions {

real normal_generalized_poisson_log(int y, real theta, real lambda, real sigob) {
    return (log(theta)
           + (y - 1) * log(theta + y * lambda)
           - lgamma(y + 1)
           - y * lambda
           - theta)*(y<=200)
           +(normal_lpdf(y|theta,sigob))*(y>200);
		  ## +log(1-normal_cdf(0.08*u,u,0.01))*(b0>0.08*u)
		  ## +log(normal_cdf((0.515+0.125*u),u,0.01))*(b2>(0.515+0.125*u));    #### +log(b0>0.08*u); (b0>0.08*u)
  }

}

#### define our data, integer value
data {
int<lower=0> N;
int y[N];
real E[N];
}

#### define parameters
parameters {

real lambda;
real u;
real b0;
real b1;
real b2;
real<lower=0> sig2;
vector[N] e;
real sigob;
}

#### define some parameters which is the function of other parameters
transformed parameters {
vector[N] mu;

### define the mean function
#mu[1] <- exp(u*exp(-b0)+e[1]);

mu[1] <- y[1];  ## not tested

  for (n in 2:N) {

      mu[n] <- mu[n-1]*exp(u*exp(-b0*n)+b1*(mu[n-1]^b2)+e[n]);

	  }

}

##### define piror and likelihood function
model {
lambda~uniform(-1,1);
u ~ normal(0.13,0.1);
b0 ~ normal(0.025,0.01);
b1 ~ normal(-0.00000006,0.00000001);
b2 ~ normal(0.1,0.1);
sig2 ~  gamma(1,1);
e~normal(0,sig2);
sigob ~ uniform(100,1100);

for (j in 1:N) {

y[j] ~ normal_generalized_poisson( mu[j]*E[j], lambda, sigob);
}

}

#### calculate DIC
generated quantities {
vector[N] log_lik;
real dev; // deviance

  for (n in 1:N){
    log_lik[n] <- normal_generalized_poisson_log (y[n],mu[n]*E[n], lambda, sigob);
  }

  dev <- 0;
        for ( n in 1:N ) {
            dev <- dev + (-2) * normal_generalized_poisson_log (y[n],mu[n]*E[n], lambda, sigob);
        }

}

"

######

####### read new data Y
setwd("./covid19modelrisk/data/covid19_infected")

  y=read.csv("COVID-19_confirmed__Germany.csv")
##  y=read.csv("COVID-19_confirmed__Italy.csv")
##  y=read.csv("COVID-19_confirmed__Japan.csv")
##  y=read.csv("COVID-19_confirmed__Spain.csv")
##  y=read.csv("COVID-19_confirmed__United Kingdom.csv")
##  y=read.csv("COVID-19_confirmed__US.csv")
##  y=read.csv("COVID-19_confirmed_Australia.csv")

y=y[,2]

E=rep(1,length(y))

N=length(y)
dat <- list(N = N, y = y,E=E)

#### initial values
inits =list(list(lambda=0,u=0.1,b0=0.025,b1=-0.00000006, b2=0.1,sig2=0.0005,e=rep(0.01,N),sigob=1000),
list(lambda=0,u=0.2,b0=0.025,b1=-0.00000006, b2=0.1,sig2=0.0005,e=rep(0.01,N),sigob=1000),
list(lambda=0,u=0.15,b0=0.025,b1=-0.00000006, b2=0.1,sig2=0.0005,e=rep(0.01,N),sigob=1000),
list(lambda=0,u=0.25,b0=0.025,b1=-0.00000006, b2=0.1,sig2=0.0005,e=rep(0.01,N),sigob=1000),
list(lambda=0,u=0.2,b0=0.05,b1=-0.00000006, b2=0.1,sig2=0.0005,e=rep(0.01,N),sigob=1000),
list(lambda=0,u=0.2,b0=0.01,b1=-0.00000006, b2=0.1,sig2=0.0005,e=rep(0.01,N),sigob=1000),
list(lambda=0,u=0.2,b0=0.01,b1=-0.0000001, b2=0.1,sig2=0.0005,e=rep(0.01,N),sigob=1000),
list(lambda=0,u=0.2,b0=0.01,b1=-0.00000001, b2=0.1,sig2=0.0005,e=rep(0.01,N),sigob=1000))

fit <- stan(model_code = stanmodelcode, model_name = "example",init =inits,
data = dat, warmup=10000,iter = 100000, chains = 8, seed=999,thin=1)
print(fit,digits = 4)

####################  trace plot

library(methods)
library(rstan)

name=c("Germany","Italy","Japan","Spain","U.K.","U.S.","Australia")
abn=c("GM","IT","JP","SP","UK","US","AU")

k=1

pdf(paste("M8_",abn[k],"_p1.pdf",sep=""), width = 16.5, height = 8.50)

traceplot(fit, pars=c("u","b0","b1","b2"), inc_warmup = T,  nrow = 4, ncol = 1, window = NULL, include = TRUE)

dev.off()

pdf(paste("M8_",abn[k],"_p2.pdf",sep=""), width = 16.5, height = 8.50)

traceplot(fit, pars=c("sigob","sig2","lambda"), inc_warmup = T,  nrow = 3, ncol = 1, window = NULL, include = TRUE)
dev.off()

##################   plot 30/45/60/   length(y)

Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(8+N):(7+2*N)] , 2 , mean )

Epars_5 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(8+N):(7+2*N)] , 2 , quantile, probs=0.05 )

Epars_9 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(8+N):(7+2*N)] , 2 , quantile, probs=0.95 )

pdf(paste("M8_",abn[k],"_30.pdf",sep=""), width = 16.5, height = 8.50)

m=30

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),lwd = 2)

dev.off()

pdf(paste("M8_",abn[k],"_45.pdf",sep=""), width = 16.5, height = 8.50)

m=45

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),lwd = 2)

dev.off()

pdf(paste("M8_",abn[k],"_60.pdf",sep=""), width = 16.5, height = 8.50)

m=60

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),lwd = 2)

dev.off()

pdf(paste("M8_",abn[k],"_all.pdf",sep=""), width = 16.5, height = 8.50)

m=length(y)

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),lwd = 2)

dev.off()

########    log plot          ####################################################

k=1

name=c("Germany","Italy","Japan","Spain","U.K.","U.S.","Australia")
abn=c("GM","IT","JP","SP","UK","US","AU")

Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(8+N):(7+2*N)] , 2 , mean )

Epars_5 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(8+N):(7+2*N)] , 2 , quantile, probs=0.05 )

Epars_9 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(8+N):(7+2*N)] , 2 , quantile, probs=0.95 )

y=log(y)
Epars_m=log(Epars_m)
Epars_9=log(Epars_9)
Epars_5=log(Epars_5)

setwd("./covid19modelrisk/output/plot")

pdf(paste("M8_",abn[k],"_log.pdf",sep=""), width = 16.5, height = 8.50)

m=length(y)

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M8 model for ",name[k],sep=""),lwd = 2)

dev.off()

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

mean(y)
median(y)

n=length(y)

u=0.13
b0=0.025
b1=-0.00000006
b2=0.1

x=c()
x[1]=100
for (i in 1:(n-1) ){

x[i+1]=x[i]*exp(u*exp(-b0*i)+b1*(x[i]^b2))
}
x=round(x)
x

plot(y,ylim=c(min(y,x),max(y,x)))
par(new=TRUE)
plot(x,col="red",ylim=c(min(y,x),max(y,x)))

#############################################################
##### GM

u=0.2
b0=0.025
b1=-0.00000006
b2=0.1

##### IT

u=0.2
b0=0.025
b1=-0.00000006
b2=0.1

##### JP

u=0.15
b0=0.025
b1=-0.00000006
b2=0.1

##### SP

u=0.2
b0=0.025
b1=-0.00000006
b2=0.1

##### UK

u=0.2
b0=0.025
b1=-0.00000006
b2=0.1

##### US

u=0.27
b0=0.025
b1=-0.00000006
b2=0.1

##### AU

u=0.13
b0=0.025
b1=-0.00000006
b2=0.1


#' Rotation of polygon
#' @param mat Two-column numeric matrix. Coordinates of the polygon.
#' @param origin Numeric vector of length two. Origin.
#' @param alpha Numeric scalar. Rotation degree in radians.
#' @export
rotate <- function(mat, origin, alpha) {
  R <- matrix(
    c(cos(alpha), -sin(alpha), sin(alpha), cos(alpha)),
    nrow = 2, byrow = TRUE)

  origin <- matrix(c(origin[1], origin[2]), ncol=2, nrow = nrow(mat), byrow = TRUE)
  t(R %*% t(mat - origin)) + origin
}


 F02EKJ Example Program Results

Iteration Limit=  500
 Arnoldi basis vectors used:  20
 The following Ritz values (mu) are related to the
 true eigenvalues (lambda) by lambda = sigma + 1/mu

 Iteration number    1
 Ritz values converged so far (   2) and their Ritz estimates:
     1 (  5.69917E-01,  8.80810E-01)   1.30081E-20
     2 (  5.69917E-01, -8.80810E-01)   1.30081E-20
 Next (unconverged) Ritz value:
     3 (  6.07774E-01,  0.00000E+00)

 The    5 Ritz values of closest to   5.50000E+00 are:
        1     (   6.01781E+00 ,  -8.00277E-01 )
        2     (   6.01781E+00 ,   8.00277E-01 )
        3     (   4.34309E+00 ,  -1.94557E+00 )
        4     (   4.34309E+00 ,   1.94557E+00 )
        5     (   7.14535E+00 ,   0.00000E+00 )


#' K-Means++ initialization to K-means
#'
#' INPUTS:
#' x: The data formatted as a matrix.
#' k: The number of clusters desired. \code{k < nrows(x)}
#'
#'
#' REFERENCE:
#' Arthur, David and Vassilvitskii, Sergei k-means++: The Advantages of Careful Seeding
#'

kmpp <- function(x,k=2){

la2 <- function(a,b){
        m1 <- matrix(as.numeric(a),nrow=dim(b)[1],ncol=dim(b)[2], byrow=TRUE)

        if(all(dim(m1) == dim(b))){
            dif <- apply((m1-b)^2,1,sum)
        return(dif)
        } else {
            stop("Wrong dimensions!")}
        }

### Step 1a
#set.seed(2^13)
s1 <- cp <- sample(nrow(x),1)

ind <- c(cp)

centers <- list()

centers[[1]] <- x[s1,]

p <- la2(x[s1,],x)
P <- p/sum(p) ## P = D(x')^2/( ∑_x\inX  D(x)^2)

### Step 1b-c
for( i in 2:k ) {
    #set.seed(2^13)
    cp <- sample(nrow(x),1,prob=P) ## c'
    centers[[i]] <-x[cp,]
    ind <- c(ind,cp)

    p <- apply(cbind(la2(x[cp,],x),p),1,min) #apply(cbind(p,ds[,cp]),1,min)
    P <- p/sum(p)
    }

Ctrs <- Reduce('rbind',centers)

kObj <- kmeans(x, centers=Ctrs)

return(kObj)
} ### END FUNCTION

bhkmpp <- function(x,blevels){
    require(data.table)

    k0 <- kmpp(x,2)
    L <- data.table(lv1=k0$cluster)

    for(y in 2:blevels){ L[[y]] <- 0L }
    colnames(L) <- paste0("lv", 1:blevels)

    for(j in 1:(blevels-1)){
    for(i in sort(unique(L[[j]]))){
        ## Set seed to keep cluster labels somewhat consistant
        set.seed(13)
        kv <- kmpp(x[L[[j]] == i,], k = 2)
        if(i != 1){kv$cluster <- as.integer(kv$cluster + 2*(i-1))}
        L[L[[j]]==i,][[j+1]] <- kv$cluster
        }
    }
    return(L)
}


multiplier <- function(n1,n2) { (function(m){n1*n2*m}) }
x  = 2.0
xi = 0.5
y  = 4.0
yi = 0.25
z  = x + y
zi = 1.0 / ( x + y )
num = c(x,y,z)
inv = c(xi,yi,zi)

multiplier(num,inv)(0.5)

Output
[1] 0.5 0.5 0.5


tb_lech_saiso <- function(x) {
    cat("tb: ", mean(x), "\n")
    # tinh do lech tieu chuan
    cat("lech tieu chuan: ", sd(x), "\n")
    # tinh
    cat("sai so chuan: ", sd(x)/sqrt(length(x)), "\n")
}

func_6_1 <- function() {
    x <- c(1, 2, 5, 7, -3, 0, 5, 1, 5, 6)
    y <- c(2, 2, 0, -5, 7, 8, 11, 9, 3, 2)
    cat("x + y: ", x + y, "\n")
    cat("x * y: ", x * y, "\n")
    cat("x - y: ", x - y, "\n")
    # z phan chan cua x
    z <- c()
    for (i in x) {
        if (i%%2 == 0) {
            z <- c(z, i)
        }
    }
    cat("z: ", z, "\n")
    # t phan le cua y
    t <- c()
    for (i in y) {
        if (i%%2 == 0) {
            t <- c(t, i)
        }
    }
    cat("t: ", t, "\n")
    # w lon hon 0
    w <- c()
    for (i in x) {
        if (i > 0) {
            w <- c(w, i)
        }
    }
    for (i in y) {
        if (i > 0) {
            w <- c(w, i)
        }
    }
    cat("w: ", w, "\n")
    # tb, lech, sai so
    cat("x: \n")
    tb_lech_saiso(x)
    cat("min: ", min(x), " max: ", max(x), "\n")
    cat("tang dan: ", sort(x), "\n")
    cat("y: \n")
    tb_lech_saiso(y)
    cat("min: ", min(y), " max: ", max(y), "\n")
    cat("giam dan", sort(y, decreasing = T), "\n")
}


## Set up and plot hypothetical paths of productivity process

## Set up scenarios
# Each scenario has ID, theta, lambda, phi, gR, R0, A0
scenario <- c('A','B','C','D','E')
theta <- c(.01,.01,.01,.01,.01)
lambda <- c(1,1,1,1,.8)
phi <- c(0,.8,-.8,0,0)
gR <- c(.02,.02,.01,.04,.02)
R0 <- c(1,1,2,1,1)
A0 <- c(1,10,1,.9,10)
label <- c('C','B','D','E','A') # allows different label for test purposes

# Year vector gives total periods to run over
year <- c(0:400)
s <- 0 # initializes vector

# Merge year and scenario data to create scenario/year dataframe
all_scenario <- data.frame(scenario,theta,lambda,phi,gR,R0,A0,label) # combine scenario parameters
year_scenario <- expand.grid(year,scenario) # create year/scenario combinations
names(year_scenario) <- c("year","scenario")
s <- merge(year_scenario,all_scenario,by="scenario") # add parameters to year/scenario combos

# Make calculations of various values using theory
# z is A^1-phi/R^lambda state variable, solved for first, then extract info
s$conv <- 1-s$lambda*s$gR
s$z <- (s$conv^s$year)*(s$A0^(1-s$phi))/(s$R0^(s$lambda)) + (1-s$conv^s$year)*(1-s$phi)*s$theta/(s$lambda*s$gR)
s$RA <- 1/s$z # put this in R/A form
s$gA <- s$theta/s$z # growth rate of A follows directly
s$R <- s$R0*(1+s$gR)^(s$year) # constant growth of R
s$lnA <- log(s$z)/(1-s$phi) + s$lambda*log(s$R)/(1-s$phi) # actual log of productivity

# Plot figure of scenarios and their BGP's
fig <- plot_ly(s, x = ~year, y = ~lnA, linetype = ~scenario, type = 'scatter', mode = 'lines')
#fig <- add_trace(fig, x = ~year, y = ~lnystar, linetype = ~scenario, type = 'scatter', mode = 'lines')
fig <- layout(fig, title = list(text = 'Log productivity', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Log of productivity (A)'),
              hovermode="x unified")
#api_create(fig, filename = "sim-prod-lnA")

fig <- plot_ly(s, x = ~year, y = ~gA, linetype = ~scenario, type = 'scatter', mode = 'lines')
fig <- layout(fig, title = list(text = 'Growth rate of productivity', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Growth rate of productivity'),
              hovermode="x unified")
#api_create(fig, filename = "sim-prod-gA")

fig <- plot_ly(s, x = ~year, y = ~z, linetype = ~scenario, type = 'scatter', mode = 'lines')
fig <- layout(fig, title = list(text = 'R/A ratio', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'R/A ratio'),
              hovermode="x unified")
#api_create(fig, filename = "sim-prod-RA")


#number of trials
n<-1000
#  the probability of success of single event  is
z<-0.001
Mean<-n*z
print(Mean)
 # Applying the Poisson probability distribution with U= 1

U<-1
# probability that none of a  patients administered the drug experiences a particular side effect

y<-0
probability_nopatientsideeffect<-((U^y)*(exp(1)^-U))/factorial(y)
print(probability_nopatientsideeffect)


x = (0:10)
> x^2
 [1]   0   1   4   9  16  25  36  49  64  81 100
> Reduce(function(y,z){return (y+z)},x)
[1] 55
> x[x[(0:length(x))] %% 2==0]
[1]  0  2  4  6  8 10


## See Paul T von Hippel, The American Statistician 58:160-164, 2004

mvector <- c(0,0)
msigma <- matrix(c(1,0.5,0.5,1), nrow=2)
library(mvtnorm)
library(Hmisc)

# XZ <- rmvnorm(1000, mvector, msigma)
mvrnorm <- function(n, p = 1, u = rep(0, p), S = diag(p)) {
  Z <- matrix(rnorm(n * p), p, n)
  t(u + t(chol(S)) %*% Z)
}

XZ <- mvrnorm(1000, 2, mvector, msigma)

U <- rnorm(1000)
Y <- XZ[,1]+XZ[,2]+U
summary(lm(Y ~ XZ))
X <- XZ[,1]
Z <- XZ[,2]
Z.ni <- Z

type <- c('random','X<0','Y<0','Z<0')[3]
i <- switch(type,
            random= runif(1000) < .5,
            'X<0' = X<0,
            'Y<0' = Y<0,
            'Z<0' = Z<0)

Zna <- Z
Zna[i] <- NA
summary(lm(Y ~ X + Zna))

#w <- aregImpute(~monotone(Y)+monotone(X)+monotone(Zna))
#w <- aregImpute(~I(Y)+I(X)+I(Zna),fweight=.75)
w <- aregImpute(~monotone(Y)+monotone(X)+monotone(Zna), n.impute=5,
                type='regression')

plot(w)
Ecdf(Zna, add=T, col='red')
Ecdf(Z, add=T, col='green')
# plot(w$imputed$Zna, Z[is.na(Zna)])  # use if n.impute=1
# abline(a=0,b=1,lty=2)
# lm(Z[is.na(Zna)] ~ w$imputed$Zna)

coef(fit.mult.impute(Y~X+Zna, lm, w, data=data.frame(X,Zna,Y),pr=F))

#--------------------------------------------------------------------
## From Ewout Steyerberg
# Missing values: illustrate MCAR, MAR, MNAR mechanism
# linear models
library(rms)

## 1. x1 and x2 with y1 outcome
## A) X only
## B) X+Y

#########################
### Test Imputation ###
### use aregImpute in default settings
#########################

n <- 20000                                      # arbitrary sample size
x2  <- rnorm(n=n, mean=0, sd=1)               # x2 standard normal
x1   <- sqrt(.5) * x2 + rnorm(n=n, mean=0, sd=sqrt(1-.5))  # x2 correlated with x1
y1   <- 1 * x1 + 1 * x2 + rnorm(n=n, mean=0, sd=sqrt(1-0)) # generate y
# var of y1 larger with correlated x1 - x2

x1MCAR   <- ifelse(runif(n) < .5, x1, NA)          # MCAR mechanism for 50% of x1
x1MARx   <- ifelse(rnorm(n=n,sd=.8) < x2, x1, NA)  # MAR on x2, R2 50%, 50% missing (since mean x2==0)
x1MARy   <- ifelse(rnorm(n=n,sd=(sqrt(3)*.8)) >y1, x1, NA) # MAR on y, R2 50%, 50% missing (since mean y1==0)
# x1MNAR   <- ifelse(rnorm(n=n,sd=.8) < x1, x1, NA)  # MNAR on x1, R2 50%, 50% missing (since mean x1==0)
x1MNAR   <- ifelse(rnorm(n=n,sd=.8) < x1, x1, NA)  # MNAR on x1, R2 50%, 50% missing (since mean x1==0)

plot(x2, x1MARx)
plsmo(x2, is.na(x1MARx), datadensity=TRUE)
dd <- datadist(x2,x1MARx)
options(datadist='dd')
f <- lrm(is.na(x1MARx) ~ rcs(x2,4))
plot(Predict(f, x2, fun=plogis))

d <- data.frame(y1,x1,x2,x1MCAR, x1MARx,x1MARy,x1MNAR)
ols(y1~x1+x2)
ols(y1 ~ x1MARx + x2)

# MAR on x: 3 approaches; CC, MI with X, MI with X+Y

g <- aregImpute(~I(y1) + I(x1MARx) + I(x2), n.impute=5, data=d, pr=F,
    type=c('pmm','regression')[1], match='closest', plotTrans=TRUE)
plot(g)
Ecdf(x1,     add=TRUE, col='red',q=.5)
Ecdf(x1MARx, add=TRUE, col='blue',q=.5)

f <- fit.mult.impute(y1 ~ x1MARx + x2, ols, xtrans=g, data=d, pr=F)
g <- aregImpute(~y1 + x1MARx + x2, n.impute=5, data=d, pr=F, type='regression', plotTrans=TRUE)
f <- fit.mult.impute(y1 ~ x1MARx + x2, ols, xtrans=g, data=d, pr=F)

# MAR on y: 3 approaches; CC, MI with X, MI with X+Y
f  <- ols(y1~x1MARy+x2)
if(FALSE) {
Mat.imputation[i,29:32] <- c(coef(f)[2:3], sqrt(diag(vcov(f)))[2:3])
g <- aregImpute(~x1MARy + x2, n.impute=5, data=d, pr=F, type='regression')
f <- fit.mult.impute(y1 ~ x1MARy + x2, ols, xtrans=g, data=d, pr=F)
Mat.imputation[i,33:36] <- c(coef(f)[2:3], sqrt(diag(vcov(f)))[2:3])
g <- aregImpute(~y1 + x1MARy + x2, n.impute=5, data=d, pr=F, type='regression')
f <- fit.mult.impute(y1 ~ x1MARy + x2, ols, xtrans=g, data=d, pr=F)
Mat.imputation[i,37:40] <- c(coef(f)[2:3], sqrt(diag(vcov(f)))[2:3])
}


###############################################################
#
# WindPlume - an R script to conduct Monte Carlo analyses
# with a simple atmospheric dispersion model
#
###############################################################

### definitions ###

options(stringsAsFactors = FALSE)

library(reshape)

require(compiler)
enableJIT(3)

#setwd("C:/Users/wmcnab/Desktop/fall 2016 projects/air dispersion R")
setwd("D:/fall 2016 projects/air dispersion R")

WindVector <- function(intense_bin, orient_bin, orient, compass) {

  # posit wind velocity magnitude
  if (intense_bin == "CALM") {
    v_min <- 0.0
    v_max <- 0.5
    }
  else if (intense_bin == ">46") {
    v_min <- 46.
    v_max <- 46.
    }
  else {
    bounds <- strsplit(intense_bin, "-")[[1]]
    v_min <- as.numeric(bounds[1]) - 0.5
    v_max <- as.numeric(bounds[2]) + 0.5
    }
  v <- runif(1, v_min, v_max) * 0.447  # convert MPH to m/sec

  # posit wind direction (origin)
  if (orient_bin != "CALM"){
    delin <- match(orient_bin, orient)
    angle_center <- compass[delin]
    angle_min <- angle_center - 22.5/2.
    angle_max <- angle_center + 22.5/2.
    }
  else {
    angle_min <- 0.
    angle_max <- 360.
    }
  angle <- runif(1, angle_min, angle_max)
  if (angle < 0.) {angle <- 360. + angle}

  return (c(v, angle*pi/180.))                 # convert angle to radians
}

Stability <- function(v, day_f, stability){

  # assign atmospheric stability class

  if (v<2) {row <- 1}                 # wind velocity magnitude component
  else if (v>=2 & v<3) {row <- 2}
  else if (v>=3 & v<4) {row <- 3}
  else if (v>=4 & v<6) {row <- 4}
  else {row <- 5}

  if (day_f <= 0.5) {col <- 1}        # solar irradiation component
  else {col <- 2}

  return (stability[row, col])
}

Dispersion <- function(x, stable_class){

  # assign transverse and vertical dispersion coefficients (standard terrain)

  switch(stable_class,
    A = {
      sigma_y <- 0.22*x / sqrt(1.0 + 0.0001*x)
      sigma_z <- 0.2*x
      },
    B = {
      sigma_y <- 0.16*x / sqrt(1.0 + 0.0001*x)
      sigma_z <- 0.12*x
      },
    C = {
      sigma_y <- 0.11*x / sqrt(1.0 + 0.0001*x)
      sigma_z <- 0.08*x / sqrt(1.0 + 0.0002*x)
      },
    D = {
      sigma_y <- 0.08*x / sqrt(1.0 + 0.0001*x)
      sigma_z <- 0.06*x / sqrt(1.0 + 0.0015*x)
      },
    E = {
      sigma_y <- 0.06*x / (1.0 + 0.0001*x)
      sigma_z <- 0.03*x / (1.0 + 0.0003*x)
      },
    F_ = {
      sigma_y <- 0.04*x / (1.0 + 0.0001*x)
      sigma_z <- 0.016*x / (1.0 + 0.0003*x)
      }

    )

  return (c(sigma_y, sigma_z))

}

Rotate <- function(x, y, theta) {

  # rotate coordinate system about theta
  x_prime <- x*cos(theta) - y*sin(theta)
  y_prime <- x*sin(theta) + y*cos(theta)

  return (c(x_prime, y_prime))

  }

C <- function(x, y, z, u, H, flux, stable_class) {

  # calculate time-integrated concentration at x, y, z

  if (x > 0) {
    sigma <- Dispersion(x, stable_class)
    sigma_y = sigma[1]
    sigma_z = sigma[2]
    f <- exp(-(y**2./(2.*sigma_y**2)))
    g1 <- exp(-((z - H)**2./(2.*sigma_z**2)))
    g2 <- exp(-((z + H)**2./(2.*sigma_z**2)))
    conc <- flux/u * f/(sigma_y*sqrt(2.*pi)) * (g1 + g2)/(sigma_z*sqrt(2.*pi))
    }
  else
    {conc <- 0.}

  return (conc)

  }

WindPlume <- function(){

  ### this is the main function of this script; specifies parameter sets, reads data, calls other functions, writes output

  # basic parameters
  num_trials <- 10000
  d_min <- 5.
  d_max <- 60.
  H <- 5.
  z <- 2.
  Q <- 2.
  log_avg_C0 <- 1.0
  log_stdev_C0 <- 0.3

  # define working parameter sets
  compass <- c(90., 67.5, 45., 22.5, 0., 337.5, 315., 292.5, 270., 247.5, 225., 202.5, 180., 157.5, 135., 112.5, 0.)
  stability_table <- matrix(c("A", "B", "F_", "A", "C", "E", "B", "C", "D", "C", "D", "D", "C", "D", "D"),
                      nrow=5, ncol=3, byrow = TRUE)

  # read in meteorology data
  wind_df <- read.csv(file="wind.txt", sep="\t", header=TRUE)

  # record bin labels for velocity ranges and direction
  orient <- colnames(wind_df)[-1]
  intense <- wind_df[,1]

  # set up wind bins lookup table
  wind_bins_df <- melt(wind_df)
  colnames(wind_bins_df) <- c("intensity", "direction", "freq")
  wind_bins_df$direction <- as.character(wind_bins_df$direction)
  wind_bins_df <- subset(wind_bins_df, freq > 0.)
  wind_bins_df$cumul <- cumsum(wind_bins_df$freq)
  rownames(wind_bins_df) <- NULL

  # posit source term vector
  log_C0 <- rnorm(num_trials, log_avg_C0, log_stdev_C0)
  C0 <- 10.**log_C0
  flux <- Q * C0

  # posit receptor location vectors
  d <- runif(num_trials, d_min, d_max)
  psi <- runif(num_trials, 0., 2.*pi)
  x <- d * cos(psi)
  y <- d * sin(psi)

  # create (empty) data frame to hold model results, one row per trial
  results_df <- data.frame("C0" = double(num_trials),
                  "x" = double(num_trials),
                  "y" = double(num_trials),
                  "w_origin" = character(num_trials),
                  "theta" = double(num_trials),
                  "v" = double(num_trials),
                  "s_class" = character(num_trials),
                  "conc" = double(num_trials),
                  stringsAsFactors=FALSE)

  # generate trials

  for (i in 1:num_trials){

    # select random numbers to choose wind vector and solar irradiation conditions
    r <- runif(1, 0., 1.)
    day_f <- runif(1, 0., 1.)
    floor <- ifelse(r > wind_bins_df$cumul, 1, 0)
    bins_index <- sum(floor) + 1
    bins_index <- min(nrow(wind_bins_df), bins_index)

    # posit meteorology
    wvector <- WindVector(wind_bins_df$intensity[bins_index], wind_bins_df$direction[bins_index], orient, compass)
    v <- wvector[1]
    theta <- wvector[2]
    if (theta>pi) {theta_point <- theta - pi}    # point theta 180 degrees away for orientation of local positive x-axis
    else {theta_point <- theta + pi}
    rot_pt <- Rotate(x[i], y[i], -theta_point)
    x_prime <- rot_pt[1]
    y_prime <- rot_pt[2]
    s <- Stability(v, day_f, stability_table)

    # run Gaussian plume model
    conc <- C(x_prime, y_prime, z, v, H, flux[i], s)

    # append results to data frame
    wind_dir <- wind_bins_df$direction[bins_index]
    results_df[i, ] <- c(C0[i], x[i], y[i], wind_dir, theta, v, s, conc)

    }

  write.csv(results_df, file = "results.csv")

}

# run the air dispersion script

ptm <- proc.time()
WindPlume()
print (proc.time() - ptm)

# process results ...
num_trials <- 10000
d_min <- 5.
d_max <- 60.
H <- 5.
z <- 2.
Q <- 2.
log_avg_C0 <- 1.0
log_stdev_C0 <- 0.3
model <- read.csv(file="results.csv", sep=",", header=TRUE)
C0 = 10.**log_avg_C0
count_steps <- c(0.01, 0.001, 0.0001, 1e-5, 1e-6)
num_bins = length(count_steps) + 1

# pie graph to summarize exposure probability
count_bin <- double(num_bins)
count_bin[1] <- sum(ifelse(model$conc>=count_steps[1]*C0, 1, 0))
for (i in 2:(num_bins-1)) {
  count_bin[i] <- sum(ifelse(model$conc>=count_steps[i]*C0, 1, 0)) - count_bin[i-1]
  }
count_bin[num_bins] <- num_trials - count_bin[num_bins-1]
lbls <- c(">0.01", "0.001 - 0.01", "0.0001 - 0.001", "0.00001 - 0.0001", "0.000001 - 0.00001", "<0.000001")
pct <- round(count_bin/num_trials*100)
lbls <- paste(lbls, pct) # add percents to labels
lbls <- paste(lbls,"%",sep="") # ad % to labels
pie(count_bin,labels = lbls, col=rainbow(length(lbls)),
    main="Normalized Conc Exposures")

# augment model results data frame with concentration bin designation (for plotting)
model$bin <- ifelse(model$conc>=count_steps[1]*C0, 1, 0)
for (i in 2:(num_bins-1)) {
  model$bin <- model$bin + ifelse((model$conc>=count_steps[i]*C0) & (model$conc<count_steps[i-1]*C0), i, 0)
}
model$bin <- model$bin + ifelse(model$conc<count_steps[num_bins-1]*C0, num_bins, 0)
write.csv(model, file = "model.csv")

print ("Done.")


tanimoto <- function(resource_x, resource_y) {
  # The Tanimoto similarity computes the sum of shared elements in vectors resource_x and resource_y and divides this by the length of the longest vector
  # If either length of resource_x or resource_y == 0, similarity == 0
  # The order of vectors consumer_x or consumer_y has no importance, as long as elements in vectors are unique

  # !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  # The same funcion is apparently used for trait similarity, including phylogeny
  # !!! There are NAs in the taxonomy that need to be taken into account, which is not the case at the moment !!!
  # !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    if(length(resource_x) == 0 || length(resource_y) == 0) {
        return(0.0)
    } else if(resource_x == "" || resource_y == "") {
        return(0.0)
    } else {
        inter <- length(resource_y[match(resource_x, resource_y, nomatch = 0)])
        return(inter / ((length(resource_x) + length(resource_y)) - inter))
    }#if
}#end tanimoto function


install.packages(c("gplots","plm", "lmtest", "zoo", "tseries"))

library(gplots)

library(plm)

library(tseries)

library(zoo)

library(lmtest)

path = "https://raw.githubusercontent.com/mogollonalex/Panel_Data_R/main/data.csv"
datos <-read.table(path,  header=TRUE, sep=",", na.strings="NA", dec=".", strip.white=TRUE)
datos

# Heterogeneidad
plotmeans(IDHr ~ COD, main="Heterogeneidad entre países", data=datos)

plotmeans(IDHr ~ YEAR, main="Heterogeneidad a lo largo de los años", data=datos)#Testing for unit roots/stationarity |||| If p-value < 0.05 then no unit roots present
Panel.set <- plm.data(datos, index = c("COD", "YEAR"))
IDHr <-Panel.set$IDHr
adf.test(IDHr, k=2)

#Testing for unit roots/stationarity |||| If p-value < 0.05 then no unit roots present
Panel.set <- plm.data(datos, index = c("COD", "YEAR"))
INBpc <-Panel.set$INBpc
adf.test(INBpc, k=2)

#Testing for unit roots/stationarity |||| If p-value < 0.05 then no unit roots present
Panel.set <- plm.data(datos, index = c("COD", "YEAR"))
IGINICEPAL<-Panel.set$IGINICEPAL
adf.test(IGINICEPAL, k=2)

#Testing for unit roots/stationarity |||| If p-value < 0.05 then no unit roots present
Panel.set <- plm.data(datos, index = c("COD", "YEAR"))
GasSocial <-Panel.set$GasSocial
adf.test(GasSocial, k=2)

#Testing for unit roots/stationarity |||| If p-value < 0.05 then no unit roots present
Panel.set <- plm.data(datos, index = c("COD", "YEAR"))
VOZYREND <-Panel.set$VOZYREND
adf.test(VOZYREND, k=2)

### within
fixed <- plm(IDHr ~ IGINICEPAL+INBpc+GasSocial+VOZYREND,
         data=datos, index=c("COD", "YEAR"), model="within")
summary(fixed)

### random
library(plm)
random <-plm(IDHr ~ IGINICEPAL+INBpc+GasSocial+VOZYREND,
 data=datos, index=c("COD", "YEAR"), model="random")
summary(random)

################# Elegir el modelo
### Fixed or Random: Hausman test |||| If p-value > 0.05, then use random effects
phtest(fixed, random)

################# Robusto
summary(random, robust = TRUE)

# Test de normalidad de residuos
residuos=residuals(random)
residuos
#jarqueberaTest(residuos)
jarque.bera.test(residuos)

# stationarity residuals
#Testing for unit roots/stationarity |||| If p-value < 0.05 then no unit roots present
adf.test(residuos, k=2)

### Testing for serial correlation |||| If p-value > 0.05, No serial correlation
pbgtest(random)

### Testing for heteroskedasticity |||| If p-value > 0.05, No Presence of heteroskedasticity
# If hetersokedaticity is detected you can use robust covariance matrix to account for it. See the following pages.
library(lmtest)
bptest(IDHr ~ IGINICEPAL+INBpc+GasSocial+VOZYREND + factor(COD), data = datos, studentize=F)

# Heteroskedasticity consistent coefficients (Arellano)   Corrección
coeftest(fixed, vcovHC(fixed, method = "arellano"))


model_netradiationequivalentevaporation <- function (lambdaV = 2.454,
         netRadiation = 1.566){
    #'- Name: NetRadiationEquivalentEvaporation -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: NetRadiationEquivalentEvaporation Model
    #'            * Author: Pierre Martre
    #'            * Reference: Modelling energy balance in the wheat crop model SiriusQuality2:
    #'            Evapotranspiration and canopy and soil temperature calculations
    #'            * Institution: INRA/LEPSE Montpellier
    #'            * ExtendedDescription:  It is given by dividing net radiation by latent heat of vaporization of water
    #'            * ShortDescription: It is given by dividing net radiation by latent heat of vaporization of water
    #'- inputs:
    #'            * name: lambdaV
    #'                          ** description : latent heat of vaporization of water
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 2.454
    #'                          ** min : 0
    #'                          ** max : 10
    #'                          ** unit : MJ kg-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: netRadiation
    #'                          ** description : net radiation
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** default : 1.566
    #'                          ** min : 0
    #'                          ** max : 5000
    #'                          ** unit : MJ m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'- outputs:
    #'            * name: netRadiationEquivalentEvaporation
    #'                          ** variablecategory : auxiliary
    #'                          ** description : net Radiation in Equivalent Evaporation
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 5000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    netRadiationEquivalentEvaporation <- netRadiation / lambdaV * 1000.0
    return (list('netRadiationEquivalentEvaporation' = netRadiationEquivalentEvaporation))
}


# ************************************************
### simon munzert
### panel data II
# ************************************************

source("packages.r")
source("functions.r")

## CRAN Task View on econometrics (including panel data models)
browseURL("https://cran.r-project.org/web/views/Econometrics.html")

# ************************************************
# Example: Comparative Political Dataset ---------

dat <- read_dta("../data/CPDS-1960-2015.dta")
dat <- dplyr::select(dat, year, country, iso, gov_left2, socexp_t_pmp, instcons, unemp, eu)
head(dat)

# ************************************************
# Panel data econometrics with R: the plm package

library(plm)

# inspect dimensionality
pdim(dat, index = c("iso", "year"))

# panel data estimators
plm() # plm can do (amongst others):
  # pooling:           --> model = "pooling" (same as lm())
  # fixed effects:     --> model = "within"
  # random effects:    --> model = "random"
  # first differences: --> model = "fd"

# various tests
mtest() # Arellano-Bond test of serial correlation
pbgtest() # Breusch-Godfrey test
pdwtest () # Durbin-Watson test
phtest() # Hausman test
plmtest() # Lagrange multiplier tests
purtest() # Unit root tests

# extract fixed effects
fixef()

# make data balanced
make.pbalanced()

# extract indices of panel data
indices <- index(model_fe)
table(indices$iso, indices$year)

# for more information, see
browseURL("https://cran.r-project.org/web/packages/plm/vignettes/plm.pdf")

# ************************************************
# Implementing the Fixed-Effects estimator -------

# pooled OLS
summary(model_pooled <- lm(socexp_t_pmp ~ gov_left2 + instcons  + unemp, data = dat))
hist(dat$gov_left2)
# interplot(model_pooled, var1 = "gov_left2", var2 = "instcons")
# interplot(model_pooled, var1 = "gov_left2", var2 = "unemp")

# pooled OLS with plm
summary(model_pooled_plm <- plm(socexp_t_pmp ~ gov_left2 + instcons  + unemp, data = dat, index = c("iso", "year"), model = "pooling"))

# fixed-effects estimator, manually
summary(model_fe <- lm(socexp_t_pmp ~ gov_left2 + instcons  + unemp + iso, data = dat))

# fixed-effects estimator with plm
summary(model_fe_plm <- plm(socexp_t_pmp ~ gov_left2 + instcons + unemp, data = dat, index = c("iso", "year"), model = "within"))

# F test for fixed effects
pFtest(model_fe_plm, model_pooled_plm) # F test FE vs pooling model

# ************************************************
# How do fixed effects look like? ----------------

# visualize fixed effects
fixed_effects <- c(coef(model_fe)[1],
                   coef(model_fe)[1] + coef(model_fe)[5:(length(coef(model_fe)))])
fe_dat <- data.frame(iso = unique(model_fe$model$iso),
                     fixed_effect = fixed_effects)

# we could've had this easier...
fixef(model_fe_plm)

# plot fixed effects
ggplot(fe_dat, aes(x = reorder(iso, fixed_effect), y = fixed_effect)) + geom_bar(stat = "identity") + labs(x = "")

# compute raw means
dat_sum <- group_by(dat, iso) %>% summarize(n_obs = n(),
                                            mean_socexp = mean(socexp_t_pmp, na.rm = T))

# merge model fixed effects with raw means: don't confuse fixed effects with "normal levels" or something - they simply account for unobserved constant effects, i.e. the portion of y in i that is not explained by the other, time-varying covariates and that is unit-constant across time
fe_dat <- merge(fe_dat, dat_sum, by = "iso", all.x = TRUE)
plot(fe_dat$fixed_effect, fe_dat$mean_socexp)
text(fe_dat$fixed_effect, fe_dat$mean_socexp, fe_dat$iso)

# ******************************************************
# LSDV/FE estimation: Is demeaning and introducing
# unit dummies really equivalent?

set.seed(1)
x = rnorm(100)
fe = rep(rnorm(10), each = 10)
id = rep(1:10,each = 10)
ti = rep(1:10, 10)
e = rnorm(100)
y = x + fe + e
dat_sim = data.frame(y, x, id, ti)

# standard FE model
reg_fe = plm(y ~ x, model = "within", index = c("id", "ti"), data = dat_sim)
summary(reg_fe)

# FE model using demeaning
y_dem = y - tapply(y, id, mean)[id]
x_dem = x - tapply(x, id, mean)[id]

reg_dem = lm(y_dem ~ -1 + x_dem) # note that we do not estimate the intercept because we have demeaned the data
summary(reg_dem) # note that the standard error is wrong. We would need to account for that we are losing degrees of freedom by taking out the fixed effects.

# ******************************************************
# What about time-fixed effects?

  # would pick up variation in the outcome that occurs over time and is not attributed to other explanatory variables
  # --> capture the influence of aggregate (time-series) trends
  # could help you deal with heteroskedasticity

# fixed-effects estimator with plm
summary(model_fe_time <- plm(socexp_t_pmp ~ gov_left2 + instcons + gov_left2 + unemp + as.factor(year), data = dat, index = c("iso", "year"), model = "within"))

# test for the need of time-fixed effects
pFtest(model_fe_time, model_fe_plm)

# Breusch-Pagan test for heteroskedasticity across time
plmtest(model_fe_plm, effect = c("time"), type = ("bp"))

# ************************************************
# Implementing the Random-Effects estimator ------

summary(model_re_plm <- plm(socexp_t_pmp ~ gov_left2 + instcons + unemp, data = dat, index = c("iso", "year"), model = "random"))

format(coef(model_fe_plm), scientific = FALSE)
format(coef(model_re_plm), scientific = FALSE)

# Hausman test
phtest(model_fe_plm, model_re_plm)

# ************************************************
# Using Panel-Corrected Standard Errors (PCSEs) --

# Beck and Katz 1995:
  # TSCS data, such as country panels, often tackled with models that do not account properly for complex error structures (autocorrelation, heteroskedasticity - it's a mess!)
  # finding: frequently applied FGLS produces dramatically inaccurate coefficient standard errors
  # PCSE estimator suggested

# pooled OLS

# extract complete cases
dat_sub <- dplyr::select(dat, socexp_t_pmp, gov_left2, instcons, unemp, iso, year)
dat_sub <- dat_sub[complete.cases(dat_sub),]

# run OLS
summary(model_pooled <- lm(socexp_t_pmp ~ gov_left2 + instcons + unemp, data = dat_sub))

# panel-corrected standard errors
model_pcse <- pcse(model_pooled, groupN = dat_sub$iso, groupT = dat_sub$year)
summary(model_pcse)

# pcse() cannot be applied on plm objects - there is another solution:
summary(model_pooled <- plm(socexp_t_pmp ~ gov_left2 + instcons + unemp, data = dat_sub, index = c("iso", "year"), model = "pooling"))
plm2 <- coeftest(model_pooled, vcov=function(x) vcovBK(x, type = "HC1", cluster = "time"))
plm2


# split plot ANOVA

class <- read.table('class.txt',header=T,as.is=T)

# convert group variables to factors
class$class.f <- as.factor(class$class)
class$method.f <- as.factor(class$method)
class$tutor.f <- as.factor(class$tutor)

# aov has more helper functions, but it only works correctly for
#  balanced data

class.aov <- aov(score~method.f*tutor.f+Error(method.f:class.f),data=class)

# aov complains that error is singular,
#  but results seem to be correct

# the * generates main effects and all interactions (SAS's |)
# the : generates interaction (SAS's *)

# fixed effects go in the usual place
# random effects go in the Error() function.
#  need to specifically indicate that class and method are related
#  'all combinations of method and class', i.e. method.f:class.f does this

# if you replace Error(method.f:class.f) with Error(class.f)
#   Method is tested against the error MS, not the class MS

# helper functions include:

model.tables(class.aov,type='means')
# marginal means and cell means

model.tables(class.aov,type='means',se=T)
# if you try to get s.e's, you get told 'not yet implemented'
#   for a multiple e.u. model

summary(class.aov)
# gives you the anova table given separately for each
#  error term

# the residual standard error is the sqrt(MSE) for each stratum

# the alternative is to use the mixed model workhorse:
#  lmer in the lme4 package

library(lme4)

class.lmer <- lmer(score~method.f*tutor.f+(1|method.f:class.f),data=class)

# fixed effects in the usual place
# random effects are indicated inside ()
#   by the parameter that varies (here, the intercept)
#   and the group that it varies by
#     (here, all comb. of method and class)

# again, if you use class instead of class:method, method
#  gets tested against the MSerror

print(class.lmer)  # or summary(class.lmer)
# gives you estimates of the variance components
# the fixed effect estimates are the regression coefficients for
#  the columns of X variables used by R

anova(class.lmer)
# gives you an anova table, but it doesn't indicate
#  error df or give you p-values.

# if there is an option to do this, please let me know and
#  I will update this information

# if there is an easy way to get marginal means (especially for
#  unbalanced data), please let me know.

# for unbalanced data, my understanding is that the R tests
#  are sequential (Type I), not type III.  The usual way to get
#  type III tests, using drop1(XXX, .~.) does not appear to work
#  with lmer objects.

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/splitteach.r


# Barometric formula: altitude analysis
# https://en.wikipedia.org/wiki/Barometric_formula
# Ideal law: P = rho * R/M * T

round_timestamp <- function(ts, scalefactor.sec = 3600*12) {
  as.POSIXct(round(as.numeric(ts)/scalefactor.sec) * scalefactor.sec, origin = '1970-01-01', tz = 'UTC')
}

logger.names <- grep('barometer/', gwloggeR.data::enumerate(), value = TRUE)

logger.names <- setdiff(logger.names, 'barometer/BAOL016X_W1666.csv')
logger.names <- setdiff(logger.names, 'barometer/BAOL050X_56819.csv') # high freq manu in range of 80 cmH2O

df.list <- sapply(logger.names, function(name) {
  df <- gwloggeR.data::read(name)$df

  # Filter
  df <- df[!duplicated(TIMESTAMP_UTC), ]
  df <- df[!is.na(PRESSURE_VALUE), ]
  df <- df[!is.na(TIMESTAMP_UTC), ]

  # Aggregate
  df <- df[, .('PRESSURE_VALUE' = mean(PRESSURE_VALUE)),
           by = .('TIMESTAMP_UTC' = round_timestamp(TIMESTAMP_UTC))]

  # Filter
  df <- df[PRESSURE_VALUE < 1100,]
  df <- df[PRESSURE_VALUE > 975,]

  # Meta data
  df[, FILE := basename(name)]
  df[, N := .N]

  data.table::setkey(df, TIMESTAMP_UTC)

  df
}, simplify = FALSE, USE.NAMES = TRUE)

df <- data.table::rbindlist(df.list, use.names = TRUE)

medians <- sapply(df.list, function(df) {
  median(df$PRESSURE_VALUE, na.rm = TRUE)
}, simplify = TRUE, USE.NAMES = TRUE)

# Load functions from analysis 07.
sys.source('./drifts/analysis_07.r', envir = (bf <- new.env()))

# This function computes the altitude in function of pressure.
# LR stands for lapse rate: the drop in temperature in function of altitude is
# here taken into consideration. For altitude between 0 and 11 km, the drop
# in temperature is taken as a linear function: T = T_b + L_b*h.
# See: https://en.wikipedia.org/wiki/Barometric_formula#Derivation
# Other assumption here is that the air pressure is hydrostatic (i.e. "fluid" is not moving).
bf$h.lr <- function(P.Pa) {
  A <- g0 * M / (R * L_b)
  B <- log(P_b / P.Pa)/A + log(T_b)
  (exp(B) - T_b)/L_b + h_b
}
environment(bf$h.lr) <- bf

bf$h.lr(bf$P_b)
bf$h.lr(bf$P.lr(50)) # Test, should be the same as input: 50

medians.Pa <- sapply(medians, bf$P.cmH2O_to_Pa, simplify = TRUE, USE.NAMES = TRUE)

altitude.m.bf <- sapply(medians.Pa, bf$h.lr, simplify = TRUE, USE.NAMES = TRUE)

hist(altitude.m.bf, breaks = 50, main = 'Altitudes (m) based on barometric formula', xlab = 'Altitude (m)')

df <- merge(x = df,
            y = data.frame(FILE = basename(names(altitude.m.bf)), ALTITUDE = as.vector(altitude.m.bf)),
            all.x = TRUE, by = 'FILE')

data.table::setkey(df, FILE, TIMESTAMP_UTC)

ggplot2::ggplot(data = df, mapping = ggplot2::aes(y = PRESSURE_VALUE, x = sprintf('%s (#%i)', FILE, N))) +
  ggplot2::geom_boxplot() +
  ggplot2::coord_flip() +
  ggplot2::ggtitle(label = 'Barometer boxplots (2 obs/day)') +
  ggplot2::xlab(NULL) +
  ggplot2::theme_light()

ggplot2::ggsave('./drifts/analysis_08/baro_hist_uhd-1.png', width = 2160/96, height = 3840/96, dpi = 96)

ggplot2::ggplot(data = df, mapping = ggplot2::aes(y = PRESSURE_VALUE, x = sprintf('%s (#%i) [%.2fm]', FILE, N, ALTITUDE))) +
  ggplot2::geom_boxplot() +
  ggplot2::geom_hline(yintercept = bf$P.Pa_to_cmH2O(bf$P.lr(0)), size = 1.5, col = 'darkblue') +
  ggplot2::geom_hline(yintercept = bf$P.Pa_to_cmH2O(bf$P.lr(50*c(-1,1))), size = 1.5, col = 'green') +
  ggplot2::geom_hline(yintercept = bf$P.Pa_to_cmH2O(bf$P.lr(100*c(-1,1))), size = 1.5, col = 'red') +
  ggplot2::coord_flip() +
  ggplot2::ggtitle(label = 'Barometer boxplots (2 obs/day) with altitudes (barometric formula) based on medians',
                   subtitle = 'Blue: 0m, green: ±50m and red: ±100m') +
  ggplot2::xlab(NULL) +
  ggplot2::theme_light()

ggplot2::ggsave('./drifts/analysis_08/baro_hist_altitudes_uhd-1.png', width = 2160/96, height = 3840/96, dpi = 96)

write.csv(as.data.frame(altitude.m.bf), file = './drifts/analysis_08/baro_barometric_formula_altitudes.csv')


prData <- 0.0081
domanda1 <- 5
domanda2_1 <- 9;
domanda2_2 <- 5;

p <- 1;

pr <- function(p){

  somma <- 0;
  for( i in 1:(domanda1-1) ){

    somma <- somma + p*(1-p)^(i-1);

  }
  return(somma);

}

f <- function(x){

  1 - prData - (pr(x));

}

prX <- function(x){

    p*(1-p)^(x-1);

}

p <- round(uniroot(f, c(0,1), extendInt="yes")$root, digits = 3);

print(p);

somma <- 0;

for( i in domanda2_2:domanda2_1 ){

    somma <- somma + prX(i);

}

prCondizionante <- 1;

for( i in 1:(domanda2_2-1) ){

  prCondizionante <- prCondizionante - prX(i);

}

risposta2 <- somma/prCondizionante;
risposta2_1 <- somma/prData;

print(risposta2)
print(risposta2_1)


mylist <- c(1, 0, 1, 0, 0, 1, 0, 1, 1, 0, 0, 1)
data <- matrix(mylist, nrow=4, ncol=3)
print(data)
target <- matrix(c(1, 0, 1, 0), nrow=4)
print(target)

sigmoid <- function(x, deriv) {
    if (deriv == TRUE) {
        return (x*(1-x))
        }
    return (1/(1+exp(-x)))
    }
w0 = matrix(c(0.1, -0.1, 0.01), nrow=3)
learning_rate <- 1
for (i in 1:10000) {
    layer0 <- data
    layer1 <- sigmoid(layer0%*%w0, FALSE)
    error <- layer1-target
    delta <- error*sigmoid(layer1, TRUE)
    w0 <- w0 - learning_rate*t(layer0)%*%delta
}
print(layer1)


#' Simple method to calculate paleoslope from preserved sediments
#'
#' \code{lynds_one} calculates the slope of an ancient river, provided you know the flow depth, the grain size of the bed material, and make some assumptions about shear stress in the river. Implemented from Lynds et al. (2014)
#' @param tau_mode Denotes whether to use a fixed value for the shields number of the flow, or to use a logarithmically-spaced range going from one to ten.
#' @param D The median grain size of bedload sediments.
#' @param rhos The density of the sediment in kg/m^3
#' @param rhof The density of the fluid in kg/m^3
#' @return Returns a single dimensionless number giving the slope.
#' @export

#	First method to reconstruct paleoslope from Lynds et al 2014
#	Eric Barefoot
#	Nov 2017

#	define needed variables and data types

lynds_one = function(D, H, tau_mode = 'fixed', rhos = 2650, rhof = 1000) {

	#	D is the D50b or median bedload grainsize
	#	H is Hbf or the bankfull flow depth

	rhos = rhos
	rhof = rhof

	#	key assumption is that shields number is equal to one. But paper varies it by up to ten. Provide here a choice for selecting either the recommended value of 1 or a range of estimates from one to ten spaced evenly in log space.

	tau_bf_50 = switch(tau_mode, fixed = 1, range = round(log10(seq(1.258935,10,length = 10)) * 10, 4))

	#	R is assumed in the paper, but we will calculate it here, and provide defaults above.

	R = rhos/rhof - 1

	#	now we calculate the slope based on equation (3) in Lynds et al 2014

	S = (tau_bf_50 * R * D)	/ H

	return(S)

}


# Binomial logistic regression with mediation simulation code
# NOTE: The assumption is that the mediator is a continuous variable

# Raymond Viviano
# rayviviano@gmail.com
# March 25, 2020

# TODO: Implement checks to make sure that all models converged

#' Inverse Logit Function
inv.logit <- function(p){
    return(exp(p)/(1+exp(p)))
}

#' Sobel indirect effect standard error approximation
sobel.std.err <- function(a, b, se.a, se.b){
    return((b^2 * se.a^2) + (a^2 + se.b^2))
}

#' Coverage Probability, i.e., the probability that the confidence interval (ci)
#' for a parameter will contain the true value
#' Inputs:
#'          b       - Estimate
#'          se      - Standard Error of the Estimate
#'          true    - True value of parameter for data-generating process
#'          cl      - Confidence level
#'          dof     - Degrees of Freedom
#' Output:
#'          List containing coverage probability, vect
coverage.prob <- function(b, se, true, cl=.95, dof=Inf){
    # Compute quantile based on confidence level
    coverage.quantile <- cl + (1-cl)/2

    # Compute confidence interval upper and lower bounds
    ci.lower <- b - qt(coverage.quantile, df=dof)*se
    ci.upper <- b + qt(coverage.quantile, df=dof)*se

    # For each ci generated for each b/se pair, eval if true param is in ci
    ci.contain.true <- ifelse(true>=ci.lower & true<=ci.upper, 1, 0)

    # Calculate coverage probability
    cp <- mean(ci.contain.true)

    # Calculate Monte Carlo Error
    mc.err.lower <- cp - 1.96*sqrt((cp*(1-cp))/length(b))
    mc.err.upper <- cp + 1.96*sqrt((cp*(1-cp))/length(b))

    # Return coverage probability and error
    return(list(cp=cp, ci=cbind(mc.err.lower, mc.err.upper)))
}

#' Power to detect any effect at various alpha levels
#' Takes a vector of p-values and calculates the proportion of modell where the
#' p-val for the effect of interest was < .5, .01, and .001.
power.detect.effect <- function(p.val.vec){
    less.than.05 <- ifelse(p.val.vec < .05, 1, 0)
    prop.05 <- sum(less.than.05)/length(less.than.05)

    less.than.01 <- ifelse(p.val.vec < .01, 1, 0)
    prop.01 <- sum(less.than.01)/length(less.than.01)

    less.than.001 <- ifelse(p.val.vec < .001, 1, 0)
    prop.001 <- sum(less.than.001)/length(less.than.001)

    cat(paste0('Power to detect effect at .05: ', prop.05, '\n'))
    cat(paste0('Power to detect effect at .01: ', prop.01, '\n'))
    cat(paste0('Power to detect effect at .001: ', prop.001, '\n'))
}

# Some equations to keep in mind for logistic regression with mediation:
#
# EQ1.  Y   =   B0_1 + Tau*X + e1
# EQ2.  Y   =   B0_2 + Tau_Prime*X + Beta*M + e2
# EQ3.  M   =   B0_3 + alpha*X + e3
# EQ4.  Tau =   alpha*beta + Tau_Prime   || (c = ab + c') (approx for logistic)
#
# Tau = total effect, tau_prime = direct effect of X on Y accounting for
# mediating relationship, alpha = effect of X on M, beta = effect of M on Y
# B0_1,2,&3 are intercept terms for their respective equations.
#
# Assuming zero error, the mean, or expected value, for the intercept term for
# EQ1 can be defined by the other variables.
#
# EQ5. E[B0_1] = E[B0_2] + Tau_Prime*E[X] + Beta*(E[B0_3] + Alpha*E[X]) - Tau*[X]
#
# If we force the mean of X to 1, then we get equation 6:
#
# EQ6. E[B0_1] = E[B0_2] + Tau_Prime + Beta*E[B0_3] + Alpha*Beta - Tau
#
# As Tau_Prime - Tau = -1 * Alpha*Beta, we get equation 7:
#
# EQ7. E[B0_1] = E[B0_2] + Beta*E[B0_3]
#
# We also get equation 7 if we force the mean of x to 0...and the derivation is easier...
#
# Define B0_1, B0_2, B0_3, alpha, beta, tau, and tau_prime for the data
# generation process.
#
# Use Eq3 to generate M, then use Eq2 to generate Y
# Test that you recover the expected values for alpha, beta, tau, tau_prime,
# B0_1, B02, and B03

# Specify indirect and direct effect terms
alpha = .2
beta = .2
tau_prime = .1

# Specify total effect (note that for logit this is actually approximate)
tau = alpha*beta + tau_prime

# Intercept terms for EQ2 and EQ3 (Means or expected values)
B0_2 <- .2
B0_3 <- .4

# Calculate intercept term for EQ1 based on the other specified values
B0_1 <- B0_2 + beta*B0_3

# Ensure reproducible results
set.seed(10000)

# Define sample size
n <- 16000

# Define number of simulations
nsims <- 50

# Define matrix to hold simulation data (estimates, std.errors, and pvals)
sim.prms <- matrix(NA, nrow=nsims, ncol=20)

# Loop through simulations
for(i in 1:nsims){
    # Generate independant variable data, uniform random between -1 and 1
    # The expected value, or expected mean of this vector should be 0
    x <- runif(n, -1, 1)

    # Generate data for the mediating variable, the mean or expected value
    # should equal B03. But, we'll add some noise
    m <- alpha*x + B0_3
    # Add noise
    m <- m + rnorm(length(m), 0, .2)

    # True data-generation-process for Bernoulli trials
    y <- rbinom(n, 1, inv.logit(B0_2 + tau_prime*x + beta*m))

    # Estimate logit model
    model1 <- glm(y ~ x, family=binomial(link=logit))
    model2 <- glm(y ~ x + m, family=binomial(link=logit))
    model3 <-  lm(m ~ x)

    # TODO: Implement checks to make sure that all models converged

    # Put model paramters in simulation matrix
    sim.prms[i, 1] <- model1$coef[1]                    # Estimate for B0_1
    sim.prms[i, 2] <- model2$coef[1]                    # Estimate for B0_2
    sim.prms[i, 3] <- model3$coef[1]                    # Estimate for B0_3
    sim.prms[i, 4] <- model3$coef[2]                    # Estimate for Alpha
    sim.prms[i, 5] <- model2$coef[3]                    # Estimate for Beta
    sim.prms[i, 6] <- sim.prms[i, 4] * sim.prms[i, 5]   # Estimate for Indirect
    sim.prms[i, 7] <- model1$coef[2]                    # Estimate for Tau
    sim.prms[i, 8] <- model2$coef[2]                    # Estimate for Tau_Prime
    sim.prms[i, 9] <- summary(model3)$coefficients[,2][2]  # Alpha Std.Err
    sim.prms[i,10] <- summary(model2)$coefficients[,2][3]  # Beta Std.Err
    sim.prms[i,11] <- sobel.std.err(sim.prms[i,4], sim.prms[i,5],
                                    sim.prms[i,9], sim.prms[i,10]) # Indirect Std.Err
    sim.prms[i,12] <- summary(model1)$coefficients[,2][2]  # Tau Std.Err
    sim.prms[i,13] <- summary(model2)$coefficients[,2][2]  # Tau_Prime Std.Err
    sim.prms[i,14] <- summary(model1)$coefficients[,4][1]  # P-Value for B0_1
    sim.prms[i,15] <- summary(model2)$coefficients[,4][1]  # P-Value for B0_2
    sim.prms[i,16] <- summary(model3)$coefficients[,4][1]  # P-Value for B0_3
    sim.prms[i,17] <- summary(model3)$coefficients[,4][2]  # P-Value for Alpha
    sim.prms[i,18] <- summary(model2)$coefficients[,4][3]  # P-Value for Beta
    sim.prms[i,19] <- summary(model1)$coefficients[,4][2]  # P-Value for Tau
    sim.prms[i,20] <- summary(model2)$coefficients[,4][2]  # P-Value for Tau'

}

# Note: The assumption for this simulation is that the mediator is continuous
cat("Note: This simulation assumes that the mediator is continous...\n\n")

# Get Covarage probabilities for the parameters
# B0_1.coverage <- coverage.prob(sim.prms[,1], sim.prms[,], B0_1, .95, n-model1$rank) TODO: Add these std.errs to sim.prms
# B0_2.coverage <- coverage.prob(sim.prms[,2], sim.prms[,], B0_2, .95, n-model2$rank) TODO: Add these std.errs to sim.prms
# B0_3.coverage <- coverage.prob(sim.prms[,3], sim.prms[,], B0_3, .95, n-model3$rank) TODO: Add these std.errs to sim.prms
alpha.coverage     <- coverage.prob(sim.prms[,4], sim.prms[, 9], alpha, .95, n-model3$rank)
beta.coverage      <- coverage.prob(sim.prms[,5], sim.prms[,10], beta,  .95, n-model2$rank)
indirect.coverage  <- coverage.prob(sim.prms[,6], sim.prms[,11], alpha*beta, .95, n-model2$rank) # TODO: Figure out confidence interval for sobel std.err
tau.coverage       <- coverage.prob(sim.prms[,7], sim.prms[,12], tau,        .95, n-model3$rank)
tau.prime.coverage <- coverage.prob(sim.prms[,8], sim.prms[,13], tau_prime,  .95, n-model2$rank)

# # Intercept coverage probabilities     -- TODO
# print("Coverage Probability for B0_1")
# print(B0_1.coverage)
# print("Coverage Probability for B0_2")
# print(B0_2.coverage)
# print("Coverage Probability for B0_3")
# print(B0_3.coverage)

print("alpha.coverage")
print(alpha.coverage)
print("beta.coverage")
print(beta.coverage)
print("indirect.coverage")
print(indirect.coverage)
print("tau.coverage")
print(tau.coverage)
print("tau.prime.coverage")
print(tau.prime.coverage)

# TODO: Update/Fix Proportion Code
# power.detect.effect(sim.prms[,5])
# power.detect.effect(sim.prms[,6])


library(tmvtnorm)

# t-Stutdet parameters
Mu = c(9, 8, 7, 6)
Sigma = matrix(c(16, -2, -1, -3,
                 -2,  9, -4, -1,
                 -1, -4,  4,  1,
                 -3, -1,  1,  1),
               nrow=4, ncol=4)
lower_bound = 5
upper_bound = 12

# Generate scenarios
data <- rtmvt(n=10000, mean=mu, sigma=sigma, df=5, lower=rep(lower_bound, 4), upper=rep(upper_bound, 4))
write.table(format(data, digits=15, drop0trailing=F), "data10000.txt", quote=F, sep="\t", eol="\n\t", col.names = F, row.names = T)
mean <- colMeans(data)

E <- function(idx, Mu, Sigma, v, alfa, beta) {
  mu = Mu[idx]
  sigma = Sigma[idx, idx]
  a = (alfa - mu)/sigma
  b = (beta - mu)/sigma
  nom = gamma((v-1)/2) *
        ((v+a^2)^(-1*(v-1)/2) -
         (v+b^2)^(-1*(v-1)/2)) *
        v^(v/2)
  den = 2 * (pt(b, v) - pt(a, v)) * gamma(v/2) * gamma(1/2)
  return (mu + sigma*(nom/den))
}

ER1 <- E(1, Mu, Sigma, 5, 5, 12)
ER2 <- E(2, Mu, Sigma, 5, 5, 12)
ER3 <- E(3, Mu, Sigma, 5, 5, 12)
ER4 <- E(4, Mu, Sigma, 5, 5, 12)
ER <- c(ER1, ER2, ER3, ER4)
write.table(ER, "ER.txt", sep="\t", col.names=F, row.names=F)


#' Generate data
#'
#'@description{
#' The generated responses are discretized and truncated from a latent exponential
#' generalized linear model with natural parameter exp(X b)
#'  }
#'
#' @param X An n x p design matrix
#' @param b A vector of p regression coefficients
#' @param d A scalar controlling the coarseness of the support, where d = 1
#'  means integer support (see details)
#' @param ymax An upper bound on the observable response (see details)
#'
#' @return A matrix with n rows and 2 columns; the first is the lower endpoint
#'  of the observed interval and the second the upper endpoint (see details)
#'
#' @details{
#'   Data are generated by (i) draw y ~ Exp(exp(X b)), (ii) replace y by floor(y
#'   / d) * d, and (iii) replace every element of y greater than ymax by ymax;
#'   this gives the lower endpoint of the interval. Observe that the operation
#'   floor(y / d) * d sets y to the nearest smaller multiple of d.
#'
#'   The upper endpoint of the observed interval is yupp = y + d, unless y =
#'   ymax in which case yupp = Inf.
#'  }
#'
#' @export
generate_ee <- function(X, b, d = 1, ymax = 10){
  # Do argument checking
  stopifnot(is.matrix(X))
  p <- ncol(X)
  n <- nrow(X)
  stopifnot(is.numeric(b), length(b) == p)
  stopifnot(is.numeric(d), length(d) == 1, d > 0)
  stopifnot(is.numeric(ymax), length(ymax) == 1, ymax >= 0)

  eta <- X %*% b
  y <- stats::rexp(n = nrow(X), rate = exp(X %*% b))
  y <- floor(y / d) * d
  y <- pmin(y, ymax)
  yupp <- y + d
  yupp[y == ymax] <- Inf
  return(cbind(y, yupp))
}

#' Evaluate objective function and its derivatives
#'
#' @description{The objective function is that of an elastic net-penalized negative
#'  log-likelihood corresponding to a latent exponential generalized linear model
#'  with natural parameter exp(X b).
#' }
#'
#' @param y A vector of n observed responses (see details in fit_ee)
#' @param X An n x p matrix of predictors
#' @param b A vector of p regression coefficients
#' @param yupp A vector of n upper endpoints of intervals corresponding to y
#'   (see details in fit_ee)
#' @param lam A scalar penalty parameter
#' @param alpha A scalar weight for elastic net (1 = lasso, 0 = ridge)
#' @param pen_factor A vector of coefficient-specific penalty weights; defaults
#' to 0 for first element of b and 1 for the remaining.
#' @param order An integer where 0 means only value is computed; 1 means both value
#'   and sub-gradient; and 2 means value, sub-gradient, and Hessian (see details)
#' @return A list with elements "obj", "grad", and "hessian" (see details)
#'
#' @details{
#'  When order = 0, the gradient and Hessian elements of the return list are set
#'  to all zeros, and similarly for the Hessian when order = 1.
#'
#'  The sub-gradient returned is that obtained by taking the sub-gradient of the
#'  absolute value to equal zero at zero. When no element of b is zero, this is
#'  the usual gradient. The Hessian returns is that of the smooth part of the
#'  objective function that is, the average negative log-likelihood plus the L2
#'  penalty only. When no element of b is zero, this is the Hessian of the
#'  objective function
#' }
#' @export
obj_diff <- function(y, X, b, yupp, lam = 0, alpha = 1, pen_factor = c(0, rep(1,
  ncol(X) - 1)), order){
  # Do argument checking
  stopifnot(is.matrix(X))
  p <- ncol(X)
  n <- nrow(X)
  stopifnot(is.numeric(b), length(b) == p)
  stopifnot(is.numeric(y), is.null(dim(y)), length(y) == n)
  stopifnot(is.numeric(yupp), is.null(dim(yupp)), length(yupp) == n)
  stopifnot(is.numeric(lam), length(lam) == 1)
  stopifnot(is.numeric(alpha), length(alpha) == 1,
            alpha >= 0, alpha <= 1)
  stopifnot(is.numeric(pen_factor), is.null(dim(pen_factor)),
            length(pen_factor) == p)
  stopifnot(is.numeric(order), length(order) == 1, order %in% 0:2)

  obj_diff_cpp(y, X, b, yupp, lam1 = alpha * lam * pen_factor, lam2 = (1 -
  alpha) * lam * pen_factor, order)
}


#' Takes a power spectrum and makes it noisy, by adding white noise to
#' its amplitude, and introducing random, uniformly distributed
#' phases.
#'
#' \deqn{A(f) \sim \mathcal{N}(PSD(f), \sigma^2)}
#' \deqn{\phi(f) \sim \mathcal{U}(0, 2\pi)}
#' \deqn{z(f) = A(f) \exp(i \phi(f))}
#'
#' @param power Power spectral density.
#' @param sd Standard deviation of white noise.
#'
#' @return Power with noise added.
#'
#' @export
noisy.power.spectrum <- function(power, sd = 1.0) {
    A   <- rnorm(power, mean = power, sd = sd)
    phi <- runif(power, min = 0, max = 2*pi)

    A * exp(1i * phi)
}


ISLMPlot <- function(input,output,values){
  prod = seq(0,input$ymax,length.out = 1000)
  to_plot = data.frame(revenu = prod)
  fig = plot_ly(to_plot, x = ~revenu)

  fig = fig %>% add_trace(y = ((1-input$alpha-input$iy)*prod+input$alpha*input$t-input$cpi-input$id*input$D/values$p-input$bari-input$g)/input$ir,
                          type = "scatter", mode = "lines", name = "$$IS_1$$", line = list(color = "#ff0000"),
                          hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))
  fig = fig %>% add_trace(y = lm_curve(input$lr, input$Ms, values$p, input$ly, prod, input$rmin),
                          type = "scatter", mode = "lines", name = "$$LM_1$$", line = list(color = "#007bff"),
                          hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))

  fig = fig %>% add_segments(0,values$eq$r,values$eq$y,values$eq$r,
                             line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                             hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))
  fig = fig %>% add_segments(values$eq$y,0,values$eq$y,values$eq$r,
                             line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                             hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))

  if(values$shock){
    for(i in 1:2){
      if(!is.na(input[[paste0("new_value_",i)]])){
        if(input[[paste0("shocked_var_",i)]] %in% choicesIS){
          fig = with(values[[paste0("shocked_params_",i)]],
                     add_trace(fig, y = ((1-alpha-iy)*prod+alpha*t-cpi-id*input$D/p-bari-g)/ir,
                               type = "scatter", mode = "lines",
                               name = paste0("$$IS_2^",i,"$$"), line = list(color = paste0("#",i+7,"a0000")),
                               hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>")))
        } else if(input[[paste0("shocked_var_",i)]] %in% choicesLM){
          fig = with(values[[paste0("shocked_params_",i)]],
                     add_trace(fig, y = lm_curve(lr,Ms,p,ly,prod,input$rmin),
                               type = "scatter", mode = "lines",
                               name = paste0("$$LM_2^",i,"$$"), line = list(color = paste0("#0234",3+i^2,"b")),
                               hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>")))
        } else if(input[[paste0("shocked_var_",i)]] == "p"){
          fig = with(values[[paste0("shocked_params_",i)]],
                     add_trace(fig, y = ((1-alpha-iy)*prod+alpha*t-cpi-id*input$D/p-bari-g)/ir,
                               type = "scatter", mode = "lines",
                               name = paste0("$$IS_2^",i,"$$"), line = list(color = paste0("#",i+7,"a0000")),
                               hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>")))
          fig = with(values[[paste0("shocked_params_",i)]],
                     add_trace(fig, y = lm_curve(lr,Ms,p,ly,prod,input$rmin),
                               type = "scatter", mode = "lines",
                               name = paste0("$$LM_2^",i,"$$"), line = list(color = paste0("#0234",3+i^2,"b")),
                               hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>")))
        }

        fig = fig %>% add_segments(0,values[[paste0("new_eq_",i)]]$r,values[[paste0("new_eq_",i)]]$y,values[[paste0("new_eq_",i)]]$r,
                                   line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                                   hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))
        fig = fig %>% add_segments(values[[paste0("new_eq_",i)]]$y,0,values[[paste0("new_eq_",i)]]$y,values[[paste0("new_eq_",i)]]$r,
                                   line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                                   hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))

        islm_new_eq = list(
          x = values[[paste0("new_eq_",i)]]$y,
          y = values[[paste0("new_eq_",i)]]$r,
          text = paste0("y*=",round(values[[paste0("new_eq_",i)]]$y), ", r*=",round(values[[paste0("new_eq_",i)]]$r,4))
        )
        fig = fig %>% layout(annotations = islm_new_eq)
      }
    }
  } else{
    islm_eq = list(
      x = values$eq$y,
      y = values$eq$r,
      text = paste0("y*=",round(values$eq$y), ", r*=",round(values$eq$r,4))
    )
    fig = fig %>% layout(annotations = islm_eq)
  }

  f <- list(
    family = "Courier New, monospace",
    size = 18,
    color = "#7f7f7f"
  )
  revenu <- list(
    title = "Revenu, y",
    titlefont = f
  )
  interest <- list(
    title = "Taux d'intérêt, r",
    titlefont = f,
    range = c(0,10)
  )
  fig = fig %>% layout(xaxis = revenu, yaxis = interest)
  return(fig)
}


is.perf <- function(n){
	if (n==0|n==1) return(FALSE)
	s <- seq (1,n-1)
	x <- n %% s
	m <- data.frame(s,x)
	out <- with(m, s[x==0])
	return(sum(out)==n)
}
# Usage - Warning High Memory Usage
is.perf(28)
sapply(c(6,28,496,8128,33550336),is.perf)


N <- 10000 # Games per run
M <- 10    # Runs

rewards <- matrix(nrow=M, ncol=N)
fracs1 <- matrix(nrow=M, ncol=N)
fracs2 <- matrix(nrow=M, ncol=N)
for (j in 1:M) {
  for (i in 1:N) {
    coin <- 1
    coins <- vector()

    # Play the St. Petersburg game
    while(coin) {
      coin <- sample(c(0, 1), 1)
      coins <- c(coins, coin)
    }

    rewards[j,i] <- 2**(sum(coins)+1)
    if (i == 1) {
      fracs1[j,i] = 0
      fracs2[j,i] = 0
    } else {
      fracs1[j,i] =
        sum(rewards[j,1:i])/(i*log2(i))
      fracs2[j,i] =
        sum(rewards[j,1:i])/(i*log2(i*log2(i)))
    }
  }
}

# Plot the results
svg(filename="Figures/petersburgslow.svg")
plot(1:N, fracs1[1,1:N], type='l',
     ylim=c(min(fracs1[,1000:N]), max(fracs1[,1000:N])),
     xlab='Trials (n)', ylab='S_n/(n*log_2(n))')
for (j in 2:M) {
  lines(1:N, fracs1[j,1:N])
}
lines(1:N, rep(1,N), col='red')
dev.off()
svg(filename="Figures/petersburgfast.svg")
plot(1:N, fracs2[1,1:N], type='l',
     ylim=c(min(fracs1[,1000:N]), max(fracs1[,1000:N])),
     xlab='Trials (n)', ylab='S_n/(n*log_2(n*log_2(n)))')
for (j in 2:M) {
  lines(1:N, fracs2[j,1:N])
}
lines(1:N, rep(1,N), col='red')
dev.off()


=begin
  # sample-algebraic-root01.rb

  require "algebra"

  R2, r2, r2_ = Root(Rational, 2) # r2 = sqrt(2), -sqrt(2)
  p r2 #=> sqrt(2)
  R3, r3, r3_ = Root(R2, 3)       # r3 = sqrt(3), -sqrt(3)
  p r3 #=> sqrt(3)
  R6, r6, r6_ = Root(R3, 6)       # R6 = R3, r6 = sqrt(6), -sqrt(6)
  p r6 #=> -r2r3
  p( (r6 + r2)*(r6 - r2) ) #=> 4

  F, a, b =  QuadraticExtensionField(Rational){|x| x**2 - x - 1}
  # fibonacci numbers
  (0..100).each do |n|
    puts( (a**n - b**n)/(a - b) )
  end
((<_|CONTENTS>))
=end


=begin
  # sample-geometry07.rb

  require "algebra"
  R = MPolynomial(Rational)
  m, b, a = R.vars("mba")
  K = LocalizedRing(R)
  a0, b0, m0 = K[a], K[b], K[m]

  M = SquareMatrix(K, 3)
  l0, l1, l2 = M[[0, 1, 0], [1, 1, -1], [1, 0, 0]]
  m4 = M[[a0, 1, -a0], [1, b0, -b0], [m0, -1, 0]]
  m40 = m4.dup; m40.set_row(0, l0)
  m41 = m4.dup; m41.set_row(1, l1)
  m42 = m4.dup; m42.set_row(2, l2)

  def mdet(m, i)
    i = i % 3
    m.minor(i, 2).determinant * (-1) ** i
  end

  def tris(m, i)
    pts = [0, 1, 2] - [i]
    (m.determinant)**2 / mdet(m, pts[0]) / mdet(m, pts[1])
  end

  u0 = (tris(m4, 0) - tris(m40, 0)).numerator
  u1 = (tris(m4, 1) - tris(m41, 1)).numerator
  u2 = (tris(m4, 2) - tris(m42, 2)).numerator

  puts [u0, u1, u2]
  puts

  [u0, u1, u2].each do |um|
    p um.factorize
  end
  puts

  x = u0 / a / (m*b+1)
  y = u1 / (m+a) / (b-1)
  z = u2 / (-b*a+1)

  p x
  p y
  p z
  puts

  gb = Groebner.basis([x, y, z])
  puts gb
  puts

  gb.each do |v|
    p v.factorize
  end
  #(-1)(-mb + m + ba^3 + ba^2 - ba - a^2)
  #(-1)(-ma + m + ba^2 - a^2)
  #(-1)(b + a - 1)(-ba + 1)(a)
  #(-1)(-ba + 1)(a)(a^2 + a - 1)

  # => a = -1/2 + \sqrt{5}/2
((<_|CONTENTS>))
=end


creatingBuckets <- function(arr) {
  o <- list(c(), c(), c(), c(), c(), c(), c(), c(), c(), c())
  for (i in 1:length(arr)) {
    n <- as.integer(floor(10 * arr[i]))
    o[[n]] <- c(o[[n]], arr[i])
  }
  for (i in 1:length(o)) {
    if(length(o[[i]])>1){
      o[[i]] <- insertionSort(o[[i]])
    }
  }
  mergeList(o)
}
insertionSort <- function(a) {
  for (c in 2:(length(a))) {
    d = c
    while (d > 1 && (a[d] < a[d-1])) {
      t = a[d]
      a[d] = a[d - 1]
      a[d - 1] = t
      d = d - 1
    }
  }
  a
}
mergeList <- function(q) {
  res <- as.vector(c())
  for (k in 1:length(q)) {
    if (!is.null(q[[k]]))
      res <- c(res, q[[k]])
  }
  print("Vector after BucketSort")
  print(res)
}
arr <- c(0.78, 0.17, 0.39, 0.26)
creatingBuckets(arr)


library(Matrix)
A <- matrix(c(1, 3, 5, 2, 4, 7, 1, 1, 0), 3, 3, byrow=T)
dim(A) <- c(3, 3)
expand(lu(A))


#### 일원 분산분석(One-way ANOVA) #####

# 01.데이터 불러오기
owa.df <- read.csv("Ch0901.OWA.csv",
                    header=TRUE,
                    na.strings = ".")

owa.df$group <- factor(owa.df$group,
                       levels = c(1:4),
                       labels = c("강남","강서","강동","강북"))

str(owa.df)
head(owa.df)

# 02.기본통계치 확인
library(psych)
describeBy(owa.df$score,
           owa.df$group,
           mat=T) # 합쳐서 하나의 표로 보여줄지, 따로 그룹별로 보여줄지 나타내는 옵션

# 03.그래프 그리기(박스그래프,히스토그램)
# install.packages("ggplot2")

library(ggplot2)

ggplot(owa.df, aes(x = group, y = score)) + #aes 축
  geom_boxplot(outlier.colour="red") + #이상치를 레드로 하라
  ggtitle("매장별 만족도") +
  theme_classic() + # ggplot2 테마
  theme(title = element_text(color="darkblue", size=20))

# facet_grid(); 그룹으로 구분- 범주형 변수
# facet_grid(.~); 수직
# facet_grid(~.); 가로

ggplot(owa.df, aes(x=score)) +
  geom_histogram(binwidth=10) +
  facet_grid(.~ group) +
  ggtitle("매장별 만족도") +
  theme_classic()

# 04.통계분석
# 등분산 검증
# 이분산일때는 하단의 부록(Welch's ANOVA test) 참조
bartlett.test(score ~ group, data=owa.df)

# barlett test는 정규분포에 민감하기 때문에 leveneTest 많이 사용
# install.packages("car")
library(car)
leveneTest(score ~ group, data=owa.df) # 레벤의 검증은 library(car)에 있다.

# 등분산일때 ANOVA분석
owa.result <- aov(score ~ group, data=owa.df)

owa.result

summary(owa.result)

# 부록: 이분산일때 Welch's ANOVA test
oneway.test(owa.df$score ~ owa.df$group, data=owa.df,
            var.equal = FALSE)

# 사후검정(Multicamparison test )
# Fisher LSD
pairwise.t.test(owa.df$score,
                owa.df$group,
                data=owa.df,
                p.adj="non") # 많이 않쓰임. 오차가 크기 때문에

# Bonferroni, Tukey HSD, Duncan LSR
pairwise.t.test(owa.df$score,
                owa.df$group,
                data=owa.df,
                p.adj="bonf") # 여기서비교하는 방법을 알려줌. 이것은 유의확률을 보여줌. 강남-강동 차이 있음

# Tukey HSD, Duncan LSR
TukeyHSD(owa.result) # 결과값으로 바로 보여줌 (분산분석 결과치를 데이타프레임으로 저장하고 입력)

# group으로 표현
# install.packages("agricolae")
library(agricolae)

# console=TRUE: 결과를 화면에 표시
# group=TRUE: 그룹으로 묶어서 표시, FALSE: 1:1로 비교하여 다 보여줌, 다른 것끼리 구분되는 것
LSD.test(owa.result,
         "group",
         console = T,
         p.adj="bonf")
duncan.test(owa.result,
            "group",
            group=T,
            console = T)
scheffe.test(owa.result,
             "group",
             group=F,
             console = T)

# 05.통계결과 그래프
tukeyPlot <- TukeyHSD(owa.result) # 그룹간 차이 비교
plot(tukeyPlot) # 0을 거치고 있다는 것은 차이가 없다는 뜻임

# 정규분포로 표시(강남)
x=88.87
se=1.34
data <-rnorm(1000, x, se)
data <- sort(data)
plot(data,
     dnorm(data, x, se),
     col="blue",
     type='l',
     main="매장별 고객만족도",
     xlim=c(75, 95),
     ylim=c(0,0.3))
abline(v=x, col="blue", lty=3)

# 그래프를 겹쳐서 표현하기
par(new=T)

# 정규분포로 표시(강서)
x=88.19
se=1.33
data <-rnorm(1000, x, se)
data <- sort(data)
plot(data,
     dnorm(data, x, se),
     type='l',
     col="red",
     xlim=c(75, 95),
     ylim=c(0,0.3))
abline(v=x, col="red", lty=3)

par(new=T)

# 정규분포로 표시(강북)
x=86.05
se=1.58
data <-rnorm(1000, x, se)
data <- sort(data)
plot(data,
     dnorm(data, x, se),
     type='l',
     col="black",
     xlim=c(75, 95),
     ylim=c(0,0.3))
abline(v=x, col="black", lty=3)

par(new=T)

# 정규분포로 표시(강동)
x=82
se=2.05
data <-rnorm(1000, x, se)
data <- sort(data)
plot(data,
     dnorm(data, x, se),
     type='l',
     col="green",
     xlim=c(75, 95),
     ylim=c(0,0.3))
abline(v=x, col="green", lty=3)

# 부록: 비모수통계분석 Kruskal Wallis H test
kruskal.test(owa.df$score ~ owa.df$group,
             data=owa.df)
# install.packages("userfriendlyscience")
library(userfriendlyscience)
posthocTGH(owa.df$score,
           owa.df$group)

# install.packages("nparcomp")  # 비모수 검정에서 다중 비교 방식
library(nparcomp)
result = mctp(owa.df$score ~ owa.df$group,
              data=owa.df)
summary(result)

ch09 - 분산분석 1/01.일원 분산분석(One-way ANOVA).r


### Nicholas Spyrison 08 March 2021
### Recreate figure 3 from spinifex paper. Silo'd, with minimal dependencies.

require("spinifex")
require("tourr")
require("ggplot2")
require("magrittr")
my_theme <- list(scale_color_brewer(palette = "Dark2"),
                 theme_void(),
                 theme(legend.position ="none"))

### Create the
make_radial_tour_fig <- function(){
  dat  <- scale_sd(flea[, 1:6])
  clas <- factor(flea$species)
  bas  <- MASS::lda(dat, grouping = clas)$scaling %>% tourr::orthonormalise()
  mvar <- 4 ## aede1, primary disting of 1 cluster.

  if(F) ## Manual check the starting LDA basis
    view_frame(bas, dat, mvar,
               aes_args = list(color = clas, shape = clas),
               ggproto = my_theme)

  ang <- .29
  mtour <- manual_tour(bas, manip_var = mvar, angle = ang)
  if(F){ ## Manually check for frames to use
    play_manual_tour(bas, dat, mvar, angle = ang)
    for(i in 1:dim(mtour)[3]){
      mvr <- mtour[mvar,, i]
      msg <- paste0("i=",i,". norm(mv)=", sqrt(mvr[1]^2 + mvr[2]^2))
      print(msg)
    }
  }
  ## Show frames: 1, 4, 10, 15

  p1 <- view_frame(mtour[,, 1], dat, mvar,
                   aes_args = list(color = clas, shape = clas)) + my_theme
  p2 <- view_frame(mtour[,, 4], dat, mvar,
                   aes_args = list(color = clas, shape = clas)) + my_theme
  p3 <- view_frame(mtour[,, 10], dat, mvar,
                   aes_args = list(color = clas, shape = clas)) + my_theme
  p4 <- view_frame(mtour[,, 15], dat, mvar,
                   aes_args = list(color = clas, shape = clas)) + my_theme

  ## Return ggplot figure.
  # gridExtra::grid.arrange(p1, p2, p3, p4, ncol = 4)
  cowplot::plot_grid(p1, p2, p3, p4, ncol = 4,
                     scale = c(1, 1, .75, 1), hjust = -.1,
                     label_fontface = "plain",
                     labels = c("1) norm = 0.86", "2) norm = 1", "3) norm = 0", "4) norm = 0.86")
  )
}

fig <- make_radial_tour_fig()
ggsave(filename = "fig_radial_manual_tour.png",
       plot = fig,
       device = "png", path = "./figures",
       dpi = 300,
       width = 6, height = 1.5, units = "in"
)


=begin
  # sample-quotientfield03.rb

  require "algebra"

  F13 = ResidueClassRing(Integer, 13)
  F = AlgebraicExtensionField(F13, "a") {|a| a**2 - 2}
  a = F.var
  RF = RationalFunctionField(F, "x")
  x = RF.var

  p( (a/4*x + RF.unity/2)/(x**2 + a*x + 1) +
    (-a/4*x + RF.unity/2)/(x**2 - a*x + 1) )
  #=> 1/(x**4 + 1)
((<_|CONTENTS>))
=end


# The sequence of the epsilons in a random walk
# A vector of size n, the elements are generated
# at random : +1 with probability 0.5 and -1 with
# probability 0.5
# 23-04-2015
# Killian Martin--Horgassan

Epsilon_is = function(n) {

	# The vector of the Epsilon_is, they are uniformly distributed on {-1,+1}
	vect <- sample(x = c(-1,1), size = n, replace = TRUE, prob = c(0.5,0.5))

	return(vect)
}


#' @title calcAt
#'
#' @description Estimate transom area (\code{At}) (m^2) using method in Rakke
#' (2016).
#'
#' @param Cm Midship area coefficient (vector of numericals, dimensionless)
#' (see \code{\link{calcCm}})
#' @param breadth Moulded breadth (vector of numericals, m)
#' @param maxDraft Maximum summer load line draft (vector of numericals, m)
#'
#' @return \code{At}
#'
#' @references
#'Holtrop, J. and Mennen, G. G. J. 1982. "An approximate power prediction
#'method." International Shipbuilding Progress 29.
#'
#'\href{http://hdl.handle.net/11250/2410741}{Rakke, S. G. 2016. "Ship Emissions
#'Calculation from AIS." NTNU}
#'
#' @seealso \code{\link{calcCm}}
#'
#' @examples
#'calcAt(0.98, 32, 10)
#'calcAt(c(0.98,0.99), c(32,45.5), c(10,15.5))
#'
#' @export

calcAt <-function(Cm, breadth, maxDraft){

  At<- 0.051*Cm*breadth*maxDraft

  return(At)
}


#' @title calcHMCa
#'
#'@description Calculate incremental hull (roughness) resistance coefficient
#'(\code{Ca}) (dimensionless), which describes the effect of hull roughness and
#' still-air resistance, using the Holtrop & Mennen method.
#'
#' @param maxDraft Maximum summer load line draft (vector of numericals, m)
#' @param lwl Waterline length (vector of numericals, m) (see \code{\link{calclwl}})
#' @param Cbw Waterline block coefficient (vector of numericals, dimensionless)
#'  (see \code{\link{calcCbw}})
#' @param breadth Moulded breadth (vector of numericals, m)
#' @param forwardDraft Forward draft (deviation from actual draft indicates trim)
#'  (vector of numericals, m)
#' @param Abt Traverse bulb area (vector of numericals, m^2) (see
#'  \code{\link{calcAbt}})
#' @param hb Center of bulb area above keel line (vector of numericals, m) (see
#'  \code{\link{calchb}})
#'
#' @return \code{Ca} (vector of numericals, dimensionless)
#'
#' @references
#'Holtrop, J. and Mennen, G. G. J. 1982. "An approximate power prediction
#'method." International Shipbuilding Progress 29.
#'
#'@seealso \itemize{
#'\item \code{\link{calclwl}}
#'\item \code{\link{calcCbw}}
#'\item \code{\link{calcAbt}}
#'\item \code{\link{calchb}}
#'}
#'
#' @family Holtrop-Mennen Calculations
#' @family Resistance Calculations
#'
#' @examples
#' calcHMCa(c(13.57,11.49),c(218.7500,209.2518),c(0.81,0.65),c(32.25,32.20),c(13.57,11.49),
#' c(25.09,55.86),c(5.43,4.6))
#'
#'calcHMCa(13.57,218.7500,0.81,32.25,13.57,25.0880,5.428)
#'
#' @export

calcHMCa<-function(maxDraft,lwl,Cbw,breadth,forwardDraft,Abt,hb){

Ca<-
  ifelse(forwardDraft/lwl<=0.04,#case 1
  0.006*((lwl+100)^-0.16)-0.00205+0.003*sqrt(lwl/7.5)*Cbw^4*
  (#c2
    exp(-1.89*sqrt(
    #c3
    0.56*Abt^1.5/(breadth*maxDraft*(
      0.31*sqrt(Abt)+forwardDraft-hb
    ))
  ))
  )*
  (0.04-
     (#c4
      forwardDraft/lwl
     ))
 ,#case 2
    0.006*((lwl+100)^-0.16)-0.00205+0.003*sqrt(lwl/7.5)*Cbw^4*
      (#c2
        exp(-1.89*sqrt(
          #c3
          0.56*Abt^1.5/(breadth*maxDraft*(
            0.31*sqrt(Abt)+forwardDraft-hb
          ))
        ))
      )*
      (0.04-
         (#c4
           0.04
         ))
  )

return(Ca)
}


esbi <- function(i, a){(1-exp(-a))/(1-exp(-a/i))}
esbia <- function(i, a){(1-exp(-a))/(i*(1-exp(-a/i)))}
esbib <- function(i, a){1-esbia(i, a)}

n <- 1000
a <- 1

x <- seq(0, n, by=1)
plot(x, x, type="l", ylim=c(0, n))
lines(x, log(x), col="green")
lines(x, esbi(x, 1), col="red")
lines(x, esbi(x, 10), col="blue")

x <- seq(0, n, by=1)
plot(x, x*x, type="l", ylim=c(0, n*n))
lines(x, x*log(x), col="green")
lines(x, x*esbi(x, 1), col="red")
lines(x, x*esbi(x, 10), col="blue")

x <- seq(0, n, by=1)
plot(x, x*x, type="l", ylim=c(0, n*n))
lines(x, x*log(x), col="green")
lines(x, x^2*esbia(x, 1), col="red")
lines(x, x^2*esbia(x, 10), col="blue")

x <- seq(0, n, by=1)
plot(x, log(x)*x, type="l", ylim=c(0, log(n)*(n-log(n))))
lines(x, rep(0, length(x)), col="green")
lines(x, x*log(x)*esbib(x, 1), col="red")
lines(x, x*log(x)*esbib(x, 10), col="blue")

x <- seq(0, n, by=1)
plot(x, x*x+log(x)*x, type="l", ylim=c(0, n*n+log(n)*(n-log(n))))
lines(x, x*log(x)+log(x)*log(x), col="green")
lines(x, x^2*esbia(x, 1)+x*log(x)*esbib(x, 1), col="red")
lines(x, x^2*esbia(x, 10)+x*log(x)*esbib(x, 10), col="blue")

x <- seq(0, n, by=1)
plot(x, esbi(x, a)/x, type="l")

x <- seq(0, n, by=1)
plot(x, exp(-1*x/n), type="l", ylim=c(0, 1))
lines(x, exp(-10*x/n), type="l", col="red")
lines(x, exp(-15*x/n), type="l", col="green")


##CTE534_Clasificación_No_Superisada=group
##Imagen=raster
##Banda=number 1
##Centros=number 10
##Iteracciones=number 500
##Inicio=number 5
##Cluster= output raster
##Algortimo=selection HartiganWong;Lloyd;Forgy;MacQueen
##showplots

nr <- getValues(Imagen[[Banda]])
set.seed(99)

if (Algortimo == 0) {
cluster <- kmeans(na.omit(nr),
                  centers = Centros,
                  iter.max = Iteracciones,
                  nstart = Inicio,
                  algorithm="Hartigan-Wong")
} else if (Algortimo == 1) {
cluster <- kmeans(na.omit(nr),
                  centers = Centros,
                  iter.max = Iteracciones,
                  nstart = Inicio,
                  algorithm="Lloyd")
} else if (Algortimo == 2) {
cluster <- kmeans(na.omit(nr),
                  centers = Centros,
                  iter.max = Iteracciones,
                  nstart = Inicio,
                  algorithm="Forgy")
} else if (Algortimo == 3) {
cluster <- kmeans(na.omit(nr),
                  centers = Centros,
                  iter.max = Iteracciones,
                  nstart = Inicio,
                  algorithm="MacQueen")
}

Cluster <- setValues(Imagen[[Banda]], cluster$cluster)

par(mfrow =c(1,2))
plot(Imagen[[Banda]],
     col =rev(terrain.colors(Centros)),
     main = names(Imagen[[Banda]]))
plot(Cluster, main = 'Clasificación No Supervisada \n (Kmeans)')