repo = "http://cran.us.r-project.org"
library(caret)
library(ggfortify)
library(ggplot2)
library(dplyr)
library(rpart)
library(rpart.plot)
library(RSQLite)
library(DBI)
library(randomForest)
library(e1071)
library(class)

classify_knn = function(pca.data, obs_data, point, k){
  neighs = get_nn(pca.data, point, k)
  neigh_data = obs_data[neighs,]
  return(names(which.max(table(neigh_data$fld))))
}

get_nn = function(d, point, k){
  point = d[point, ]
  dists = sort(sqrt(rowSums((t(t(d) - point))^2)))
  close_points = names(dists)[2:k]
  return(close_points)
}

base_dir<- "C:/Users/Jeff/Documents/research/Sadler_3rdPaper/manuscript/"
data_dir<- "C:/Users/Jeff/Google Drive/research/Sadler_3rdPaper_Data/"
fig_dir <- paste(base_dir, "Figures/general/", sep="")
db_filename <- "floodData.sqlite"

con = dbConnect(RSQLite::SQLite(), dbname=paste(data_dir, db_filename, sep=""))

df = dbReadTable(con, 'flood_locations')

colnames(df)

in_col_names = c('elev_1',
                 #'dist_to_ba',
                 'imp',
                 'dist_to_wa',
                 'Structure1',
                 'twi',
                 'Rim_Elevat',
                 'Invert_Ele',
                 'Year_Insta',
                 'Pipe_Geome',
                 'Horizontal',
                 'Vertical_D',
                 'Pipe_Lengt',
                 'Pipe_Mater',
                 'Vertical_D'
                )
out_col_name = 'flood_pt'
model_data = df[, c(in_col_names, out_col_name)]
model_data[,out_col_name] = model_data[,out_col_name]>0
model_data[,out_col_name] = factor(model_data[,out_col_name])

model_data = na.omit(model_data)

model_data$Structure1 = as.factor(model_data$Structure1)
model_data$Pipe_Geome = as.factor(model_data$Structure1)
model_data$Pipe_Mater = as.factor(model_data$Structure1)

head(model_data)

print(summary(model_data[,out_col_name]))
sum(as.numeric(model_data[,out_col_name] == TRUE))/sum(as.numeric(model_data[,out_col_name] == FALSE))

prt = createDataPartition(model_data[, out_col_name], p=0.7)
train_ind = prt$Resample1
test_ind = rownames(model_data[-train_ind,])
print(length(test_ind) + length(train_ind))
# length(rownames(model_data[model_data[train_ind, out_col_name]==TRUE]))
length(test_ind)

train_data = model_data[train_ind, ]
test_data = model_data[test_ind, ]

tst_out = model_data[test_ind, out_col_name]
trn_out = model_data[train_ind, out_col_name]

nfld_train = rownames(train_data[train_data[, out_col_name] == FALSE,])
fld_train = rownames(train_data[train_data[, out_col_name] == TRUE,])
nfld_test = rownames(test_data[test_data[, out_col_name] == FALSE,])
fld_test = rownames(test_data[test_data[, out_col_name] == TRUE,])
down_sample_percent = 1
nfld_train_dwnsmp = sample(nfld_train, down_sample_percent*length(nfld_train))
train_ind = c(fld_train, nfld_train_dwnsmp)

train_in_data = model_data[train_ind, in_col_names]
test_in_data = model_data[test_ind, in_col_names]

dt_fmla = as.formula(paste(out_col_name, "~", paste(in_col_names, collapse="+")))
dt_train_data = model_data[train_ind, ]
dt_test_data = model_data[test_ind, in_col_names]

fit = rpart(dt_fmla, method='class', data=dt_train_data, minsplit=2)
printcp(fit)

tiff(paste(fig_dir, "Plot2.tif"), width=9, height=6, units='in', res = 300)
rpart.plot(fit, under=TRUE, cex=0.9, extra=1, varlen = 6)
dev.off()
rpart.plot(fit, under=TRUE, cex=0.9, extra=1, varlen = 6)

pfit<- prune(fit, cp=fit$cptable[which.min(fit$cptable[,"xerror"]),"CP"])
rpart.plot(pfit, under=TRUE, cex=0.9, extra=1, varlen = 6)

pred = predict(pfit, dt_train_data[, in_col_names], type = 'class')
table(trn_out, pred)

pred = predict(pfit, dt_test_data, type = 'class')
table(tst_out, pred)

forest = randomForest(dt_fmla, data = dt_train_data, importance = TRUE, type="classification", nodesize=2)

pred = predict(forest, dt_train_data[, in_col_names])
table(trn_out, pred)

pred = predict(forest, dt_test_data)
table(tst_out, pred)
forest$importance

impo = as.data.frame(forest$importance)
impo = impo[order(-impo$MeanDecreaseGini),]
par(las=2)
barplot(impo$MeanDecreaseGini, names.arg=rownames(impo), ylim = c(0, 70))


# This example uses the summarize function in Hmisc to
# compute the median and outer quartiles.  The outer quartiles are
# displayed using "filled bands"

require(Hmisc)
set.seed(111)
dfr <- expand.grid(month=1:12, year=c(1997,1998), reps=1:100)
month <- dfr$month; year <- dfr$year
y <- abs(month-6.5) + 2*runif(length(month)) + year-1997
s <- summarize(y, llist(month,year), smedian.hilow, conf.int=.5)

# filled bands: default fill = pastel colors matching solid colors
# in superpose.line (this works differently in R)
xYplot ( Cbind ( y, Lower, Upper ) ~ month, groups=year,
     method="filled bands" , data=s, type="l")


library("lattice")

## Example data
data=matrix(runif(100, 0, 5) , 10 , 10)
colnames(data)=letters[c(1:10)]
rownames(data)=paste( rep("row",10) , c(1:10) , sep=" ")

## Try it out
png("#28_levelplot_correct_order.png" , width = 480, height = 480)
par(mar=c(3,4,2,2))
levelplot(t(data[c(nrow(data):1) , ]))
dev.off()


# Set up the environment

# Makes sure package is not already installed and loaded before it loads it
prepare.package <- function(package) {
    if(package %in% rownames(installed.packages()) == FALSE) {
        install.packages(package)
    }
    require(package, character.only = TRUE)
}

setwd(dirname(parent.frame(2)$ofile))
prepare.package("doBy")
prepare.package("ggplot2")

# Load the data for a specific day
cat(c("Initializing data...\n"), sep="")

if(file.exists("./data_set/nyt1.csv")) {
    day <- read.csv(file="./data_set/nyt1.csv")
} else {
    cat(c("Can't find data file!\n"), sep="")
    #day <- read.csv(url("http://stat.columbia.edu/~rachel/datasets/nyt1.csv"))
}

# Once you have the data loaded, it's time for some EDA:

# Sample data to get familiar with its layout
head(day)

# Only signed in users have ages and genders
summaryBy(Gender+Signed_In+Impressions+Clicks~age_group, data = day)

# QUESTION:
# 1. Create a new variable, age_group, that categorizes users as
#    "<18", "18-24", "25-34", "35-44", "45-54", "55-64", and "65+".
intervals <- c(-Inf,0,18,24,34,44,54,64,Inf)
categories <- c("N/A","<18","18-24","25-34","35-44","45-54","55-64","65+")
age_group <- cut(day$Age, intervals, categories)
day$age_group <- age_group

# QUESTION:
# 2. For a single day:

#      BULLET 1:
#    - Plot the distributions of number impressions and click-
#      through-rate (CTR=# click/# impressions) for these eight age
#      categories.

# We can't have no impressions for the click-through-rate
subset(day, (Clicks>0)&(Impressions==0))

# It looks like there are no clicks where there are no impressions which is
# good and to be expected.

# Number of impressions distribution plots:
# Histogram
ggplot(day, aes(x=Impressions, fill=age_group)) + geom_histogram(binwidth=1)
# Box and whisker plot
ggplot(day, aes(x=age_group, y=Impressions, fill=age_group)) + geom_boxplot()
# Density plot
ggplot(day, aes(x=Impressions,color=age_group)) + geom_density()
# Violin plot
ggplot(day, aes(x=age_group, y=Impressions, fill=age_group)) + geom_violin()
# Jitter
ggplot(day, aes(x=age_group, y=Impressions, colour=age_group)) + geom_jitter()
# Frequency polygon plot
ggplot(day, aes(x=Impressions, color=age_group)) + geom_freqpoly(binwidth=1)
# Kernel density estimate
ggplot(day, aes(x=Impressions, fill=age_group)) + stat_density()

# Click-through-rate plots:
# Density plot
# Subset with Clicks>0 provides more understandable plots than Impressions>0
# This can be seen by plotting the following density plots:
ggplot(subset(day, Impressions>0),
       aes(x=Clicks/Impressions, colour=age_group)) + geom_density()
ggplot(subset(day, Clicks>0),
       aes(x=Clicks/Impressions, colour=age_group)) + geom_density()
# Box and whisker plot
ggplot(subset(day, Clicks>0),
       aes(x=age_group, y=Clicks/Impressions, fill=age_group)) + geom_boxplot()
# Viloin plot
ggplot(subset(day, Clicks>0),
       aes(x=age_group, y=Clicks/Impressions, fill=age_group)) + geom_violin()
# Jitter
ggplot(subset(day, Clicks>0),
       aes(x=age_group, y=Clicks/Impressions, color=age_group)) + geom_jitter()
# Frequency polygon plot
ggplot(subset(day, Clicks>0),
       aes(x=Clicks/Impressions, color=age_group)) + geom_freqpoly(binwidth=.05)
# Histogram
ggplot(subset(day, Clicks>0),
       aes(x=Clicks/Impressions, fill=age_group)) +
    geom_histogram(binwidth=.025)
# Kernel density estimate
ggplot(subset(day, Clicks>0),
       aes(x=Clicks/Impressions, fill=age_group)) + stat_density()

#      BULLET 2:
#    - Define a new variable to segment or categorize users based on
#      their click behavior.

# Investigate click behavior
ggplot(subset(day, Clicks>0),
       aes(x=age_group, y=Clicks, fill=age_group)) + geom_boxplot()
ggplot(subset(day, Clicks>0), aes(x=Clicks, colour=age_group)) + geom_density()
ggplot(subset(day, Clicks>0), aes(x=Clicks, colour=age_group)) + stat_density()

# It seems clicks are close to 1 in general so we can categorize them as such:
day$click_group[day$Impressions==0] <- "No_Impressions"
day$click_group[day$Impressions>0] <- "No_Clicks"
day$click_group[day$Clicks>0] <- "Clicks"

#Convert the column to a factor
day$click_group <- factor(day$click_group)
click_group <- day$click_group
head(day)

#      BULLET 3:
#    - Explore the data and make visual and quantitative comparisons
#      across user segments/demographics (<18-year-old males versus
#      <18-year-old females or logged-in versus not, for example).

# Factorize Gender and Signed_In
day$Gender <- factor(day$Gender)
day$Signed_In <- factor(day$Signed_In)

# Visual comparisons
# Logged-in versus not
ggplot(day, aes(x=Signed_In, fill=factor(Signed_In, labels=c("No","Yes")),
                ymax=max(..count..))) + geom_histogram(binwidth=1) +
    stat_bin(binwidth=1,geom="text",drop=TRUE,aes(label=..count.., vjust=-1)) +
    guides(fill=guide_legend(title="Signed In"))
# By click behavior categories
ggplot(day, aes(x=click_group, fill=click_group,
                ymax=max(..count..))) + geom_histogram(binwidth=1) +
    stat_bin(binwidth=1,geom="text",drop=TRUE,aes(label=..count.., vjust=-1))
# By age group
ggplot(day, aes(x=age_group, fill=age_group,
                ymax=max(..count..))) + geom_histogram(binwidth=1) +
    stat_bin(binwidth=1,geom="text",drop=TRUE,aes(label=..count.., vjust=-1))
# Males versus females total
ggplot(subset(day, Signed_In==1),
       aes(x=Gender, fill=factor(Gender, labels=c("Female","Male")),
           ymax=max(..count..))) + geom_histogram(binwidth=1) +
    stat_bin(binwidth=1,geom="text",drop=TRUE,aes(label=..count.., vjust=-1)) +
    guides(fill=guide_legend(title="Gender"))
# <18-year-old males versus <18-year-old females
ggplot(subset(day, age_group=="<18"),
       aes(x=Gender, fill=factor(Gender, labels=c("Female","Male")),
           ymax=max(..count..))) + geom_histogram(binwidth=1) +
    stat_bin(binwidth=1,geom="text",drop=TRUE,aes(label=..count.., vjust=-1)) +
    guides(fill=guide_legend(title="Gender"))
# 18-24-year-old males versus 18-24-year-old females
ggplot(subset(day, age_group=="18-24"),
       aes(x=Gender, fill=factor(Gender, labels=c("Female","Male")),
           ymax=max(..count..))) + geom_histogram(binwidth=1) +
    stat_bin(binwidth=1,geom="text",drop=TRUE,aes(label=..count.., vjust=-1)) +
    guides(fill=guide_legend(title="Gender"))
# 25-34-year-old males versus 25-34-year-old females
ggplot(subset(day, age_group=="25-34"),
       aes(x=Gender, fill=factor(Gender, labels=c("Female","Male")),
           ymax=max(..count..))) + geom_histogram(binwidth=1) +
    stat_bin(binwidth=1,geom="text",drop=TRUE,aes(label=..count.., vjust=-1)) +
    guides(fill=guide_legend(title="Gender"))
# 35-44-year-old males versus 35-44-year-old females
ggplot(subset(day, age_group=="35-44"),
       aes(x=Gender, fill=factor(Gender, labels=c("Female","Male")),
           ymax=max(..count..))) + geom_histogram(binwidth=1) +
    stat_bin(binwidth=1,geom="text",drop=TRUE,aes(label=..count.., vjust=-1)) +
    guides(fill=guide_legend(title="Gender"))
# 45-54-year-old males versus 45-54-year-old females
ggplot(subset(day, age_group=="45-54"),
       aes(x=Gender, fill=factor(Gender, labels=c("Female","Male")),
           ymax=max(..count..))) + geom_histogram(binwidth=1) +
    stat_bin(binwidth=1,geom="text",drop=TRUE,aes(label=..count.., vjust=-1)) +
    guides(fill=guide_legend(title="Gender"))
# 55-64-year-old males versus 55-64-year-old females
ggplot(subset(day, age_group=="55-64"),
       aes(x=Gender, fill=factor(Gender, labels=c("Female","Male")),
           ymax=max(..count..))) + geom_histogram(binwidth=1) +
    stat_bin(binwidth=1,geom="text",drop=TRUE,aes(label=..count.., vjust=-1)) +
    guides(fill=guide_legend(title="Gender"))
# 65+-year-old males versus 65+-year-old females
ggplot(subset(day, age_group=="65+"),
       aes(x=Gender, fill=factor(Gender, labels=c("Female","Male")),
           ymax=max(..count..))) + geom_histogram(binwidth=1) +
    stat_bin(binwidth=1,geom="text",drop=TRUE,aes(label=..count.., vjust=-1)) +
    guides(fill=guide_legend(title="Gender"))

# An interesting thing to note is that the only age category with
# more females than males is 65+

# Quantitative comparisons
summaryBy(Impressions~click_group+Gender+age_group+Signed_In,
          data = day, FUN = length, var.names="Total_Users", keep.names=TRUE)

#      BULLET 4:
#    - Create metrics/measurements/statistics that summarize the data.
#      Examples of potential metrics include CTR, quantiles, mean,
#      median, variance, and max, and these can be calculated across
#      the various user segments. Be selective. Think about what will
#      be important to track over time—what will compress the data,
#      but still capture user behavior.

# When checking CTR make sure x = Clicks and y = Impressions
# When x = Impressions z = TRUE
metrics <- function(x, y, z=FALSE) {
    if(z == TRUE) {
        metrics_out <- c(sum(x))                                  # count
    } else if(missing(y)) {
        metrics_out <- c(length(x))                               # count
    } else {
        metrics_out <- c(sum(x),                                  # count
                         signif(length(x)/length(y), digits = 4)) # CTR
    }
    metrics_out <- c(metrics_out,
                     signif(mean(x), digits = 4),                 # mean
                     signif(median(x), digits = 4),               # median
                     names(sort(-table(x)))[1],                   # mode
                     signif(var(x), digits = 4),                  # variance
                     min(x),                                      # minimum
                     max(x),                                      # maximum
                     max(x)-min(x))                               # range
    metrics_out
}

# Quartiles don't seem to be particularly useful of a metric with this data set

# View general summary
summary(day)
# Age by age group
summaryBy(Age~age_group, data=day, FUN=metrics,
          fun.names=c("Count", "Mean", "Median", "Mode", "Variance",
                      "Min", "Max", "Range"))
# Gender by age group
summaryBy(Gender~age_group, data=day, FUN=metrics,
          fun.names=c("Count", "Mean", "Median", "Mode", "Variance",
                      "Min", "Max", "Range"))
# Impressions by age group
summaryBy(Impressions~age_group, data=day, FUN=metrics, var.names="Imp", z=T,
          fun.names=c("Count", "Mean", "Median", "Mode", "Variance",
                      "Min", "Max", "Range"))
# Impressions by gender
summaryBy(Impressions~Gender, data=subset(day, Signed_In==1),
          FUN=metrics, var.names="Imp", z=T,
          fun.names=c("Count", "Mean", "Median", "Mode", "Variance",
                      "Min", "Max", "Range"))
# Impressions by click group
summaryBy(Impressions~click_group, data=day, FUN=metrics, var.names="Imp", z=T,
          fun.names=c("Count", "Mean", "Median", "Mode", "Variance",
                      "Min", "Max", "Range"))
# Impressions by login status
summaryBy(Impressions~Signed_In, data=day, FUN=metrics, var.names="Imp", z=T,
          fun.names=c("Count", "Mean", "Median", "Mode", "Variance",
                      "Min", "Max", "Range"))
# Clicks by age group
summaryBy(Clicks~age_group, data=day, FUN=metrics, y=day$Impressions,
          fun.names=c("Count", "CTR", "Mean", "Median", "Mode", "Variance",
                      "Min", "Max", "Range"))
# Clicks by gender
summaryBy(Clicks~Gender, data=subset(day, Signed_In==1),
          FUN=metrics, y=day$Impressions,
          fun.names=c("Count", "CTR", "Mean", "Median", "Mode", "Variance",
                      "Min", "Max", "Range"))
# Clicks by login status
summaryBy(Clicks~Signed_In, data=day, FUN=metrics, y=day$Impressions,
          fun.names=c("Count", "CTR", "Mean", "Median", "Mode", "Variance",
                      "Min", "Max", "Range"))

# QUESTION:
# 3. Now extend your analysis across days. Visualize some metrics and
#    distributions over time.

# We will do this by collecting relevant information about each day into a
# data.frame. We can look at specific data by simply changing the day at the
# top of this file and running source on it.  To view data about the whole
# month, on the other hand, we will parse relevant totals into said data.frame.
# One can change the for loop to do only particular days as well if needed.

# NOTE: We will create a groups and a days frame.  Groups will give us data by
# specific user groups, while days will give us data by specific days

# IMPORTANT: Make sure all the csv files for the month are located in the folder
# specified by the "folder" string variable! Also make sure totals and days are
# both loaded as defined.
folder <- "./data_set"
totals <- matrix(0, 45, 3)
days <- data.frame(Day = 1:31, Users = NA, Clicks = NA, Impressions = NA,
                   Females = NA, Males = NA, NI_Users = NA, NC_Users = NA,
                   C_Users = NA)
for(x in 1:31) {
    # Set up
    current_file <- paste(c(folder, "/nyt"), collapse = "")
    current_file <- paste(c(current_file, x), collapse = "")
    current_file <- paste(c(current_file, ".csv"), collapse = "")
    d <- read.csv(file=current_file)
    d$age_group <- cut(d$Age, intervals, categories)
    d$click_group[d$Impressions==0] <- "No_Impressions"
    d$click_group[d$Impressions>0] <- "No_Clicks"
    d$click_group[d$Clicks>0] <- "Clicks"
    d$click_group <- factor(d$click_group)
    d$Gender <- factor(d$Gender)
    d$Signed_In <- factor(d$Signed_In)

    cat(c("Computing data for 5/", x, "/2012\n"), sep="")

    # Additional per day totals
    days[days$Day==x,5] <- nrow(subset(d, (Gender==0)&(Signed_In==1)))
    days[days$Day==x,6] <- nrow(subset(d, (Gender==1)&(Signed_In==1)))
    days[days$Day==x,7] <- nrow(subset(d, click_group=="No_Impressions"))
    days[days$Day==x,8] <- nrow(subset(d, click_group=="No_Clicks"))
    days[days$Day==x,9] <- nrow(subset(d, click_group=="Clicks"))

    # Totals
    # Users
    days[days$Day==x,2] <- nrow(d)

    groups <- summaryBy(Age~age_group+Gender+click_group+Signed_In,
                       data=d, FUN=length, keep.names=TRUE, var.names="Users")
    groups$Clicks <- 0
    groups$Impressions <- 0
    totals <- totals + as.matrix(groups[5:7])
    # Total Clicks
    days[days$Day==x,3] <- sum(d$Clicks)

    groups <- summaryBy(0+Clicks+0~age_group+Gender+click_group+Signed_In,
                       data=d, FUN=sum, keep.names=TRUE,
                       var.names=c("Users", "Clicks", "Impressions"))
    totals <- totals + as.matrix(groups[5:7])
    # Total Impressions
    days[days$Day==x,4] <- sum(d$Impressions)

    groups <- summaryBy(0+0+Impressions~age_group+Gender+click_group+Signed_In,
                       data=d, FUN=sum, keep.names=TRUE,
                       var.names=c("Users", "Clicks", "Impressions"))
    totals <- totals + as.matrix(groups[5:7])
}
groups <- as.data.frame(summaryBy(Age~age_group+Gender+click_group+Signed_In,
                                 data=d, var.names=c("rm"), keep.names=TRUE))
groups["rm"] <- NULL
groups <- cbind(groups, as.data.frame(totals))

# Write the frames into csv files just in case we need to load them quickly
write.csv(groups, file="groups.csv", row.names=FALSE)
write.csv(days, file="days.csv", row.names=FALSE)
# Run this line in order to load the frames quickly from above created csv files
groups <- read.csv(file="groups.csv")
days <- read.csv(file="days.csv")

# We should now have nice data frames containing information needed to perform
# EDA analysis and create nice visualizations for metrics and distributionbs
# over time:

# Some quntitive analysis before we proceed with the visualizations:
summaryBy(Users+Clicks+Impressions+Females+Males+NI_Users+NC_Users+C_Users~Day,
          data=days, FUN=sum)
summaryBy(Users+Clicks+Impressions~age_group, data=groups, FUN=sum)
summaryBy(Users+Clicks+Impressions~age_group, data=groups, FUN=mean)
summaryBy(Users+Clicks+Impressions~Gender, data=groups, FUN=sum)
summaryBy(Users+Clicks+Impressions~Gender, data=groups, FUN=mean)
summaryBy(Users+Clicks+Impressions~click_group, data=groups, FUN=sum)
summaryBy(Users+Clicks+Impressions~click_group, data=groups, FUN=mean)
summaryBy(Users+Clicks+Impressions~Signed_In, data=groups, FUN=sum)
summaryBy(Users+Clicks+Impressions~Signed_In, data=groups, FUN=mean)

# Metric visualizations:
# NOTE: May 1st 2012 is a Tuesday
# Users per day - very interesting to note that we see most users on Sundays
# there is a huge spike, almost double the user base.  Least amount of users
# on the other hand is on Saturdays, not by too much however.
ggplot(days, aes(x=Day,y=Users,fill=Day))+geom_bar(binwidth=1,stat="identity")
# Clicks per day - Similarly to Users per day we see most clicks on Sundays
# and least clicks on Saturdays, this is definitly due to the amount of users on
# those days
ggplot(days, aes(x=Day,y=Clicks,fill=Day))+geom_bar(binwidth=1,stat="identity")
# Impressions per day - Similarly to Users per day we see most clicks on Sundays
# and least clicks on Saturdays, this is definitly due to the amount of users on
# those days
ggplot(days, aes(x=Day,y=Impressions,fill=Day))+
    geom_bar(binwidth=1,stat="identity")
# Click-through-rate per day - We see a lot higher of a click-through-rate
# 15-30th day of the month, as compared to 31-14th, so we may conclude that
# the click through rate alternates every 15 days.
ggplot(days, aes(x=Day,y=Clicks/Impressions,fill=Day))+
    geom_bar(binwidth=1,stat="identity")
# Additional per day visualizations - similar to User observations:
ggplot(days,aes(x=Day,y=Females,fill=Day))+geom_bar(binwidth=1,stat="identity")
ggplot(days,aes(x=Day,y=Males,fill=Day))+geom_bar(binwidth=1,stat="identity")
ggplot(days,aes(x=Day,y=NI_Users,fill=Day))+geom_bar(binwidth=1,stat="identity")
ggplot(days,aes(x=Day,y=NC_Users,fill=Day))+geom_bar(binwidth=1,stat="identity")
ggplot(days,aes(x=Day,y=C_Users,fill=Day))+geom_bar(binwidth=1,stat="identity")

# Logged-in versus not totals
ggplot(groups,
       aes(x=Signed_In, y=Users, fill=factor(Signed_In, labels=c("No","Yes"))))+
    geom_bar(binwidth=1, stat="identity")+
    guides(fill=guide_legend(title="Signed In"))
# By click behavior categories
ggplot(groups, aes(x=click_group, y=Users, fill=click_group))+
    geom_bar(binwidth=1, stat="identity")
# By age group
ggplot(groups, aes(x=age_group, y=Users, fill=age_group))+
    geom_bar(binwidth=1, stat="identity")
# Males versus females total
ggplot(subset(groups, Signed_In==1), aes(x=Gender, y=Users,
                   fill=factor(Gender, labels=c("Female","Male"))))+
    geom_bar(binwidth=1, stat="identity")+
    guides(fill=guide_legend(title="Gender"))
# <18-year-old males versus <18-year-old females
ggplot(subset(groups, age_group=="<18"),
       aes(x=Gender, y=Users, fill=factor(Gender, labels=c("Female","Male"))))+
    geom_bar(binwidth=1, stat="identity")+
    guides(fill=guide_legend(title="Gender"))
# 18-24-year-old males versus 18-24-year-old females
ggplot(subset(groups, age_group=="18-24"),
       aes(x=Gender, y=Users, fill=factor(Gender, labels=c("Female","Male"))))+
    geom_bar(binwidth=1, stat="identity")+
    guides(fill=guide_legend(title="Gender"))
# 25-34-year-old males versus 25-34-year-old females
ggplot(subset(groups, age_group=="25-34"),
       aes(x=Gender, y=Users, fill=factor(Gender, labels=c("Female","Male"))))+
    geom_bar(binwidth=1, stat="identity")+
    guides(fill=guide_legend(title="Gender"))
# 35-44-year-old males versus 35-44-year-old females
ggplot(subset(groups, age_group=="35-44"),
       aes(x=Gender, y=Users, fill=factor(Gender, labels=c("Female","Male"))))+
    geom_bar(binwidth=1, stat="identity")+
    guides(fill=guide_legend(title="Gender"))
# 45-54-year-old males versus 45-54-year-old females
ggplot(subset(groups, age_group=="45-54"),
       aes(x=Gender, y=Users, fill=factor(Gender, labels=c("Female","Male"))))+
    geom_bar(binwidth=1, stat="identity")+
    guides(fill=guide_legend(title="Gender"))
# 55-64-year-old males versus 55-64-year-old females
ggplot(subset(groups, age_group=="55-64"),
       aes(x=Gender, y=Users, fill=factor(Gender, labels=c("Female","Male"))))+
    geom_bar(binwidth=1, stat="identity")+
    guides(fill=guide_legend(title="Gender"))
# 65+-year-old males versus 65+-year-old females
ggplot(subset(groups, age_group=="65+"),
       aes(x=Gender, y=Users, fill=factor(Gender, labels=c("Female","Male"))))+
    geom_bar(binwidth=1, stat="identity")+
    guides(fill=guide_legend(title="Gender"))

# Distribution visualizations:
# Total impressions/total users over a month by age group distribution plots:
ggplot(groups, aes(x=age_group, y=Impressions/Users, fill=age_group)) +
    geom_boxplot()
ggplot(groups, aes(x=Impressions/Users,color=age_group)) + geom_density()
ggplot(groups, aes(x=age_group, y=Impressions/Users, fill=age_group)) +
    geom_violin()
ggplot(groups, aes(x=Impressions/Users, fill=age_group)) + stat_density()

# Total Click-through-rate over a month by age group:
ggplot(subset(groups, Impressions>0),
       aes(x=Clicks/Impressions, colour=age_group)) + geom_density()
ggplot(subset(groups, Impressions>0),
       aes(x=age_group, y=Clicks/Impressions, fill=age_group)) + geom_boxplot()
ggplot(subset(groups, Impressions>0),
       aes(x=age_group, y=Clicks/Impressions, fill=age_group)) + geom_violin()
ggplot(subset(groups, Impressions>0),
       aes(x=Clicks/Impressions, fill=age_group)) + stat_density()

# CTR per gender
ggplot(subset(groups, (Signed_In==1)&(Impressions>0)),
       aes(x=Gender, y=sum(Clicks)/sum(Impressions),
           fill=factor(Gender, labels=c("Female","Male"))))+
    geom_bar(binwidth=1, stat="identity")+
    guides(fill=guide_legend(title="Gender"))

# QUESTION:
# 4. Describe and interpret any patterns you find.

# - Users, Clicks, and Impressions are generally much higher on Sundays, there
#   is a huge spike in usage every Sunday, near double the average!
# - Users, Clicks, and Impressions are noticably lower on Saturdays.
# - CTR seems to alternate between around .018 and .021 every 15 days at least
#   as seen in the data provided.
# - CTR over time seems to be the same for females and males
# - Clicks seem to be increasing very slightly over time, but the rate is so low
#   that we may need more data to make sure that this is indeed the case.
# - User, User Types, and Impression numbers seem pretty consistent over time.
# - On average there are around 5 impressions per user.
# - The higher the age-range the more the click-through-rate probability tends
#   towards certain values.
# - When there are clicks, they are rearely more than 1 per user.
# - The age groups seem to be normally distributed around 35-44.
# - Most of the time there are no clicks, rearly no impressions.
# - There are generaly more males than females.
# - There are significantly more males than females in the <18 age group.
# - The 65+ group is the only group with more females than males.
# - There are significantly more females than males in the 65+ group.
# - Around 2/3 of the users are singed in.


a <- c( "John", "Bob", "Mary", "Serena" )
b <- c( "Jim", "Mary", "John", "Bob" )
c(setdiff(b, a), setdiff(a, b))

a <- c("John", "Serena", "Bob", "Mary", "Serena")
b <- c("Jim", "Mary", "John", "Jim", "Bob")
c(setdiff(b, a), setdiff(a, b))


### calculate the sample size needed for achieving a certain power in three ways: TSLS, AR, ARsens
### some parameter values are inferred from the ivmodel

IVsize=function(ivmodel, power, alpha=0.05, beta=NULL, type="TSLS", deltarange=NULL, delta=NULL){
  esti = para(ivmodel)
  if(is.null(beta))
    beta = esti$beta
  if(is.null(deltarange))
    deltarange = ivmodel$deltarange

  if(type=="TSLS"){
     return(TSLS.size(power, beta, cor(ivmodel$Zadj, ivmodel$Dadj), esti$sigmau, var(ivmodel$Dadj), alpha))
  }
  if(type=="AR"){
    return(AR.size(power, ivmodel$p, ivmodel$L, beta, esti$gamma, var(ivmodel$Zadj), esti$sigmau, esti$sigmav, esti$rho, alpha))
  }

  if(type=="ARsens"){
    return(ARsens.size(power, ivmodel$p, beta, esti$gamma, var(ivmodel$Zadj), esti$sigmau, esti$sigmav, esti$rho, alpha, deltarange, delta))
  }
  print("Input error.")
  return(NULL)
}


#' to impute missing values with row means
#' x <- impute.matrix(x,1)
#' to impute missing values with column means
#' x <- impute.matrix(x,2)
impute.matrix <- function(x, margin=1, fun=function(x) mean(x, na.rm=T)) {
    if (margin == 2) x <- t(x)

    idx <- which(is.na(x) | !is.finite(x), arr.ind=T)
    if (length(idx) > 0) {
        na.idx <- unique(idx[,"row"])
        v <- apply(x[na.idx,,drop=F],1,fun) ## v = summary for each row
        v[which(is.na(v))] <- fun(v)      ## if v[i] is NA, v[i] = fun(v)
        x[idx] <- v[match(idx[,"row"],na.idx)] ##
        stopifnot(all(!is.na(x)))
    }

    if (margin == 2) x <- t(x)
    x
}


library(readr)
library(data.table)
library(Rtsne)
library(Metrics)
path <- "../Data/"
train <- fread(paste0(path,"train_2nd.csv"))
train <- as.data.frame(train)
train$id <-NULL
for(i in 1:(ncol(train)-1)) { train[,i] <- as.numeric(train[,i])}
test <- fread(paste0(path,"test_2nd.csv"))
test <- as.data.frame(test)
test$id <- NULL
for(i in 1:ncol(test)) { test[,i] <- as.numeric(test[,i])}
TsneDim <- 3 # 2 or 3
tmp <- as.factor(train$target)
train$target <- NULL
x <- rbind(train,test)
dim(x)
N <- nrow(train)
rm(train)
rm(test)
gc()

print("constructing t-sne")
set.seed(131)
tsne <- Rtsne(x, dims = TsneDim, perplexity = 50, initial_dims = 50,
theta = 0.5, check_duplicates = F, pca = T, verbose=TRUE, max_iter = 500)

colors = rainbow(length(unique(tmp)))
names(colors) = unique(tmp)

if(TsneDim==2){
  plot(tsne$Y[1:N,], t='n', main="tsne")
  text(tsne$Y[1:N,], labels=tmp, col=colors[tmp])
}
if(TsneDim==3){
  library(rgl)
  plot3d(tsne$Y[1:N,1],tsne$Y[1:N,2],tsne$Y[1:N,3],col=colors[tmp])
}

train <- tsne$Y[1:N,]
test <- tsne$Y[(N+1):nrow(tsne$Y),]
if(TsneDim==2){
colnames(train) <- c("dim1","dim2")
colnames(test) <- c("dim1","dim2")
}
if(TsneDim==3){
colnames(train) <- c("dim1","dim2","dim3")
colnames(test) <- c("dim1","dim2","dim3")
}

train <- as.data.frame(train)
test <- as.data.frame(test)
for(i in 1:3){
train[,i] <- as.character(train[,i])
test[,i] <- as.character(test[,i])
}
gc()

write_csv(train,paste0(path,"train_2nd_tsne.csv"),col_names=T)
write_csv(test,paste0(path,"test_2nd_tsne.csv"),col_names=T)


library(jsonlite)
library(ggplot2)
library(magrittr)
library(dplyr)

fromJSON("hsdata.json")$confirmed %>% mutate(date=as.POSIXct(date)) -> conf
count(conf, date, name="dn") %>% arrange(date) %>%
    mutate(n=cumsum(dn),
           days=as.double(difftime(date, date[1], units="d"))) -> conf.agg

(fromJSON("testdata.json")$tested %>% mutate(date=as.POSIXct(date))
    %>% rename(tested=value)) -> tests

tc <- full_join(tests, conf.agg, by="date")
tc$dn[is.na(tc$dn)] <- 0
tc %<>% filter(dn != 0 | tested != 0)

d.new <- "2020-03-28"
tc %>% filter(date >= d.new) -> tc.new
tc.lm <- lm(dn ~ tested + n, tc)
tc.lm2 <- lm(dn ~ tested + n, tc.new)

pdf("test.pdf", title="Testing")
print(qplot(date, tested, data=tc[tc$tested > 0,])
      + scale_y_log10() + annotation_logticks(sides="l")
      + geom_vline(xintercept=as.POSIXct(d.new), linetype="dotted")
      + ggtitle(paste("Raja", d.new)))
plot(tc[, c("days", "tested", "n", "dn")],
     main=paste("Kaikki:", min(tc$date), "-", max(tc$date)))
## print(qplot(date, tested, data=tc) + geom_point(aes(y=dn), colour="red")
##       + scale_y_log10())
plot(tc.new[, c("days", "tested", "n", "dn")], main=paste("Alkaen", d.new))
dev.off()

summary(tc.lm)
summary(tc.lm2)


#install.packages("ggplot2")
require("ggplot2")
library("markovchain")

setwd("C:/Code/climData/glaser2019")

dfHhi <- read.csv("csv/hhi_1500_2019.csv", sep=",", na = "NA")

pic <- dfHhi$hhi
len <- length(pic)
## mirror pic
pic <- append(pic, pic)
for(i in 1:len) {
  pic[i+len] <- pic[1+len-i]
}

frq <- fft(pic, inverse = FALSE)

frq1 <- frq
filterYears = 0.1   #filter 1m
start = round(len/(12.0*filterYears))
stop  = round(2.0*len-start)
frq1[start:stop] <- 0.0
pic1 <- Re(fft(frq1, inverse = TRUE)/length(frq1))
pic1 <- pic1[1:len]
dfHhi$hhi1 <-  pic1

frq5 <- frq
filterYears = 5   #filter 5y
start = round(len/(12.0*filterYears))
stop  = round(2.0*len-start)
frq5[start:stop] <- 0.0
pic5 <- Re(fft(frq5, inverse = TRUE)/length(frq5))
pic5 <- pic5[1:len]
dfHhi$hhi5 <-  pic5

dfHhi$rhi <- dfHhi$hhi
dfHhi$rmhi <- dfHhi$hhi
for(i in 1:length(dfHhi$rhi)) {
  dfHhi$rhi[i] = 'd4'
  if (dfHhi$hhi1[i] > -3.0) {dfHhi$rhi[i] = 'd3'}
  if (dfHhi$hhi1[i] > -2.0) {dfHhi$rhi[i] = 'd2'}
  if (dfHhi$hhi1[i] > -1.5) {dfHhi$rhi[i] = 'd1'}
  if (dfHhi$hhi1[i] > -1.0) {dfHhi$rhi[i] = 'n0'}
  if (dfHhi$hhi1[i] >  1.0) {dfHhi$rhi[i] = 'w1'}
  if (dfHhi$hhi1[i] >  1.5) {dfHhi$rhi[i] = 'w2'}
  if (dfHhi$hhi1[i] >  2.0) {dfHhi$rhi[i] = 'w3'}
  if (dfHhi$hhi1[i] >  3.0) {dfHhi$rhi[i] = 'w4'}
  dfHhi$rmhi[i] <- paste('m',dfHhi$month[i],':',dfHhi$rhi[i], sep='')
}
dfHhi$hstate  <- dfHhi$hhi
dfHhi$hstate[1] <- paste('n0','-',dfHhi$rhi[1], sep='')
dfHhi$mhstate <- dfHhi$hhi
dfHhi$mhstate[1] <- paste('m',dfHhi$month[12],':','n0','-','m',dfHhi$month[1],':',dfHhi$rhi[1], sep='')
for(i in 2:length(dfHhi$hstate)) {
  dfHhi$hstate[i] <- paste(dfHhi$rhi[i-1],'-',dfHhi$rhi[i], sep='')
  dfHhi$mhstate[i] <- paste('m',dfHhi$month[i-1],':',dfHhi$rhi[i-1],'-','m',dfHhi$month[i],':',dfHhi$rhi[i], sep='')
}
monthStates <- c("m1","m2","m3","m4","m5","m6","m7","m8","m9","m10","m11","m12")
humidityStates <- c("w4", "w3", "w2", "w1", "n0", "d1", "d2", "d3", "d4")
byRow <- TRUE
humidityMatrix  <- matrix(rep( 0.0, len=length(humidityStates)^2), nrow=length(humidityStates))
for(row in 1:length(humidityStates)) {
  sumRow <- 0.0
  for(col in 1:length(humidityStates)) {
    trans <- paste(humidityStates[row],'-',humidityStates[col], sep='')
    count <- length(subset(dfHhi, dfHhi$hstate==trans)$hstate)
    humidityMatrix[row,col] <- count
    sumRow <- sumRow + count
  }
  if(sumRow > 0.0)  {
    for(col in 1:length(humidityStates)) {
      humidityMatrix[row,col] <- humidityMatrix[row,col] / sumRow
    }
  }
}

mcHumidity <- new("markovchain", states = humidityStates, byrow = byRow,
                  transitionMatrix = humidityMatrix, name = "Humidity")

initialState <- c(0, 0, 0, 0, 1, 0, 0, 0, 0)
after1000month <- initialState * (mcHumidity ^ 1000)
transitionProbability(mcHumidity, "w4", "w3")

print(mcHumidity)
show(mcHumidity)
steadyStates(mcHumidity) #endless time

simHumidity <- rmarkovchain(n = 12*10, object = mcHumidity, t0 = "n0")

sequence <- c("a", "b", "a", "a", "a", "a", "b", "a", "b", "a", "b", "a", "a",
              "b", "b", "b", "a")
sequenceMatr <- createSequenceMatrix(dfHhi$rhi, sanitize = FALSE)

mcFitMLE <- markovchainFit(data = dfHhi$rhi)
mcFitBSP <- markovchainFit(data = dfHhi$rhi, method = "bootstrap", nboot = 5, name = "Bootstrap Mc")

sequenceMatr <- createSequenceMatrix(dfHhi$rmhi, sanitize = FALSE)
mcFitMLE <- markovchainFit(data = dfHhi$rmhi)
mcFitBSP <- markovchainFit(data = dfHhi$rmhi, method = "bootstrap", nboot = 5, name = "Bootstrap Mc")

steadyStates(mcFitBSP$estimate)
simHumidity <- rmarkovchain(n = 12*10, object = mcFitBSP$estimate, t0 = "m1:n0")

verifyMarkovProperty(dfHhi$rmhi)
verifyEmpiricalToTheoretical(data=dfHhi$rhi,object=mcFitBSP$estimate)
verifyHomogeneity(inputList=list(dfHhi$rmhi[3601:6000], dfHhi$rmhi[1:2400]),verbose=TRUE)

## create monthly
mcFitBSP <- markovchainFit(data = dfHhi$rmhi, method = "bootstrap", nboot = 5, name = "Bootstrap Mc")

from = "d2"
to = "d1"

props <- monthStates
mon <- monthStates
for(i in 1:length(monthStates)) {
  start = paste(monthStates[i],':',from, sep='')
  stop  = paste(monthStates[(i+1)%%length(monthStates)],':',to, sep='')
  props[i] = transitionProbability(mcFitBSP$estimate, start, stop)
  mon[i] <- 0.01*i
}

mp <- ggplot()
mp +
  theme_classic() +
  geom_point(aes(y=props, x=mon))

## 100 years

from = "w1"
to = "w2"

result <- data.frame(years = c(1:9))
mp <- ggplot(result) + theme_classic() +
  scale_y_continuous(limits=c(0,1))+
  scale_x_continuous(limits=c(1500,2020))

for (from in humidityStates) {
  for (to in humidityStates) {
  result$prop <- c(1:9)
for (i in 1:9) {
  yS = 1450 + 50*i
  yE = 1550 + 50*i
  result$years[i] <- 1500 + 50*i
  seq <- subset(dfHhi, dfHhi$year>yS & dfHhi$year<yE)
  mcFitBSP <- markovchainFit(data = seq$rhi, method = "bootstrap", nboot = 5, name = "Bootstrap Mc")
  steadyStates(mcFitBSP$estimate)
  result$prop[i] <-transitionProbability(mcFitBSP$estimate, from, to)

}
  newName <- paste(from,'-',to, sep='')
  names(result)[names(result) == 'prop'] <- newName
  mp <- mp + geom_line(aes(y=!!result[,newName], x=result[,"years"]))

  }
}

### only look for rsults

result <- data.frame(years = c(1:9))
for (i in 1:9) {
  yS = 1450 + 50*i
  yE = 1550 + 50*i
  result$years[i] <- 1500 + 50*i
  seq <- subset(dfHhi, dfHhi$year>yS & dfHhi$year<yE)
  mcFitBSP <- markovchainFit(data = seq$rhi, method = "bootstrap", nboot = 5, name = "Bootstrap Mc")
  states <- steadyStates(mcFitBSP$estimate)
  for(col in colnames(states)){
     result[i,col] <- states[,col]
  }
}

## continous
result <- data.frame(years = c(1600:2018))
for (yE in 1600:2018) {
  yS = yE - 100
  result$years[yE-1599] <- yE - 50
  seq <- subset(dfHhi, dfHhi$year>yS & dfHhi$year<yE)
  mcFitBSP <- markovchainFit(data = seq$rhi, method = "bootstrap", nboot = 5, name = "Bootstrap Mc")
  states <- steadyStates(mcFitBSP$estimate)
  for(col in colnames(states)){
    result[yE-1599,col] <- states[,col]
  }
}

mp <- ggplot(result) + theme_classic() +
  scale_y_continuous(limits=c(0,1))+
  scale_x_continuous(limits=c(1500,2020)) +
  geom_line(aes(y=result$d4, x=result$years, col="iD4")) +
  geom_line(aes(y=result$d3, x=result$years, col="hD3")) +
  geom_line(aes(y=result$d2, x=result$years, col="gD2")) +
  geom_line(aes(y=result$d1, x=result$years, col="fD1")) +
  geom_line(aes(y=result$n0, x=result$years, col="eN0")) +
  geom_line(aes(y=result$w1, x=result$years, col="dW1")) +
  geom_line(aes(y=result$w2, x=result$years, col="cW2")) +
  geom_line(aes(y=result$w3, x=result$years, col="bW3")) +
  geom_line(aes(y=result$w4, x=result$years, col="aW4"))
mp

result$wavg <- (result$w4*4 + result$w3*3 + result$w2*2 + result$w1*1)
result$davg <- 0-(result$d4*4 + result$d3*3 + result$d2*2 + result$d1*1)
result$avg <- (result$davg + result$wavg)/2

mp <- ggplot(result) + theme_classic() +
  scale_y_continuous(limits=c(-1.5,1.5))+
  scale_x_continuous(limits=c(1500,2020)) +
  geom_line(aes(y=result$wavg, x=result$years, col="wavg")) +
  geom_line(aes(y=result$avg, x=result$years, col="avg")) +
  geom_line(aes(y=result$davg, x=result$years, col="davg"))
mp

mp <- ggplot(dfHhi, aes(year, month))
mp + geom_raster(aes(fill=hhi1))+
  #theme_classic(base_size=80) +
  theme_classic() +
  scale_y_continuous(breaks=c(1,6,12))+
  scale_x_continuous(limits=c(1500,2020)) +
  scale_fill_gradient2(low="#AA6010", mid="#FCF0C2", high="#23AB30") +
  theme( legend.key.width = unit(2,"cm")) +
  geom_line(aes(y=6+2*dfHhi$hhi5, x=dfHhi$time)) +
  #geom_line(aes(y=10+0.5*dfHhi$hhi, x=dfHhi$time)) +
  guides(fill=guide_legend(title="PI", reverse = TRUE))

library("psych")
pairs.panels(result)

cr <- cor(result)


\name{as.PAFit_net}
\alias{as.PAFit_net}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{
  Converting an edgelist matrix to a PAFit_net object
}
\description{
  This function converts a graph stored in an edgelist matrix format to a \code{PAFit_net} object.
}
\usage{
as.PAFit_net(graph, type = "directed", PA = NULL, fitness = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{graph}{
An edgelist matrix. Each row is assumed to be of the form (\code{from_node_id} \code{to_node_id} \code{time_stamp}). For a directed network ,\code{from_node_id} is the id of the source node and \code{to_node_id} is the id of the destination node. For an undirected network, the order is ignored and \code{from_node_id} and \code{to_node_id} are the ids of two ends. \code{time_stamp} is the arrival time of the edge. \code{from_node_id} and \code{to_node_id} are assumed to be integers that are at least \eqn{0}. The whole ids need not to be contiguous.

To register a new node \eqn{i} at time \eqn{t} without any edge, add a row with format (\code{i -1 t}). This works for both undirected and directed networks.

\code{time_stamp} can be either numeric or string. The value of a time-stamp can be arbitrary, but we assume that a smaller time_stamp (regarded so by the \code{sort} function in \code{R}) represents an earlier arrival time. Examples of time-stamps that satisfy this assumption are the integer \code{0:T}, the string format `yyyy-mm-dd', and the POSIX time.

}
\item{type}{
String. Indicates whether the network is \code{"directed"} or \code{"undirected"}.
}
\item{PA}{
Numeric vector. Contains the PA function. Default value is \code{NULL}.
}
\item{fitness}{
Numeric vector. Contains node fitnesses. Default value is \code{NULL}.
}
}

\value{
An object of class \code{PAFit_net}
}

\author{
Thong Pham \email{thongpham@thongpham.net}
}

\examples{
library("PAFit")
# a network from Bianconi-Barabasi model
net        <- generate_BB(N = 50 , m = 10 , s = 10)
as.PAFit_net(net$graph)
}


#' Deviation Diverging Dot Plot.
#'
#' divdot function will draw Diverging Dot Plot for Deviation analysis.
#' @param data input data.frame
#' @param div.var diverging value variable
#' @param method "mean" or "median"
#' @param title main title
#' @param subtitle subtitle
#' @param xtitle x axis title
#' @param ytitle y axis title
#' @param caption caption
#' @return An object of class \code{ggplot}
#' @examples
#' plot<- divdot(data=mtcars,div.var="mpg",method="mean")
#' plot
#'
#' @import ggplot2
#' @import scales
#' @import reshape2
#' @import ggthemes
#' @import gganimate
#' @import gapminder
#' @import ggalt
#' @import ggExtra
#' @import ggcorrplot
#' @import dplyr
#' @import treemapify
#' @import ggfortify
#' @import zoo
#' @import ggdendro
#' @export
divdot<-function(data,div.var, method="mean",
                 title=NULL,subtitle=NULL,xtitle=NULL,ytitle=NULL,caption=NULL){
  df<- data
  div.var<- div.var

  if(method=="mean"){
    df$row<-rownames(df)
    df$z<-round((df[,div.var] - mean(df[,div.var])), 2)
    df$z_type <- ifelse(df$z < 0, "below", "above")
    df <- df[order(df$z), ]
    df$row <- factor(df$row, levels = df$row)
  }

  if(method=="median"){
    df$row<-rownames(df)
    df$z<-round((df[,div.var] - median(df[,div.var])), 2)
    df$z_type <- ifelse(df$z < 0, "below", "above")
    df <- df[order(df$z), ]
    df$row <- factor(df$row, levels = df$row)
  }

  p<-ggplot(df, aes_string(x="row", y="z", label="z")) +
    geom_point(stat='identity', aes_string(col="z_type"), size=6)  +
    scale_color_manual(name=div.var,
                      labels = c("Above Average", "Below Average"),
                      values = c("above"="#008FD5", "below"="#FF2700")) +
    geom_text(color="white", size=2) +
    theme_fivethirtyeight() +
    theme(axis.title = element_text(),
          legend.title = element_text(face = 4,size = 10),
          legend.direction = "horizontal", legend.box = "horizontal")+
    labs(title=title,
         subtitle=subtitle,
         x=xtitle,
         y=ytitle,
         caption=caption) +
    coord_flip()

  return(p)
}


names(data)

lm1 = glm(bup1~.,data = data)

logit=function(x){return(exp(x)/(exp(x)+1))}
invlogit = function(x){return(log(x/(1 -x)))}

logit(invlogit(0.5)-(1.04546+1.090909)*0.0554)


\name{only_F_estimate}
\alias{only_F_estimate}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{
  Estimating node fitnesses in isolation
}
\description{
  This function estimates node fitnesses \eqn{\eta_i} assusming either \eqn{A_k = k} (i.e. linear preferential attachment) or \eqn{A_k = 1} (i.e. no preferential attachment). The method has a hyper-parameter \eqn{s}. It first performs a cross-validation to select the optimal parameter \eqn{s} for the prior of \eqn{\eta_i}, then estimates \eqn{eta_i} with the full data (Ref. 1).
}
\usage{
only_F_estimate(net_object                             ,
               net_stat    = get_statistics(net_object),
               p           = 0.75                      ,
               stop_cond   = 10^-8                     ,
               model_A     = "Linear"                  ,
               ...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
 \item{net_object}{
    an object of class \code{PAFit_net} that contains the network.
  }
\item{net_stat}{
   An object of class \code{PAFit_data} which contains summerized statistics needed in estimation. This object is created by the function \code{\link{get_statistics}}. The default value is \code{get_statistics(net_object)}.
}
  \item{p}{Numeric. This is the ratio of the number of new edges in the learning data to that of the full data. The data is then divided into two parts: learning data and testing data based on \code{p}. The learning data is used to learn the node fitnesses and the testing data is then used in cross-validation. Default value is \code{0.75}.}
\item{stop_cond}{Numeric. The iterative algorithm stops when \eqn{abs(h(ii) - h(ii + 1)) / (abs(h(ii)) + 1) < stop.cond} where \eqn{h(ii)} is the value of the objective function at iteration \eqn{ii}. We recommend to choose \code{stop.cond} at most equal to \eqn{10^(- number of digits of h - 2)}, in order to ensure that when the algorithm stops, the increase in posterior probability is less than 1\% of the current posterior probability. Default is \code{10^-8}. This threshold is good enough for most applications.}

  \item{model_A}{String. Indicates which attachment function \eqn{A_k} we assume:
      \itemize{
        \item \code{"Linear"}: We assume \eqn{A_k = k}, i.e. the Bianconi-\enc{Barabási}{Barabasi} model (Ref. 2).
        \item \code{"Constant"}: We assume \eqn{A_k = 1}, i.e. the Caldarelli model (Ref. 3).
      }
  }
    \item{\dots}{
    %%     ~~Describe \code{\dots} here~~
  }
}

\value{
   Outputs a \code{Full_PAFit_result} object, which is a list containing the following fields:
  \itemize{
    \item \code{cv_data}: a \code{CV_Data} object which contains the cross-validation data. Normally the user does not need to pay attention to this data.

    \item \code{cv_result}: a \code{CV_Result} object which contains the cross-validation result. Normally the user does not need to pay attention to this data.

    \item \code{estimate_result}: this is a \code{PAFit_result} object which contains the estimated node fitnesses and their confidence intervals. In particular, the important fields are:
    \itemize{
    \item \code{shape}: this is the selected value for the hyper-parameter \eqn{s}.
    \item \code{g}: the number of bins used.
    \item \code{f}: the estimated node fitnesses.
    \item \code{var_f}: the estimated variance of \eqn{\eta_i}.
    \item \code{upper_f}: the estimated upper value of the interval of two standard deviations around \eqn{\eta_i}.
    \item \code{lower_f}: the estimated lower value of the interval of two standard deviations around \eqn{\eta_i}.
    \item \code{objective_value}: values of the objective function over iterations in the final run with the full data.
    \item \code{diverge_zero}: logical value indicates whether the algorithm diverged in the final run with the full data.
}
  }
}
\author{
  Thong Pham \email{thongpham@thongpham.net}
}
\references{
  1. Pham, T., Sheridan, P. & Shimodaira, H. (2016). Joint Estimation of Preferential Attachment and Node Fitness in Growing Complex Networks. Scientific Reports 6, Article number: 32558. doi:10.1038/srep32558   (\url{http://www.nature.com/articles/srep32558}).

  2. Bianconni, G. & \enc{Barabási}{Barabasi}, A. (2001). Competition and multiscaling in evolving networks. Europhys. Lett., 54, 436 (\url{http://iopscience.iop.org/article/10.1209/epl/i2001-00260-6/meta}).

  3. Caldarelli, G., Capocci, A. , De Los Rios, P. & \enc{Muñoz}{Munoz}, M.A. (2002). Scale-Free Networks from Varying Vertex Intrinsic Fitness. Phys. Rev. Lett., 89, 258702 (\url{http://link.aps.org/doi/10.1103/PhysRevLett.89.258702}).

}
\seealso{
  See \code{\link{get_statistics}} for how to create summerized statistics needed in this function.

  See \code{\link{joint_estimate}} for the method to jointly estimate the attachment function \eqn{A_k} and node fitnesses \eqn{\eta_i}.

}

\examples{
\dontrun{
  library("PAFit")
  set.seed(1)
  # size of initial network = 100
  # number of new nodes at each time-step = 100
  # Ak = k; inverse variance of the distribution of node fitnesse = 10
  net        <- generate_BB(N        = 1000 , m             = 50 ,
                            num_seed = 100  , multiple_node = 100,
                            s        = 10)

  net_stats  <- get_statistics(net)

  # estimate node fitnesses in isolation, assuming Ak = k
  result     <- only_F_estimate(net, net_stats)

  # plot the estimated node fitnesses and true node fitnesses
  plot(result, net_stats, true = net$fitness, plot = "true_f")
  }
}

\concept{fitness model}


#! /usr/bin/Rscript --vanilla
	# install.packages("moments")

	library(moments)
	x <- read.csv('stdin', header = F);
	# "min, q1, med, mean, q3, max"
	summary(x);
	# describe(x)
	# sprintf("sd :%.02f", sd(x[,1]));
	# skewness(x[,1]);
	# kurtosis(x[,1]);


library(Romp)
library(rbenchmark)

m <- 50000
n <- 500

x <- matrix(rnorm(m*n), m, n)
vec <- rnorm(m)

r_sweep <- function(x, vec) sweep(x, STATS=vec, MARGIN=1, FUN="-")

cols <- c("test", "replications", "elapsed", "relative")

reps <- 100
benchmark(r_sweep(x, vec), c_sweep(x, vec), rcpp_sweep(x, vec), f77_sweep(x, vec), f90_sweep(x, vec), columns=cols, order="relative", replications=reps)


#### #### #### #### #### #### #### #### #### #### ####
####
#### Confronti tra Machine Learning approaches
#### https://machinelearningmastery.com/compare-the-performance-of-machine-learning-algorithms-in-r/
#### #### #### #### #### #### #### #### #### #### ####

rm(list=ls())

# libraries
library(mlbench)
library(caret)

# load the dataset
data(PimaIndiansDiabetes)
#### Pima Indians Diabetes Database
# Variables:
# pregnant  Number of times pregnant
# glucose  Plasma glucose concentration (glucose tolerance test)
# pressure  Diastolic blood pressure (mm Hg)
# triceps  Triceps skin fold thickness (mm)
# insulin  2-Hour serum insulin (mu U/ml)
# mass  Body mass index (weight in kg/(height in m)\^2)
# pedigree  Diabetes pedigree function
# age  Age (years)
# diabetes  Class variable (test for diabetes)

# descriptives
summary(PimaIndiansDiabetes)
plot(PimaIndiansDiabetes[,-9])
dim(PimaIndiansDiabetes)
# puliamo il dataset
for(i in c(2,3,4,7,8))
{
	W = PimaIndiansDiabetes[,i]!=0
 	PimaIndiansDiabetes = PimaIndiansDiabetes[W,]
}
dim(PimaIndiansDiabetes)
plot(PimaIndiansDiabetes[,-9])

# boxplot
par(mfrow=c(1,4))
boxplot(pregnant ~diabetes, data=PimaIndiansDiabetes, col=2:3)
boxplot(glucose ~diabetes, data=PimaIndiansDiabetes, col=2:3)
boxplot(pressure ~diabetes, data=PimaIndiansDiabetes, col=2:3)
boxplot(triceps ~diabetes, data=PimaIndiansDiabetes, col=2:3)

par(mfrow=c(1,4))
boxplot(insulin ~diabetes, data=PimaIndiansDiabetes, col=2:3)
boxplot(mass ~diabetes, data=PimaIndiansDiabetes, col=2:3)
boxplot(pedigree ~diabetes, data=PimaIndiansDiabetes, col=2:3)
boxplot(age ~diabetes, data=PimaIndiansDiabetes, col=2:3)

# Creiamo il training set
control <- trainControl(method="repeatedcv", number=10, repeats=3)
# CART
set.seed(7)
fit.cart <- train(diabetes~., data=PimaIndiansDiabetes, method="rpart", trControl=control)
# LDA
set.seed(7)
fit.lda <- train(diabetes~., data=PimaIndiansDiabetes, method="lda", trControl=control)
# SVM
set.seed(7)
fit.svm <- train(diabetes~., data=PimaIndiansDiabetes, method="svmRadial", trControl=control)
# kNN
set.seed(7)
fit.knn <- train(diabetes~., data=PimaIndiansDiabetes, method="knn", trControl=control)
# Random Forest
set.seed(7)
fit.rf <- train(diabetes~., data=PimaIndiansDiabetes, method="rf", trControl=control)
# collect resamples
results <- resamples(list(CART=fit.cart, LDA=fit.lda, SVM=fit.svm, KNN=fit.knn, RF=fit.rf))

# facciamo un summary
summary(results)

# box and whisker plots to compare models
scales <- list(x=list(relation="free"), y=list(relation="free"))
bwplot(results, scales=scales)
#bwplot(results)

# density plots of accuracy
scales <- list(x=list(relation="free"), y=list(relation="free"))
densityplot(results, scales=scales, pch = "|")

# dot plots of accuracy
scales <- list(x=list(relation="free"), y=list(relation="free"))
dotplot(results, scales=scales)

# parallel plots to compare models
parallelplot(results)

# pair-wise scatterplots of predictions to compare models
splom(results)

# xyplot plots to compare models
xyplot(results, models=c("LDA", "SVM"))

# difference in model predictions
diffs <- diff(results)
# ?diff.resamples
# summarize p-values for pair-wise comparisons
summary(diffs)


\name{print.CV_Data}
\alias{print.CV_Data}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{
  Printing simple information of the cross-validation data
}
\description{
  This function prints simple information of the cross-validation data stored in a \code{CV_Data} object. This object is the field \code{$cv_data} of a \code{Full_PAFit_result} object, which in turn is the returning value of \code{\link{only_A_estimate}}, \code{\link{only_F_estimate}} or \code{\link{joint_estimate}}.
}
\usage{
  \method{print}{CV_Data}(x,...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
  \item{x}{
    An object of class \code{CV_Data}.
  }
    \item{\dots}{
    %%     ~~Describe \code{\dots} here~~
  }
}

\value{
  Prints simple information of the cross-validation data.
}
\author{
  Thong Pham \email{thongpham@thongpham.net}
}
\examples{
  ## Since the runtime is long, we do not let this example run on CRAN
  \dontrun{
    library("PAFit")
    set.seed(1)
    # a network from Bianconi-Barabasi model
    net        <- generate_BB(N        = 1000 , m             = 50 ,
                              num_seed = 100  , multiple_node = 100,
                              s        = 10)
    net_stats  <- get_statistics(net)
    result     <- joint_estimate(net, net_stats)
    print(result$cv_data)
  }
}


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

## -----------------------------------------------------------------------------
require(rms)
options(prType='latex')
getHdata(prostate)
prostate <-
  within(prostate, {
    levels(ekg)[levels(ekg) %in%
                c('old MI','recent MI')] <- 'MI'
    ekg.norm <- 1*(ekg %in% c('normal','benign'))
    levels(ekg) <- abbreviate(levels(ekg))
    pfn <- as.numeric(pf)
    levels(pf)  <- levels(pf)[c(1,2,3,3)]
    cvd <- status %in% c("dead - heart or vascular",
                         "dead - cerebrovascular")
    rxn = as.numeric(rx) })
# Use transcan to compute optimal pre-transformations
ptrans <-   # See Figure (*\ref{fig:prostate-transcan}*)
  transcan(~ sz + sg + ap + sbp + dbp +
           age + wt + hg + ekg + pf + bm + hx + dtime + rx,
           imputed=TRUE, transformed=TRUE,
           data=prostate, pl=FALSE, pr=FALSE)
# Use transcan single imputations
imp <- impute(ptrans, data=prostate, list.out=TRUE)
NAvars <- all.vars(~ sz + sg + age + wt + ekg)
for(x in NAvars) prostate[[x]] <- imp[[x]]
subset <- prostate$status %in% c("dead - heart or vascular",
    "dead - cerebrovascular","dead - prostatic ca")
trans <- ptrans$transformed[subset,]
psub  <- prostate[subset,]

## -----------------------------------------------------------------------------
# Function to compute the first k PCs
ipc <- function(x, k=1, ...)
  princomp(x, ..., cor=TRUE)$scores[,1:k]
# Compute the first 8 PCs on raw variables then on
# transformed ones
pc8 <- ipc(~ sz + sg + log(ap) + sbp + dbp + age +
           wt + hg + ekg.norm + pfn + bm + hx + rxn + dtime,
           data=psub, k=8)
f8   <- lrm(cvd ~ pc8, data=psub)
pc8t <- ipc(trans, k=8)
f8t  <- lrm(cvd ~ pc8t, data=psub)
# Fit binary logistic model on original variables
f <- lrm(cvd ~ sz + sg + log(ap) + sbp + dbp + age +
         wt + hg + ekg + pf + bm + hx + rx + dtime, data=psub)
# Expand continuous variables using splines
g <- lrm(cvd ~ rcs(sz,4) + rcs(sg,4) + rcs(log(ap),4) +
         rcs(sbp,4) + rcs(dbp,4) + rcs(age,4) + rcs(wt,4) +
         rcs(hg,4) + ekg + pf + bm + hx + rx + rcs(dtime,4),
         data=psub)
# Fit binary logistic model on individual transformed var.
h <- lrm(cvd ~ trans, data=psub)

## -----------------------------------------------------------------------------
c(f8=AIC(f8), f8t=AIC(f8t), f=AIC(f), g=AIC(g), h=AIC(h))

## ----full,h=2.25,w=2.5,ps=8,results='asis',cap='Ranking of apparent importance of predictors of cause of death'----
f
an <- anova(f)
an
plot(an)   # Figure (*\ref{fig:lrcase1-full}*)
s <- f$stats
gamma.hat <- (s['Model L.R.'] - s['d.f.'])/s['Model L.R.']

## ----fullpeffects,h=6.5,w=6,cap='Partial effects (log odds scale) in full model for cause of death, along with vertical line segments showing the raw data distribution of predictors',scap='Partial effects in cause of death model'----
dd <- datadist(psub); options(datadist='dd')
ggplot(Predict(f), sepdiscrete='vertical', vnames='names',
       rdata=psub,
       histSpike.opts=list(frac=function(f) .1*f/max(f) )) # Figure (*\ref{fig:lrcase1-fullpeffects}*)

## ----fullor,h=4,w=5,top=2,cap='Interquartile-range odds ratios for continuous predictors and simple odds ratios for categorical predictors.  Numbers at left are upper quartile : lower quartile or current group : reference group.  The bars represent $0.9, 0.95, 0.99$ \\index{confidence intervals}confidence limits.  The intervals are drawn on the log odds ratio scale and labeled on the odds ratio scale.  Ranges are on the original scale.',scap='Interquartile-range odds ratios and confidence limits'----
plot(summary(f), log=TRUE)   # Figure (*\ref{fig:lrcase1-fullor}*)

## -----------------------------------------------------------------------------
fastbw(f)

## ----nom,results='asis',w=5,h=3.25,ps=8,cap='Nomogram calculating $X\\hat{\\beta}$ and $\\hat{P}$ for \\co{cvd} as the cause of death, using the step-down model.  For each predictor, read the points assigned on the 0--100 scale and add these points.  Read the result on the \\texttt{Total Points} scale and then read the corresponding predictions below it.',scap='Nomogram for obtaining $X\\hat{\\beta}$ and $\\hat{P}$ from step-down model'----
fred <- lrm(cvd ~ sz + log(ap) + age + hx, data=psub)
latex(fred, file='')
nom <- nomogram(fred, ap=c(.1, .5, 1, 5, 10, 50),
                fun=plogis, funlabel="Probability",
                fun.at=c(.01,.05,.1,.25,.5,.75,.9,.95,.99))
plot(nom, xfrac=.45)   # Figure (*\ref{fig:lrcase1-nom}*)

## ----results='hide'-----------------------------------------------------------
f <- update(f, x=TRUE, y=TRUE)
v <- validate(f, B=200, bw=TRUE)

## ----results='asis'-----------------------------------------------------------
latex(v, B=20, digits=3)

## ----cal,results='hide',h=3,w=4.75,ps=9,bot=1,cap='Bootstrap overfitting--corrected calibration curve estimate for the backwards step-down cause of death logistic model, along with a rug plot showing the distribution of predicted risks.  The smooth nonparametric calibration estimator (\\co{loess})\\index{nonparametric!regression} is used.',scap='Bootstrap nonparametric calibration curve for reduced cause of death model'----
cal <- calibrate(f, B=200, bw=TRUE)
plot(cal)   # Figure (*\ref{fig:lrcase1-cal}*)

## ----results='asis'-----------------------------------------------------------
vfull <- validate(f, B=200)
latex(vfull, digits=3)

## -----------------------------------------------------------------------------
v5 <- validate(f, bw=TRUE, sls=0.5, type='individual', B=200)

## ----results='asis'-----------------------------------------------------------
latex(v5, digits=3, B=0)

## ----approxr2,h=3,w=3.5,bty='l',cap='Fraction of explainable variation (full model LR $\\chi^2$) in \\co{cvd} that was explained by approximate models, along with approximation accuracy ($x$--axis)',scap='Model approximation vs.\\ LR $\\chi^2$ preserved'----
lp <- predict(f)   # Compute linear predictor from full model
# Insert sigma=1 as otherwise sigma=0 will cause problems
a <- ols(lp ~ sz + sg + log(ap) + sbp + dbp + age + wt +
         hg + ekg + pf + bm + hx + rx + dtime, sigma=1,
         data=psub)
# Specify silly stopping criterion to remove all variables
s <- fastbw(a, aics=10000)
betas <- s$Coefficients   # matrix, rows=iterations
X     <- cbind(1, f$x)    # design matrix
# Compute the series of approximations to lp
ap <- X %*% t(betas)
# For each approx. compute approximation R^2 and ratio of
# likelihood ratio chi-square for approximate model to that
# of original model
m <- ncol(ap) - 1   # all but intercept-only model
r2 <- frac <- numeric(m)
fullchisq <- f$stats['Model L.R.']
for(i in 1:m) {
  lpa <- ap[,i]
  r2[i] <- cor(lpa, lp)^2
  fapprox <- lrm(cvd ~ lpa, data=psub)
  frac[i] <- fapprox$stats['Model L.R.'] / fullchisq
  }   # Figure (*\ref{fig:lrcase1-approxr2}*):
plot(r2, frac, type='b',
     xlab=expression(paste('Approximation ', R^2)),
     ylab=expression(paste('Fraction of ',
         chi^2, ' Preserved')))
abline(h=.95, col=gray(.83)); abline(v=.95, col=gray(.83))
abline(a=0, b=1, col=gray(.83))

## ----nomapprox,results='asis',h=5,w=5,ps=8,cap='Nomogram for predicting the probability of \\co{cvd} based on the approximate model',scap='Approximate nomogram for predicting cause of death'----
fapprox <- ols(lp ~ sz + sg + log(ap) + age + ekg + pf + hx +
               rx, data=psub)
fapprox$stats['R2']   # as a check
latex(fapprox, file='')
nom <- nomogram(fapprox, ap=c(.1, .5, 1, 5, 10, 20, 30, 40),
                fun=plogis, funlabel="Probability",
                lp.at=(-5):4,
           fun.lp.at=qlogis(c(.01,.05,.25,.5,.75,.95,.99)))
plot(nom, xfrac=.45)   # Figure (*\ref{fig:lrcase1-nomapprox}*)


#' @title FB2C
#' @description catch given Fishing mortality and Biomass; useful for  projections
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
#

FB2C <- function(F,B) {
	C = B*(exp(F)-1)*exp(-F)
	return(C)
}


get_grade <- function(a, b, c) {
  i <- min( 5, max( 1, ( mean(c(a,b,c)) - 40 ) %/% 10 ) )
  substr( "FDCBA", i, i )
}


library(leaps)
library(neuralnet)
library(hydroGOF)
library(arules)

# Change this to your file name
FILE <- "C:\\Users\\joaop\\Documents\\GitHub\\srcr_assignment\\parte3\\original_data\\exaustao.csv"
dataset <- read.csv(FILE)

## DATA ADAPTATION ##
dataset$Performance.Task <- as.numeric(dataset$Performance.Task)

## USEFUL VALUES ##
formulaFL = FatigueLevel ~ Performance.KDTMean + Performance.MAMean + Performance.MVMean + Performance.TBCMean + Performance.DDCMean + Performance.DMSMean + Performance.AEDMean + Performance.ADMSLMean
formulaT = Performance.Task ~ Performance.KDTMean + Performance.MAMean + Performance.MVMean + Performance.TBCMean + Performance.DDCMean + Performance.DMSMean + Performance.AEDMean + Performance.ADMSLMean
formulaT_FL = Performance.Task + FatigueLevel ~ Performance.KDTMean + Performance.MAMean + Performance.MVMean + Performance.TBCMean + Performance.DDCMean + Performance.DMSMean + Performance.AEDMean + Performance.ADMSLMean

# DATA DISCRETIZATION #
# after using weka to see the distribution of each
# variable, we discretize each one accordingly
x1 <- as.numeric(discretize(dataset$Performance.KDTMean,method="frequency",categories=1,labels=1:1))
x2 <- as.numeric(discretize(dataset$Performance.MAMean,method="frequency",categories=3,labels=1:3))
x3 <- as.numeric(discretize(dataset$Performance.MVMean,method="frequency",categories=3,labels=1:3))
x4 <- as.numeric(discretize(dataset$Performance.TBCMean,method="frequency",categories=2,labels=1:2))
x5 <- as.numeric(discretize(dataset$Performance.DDCMean,method="frequency",categories=3,labels=1:3))
x6 <- as.numeric(discretize(dataset$Performance.DMSMean,method="frequency",categories=2,labels=1:2))
x7 <- as.numeric(discretize(dataset$Performance.AEDMean,method="frequency",categories=3,labels=1:3))
x8 <- as.numeric(discretize(dataset$Performance.ADMSLMean,method="frequency",categories=4,labels=1:4))

dataset$Performance.KDTMean <- x1
dataset$Performance.MAMean <- x2
dataset$Performance.MVMean <- x3
dataset$Performance.TBCMean <- x4
dataset$Performance.DDCMean <- x5
dataset$Performance.DMSMean <- x6
dataset$Performance.AEDMean <- x7
dataset$Performance.ADMSLMean <- x8

# set a seed so that sample always gives the same train set
set.seed(11)
TRAIN_PERCENTAGE = 0.75
DATASET_SIZE = nrow(dataset)

sample <- sample.int(n=DATASET_SIZE, size=floor(TRAIN_PERCENTAGE*DATASET_SIZE),replace=F)
train <- dataset[sample, ]
test  <- dataset[-sample, ]

# cases used to test neural network accuracy
testCases <- subset(test, select=c("Performance.MAMean", "Performance.AEDMean", "Performance.DDCMean", "Performance.DMSMean", "Performance.KDTMean", "Performance.MVMean", "Performance.TBCMean", "Performance.ADMSLMean"))

## STATISTICAL ANALISYS ##
rsubsFL <- regsubsets(x = formulaFL, data = dataset, nvmax = 8)
rsubsT <- regsubsets(x = formulaT, data = dataset, nvmax = 8)
rsubsT_FL <- regsubsets(x = formulaT_FL, data = dataset, nvmax = 8)

## NEURAL NETWORK DEFINITION AND TRAINING ##
# RNA for analysis of the Fatigue Level #
rnaFL <- neuralnet(formulaFL, train, hidden=c(7,4,4,3), lifesign = "FULL",algorithm="rprop+",linear.output = FALSE,threshold = 0.01)
rnaFL.results <- compute(rnaFL, testCases)
resultsFL <- data.frame(real=test$FatigueLevel, calculated=rnaFL.results$net.result)
resultsFL$calculated <- round(resultsFL$calculated, digits=0)
rmse(c(test$FatigueLevel), c(resultsFL$calculated))

# RNA for analysis of the Task #
rnaT <- neuralnet(formulaT, train, hidden=c(7,4,3), lifesign = "FULL",algorithm="rprop+",linear.output = FALSE,threshold = 0.01)
rnaT.results <- compute(rnaT, testCases)
resultsT <- data.frame(real=test$Performance.Task, calculated=rnaT.results$net.result)
resultsT$calculated <- round(resultsT$calculated, digits=0)
rmse(c(test$FatigueLevel), c(resultsT$calculated))

rnaT_FL <- neuralnet(formulaT_FL, train, hidden=c(7,4,3), lifesign = "FULL",algorithm="rprop+",linear.output = FALSE,threshold = 0.01)


addalpha <- function(colors, alpha=1.0) {
  r <- col2rgb(colors, alpha=T)
  # Apply alpha
  r[4,] <- alpha*255
  r <- r/255.0
  return(rgb(r[1,], r[2,], r[3,], r[4,]))
}

colorRampPaletteAlpha <- function(colors, n=32, interpolate='linear',alpha=1.0) {
  # Create the color ramp normally
  cr <- colorRampPalette(colors, interpolate=interpolate)(n)
  # Find the alpha channel
  a <- col2rgb(colors, alpha=T)[4,]
  # Interpolate
if (interpolate=='linear') {
l <- approx(a, n=n)
} else {
l <- spline(a, n=n)
}
l$y[l$y > 255] <- 255 # Clamp if spline is > 255
#cr <- addalpha(cr, l$y/255.0)

cr<- addalpha(cr,alpha)
return(cr)
}


#' cond.pr
#'
#' Estimate conditional probability for each observation
#' Default to use local method over knn method,
#' if both arguement supply or unspecify, only the local method will use.
#'
#' @param x vector or matrix whose rows contains predictors
#'          of each observations.
#' @param y vector of the variable we want to estimate its condtional cdf
#' @param span  fraction of total distance to be the bandwidth, between 0 and 1,
#'             default to be 0.5 if bandwidth not supply.
#' @param bandwidth the bandwidth of x to evaluate the cdf,
#'                 overwrite the span input.
#' @param rnn   fraction of total number of observations to be knn,
#'              between 0 and 1. Set span to be NULL to use knn,
#'              default to be 0.5, if not supply
#' @param knn   the number of nearest neighbor to estimate the cdf,
#'              should be less than the number of observation and greater than 0
#'              (\code{knn < length(y)}.
#'              setting this value overwrite the rnn
#'
#' @return vector of conditional probability \code{p(Y < y | x)}
#'
#' @examples
#' cond_pr(1:5, 1:5) #[1] 0.33 0.5 0.6 0.75 1
#' cond_pr(1:5, 5:1, span=0) #[1] 1 1 1 1 1
#' cond_pr(1:5, 5:1, span=1) #[1] 1.0 0.8 0.6 0.4 0.2
#' cond_pr(1:5, 5:1, span=NULL) [1] 1. 0.66 0.66 0.66 0.33
#' cond_pr(1:5, 5:1, span=NULL, rnn=1) [1] 1.0 0.8 0.6 0.4 0.2
#' cond_pr(1:5, 5:1, span=NULL, rnn=0) [1] 1 1 1 1 1
#' cond_pr(1:5, 5:1, span=NULL, rnn=0, knn=1) [1] 1. 0.6 0.66 0.66 0.5
#' cond_pr(1:5, 5:1, span=NULL, rnn=0, knn=3) [1] 1.00 0.75 0.60 0.50 0.25
#' cond_pr(1:5, 5:1, bandwidth=1) [1] 1 0.6 0.6 0.6 0.5
#' cond_pr(matrix(1:12, nrow=6), 6:1) [1] 1. 0.75 0.6 0.6 0.5 0.33
#' cond_pr(matrix(1:12, nrow=6), 6:1, span = 0.6) [1] 1.0.8 0.67 0.5 0.4 0.25
#' cond_pr(matrix(1:12, nrow=6), 6:1, bandwidth = 5) 1. 0.8 0.6 0.5 0.4 0.25
#' cond_pr(matrix(1:12, nrow=6), 6:1, span = NULL) [1] 1. 0.75 0.6 0.6 0.5 0.25
#' cond_pr(matrix(1:12, nrow=6), 6:1, span = NULL, rnn = 0)
#' cond_pr(matrix(1:12, nrow=6), 6:1, span = NULL, rnn = 1)
#' cond_pr(matrix(1:12, nrow=6), 6:1, span = NULL, rnn = 1, knn=1)

cond_pr <- function(x, y,
                    span = 0.1, bandwidth=NULL,
                    rnn = NULL, knn=NULL) {
    #--------------------------------------
    ### Checking---------------------------
    #--------------------------------------
    if (is.vector(x)) {
        if ((s_n <- length(x)) != length(y)) {
            stop("input error: length(x)!=length(y)!")
        }
        is_vec <- T
    } else {
        if ((s_n <- nrow(x)) != length(y)) {
            stop("input error: nrow(x)!=length(y)!")
        }
        is_vec <- F
    }

    use_local <- F
    if (!is.null(span) || !is.null(bandwidth)) {
        if ((span < 0 || span > 1) & missing(bandwidth)) {
            stop("input error: span out of bound, no bandwidth supply!")
        }
        use_local <- T
    } else {
        if (missing(knn) || is.null(knn)) {
            if (is.null(rnn)) {
                rnn <- 0.5
            } else if (rnn < 0 || rnn > 1) {
                stop("input error: rnn out of bound, no knn supply!")
            }
            knn <- floor(rnn * s_n)
        }

        if (knn >= s_n) {
            print("warning: knn > s_n, set knn = s_n.")
            return(order(y) / s_n)
        }
    }

    #---------------------------------------------------
    ### Calculate probability---------------------------
    #---------------------------------------------------
    if (use_local) {
        output <- local_method(s_n, x, y, span, bandwidth, is_vec)
    } else {
        output <- knn_method(s_n, x, y, knn, is_vec)
    }

    return(output)
}

local_method <- function(s_n, x, y, span, bandwidth, is_vec) {
    # preallocate vector for condition probability
    c_prob <- c()
    if (is_vec) {
        s_range <- max(x) - min(x)
        if (missing(bandwidth) || is.null(bandwidth)) {
            bandwidth <- span * s_range
        }
        if (bandwidth >= s_range) {
            print("warning: bandwidth > maxwidth, bandwidth = maxwidth.")
            return(order(y) / s_n)
        }
        # Estimate conditional probability
        for (i in seq_len(s_n)) {
            idx <- which(abs(x - x[i]) <= bandwidth)
            c_prob[i] <- mean(y[idx] <= y[i])
        }
    } else {
        # Preallocate matrix for distance
        m_dist <- matrix(0, nrow = s_n, ncol = s_n)
        # Estimate distance between each x_i
        for (i in seq_len(s_n)) {
            diff <- x[- (1:i), ] - tcrossprod(rep(1, s_n - i), x[i, ])
            m_dist[i, - (1:i)] <- rowSums(diff^2)
        }
        m_dist <- sqrt(m_dist)
        s_range <- max(m_dist) - min(m_dist)
        if (missing(bandwidth) || is.null(bandwidth)) {
            bandwidth <- span * s_range
        }
        if (bandwidth >= s_range) {
            print("warning: bandwidth > maxwidth, bandwidth = maxwidth.")
            return(order(y) / s_n)
        }
        m_dist <- m_dist + t(m_dist)
        for (i in seq_len(s_n)) {
            idx <- which(m_dist[i, ] <= bandwidth)
            c_prob[i] <- mean(y[idx] <= y[i])
        }
    }

    return(c_prob)
}

knn_method <- function(s_n, x, y, knn, is_vec) {
    # preallocate vector for condition probability
    c_prob <- c()
    if (is_vec) {
        ord <- order(x)
        # Estimate conditional probability
        for (i in seq_len(s_n)) {
            ord_i <- which(ord == i)
            l_idx <- max(1, ord_i - knn)
            u_idx <- min(s_n, ord_i + knn)
            set <- ord[l_idx:u_idx]
            v_dist <- abs(x[set] - x[i])
            # find the closest k elements
            kth <- sort(v_dist, partial = knn + 1)[knn + 1]
            idx <- which(v_dist <= kth)
            c_prob[i] <- mean(y[set[idx]] <= y[i])
        }
    } else {
        # Estimate distance between each x_i
        for (i in seq_len(s_n)) {
            diff <- abs(x - tcrossprod(rep(1, s_n), x[i, ]))
            v_dist <- rowSums(diff^2)

            kth <- sort(v_dist, partial = knn + 1)[knn + 1]
            idx <- which(v_dist <= kth)
            c_prob[i] <- mean(y[idx] <= y[i])
        }
    }

    return(c_prob)
}


#### SA Analysis: Continuous RQA Parameter Searching ####
# [MC]: Created new subdirectory 'crqa_results' under 'data' for results!

# set working directory
setwd("./SA_Analysis/")

# read in libraries and functions
source('./lib/functions_and_libraries-SA.R')
library(crqa)

# read in gaze csv of all participants
gaze_data = read.table('./data/downsampled/all_participants-downsampled.csv',
                       sep=',',header=TRUE)

#### Determine DELAY with average mutual information (AMI) ####

# set maximum AMI
ami.lag.max = 200

# get AMI lag
gaze_data = gaze_data %>%

  # group data of each participant
  group_by(participant) %>%

  # find first local minimum
  mutate(ami.loc = first_local_minimum(tseriesChaos::mutual(gaze_diff, lag.max = ami.lag.max, plot = FALSE)))

ami_df = gaze_data %>%
  select(participant, ami.loc) %>%
  distinct()
#
# test_df = gaze_data %>%
#   dplyr::filter(participant == 'sa1_2019-10-31_001-0')
#
# test_ami = tseriesChaos::mutual(test_df$gaze_diff, lag.max = ami.lag.max, plot = TRUE)

# write AMI information to file
write.table(gaze_data %>%
              select(participant, ami.loc) %>%
              distinct(),
            './data/crqa_results/ami.csv',
            sep=',',
            row.names=FALSE, col.names=TRUE)

#### Determing embedding dimension with FNN ####

# create empty data frame for saving embed results
embed_results = data.frame()

# set maximum percentage of false nearest neighbors
fnnpercent = 10

# split up data into each participant
participant.dfs = split(gaze_data,
                  list(gaze_data$participant))

# loop through each participant file to calculate fNN
for (next.participant in participant.dfs) {

  # call in the needed data
  next_participant = data.frame(next.participant)

  # tell us whats up
  print(paste0("Beginning fNN calculations for participant ", unique(next_participant$participant)))

  # grab unique ami for the participant
  next_ami = unique(next_participant$ami.loc)[1]

  # calculate false nearest neighbors
  fnn = tseriesChaos::false.nearest(series = next_participant$gaze_diff,
                                    m = fnnpercent,
                                    d = next_ami,
                                    t = 1,
                                    rt = 10,
                                    eps = sd(next_participant$gaze_diff) / 10)
  fnn = fnn[1,][complete.cases(fnn[1,])]
  threshold = as.numeric(fnn[1]/fnnpercent)

  # identify the largest dimension after a large drop
  embed = max(as.numeric(which(diff(fnn) < -threshold))) + 1

  next_participant = next_participant %>%
    mutate(embed = embed)

  embed_results = rbind.data.frame(embed_results,
                              next_participant)
}

# save false nearest neighbor calculations to file
write.table(embed_results %>%
              select(participant, embed) %>%
              distinct(),
            './data/crqa_results/embed.csv', sep=',',row.names=FALSE,col.names=TRUE)

gaze_data = full_join(gaze_data, embed_results)

#### Determine optimal radius ####

# rescale by mean distance
gaze_crqa = gaze_data %>%
  dplyr::select(participant, gaze_diff, ami.loc, embed) %>%
  group_by(participant) %>%
  mutate(rescale.gaze_diff = gaze_diff/mean(gaze_diff))

# create an empty dataframe to hold the parameter information
radius_selection = data.frame(participant = numeric(),
                              choosen.delay = numeric(),
                              chosen.embed = numeric(),
                              chosen.radius = numeric(),
                              rr = numeric())

# identify radius for calculations
radius.list = seq(.05,.20,by=.05)

# split up data into each participant
participant.dfs = split(gaze_crqa,
                        list(gaze_crqa$participant))

# cycle through all participants
for (next.particiant in participant.dfs){

  # reset `target` variables for new radius (above what RR can be)
  from.target = 101
  last.from.target = 102

  # cycle through radii
  for (chosen.radius in radius.list){

    # if we're still improving, keep going
    if (from.target < last.from.target){

      # keep the previous iteration's performance
      last.from.target = from.target

      # print update
      print(paste("Participant ", unique(next.particiant$participant),
                  ": radius ", chosen.radius,sep=""))

      # identify parameters
      chosen.delay = unique(next.particiant$ami.loc)
      chosen.embed = unique(next.particiant$embed)

      # run CRQA and grab recurrence rate (RR)
      rec_analysis = crqa(next.particiant$rescale.gaze_diff,
                          next.particiant$rescale.gaze_diff,
                          delay = chosen.delay,
                          embed = chosen.embed,
                          r = chosen.radius,
                          normalize = 0,
                          rescale = 0,
                          mindiagline = 2,
                          minvertline = 2,
                          tw = 1,
                          whiteline = FALSE,
                          recpt = FALSE)
      rr = rec_analysis$RR
      det = rec_analysis$DET
      meanL = rec_analysis$L

      # clear it so we don't take up too much memory (optional)
      rm(rec_analysis)

      # identify how far off the RR is from our target (5%)
      from.target = abs(rr - 5)

      # save individual radius calculations
      write.table(cbind.data.frame(unique(next.participant$participant),
                                   chosen.delay,
                                   chosen.embed,
                                   chosen.radius,
                                   rr,
                                   det,
                                   meanL,
                                   from.target),
                  paste('./data/crqa_results/radius_calculations-mean_scaled-r',chosen.radius,'-', unique(next.participont$particiant),'.csv', sep=''),
                  sep=',',row.names=FALSE,col.names=TRUE)

      # append to dataframe
      radius_selection = rbind.data.frame(radius_selection,
                                          cbind.data.frame(unique(next.participant$participant),
                                                           chosen.delay,
                                                           chosen.embed,
                                                           chosen.radius,
                                                           rr,
                                                           det,
                                                           meanL,
                                                           from.target))
    } else {

      # if we're no longer improving, break
      break

    }}}

# save the radius explorations to file
write.table(radius_selection,'./data/crqa_results/radius_calculations-mean_scaled-SA.csv', sep=',',row.names=FALSE,col.names=TRUE)

# let us know when it's finished
beepr::beep("fanfare")

#### Export chosen radii for all participants ####

# load in files
radius_selection = read.table('./data/crqa_results/radius_calculations-mean_scaled-SA.csv',
                              sep=',',header=TRUE)

# identify the target radii
radius_stats = radius_selection %>% ungroup() %>%
  group_by(participant) %>%
  dplyr::filter(from.target==min(from.target)) %>%
  dplyr::arrange(participant) %>%
  dplyr::arrange(desc(from.target)) %>%
  slice(1) %>%
  distinct()

# join the dataframes
gaze_crqa = full_join(radius_stats,
                                 gaze_crqa,
                                 by = c("participant",
                                        "chosen.embed" = "embed.selected",
                                        "chosen.delay" = "ami.selected"))

# save to files
write.table(gaze_crqa,'./data/crqa_results/crqa_data_and_parameters-SA.csv',
            sep=',',row.names=FALSE,col.names=TRUE)
write.table(radius_stats, './data/crqa_results/crqa_parameters-SA.csv',
            sep=',',row.names=FALSE,col.names=TRUE)


# The key to similarity is not that terms happen to occur in the same document:
# it is that the terms happen to occur in the same context - that they have very similar neighbors.

build_tdm<-function(lookup_tbl,vocabulary=NULL,weighted=FALSE){
	# Construct LSA space
	MINWORDLENGTH<-2
	WORDSTOEXCLUDE<-c("a","the","this","these","that","those","then","and","an","with","within","without","when","why","how","in",
	"on","of","from","for","at","so","then","thus","here","there")
	library(LSAfun)
	library(text2vec)
	myList<-list()
	# Construct terms/documents matrix based on a given set of documents or read it from the file
	s<-breakdown(as.character(lookup_tbl[[1]]))
	it <- itoken(s, preprocess_function = tolower,tokenizer = word_tokenizer, chunks_number = 10, progessbar = F)
	if(is.null(vocabulary)){
		vocab<-create_vocabulary(it,stopword=WORDSTOEXCLUDE,ngram=c(ngram_min=1L,ngram_max=1L))
	}else{
		vocab<-vocabulary
	}
	myList[[1]]<-vocab
	vectorizer = vocab_vectorizer(vocab)
	dtm = create_dtm(it, vectorizer)
	myMatrix<-as.textmatrix(t(as.matrix(dtm)))
	colnames(myMatrix)<-paste0("D",seq(1,ncol(myMatrix)))

	# apply tfidf weights to the terms/documents matrix
	if(weighted){
		myMatrix<-apply_tfidf(myMatrix)
	}
	myList[[2]]<-myMatrix
	gc()
	return(myList)
}

append_doc<-function(lookup_tbl,myLSAspace,myVocabulary,filename_lsa,weighted=FALSE){
	existTDM<-as.textmatrix(myLSAspace)
	myList<-build_tdm(lookup_tbl,myVocabulary,weighted)
	myTDM<-myList[[2]]
	newTDM<-fold_in(myTDM,myLSAspace)
	n<-ncol(existTDM)
	m<-ncol(newTDM)
	colnames(newTDM)<-paste0("D",seq(n+1,n+m))
	combTDM<-cbind(existTDM,newTDM)
	existSum<-sum(myLSAspace$sk)
	combLSAspace = lsa(combTDM,dims=dimcalc_ndocs(existSum))
	saveRDS(combLSAspace, paste0(filename_lsa,".rds"))
	gc()
	return(combLSAspace)
}

append_docs<-function(lookup_tbl,myLSAspace,myVocabulary,filename_lsa,weighted=FALSE){
	# Get LSa space components
	tk<-existLSAspace$tk
	sk<-existLSAspace$sk
	dk<-existLSAspace$dk
	n<-nrow(dk)
	# Construct additional docs term document matrix
	s<-breakdown(as.character(tbl2[[1]]))
	it <- itoken(s, preprocess_function = tolower,tokenizer = word_tokenizer, chunks_number = 10, progessbar = F)
	vocab<-readRDS("original-lsa-vocab.rds")
	vectorizer = vocab_vectorizer(vocab)
	dtm = create_dtm(it, vectorizer)
	q<-as.textmatrix(t(as.matrix(dtm)))
	colnames(q)<-paste0("D",seq(n+1,n+ncol(q)))
	# If term frequency if needed
	if(weighted){
		q<-q/colSums(q)
	}
	# Map new docs into the existing LSa space
	s<-diag(sk)
	q<-t(q) %*% as.matrix(tk) %*% solve(s)
	# Extend existing LSA space with new docs
	dk<-rbind(dk,q)
	combLSAspace<-existLSAspace
	combLSAspace$dk<-dk
	saveRDS(combLSAspace, paste0(filename_lsa,".rds"))
	gc()
	return(combLSAspace)

}

apply_tfidf<-function(matrix){
	# Compute tfidf weights and apply them to a given terms/documents matrix
	totals<-colSums(matrix)
	tfidf_matrix<-matrix/totals*gw_idf(matrix)
	return(tfidf_matrix)
}

lsi_mgr<-function(lookup_tbl,share=SHARE,filename_lsa=LSA_filename,weighted=FALSE){
	# build LSA space
	SHARE<-0.8
	LSA_filename<-"LSAspace"
	# Construct term document matrix
	myList<-build_tdm(lookup_tbl,NULL,weighted)
	myVocabulary<-myList[[1]]
	myMatrix<-myList[[2]]
	# Build LSa space
	myLSAspace = lsa(myMatrix, dims=dimcalc_share(share))
	saveRDS(myLSAspace, paste0(filename_lsa,".rds"))
	saveRDS(myVocabulary, paste0(filename_lsa,"-vocab.rds"))
	rm(myLSAspace,myVocabulary,myList)
}

match_desc<-function(terms, desc){
	# mapping query terms to LSI terms
	MAXDIST<-1
	library(stringdist)
	v_terms<-terms[terms %in% desc]
	unmatched_desc<-desc[!(desc %in% v_terms)]
	if(length(unmatched_desc) > 0){
		v_terms1<-terms[amatch(unmatched_desc,terms,maxDist=MAXDIST)]
		v_terms1<-v_terms1[!is.na(v_terms1)]
		if(length(v_terms1) > 0){
			desc<-c(v_terms,v_terms1)
		}
	}
	gc()
	return(desc)
}

lsi_lookup<-function(item,lookup_tbl,margin=0.01,myLSAspace,weighted=FALSE){
	# perform lsi lookup
	library(lsa)
	library(plyr)
	tk<-myLSAspace$tk
	dk<-myLSAspace$dk
	sk<-myLSAspace$sk
	myList<-list()

	terms<-rownames(tk)
	# parse a given item
	desc<-tolower(unlist(strsplit(item," ")))
	# map the item to actual terms in case it is not exact match to terms
	desc<-match_desc(terms,desc)
	if(length(desc) > 0){
		# calculate query terms frequency
		o<-count(desc)
		o$tf<-o$freq/sum(o$freq)
		w<-ifelse(terms %in% o$x, o$tf, 0)
		# query in original coordinates
		q<-ifelse(terms %in% desc, 1, 0)
		# if weighted apply term frequency
		if(weighted) {
			q<-q*w
		}
		# express query in new coordinates
		# diagonal eigenvalues matrix
		s<-diag(sk)
		q<-t(q) %*% as.matrix(tk) %*% solve(s)
	} else{
		return(myList)
	}
	# perform cosine similarity between query and the documents
	# to identify the most similar match
	m<-nrow(dk)
	v<-vector()
	for(i in 1:m){
		v[i]<-cosine(as.numeric(q),as.numeric(dk[i,]))
	}
	r<-max(v)
	row<-which(v>(max(v)-margin))
	nbr<-as.integer(substring(rownames(dk)[row],2))
	myList[[1]]<-as.character(lookup_tbl[nbr,1])
	myList[[2]]<-paste0(as.character(lookup_tbl[nbr,2]))
	myList[[3]]<-v[row]
	rm(tk,dk,sk,desc,w,o,m,v,r)
	#return(paste0(as.character(lookup_tbl[nbr,"Category"]),"-",as.character(lookup_tbl[nbr,"DoD_SE_Category"])))
	return(myList)
}


library(anchors)

# this.dir<- dirname(parent.frame(2)$ofile)
# parent.dir <- strsplit(this.dir,'scripts')[[1]]
# setwd(parent.dir)

clusters <- read.csv('output/clusters-9-factors-ward-scaled.csv')
data1$clusterID <- clusters$cluster

d1 <- colMeans(data1[data1$clusterID==1,][,-c(1:4)],na.rm=TRUE)
d2 <- colMeans(data1[data1$clusterID==2,][,-c(1:4)],na.rm=TRUE)
d3 <- colMeans(data1[data1$clusterID==3,][,-c(1:4)],na.rm=TRUE)
d4 <- colMeans(data1[data1$clusterID==4,][,-c(1:4)],na.rm=TRUE)
d5 <- colMeans(data1[data1$clusterID==5,][,-c(1:4)],na.rm=TRUE)
d6 <- colMeans(data1[data1$clusterID==6,][,-c(1:4)],na.rm=TRUE)
d7 <- colMeans(data1[data1$clusterID==7,][,-c(1:4)],na.rm=TRUE)
d8 <- colMeans(data1[data1$clusterID==8,][,-c(1:4)],na.rm=TRUE)
d9 <- colMeans(data1[data1$clusterID==9,][,-c(1:4)],na.rm=TRUE)
d10 <- colMeans(data1[data1$clusterID==10,][,-c(1:4)],na.rm=TRUE)
d11 <- colMeans(data1[data1$clusterID==11,][,-c(1:4)],na.rm=TRUE)
d12 <- colMeans(data1[data1$clusterID==12,][,-c(1:4)],na.rm=TRUE)
if(num_clust==13){
  d13 <- colMeans(data1[data1$clusterID==13,][,-c(1:4)],na.rm=TRUE)
}

datameans <- colMeans(data1[,-c(1:4)],na.rm=TRUE)
if(num_clust==13){clustermeans <- data.frame(rbind(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13))
}else{clustermeans <- data.frame(rbind(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12))}
for (ii in c(1:64)){
  clustermeans[,ii][is.na(clustermeans[,ii])] = as.numeric(datameans[ii])
}

data2 <- data.frame(data1)
head(data2[data2$clusterID==1,][names(clustermeans)[64]])
for (ii in c(1:13)){
  for (jj in c(1:64)){
      data2[data2$clusterID==ii,] <- replace.value(data2[data2$clusterID==ii,] , names(clustermeans)[jj], NA, clustermeans[ii,jj] )
  }
}
head(data2[data2$clusterID==1,][names(clustermeans)[64]])

data3 <- as.data.frame(data2[,-c(1:4)])


  SWEIGHT<-function(data2=Age_w,TA=Total_AGE,fyear=fyear){
  require(mgcv)
  #data=subset(data,!is.na(data$WEIGHT))
  ##fill in the 1980 weights by length
  #test<-gam(log(WEIGHT)~as.factor(YEAR)+s(LENGTH,by=as.factor(YEAR)),gamma=1.4,data=data)
  #new_data<-subset(data,data$YEAR==1980)
  #new_data$YEAR=1983
  #data$WEIGHT[data$YEAR==1980]<-exp(predict(test,newdata=new_data))

  Weight<-subset(data2,!is.na(data2$WEIGHT))
  Weight$AGE1<-Weight$AGE
   Weight$AGE1[Weight$AGE>15]<-15

  WEIGHT<-aggregate(list(WEIGHT=Weight$WEIGHT),by=list(SEX=Weight$SEX,AGE=Weight$AGE1,YEAR=Weight$YEAR),FUN=mean)
  grid=expand.grid(YEAR=sort(unique(WEIGHT$YEAR)),SEX=c(1,2),AGE=c(min(Weight$AGE1):15))
  WEIGHT_A<-merge(grid,WEIGHT,all=T)
  test<-gam(log(WEIGHT)~as.factor(YEAR)+as.factor(SEX)+s(AGE,by=as.factor(YEAR)),gamma=1.4,data=subset(WEIGHT_A,is.na(WEIGHT_A$AGE)==F))
  WEIGHT_A$pred<-exp(predict(test,newdata=WEIGHT_A))
  WEIGHT_A$WEIGHT2<-WEIGHT_A$WEIGHT
  WEIGHT_A$WEIGHT2[is.na(WEIGHT_A$WEIGHT2)==T]<-WEIGHT_A$pred[is.na(WEIGHT_A$WEIGHT2)==T]

  WEIGHT_A2<-subset(WEIGHT_A,select=c(YEAR,SEX,AGE,WEIGHT2))

  Total_A<-merge(TA,WEIGHT_A2,all=T)
  Total_A<-Total_A[order(Total_A$YEAR,Total_A$SEX,Total_A$AGE),]

  Total<-subset(Total_A,!is.na(Total_A$WEIGHT2))
  Total$FREQ[is.na(Total$FREQ)]<-0
  Total$w<-Total$WEIGHT*Total$FREQ
  Total$w[Total$w==0]<-Total$WEIGHT2[Total$w==0]

  Total<-aggregate(list(Total=Total$FREQ,WW=Total$w),by=list(YEAR=Total$YEAR,AGE=Total$AGE),FUN=sum)
  Total$Total[Total$Total==0]<-2
  Total$AWEIGHT<-Total$WW/Total$Total
  Total<-Total[order(Total$YEAR,Total$AGE),]
  Total<-subset(Total,select=-c(Total,WW))

  GRID<-expand.grid(YEAR=c(1978:fyear),AGE=c(1:15))
  WEIGHT_B<-merge(GRID,Total,all=T)

  WEIGHT_B$PERIOD<-"F1"
  WEIGHT_B$PERIOD[WEIGHT_B$YEAR>1985]<-"F2"
  WEIGHT_B$PERIOD[WEIGHT_B$YEAR>1990]<-"D1"
  WEIGHT_B$PERIOD[WEIGHT_B$YEAR>1995]<-"D2"
  WEIGHT_B$PERIOD[WEIGHT_B$YEAR>2000]<-"D3"

  WEIGHT_B$PERIOD<-as.factor(WEIGHT_B$PERIOD)

  test1<-gam(log(AWEIGHT)~PERIOD+s(AGE,by=as.factor(PERIOD)),gamma=1.4,data=subset(WEIGHT_B,!is.na(WEIGHT_B$AGE)))

  WEIGHT_B$pred[!is.na(WEIGHT_B$AGE)]<-exp(predict(test1,newdata=WEIGHT_B))

  WEIGHT_B$AWEIGHT2[is.na(WEIGHT_B$AWEIGHT)]<-WEIGHT_B$pred[is.na(WEIGHT_B$AWEIGHT)]

  WEIGHT_B$AWEIGHT2[is.na(WEIGHT_B$AWEIGHT2)]<- WEIGHT_B$AWEIGHT[is.na(WEIGHT_B$AWEIGHT2)]

  S_AGE_WEIGHT<-data.frame(matrix(ncol=15,nrow=length(unique(WEIGHT_B$YEAR))))
  names(S_AGE_WEIGHT)<-c("YEAR","A2","A3" ,"A4","A5","A6","A7","A8","A9","A10","A11","A12","A13","A14","A15")
  S_AGE_WEIGHT$YEAR<-c(1978:fyear)

  Years1<-c(1978:fyear)
  for( i in 1:length(Years1)){
  S_AGE_WEIGHT[i,2:15]<-WEIGHT_B$AWEIGHT2[WEIGHT_B$YEAR==Years1[i]][2:15]
  }
  WEIGHT2<-subset(WEIGHT_A,select=c(YEAR,SEX,AGE,WEIGHT2))

  SWEIGHT<-list( WEIGHT=WEIGHT2,AGE_WEIGHT=S_AGE_WEIGHT)
  SWEIGHT
}


rm(list = ls())
clc <- function() cat(rep("\n", 50))
clc()
rm(list = ls())

library(quantmod)
library(fPortfolio)
library(tidyverse)

# setwd("./")
# source("./Utility/utility.R")

# environmentSettings()
start.date = as.Date("2017-09-09")
end.date = as.Date("2018-09-09")

# mystocks <- new.env(hash=TRUE)
# result <- getSymbols(myTitles,src="yahoo", auto.assign = TRUE, env=mystocks)
getTitles <- function(myTitle,source){

  numberTitles <- ncol(myTitles)

  getSymbols(myTitles, src=source, from="2017-09-09", to="2018-09-09")

  #ClosePrices <- do.call(merge, lapply(myTitles, function(x) Cl(get(x))))
  #OpenPrices <- do.call(merge, lapply(myTitles, function(x) Op(get(x))))
  #Volumes <- do.call(merge, lapply(myTitles, function(x) Vo(get(x))))
  portfolioPrices <- do.call(merge, lapply(myTitles, function(x) Ad(get(x))))

  # result <- as.data.frame(Adjusted)

  #Remove NA from the Portfolio Prices
  portfolioPrices <- portfolioPrices[apply(portfolioPrices,1,function(x) all(!is.na(x))),]

  #Add the correct names to the dataframe
  colnames(portfolioPrices) <- myTitle

  return(portfolioPrices)

}

#***********************#
myTitles <- c("GOOG","AAPL","MSFT","AMZN","INTC")
source = "yahoo"

titles <- getTitles(myTitles,source)


# event-duration-per-patient

# calculate start, end and duration per patient from a table with columns for patient id and date/time of events

library(tidyverse) # for packages dplyr

# create a small example dataframe
# this uses as.Date from base R
df1 <- data_frame( patient = c(1,1,2,2,3,3),
                   event_date = as.Date(c("2021-12-25","2022-01-10",
                                          "2022-01-10","2021-04-17",
                                          "2022-01-10","2022-01-10")))

df2 <- df1 %>%
  group_by(patient) %>%
  summarise( start_date = min(event_date, na.rm=FALSE),
             end_date = max(event_date, na.rm=FALSE),
             n_events = n()) %>%
  mutate( duration_days = end_date - start_date)

df2

# na.rm included in case there is any missing data
# although maybe unlikely in this case
# note1 n_events will include any with missing data
# note2 duration_days is an object of type 'drtn' which sometimes is treated as an integer
# but also has information on units

# patient start_date end_date   n_events duration_days
# <dbl> <date>     <date>        <int> <drtn>
# 1       1 2021-12-25 2022-01-10        2  16 days
# 2       2 2021-04-17 2022-01-10        2 268 days
# 3       3 2022-01-10 2022-01-10        2   0 days


##### Chapter 8: Association Rules -------------------

## Example: Identifying Frequently-Purchased Groceries ----
## Step 2: Exploring and preparing the data ----

# load the grocery data into a sparse matrix
library(arules)
groceries <- read.transactions("groceries.csv", sep = ",")
summary(groceries)

# look at the first five transactions
inspect(groceries[1:5])

# examine the frequency of items
itemFrequency(groceries[, 1:3])

# plot the frequency of items
itemFrequencyPlot(groceries, support = 0.1)
itemFrequencyPlot(groceries, topN = 20)

# a visualization of the sparse matrix for the first five transactions
image(groceries[1:5])

# visualization of a random sample of 100 transactions
image(sample(groceries, 100))

## Step 3: Training a model on the data ----
library(arules)

# default settings result in zero rules learned
apriori(groceries)

# set better support and confidence levels to learn more rules
groceryrules <- apriori(groceries, parameter = list(support =
                          0.006, confidence = 0.25, minlen = 2))
groceryrules

## Step 4: Evaluating model performance ----
# summary of grocery association rules
summary(groceryrules)

# look at the first three rules
inspect(groceryrules[1:3])

## Step 5: Improving model performance ----

# sorting grocery rules by lift
inspect(sort(groceryrules, by = "lift")[1:5])

# finding subsets of rules containing any berry items
berryrules <- subset(groceryrules, items %in% "berries")
inspect(berryrules)

# writing the rules to a CSV file
write(groceryrules, file = "groceryrules.csv",
      sep = ",", quote = TRUE, row.names = FALSE)

# converting the rule set to a data frame
groceryrules_df <- as(groceryrules, "data.frame")
str(groceryrules_df)


#########################################################################
##   Create a layout scheme for an electrode grid.
##
##
##   (c) wolf zinke (Feb. 2014) - Electrode Grid Tools
##
##
##  ToDo:  - Use other layouts in addition to the crist grid with 72 holes
##
##########################################################################

GridLayout = function(grid_rad=7, hole_rad=0.4, hemi='R', grid_type='crist72', titl=NULL, filename=NULL)
{
    if(!is.null(filename)){
        postscript(file=filename , pointsize = 14, ,width = 0.39*25, height = 0.39*25,paper='special', horizontal=F) }

    # create tick mark labels (quick & dirty)
    gridvec = -grid_rad:grid_rad
    APlbl = paste('A',gridvec,sep='')
    APlbl = gsub("A-",'P',APlbl)
    APlbl = gsub("A0",'0',APlbl)

    MLlbl = paste('L',gridvec,sep='')
    MLlbl = gsub("L-",'M',MLlbl)
    MLlbl = gsub("L0",'0',MLlbl)

    # swap M/L label depending on hemisphere
    if(toupper(hemi) == 'R'){
        lbls = c('M', 'L', 'P', 'A')
    }else{
        lbls = c('L', 'M', 'P', 'A')
        MLlbl = rev(MLlbl)
    }

    grid_pos = -grid_rad:grid_rad
    grid_x = c()
    grid_y = c()

    odia = grid_rad+1 # radius to draw cylinder
    plot_range = c(-odia-2, odia+2)
    lblpos=odia+1

    # determine grid layout
    if(grid_type == 'crist72'){
        for(i in grid_pos){
            for(j in grid_pos){
            if(i^2+j^2 < (grid_rad+0.5)^2){
                grid_x = c(grid_x, i)
                grid_y = c(grid_y, j)
        }}}
    }else{ stop("Other layout options not implemented yet!") }

    # plot chamber and grid
    plot(0,0,asp=1, xlim=plot_range, ylim=plot_range, type='n', axes = T, xlab = "medio-lateral axis", ylab = 'anterio-posterior axis', bty="n", xaxs='i', yaxs='i', yaxt="n", xaxt="n", main=titl)

    axis(1, at=gridvec,labels=MLlbl, cex.axis=0.8)
    axis(2, at=gridvec,labels=APlbl, cex.axis=0.8)

    lines(x=c(0, 0), y=c(-odia, odia), col='lightgrey', lty=1, lwd=1)
    lines(x=c(-odia, odia), y=c(0, 0), col='lightgrey', lty=1, lwd=1)

    # ok, I know, one would be enough...
    symbols (0,0, circles=odia, add=TRUE, inches=FALSE, fg='black',     lwd=8)
    symbols (0,0, circles=odia, add=TRUE, inches=FALSE, fg='darkgrey',  lwd=6)
    symbols (0,0, circles=odia, add=TRUE, inches=FALSE, fg='grey',      lwd=4)
    symbols (0,0, circles=odia, add=TRUE, inches=FALSE, fg='lightgrey', lwd=2)
    symbols (0,0, circles=odia, add=TRUE, inches=FALSE, fg='white',     lwd=1)

    symbols (grid_x, grid_y, circles=rep(hole_rad,length(grid_y)), add=TRUE, inches=FALSE, fg='darkgrey',lwd=1.5)

    text(x = c(-lblpos, lblpos, 0, 0), y = c(0,0,-lblpos, lblpos), labels = lbls, cex = 1.5)

    if(!is.null(filename)){ dev.off() }

}