#### 13-2 ####

## -------------------------------------------------------------------- ##
mpg <- as.data.frame(ggplot2::mpg)

library(dplyr)
mpg_diff <- mpg %>%
  select(class, cty) %>%
  filter(class %in% c("compact", "suv"))

head(mpg_diff)
table(mpg_diff$class)

t.test(data = mpg_diff, cty ~ class, var.equal = T)

## -------------------------------------------------------------------- ##
mpg_diff2 <- mpg %>%
  select(fl, cty) %>%
  filter(fl %in% c("r", "p"))  # r:regular, p:premium

table(mpg_diff2$fl)

t.test(data = mpg_diff2, cty ~ fl, var.equal = T)

#### 13-3 ####

## -------------------------------------------------------------------- ##
economics <- as.data.frame(ggplot2::economics)
cor.test(economics$unemploy, economics$pce)

## -------------------------------------------------------------------- ##
head(mtcars)
car_cor <- cor(mtcars)  # 상관행렬 생성
round(car_cor, 2)       # 소수점 셋째 자리에서 반올림해서 출력

install.packages("corrplot")
library(corrplot)

corrplot(car_cor)

corrplot(car_cor, method = "number")

col <- colorRampPalette(c("#BB4444", "#EE9988", "#FFFFFF", "#77AADD", "#4477AA"))

corrplot(car_cor,
         method = "color",       # 색깔로 표현
         col = col(200),         # 색상 200개 선정
         type = "lower",         # 왼쪽 아래 행렬만 표시
         order = "hclust",       # 유사한 상관계수끼리 군집화
         addCoef.col = "black",  # 상관계수 색깔
         tl.col = "black",       # 변수명 색깔
         tl.srt = 45,            # 변수명 45도 기울임
         diag = F)               # 대각 행렬 제외


library(ggplot2)
args <- commandArgs(trailingOnly = TRUE)
fn <- args[1]
d <- read.csv(paste0(fn))

d$n <- gsub('(\\d)/\\d\\.\\d.*','\\1', d$Name)
d$p <- gsub('\\d/(\\d\\.\\d).*','\\1', d$Name)

d$n <- as.numeric(d$n)

pdf(width=8, height=5,
    file=paste0(gsub('.csv', '', fn), '.pdf'))
ggplot(data=d, aes(x=n, colour=p, group=p)) +
    geom_line(aes(y=Mean*1000)) +
    geom_line(aes(y=MeanLB*1000)) +
    geom_line(aes(y=MeanUB*1000)) +
    geom_ribbon(aes(
        ymin=(Mean-1.96*Stddev)*1000,
        ymax=(Mean+1.96*Stddev)*1000),
        alpha=0.3)+
    xlab('Size of square matrix') +
    ylab('Mean, micro seconds')
dev.off()


rm(list=ls())
setwd("C:/Users/ABISEK/Downloads/kk")
dataset0=read.csv("test.csv",header=T)
dataset=dataset0[1:5]
library("factoextra")
library(cluster)
df=dataset
print(df)
df=dataset[4:5]
print(df)
head(df, n = 3)
pam(x, k, metric = "euclidean", stand = FALSE)

pam.res <- pam(df, 3)
print(pam.res)
dd <- cbind(df, cluster = pam.res$cluster)
head(dd, n = 3)
pam.res$medoids
head(pam.res$clustering)
fviz_cluster(pam.res, geom = "point", ellipse.type = "norm")


#getwd()
library(dplyr)

par(mfrow = c(1, 1))

# Načtení dat z xlsx souboru
data_xlsx = readxl::read_excel("./1S/ukol_123.xlsx",
                  sheet = "Vysledky mereni",
                  skip = 0)

data_xlsx = data_xlsx[,-1] # odstraníme první sloupec s indexy
colnames(data_xlsx)=c("A22","A5","B22","B5","C22","C5","D22","D5")
head(data_xlsx)

data=reshape(data=as.data.frame(data_xlsx),
                  direction="long",
                  varying=list(c("A5", "B5", "C5", "D5"),
                               c("A22","B22","C22","D22")),
                  v.names=c("C5","C22"),
                  times=c("Amber","Bright","Clear","Dim"),
                  timevar="vyrobce")
row.names(data) = 1:nrow(data)
data = data[-length(data)]
data = na.omit(data)

head(data)
tail(data)

# A) boxpolt a odstranění OP + histogramy a qq
boxplot(data$C5 ~ data$vyrobce, xlab="", ylab="světelný tok (lm)", main="Boxploty světelnosti při 5°C, podle výrobce")

data = data %>% group_by(vyrobce) %>% mutate(C5_bezOP = C5 %in% boxplot(C5, plot = FALSE)$out)
OP = data %>% filter(C5_bezOP == TRUE)
data = data %>% mutate(C5_bezOP = ifelse(C5_bezOP, NA, C5))
data %>% print(n=40)

# směr. odchylka zaokrouhluji nahoru, 3 platné cifry pro <30;2000>
# při zaokrouhlování nezapomenout přidat nuly, pokud je potřeba
zaokr = data %>% group_by(vyrobce) %>%
    summarise  (pocet = sum(!is.na(C5_bezOP)),
                prumer = round(mean(C5_bezOP, na.rm = TRUE),0),
                smer.odch = ceiling(sd(C5_bezOP, na.rm = TRUE)*10)/10) %>% print.data.frame()
colnames(zaokr) = c('Výrobce','Počet záznamů','Průměr','Směrodatná odchylka')
zaokr %>% print.data.frame()

xvalues= c(720,880)
yvalues= c(0,16)
breaks=seq(min(data$C5_bezOP,na.rm=TRUE),max(data$C5_bezOP,na.rm=TRUE),length.out=16)

par(mfrow = c(4, 2))

data %>% group_by(vyrobce) %>% group_walk(~{
    hist(.x$C5_bezOP, xlim=xvalues, ylim=yvalues, breaks=breaks,
        xlab="Lumeny", ylab="Četnost", main=paste0('Histogram světelnosti při 5°C, výrobce ',.y$vyrobce))
    qqnorm(.x$C5_bezOP, xlab="Teoretické kvantily", ylab="Výběrové kvantily", main=paste0('Q-Q graf světelnosti při 5°C (lm), výrobce ',.y$vyrobce))
    qqline(.x$C5_bezOP)
    })

# B) Normalita a symetrie
# šikmost a špičatost zaokrouhlovat na 1 desetinu
# p-hodnoty na o jednu větší cifru než 0.05 - tisíciny
normSymet = data %>% group_by(vyrobce) %>%
    summarise(  sikmost=round(moments::skewness(C5_bezOP, na.rm=TRUE),1),
                spicatost=round(moments::kurtosis(C5_bezOP, na.rm=TRUE)-3,1),
                SW=round(shapiro.test(C5_bezOP)$p.value,3),
                symetrie=round(lawstat::symmetry.test(C5_bezOP, boot=FALSE)$p.value,3))
colnames(normSymet) = c('Výrobce','Šikmost','Špičatost','Shapirův-Wilkův test (p-hodnota)','Test symetrie (p-hodnota)')
normSymet %>% print.data.frame()
# zamítám normalitu

# C) homoskedasticita
# Empirické posouzení
skeda = data %>% group_by(vyrobce) %>%
    summarise(  rozptyl = sd(C5_bezOP, na.rm=TRUE)^2,
                rozptyl_rounded = round(sd(C5_bezOP, na.rm=TRUE)^2,1), #rozptyl exploračně
    )

# poměr Amber/Bright
round(max(skeda$rozptyl)/min(skeda$rozptyl),2)

colnames(skeda) = c('Výrobce','Rozptyl','Zaokrouhleno')
skeda %>% print.data.frame()

# nemám normalitu, takže beru Leven test místo Bartlet testu
car::leveneTest(data$C5_bezOP ~ data$vyrobce)
# round(bartlett.test(data$C5_bezOP ~ data$vyrobce)$p.value,3)
# zamítám homoskedasticitu

# D) bodové a 95% intervalové odhady
# zaokrouhlit interval (dolů;nahoru)
odhady = data %>% group_by(vyrobce) %>%
    summarise(  median = round(median(C5_bezOP, na.rm=TRUE),1),
                interval = paste0('(',
                    floor(t.test(C5_bezOP, alternative="two.sided",conf.level=0.95)$conf.int[1]*10)/10, " ; ",
                    ceiling(t.test(C5_bezOP, alternative="two.sided",conf.level=0.95)$conf.int[2]*10)/10
                    ,')'),

    )
colnames(odhady) = c('Výrobce','Bodový odhad (lm)','95% intervalový odhad (lm)')
odhady %>% print.data.frame()

# oboustranný intervalový odhad, nemám normalitu, takže můžu použít mannův-whitneyho?
wilcox.test(data$C5_bezOP, alternative="two.sided",conf.level=0.95,conf.int=T)
# t.test(data$C5_bezOP[data$vyrobce=="Amber"], alternative = "two.sided", conf.level = 0.95)$conf.int
# var.test(data$C5_bezOP[data$vyrobce=="Amber"],alternative="two.sided")

# E) test významnosti a homogennost
# zamítám normalitu, takže nepoužívám ANOVA, ale Kruskalův-Wallisův
# summary(aov(data$C5_bezOP ~ data$vyrobce))

round(kruskal.test(data$C5_bezOP ~ data$vyrobce)$p.value,3)
# <<0,001 - Zamítám H_0
# Existuje statisticky významný rozdíl mezi výrobci

# install.packages("dunn.test")
# post-hoc dun-test, bonferoni
dunn.test::dunn.test(data$C5_bezOP, data$vyrobce, method="bonferroni",altp=TRUE)
# seřadit podle efektů

# počítání efektů
# průměry ve skupinách
efekty = data %>% group_by(vyrobce) %>%
    summarize(median_skup = median(C5_bezOP, na.rm=T))

# efekty
efekty$efekt = efekty$median_skup - median(data$C5_bezOP, na.rm=T)# celkový průměr

# vypsat setřízené
efekty %>% arrange(desc(efekt)) %>% print.data.frame()

# B   a
# A   x   b
# C   x   b   c
# D   x   b   c   d

# a(Bright) - mezi 'a' a 'b' je statistiky významný rozdíl v mediánu světelného toku při 5*C
# b(Amber,Clear,Dim) - není statistiky vyz. roz. v medianu


# This offline tool is a new method to identify the vent location of tephra fall deposits
# based on thickness or maximum clast size measurements.
# It is temporarily named "svl", which is short for Source Vent Locator.
# This file includes the associated R functions and their notations.

###
# Since the presented method gives estimate on the vent location and prevailing wind
# direction, it can be used to produce the input for our method to model the thickness
# or maximum clast size distribution of
# tephra fall deposits (Yang and Bursik, 2016; https://vhub.org/resources/3957).
###
# Author: Qingyuan Yang, Marcus Bursik, and E. Bruce Pitman.
###
# License: GPL. Use at your own risk.
###
# The work was supported by National Science Foundation Hazard SEES grant number 1521855 to
# G. Valentine, M. Bursik, E.B. Pitman and A.K. Patra, and National Science Foundation
# DMS grant number 1621853 to A.K. Patra, M. Bursik, and E.B. Pitman.
###
# We appreciate your comments, suggestions, and feedback.
# Please feel free to contact us through vhub or email: qyang5@buffalo.edu
# Notes:
#	The functions below are the version of the method that is coupled with the semi-
#	empirical model proposed by Gonzalez-Mellado and De la Cruz-Reyna (2010).
###### Functions ######
#################################Intermediate functions#################################
sp_par_cal <- function(obs, sv, wind_dir){
	sv = as.vector(sv)
	zr <- obs[,3]
	xy <- as.matrix(obs[,c(1,2)])
	nr <- nrow(obs)
	sv_matrix <- matrix(ncol=2, nrow=nr)
	sv_matrix[,1] <- rep(sv[1], nr)
	sv_matrix[,2] <- rep(sv[2], nr)
	unit_vector <- as.matrix(c(sin(wind_dir*pi/180),cos(wind_dir*pi/180)))
	rel_xy <- xy - sv_matrix
	dist <- (rel_xy[,1]^2 + rel_xy[,2]^2)^0.5
	dd <- (rel_xy) %*% (unit_vector)
	cd <- (dist^2 - dd^2)^0.5
	output <- matrix(nrow = nr, ncol=7)
	output[,1:2] <- xy
	output[,3:5] <- cbind(dist, dd, cd)
	output[,6] <- dist - dd
	output[,7] <- zr
	return(output)
}

fi <- function(obs, sv, wind_dir){
	td <- as.data.frame(sp_par_cal(obs, sv, wind_dir))
	colnames(td) <- c("x","y","dist","dd","cd", "dif","zr")
	td$z = log10(td$zr)

      	fit.res <- lm(z~dif+log(dist),data=td)		# ***case 1: power-law model***
#    	fit.res <- lm(z~dist+dd,data=td)		# ***case 2: exponential model***
        ssr <- sum(fit.res$residuals^2)
	return(ssr)
}

fi2 <- function(obs, sv, wind_dir){
	td <- as.data.frame(sp_par_cal(obs, sv, wind_dir))
	colnames(td) <- c("x","y","dist","dd","cd", "dif","zr")
	td$z = log10(td$zr)
      	fit.res <- lm(z~dif+log(dist),data=td)		# ***case 1: power-law model ***
#       fit.res <- lm(z~dist+dd,data=td)		# ***case 2: exponential model***
     	ssr <- sum(fit.res$residuals^2)
	return(c(ssr, fit.res$coefficients, summary(fit.res)$r.squared))
}

cg <- function(sv, h){
	output  = cbind(c(rep(sv[,1],4)+sin(0:3*90*pi/180)*h),
		    c(rep(sv[,2],4)+cos(0:3*90*pi/180)*h))
	return(output)
}

baf_pre <- function(sv, obs, nlps){
	pot_ang <- as.data.frame((1:36)*10)
	pot_ssr <- apply(pot_ang, MARGIN = 1, FUN=fi, obs = obs, sv = sv)
	lowest_rank = which(rank(pot_ssr)==1)			# ***Power-law***
	next_lowest_rank = which(rank(pot_ssr)==2)		# ***Power-law***
	#lowest_rank = min(which(rank(pot_ssr)<2))				# ***exponential***
	#next_lowest_rank = min(which(rank(pot_ssr)<4 & rank(pot_ssr)>2))	# ***exponential***
	if(abs(lowest_rank - next_lowest_rank)==1 || abs(lowest_rank - next_lowest_rank)==35){
		return(c(1, pot_ang[lowest_rank,1]))
	}else{
		return(c(2, pot_ang[lowest_rank,1], pot_ang[next_lowest_rank, 1]))
	}
}

baf_processor <- function(sv, obs, nlps, proposed_winddir){
	fdm <- matrix(c(-1,0,1,-1,0,1), nrow=2)
	h <- 5
	warns <- 0
	resm <- data.frame(matrix(ncol=2,nrow=2))
	gdnt <- c()
	wind_dir = proposed_winddir
	res <- fi(obs, sv, wind_dir)
	resm[1,1] <- wind_dir
	resm[1,2] <- res[1]
	wind_dir <- wind_dir + h
	res <- fi(obs, sv, wind_dir)
	resm[2,1] <- wind_dir
	resm[2,2] <- res[1]
	if(resm[1,2] >= resm[2,2]){
		lid <- 1
	}else{
		lid <- -1
	}
	r = 1
	for(i in 3:nlps){
		if(lid == 1){
			wind_dir <- resm[order(resm[,2]),][1,1] + h
			lid <- 1
		}else if(lid == -1){
			wind_dir <- resm[order(resm[,2]),][1,1] - 2 * h
			lid <- -1
		}else if(lid == 0 && r == 1){
			h <- h * 0.4
			wind_dir <-resm[order(resm[,2]),][1,1] + h
			r = 0
		}else if(lid == 0 && r == 0){
			wind_dir <-resm[order(resm[,2]),][1,1] - h
			r = 1
		}

		res <- fi(obs, sv, wind_dir)
		resm[i,1] <- wind_dir
		resm[i,2] <- res[1]
		resm <- resm[order(resm[,1]),]
			if(lid == 1){
				gdnt <-  fdm %*% resm[c(i-2,i-1,i),2]
			}
			if(lid == -1){
				gdnt <- fdm %*% resm[c(1,2,3),2]
			}
			if(lid == 0 ){
				n <- which(resm[,2]==min(resm[,2]))
				gdnt <- fdm %*% resm[c(n-1,n, n+1) ,2]
			}
		if(gdnt[1]<0 && gdnt[2]>=0){lid <- 0}
		if(gdnt[1]>=0 && gdnt[2] >= 0){lid <- -1}
		if(gdnt[1]<0 && gdnt[2] <0){lid <- 1}
		if(gdnt[1] > 0 && gdnt[2] < 0){lid <- -1}

		if(h < 0.01){break}
	}
	temp <- resm[which(resm[,2]==min(resm[,2])),]
	output <- as.matrix(cbind(temp[1], temp[2]), nrow = 1)
	return(output)

}

baf <- function(sv, obs, nlps){
	raw_inference <- baf_pre(sv, obs, nlps)
	if(raw_inference[1] == 1){
		output = baf_processor(sv, obs, nlps, raw_inference[2])
		return(output)
	}else{
		output_1 = baf_processor(sv, obs, nlps, raw_inference[2])
		output_2 = baf_processor(sv, obs, nlps, raw_inference[3])
		if(output_1[2]<output_2[2]){return(output_1)}else{return(output_2)}
	}
}

compare <- function(sv, obs, h, nlps, h_ratio){
	rsm <- (cg(sv, h*h_ratio))
	cr <- baf(sv, obs, nlps)
	rr = t(apply(X = rsm,  MARGIN = 1, FUN = baf, obs = obs, nlps = nlps))
	first_order_grad <- rr[,2]-cr[2]
	if(min(first_order_grad>0)){
		return(1)
	}else{
		first_order_grad[first_order_grad > 0] = 0
		direction = c(1,1,-1,-1)
		grad_y = (-1*direction[c(1,3)])%*%first_order_grad[c(1,3)]
		grad_x = (-1*direction[c(2,4)])%*%first_order_grad[c(2,4)]
		grad_unit = c(grad_x/(grad_x^2+grad_y^2)^0.5, grad_y/(grad_x^2+grad_y^2)^0.5)
		return(c(2,grad_unit))
	}
}
####################End of intermediate functions#################################

#################### Function name: gd_simplified ####################
gd_simplified <- function(sv, obs, runs, h, r, nlps, h_ratio, numb){
 obs = obs[numb,]
	tcoord <- as.data.frame(matrix(ncol=2))
	dec <- c()
	hl <- c()
	ihd <- h
	ir=1
	jg <- 0
	warns <- 0
	for(i in 1:runs){
			dec <- compare(sv, obs, h, nlps, h_ratio)
			if(dec[1]!= 1 && jg ==0){
					sv <- sv + h*dec[2:3]
					tcoord[i,] <- sv
					hl[i] <- h
					jg <- 0
			}else if(dec[1] != 1 && jg == 1){
					h <- h *(1 - r)
					sv <- sv + h*dec[2:3]
					tcoord[i,] <- sv
					hl[i] <- h
					jg <- 0
			}else if(dec[1] == 1 && h/ihd >= 0.0001){
				h = h * r
				hl[i] <- h
				jg <- 1
			}
		if(h < 0.1){break}
	}
	bd <- baf(sv, obs, nlps)
	rownames(tcoord) <- NULL
	output_sv = tcoord[nrow(tcoord),]
	output_ang = bd[1]
	fitted_results= fi2(obs, as.matrix(sv), output_ang)
	return(as.matrix(cbind(sv, output_ang, h, coef = t(fitted_results[c(2,3,4)]), ssr = fitted_results[1], rsquare = fitted_results[5])))
}

########################################## End of functions #####################################################

# Reference:
#	Gonzalez-Mellado, A. O., and S. De la Cruz-Reyna. "A simple semi-empirical approach to model thickness of
# ash-deposits for different #eruption scenarios." Natural Hazards and Earth System Sciences 10.11 (2010): 2241.
# 	Yang Q, Bursik M. A new interpolation method to model thickness, isopachs, extent, and volume of tephra fall
# deposits. Bulletin of Volcanology, 2016, 78(10): 68.


#' Discard 4 panel plots by fleet
#'
#' Shows observed and predicted discards regular and log scale, residuals over time, and resid histogram.
#' @param asap name of the variable that read in the asap.rdat file
#' @param fleet.names names of fleets
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @param liz.palette color definitions
#' @export

PlotDiscard4Panel <- function(asap,fleet.names,save.plots,od,plotf,liz.palette){
  par(mar=c(4,4,3,2), oma=c(1,1,1,1), mfrow=c(2,2)  )
  for (i in 1:asap$parms$nfleets) {
    discard.yrs = which(asap$discard.obs[i,]>0)
    if(length(discard.yrs) > 0){
      x.yrs = as.numeric(names(discard.yrs))
      plot(as.numeric(names(discard.yrs)), asap$discard.obs[i,discard.yrs] ,
           type='p', col=liz.palette[i], pch=1, xlab="Year", ylab="Total Discards",
           ylim=c(0, 1.1*max(asap$discard.obs[i,discard.yrs] )) )
      lines( as.numeric(names(discard.yrs)), asap$discard.pred[i,discard.yrs], col=liz.palette[i], lwd=2)

      sigma <- sqrt(log(asap$control.parms$catch.tot.cv[discard.yrs,i]^2+1.0))
      log.ob.min <- log(asap$discard.obs[i,discard.yrs])-1.96*sigma
      log.ob.max <- log(asap$discard.obs[i,discard.yrs])+1.96*sigma
      plot(as.numeric(names(discard.yrs)), log(asap$discard.obs[i,discard.yrs]) ,
           type='p', col=liz.palette[i], pch=1, xlab="Year", ylab="Ln(Total Discards)",
           ylim=c(min(log.ob.min,log(asap$discard.pred[i,discard.yrs])),
                  1.1*max(log.ob.max,log(asap$discard.pred[i,discard.yrs]) )) )
      lines( as.numeric(names(discard.yrs)), log(asap$discard.pred[i,discard.yrs]), col=liz.palette[i], lwd=2)
      arrows(x.yrs, log.ob.min, x.yrs, log.ob.max, length=0)
      title (paste0("Fleet ",i, " Discards  (", fleet.names[i], ")"), outer=T, line=-1 )

      c.resid <- rep(NA, length(discard.yrs))
      c.resid <- asap$discard.std.resid[i, discard.yrs]
      plot( as.numeric(names(discard.yrs)), c.resid, type='h', lwd=2, col=liz.palette[i],
            xlab="Year", ylab="Log-scale Std. Residual")
      abline(h=0)

      hist(c.resid, plot=T, xlab="Std. Residual", ylab="Probability Density", freq=F, main=NULL)
      if (save.plots) savePlot(paste0(od, "Discard.4panel.",i,".",plotf), type=plotf)
    }
  } #end loop nfleets
  par(mfrow=c(1,1))
  return()
}


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

###################################
#--- EXPONENTIAL APPROXIMATION ---#
###################################
p = 0.01
k = c(0:100)
geomProbs = 1 - pgeom(k, prob = p)
expProbs = 1 - pexp(k, rate = p)

p <- ggplot()
p <- p + geom_rect( aes(xmin = k, xmax = k + 1, ymin = 0, ymax = geomProbs), linetype = 2, fill = "white", color = "black" )
p <- p + geom_line(aes(x = k, y = expProbs), color = "red")
p <- p + theme_bw()
p <- p + xlab("k") + ylab("P(X>k)")
p


library("tidyverse")
library("ggplot2")
library("ggrepel")
library("ggcorrplot")
library("DT")
library("gridExtra")
library("knitr")
library("ggpubr")
library("dplyr")

data_final <- read_csv("./data/Query1.csv")

# Normalize population
data_final$original_total_pop <- data_final$total_pop

data_final <- data_final %>% mutate_at(c("total_pop"), ~(scale(.) %>% as.vector))

# Get the rent burden feature

# Break up into Severe burden, rent burden and no burden

data_final$renters = data_final$households - data_final$owner_occupied_housing_units

data_final$severe_burden = data_final$rent_over_50_percent / data_final$renters

data_final$rent_burden = (data_final$rent_40_to_50_percent +
                            data_final$rent_35_to_40_percent +
                            data_final$rent_30_to_35_percent) / data_final$renters
data_final$no_rent_burden = (data_final$rent_25_to_30_percent +
                               data_final$rent_20_to_25_percent +
                               data_final$rent_15_to_20_percent +
                               data_final$rent_10_to_15_percent +
                               data_final$rent_10_to_15_percent +
                               data_final$rent_under_10_percent) / data_final$renters

data_final$test= data_final$severe_burden +
  data_final$rent_burden +
  data_final$no_rent_burden +
  (data_final$rent_burden_not_computed/data_final$households)

# Check to make sure that there we are looking at all the households renting
data_final %>% select(test) %>% summary()

# Get cases/deaths per 1000
data_final$confirmed_cases_per1000 = data_final$confirmed_cases /
  (data_final$original_total_pop)*1000
data_final$deaths_per1000 = data_final$deaths /
  (data_final$original_total_pop)*1000

# Get the percentages of each population group
data_final$white_pop_per = data_final$white_pop / data_final$original_total_pop
data_final$black_pop_per = data_final$black_pop / data_final$original_total_pop
data_final$asian_pop_per = data_final$asian_pop / data_final$original_total_pop
data_final$hispanic_pop_per = data_final$hispanic_pop / data_final$original_total_pop
data_final$amerindian_pop_per = data_final$amerindian_pop / data_final$original_total_pop
data_final$other_race_pop_per = data_final$other_race_pop / data_final$original_total_pop
data_final$two_or_more_races_pop_per = data_final$two_or_more_races_pop / data_final$original_total_pop
data_final$not_hispanic_pop_per = data_final$not_hispanic_pop / data_final$original_total_pop

data_final %>% write.csv(file = "for_eval.csv")

data_final$total_pop

temp <- data_final %>% select(total_pop, original_total_pop, no_rent_burden, rent_burden,
                      severe_burden, median_income,
                      deaths_per1000, confirmed_cases_per1000,
                      white_pop_per, black_pop_per, asian_pop_per, hispanic_pop_per,
                      amerindian_pop_per, other_race_pop_per, two_or_more_races_pop_per,
                      not_hispanic_pop_per, commuters_by_public_transportation,
                      county_name, state, county_fips_code, deaths, confirmed_cases)
temp
temp %>% write.csv(file = "datatable.csv")

temp %>% summary()

# Get Standard Deviation
temp_numeric <- temp %>% select(total_pop, original_total_pop, no_rent_burden,
                                rent_burden, severe_burden, median_income,
                                deaths_per1000, confirmed_cases_per1000,
                                white_pop_per, black_pop_per, asian_pop_per,
                                hispanic_pop_per, amerindian_pop_per,
                                other_race_pop_per, two_or_more_races_pop_per,
                                not_hispanic_pop_per,
                                commuters_by_public_transportation)
apply(temp_numeric,2,sd)

# Investigate Outliers
# Invwargate rent Burden
p1 <- ggplot(temp, aes(x = severe_burden, y = rent_burden)) + geom_point()
p2 <- ggplot(temp, aes(x = severe_burden, y = no_rent_burden)) + geom_point()
p3 <- ggplot(temp, aes(x = rent_burden, y = no_rent_burden)) + geom_point()

g <- ggarrange(p1, p2, p3)
annotate_figure(g, top = text_grob("Rent Burden Plot Chart"))
ggsave("./charts/RentBurdenPlots.jpg", width = 6.5, height = 3)

# Investigate Population vs cases and deaths
p1 <- ggplot(temp, aes(x = original_total_pop, y = confirmed_cases_per1000)) +
  geom_point()
p1
target <- max(temp$original_total_pop)
target

match(temp$original_total_pop, target)

outlier_row = temp %>% filter(original_total_pop > 7.5e6)
outlier_row$county_name
outlier_row$state
outlier_row$county_fips_code

p1 <- ggplot(temp, aes(x = original_total_pop, y = deaths)) +
  geom_point() +
  geom_text(data = temp,
            aes(x = 1e07-21e5, y = 1.425e4, label = "LA County >>")) +
  ggtitle("Cases per Population Outliers")
p2 <- ggplot(temp, aes(x = original_total_pop, y = confirmed_cases)) +
  geom_point() +
  geom_text(data = temp,
            aes(x = 1e07-21e5, y = 9.3e5, label = "LA County >>")) +
  ggtitle("Deaths per Population Outliers")

g <- ggarrange(p1, p2)
annotate_figure(g, top = text_grob("Populations vs Deaths and Cases"))

ggsave("./charts/DeathsCasesPlot.jpg", width = 6.5, height = 3)

# Filter out LA county.

temp <- temp %>% filter(county_fips_code != "06037")

temp

temp <- temp %>% filter(original_total_pop >= 1000)

temp %>% write.csv(file = "datatable.csv")

source("./clustering_helpers.R")
data <- temp

data$deaths_per10000 <-  data$deaths_per1000 * 10
n <- 5
vect <- data$deaths_per10000
vect <- sort(vect)
l <- length(data$deaths_per10000)
break_deaths <- c(-Inf)
n <- n + 1
window <- l %/% ((n - 1))
for (i in 1:(n-2)) {
  print(i*window)
  break_deaths <- append(break_deaths, vect[i*window])
}
break_deaths <- append(break_deaths, Inf)

labels_deaths <- c()
for (i in 1:(n-1)) {
  labels_deaths <- append(labels_deaths, paste("deaths_class_", i, sep = ""))
}
labels_deaths

cut(data$deaths_per10000,
    breaks = break_deaths,
    labels = labels_deaths)

test <- catagorize_deaths(data, 5)
data$deaths_class = test
print(data %>% filter(deaths_class == "deaths_class_3"))
catagorize_cases(data, 5)

n
cut1 <- med - min
cut2 <- max - med
cut(data$confirmed_cases_per1000,
    breaks=c(-Inf, cut1, cut2, Inf),
    labels=c("low","middle","high"))


# Carregando a library de gráficos bonitinhos
library(ggplot2)

# Definindo o número de random()
set.seed(1)

# Carregamos o dataset sobre as flores Iris
data(iris)

# Extraimos as colunas de 1 a 4 para a variavel my_iris
my_iris <- iris[,1:4]

# Extraimos a coluna 5 para a variável especies
species <- iris[,5]

# Criamos um agrupamento de 3
km <- kmeans(my_iris, 3, nstart = 20)

# Imprimindo o conteúdo de KM
# Aqui nós conseguimos dados com o total_SS
# O total_SS significa o sum of squares by cluster
# com o dataset do iris nós chegamos a 88,4% de confiabilidade
km

# Exibindo o resultado do agrupamento em forma de tablea
table(km$cluster, species)

# Exindo o resultado via gráfico
ggplot(iris, aes(Petal.Length, Petal.Width, color = species)) + geom_point()


#
# Vars
#
i = 10
f = 10.6
s = "Diego String"
b = TRUE

#
# Sequence
#
s1 = 1:10

#
# Vector
#
v1 = c(1,2,3,6)

#
# Functions
#
inc = function(v){ v + 1 }
inc(5)

#
# Matrix
#
m = matrix(data = 1:10, nrow=5, ncol=5)

mm1 = matrix(1:4,2,2)
mm2 = matrix(1:4,2,2)
mm1 == mm2
identical(mm1,mm2)

#
# Lists
#
l = list(1,10,100,500)

#
# Factors
#
factors = factor(c("MALE","FEMALE","MALE","FEMALE"))
levels(factors)
unclass(factors)

#
# Data Frame
#
df = data.frame(
  Name = c("CAT","DOG","PIG","LION"),
  HowMany = c(2,1,0,3),
  isPet = c(TRUE,TRUE,FALSE,FALSE)
)

# col - row
df[1,1]
# row
df[1,]
# cols
df[,1]
# name
df[["Name"]]
# shortcut
df$Name
# sub framing
df[c(2,4),]
# kinda of queries
df[df$isPet==TRUE,]
df[df$HowMany>=2,]
df[df$Name %in% c("CAT","ALIGATTOR"),]

#
# R is a vectorized lang
#
1 + 2
c(1,2,3) + c(4,5,6)

# HELP
?c


library(ggplot2)
args <- commandArgs(trailingOnly = T)
directory <- args[1]
corpus <- read.csv(paste(directory,"/corpus.csv", sep=""))
fit <- cmdscale(corpus, k=2)
data <- as.data.frame(fit)
data$Category <- gsub("\\d+ ", "", rownames(data))

Category <- factor(gsub("\\d+ ", "", rownames(fit)))

png(paste(directory,"/corpus-mds.png", sep=""), width=500, height=500, res=100)

p <- ggplot(data) +
    geom_point(aes(x=V1, y=V2, color=Category)) +
    scale_x_continuous("", breaks=NA) +
    scale_y_continuous("", breaks=NA) +
    opts(axis.text.x = theme_blank(), axis.title.x=theme_blank(),
        axis.text.y = theme_blank(), axis.title.y=theme_blank(),
        legend.position = "none")
p
dev.off()

corpus <- read.csv(paste(directory,"/models.csv", sep=""))
fit <- cmdscale(corpus, k=2)
data <- as.data.frame(fit)
data$Category <- rownames(data)
png(paste(directory,"/corpus-mds-centroids.png", sep=""),
    width=500, height=500, res=100)
p <- ggplot(data) +
    geom_text(aes(x=V1, y=V2, label=Category, size=3, color=Category)) +
    scale_x_continuous("", breaks=NA) +
    scale_y_continuous("", breaks=NA) +
    opts(axis.text.x = theme_blank(), axis.title.x=theme_blank(),
        axis.text.y = theme_blank(), axis.title.y=theme_blank(),
        legend.position = "none")
p
dev.off()

png(paste(directory,"/corpus-mds-faceted.png", sep=""),
    width=500, height=500, res=100)
p <- ggplot(data)
cats <- as.vector(unique(Category))
for(cat in cats)
{
    corpus <- read.csv(paste(directory,"/",cat,".csv", sep=""))
    if(nrow(corpus) > 2)
    {
        fit <- cmdscale(corpus, k=2)
        data_cat <- as.data.frame(fit)
        data_cat$Category <- gsub("\\d+ ", "", rownames(data_cat))
        data_cat$URLID <- gsub("(\\d+)?.*", "\\1", rownames(fit))

        p <- p + geom_point(data=subset(data_cat, URLID != ""),
                aes(x=V1, y=V2, size=1.5, color=Category)) +
            geom_point(data=subset(data_cat, URLID == ""),
                aes(x=V1, y=V2, size=7, shape=c(1)))
    }
}
p <- p + scale_x_continuous("", breaks=NA) +
    scale_y_continuous("", breaks=NA) +
    opts(axis.text.x = theme_blank(), axis.title.x=theme_blank(),
        axis.text.y = theme_blank(), axis.title.y=theme_blank(),
        legend.position = "none") +
    facet_wrap(~ Category)
p
dev.off()


library(keras)

# Define maximum number of input features
max_features <- 20000

# Cut texts after this number of words
# (among top max_features most common words)
maxlen <- 100

batch_size <- 32

# Load imdb dataset
cat('Loading data...\n')
imdb <- dataset_imdb(num_words = max_features)

# Define training and test sets
x_train <- imdb$train$x
y_train <- imdb$train$y
x_test <- imdb$test$x
y_test <- imdb$test$y

# Output lengths of testing and training sets
cat(length(x_train), 'train sequences\n')
cat(length(x_test), 'test sequences\n')

cat('Pad sequences (samples x time)\n')

# Pad training and test inputs
x_train <- pad_sequences(x_train, maxlen = maxlen)
x_test <- pad_sequences(x_test, maxlen = maxlen)

# Output dimensions of training and test inputs
cat('x_train shape:', dim(x_train), '\n')
cat('x_test shape:', dim(x_test), '\n')

# Initialize model
model <- keras_model_sequential()
model %>%
  # Creates dense embedding layer; outputs 3D tensor
  # with shape (batch_size, sequence_length, output_dim)
  layer_embedding(input_dim = max_features,
                  output_dim = 128,
                  input_length = maxlen) %>%
  bidirectional(layer_lstm(units = 64)) %>%
  layer_dropout(rate = 0.5) %>%
  layer_dense(units = 1, activation = 'sigmoid')

# Try using different optimizers and different optimizer configs
model %>% compile(
  loss = 'binary_crossentropy',
  optimizer = 'adam',
  metrics = c('accuracy')
)

# Train model over four epochs
cat('Train...\n')
model %>% fit(
  x_train, y_train,
  batch_size = batch_size,
  epochs = 4,
  validation_data = list(x_test, y_test)
)


#  James Rekow

geoGradientAbdListCreator  = function(M = 100){

  #  ARGS: M - number of spatial grid points. These are the samples in this model. Schnerb et al. used
  #             = 500.
  #
  #  RETURNS:

  #  number of species
  N = 200

  #  spatial grid of 500 geographical sites
  x = 1:M

  createGeoSpeciesAbd = function(placeholder = NULL){

    slope = rnorm(n = 1, mean = 0, sd = 1)
    intercept = rnorm(n = 1, mean = 0, sd = 50)

    computeGeoAbd = function(z) slope * z + intercept

    geoAbd = sapply(x, computeGeoAbd)

    geoAbd[geoAbd < 0] = 0

    return(geoAbd)

  } #  end createGeoSpeciesAbd function

  geoSpeciesMat = sapply(1:N, createGeoSpeciesAbd)

  extractAbdGeoSample = function(n) geoSpeciesMat[n, ]

  abdList = lapply(as.list(x), extractAbdGeoSample)

  return(abdList)

} #  end  geoGradientAbdListCreator  function


price_fraction <- function(x)
{
  stopifnot(all(x >= 0 & x <= 1))
  breaks <- seq(0.06, 1.01, 0.05)
  values <- c(.1, .18, .26, .32, .38, .44, .5, .54, .58, .62, .66, .7, .74, .78, .82, .86, .9, .94, .98, 1)
  indices <- sapply(x, function(x) which(x < breaks)[1])
  values[indices]
}

#Example usage:
price_fraction(c(0, .01, 0.06, 0.25, 1))                # 0.10 0.10 0.18 0.38 1.00


# Main program for local optimisation
##########################
#Set workking directory
#Source functions
#Set cost
#Set patternCost
#Set sensitivity
#Set specificity
#Set p range
#Set restricted t
#Initialise
#Run optimisations
##########################

# Set directory
setwd("./")

# Source functions
source("./testAllocationOptimisation.r")

# Set cost of RAT, RT-PCR, IgG antibody in 1000 rupees
#testCosts = c(0.45, 1.6, 0.30)
testCosts = c(0.45, 0.1, 0.30)

# Set cost of test patterns. Remember to remove the top row.
patternCost = getCosting(testCosts)
patternCost = patternCost[-1]

## Global sensitivity and specificity
## 1=RAT,2=RTPCR,3=AB
Spec = c(0.975,0.97,0.977)
Sen  = c(0.5,0.95,0.921)

# Set the guessed prevalence for local c-optimal design
p = c(0.1,0.3,0.01)

# Set p range
p1set = c(1:15)/100
p2set = c(10:50)/100
p3set = c(0:2)/100
# p1set = c(50)/100
# p2set = c(5)/100
# p3set = c(0)/100
t = 6 #Focus only on RTPCR and AB
resultM = t(c(0,0,0,0))

for (p1 in p1set) {
  for (p2 in p2set) {
    for (p3 in p3set) {
      u = c(1,1,1)
      p = c(p1,p2,p3)
      localI = getPatternFisherInfo(p,t)
      # Uncomment these lines to run for calculated worst case.
      # r=0.025141
      # localI1 = getPatternFisherInfo(p,t-1)
      # localI = (1-r)*localI+r*localI1
      localJ = matrix.inverse(localI)
      var = (t(u) %*% localJ %*% u)
      resultM = rbind(resultM,t(c(p1,p2,p3,var)))
    }
  }
}
resultM
maxVar = max(resultM[,4])
deff = 3
merr = 0.05
zalpha=1.96
numSamples = maxVar*deff*zalpha*zalpha/(merr*merr)

# Run this lines 54-57 commented to get variance of the simple design (0,1,1).
# Then run this with the same lines uncommented to get variance of the worst-
# case design for range ([0.01-0.15, 0.1-0.5, 0-0.02]). The best design for
# for this worst case invest r=0.025141 in the pattern (0,0,1).


#' Takes predictions from model object(s) and and combines it with actual values
#' This function takes a vector of strings that represent the model object names
#' trfm <- function(df_variable, missing, min, max, zero_value, transformation)
#' @param df_variable A vector that contains the original values that need to be transformed
#' @param missing The value that should replace any  missing values in the dataset
#' @param min The minimum value that a given variable should take; any value below the minimum will
#'   be set equal to the min value
#' @param max The maximum value that a given variable should take; any value above the maximum will
#'   be set equal to the max value
#' @param zero_value This is the value that any value of 0 should be.
#' @param transformation This is an integer value for corresponding to one of three transformation:
#'   0 == no transformation, 1 == log(), 2 == sqrt()
#' @return trfm() will a vector of transformed values
#' @export
# @examples
# original SAS code:
# %macro trfm(var,md,min,max,zd,trfm);
# if &var = . then
# t&var = &md ;
# else t&var = &var;
#
# if t&var = 0 then
# t&var = &zd;
# else
#   t&var = t&var;
#
# t&var = min(max(t&var,&min),&max);
#
# if &trfm = 1 then do;
# if t&var le 0 then
# t&var = log(0.0001);
# else
#   t&var = log(t&var);
# end;
# if &trfm = 2 then do;
# t&var = sqrt(t&var);
# end;
# %mend trfm;

trfm <- function(df_variable, missing, min, max, zero_value, transformation){
  # function to transform columns based on parameters
  # missing value is applied to the vector after missing transformation is applied

  vec_new <- sapply(df_variable, function(x) ifelse(is.na(x) == T, missing, x))
  vec_new <- sapply(vec_new, function(x) ifelse(x == 0, zero_value, x))
  vec_new <- sapply(vec_new, function(x) min(max(min, x), max))

  if (transformation == 1) {
    vec_new_trans <- sapply(vec_new, function(x) ifelse(x <= 0, log(0.0001), log(x)))
  } else if (transformation == 2) {
    vec_new_trans <- sapply(vec_new, function(x) sqrt(x))
  } else {
    vec_new_trans <- vec_new
  }
  return(vec_new_trans)
}


##set working directory
setwd("~/Downloads")

#import the data
example = read.csv("mlm example.csv")

##factor the categorical variables
example$gender = factor(example$gender,
                        levels = c(1, 2),
                        labels = c("Male", "Female"))
example$college = factor(example$college,
                         levels = c(1,2,3),
                         labels = c("Arts", "Sciences", "Math"))

##data screening
##accuracy
summary(example)

##missing data
summary(example)

##outliers
mahal = mahalanobis(example[ , -c(1,2)],
                    colMeans(example[ , -c(1,2)], na.rm = TRUE),
                    cov(example[ , -c(1,2)], use = "pairwise.complete.obs"))
summary(mahal)
cutoff = qchisq(1-.001, ncol(example[ , -c(1,2)]))
summary(mahal < cutoff)
example = example[mahal < cutoff , ]

##multicollinearity
correlation = cor(example[ , -c(1,2)])
symnum(correlation)

##assumptions
random = rchisq(nrow(example), 7)
fake = lm(random ~ ., data = example)
fitted = scale(fake$fitted.values)
standardized = rstudent(fake)

##linearity
qqnorm(standardized)
abline(0,1)

##normality
hist(standardized)

##homog / homos
plot(fitted, standardized)
abline(0,0)
abline(v=0)

##run the analysis

##set up the analysis
library(reshape)
library(nlme)
##need a participant number
example$partno = c(1:nrow(example))
example$tech_exp = scale(example$tech_exp, scale = F)
example$comp_exp = scale(example$comp_exp, scale = F)

examplelong = melt(example,
                   id = c("partno", "gender", "college", "comp_anx"),
                   measured = c("tech_exp", "comp_exp"))
##intercept only model
##gls = generalized least squares
##ML = maximum likelihood
model1 = gls(value ~ 1,
             data = examplelong,
             method = "ML",
             na.action = "na.omit")
summary(model1)

##random intercept only model
##note we switched to LME function
model2 = lme(value ~ 1,
             data = examplelong,
             method = "ML",
             na.action = "na.omit",
             random = ~1|partno)
summary(model2)
anova(model1, model2)

##let's pretend we need to do the MLM (nest the variables)
##let's add predictors
model3 = lme(value ~ gender + college + comp_anx,
             data = examplelong,
             method = "ML",
             na.action = "na.omit",
             random = ~1|partno)
summary(model3)
summary(examplelong)

tapply(examplelong$value, examplelong$gender, mean)
tapply(examplelong$value, examplelong$college, mean)

##random slopes
model4 = lme(value ~ gender + college + comp_anx,
             data = examplelong,
             method = "ML",
             na.action = "na.omit",
             random = ~ comp_anx|partno,
             control = lmeControl(msMaxIter = 200))
summary(model4)
anova(model3, model4)


# raw data
x   = runif(100);
y   = runif(100);
seq = lapply(1:length(x), function(i) list(v = c(x[i], y[i])));

# define compares order
index = function(p1, p2) {
	d = sqrt(sum((p1$v - p2$v) ^ 2));

	if (d <= 0.3) {
		0
	} else if (d <= 0.6) {
		1
	} else {
		-1
	}
}

# run clustering
c = bcluster(seq, index);

# plot result data
plot(x, y, pch = 2, col = "white");

i       = 1;
colors1 = c(
	"red", "blue", "green", "yellow", "steelblue",
	"purple", "black", "orange", "gray", "cyan",
	"pink", "skyblue", "limegreen"
);

for(name in names(c)) {
	points(x[c[[name]]], y[c[[name]]], pch=25, col=colors1[i], bg=colors1[i]);
	i = i + 1;
}


# published on http://www.r-statistics.com/2010/07/visualization-of-regression-coefficients-in-r
# originally written by "Achim Zeileis"
# GPL-2

coefplot <- function(object, df = NULL, level = 0.95, parm = NULL,
					 labels = TRUE, xlab = "Coefficient confidence intervals", ylab = "",
					 xlim = NULL, ylim = NULL,
					 las = 1, lwd = 1, lty = c(1, 2), pch = 19, col = 1,
					 length = 0, angle = 30, code = 3, ...)
{
	 cf <- coef(object)
	 se <- sqrt(diag(vcov(object)))
	 if(is.null(parm)) parm <- seq_along(cf)
	 if(is.numeric(parm) | is.logical(parm)) parm <- names(cf)[parm]
	 if(is.character(parm)) parm <- which(names(cf) %in% parm)
	 cf <- cf[parm]
	 se <- se[parm]
	 k <- length(cf)

	 if(is.null(df)) {
	   df <- if(identical(class(object), "lm")) df.residual(object) else 0
	 }

	 critval <- if(df > 0 & is.finite(df)) {
	   qt((1 - level)/2, df = df)
	 } else {
	   qnorm((1 - level)/2)
	 }
	 ci1 <- cf + critval * se
	 ci2 <- cf - critval * se

	 lwd <- rep(lwd, length.out = 2)
	 lty <- rep(lty, length.out = 2)
	 pch <- rep(pch, length.out = k)
	 col <- rep(col, length.out = k)

	 if(is.null(xlim)) xlim <- range(c(0, min(ci1), max(ci2)))
	 if(is.null(ylim)) ylim <- c(1 - 0.05 * k, 1.05 * k)

	 if(isTRUE(labels)) labels <- names(cf)
	 if(identical(labels, FALSE)) labels <- ""
	 labels <- rep(labels, length.out = k)

	 plot(0, 0, xlim = xlim, ylim = ylim, xlab = xlab, ylab = ylab,
	   axes = FALSE, type = "n", las = las, ...)
	 arrows(ci1, 1:k, ci2, 1:k, lty = lty[1], lwd = lwd[1], col = col,
	   length = length, angle = angle, code = code)
	 points(cf, 1:k, pch = pch, col = col)
	 abline(v = 0, lty = lty[2], lwd = lwd[2])
	 axis(1)
	 axis(2, at = 1:k, labels = labels, las = las)
	 box()
}


#' Iterator that returns the Cartesian product of the arguments.
#'
#' Constructs an iterator that is the Cartesian product of each of the
#' arguments.
#'
#' Although they share the same end goal, \code{iproduct} can yield drastic
#' memory savings compared to \code{\link[base]{expand.grid}}.
#'
#' @importFrom iterators iter nextElem
#' @export
#' @param ... multiple arguments
#' @param times the number of times the Cartesian product is repeated. By
#' default, repeated only once.
#' @return iterator that iterates through each element from the Cartesian
#' product
#'
#' @examples
#' it <- iproduct(x=1:3, y=4:5)
#' iterators::nextElem(it) # list(x=1, y=4)
#' iterators::nextElem(it) # list(x=1, y=5)
#' iterators::nextElem(it) # list(x=2, y=4)
#' iterators::nextElem(it) # list(x=2, y=5)
#' iterators::nextElem(it) # list(x=3, y=4)
#' iterators::nextElem(it) # list(x=3, y=5)
#'
#' # Repeats the Cartesian product twice
#' it <- iproduct(x=1:3, y=4:5, times=2)
#' # First Cartesian product
#' iterators::nextElem(it) # list(x=1, y=4)
#' iterators::nextElem(it) # list(x=1, y=5)
#' iterators::nextElem(it) # list(x=2, y=4)
#' iterators::nextElem(it) # list(x=2, y=5)
#' iterators::nextElem(it) # list(x=3, y=4)
#' iterators::nextElem(it) # list(x=3, y=5)
#'
#' # Second Cartesian product
#' iterators::nextElem(it) # list(x=1, y=4)
#' iterators::nextElem(it) # list(x=1, y=5)
#' iterators::nextElem(it) # list(x=2, y=4)
#' iterators::nextElem(it) # list(x=2, y=5)
#' iterators::nextElem(it) # list(x=3, y=4)
#' iterators::nextElem(it) # list(x=3, y=5)
#'
#' # iproduct is a replacement for base::expand.grid()
#' # Large data.frames are not created unless the iterator is manually consumed
#' a <- 1:2
#' b <- 3:4
#' c <- 5:6
#' it3 <- iproduct(a=a, b=b, c=c)
#' df_iproduct <- do.call(rbind, as.list(it3))
#' df_iproduct <- data.frame(df_iproduct)
#'
#' # Compare df_iproduct with the results from base::expand.grid()
#' base::expand.grid(a=a, b=b, c=c)
#'
iproduct <- function(..., times=1) {
  args_list <- list(...)
  if (length(args_list) == 0) {
    stop("At least one argument must be supplied.")
  }

  # Determines the frequency and number of replicates each element in args_list
  # must be repeated
  args_lengths <- sapply(args_list, length)
  freq <- cumprod(c(1, rev(args_lengths[-1])))
  freq <- rev(unname(freq))
  rep_times <- unname(prod(args_lengths) / freq / args_lengths)

  # To repeat the Cartesian product multiple times, the 'rep_times' is simply
  # scaled by 'times'
  rep_times <- rep_times * times

  # For each element in args_list, an iterator is constructed that repeats each
  # of its values with the proper frequency and cadence.
  args_iters <- mapply(irep,
                       args_list,
                       times=rep_times,
                       each=freq,
                       SIMPLIFY=FALSE)

  # Finally, izip's the list of iterators
  do.call(izip, args=args_iters)
}


library(statnet)
library(ergm)
library(sna)
library(coda)
library(network)
sessionInfo()
set.seed(0)

Nsample = 10
N = 10
T  =20
net <- network.initialize(N)
sampledMat_T_R =    array(0, dim=c(N,N,T,Nsample))

changeStats_T_R = list()
stats_T_R = list()
    for(t in 1:T){
        changeStats_t_R = list()
        stats_t_R = list()
        print(t)
        for(n in 1:Nsample){
            print(parDgpT[,t])
             net <- simulate(formula_ergm, nsim = 1, seed = sample(1:100000000,1), coef = parDgpT[,t],control = control.simulate.formula(MCMC.burnin = 100000))
             sampledMat_T_R[,,t,n] <- as.matrix.network( net)
             print(c(t,n))
             chStat_t <- ergmMPLE(formula_ergm)
             changeStats_t_R[[n]] <- cbind(chStat_t$response, chStat_t$predictor,chStat_t$weights)
             stats_t_R[[n]] <- summary(formula_ergm)

             }
              changeStats_T_R[[t]] <-changeStats_t_R
              stats_T_R[[t]] <- stats_t_R
         }


#' Sparse Matrix Generators
#'
#' Generate sparse matrices.
#'
#' @details
#' \code{spar_gen_bandish()} generates a "band-ish" matrix, a matrix whose
#' entries are probabilistically more likely to be 1 the closer to the main
#' diagonal they are.
#'
#' \code{spar_gen_banded()} generates a banded matrix.
#'
#' @param nrows,ncols
#' The dimension
#' @param seed
#' Random seed.
#' @param band
#' The band size, a positive integer. \code{band=1} returns a matrix whose
#' diagonal entries are all 1; \code{band=2} returns a matrix with 1 on each
#' diagonal entry and 1 on each entry directly above and below the main
#' diagonal; etc.
#'
#' @return
#' A sparse \code{"dgCMatrix"} object is returned.
#'
#' @name sparse_gen
#' @rdname sparse_gen
NULL

#' @useDynLib cop cop_spar_gen_bandish
#' @rdname sparse_gen
#' @export
spar_gen_bandish = function(nrows, ncols, seed)
{
  if (!missing(seed))
    seed = as.integer(seed)
  else
    seed = -1L

  m = as.integer(nrows)
  n = as.integer(ncols)

  check_is_posint(seed)
  check_is_posint(m)
  check_is_posint(n)

  .Call(cop_spar_gen_bandish, seed, m, n)
}

#' @useDynLib cop cop_spar_gen_banded
#' @rdname sparse_gen
#' @export
spar_gen_banded = function(nrows, ncols, band=2)
{
  band = as.integer(band)
  m = as.integer(nrows)
  n = as.integer(ncols)

  check_is_posint(band)
  check_is_posint(m)
  check_is_posint(n)

  .Call(cop_spar_gen_banded, band, m, n)
}


suppressPackageStartupMessages(library(kazaam))

y = matrix(c(-1, 1, 0, 1), 2)

if (comm.rank() == 0){
  x = matrix(rnorm(30), 15)
  mm = x %*% y
} else {
  x = NULL
}

dx = expand(x)

mm_test = collapse(dx %*% y)

comm.print(all.equal(mm, mm_test))

finalize()


normalize_to_01 <- function( p ) {

	max_p = max( p )
	min_p = min( p )

	p_norm = p - min_p
	p_norm = p_norm / ( max_p - min_p )

	return( p_norm )

}


#' @title calcShipM
#'
#' @description Calculate the fineness/slenderness ratio (\code{M})
#' (dimensionless) of the ship.
#'
#' @param actualDisplacement Actual loaded displacement (vector of
#' numericals, m^3) (see \code{\link{calcActualDisp}})
#' @param lwl Waterline length (vector of numericals, m) (see
#' \code{\link{calclwl}})
#'
#' @return \code{M} (vector of numericals, dimensionless)
#'
#' @references
#'\href{https://www.man-es.com/marine/products/propeller-aft-ship}{MAN Energy
#' Solutions. 2011. "Basic Principles of Propulsion."}
#'
#'@seealso
#' \itemize{
#' \item \code{\link{calcActualDisp}}
#' \item \code{\link{calclwl}}
#' }
#'
#' @examples
#' calcShipM(73663,218)
#' calcShipM(c(73663,216726),c(218,400))
#'
#' @export

calcShipM <-function(actualDisplacement, lwl){

  M <- lwl/(actualDisplacement^(1/3))

  return(M)
}


# for filtering signals
library("signal");

##
# Function that calculates the mean and the confidence inteval of each instant
# of time in a matrix with several replicas. The matrix must be  in the
# following format:
#
#    Not part
#    of data    Matrix containing the data
#    -------    ---------------------------
#    [Time]     R1    R2    R3     R4    ...
#    [1]        10    11     9     12
#    [2]        15    16    14     17
#    [3]        20    21    19     22
#    [4]        16    17    15     18
#    [5]        12    13    11     14
#    [6]        18    19    17     20
#    [7]        11    12    10     13
#    ...
#
#    Time: instant of time that values were sampled. It is not part of the data.
#    Rn: number of the replica where the values were generated.
#
# Computation reference:
#   To compute confidence interval see summarizeSE function at
#     http://www.cookbook-r.com/Manipulating_data/Summarizing_data/
#
# BOGUS: handle NA values
#
# Input: dset -> dataset
# Output: for each line the tuple (mean-ci, mean, mean+ci)
get_ci <- function(dset, confidence = .95, smooth = plotyy.smooth) {
    ds <- data.matrix(dset);
    nr <- ncol(ds); # number of replicas

    res <- data.frame(Lower = numeric(), Mean = numeric(), Upper = numeric());
    for (i in 1:nrow(ds)) {
        m <- mean(ds[i,]);
        dev <- sd(ds[i,]);
        serr <- dev/sqrt(nr);
        cim <- qt(confidence/2 + .5, nr-1);
        ci <- serr * cim;
        res <- rbind(res, data.frame(m-ci, m, m+ci));
    }
    colnames(res) <- c("Lower", "Mean", "Upper");

    if (smooth) {
        res$Lower = smooth_data(res$Lower);
        res$Mean = smooth_data(res$Mean);
        res$Upper = smooth_data(res$Upper);
    }

    r <- list("replicas" = nr, "data" = res, "smoothed" = smooth);
    r;
}

##
# Take a series and pass it through a filter.
smooth_data <- function (series, lospan = 0.1) {
    # FINITE IMPULSE RESPONSE --- FIR
    # setting the cutoff frequency
    spec = spectrum(series, plot = FALSE)#, spans = c(5,7)); # smoothed spectrum
    cr = ceiling(length(spec$freq) * .1); # cutoff frequency range
    mi = min(spec$freq[1:cr])
    ma = max(spec$freq[1:cr]) - mi
    nfreq = (spec$freq[1:cr] - mi)/ma;

    #lo <- loess(series ~ xseq, span = lospan);
    #ch = fir2(n = 11, f = nfreq, m = spec$spec[1:cr]);
    ch = cheby2(2, 20, .5, type = "low");

    #pred = predict(lo)
    #plot(pre);return();
    filter(ch, series)
}

##
# Plot a serires surrounded by its confidence interval
# BOGUS: did not consider x-axis values.
plot_series <- function(series, col = 1, alpha.f = 0.10, pch = 4,
                        type = ifelse(plotyy.smooth, "l", "o"),
                        #xlim = c(0, length(series$Mean)),
                        ylim = range(series)
                        ) {
    # Tackle with differents sample times. Solution: span values throughout the x-axis
    xseq = seq(1, xlim[2], by = (xlim[2]/length(series$Mean)));

    plot(x = xseq,
         y = series$Mean,
         type = type,
         main = "",
         sub = "",
         xlab = "",
         ylab = "",
         ylim = ylim,
         col = col,
         xaxt = "n",
         yaxt = "n",
         pch = pch,
         frame = FALSE,
    );

    polygon(
        x = c(rev(xseq), xseq),
        y = c(rev(series$Lower), series$Upper),
        col = adjustcolor(col, alpha.f = alpha.f),
        border = FALSE
    );

}

##
# Set the colors palette up.
palette_setup <- function() {
    palette(c(
        "black",
        "blue",
        "red",
        "green3",
        "steelblue3",
        "yellow4",
        "darkgray",
        "magenta"
    ));
}

##
#  This function plots a bunch of series. It calculates, the ylim and get
#     the confidence interval.
#
#  Known issues: it is not generic enough. dsset must a list().
#
# Input:
#       - dsset: must be a LIST, representing a set of datasets to be plotted.
# return:
#       - the number of replicas (assuming it is the same for all
#           datasets in the set)
series_set_plot <- function(dsset, pch = 4, col = color) {
    dssetm <- list();
    rang <- list();
    # BOGUS: not generic code, dsset must be explicity passed as a list().
    for (s in dsset) {
        sm <- get_ci(s);

        dssetm[[length(dssetm) + 1]] <- sm;

        rang[[length(rang) + 1]] <- range(sm$data$Upper);
        rang[[length(rang) + 1]] <- range(sm$data$Mean);
        rang[[length(rang) + 1]] <- range(sm$data$Lower);

    }

    ylim <- range(rang) * 1.05;
    for (s in dssetm) {
        par(new = TRUE);
        plot_series(s$data, col = col, pch = pch, ylim = ylim);
        color <<- color + 1
        col = color
    }

    dssetm
}

##
# Prepare the device for plotting.
setup_plot <- function(output_file) {
    if (!is.null(output_file)) {
        pdf(output_file, width = 10.5, height = 6.75);
    }

    # set margin extra space for y-right label:
    #       adding size to another y axis at right-hand side.
    #       resize margin at right-hand side, default was c(5,4,4,2)+.1
    par(mar = c(5, 4, 4, 5) + .1, lwd = 2);
    # produce a blank plot.
    plot(1, type="n", axes=F, xlab="", ylab="");
    color <<- 1;

}

##
#  Compute the maximum number of rows in the series. The number of rows
#    represents the samples of values in time.
compute_xlim <- function(s1 = NULL, s2 = NULL) {
    lengths = NULL

    for (s in c(s1, s2)) {
        lengths = c(lengths, nrow(s));
    }

    c(0, max(lengths))
}

##
# Plot two set of series (datasets)
#
# BOGUS: pch has two default values, the best solution is to be a set of values
#        just like palette.
# BOGUS: assume number of replicas is the same for both left and right values.
# BOGUS: assume the x-axis limit is maximum number of lines from the series.
#
plotyy <- function(
                    y_left_values = NULL,
                    y_right_values = NULL,
                    pch = c(4, 5),
                    title = "title = Top of the graph",
                    subtitle = "subtitle = Below the x-axis legend",
                    xlab = "xlab = Sample time (seconds)",
                    yleft = "yleft = y at left-hand side",
                    yright = "yright = y at right-hand side",
                    xleg = "topleft",
                    yleg = NULL,
                    leglabels = NULL,
                    output_file = NULL,
                    smooth = FALSE
                    ) {
    if (is.null(y_left_values) && is.null(y_right_values)) {
        return();
    }

    plotyy.smooth <<- smooth;
    xlim <<- compute_xlim(y_left_values, y_right_values);
    setup_plot(output_file);
    response <- list("left" = NULL, "right" = NULL);

    if (!is.null(y_left_values)) {
        left_means <- series_set_plot(y_left_values, pch = pch[1]);
        nr <- left_means[[1]]$replicas;
        response$left <- left_means;
        # side = 2 -> left
        axis(side = 2);
        # annotation
        mtext(yleft, side = 2, line = 3);
    }

    if (!is.null(y_right_values)) {
        right_means <- series_set_plot(y_right_values, pch = pch[2]);
        nr <- right_means[[1]]$replicas;
        response$right <- right_means;
        # side = 4 -> right
        axis(side = 4);
        #annotation
        mtext(yright, side = 4, line = 3);
    }

    # set x-axis
    axis(1);
    grid();
    # annotations
    title(main = title,
          sub = paste0(subtitle, " (number of replicas = ", nr, ")"),
          xlab = xlab);
    # legend
    if (!is.null(leglabels)) {
        n_left_values = length(y_left_values);
        n_rigth_values = length(y_right_values);
        legend(x = xleg, y = yleg, lwd = 2,
               pch =  c(rep(pch[1], n_left_values), rep(pch[2], n_rigth_values)),
               col = palette()[1:(n_left_values + n_rigth_values)],
               legend = leglabels);
    }

    # flush i/o graph
    if (!is.null(output_file)) {
        dev.off();
    }

    response
}

plot_csv <- function(fname, ...) {
  csv = read.csv(fname, header = FALSE)
  r = plotyy(list(csv), ...)
}

setup <- function() {
    palette_setup();
    color <<- 1;
    xlim <<- NULL;
    plotyy.smooth <<- FALSE;
}

setup();


#  pth percentile
L <- 33.75
n <- 100
cfb <- 82
f90 <- 11
w <-2.5
P<-L+(w/f90)*(0.9*n-cfb)
print(P)


#################################
###########
# The following VIF function were extracted from
# https://beckmw.wordpress.com/2013/02/05/collinearity-and-stepwise-vif-selection/
###########
###########

vif_func<-function(in_frame,thresh=10,trace=T,...){

  if(class(in_frame) != 'data.frame') in_frame<-data.frame(in_frame)

  #get initial vif value for all comparisons of variables
  vif_init<-NULL
  var_names <- names(in_frame)
  for(val in var_names){
    regressors <- var_names[-which(var_names == val)]
    form <- paste(regressors, collapse = '+')
    form_in <- formula(paste(val, '~', form))
    vif_init<-rbind(vif_init, c(val, VIF(lm(form_in, data = in_frame, ...))))
  }
  vif_max<-max(as.numeric(vif_init[,2]))

  if(vif_max < thresh){
    if(trace==T){ #print output of each iteration
      prmatrix(vif_init,collab=c('var','vif'),rowlab=rep('',nrow(vif_init)),quote=F)
      cat('\n')
      cat(paste('All variables have VIF < ', thresh,', max VIF ',round(vif_max,2), sep=''),'\n\n')
    }
    return(var_names)
  }
  else{

    in_dat<-in_frame

    #backwards selection of explanatory variables, stops when all VIF values are below 'thresh'
    while(vif_max >= thresh){

      vif_vals<-NULL
      var_names <- names(in_dat)

      for(val in var_names){
        regressors <- var_names[-which(var_names == val)]
        form <- paste(regressors, collapse = '+')
        form_in <- formula(paste(val, '~', form))
        vif_add<-VIF(lm(form_in, data = in_dat, ...))
        vif_vals<-rbind(vif_vals,c(val,vif_add))
      }
      max_row<-which(vif_vals[,2] == max(as.numeric(vif_vals[,2])))[1]

      vif_max<-as.numeric(vif_vals[max_row,2])

      if(vif_max<thresh) break

      if(trace==T){ #print output of each iteration
        prmatrix(vif_vals,collab=c('var','vif'),rowlab=rep('',nrow(vif_vals)),quote=F)
        cat('\n')
        cat('removed: ',vif_vals[max_row,1],vif_max,'\n\n')
        flush.console()
      }

      in_dat<-in_dat[,!names(in_dat) %in% vif_vals[max_row,1]]

    }

    return(names(in_dat))

  }

}


# Load data
library(rtdists)
data(speed_acc)

# See which priors you can set for this model
get_prior(rt ~ condition + (1|id), speed_acc, family = shifted_lognormal())

# Define them
prior = c(
  set_prior('normal(-1, 0.5)', class = 'Intercept'),  # around exp(-1) = 0.36 secs
  set_prior('normal(0.4, 0.3)', class = 'sigma'),  # SD of individual rts in log-units
  set_prior('normal(0, 0.3)', class = 'b'),  # around exp(-1) - exp(-1 + 0.3) = 150 ms effect in either direction
  set_prior('normal(0.3, 0.1)', class = 'sd')  # some variability between participants
)

data_plot = filter(data, id %in% c(1, 8, 15))

ggplot(data_plot, aes(x=rt)) +
  geom_histogram(aes(fill=condition), alpha=0.5, bins=60) +
  facet_grid(~id) +  # One panel per id
  coord_cartesian(xlim=c(0, 1.6))  # Zoom in

# Remove bad trials
library(tidyverse)
data = speed_acc %>%
  filter(rt > 0.18, rt < 3) %>%  # Between 180 and 3000 ms
  mutate_at(c('stim_cat', 'response'), as.character) %>%  # from factor to char
  filter(response != 'error', stim_cat == response) # Only correct responses

library(brms)
fit = brm(formula = bf(rt ~ congruent + trial_no + bad_lag1 + (congruent|id) + (1|counterbalancing)),
          data = data,
          family = shifted_lognormal(),
          file = 'fit_slog')  # Save all that hard work.

pp_check(fit)
summary(fit)  # See parameters


pitman_yor = function(n, a, b) {
  bundle = rbeta(1, 1 - a, b + a)
  for (j in seq(n)) {
    bundle = snap(bundle, a, b, j + 1)
  }
  bundle
  }

snap = function(acc, a, b, k) {
  v = rbeta(1, 1 - a, b + k * a)
  p = v * (1 - sum(acc))
  c(acc, p)
  }


# Negative log-likelihood component for the tag-recapture data
# (using Gauss-Hermite quadrature) and assuming a lognormal distn for A.

# Assumes data is in a matrix with columns: l1, l2, t1, t2, measr
# where l1=release length
#       l2=recapture length
#       t1=release time (in julian time since Jan 1 of reference year)
#       t2=recapture time (in julian time since Jan 1 of reference year)
#       measr=0 if recapture length measured by a scientist
#            =1 if recapture length measured by a fisherman

# Assumes parameters are: mu.L, sig.L, param.f, mu.logA, sig.logA, sig.s, sig.f
# where param.f is parameters of growth function, mu.logA and sig.logA are
# parameters of the log normal distribution for A, sig.s is the error variance
# for scientists, and sig.f is the error variance for fisherman.

# The log density of the age-at-tagging  must be specified in a function
# logdensA.f(a,param.A)

# The errors are specified in the function error.ssnl.f

            #------------------------------------------------#

log.lognormA.f<- function(a,param.A)
{   # the log density of the tagging age A
    # A log-normal
    alpha.A<- param.A[1]
    beta.A<-  param.A[2]

    # a is nf x n matrix
    lna<- a
    tf<- a>0

    lna[tf]<- log(a[tf])
    lna[!tf]<- -300

    logpa<- (lna-alpha.A)/beta.A
    logpa<- -0.5*log(2*pi)-log(beta.A)-lna-0.5*logpa^2
    return(logpa)
}

lognormA.f<- function(a,param.A)
{# dlnorm only takes vectors for the first argument
    veca<- as.vector(a)

    alpha.A<- param.A[1]
    beta.A<-  param.A[2]

    tf<- a <= 0
    a[tf]<- exp(-30)

    pa<- dlnorm(veca,alpha.A,beta.A)
    pa<- matrix(pa,nrow=nrow(a),ncol=ncol(a),byrow=F)
    return(pa)
}

# The function logdensA.f() is changed if a new distribution for
# A is tried
logdensA.f<- log.lognormA.f
densA.f<-lognormA.f

error.ssnl.f<- function(capstatus,measr,param.sig)
{   # -this gives the additive error structure of the model
    # -capstatus = "release" or "recapture"
    # -measr = 0 if a scientist measured the recapture length
    #       = 1 if a fisherman measured the recapture length

    sig.s<- param.sig[1]   # s.d. for a scientiest
    sig.f<- param.sig[2]   	# this is the additional error for fishermen
    if(capstatus=="release")
       {sigma<- sig.s}
    if(capstatus=="recapture")
       {sigma<- sig.s+sig.f*measr}
    return(sigma)
}

ha.ssnl.f<- function(a,tagdat,param.g,param.sig)
{   # this calculates h(l1,l2|a)
    # it is needed as part of int.f

    # a is nf x n matrix
    tf<- a<0
    a[tf]<-0

    h<- exp(logha.ssnl.f(a,tagdat,param.g,param.sig))
    return(h)
}

logha.ssnl.f<- function(a,tagdat,param.g,param.sig)
{   # this calculates log h(l1,l2|a)
    # it is needed as part of logint.f

    # a is nf x n matrix
    tf<- a<0
    a[tf]<-0

    # retrieve the data
    l1<- tagdat[,1]
    l2<- tagdat[,2]
    t1<- tagdat[,3]
    t2<- tagdat[,4]
    measr<- tagdat[,5]

    # retrieve the growth curve parameters
    mu.L<-    param.g[1]
    sigma.L<- param.g[2]
    param.f<- param.g[3:length(param.g)]

    ucol<- matrix(1,nrow=nrow(a),ncol=1)
    urow<- matrix(1,nrow=1,ncol=ncol(a))

    a2<- a+(t2-t1)%*%urow
    f1<- growth.ssnl.f(a,param.f,t1-floor(t1))
    f2<- growth.ssnl.f(a2,param.f,t2-floor(t2))
    sigma1<- error.ssnl.f("release",measr,param.sig)
    sigma2<- error.ssnl.f("recapture",measr,param.sig)
    mu1a<- mu.L*f1
    mu2a<- mu.L*f2
    var1a<- (sigma.L*f1)^2 + sigma1^2
    var2a<- (sigma.L*f2)^2 + sigma2^2
    s12<- sqrt(var1a*var2a)
    rhoa<-  (sigma.L^2)*f1*f2/s12
    q1<- l1%*%urow-mu1a
    q2<- l2%*%urow-mu2a
    q12<- q1*q2
    q1<- q1^2/var1a
    q2<- q2^2/var2a
    q12<- q12*rhoa/s12
    q<- q1+q2-2*q12
    logh<- -log(2)-log(pi)-0.5*log(var1a)-0.5*log(var2a)-0.5*log(1-rhoa^2)
    rho<- 2*(1-rhoa^2)
    logh<- logh-q/rho
    return(logh)
}

int.ssnl.f<- function(a,tagdat,param.g,param.A,param.sig)
{   # this calculates h(l1,l2|a) p(a)
    # so that later it can be integrated
    #
    # a is a nf x n matrix, where nf=nrow(tagdat)

    pa<- densA.f(a,param.A)
    integrand<- ha.ssnl.f(a,tagdat,param.g,param.sig)*pa
    return(integrand)
}

logint.ssnl.f<- function(a,tagdat,param.g,param.A,param.sig)
{   # this calculates  -log[h(l1,l2|a) p(a)]
    # it is used in the grid search or golden section search
    # for the mode of h(l1,l2|a) p(a)
    # we search on the log scale because the log is more
    # numerically stable
    #
    # a is a nf x n matrix, where nf=nrow(tagdat)
    # tagdat is a nf x 4 matrix of variables l1,l2,t1,t2

    logpa<- logdensA.f(a,param.A)
    logha<- logha.ssnl.f(a,tagdat,param.g,param.sig)
    integrand<- logha+logpa
    return(integrand)
}

h.ssnl.f<- function(tagdat,param.g,param.A,param.sig)
{
    # This calculates  int_-\infty^\infty h(l1,l2|a) p(a) da
    # using 20-point Gauss-Hermite integration

    gms<- gstats.ssnl.f(tagdat,param.g,param.A,param.sig)
    mng<- gms[,1]
    sdg<- gms[,2]
    pdf.l1.l2<- hermite20.f(int.ssnl.f,tagdat,param.g,param.A,
        param.sig,nrow(tagdat),mng,sdg)
    return(pdf.l1.l2)
}

logl.ssnl.f<-function(param,npf,npA,tagdat)
{   # this calculates the negative log likelihood of the data

    npg<- npf+2
    param.g<- param[1:npg]
    param.A<- param[(npg+1):(npg+npA)]
    param.sig<- param[(npg+npA+1):(npg+npA+2)]

    # print(c(param.g, param.A, param.sig))

    ndata<- nrow(tagdat)
    gms<-   gstats.ssnl.f(tagdat,param.g,param.A,param.sig)
    mng<- gms[,1]
    sdg<- gms[,2]
    pdf.l1.l2<- hermite20.f(int.ssnl.f,tagdat,param.g,param.A,
		param.sig,ndata,mng,sdg)
    negloglz<- -sum(log(pdf.l1.l2))
    if(is.na(neglogl)){print(" neglogl NA ")}
    return(neglogl)
}

hermite20.f<- function(f,tagdat,param.g,param.A,param.sig,nf,mu,sigma)
 { # this carries out 20-point Gauss-Hermite integration of f(x)
   # i.e. int_-\infty^\infty f(x) dx
   # it assumes that f(x) is roughly Gaussian with mean mu and s.d. sigma
   # here f is a nfx1 vector of functions, and mu, sigma are nfx1 vectors
   #
   # tagdat is a matrix of data which comprise the second argument of f
   # param is a vector of parameters which comprise the third argument of f
   #
   x<- c(-5.3874808900112,-4.6036824495507,-3.9447640401156,-3.3478545673832,
         -2.7888060584281,-2.2549740020893,-1.7385377121166,-1.2340762153953,
         -0.7374737285454,-0.2453407083009, 0.2453407083009, 0.7374737285454,
      1.2340762153953, 1.7385377121166, 2.2549740020893, 2.7888060584281,
      3.3478545673832, 3.9447640401156, 4.6036824495507, 5.3874808900112)

   wexp<- c(0.8985919614532, 0.7043329611769, 0.6222786961914, 0.5752624428525,
            0.5448517423644, 0.5240803509486, 0.5096790271175, 0.4999208713363,
            0.4938433852721, 0.4909215006667, 0.4909215006667, 0.4938433852721,
        0.4999208713363, 0.5096790271175, 0.5240803509486, 0.5448517423644,
        0.5752624428525, 0.6222786961914, 0.7043329611769, 0.8985919614532)

   rt2<- c(1.414213562373)
   urow<- matrix(1,nrow=1,ncol=20)

   xmat<- rt2*(sigma%*%t(x))+mu%*%urow        # xmat is a nf x 20 matrix
   fx<-    f(xmat,tagdat,param.g,param.A,param.sig)

   intf<-  fx%*%wexp
   intf<- rt2*sigma*intf
   if(sum(is.na(intf))>0){print(" hermite20 NA ")}
   return(intf)
}

gridsch.f<- function(f,l,u,vmat,param.g,param.A,param.sig)
{   # gridsch.f is a grid search
    #
    # l is vector of true lower bounds
    # u is a vector of true upper bounds

    eps1<- 1e-13

    n<- 100
    urow<- matrix(1,nrow=1,ncol=(n+1))
    range<- u-l
    ind<- (0:n)
    x<- range%*%t(ind)
    x<- l%*%urow+x/n
    fx<- f(x,vmat,param.g,param.A,param.sig)
    fmax<- apply(fx,1,max)
    xmax<- fmax%*%urow
    tf<- fx >= xmax - eps1

    # if there are two minima in a row by some extraordinary chance,
    # xmax found in the following line of code will keep both
    # this is undesirable

    # xmax<- as.vector(t(x)[t(tf)])

    # the following piece of code avoids that problem
    rmax<- row(x)[tf]
    cmax<- col(x)[tf]
    tf<- (!duplicated(rmax))
    rmax<- rmax[tf]
    cmax<- cmax[tf]
    ord<- order(rmax)
    rmax<- rmax[ord]
    cmax<- cmax[ord]
    rcmax<- cbind(rmax,cmax)
    xmax<- as.vector(x[rcmax])
    if(min(cmax)==1) {print("maximum on lower bound")
                          print("rows")
                          print(rmax[cmax==1])
                          #browser()
                          cmax[cmax==1]<-2
    }
    if(max(cmax)==ncol(x)) {print("maximum on upper bound")
                          print("rows")
                          print(rmax[cmax==ncol(x)])
                          #browser()
                          cmax[cmax==ncol(x)]<-ncol(x)-1
    }
    rcmax<- cbind(rmax,cmax-1)
    a1<- as.vector(x[rcmax])
    f1<- as.vector(fx[rcmax])
    rcmax<- cbind(rmax,cmax+1)
    a3<- as.vector(x[rcmax])
    f3<- as.vector(fx[rcmax])
    return(cbind(a1,f1,xmax,fmax,a3,f3))
}

quadmax.f<- function(ahdat)
{   # we are attempting to improve the estimate of the location
    # of the maximum of a nearly quadratic function h(a)
    # ahdat = cbind(a1,h1,a2,h2,a3,h3)
    # a1 < a2 < a3
    # h2>h1 and h2>h3

    a1<- ahdat[,1]
    h1<- ahdat[,2]
    a2<- ahdat[,3]
    h2<- ahdat[,4]
    a3<- ahdat[,5]
    h3<- ahdat[,6]

    dett<-  (a1-a2)*(a3-a2)*(a3-a1)
    alpha<- ((a3-a2)^2)*(h1-h2)-((a1-a2)^2)*(h3-h2)
    beta<-  -(a3-a2)*(h1-h2)+(a1-a2)*(h3-h2)
    alpha<- alpha/dett
    beta<-  beta/dett
    mng<- a2-alpha/(2*beta)
    sdg<- sqrt(-1/(2*beta))
    return(cbind(mng,sdg))
}

gstats.ssnl.f<- function(tagdat,param.g,param.A,param.sig)
{   qt1<- 0.001
    qt2<- 15

    l<- matrix(rep(qt1,nrow(tagdat)),ncol=1)
    u<- matrix(rep(qt2,nrow(tagdat)),ncol=1)

    aa<- gridsch.f(logint.ssnl.f,l,u,tagdat,param.g,param.A,param.sig)
    brk<-0
    for(i in (1:10))
       {ms<- quadmax.f(aa)

	# we need to make sure that the mng values have stabilised
	# if it has we break out
	if(i>3)
	   {stdiff<- abs((ms[,1]-mngold)/ms[,2])
	    msd<- max(stdiff)
	    if(msd<0.2)
	    {   brk<- 1
	        break
	       }
           }

	# if not, we refine the estimates
        a2<- pmax(ms[,1],0.9*aa[,1]+0.1*aa[,5])
        a2<- pmin(a2,0.1*aa[,1]+0.9*aa[,5])
        a1<- pmin(a2,aa[,3])
        a2<- a2+aa[,3]-a1
        a1<- pmin(a1,0.1*aa[,1]+0.9*a2)
        f12<- logint.ssnl.f(cbind(a1,a2),tagdat,param.g,param.A,param.sig)
        tf<- f12[,1]<f12[,2]
        atemp<- cbind(a1,f12[,1],a2,f12[,2],aa[,5:6])
        aa<- cbind(aa[,1:2],atemp[,1:4])
        aa[tf,]<-atemp[tf,]
	mngold<- ms[,1]
       }
    if(brk==0) {assign("nits.gstats",1,where=1)
		print("max # iterations reached")}
    ms<- quadmax.f(aa)
    return(ms)
}

a.l1.l2.ssnl.f<- function(a,tagdat,param.g,param.A,param.sig)
{   # This calculates  a h(l1,l2|a) p(a)

    apa<- a*densA.f(a,param.A)
    integrand<- ha.ssnl.f(a,tagdat,param.g,param.sig)*apa
    return(integrand)
}

ahat.ssnl.f<- function(tagdat,param.g,param.A,param.sig)
{   # this estimates E[A|l1,l2] from the data
    # for given parameter values

    gms<-   gstats.ssnl.f(tagdat,param.g,param.A,param.sig)
    mng<- gms[,1]
    sdg<- gms[,2]
    mean.A<- hermite20.f(a.l1.l2.ssnl.f,tagdat,param.g,param.A,param.sig,
		nrow(tagdat),mng,sdg)
    pdf.l1.l2<- h.ssnl.f(tagdat,param.g,param.A,param.sig)
    mean.A<- mean.A/pdf.l1.l2
    return(mean.A)
}

linfhat.a.ssnl.f<- function(a,tagdat,param.g,param.A,param.sig)
{	# this calculates E[linf|l1,l2,a]

	l1<-	tagdat[,1]
	l2<- 	tagdat[,2]
	t1<-	tagdat[,3]
	t2<- 	tagdat[,4]
	measr<- tagdat[,5]

	mu.L<-		param.g[1]
	sig.L<-	param.g[2]
	param.f<- param.g[3:length(param.g)]

	ucol<- matrix(1,nrow=nrow(a),ncol=1)
  	urow<- matrix(1,nrow=1,ncol=ncol(a))
  	a2<- a+(t2-t1)%*%urow
  	f1<- growth.ssnl.f(a,param.f,t1-floor(t1))
  	f2<- growth.ssnl.f(a2,param.f,t2-floor(t2))
	sig1<- 	error.ssnl.f("release",measr,param.sig)
   	sig2<- 	error.ssnl.f("recapture",measr,param.sig)

	denom<- sig1^2*sig2^2 + sig.L^2*(sig1^2*f2^2 + sig2^2*f1^2)
	numer<- sig2^2*f1*(l1 - mu.L*f1) + sig1^2*f2*(l2 - mu.L*f2)
	linfhat.a<- mu.L + sig.L^2*numer/denom

	return(linfhat.a)
}

linf.int.ssnl.f<- function(a,tagdat,param.g,param.A,param.sig)
{	# this calculates E[linf|l1,l2,a]*h(l1,l2|a)*p(a)

	integrand<- linfhat.a.ssnl.f(a,tagdat,param.g,param.A,param.sig)*
		ha.ssnl.f(a,tagdat,param.g,param.sig)*densA.f(a,param.A)
}

linfhat.ssnl.f<-function(tagdat,param.g,param.A,param.sig)
{ 	# this estimates E[Linf|l1,l2] from the data
  	# for given parameter values

	gms<-   gstats.ssnl.f(tagdat,param.g,param.A,param.sig)
   	mng<- gms[,1]
   	sdg<- gms[,2]
	mean.linf<- hermite20.f(linf.int.ssnl.f,tagdat,param.g,param.A,
		param.sig,nrow(tagdat),mng,sdg)
	pdf.l1.l2<- h.ssnl.f(tagdat,param.g,param.A,param.sig)
	mean.linf<- mean.linf/pdf.l1.l2
   return(mean.linf)
}


######################################################################################################
# Mark Cembrowski, Janelia Farm, Sept 13 2015
#
# This script plots the number of enriched genes as a function of fold change for two datasets.
#
# 100415: edited to work for count data.
#
# OPTIONAL INPUTS:
# fpkmThres=10: variable.  Threshold for cutting off genes.
# rMax=-1: variable.  Maximum y value on rendered graph.
#
######################################################################################################

enrichmentVsFold <- function(popA,popB,fpkmThres=10,cpmThres=20,doFpkm=T,rMax=-1){
	# Retrieve all values.
	if(doFpkm){
		theMat <- fpkmPoolMat
		theThres <- fpkmThres
	}else{
		theMat <- cpmPoolMat
		theThres <- cpmThres
	}

	aEnr <- .getFoldDiff(theMat,popA,popB,theThres)
	bEnr <- .getFoldDiff(theMat,popB,popA,theThres)
	abEnr <- aEnr
	abEnr$yAxis <- abEnr$yAxis + bEnr$yAxis
	abEnr$yAxisNorm <- abEnr$yAxis/(abEnr$yAxis[1])*100

	# Do a plot for two lines for each comparison (e.g., one line for dosally-enriched transcripts
	# and one line for ventrally-enriched transcripts).
	plotOut <- ggplot(aEnr,aes_string(x='xAxis',y='yAxis'))
	plotOut <- plotOut + geom_line(colour='green')
	plotOut <- plotOut + geom_line(data=bEnr,aes_string(x='xAxis',y='yAxis'),colour='purple')
	plotOut <- plotOut + geom_line(data=abEnr,aes_string(x='xAxis',y='yAxis'),colour='black')
	plotOut <- plotOut + labs(x='Fold change',y='Number of genes')
	if(rMax<0){
		plotOut <- plotOut + ylim(c(0,abEnr$yAxis[1]))
	}else{
		plotOut <- plotOut + ylim(c(0,rMax))
	}
	plotOut <- plotOut + theme_bw()
	print(plotOut)

}

# Single-serving function filtering the original FPKM matrix.
.getFoldDiff <- function(fpkmMat,sampleX,sampleY,fpkmThres){
	procMat <- fpkmMat[,c(sampleX,sampleY)]
	toFilt <- procMat[,1]>fpkmThres
	print(paste(sum(toFilt),'of',nrow(procMat),'passed threshold'))

	procMat <- procMat[toFilt,]

	foldMat <- procMat[,1] / procMat[,2]

	xHigh <- 10
	xAxis <- 3:xHigh
	yAxis <- xAxis*0
	for (ii in 1:length(xAxis)){
		curX <- xAxis[ii]
		curY <- round(sum(foldMat>curX))
		yAxis[ii] <- curY
	}
	yAxisNorm <- yAxis/yAxis[1]*100

	outList <- data.frame(xAxis,yAxis,yAxisNorm)

	return(outList)
}


source('gibbs.r')

run.example <- function(dataset=c('iris', 'geyser')){
  dataset <- match.arg(dataset)

  if(dataset == 'iris'){
    data(iris)
    A <- t(iris[,1:4])
    z_init <- sample(10, dim(A)[2], replace=TRUE) # random initialization
    #z_init <- rep(1, dim(A)[2]) # uniform initialization
  }
  if(dataset == 'geyser'){
    data(geyser)
    A <- t(geyser)
    z_init <- sample(2, dim(A)[2], replace=TRUE) # random initialization
  }

  # Run
  res <- gibbs(A, z_init=z_init, iters=1000)

  # plot traces
  traces <- res$traces
  chains <- mcmc(traces)
  plot(chains)
}

set.seed(2)
run.example(dataset='geyser')


#grupo Javier Olazábal - Sebastián Chávarry - Fabrizio figari - Fiorella Valdivia

#funcion normalizar
normalize<-function(val , data , n){
  return((as.numeric(val) - as.numeric(min(data[,n]))) / (as.numeric(max(data[,n]))- as.numeric(min(data[,n]))))
}

#se categoriza data no, sometimes, frequently, always
CategoricData <- function(value) {
  if(value == 'no'){
    return(0)}
  else if(value == 'Sometimes'){
    return(0.3333)
  }else if(value == 'Frequently'){
    return(0.6666)
  }else if(value == 'Always'){
    return(1)
  }else{
    print("error")
    return(-1)
  }
}

#se categoriza data walking,bike, pt, motorbike, automobile
TransData <- function(value) {
  if(value == 'Walking'){
    return(0)}
  else if(value == 'Bike'){
    return(0.25)
  }else if(value == 'Public_Transportation'){
    return(0.5)
  }else if(value == 'Motorbike'){
    return(0.75)
  }else if(value == 'Automobile'){
    return(1)
  }else{
    print("error")
    return(-1)
  }
}

#funcion calcular distancia
calcDist <- function(persona , data){
  #vector donde se va a almacenar la diferencia de la distancia del dataframe con persona
  #y el tipo de peso que le corresponde
  tipo <- c()
  distancia <- c(numeric())

  for (i in 1:nrow(data)){
    dist = 0
    #genero
    if(data[i,1] != persona[1]) dist = dist + 1
    #edad
    dist = dist + (normalize(persona[2], data , 2) - normalize(data[i,2], data, 2))^2
    #altura
    dist = dist + (normalize(persona[3], data , 3) - normalize(data[i,3], data, 3))^2
    #peso
    dist = dist + (normalize(persona[4], data , 4) - normalize(data[i,4], data, 4))^2
    #family history
    if(data[i,5] != persona[5]) dist = dist + 1
    #FAVC
    if(data[i,6] != persona[6]) dist = dist + 1
    #FCVC
    dist = dist + (normalize(persona[7], data , 7) - normalize(data[i,7], data, 7))^2
    #NCP
    dist = dist + (normalize(persona[8], data , 8) - normalize(data[i,8], data, 8))^2
    #caec
    dist = dist + (CategoricData(persona[9]) - CategoricData(data[i,9]))^2
    #smoke
    if(data[i,10] != persona[10]) dist = dist + 1
    #ch20
    dist = dist + (normalize(persona[11], data , 11) - normalize(data[i,11], data, 11))^2
    #SCC
    if(data[i,12] != persona[12]) dist = dist + 1
    #faf
    dist = dist + (normalize(persona[13], data , 13) - normalize(data[i,13], data, 13))^2
    #TUE
    dist = dist + (normalize(persona[14], data , 14) - normalize(data[i,14], data, 14))^2
    #calc
    dist = dist + (CategoricData(persona[15]) - CategoricData(data[i,15]))^2
    #mtrans
    dist = dist + (TransData(persona[16]) - TransData(data[i,16]))^2

    dist = sqrt(dist)
    #almacenao la data para dist y el tipo en vectores
    distancia = c(distancia, as.double(dist))
    tipo = c(tipo,data[i,17])

  }
  distXtipo <- matrix(c(distancia,tipo),nrow = 2111,ncol = 2)
  distXtipo = distXtipo[order(distXtipo[,1]),]
  return(distXtipo)
}

#algoritmo knn
knn <- function(k , distXtipo)
{
  cadena = ""
  index = 1
  max = 0
  flag = FALSE

  #vector (usado como dicc) para asociar los tipos de obesidad mas cercanos
  #ejemplo de dibujo de diccionario
  diccTipos <- c("Normal_Weight" = 0 , "Overweight_Level_I" = 0, "Overweight_Level_II" = 0 , "Obesity_Type_III" = 0,
                 "Obesity_Type_II" = 0 , "Obesity_Type_I" = 0, "Insufficient_Weight" = 0)

  while (k > 0)
  {
    diccTipos[distXtipo[index,2]] <- diccTipos[distXtipo[index,2]] + 1
    index = index + 1
    k = k - 1
    #si ya no quedan m�s vecinos por recorrer
    #cuando el dicc esta completo
    if(k == 0)
    {
      for(i in 1:(length(diccTipos) - 1 ))
      {
        value = diccTipos[i]
        if(max < value){
          cadena = names(value)
          max = value
          flag = FALSE
        }
        else if (max == value){
          flag = TRUE
        }
      }
      #Si la moda se repite en 2 tipos de datos entonces
      #aumentamos en 1 el k
      if (flag == TRUE)
      {
        k = k + 1
      }
    }
  }
  return(cadena)
}

crear_persona <- function()
{

  while (TRUE)
  {
    gender <- as.integer(readline(writeLines("Cual es su genero?\nOPCIONES:\n(0) Masculino\n(1) Femenino ")))
    if (gender == 0) {
      gender <- "Male"
      break
    }
    else if (gender == 1) {
      gender <- "Female"
      break
    }
    else
    {
      print("Ingresar un valor dentro de las opciones")
    }
  }

  age <- as.integer(readline("Cual es su edad?: \n"))

  height <-as.double(readline("Cual es su altura en metros?: \n"))

  weight <-as.double(readline("Cual es su peso en kg?: \n"))

  while (TRUE)
  {
    family_overweight <-as.integer(readline(writeLines("En su familia alguien sufre o ha sufrido de sobrepeso?\nOPCIONES:\n(0) SI\n(1) NO ")))
    if (family_overweight == 0) {
      family_overweight <- "yes"
      break
    }
    else if (family_overweight == 1) {
      family_overweight <- "no"
      break
    }
    else
    {
      print("Ingresar un valor dentro de las opciones")
    }
  }

  while (TRUE)
  {
    favc  <- as.integer(readline(writeLines("Come comida alta en calorias frecuentemente?\nOPCIONES:\n(0) SI\n(1) NO ")))
    if (favc == 0) {
      favc <- "yes"
      break
    }
    else if (favc == 1) {
      favc <- "no"
      break
    }
    else
    {
      print("Ingresar un valor dentro de las opciones")
    }
  }

  while (TRUE)
  {
    fcvc  <-as.integer(readline(writeLines("Come vegetales en su comida?\nOPCIONES:\n(0) Nunca\n(1) A veces\n(2) Siempre? ")))
    if (fcvc == 0)
    {
      fcvc <- 1
      break
    }
    else if (fcvc == 1) {
      fcvc <- 2
      break
    }
    else if (fcvc == 2) {
      fcvc <- 3
      break
    }
    else
    {
      print("Ingresar un valor dentro de las opciones")
    }
  }

  while (TRUE)
  {
    ncp  <-as.integer(readline(writeLines("Cuantas comidas principales ingiere en el dia?\nOPCIONES:\nINgrese un n�mero entre 1-4")))
    if (ncp >= 1 | ncp <=4){
      break
    }
    else
    {
      print("Ingresar un valor dentro de las opciones")
    }
  }

  while (TRUE)
  {
    caec  <- as.integer(readline(writeLines("Come algo durante sus comidas? \nOPCIONES:\n(0) Nunca\n(1) A veces\n(2) Frecuentemente\n(3) Siempre ")))
    if (caec == 0) {
      caec <- "no"
      break
    }
    else if (caec == 1) {
      caec <- "Sometimes"
      break
    }
    else if (caec == 2) {
      caec <- "Frequently"
      break
    }
    else if (caec == 3) {
      caec <- "Always"
      break
    }
    else
    {
      print("Ingresar un valor dentro de las opciones")
    }
  }

  while (TRUE)
  {
    smoke <- as.integer(readline(writeLines("Usted fuma?\n OPCIONES:\n(0) SI\n(1) NO ")))
    if (smoke == 0) {
      smoke <- "yes"
      break
    }
    else if (smoke == 1) {
      smoke <- "no"
      break
    }

    else
    {
      print("Ingresar un valor dentro de las opciones")
    }
  }

  while (TRUE)
  {
    ch20 <-as.integer(readline(writeLines("Cuanta agua bebe al dia?\nOPCIONES:\n(0) Menos de 1 litro\n(1) Entre 1 y 2 litros\n(2) Mas de 2 litros ")))

    if (ch20 == 0)
    {
      ch20 <- 1
      break
    }
    else if (ch20 == 1) {
      ch20 <- 2
      break
    }
    else if (ch20 == 2) {
      ch20 <- 3
      break
    }

    else
    {
      print("Ingresar un valor dentro de las opciones")
    }
  }

  while (TRUE)
  {
    scc <-as.integer(readline(writeLines("Monitorea sus calorias diariamente?\nOPCIONES:\n(0) SI\n(1) NO ")))
    if (scc == 0) {
      scc <- "yes"
      break
    }
    else if (scc == 1) {
      scc <- "no"
      break
    }
    else
    {
      print("Ingresar un valor dentro de las opciones")
    }
  }

  while (TRUE)
  {
    faf <-as.integer(readline(writeLines("Cuantas veces a la semana hace actividad fisica?\nOPCIONES:\n(0) Nunca\n(1) 1 o 2 dias\n(2) 2 o 4 dias\n(3) 4 o 5 dias ")))
    if (faf == 0 | faf == 1 | faf== 2 | faf== 3) {
      break
    }

    else
    {
      print("Ingresar un valor dentro de las opciones")
    }
  }

  while (TRUE)
  {
    tue <-as.integer(readline(writeLines("Cuanto tiempo usa aparatos tecnologicos?\nOPCIONES:\n(0) 0 a 2 horas\n(1) 3 a 5 horas\n(2) Mas de 5 horas ")))
    if (tue == 0 | tue == 1 | tue== 2) {
      break
    }

    else
    {
      print("Ingresar un valor dentro de las opciones")
    }
  }

  while (TRUE)
  {
    calc <-as.integer(readline(writeLines("Que tan amenudo ingiere alcohol?\nOPCIONES:\n(0) Nunca\n(1) A veces\n(2) Frecuentemente\n(3) Siempre ")))
    if (calc == 0) {
      calc <- "no"
      break
    }
    else if (calc == 1) {
      calc <- "Sometimes"
      break
    }
    else if (calc == 2) {
      calc <- "Frequently"
      break
    }
    else if (calc == 3) {
      calc <- "Always"
      break
    }
    else
    {
      print("Ingresar un valor dentro de las opciones")
    }
  }

  while (TRUE)
  {
    mtran <-as.integer(readline(writeLines("Que medio de transporte normalmente usa?\nOPCIONES:\n(0) Automovil\n(1) Motocileta\n(2) Bicicleta\n(3) Transporte publico\n(4) Caminando ")))
    if (mtran == 0) {
      mtran <- "Automobile"
      break
    }
    else if (mtran == 1) {
      mtran <- "Motorbike"
      break
    }
    else if (mtran == 2) {
      mtran <- "Bike"
      break
    }
    else if (mtran == 3) {
      mtran <- "Public_Transportation"
      break
    }
    else if (mtran == 4) {
      mtran <- "Walking"
      break
    }

    else
    {
      print("Ingresar un valor dentro de las opciones")
    }
  }

  persona = c(gender,age,height,weight,family_overweight,favc,fcvc,ncp,caec,smoke,ch20,scc,faf,tue,calc,mtran)

  return(persona)

}

#leemos el csv
data<-read.csv('data.csv')

# persona <- rep(NA, 17) <= para cuando hagamos el input
persona <- crear_persona()
#print(persona)

#persona2 <- c('Female', 15, 1.7 , 80, 'yes' , 'yes' , 2 , 2 , 'Always' , 'no' , 3 , 'yes', 0, 0, 'no','Walking')

paste("La clasificacion de la persona es:", knn(30,calcDist(persona, data)), sept= " ")


#' Fit parameters using the optim function
#'
#' @param x  design matrix of dimension ‘n * p’
#' @param y  vector of observations of length ‘n’
#' @param weights  vector of weights of length ‘n’
#' @param offset  vector of coefficient offsets of length ‘n’
#' @param control  list of control paramters, e.g. ‘maxit’
#' @param lower  vector of coefficient lower bounds
#' @param upper  vector of coefficient upper bounds
#' @param hessian  whether to return the hessian at the optimized nll
#' @param verbose  print debug messages
#' @return  named list with estimated coefficients
fit = function(x, y, weights=rep(1,nrow(x)), offset=0, control=list(),
               lower=-Inf, upper=Inf, hessian=FALSE, verbose=FALSE) {
    mod = tryCatch(error = function(e) list(converged=FALSE),
        suppressWarnings(stats::glm.fit(x, y, weights=weights, offset=offset,
                       family=stats::poisson(link=identity), control=control)))
    within_bounds = all(mod$coefficients >= lower[-length(lower)] &
                        mod$coefficients <= upper[-length(upper)])
    if (mod$converged && within_bounds)
        start = c(mod$coefficients, theta=1)
    else
        start = c(setNames(rep(1, ncol(x)), colnames(x)), theta=1)
#    start = pmin(start, upper)
#    start = pmax(start, lower)

    # @return  list with the following components:
    #   ‘par’ - best values for paramters found
    #   ‘value’ - negative log-likelihood at end of iterations
    #   ‘convergence’ - 0 if converged, other values encode condition
    #   ‘message’ - character string with additional information
    stats::optim(par=start, fn=nll, gr=gradient, method="L-BFGS-B",
        control=control, .x=x, .y=y, weights=weights, offset=offset,
        lower=lower, upper=upper, hessian=hessian, .verbose=verbose)
}


library(tidyverse)
library(readxl) # read xlsx
library(feather) # file format lib
library(skimr) # summary statistics for larger data sets
library(car)
library(nortest)
library(psych)

# Maksymilian Drzezdzon

####################
# Data Exploration #
####################

# loading data
df = read_excel('idepen_proj_stats.xlsx')
df = read_feather('idepen_proj_stats.feather')

# basic exploration
head(df)
summary(df)
glimpse(df)
colnames(df)
# how many missing values are in each col
map(df , ~sum(is.na(.)))

# looking at cols with potential problems
unique(df$PHONE)
unique(df$...10) # found potential issues

unique(df$JOB) # found potential issues
unique(df$UNIVERSITY)
unique(df$SCHOOL_NAT)
unique(df$ACADEMIC_PROGRAM)

unique(df$EDU_FATHER)
# found potential issues a field with a value of 0,
# however this could indicate something else such as an absent parent,
# it will be left as is
unique(df$OCC_FATHER) # found potential issues, ^
unique(df$EDU_MOTHER) # found potential issues, ^
unique(df$OCC_MOTHER) # found potential issues, ^
#########################
# variables of interest #
#########################

colnames(df)

# looking for odd values which can be found easily via unique, such as negative values on exams etc

unique(df$SISBEN) # found potential issues
unique(df$INTERNET)
unique(df$TV)
unique(df$COMPUTER)
unique(df$WASHING_MCH)
unique(df$CAR)
unique(df$MIC_OVEN)
unique(df$DVD)
unique(df$FRESH)
unique(df$PHONE)
unique(df$MOBILE)

# Saber 11 EXAMS - no issues found
unique(df$MAT_S11) # maths
unique(df$CR_S11) # critical reading
unique(df$CC_S11) # citizen competencies
unique(df$BIO_S11) # biology
unique(df$ENG_S11) # communication in English

# SABER PRO EXAMS - no issues found
unique(df$CR_PRO) # critical reading
unique(df$QR_PRO) # quantitative reasoning
unique(df$CC_PRO) # citizen competencies
unique(df$WC_PRO) # written communication
unique(df$ENG_PRO) # communication in English

#################
# Data Cleaning #
#################

# column is completely empty and serves no purpose
df = df[,!names(df) %in% c("...10")]

# fixing inconsistency
df$SISBEN[df$SISBEN == "It is not classified by the SISBEN"] = "Level NA"
df$SISBEN[df$SISBEN == "Esta clasificada en otro Level del SISBEN"] = "Level NA"

df$SISBEN[df$SISBEN == "Level NA"] = 0
df$SISBEN[df$SISBEN == "0"] = 0
df$SISBEN[df$SISBEN == "Level 1"] = 1
df$SISBEN[df$SISBEN == "Level 2"] = 2
df$SISBEN[df$SISBEN == "Level 3"] = 3

df$JOB[df$JOB == "0"] = "No"

df$INTERNET[df$INTERNET == "Yes"] = 1
df$INTERNET[df$INTERNET == "No"] = 0

df$TV[df$TV == "Yes"] = 1
df$TV[df$TV == "No"] = 0

df$COMPUTER[df$COMPUTER == "Yes"] = 1
df$COMPUTER[df$COMPUTER == "No"] = 0

df$WASHING_MCH[df$WASHING_MCH == "Yes"] = 1
df$WASHING_MCH[df$WASHING_MCH == "No"] = 0

df$MIC_OVEN[df$MIC_OVEN == "Yes"] = 1
df$MIC_OVEN[df$MIC_OVEN == "No"] = 0

df$CAR[df$CAR == "Yes"] = 1
df$CAR[df$CAR == "No"] = 0

df$DVD[df$DVD == "Yes"] = 1
df$DVD[df$DVD == "No"] = 0

df$FRESH[df$FRESH == "Yes"] = 1
df$FRESH[df$FRESH == "No"] = 0

df$PHONE[df$PHONE == "Yes"] = 1
df$PHONE[df$PHONE == "No"] = 0

df$MOBILE[df$MOBILE == "Yes"] = 1
df$MOBILE[df$MOBILE == "No"] = 0

# saving file into feather while working on project
# it offers faster load times, however its not used
# to store data long term
write_feather(df, 'idepen_proj_stats.feather')
df = read_feather('idepen_proj_stats.feather')

#########################
# Testing for normality #
#########################

# fragmenting data
df_pro_exams =  data.frame(df$CR_PRO, df$QR_PRO, df$CC_PRO, df$WC_PRO, df$ENG_PRO)
summary(df_pro_exams)
# anderson-darling normality test is used over shapiro-wilks
# because it has a limitation of 5000 records
# for comparison both give the same result
shapiro.test(df_pro_exams$df.CR_PRO[0:5000])
ad.test(df_pro_exams$df.CR_PRO)
ad.test(df_pro_exams$df.QR_PRO)
ad.test(df_pro_exams$df.CC_PRO)
ad.test(df_pro_exams$df.WC_PRO)
ad.test(df_pro_exams$df.ENG_PRO)
# p < 2.2e-16
qqPlot(df_pro_exams$df.CR_PRO, ylab = "critical reading exam scores")
qqPlot(df_pro_exams$df.QR_PRO, ylab = "quantitative reasoning exam scores")
qqPlot(df_pro_exams$df.CC_PRO, ylab = "citizen competencies exam scores")
qqPlot(df_pro_exams$df.WC_PRO, ylab = "written communication exam scores")
qqPlot(df_pro_exams$df.ENG_PRO, ylab = "communication in English exam scores")

hist(df_pro_exams$df.CR_PRO, xlab = "critical reading exam scores")
hist(df_pro_exams$df.QR_PRO, xlab = "quantitative reasoning exam scores")
hist(df_pro_exams$df.CC_PRO, xlab = "citizen competencies exam scores")
hist(df_pro_exams$df.WC_PRO, xlab = "written communication exam scores")
hist(df_pro_exams$df.ENG_PRO, xlab = "communication in English exam scores")

Boxplot(df_pro_exams$df.CR_PRO, ylab = "critical reading exam scores")
Boxplot(df_pro_exams$df.QR_PRO, ylab = "quantitative reasoning exam scores")
Boxplot(df_pro_exams$df.CC_PRO, ylab = "citizen competencies exam scores")
Boxplot(df_pro_exams$df.WC_PRO, ylab = "written communication exam scores")
Boxplot(df_pro_exams$df.ENG_PRO, ylab = "communication in English exam scores")

# from the visualizations, p-value and a-value the pro exams are NOT normally distributed

df_saber_exams =  data.frame(df$MAT_S11, df$CR_S11, df$CC_S11, df$BIO_S11, df$ENG_S11)
summary(df_saber_exams)

ad.test(df_saber_exams$df.MAT_S11)
ad.test(df_saber_exams$df.CR_S11)
ad.test(df_saber_exams$df.CC_S11)
ad.test(df_saber_exams$df.BIO_S11)
ad.test(df_saber_exams$df.ENG_S11)
# p < 2.2e-16

hist(df_saber_exams$df.MAT_S11, xlab = "maths exam scores")
hist(df_saber_exams$df.CR_S11, xlab = "critical reading exam scores")
hist(df_saber_exams$df.CC_S11, xlab = "citizen competencies exam scores")
hist(df_saber_exams$df.BIO_S11, xlab = "biology exam scores")
hist(df_saber_exams$df.ENG_S11, xlab = "communication in English exam scores")

boxplot(df_saber_exams$df.MAT_S11, ylab = "Maths Exam scores exam scores")
boxplot(df_saber_exams$df.CR_S11, ylab = "critical reading exam scores")
boxplot(df_saber_exams$df.CC_S11, ylab = "citizen competencies exam scores")
boxplot(df_saber_exams$df.BIO_S11, ylab = "biology exam scores")
boxplot(df_saber_exams$df.ENG_S11, ylab = "communication in English exam scores")

# even though the p value in normality test doesnt confirm normality, the low A value and
# visualizations confirm a normally distribution

# testing
df_sisben = sapply(df_sisben, as.double)
glimpse(df_sisben)

df_sisben =  data.frame(df$SISBEN, df$INTERNET, df$TV, df$COMPUTER, df$WASHING_MCH, df$CAR, df$MIC_OVEN, df$DVD, df$FRESH, df$PHONE, df$MOBILE)

help("hist")
barplot(as.numeric(df_sisben$df.SISBEN), breaks=5)
hist(as.numeric(df_sisben$df.INTERNET), breaks=2)
hist(df_sisben$df.TV)
hist(df_sisben$df.COMPUTER)
hist(df_sisben$df.WASHING_MCH)

#######################
# Dimension Reduction #
#######################
prepare_matrix_data = df[,!names(df) %in% c("ACADEMIC_PROGRAM", "UNIVERSITY", "Cod_SPro",
                                            "SCHOOL_TYPE", "SCHOOL_NAT", "SCHOOL_NAME",
                                            "JOB", "REVENUE", "OCC_MOTHER",
                                            "OCC_FATHER", "EDU_MOTHER", "EDU_FATHER", "COD_S11",
                                            "GENDER", "PEOPLE_HOUSE", "STRATUM",
                                            "SEL", "SEL_IHE", "QUARTILE", "2ND_DECILE",
                                            "WC_PRO", "PERCENTILE", "G_SC")]

prepare_matrix_data_tests = df[,!names(df) %in% c("ACADEMIC_PROGRAM", "UNIVERSITY", "Cod_SPro",
                                                  "SCHOOL_TYPE", "SCHOOL_NAT", "SCHOOL_NAME",
                                                  "JOB", "REVENUE", "OCC_MOTHER",
                                                  "OCC_FATHER", "EDU_MOTHER", "EDU_FATHER", "COD_S11",
                                                  "GENDER", "PEOPLE_HOUSE", "STRATUM", "INTERNET",
                                                  "TV", "COMPUTER", "WASHING_MCH", "MIC_OVEN",
                                                  "CAR", "DVD", "FRESH", "PHONE", "MOBILE",
                                                  "SEL", "SEL_IHE", "QUARTILE", "2ND_DECILE",
                                                  "WC_PRO", "PERCENTILE", "G_SC")]

glimpse(prepare_matrix_data)
glimpse(prepare_matrix_data_tests)

tests_matrix = sapply(prepare_matrix_data_tests, as.double)
matrix_data = sapply(prepare_matrix_data, as.double)
heatmap(cor(tests_matrix), Rowv = NA, Colv = NA)
heatmap(cor(matrix_data), Rowv = NA, Colv = NA)

cortest.bartlett(cor(tests_matrix), n=nrow(prepare_matrix_data_tests))
cortest.bartlett(cor(matrix_data), n=nrow(prepare_matrix_data))

result = corrplot::cor.mtest(cor(matrix_data), conf.level = .95)
corrplot::corrplot(cor(matrix_data), method="square", p.mat = result$p, type="lower", sig.level = .05)

KMOS(tests_matrix)
KMOS(matrix_data)

help(principal)

#There are 4 factors to extract
unique(df$SISBEN)
facsol = psych::fa(matrix_data, nfactors=4, obs=NA, n.iter=1, rotate="varimax", fm="pa")

#Create your scree plot
plot(facsol$values, type = "b")

#Print the Variance accounted for by each factor/component
facsol$Vaccounted
#Output the Eigenvalues
facsol$values

#Print the components with loadings
psych::print.psych(facsol,cut=0.3, sort=TRUE)

#Print sorted list of loadings
fa.sort(facsol$loading)

#create a diagram showing the factors and how the manifest variables load
fa.diagram(facsol)

#Apply rotation to try to refine the component structure
facsolrot =  principal(matrix_data, nfactors = 4, rotate = "varimax")
#output the components
psych::print.psych(facsolrot, cut = 0.3, sort = TRUE)
#output the commonalities
facsolrot$communality

facsolrot$loadings
pre_rotation_loadings

PCA_data = sapply(prepare_matrix_data, as.double)
glimpse(PCA_data)
classes = factor(df$SISBEN)
# normalize data so larger values dont overweight smaller ones
dfPCA = prcomp(scale(PCA_data[, -1]))
# view PCA statistics
summary(dfPCA)
# this is used to see how many of the variables can be dropped and at what cost
# the cumulative proportion increases with each PC component
# for instance pc27 offers less than 1% up from pc26 making it not very useful
# you can then pick a cut off point to see how many components can be dropped

# the cut off for this analysis will be pc16-17 which allows the prediction of upto 90-92% the last 9-10 pc components only contribute 8-10%

plot(dfPCA$x, col=classes)


library(ggvis)

# Basic scatter plot
mtcars %>% ggvis(x = ~wt, y = ~mpg) %>% layer_points()

# Variable transformations
mtcars %>% ggvis(x = ~wt, y = ~wt/mpg) %>% layer_points()
mtcars %>% ggvis(x = ~factor(cyl), y = ~mpg) %>% layer_points()

# With colour
# continuous:
mtcars %>% ggvis(x = ~wt, y = ~mpg, fill = ~cyl) %>% layer_points()
# and discrete:
mtcars %>% ggvis(x = ~wt, y = ~mpg, fill = ~factor(cyl)) %>%
  layer_points()

# Use unscaled constant: 10 refers to 10 pixels from top
mtcars %>% ggvis(x = ~wt) %>%
  layer_points(y = ~mpg) %>%
  layer_points(y := 10, fill := "red")

# Use scaled constant: 10 refers to data space
mtcars %>% ggvis(x = ~wt) %>%
  layer_points(y = ~mpg) %>%
  layer_points(y = 10, fill := "red")

# Line and point graph
mtcars %>% ggvis(x = ~wt, y = ~mpg) %>%
  layer_lines() %>%
  layer_points(fill := "red")

# Two marks
mtcars %>% ggvis(x = ~wt, y = ~mpg) %>%
  layer_points() %>%
  layer_points(fill := "red", size := 25)

# Two marks at different levels of the tree, with different mappings for a
# variable
mtcars %>% ggvis(x = ~wt, y = ~mpg) %>%
  layer_points() %>%
  layer_points(fill := "red", y = ~qsec, size := 25)

# Two y scales
mtcars %>% ggvis(x = ~wt, y = ~mpg) %>%
  layer_points() %>%
  layer_points(fill := "red", prop("y", ~qsec, scale = "yq"))

# Two separate data sets, equal in the tree
mtc1 <- mtcars[1:10, ]
mtc2 <- mtcars[11:20, ]
ggvis(NULL, x = ~wt, y = ~mpg) %>%
  layer_points(stroke := "black", fill := "black", data = mtc1) %>%
  layer_points(fill := "red", size := 40, data = mtc2)

# Scatter plot with one set of points with `cyl` mapped to stroke,
# and another set with `am` mapped to fill
mtcars %>% ggvis(x = ~wt, y = ~mpg) %>%
  layer_points(stroke = ~factor(cyl), fill := NA) %>%
  layer_points(fill = ~factor(am), size := 25)

# Same as previous, but also with (useless) grouping in the layers
mtcars %>% group_by(cyl) %>%
  ggvis(x = ~wt, y = ~mpg) %>%
  layer_points(stroke = ~factor(cyl), fill := NA) %>%
  layer_points(fill = ~factor(am), size := 25)

# Use expression in a prop
pressure %>% ggvis(x = ~temperature, y = ~log(pressure)) %>% layer_points()

# Use variable from the calling environment
y_min <- min(log(pressure$pressure))
pressure %>% ggvis(x = ~temperature, y = ~log(pressure) - y_min) %>%
  layer_points()