<<<<<<< HEAD
#### Healthy Neighborhoods Project: Using Ecological Data to Improve Community Health
### Cedric subproject: Developing better ways to measure equity in health
## Florida Charts Census Tract Mortality Data: Pyhton Computing Language Code Script by DrewC!

#### Section A: Import Libraries and Datasets and Prepare Data

### Import Libraries and Data

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

## Import Hadley Wickham Libraries
library(tidyverse) # All of the libraries above in one line of code

## Import Statistics Libraries
library(ineq) # Gini coefficient and Lorenz curve
library(pROC) # ROC tests with AUC output

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

### Step 2: Prepare Data for Classificaiton

## Tidy data types and objects
df_fl = na.omit(df_fl) # Omit rows with NA from Data Frame

## Verify Data
glimpse(df_fl) # Rows, columns, variable types and 10

### Step 3: Develop Inequality Measures for Data

## Create new column as sum of others
df_fl$Vascular = df_fl$Heart.Diseases + df_fl$Cerebrovascular.Diseases +  df_fl$Essen.Hypertension...Hypertensive.Renal.Dis + df_fl$ Aortic.Aneurysm...Dissection + df_fl$Atherosclerosis  # Create new column based on conditions
df_fl$Metabolic = df_fl$Diabetes.Mellitus + df_fl$Nephritis..Nephrotic.Syndrome..Nephrosis # Create new column based on conditions
df_fl$MetaVasc = df_fl$Metabolic + df_fl$Vascular

## Group by County for internal Gini
tib_gini = df_fl %>% group_by(County) %>% summarise(ineq(Metabolic, type = "Gini")) # Group By Columns and Average
df_gini = as.data.frame(tib_gini) # Convert tiblle to Data Frame
colnames(df_gini) <- c("County", "Gini") # Change Column Names
df_gini$County = toupper(df_gini$County)

## Export County Gini Data
write.csv(df_gini, "_data/cedric_dm2_gini.csv") #clean in excel and select variable

### Step 3: Develop Inequality Measures for Data

## Create new column as sum of others
df_fl$Vascular = df_fl$Heart.Diseases + df_fl$Cerebrovascular.Diseases +  df_fl$Essen.Hypertension...Hypertensive.Renal.Dis + df_fl$ Aortic.Aneurysm...Dissection + df_fl$Atherosclerosis  # Create new column based on conditions
df_fl$Metabolic = df_fl$Diabetes.Mellitus + df_fl$Nephritis..Nephrotic.Syndrome..Nephrosis # Create new column based on conditions
df_fl$MetaVasc = df_fl$Metabolic + df_fl$Vascular

## Group by County for internal Gini
tib_gini = df_fl %>% group_by(County) %>% summarise(ineq(Vascular, type = "Gini")) # Group By Columns and Average
df_gini = as.data.frame(tib_gini) # Convert tiblle to Data Frame
colnames(df_gini) <- c("County", "Gini") # Change Column Names
df_gini$County = toupper(df_gini$County)

## Export County Gini Data
write.csv(df_gini, "_data/cedric_vasc_gini.csv") #clean in excel and select variable

### Step 3: Develop Inequality Measures for Data

## Create new column as sum of others
df_fl$Vascular = df_fl$Heart.Diseases + df_fl$Cerebrovascular.Diseases +  df_fl$Essen.Hypertension...Hypertensive.Renal.Dis + df_fl$ Aortic.Aneurysm...Dissection + df_fl$Atherosclerosis  # Create new column based on conditions
df_fl$Metabolic = df_fl$Diabetes.Mellitus + df_fl$Nephritis..Nephrotic.Syndrome..Nephrosis # Create new column based on conditions
df_fl$MetaVasc = df_fl$Metabolic + df_fl$Vascular
df_fl$Cancer = df_fl$Malignant.Neoplasm.or.Cancer

## Group by County for internal Gini
tib_gini = df_fl %>% group_by(County) %>% summarise(ineq(Cancer, type = "Gini")) # Group By Columns and Average
df_gini = as.data.frame(tib_gini) # Convert tiblle to Data Frame
colnames(df_gini) <- c("County", "Gini") # Change Column Names
df_gini$County = toupper(df_gini$County)

## Export County Gini Data
=======
#### Healthy Neighborhoods Project: Using Ecological Data to Improve Community Health
### Cedric subproject: Developing better ways to measure equity in health
## Florida Charts Census Tract Mortality Data: Pyhton Computing Language Code Script by DrewC!

#### Section A: Import Libraries and Datasets and Prepare Data

### Import Libraries and Data

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

## Import Hadley Wickham Libraries
library(tidyverse) # All of the libraries above in one line of code

## Import Statistics Libraries
library(ineq) # Gini coefficient and Lorenz curve
library(pROC) # ROC tests with AUC output

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

### Step 2: Prepare Data for Classificaiton

## Tidy data types and objects
df_fl = na.omit(df_fl) # Omit rows with NA from Data Frame

## Verify Data
glimpse(df_fl) # Rows, columns, variable types and 10

### Step 3: Develop Inequality Measures for Data

## Create new column as sum of others
df_fl$Vascular = df_fl$Heart.Diseases + df_fl$Cerebrovascular.Diseases +  df_fl$Essen.Hypertension...Hypertensive.Renal.Dis + df_fl$ Aortic.Aneurysm...Dissection + df_fl$Atherosclerosis  # Create new column based on conditions
df_fl$Metabolic = df_fl$Diabetes.Mellitus + df_fl$Nephritis..Nephrotic.Syndrome..Nephrosis # Create new column based on conditions
df_fl$MetaVasc = df_fl$Metabolic + df_fl$Vascular

## Group by County for internal Gini
tib_gini = df_fl %>% group_by(County) %>% summarise(ineq(Metabolic, type = "Gini")) # Group By Columns and Average
df_gini = as.data.frame(tib_gini) # Convert tiblle to Data Frame
colnames(df_gini) <- c("County", "Gini") # Change Column Names
df_gini$County = toupper(df_gini$County)

## Export County Gini Data
write.csv(df_gini, "_data/cedric_dm2_gini.csv") #clean in excel and select variable

### Step 3: Develop Inequality Measures for Data

## Create new column as sum of others
df_fl$Vascular = df_fl$Heart.Diseases + df_fl$Cerebrovascular.Diseases +  df_fl$Essen.Hypertension...Hypertensive.Renal.Dis + df_fl$ Aortic.Aneurysm...Dissection + df_fl$Atherosclerosis  # Create new column based on conditions
df_fl$Metabolic = df_fl$Diabetes.Mellitus + df_fl$Nephritis..Nephrotic.Syndrome..Nephrosis # Create new column based on conditions
df_fl$MetaVasc = df_fl$Metabolic + df_fl$Vascular

## Group by County for internal Gini
tib_gini = df_fl %>% group_by(County) %>% summarise(ineq(Vascular, type = "Gini")) # Group By Columns and Average
df_gini = as.data.frame(tib_gini) # Convert tiblle to Data Frame
colnames(df_gini) <- c("County", "Gini") # Change Column Names
df_gini$County = toupper(df_gini$County)

## Export County Gini Data
write.csv(df_gini, "_data/cedric_vasc_gini.csv") #clean in excel and select variable

### Step 3: Develop Inequality Measures for Data

## Create new column as sum of others
df_fl$Vascular = df_fl$Heart.Diseases + df_fl$Cerebrovascular.Diseases +  df_fl$Essen.Hypertension...Hypertensive.Renal.Dis + df_fl$ Aortic.Aneurysm...Dissection + df_fl$Atherosclerosis  # Create new column based on conditions
df_fl$Metabolic = df_fl$Diabetes.Mellitus + df_fl$Nephritis..Nephrotic.Syndrome..Nephrosis # Create new column based on conditions
df_fl$MetaVasc = df_fl$Metabolic + df_fl$Vascular
df_fl$Cancer = df_fl$Malignant.Neoplasm.or.Cancer

## Group by County for internal Gini
tib_gini = df_fl %>% group_by(County) %>% summarise(ineq(Cancer, type = "Gini")) # Group By Columns and Average
df_gini = as.data.frame(tib_gini) # Convert tiblle to Data Frame
colnames(df_gini) <- c("County", "Gini") # Change Column Names
df_gini$County = toupper(df_gini$County)

## Export County Gini Data
>>>>>>> 321eaea894d29a3f212ee3e111b86695f46cf6db
write.csv(df_gini, "_data/cedric_can_gini.csv") #clean in excel and select variable


# load package and data

library(dslabs)
data(murders)
data(movielens)

# use the function names to extract the variable names
names(murders)

# to access the population variable from the murders dataset use the following:
p <- murders$population
m <- movielens$movieid

# to determine the calss of object 'p' we use the following
class(p)
class(m)

# so if we change the population with murders the following should work
x <- murders$murders
class(x)

# this is how we would extract the population:
p <- murders$population

# this is how we would do the same with double brackets:
o <- murders[["population"]]

# this can be confirmed by doing the following:
identical (o, p )


pdf_file<-"pdf/tablecharts_treemap_2a_inc.pdf"
cairo_pdf(bg="grey98", pdf_file,width=11.69,height=7.5)

par(omi=c(0.65,0.25,1.25,0.75),mai=c(0.3,2,0.35,0),family="Lato Light",las=1)
library(treemap)
library(RColorBrewer)

# Read data and prepare chart

load("myData/hnp.RData")
daten<-subset(daten,daten$gni>0)
attach(daten)
popgni<-pop*gni
daten$popgni<-popgni
kontinente<-aggregate(cbind(pop,popgni) ~ kontinent,data=daten,sum)
kgni<-kontinente$popgni/kontinente$pop
kontinente$kgni<-kgni
kkgni<-cut(kgni,c(0,5000,10000,100000))
levels(kkgni)<-c("low","middle","high")
kontinente$kkgni<-kkgni
kontinente$nkkgni<-as.numeric(kkgni)

# Create chart and other elements

plot(1:1,type="n",axes=F)
treemap(kontinente,title="",index="kontinent", vSize="pop",vColor="kgni",type="value",palette="YlOrBr",aspRatio=2.5,position.legend="none",inflate.labels=T)
legend(0.35,0.6,levels(kkgni)[1:3],cex=1.65,ncol=6,border=F,bty="n",fill= brewer.pal(5,"YlOrBr")[3:5],text.col="black",xpd=NA)

# Titling

mtext("Population and Gross National Income",3,line=2,adj=0,cex=2.4,outer=T,family="Lato Black")
mtext("Size: population - Colour: GNI per capita. Atlas method (current US $), 2010",3,line=0,adj=0,cex=1.75,outer=T,font=3)
mtext("",1,line=1,adj=1.0,cex=1.25,outer=T,font=3)
dev.off()


# generate some test data for a merge
d1 = data.frame(PatientID=c("P000"), PatientName=c("P000"), StudyDate=as.Date("20190101","%Y%m%d"), Vol_Hippocampus=c(5200), Vol_Amygdala=c(1000))
num = 500
for (i in 1:num) {
  date = sample(seq(as.Date('1999/01/01'), as.Date('2019/01/01'), by="day"), 1)
  r = data.frame(PatientID=c(sprintf("P%03d", i)), PatientName=c(sprintf("P%03d", i)), StudyDate=date, Vol_Hippocampus=c(5000*runif(1)), Vol_Amygdala=c(100000*runif(1)))
  d1 <- rbind(d1, r)
}

# generate some test data for a merge
d2 = d1
d2$intra_cranial_volume = d2$Vol_Hippocampus*23
d2$Vol_Amygdala_l = d2$Vol_Amygdala/2
d2$Vol_Hippocampus = NULL
d2$Vol_Amygdala = NULL
# remove some rows
d2 = d2[-seq(100,200),]

write.csv(d1, 'd1.csv',row.names=F)
write.csv(d2, 'd2.csv',row.names=F)


print('\n\n\n\n')
print('===============================================================================')

library(randomForest)
library(Hmisc)

set.seed(42)

read.data <- function(file) {
	data <- read.csv(file, sep=',', na.strings=c(''), stringsAsFactors=FALSE)
	data <- subset(data, select = -c(Name, Fare, Ticket))
	return (data)
}
train <- read.data('data/train.csv')
train$Survived = factor(train$Survived)

test <- read.data('data/test.csv')

# massage and impute missing data
cabin_to_deck <- function(data) {
	data = as.character(data)
	for(i in seq(along=data)) {
		if (is.na(data[i]))
			next
		data[i] <- substr(data[i], 1, 1)
	}
	return (data)
}

# Cabin
train$Cabin = cabin_to_deck(train$Cabin)
train$Cabin = factor(train$Cabin, levels=c('A', 'B', 'C', 'D', 'E', 'F', 'G', 'T'))
train$Cabin = impute(train$Cabin, max)

test$Cabin = cabin_to_deck(test$Cabin)
test$Cabin = factor(test$Cabin, levels=c('A', 'B', 'C', 'D', 'E', 'F', 'G', 'T'))
test$Cabin = impute(test$Cabin, max)

# Age
train$Age <- impute(train$Age, mean)
test$Age <- impute(test$Age, mean)

# Embarked
train$Embarked <- impute(factor(train$Embarked), max)
test$Embarked <- impute(factor(test$Embarked), max)

# Sex
train$Sex <- factor(train$Sex)
test$Sex <- factor(test$Sex)

# Pclass
train$Pclass <- factor(train$Pclass, levels=c(1,2,3))
test$Pclass <- factor(test$Pclass, levels=c(1,2,3))

str(train)
str(test)

model <- randomForest(
	Survived ~ Pclass + Sex + Age + SibSp + Parch + Embarked + Cabin ,
	data=train,
	ntree=2002,
	mtry=2,
	replace=FALSE,
	importance=TRUE,
	proximity=TRUE,
	# we should have 0 na's so die loudly if we find any
	na.action=na.fail
)
print(model)
importance(model)

#print(model$importance)

#test$Survived <- predict(model, newdata=test, type="response")

#write.csv(test[,c("PassengerId", "Survived")], file="predictions.csv", row.names=FALSE, quote=FALSE)


set.seed(3147)
x <- rnorm(100)
y <- rnorm(100)
summary(x)
summary(y)

boxplot.stats(x)$out
boxplot(x)

df <- data.frame(x,y)
rm(x,y)

attach(df)
( a <- which(x %in% boxplot.stats(x)$out) )
( b <- which(y %in% boxplot.stats(y)$out) )
detach(df)

(outlier.list <- union(a,b))
plot(df)
points(df[outlier.list,], col = "blue", pch = "x", cex=2)


#' Create object of class 'cover'.
#'
#' @param rho_1 A single numerical value between 0 and 1. Total vegetation cover, i.e. the probability of a cell to be vegetated.
#' @param rho_11 A single numerical value between 0 and 1. Vegetation cover of pairs of vegetated cells. It defaults to \code{rho_11 = rho_1^2}, which leads to an assumption of random clustering.
#' @param q_11 A single numerical value between 0 and 1. Average vegetation cover of vegetated cells, i.e.  the conditional probability of finding vegetated cells in the 4-cell neighborhood given that the focal cell is vegetated. It defaults to NULL which leads to an assumption of neutral clustering, i.e. \code{q_11 == rho_1}.
#' @param cc A single numerical value greater than 0. Clustering coefficient,
#'   describing the ratio between average local cover \code{rho_11}, and global cover \code{rho_1}. A value greater 1 denotes strong clustering. It defaults to NULL which leads to an assumption of neutral clustering, i.e. \code{rho_11 == rho_1}.
#'
#' @return A named vector of two numerical values for the global cover of vegetation (rho_1) and the cover of vegetated pairs (rho_11).
#' @export
#'
#' @examples
#'
#' ini_rho(0.9, cc = 1.2)
#'
#'

ini_rho <- function(rho_1, rho_11 = NULL, q_11 = NULL, cc = NULL) {
  if(is.null(rho_11[1]) & is.null(cc) & is.null(q_11)) {rho_11 <- rho_1^2}
  if(is.null(rho_11[1]) & !is.null(cc) & is.null(q_11)) {rho_11 <- cc*rho_1^2}
  if(is.null(rho_11[1]) & is.null(cc) & !is.null(q_11)) {rho_11 <- q_11*rho_1}
  rho_11[rho_11 > rho_1] <- rho_1[rho_11 > rho_1]

    out <- list(
      rho_1 = rho_1,
      rho_11 = rho_11#,
      #rho_10 = rho_1-rho_11,
      #rho_00 = 1-2*rho_1+rho_11,
      #rho_0 = 1-rho_1
    )

    if(any(unlist(out) < 0)) {
      out <- list(
      rho_1 = NA,
      rho_11 = NA#,
      #rho_10 = NA,
      #rho_00 = NA,
      #rho_0 = NA
    )
    warning("The value of requested clustering is not compatible with the requested total vegetation cover: please provide a lower local cover or clustering value.")
      }

  class(out) <- "cover"
  return(out)
}

#' @export
check_rho <- ini_rho


#Still another solution, using ISOdate and weekdays
(2008:2121)[weekdays(ISOdate(2008:2121, 12, 25)) == "Sunday"]

# Simply replace "Sunday" with whatever it's named in your country,
# or set locale first, with
Sys.setlocale(cat="LC_ALL", "en")


#==============================================================================
#	Test for MCMCglmm
#==============================================================================

source("tests.r")

# Prepare data.
iris2 <- make.test.data.frame()

#------------------------------------------------------------------------------
#	Tests without specification of 'data' argument.
#------------------------------------------------------------------------------

test.data <- list(
	call = list(
		substitute(
			MCMCglmm(
				Sepal.Length ~ Petal.Length, data = iris2, family = "gaussian",
				verbose = FALSE, nitt = 1000, burnin = 100
			)
		),
		substitute(
			MCMCglmm(
				n ~ Petal.Length, data = iris2, family = "poisson",
				verbose = FALSE, nitt = 1000, burnin = 100
			)
		),
		substitute(
			MCMCglmm(
				cbind(bin1, bin2) ~ Petal.Length, data = iris2,
				family = "multinomial2",
		 		verbose = FALSE, nitt = 500, burnin = 100
			)
		),
		substitute(
			MCMCglmm(
				bin ~ Petal.Length, data = iris2, family = "exponential",
				verbose = FALSE, nitt = 500, burnin = 100
			)
		)
	),
	formula = list(
		Sepal.Length ~ Petal.Length,
		n ~ Petal.Length,
		cbind(bin1, bin2) ~ Petal.Length,
		bin ~ Petal.Length,
		bin ~ Petal.Length
	),
	family = list(
		"gaussian", "poisson", "multinomial", "exponential"
	),
	model.type = list(
		"regression", "regression", "classification", "regression"
	),
	link = list(
		identity, log, binomial()$linkfun, function(x) - log(x)
	),
	linkinv = list(
		identity, exp, binomial()$linkinv, function(x) exp(-x)
	)
)

test.model.adapter(
	"MCMCglmm", iris2, test.data,
	object.has.call = FALSE, object.has.data = FALSE
)

#------------------------------------------------------------------------------
#	Tests with specification of 'data' argument.
#------------------------------------------------------------------------------

test.data <- list(
	call = list(
		substitute(
			MCMCglmm(
				cbind(bin1, bin2) ~ Petal.Length, data = iris2,
				family = "multinomial2", verbose = FALSE,
				nitt = 500, burnin = 100
			)
		)
	),
	formula = list(cbind(bin1, bin2) ~ Petal.Length),
	family = list("multinomial"),
	model.type = list("classification"),
	link = list(binomial()$linkfun),
	linkinv = list(binomial()$linkinv)
)

test.model.adapter(
	"MCMCglmm", iris2, test.data, FALSE, TRUE,
	args.for.object = list(data = iris2)
)

rm(test.data, iris2)


################################################################################
#
# Script that presents and tests a function that performs an LRT to two
# models that are fitted to datasets generated by multiple imputation
# and provides a test statistic per Meng and Rubin (1992)
#
# The parallel version will not work on Windows machines because of the use of
# Unix-alike specific parallel code.
#
# Andrew Robinson 15-April-2015
#
################################################################################

library(lme4)    # For mixed-effects models

library(Amelia)  # For imputation

library(equivalence) # For data that I know

library(parallel) # Speed things up

library(compiler) # A different speed-up

data(ufc)

str(ufc)

ufc <- subset(ufc, !is.na(Dbh))
ufc$Species[ufc$Species %in% c("F","FG")] <- "GF"
ufc$Species <- factor(ufc$Species)
ufc$ht.measured <- is.na(ufc$Height)

ufc <- subset(ufc,
              Species %in% names(sort(-table(Species)))[1:6],
              select = c("ht.measured","Plot","Dbh.in","Species"))

## Fit a pair of models to compare using LRT

ufc.whole <- ufc

isna.1.w <- glmer(ht.measured ~ Dbh.in + Species + (1 | Plot),
                  data = ufc.whole, family = binomial)
isna.0.w <- glmer(ht.measured ~ Dbh.in + (1 | Plot),
                  data = ufc.whole, family = binomial)

anova(isna.0.w, isna.1.w)

## Make some data missing - 5% each of Dbh, Species, and the response.

make.missing <- sample(1:nrow(ufc), size = 90, replace = FALSE)

is.na(ufc$Species[make.missing[1:30]]) <- TRUE
is.na(ufc$Dbh.in[make.missing[31:60]]) <- TRUE
is.na(ufc$ht.measured[make.missing[61:90]]) <- TRUE

## Impute datasets using Amelia

ufc.imputes <- amelia(ufc,
                      m = 5,
                      cs = "Plot",
                      noms = "Species")

names(ufc.imputes)

str(ufc.imputes$imputations)

## Fit models to each instance

ufc.models <- mclapply(ufc.imputes$imputations,
                       function (dataset) {
                         glmer(ht.measured ~ Dbh.in + Species + (1 | Plot),
                               data = dataset, family = binomial)
                       },
                       mc.cores = 4)

## Obtain average model parameters

ufc.par.hat <-
  do.call(rbind, lapply(ufc.models,
                        function (fit) {
                          c(getME(fit, "theta"), fixef(fit))
                        }))

ufc.par.hat <- colMeans(ufc.par.hat)

## Create deviance functions for each imputation

ufc.dev.funs <- mclapply(ufc.imputes$imputations,
                         function (dataset) {
                           glmer(ht.measured ~ Dbh.in + Species + (1 | Plot),
                                 data = dataset, family = binomial,
                                 devFunOnly = TRUE)
                         },
                       mc.cores = 4)

## Evaluate the deviance for each refitted model at these estimates

(ufc.dev <- sapply(ufc.dev.funs, function(devfun) devfun(ufc.par.hat)))

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

###  Ok, now develop an LRT function using these pieces.

imputeLRT.p <- function(h0, h1, imputed.data.list, mc.cores = 4) {
  m <- length(imputed.data.list)
  h0.models <- mclapply(imputed.data.list,
                        function (dataset) {
                          update(h0, data = dataset)
                        },
                        mc.cores = mc.cores)
  h0.dev.funs <- mclapply(imputed.data.list,
                          function (dataset) {
                            update(h0, data = dataset,
                                   devFunOnly = TRUE)
                          },
                          mc.cores = mc.cores)
  Q.bar.0 <-
    colMeans(do.call(rbind,
                     lapply(h0.models,
                            function (fit) {
                              c(getME(fit, "theta"), fixef(fit))
                            })))
  h1.models <- mclapply(imputed.data.list,
                        function (dataset) {
                          update(h1, data = dataset)
                        },
                        mc.cores = mc.cores)
  h1.dev.funs <- mclapply(imputed.data.list,
                          function (dataset) {
                            update(h1, data = dataset,
                                   devFunOnly = TRUE)
                          },
                          mc.cores = mc.cores)
  Q.bar.1 <-
    colMeans(do.call(rbind,
                     lapply(h1.models,
                            function (fit) {
                              c(getME(fit, "theta"), fixef(fit))
                            })))
  d.prime.m.bar <- mean(unlist(mclapply(1:m,
                                        function(i) {
                                          anova(h0.models[[i]],
                                                h1.models[[i]])$Chisq[2]
                                        },
                                        mc.cores = mc.cores)))
  d.L.bar <- mean(unlist(mclapply(1:m,
                                  function(i) {
                                    h0.dev.funs[[i]](Q.bar.0) -
                                      h1.dev.funs[[i]](Q.bar.1)
                                  },
                                  mc.cores = mc.cores)))
  p0 <- length(Q.bar.0)
  p1 <- length(Q.bar.1)
  k <- p1 - p0
  rL <- (m + 1) / ((m - 1) * k) * (d.prime.m.bar - d.L.bar) # 3.8
  D.L <- d.L.bar / ((1 + rL) * k)                           # 3.7
  v <- k * (m - 1)
  w <- ifelse(v > 4,                                        # 2.7
              4 + (v - 4) * (1 + (1 - v/2) / rL)^2,
              v / 2 * (1 + 1/k) * (1 + 1/rL)^2)
  Pval <- 1 - pf(D.L, k, w)
  return(list(
    D.L = D.L,
    Pval = Pval,
    rL = rL,
    d.L.bar = d.L.bar,
    d.prime.m.bar = d.prime.m.bar,
    Q.bar.0 = Q.bar.0,
    Q.bar.1 = Q.bar.1,
    k = k,
    w = w,
    p0 = p0,
    p1 = p1,
    m = m))
}

## Here's a test

isna.1 <- glmer(ht.measured ~ Dbh.in + Species + (1 | Plot),
                data = ufc, family = binomial)
isna.0 <- glmer(ht.measured ~ Dbh.in + (1 | Plot),
                data = ufc, family = binomial)

imputeLRT.p(isna.0, isna.1,
          list(ufc.whole, ufc.whole, ufc.whole, ufc.whole, ufc.whole))

## P-value should be comparable to

anova(isna.0.w, isna.1.w)

## Now apply to missing data cases

ufc.imputes.V <- amelia(ufc,
                        m = 5,
                        cs = "Plot",
                        noms = "Species")

imputeLRT.p(isna.0, isna.1, ufc.imputes.V$imputations)

ufc.imputes.X <- amelia(ufc,
                        m = 10,
                        cs = "Plot",
                        noms = "Species")

imputeLRT.p(isna.0, isna.1, ufc.imputes.X$imputations)

ufc.imputes.XX <- amelia(ufc,
                        m = 20,
                        cs = "Plot",
                        noms = "Species")

imputeLRT.p(isna.0, isna.1, ufc.imputes.XX$imputations)

ufc.imputes.L <- amelia(ufc,
                        m = 50,
                        cs = "Plot",
                        noms = "Species")

imputeLRT.p(isna.0, isna.1, ufc.imputes.L$imputations)

##  A version that should work more broadly

imputeLRT <- function(h0, h1, imputed.data.list) {
  m <- length(imputed.data.list)
  h0.models <- lapply(imputed.data.list,
                      function (dataset) {
                        update(h0, data = dataset)
                      })
  h0.dev.funs <- lapply(imputed.data.list,
                        function (dataset) {
                          update(h0, data = dataset,
                                 devFunOnly = TRUE)
                        })
  Q.bar.0 <-
    colMeans(do.call(rbind,
                     lapply(h0.models,
                            function (fit) {
                              c(getME(fit, "theta"), fixef(fit))
                            })))
  h1.models <- lapply(imputed.data.list,
                      function (dataset) {
                        update(h1, data = dataset)
                      })
  h1.dev.funs <- lapply(imputed.data.list,
                        function (dataset) {
                          update(h1, data = dataset,
                                 devFunOnly = TRUE)
                        })
  Q.bar.1 <-
    colMeans(do.call(rbind,
                     lapply(h1.models,
                            function (fit) {
                              c(getME(fit, "theta"), fixef(fit))
                            })))
  d.prime.m.bar <- mean(unlist(lapply(1:m,
                                      function(i) {
                                        anova(h0.models[[i]],
                                              h1.models[[i]])$Chisq[2]
                                      })))
  d.L.bar <- mean(unlist(lapply(1:m,
                                function(i) {
                                  h0.dev.funs[[i]](Q.bar.0) -
                                    h1.dev.funs[[i]](Q.bar.1)
                                })))
  p0 <- length(Q.bar.0)
  p1 <- length(Q.bar.1)
  k <- p1 - p0
  rL <- (m + 1) / ((m - 1) * k) * (d.prime.m.bar - d.L.bar) # 3.8
  D.L <- d.L.bar / ((1 + rL) * k)                           # 3.7
  v <- k * (m - 1)
  w <- ifelse(v > 4,                                        # 2.7
              4 + (v - 4) * (1 + (1 - v/2) / rL)^2,
              v / 2 * (1 + 1/k) * (1 + 1/rL)^2)
  Pval <- 1 - pf(D.L, k, w)
  return(list(
    D.L = D.L,
    Pval = Pval,
    rL = rL,
    d.L.bar = d.L.bar,
    d.prime.m.bar = d.prime.m.bar,
    Q.bar.0 = Q.bar.0,
    Q.bar.1 = Q.bar.1,
    k = k,
    w = w,
    p0 = p0,
    p1 = p1,
    m = m))
}

imputeLRT(isna.0, isna.1,
          list(ufc.whole, ufc.whole, ufc.whole, ufc.whole, ufc.whole))

imputeLRT(isna.0, isna.1, ufc.imputes.X$imputations)

imputeLRT.pw <- function(h0, h1, imputed.data.list, mc.cores = 4) {
#    browser()
    my.cluster <- makeCluster(mc.cores)
    clusterExport(my.cluster,
                  c("h0","h1","imputed.data.list"),
                  environment())
    m <- length(imputed.data.list)
    h0.models <- clusterApplyLB(my.cluster,
                                imputed.data.list,
                                function (dataset) {
                                    require(lme4)
                                    update(h0, data = dataset)
                                })
    h0.dev.funs <- clusterApplyLB(my.cluster,
                                  imputed.data.list,
                                  function (dataset) {
                                      update(h0, data = dataset,
                                             devFunOnly = TRUE)
                                  })
    Q.bar.0 <-
        colMeans(do.call(rbind,
                         lapply(h0.models,
                                function (fit) {
                                    c(getME(fit, "theta"), fixef(fit))
                                })))
    h1.models <- clusterApplyLB(my.cluster,
                                imputed.data.list,
                                function (dataset) {
                                    update(h1, data = dataset)
                                })
    h1.dev.funs <- clusterApplyLB(my.cluster,
                                  imputed.data.list,
                                  function (dataset) {
                                      update(h1, data = dataset,
                                             devFunOnly = TRUE)
                                  })
    Q.bar.1 <-
        colMeans(do.call(rbind,
                         lapply(h1.models,
                                function (fit) {
                                    c(getME(fit, "theta"), fixef(fit))
                                })))
    d.prime.m.bar <- mean(unlist(clusterApplyLB(my.cluster,
                                                1:m,
                                                function(i) {
                                                    anova(h0.models[[i]],
                                                          h1.models[[i]])$Chisq[2]
                                                })))
    d.L.bar <- mean(unlist(clusterApplyLB(my.cluster,
                                          1:m,
                                          function(i) {
                                              h0.dev.funs[[i]](Q.bar.0) -
                                                  h1.dev.funs[[i]](Q.bar.1)
                                          })))
    stopCluster(my.cluster)
    p0 <- length(Q.bar.0)
    p1 <- length(Q.bar.1)
    k <- p1 - p0
    rL <- (m + 1) / ((m - 1) * k) * (d.prime.m.bar - d.L.bar) # 3.8
    D.L <- d.L.bar / ((1 + rL) * k)                           # 3.7
    v <- k * (m - 1)
    w <- ifelse(v > 4,                                        # 2.7
                4 + (v - 4) * (1 + (1 - v/2) / rL)^2,
                v / 2 * (1 + 1/k) * (1 + 1/rL)^2)
    Pval <- 1 - pf(D.L, k, w)
    return(list(
        D.L = D.L,
        Pval = Pval,
        rL = rL,
        d.L.bar = d.L.bar,
        d.prime.m.bar = d.prime.m.bar,
        Q.bar.0 = Q.bar.0,
        Q.bar.1 = Q.bar.1,
        k = k,
        w = w,
        p0 = p0,
        p1 = p1,
        m = m))
}

imputeLRT.pw(isna.0, isna.1,
             list(ufc.whole, ufc.whole, ufc.whole, ufc.whole, ufc.whole))

imputeLRT.pw(isna.0, isna.1, ufc.imputes.X$imputations)

########

## Timing test

system.time(imputeLRT(isna.0, isna.1, ufc.imputes.XX$imputations))

system.time(imputeLRT.p(isna.0, isna.1, ufc.imputes.XX$imputations))

# system.time(imputeLRT.pw(isna.0, isna.1, ufc.imputes.XX$imputations))

imputeLRT.c <- cmpfun(imputeLRT)

system.time(imputeLRT.c(isna.0, isna.1, ufc.imputes.XX$imputations))


# Multivariate PCMs

#Read Tree and data; prune
library(geomorph)
library(geiger)
library(phytools)
tree.best<-read.nexus("TutorialData/Consensus of 1000 salamander trees.nex") #Maximum Credible Tree
plethdata<-read.csv("TutorialData/meandata-CinGlutOnly.csv",row.names=1, header=TRUE )
 Y<-plethdata[,c(3:8)]
     Y<-apply(Y,2,as.numeric);row.names(Y)<-row.names(plethdata)
 size<-plethdata[,2];names(size)<-row.names(plethdata)
 gp<-as.factor(plethdata[,1]); names(gp)<-row.names(plethdata)
plethtree<-treedata(phy = tree.best,data = plethdata, warnings = FALSE)$phy
plot(plethtree)
axisPhylo(1)

gdf <- geomorph.data.frame(Y=Y, size=size,gp=gp,phy = plethtree) #needed for geomorph

Y.pc<-prcomp(Y)$x   #principal components of Y
plot(Y.pc,asp=1, pch=21,bg="black")
text(x=2+Y.pc[,1],y=.5+Y.pc[,2],row.names(Y.pc),cex=.5)

#### Analyses
#0: Phylomorphospace (ie, plot the data)
phylomorphospace(tree = plethtree,X = Y.pc[,1:2])
plotGMPhyloMorphoSpace(phy = plethtree,A = arrayspecs(Y,p=1,k=6), ancStates = FALSE, tip.labels = FALSE)
plotGMPhyloMorphoSpace(phy = plethtree,A = arrayspecs(Y,p=1,k=6), ancStates = FALSE)
    #note: axes are properly scaled; In phytools they are not
plotGMPhyloMorphoSpace(phy = plethtree,A = arrayspecs(Y,p=1,k=6),ancStates = FALSE, zaxis = "time")

#1: Phylogenetic regression via phylo-transform and RRPP: Regression of multivariate data~size
PGLS.reg<-procD.pgls(Y ~ size, phy = phy, data = gdf, iter = 999, print.progress = FALSE) # randomize residuals
summary(PGLS.reg)
plot(PGLS.reg, type = "regression", predictor=size,reg.type = "RegScore")

#2: Phylogenetic ANOVA via phylo-transform and RRPP: ANOVA of multivariate data~group
PGLS.aov<-procD.pgls(Y ~ gp, phy = phy, data = gdf, iter = 999, print.progress = FALSE) # randomize residuals
summary(PGLS.aov)  #no difference once phylogeny considered

#3: Phylogenetic PLS
PLS.Y <- phylo.integration(A = Y[,1:3], A2 = Y[,4:6], phy= plethtree, print.progress = FALSE)
summary(PLS.Y)
plot(PLS.Y)

#4: Phylogenetic signal
PS.shape <- physignal(A=Y,phy=plethtree,iter=999, print.progress = FALSE)
summary(PS.shape)
plot(PS.shape)

#5a: Compare Evolutionary Rates Among Clades
ER<-compare.evol.rates(A=Y, phy=plethtree,gp=gp,iter=999, print.progress = FALSE)
summary(ER)   #significantly higher rate of morphological evolution 'large' Plethodon
plot(ER)

#5b: Compare Evolutionary Rates Among Traits
var.gp <- c("B","A","A","B","B","B")  #head (A) vs. body (B)
EMR<-compare.multi.evol.rates(A=Y,gp=var.gp, Subset=TRUE, phy= plethtree,iter=999, print.progress = FALSE)
summary(EMR) #Limb traits evolve faster than head traits
plot(EMR)


#' rpois
#'
#' Generate from a poisson distribution using a gpu.
#'
#' @details
#' Uses \code{curand_poisson()} from cuRAND.
#'
#' @param n
#' The number of values to generate
#' @param lambda
#' Parameter for poisson random variables.
#' @param seed
#' Seed for the random number generation.
#' @param type
#' Ignored; present only to match API with other generators. The return is
#' always a vector of ints.
#'
#' @references CUDA Toolkit Documentation for cuRAND
#' \url{https://docs.nvidia.com/cuda/curand/index.html}
#'
#' @useDynLib curand R_curand_rpois
#' @export
rpois = function(n, lambda=1, seed=getseed(), type="double")
{
  n1 = floor(sqrt(n))
  n2 = n - n1*n1

  if (n < 0)
    stop("invalid arguments")
  else if (n == 0)
    return(integer(0))

  if (lambda < 0 || is.badval(lambda))
  {
    warning("NAs produced")
    ret = setnan(n1, n2, type)
  }
  else
    ret = .Call(R_curand_rpois, as.integer(n1), as.integer(n2), as.double(lambda), as.integer(seed))

  ret
}


#' isSym
#'
#' Test if a matrix-like object is symmetric.  In addition to supporting
#' the new classes, this method is SIGNIFICANTLY more efficient
#' than R's \code{isSymmetric()} for matrix types.
#'
#' @details
#' For a matrix input, we use a block algorithm.
#'
#' @param x
#' A matrix-like object.
#'
#' @return
#' \code{TRUE} or \code{FALSE}, accordingly.
#'
#' @export
isSym <- function(x) UseMethod("isSym", x)

dimseq <- function(x)
{
  dim <- getdim(x)
  if (dim[1L] != dim[2L])
    FALSE
  else
    TRUE
}

#' @export
isSym.DiagMat <- dimseq

#' @export
isSym.ZeroMat <- dimseq

#' @export
isSym.SymMat <- dimseq

#' @export
isSym.GenBandMat <- function(x)
{
  dims <- getdim(x)
  if (dims[1L] != dims[2L])
    return(FALSE)

  k <- kdim(x)
  if (k[1L] != k[2L])
    return(FALSE)

  .Call(R_isSym_band, getData(x), dims[1L], k[1L])
}

#' @export
isSym.matrix <- function(x)
{
  .Call(R_isSym_full, x)
}


library ('factoextra')
library ('apcluster')
data = read.table ({{i.infile | quote}}, sep="\t", header={{args.cnames | R}}, row.names={{args.rnames | lambda x: 'NULL' if not x else int(x)}}, check.names=F)
if ({{args.transpose | R}}) {
	data = t(data)
}
data = data[, apply(data, 2, sd)!=0, drop=F]
ap        = apcluster(negDistMat(r=2), data)
clusters  = ap@clusters
nclust    = length (clusters)
clusts    = matrix (NA, ncol=1, nrow=ap@l)
rownames (clusts) = rownames(data)
for (i in 1:nclust) {
	cids  = unlist (clusters[i])
	for (cid in cids) clusts[cid, 1] = i
}
fvizobj   = {}
fvizobj$data = data
fvizobj$cluster = clusts

clustfile = file.path ({{o.outdir | quote}}, "clusters.txt")
write.table (clusts, clustfile, quote=F, col.names = F, sep="\t")
clustfig  = file.path ({{o.outdir | quote}}, "clusters.png")

do.call(png, c(list(file = clustfig), {{args.devpars | Rlist}}))
labels    = colnames(data)
print (fviz_cluster (fvizobj, main = ""))
dev.off()


##WEATHER RANKING:
lst <- dir('D:\\SOD-modeling\\layers\\weather\\weatherCoeff_19902008_20082014PRISM', pattern='\\.img$', full.names=T)
Mlst <- lst[grep("_m", lst)]
Clst <- lst[grep("_c", lst)]

years <- 1990:2014

prod_mc_TOT <- rep(0, length(years))
cnt <- 0

for (yr in years){

	cat(paste('year', yr), '\n')
	cnt <- cnt + 1

	Mlst_sel <- grep(paste0(as.character(yr),"_"), Mlst, value=TRUE)
	Clst_sel <- grep(paste0(as.character(yr),"_"), Clst, value=TRUE)

	Mstack <- stack(Mlst_sel) #M = moisture;
	Cstack <- stack(Clst_sel) #C = temperature;

	prod_mc <- rep(0, nlayers(Mstack))

	for (wk in 1:nlayers(Mstack)){

		cat(paste('week', wk), '\n')
		prod_mc_ras <- Mstack[wk] * Cstack[wk]

		#sum over all cells of the raster for current week
		prod_mc[wk] <- sum(prod_mc_ras, na.rm=T)
	}

	#sum over all weeks of the current year
	prod_mc_TOT[cnt] <- mean(prod_mc, na.rm=T)

}


## Berechnung der Bachelor-Gesamtnote
# Setting up virtual environment
print("Starting R virtual environment...")
print("Executing script!")
options(digits=3)

# Input einlesen
current_gpa <- readline(prompt="Derzeitiger gesamt-GPA: ")
current_gpa <-gsub(",", ".", current_gpa)
current_gpa <- as.numeric(current_gpa)
print("Eingabe der Berechnungsgrundlage in CP")
print("ACHTUNG! Wenn die finale Note berechnet werden soll, mit der Standardanzahl der CP bei Beendigung rechnen")
print("Normalerweise 180 CP - Bachelorthesis CP")
base_cp <- readline(prompt="Berechnungsgrundlage in CP: ")
base_cp <- as.numeric(base_cp)
current_ba <- readline(prompt="(Voraussichtliche) Bachelor-Thesis-Note: ")
current_ba <-gsub(",", ".", current_ba)
current_ba <- as.numeric(current_ba)
base_bacp <- readline(prompt="CP für Thesis: ")
base_bacp <- as.numeric(base_bacp)

# Berechnung der Noten
weighted_grade_sum <- current_gpa * base_cp
print(paste0("Summe der gewichteten Noten: ", weighted_grade_sum), quote = FALSE)
print(paste0("Summe der zur Berechnung verwendeten CP: ", base_cp), quote = FALSE)
weighted_grade <- weighted_grade_sum / base_cp
print(paste0("Gewichtete Modulnote: ", weighted_grade_sum), quote = FALSE)

weighted_ba_grade_sum <- current_ba * base_bacp
full_cp <- base_cp + base_bacp
print(paste0("Bachelornote: ", current_ba), quote = FALSE)
print(paste0("Bachelor-CP: ", base_bacp), quote = FALSE)
print(paste0("Gewichtete Bachelornote: ", weighted_ba_grade_sum), quote = FALSE)

weighted_full_grade <- weighted_ba_grade_sum + weighted_grade_sum
final_grade <- weighted_full_grade / full_cp
print(paste0("Gewichtete Gesamtnote: ", weighted_full_grade), quote = FALSE)
print(paste0("Gesamte CP: ", full_cp), quote = FALSE)
print("", quote = FALSE)
print(paste0("Voraussichtliche finale Note: ", round(final_grade, digits = 3)), quote = FALSE)


# S1; S2; X; r; metric = "rec"; method = "supt"; type = "band"; plus = T; alpha = .05; h = NULL; mc.rep = 100000

#' Perform a hypothesis test for the difference between two performance curves.
#'
#' \code{PerfCurveTest} takes score vectors for two scoring algorithms and an activity vector.
#' A performance curve is created for the two scoring algorithms and hypothesis tests are performed
#' at the selected testing fractions.
#'
#' @param S1 a vector of scores for scoring algorithm 1.
#' @param S2 a vector of scores for scoring algorithm 2.
#' @param X a vector of activities.
#' @param r a vector of testing fractions.
#' @param metric the performance curve to use. Options are recall ("rec") and precision ("prec").
#' @param method the method to use. Recall options are
#' c("EmProc", "binomial", "JZ ind", "mcnemar", "binomial ind"). Precision options are
#' c("EmProc", "binomial", "JZ ind", "stouffer", "binomial ind").
#' @param plus should plus correction be used or not?
#' @param alpha the significance level.
#'
#' @export
PerfCurveTest <- function(S1, S2, X, r, metric = "rec", type = "pointwise", method = "EmProc",
                          plus = T, alpha = .05, h = NULL, seed = 111, mc.rep = 100000){

  set.seed(seed)
  m <- length(S1) #total sample size
  r.all <- (1:m)/m
  idx <- which(r.all %in% r)

  # Convert fractions in r to thresholds, for both sets of scores
  # Also accumulate the number of actives, for each score and jointly
  F1cdf <- ecdf(S1); yyobs <- sort(unique(S1))
  F1inv <- stepfun(x = F1cdf(yyobs), y = c(yyobs, max(yyobs)), right=TRUE, f=1)
  F2cdf <- ecdf(S2); yyobs <- sort(unique(S2))
  F2inv <- stepfun(x = F2cdf(yyobs), y = c(yyobs, max(yyobs)), right=TRUE, f=1)
  hits1 <- hits2 <- hits12 <- ntest12 <- vector(length = length(r))
  for(i in 1:length(r)) {
    t1 <- F1inv(1-r[i])
    t2 <- F2inv(1-r[i])
    hits1[i] <- sum(X*(S1 > t1))
    hits2[i] <- sum(X*(S2 > t2))
    hits12[i] <- sum(X*(S1 > t1 & S2 > t2))
    ntest12[i] <- sum(S1 > t1 & S2 > t2)
  }
  nact <- sum(X) #total number of actives
  ntest <- (m*r) #number of compounds tested

  # Uncorrected parameters
  r <- ntest/m
  pi.0 <- nact/m
  k1 <- (hits1)/nact
  k2 <- (hits2)/nact
  k12 <- (hits12)/nact
  pi1 <- pi.0/r*k1
  pi2 <- pi.0/r*k2
  r12 <- ntest12/m
  pi12 <- hits12/ntest12
  pi12 <- ifelse(is.na(pi12), 0, pi12)
  # pooled estimates
  pi <- (pi1 + pi2)/2
  k <- (k1 + k2)/2

  if(plus) {
    hits1.c <- hits1 + 1
    hits2.c <- hits2 + 1
    nact.c <- nact + 2
    ntest.c <- ntest + 1
    m.c <- m + 2
  } else {
    hits1.c <- hits1
    hits2.c <- hits2
    nact.c <- nact
    ntest.c <- ntest
    m.c <- m
  }

  # Corrected parameters
  r.c <- ntest.c/m.c
  pi.0.c <- nact.c/m.c
  k1.c <- (hits1.c)/nact.c
  k2.c <- (hits2.c)/nact.c
  k12.c <- (hits12)/nact.c
  pi1.c <- (hits1.c)/(ntest.c)
  pi2.c <- (hits2.c)/(ntest.c)
  r12.c <- ntest12/m.c
  pi12.c <- hits12/ntest12
  pi12.c <- ifelse(is.na(pi12.c), 0, pi12.c)

  Lam1.vec <- vector(length = length(k1))
  Lam2.vec <- vector(length = length(k1))
  for(j in seq_along(k1)){
    Lam1.vec[j] <- EstLambda(S1, X, t = F1inv(1-r[j]), idx = idx[j], h)
    Lam2.vec[j] <- EstLambda(S2, X, t = F2inv(1-r[j]), idx = idx[j], h)
  }

  CI.int <- matrix(ncol = 2, nrow = length(k1))
  se.p <- se.np <- p.val <- vector(length = length(k1))
  if(metric == "rec") {
    if(type == "pointwise") {
      quant <- qnorm(1-alpha/2)

      if(method %in% c("JZ ind", "EmProc")){
        for(j in seq_along(k1)) {
          Lam1 <- Lam1.vec[j]
          Lam2 <- Lam2.vec[j]

          # unpooled variances
          var1.k.np <- ((k1.c[j]*(1-k1.c[j]))/(m.c*pi.0.c))*(1-2*Lam1) +
            (Lam1^2*(1-r.c[j])*r.c[j])/(m.c*pi.0.c^2)
          # Check to see if var.k.np is negative due to m.cachine precision problem.c
          var1.k.np <- ifelse(var1.k.np < 0, 0, var1.k.np)
          var2.k.np <- ((k2.c[j]*(1-k2.c[j]))/(m.c*pi.0.c))*(1-2*Lam2) +
            (Lam2^2*(1-r.c[j])*r.c[j])/(m.c*pi.0.c^2)
          var2.k.np <- ifelse(var2.k.np < 0, 0, var2.k.np)
          cov.k.np <- (m.c^-1*pi.0.c^-2)*(pi.0.c*(k12.c[j]-k1.c[j]*k2.c[j])*(1-Lam1-Lam2) +
                                            (r12.c[j]-r.c[j]^2)*Lam1*Lam2)

          # pooled variances
          var1.k.p <- ((k[j]*(1-k[j]))/(m*pi.0))*(1-2*Lam1) +
            (Lam1^2*(1-r[j])*r[j])/(m*pi.0^2)
          var1.k.p <- ifelse(var1.k.p < 0, 0, var1.k.p)
          var2.k.p <- ((k[j]*(1-k[j]))/(m*pi.0))*(1-2*Lam2) +
            (Lam2^2*(1-r[j])*r[j])/(m*pi.0^2)
          var2.k.p <- ifelse(var2.k.p < 0, 0, var2.k.p)
          cov.k.p <- (m^-1*pi.0^-2)*(pi.0*(k12[j]-k[j]*k[j])*(1-Lam1-Lam2) +
                                       (r12[j]-r[j]^2)*Lam1*Lam2)

          if(method == "JZ ind"){
            # assuming independence of k
            var.k.p <- var1.k.p + var2.k.p
            var.k.np <- var1.k.np + var2.k.np
          } else if(method == "EmProc") {
            var.k.p <- var1.k.p + var2.k.p - 2*cov.k.p
            var.k.np <- var1.k.np + var2.k.np - 2*cov.k.np
          }
          var.k.p <- ifelse(var.k.p < 0, 0, var.k.p)
          var.k.np <- ifelse(var.k.np < 0, 0, var.k.np)
          se.p[j] <- sqrt(var.k.p)
          se.np[j] <- sqrt(var.k.np)

          # Use pooled variance for tests, and unpooled for CIs
          CI.int[j, ] <- c( (k1[j]-k2[j]) - quant*se.np[j],
                            (k1[j]-k2[j]) + quant*se.np[j])
          zscore <- ( (k1[j]-k2[j]) )/se.p[j]
          p.val[j] <- 2*pnorm(-abs(zscore))
          p.val[j] <- ifelse(is.na(p.val[j]), 1, p.val[j])
        }
      } else if(method %in% c("binomial ind", "binomial")) {
        for(j in seq_along(k1.c)) {

          # unpooled variances
          var1.k.np <- (m.c*pi.0.c)^-1*(k1.c[j])*(1-k1.c[j])
          var2.k.np <- (m.c*pi.0.c)^-1*(k2.c[j])*(1-k2.c[j])
          cov.k.np <- (m.c*pi.0.c)^-1*(k12.c[j] - k1.c[j]*k2.c[j])

          # pooled variances
          var1.k.p <- (m*pi.0)^-1*(k[j])*(1-k[j])
          var2.k.p <- (m*pi.0)^-1*(k[j])*(1-k[j])
          cov.k.p <- (m*pi.0)^-1*(k12[j] - k[j]*k[j])

          if(method == "binomial") {
            var.k.p <- var1.k.p + var2.k.p - 2*cov.k.p
            var.k.np <- var1.k.np + var2.k.np - 2*cov.k.np
          } else if(method == "binomial ind") {
            var.k.p <- var1.k.p + var2.k.p
            var.k.np <- var1.k.np + var2.k.np
          }
          var.k.p <- ifelse(var.k.p < 0, 0, var.k.p)
          var.k.np <- ifelse(var.k.np < 0, 0, var.k.np)
          se.p[j] <- sqrt(var.k.p)
          se.np[j] <- sqrt(var.k.np)
          CI.int[j, ] <- c( (k1[j]-k2[j]) - quant*se.np[j],
                            (k1[j]-k2[j]) + quant*se.np[j])
          zscore <- ( (k1[j]-k2[j]) )/se.p[j]
          p.val[j] <- 2*pnorm(-abs(zscore))
          p.val[j] <- ifelse(is.na(p.val[j]), 1, p.val[j])
        }
      } else if(method == "mcnemar") {
        for(j in seq_along(k1.c)) {
          BminusC <- hits1[j] - hits2[j]
          BplusC <- hits1[j] + hits2[j] - 2*hits12[j]
          BminusC.c <- hits1.c[j] - hits2.c[j]
          BplusC.c <- hits1.c[j] + hits2.c[j] - 2*hits12[j]
          zscore <- ifelse(BplusC>0, BminusC/sqrt(BplusC), 0)
          p.val[j] <- 2*pnorm(-abs(zscore))
          se.np[j] <- sqrt(BplusC.c - BminusC.c^2/nact.c) / nact.c
          # TODO use the actual difference as the center point for the CI?
          # No, use actual BP corrected McNemar for a fair comparison
          CI.int[j,] <- c( BminusC.c/nact.c - quant*se.np[j], BminusC.c/nact.c + quant*se.np[j])
        }
      }
    } else if (type == "band") {
      if(method == "sup-t") {
        cor.C <- matrix(NA, ncol = length(k1), nrow = length(k1))
        for(f in seq_along(k1)) {
          for(e in 1:f) {

            # Alg 1 unpooled variance
            Lam11 <- Lam1.vec[e]; Lam21 <- Lam2.vec[e];
            var1.k.r1 <- ((k1.c[e]*(1-k1.c[e]))/(m.c*pi.0.c))*(1-2*Lam11) +
              (Lam11^2*(1-r.c[e])*r.c[e])/(m.c*pi.0.c^2)
            var1.k.r1 <- ifelse(var1.k.r1 < 0, 0, var1.k.r1)
            var2.k.r1 <- ((k2.c[e]*(1-k2.c[e]))/(m.c*pi.0.c))*(1-2*Lam21) +
              (Lam21^2*(1-r.c[e])*r.c[e])/(m.c*pi.0.c^2)
            var2.k.r1 <- ifelse(var2.k.r1 < 0, 0, var2.k.r1)
            cov.k.r1 <- (m.c^-1*pi.0.c^-2)*(pi.0.c*(k12.c[e]-k1.c[e]*k2.c[e])*(1-Lam11-Lam21) +
                                              (r12.c[e]-r.c[e]^2)*Lam11*Lam21)
            var.difk.r1 <- var1.k.r1 + var2.k.r1 - 2*cov.k.r1

            # Alg 2 unpooled variances
            Lam12 <- Lam1.vec[f]; Lam22 <- Lam2.vec[f];
            var1.k.r2 <- ((k1.c[f]*(1-k1.c[f]))/(m.c*pi.0.c))*(1-2*Lam12) +
              (Lam12^2*(1-r.c[f])*r.c[f])/(m.c*pi.0.c^2)
            var1.k.r2 <- ifelse(var1.k.r2 < 0, 0, var1.k.r2)
            var2.k.r2 <- ((k2.c[f]*(1-k2.c[f]))/(m.c*pi.0.c))*(1-2*Lam22) +
              (Lam22^2*(1-r.c[f])*r.c[f])/(m.c*pi.0.c^2)
            var2.k.r2 <- ifelse(var2.k.r2 < 0, 0, var2.k.r2)
            cov.k.r2 <- (m.c^-1*pi.0.c^-2)*(pi.0.c*(k12.c[f]-k1.c[f]*k2.c[f])*(1-Lam12-Lam22) +
                                              (r12.c[f]-r.c[f]^2)*Lam12*Lam22)
            var.difk.r2 <- var1.k.r2 + var2.k.r2 - 2*cov.k.r2

            # Covariance
            cov.k11.k12 <- ((m.c^-1*pi.0.c^-2)*(pi.0.c*(k1.c[e]-k1.c[e]*k1.c[f])*(1-Lam11-Lam12) +
                                                       (r.c[e]-r.c[e]*r.c[f])*Lam11*Lam12))
            cov.k21.k22 <- ((m.c^-1*pi.0.c^-2)*(pi.0.c*(k2.c[e]-k2.c[e]*k2.c[f])*(1-Lam21-Lam22) +
                                                  (r.c[e]-r.c[e]*r.c[f])*Lam21*Lam22))

            t1 <- F1inv(1-r[e])
            t2 <- F2inv(1-r[f])
            hits11.22 <- sum(X*(S1 > t1 & S2 > t2))
            ntest11.22 <- sum(S1 > t1 & S2 > t2)
            k11.22.c <- (hits11.22)/nact.c
            r11.22.c <- ntest11.22/m.c

            cov.k11.k22 <- (m.c^-1*pi.0.c^-2)*(pi.0.c*(k11.22.c-k1.c[e]*k2.c[f])*(1-Lam11-Lam22) +
                                              (r11.22.c-r.c[e]*r.c[f])*Lam11*Lam22)

            t1 <- F1inv(1-r[f])
            t2 <- F2inv(1-r[e])
            hits12.21 <- sum(X*(S1 > t1 & S2 > t2))
            ntest12.21 <- sum(S1 > t1 & S2 > t2)
            k12.21.c <- (hits12.21)/nact.c
            r12.21.c <- ntest12.21/m.c

            cov.k12.k21 <- (m.c^-1*pi.0.c^-2)*(pi.0.c*(k12.21.c-k1.c[f]*k2.c[e])*(1-Lam21-Lam12) +
                                                 (r12.21.c-r.c[f]*r.c[e])*Lam21*Lam12)

            cov.difk <- cov.k11.k12 + cov.k21.k22 - cov.k11.k22 - cov.k12.k21

            if(e == f) {
              # If the covariance serves as a variance then it cant be non-negative
              # otherwise, it can be negative
              cov.difk <- ifelse(cov.difk < 0, 0, cov.difk)
            }
            cor.difk <- cov.difk/(sqrt(var.difk.r1)*sqrt(var.difk.r2))
            cor.difk <- ifelse(var.difk.r1 == 0 | var.difk.r2 == 0, ifelse(e == f, 1, 0), cor.difk)
            cor.C[e, f] <- cor.difk
            cor.C[f, e] <- cor.difk
          }
        }
        mc.samples <- MASS::mvrnorm(n = mc.rep, rep(0, length = length(k)), cor.C, tol = 1)
        max.q <- vector(length = mc.rep)
        for(j in 1:mc.rep) {
          max.q[j] <- max(abs(mc.samples[j, ]))
        }
        # This should be divided by two because standard normal dist and not the chi-square
        # in Montiel Olea and Plagborg-Møller
        quant <- quantile(max.q, probs = 1-alpha/2)
      } else if(method == "theta-proj") {
        quant <- sqrt(qchisq(1-alpha, length(k1)))
      } else if(method == "bonf") {
        quant <- qnorm(1-alpha/(2*length(k1)))
      }
      for(j in seq_along(k)) {
        Lam1 <- Lam1.vec[j]
        Lam2 <- Lam2.vec[j]

        print(quant)
        # unpooled variances
        var1.k.np <- ((k1.c[j]*(1-k1.c[j]))/(m.c*pi.0.c))*(1-2*Lam1) +
          (Lam1^2*(1-r.c[j])*r.c[j])/(m.c*pi.0.c^2)
        # Check to see if var.k.np is negative due to machine precision problem
        var1.k.np <- ifelse(var1.k.np < 0, 0, var1.k.np)
        var2.k.np <- ((k2.c[j]*(1-k2.c[j]))/(m.c*pi.0.c))*(1-2*Lam2) +
          (Lam2^2*(1-r.c[j])*r.c[j])/(m.c*pi.0.c^2)
        var2.k.np <- ifelse(var2.k.np < 0, 0, var2.k.np)
        cov.k.np <- (m.c^-1*pi.0.c^-2)*(pi.0.c*(k12.c[j]-k1.c[j]*k2.c[j])*(1-Lam1-Lam2) +
                                          (r12.c[j]-r.c[j]^2)*Lam1*Lam2)
        var.k.np <- var1.k.np + var2.k.np - 2*cov.k.np
        var.k.np <- ifelse(var.k.np < 0, 0, var.k.np)
        se.np[j] <- sqrt(var.k.np)
        CI.int[j, ] <- c( (k1[j]-k2[j]) - quant*se.np[j],
                          (k1[j]-k2[j]) + quant*se.np[j])
        p.val[j] <- NA
      }
    }
    # difference estimates
    est <- (k1 - k2)
  } else if(metric == "prec") {
    # TODO implement pooled and unpooled variances here
    if(method %in% c("JZ ind", "EmProc")) {
      for(j in seq_along(pi1.c)) {
        Lam1 <- Lam1.vec[j]
        var1.pi <- (pi1.c[j]*(1-pi1.c[j]))/(m*r[j]) + (1-r[j])*(pi1.c[j]-Lam1)^2/(m*r[j])
        var1.pi <- ifelse(var1.pi < 0, 0, var1.pi)
        Lam2 <- Lam2.vec[j]
        var2.pi <- (pi2.c[j]*(1-pi2.c[j]))/(m*r[j]) + (1-r[j])*(pi2.c[j]-Lam2)^2/(m*r[j])
        var2.pi <- ifelse(var2.pi < 0, 0, var2.pi)
        cov.pi <- ((m^-1*r[j]^-2))*(r12[j]*pi12.c[j]*(1 - pi12.c[j]) +
                                      (pi12.c[j]-Lam1)*(pi12.c[j]-Lam2)*(r12[j] - r[j]^2))

        if(method == "JZ ind") {
          var.pi <- var1.pi + var2.pi
        } else if(method == "EmProc") {
          var.pi <- var1.pi + var2.pi - 2*cov.pi
        }

        # Check to see if var.k is negative due to machine precision problem
        var.pi <- ifelse(var.pi < 0, 0, var.pi)
        se <- sqrt(var.pi)
        CI.int[j, ] <- cbind((pi1[j] - pi2[j]) - quant*se, (pi1[j] - pi2[j]) + quant*se)
        zscore <- (pi1[j] - pi2[j])/se
        p.val[j] <- 2*pnorm(-abs(zscore))
        p.val[j] <- ifelse(is.na(p.val[j]), 1, p.val[j])
      }
    } else if(method %in% c("binomial ind", "binomial")) {
      for(j in seq_along(k1.c)) {
        var1.pi <- (pi.c[j]*(1-pi.c[j]))/(m*r[j])
        var2.pi <- (pi.c[j]*(1-pi.c[j]))/(m*r[j])
        cov.pi <- (r12[j]/(m*r[j]^2))*(pi12.c[j]*(1 - pi12.c[j]))

        if(method == "binomial") {
          var.pi <- var1.pi + var1.pi - 2*cov.pi
        } else if(method == "binomial ind") {
          var.pi <- var1.pi + var1.pi
        }

        # Check to see if var.k is negative due to machine precision problem
        var.pi <- ifelse(var.pi < 0, 0, var.pi)
        se <- sqrt(var.pi)
        CI.int[j, ] <- cbind((pi1.c[j] - pi2.c[j]) - quant*se, (pi1.c[j] - pi2.c[j]) + quant*se)
        zscore <- (pi1.c[j] - pi2.c[j])/se
        p.val[j] <- 2*pnorm(-abs(zscore))
        p.val[j] <- ifelse(is.na(p.val[j]), 1, p.val[j])
      }
    } else if(method == "stouffer") {
      # TODO check that stouffer implemented correctly after changes
      for(j in seq_along(pi1.c)) {
        Sorder1 <-  order(S1,decreasing=TRUE)
        Sorder2 <-  order(S2,decreasing=TRUE)
        overlap.idx <- Sorder1[which(Sorder1[1:idx[j]] %in% Sorder2[1:idx[j]])]
        S1.unique.idx <- Sorder1[which(!Sorder1[1:idx[j]] %in% Sorder2[1:idx[j]])]
        S2.unique.idx <- Sorder2[which(!Sorder2[1:idx[j]] %in% Sorder1[1:idx[j]])]
        n12 <- length(overlap.idx)
        a <- sum(X[overlap.idx])
        d <- n12 - a
        n1 <- m*r[j] - n12
        e <- sum(X[S1.unique.idx])
        g <- sum(X[S2.unique.idx])
        p.1 <- e/n1
        p.2 <- g/n1
        p.bar <- (e + g)/(2*n1)
        if(correction == "plus") {
          n1 <- n1 + 4
          e <- e + 2
          g <- g + 2
        }
        z1 <- (p.1 - p.2)/sqrt((2*p.bar*(1-p.bar))/n1)
        z1 <- ifelse(is.na(z1), 0, z1)
        z3 <- 0
        w <- (n1 + n1)/(2*n12 + n1 + n1)
        z5 <- (w*z1 + (1-w)*z3)/(sqrt(w^2 + (1-w)^2))
        p.val[j] <- 2*(1 - pnorm(abs(z5)))
      }
    }
    # difference estimates
    est <- pi1 - pi2
  }
  list(diff_estimate = est, std_err = se.np, ci_interval = CI.int, p_value = p.val)
}


data=read.csv('/home/hoshank/Desktop/bdcc/balance_sheet.csv')

library("scrime")

data=read.csv('/home/hoshank/Desktop/bdcc/balance_sheet.csv')
cor(data)
install.packages("corrplot")
library("corrplot")
corrplot(cor(data))
corrplot(data)
library("ggplot2")
ggcorr(data)
install.packages("GGally")
library(GGally)
ggcorr(data)
ggcorr(data,label=FALSE)
ggcorr(data,label=TRUE)
ggcorr(data[2:4,],label=TRUE)
ggcorr(data[,2:4],label=TRUE)
ggcorr(data[2:4,])
ggcorr(data[3:4,])
ggcorr(data[1:4,])
data(1:4,)
data[1:4,]
data[2:4,]
data[1:3,]
ggcorr(data[1:3,])
ggcorr(data[1:3,],name="hh")
data2=names(data)<- NULL
head(data2)
data2=names(data)<-NULL
data2
data2=names(data1)<-NULL
data2
names(data1)<-NULL
data1
data
ggcorr(data[1:3,])
ggcorr(data[1:3,],labels=TRUE)
ggcorr(data[1:3,],label=TRUE)
ggcorr(data[1:3,],label=TRUE,geom="circle")
ggcorr(data[1:3,],label=TRUE,geom="circle",label_size = 2)
ggcorr(data[1:3,],label=TRUE,label_size = 3)
data[1:3,]
history()


#' Estimating the isodensity (ISO) environmental contours
#'
#' @description
#' This function estimates the isodensity (ISO) environmental contours for a fitted joint distribution of
#' class \code{ht} or \code{wln}.
#'
#' @param object the fitted joint distribution object as generated by function \code{\link{fit_ht}}
#' or \code{\link{fit_wln}}.  See details.
#'
#' @param output_rp the required return periods (in years) for the estimated contours.
#'
#' @param n_point the number of points to output around each contour. The default value is 100.
#'
#' @details
#' The estimated isodensity contour for is a set of points with constant joint
#' probability density, equal to that at the anchor point.  The anchor point for the \eqn{T}-year contour
#' is the \eqn{K}-year return level on wave height \code{hs}, and the conditional median of
#' the wave period \code{tp}. See the guidance by DNV-GL section 3.7.2.
#'
#' Due to the challenge of the non-parametric estimation of a joint denisty, the current version only
#' supports joint probability density estimation based on
#' the parametric form of the Weibull-log-normal model or the parametric part of the Heffernan-Tawn
#' model.  The residual distribution in the Heffernan-Tawn is approximted by a normal
#' distribution, rather than estimated using the kernel density.
#'
#' For this same reason, this function does not support sample data as the input \code{object}, unlike
#' the other contour estimation functions in this package.  When applied
#' to a fitted \code{ht} object, the quadrant below the dependence thresholds is ignored.
#'
#' @return
#' A set of estimated ISO contours with the specified return periods in the format
#' of a \code{data.table} with \code{rp}, \code{hs}, and \code{tp} as columns.
#'
#' @examples
#' # Estimating ISO contours based on a fitted ht object
#' data(ww3_pk)
#' ht = fit_ht(data = ww3_pk, npy = nrow(ww3_pk)/10, margin_thresh_count = 50, dep_thresh_count = 500)
#' ec_ht = estimate_iso(object = ht, output_rp = c(10,100,1000,10000))
#' plot_ec(ec = ec_ht, raw_data = ww3_pk)
#'
#' # Estimating ISO contours based on a fitted wln object
#' data(ww3_ts)
#' wln = fit_wln(data = ww3_ts, npy = nrow(ww3_ts)/10)
#' ec_wln = estimate_iso(object = wln, output_rp = c(10,100,1000,10000))
#' plot_ec(ec = ec_wln, raw_data = ww3_ts)
#'
#' @seealso \code{\link{fit_ht}}, \code{\link{fit_wln}}, \code{\link{plot_ec}}
#'
#' @references
#' DNVGL-RP-C205, Recommended Practice - Environmental conditions and environmental loads,
#' Edition August 2017, https://rules.dnvgl.com/docs/pdf/DNVGL/RP/2017-08/DNVGL-RP-C205.pdf
#'
#' Heffernan, Janet & A. Tawn, Jonathan. (2004). A Conditional Approach for Multivariate Extreme Values.
#' Journal of the Royal Statistical Society Series B. 66. 497-546. 10.1111/j.1467-9868.2004.02050.x.
#'
#'
#' @export
estimate_iso = function(object, output_rp, n_point=100){

  if("ht" %in% class(object)){

    res = .estimate_iso_from_ht(
      ht = object, output_rp = output_rp,
      n_point = n_point)

  }else if("wln" %in% class(object)){

    res = .estimate_iso_from_wln(
      wln = object, output_rp = output_rp,
      n_point = n_point)

  }else if("data.table" %in% class(object)){

    stop("Estimation of the isodensity contours based on sample data is not currently supported. Please consider
         the alternative types of contours or fitting a Weibull-log-normal or Heffernan-Tawn distribtuion to
         the data set first.")

  }else{

    stop("The input object must be of class ht or wln.")
  }
  return(res)
}

# Estimate the contour based on a formulated wln --------------------------

.estimate_iso_from_wln = function(wln, output_rp, n_point, ...){

  ## Anchor point log-density
  hs_par = wln$hs$par
  tp_par = wln$tp$par
  prob_hs = 1-1/(output_rp*wln$npy)
  hs0 = qweibull(p = prob_hs, shape = hs_par[["shape"]], scale = hs_par[["scale"]])+hs_par[["loc"]]
  tp0 = exp(tp_par[1] + tp_par[2] * hs0^tp_par[3])
  ld0 = .ldwln(hs0, tp0, hs_par, tp_par)

  ## Main loop
  res_list = list()
  for(i in 1:length(output_rp)){

    ### Identify ranges of hs
    this_hs_range = .find_hs_range_given_ldwln(
      target_ldwln = ld0[i], hs_par = hs_par, tp_par = tp_par, hs_rl = hs0[i])
    this_calc = data.table(hs = seq(this_hs_range[1], this_hs_range[2], length.out = round(n_point/2)+1))

    ### Find the corresponding tp
    this_calc[, mean_log:=tp_par[1] + tp_par[2] * (hs^tp_par[3])]
    # this_calc[, sd_log:=tp_par[4] + tp_par[5] * exp(tp_par[6] * hs)]
    this_calc[, sd_log:=pmax(.limit_zero, tp_par[4] + tp_par[5] * exp(tp_par[6] * hs))]
    this_calc[, ld_hs:=log(dweibull(hs-hs_par[["loc"]], shape=hs_par[["shape"]], scale=hs_par[["scale"]]))]
    this_calc[, ld_tp:=ld0[i]-ld_hs]
    for(i_row in 1:this_calc[,.N]){
      i_tp_range = this_calc[i_row, .find_tp_given_ldtp(ld_tp, mean_log, sd_log)]
      this_calc[i_row, tp_lb:=i_tp_range[1]]
      this_calc[i_row, tp_ub:=i_tp_range[2]]
    }

    ### Return
    res_list[[i]] = this_calc[, .(
      rp = output_rp[i],
      hs = hs[c(1:(.N-1), .N:1)],
      tp = c(tp_lb[1:(.N-1)], tp_ub[.N]/2+tp_lb[.N]/2, tp_ub[(.N-1):1]))]
  }

  ## Return
  res = rbindlist(res_list)
  return(res)
}

.ldwln = function(hs, tp, hs_par, tp_par){
  f_hs = dweibull(hs-hs_par[["loc"]], shape=hs_par[["shape"]], scale=hs_par[["scale"]])
  mean_log = tp_par[1] + tp_par[2] * (hs^tp_par[3])
  sd_log = pmax(.limit_zero, tp_par[4] + tp_par[5] * exp(tp_par[6] * hs))
  f_tp_hs = dlnorm(tp, meanlog = mean_log, sdlog = sd_log)
  return(log(f_hs)+log(f_tp_hs))
}

.find_max_ldwln_given_hs = function(hs, hs_par, tp_par){
  mean_log = tp_par[1] + tp_par[2] * (hs^tp_par[3])
  sd_log = pmax(.limit_zero, tp_par[4] + tp_par[5] * exp(tp_par[6] * hs))
  tp_mode = exp(mean_log-sd_log^2)
  return(.ldwln(hs, tp_mode, hs_par, tp_par))
}

.find_hs_range_given_ldwln = function(target_ldwln, hs_par, tp_par, hs_rl){
  op_fn = function(hs, hs_par, tp_par)(.find_max_ldwln_given_hs(hs, hs_par, tp_par)-target_ldwln-.limit_zero)^2
  # op1 = optim(
  #   par = hs_rl/4, fn = op_fn, hs_par=hs_par, tp_par=tp_par, method = "Brent",
  #   lower = hs_par["loc"], upper = hs_rl/1.1)
  op2 = optim(
    par = hs_rl, fn = op_fn, hs_par=hs_par, tp_par=tp_par, method = "Brent",
    lower = hs_rl/2, upper = hs_rl*2)
  # c(op1$par, op2$par)
  c(hs_par["loc"]+.limit_zero, op2$par)
}

.find_tp_given_ldtp = function(target_ldtp, mean_log, sd_log){
  op_fn = function(tp, target_ldtp, mean_log, sd_log)
    (log(dlnorm(tp, meanlog = mean_log, sdlog = sd_log))-target_ldtp)^2

  op1 = optim(
    par = .limit_zero, fn = op_fn,
    mean_log=mean_log, sd_log=sd_log, target_ldtp = target_ldtp,
    method = "Brent", lower = .limit_zero, upper = exp(mean_log-sd_log^2))
  op2 = optim(
    par = exp(mean_log-sd_log^2), fn = op_fn,
    mean_log=mean_log, sd_log=sd_log, target_ldtp = target_ldtp,
    method = "Brent", lower = exp(mean_log-sd_log^2), upper =  exp(mean_log-sd_log^2)*10)
  return(c(op1$par, op2$par))
}

# Esimate the contour based on a formulated ht ----------------------------

.estimate_iso_from_ht = function(ht, output_rp, n_point){

  ## Find anchro points
  ap = .find_ht_iso_anchor_points(ht, output_rp)

  ## Calculate density on lap_grid exceedance area only
  lap_thresh = -log(2-2*ht$dep$p_dep_thresh)
  max_lap = -2*log(2-2*(1-1/max(output_rp)/ht$npy))
  dlap = (max_lap-lap_thresh)/max(100,n_point)
  range_lap = seq(max_lap, by = -dlap, to = -max_lap)
  grid_lap = data.table(
    lap_hs = range_lap, lap_tp = rep(range_lap, each=length(range_lap)))
  setkey(grid_lap, lap_hs, lap_tp)
  ld_calc = .ld_ht(dt_lap = grid_lap[, .(lap_hs, lap_tp)], ht = ht)
  grid_lap = merge(grid_lap, ld_calc, by = c("lap_hs", "lap_tp"))

  ## Draw contours
  mat = as.matrix(dcast.data.table(grid_lap, lap_hs~lap_tp, value.var = "ld")[,-1,with=F])
  cl = contourLines(
    x = sort(range_lap), y = sort(range_lap),
    z = mat, levels = ap$ld)
  res = rbindlist(lapply(cl, function(x)data.table(ld=x$level, lap_hs=x$x, lap_tp=x$y)))

  ## Convert contour to original scale
  res[, u_hs:=.convert_lap_to_unif(lap_hs)]
  res[, hs:=.convert_unif_to_origin(
    unif = u_hs, p_thresh = ht$margin$p_margin_thresh, gpd_par = ht$margin$hs$par, emp = ht$margin$hs$emp)]

  res[, u_tp:=.convert_lap_to_unif(lap_tp)]
  res[, tp:=.convert_unif_to_origin(
    unif = u_tp, p_thresh = ht$margin$p_margin_thresh, gpd_par = ht$margin$tp$par, emp = ht$margin$tp$emp)]

  res[, angle:=atan2(y = lap_tp, x = lap_hs)/pi*180]

  ## Refine output contour
  contour = merge(res[, .(ld, hs, tp, angle)], ap[, .(ld, rp)], by = "ld")[, .(rp, hs, tp, angle)]
  setkey(contour, rp, angle)
  out = contour[, .SD[round(seq(1, .N, length.out = n_point))], .(rp)]

  ## Return
  return(out[, .(rp, hs, tp)])
}

.find_ht_iso_anchor_points = function(ht, output_rp){

  ## Find lap_hs0
  npy = ht$npy
  p_dep_thresh = ht$dep$p_dep_thresh
  p_hs0 = 1-(1/(output_rp*npy))
  if(any(p_hs0<ht$dep$p_dep_thresh)){
    warning("Not all output_rp are above the threshold for the Heffernan-Tawn model.")
    warning("Those below the threshold will be ignored.")
    warning("Increase the argument dep_thresh_count in function fit_ht, or adjust the output RP for the
            contours.")
  }
  keep_idx = which(p_hs0>=p_dep_thresh)
  lap_hs0 = -log(2*(1-p_hs0))[keep_idx]
  p_hs0 = p_hs0[keep_idx]
  output_rp = output_rp[keep_idx]

  ## Find median lap_tp0 given lap_hs0
  dep_par = ht$dep$hs$par
  dep_median_resid = median(ht$dep$hs$resid)
  lap_tp0 = lap_hs0*dep_par[["a"]]+dep_median_resid*lap_hs0^dep_par[["b"]]
  p_tp0 = 1-exp(-abs(lap_tp0))/2

  ## Find hs0
  hs0_calc = data.table(p = p_hs0, p_gpd = (p_hs0-ht$margin$p_margin_thresh)/(1-ht$margin$p_margin_thresh))
  hs_par = ht$margin$hs$par
  hs0_calc[p_gpd<1 & p_gpd>0, hs0:= qgpd(
    p_gpd, loc=hs_par[["loc"]], scale = hs_par[["scale"]], shape = hs_par[["shape"]])]

  ## Find tp0
  tp0_calc = data.table(p = p_tp0, p_gpd = (p_tp0-ht$margin$p_margin_thresh)/(1-ht$margin$p_margin_thresh))
  tp0_calc[, tp0:=quantile(ht$dep$dep_data$tp, p)]
  if(tp0_calc[p_gpd<1 & p_gpd>0, .N]>0){
    tp_par = ht$margin$tp$par
    tp0_calc[p_gpd<1 & p_gpd>0, tp0:= qgpd(
      p_gpd, loc=tp_par[["loc"]], scale = tp_par[["scale"]], shape = tp_par[["shape"]])]
  }

  ## Estimate density
  out = data.table(rp=output_rp, hs0=hs0_calc$hs0, tp0=tp0_calc$tp0, lap_hs0 = lap_hs0, lap_tp0 = lap_tp0)
  setkey(out, lap_hs0, lap_tp0)
  ld_calc = .ld_ht(dt_lap = out[, .(lap_hs=lap_hs0, lap_tp=lap_tp0)], ht = ht)
  out[, ld:=ld_calc$ld]

  ## Return
  return(out[, .(rp, hs0, tp0, ld)])
}

.ld_ht = function(dt_lap, ht){
  calc = copy(dt_lap)
  lap_thresh = -log(2-2*ht$dep$p_dep_thresh)
  out = list()
  for(cond_var in c("hs","tp")){
    dep_var = setdiff(c("hs", "tp"), cond_var)
    this_resid = ht$dep[[cond_var]]$resid
    this_mu = mean(this_resid)
    this_sigma = sd(this_resid)
    setnames(calc, paste0("lap_", cond_var), "cond_var")
    setnames(calc, paste0("lap_", dep_var), "dep_var")

    this_par = ht$dep[[cond_var]]$par
    calc[cond_var>=lap_thresh, resid:=(dep_var-this_par[["a"]]*dep_var)/(cond_var^this_par[["b"]])]
    calc[cond_var>=lap_thresh, ld_resid:=dnorm(resid, mean=this_mu, sd = this_sigma, log = T), .(resid)]
    calc[cond_var>=lap_thresh, ld_dep:=ld_resid-log(cond_var)*this_par[["b"]]]
    calc[cond_var>=lap_thresh, ld_cond:=log(.5)-abs(cond_var)]
    calc[cond_var>=lap_thresh, ld:=ld_cond+ld_dep]
    setnames(calc, "cond_var", paste0("lap_", cond_var))
    setnames(calc, "dep_var", paste0("lap_", dep_var))
    setnames(calc, "ld", paste0("ld_", cond_var))
    out[[cond_var]] = calc[, c("lap_hs", "lap_tp", paste0("ld_", cond_var)), with=F]
  }

  calc = merge(out[[1]], out[[2]], by=c("lap_hs", "lap_tp"))
  calc[lap_hs<lap_thresh & lap_tp<lap_thresh, ld:=NA_real_]
  calc[lap_hs>=lap_thresh & lap_tp>=lap_thresh, w_hs:= (lap_hs-lap_thresh)/(lap_hs+lap_tp-2*lap_thresh)]
  calc[lap_hs>=lap_thresh & lap_tp>=lap_thresh, w_tp:= 1-w_hs]
  calc[lap_hs>=lap_thresh & lap_tp>=lap_thresh, ld:=ld_hs*w_hs+ld_tp*w_tp]
  calc[lap_hs>=lap_thresh & lap_tp<lap_thresh, ld:=ld_hs]
  calc[lap_hs<lap_thresh & lap_tp>=lap_thresh, ld:=ld_tp]
  return(calc[, .(lap_hs, lap_tp, ld)])
}


#Seeing the current directory
getwd()
#Setting the current directory
setwd('C:/Users/anura/Downloads')
#Required packages
library(funModeling)
library(tidyverse)
library(Hmisc)
library(DataExplorer)
#Load libraries
library(dplyr)
library(caret)
library(lattice)

library(magrittr)
suppressPackageStartupMessages(library(tidyverse))
suppressPackageStartupMessages(library(ggplot2))
suppressPackageStartupMessages(library(scales))
suppressPackageStartupMessages(library(gridExtra))
#reading data
hotels <- read.csv('hotel_bookings.csv')
#First 6 rows
head(hotels)
#Dimension of the hotel data set
dim(hotels)
#Summary of the hotel data set
summary(hotels)

H=hotels
dim(hotels)
#Dropping the agent column
#hotels <-hotels[ ,-c(24)]
is.na(hotels$agent)
#Missing value of hotel data set
plot_missing(hotels)
#There are 4 missing values in column children
#There are many missing values in categorical data we have to clean it
sum(is.na(hotels))
#Structure of the hotel data set
str(hotels)

# ---------------------Missing VALUE REPLACEMENT-----------------------------------

#Replacing  missing values in Children column from the corresponding Babies column
n <- length(hotels$children)
for (i in 1:n) {
  if (is.na(hotels$children[i]))
    hotels$children[i] <- hotels$babies[i]
}
#Get MOde
getmode <- function(v) {
  uniqv <- unique(v)
  uniqv[which.max(tabulate(match(v, uniqv)))]
}

#Replacing undefined as SC .Both means no meal package
hotels <-fix(hotels)
hotels$meal <-replace(hotels$meal,hotels$meal=='Undefined','SC')
#We are dropping the levels as we have replaced Undefined with SC
hotels$meal <- factor(hotels$meal)
unique(hotels$meal)
hotels
#Replacing Undefinded with mode
#Function to calculate mode
modeM <- getmode(hotels$market_segment)
modeM
#Replacing Undefined with mode
hotels$market_segment <- replace(hotels$market_segment,hotels$market_segment=='Undefined',modeM)
#We are droping the levels as we have replaced Undefined with mode
hotels$market_segment <- factor(hotels$market_segment)
#Checking unique value in market_segment
unique(hotels$market_segment)

#Replacing Undefinded with mode
#Function to calculate mode
modeD <- getmode(hotels$distribution_channel)
modeD
#Replacing Undefined with mode
hotels$distribution_channel <- replace(hotels$distribution_channel,hotels$distribution_channel=='Undefined',modeD)
#We are droping the levels as we have replaced Undefined with mode
hotels$distribution_channel <- factor(hotels$distribution_channel)
#Checking unique value in market_segment
unique(hotels$distribution_channel)

#Correlation of numeric data
my_num_data <- hotels[, sapply(hotels, is.numeric)]
cor(my_num_data, use = "complete.obs", method = "pearson")

#checking missing values in quantitve columns
sapply(hotels, function(x) sum(is.na(x)))
#Missing value of quantitive hotel data set
plot_missing(hotels)
#describeBy function
library(psych)
psych::describe(hotels)
describeBy(hotels, hotels$hotel)

#--------------------checking our data after cleaning-----------------------------------------------

#Good way to see the dataframe dividing categorical and qualntitve features

library(skimr)

skim(hotels)

#--------------------------------------------------EDA---------------------------------------------------#

#Hotels
ggplot(hotels,aes(x=factor(hotel))) +
  geom_bar(col ="black",fill="#993333",alpha=0.5) +
  theme(axis.text.x = element_text(face="bold", size=10)) +
  scale_x_discrete("Hotel") +
  scale_y_continuous("Count")

# Number of arrival Date by Month
d <- hotels %>%
  group_by(arrival_date_month) %>%
  count() %>%
  arrange(match(arrival_date_month,month.name))
d <- data.frame(ArrivalDateMonth = d$arrival_date_month,N =d$n);
d
# Graph of Number of arrival Date by Month
ggplot(hotels,aes(factor(arrival_date_month,levels=month.name))) +
  geom_bar(col ="black",fill="#993333",alpha=0.5) +
  theme(axis.text.x = element_text(face="bold", size=8, angle=30)) +
  scale_y_continuous("Count",limits = c(0,15000),breaks=seq(0,15000,by=1500)) +
  scale_x_discrete("Month")

#NUmber of city hotel and Resort Hotel cancelled or not cancelled
ggplot(data = hotels,aes(factor(is_canceled)))+
  geom_bar( col='black', fill="#993333", alpha = 0.5) +
  facet_wrap(~hotel) +
  scale_x_discrete("Canceled",labels = c("No","Yes")) +
  scale_y_continuous("Count",limits = c(0,50000),breaks=seq(0,47222,by=5000))  +
  theme(axis.text.x = element_text(face="bold", size=10))

#Canceled and Lead time
ggplot(data = hotels, aes(x = factor(is_canceled), y = lead_time  )) +
  geom_boxplot(col='black', fill="#993333", alpha = 0.5) +
  theme(axis.text.x = element_text(face="bold", size=10)) +
  scale_y_continuous("Lead Time",limits = c(0,800),breaks=seq(0,800,by=100)) +
  scale_x_discrete("Canceled",labels = c("No","Yes"))

#Year of arrival
barplot(table(hotels$arrival_date_year), col='orange')

#May and October have  the highest waiting times; these months represent the times right before and after peak reservation months (respectively)
ggplot(hotels, aes(x=arrival_date_month, y=days_in_waiting_list, group=1)) + stat_summary(fun="mean", geom="line", col="navy") +
  ggtitle("Average Days on Waiting List by Arrival Month") + ylab("Waiting List: Average Days") + xlab("Month") +
  theme(axis.text.x=element_text(angle=40))

#The number of children included on reservations peaks in August, summer vacation season
hotels %>% group_by(arrival_date_month) %>% summarize(MEANADULTS=mean(adults)) -> ADULTS
hotels %>% group_by(arrival_date_month) %>% summarize(MEANCHILDREN=mean(children)) ->CHILDREN
ADULTS<-data.frame(ADULTS)
CHILDREN<-data.frame(CHILDREN)
ADULTSCHILDREN<-merge(ADULTS, CHILDREN, by="arrival_date_month")

ggplot(data=ADULTSCHILDREN) +
  geom_line(aes(y=MEANADULTS, x=arrival_date_month, group=1, col="Adults")) +
  geom_line(aes(y=MEANCHILDREN, x=arrival_date_month, group=1, col="Children")) +
  ggtitle("Average Adults and Children Reserved for by Arrival Month") + xlab("Month") + ylab("Average Days") +
  theme(axis.text.x=element_text(angle=40))

#Online market segment's cancellation is more
hotels%>% group_by(hotels$market_segment)  %>% summarise(length(is_canceled))

#City Hotel Cancellation is more
hotels %>% group_by(hotels$hotel)  %>% summarise(length(is_canceled))

#Couples booking cancellation is more
hotels %>% group_by(hotels$adults)  %>% summarise(length(is_canceled))

#'A' type room cancellation is higher
hotels %>% group_by(hotels$reserved_room_type)  %>% summarise(length(is_canceled))

##---------Few time Series EDA-------------
#Reservation status date by year
ts<- hotels%>%group_by(reservation_status_date)%>%summarise(n=n())
ts$reservation_status_date <- as.Date(ts$reservation_status_date)
ggplot(ts, aes(reservation_status_date, n)) + geom_line()

#Time Series Analysis
ggplot(ts, aes(reservation_status_date, n)) + geom_line()

ts <- ts %>% filter(!is.na(n))
ts
# Frequency is set with 365 because it's daily
components <- stl(ts(ts$n, frequency=365), 'periodic')
# seasonal, trend, remainder
plot(components)

# note this data use the booking confirmation and not the check ins, so this graph shows the
# booking made for particular month and not the confirmed check ins.

ggplot(hotels, aes(arrival_date_month, fill = factor(is_canceled))) +
  geom_bar() + geom_text(stat = "count", aes(label = ..count..), hjust = 1) +
  coord_flip() + scale_fill_discrete(
    name = "Booking Status",
    breaks = c("0", "1"),
    label = c("Cancelled", "Not Cancelled")
  ) +
  labs(title = "Booking Status by Month",
       x = "Month",
       y = "Count") + theme_bw()

plot_str(hotels)         #show data structure
introduce(hotels)        #show basic description
plot_intro(hotels)       #plot basic description
describe(hotels)
summary(hotels)
df_status(hotels)

###################################### Univariate stats #######################################

plot_num(hotels)         #plot histogram of all numeric data
plot_histogram(hotels)
plot_bar(hotels)
plot_density(hotels)     #show density plot of all data
plot_correlation(hotels)
barplot(table(hotels$arrival_date_year))
barplot(table(hotels$arrival_date_month))

################################# Bivariate stats##############################################

hotels$is_canceled=as.numeric(hotels$is_canceled)
#cancellations for both the hotels
ggplot(data = hotels,aes(is_canceled))+ geom_histogram(binwidth = 0.5,
                                                       col='black', fill='blue',alpha=0.4) + facet_wrap(~hotel)

#cancellation leadtime
ggplot(data=hotels,aes(lead_time))+ geom_histogram(binwidth = 0.5)+facet_wrap(~is_canceled)

#stay duration for both the hotels
ggplot(data=hotels, aes(stays_in_weekend_nights + stays_in_week_nights))+geom_density(col="red")+facet_wrap(~hotel)+theme_bw()

#Average daily rate for both hotels
ggplot(data=hotels,aes(x=adr,fill=hotel,color=hotel))+geom_histogram(aes(y=..density..),
                                                                     position = position_dodge(),binwidth=80)+geom_density(alpha=0.2)+
  labs(title = "Average Daily rate by Hotel", x = "Hotel Price(in Euro)",y = "Count")+
  scale_color_brewer(palette = "Paired") + theme_classic() + theme(legend.position = "top")

#Hotel preference by customer type
ggplot(data=hotels,aes(customer_type,fill=hotel)) +geom_bar(stat="count",position = position_dodge())

# Meal
ggplot(data = hotels,aes( x = meal,fill = meal,y = prop.table(stat(count)),
                          label = scales::percent(prop.table(stat(count))))) +  geom_bar() +
  geom_text(stat = "count", position = position_dodge(1),vjust = 1, hjust=0,size = 3)+scale_y_continuous(labels = scales::percent) + coord_flip() +labs(title = "Bookings by Meal", x = "Meal type",y = "Number of bookings") +
  geom_text(stat = "count", aes(label = ..count..), hjust = 5)

#market segment
ggplot(data = hotels,aes( x = market_segment,fill = market_segment,y = prop.table(stat(count)),
                          label = scales::percent(prop.table(stat(count))))) +  geom_bar() +
  geom_text(stat = "count", position = position_dodge(1),vjust = 1, hjust=0,size = 3)+scale_y_continuous(labels = scales::percent) + coord_flip() +labs(title = "Bookings by Market Segment", x = "MS type",y = "Number of bookings") +
  geom_text(stat = "count", aes(label = ..count..), hjust = 1)

#----------------------------------- Questions to Answer -------------------------------------------

#Q1.Are the Guest with children need parking space then guest with no children?(Multivariate)

hotel_stays <- hotels %>%
  filter(is_canceled == 0) %>%
  mutate(
    children = case_when(
      children + babies > 0 ~ "children",
      TRUE ~ "none"
    ),
    required_car_parking_spaces = case_when(
      required_car_parking_spaces > 0 ~ "parking",
      TRUE ~ "none"
    )
  )#%>%
#select(-is_canceled, -reservation_status, -babies)

hotel_stays

hotel_stays %>%
  count(hotel, required_car_parking_spaces, children) %>%
  group_by(hotel, children) %>%
  mutate(proportion = n / sum(n)) %>%
  ggplot(aes(required_car_parking_spaces, proportion, fill = children)) +
  geom_col(position = "dodge") +
  scale_y_continuous(labels = scales::percent_format()) +
  facet_wrap(~hotel, nrow = 2) +
  labs(
    x = NULL,
    y = "Proportion of hotel stays",
    fill = NULL
  )

# 2. WHich customer type pay more in  the hotels (this is for not cancelled one)?
#library(GGally)
#hotel_stays %>%
#select(
#hotel, adr,
#customer_type,
#total_of_special_requests
#  ) %>%
# ggpairs(mapping = aes(color = customer_type))

# 3.Which country the guest come from (for non cancelled)? Need to do some work not able to draw the map by plotly
country <- hotels %>%
  filter(is_canceled==0)%>%
  count(country)

country

#-------------------------------------Plotly Interactive Graphs---------------------------
# Load the plotly package
library(plotly)

# Store the scatterplot of total_of_special_request vs.previous_bookings_not_canceled in 2016
scatter <- hotels %>%
  filter(arrival_date_year == '2016') %>%
  ggplot(aes(x = total_of_special_requests, y = previous_bookings_not_canceled)) +
  geom_point(alpha = 0.3)

# Convert the scatterplot to a plotly graphic
ggplotly(scatter)

#Histogram of lead time
# Create a histogram with bins of width 10 between 0 and 100
hotels %>%
  plot_ly(x = ~lead_time) %>%
  add_histogram(xbins = list(start=0,end=100, size=10),color=I('#111e6c'))

#Bar Plot for meal
# Create a frequency for meal
meal_table <- hotels %>%
  count(meal)

# Reorder the bars for meal by n
meal_table %>%
  mutate(meal = fct_reorder(meal, n, .desc = TRUE)) %>%
  plot_ly(x = ~meal, y = ~n) %>%
  add_bars()
meal_table

# Create a frequency for country
country_table <- hotels %>%
  count(country)
#Bar Plot for country
country_table %>%
  mutate(country = fct_reorder(country, n, .desc = TRUE)) %>%
  plot_ly(x = ~country, y = ~n) %>%
  add_bars()
country_table

# Create a scatter plot of days in waiting against lead time
hotels %>%
  plot_ly(x = ~days_in_waiting_list, y = ~lead_time) %>%
  add_markers(marker= list(opacity=0.2))

# Filter out the Reservation status and depodit type
Dep_Reserv<- hotels%>%
  filter(arrival_date_year == 2016 | arrival_date_year==2017 | arrival_date_year==2015)

#Create a stacked bar chart of Reservation type by Deposit type
Dep_Reserv %>%
  count(deposit_type, reservation_status) %>%
  plot_ly(x = ~deposit_type, y = ~n, color = ~reservation_status) %>%
  add_bars() %>%
  layout(barmode = "stack")

# Made a table
WaitingReserved<- hotels%>%
  filter(arrival_date_year == 2016 | arrival_date_year==2017 | arrival_date_year==2015)

# Create boxplots of days_in_waiting_list by reserved_room_type for above data
WaitingReserved %>%
  plot_ly(x = ~days_in_waiting_list, y =  ~reserved_room_type,hover_info='text',text=~paste("Days in waiting:",days_in_waiting_list,"Reserved room type:",reserved_room_type)) %>%
  add_boxplot()

# Use color to add is_cancelled as a third variable
hotels%>%
  plot_ly(x = ~days_in_waiting_list, y = ~previous_bookings_not_canceled, color = ~hotel) %>%
  add_markers(colors = "Dark2",marker= list(opacity=0.2))

# Polish the scatterplot by transforming the x-axis and labeling both axes

hotels%>%
  plot_ly(x = ~total_of_special_requests, y = ~adr) %>%
  add_lines() %>%
  layout(paper_bgcolor = "#ebebeb", xaxis = list(showgrid = FALSE))


Auto=read.table("datasets/Auto.data", header=TRUE, na.strings="?")
attach(Auto)
plot(cylinders, mpg)


# Assignment 3: Using Data
#
# Before you get started:
# - Set your working directory to "source file location" using the Session menu
# - Run the following line of code to delete all variables in your workspace
#     (This will make it easier to test your script)
rm(list = ls())

### Built in R Data ###########################################################

# In this section, you'll work with the variable `Titanic`, a data set which is
# built into the R environment.
# This data set actually loads in a format called a *table*
# See https://cran.r-project.org/web/packages/data.table/data.table.pdf
# Use the `is.data.frame()` function to test if it is a table.
is.data.frame(Titanic)

# Create a variable `titanic_df` by converting `Titanic` into a data frame;
# you can use the `data.frame()` function or `as.data.frame()`
titanic_df <- data.frame(Titanic, stringsAsFactors = FALSE)

# It's important to understand the _meaning_ of each column before analyzing it
# Using comments below, describe what information is stored in each column
# For categorical variables, list all possible values
# Class: [What class they were on the ship]
# Sex: [The gender of the person (male or female)]
# Age: [The age of the person (child or adult)]
# Survived: [Whether or not anyone survived the wreck]
# Freq: [The frequency of the data]

# Create a variable `children` that is a data frame containing only the rows
# from `titanic_df` with information about children on the Titanic
# Hints:
# - Filter rows using a vector of boolean values (like vector filtering)
# - See chapter 10.2.3
children <- data.frame(titanic_df[titanic_df$Age == "Child", ])

# Create a variable `num_children` that is the total number of children.
# Hint: Remember the `sum()` function!
num_children <- sum(titanic_df$Age == "Child")

# Create a variable `most_lost` that is the *row* from `titanic_df` with the
# largest absolute number of losses (people who did not survive)
# You can use multiple lines of code if you find that helpful
# to create this variable
# Hint: Filter for those who did not survive, then look for the row
dead <- titanic_df[titanic_df$Survived == "No", ]
most_lost <- dead[dead$Freq == max(dead$Freq), ]

# Define a function called `survival_rate()` that takes in two arguments which
# must be in *the following order*:
# - a ticket class (e.g., "1st", "2nd"), and
# - the dataframe itself (it's good practice to explicitly pass in data frames)
#
# This function should return a sentence that states the *survival rate*
# (# survived / # in group) of adult men and "women and children" in that
# ticketing class.
# It should read (for example):
# >"Of Crew class, 87% of women and children survived and 22% of men survived."
#
# This is a complicated function! We recommend the following approach:
# - Filter for all rows representing the given ticketing class and save the
#   new data frame to a variable
# - Using this data frame, filter for all rows representing Adult Males
# - Find the total number of men and total number of male survivors to
#   calculate the survival rate
# - Likewise, use the data frame to filter for all Children and Adult Females
# - Perform the above calculation for this group as well
#
# Other approaches are also acceptable, please comment to explain what you do!

survival_rate <- function(ticket_class, data_frame) {
  #Filters to the adult males
  class <- data.frame(data_frame[data_frame$Class == ticket_class, ])

  #Using this data frame, filter for all rows representing Adult Males and Female and Children
  data_male <- data.frame(class[class$Age == "Adult" & class$Sex == "Male", ])
  data_wom <- data.frame(class[class$Sex == "Female" | class$Age == "Child", ])

  #Find the total number of men and total number of survivors
  males_survived <- data.frame(data_male[data_male$Survived == "Yes", ])
  wom_survived   <- data.frame(data_wom [data_wom$Survived == "Yes", ])

  #Found the total survival rate
  male_survival_rate <- round(sum(males_survived["Freq"]) * 100 / sum(data_male["Freq"]))
  wom_survival_rate <- round((sum(wom_survived["Freq"])) * 100 / (sum(data_wom["Freq"])))

  output <= paste0("Of ", ticket_class, " class, ", wom_survival_rate,"% of women and children survived and ", male_survival_rate, "% of men survived.")
  return(output)
}

survival_rate("1st", titanic_df)

# Create variables `first_survived`, `second_survived`, `third_survived` and
# `crew_survived` by passing each class and the `titanic_df` data frame
# to your `survival_rate` function
first_survived <- survival_rate("1st", titanic_df)
second_survived <- survival_rate("2nd", titanic_df)
third_survived <- survival_rate("3rd", titanic_df)
crew_survived <- survival_rate("Crew", titanic_df)

# What notable differences do you observe in the survival rates across classes?
# Note at least 2 observations.
# [1. The people that had a high class had a higher survival rate.
#  2. The children were much more likely to die compared to the adults in all the classes.]

# What notable differences do you observe in the survival rates between the
# women and children versus the men in each group?
# Note at least 2 observations.
# [1. More women and children survived compared to the men
#  2. In the second class, more than 10x as many women and children survived compared to men]

### Reading in Data ###########################################################

# In this section, you'll work with .csv data of life expectancy by country
# First, download the csv file of `Life Expectancy` data from GapMinder:
# https://www.gapminder.org/data/
# You should save the .csv file into your `data` directory

# Before getting started, explore the GapMinder website to better understand
# the *original* source of the data (e.g., who calculated these estimates)
# Place a brief summary of the each data source here (e.g., 1 - 2 sentences
# per data source)
# []

# Using the `read.csv` function, read the life_expectancy_years.csv file into
# a variable called `life_exp`.
life_exp <- read.csv("data/life_expectancy_years.csv", )

# Write a function `get_col_mean()` that takes a column name and a data frame
# and returns the mean of that column. Make sure to properly handle NA values
# Hint: `mean()` takes in an argument called `na.rm`
get_col_mean <- function(column_name, data_frame_2) {
  name <- paste0("X", column_name)
  mean(data_frame_2[, name], na.rm = T )
}

# Create a list `col_means` that has the mean value of each column in the
# data frame (except the `Country` column). You should use your function above.
# Hint: Use an `*apply` function (lapply, sapply, etc.)

# Create a variable `avg_diff` that is the difference in average country life
# expectancy between 1800 and 2018
avg_diff <- get_col_mean("2018", life_exp) - get_col_mean("1800", life_exp)

# Create a column `life_exp$change` that is the change in life
# expectancy from 2000 to 2018. Increases in life expectancy should
# be *positive*
life_exp["change"] <- (life_exp["X2018"] - life_exp["X2000"])

# Create a variable `most_improved` that is the *name* of the country
# with the largest gain in life expectancy. Make sure to filter NA values
# Hint: `max()` takes in an argument called `na.rm`
most_improved <- life_exp[which.max(life_exp$change),]["country"]

# Create a variable `num_small_gain` that has the *number* of countries
# whose life expectance has improved less than 1 year between 2000 and 2018
# Make sure to filter NA values
# Hint: Lookup `is.na()`
num_small_gain <- nrow(!is.na(life_exp[life_exp$change < 1 & life_exp$change > 0, ]))

# Write a function `country_change()` that takes in a country's name,
# two years as numbers (not strings), and the `life_exp` data frame
# Parameters should be written *in the above order*
# It should return the phrase:
# "Between YEAR1 and YEAR2, the life expectancy in COUNTRY went DIRECTION by
# SOME_YEARS years".
# Make sure to properly indictate the DIRECTION as "up" or "down"
# Hint: Use an if/else statement to help compute DIRECTION
country_change <- function(country_name, year1, year2, data_frame) {
  date1 <- paste0("X", year1)
  date2 <- paste0("X", year2)
  first <- data_frame[data_frame["country"] == country_name, date1]
  second <- data_frame[data_frame["country"] == country_name, date2]
  change <- round(second - first)
  if (change >= 0) {
    output <- paste0("Between ", year1, " and ", year2, " the life expectancy in ", country_name, " went up by ", change, " years")
  }
  else {
    change = 0 - change
    output <= paste0("Between ", year1, " and ", year2, " the life expectancy in ", country_name, " went down by ", change, " years")
  }
  return(output)
}

# Using your `country_change()` function, create a variable `sweden_change`
# that is the change in life expectancy from 1960 to 1990 in Sweden
sweden_change <- country_change("Sweden", 1960, 1990, life_exp)

# Write a function `compare_change()` that takes in two country names and your
# `life_exp` data frame as parameters, and returns a sentence that describes
# their change in life expectancy from 2000 to 2018 (the `change` column)
# For example, if you passed the values "China", and "Bolivia" to you function,
# It would return this:
# "The country with the bigger change in life expectancy was China (gain=6.9),
#  whose life expectancy grew by 0.6 years more than Bolivia's (gain=6.3)."
# Make sure to round your numbers to one digit (though only after calculations)
# Hint: Use an if/else statement to paste the countries in the correct order
compare_change <- function(country1, country2, data_frame) {
  gain <- round(data_frame[data_frame["country"] == country1, "change"] - data_frame[data_frame["country"] == country2, "change"])
  gain2 <- 0 - gain
  first <-  round(data_frame[data_frame["country"] == country1, "change"])
  second <- round(data_frame[data_frame["country"] == country2, "change"])
  if (gain >= 0) {
    output <- paste0("The country with the bigger change in life expectancy was ", country1, " (gain=", first, "), whose life expectancy grew by ", gain, " years more than ", country2, " (gain=", second, ").")
  }
  else {
    output <- paste0("The country with the bigger change in life expectancy was ", country2, " (gain=", second, "), whose life expectancy grew by ", gain2, " years more than ", country1, " (gain=", first, ").")
  }
  return(output)
}

# Using your `bigger_change()` function, create a variable `usa_or_france`
# that describes who had a larger gain in life expectancy (the U.S. or France)
usa_or_france <- compare_change("United States", "France", life_exp)

# Write your `life_exp` data.frame to a new .csv file to your
# data/ directory with the filename `life_exp_with_change.csv`.
# Make sure not to write row names.
write.csv(data.frame(life_exp), "data\\life_exp_with_change.csv", row.names = FALSE)


######## utility functions #########

point <- function(x,y) list(x=x, y=y)

# pts = list(p1, p2, ... )... coords
# segs = list(c(1,2), c(2,1) ...) indices
createPolygon <- function(pts, segs) {
  pol <- list()
  for(pseg in segs) {
    pol <- c(pol, list(list(A=pts[[pseg[1]]], B=pts[[pseg[2]]])))
  }
  pol
}


nth <- function(n)
{
  if (length(n) > 1) return(sapply(n, nth))

  mod <- function(m, n) ifelse(!(m%%n), n, m%%n)
  suffices <- c("th", "st", "nd", "rd", "th", "th", "th", "th", "th", "th")

  if (n %% 100 <= 10 || n %% 100 > 20)
    suffix <- suffices[mod(n+1, 10)]
  else
    suffix <- 'th'

  paste(n, "'", suffix, sep="")
}

range <- list(0:25, 250:275, 500:525, 750:775, 1000:1025)

sapply(range, nth)