# 4. faza: Analiza podatkov

logisticna <- function(x) { 100 / (1 + exp(-x)) }
logisticna_inv <- function(y) { log(y / (100 - y)) }
logisticna_breaks <- . %>% logisticna() %>% extended_breaks()() %>% logisticna_inv()

logisticna_trans <- trans_new("logistična funkcija", logisticna, logisticna_inv)

primerjava_rasti_log <- primerjava_rasti %>% mutate(delez=logisticna_inv(delez))

graf7 <- ggplot(primerjava_rasti_log %>% filter(drzava %in% c("Islandija", "Nizozemska", "Norveška", "Bolgarija", "Turčija", "Grčija")),
                aes(x=leto, y=delez, col=drzava)) +
  geom_point() + ggtitle("Primerjava rasti držav z največjo in najmanjšo rastjo") +
  xlab("leto") + ylab("delež v %") + facet_grid(. ~ drzava) + stat_smooth(method="lm") +
  coord_trans(y=logisticna_trans) + scale_y_continuous(breaks=logisticna_breaks,
                                                       labels=logisticna) +
  theme(axis.text.x=element_text(angle=45, vjust=0.5, hjust=1))

bolgarija = c('Bolgarija')
rasti_b <- primerjava_rasti_log %>% filter(drzava=="Bolgarija")
rasti_b$vrsta <- "podatki"
names(rasti_b)[names(rasti_b) == "delez"] <- "rast"
model7b <- lm(rast~leto, data=rasti_b)
pr <- predict(model7b, data.frame(leto=seq.int(2020, 2025, 1)))
napoved_rasti_b <- data.frame(leto = c(2020, 2021, 2022, 2023, 2024, 2025), rast = c(pr[1], pr[2], pr[3], pr[4], pr[5], pr[6]))
napoved_rasti_b$drzava <- bolgarija
napoved_rasti_b$vrsta <- "napoved"
skupne_rasti_b <- rbind(rasti_b, napoved_rasti_b)

turcija = c('Turčija')
rasti_t <- primerjava_rasti_log %>% filter(drzava=="Turčija")
rasti_t$vrsta <- "podatki"
names(rasti_t)[names(rasti_t) == "delez"] <- "rast"
model7t <- lm(rast~leto, data=rasti_t)
prt <- predict(model7t, data.frame(leto=seq.int(2020, 2025, 1)))
napoved_rasti_t <- data.frame(leto = c(2020, 2021, 2022, 2023, 2024, 2025), rast = c(prt[1], prt[2], prt[3], prt[4], prt[5], prt[6]))
napoved_rasti_t$drzava <- turcija
napoved_rasti_t$vrsta <- "napoved"
skupne_rasti_t <- rbind(rasti_t, napoved_rasti_t)

grcija = c('Grčija')
rasti_g <- primerjava_rasti_log %>% filter(drzava=="Grčija")
rasti_g$vrsta <- "podatki"
names(rasti_g)[names(rasti_g) == "delez"] <- "rast"
model7g <- lm(rast~leto, data=rasti_g)
prg <- predict(model7g, data.frame(leto=seq.int(2020, 2025, 1)))
napoved_rasti_g <- data.frame(leto = c(2020, 2021, 2022, 2023, 2024, 2025), rast = c(prg[1], prg[2], prg[3], prg[4], prg[5], prg[6]))
napoved_rasti_g$drzava <- grcija
napoved_rasti_g$vrsta <- "napoved"
skupne_rasti_g <- rbind(rasti_g, napoved_rasti_g)

napoved_rasti <- rbind(skupne_rasti_b, skupne_rasti_g, skupne_rasti_t)

graf7a <- ggplot(napoved_rasti, aes(x=leto, y=rast, col=drzava, shape=vrsta)) +
  geom_point() + ggtitle("Napoved rasti držav z največjo rastjo") +
  xlab("leto") + ylab("delež v %") + facet_grid(. ~ drzava) + stat_smooth(method="lm") +
  coord_trans(y=logisticna_trans) + scale_y_continuous(breaks=logisticna_breaks,
                                                       labels=logisticna)

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

primerjava_rasti_komunikacije_log <- primerjava_rasti_komunikacije %>% mutate(delez=logisticna_inv(delez))

graf8 <- ggplot(primerjava_rasti_komunikacije_log %>% filter(drzava %in% c("Latvija", "Estonija", "Danska", "Bolgarija", "Italija")),
                aes(x=leto, y=delez, col=drzava)) +
  geom_point() + ggtitle("Primerjava rasti držav z največjo in najmanjšo stopnjo komunikacije") +
  xlab("leto") + ylab("delež v %") + facet_grid(. ~ drzava) + stat_smooth(method="lm") +
  coord_trans(y=logisticna_trans) + scale_y_continuous(breaks=logisticna_breaks,
                                                       labels=logisticna) +
  theme(axis.text.x=element_text(angle=45, vjust=0.5, hjust=1))

komunikacija_b <- primerjava_rasti_komunikacije_log %>% filter(drzava=="Bolgarija")
komunikacija_b$vrsta <- "podatki"
names(komunikacija_b)[names(komunikacija_b) == "delez"] <- "rast"
model8b <- lm(rast~leto, data=komunikacija_b)
prb <- predict(model8b, data.frame(leto=seq.int(2020, 2025, 1)))
napoved_komunikacije_b <- data.frame(leto = c(2020, 2021, 2022, 2023, 2024, 2025), rast = c(prb[1], prb[2], prb[3], prb[4], prb[5], prb[6]))
napoved_komunikacije_b$drzava <- bolgarija
napoved_komunikacije_b$vrsta <- "napoved"
skupna_komunikacija_b <- rbind(komunikacija_b, napoved_komunikacije_b)

danska <- c('Danska')
komunikacija_d <- primerjava_rasti_komunikacije_log %>% filter(drzava=="Danska")
komunikacija_d$vrsta <- "podatki"
names(komunikacija_d)[names(komunikacija_d) == "delez"] <- "rast"
model8d <- lm(rast~leto, data=komunikacija_d)
prd <- predict(model8d, data.frame(leto=seq.int(2020, 2025, 1)))
napoved_komunikacije_d <- data.frame(leto = c(2020, 2021, 2022, 2023, 2024, 2025), rast = c(prd[1], prd[2], prd[3], prd[4], prd[5], prd[6]))
napoved_komunikacije_d$drzava <- danska
napoved_komunikacije_d$vrsta <- "napoved"
skupna_komunikacija_d <- rbind(komunikacija_d, napoved_komunikacije_d)

estonija <- c('Estonija')
komunikacija_e <- primerjava_rasti_komunikacije_log %>% filter(drzava=="Estonija")
komunikacija_e$vrsta <- "podatki"
names(komunikacija_e)[names(komunikacija_e) == "delez"] <- "rast"
model8e <- lm(rast~leto, data=komunikacija_e)
pre <- predict(model8e, data.frame(leto=seq.int(2020, 2025, 1)))
napoved_komunikacije_e <- data.frame(leto = c(2020, 2021, 2022, 2023, 2024, 2025), rast = c(pre[1], pre[2], pre[3], pre[4], pre[5], pre[6]))
napoved_komunikacije_e$drzava <- estonija
napoved_komunikacije_e$vrsta <- "napoved"
skupna_komunikacija_e <- rbind(komunikacija_e, napoved_komunikacije_e)

italija <- c('Italija')
komunikacija_i <- primerjava_rasti_komunikacije_log %>% filter(drzava=="Italija")
komunikacija_i$vrsta <- "podatki"
names(komunikacija_i)[names(komunikacija_i) == "delez"] <- "rast"
model8i <- lm(rast~leto, data=komunikacija_i)
pri <- predict(model8i, data.frame(leto=seq.int(2020, 2025, 1)))
napoved_komunikacije_i <- data.frame(leto = c(2020, 2021, 2022, 2023, 2024, 2025), rast = c(pri[1], pri[2], pri[3], pri[4], pri[5], pri[6]))
napoved_komunikacije_i$drzava <- italija
napoved_komunikacije_i$vrsta <- "napoved"
skupna_komunikacija_i <- rbind(komunikacija_i, napoved_komunikacije_i)

latvija <- c('Latvija')
komunikacija_l <- primerjava_rasti_komunikacije_log %>% filter(drzava=="Latvija")
komunikacija_l$vrsta <- "podatki"
names(komunikacija_l)[names(komunikacija_l) == "delez"] <- "rast"
model8l <- lm(rast~leto, data=komunikacija_l)
prl <- predict(model8l, data.frame(leto=seq.int(2020, 2025, 1)))
napoved_komunikacije_l <- data.frame(leto = c(2020, 2021, 2022, 2023, 2024, 2025), rast = c(prl[1], prl[2], prl[3], prl[4], prl[5], prl[6]))
napoved_komunikacije_l$drzava <- latvija
napoved_komunikacije_l$vrsta <- "napoved"
skupna_komunikacija_l <- rbind(komunikacija_l, napoved_komunikacije_l)

napoved_komunikacije <- rbind(skupna_komunikacija_b, skupna_komunikacija_d, skupna_komunikacija_e,
                              skupna_komunikacija_i, skupna_komunikacija_l)

graf8a <- ggplot(napoved_komunikacije, aes(x=leto, y=rast, col=drzava, shape=vrsta)) +
  geom_point() + ggtitle("Napoved komunikacije državljanov z oblastmi") +
  xlab("leto") + ylab("delež v %") + facet_grid(. ~ drzava) + stat_smooth(method="lm") +
  coord_trans(y=logisticna_trans) + scale_y_continuous(breaks=logisticna_breaks,
                                                       labels=logisticna) +
  theme(axis.text.x=element_text(angle=45, vjust=0.5, hjust=1))


install.packages("rstan", repos = "https://cloud.r-project.org/", dependencies = TRUE)
library(rstan)

y <- read.table("hw4data_stan.txt")
N <- length(y[,1])

plot(density(y[,1]))
plot(density(y[,2]))
plot(density(y[,3]))
plot(density(y[,4]))

## stan data
stan_data <- list(N = N, y = y, K = 3, D = 4)

write("// Stan model

      data {
        int N; // sample size
        int D; // dimension of observed vars
        int K; // number of latent groups
        vector[D] y[N]; // data
      }

      parameters {
        ordered[K] mu; // locations of hidden states
        vector<lower = 0>[K] sigma; // variances of hidden states
        simplex[K] theta[D]; // mixture components
      }

      model {
        vector[K] obs[D];

        // priors
        for(k in 1:K){
          mu[k] ~ normal(0,10);
          sigma[k] ~ inv_gamma(1,1);
        }

        for(d in 1:D){
          theta[d] ~ dirichlet(rep_vector(2.0, K));
        }

        // likelihood
        for(d in 1:D){
          for(i in 1:N) {
            for(k in 1:K) {
              obs[d][k] = log(theta[d][k]) + normal_lpdf(y[i][d] | mu[k], sigma[k]);
            }
            target += log_sum_exp(obs[d]);
          }
        }
      } ",

"stan_model.stan")

## check
stanc("stan_model.stan")

## save filepath
stan_model <- "stan_model.stan"

## fit
fit <- stan(file = stan_model, data = stan_data, warmup = 500, iter = 1000, chains = 4, cores = 2, thin = 1)

## check it out
fit

## look at posterior
posterior <- extract(fit)
hist(posterior$mu)

## some other diagnostics
traceplot(fit)
stan_dens(fit)
stan_hist(fit)

## try out some variational inference methods in Stan...
m <- stan_model(file = "stan_model.stan")
fit2 <- vb(m, data = stan_data, algorithm = "meanfield")
fit2


# Example : 2.5B   Chapter : 2.5   Pageno : 88
# Inverse of the given matrices
B<-matrix(c(4,8,3,7),ncol=2)
C<-matrix(c(6,6,6,0),ncol=2)
S<-matrix(c(1,1,1,0,1,1,0,0,1),ncol=3)
B1<-solve(B)
C1<-solve(C)
S1<-solve(S)
print("Inverses of given matrices ")
print(B1)
print(C1)
print(S1)


##### rmse function
rmse <- function(y, yhat){

	yhat[yhat < 0] = 0
	r = sqrt(mean((y - yhat)^2));
	return(r);
}
##### rmsle function
rmsle <- function(y, yhat){

	yhat[yhat < 0] = 0
	r = sqrt(mean((log(y+1) - log(yhat+1))^2));
	return(r);
}
#################################################################
# RMSLE based Objective function t
rmsle_objfun <- function(beta,y,x){

	yhat = x%*%beta;
	yhat[yhat <0] =0;
	res <- rmsle(y,yhat)
	#n = length(y);
	#attr(res, "gradient") <- -t((log(y+1) - log(yhat+1))/(yhat+1))%*%x/(n*res);
	return(res);
}
# RMSLog_Yratio based Objective function
rmslyr_objfun <- function(beta,yr,x){

	yrhat = x%*%beta;

	res <- sqrt(mean((log(yr) - log(yrhat))^2));
	return(res);
}
# RMSE based Objective function
rmse_objfun <- function(beta,y,x){

	yhat = x%*%beta;

	res <- sqrt(mean((y - yhat)^2));
	return(res);
}

###################################################################
single_test <- function(dtest,params,onresids=F){
	test.x = as.matrix(dtest$X)
	if (onresids){

		yratio_hat <- test.x %*% params
		test.yhat <- yratio_hat*dtest$yhat_prev + yratio_hat - 1
	}
	else{
		test.yhat <- test.x %*% params
	}
  test.yhat[test.yhat < 0] = 0
	test.rmsle <- rmsle(dtest$Y, test.yhat)
	return(list(rmsle = test.rmsle,yhat=test.yhat))

}
single_fit <- function(dtrain,init.param,onresids=F){

	train.x = as.matrix(dtrain$X)
	if(onresids){
		optim.y = dtrain$yratio
		# oout = nlm(rmslyr_objfun, init.param, optim.y,train.x);
		# oout = nlm(rmse_objfun, init.param, optim.y,train.x);

		oout =  optim(init.param, rmslyr_objfun, gr = NULL, optim.y, train.x, method = "BFGS", control=list((maxit = 1E3)));
	}
	else{
		optim.y = dtrain$Y
		# oout = nlm(rmsle_objfun, init.param, optim.y,train.x);

		oout =  optim(init.param, rmsle_objfun, gr = NULL, optim.y, train.x, method = "BFGS", control=list((maxit = 1E3)));
	}

	# fminval = oout$minimum
	# params = oout$estimate
	fminval = oout$value
	params = oout$par

	if (onresids){
		yratio_hat <- train.x %*% params
		train.yhat <- yratio_hat*dtrain$yhat_prev + yratio_hat - 1

	}
	else{
		train.yhat <- train.x %*% params
	}
	train.rmsle <- rmsle(dtrain$Y, train.yhat)

	res = list(params = params, fminval = fminval, train.rmsle = train.rmsle)
	return(res)
}
mycortest <- function(X,Y){
	randind = sample(1:length(Y),length(Y))
	pY = Y[randind]

	par(mfrow=c(2,1))

	plot(X,Y,main=round(cor(X,Y),2));
	abline(h=0,lwd=2,col='red')
	#mod = lm(formula = Y[X>300] ~ X[X>300])
	#abline(a=mod$coef[1],b=mod$coef[2],col='green',lwd=2)

	plot(X,pY,main=round(cor(X,pY),2))
	abline(h=0,lwd=2,col='red')

}

###################################################################
nfold_jknife <- function(dall,Nf,test_frac,init.param,onresids=F,fullres = F){
	N = length(dall$Y)
	Ntest = floor(N*test_frac)
	set.seed(59);

	params = matrix(0,Nf,length(init.param))
	fminval = rep(0,Nf)
	train.rmsle = rep(0,Nf)
	test.rmsle = rep(0,Nf)
  if(fullres==T){
    test.inds = matrix(0,Ntest,Nf)
    test.pred = matrix(0,Ntest,Nf)
  }
	for (i in 1:Nf){
		test_inds = sample(1:N, Ntest);
		test.X = dall$X[test_inds,]
		test.Y = dall$Y[test_inds]
		train.X = dall$X[-test_inds,]
		train.Y = dall$Y[-test_inds]

		if(onresids){
			test.yhat_prev = dall$yhat_prev[test_inds]
			test.yratio = dall$yratio[test_inds]
			train.yhat_prev = dall$yhat_prev[-test_inds]
			train.yratio = dall$yratio[-test_inds]

			dtrain = list(X = train.X, Y = train.Y, yhat_prev = train.yhat_prev, yratio = train.yratio)
			dtest = list(X = test.X, Y = test.Y, yhat_prev = test.yhat_prev, yratio = test.yratio)
		}else{
			dtrain = list(X = train.X, Y = train.Y)
			dtest = list(X = test.X, Y = test.Y)
		}
		r <- single_fit(dtrain,init.param,onresids)

		# Store the results
		params[i,] <- r$params
		fminval[i] <- r$fminval
		train.rmsle[i] <- r$train.rmsle
    rtest = single_test(dtest,r$params,onresids)
		test.rmsle[i] <- rtest$rmsle
    if(fullres==T){
      test.pred[,i] = rtest$yhat
      test.inds[,i] = test_inds
    }
		cat(sprintf('JK-iter %i, train rmsle %.6f, test rmsle %.6f\n',i,train.rmsle[i],test.rmsle[i]))
		flush.console()
	}
  if(fullres==T){
    res = list(params=params,fminvals = fminval, train.rmsle = train.rmsle, test.rmsle = test.rmsle, test.inds = test.inds, test.pred = test.pred)
  }else{
	  res = list(params=params,fminvals = fminval, train.rmsle = train.rmsle, test.rmsle = test.rmsle)
  }
  cat(sprintf('AggRes:: median(train rmsle) %.6f, median(test rmsle) %.6f\n',median(train.rmsle),median(test.rmsle)))
  flush.console()
	return(res)
}

rmsle_fun <- function(beta,y,x){
n = length(y);
yhat = x%*%beta;
yhat[yhat <0] =0;
res <- sqrt(mean((log(y+1) - log(yhat+1))^2));
#attr(res, "gradient") <- -t((log(y+1) - log(yhat+1))/(yhat+1))%*%x/(n*res);
return(res);
}

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

FitValidatePredictAll <- function(y.train, x.train, x.lead, model1, model2, model3, beta1, beta2, beta3){

n = length(y.train);
loss.train = rep(0,4); ### seg1, seg2, seg3, overall
loss.test = rep(0,4);  ### seg1, seg2, seg3, overall
### do a training-test split (80-20)
### fit on training, validate on test and return joint fit coefficients
set.seed(39);
samp = sample(1:n, floor(0.8*n));
x.tr = x.train[samp,];
y.tr = y.train[samp];
x.te = x.train[-samp,];
y.te = y.train[-samp];

#####################################################################
### Fit on the training -seg1
#####################################################################
x1 = as.matrix(cbind(1, x.tr[x.tr$seg==1, model1]));
y1 = y.tr[x.tr$seg ==1];
p1 = length(model1)+1;
mod1 =  optim(beta1, rmsle_fun, gr = NULL, y1, x1 , method = "BFGS");

### Predict on test -seg1
x1.te = as.matrix(cbind(1, x.te[x.te$seg==1, model1]));
y1.te = y.te[x.te$seg ==1];
pred1.te = x1.te%*%mod1$par;
pred1.te[pred1.te <0] =0;

### compute loss
#loss.train[1] = mod1$minimum;
loss.test[1] = rmsle(y1.te, pred1.te);

#################################################################33
### Fit on the training -seg2
###################################################################
x2 = as.matrix(cbind(1, x.tr[x.tr$seg==2, model2]));
y2 = y.tr[x.tr$seg ==2];
p2 = length(model2)+1;
mod2 =  optim(beta2, rmsle_fun, gr = NULL, y2, x2, method = "BFGS");

### Predict on test -seg2
x2.te = as.matrix(cbind(1, x.te[x.te$seg==2, model2]));
y2.te = y.te[x.te$seg ==2];
pred2.te = x2.te%*%mod2$par;
pred2.te[pred2.te <0] =0;

### compute loss
#loss.train[2] = mod2$minimum;
loss.test[2] = rmsle(y2.te, pred2.te);

#################################################################33
### Fit on the training -seg3
###################################################################
x3 = as.matrix(cbind(1, x.tr[x.tr$seg==3, model3]));
y3 = y.tr[x.tr$seg ==3];
p3 = length(model3)+1;
mod3 =  optim(beta3, rmsle_fun, gr = NULL, y3, x3, method = "BFGS");

### Predict on test -seg3
x3.te = as.matrix(cbind(1, x.te[x.te$seg ==3, model3]));
y3.te = y.te[x.te$seg ==3];
pred3.te = x3.te%*%mod3$par;
pred3.te[pred3.te <0] =0;

### compute loss
#loss.train[3] = mod3$minimum;
loss.test[3] = rmsle(y3.te, pred3.te);

#######################################################################
### Compute Overall loss
#######################################################################
fit = rep(0,nrow(x.tr));
fit[x.tr$seg ==1] = x1%*%mod1$par;
fit[x.tr$seg ==2] = x2%*%mod2$par;
fit[x.tr$seg ==3] = x3%*%mod3$par;
fit[fit <0] =0;

pred.te = rep(0,nrow(x.te));
pred.te[x.te$seg ==1] = x1.te%*%mod1$par;
pred.te[x.te$seg ==2] = x2.te%*%mod2$par;
pred.te[x.te$seg ==3] = x3.te%*%mod3$par;
pred.te[pred.te <0] =0;

loss.train[1] = rmsle(y.tr[x.tr$seg ==1], fit[x.tr$seg ==1]);
loss.train[2] = rmsle(y.tr[x.tr$seg ==2], fit[x.tr$seg ==2]);
loss.train[3] = rmsle(y.tr[x.tr$seg ==3], fit[x.tr$seg ==3]);
loss.train[4] = rmsle(y.tr, fit);
loss.test[4] = rmsle(y.te, pred.te);

##########################################################################
### Generate prediction for the leaderboard
##########################################################################
x1.lead = as.matrix(cbind(1, x.lead[x.lead$seg==1, model1]));
x2.lead = as.matrix(cbind(1, x.lead[x.lead$seg==2, model2]));
x3.lead = as.matrix(cbind(1, x.lead[x.lead$seg==3, model3]));

pred.lead = rep(0, nrow(x.lead));
pred.lead[x.lead$seg ==1] = x1.lead%*%mod1$par;
pred.lead[x.lead$seg ==2] = x2.lead%*%mod2$par;
pred.lead[x.lead$seg ==3] = x3.lead%*%mod3$par;
pred.lead[pred.lead <0] =0;

r = list(loss.train = loss.train, loss.test = loss.test, seg1.beta = mod1$par, seg2.beta = mod2$par,
seg3.beta = mod3$par, pred.lead = pred.lead);
return(r);
}


### FIRST PART

calcCurvature <- function(trip,nlag) {

  ib=seq(2,nrow(trip)-1)
  ia=ib-1
  ic=ib+1
  A_x = trip$x[ia]
  B_x = trip$x[ib]
  C_x = trip$x[ic]
  A_y = trip$y[ia]
  B_y = trip$y[ib]
  C_y = trip$y[ic]
  D = 2 * (A_x*(B_y - C_y) + B_x*(C_y - A_y) + C_x*(A_y - B_y) )
  U_x = ((A_x^2 + A_y^2) * (B_y - C_y) + (B_x^2 + B_y^2) * (C_y - A_y) + (C_x^2 + C_y^2) * (A_y - B_y)) / D
  U_y = ((A_x^2 + A_y^2) * (C_x - B_x) + (B_x^2 + B_y^2) * (A_x - C_x) + (C_x^2 + C_y^2) * (B_x - A_x)) / D
  R = sqrt((A_x - U_x)^2 + (A_y - U_y)^2)
  #   cur <- data.table(center_x = c(NA, U_x, NA),
  #                     center_y = c(NA, U_y, NA),
  #                     radius = c(NA, R, NA))
  mlag <- nlag
  if (nlag %% 2 == 0) {
    mlag <- nlag + 1
  }
  f21 <- rep(1/mlag,mlag)
  smth_x <- filter(U_x, f21, sides=2)
  smth_y <- filter(U_y, f21, sides=2)
  smth_R <- filter(R, f21, sides=2)
  cur_smooth <- data.table(center_x = c(NA, smth_x, NA),
                           center_y = c(NA, smth_y, NA),
                           radius = c(NA, smth_R, NA))
  return(cur_smooth)
}

speedDistribution <- function(trip)
{

  vitesse = 3.6*sqrt(diff(trip$x,1,1)^2 + diff(trip$y,1,1)^2)/20

  vitesse5 = 3.6*sqrt(diff(trip$x,5,1)^2 + diff(trip$y,5,1)^2)/20

  vitesse10 = 3.6*sqrt(diff(trip$x,10,1)^2 + diff(trip$y,10,1)^2)/20

  vitesse20 = 3.6*sqrt(diff(trip$x,20,1)^2 + diff(trip$y,20,1)^2)/20

  tangacel = 3.6*sqrt(diff(trip$x,1,2)^2 + diff(trip$y,1,2)^2)/20

  tangacel5 = 3.6*sqrt(diff(trip$x,5,2)^2 + diff(trip$y,5,2)^2)/20

  tangacel10 = 3.6*sqrt(diff(trip$x,10,2)^2 + diff(trip$y,10,2)^2)/20

  tangacel20 = 3.6*sqrt(diff(trip$x,20,2)^2 + diff(trip$y,20,2)^2)/20

  cur <- calcCurvature(trip,1)
  cur5 <- calcCurvature(trip,5)
  cur10 <- calcCurvature(trip,10)
  cur20 <- calcCurvature(trip,20)

  acelnorm = c(rep(NA,1),vitesse)/cur$radius
  acelnorm5 = c(rep(NA,5),vitesse5)/cur5$radius
  acelnorm10 = c(rep(NA,10),vitesse10)/cur10$radius
  acelnorm20 = c(rep(NA,20),vitesse20)/cur20$radius

  aceltotal = acelnorm + c(rep(NA,2),tangacel)
  aceltotal5 = acelnorm5 + c(rep(NA,10),tangacel5)
  aceltotal10 = acelnorm10 + c(rep(NA,20),tangacel10)
  aceltotal20 = acelnorm20 + c(rep(NA,40),tangacel20)

  dist = sum(vitesse)
  acel = diff(vitesse,1,1)

  features = c( cbind(quantile(vitesse, seq(0.05,1, by = 0.05)),
                   quantile(vitesse5, seq(0.05,1, by = 0.05)),
                   quantile(vitesse10, seq(0.05,1, by = 0.05)),
                   quantile(vitesse20, seq(0.05,1, by = 0.05)),
                   quantile(tangacel, seq(0.05,1, by = 0.05)),
                   quantile(tangacel5, seq(0.05,1, by = 0.05)),
                   quantile(tangacel10, seq(0.05,1, by = 0.05)),
                   quantile(tangacel20, seq(0.05,1, by = 0.05)),
                   quantile(cur$radius[is.finite(cur$radius) ] , seq(0.05,1, by = 0.05), na.rm = T),
                   quantile(cur5$radius[is.finite(cur5$radius) ] , seq(0.05,1, by = 0.05), na.rm = T),
                   quantile(cur10$radius[is.finite(cur10$radius) ] , seq(0.05,1, by = 0.05), na.rm = T),
                   quantile(cur20$radius[is.finite(cur20$radius) ] , seq(0.05,1, by = 0.05), na.rm = T),
                   quantile(acelnorm, seq(0.05,1, by = 0.05), na.rm = T),
                   quantile(acelnorm5, seq(0.05,1, by = 0.05), na.rm = T),
                   quantile(acelnorm10, seq(0.05,1, by = 0.05), na.rm = T),
                   quantile(acelnorm20, seq(0.05,1, by = 0.05), na.rm = T),
                   quantile(aceltotal, seq(0.05,1, by = 0.05), na.rm = T),
                   quantile(aceltotal5, seq(0.05,1, by = 0.05), na.rm = T),
                   quantile(aceltotal10, seq(0.05,1, by = 0.05), na.rm = T),
                   quantile(aceltotal20, seq(0.05,1, by = 0.05), na.rm = T),
                   quantile(acel, seq(0.05,1, by = 0.05)))
              ,
                   length(trip[,1]), var(vitesse), var(vitesse5), var(vitesse10), var(vitesse20),
                   var(tangacel), var(tangacel5), var(tangacel10), var(tangacel20),
                   var(acelnorm,na.rm = T), var(acelnorm5,na.rm = T), var(acelnorm10,na.rm = T),
                   var(acelnorm20,na.rm = T), var(acel,na.rm = T))

  return(features)
}

### SECOND PART (BASED ON DEXUAN'S CODE)

features2 <- function(trip)
{
  v = NULL
  angle = NULL
  acceleration = NULL
  deceleration = NULL
  turning_speed = NULL
  distancesum = 0
  shift = -1

  for(i in 2:length(trip[,1])){
    dist = sqrt((trip$x[i-1] - trip$x[i])^2 + (trip$y[i-1] - trip$y[i])^2)
    v = rbind(v,dist)
    distancesum = distancesum + dist

    flag = 1
    if(i > 2){
      if(v[i-1] >= v[i-2]){
        acceleration = rbind(acceleration, (v[i-1]-v[i-2]))

        if(flag == 0){
          shift = shift + 1
          flag = 1
        }

      }
      else{
        deceleration = rbind(deceleration, (v[i-2]-v[i-1]))
        if(flag == 1){
          shift = shift + 1
          flag = 0
        }

      }

      dist_2 = sqrt((trip$x[i-2] - trip$x[i])^2 + (trip$y[i-2] - trip$y[i])^2)
      if(v[i-1]*v[i-2] != 0){
        cosin = (v[i-1]*2+v[i-2]*2-dist_2*2)/(2*v[i-1]*v[i-2])
      }
      else{
        cosin = -1
      }
      angle = rbind(angle,(pi-acos(max(min(cosin, 1), -1))))
      temp = angle[i-2]*(v[i-1]+v[i-2])/2
      #if temp>0:
      turning_speed = rbind(turning_speed,temp)
    }

  }

  features = c(cbind(quantile(v, seq(0.05,1, by = 0.05)),
                 quantile(angle, seq(0.05,1, by = 0.05)),
                 quantile(acceleration, seq(0.05,1, by = 0.05)),
                 quantile(deceleration, seq(0.05,1, by = 0.05)),
                 quantile(turning_speed, seq(0.05,1, by = 0.05))),
                 var(v),var(angle),var(acceleration),var(deceleration),
                 var(turning_speed),distancesum,shift)

  return(features)

}


#' Optimal Rank Beta
#'
#' This finds recommends a beta value between two extremes where the rank correlation between the two extremes best agrees.
#'
#' @param g An igraph graph object
#' @param comp.left The beta on the left for comparison
#' @param comp.right The beta on the right for comparison
#' @param starting.beta The beta value to start when starting the optimization
#' @export
#' @examples
#' pii(g, pii.beta = optimal.rank.beta(g))
#'

optimal.rank.beta <-  function(g, comp.left = -0.9, comp.right = -0.5, starting.beta = -0.8) {
  rc.diff <- function(b, g, comp.left = comp.left, comp.right = comp.right) {
      p <- pii(g, pii.beta = b)
      pii.left <- pii(g, pii.beta = comp.left)
      pii.right <- pii(g, pii.beta = comp.right)
      rc.left = cor(p, pii.left, method = "spearman")
      rc.right = cor(p, pii.right, method = "spearman")
      return(abs(rc.left - rc.right))
    }

  o <- optim( par = c(starting.beta), fn = rc.diff, gr = NULL,
              g = g, comp.right = comp.right, comp.left = comp.left, method = 'Brent',
              lower = -1, upper = -0.001)
  cross.point <- o$par
  attr(cross.point, 'spearman.correlation') <- cor(pii(g, pii.beta = cross.point), pii(g, pii.beta = cross.point), method = 'spearman')
  attr(cross.point, 'approx') <- o$value
  return(cross.point)
}


Horner <- function(Coef_Polinomio, x0) {
  # Creación de la función,
  #recibe los coeficientes del polinomio
  #y el punto a evaluar.
  TerminoInd <- Coef_Polinomio[1]
  Coef_Polinomio <- Coef_Polinomio[-1]
  #Guarda el término de independiente en una
  #variable aparte de los coeficientes que
  #acompañan algún valor de "x".
  P_x0  <- Coef_Polinomio[length(Coef_Polinomio)]
  P1_x0 <- Coef_Polinomio[length(Coef_Polinomio)]
  j <- length(Coef_Polinomio)-1
  #Guarda los coeficientes no independientes
  #del polinomio en dos variables,
  #y se inicializa la variable iterativa.
  while (j>0) {
    P_x0  <- x0*P_x0 + Coef_Polinomio[j]
    P1_x0 <- x0*P1_x0 + P_x0
    j <- j-1
  }
  #Se aplica el Método de Horner para
  #calcular el valor del polinomio en x0
  #y el valor de su derivada en x0.
  P_x0 <- (x0*P_x0)+TerminoInd
  #Se suma el término independiente al polinomio,
  #pero no a la derivada, ya que en la
  #derivada este término desaparece.
  cat(paste("P(", x0, ") =", P_x0,
            "\nP'(", x0, ") =", P1_x0))
}
#Se imprimen los resultados.
#Siendo P_x0 el valor del polinomio en x0 y
#P1_x0 el valor de la derivada en x0.

HornerC <- function(Coef_Polinomio, x0) {
  Coef_Polinomio  <- as.complex(Coef_Polinomio)
  #Los coeficientes pasan a ser tratados como números complejos.
  TerminoInd      <- Coef_Polinomio[1]
  Coef_Polinomio  <- Coef_Polinomio[-1]
  P_x0  <- Coef_Polinomio[length(Coef_Polinomio)]
  P1_x0 <- Coef_Polinomio[length(Coef_Polinomio)]
  j <- length(Coef_Polinomio)-1
  while (j>0) {
    P_x0  <- x0*P_x0 + Coef_Polinomio[j]
    P1_x0 <- x0*P1_x0 + P_x0
    j <- j-1
  }
  P_x0 <- (x0*P_x0)+TerminoInd
  cat(paste("P(", x0, ") =", P_x0,
            "\nP'(", x0, ") =", P1_x0))
}

install.packages("signal")
library(signal)
Operaciones <- 0
#Se instala un paquete para utilizar
#la función "polyval" más adelante y se
#inicia el número de operaciones PRINCIPALES en 0.

Seno_Taylor <- function(n){
  Taylor_Pol <- c()
  for(i in 0:n){
    Taylor_Pol <- c(Taylor_Pol,0)
    Taylor_Pol <- c(Taylor_Pol,((-1)^i)/factorial(2*i+1))
    Operaciones <- Operaciones + 1
  }
  return(Taylor_Pol)
}
#Esta función recibe un valor de "n"
#y devuelve los coeficientes del polinomio de Taylor
#de grado "n" de la función seno.

Norm <- function(vect1,vect2){
  error_relativo <- 0
  err <- 0
  for(i in 1:length(vect1)){
    error_relativo <- error_relativo + abs(vect1[i]-vect2[i])
    Operaciones <- Operaciones + 1
    err <- err + abs(vect1[i])
    Operaciones <- Operaciones + 1
  }
  return((error_relativo/err)-1)
}
#Se define una función que recibe imágenes de dos
#funciones en los mismos puntos, y devuelve una forma
#de medir el error que hay entre ellas.
#En este caso se calcula este error como un ponderado
#de los valores absolutos de las restas entre valores.

Taylor <- function(error_minimo){
  test_val <- c()
  for(i in seq(from=-pi/64,to=pi/64,by=0.001)){
    test_val <- c(i,test_val)
  }
  #Se generan varios valores en el intervalo de interés
  #y se guardan en la variable "test_val".
  iteraciones <- 0
  n <- 0
  e_rel <- 1
  #Se inicializan varias variables.
  #El número de iteraciones en 0, el grado del
  #polinomio de Taylor en 0, y el error relativo en 1.
  cat("Iteracion =",iteraciones,"\n")
  #Se muestra la iteración en la que va el código.
  Aprox_Pol <- Seno_Taylor(n)
  Pol_Ant <- polyval(Aprox_Pol[length(Aprox_Pol):1],test_val)
  #Se inicializa el polinomio de aproximación en grado 0
  #y se evaluan los datos de prueba en él.
  Operaciones <- Operaciones + 1
  while(e_rel>error_minimo){
    n <- n+1
    Operaciones <- Operaciones + 1
    Aprox_Pol <- Seno_Taylor(n)
    Pol_Act <- polyval(Aprox_Pol[length(Aprox_Pol):1],test_val)
    #La función polyval evalúa el vector de puntos en el
    #polinomio, dados sus coeficientes en orden descendente.
    Operaciones <- Operaciones + 1
    e_rel <- Norm(Pol_Ant,Pol_Act)
    iteraciones <- iteraciones+1
    cat("Iteracion =",iteraciones,"\n")
    cat("Error Relativo =",e_rel,"\n")
    Pol_Ant <- Pol_Act
  }
  #Se lleva a cabo la aproximación de Taylor.
  #A cada iteración se eleva el grado del polinomio de
  #aproximación en 1, se evaluan los datos de prueba en él,
  #y se compara con los valores anteriores bajo la norma
  #definida arriba. Esto se repite hasta que el error sea
  #menor al valor ingresado por el usuario.
  cat("Polinomio =",Aprox_Pol,"\n")
  cat("Operaciones =",Operaciones,"\n")
  #Se imprimen los coeficientes del polinomio
  #que mejor aproxima la función en el intervalo
  #dado y el número de operaciones principales
  #que se realizaron.
}

install.packages("limSolve")
install.packages("signal")
library(signal)
library(limSolve)
#Se instalan dos paquetes, uno para poder utilizar la función
#"polyval", y el otro para utilizar la función "Solve" más adelante.

Norma_f <- function(p){
  inf <- 0
  ans <- c(0,0)
  for(i in seq(from=-pi/64,to=pi/64,by=0.001)){
    y = abs(sin(i)-polyval(p[length(p):1],i))
    Operaciones <- Operaciones + 1
    if(y<inf){
      inf <- y
      ans[1] <- inf
      ans[2] <- i
    }
  }
  return(ans)
}
#Esta función estima el valor de la norma que usa el
#método de Remez, devuelve el valor de la norma y
#el punto del intervalo en dónde da dicho valor.
#La función seno ya está predeterminada en el código.

Remez <- function(n,error_min){
  #El usuario debe ingresar el error_min, el cual es el epsilon
  #que aparece en el resúmen del método, y el "n" para la
  #cantidad de datos a tomar al comienzo.
  Iteraciones <- 0
  Operaciones <- 0
  Ptos_Muestra <- c()

  #USAR DATOS UNIFORMEMENTE ELEGIDOS:
  dx = (pi/32)/(n+1)
  for(x in seq(from=-pi/64,to=pi/64,by=dx)){
    Ptos_Muestra <- c(Ptos_Muestra,x)
  }
  #USAR DATOS ALEATORIAMENTE ELEGIDOS
  #Ptos_Muestra <- runif((n+2),min=-pi/64,max=pi/64)

  #Se toman "n+2" datos distribuidos uniformemente en el
  #intervalo de interés.
  while(TRUE){
    cat("Iteracion =",Iteraciones,"\n")
    A <- matrix(Ptos_Muestra,n+2,n+2)
    for(i in seq(from=1,to=n+2,by=1)){
      A[i,1] <- 1
      A[i,n+2] <- (-1)**i
    }
    for(i in seq(from=1,to=n+2,by=1)){
      for(j in seq(from=1,to=n+2,by=1)){
        if(j!=1 && j!=(n+2)){
          A[i,j] <- A[i,j]^j
        }
      }
    }
    #Se crea la matriz que codifica el sistema de
    #ecuaciones linealess que hay que resolver.
    b <- c()
    for(i in Ptos_Muestra){
      b <- rbind(b,sin(i))
    }
    #Se crea el vector que codifica el otro lado de la
    #igualdad del sistema de ecuaciones lineales; en este
    #caso la función "f" es seno.
    B <- Solve(A,b)
    #Se usa el comando "Solve" para hallar la solución "x"
    #al sistema de ecuaciones lineales Ax=b.
    Operaciones <- Operaciones + 1
    Pol <- B[0:n+1]
    e <- B[n+2]
    #Se guardan los coeficientes del polinomio y el error.
    norma <- Norma_f(Pol)
    #Se estima la norma entre el polinomio y el seno.
    cat("Error =",abs(norma[1]-abs(e)),"\n")
    if(abs((norma[1]-abs(e)))<=error_min){
      return(Pol)
      #Se revisa la condición de parada.
    }else{
      E = norma[2]
      for(j in 1:length(Ptos_Muestra)){
        if(E<=Ptos_Muestra[j]){
          Ptos_Muestra[j] <- E
          Iteraciones <- Iteraciones + 1
          break
          #Se agrega el punto (en donde la norma equivale a la
          #resta entre el seno y el polinomio) al conjunto de "n+2"
          #valores y se retira el punto más cercano a éste.
        }
      }
    }
  }
}


hofcon = c(1, 1, rep(NA, 2^20 - 2))
for (n in 3 : (2^20))
  {hofcon[n] =
       hofcon[hofcon[n - 1]] +
       hofcon[n - hofcon[n - 1]]}


# Example : 3   Chapter : 6.6     Page No: 357
# Jordans theorem and Jordan Matrix
J<-matrix(c(5,0,0,1,5,0,0,1,5),ncol=3)
Jev<-eigen(J)$values
JT<-t(J)
JTev<-eigen(JT)$values
print("Jordans theorem says that both J and transpose of J are similar")
print(Jev)
print(JTev)


# ----------------------------------------
#  App Title: Chaos Game -- 3 Dimensions
#     Author: Jimmy Doi
# ----------------------------------------

###################################################################
# Tetrahedron
###################################################################

tetra.gen <- function(wt){
    weight <- wt

    len <- 50000

    # loci matrix to contain all endpoints
		loci <- matrix(NA,ncol=4,nrow=4)

		loci[1,] <- c(1,1,0,-1/sqrt(2))
		loci[2,] <- c(2,-1,0,-1/sqrt(2))
		loci[3,] <- c(3,0,1,1/sqrt(2))
  	loci[4,] <- c(4,0,-1,1/sqrt(2))

    # vertices contains all random vertex points
    vertices <- runif(len)
    vertices[which(vertices>3/4)]<- 4
    vertices[which(2/4<vertices & vertices<=3/4)]<- 3
    vertices[which(1/4<vertices & vertices<=2/4)]<- 2
    vertices[which(vertices<=1/4)]<- 1

    coords <- matrix(NA,ncol=4,nrow=(len+1))

    coords[1,] <- c(runif(1),runif(1)*sqrt(3)/2,runif(1)*sqrt(6)/3,0)

		for (i in 1:len){
		  row <- i+1
      spot <- which(loci[,1]==vertices[i])
      x <- loci[spot,2]
      y <- loci[spot,3]
      z <- loci[spot,4]
      x.new <- weight*x + (1-weight)*coords[i,1]
      y.new <- weight*y + (1-weight)*coords[i,2]
      z.new <- weight*z + (1-weight)*coords[i,3]
	    coords[row,]<-c(x.new,y.new,z.new,0)
		}

    for (i in 1:(len+1)){
      d1 <- sqrt((coords[i,1]-loci[1,2])**2 + (coords[i,2]-loci[1,3])**2 + (coords[i,3]-loci[1,4])**2)
      d2 <- sqrt((coords[i,1]-loci[2,2])**2 + (coords[i,2]-loci[2,3])**2 + (coords[i,3]-loci[2,4])**2)
      d3 <- sqrt((coords[i,1]-loci[3,2])**2 + (coords[i,2]-loci[3,3])**2 + (coords[i,3]-loci[3,4])**2)
      d4 <- sqrt((coords[i,1]-loci[4,2])**2 + (coords[i,2]-loci[4,3])**2 + (coords[i,3]-loci[4,4])**2)
      if (min(d1,d2,d3,d4)==d1) coords[i,4]<-1
      if (min(d1,d2,d3,d4)==d2) coords[i,4]<-2
      if (min(d1,d2,d3,d4)==d3) coords[i,4]<-3
      if (min(d1,d2,d3,d4)==d4) coords[i,4]<-4
    }

    return(list(loci,vertices,coords))
}

###################################################################
# Cube
###################################################################

cube.gen <- function(wt){
    weight <- wt

    len <- 50000

    # loci matrix to contain all endpoints
		loci <- matrix(NA,ncol=4,nrow=20)

		loci[1,]  <-  c(1,0,0,0)
		loci[2,]  <-  c(2,.5,0,0)
		loci[3,]  <-  c(3,1,0,0)
  	loci[4,]  <-  c(4,1,.5,0)
    loci[5,]  <-  c(5,1,1,0)
    loci[6,]  <-  c(6,.5,1,0)
    loci[7,]  <-  c(7,0,1,0)
    loci[8,]  <-  c(8,0,.5,0)
    loci[9,]  <-  c(9,1,0,.5)
    loci[10,] <- c(10,0,0,.5)
    loci[11,] <- c(11,0,1,.5)
    loci[12,] <- c(12,1,1,.5)
  	loci[13,] <- c(13,0,0,1)
		loci[14,] <- c(14,.5,0,1)
		loci[15,] <- c(15,1,0,1)
  	loci[16,] <- c(16,1,.5,1)
    loci[17,] <- c(17,1,1,1)
    loci[18,] <- c(18,.5,1,1)
    loci[19,] <- c(19,0,1,1)
    loci[20,] <- c(20,0,.5,1)

    # vertices contains all random vertex points
    vertices <- runif(len)
    vertices[which(vertices>19/20)]<- 20
    vertices[which(18/20<vertices & vertices<=19/20)]<- 19
    vertices[which(17/20<vertices & vertices<=18/20)]<- 18
    vertices[which(16/20<vertices & vertices<=17/20)]<- 17
    vertices[which(15/20<vertices & vertices<=16/20)]<- 16
    vertices[which(14/20<vertices & vertices<=15/20)]<- 15
    vertices[which(13/20<vertices & vertices<=14/20)]<- 14
    vertices[which(12/20<vertices & vertices<=13/20)]<- 13
    vertices[which(11/20<vertices & vertices<=12/20)]<- 12
    vertices[which(10/20<vertices & vertices<=11/20)]<- 11
    vertices[which(9/20<vertices & vertices<= 10/20)]<- 10
    vertices[which(8/20<vertices & vertices<= 9/20)]<- 9
    vertices[which(7/20<vertices & vertices<= 8/20)]<- 8
    vertices[which(6/20<vertices & vertices<= 7/20)]<- 7
    vertices[which(5/20<vertices & vertices<= 6/20)]<- 6
    vertices[which(4/20<vertices & vertices<= 5/20)]<- 5
    vertices[which(3/20<vertices & vertices<= 4/20)]<- 4
    vertices[which(2/20<vertices & vertices<= 3/20)]<- 3
    vertices[which(1/20<vertices & vertices<= 2/20)]<- 2
    vertices[which(vertices<=1/20)]<- 1

    coords <- matrix(NA,ncol=4,nrow=(len+1))

    coords[1,] <- c(runif(1),runif(1),runif(1),0)

		for (i in 1:len){
		  row <- i+1
      spot <- which(loci[,1]==vertices[i])
      x <- loci[spot,2]
      y <- loci[spot,3]
      z <- loci[spot,4]
      x.new <- weight*x + (1-weight)*coords[i,1]
      y.new <- weight*y + (1-weight)*coords[i,2]
      z.new <- weight*z + (1-weight)*coords[i,3]
	    coords[row,]<-c(x.new,y.new,z.new,0)
		}

    for (i in 1:(len+1)){
      d1 <- sqrt((coords[i,1]-loci[1,2])**2 + (coords[i,2]- loci[1,3])**2 + (coords[i,3]- loci[1,4])**2)
      d2 <- sqrt((coords[i,1]-loci[2,2])**2 + (coords[i,2]- loci[2,3])**2 + (coords[i,3]- loci[2,4])**2)
      d3 <- sqrt((coords[i,1]-loci[3,2])**2 + (coords[i,2]- loci[3,3])**2 + (coords[i,3]- loci[3,4])**2)
      d4 <- sqrt((coords[i,1]-loci[4,2])**2 + (coords[i,2]- loci[4,3])**2 + (coords[i,3]- loci[4,4])**2)
      d5 <- sqrt((coords[i,1]-loci[5,2])**2 + (coords[i,2]- loci[5,3])**2 + (coords[i,3]- loci[5,4])**2)
      d6 <- sqrt((coords[i,1]-loci[6,2])**2 + (coords[i,2]- loci[6,3])**2 + (coords[i,3]- loci[6,4])**2)
      d7 <- sqrt((coords[i,1]-loci[7,2])**2 + (coords[i,2]- loci[7,3])**2 + (coords[i,3]- loci[7,4])**2)
      d8 <- sqrt((coords[i,1]-loci[8,2])**2 + (coords[i,2]- loci[8,3])**2 + (coords[i,3]- loci[8,4])**2)
      d9 <- sqrt((coords[i,1]-loci[9,2])**2 + (coords[i,2]- loci[9,3])**2 + (coords[i,3]- loci[9,4])**2)
      d10<- sqrt((coords[i,1]-loci[10,2])**2 + (coords[i,2]-loci[10,3])**2 + (coords[i,3]-loci[10,4])**2)
      d11<- sqrt((coords[i,1]-loci[11,2])**2 + (coords[i,2]-loci[11,3])**2 + (coords[i,3]-loci[11,4])**2)
      d12<- sqrt((coords[i,1]-loci[12,2])**2 + (coords[i,2]-loci[12,3])**2 + (coords[i,3]-loci[12,4])**2)
      d13<- sqrt((coords[i,1]-loci[13,2])**2 + (coords[i,2]-loci[13,3])**2 + (coords[i,3]-loci[13,4])**2)
      d14<- sqrt((coords[i,1]-loci[14,2])**2 + (coords[i,2]-loci[14,3])**2 + (coords[i,3]-loci[14,4])**2)
      d15<- sqrt((coords[i,1]-loci[15,2])**2 + (coords[i,2]-loci[15,3])**2 + (coords[i,3]-loci[15,4])**2)
      d16<- sqrt((coords[i,1]-loci[16,2])**2 + (coords[i,2]-loci[16,3])**2 + (coords[i,3]-loci[16,4])**2)
      d17<- sqrt((coords[i,1]-loci[17,2])**2 + (coords[i,2]-loci[17,3])**2 + (coords[i,3]-loci[17,4])**2)
      d18<- sqrt((coords[i,1]-loci[18,2])**2 + (coords[i,2]-loci[18,3])**2 + (coords[i,3]-loci[18,4])**2)
      d19<- sqrt((coords[i,1]-loci[19,2])**2 + (coords[i,2]-loci[19,3])**2 + (coords[i,3]-loci[19,4])**2)
      d20<- sqrt((coords[i,1]-loci[20,2])**2 + (coords[i,2]-loci[20,3])**2 + (coords[i,3]-loci[20,4])**2)
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d1) coords[i,4]<-1
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d2) coords[i,4]<-2
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d3) coords[i,4]<-3
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d4) coords[i,4]<-4
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d5) coords[i,4]<-5
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d6) coords[i,4]<-6
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d7) coords[i,4]<-7
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d8) coords[i,4]<-8
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d9) coords[i,4]<-9
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d10) coords[i,4]<-10
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d11) coords[i,4]<-11
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d12) coords[i,4]<-12
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d13) coords[i,4]<-13
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d14) coords[i,4]<-14
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d15) coords[i,4]<-15
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d16) coords[i,4]<-16
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d17) coords[i,4]<-17
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d18) coords[i,4]<-18
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d19) coords[i,4]<-19
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d20) coords[i,4]<-20
    }

    return(list(loci,vertices,coords))
}

###################################################################
# Dodecahedron
###################################################################

dodec.gen <- function(wt){
    weight <- wt

    len <- 50000

    # loci matrix to contain all endpoints
		loci <- matrix(NA,ncol=4,nrow=20)

    psi <- (1+sqrt(5))/2

		loci[1,]  <-   c(1,1,-1,1)
		loci[2,]  <-   c(2,1,1,-1)
		loci[3,]  <-   c(3,psi,0,-1/psi)
  	loci[4,]  <-   c(4,1,1,1)
    loci[5,]  <-   c(5,-1,1,1)
    loci[6,]  <-   c(6,-1,1,-1)
    loci[7,]  <-   c(7,1/psi,psi,0)
    loci[8,]  <-   c(8,0,1/psi,psi)
    loci[9,]  <-   c(9,-psi,0,-1/psi)
    loci[10,] <-  c(10,0,-1/psi,-psi)
    loci[11,] <-  c(11,0,-1/psi,psi)
    loci[12,] <-  c(12,0,1/psi,-psi)
  	loci[13,] <-  c(13,-1/psi,psi,0)
		loci[14,] <-  c(14,-psi,0,1/psi)
		loci[15,] <-  c(15,-1,-1,1)
  	loci[16,] <-  c(16,-1/psi,-psi,0)
    loci[17,] <-  c(17,psi,0,1/psi)
    loci[18,] <-  c(18,1,-1,-1)
    loci[19,] <-  c(19,1/psi,-psi,0)
    loci[20,] <-  c(20,-1,-1,-1)

    # vertices contains all random vertex points
    vertices <- runif(len)
    vertices[which(vertices>19/20)]<- 20
    vertices[which(18/20<vertices & vertices<=19/20)]<- 19
    vertices[which(17/20<vertices & vertices<=18/20)]<- 18
    vertices[which(16/20<vertices & vertices<=17/20)]<- 17
    vertices[which(15/20<vertices & vertices<=16/20)]<- 16
    vertices[which(14/20<vertices & vertices<=15/20)]<- 15
    vertices[which(13/20<vertices & vertices<=14/20)]<- 14
    vertices[which(12/20<vertices & vertices<=13/20)]<- 13
    vertices[which(11/20<vertices & vertices<=12/20)]<- 12
    vertices[which(10/20<vertices & vertices<=11/20)]<- 11
    vertices[which(9/20<vertices & vertices<= 10/20)]<- 10
    vertices[which(8/20<vertices & vertices<= 9/20)]<- 9
    vertices[which(7/20<vertices & vertices<= 8/20)]<- 8
    vertices[which(6/20<vertices & vertices<= 7/20)]<- 7
    vertices[which(5/20<vertices & vertices<= 6/20)]<- 6
    vertices[which(4/20<vertices & vertices<= 5/20)]<- 5
    vertices[which(3/20<vertices & vertices<= 4/20)]<- 4
    vertices[which(2/20<vertices & vertices<= 3/20)]<- 3
    vertices[which(1/20<vertices & vertices<= 2/20)]<- 2
    vertices[which(vertices<=1/20)]<- 1

    coords <- matrix(NA,ncol=4,nrow=(len+1))

    coords[1,] <- c(runif(1),runif(1),runif(1),0)

		for (i in 1:len){
		  row <- i+1
      spot <- which(loci[,1]==vertices[i])
      x <- loci[spot,2]
      y <- loci[spot,3]
      z <- loci[spot,4]
      x.new <- weight*x + (1-weight)*coords[i,1]
      y.new <- weight*y + (1-weight)*coords[i,2]
      z.new <- weight*z + (1-weight)*coords[i,3]
	    coords[row,]<-c(x.new,y.new,z.new,0)
		}

        for (i in 1:(len+1)){
      d1 <- sqrt((coords[i,1]-loci[1,2])**2 + (coords[i,2]- loci[1,3])**2 + (coords[i,3]- loci[1,4])**2)
      d2 <- sqrt((coords[i,1]-loci[2,2])**2 + (coords[i,2]- loci[2,3])**2 + (coords[i,3]- loci[2,4])**2)
      d3 <- sqrt((coords[i,1]-loci[3,2])**2 + (coords[i,2]- loci[3,3])**2 + (coords[i,3]- loci[3,4])**2)
      d4 <- sqrt((coords[i,1]-loci[4,2])**2 + (coords[i,2]- loci[4,3])**2 + (coords[i,3]- loci[4,4])**2)
      d5 <- sqrt((coords[i,1]-loci[5,2])**2 + (coords[i,2]- loci[5,3])**2 + (coords[i,3]- loci[5,4])**2)
      d6 <- sqrt((coords[i,1]-loci[6,2])**2 + (coords[i,2]- loci[6,3])**2 + (coords[i,3]- loci[6,4])**2)
      d7 <- sqrt((coords[i,1]-loci[7,2])**2 + (coords[i,2]- loci[7,3])**2 + (coords[i,3]- loci[7,4])**2)
      d8 <- sqrt((coords[i,1]-loci[8,2])**2 + (coords[i,2]- loci[8,3])**2 + (coords[i,3]- loci[8,4])**2)
      d9 <- sqrt((coords[i,1]-loci[9,2])**2 + (coords[i,2]- loci[9,3])**2 + (coords[i,3]- loci[9,4])**2)
      d10<- sqrt((coords[i,1]-loci[10,2])**2 + (coords[i,2]-loci[10,3])**2 + (coords[i,3]-loci[10,4])**2)
      d11<- sqrt((coords[i,1]-loci[11,2])**2 + (coords[i,2]-loci[11,3])**2 + (coords[i,3]-loci[11,4])**2)
      d12<- sqrt((coords[i,1]-loci[12,2])**2 + (coords[i,2]-loci[12,3])**2 + (coords[i,3]-loci[12,4])**2)
      d13<- sqrt((coords[i,1]-loci[13,2])**2 + (coords[i,2]-loci[13,3])**2 + (coords[i,3]-loci[13,4])**2)
      d14<- sqrt((coords[i,1]-loci[14,2])**2 + (coords[i,2]-loci[14,3])**2 + (coords[i,3]-loci[14,4])**2)
      d15<- sqrt((coords[i,1]-loci[15,2])**2 + (coords[i,2]-loci[15,3])**2 + (coords[i,3]-loci[15,4])**2)
      d16<- sqrt((coords[i,1]-loci[16,2])**2 + (coords[i,2]-loci[16,3])**2 + (coords[i,3]-loci[16,4])**2)
      d17<- sqrt((coords[i,1]-loci[17,2])**2 + (coords[i,2]-loci[17,3])**2 + (coords[i,3]-loci[17,4])**2)
      d18<- sqrt((coords[i,1]-loci[18,2])**2 + (coords[i,2]-loci[18,3])**2 + (coords[i,3]-loci[18,4])**2)
      d19<- sqrt((coords[i,1]-loci[19,2])**2 + (coords[i,2]-loci[19,3])**2 + (coords[i,3]-loci[19,4])**2)
      d20<- sqrt((coords[i,1]-loci[20,2])**2 + (coords[i,2]-loci[20,3])**2 + (coords[i,3]-loci[20,4])**2)
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d1) coords[i,4]<-1
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d2) coords[i,4]<-2
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d3) coords[i,4]<-3
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d4) coords[i,4]<-4
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d5) coords[i,4]<-5
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d6) coords[i,4]<-6
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d7) coords[i,4]<-7
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d8) coords[i,4]<-8
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d9) coords[i,4]<-9
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d10) coords[i,4]<-10
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d11) coords[i,4]<-11
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d12) coords[i,4]<-12
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d13) coords[i,4]<-13
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d14) coords[i,4]<-14
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d15) coords[i,4]<-15
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d16) coords[i,4]<-16
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d17) coords[i,4]<-17
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d18) coords[i,4]<-18
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d19) coords[i,4]<-19
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d20) coords[i,4]<-20
    }

    return(list(loci,vertices,coords))
}

##############################################################################
# Shiny Server Contents
##############################################################################

shinyServer(function(input, output, session) {

  updateButton(session, "gen", style = "primary", size = "default", disabled = FALSE)

  all.list <- reactive({
        withProgress(message = 'Generating Coordinates', style = 'notification', value = 1, {
    if (input$shape == "tetra") {
      return(tetra.gen(input$dist.tetra*(input$gen>-1)))
      }
    if (input$shape == "cube") {
      return(cube.gen(input$dist.cube*(input$gen>-1)))
      }
    if (input$shape == "dodec") {
      return(dodec.gen(input$dist.dodec*(input$gen>-1)))
      }
    }) #CLOSE withProgress

  })

  output$sctPlot <- renderRglwidget({
    withProgress(message = 'Please wait up to 15 seconds', style = 'notification', value = 1, {
    try(rgl.close())
    withProgress(message = 'Generating Plot', style = 'notification', value = 1, {
    loci      <- all.list()[[1]]
    vertices  <- all.list()[[2]]
    coords    <- all.list()[[3]]

    if (max(coords[,4]==4)) {
    set1 <- coords[coords[,4]==1,1:3]
    set2 <- coords[coords[,4]==2,1:3]
    set3 <- coords[coords[,4]==3,1:3]
    set4 <- coords[coords[,4]==4,1:3]

    col1 <- brewer.pal(n = 12, name = "Paired")[2]
    col2 <- brewer.pal(n = 12, name = "Paired")[4]
    col3 <- brewer.pal(n = 12, name = "Paired")[8]
    col4 <- brewer.pal(n = 12, name = "Paired")[10]

    points3d(set1[1:round(nrow(set1)*(input$pts/100),0),1],
             set1[1:round(nrow(set1)*(input$pts/100),0),2],
             set1[1:round(nrow(set1)*(input$pts/100),0),3],
             size = 1.25,col=col1)

    points3d(set2[1:round(nrow(set2)*(input$pts/100),0),1],
             set2[1:round(nrow(set2)*(input$pts/100),0),2],
             set2[1:round(nrow(set2)*(input$pts/100),0),3],
             size = 1.25,col=col2)

    points3d(set3[1:round(nrow(set3)*(input$pts/100),0),1],
             set3[1:round(nrow(set3)*(input$pts/100),0),2],
             set3[1:round(nrow(set3)*(input$pts/100),0),3],
             size = 1.25,col=col3)

    points3d(set4[1:round(nrow(set4)*(input$pts/100),0),1],
             set4[1:round(nrow(set4)*(input$pts/100),0),2],
             set4[1:round(nrow(set4)*(input$pts/100),0),3],
             size = 1.25,col=col4)
    }

    if (max(coords[,4]==20)) {
    set1 <- coords[coords[,4]==1,1:3]
    set2 <- coords[coords[,4]==2,1:3]
    set3 <- coords[coords[,4]==3,1:3]
    set4 <- coords[coords[,4]==4,1:3]
    set5 <- coords[coords[,4]==5,1:3]
    set6 <- coords[coords[,4]==6,1:3]
    set7 <- coords[coords[,4]==7,1:3]
    set8 <- coords[coords[,4]==8,1:3]
    set9 <- coords[coords[,4]==9,1:3]
    set10<- coords[coords[,4]==10,1:3]
    set11<- coords[coords[,4]==11,1:3]
    set12<- coords[coords[,4]==12,1:3]
    set13<- coords[coords[,4]==13,1:3]
    set14<- coords[coords[,4]==14,1:3]
    set15<- coords[coords[,4]==15,1:3]
    set16<- coords[coords[,4]==16,1:3]
    set17<- coords[coords[,4]==17,1:3]
    set18<- coords[coords[,4]==18,1:3]
    set19<- coords[coords[,4]==19,1:3]
    set20<- coords[coords[,4]==20,1:3]

    col1 <- brewer.pal(n = 12, name = "Paired")[2]  #dark blue
    col2 <- brewer.pal(n = 12, name = "Paired")[4]  #dark green
    col3 <- brewer.pal(n = 12, name = "Paired")[6]  #red
    col4 <- brewer.pal(n = 12, name = "Paired")[8]  #orange
    col5 <- brewer.pal(n = 11, name = "RdBu")[11]   #DarkBl
    col6 <- brewer.pal(n = 12, name = "Paired")[12] #brown
    col7 <- brewer.pal(n = 8, name = "Dark2")[8]    #grey
    col8 <- brewer.pal(n = 8, name = "Accent")[6]   #dark pink
    col20 <- col8
    col19 <- col7
    col18 <- col6
    col17 <- col5
    col16 <- col4
    col15 <- col3
    col14 <- col2
    col13 <- col1
    col12 <- brewer.pal(n = 11, name = "BrBG")[9]   #SoftBl
    col9  <- brewer.pal(n = 11, name = "RdBu")[11]  #DarkBl
    col11 <- brewer.pal(n = 11, name = "PiYG")[1]   #Maroon
    col10 <- brewer.pal(n = 11, name = "PiYG")[11]  #DarkGrn

    points3d(set1[1:round(nrow(set1)*(input$pts/100),0),1],
             set1[1:round(nrow(set1)*(input$pts/100),0),2],
             set1[1:round(nrow(set1)*(input$pts/100),0),3],
             size = 1.25,col=col1)

    points3d(set2[1:round(nrow(set2)*(input$pts/100),0),1],
             set2[1:round(nrow(set2)*(input$pts/100),0),2],
             set2[1:round(nrow(set2)*(input$pts/100),0),3],
             size = 1.25,col=col2)

    points3d(set3[1:round(nrow(set3)*(input$pts/100),0),1],
             set3[1:round(nrow(set3)*(input$pts/100),0),2],
             set3[1:round(nrow(set3)*(input$pts/100),0),3],
             size = 1.25,col=col3)

    points3d(set4[1:round(nrow(set4)*(input$pts/100),0),1],
             set4[1:round(nrow(set4)*(input$pts/100),0),2],
             set4[1:round(nrow(set4)*(input$pts/100),0),3],
             size = 1.25,col=col4)

    points3d(set5[1:round(nrow(set5)*(input$pts/100),0),1],
             set5[1:round(nrow(set5)*(input$pts/100),0),2],
             set5[1:round(nrow(set5)*(input$pts/100),0),3],
             size = 1.25,col=col5)

    points3d(set6[1:round(nrow(set6)*(input$pts/100),0),1],
             set6[1:round(nrow(set6)*(input$pts/100),0),2],
             set6[1:round(nrow(set6)*(input$pts/100),0),3],
             size = 1.25,col=col6)

    points3d(set7[1:round(nrow(set7)*(input$pts/100),0),1],
             set7[1:round(nrow(set7)*(input$pts/100),0),2],
             set7[1:round(nrow(set7)*(input$pts/100),0),3],
             size = 1.25,col=col7)

    points3d(set8[1:round(nrow(set8)*(input$pts/100),0),1],
             set8[1:round(nrow(set8)*(input$pts/100),0),2],
             set8[1:round(nrow(set8)*(input$pts/100),0),3],
             size = 1.25,col=col8)

    points3d(set9[1:round(nrow(set9)*(input$pts/100),0),1],
             set9[1:round(nrow(set9)*(input$pts/100),0),2],
             set9[1:round(nrow(set9)*(input$pts/100),0),3],
             size = 1.25,col=col9)

    points3d(set10[1:round(nrow(set10)*(input$pts/100),0),1],
             set10[1:round(nrow(set10)*(input$pts/100),0),2],
             set10[1:round(nrow(set10)*(input$pts/100),0),3],
             size = 1.25,col=col10)

    points3d(set11[1:round(nrow(set11)*(input$pts/100),0),1],
             set11[1:round(nrow(set11)*(input$pts/100),0),2],
             set11[1:round(nrow(set11)*(input$pts/100),0),3],
             size = 1.25,col=col11)

    points3d(set12[1:round(nrow(set12)*(input$pts/100),0),1],
             set12[1:round(nrow(set12)*(input$pts/100),0),2],
             set12[1:round(nrow(set12)*(input$pts/100),0),3],
             size = 1.25,col=col12)

    points3d(set13[1:round(nrow(set13)*(input$pts/100),0),1],
             set13[1:round(nrow(set13)*(input$pts/100),0),2],
             set13[1:round(nrow(set13)*(input$pts/100),0),3],
             size = 1.25,col=col13)

    points3d(set14[1:round(nrow(set14)*(input$pts/100),0),1],
             set14[1:round(nrow(set14)*(input$pts/100),0),2],
             set14[1:round(nrow(set14)*(input$pts/100),0),3],
             size = 1.25,col=col14)

    points3d(set15[1:round(nrow(set15)*(input$pts/100),0),1],
             set15[1:round(nrow(set15)*(input$pts/100),0),2],
             set15[1:round(nrow(set15)*(input$pts/100),0),3],
             size = 1.25,col=col15)

    points3d(set16[1:round(nrow(set16)*(input$pts/100),0),1],
             set16[1:round(nrow(set16)*(input$pts/100),0),2],
             set16[1:round(nrow(set16)*(input$pts/100),0),3],
             size = 1.25,col=col16)

    points3d(set17[1:round(nrow(set17)*(input$pts/100),0),1],
             set17[1:round(nrow(set17)*(input$pts/100),0),2],
             set17[1:round(nrow(set17)*(input$pts/100),0),3],
             size = 1.25,col=col17)

    points3d(set18[1:round(nrow(set18)*(input$pts/100),0),1],
             set18[1:round(nrow(set18)*(input$pts/100),0),2],
             set18[1:round(nrow(set18)*(input$pts/100),0),3],
             size = 1.25,col=col18)

    points3d(set19[1:round(nrow(set19)*(input$pts/100),0),1],
             set19[1:round(nrow(set19)*(input$pts/100),0),2],
             set19[1:round(nrow(set19)*(input$pts/100),0),3],
             size = 1.25,col=col19)

    points3d(set20[1:round(nrow(set20)*(input$pts/100),0),1],
             set20[1:round(nrow(set20)*(input$pts/100),0),2],
             set20[1:round(nrow(set20)*(input$pts/100),0),3],
             size = 1.25,col=col20)
    }
    points3d(loci[,2],loci[,3],loci[,4], size=6,col="red")
    rglwidget()
    }) #Close withProgress
    }) #Close withProgress
    })
})


M <- 1
F <- 4

M_tot <- 4
F_tot <- 6

Es1 <- choose(M_tot, M) * choose(F_tot, F)
Es2 <- choose(M_tot, M) * choose(F_tot - 1, F - 1)
Es3 <- choose(M_tot - 2, M) * choose(F_tot, F)
print(Es1)
print(Es2)
print(Es3)


#Helpful equations for ET calculations according to FAO methodology (Allen et al. 1998, FAO Irr Drain Paper 56)

#saturated vapor pressure for a given temperature
e0=function(temp) 0.6108*exp(17.27*temp/(temp+237.3))

#this is how FAO suggests one do it for daily esat b/c of nonlinearity of e0 function
esat=function(tmax,tmin) (e0(tmax)+e0(tmin))/2

#slope of saturation curve
s=function(temp) 4098*(0.6108*exp(17.27*temp/(temp+237.3)))/(temp+237.3)^2

#extraterrestrial (MJ / m^2 / day)
Ra=function(doy,lat){   #lat in decimal degrees       #p79 FAO
  psi=(pi/180)*lat
  delta=0.409*sin((2*pi*doy/365)-1.39)
  ws=acos(-tan(psi)*tan(delta))
  dr=1+0.033*cos(2*pi*doy/365)
  Ra=(24*60/pi)*0.082*dr*(ws*sin(psi)*sin(delta)+cos(psi)*cos(delta)*sin(ws))
  Ra
}

#psychrometric constant [kPa C-1]
psychro=function(elev){             #elev in m
  press=101.3*((293-0.0065*elev)/293)^5.26
  0.665e-3*press
}

#daylength (returns # hours in the day with sunlight. only for areas between 65N-6)
daylength=function(lat,doy){
  psi=(pi/180)*lat
  delta=0.409*sin((2*pi*doy/365)-1.39)
  ws=acos(-tan(psi)*tan(delta))
  d=24*ws/pi
  d
}

#net surface radiation
Rn=function(lat,elev,doy,dew,tmax,tmin,Rs){
  ea=e0(dew)
  Ra=Ra(doy,lat)
  Rso=(0.75+(2e-5)*elev)*Ra          #p85
  Rnl=4.903e-9*(((tmax+273)^4+(tmin+273)^4)/2)*(0.34-0.14*sqrt(ea))*(1.35*(Rs/Rso)-0.35)  #p86
  Rn=(1-0.23)*Rs-Rnl             #(Rns=(1-0.23)Rs) ; Rn=Rns-Rnl p87
  Rn
}


#' @title calcCf
#'
#' @description  Calculates the frictional resistance coefficient (\code{Cf})
#' (dimensionless).
#'
#' @param shipSpeed Ship actual speed (vector of numericals, m/s) (see
#' \code{\link{calcSpeedUnitConversion}})
#' @param lwl Waterline length (vector of numericals, m) (see
#' \code{\link{calclwl}})
#' @param seawaterTemp Sea water temperature. Default = 15 (degrees Celsius).
#' Can supply either a vector of numericals, a single number, or rely on the
#' default
#' @param seawaterDensity Sea water density. Default = 1.025 (g/cm^3). Can
#' supply either a vector of numericals, a single number, or rely on the default
#'
#' @details
#' Calculates frictional resistance coefficient using the International Tank
#' Towing Committee (ITTC) 1957 method where:
#' \deqn{Cf = \frac{0.075}{(log(V*Lwl/visc)-2)^2}}{Cf = 0.075/((log(V*Lwl/visc)-2)^2)}
#'
#' @return \code{Cf} (vector of numericals, dimensionless)
#'
#' @references
#'Kristensen, H. O. and Lutzen, M. 2013. "Prediction of Resistance and Propulsion
#'Power of Ships."
#'
#'@seealso \itemize{
#'\item \code{\link{calcSpeedUnitConversion}}
#'\item \code{\link{calclwl}}
#'}
#'
#' @family Resistance Calculations
#'
#' @examples
#' calcCf(seq(1,5,1), 218.75, 15, 1.025)
#'
#' @export

calcCf <- function(shipSpeed, lwl, seawaterTemp=15, seawaterDensity=1.025){

  Cf<-0.075/((log10(
    (shipSpeed*lwl)/
                      (((43.4233-31.38*seawaterDensity)*
                          ((seawaterTemp+20)^(1.72*seawaterDensity-2.202))+
                          4.7478-5.779*seawaterDensity)*(10^(-6)))

    )
    -2)^(2))

 return(Cf)
}


# Compare means with Kruskal-Wallis test (nonparametric, because non-normal distribution)

data <- read.csv('../../results/delay/data_all.csv', sep = ';')
data_none <- data[which(data$combination=='combination_0' | data$combination=='combination_1' | data$combination=='combination_2' | data$combination=='combination_3'),]
data_triple <- data[which(data$combination=='combination_4' | data$combination=='combination_5' | data$combination=='combination_6' | data$combination=='combination_7'),]
data_bgp <- data[which(data$combination=='combination_8' | data$combination=='combination_9' | data$combination=='combination_10' | data$combination=='combination_11'),]

# Means
aggregate(data$time, list(data$combination), median)
#  combination_0 1516.5
#  combination_1 1196.0
#  combination_2  957.0
#  combination_3  935.0
#  combination_4 1479.0
#  combination_5 1193.0
#  combination_6  986.5
#  combination_7  977.5
#  combination_8 1241.0
#  combination_9  679.0
#  combination_10  422.5
#  combination_11  400.5

median(data_none$time)
median(data_triple$time)
median(data_bgp$time)
# None: 1054
# Triple: 1055.5
# BGP: 556.5

#boxplot(time ~ combination, data = data, ylab="Exec (ms)", xlab="Combination")

# H0: None == Triple
kruskal.test(time ~ combination, data = data_none)
kruskal.test(time ~ combination, data = data_triple)
kruskal.test(time ~ combination, data = data_bgp)
# p: 0.2905, 0.2306, 0.002891
# => Accept H0, equal means => None == Triple


##################################################################
#     Calculate Great Circle Distance in m based upon spherical
#     trig.
##################################################################

great.circle.distance = function (loc1, loc2, R) {

  names(loc1) = c("lon", "lat")
  names(loc2) = c("lon", "lat")

  if (is.null(R)) R = 6367.436  # radius of earth (geometric mean) km
    # if R=1 then distances in radians
    if (missing(loc2)) loc2 <- loc1
    pi180 = pi/180
    coslat1 = cos(loc1$lat * pi180)
    sinlat1 = sin(loc1$lat * pi180)
    coslon1 = cos(loc1$lon * pi180)
    sinlon1 = sin(loc1$lon * pi180)
    coslat2 = cos(loc2$lat * pi180)
    sinlat2 = sin(loc2$lat * pi180)
    coslon2 = cos(loc2$lon * pi180)
    sinlon2 = sin(loc2$lon * pi180)
    pp =   cbind(coslat1 * coslon1, coslat1 * sinlon1, sinlat1) %*%
         t(cbind(coslat2 * coslon2, coslat2 * sinlon2, sinlat2))

    d = R * acos(ifelse(pp > 1, 1, pp))

    return(d)
}


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

ethiopicmult<-function(x,y){
	res<-ifelse(iseven(y),0,x)
	while(!y==1){
		x<-double(x)
		y<-halve(y)
		if(!iseven(y)) res<-res+x
	}
	return(res)
}

print(ethiopicmult(17,34))


################
#---PACKAGES---#
################
require(ggplot2)
require(reshape2)

###########################
#---POISSON SAMPLE PATH---#
###########################
# 4 x 12
paths = 1
N = 50

rate = 0.1

colorBeta <- rgb(252, 141, 98, maxColorValue = 255, alpha = 255)
colorAlpha <- rgb(141, 160, 203, maxColorValue = 255, alpha = 255)

theList <- list()
for(j in 1 : paths) {

  data = data.frame(
    x = rep(NA, 2 * N + 1),
    xend = rep(NA, 2 * N + 1 ),
    y = rep(NA, 2 * N + 1),
    yend = rep(NA, 2 * N + 1),
    path = rep(NA, 2 * N + 1)
  )

  data$x[1] = 0
  data$xend[1] = rexp(1, rate = rate)

  data$y[1] = sample(c("A", "C", "G", "T"), size = 1)
  data$yend = data$y

  ids = seq( from = 1, to = (2 * N - 1), by = 2 )

  for(i in ids) {

    char = sample(c("A", "C", "G", "T"), size = 1)
    time = rexp(1, rate = rate)

    data$x[i + 1] = data$xend[i]
    data$xend[i + 1] = data$x[i + 1]

    data$y[i + 1] = data$yend[i]
    data$yend[i + 1] = char

    data$x[i + 2] = data$xend[i + 1]
    data$xend[i + 2] = data$x[i + 2] + time

    data$y[i + 2] = data$yend[i + 1]
    data$yend[i + 2] = data$y[i + 2]

    data$path[i] <- data$path[i + 1] <- data$path[i + 2] <- j

  } # END: i

  theList[[j]] = data
} # END: j

data_melt <- do.call("rbind", theList)
data_melt$path <- as.factor(data_melt$path)

p <- ggplot(data_melt)
p <- p + geom_segment(aes(x = x, y = y, xend = xend, yend = yend, linetype = path), colour = colorAlpha, size = 1)
# p <- p + geom_point(aes(x = x, y = y), colour = colorAlpha, fill = colorAlpha, shape = 21, size = 2)

theme1 <- theme(
  axis.line = element_line(colour = "black"),
  axis.text = element_text(colour = "black"),
  axis.ticks = element_line(colour = "black"),
  legend.position = "none",
  panel.background = element_rect(size = 1, fill = "white", colour = NA),
  panel.border = element_blank(),
  panel.grid.major = element_blank(),
  panel.grid.minor = element_blank()
)

nth = 2
ticks <- unique(round(data_melt$x, 1))
ticks <- ticks[seq(1, length(ticks), nth)]
p <- p + scale_x_continuous(
  breaks = ticks
  )

p <- p + theme1
p <- p + xlab("Time") + ylab("")
print(p)

#########################
#---JC69 CTMC EXAMPLE---#
#########################
JC69 <- function (theta, t) {
  p0 = 1/4 + 3/4 * exp(-4*theta*t)
  p1 = 1/4 - 1/4 * exp(-4*theta*t)

  trans_prob = matrix(c(p0, p1, p1, p1,
                        p1, p0, p1, p1,
                        p1, p1, p0, p1,
                        p1, p1, p1, p0
  ), nrow = 4, ncol = 4, byrow = T)

  colnames(trans_prob) <- rownames(trans_prob) <- c("T", "C", "A", "G")
  return(trans_prob)
}

N = 50
times = seq(0, 0.1, length.out = N)
data <- data.frame(
    T = rep(NA, N),
    C = rep(NA, N),
    A = rep(NA, N),
    G = rep(NA, N)
    )

# set.seed(123)
r    <- runif(4)
vect <- r / sum(r)

data[1, ] <- vect
theta    <- 2

for (i in 2 : N) {
   probs = as.matrix(data[i - 1, ], nrow = 1, ncol = 4)
   data[i, ] <- probs %*% JC69(theta, t = times[i])
}

data_melt <- melt(cbind(t = times, data), id.vars = "t")

p <- ggplot(data_melt)
p <- p + geom_line(aes(x = t, y = value, color = variable))
p <- p + xlab("Time") + ylab("Probability")
theme <- theme(
  axis.title = element_text(colour = "black"),
  axis.text = element_text(colour = "black"),
  axis.line = element_line(colour = "black"),
  axis.ticks = element_line(colour = "black"),
  panel.background = element_rect(size = 1, fill = "white", colour = NA),
  plot.background = element_rect(colour = NA),
  panel.border = element_blank(),
  panel.grid.major = element_blank(),
  panel.grid.minor = element_blank()
)
p <- p + theme
print(p)

###################################
#---BINOMIAL LIKELIHOOD EXAMPLE---#
###################################
myBlue = rgb(r = 86, g = 110, b = 126, maxColorValue = 250)

like <- function(theta, k = 8, n = 10) {
  return(dbinom(k, n, theta))
}

# 900 x 600
theta <- seq(from = 0, to = 1, by = 0.01)
plot(theta, like(theta), type = "l", col = myBlue, lwd = 3)

points(0.8, like(0.8), pch = 19, col = myBlue, cex = 1.5)

######################
#---NEWTON RAPHSON---#
######################
myBlue = rgb(r = 86, g = 110, b = 126, maxColorValue = 250)

f <- function(x) {
  f = exp(x)/(1 + exp(x))^2
  fx = exp(x)/(1 + exp(x))^2 - 2*exp(2*x)/(1 + exp(x))^3
  fxx = 6 * exp(x)/(1 + exp(x))^4 - 6*exp(2*x)/(1 + exp(x))^3 + exp(x)/(1+exp(x))^2
  return( data.frame(f = f, fx = fx, fxx = fxx ) )
}

x = seq(-10, 10, length.out = 100)
plot(x, f(x)[,1], type = "l", col = myBlue, lwd = 3)

newtonRaphson <- function(f, x0, tol = 1/10^9, maxIter = 100) {

  x  = x0
  fx = f(x)
  i  = 0

  cat(paste(c("i", "x", "f(x)", "\n"), sep = "\t"))
  while ( (abs(fx[, 2]) > tol) ) {

    if(i < maxIter) {

      x  = x - fx[, 2] / fx[, 3]
      fx = f(x)

      points(x, fx[,1], pch = 19, col = myBlue, cex = 1.5)
      cat(paste(c(i, x, fx[,1], "\n"), sep = "\t"))
      Sys.sleep(0.5)

      i  = i + 1

    } else {
      break;
    }#END: maxIter check
  }#END: tolerance loop

  return(x)
}

x.star <- newtonRaphson(f, 5)


Data_<-structure(list(item = c("Panacea", "Ichor", "Gold"), value = c(3000,
1800, 2500), weight = c(3, 2, 20), volume = c(25, 15, 2)), .Names = c("item",
"value", "weight", "volume"), row.names = c(NA, 3L), class = "data.frame")

knapsack_volume<-function(Data, W, Volume, full_K)
{

	# Data must have the colums with names: item, value, weight and volume.
	K<-list() # hightest values
	K_item<-list() # itens that reach the hightest value
	K<-rep(0,W+1) # The position '0'
	K_item<-rep('',W+1) # The position '0'
	for(w in 1:W)
	{
		temp_w<-0
		temp_item<-''
		temp_value<-0
		for(i in 1:dim(Data)[1]) # each row
		{
			wi<-Data$weight[i] # item i
			vi<- Data$value[i]
			item<-Data$item[i]
			volume_i<-Data$volume[i]
			if(wi<=w & volume_i <= Volume)
			{
				back<- full_K[[Volume-volume_i+1]][w-wi+1]
				temp_wi<-vi + back

				if(temp_w < temp_wi)
				{
					temp_value<-temp_wi
					temp_w<-temp_wi
					temp_item <- item
				}
			}
		}
	K[[w+1]]<-temp_value
	K_item[[w+1]]<-temp_item
	}
return(list(K=K,Item=K_item))
}

Un_knapsack<-function(Data,W,V)
{
	K<-list();K_item<-list()
	K[[1]]<-rep(0,W+1) #the line 0
	K_item[[1]]<-rep('', W+1) #the line 0
	for(v in 1:V)
	{
		best_volum_v<-knapsack_volume(Data, W, v, K)
		K[[v+1]]<-best_volum_v$K
		K_item[[v+1]]<-best_volum_v$Item
	}

return(list(K=data.frame(K),Item=data.frame(K_item,stringsAsFactors=F)))
}

retrieve_info<-function(knapsack, Data)
{
	W<-dim(knapsack$K)[1]
	itens<-c()
	col<-dim(knapsack$K)[2]
	selected_item<-knapsack$Item[W,col]
	while(selected_item!='')
	{
		selected_item<-knapsack$Item[W,col]
		if(selected_item!='')
		{
			selected_item_value<-Data[Data$item == selected_item,]
			W <- W - selected_item_value$weight
			itens<-c(itens,selected_item)
			col <- col - selected_item_value$volume
		}
	}
return(itens)
}

main_knapsack<-function(Data, W, Volume)
{
	knapsack_result<-Un_knapsack(Data,W,Volume)
	items<-table(retrieve_info(knapsack_result, Data))
	K<-knapsack_result$K[W+1, Volume+1]
	cat(paste('The Total profit is: ', K, '\n'))
	cat(paste('You must carry:', names(items), '(x',items, ') \n'))
}

main_knapsack(Data_, 250, 250)


#!/usr/bin/env R
#!-*- coding: utf-8 -*-

d = read.csv('./data/10group-100n.csv')

lmm <- function(formula, data, niter = 1000) {
    require(data.table)
    # convert the data to data.table as well
    data = data.table(data)

    # process the formula
    f.terms = terms(formula)
    f.vars = attr(f.terms, "variables")
    if (attr(f.terms, "response") == 1) {
        outcome = as.character(f.vars[[2]])
    }
    intercept = attr(f.terms, "intercept")
    fixed = grep("[|]", attr(f.terms, "term.labels"), value=T, invert=T)

    # create the results matrix for storing samples
    samples = as.data.table(
        matrix(0,
               nrow = niter,
               ncol = intercept + length(fixed))
    )
    if (intercept == 1) {
        fixed = c('Intercept', fixed)
        data[, Intercept := 1]
    }
    setnames(samples, 1:ncol(samples), fixed)
    samples[, "sigma2" := 1]
    samples[1, x1 := 0.25]

    for (i in 2:niter) {
        inferFixedBeta(samples, data, i, fixed.vars = fixed, outcome = outcome)
        inferSigma2(samples, data, i, fixed.vars = fixed, outcome = outcome)
    }
    samples
}

inferFixedBetaMH <- function(samples, data, iter, fixed.vars, outcome, proposal.sd = 0.05) {
    sigma2 = as.numeric(samples[iter-1, 'sigma2', with=F])
    outcome.obs = data[, outcome, with=F]
    X = as.matrix(data[, fixed.vars, with=F])
    Beta = samples[iter-1, fixed.vars, with=F]
    logrand = log(runif(n = length(fixed.vars)))
    for (vi in 1:length(fixed.vars)) {
        v = fixed.vars[vi]
        old.beta = as.numeric(Beta[,v,with=F])
        new.beta = rnorm(1, mean = old.beta, sd = proposal.sd)

        # calculate the old loglikelihood
        log.g.old = - (1 / (2 * sigma2)) *
            sum((outcome.obs - X %*% t(Beta)) ** 2)

        # modify the beta value and calculate the new loglikelihood
        Beta[, eval(v):= new.beta]
        log.g.new = - (1 / (2 * sigma2)) *
            sum((outcome.obs - X %*% t(Beta)) ** 2)

        # compute candidate densities q for old and new beta
        # since the proposal distribution is normal this step is not needed
        log.q.old = 0
        log.q.new = 0

        # compute the moving probability
        moving.logprob = (log.g.new + log.q.old) - (log.g.old + log.q.new)
        samples[iter, eval(v) := ifelse(logrand[vi] < moving.logprob, new.beta, old.beta)]
    }
}

inferFixedBeta <- function(samples, data, iter, fixed.vars, outcome, proposal.sd = 0.05) {
    sigma2 = as.numeric(samples[iter-1, 'sigma2', with=F])
    outcome.obs = as.matrix(data[, outcome, with=F])
    X = as.matrix(data[, fixed.vars, with=F])
    Beta = samples[iter-1, fixed.vars, with=F]

    Mu = solve(t(X) %*% X) %*% t(X) %*% outcome.obs
    Sigma = sigma2 * solve(t(X) %*% X)
    require(MASS)
    samples[iter, eval(fixed.vars) := as.list(mvrnorm(1, Mu, Sigma))]

}

inferSigma2 <- function(samples, data, iter, fixed.vars, outcome) {
    alpha_0 = 1
    beta_0 = 1
    alpha_n = alpha_0 + nrow(data) / 2
    outcome.obs = as.matrix(data[, outcome, with=F])
    X = as.matrix(data[, fixed.vars, with=F])
    Beta = as.matrix(samples[iter-1, fixed.vars, with=F])
    beta_n = beta_0 + 0.5 * sum((outcome.obs - X %*% t(Beta)) ** 2)
    samples[iter, 'sigma2' := 1 / rgamma(1, shape = alpha_n, scale = 1 / beta_n)]
}


## Dexter Barrows
## dbarrows.github.io
## McMaster University
## 2016

library(deSolve)
library(ggplot2)
library(reshape2)
library(gridExtra)
library(Rcpp)

SIR <- function(Time, State, Pars) {

    with(as.list(c(State, Pars)), {

        B   <- R0*r/N
        BSI <- B*S*I
        rI  <- r*I

        dS = -BSI
        dI = BSI - rI
        dR = rI

        return(list(c(dS, dI, dR)))

    })

}

T 		<- 100
N 		<- 500
sigma 	<- 10
i_infec <- 5

## Generate true trajecory and synthetic data
##

true_init_cond <- c(S = N - i_infec,
                    I = i_infec,
                    R = 0)

true_pars <- c(R0 = 3.0,
               r = 0.1,
               N = 500.0)

odeout <- ode(true_init_cond, 0:T, SIR, true_pars)
trueTraj <- odeout[,3]

set.seed(1001)

infec_counts_raw <- odeout[,3] + rnorm(T+1, 0, sigma)
infec_counts     <- ifelse(infec_counts_raw < 0, 0, infec_counts_raw)

g <- qplot(0:T, odeout[,3], geom = "line", xlab = "Time (weeks)", ylab = "Infection Count") +
		geom_point(aes(y = infec_counts)) +
		theme_bw()

print(g)
ggsave(g, filename="dataplot.pdf", height=4, width=6.5)

## Rcpp stuff
##

sourceCpp(paste(getwd(),"d_if2.cpp",sep="/"))

paramdata <- data.frame(if2(infec_counts, T+1, N))
colnames(paramdata) <- c("R0", "r", "sigma", "Sinit", "Iinit", "Rinit")

## Parameter density kernels
##

R0points <- paramdata$R0
R0kernel <- qplot(R0points, geom = "density", xlab = expression(R[0]), ylab = "frequency") +
				geom_vline(aes(xintercept=true_pars[["R0"]]), linetype="dashed", size=1, color="grey50") +
				theme_bw()

print(R0kernel)
ggsave(R0kernel, filename="kernelR0.pdf", height=3, width=3.25)

rpoints <- paramdata$r
rkernel <- qplot(rpoints, geom = "density", xlab = "r", ylab = "frequency") +
				geom_vline(aes(xintercept=true_pars[["r"]]), linetype="dashed", size=1, color="grey50") +
				theme_bw()

print(rkernel)
ggsave(rkernel, filename="kernelr.pdf", height=3, width=3.25)

sigmapoints <- paramdata$sigma
sigmakernel <- qplot(sigmapoints, geom = "density", xlab = expression(sigma), ylab = "frequency") +
				geom_vline(aes(xintercept=sigma), linetype="dashed", size=1, color="grey50") +
				theme_bw()

print(sigmakernel)
ggsave(sigmakernel, filename="kernelsigma.pdf", height=3, width=3.25)

infecpoints <- paramdata$Iinit
infeckernel <- qplot(infecpoints, geom = "density", xlab = "Initial Infected", ylab = "frequency") +
				geom_vline(aes(xintercept=true_init_cond[['I']]), linetype="dashed", size=1, color="grey50") +
				theme_bw()

print(infeckernel)
ggsave(infeckernel, filename="kernelinfec.pdf", height=3, width=3.25)

# show grid
grid.arrange(R0kernel, rkernel, sigmakernel, infeckernel, ncol = 2, nrow = 2)

pdf("if2kernels.pdf", height = 6.5, width = 6.5)
grid.arrange(R0kernel, rkernel, sigmakernel, infeckernel, ncol = 2, nrow = 2)
dev.off()


library(shiny)
library(shinythemes)
options(scipen = 999999999)
ui <- fluidPage(theme=shinytheme("flatly"),
  titlePanel("Likelihood Ratio for Mixed Results"),
  sidebarLayout(
    sidebarPanel(numericInput("n", "Number of studies :", 3, min = 1, max = 100),
                 numericInput("x", "Number of successes:", 2, min = 0, max = 100),
                 sliderInput("H0", "Type 1 error rate:", min = 0, max = 1, value = 0.05, step= 0.01),
                 sliderInput("H1", "Assumed Power:", min = 0, max = 1, value = 0.8, step= 0.01)
                 ),
    mainPanel(plotOutput("coolplot"),br(),
              h4("Shiny app accompanying: Lakens, D., & Etz, A. J. (2017). Too true to be bad: When sets of studies with significant and non-significant findings are probably true. Social Psychological and Personality Science. https://osf.io/preprints/psyarxiv/nnkg9"),br(),
              h4(textOutput("text1")), br(),
              h4(textOutput("text2")),br(),
              h4("When the observed results are equally likely under H0 and H1, the likelihood ratio is 1. Benchmarks to interpret Likelihood Ratios suggest that when 1<LR<8 there is weak evidence, when 8<LR<32 there is moderate evidence, and when LR>32, there is strong evidence."),br(),
              h4(textOutput("text3")), br(),
              dataTableOutput("table")
    )
  )
)
server <- function(input, output) {
  output$coolplot <- renderPlot({
    n<-input$n
    x<-input$x
    H0<-input$H0
    H1<-input$H1
    LR<-round(max(dbinom(x,n,H0)/dbinom(x,n,H1),dbinom(x,n,H1)/dbinom(x,n,H0)),digits=2) #Calculate LR (H1 over H0 and H0 over H1, pick max)
    H0H1<-ifelse(dbinom(x,n,H0)>dbinom(x,n,H1),"The data are more likely under the null hypothesis than the alternative hypothesis","The data are more likely under the alternative hypothesis than the null hypothesis")
    theta<- seq(0,1,len=1000)
    like <- dbinom(x,n,theta)
    plot(theta,like,type='l',xlab=expression(theta), ylab='Likelihood', lwd=2)
    points(H0,dbinom(x,n,H0), lwd=2)
    points(H1,dbinom(x,n,H1), lwd=2)
    segments(H0, dbinom(x,n,H0), x/n, dbinom(x,n,H0), lty=2, lwd=2)
    segments(H1, dbinom(x,n,H1), x/n, dbinom(x,n,H1), lty=2, lwd=2)
    segments(x/n, dbinom(x,n,H0), x/n, dbinom(x,n,H1), lwd=2)
    abline(v=H0, col="gray40", lty=3, lwd=2)
    abline(v=H1, col="gray40", lty=3, lwd=2)
    title(paste('Likelihood Ratio:',LR))

    #create Table
    studies<-c(0:n)
    ProbH0<-dbinom(studies,n,H0)
    ProbH1<-dbinom(studies,n,H1)
    table<-cbind(studies,ProbH0,ProbH1)
    colnames(table) <- c("Number of significant studies", "Probability of observing x out of n significant studies when H0 is true","Probability of observing x out of n significant studies when H1 is true")

    output$text1 <- renderText({
      paste("When H1 is true, in the long run, the probability of observing", x," out of ",n, " significant studies, given" ,H1, "power, is:", dbinom(x,n,H1),". If all studies examine true effects with",100*H1,"% power,",100*round(dbinom(x,n,H1),digits=4),"% of published articles with",n,"studies should observe",x,"significant results. When power is less than",100*round(0.5^(1/n), digits=4),"% observing",n,"out of",n,"significant results is less likely (i.e., occurs less than 50% of the time) than observing mixed results.")
    })
    output$text2 <- renderText({
      paste("When H0 is true, in the long run, the probability of observing", x," out of ",n, " significant studies, given a" ,H0, "Type 1 error rate, is:", round(dbinom(x,n,H0),digits=10),". When all studies examine null-effects with a",100*H0,"% Type 1 error rate,",100*round(dbinom(x,n,H0),digits=4),"% of published articles with",n,"studies should observe",x,"significant results.")
    })
    output$text3 <- renderText({
      paste(H0H1, "with a likelihood ratio of",LR,".")
    })
    output$table = renderDataTable(
      table,
      options = list(paging = FALSE, searching = FALSE)
    )
  })
}
shinyApp(ui = ui, server = server)


#' radtheoricR
#'
#' @description R function to assess raw  solar irradiance parameter.
#'
#' @param  timenow time "POSIXct" or "POSIXt" object.
#' @param  lat numeric latitude in decimal degrees.
#' @param  lon numeric longitude in decimal degrees.
#' @param  albedo numeric albedo of surface.
#' @return Theoretical radiation in W/mq
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#'
#'
#'
#' @export

radtheoricR <- function(timenow,lat,lon,albedo){
 rho=albedo
 sunpar=sunposition(timenow,lat, lon)
 elev=sunpar$elevation
 timeday=as.POSIXlt(timenow, "GMT")
 nday=format(timeday,"%j")
 # Solar constant
 SC = 1.361 # kW/m2
 # ET solar radition I0 kW/m2
 I0 <- SC*(1+0.034*cos((nday)*2*pi/365))
 # atmospheric effect
 A <- 1.160 + 0.075 * sin((nday-274)*2*pi/365)
 opt.depth <- 0.174 + 0.035 * sin((nday-100)*2*pi/365)
 air.mass <- 1/sin(elev*2*pi/360)
 # Direct
 IB <- I0*exp(-opt.depth*air.mass)
 # diffuse
 IDH <- IB*(0.095 + 0.04*sin((nday-100)*2*pi/365))
 ID <- IDH*(1+cos(pi-elev*2*pi/360))/2
 # reflected
 IBH <- IB*sin(elev*2*pi/360)
 IR <-  rho*(IBH+IDH)*(1+cos(pi-elev*2*pi/360))/2
 # total
 IT <- IB+ID+IR
 I <- cbind(IB,ID,IR,IT)
 return(list(I0=I0,A=A,opt.depth=opt.depth, air.mass=air.mass,I=I,jd=nday,elev=elev,azimuth=sunpar$azimuth))
}


#Using data from insideairbnb.com - data from the Santa Cruz, CA area, last updated October 2015
santacruz = read.csv("documents/airbnb_santacruz.csv")
attach(santacruz)

#thanks to http://www.geodatasource.com/developers/javascript for ideas behind this function
#Note that "West" and "South" need negative signs for lat/lon
distance <- function(lat1, lon1, lat2, lon2) {
    #lat2 <- 36.9643, lon2 <- -122.0189 for Santa Cruz Beach Boardwalk
    radlat1 = pi * lat1/180
    radlat2 = pi * lat2/180
    theta = lon1-lon2
    radtheta = pi * theta/180
    dist = (sin(radlat1) * sin(radlat2) + cos(radlat1) * cos(radlat2) * cos(radtheta))
    dist = acos(dist)
    dist = dist * 180/pi
    dist = dist * 60 * 1.1515
    return(dist)
}

#use distance to regress price on distance, split by type of room (maybe focus on home first)
santacruz$distance<- distance(santacruz$latitude, santacruz$longitude,36.9643,-122.0189)

santacruz$room_type <- factor(santacruz$room_type)
lm <- lm(santacruz$price ~ santacruz$distance + santacruz$room_type)
summary(lm)

#These two regressions indicate somewhat odd findings.
#For one, the farther a house is away from the Santa Cruz Beach Boardwalk,
#the more expensive it is to stay per night.
#For another, you have very big negative coefficients for Private Room or Shared Room categories.
#The latter is easily explained upon realizing that the third category, renting a full house,
#should logically be more expensive per night. The former (positive distance variable) may be explained
#by physically looking through the data, where a lot of houses
#in the "Santa Cruz" area are actually closer to Capitola Beach.

santacruz$capitola<- distance(santacruz$latitude, santacruz$longitude,36.9716, -121.9516)
lmcap <- lm(santacruz$price ~ santacruz$capitola + santacruz$room_type)
summary(lmcap)

mean(santacruz$latitude)
mean(santacruz$longitude)

#I tried using Capitola Beach as another distance measure, but again the further away a house was from the beach,
#the more my model predicted it would cost.
#Upon checking the average location for latitude and longitude, I figured out the reason why:
#this dataset ranges from Santa Cruz Beach Boardwalk to Capitola Beach,
#making both anchor points the extremes of their datasets:
#https://www.google.com/maps/place/36%C2%B059'12.2%22N+121%C2%B059'13.0%22W/@36.9792869,-122.0092925,13.42z/data=!4m5!3m4!1s0x0:0x0!8m2!3d36.9867106!4d-121.9869506

#Separate Capitola from Santa Cruz Beach houses (focus on Santa Cruz Boardwalk first)
#first, see what neighborhoods are in there
unique(neighbourhood)

sconly <- subset(santacruz, santacruz$neighbourhood == "City of Santa Cruz")
sconly$distance<- distance(sconly$latitude, sconly$longitude,36.9643,-122.0189)
lmsconly <- lm(sconly$price ~ sconly$distance + sconly$room_type)
summary(lmsconly)

caponly <- subset(santacruz, santacruz$neighbourhood == "City of Capitola")
caponly$capitola<- distance(caponly$latitude, caponly$longitude,36.9716, -121.9516)
lmcaponly <- lm(caponly$price ~ caponly$capitola + caponly$room_type)
summary(lmcaponly)

#Now the adage of "location, location, location" is correctly displayed in the regression for Capitola
#the further away a house is from Capitola Beach, the less a person should be willing to pay to stay in an Airbnb),
#and is significant at the 5% level. The sign on the Santa Cruz coefficient is still positive,
#but it's not significant for the regression.


# This code computes minimum detectable odds ratio
# for the Vaccine effectiveness against referral
# to hospital and severe lung injury associated with COVID-19
# study
library(epiR)

# Declare working directory beforehand in an environment variable
# SPB_COVID_STUDY_PATH = "path_to_your_folder"
# with the aid of usethis::edit_r_environ()
# Restart R session for the changes to make effect
setwd(Sys.getenv('SPB_COVID_STUDY_PATH'))

# Load data to extract characteristics
load("data/ve_ct_paper/trc_dt.Rdata")

# Study characteristics
total_patients <- trc_dt[, .N] # 13893
completely_vaccinated_patients <- trc_dt[vac_status3 == "full_vac", .N] # 1291
partially_vaccinated_patients <- trc_dt[vac_status3 == "part_vac", .N] # 448

# Outcomes
hospitalized_patients <- trc_dt[hospitalization == 1, .N] # 495
any_lung_injury_patients <- trc_dt[ct_score != 0, .N] # 9368
saturation_less_than_96 <- trc_dt[saturation < 96 | is.na(saturation), .N] # 385

# MDE for hospitalization, complete vaccination
epi.sscc(OR = NA,
				 p0 = completely_vaccinated_patients/total_patients,
				 n = total_patients,
				 conf.level = 0.95,
				 power = 0.8,
				 method = "unmatched",
				 r = (total_patients-hospitalized_patients)/hospitalized_patients)

# MDE for any lung injury, complete vaccination
epi.sscc(OR = NA,
				 p0 = completely_vaccinated_patients/total_patients,
				 n = total_patients,
				 conf.level = 0.95,
				 power = 0.8,
				 method = "unmatched",
				 r = (total_patients-any_lung_injury_patients)/any_lung_injury_patients)

# MDE for oxygen saturation, complete vaccination
epi.sscc(OR = NA,
				 p0 = completely_vaccinated_patients/total_patients,
				 n = total_patients,
				 conf.level = 0.95,
				 power = 0.8,
				 method = "unmatched",
				 r = (total_patients-saturation_less_than_96)/saturation_less_than_96)

# MDE for hospitalization, partial vaccination
epi.sscc(OR = NA,
				 p0 = partially_vaccinated_patients/total_patients,
				 n = total_patients,
				 conf.level = 0.95,
				 power = 0.8,
				 method = "unmatched",
				 r = (total_patients-hospitalized_patients)/hospitalized_patients)


bilinear.interp<-function(x,f){
	#interpolate a 2d point for fn f
	indx<-trunc(x[1]*(res-1)+1)
	indy<-trunc(x[2]*(res-1)+1)
	seq.Out<-seq(0,1,length.out=res)
	fr1<- (seq.Out[indx+1]-x[1])/(seq.Out[indx+1]-seq.Out[indx]) * f[indx,indy] + (x[1]-seq.Out[indx])/(seq.Out[indx+1]-seq.Out[indx]) * f[indx+1,indy]
	fr2<- (seq.Out[indx+1]-x[1])/(seq.Out[indx+1]-seq.Out[indx]) * f[indx,indy+1] + (x[1]-seq.Out[indx])/(seq.Out[indx+1]-seq.Out[indx]) * f[indx+1,indy+1]
	fp<- (seq.Out[indy+1]-x[2])/(seq.Out[indy+1]-seq.Out[indy]) * fr1 + (x[2]-seq.Out[indy])/(seq.Out[indy+1]-seq.Out[indy]) * fr2
	return(fp)
}

bilinear.interp(c(.4,.5),matrix(rnorm(res^2),res,res))

univ.interp<-function(x,f){
	seq.Out<-seq(0,1,length.out=res)
	indx<-trunc(x*(res-1)+1)
	(seq.Out[indx+1]-x)/(seq.Out[indx+1]-seq.Out[indx]) * f[indx] + (x-seq.Out[indx])/(seq.Out[indx+1]-seq.Out[indx]) * f[indx+1]
}

univ.interp(.4,1:res)

tree.mix.lik<-function(x,edge_den,beliefs,edgelist,tree.list,weights,part_fn){
	e<- dim(edgelist)[1]
	d<-dim(beliefs)[1]
	uni.prod<-mapply(function(u){
		log(univ.interp(x[u],beliefs[u,]))
	},1:d)
	if(e==0){
		return(sum(uni.prod))
	}
		if(any(is.na(uni.prod))) print("help!")

	biv.prod<-mapply(
				function(l){
					s<- edgelist[l,1]
					t<- edgelist[l,2]
					log(bilinear.interp(c(x[s],x[t]) , edge_den[,,l]))  - (uni.prod[s]) - (uni.prod[t])
				},
				1:e
			)
	tree.prod<- lapply(tree.list,
					function(t){
						tree<- graph.adjacency(t,mode="undirected")
						el1<-apply(get.edgelist(tree), 1, paste, collapse="-")
						el2<-apply(get.edgelist(tree), 1, function(x)paste(rev(x),collapse="-"))
						el<-apply(edgelist, 1, paste, collapse="-")
						ekeep<- (el %in% el1) | (el %in% el2)
						sum( biv.prod[ekeep] )
					})
		tree.prod<- unlist(tree.prod)
		tmax<- max(tree.prod)
		#tmax<-0
		#tree.weight<- exp(tree.prod-tmax)*weights
		#out<- sum( uni.prod ) + tmax + log( sum( tree.weight ) )
		out<- sum( uni.prod ) + weights * tree.prod
	return(out)
	}

# risk_path_tree<-lapply(path,function(x){
#   outvec<-lapply(1:dim(test)[1],
#   	function(i){
# 	  tree.mix.lik(test[i,],
# 		x$edge_den,
# 		x$beliefs,
# 		x$edgelist,
# 		x$tree_obj$tree.list,
# 		x$tree_obj$weight.list)
#   	})
#   	outvec<- unlist(outvec)
#   	return(- mean(outvec))
# })
# #risk_path_tree
#
# #
# # lik<-tree.mix.lik(test[1,],
# # 	fit$edge_den,
# # 	fit$beliefs,
# # 	edgelist,
# # 	tree_obj$tree.list,
# # 	tree_obj$weight.list
# # )


# Normal Approximation to the Binomial
# number of trails
n<-100
# probability of success of single event
z<-0.2
Mean<-n*z
s<-sqrt(n*z*(1-z))
#  e probability that at least 15 of the 100 drugs are eventually licensed (>14.5)
pnorm(14.5, mean=Mean, sd=s, lower.tail=FALSE)