designBased = function(gamma, outcome_vec, pcf_cat_vec, instid_vec){
	#' Compute Design Based Draper-Gittoes Z-Scores
	#'
	#'	\code{designBased} implements design based approach and
	#' computes O, E, and z vectors following Draper-Gittoes (2004)
	#'
	#' @param gamma Parameter in [0,1] controling pooling.
	#' Gamma = 1 is complete global pooling, gamma = 0 is complete local pooling.
	#' @param outcome_vec Vector with elements in {0,1} denoting the binary outcome.
	#' @param pcf_cat_vec Vector with unique values for each PCF category.
	#' @param instid_vec Vector with unique values for each institution.
	stopifnot( all( outcome_vec %in% c(0,1)) )
	#Some of the inputs need to be factors
	pcf_cat_vec = as.factor(pcf_cat_vec)
	instid_vec = as.factor(instid_vec)

	#Summarize
	instid_unique = levels(instid_vec)
	n_students = length(outcome_vec)
	n_u = length(levels(instid_vec))
	n_cat = length(levels(pcf_cat_vec))
	p_global = mean(outcome_vec)
	#Compute Table 2 in Draper-Gittoes
	y_mat = n_mat = matrix(0, nrow =n_u, ncol = n_cat)

	for (i in 1:n_students){
    inst = as.integer(instid_vec[i])
    categ = as.integer(pcf_cat_vec[i])
    n_mat[inst,categ] = n_mat[inst,categ] + 1
    y_mat[inst, categ] = y_mat[inst, categ] + outcome_vec[i]
	}
	p_mat = y_mat / n_mat
	p_mat[n_mat == 0] = 0

	#Marginal summaries
	pcf_p_vec = apply(y_mat, 2, sum) / apply(n_mat, 2, sum)
	n_u_vec = apply(n_mat, 1, sum)
	n_cat_vec = apply(n_mat, 2, sum)

	#Equation (2) in Draper-Gittoes (2004)
	O = apply(y_mat, 1, sum) / apply(n_mat, 1, sum)
	#Equation (3) in D-G
	E = apply(t(t(n_mat) * pcf_p_vec), 1, sum) / n_u_vec
	#Equation (4) in D-G
	D = O - E

	#Variance
	lambdaFun = function(i,k,j){
		#Equation (7) in D-G
		if (i == k){
			return(n_mat[i,j]/n_u_vec[i] * (1 - (n_mat[i,j]/n_cat_vec[j])))
		} else{
			return( -1 * (n_mat[i,j] * n_mat[k,j]) / (n_u_vec[i] * n_cat_vec[j]) )
		}
	}
	vFun = function(k,j, gamma = 0.5){
		#Equation (11) in D-G
		n = n_mat[k,j]
		pcomb = function(p_local){gamma * p_global + (1-gamma) * p_local}
		if (n > 0){
			p_local = p_mat[k, j]
			p_star = pcomb(p_local)
			return(p_star * (1-p_star)/n)
		} else {
			return(0)
		}
	}
	computeVi = function(i, gamma){
		#Equation (8) in D-G
		v = 0
		for (k in 1:n_u){
			for (j in 1:n_cat){
				v = v + lambdaFun(i,k,j)^2 * vFun(k, j, gamma)
			}
		}
		return(v)
	}
	#Now compute w/ lapply
	V = sapply(1:n_u, computeVi, gamma)
	SE = sqrt(V)

	Z = (O - E) / SE

	out_df = data.frame(
			inst = as.numeric(as.character(instid_unique)),
			effect = O-E,
			O = O,
			E = E,
			D = D,
			SE = SE,
			Z = Z,
			n = n_u_vec
	)
	return( out_df[order(out_df$inst), ])
}


r <- combn(0:4, 3)
for(i in 1:choose(5,3)) print(r[,i])


## Absolute error vals for the whole range (including outliers)
rf_error_vals = abs(w$Time.s. - w$pred_rfe)
#hist(rf_error_vals, main = "", xlab = "", ylab="")

## Relative error including outliers
rf_rel_ev = sapply(rf_error_vals, function(x) x/253)
#hist(rf_rel_ev, main = "", xlab = "", ylab="")
#rug(rf_rel_ev)

library(dplyr)

## Eliminate outliers
no_outliers_2 = quantile(w$Time.s., probs = c(0.02, 0.98))
no_outliers_df_2 = data.frame(w$Time.s., w$pred_rfe)
dd_2 = no_outliers_df_2 %>% filter(no_outliers_df_2$w.Time.s. >= no_outliers_2[1] & no_outliers_df_2$w.Time.s. <= no_outliers_2[2])
range_no_outliers_2 = max(dd_2$w.Time.s.) - min(dd_2$w.Time.s.)
no_outliers_rf_error_2 = abs(dd_2$w.Time.s. - dd_2$w.pred_rfe)
no_outliers_rf_rel_error_2 = sapply(no_outliers_rf_error_2, function(x) x/range_no_outliers_2)

## Plot the maximum relative error per quantile
cdf_2 = quantile(no_outliers_rf_rel_error_2, seq(0.01,1,0.01))
no_outliers_median_rel_error_2 = sapply(seq(1,100,1), function(x) median(no_outliers_rf_rel_error_2[no_outliers_rf_rel_error_2 < cdf_2[x]]))

lines(cdf_2, lty=2, lwd=3, col="#999999")

## Add median error
lines(no_outliers_median_rel_error_2, col="#999999", lwd=3, lty=3)

## Add legend
legend("topleft", title="Type of error", c("Maximum error with 10% of outliers removed",
                                           "Maximum error with 4% of outliers removed",
                                           "Median error with 10% of outliers removed",
                                           "Median error with 4% of outliers removed"),
       col=c("black", "#999999", "black", "#999999"), lwd=c(2,3,2,3), lty=c(1,2,6,3))


# A matrix is a collection of elements of the same data type (numeric, character, or logical)
# arranged into a fixed number of rows and columns. Since you are only working with rows and columns,
# a matrix is called two-dimensional.

# Construct a matrix with 3 rows that contain the numbers 1 up to 9
matrix(1:9, byrow=TRUE, nrow=3)

# byrow: indicates that the matrix is filled by row. For columns use param of FALSE
# nrow: indicates the number of rows to fill

# Box office Star Wars (in millions!)
new_hope <- c(460.998, 314.4)
empire_strikes <- c(290.475, 247.900)
return_jedi <- c(309.306, 165.8)

# Create box_office
box_office <- c(new_hope, empire_strikes, return_jedi)

# Construct star_wars_matrix
star_wars_matrix <- matrix(box_office, byrow=TRUE, nrow=3)


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

# Hypothesis testing: Wald test, Likelihood Ratio, Lagrange Multiplier (práctico)
options(scipen=100000000)
set.seed(2020)

# Data
mydata <- read.csv("https://stats.idre.ucla.edu/stat/data/binary.csv")
head(mydata)
summary(mydata)
mydata$rank <- factor(mydata$rank)

#############
# Modelos
#############

# modelo 1
logit.1 <- glm(admit ~ gre + gpa + rank, data = mydata, family = binomial(link = "logit")) # unrestricted
summary(logit.1)

# modelo 2: sin rank
logit.2 <- glm(admit ~ gre + gpa, data = mydata, family = binomial(link = "logit")) # restricted
summary(logit.2)

#############
# Wald Test: probando parametros theta
#############

p_load(aod)

# Wald Test en el Intercepto
aod::wald.test(b = coef(logit.1), Sigma = vcov(logit.1), Terms = 1) # probemos que el primer coef = 0
# Si da significativo, b0 lo es tambien.

aod::wald.test(b = coef(logit.1), Sigma = vcov(logit.1), Terms = 1:2) # probemos que el primer y seg coef = 0
# Si da significativo, b0 Y b1 lo son tambien.

# Debes ingresar el numero de coeficiente segun como sale en el "call" del modelo.
# Sigma entrega la matrix de varianza-covarianza de los errores std.

#############
# Likelihood Ratio: comparando log-lilelihoods
#############

lrtest(logit.1, logit.2) # Fijate que aqui no comparamos parametros, si no que LogLik

# Extraer Lig Likelihood de cada modelo

logLik(logit.1)
logLik(logit.2)

# Que modelo es mejor?

#############
# Lagrange Multiplier
#############

# Otro nombre del Lagrange Multiplier es el Rao Score.
# Notar: "Terms added sequentially (first to last)"

anova(logit.1, test="Rao") # Terminos del modelo 1 son anadidos sequentially y comparados si aportan a mejorar el slope de la curva.

anova(logit.1,logit.2, test="Rao") # Ambos modelos son comparados y ven si EN CONJUNTO ("joint hypothesis") mejoran el slope de la curva.


install.packages("pbapply")
install.packages("dplyr")
library("pbapply")
library("dplyr")

generate_data <- function(n, alpha1, alpha2, alpha3) {
  x1 <- runif(100, 0, 1000)
  x2 <- runif (100, 0, 1000)
  x3 <- runif(100, 0, 1300)
  y <- alpha1*x1 + alpha2*x2 + alpha3*x3
  return(data.frame(x1=x1,
                    x2=x2,
                    x3=x3,
                    y=y))
}

estimate <- function(data) {
  ls <- lm(y ~ x1 + x2 + x3, data = data)
  coef <- ls$coefficients
  return(coef)
}

evaluate <- function(est, alpha1, alpha2, alpha3) {
  return(c(alpha1 - est[1],  alpha2 - est[2], alpha3 - est[3]))
}

iteration <- function(alpha1, alpha2, alpha3) {
  data <- generate_data(alpha1, alpha2, alpha3)
  est <- estimate(data)
  return(evaluate(alpha1, alpha2, alpha3))
}

simulation <- function(n, alpha1, alpha2, alpha3) {
  result <- pbsapply (1:n, function (x) {
    iteration(alpha1, alpha2, alpha3)
  })
  rowMeans(result)

}

simulation(100, 10, 13, 3)


# calculate probability in normal distribution with R
# variable y  with normal distribution N(??, ??), where ??=20 and ?? = 2
# pnorm function gives the probability of a normally distributed random number to be less that the value of a given number.
#  the probability that a measurement will be less than 23 is given by
pnorm(23,mean =20,sd=2)


library(tidyverse)
library(ggcorrplot)

demo_data = read_csv("output/medicare-analysis/demographic-data.csv")
medicare_opiate_data = read_csv("output/medicare-analysis/medicare-opiate-data.csv")
medicare_opiate_data = medicare_opiate_data %>% rename(CENSUSTRACT = census_tract)
medicare_opiate_data = medicare_opiate_data %>% rename(TOTAL_CLAIM_COUNT = CT_Total_Claim_Count,
                                                       OPIOD_CLAIM_COUNT = CT_Opioid_Claim_Count,
                                                       LONG_ACTING_OPIOD_CLAIM_COUNT = CT_Long_Acting_Opioid_Claims)

medicare_opiate_data = medicare_opiate_data %>% mutate(OPIOD_CLAIM_RATE = OPIOD_CLAIM_COUNT/TOTAL_CLAIM_COUNT)
medicare_opiate_data = medicare_opiate_data %>% mutate(LONG_ACTING_OPIOD_CLAIM_RATE = LONG_ACTING_OPIOD_CLAIM_COUNT/TOTAL_CLAIM_COUNT)

ho_data = read_csv("output/medicare-analysis/ho_data_for_analysis.csv")
ho_data = ho_data %>% rename(CENSUSTRACT = CensusTract)
prevention_data = read_csv("output/medicare-analysis/prevention_data_for_analysis.csv")
prevention_data = prevention_data %>% rename(CENSUSTRACT = CensusTract)
ub_data = read_csv("output/medicare-analysis/ub_data_for_analysis.csv")
ub_data = ub_data %>% rename(CENSUSTRACT = CensusTract)

# select(c(CensusTract, BINGE, CSMOKING, LPA, OBESITY))

ct_names = read_csv("output/medicare-analysis/census_tract_names.csv")
colnames(ct_names) = c("CENSUSTRACT", "CENSUSTRACT_NAME")

agg_demo_data = demo_data
agg_demo_data = agg_demo_data %>% mutate(PRCT_20_24 = (AGE_20_24) / Total_Population)
agg_demo_data = agg_demo_data %>% mutate(PRCT_25_34 = (AGE_25_35) / Total_Population)
agg_demo_data = agg_demo_data %>% mutate(PRCT_35_44 = (AGE_35_44) / Total_Population)
agg_demo_data = agg_demo_data %>% mutate(PRCT_45_54 = (AGE_45_54) / Total_Population)
agg_demo_data = agg_demo_data %>% mutate(PRCT_55_59 = (AGE_55_59) / Total_Population)
agg_demo_data = agg_demo_data %>% mutate(PRCT_60_64 = (AGE_60_64) / Total_Population)

agg_demo_data = agg_demo_data %>% mutate(PRCT_65_74 = (AGE_65_74) / Total_Population)
agg_demo_data = agg_demo_data %>% mutate(PRCT_75_84 = (AGE_75_84) / Total_Population)
agg_demo_data = agg_demo_data %>% mutate(PRCT_85_years_plus = (AGE_85_years_plus) / Total_Population)
agg_demo_data = agg_demo_data %>% mutate(PRCT_45_PLUS = (AGE_45_54 + AGE_55_59 + AGE_60_64 + AGE_65_74 + AGE_75_84 + AGE_85_years_plus) / Total_Population)
agg_demo_data = agg_demo_data %>% mutate(PRCT_45_64 = (AGE_45_54 + AGE_55_59 + AGE_60_64) / Total_Population)

agg_demo_data = agg_demo_data %>% mutate(PRCT_WHITE = (White_Pop / Total_Population))
agg_demo_data = agg_demo_data %>% mutate(PRCT_BLACK = (Black_Pop / Total_Population))
agg_demo_data = agg_demo_data %>% mutate(PRCT_HISPANIC = (Hispanic_Population / Total_Population))
agg_demo_data = agg_demo_data %>% mutate(MALE_TO_FEMALE_RATIO = (Males_To_Female / Total_Population))
# agg_demo_data = agg_demo_data %>% select(CensusTract, PRCT_20_24, PRCT_25_34, PRCT_35_44, PRCT_45_54, PRCT_55_59, PRCT_60_64,
#                                          PRCT_65_74, PRCT_75_84, PRCT_85_years_plus, MALE_TO_FEMALE_RATIO, PRCT_WHITE, PRCT_BLACK, PRCT_HISPANIC)
agg_demo_data = agg_demo_data %>% rename(CENSUSTRACT = CensusTract)

joined_data = ct_names %>% inner_join(agg_demo_data) %>% inner_join(ho_data) %>% inner_join(prevention_data) %>% inner_join(ub_data) %>% inner_join(medicare_opiate_data)

# corr_plots
demo_corr = ct_names %>% inner_join(agg_demo_data) %>% inner_join(medicare_opiate_data)
demo_corr = demo_corr %>% select(-c(CENSUSTRACT, CENSUSTRACT_NAME))
demo_corr = demo_corr %>% select(PRCT_25_34, PRCT_45_PLUS, MALE_TO_FEMALE_RATIO, PRCT_WHITE, PRCT_BLACK, PRCT_HISPANIC, OPIOD_CLAIM_RATE)
p.mat <- cor_pmat(demo_corr)
corr_obs = "pairwise.complete.obs"
corr_method = "pearson"
demo_corr = demo_corr %>% cor(use=corr_obs, method = corr_method) %>% round(2)
demo_corrplot_opiate_rate = demo_corr %>% ggcorrplot(type="lower", lab = TRUE, p.mat = p.mat, sig.level = .05) + ggtitle("Correlation Among Different Census Tract \nDemographics & Medicare Data Statistics")

demo_corr = ct_names %>% inner_join(agg_demo_data) %>% inner_join(medicare_opiate_data)
demo_corr = demo_corr %>% select(-c(CENSUSTRACT, CENSUSTRACT_NAME))
demo_corr = demo_corr %>% select(PRCT_45_64, PRCT_85_years_plus, TOTAL_CLAIM_COUNT, OPIOD_CLAIM_COUNT)
p.mat <- cor_pmat(demo_corr)
corr_obs = "pairwise.complete.obs"
corr_method = "pearson"
demo_corr = demo_corr %>% cor(use=corr_obs, method = corr_method) %>% round(2)
demo_corrplot_total_claims = demo_corr %>% ggcorrplot(type="lower", lab = TRUE, p.mat = p.mat, sig.level = .05) + ggtitle("Correlation Among Different Census Tract \nDemographics & Medicare Data Statistics")

# corr_plots - ub_data
ub_data_corr = ct_names  %>% inner_join(ub_data) %>% inner_join(medicare_opiate_data)
ub_data_corr = ub_data_corr %>% select(-c(CENSUSTRACT, CENSUSTRACT_NAME))
p.mat <- cor_pmat(ub_data_corr)
corr_obs = "pairwise.complete.obs"
corr_method = "pearson"
ub_data_corr = ub_data_corr %>% cor(use=corr_obs, method=corr_method) %>% round(2)
ub_data_corrplot = ub_data_corr %>% ggcorrplot(type="lower", lab = TRUE, p.mat = p.mat, sig.level = .35) + ggtitle("Correlation Among Different Census Tract Unhealthy Behaviors\n & Medicare Data Statistics")

# corr_plots - prevention_data
prevention_data_corr = ct_names  %>% inner_join(prevention_data) %>% inner_join(medicare_opiate_data)
prevention_data_corr = prevention_data_corr %>% select(-c(CENSUSTRACT, CENSUSTRACT_NAME))
prevention_data_corr = prevention_data_corr %>% select(ACCESS2, TOTAL_CLAIM_COUNT, OPIOD_CLAIM_COUNT, OPIOD_CLAIM_RATE, LONG_ACTING_OPIOD_CLAIM_RATE)
p.mat <- cor_pmat(prevention_data_corr)
corr_obs = "pairwise.complete.obs"
corr_method = "pearson"
prevention_data_corr = prevention_data_corr %>% cor(use=corr_obs, method=corr_method) %>% round(2)
prevention_data_corrplot = prevention_data_corr %>% ggcorrplot(type="lower", lab = TRUE, p.mat = p.mat, sig.level = .35) + ggtitle("Correlation Among Different Census Tract Preventative Measures\n & Medicare Data Statistics")

# corr_plots - prevention_data
ho_data_corr = ct_names  %>% inner_join(ho_data) %>% inner_join(medicare_opiate_data)
ho_data_corr = ho_data_corr %>% select(-c(CENSUSTRACT, CENSUSTRACT_NAME))
ho_data_corr = ho_data_corr %>% select(c(PHLTH, MHLTH, DIABETES, COPD, BPHIGH, TOTAL_CLAIM_COUNT, OPIOD_CLAIM_COUNT, OPIOD_CLAIM_RATE, LONG_ACTING_OPIOD_CLAIM_RATE))
p.mat <- cor_pmat(ho_data_corr)
corr_obs = "pairwise.complete.obs"
corr_method = "pearson"
ho_data_corr = ho_data_corr%>% cor(use=corr_obs, method=corr_method)  %>% round(2)
ho_data_corrplot = ho_data_corr %>% ggcorrplot(type="lower", lab = TRUE, p.mat = p.mat, sig.level = .35) + ggtitle("Correlation Among Different Census Tract Health Outcome\n & Medicare Data Statistics")


#==============================================================================
#	Unit test of MESS calculation
#==============================================================================
library(testthat)
#library(cv.models)

#------------------------------------------------------------------------------
context("Unit test for distance using the Vincenty's formulae.")

deg2rad <- cv.models:::deg2rad
vincenty.distance <- cv.models:::vincenty.distance

#------------------------------------------------------------------------------
test_that(
	"Test correctness of distance calculation using the Vincenty's formulae.",
	{
		# Test data were calculated by:
		# http://geographiclib.sourceforge.net/cgi-bin/GeodSolve
		data <- list(
			# Correct cases.
			list(x1 = 130, y1 = 45, x2 = 135, y2 = 50, d = 671179.867),
			list(x1 = 135, y1 = 50, x2 = 130, y2 = 45, d = 671179.867),
			list(x1 = 0, y1 = 0, x2 = 135, y2 = 50, d = 13021637.948),
			# Vectorized version.
			list(
				x1 = rep(130, 2), y1 = rep(45, 2),
				x2 = rep(135, 2), y2 = rep(50, 2), d = rep(671179.867, 2)
			),
			# Negative coordinates
			list(x1 = -130, y1 = 0, x2 = 135, y2 = 50, d = 10367107.083856503),
			list(x1 = -130, y1 = 0, x2 = -135, y2 = -50, d = 5561303.74228109),
			# Extreme values.
			list(x1 = -180, y1 = 0, x2 = 180, y2 = 90, d = 10001965.729312723),
			list(x1 = 180, y1 = 90, x2 = 180, y2 = 89.999999, d = 0.111693980)
		)
		for (i in data) {
			expect_equal(
				vincenty.distance(
					6378137, 6356752.3142451793,
					deg2rad(i$x1), deg2rad(i$y1), deg2rad(i$x2), deg2rad(i$y2)
				),
				i$d
			)
		}
	}
)


needed_packages <- c(
  "tidyverse"
  , "lubridate"
  , "EpiEstim"
  , "incidence"
  , "projections"
  , "epitrix"
  , "distcrete")

lapply(needed_packages, function(x) { if(!require(x,character.only = TRUE)) install.packages(x)} )

require(lubridate)
require(tidyverse)
theme_set(theme_bw())
source("R/functions.r")

#csv_fname <- "https://raw.githubusercontent.com/lsaravia/covid19ar/master/coronavirus_ar.csv"
csv_fname <- "Data/coronavirus_ar.csv"

cor <- read_csv(csv_fname) %>% dplyr::select(fecha:TDFdia)
cor <- cor  %>% mutate(fecha=ymd(fecha), dias =as.numeric( fecha - min(fecha)))
cor <- cor %>% mutate(importadosdia=importados-lag(importados))
cor$importadosdia[1] <- 1
cor <- cor %>% mutate(localesdia=casosdia - importadosdia, CABAdia=ifelse(is.na(CABAdia),0,CABAdia))

#
# Ajuste de modelos log-lineales (exponencial)
#
require(incidence)
require(projections)

cor_incidence <- cor  %>% dplyr::select(fecha, CABAdia) %>% uncount(CABAdia)
cor_incidence_obj <- incidence::incidence(cor_incidence$fecha, last_date=max(cor$fecha))

#
#
#
cor_incidence_peak <- as.Date("2020-03-30")   # Estimo que alli termina la fase exponencial inicial
cor_incidence_peak <- estimate_peak(cor_incidence_obj)
cor_incidence_peak <- ymd(cor_incidence_peak$estimated)

cor_incidence_fit <- incidence::fit(cor_incidence_obj,
                                    split = cor_incidence_peak)

cor_incidence_fit

# plot the incidence data and the model fit
plot(cor_incidence_obj) %>% add_incidence_fit(cor_incidence_fit) + ylab("Nro de Casos por Día")+
  labs(title = "Incidencia Observada y ajuste log-lineal para CABA COVID-19",
       subtitle = "Argentina, 2020 by @larysar") +
  geom_vline(xintercept = cor_incidence_peak,col = "red", lty = 2) + scale_y_log10()

require(epitrix)
require(distcrete)
#
# Parametros de la distribucion gamma para el intervalos serial
#
mu <- 6.6944741
sigma <- 4.4140809

param <- gamma_mucv2shapescale(mu, sigma / mu)
w <- distcrete("gamma", interval = 1,
               shape = param$shape,
               scale = param$scale, w = 0)

#
# Calculo del R0
#

dfCABA <- cor %>% dplyr::rename(nue_casosconf_diff=CABAdia)
esProv <- estima_Re_from_df(dfCABA,"CABA",end_date = max(cor$fecha),nombre_fases = c("Cuarentena","Fase 2","Fase 3","Fase 3"))
meanR <- esProv[[2]]$R$`Mean(R)`

growth_R0 <- lm2R0_sample(cor_incidence_fit$before$model, w)

summary(growth_R0)

decay_R0 <- lm2R0_sample(cor_incidence_fit$after$model, w)
summary(decay_R0)

#
#
#
set.seed(1)
pred_fwd_days <- 10

date_range <- 1:(which(get_dates(cor_incidence_obj) == cor_incidence_peak) - pred_fwd_days)
test_pred_growth <- project(cor_incidence_obj[date_range],
                            R = median(growth_R0),
                            si = w,
                            n_days = pred_fwd_days, n_sim = 1000)

#
#
set.seed(1)
pred_fwd_days <- 10 # 5
if(cor_incidence_peak < "2020-04-30"){
  date_range <- which(get_dates(cor_incidence_obj) == cor_incidence_peak):(length(get_dates(cor_incidence_obj)) - pred_fwd_days)

} else {
date_range <- (which(get_dates(cor_incidence_obj) == cor_incidence_peak)-pred_fwd_days):(which(get_dates(cor_incidence_obj) == cor_incidence_peak))
}
#
# Ultimos 7 dias
#
cor_incidence_peak = max(cor$fecha) - 7
date_range <- (which(get_dates(cor_incidence_obj) == cor_incidence_peak)-pred_fwd_days):(which(get_dates(cor_incidence_obj) == cor_incidence_peak))
decay_R0 <- meanR[length(meanR)]

test_pred_decay <- project(cor_incidence_obj[date_range],
                           R = median(decay_R0),
                           si = w,
                           n_days = 60, n_sim = 1000)

plot(cor_incidence_obj) %>% add_projections(test_pred_growth, boxplots = FALSE) %>% add_projections(test_pred_decay, boxplots = FALSE) +  geom_vline(xintercept = cor_incidence_peak,col = "red", lty = 2)

#
# Extraer la info del objeto test_pred_decay (con las predicciones)
# calcular la relacion entre incidencia y los fallecidos 14 dias despues (se supone que en ese momento entraron en la UTI)
#
preds <- data.frame(test_pred_decay) %>% pivot_longer(-dates,values_to = "pred",names_to = "sim") %>% group_by(dates) %>%
  summarise(pred_mean=mean(pred), pred_99=quantile(pred,.995),pred_1=quantile(pred,.005)  ) %>% rename(fecha=dates) %>%
  full_join( cor %>% select(fecha,CABA,CABAdia,CABAFallecido,CABAterapia)) %>% arrange(fecha) %>%
  mutate(CABAlag14 = lag(CABAdia,14), porcUTI=CABAFallecido/CABAlag14)

mporcUTI <-  median(preds$porcUTI[preds$porcUTI>0],na.rm = T)

#
# A partir del dato de ocupacion de UTI de CABA del dia 2020-05-30 calculo entradas y salidas usando `mporcUTI`
#
preds <- preds %>% mutate( CABAdia = ifelse(is.na(CABAdia),pred_mean,CABAdia), entraUTI=rpois(n(),CABAdia*mporcUTI), saleUTI=lag(entraUTI,14),
                           entraSale= ifelse(fecha<"2020-05-31",0,entraUTI-saleUTI),
                           permaUTI=ifelse(fecha<"2020-05-31",CABAterapia,152 + cumsum(entraSale)),CABAcum=cumsum(CABAdia))

col <- viridisLite::viridis(3)

ggplot(preds, aes(x = fecha, y = CABAcum) ) +
  geom_line(color = col[1]) +
  geom_point( aes(x=fecha,y=permaUTI), size = .5, color= col[2]) + scale_y_log10() +
  geom_hline(yintercept = 1250, size = .5, color= "red",lty=2) +  theme_bw() + ylab("Casos") +
  annotate("text",x=ymd("20200701"), y=2,label=paste("% a UTI=", round(mporcUTI,2)*100,"\n R0 =", round(median(decay_R0),2), "\nby @larysar"),color="red",size=2) +
      labs(title = paste("Incidencia Observada hasta", today()),
        subtitle ="y modelada para CABA COVID-19")


#loading libraries
library (ISLR )
library(caret)
library(dplyr)
library(glmnet)
library(elasticnet)

#reading the input file
df1 <- read.csv("/Users/rajivranjan/Desktop/slump.csv", header=TRUE)
df1<-select(df1, Cement,Slag,Fly.ash,Water,SP,Coarse.Aggr.,Fine.Aggr.,FLOW.cm.)

#randomly selecting 85 Samples
smp_size1 <- floor(0.83 * nrow(df1))
set.seed(123)
train_ind1 <- sample(seq_len(nrow(df1)), size = smp_size1)

#divinding train and test data
train1 <- df1[train_ind1, ]
test1 <- df1[-train_ind1, ]

#changing the data set into matrix bcz ridgefit takes only matrix
#selecting all the values except FLOW.cm in x
x1<-model.matrix(FLOW.cm.~.,train1)
y1<-as.matrix(train1$FLOW.cm.)

xtest1<-model.matrix(FLOW.cm.~.,test1)
ytest1<-as.matrix(test1$FLOW.cm.)

#generating the model
RidgeMod <- cv.glmnet(x1, y1, alpha=0, nlambda=100,lambda.min.ratio=0.0001,nfolds=5)
LassoMod <- cv.glmnet(x1, y1, alpha=1, nlambda=100,lambda.min.ratio=0.0001,nfolds=5)

#Plotting the best model Ridge
fit1 <- RidgeMod$glmnet.fit

plot(fit1,xlab="L2 Norm",main="Degree of freedom")
grid (NULL,NULL, lty = 1, col = "brown4")

legend("topleft", legend=c("Cement", "Slag","Fly.ash","Water","SP","Coarse.Aggr.","Fine.Aggr."),
       col=c("gray74", "red","green","blue","paleturquoise","orchid","black"), lty=1, cex=0.8,
       text.font=2)
#plotting the best model Lasso

fit2 <- LassoMod$glmnet.fit

plot(fit2,xlab="L1 Norm",main="Degree of freedom")
grid (NULL,NULL, lty = 1, col = "brown4")

legend("topleft", legend=c("Cement", "Slag","Fly.ash","Water","SP","Coarse.Aggr.","Fine.Aggr."),
       col=c("gray74", "red","green","blue","paleturquoise","orchid","black"), lty=1, cex=0.8,
        text.font=2)


#---------------------------------------------------------------------
# nn_norm -- Utility function for normalizing matrices for neural
#            network analyses.
#
# Usage:  normed_mat <- nn_norm(input, [type=c("mm","z")], [alt=normed_mat])
#
# Args:
#  input  -- An input vector or matrix to be normalized by columns.
#  type   -- One of "mm" for min-max normalization or "z" for z-scores
#  alt    -- An already normalized matrix with the same number of columns
#            as the input from which the scaling and offset are used.
#
# Description:
#  By default, nn_norm applies min-max scaling to the input matrix and
#  returns a normalized copy of the input. The offset and scaling factor
#  used for normalization are returned as attributes of the output
#  matrix, specifically "nn_norm:offset" and "nn_norm:scale". These
#  attributes can then be used to restore the original matrix, or used
#  to apply equivalent normalization to another matrix when passed as
#  the alt argument.
#
#  See nn_unnorm for the inverse of this.
#
# Author: Bunnell -- 1/4/20
#----------------------------------------------------------------------
nn_norm <- function(inp, type="mm", alt=NULL) {
#
# Calculate or assign scale and offset
#
  if (is.null(alt)) {
    if (type == "mm") {
      #cat("scale MM\n")
      if (is.null(dim(inp))) {
        coff <- min(inp)
        cscl <- max(inp) - coff
        if (cscl == 0) {
          cscl = 1
        }
      } else {
        cmax <- apply(inp, 2, max)
        coff <- apply(inp, 2, min)
        cscl <- cmax - coff
        j <- which(cscl == 0 | is.nan(cscl) | is.na(cscl))
        cscl[j] <- 1
      }
    } else {
      #cat("scale Z\n")
      if (is.null(dim(inp))) {
        coff <- mean(inp)
        cscl <- sd(inp)
        if (cscl == 0 || is.na(cscl) || is.nan(cscl))
          cscl = 1
      } else {
        cscl <- apply(inp, 2, sd)
        coff <- apply(inp, 2, mean)
        j <- which(cscl == 0 | is.nan(cscl) | is.na(cscl))
        cscl[j] <- 1
      }
    }
  } else {
    #cat("alt scaling\n")
    coff <- attr(alt, "nn_norm:offset")
    cscl <- attr(alt, "nn_norm:scale")
  }
#
# Apply the scaling
#
  if (is.null(dim(inp))) {  # Must be a vector
    oup <- (inp - coff) / cscl
  } else {
    oup <- t((t(inp) - coff) / cscl)
  }
#
# Save scaling parameters as attributes
#
  attr(oup, 'nn_norm:offset') = coff
  attr(oup, 'nn_norm:scale') = cscl

  oup
}

#---------------------------------------------------------------------
# nn_unnorm -- Utility function to undo normalization that was applied
#              to a matrix or vector.
#
# Usage:  matrix <- nn_unnorm(input, [alt=normed_mat])
#
# Args:
#  input  -- An previously normalized input vector or matrix or similar
#            object that is presumed to be in the normalized space of
#            another object passed as the alt argument.
#  alt    -- An already normalized matrix with the same number of columns
#            as the input from which the scaling and offset are used.
#
# Description:
#  By default, nn_unnorm uses the attributes of the input matrix to
#  recover the offset and scaling parameters and applies the inverse
#  operation to restore the original unnormalized matrix.
#
#  If the alt argument is provided, nn_unnorm instead uses the
#  scaling attributes from the alt matrix to apply to the input matrix.
#
#  See nn_norm for the inverse of this.
#
# Author: Bunnell -- 1/4/20
#----------------------------------------------------------------------
#
nn_unnorm <- function(inp, alt=NULL) {
  if (is.null(alt)) {
    coff <- attr(inp, "nn_norm:offset")
    cscl <- attr(inp, "nn_norm:scale")
  } else {
    coff <- attr(alt, "nn_norm:offset")
    cscl <- attr(alt, "nn_norm:scale")
  }

  if (is.null(dim(inp))) {
    oup <- cscl * inp + coff
  } else {
    oup <- t((t(inp) * cscl) + coff)
  }

  oup
}


model = kmeans(scale(dat[, sapply(dat, is.numeric)]), 10)

# Radial plot vizualization
radial = function(model) {
  clusters = length(model$size)
  params = ncol(model$centers)
  melted = melt(model$centers)

  names(melted) = c("Cluster", "Variable", "Value")
  melted$Cluster = as.factor(melted$Cluster)

  plt = ggplot(melted, aes(x=Variable, y=Value, group=Cluster, color=Cluster))
  plt = plt + coord_polar() + geom_point(size=3) + geom_path()
  plt
}

# Evaluate cluster robustness
robustness = function(dat, runs=10, krange=10) {
  library(fpc)

  perf = clusterboot(scale(dat[, sapply(dat, is.numeric)]), clusterMethod=kmeansCBI, runs=runs, krange=krange)
  return(perf)
}

# Evaluate criterias for selecting optimal number of clusters
criterias = function(dat, model) {
  library(clusterCrit)

  ic = intCriteria(as.matrix(dat), model$cluster, "all")
  crit = data.frame()
  for (k in 2:20) {
    m = kmeans(scale(dat), k)
    crit = rbind(crit, as.numeric(intCriteria(as.matrix(dat), m$cluster, "all")))
  }
  crit = data.frame(sapply(crit, function(x) {x[is.nan(x)] = 0; x}))

  dsc = cbind(k=2:20, data.frame(sapply(crit, scale)))
  dscm = melt(dsc, id.vars="k", variable.name="Measure")
  dscm$value[is.nan(dscm$value)] = 0
  ms = as.character(unique(dscm$Measure))

  plt = ggplot(subset(dscm, Measure %in% ms), aes(x=k, y=value, colour=Measure))
  plt = plt + geom_point(aes(shape=Measure)) + geom_line(aes(linetype=Measure))
  plt
}

selfOrganizingMap = function(dat) {
  library(kohonen)
  model <- som(scale(dat), grid = somgrid(5, 4, "hexagonal"))
  plot(model, main="Clusters")

  return(model)
}


# ------------------------------------------------------------------------------
# Description:  Script to process bulk density data from Grassland Connectivity
#               study in Walnut Gulch Experimental Watershed (2018). Soils were
#               sampled using the displacement methods (Voluvessel).
# Date:         1/5/21
# Author:       Justin Johnson
# ------------------------------------------------------------------------------
# Install and load packages
pkgs <- c('tidyverse','car')

check <- sapply(pkgs,require,warn.conflicts = TRUE,character.only = TRUE)
if(any(!check)){
  pkgs.missing <- pkgs[!check]
  install.packages(pkgs.missing)
  check <- sapply(pkgs.missing,require,warn.conflicts = TRUE,character.only = TRUE)
}

# ------------------------------------------------------------------------------
# Inputs
filename <- "Data/rg47_finescale_bulk_density.csv"

# ------------------------------------------------------------------------------
# Read in bulk density data
fine_bd <- read_csv(filename, col_types = "ffffn")

# Add a column for all four combinations of microsites and treatments
fine_bd <- fine_bd %>%
  unite(micro, treatment, microsite, remove = FALSE) %>%
  mutate(micro = factor(micro))

# Create linear model
bd_model <- aov(lm(bulk_density.gcm3 ~ micro, data = fine_bd))

# View diagnostic plots
plot(bd_model)

# Test for homogeneity of variance (Levene's Test)
leveneTest(bd_model)

# Test for normality of data
aov_residuals <- residuals(object = bd_model)
shapiro.test(aov_residuals)

# Assumptions of normality and homogeneity of variance are met.
# Perform one-way ANOVA.
summary(bd_model)

# All microsites are statistically comparable
# ------------------------------------------------------------------------------
# Get means and standard error by microsite

bd_summary <- fine_bd %>%
  group_by(micro) %>%
  summarize(mean = mean(bulk_density.gcm3),
            se = sd(bulk_density.gcm3)/sqrt(n()))


#' @title quantile_to_normal
#' @description convert quantile to normal with mean 0.5 and variance such that ci% are found within the range (0,1)
#' @family abysmally documented
#' @author  Jae Choi, \email{jae.choi@@dfo-mpo.gc.ca}
#' @export
quantile_to_normal = function( x, mean =0.5, ci=0.999 ) {

  xmin = min( x[ which(x>0) ], na.rm=T )
  xmax = max( x[ which(x<1) ], na.rm=T )

  pr = (1 - ci) / 2  # one-tailed prob in normal approximation desired
  zsd = 2 * abs( qnorm( pr, mean=0, sd=1) )  # range in x required to have ci% of the population, two tailed
  rsd = 1 / zsd # sd required for population to fit in (0,1)

  zscore = qnorm( x, mean=mean, sd=rsd )

  xx = which( x>=1 | zscore > 1)
  if (length(xx) > 0 ) zscore[ xx ] = 1

  nn = which( x<=0 | zscore < 0)
  if (length(nn) > 0 ) zscore[ nn ] = 0

  return (zscore)
}


library(MASS);

intervallo1 <- c(0,9)
intervallo2 <- c(9,16)

k_coeffs <- c(1, -1/7);

domanda3 <- 9

k <- 1
density1 <- function(x){

  k*k_coeffs[1]

}

density2 <- function(x){

  k*k_coeffs[2]*(x-intervallo2[2]);

}

ass1 <- function(x){

  x*k*k_coeffs[1];

}

ass2 <- function(x){

  x*k*k_coeffs[2]*(x-16)

}

integral1 <- integrate(Vectorize(density1), lower = intervallo1[1], upper = intervallo1[2])
integral2 <- integrate(Vectorize(density2), lower = intervallo2[1], upper = intervallo2[2])
integral <- integral1$value + integral2$value;
risposta1 <- 1/integral
print(fractions(risposta1));

k <- risposta1

integral1 <- integrate(Vectorize(ass1), lower = intervallo1[1], upper = intervallo1[2])
integral2 <- integrate(Vectorize(ass2), lower = intervallo2[1], upper = intervallo2[2])
integral <- integral1$value + integral2$value;

print(integral);

risposta3 <- 0
if( domanda3 >= intervallo1[1] && domanda3 <= intervallo2[2] ){
  if( intervallo1[1] <= domanda3 && domanda3 < intervallo1[2] ){
    integral <- integrate(Vectorize(density1), lower = intervallo1[1], upper= domanda3)
    integral <- integral$value
  } else{
    integral1 <- integrate(Vectorize(density1), lower = intervallo1[1], upper = intervallo1[2])
    integral2 <- integrate(Vectorize(density2), lower = intervallo2[1], upper = domanda3)
    integral <- integral1$value + integral2$value
  }
  risposta3 <- 1 - (integral);
}

print(risposta3)


###################################################
## Handy function to make contingency tables     ##
## of another, dimensionally-matching data frame ##
##                                               ##
## Author: Eric Magar emagar at itam dot mx      ##
## Created: 28may2021                            ##
## Revised: 28may2021                            ##
###################################################

myxtab <- function(r=NA, c=NA, margin=1, rel=TRUE, pct=FALSE, marginals=TRUE, digits=1){
    tmp <- table(r,c)
    pct <- ifelse(pct==FALSE | rel==FALSE, 1, 100)
    if (margin==1 & rel==TRUE  & marginals==TRUE)  tmp <- cbind(round(prop.table(tmp, margin)*pct, digits), tot=rep(pct, nrow(tmp)), N=margin.table(tmp, margin));
    if (margin==1 & rel==TRUE  & marginals==FALSE) tmp <-       round(prop.table(tmp, margin)*pct, digits);
    if (margin==1 & rel==FALSE & marginals==TRUE)  tmp <- cbind(                 tmp,                       tot=rowSums(tmp));
    if (margin==1 & rel==FALSE & marginals==FALSE) tmp <-                        tmp;
    #
    if (margin==2 & rel==TRUE  & marginals==TRUE)  tmp <- rbind(round(prop.table(tmp, margin)*pct, digits), tot=rep(pct, ncol(tmp)), N=margin.table(tmp, margin));
    if (margin==2 & rel==TRUE  & marginals==FALSE) tmp <-       round(prop.table(tmp, margin)*pct, digits);
    if (margin==2 & rel==FALSE & marginals==TRUE)  tmp <- rbind(                 tmp,                       tot=rowSums(tmp));
    if (margin==2 & rel==FALSE & marginals==FALSE) tmp <-                        tmp;
    return(tmp)
}


linear_regression = function(x,y){
 b1 = (length(x)*sum(x*y)-sum(x)*sum(y))/(length(x)*sum(x^2)-(sum(x))^2)
 b0 = (sum(y)-b1*sum(x))/length(x)
 return(c(b0,b1))
}

squarederror<-function(b0,b1,x,y)


# Clases
x <- 1:7
y <- x > 3 & x < 5
y

paste(c("X", "Y"), 1:5, sep = "")
names(x) <- paste(c("x"), seq_along(x), sep = "")
x
nth <- paste0(1:10, c("st", "nd", "rd", rep("th", 7)))
nth

LETTERS[1:20]
month.name[1:14]

x <- seq(0, 1, length.out = 10)
x[c(2, 4)]
x[1:7]
x[seq(1, 10, by = 2)]
x
x[-c(2, 5)] # x quitando -c(...)

x <- -5:5
x > 0
x[x > 0]

peso <- c(60, 75, 56, 70)
sexo <- c("F", "M", "F", "M")
peso[sexo == "F"]
names(peso) <- c("Marta", "Jose", "Paula", "Paco")
peso[c("Marta", "Paula")]

x <- c(1:8, NA, 10) # x es un vector con un dato faltante
x
is.na(x)
mean(x)
mean(x, na.rm = TRUE)
is.na(x) <- c(2, 3)
x # la sentencia anterior define como NA los elementos segundo y tercero

x[is.na(x)] <- 77
x
0 / 0
Inf - Inf
x <- c(NaN, 1:4, NA)
x
is.na(x)
is.nan(x)

x <- 1:5
y <- seq(0, 1, length.out = 5)
x + y
x * y
exp(x) + log(1 + y)
x^2

z <- c(-2, -1)
x + z

x <- (1:10) / 10
(x < 0.3) * (2 * x) + (0.3 <= x & x < 0.7) * x^2 + (x >= 0.7) * 2

x <- c(2, 3, 5, 10, 6, 1)
cumsum(x)
prod(x)
cumprod(x)
max(x)
which.max(x)
x[which.min(x)] # equivale a min(x)
x
sort(x) # ordena
order(x) # devuelve los índices ordenados
x
x[order(x)] ### == sort(x)

set.seed(1)
x <- runif(100) # 100 valores aleatorios de una Uniforme(0,1)
mx <- mean(x)
which((x - mx) == min((x - mx)))

x <- 1:5
mode(x)

y <- x > 2
mode(y)

z <- letters[5]
mode(z)


#  Calculating a Confidence Interval From a Normal Distribution
n<-50
 a<-2.8
 s<-0.6
 #  we will use a 95% confidence level and wish to find the confidence interval
 margin <- qnorm(0.975)*s/sqrt(n)
 left_i <- a-margin
   right_i <- a+margin
   print("Confidence interval is")
   print(left_i)
   print(right_i)


=begin
  # sample-geometry04.rb

  require 'algebra'

  R = MPolynomial(Rational)
  x,y,a1,a2,b1,b2,c1,c2 = R.vars('xya1a2b1b2c1c2')
  V = Vector(R, 2)
  X, A, B, C = V[x,y], V[a1,a2], V[b1,b2], V[c1,c2]

  def perpendicular(p0, p1, p2, p3)
    (p0-p1).inner_product(p2-p3)
  end

  def line(p1, p2, p3)
    SquareMatrix.det([[1, *p1], [1, *p2], [1, *p3]])
  end

  l1 = perpendicular(X, A, B, C)
  l2 = perpendicular(X, B, C, A)
  l3 = perpendicular(X, C, A, B)

  s = line(A, B, C)
  g = Groebner.basis [l1, l2, l3, s-1] #s-1 means non degeneracy

  g.each do |f|
    p f
  end
  #x + a1a2b1 - a1a2c1 - a1b1c2 + a1c1c2 + a2^2b2 - a2^2c2 - a2b1^2 + a2b1c1 - a2b2^2 + a2c2^2 + b1^2c2 - b1c1c2 - b1 + b2^2c2 - b2c2^2
  #y - a1^2b1 + a1^2c1 + a1b1^2 - a1c1^2 - a2^2b1 + a2^2c1 + a2b1b2 + a2b1c2 - a2b2c1 - a2c1c2 - a2 - b1^2c1 - b1b2c2 + b1c1^2 + b2c1c2
  #a1b2 - a1c2 - a2b1 + a2c1 + b1c2 - b2c1 - 1
((<_|CONTENTS>))
=end


# http://blog.fosstrading.com/2011/03/how-to-backtest-strategy-in-r.html
require(quantmod)
require(PerformanceAnalytics)

# Step 1: Get the data
getSymbols("SPL.AX")
# SPL<-SPL[complete.cases(SPL),]                                                  # Delete NA
## use underlying time scale for interpolation
na.approx(SPL.AX)

# Step 2: Create your indicator
dvi <- DVI(Cl(na.approx(SPL.AX)))
# dfDVI <- data.frame(dvi)
# Convert indicartor to a tibble
# dvi <- as_data_frame(dvi)

# Step 3: Construct your trading rule
sig <- Lag(ifelse(dvi$dvi < 0.5, 1, -1))

# Step 4: The trading rules/equity curve
ret <- ROC(Cl(na.approx(SPL.AX)))*sig
ret <- ret['2009-06-02/2010-09-07']
eq <- exp(cumsum(ret))
plot(eq)

# Step 5: Evaluate strategy performance
table.Drawdowns(ret, top=10)
table.DownsideRisk(ret)
charts.PerformanceSummary(ret)


comb.sort<-function(a){
  gap<-length(a)
  swaps<-1
  while(gap>1 & swaps==1){
    gap=floor(gap/1.3)
    if(gap<1){
      gap=1
      }
    swaps=0
    i=1
    while(i+gap<=length(a)){
        if(a[i]>a[i+gap]){
        a[c(i,i+gap)] <- a[c(i+gap,i)]
        swaps=1
        }
        i<-i+1
      }
  }
  return(a)
}


Mar1Tab2 <- Mar1Tab[Mar1Tab$SALES > 0]

res.ftest <- var.test(SALES ~ HOLDOUT_FLAG, data = Mar1Tab2)
res.ftest

res.ttest <- t.test(SALES ~ HOLDOUT_FLAG, data = Mar1Tab1)
res.ttest

library(ggplot2)

ggplot(Mar1Tab2, aes(x=SALES))+ geom_histogram(bins=100)+facet_grid(~HOLDOUT_FLAG)

library(MASS)
tbl = table(Mar1Tab$HOLDOUT_FLAG, Mar1Tab$RESPONDED_FLAG)
tbl

chisq.test(tbl)

res.wilcox <- wilcox.test(SALES ~ HOLDOUT_FLAG, data = Mar1Tab)
res.wilcox


### fimd1.R
### R code from Van Buuren, S. (2012).
###		Flexible Imputation of Missing Data.
###		CRC/Chapman & Hall, Boca Raton, FL.
### (c) 2012 Stef van Buuren, www.multiple-imputation.com
### Version 1, 21mar2012
### Version 2, 4nov2015
### Tested with Mac OS X 10.7.3, R2.14-2, mice 2.12

### Chapter 1 	Introduction
### Section 1.1 The problem of missing data

### calculate the mean of three numbers
y <- c(1, 2, 4)
mean(y)

### calculate the mean of three numbers, where one is missing
y <- c(1, 2, NA)
mean(y)

### repeat, but with any missing data removed
mean(y, na.rm=TRUE)

### store your current options (safety measure)
youroptions <- options()

### demo regression that generates an error message using default na.fail
options(na.action = na.fail)

### uncomment to see the error
### lm(Ozone ~ Wind, data=airquality)

### remove incomplete observations by 'na.action = na.omit'
fit <- lm(Ozone ~ Wind, data = airquality, na.action = na.omit)
coef(fit)

### set automatic na.action = na.omit
options(na.action = na.omit)

### find out how many rows were deleted
deleted <- na.action(fit)
naprint(deleted)

### more incomplete rows if we add Solar.R as predictor
fit2 <- lm(Ozone ~ Wind+Solar.R, data=airquality)
naprint(na.action(fit2))

### restore your original options, but set na.omit
options(youroptions)
options(na.action=na.omit)

### Section 1.3.2 Pairwise deletion

### note: mean(<data.frame>) is deprecated
colMeans(airquality, na.rm=TRUE)
cor(airquality, use="pair")
cov(airquality, use="pair")

### Section 1.3.3 Mean imputation

### install the mice package from CRAN if you have not yet done so
### by uncommenting and running the next line
# install.packages("mice")

library("mice")
library("lattice")

### impute the mean
imp <- mice(airquality, method="mean", m=1, maxit=1)

### Figure 1.1
lwd <- 1.5
par(mfrow=c(1,2))
breaks <- seq(-20, 200, 10)
nudge <- 1
x <- matrix(c(breaks-nudge, breaks+nudge), ncol=2)
obs <- airquality[,"Ozone"]
mis  <- imp$imp$Ozone[,1]
fobs <- c(hist(obs, breaks, plot=FALSE)$counts, 0)
fmis <- c(hist(mis, breaks, plot=FALSE)$counts, 0)
y <- matrix(c(fobs, fmis), ncol=2)
matplot(x, y, type="s",
        col=c(mdc(4),mdc(5)), lwd=2, lty=1,
        xlim = c(0, 170), ylim = c(0,40), yaxs = "i",
        xlab="Ozone (ppb)",
        ylab="Frequency")
box()

tp <- xyplot(imp, Ozone~Solar.R, na.groups=ici(imp),
       ylab="Ozone (ppb)", xlab="Solar Radiation (lang)",
       cex = 0.75, lex=lwd,
       ylim = c(-20, 180), xlim = c(0,350))
print(tp, newpage = FALSE, position = c(0.48,0.08,1,0.92))

### Section 1.3.4 Regression imputation

fit <- lm(Ozone ~ Solar.R, data=airquality)
pred <- predict(fit, newdata=ic(airquality))

### alternative using mice
imp <- mice(airquality[,1:2], method="norm.predict", m=1, maxit=3,seed=1)

### Figure 1.2
par(mfrow = c(1,2))
fmis <- c(hist(pred, breaks, plot=FALSE)$counts, 0)
y <- matrix(c(fobs, fmis), ncol=2)
matplot(x, y, type="s",
        col=c(mdc(4),mdc(5)), lwd=2, lty=1,
        xlim = c(0, 170), ylim = c(0,40), yaxs = "i",
        xlab="Ozone (ppb)",
        ylab="Frequency")
box()

tp <- xyplot(imp, Ozone~Solar.R,
       ylab="Ozone (ppb)", xlab="Solar Radiation (lang)",
       cex = 0.75, lex=lwd,
       ylim = c(-20, 180), xlim = c(0,350))
print(tp, newpage = FALSE, position = c(0.48,0.08,1,0.92))

### Section 1.3.5 Stochastic regression imputation

imp <- mice(airquality[,1:2],method="norm.nob",m=1,maxit=1,seed=1)

### Figure 1.3
par(mfrow = c(1,2))
mis  <- imp$imp$Ozone[,1]
fmis <- c(hist(mis, breaks, plot=FALSE)$counts, 0)
y <- matrix(c(fobs, fmis), ncol=2)
matplot(x, y, type="s",
        col=c(mdc(4),mdc(5)), lwd=2, lty=1,
        xlim = c(0, 170), ylim = c(0,40), yaxs = "i",
        xlab="Ozone (ppb)",
        ylab="Frequency")
box()

tp <- xyplot(imp, Ozone~Solar.R, na.groups=ici(imp),
       ylab="Ozone (ppb)", xlab="Solar Radiation (lang)",
       cex = 0.75, lex=lwd,
       ylim = c(-20, 180), xlim = c(0,350))
print(tp, newpage = FALSE, position = c(0.48,0.08,1,0.92))

### Section 1.3.6 LOCF and BOCF

par(mfrow=c(1,1))
Oz <- airquality$Ozone
locf <- function(x) {
  a <- x[1]
  for (i in 2:length(x)) {
    if (is.na(x[i])) x[i] <- a
    else a <- x[i]
  }
  return(x)
}
Ozi <- locf(Oz)
colvec <- ifelse(is.na(Oz),mdc(2),mdc(1))

### Figure 1.4

plot(Ozi[1:80],col=colvec,type="l",xlab="Day number",ylab="Ozone (ppb)")
points(Ozi[1:80],col=colvec,pch=20,cex=1)

### Section 1.4.3 Example of multiple imputation

imp <- mice(airquality, seed=1, print=FALSE)
fit <- with(imp, lm(Ozone ~ Wind + Temp + Solar.R))
tab <- round(summary(pool(fit)),3)
tab[,c(1:3,5)]

fit <- lm(Ozone~Wind+Temp+Solar.R,data=airquality,na.action=na.omit)
round(coef(summary(fit)),3)

### Figure 1.6
par(mfrow = c(1,2))
mis  <- imp$imp$Ozone[,1]
fmis <- c(hist(mis, breaks, plot=FALSE)$counts, 0)
y <- matrix(c(fobs, fmis), ncol=2)
matplot(x, y, type="s",
        col=c(mdc(4),mdc(5)), lwd=2, lty=1,
        xlim = c(0, 170), ylim = c(0,40), yaxs = "i",
        xlab="Ozone (ppb)",
        ylab="Frequency")
box()

tp <- xyplot(imp, Ozone~Solar.R, subset = .imp==1,
       ylab="Ozone (ppb)", xlab="Solar Radiation (lang)",
       cex = 0.75, lex=lwd,
       ylim = c(-20, 180), xlim = c(0,350))
print(tp, newpage = FALSE, position = c(0.48,0.08,1,0.92))

### scatterplot of all imputed data sets (not in the book)
xyplot(imp, Ozone~Solar.R | .imp,
       ylab="Ozone (ppb)", xlab="Solar Radiation (lang)",
       cex = 0.75, lex=lwd,
       ylim = c(-20, 180), xlim = c(0,350))

### Figure 1.7

Oz <- airquality$Ozone
colvec <- ifelse(is.na(Oz),mdc(2),mdc(1))
par(mfrow=c(1,1))
plot(Oz[1:80],col=mdc(1),type="l",xlab="Day number",ylab="Ozone (ppb)")
points(Oz[1:80],col=mdc(1),pch=20,cex=1)

idx <- ici(airquality$Ozone) & (1:153)<81
x   <- (1:153)[idx]
points(x=x,y=complete(imp,1)$Ozone[idx],col=mdc(2),pch=20,cex=1)
points(x=x,y=complete(imp,2)$Ozone[idx],col=mdc(2),pch=20,cex=1)
points(x=x,y=complete(imp,3)$Ozone[idx],col=mdc(2),pch=20,cex=1)
points(x=x,y=complete(imp,4)$Ozone[idx],col=mdc(2),pch=20,cex=1)
points(x=x,y=complete(imp,5)$Ozone[idx],col=mdc(2),pch=20,cex=1)

### figure of the autocorrelation function
### (not in the book)

par(mfrow=c(2,5))
acf.ozone <- with(imp,acf(Ozone))
model <- expression(acf(resid(lm(Ozone ~ Wind + Temp + Solar.R))))
acf.resid <- with(imp,model)
calcacf <- function(acf.list) {
  k <- length(acf.list)
  acc <- acf.list[[1]]$acf
  for (i in 2:k) acc <- acc + acf.list[[i]]$acf
  return(acc/k)
 }
oz <- round(calcacf(acf.ozone$analyses),2)
re <- round(calcacf(acf.resid$analyses),2)


options(scipen = 999)

set.seed(082421)
# creating 5 different categories, with different amounts of time they show up in the data
categories = rep(letters[1:5], times = c(5, 4, 6, 8, 7))

# 30 observations with the mean and standard deviation
test_scores = rnorm(n = 30, mean = 7.14, sd = 2.16)

# Making the categories act like categories rather than numerical values
categories = as.factor(categories)

# Observations (be careful R is case sensitive)
N = 30

# Getting frequencies by using R as a calculator

# get the frequencies of all the categories
table(categories)

# Frequency & Percentage of A
5/30
(5/30)*100

# Frequency & Percentage of B
4/30
(4/30)*100

# Frequency & Percentage of C
6/30
(6/30)*100

# Frequency & Percentage of D
8/30
(8/30)*100

# Frequency & Percentage of E
7/30
(7/30)*100

# cumulative frequencies of categories A & B
(5/30) + (4/30)
# another option is to do the calculations above and then just add up the frequency of A with the frequency of B
.167 + .133

# To get the cumlative percentage of all 5 categories
(5/30)*100 + (4/30)*100 + (6/30)*100 + (8/30)*100 + (7/30)*100
# you can also use the calculations above to add up all the percentages
16.667 + 13.333 + 20 + 26.667 + 23.333

# Now getting frequencies by using objects

#remember that N is the number of observations
N

freq_a <- 5/N
freq_a

# Percent of category A
percent_a <- freq_a*100
percent_a

freq_b <- 4/N
freq_b

percent_b <- freq_b*100
percent_b

freq_c <- 6/N
freq_c

percent_c <- freq_c*100
percent_c

freq_d <- 8/N
freq_d

percent_d <- freq_d*100
percent_d

freq_e <- 7/N
freq_e

percent_e <- freq_e*100
percent_e

# cumulative frequency of A & B
freq_ab = freq_a + freq_b
freq_ab

# To get the cumlative percentage of all 5 categories
total_percent = percent_a + percent_b + percent_c + percent_d + percent_e
total_percent

# find the mode
# which value occurs most often
table(categories)

# Finding the mean
sort(test_scores)

#look for the middle value or in this case the 15th and 16th observations
# 7.060384 & 7.212301 and then divide by 2
(7.06 + 7.21)/2

# find the median using objects
sort(test_scores)
sort(test_scores)[15:16]

get_median = (7.06 + 7.21)/2
get_median

median(test_scores)

# Finding the mean
# look at test scores first in order for lowest to highest
sort(test_scores)

# Now let's get the sum of the scores
1.98 + 3.54 + 3.57 + 4.28 + 4.40 + 4.51 + 4.98 + 5.67 + 5.90 + 6.09 + 6.44 + 6.44 + 6.59 + 6.82 + 7.06 +
  7.21 + 7.29 + 7.82 + 7.87 + 7.87 + 8.24 + 8.69 + 8.85 + 8.92 + 9.38 + 9.41 + 10.67 + 10.95 + 12.06 + 12.59

# Now let's divide the sum of the scores by the number of observations to get the mean
(1.98 + 3.54 + 3.57 + 4.28 + 4.40 + 4.51 + 4.98 + 5.67 + 5.90 + 6.09 + 6.44 + 6.44 + 6.59 + 6.82 + 7.06 +
    7.21 + 7.29 + 7.82 + 7.87 + 7.87 + 8.24 + 8.69 + 8.85 + 8.92 + 9.38 + 9.41 + 10.67 + 10.95 + 12.06 + 12.59)/30

# 7.20 is the mean of our scores

# Now getting the mean with objects
sort(test_scores)

# look at how many observations we have
N

# Now lets get the sum of the scores
sum_of_scores = sum(test_scores)
sum_of_scores

# get the mean
xbar = sum_of_scores/N
# could also look at it this way
xbar2 = sum_of_scores/30

xbar
xbar2

# we get the same mean

#Finding how far each participant deviates from the mean value/score
sort(test_scores)
# look at how far students deviated from the average score by doing each one individually
1.98 - 7.20
3.54 - 7.20
3.57 - 7.20
4.28 - 7.20
4.40 - 7.20
4.51 - 7.20
4.98 - 7.20
5.67 - 7.20
5.90 - 7.20
6.09 - 7.20
6.44 - 7.20
6.44 - 7.20
6.59 - 7.20
6.82 - 7.20
7.06 - 7.20
7.21 - 7.20
7.29 - 7.20
7.82 - 7.20
7.87 - 7.20
7.87 - 7.20
8.24 - 7.20
8.69 - 7.20
8.85 - 7.20
8.92 - 7.20
9.38 - 7.20
9.41 - 7.20
10.67 - 7.20
10.95 - 7.20
12.06 - 7.20
12.59 - 7.20

# now to get the sum of the deviations
# this is right, you might just have to go past two decimal points
(-5.22) + (-3.66) + (-3.63) + (-2.92) + (-2.8) + (-2.69) + (-2.22) + (-1.53) + (-1.3) + (-1.11) + (-.76) + (-.76) +
  (-.61) + (-.38) + (-.14) + .01 + .09 + .62 +.67 + .67 + 1.04 + 1.49 + 1.65 + 1.72 + 2.18 +2.21 + 3.47 + 3.75 + 4.86 + 5.39

# Now getting the deviations from the mean score/value using objects
# remember to look at the test scores
sort(test_scores)

# lets remember what the mean was
xbar

# look at how far students deviated from the average score using the objects we created earlier
deviation = test_scores - xbar
deviation

# look to see how far the worse test score was from the mean
sort(deviation)

# getting the sum of the deviations
sum(deviation)


# Example : 4   Chapter : 2.7   Pageno : 110
# Product of matrix and its trnspose gives symmetric matrix
R<-matrix(c(-1,0,1,-1,0,1),ncol=3)
RT<-t(R)
print("R * t(R)")
print(R%*%RT)
print("t(R) * R")
print(RT%*%R)


#
# Ejemplo de búsqueda de outliers con LOF
#

library(Rlof)

# Leemos el dataset Iris
ds.iris = iris

# Calculamos los scores de LOF
# Con k=5
scores = lof(ds.iris[-c(5)], k=5, cores = 3)

# Graficamos la densidad
plot(density(scores))

# Filtramos los Top5 con mayor scores
outliers = order(scores, decreasing=T)[1:5]
print(outliers)

# Podemos ver los registros identificados como outliers
print(ds.iris[outliers,])

# --------------------------------------------------------------------------
#    Ejemplo1: Graficamos los outliers
# --------------------------------------------------------------------------
# 1) Los coloreo
ds.iris$col.out = '#ff0000'
ds.iris[outliers,]$col.out = '#0000ff'

# 2) Defino los símbolos
ds.iris$pch = 'o'
ds.iris[outliers,]$pch = '+'

# 3) Grafico el scatter plot
plot(ds.iris[c(1:4)], col=ds.iris$col.out, pch=ds.iris$pch)

# --------------------------------------------------------------------------
#  Ejemplo 2: Colorear cada uno de los outliers y cambiar el color también
# --------------------------------------------------------------------------
# Graficas cada uno de los outliers con un color y un caracter diferente
ds.iris$col.out = '#ff0000'
colores=c("#1b9e77","#d95f02","#7570b3","#e7298a","#66a61e")
simb=c('G','K','H','@','A')
for(i in 1:length(colores)){
  ds.iris[outliers[i],]$col.out = colores[i]
  ds.iris[outliers[i],]$pch = simb[i]
}
plot(ds.iris[c(1:4)], col=ds.iris$col.out, pch=ds.iris$pch)


library('fastDummies')
mat <- read.csv("student-mat.csv")
mat_prepros <- dummy_cols(mat,remove_first_dummy = TRUE)
mat_prepros <- mat_prepros[-c(1,2,4,5,6,9,10,11,12,16,17,18,19,20,21,22,23)]
data_mat <- mat_prepros[-c(16)]

data_mat_norm <-scale(data_mat)
Y <- c(mat_prepros$G3)

model <- lm(formula=Y~.,data=data_mat_norm)
summary(model)


context("minor breaks")

l1 <- c(0, 9)
l2 <- -l1
b1 <- extended_breaks()(l1)
b2 <- extended_breaks()(l2)
m1 <- regular_minor_breaks()(b1, l1, n = 2)
m2 <- regular_minor_breaks()(b2, l2, n = 2)

test_that("minor breaks are calculated correctly", {
  expect_equal(m1, seq(b1[1], b1[length(b1)], by = 1.25))
  expect_equal(m2, seq(b2[1], b2[length(b2)], by = 1.25))
})

test_that("minor breaks for reversed scales are comparable to non-reversed", {
  expect_equal(m1, sort(-m2))
})


<<<<<<< HEAD
library(arules)

setwd('C:\\Users\\fu\\Documents\\R\\Demo\\Apriori2')

#transaction database
tnx_db<-read.transactions('demo_basket',sep=',')
head(as(tnx_db,'matrix'))
colnames(as(tnx_db,'matrix'))

#find rules
rules<-apriori(
  tnx_db,
  parameter=list(support=0.05)
)

#support, confidence, lift
inspect(rules)
=======
library(arules)

setwd('C:\\Users\\fu\\Documents\\R\\Demo\\Apriori2')

#transaction database
tnx_db<-read.transactions('demo_basket',sep=',')
head(as(tnx_db,'matrix'))
colnames(as(tnx_db,'matrix'))

#find rules
rules<-apriori(
  tnx_db,
  parameter=list(support=0.05)
)

#support, confidence, lift
inspect(rules)
>>>>>>> 7b6db310dcb72ccc7ca457a560968aeaa9452357


#Using data from insideairbnb.com - data from the Santa Cruz, CA area, last updated October 2015
#Focus is on visualizing the data by room type

santacruz = read.csv("documents/airbnb_santacruz.csv")
attach(santacruz)

#Find out types of rooms
unique(santacruz$room_type)

#price per night based on room type
private <- subset(santacruz, room_type=="Private room")$price
home <- subset(santacruz, room_type=="Entire home/apt")$price
shared <- subset(santacruz, room_type=="Shared room")$price
prices <- c(mean(private),mean(home),mean(shared))

#Without ggplot, can just use built-in barplot (but it takes longer to try and make error bars)
barplot(prices,xlab="Room Type",ylab="$/night", main="Santa Cruz Airbnb Daily Price by Rental Type",
        names.arg=c("Private Room", "Full House/Apt", "Shared Room"), col=c("Red","Yellow","Blue"))

#With ggplot
#bar chart based on mean price per night, separated by room type
install.packages("ggplot2")
library(ggplot2)
ggplot(santacruz,aes(x=room_type,y=price)) + geom_bar(
    aes(fill=room_type),stat = "summary", fun.y = "mean") + labs(
    title="Santa Cruz Airbnb Daily Price by Rental Type", x="Room Type", y="$/night", fill="Room Type") +
geom_errorbar(stat = "summary",
                  width=.2,                    # Width of the error bars
                  position=position_dodge(.9))

#Is the difference in price between a private and a shared room significant?
#It certainly looks so in bar graph, but good to check (t should indeed be quite large)
t <- (mean(private)-mean(shared))/(sqrt(sd(private)^2/length(private)+sd(shared)^2/length(private)))
t


## ----echo=FALSE---------------------------------------------------------------
require(Hmisc)
knitrSet('gen')

## ----lspline2,echo=FALSE,child='lspline.Rnw'----------------------------------

## ----lspline,echo=FALSE,bty='l',cap='A linear spline function with knots at $a = 1, b = 3, c = 5$.'----
x <- c(0,1,3,5,6)
y <- c(4,3,5.5,5,2)
plot(x, y, type="l", xlab=expression(X), ylab=expression(f(X)), axes=FALSE)
axis(1)
axis(2, labels=FALSE)

## ----rcscomp2,child='rcscomp.Rnw'---------------------------------------------

## ----rcscomp,mfrow=c(1,2),left=-2,h=3.5,w=4.5,cap='Restricted cubic spline component variables for $k = 5$ and knots at $X = .05, .275, .5, .725$, and $.95$.  Nonlinear basis functions are scaled by $\\tau$.  The left panel is a $y$--magnification of the right panel.  Fitted functions such as those in Figure \\ref{fig:gen-rcsex} will be linear combinations of these basis functions as long as knots are at the same locations used here.',scap='Restricted cubic spline component variables for 5 knots'----
require(Hmisc)
x <- rcspline.eval(seq(0,1,.01),
                   knots=seq(.05,.95,length=5), inclx=T)
xm <- x
xm[xm > .0106] <- NA
matplot(x[,1], xm, type="l", ylim=c(0,.01),
        xlab=expression(X), ylab='', lty=1)
matplot(x[,1], x,  type="l",
        xlab=expression(X), ylab='', lty=1)

## ----rcsex2,child='rcsex.Rnw'-------------------------------------------------

## ----rcsex,h=6,w=5.5,left=-2,bot=2,mfrow=c(2,2),ps=13,cap='Some typical restricted cubic spline functions for $k = 3, 4, 5, 6$.  The $y$--axis is $X\\beta$.  Arrows indicate knots. These curves were derived by randomly choosing values of $\\beta$ subject to standard deviations of fitted functions being normalized.',scap='Some typical restricted cubic spline functions'----
x <- seq(0, 1, length=300)
for(nk in 3:6) {
  set.seed(nk)
  knots <- seq(.05, .95, length=nk)
  xx <- rcspline.eval(x, knots=knots, inclx=T)
  for(i in 1 : (nk - 1))
    xx[,i] <- (xx[,i] - min(xx[,i])) /
              (max(xx[,i]) - min(xx[,i]))
  for(i in 1 : 20) {
    beta  <- 2*runif(nk-1) - 1
    xbeta <- xx %*% beta + 2 * runif(1) - 1
    xbeta <- (xbeta - min(xbeta)) /
             (max(xbeta) - min(xbeta))
    if(i == 1) {
      plot(x, xbeta, type="l", lty=1,
           xlab=expression(X), ylab='', bty="l")
      title(sub=paste(nk,"knots"), adj=0, cex=.75)
      for(j in 1 : nk)
        arrows(knots[j], .04, knots[j], -.03,
               angle=20, length=.07, lwd=1.5)
    }
    else lines(x, xbeta, col=i)
  }
}

## ----regass2,child='regass.Rnw'-----------------------------------------------

## ----regass,echo=FALSE,cap='Regression assumptions for one binary and one continuous predictor',axes=FALSE----
plot(0:1, 0:1, xlab=expression(X[2]), ylab=expression(C(Y)),
     axes=FALSE,  type='n')
axis(1, at=0:1, labels=rep('',2))
axis(2, at=0:1, labels=rep('',2))
lines(c(.05, .8), c(.05, .5))
lines(c(.05, .8), c(.30, .75))
text(.9, .5, expression(X[1]==0), adj=.5)
text(.9, .75,expression(X[1]==1), adj=.5)

x <- c(0,1,3,5,6)
y <- c(4,3,5.5,5,2)
plot(x, y, type="l", xlab=expression(X), ylab=expression(f(X)), axes=FALSE)
axis(1)
axis(2, labels=FALSE)

require(Hmisc)
x <- rcspline.eval(seq(0,1,.01),
                   knots=seq(.05,.95,length=5), inclx=T)
xm <- x
xm[xm > .0106] <- NA
matplot(x[,1], xm, type="l", ylim=c(0,.01),
        xlab=expression(X), ylab='', lty=1)
matplot(x[,1], x,  type="l",
        xlab=expression(X), ylab='', lty=1)

x <- seq(0, 1, length=300)
for(nk in 3:6) {
  set.seed(nk)
  knots <- seq(.05, .95, length=nk)
  xx <- rcspline.eval(x, knots=knots, inclx=T)
  for(i in 1:(nk-1))
    xx[,i]<-(xx[,i] - min(xx[,i])) /
      (max(xx[,i]) - min(xx[,i]))
  for(i in 1:20) {
    beta  <- 2*runif(nk-1) - 1
    xbeta <- xx%*%beta+2*runif(1) - 1
    xbeta <- (xbeta - min(xbeta)) /
             (max(xbeta) - min(xbeta))
    if(i==1) {
      plot(x, xbeta, type="l", lty=1,
           xlab=expression(X), ylab='', bty="l")
      title(sub=paste(nk,"knots"), adj=0, cex=.75)
      for(j in 1:nk)
        arrows(knots[j], .04, knots[j], -.03,
               angle=20, length=.07, lwd=1.5)
    }
    else lines(x, xbeta, col=i)
  }
}

plot(0:1, 0:1, xlab=expression(X[2]), ylab=expression(C(Y)),
     axes=FALSE,  type='n')
axis(1, at=0:1, labels=rep('',2))
axis(2, at=0:1, labels=rep('',2))
lines(c(.05, .8), c(.05, .5))
lines(c(.05, .8), c(.30, .75))
text(.9, .5, expression(X[1]==0), adj=.5)
text(.9, .75,expression(X[1]==1), adj=.5)


# In the name of GOD

# Importing packages
library(readr) # A cool package for reading files!
library(ggplot2) # Another cool package for plots
library(ggthemes) # Themes of ggplot2
library(dplyr) # A very useful package for data transformation

# Starting with ggplot: point plot
p + geom_point()
p = ggplot(data = mtcars,aes(x = hp, y = disp))
p + geom_point() + theme_dark() # Adding some cool theme!
p + geom_point() + theme_economist() + xlab('Horse Power')+ ylab('Displacement') + ggtitle('Displacement vs Horse Power') # Labels
p + geom_point(size = 4,alpha = 0.1,color = 'blue')
p + geom_point(aes(size = mpg),alpha = 0.6,color = 'blue')
p + geom_point(aes(size = mpg, color = gear),alpha = 0.6)
# What do we understand from these plots?

# Histograms
ggplot(data = mtcars,aes(x = qsec)) + geom_histogram(binwidth = 5,fill = "red",alpha = 0.7) # We can Change Bin Width!

# Changing coordinate!
ggplot(data = mtcars,aes(x = qsec)) + geom_histogram(binwidth = 3,fill = "red",alpha = 0.7) + scale_y_reverse() # We can Change Bin Width!

# Box plot
mtcars$gear = as.factor(mtcars$gear)
ggplot(data = mtcars,aes(x = gear,y = qsec)) + geom_boxplot()

# Reading Data
aqi = read_csv("~/Statistics-98/daily_aqi_by_county_2019.csv")
# Let's explore data!
View(aqi)
summary(aqi)
unique(aqi$`State Name`)
unique(aqi$Category)

# Let's visualize some important apsects of our data.


func1 <- function(x) {

    result <- c()

    for(i in 1:length(x)) {

        result<-append(result, x[i]**i)
    }
    return(result)

}

func2 <- function(x) {

    result <- c()

    for(i in 1:length(x)) {

        result<-append(result, (x[i]**i)/i)
    }
    return(result)

}

func3 <- function(x, n) {

    if(n<=0) {
        return("n must be a positive number")
    }

    result = 1

    for(i in 1:n) {
        result = result + (x**i)/i
    }

    return(result)

}

l = func1(c(2,3,4,5,7,9))

func2(c(4,3,5,2))

func3(3,3)


#Series temporais e analises preditivas - Fernando Amaral
library(forecast)
library(ggplot2)

modelo = auto.arima(co2, trace = T)
print(modelo)

modelo2 = auto.arima(co2, trace = T,stepwise = F, approximation = F )
print(modelo2)

prev1 = forecast(modelo,h=12)
plot(prev1)

prev2 = forecast(modelo2,h=12)
plot(prev2)

print(prev1$mean)
print(prev2$mean)

plot(prev1)
lines(prev2$mean, col="red")

Udemy/Series Temporais e Analises Preditivas/Resources/Codigo/7.5.Auto-Arima.r


require("ggplot2")
require(gridExtra)

tmb <- read.csv("https://raw.githubusercontent.com/climdata/glaser2019/master/csv/d_1000_2019.csv", sep=",")

tmb$rel <- tmb$drought/(tmb$all + 0.00000001)

mp1 <- ggplot() +
  theme_classic(base_size=80) +
  coord_cartesian(ylim=c(0,300)) +
  labs(x="Year", y="n", title="", subtitle="") +
  geom_line(aes(y=tmb$drought, x=tmb$year), color="#0000AA", size=3)

mp2 <- ggplot() +
  theme_classic(base_size=80) +
  labs(x="Year", y="%", subtitle="") +
  geom_line(aes(y=100*tmb$rel, x=tmb$year), color="#0000AA", size=3)

p <- grid.arrange(mp1, mp2, nrow=2)
p


# install.packages("Exact", repos="https://cloud.r-project.org")
library("Exact")

f_obs <- matrix(c(15, 0, 38, 47), nrow=2, ncol=2, byrow=TRUE)
result <- exact.test(f_obs, alternative="two.sided", method="csm", model="Binomial", cond.row=FALSE)
result

f_obs <- matrix(c(16, 13, 37, 34), nrow=2, ncol=2, byrow=TRUE)
result <- exact.test(f_obs, alternative="two.sided", method="csm", model="Binomial", cond.row=FALSE)
result


# Euler/Milstein

r <- 2; K <- 1; beta <- 0.25; Xzero <- 0.5;   # problem parameters
T <- 1; N <- 2^(11); dt <- T/N;               #
M <- 500;                                     # number of paths sampled
R <- c(1, 16, 32, 64, 128);                   # Milstein stepsizes are R*dt

dW <- sqrt(dt)* matrix(runif(M*N),M);
Xmil <- matrix(M, 5);
for(p in 1:5) {
    Dt = R[p]*dt;
    L = N/R[p];
    Xtemp = Xzero*rep(M,1);
    for(j in 1:L) {
        Winc = sum(dW[, seq(R[p]*(j-1)+1, R[p]*(j))]);
        Xtemp = Xzero + Dt*r*Xtemp*(K-Xtemp) + beta*Xtemp*Winc + .5*beta^2*Xtemp*(Winc*Winc - Dt);
    }
    Xmil[,p] <- Xtemp; #store Milstein solution at t=1
}

Xref = Xmil[,1];                             # Reference solution
Xerr = abs(Xmil[,2:5] - repmat(Xref,1,4));   # Error in each path
mean(Xerr);                                  # Mean pathwise errors
Dtvals = dt*R(2:5);                          # Milstein timesteps used

#subplot(224)
plot(Dtvals,
     mean(Xerr),
     log = "xy",
     type = "l");
lines(Dtvals, Dtvals, log = "xy",
#     axis([1e-3 1e-1 1e-4 1],
      xlab = 'dt',
      ylab = 'Sample average of | X(T) - X_L|',
      main = 'milstein')


rmse <- function(error)
{
  sqrt(mean(error * error))
}


pow = function(x,y) x^y
pquick = function(x,chance,lapse,threshold,slope){(
	chance
	+ (
		(1-chance-lapse)
		* (
			1-pow(2,-pow(x/threshold,slope))
		)
	)
)}


estimate_y = function(coeffs, x)
{
	x %*% coeffs[-1] + coeffs[1]
}

estimate_s = function(y, x)
{
	m = nrow(x)
	n = ncol(x)
	coeffs = coefficients(lm(y~x))
	y_estimate = estimate_y(coeffs, x)

	s = sum( (y - y_estimate)^2 ) / (m - n - 1)
	s
}

get_measures = function(y, x, s)
{
	x = as.matrix(x)
	y = as.matrix(y)

	m = nrow(x)
	n = ncol(x)
	coeffs = coefficients(lm(y~x))

	y_estimate = estimate_y(coeffs, x)
	y_mean = mean(y)

	rss = sum( (y - y_estimate)^2 )
	tss = sum( (y - y_mean)^2 )

	r = 1 - rss/tss
	ra = 1 - (1 - r) * ( (m - 1) / (m - n - 1) )
	cp = rss/s - (m - 2*(n+1))

	rbind(rss, r, ra, cp)
}

best_subset = function(y, x)
{
	s = estimate_s(y, x)
	all_preds = 1:ncol(x)

	best_rss = best_r = best_ra = best_cp = c()

	for(pred in all_preds)
	{
		combs = combn(all_preds, pred)
		combs_v = if(ncol(combs) > 1) 2:ncol(combs) else 1

		best_comb_measures = get_measures(y, x[, combs[,1]], s)
		best_rss_comb = best_r_comb = best_ra_comb = best_cp_comb = combs[,1]

		for(comb in combs_v)
		{
			local_measures = get_measures(y, x[, combs[, comb]], s)

			if(local_measures[1] < best_comb_measures[1])
			{
				best_comb_measures[1] = local_measures[1]
				best_rss_comb = combs[, comb]
			}
			if(local_measures[2] > best_comb_measures[2])
			{
				best_comb_measures[2] = local_measures[2]
				best_r_comb =  combs[, comb]
			}
			if(local_measures[3] > best_comb_measures[3])
			{
				best_comb_measures[3] = local_measures[3]
				best_ra_comb = combs[, comb]
			}
			if(abs(local_measures[4] - (pred+1)) < best_comb_measures[4])
			{
				best_comb_measures[4] = abs(local_measures[4] - (pred+1))
				best_cp_comb = combs[, comb]
			}
		}

		best_rss = rbind(best_rss, cbind(best_comb_measures[1], list(best_rss_comb)))
		best_r = rbind(best_r, cbind(best_comb_measures[2], list(best_r_comb)))
		best_ra = rbind(best_ra, cbind(best_comb_measures[3], list(best_ra_comb)))
		best_cp = rbind(best_cp, cbind(best_comb_measures[4], list(best_cp_comb)))
	}

	rbind(list(best_rss), list(best_r), list(best_ra), list(best_cp))
}

plot_data = function(x, y, file_name)
{
	pdf(file=paste0(
			"D:\\Facultate\\",
			"Capitole Speciale de Inteligenta Artificiala\\",
			"homework4\\graphs\\",
			file_name, ".pdf"),
			width=8, height=8)
	plot(x, y, type = "l", lty = 1,
		main=file_name,
		xlab="dimensions",
		ylab=file_name)
	dev.off()
}

plot_and_save = function(data)
{
	xs = 1:nrow(data[[1]])

	plot_data(xs, unlist(data[[1]][,1]), "RSS")
	plot_data(xs, unlist(data[[2]][,1]), "R_Squared")
	plot_data(xs, unlist(data[[3]][,1]), "R_Adj")
	plot_data(xs, unlist(data[[4]][,1]), "Cp")
}

ex1 = function()
{
	data = read.table(
			paste0(
				"D:\\Facultate\\",
				"Capitole Speciale de Inteligenta Artificiala\\",
				"homework4\\data\\house.dat"),
			header=T, sep="", dec=".")
	y = data[,1]
	x = data.matrix(data[,-1])

	data = best_subset(y, x)
	plot_and_save(data)
	data
}


#### Hope Score Project: Using the YRBSS to predict youth suicide ideation
### Risk Score Development: Using Variable Classification SYstems to Build Regression Models and Risk Scores
## CDC Youth Behavioral Risk Surveillance Survey: Code Script by DrewC!

#### Section A: Prepare Code

### Step 1: Import Libraries and Import Dataset

## Open R Terminal
R # open R in VS Code (any terminal)

## Import Hadley Wickham Libraries
library(tidyverse) # All of the libraries above in one line of code
library(skimr) # Library used for easy summary of data

## Import Machine Learning Libraries
library(randomForest) # Popular random forest package for R

## Import Statistics Libraries
library(MASS) # Stepwise inclusion model with linear and logistic options
library(pROC) # ROC tests with AUC output
library(psych) # Survey analysis library with factor analysis
library(GPArotation) # Rotation options for factor analysis

## Import Data
setwd("C:/Users/drewc/GitHub/HNB") # Set wd to project repository
df_nhanes = read.csv("_data/nhanes_1516_noRX_stage.csv") # Import dataset from _data folder

## Verify
dim(df_nhanes)

### Step 2: Prepare Data for Classificaiton

## Subset for outcome of interest
df_nhanes$outcome <- 0 # Add new outcome column and set value to 0
df_nhanes$outcome[df_nhanes$LBXGH >= 5.7 & df_nhanes$LBXGH < 6.4] <- 1 # Create new column based on conditions
df_nhanes = subset(df_nhanes, select = -c(SEQN, LBXGH, DIQ010))

## Verify
head(df_nhanes$outcome)

## Resolve missing data
df_na = df_nhanes
df_na = df_na[-which(rowSums(is.na(df_na)) > 1089),] # Remove variables with high missing values
df_na = df_na[, -which(colSums(is.na(df_na)) > 3034)] # Remove variables with high missing values
df_na = df_na[-which(rowSums(is.na(df_na)) > 195),] # Remove variables with high missing values
df_na = df_na[, -which(colSums(is.na(df_na)) > 146)] # Remove variables with high missing values
df_na = subset(df_na, select = -c(AUATYMTL, SLQ300, SLQ310, AUATYMTR)) # Remove variables with factor value types
df_na = na.omit(df_na) # Omit rows with NA from Data Frame

## Name reduction data neville
df_nev = df_na

## Verify
dim(df_na)
colnames(df_na)
median(rowSums(is.na(df_na)))
median(colSums(is.na(df_na)))

#### Section B: Vairable Selection using Quantitative and Qualitative Methods

### Step 3: Conduct Factor Analysis to Identify Latent Variables

## Subset by group with outcome
df_fa = subset(df_na, outcome == 1) # Subset for outcome of interest
df_fa = subset(df_fa, select = -(outcome)) # Remove outcome variable
df_fa = na.omit(df_fa)
nrow(df_fa) # Check number of rows

## Perform Scree test and loadings
cor_fa = cor(df_fa)
cor_fa[!is.finite(cor_fa)] <- 0
model_scree = fa.parallel(cor_fa) # Create scree plot to determine number of latent variables
print(model_scree)

## Write Scree Test Output to File
result = model_scree # Save result df to variable
file = file("neville/neville_nhanes_dm2_results.txt") # Open result file in subproject repository
open(file, "w") # Open file and "a" to append
write("Factor Analysis",  file) # Insert title
write(" ", file) # Insert space below title
write("Eigenvalues from Scree Test",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

## Idenitfy Loadings
factors = fa(r = cor_fa, nfactors = 6)
df_load = as.data.frame(unclass(factors$loadings))
colMax <- function(data) sapply(data, max, na.rm = TRUE)

colMax(df_load)

## Identify Vairbles with Loadings over 0.5
df_ld = df_load
df_ld$factor1[df_ld$MR1 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor2[df_ld$MR2 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor3[df_ld$MR3 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor4[df_ld$MR4 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor5[df_ld$MR5 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor6[df_ld$MR6 > 0.5] <- 1 # Create new column based on conditions
df_ld = subset(df_ld, select = -c(MR1, MR2, MR3, MR4, MR5, MR6))

df_f1 = subset(df_ld, factor1 == 1) # Subset for outcome of interest
df_f1 = df_f1["factor1"]
df_f2 = subset(df_ld, factor2 == 1) # Subset for outcome of interest
df_f2 = df_f2["factor2"]
df_f3 = subset(df_ld, factor3 == 1) # Subset for outcome of
df_f3 = df_f3["factor3"]
df_f4 = subset(df_ld, factor4 == 1) # Subset for outcome of interest
df_f4 = df_f4["factor4"]
df_f5 = subset(df_ld, factor5 == 1) # Subset for outcome of interest
df_f5 = df_f5["factor5"]
df_f6 = subset(df_ld, factor6 == 1) # Subset for outcome of interest
df_f6 = df_f6["factor6"]

## Write Scree Test Output to File
file = file("neville/neville_nhanes_dm2_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Factor Loadings",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(df_f1, file = file, append = TRUE) # write summary to file
capture.output(df_f2, file = file, append = TRUE) # write summary to file
capture.output(df_f3, file = file, append = TRUE) # write summary to file
capture.output(df_f4, file = file, append = TRUE) # write summary to file
capture.output(df_f5, file = file, append = TRUE) # write summary to file
capture.output(df_f6, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

### Step 4: Use a Random Forest to rank variables by importance

## Create a Random Forest
df_rf = df_nev
forest = randomForest(formula = outcome ~ ., data = df_rf, ntree = 1000, importance = TRUE) # This will take time
summary(forest) # Summary of forest model

## Tidy Results for Variable Classification
mat_forest = round(importance(forest), 2) # Round importance outcomes to two places,
df_forest = as.data.frame(mat_forest) # Save as data frame
df_forest = rownames_to_column(df_forest)
colnames(df_forest) <- c("Variable", "MSE", "Gini") # Change column names to easily readible. Both values correspond to the summed increse in either Mean Squared Error or Gini as the variable is removed. Both are important and used elsewhere in randomforests (Scikit-learn).

## Create Importance Variable Lists
df_rank = arrange(df_forest, desc(Gini)) # Descend by variable in data frame
print(df_rank) # Print output

## Write Random Forest Output to File
result = print(df_rank) # Save result df to variable
file = file("neville/neville_nhanes_dm2_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "w" to overwrite
write("Random Forest Variable Classification", file) # Insert title
write(" ", file) # Insert space below title
write.table(result, file, quote = FALSE, sep = "   ") # write table of values to filee
write(" ", file) # Insert space below result
close(file) # Close file

### Summary Statistics of Model Variables
file = file("neville/neville_nhanes_pdm_fa_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "w" to overwrite
write("Summary of Model Variables", file) # Insert title
write(" ", file) # Insert space below result
write("BMXSAD1", file) # Insert space below title
capture.output(summary(df_nev$BMXSAD1), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("BPXSY1", file) # Insert space below title
capture.output(summary(df_nev$BPXSY1), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("LBXNEPCT", file) # Insert space below title
capture.output(summary(df_nev$LBXNEPCT), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("URDACT", file) # Insert space below title
capture.output(summary(df_nev$URDACT), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("HSQ510", file) # Insert space below title
capture.output(summary(df_nev$HSQ510), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("LBXSF3SI", file) # Insert space below title
capture.output(summary(df_nev$LBXSF3SI), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("CBD071", file) # Insert space below title
capture.output(summary(df_nev$CBD071), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("OHARNF", file) # Insert space below title
capture.output(summary(df_nev$OHARNF), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

#### Section C: Build Regression Model and Risk Score for Validation

### Step 5: Create Dichotomous Variables Based on 3rd Quartile

## Create New Variables
df_nh$SAD <- 0 # Add new outcome column and set value to 0
df_nh$SYS <- 0 # Add new outcome column and set value to 0
df_nh$NEU <- 0 # Add new outcome column and set value to 0
df_nh$ACR <- 0 # Add new outcome column and set value to 0
df_nh$STO <- 0 # Add new outcome column and set value to 0
df_nh$FOL <- 0 # Add new outcome column and set value to 0
df_nh$GRO <- 0 # Add new outcome column and set value to 0
df_nh$ORL <- 0 # Add new outcome column and set value to 0
df_nh$SAD[df_nh$BMXSAD1 > 25.6] <- 1 # Create new column based on conditions
df_nh$SYS[df_nh$BPXSY1 > 130] <- 1 # Create new column based on conditions
df_nh$NEU[df_nh$LBXNEPCT > 50.95] <- 1 # Create new column based on conditions
df_nh$ACR[df_nh$URDACT > 4.64] <- 1 # Create new column based on conditions
df_nh$STO[df_nh$HSQ510 == 1] <- 1 # Create new column based on conditions
df_nh$FOL[df_nh$LBXSF3SI > 0.1410] <- 1 # Create new column based on conditions
df_nh$GRO[df_nh$CBD071 > 526] <- 1 # Create new column based on conditions
df_nh$ORL[df_nh$OHARNF != 0] <- 1 # Create new column based on conditions

## Resolve missing data
df_lon = subset(df_nh, select = c(outcome, SAD, SYS, NEU, ACR, STO, FOL, GRO, ORL)) # Remove variables with factor value types
df_lon = na.omit(df_lon) # Omit rows with NA from Data Frame
dim(df_lon)

### Step 6: Logistic Regression with Stepwise Selection for Final Model

## Create training and validation set
sample = sample.int(n = nrow(df_lon), size = floor(.50*nrow(df_lon)), replace = F) # Create training and testing dataset with 50% split
train = df_lon[sample, ] # Susbset data frame by sample
test = df_lon[-sample, ] # Subset data frame by removing sample

## Perform Logisitc Regression on selected variables
model_logistic = glm(outcome ~ SAD + SYS + NEU + ACR + STO + FOL + GRO + ORL, data = train)
summary(model_logistic)

## Stepwise backward selection
model_back = stepAIC(model_logistic, direction = "backward") # Stepwise backwards selection on model
summary(model_back) # Output model summary and check for variables to remove for final model

## Write Quantitative Selection Model Output to File
result1 = print(summary(model_logistic)) # Save result df to variable
result2 = print(summary(model_back)) # Save result df to variable
file = file("neville/neville_nhanes_pdm_fa_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Logistic Regression Model", file) # Insert space below title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below title
write("Stepwise Backwards Selection", file) # Insert space below title
write(" ", file) # Insert space below title
capture.output(result2, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below title
close(file) # Close file

### Step 7: Create Score and Verify

# Create new column based on conditions
test$score <- 0 # Add new outcome column and set value to 0
test$score = (11*test$SAD) + (13*test$SYS) + (6*test$NEU) + (2*test$ACR) + (2*test$GRO) + (2*test$ORL)
df_nh$score <- 0
df_nh$score = (11*df_nh$SAD) + (13*df_nh$SYS) + (6*df_nh$NEU) + (2*df_nh$ACR) + (2*df_nh$GRO) + (2*df_nh$ORL)

## Final Model and AUC Score
model_score = glm(outcome~ score, data = test) # Perform logistic regression model on selected variables on test data
roc_test = roc(model_score$y, model_score$fitted.values, ci = T, plot = T) # Perform ROC test on test data
auc(roc_test) # Print AUC score

## Write Quantitative Selection Model Output to File
result = print(auc(roc_test)) # Save result df to variable
file = file("neville/neville_nhanes_pdm_fa_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Risk Score Validation", file) # Insert space below title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below title
close(file) # Close file

### Step 9: Create Score with Simple Values and Non-Lab Tests

## Create New Variables
df_nh$SAD <- 0 # Add new outcome column and set value to 0
df_nh$SYS <- 0 # Add new outcome column and set value to 0
df_nh$STO <- 0 # Add new outcome column and set value to 0
df_nh$GRO <- 0 # Add new outcome column and set value to 0
df_nh$ORL <- 0 # Add new outcome column and set value to 0
df_nh$SAD[df_nh$BMXSAD1 > 25.6] <- 1 # Create new column based on conditions
df_nh$SYS[df_nh$BPXSY1 > 130] <- 1 # Create new column based on conditions
df_nh$STO[df_nh$HSQ510 != 1] <- 1 # Create new column based on conditions
df_nh$GRO[df_nh$CBD071 < 500] <- 1 # Create new column based on conditions
df_nh$ORL[df_nh$OHARNF != 1] <- 1 # Create new column based on conditions

## Resolve missing data
df_lon = subset(df_nh, select = c(outcome, SAD, SYS, STO, GRO, ORL)) # Remove variables with factor value types
df_lon = na.omit(df_lon) # Omit rows with NA from Data Frame
dim(df_lon)

## Create training and validation set
sample = sample.int(n = nrow(df_lon), size = floor(.50*nrow(df_lon)), replace = F) # Create training and testing dataset with 50% split
train = df_lon[sample, ] # Susbset data frame by sample
test = df_lon[-sample, ] # Subset data frame by removing sample

## Perform Logisitc Regression on selected variables
model_logistic2 = glm(outcome ~ SAD + SYS + STO + GRO + ORL, data = train)
summary(model_logistic2)

# Create new column based on conditions
test$score <- 0 # Add new outcome column and set value to 0
test$score = (13*test$SAD) + (14*test$SYS) + (5*test$STO) + (3*test$GRO) + (2*test$ORL)
df_nh$score <- 0
df_nh$score = (13*df_nh$SAD) + (14*df_nh$SYS) + (5*df_nh$STO) + (3*df_nh$GRO) + (29*df_nh$ORL)

## Resolve missing data
df_lon = subset(df_nh, select = c(outcome, SAD, SYS, STO, GRO, ORL)) # Remove variables with factor value types
df_lon = na.omit(df_lon) # Omit rows with NA from Data Frame
dim(df_lon)

## Final Model and AUC Score
model_score = glm(outcome~ score, data = test) # Perform logistic regression model on selected variables on test data
roc_test = roc(model_score$y, model_score$fitted.values, ci = T, plot = T) # Perform ROC test on test data
auc(roc_test) # Print AUC score


##################################################################################################
## Make regressioin subsample null distributions
##################################################################################################

setwd("/Users/ChatNoir/Projects/Squam/scripts_ch1/Graphing/DataFiles")
load("Calcs_Smoosh2021.RData")

# remove all but full dataset
rm(list=setdiff(ls(), "all"))

##################################################################################################
## Test correlation across all hypotheses
##################################################################################################
# http://www.sthda.com/english/wiki/correlation-test-between-two-variables-in-r
# https://rpubs.com/aaronsc32/spearman-rank-correlation
library(plyr)
library(dplyr)
library(ggplot2)
library(tidyr)
library(ggpubr)
library(stats)
library(tibble)
library(reshape)
library(xlsx)
emptyFrame <- function(h,s){
  c.d <- data.frame("test"=c("emp.spearman","emp.pearson"),
                          "sample"=c(s,s),
                          "hypothesis"=c(h,h),
                          "Correlation"=c(NA,NA),
                          "emp"=c(NA,NA),
                          "p0.975"=c(NA,NA),
                          "p0.95"=c(NA,NA),
                          "p0.05"=c(NA,NA),
                          "p0.025"=c(NA,NA))
  return(c.d)
}

corTest <- function(d,h,s){

  # Create two datasets, one to add permutation columns to, one to pull from. because that's how I coded it?
  a <- d %>% filter(variable == h)
  perms <- d %>% filter(variable == h)
  nloci <- length(a$Locus)
  maxB <- max(a$BF)
  minB <- min(a$BF)
  maxG <- max(a$GL)
  minG <- min(a$GL)
  #print(length(a$Locus))

  # Safety check for if a subset of data has too few observations
  if(length(a$Locus) < 5){
    c.d <- emptyFrame(h,s)
    return(c.d)
  }

  # Define which column numbers to test for correlation

  b <- match('BF',names(a))
  g <- match('GL',names(a))

  # Permute BF values in 1,000 separate columns, could permute BF or GL doesnt matter.

  for (n in 1:1000) {
    newcolname1 <- paste('BF',n,sep='')
    perms[, newcolname1] <- sample(a[[b]], replace = FALSE)
    #newcolname2 <- paste('GL',n,sep='')
    #null[, newcolname2] <- sample(a[[g]], replace = FALSE)
  }

  # Create new dataset to add null rank coefficients to

  assign('null', setNames(data.frame(1:1000), "replicate"))

  # Add bf gl

  for (n in 1:1000) {

    # Grab column names, calculate value
    colname1 <- paste('BF',n,sep='')
    cc1.s <- cor(perms[,'GL'],perms[,colname1],method="spearman")
    null[n,'null.spearman'] <- cc1.s
  }

  # Dataframe for emp scores
  emp <- data.frame(TestType=character(),
                    corr.eff=integer(),
                    p=integer(),
                    p0.975=integer(),
                    p0.95=integer(),
                    p0.05=integer(),
                    p0.025=integer(),stringsAsFactors=FALSE)

  # Designate which row is for which test

  emp[1,'TestType'] <- 'emp.spearman'

  # Calculate correlation stats from emperical data,  add to df

  e.s <- cor(a[[b]],a[[g]],method="spearman")

  emp[1,'corr.eff'] <- e.s

  # Calculate 2 sided p values

  p.s <- sum(abs(null$null.spearman) >= abs(e.s)) / length(null$null.spearman)

  emp[1,'p'] <- p.s

  # Add rows for quantile cut offs

  emp[1,'p0.025'] <- quantile(null$null.spearman, c(0.025, 0.975),na.rm = TRUE)[[1]]
  emp[1,'p0.975'] <- quantile(null$null.spearman, c(0.025, 0.975),na.rm = TRUE)[[2]]
  emp[1,'p0.05'] <- quantile(null$null.spearman, c(0.05, 0.95),na.rm = TRUE)[[1]]
  emp[1,'p0.95'] <- quantile(null$null.spearman, c(0.05, 0.95),na.rm = TRUE)[[2]]

  # Add significance yes/no and other data

  corr.data <- emp %>%
    mutate_if(is.numeric,round,2) %>%
    add_column(Hypothesis = h, .after = "TestType") %>%
    add_column(Sample = s, .after = "TestType") %>%
    add_column(Loci = nloci, .after = "p") %>%
    add_column(minG = minG, .after = "Loci")%>%
    add_column(maxG = maxG, .after = "Loci")%>%
    add_column(minB = minB, .after = "Loci")%>%
    add_column(maxB = maxB, .after = "Loci")

  return(corr.data)
}

##################################################################################################
## Subsample
##################################################################################################

all <- all %>% filter(dataSet == "Burbrink")

# full dataset numbers

tvsx <- corTest(all,"TvS","all")
aivsax <- corTest(all,"AIvSA","all")
aivsix <- corTest(all,"AIvSI","all")
savsix <- corTest(all,"SAvSI","all")

m = lm(all$GL ~ all$BF)

names(summary(m))

#to get the p value for the t test
summary(m)$coefficients[,4][2]

results <- bind_rows(tvsx,aivsax,aivsix,savsix) %>% filter(TestType == "emp.spearman")

r <- results

# run this x number of times
reps = 1000

# subsample number and make sure variables are grouped
all <- all %>% group_by(variable)
sn = "150" # the name for the subsample - make sure to edit how many go into the subsample
print(sn)
for (n in 1:reps) {
  sb <- sample_n(all, 150)
  tvs <- corTest(sb,"TvS",sn)
  aivsa <- corTest(sb,"AIvSA",sn)
  aivsi <- corTest(sb,"AIvSI",sn)
  savsi <- corTest(sb,"SAvSI",sn)
  results <- bind_rows(results,tvs,aivsa,aivsi,savsi) %>% filter(TestType == "emp.spearman")
  print(n)
}

save(results,file="corsubsampleBurbrink")

all <- all %>% group_by(variable)
sn = "200"
print(sn)
for (n in 1:reps) {
  sb <- sample_n(all, 200)
  tvs <- corTest(sb,"TvS",sn)
  aivsa <- corTest(sb,"AIvSA",sn)
  aivsi <- corTest(sb,"AIvSI",sn)
  savsi <- corTest(sb,"SAvSI",sn)
  results <- bind_rows(results,tvs,aivsa,aivsi,savsi) %>% filter(TestType == "emp.spearman")
  print(n)
}

save(results,file="corsubsampleBurbrink")

all <- all %>% group_by(variable)
sn = "100"
print(sn)
for (n in 1:reps) {
  sb <- sample_n(all, 100)
  tvs <- corTest(sb,"TvS",sn)
  aivsa <- corTest(sb,"AIvSA",sn)
  aivsi <- corTest(sb,"AIvSI",sn)
  savsi <- corTest(sb,"SAvSI",sn)
  results <- bind_rows(results,tvs,aivsa,aivsi,savsi) %>% filter(TestType == "emp.spearman")
  print(n)
}

save(results,file="corsubsampleBurbrink")

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

all <- all %>% filter(dataSet == "Reeder")

# full dataset numbers

tvsx <- corTest(all,"TvS","all")
aivsax <- corTest(all,"AIvSA","all")
aivsix <- corTest(all,"AIvSI","all")
savsix <- corTest(all,"SAvSI","all")
results <- bind_rows(tvsx,aivsax,aivsix,savsix) %>% filter(TestType == "emp.spearman")

r <- results

# run this x number of times
reps = 1000

# subsample number and make sure variables are grouped
all <- all %>% group_by(variable)
sn = "30" # the name for the subsample - make sure to edit how many go into the subsample
print(sn)
for (n in 1:reps) {
  sb <- sample_n(all, 30)
  tvs <- corTest(sb,"TvS",sn)
  aivsa <- corTest(sb,"AIvSA",sn)
  aivsi <- corTest(sb,"AIvSI",sn)
  savsi <- corTest(sb,"SAvSI",sn)
  results <- bind_rows(results,tvs,aivsa,aivsi,savsi) %>% filter(TestType == "emp.spearman")
  print(n)
}

save(results,file="corsubsampleReeder")

all <- all %>% group_by(variable)
sn = "25"
print(sn)
for (n in 1:reps) {
  sb <- sample_n(all, 25)
  tvs <- corTest(sb,"TvS",sn)
  aivsa <- corTest(sb,"AIvSA",sn)
  aivsi <- corTest(sb,"AIvSI",sn)
  savsi <- corTest(sb,"SAvSI",sn)
  results <- bind_rows(results,tvs,aivsa,aivsi,savsi) %>% filter(TestType == "emp.spearman")
  print(n)
}

save(results,file="corsubsampleReeder")

all <- all %>% group_by(variable)
sn = "35"
print(sn)
for (n in 1:reps) {
  sb <- sample_n(all, 35)
  tvs <- corTest(sb,"TvS",sn)
  aivsa <- corTest(sb,"AIvSA",sn)
  aivsi <- corTest(sb,"AIvSI",sn)
  savsi <- corTest(sb,"SAvSI",sn)
  results <- bind_rows(results,tvs,aivsa,aivsi,savsi) %>% filter(TestType == "emp.spearman")
  print(n)
}

save(results,file="corsubsampleReeder")

##################################################################################################
## Graph
##################################################################################################
rm(list=ls())

mytheme <- theme_bw() + theme(panel.border = element_blank()) +
  theme_classic() +
  theme(
    axis.text = element_text(size=12, color="black"),
    text = element_text(size=14),
    panel.border = element_blank(),
    panel.background = element_rect(fill = "transparent"), # bg of the panel
    plot.background = element_rect(fill = "transparent", color = NA), # bg of the plot
    panel.grid = element_blank(), # get rid of major grid
    plot.title = element_text(hjust = 0.5),
    axis.title.x=element_blank(),
    axis.title.y=element_blank(),
    legend.background = element_rect(colour = "transparent",fill = "transparent"))

library("readxl")
library(dplyr)
library(ggplot2)
library("viridis")

setwd("/Users/ChatNoir/Projects/Squam/scripts_ch1/Graphing/DataFiles")
load("corsubsample")
setwd("/Users/chatnoir/Projects/Squam/Graphs/")
empvals <- read_excel("/Users/chatnoir/Projects/Squam/Graphs/Tables/AllSchmoosh.xlsx")

all <- bind_rows(results,empvals) %>% filter(Sample != "50l") %>% filter(Sample != "50h") %>%
  mutate(Sample=factor(Sample, levels=c("100","500","1k","2k","3k","4k","sig50m","sig60m","sig80m","sig0x","sig1x","sig2x","all")))

tvs <- all %>% filter(Hypothesis == "TvS")

df <- all %>% filter(Hypothesis == "AIvSA")

#df <- all

x.tic <- seq(-lowerx,upperx,ticx)
y.tic <- seq(-lowery,uppery,ticy)
#x.tic <- c(-lowerx,upperx,ticx)
#y.tic <- c(-lowery,uppery,ticy)

scat <- ggplot(df, aes(x=Loci,y=corr.eff)) +
  geom_point(alpha=0.75,aes(color=as.factor(Sample))) + mytheme

scat

scat <- ggplot(df, aes(x=Loci,y=corr.eff)) +
  geom_point(alpha=0.5,aes(color=p)) +
  scale_color_viridis(direction = -1,option='D') + mytheme

scat

   +
  scale_color_viridis(direction = -1,option='D')
  #coord_cartesian(ylim=y.tic,xlim = x.tic) +
  #scale_y_continuous(breaks = y.tic) +
  #scale_x_continuous(breaks = x.tic) +
  #labs(x="dGLS",y="ln(BF)", color="Metric Disagreement") +
  #scale_color_manual(values=cc)
#quartz()
scat


library(MASS)
# /////////////////////////////////////////

generate_parcoord_plot_with_costs<- function(points_dataframe, fraction_of_maxforce_for_task, my_column_names, fmax_vector){
  points_with_costs <- fill_costs(points_dataframe, 7, fmax_vector)
  points_with_costs$TaskForce <- rep(fraction_of_maxforce_for_task, length(points_with_costs[,1]))
  colnames(points_with_costs) <- my_column_names

  # parcoord(points_with_costs, var.label=TRUE, ylim=c(0,1))

  nonweighted_max_observed_cost <- max(points_with_costs$L1)
  weighted_max_observed_cost <- max(points_with_costs$L1W)

  #unweighted
  points_with_costs$L1 <- points_with_costs$L1 / nonweighted_max_observed_cost
  points_with_costs$L2 <- points_with_costs$L2 / nonweighted_max_observed_cost
  #weighted
  points_with_costs$L1W <- points_with_costs$L1W / weighted_max_observed_cost
  points_with_costs$L2W <- points_with_costs$L2W / weighted_max_observed_cost

  require(GGally)
  require(ggplot2)
  p_raw <- ggparcoord(points_with_costs, scale='globalminmax', alpha=0.025, boxplot=FALSE, mapping=ggplot2::aes(colour="midnightblue"))
  p <- p_raw + theme_bw() + theme(
    panel.grid.major.x = element_line(color = "black", size = 0.5),
    panel.grid.major = element_blank(),
    legend.position = "none"
) + geom_hline(yintercept=seq(0, 1, by=0.2))
  return(p)
}

# fills raw cost columns (14-19 for finger)
# section 3 of dataframe
fill_costs = function(df,m, fmax_vector) {
  F0 = matrix(fmax_vector,dim(df)[1],m,byrow=TRUE)
  # L1
  df[,(m+1)] = rowSums(df[,1:m])
  # L2
  df[,(m+2)] = (rowSums(df[,1:m]^2))^(1/2)
  # Lw1
  df[,(m+3)] = rowSums(df[,1:m]*F0)
  # Lw2
  df[,(m+4)] = (rowSums((df[,1:m]*F0)^2))^(1/2)

  return(df)

}

frac_of_indexfinger_max <- function(task_force_newtons) {
  fraction_of_maxforce_for_task <- task_force_newtons/28.81155463796023
  return(fraction_of_maxforce_for_task)
}

my_column_names <- c("FDP",
                    "FDS",
                    "EIP",
                    "EDC",
                    "LUM",
                    "DI",
                    "PI",
                    "L1",
                    "L2",
                    "L1W",
                    "L2W",
                    "TaskForce")

fmax_vector=c(123, 219, 124.8, 129.6, 23.52, 21.6, 91.74) #newtons each muscle is maximally capable of producing.
#tasks chosen: c(0,.2,.4,.6,.8,.1)*28.811554635079077
points_a <- read.csv("n_1000_alphalen_1000/finger_forcevector_0.0_1484767835427.csv", header=FALSE)
points_b <- read.csv("n_1000_alphalen_1000/finger_forcevector_5.768079006021837_1484784224782.csv", header=FALSE)
points_c <- read.csv("n_1000_alphalen_1000/finger_forcevector_11.507317617013564_1484878583772.csv", header=FALSE)
points_d <- read.csv("n_1000_alphalen_1000/finger_forcevector_17.275396623035405_1484881413230.csv", header=FALSE)
points_e <- read.csv("n_1000_alphalen_1000/finger_forcevector_23.04347562905724_1484876827322.csv", header=FALSE)
points_f <- read.csv("n_1000_alphalen_1000/finger_forcevector_28.811554635079077_1484891275183.csv", header=FALSE)

plot_a <- generate_parcoord_plot_with_costs(points_a, frac_of_indexfinger_max(0.0), my_column_names, fmax_vector)
plot_b <- generate_parcoord_plot_with_costs(points_b, frac_of_indexfinger_max(5.768079006021837), my_column_names, fmax_vector)
plot_c <- generate_parcoord_plot_with_costs(points_c, frac_of_indexfinger_max(11.507317617013564), my_column_names, fmax_vector)
plot_d <- generate_parcoord_plot_with_costs(points_d, frac_of_indexfinger_max(17.275396623035405), my_column_names, fmax_vector)
plot_e <- generate_parcoord_plot_with_costs(points_e, frac_of_indexfinger_max(23.04347562905724), my_column_names, fmax_vector)
plot_f <- generate_parcoord_plot_with_costs(points_f, frac_of_indexfinger_max(28.811554635079077), my_column_names, fmax_vector)

require(gridExtra)
  combined_figure <- grid.arrange(
                  plot_a,
                  plot_b,
                  plot_c,
                  plot_d,
                  plot_e,
                  plot_f,
                  ncol=1)

ggsave("figure_5_parcoord.pdf", combined_figure, width=8, height=10)


# Program make a simple calculator that can add, subtract, multiply and divide using functions
add <- function(x, y) {
return(x + y)
}
subtract <- function(x, y) {
return(x - y)
}
multiply <- function(x, y) {
return(x * y)
}
divide <- function(x, y) {
return(x / y)
}
# take input from the user
print("Select operation.")
print("1.Add")
print("2.Subtract")
print("3.Multiply")
print("4.Divide")
choice = as.integer(readline(prompt="Enter choice[1/2/3/4]: "))
num1 = as.integer(readline(prompt="Enter first number: "))
num2 = as.integer(readline(prompt="Enter second number: "))
operator <- switch(choice,"+","-","*","/")
result <- switch(choice, add(num1, num2), subtract(num1, num2), multiply(num1, num2), divide(num1, num2))
print(paste(num1, operator, num2, "=", result))