library(methods)
{{rimport}}('plot.r', '__init__.r')
options(stringsAsFactors = F)

infile   = {{i.infile | R}}
gfile    = {{i.groupfile | R}}
cfile    = {{i.casefile | R}}
outfile  = {{o.outfile | R}}
outdir   = {{o.outdir | R}}
pcut     = {{args.pval | R}}
dofdr    = {{args.fdr | R}}
plotchow = {{args.plot | R}}
devpars  = {{args.devpars | R}}
ggs      = {{args.ggs | R}}
inopts   = {{args.inopts | R}}
covfile  = {{args.cov | R}}
if (dofdr == T) dofdr = 'BH'

regress = function(regdata, name, fmula = NULL) {
	Y = bQuote(colnames(regdata)[ncol(regdata)])
	fmula = ifelse(is.null(fmula), paste(Y, "~ ."), fmula)
	m = lm(as.formula(fmula), data = regdata)
	list(model = m, ssr = sum(m$residuals ^ 2), n = nrow(regdata), name = name)
}

formlm = function(model, k, withname = T) {
	lencoef = length(model$model$coefficients)
	coefns  = c(names(model$model$coefficients)[(lencoef-k+2):lencoef], '_')
	coeffs  = as.numeric(c(model$model$coefficients[(lencoef-k+2):lencoef], model$model$coefficients[1]))
	coefns  = c(coefns, "N")
	coeffs  = c(coeffs, model$n)
	if (withname) {
		paste0(model$name, ': ', paste(coefns, round(coeffs, 3), sep = '=', collapse = ' '))
	} else {
		paste(coefns, round(coeffs, 3), sep = '=', collapse = ' ')
	}
}

chow = function(pooled, subregs, k, case) {
	subssr  = sum(sapply(subregs, function(x) x$ssr))
	ngroups = length(subregs)
	J  = (ngroups - 1) * k
	DF = pooled$n - ngroups * k
	FS = (pooled$ssr - subssr) * DF / subssr / J
	groups = lapply(subregs, function(m) formlm(m, k))
	pooledm = formlm(pooled, k, FALSE)
	list(Case = case, Pooled = pooledm, Groups = paste(groups, collapse = '; '), Fstat = FS, Pval = pf(FS, J, DF, lower.tail = FALSE))
}

model2eq = function(model) {
	vars = colnames(model$model)
	cf   = sapply(model$coefficients, function(f) {
		if (is.na(f)) return("NA")
		f = round(f, 2)
		if (f >= 0) return(paste0("+", f))
		return(paste0("-", -f))
	})
	paste0(vars[1], ' = ', cf[1], paste(
		sapply(
			2:length(cf),
			function(x) paste0(cf[x], '*', vars[x])
		), collapse = ''
	))
}

indata = read.table.inopts(infile, inopts)
#     X1  X2  X3  X4 ... Y
# G1  1   2   1   4  ... 9
# G2  2   3   1   1  ... 3
# ... ...
# Gm  3   9   1   7  ... 8
#K = ncol(indata)
if (covfile != "") {
	covdata = read.table(covfile, header = T, row.names = 1, check.names = F)
	indata  = cbind(covdata[rownames(indata),,drop = F], indata)
}
gdata  = read.table(gfile, header = F, row.names = NULL, check.names = F)
# G1	Group1	Case1
# G2	Group1	Case1
# ... ...
# Gs	Group2	Case1
# Gt	Group2	Case1
# Gt	Group1	Case2
# ... ...
# Gu	Group1	Case2
# ... ...
# Gz	Group2	Case2
if (ncol(gdata) == 2) { # no case
	cases = 'Case1'
}
fmulas = NULL
if (cfile != "") {
	fmulas = read.table(cfile, header = F, row.names = 1, sep = "\t", check.names = F)
	cases  = rownames(fmulas)
}

results = data.frame(
	Case   = character(),
	Pooled = character(),
	Groups = character(),
	Fstat  = double(),
	Pval   = double())
for (case in cases) {
	caserows  = if(ncol(gdata) > 2) gdata[which(gdata$Case == case),,drop = F] else gdata
	fmula     = fmulas[case,]
	allvars   = all.vars(as.formula(fmula))
	K         = ifelse(is.null(fmula), ncol(indata), length(allvars))
	pooled_lm = regress(indata[caserows[,1],,drop = F], name = 'Pooled', fmula = fmulas[case,])
	subgroups = levels(factor(caserows[,2]))
	subgrp_lm = lapply(subgroups, function(sgroup) {
		sdata = indata[caserows[which(caserows[,2] == sgroup),1],,drop = F]
		if (nrow(sdata) < 3) NULL
		else regress(sdata, name = sgroup, fmula = fmulas[case,])
	})
	subgrp_lm[sapply(subgrp_lm, is.null)] <- NULL
	# no subgroups
	if (length(subgrp_lm) < 2) next
	ret = chow(pooled_lm, subgrp_lm, k = K, case = case)
	if (is.na(ret$Pval) || ret$Pval >= pcut) next
	results = rbind(results, ret)

	# doplot
	if (plotchow) {
		incol = ncol(indata)
		plotdata = cbind(indata[caserows[,1],,drop = F], Group = caserows[,2])
		rcase = make.names(case)
		colnames(plotdata)[incol + 1] = rcase

		labels = sapply(c(subgrp_lm, list(pooled_lm)), function(m) paste0(m$name, ': ', model2eq(m$model), ' (N=', m$n, ')'))
		if (!is.null(ggs$scale_color_manual) && !is.null(ggs$scale_color_manual$labels)) {
			if (is.function(ggs$scale_color_manual$labels)) {
				labels = ggs$scale_color_manual$labels(labels)
			} else {
				labels = ggs$scale_color_manual$labels
			}
		}
		ggs1 = c(ggs, list(
			geom_smooth = list(
				aes(color = 'Pooled'),
				method   = 'lm',
				se       = F,
				linetype = "twodash"
			),
			geom_smooth = list(
				aes_string(color = rcase),
				method  = 'lm',
				se      = F
			),
			theme = list(
				legend.position = "bottom"
			),
			guides = list(
				color=guide_legend(ncol=1),
				shape=F
			),
			scale_color_manual = list(
				values = c(scales::hue_pal()(length(subgroups)), '#555555'),
				name   = "",
				limit  = c(subgroups, 'Pooled'),
				labels = labels
			)
		))
		plot.scatter(
			plotdata,
			file.path(outdir, paste0(case, '.png')),
			x      = which(allvars[2] == colnames(plotdata)),
			y      = which(allvars[1] == colnames(plotdata)),
			ggs    = ggs1,
			params = list(aes_string(shape = rcase, color = rcase))
		)
	}
}

if (dofdr != F) {
	results = cbind(results, Qval = p.adjust(results$Pval, method = dofdr))
}
write.table(pretty.numbers(results, list(
	Fstat      = '%.3f',
	Pval..Qval = '%.3E'
)), outfile, col.names = T, row.names = F, sep = "\t", quote = F)


#Provide examples of ggplot utilizing unemployment and poverty data

# clean workspace and environment
cat("\014")
rm(list=ls())

### Put in your own folder path here
workingdir<-#"Path_to_your_main_folder"
# for example for me it was workingdir<-"C:/Users/Documents/GitHub/Rcourse/"

#load in folder paths
source(paste0(workingdir, "workingdir.R"))

#load required packages
require(tidyverse)

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

#load in unemployment data
load(paste0(folder_processed_data, "/unemp_data.rda"))

#filter to just indiana
indiana <- unemp_data %>% filter(State_fips=="18")

#create just monroe cty df
monroecty<-indiana %>% filter(County_fips=="105")

#make plot highlighting monroe county in black. suppress key.
ggplot(data=indiana, aes(x=Year, y=Unemp_rate, colour=County_fips, group=County_fips)) +
  geom_line(size=0.3, alpha=0.5) +
  geom_line(data=monroecty, aes(x=Year, y=Unemp_rate, colour=County_fips, group=1),
    size=0.6, colour='black') +
  theme(legend.position="none", axis.text.x=element_text(angle=45)) +
  ylab('Indiana Unemployment Rate by County')

ggsave(file=paste0(folder_figures, "/indiana_unemp.png"), height = 5, width = 7)

#state aves

## TO DO

unemp_data <- unemp_data %>%
  mutate(state_abbr=substr(County_name, str_length(County_name)-1, str_length(County_name)))

unemp_data$state_abbr[unemp_data$State_fips=='11']<-"DC"

state_ave<-unemp_data %>% group_by(state_abbr, Year) %>% summarise(ave_unemp=mean(Unemp_rate))

ggplot(data=state_ave)+
  geom_line(aes(x=Year, y=ave_unemp, colour=state_abbr, group=state_abbr))

## Dispersion in State aves

disp<-state_ave %>% group_by(Year) %>%
  summarise(perc90m10=quantile(ave_unemp, c(0.9), na.rm = TRUE)-quantile(ave_unemp, c(0.1), na.rm = TRUE),
            stddev=sd(ave_unemp, na.rm = TRUE),maxmin=max(ave_unemp, na.rm = TRUE)-min(ave_unemp, na.rm=TRUE))

ggplot(data=disp)+
  geom_line(aes(x=Year, y=perc90m10, group=1))

ggplot(data=disp)+
  geom_line(aes(x=Year, y=stddev, group=1))

ggplot(data=disp)+
  geom_line(aes(x=Year, y=maxmin, group=1))

disp_long<-gather(disp, disp_measure, value, perc90m10:maxmin, factor_key = TRUE)

ggplot(data=disp_long)+
  geom_line(aes(x=Year, y=value, colour=disp_measure, group=disp_measure))


#' Round to multiple of any number.
#'
#' @param x numeric or date-time (POSIXct) vector to round
#' @param accuracy number to round to; for POSIXct objects, a number of seconds
#' @param f rounding function: \code{\link{floor}}, \code{\link{ceiling}} or
#'  \code{\link{round}}
#' @keywords manip
#' @export
#' @examples
#' round_any(135, 10)
#' round_any(135, 100)
#' round_any(135, 25)
#' round_any(135, 10, floor)
#' round_any(135, 100, floor)
#' round_any(135, 25, floor)
#' round_any(135, 10, ceiling)
#' round_any(135, 100, ceiling)
#' round_any(135, 25, ceiling)
#'
#' round_any(Sys.time() + 1:10, 5)
#' round_any(Sys.time() + 1:10, 5, floor)
#' round_any(Sys.time(), 3600)
round_any <- function(x, accuracy, f = round) {
  UseMethod("round_any")
}

#' @export
round_any.numeric <- function(x, accuracy, f = round) {
  f(x / accuracy) * accuracy
}

#' @export
round_any.POSIXct <- function(x, accuracy, f = round) {
  tz <- format(x[1], "%Z")
  xr <- round_any(as.numeric(x), accuracy, f)
  as.POSIXct(xr, origin="1970-01-01 00:00.00 UTC", tz=tz)
}


"
  Code to perform Regression and Classification modelling on Dublin Bikes
  usage data.
"
####################### Import packages set seed ###################################
library(tidyverse)
library(lubridate)
library(randomForest)
library(caret)
library(Metrics)
library(corrplot)
library(grid)
library(gridExtra)
library(gbm)
library(stringr)
library(lubridate)
library(pls)
library(leaps)
library(bst)
library(MASS)
library(dplyr)
library(fitdistrplus)
library(logspline)
library(e1071)
# set a seed so that we can reproduce results
set.seed(3482)

###################### Analyse top/bottom stations in each cluster ###################
clusters <- read_rds("db_clustered_stations.rds")
all <- read_rds("db_all_data.rds")
#%>%  filter(Date >= "2016-10-14" & Date <= "2017-10-31")

#old <- read_rds("db_all_data_old.rds")
#%>%  filter(Date >= "2016-10-14" & Date <= "2017-10-31")

#head(all)

#all<-rbind(old, all)
dim(all)

summary(all$Date)
df_backup<-df

all_clust <- df %>%
  left_join(clusters, by = "Number") %>%
  mutate(cluster = factor(cluster)) %>%
  select(-Name.y, Name = Name.x)

# Find the most active station per cluster
top_stations <- all_clust %>%
  mutate( activity = Check_in + Check_out) %>%
  group_by(Number, cluster) %>%
  summarise( tot_act = sum(activity)) %>%
  ungroup() %>%
  group_by(cluster) %>%
  top_n(1, tot_act) %>%
  ungroup() %>%
  arrange(activity)

# find the least active station per cluster
bot_stations <- all_clust %>%
  mutate( activity = Check_in + Check_out) %>%
  group_by(Number, cluster) %>%
  summarise( tot_act = sum(activity)) %>%
  ungroup() %>%
  group_by(cluster) %>%
  top_n(-1, tot_act) %>%
  ungroup()

# gets the station numbers for most active and least active into a list
selected <- rbind(top_stations, bot_stations) %>%
  pull(Number)

# Randomly select 3 stations in each cluster for the random forest modelling
for(clust_num in 1:4){
  n <- all_clust %>%
    filter(cluster == clust_num) %>%
    filter(!(Number %in% selected)) %>%
    group_by(Number, cluster) %>%
    summarise() %>%
    ungroup() %>%
    sample_n(3) %>%
    pull(Number)
  selected <- append(selected, n)
}
####################### Prepare the data for random forest #################################
# filter the full dataset based on the selection above
df <- all_clust %>%
  filter(Number %in% selected)

selected
# Group time into 48 factors and categorize the seasons
time_df2 <- df %>%
  mutate(
    t_hour = as.numeric(str_extract(Time, "^\\d{1,2}")),
    t_min = as.numeric(str_extract( str_extract(Time, ":\\d+:"), "\\d+")),
    Time = as.factor(if_else(
      t_min < 30,
      if_else(
        t_hour < 10,
        paste(paste("0", t_hour, sep = ""), "00", sep=":"),
        paste(t_hour, "00", sep=":")
      ),
      if_else(
        t_hour < 10,
        paste(paste("0", t_hour, sep = ""), "30", sep=":"),
        paste(t_hour, "30", sep=":")
      )
    )),
    #Name = as.factor(Name),
    season = as.factor(
              if_else(month(Date) == 11 |month(Date) == 12 | month(Date) == 1, "Winter",
                if_else(month(Date) == 2 |month(Date) == 3 | month(Date) == 4, "Spring",
                  if_else(month(Date) == 5 |month(Date) == 6 |month(Date) == 7, "Summer",
                    "Autumn")))
              ),
    av_bikes = Bike_stands - Available_stands
  ) %>%
  group_by(
    Number, Name, Address, Bike_stands, Date, season, Weekday, Time
  ) %>%
  summarise(
    av_bikes = round(mean(av_bikes)),
    cluster = first(cluster)
  ) %>%
  mutate(
    cluster = as.factor(cluster),
    prev_bike_num = lag(av_bikes), # number of bikes in previous time period
    prev_bike_num = if_else(is.na(prev_bike_num), av_bikes, prev_bike_num),
    prev_bike_num2 = lag(av_bikes, k=3), # number of bikes in previous time period
    prev_bike_num2 = if_else(is.na(prev_bike_num2), av_bikes, prev_bike_num2)
  ) %>%
  ungroup()

#Calculating the bike numbers from precious weeks
for(i in 1:nrow(time_df2)) {
  currDate <- time_df2[i,"Date"]
  currTime <- time_df2[i,"Time"]
  timeVal <- as.data.frame(currTime)[[1]]
  stationNumber <- time_df2[i,"Number"][[1]]
  prevWeekDate <- currDate - 7
  prevWeekDate2 <- currDate - 14
  prevWeekDate3 <- currDate - 21
  prevWeekDate4 <- currDate - 28
  rowsFromPrevWeek <- filter(time_df2, Number == stationNumber & Date==prevWeekDate[[1]] & Time %in% timeVal)
  rowsFromPrevWeek2 <- filter(time_df2, Number == stationNumber & Date==prevWeekDate2[[1]] & Time %in% timeVal)
  rowsFromPrevWeek3 <- filter(time_df2, Number == stationNumber & Date==prevWeekDate3[[1]] & Time %in% timeVal)
  rowsFromPrevWeek4 <- filter(time_df2, Number == stationNumber & Date==prevWeekDate4[[1]] & Time %in% timeVal)
  if(nrow(rowsFromPrevWeek) > 0) {
    avgAVBikes <- mean(rowsFromPrevWeek[,"av_bikes"][[1]], na.rm = T)
    time_df2[i,"prevWeek_bike_num"] <- avgAVBikes
  }
 # else {
 #   time_df2[i,"prevWeek_bike_num"] = lag(time_df2[i, "av_bikes"])
 # }
  if(nrow(rowsFromPrevWeek2) > 0) {
    avgAVBikes2 <- mean(rowsFromPrevWeek2[,"av_bikes"][[1]], na.rm = T)
    time_df2[i,"prevWeek_bike_num2"] <- avgAVBikes2
  }
 # else {
 #   time_df2[i,"prevWeek_bike_num2"] = lag(time_df2[i, "av_bikes"])
 # }
  if(nrow(rowsFromPrevWeek3) > 0) {
    avgAVBikes3 <- mean(rowsFromPrevWeek3[,"av_bikes"][[1]], na.rm = T)
    time_df2[i,"prevWeek_bike_num3"] <- avgAVBikes3
  }
 # else {
 #   time_df2[i,"prevWeek_bike_num3"] = lag(time_df2[i, "av_bikes"])
 # }
  if(nrow(rowsFromPrevWeek4) > 0) {
    avgAVBikes4 <- mean(rowsFromPrevWeek4[,"av_bikes"][[1]], na.rm = T)
    time_df2[i,"prevWeek_bike_num4"] <- avgAVBikes4
  }
 # else {
 #  time_df2[i,"prevWeek_bike_num4"] = lag(time_df2[i, "av_bikes"])
 # }
 # if(is.na(time_df2[i,"prevWeek_bike_num"])){
 #   time_df2[i,"prevWeek_bike_num"] = time_df2[i, "av_bikes"]
 # }
}

#Saving the data frame
write_rds(time_df2, "time_df2_withprevweeks.rds")

head(wInfo)
head(rf_df)

#rf_df <- rf_df %>% mutate(Hour=as.numeric(str_extract(rf_df$Time, "^\\d{1,2}")))
#df2<-NULL
#df2 <- merge(x=rf_df, y=wInfo, by=c("Date", "Hour"), all.x=TRUE)
#head(df2)

#df2<-df2%>%
#  mutate(
 #   av_perc= (av_bikes/Bike_stands)*100,
 #   av_ind = ifelse(av_perc<=10,'low','high')
#  )

# Create training and test samples
#n = floor(nrow(rf_df)/ 10)
#lb = 7*n +1
#ub = 10*n
#subset = lb:ub

# DF containing geographical info
geo <- read_csv("geo_data/db_geo.csv")

# Join the geographical info to the original dataset
time_df2 <- time_df2 %>%
  left_join(geo, by = "Number") %>%
  select(-Name.y, -Address.y, Name = Name.x, Address = Address.x)

#Reading the weather info from M2 weather buoy
wInfo <- read_csv("M2_weather.csv")

wInfo <- distinct(wInfo)

wInfo <- wInfo %>%
  # Convert POSIXct to date and split into each col
  mutate(
    last_update = parse_date_time(datetime, orders="mdy HM", tz = "UTC"),
    Year = year(last_update),
    Month = month(last_update),
    Day = day(last_update),
    Hour = as.numeric(hour(last_update)),
    #Min = minute(last_update),Sec = "00",
    DateNew = ymd(paste(Year, Month, Day, sep = "-"))
    #Time = paste(Hour, Min, Sec, sep = ":")
  )

#Imputing the missing values with mean
wInfo$AirTemperature[is.na(wInfo$AirTemperature)]=mean(wInfo$AirTemperature, na.rm = T)
wInfo$WindSpeed[is.na(wInfo$WindSpeed)]=mean(wInfo$WindSpeed, na.rm = T)

time_df2 <- read_rds("time_df2_withprevweeks.rds")
# Join the geographical info to the original dataset
rf_df2 <- time_df2 %>%
  left_join(geo, by = "Number")
#%>%select(-Name.y, -Address.y, Name = Name.x, Address = Address.x)

#df2 <- merge(x=rf_df2, y=wInfo, by=c("Date", "Hour"), all.x=TRUE)

rf_df2 <- rf_df2 %>% mutate(Hour=as.numeric(str_extract(Time, "^\\d{1,2}")),
                            DateNew=ymd(Date))

write.csv(wInfo, file = "wInfo.csv")
write.csv(rf_df2, file = "rf_df2.csv")

#Joining weather info with bike usage data
df2<-NULL
df2 <- merge(rf_df2, wInfo, all.x=T)

#Reading Holiday Data
holidays <- read_csv("holiday16-17.csv")

holidays <- holidays %>%
  mutate(

    #Date = parse_date_time(Date, orders="ymd"),
    #Year = year(Date),
    #Month = month(Date),
    #Day = day(Date),
    #Date = ymd(paste(Year, Month, Day, sep = "-"))
    Date=ymd(Date)
  )

#joining holiday data with the usage-weather data frame
df2 <- df2 %>%
  left_join(holidays, by=c("Date"))

write_csv(df2, "df2_exploration.csv")

#Creating a categorical column for holiday/observance indicator
df2 <- df2 %>%
  mutate(holiday=ifelse(df2$`Holiday_Name`!='NA', 'T', 'F'))

df2$holiday <- ifelse(is.na(df2$holiday), 'F', 'T')

write.csv(df2, file = "df2-test.csv")

#Creating new columns for available bikes percentage
df2<-df2%>%
  mutate(
    av_perc= (av_bikes/Bike_stands)*100,
    av_ind = ifelse(av_perc<=25,'low','high'),
    prevweeks_avg = ((prevWeek_bike_num + prevWeek_bike_num2 + prevWeek_bike_num3 + prevWeek_bike_num4)/4)
  )

df2$av_ind <- factor(df2$av_ind)

#n = floor(nrow(rf_df)/ 10)
#lb = 7*n +1
#ub = 10*n
#subset = lb:ub

write.csv(df2, file = "df2-with_prevweeks_avind.csv")

#df2$WindSpeed[is.na(df2$WindSpeed)]=0
#df2$AirTemperature[is.na(df2$AirTemperature)]=0

# Create training and test samples
n = floor(nrow(df2)/ 4)
set.seed(3482)
indexValues <- sample( nrow(df2),n, replace=T)

train <- df2[-indexValues,]
test <- df2[indexValues,]

#Checking for invalid data
test[test[,"av_bikes"]<0,]
which(train[,"av_bikes"]<0)
which(test[,"av_bikes"]<0)

#Removing invalid rows
train<-train[-c(63107,  63117, 74841),]

newcombined<-rbind(train, test)

which(train[,"season"]=="Summer")
which(test[,"season"]=="Summer")

#Removing row with Summer value to avoid zero variance
test<-test[-16551,]

dim(test)

write.csv(train, file = "train_df2-with_prevweeks_avind.csv")
write.csv(test, file = "test_df2-with_prevweeks_avind.csv")

train<-NULL
train<- read_csv("train_df2-with_prevweeks_avind.csv", col_types = cols(Time.x = col_character()))

test<-NULL
test<- read_csv("test_df2-with_prevweeks_avind.csv", col_types = cols(Time.x = col_character()))

#typeof(prevWeekDate[[1]])
#newDF <- time_df2[, time_df2$Date==prevWeekDate[[1]] & time_df2$Time == (currTime[1,1])]
#time_df2[,time_df2$Time %in% currTime]
#nrow(filter(time_df2, Date == "2016-09-12"))
#time_df2[, "prevWeek_bike_num"]

# Run random forest model and evaluate results
start.time <- Sys.time()
rf <- randomForest(av_bikes ~  Weekday + Time.x + prev_bike_num +
                     cluster + Latitude + Longitude + season + AirTemperature +WindSpeed,
                   data = train, importance = TRUE, ntree = 200, na.action=na.roughfix)
end.time <- Sys.time()
time.taken <- end.time - start.time
time.taken

rf
plot(rf)
importance(rf)
varImpPlot(rf)
write_rds(rf, "saved_data_frames/rf_model_with_weather.rds") # Save rf to avoid running it again

# Predict target data fram and evaluate error
test$pred <- predict(rf, test)
rmsle(test$pred, test$av_bikes)
rmse(test$pred, test$av_bikes)

rf <- read_rds("rf_model_with_weather.rds") # Import model
test$pred <- predict(rf, test)
rmsle(test$pred, test$av_bikes)
rmse(test$pred, test$av_bikes)
######################################## Plot results ############################
# Plot prediction to compare it against actual results
test$pred <- round(test$pred)

rf_err <- rmse(test$pred, test$av_bikes)
rf_err

time_breaks <- test %>%
  filter(str_detect(Time, "\\d{2}:00")) %>%
  group_by(Time) %>%
  summarise() %>%
  pull(Time)

####################################################################################
# Label for the error
err_label <- paste("Error margin:", round(rf_err, 2))

# plot means per stations
base_plot <- test %>%
  group_by(Number, Address, Time) %>%
  summarise(
    mean_av_bikes = mean(av_bikes),
    mean_pred = mean(pred),
    tot_stands = max(Bike_stands)
  ) %>%
  ggplot(aes(Time, mean_av_bikes, group = 1)) +
  theme_minimal() +
  geom_line(aes(y = tot_stands, colour = "Total stands"), linetype = 6) +
  geom_line(aes(colour = "Actual"), size = 1.1) +
  geom_line(aes(y = mean_pred, group = 1, colour = "Predicted"), size = 1.1) +
  geom_ribbon(aes(ymin = mean_pred - rf_err, ymax = mean_pred + rf_err), fill = "grey30", alpha = 0.2) +
  theme(axis.text.x = element_text(angle = 90, size = 7)) +
  scale_x_discrete(
    breaks = time_breaks,
    labels = time_breaks
  ) +
  ggtitle("Random forest prediction and actual number") +
  ylab("Mean available bikes") +
  scale_colour_manual(
    breaks = c("Predicted", "Actual", "Total"),
    values = c("Predicted"="red", "Actual"="blue", "Total stands"="black")
  ) +
  facet_wrap(~ Address) +
  theme(
    legend.box.background = element_rect(),
    legend.position = "bottom"
  )
base_plot

# Pull the station names as a factor level and create a label df for the annotation
ann_levels <- test %>% group_by(Address) %>% summarise() %>% pull(Address) %>% as.factor()
ann_text <- tibble(Time = "09:00", mean_av_bikes = 33,
                   Address = factor("Royal Hospital", levels = ann_levels))
test_set_mean_pred <- base_plot +
  geom_label(data = ann_text, label = err_label, size = 4)
test_set_mean_pred

ggsave("./plots/predictions/test_mean_prediction.png", test_set_mean_pred)

#Gradient Boosting from gbm pacakge
start2.time <- Sys.time()
boost=gbm(av_bikes ~  Weekday + Time.x + prev_bike_num2 +cluster + Latitude + Longitude + season + WindSpeed + AirTemperature,
          data = train,distribution = "gaussian",n.trees = 10000,
          shrinkage = 0.01, interaction.depth = 6)
boost
summary(boost)
end2.time <- Sys.time()
time2.taken <- end2.time - start2.time
time2.taken
write_rds(boost, "saved_data_frames/gbm_model_with_Weather.rds") # Save GB to avoid running it again
boost
plot(boost)

predict.gbm <- function (object, newdata, n.trees, type = "link", single.tree = FALSE, ...) {
  if (missing(n.trees)) {
    if (object$train.fraction < 1) {
      n.trees <- gbm.perf(object, method = "test", plot.it = FALSE)
    }
    else if (!is.null(object$cv.error)) {
      n.trees <- gbm.perf(object, method = "cv", plot.it = FALSE)
    }
    else {
      n.trees <- length(object$train.error)
    }
    cat(paste("Using", n.trees, "trees...\n"))
    gbm::predict.gbm(object, newdata, n.trees, type, single.tree, ...)
  }
}

test$predGB <- predict.gbm(boost, test)
rmsle(test$predGB, test$av_bikes)
rmse(test$predGB, test$av_bikes)

#Machine learning imlementaitons from caret package

#GBM
fitControl <- trainControl(method = "cv", number = 4)
start2.time <- Sys.time()
newgbm<-train(av_bikes ~  Weekday + Time.x + prev_bike_num +cluster + Latitude + Longitude + season + WindSpeed + AirTemperature + holiday,
              data = train, method = "gbm",
              trControl = fitControl,
              verbose = FALSE, na.action=na.omit)
newgbm
summary(newgbm)
end2.time <- Sys.time()
time2.taken <- end2.time - start2.time
time2.taken

start2.time <- Sys.time()
newgbm<-train(av_ind ~  Weekday + Time.x + cluster + Latitude + Longitude + season + WindSpeed + AirTemperature + Holiday,
              data = train, method = "gbm",
              trControl = fitControl,
              verbose = FALSE, na.action=na.omit)
newgbm
summary(newgbm)
end2.time <- Sys.time()
time2.taken <- end2.time - start2.time
time2.taken

#Predicting the values and calculating the RMSE/RMSLE
test$predGBMCaret <- predict(newgbm, newdata = test, type="raw",na.action =NULL)
rmsle(test$predGBMCaret, test$av_bikes)
rmse(test$predGBMCaret, test$av_bikes)
anyNA(test$predGBMCaret)

table(test$predGBMCaret, test$av_ind)

#Random Forest
fitControl <- trainControl(method = "cv", number = 2)
start2.time <- Sys.time()
newrf<-train(av_bikes ~  Weekday + Time.x + prev_bike_num +cluster + Latitude + Longitude + season + WindSpeed + AirTemperature, data = train, method = "rf",
             trControl = fitControl,
             verbose = FALSE, na.action=na.omit)
newrf
summary(newrf)
end2.time <- Sys.time()
time2.taken <- end2.time - start2.time
time2.taken

test$predRFCaret <- predict(newrf, newdata = test, type="raw",na.action =NULL)
rmsle(test$predRFCaret, test$av_bikes)
rmse(test$predRFCaret, test$av_bikes)

# GBM - experimental run with a different bike nuum predictor
fitControl <- trainControl(method = "cv", number = 5)
start2.time <- Sys.time()
newgbm<-train(av_bikes ~  Weekday + Time.x + prev_bike_num +cluster + Latitude + Longitude + season + WindSpeed + AirTemperature + holiday,
              data = train, method = "gbm",
              trControl = fitControl,
              verbose = FALSE, na.action=na.omit)
newgbm
summary(newgbm)
end2.time <- Sys.time()
time2.taken <- end2.time - start2.time
time2.taken

test$predGBMCaret <- predict(newgbm, newdata = test, type="raw",na.action =NULL)

test$predGBMCaret[test$predGBMCaret<0]=0

rmsle(test$predGBMCaret, test$av_bikes)
rmse(test$predGBMCaret, test$av_bikes)

#Elastic Net
library(elasticnet)
start2.time <- Sys.time()
enetModel<-train(av_bikes ~  Weekday + Time.x + prev_bike_num +cluster + Latitude + Longitude + season + WindSpeed + AirTemperature + holiday,
              data = train, method = "enet",
              trControl = fitControl,
              na.action=na.omit)
enetModel
summary(enetModel)
end2.time <- Sys.time()
time2.taken <- end2.time - start2.time
time2.taken

test$predENETCaret <- predict(enetModel, newdata = test, type="raw",na.action =NULL)

test$predENETCaret[test$predENETCaret<0]=0

rmsle(test$predENETCaret, test$av_bikes)
rmse(test$predENETCaret, test$av_bikes)

# Linear Regression with Stepwise Selection
start2.time <- Sys.time()
lnrStpModel<-train(av_bikes ~  Weekday + Time.x + prev_bike_num +cluster + Latitude + Longitude + season + WindSpeed + AirTemperature + holiday,
                data = train, method = "leapSeq",
                trControl = fitControl,
                verbose = FALSE, na.action=na.omit)
lnrStpModel
summary(lnrStpModel)
end2.time <- Sys.time()
time2.taken <- end2.time - start2.time
time2.taken

#lnrStpModel<-read_rds("models/lnrStpModel_with_weather_caret.rds")

test$predLNRSTPCaret <- predict(lnrStpModel, newdata = test, type="raw",na.action =NULL)
test$predLNRSTPCaret[test$predLNRSTPCaret<0]=0

rmsle(test$predLNRSTPCaret, test$av_bikes)
rmse(test$predLNRSTPCaret, test$av_bikes)

#Boosted Linear Regression
start2.time <- Sys.time()
bstLmModel<-train(av_bikes ~  Weekday + Time.x + prev_bike_num +cluster + Latitude + Longitude + season + WindSpeed + AirTemperature + holiday,
                   data = train, method = "BstLm",
                   trControl = fitControl,
                   na.action=na.omit)
bstLmModel
summary(bstLmModel)
end2.time <- Sys.time()
time2.taken <- end2.time - start2.time
time2.taken

bstLmModel<-read_rds()
test$predBstLmCaret <- predict(bstLmModel, newdata = test, type="raw",na.action =NULL)

test$predBstLmCaret[test$predBstLmCaret<0]=0

rmsle(test$predBstLmCaret, test$av_bikes)
rmse(test$predBstLmCaret, test$av_bikes)

#KNN
library(kknn)
start2.time <- Sys.time()
knnRegModel<-train(av_bikes ~  Weekday + Time + prev_bike_num +cluster + Latitude + Longitude + season + WindSpeed + AirTemperature + holiday,
                  data = train, method = "kknn",
                  trControl = fitControl,
                  na.action=na.omit)
knnRegModel
summary(knnRegModel)
end2.time <- Sys.time()
time2.taken <- end2.time - start2.time
time2.taken

test$predknnRegCaret <- predict(knnRegModel, newdata = test, type="raw",na.action =na.pass)

test$predknnRegCaret[test$predknnRegCaret<0]=0

rmsle(test$predknnRegCaret, test$av_bikes)
rmse(test$predknnRegCaret, test$av_bikes)

any(is.na(test$predGBMCaret))
which(is.nan(log(test$predGBMCaret+1)))

#SVM - Linear
start2.time <- Sys.time()

ctrl <- trainControl(method = "cv",
                     summaryFunction = twoClassSummary,
                     classProbs = TRUE)

svmL<-train(av_ind ~  Weekday + Time.x + prevWeek_bike_num + prevWeek_bike_num2 + prevWeek_bike_num3 + prevWeek_bike_num4 + cluster + Latitude + Longitude + season + WindSpeed + AirTemperature,
              data = train, method = "svmLinear",
              metric = "ROC",
              verbose = FALSE,
              trControl = ctrl,
              scale=FALSE,
              na.action=na.omit)
svmL
summary(svmL)
end2.time <- Sys.time()
time2.taken <- end2.time - start2.time
time2.taken
write_rds(newgbm2, "svmLmodel_with_weather_caret.rds") # Save rf to avoid running it again

#SVM - Radial
start2.time <- Sys.time()

ctrl <- trainControl(method = "cv",
                     summaryFunction = twoClassSummary,
                     classProbs = TRUE)

svmR<-train(av_ind ~  Weekday + Time.x + prevWeek_bike_num + prevWeek_bike_num2 + prevWeek_bike_num3 + prevWeek_bike_num4 + cluster + Latitude + Longitude + season + WindSpeed + AirTemperature,
               data = train, method = "svmRadial",
               metric = "ROC",
               verbose = FALSE,
               trControl = ctrl,
               scale=FALSE,
               na.action=na.omit)
svmR
summary(svmR)
end2.time <- Sys.time()
time2.taken <- end2.time - start2.time
time2.taken

write_rds(svmR, "svmRmodel_with_weather_caret.rds") # Save rf to avoid running it again

# GBM- Classification
#start2.time <- Sys.time()
#newgbm3<-train(av_bikes ~  Weekday + Time.x + prevWeek_bike_num + prevWeek_bike_num2 + prevWeek_bike_num3 + prevWeek_bike_num4
#               + cluster + Latitude + Longitude + season + WindSpeed + AirTemperature + holiday,
 #              data = train, method = "gbm",
 #              trControl = fitControl,
 #              verbose = FALSE, na.action=na.omit)
#newgbm3
#summary(newgbm3)
#end2.time <- Sys.time()
#time2.taken <- end2.time - start2.time
#time2.taken
#test$predGBMCaret3 <- predict(newgbm3, newdata = test, type="raw",na.action =NULL)
#rmsle(test$predGBMCaret3, test$av_bikes)
#rmse(test$predGBMCaret3, test$av_bikes)

#sqrt(1/length(test$av_bikes)*sum((log(test$predGBMCaret3 +1)-log(test$av_bikes +1))^2))

#test$predGBMCaret <- predict(newgbm3, newdata = test, type="raw", na.action = na.pass)
#rmsle(test$predGBMCaret, test$av_bikes)
#rmse(test$predGBMCaret, test$av_bikes)
#any(is.na(test$predGBMCaret))
#which(is.nan(log(test$predGBMCaret+1)))

#predGBMCaret <- predict(newgbm3, newdata = test, type="raw", na.action = na.pass)
#length(predGBMCaret)
#length(test$av_bikes)
#rmsle(predGBMCaret, test$av_bikes)
#rmse(predGBMCaret, test$av_bikes)
#any(is.na(predGBMCaret))
#which(is.nan(log(predGBMCaret+1)))

#test$predGBMCaret2 <- predict(newgbm2, newdata = test, type="prob",na.action =NULL)
#pred <- factor(ifelse(test$predGBMCaret2[,'low'] > .6, "low", "high"))

#length(pred)
#length(test$av_ind)

#confusionMatrix(test$av_ind, pred)
#table(test$predGBMCaret2, test$av_ind)
#anyNA(test$predGBMCaret)

## Classification Models

# CLeaning the missing values from previous bike number columns
library(DataCombine)

train2 <- DropNA(train, Var = c("prevWeek_bike_num","prevWeek_bike_num2","prevWeek_bike_num3","prevWeek_bike_num4"))
test2 <- DropNA(test, Var = c("prevWeek_bike_num","prevWeek_bike_num2","prevWeek_bike_num3","prevWeek_bike_num4"))

filter(train2, av_ind=='low')

test2=test2 %>% mutate_if(is.character, as.factor)
train2=train2 %>% mutate_if(is.character, as.factor)
train2$av_ind<-factor(train2$av_ind)
test2$av_ind<-factor(test2$av_ind)

nearZeroVar(train2, saveMetrics = TRUE)

#SVM- Linear
start2.time <- Sys.time()
trctrl <- trainControl(method = "repeatedcv", number = 10, repeats = 3)

svmModel<-train(av_ind ~  Weekday + Time.x + prevWeek_bike_num + prevWeek_bike_num2 + prevWeek_bike_num3 + prevWeek_bike_num4 + cluster + Latitude + Longitude + season,
                     data = train, method = "svmLinear",
                     trControl=trctrl,
                     preProcess = c("center", "scale"),
                     tuneLength = 10,
                     na.action=na.omit)
svmModel
summary(svmModel)
end2.time <- Sys.time()
time2.taken <- end2.time - start2.time
time2.taken

test$predSVM <- predict(svmModel, newdata = test, type="prob",na.action =NULL)
pred <- factor(ifelse(test$predSVM[,'low'] > .5, "low", "high"))
confusionMatrix(test$av_ind, pred)

# User defined function for calculating f1 score
f1_score <- function(predicted, expected, positive.class="high") {
  predicted <- factor(as.character(predicted), levels=unique(as.character(expected)))
  expected  <- as.factor(expected)
  cm = as.matrix(table(expected, predicted))

  precision <- diag(cm) / colSums(cm)
  recall <- diag(cm) / rowSums(cm)
  f1 <-  ifelse(precision + recall == 0, 0, 2 * precision * recall / (precision + recall))

  #Assuming that F1 is zero when it's not possible compute it
  f1[is.na(f1)] <- 0

  #Binary F1 or Multi-class macro-averaged F1
  ifelse(nlevels(expected) == 2, f1[positive.class], mean(f1))
}

#User defined function for calculating MCC score
mcc <- function (actual, predicted, positive="high", negative="low")
{
  # Compute the Matthews correlation coefficient (MCC) score
  # Jeff Hebert 9/1/2016
  # Geoffrey Anderson 10/14/2016
  # Added zero denominator handling.
  # Avoided overflow error on large-ish products in denominator.
  #
  # actual = vector of true outcomes, 1 = Positive, 0 = Negative
  # predicted = vector of predicted outcomes, 1 = Positive, 0 = Negative
  # function returns MCC

  TP <- sum(actual == positive & predicted == positive)
  TN <- sum(actual == negative & predicted == negative)
  FP <- sum(actual == negative & predicted == positive)
  FN <- sum(actual == positive & predicted == negative)
  #TP;TN;FP;FN # for debugging
  sum1 <- TP+FP; sum2 <-TP+FN ; sum3 <-TN+FP ; sum4 <- TN+FN;
  denom <- as.double(sum1)*sum2*sum3*sum4 # as.double to avoid overflow error on large products
  if (any(sum1==0, sum2==0, sum3==0, sum4==0)) {
    denom <- 1
  }
  mcc <- ((TP*TN)-(FP*FN)) / sqrt(denom)
  return(mcc)
}

#KNN
library(kknn)
fitControl <- trainControl(method = "cv", number = 5)

start2.time <- Sys.time()
knnModel<-train(av_ind ~  Weekday + Time.x + prevWeek_bike_num + prevWeek_bike_num2 + prevWeek_bike_num3 + prevWeek_bike_num4 +cluster + Latitude + Longitude + season + holiday,
              data = train2, method = "kknn",
              trControl = fitControl,
              verbose = FALSE, na.action=na.omit)
knnModel
summary(knnModel)
end2.time <- Sys.time()
time2.taken <- end2.time - start2.time
time2.taken
test2$knnModel <- predict(knnModel, newdata = test2, type="raw",na.action = na.pass)
#predknnModel <- factor(ifelse(test$knnModel[,'low'] > .5, "low", "high"))
confusionMatrix(test2$av_ind, test2$knnModel)

mcc(test2$av_ind, test2$knnModel)

train2[train2[,'season']=='Summer',]

#LDA
start2.time <- Sys.time()
ldaModel<-train(av_ind ~  Weekday + Time.x + prevWeek_bike_num + prevWeek_bike_num2 + prevWeek_bike_num3 + prevWeek_bike_num4 +cluster + Latitude + Longitude + season + holiday,
                data = train2, method = "lda",
                trControl = fitControl,
                verbose = TRUE, na.action=na.omit)
ldaModel
summary(ldaModel)
end2.time <- Sys.time()
time2.taken <- end2.time - start2.time
time2.taken
test2$ldaModel <- predict(ldaModel, newdata = test2, type="raw",na.action = na.pass)
#predldaModel <- factor(ifelse(test2$ldaModel[,'low'] > .4, "low", "high"))
confusionMatrix(test2$av_ind, test2$ldaModel)
mcc(test2$av_ind, test2$ldaModel)

#QDA
start2.time <- Sys.time()
qdaModel<-train(av_ind ~  Weekday + Time.x + prevWeek_bike_num + prevWeek_bike_num2 + prevWeek_bike_num3 + prevWeek_bike_num4 +cluster + Latitude + Longitude + season + holiday,
                data = train2, method = "qda",
                trControl = fitControl,
                verbose = T, na.action=na.pass)
qdaModel
summary(qdaModel)
end2.time <- Sys.time()
time2.taken <- end2.time - start2.time
time2.taken
test2$qdaModel <- predict(qdaModel, newdata = test2, type="raw",na.action = na.pass)
#predqdaModel <- factor(ifelse(test2$qdaModel[,'low'] > .5, "low", "high"))

confusionMatrix(test2$av_ind, test2$qdaModel)
mcc(test2$av_ind, test2$qdaModel)

#Logistic Regression
start2.time <- Sys.time()
ctrl <- trainControl(method = "cv",
                     summaryFunction = twoClassSummary,
                     classProbs = TRUE)

#logisticModel<-train(av_ind ~  Weekday + Time.x + prevWeek_bike_num + prevWeek_bike_num2 + prevWeek_bike_num3 + prevWeek_bike_num4 + cluster + Latitude + Longitude + season + WindSpeed + AirTemperature,
logisticModel<-train(av_ind ~  Weekday + Time.x + prevWeek_bike_num + prevWeek_bike_num2 + prevWeek_bike_num3 + prevWeek_bike_num4 + cluster + Latitude + Longitude + season + holiday,
                     data = train2, method="glm", family="binomial",
                     na.action=na.omit)
logisticModel
summary(logisticModel)
end2.time <- Sys.time()
time2.taken <- end2.time - start2.time
time2.taken

test2$predLogistic <- predict(logisticModel, newdata = test2, type="raw",na.action = na.pass)
#predlogistic <- factor(ifelse(test$predLogistic[,'low'] > .5, "low", "high"))
confusionMatrix(test2$av_ind, test2$predLogistic )

mcc(test2$av_ind, test2$predLogistic)

#GBM - Classification
fitControl <- trainControl(method = "cv", number = 5)
start2.time <- Sys.time()
gbmCategorical<-train(av_ind ~  Weekday + Time.x + prevWeek_bike_num + prevWeek_bike_num2 + prevWeek_bike_num3 + prevWeek_bike_num4 +cluster + Latitude + Longitude + season + holiday,
                      data = train2, method = "gbm",
                      trControl = fitControl,
                      verbose = FALSE, na.action=na.omit)
gbmCategorical
summary(gbmCategorical)
end2.time <- Sys.time()
time2.taken <- end2.time - start2.time
time2.taken
test2$gbmCategorical <- predict(gbmCategorical, newdata = test2, type="raw",na.action = na.pass)
#predgbmCat <- factor(ifelse(test$gbmCategorical[,'low'] > .5, "low", "high"))
confusionMatrix(test2$av_ind, test2$gbmCategorical)
mcc(test2$av_ind, test2$gbmCategorical)

#Random Frest - Classification
start2.time <- Sys.time()
rfCategorical<-train(av_ind ~  Weekday + Time.x + prevWeek_bike_num + prevWeek_bike_num2 + prevWeek_bike_num3 + prevWeek_bike_num4 +cluster + Latitude + Longitude + season + holiday,
                      data = train2, method = "rf",
                      trControl = fitControl,
                      verbose = FALSE, na.action=na.omit)
rfCategorical
summary(rfCategorical)
end2.time <- Sys.time()
time2.taken <- end2.time - start2.time
time2.taken
test2$rfCategorical <- predict(rfCategorical, newdata = test2, type="raw",na.action = na.pass)
#predgbmCat <- factor(ifelse(test$gbmCategorical[,'low'] > .5, "low", "high"))
confusionMatrix(test2$av_ind, test2$rfCategorical)
mcc(test2$av_ind, test2$rfCategorical)

test$predGBRound <- round(test$predLNRSTPCaret)
gb_err <- rmse(test$predGBRound, test$av_bikes)
gb_err

time_breaks <- test %>%
  dplyr::filter(str_detect(Time.x, "\\d{2}:00")) %>%
  group_by(Time.x) %>%
  summarise() %>%
  pull(Time.x)

####################################################################################
# Label for the error
err_label <- paste("Error margin:", round(gb_err, 2))

# plot means per stations
base_plotgb <- test %>%
  group_by(Number, Address.x, Time.x) %>%
  summarise(
    mean_av_bikes = mean(av_bikes),
    mean_predgb = mean(predGBRound),
    tot_stands = max(Bike_stands)
  ) %>%
  ggplot(aes(Time.x, mean_av_bikes, group = 1)) +
  theme_minimal() +
  geom_line(aes(y = tot_stands, colour = "Total stands"), linetype = 6) +
  geom_line(aes(colour = "Actual"), size = 1.1) +
  geom_line(aes(y = mean_predgb, group = 1, colour = "Predicted"), size = 1.1) +
  geom_ribbon(aes(ymin = mean_predgb - gb_err, ymax = mean_predgb + gb_err), fill = "grey30", alpha = 0.2) +
  theme(axis.text.x = element_text(angle = 90, size = 7)) +
  scale_x_discrete(
    breaks = time_breaks,
    labels = time_breaks
  ) +
  ggtitle("Linear Regression with Stepwise Selection  - Predicted vs Actual number") +
  ylab("Mean available bikes") +
  scale_colour_manual(
    breaks = c("Predicted", "Actual", "Total"),
    values = c("Predicted"="red", "Actual"="blue", "Total stands"="black")
  ) +
  facet_wrap(~ Address.x) +
  theme(
    legend.box.background = element_rect(),
    legend.position = "bottom"
  )
base_plotgb

# Pull the station names as a factor level and create a label df for the annotation
ann_levels <- test %>% group_by(Address.x) %>% summarise() %>% pull(Address.x) %>% as.factor()
ann_text <- tibble(Time.x = "09:00", mean_av_bikes = 37,
                   Address.x = "Merrion Square West"  ) #factor("Merrion Square West", levels = ann_levels))
test_set_mean_predgb <- base_plotgb +
  geom_label(data = ann_text, label = err_label, size = 4)
test_set_mean_predgb

##### EXPERIMENTAL MODELS ###############
#Gradient Boosting
start2.time <- Sys.time()
boost=gbm(av_bikes ~  Weekday + Time + prevWeek_bike_num +cluster + Latitude + Longitude + season,
          data = train,distribution = "gaussian",n.trees = 10000,
          shrinkage = 0.01, interaction.depth = 6)
boost
summary(boost)
end2.time <- Sys.time()
time2.taken <- end2.time - start2.time
time2.taken
write_rds(boost, "saved_data_frames/gbm_model-prev_week.rds") # Save GB to avoid running it again
boost

#Gradient Boosting
start2.time <- Sys.time()
boost2=gbm(av_bikes ~  Weekday + Time + prev_bike_num + prevWeek_bike_num +cluster + Latitude + Longitude + season,
          data = train,distribution = "gaussian",n.trees = 10000,
          shrinkage = 0.01, interaction.depth = 6)
boost2
summary(boost2)
end2.time <- Sys.time()
time2.taken <- end2.time - start2.time
print("Boost2")
time2.taken
write_rds(boost2, "C:/MSc Materials/Dissertation/dublin_bikes-master//saved_data_frames/gbm_model-prev_week and prev_bikes.rds") # Save GB to avoid running it again
boost2

predict.gbm <- function (object, newdata, n.trees, type = "link", single.tree = FALSE, ...) {
  if (missing(n.trees)) {
    if (object$train.fraction < 1) {
      n.trees <- gbm.perf(object, method = "test", plot.it = FALSE)
    }
    else if (!is.null(object$cv.error)) {
      n.trees <- gbm.perf(object, method = "cv", plot.it = FALSE)
    }
    else {
      n.trees <- length(object$train.error)
    }
    cat(paste("Using", n.trees, "trees...\n"))
    gbm::predict.gbm(object, newdata, n.trees, type, single.tree, ...)
  }
}

test$predGB <- predict.gbm(boost, test)
rmsle(test$predGB, test$av_bikes)
rmse(test$predGB, test$av_bikes)

table(test2$av_ind)
#######################END ###################################################

############################ Python Data - Plots #############################################

#Reading the output data from python LSTM model
from_python<-read_csv('regOutput-python.csv', col_types = cols('5' = col_character()))

from_python<-from_python %>%
  rename('Number'='0', 'Bike_stands'='1', 'Time'='5', 'av_bikes'='6', 'python_pred'='328')

from_python$predGBRound <- round(from_python$python_pred)
from_python<-from_python %>%
  left_join(geo, by = "Number")

gb_err <- rmse(from_python$predGBRound, from_python$av_bikes)

#Cleaning the Time column values
for(i in  1:nrow(from_python)) {

  if(nchar(from_python[i,"Time"][[1]]) < 5) {
    from_python[i,"Time"] = paste0("0", from_python[i,"Time"])
  }
}

typeof(from_python$Time)

time_breaks2 <- from_python %>%
  filter(str_detect(Time, "\\d{2}:00")) %>%
  group_by(Time) %>%
  summarise() %>%
  pull(Time)

# Label for the error
err_label <- paste("Error margin:", round(gb_err, 2))

# plot means per stations
base_plotgb <- from_python %>%
  group_by(Number, Address, Time) %>%
  summarise(
    mean_av_bikes = mean(av_bikes),
    mean_predgb = mean(predGBRound, na.rm = T),
    tot_stands = max(Bike_stands)

  ) %>%
  ggplot(aes(Time, mean_av_bikes, group = 1)) +
  theme_minimal() +
  geom_line(aes(y = tot_stands, colour = "Total stands"), linetype = 6) +
  geom_line(aes(colour = "Actual"), size = 1.1) +
  geom_line(aes(y = mean_predgb, group = 1, colour = "Predicted"), size = 1.1) +
  geom_ribbon(aes(ymin = mean_predgb - gb_err, ymax = mean_predgb + gb_err), fill = "grey30", alpha = 0.2) +
  theme(axis.text.x = element_text(angle = 90, size = 7)) +
  scale_x_discrete(
    breaks = time_breaks2,
    labels = time_breaks2
  ) +
  ggtitle("LSTM - Prediction and Actual number") +
  ylab("Mean available bikes") +
  scale_colour_manual(
    breaks = c("Predicted", "Actual", "Total"),
    values = c("Predicted"="red", "Actual"="blue", "Total stands"="black")
  ) +
  facet_wrap(~ Address) +
  theme(
    legend.box.background = element_rect(),
    legend.position = "bottom"
  )
base_plotgb

# Pull the station names as a factor level and create a label df for the annotation
ann_levels <- from_python %>% group_by(Address) %>% summarise() %>% pull(Address) %>% as.factor()
ann_text <- tibble(Time = "09:00", mean_av_bikes = 33,
                   Address = factor("Merrion Square West", levels = ann_levels))
test_set_mean_predgb <- base_plotgb +
  geom_label(data = ann_text, label = err_label, size = 4)
test_set_mean_predgb

#######################################FITTING DISTRIBUTION FUNCTIONS ########################################

# Funtion to estimate the alpha-beta parameters of a beta distribution
estBetaParams <- function(mu, var) {
  alpha <- ((1 - mu) / var - 1 / mu) * mu ^ 2
  beta <- alpha * (1 / mu - 1)
  return(params = list(alpha = alpha, beta = beta))
}

#Checking for probability distributions in bike numbers at particular stations

# Group time into 48 factors
dist_data <- all_clust %>%
  mutate(
    t_hour = as.numeric(str_extract(Time, "^\\d{1,2}")),
    t_min = as.numeric(str_extract( str_extract(Time, ":\\d+:"), "\\d+")),
    Time = as.factor(if_else(
      t_min < 30,
      if_else(
        t_hour < 10,
        paste(paste("0", t_hour, sep = ""), "00", sep=":"),
        paste(t_hour, "00", sep=":")
      ),
      if_else(
        t_hour < 10,
        paste(paste("0", t_hour, sep = ""), "30", sep=":"),
        paste(t_hour, "30", sep=":")
      )
    )),
    #Name = as.factor(Name),
    season = as.factor(
      if_else(month(Date) == 11 |month(Date) == 12 | month(Date) == 1, "Winter",
              if_else(month(Date) == 2 |month(Date) == 3 | month(Date) == 4, "Spring",
                      if_else(month(Date) == 5 |month(Date) == 6 |month(Date) == 7, "Summer",
                              "Autumn")))
    ),
    av_bikes = Bike_stands - Available_stands
  ) %>%
  group_by(
    Number, Name.x, Address, Bike_stands, Date, season, Weekday, Time
  ) %>%
  summarise(
    av_bikes = round(mean(av_bikes)),
    cluster = first(cluster)
  ) %>%
  mutate(
    cluster = as.factor(cluster),
    prev_bike_num = lag(av_bikes), # number of bikes in previous time period
    prev_bike_num = if_else(is.na(prev_bike_num), av_bikes, prev_bike_num),
    prev_bike_num2 = lag(av_bikes, k=3), # number of bikes in previous time period
    prev_bike_num2 = if_else(is.na(prev_bike_num2), av_bikes, prev_bike_num2)
  ) %>%
  ungroup()

dim(dist_data)

# Cullen Frey graphs for stations during three timepoints
for(i in c(5,34,19,28,38,15,96,82,30,80)) {

  for(j in c('09:00', '13:00', '17:00')) {
    values<-dist_data[dist_data[,'Number']==i & dist_data[,'Time']==j & dist_data[,'Weekday']=='Sat','av_bikes']
    bike_standsnum<-max(dist_data[dist_data[,'Number']==i,'Bike_stands'])
    values<-values[[1]]
    #descdist((values), boot=50)
    normalized = (values+ 0.001)/(bike_standsnum+ 0.002)

    cat('Station: ', i)
    cat(' Time: ', j , '  ')

    betaparams<-estBetaParams(mean(normalized), var(normalized))
    print(((1/(1+betaparams$beta/betaparams$alpha))*bike_standsnum))
    print(var(normalized)*bike_standsnum)
    plot(values)
    abline(h=((1/(1+betaparams$beta/betaparams$alpha))*bike_standsnum))
  }
}

#HUESTON CENTRAL - Monday
#----------------

# 9:00 - > 0.11
# 13:00 -> 0.07
# 17:00 -> 0.6

#CHARLEMONT - Monday
#----------------

# 9:00 - > 0.19
# 13:00 -> 0.24
# 17:00 -> 0.5

#Kolmogorov-Smirnov Test
ks.test(hueston, rnorm(1000))
typeof(hueston)

#Shapiro-Wilk Test for Normality
shapiro.test(hueston)

skewness(hueston)
hist(hueston)
hist(log(hueston))
estBetaParams(mean(hueston), var(hueston))
descdist(normalized)
fit.beta <- fitdist((normalized), "beta")

################################### NOT INCLUDED IN THE REPORT ##########################################

library('forecast')
library('tseries')
library(zoo)
library(forecast)
library(chron)
library(plyr)
library(caret)
library(foreach)
library(doMC)
library(parallel)
library(dplyr)
library(ggplot2)

#Running ARIMA for only one station

bensonSt <- rf_df2[rf_df2[,"Number"]==90 & rf_df2[,"Date"] != "2016-09-12" ,]

nrow(bensonSt)
nrow(bensonSt[bensonSt[,"Date"]=="2016-09-12",])

btrain=bensonSt[bensonSt$Date<="2017-07-30",]
btest=bensonSt[bensonSt$Date>"2017-07-30",]

constant_columns <- apply(bensonSt, 2, is.constant)
if (any(constant_columns)) { # Remove first one
  print(constant_columns[2])
  #xregg <- xregg[, -which(constant_columns)[1]]
}

trainC=ts(btrain,frequency = 48)

btest2 = btest[,-c(1:5,9:10,13:14)]
testC=ts(btest2,frequency = 48)

arimaCols <- c("Weekday" , "Time" ,"prev_bike_num" , "prevWeek_bike_num", "season")

#arimaModA=suppressWarnings(auto.arima(trainC[,"av_bikes"],xreg=trainC[,arimaCols],stepwise=F, approximation=T))

arimaModA=(auto.arima(trainC[,"av_bikes"],xreg=trainC[,arimaCols],seasonal=FALSE, stepwise=F, approximation=T))
arimaModf=forecast(arimaModA, xreg=testC)
library(readr)
write_rds(arimaModA, "C:/MSc Materials/Dissertation/dublin_bikes-master/saved_data_frames/arima-bensonst.rds")

btestMerged <- merge(btest, arimaModf$mean, by="row.names")

base_plotgbArima <- btestMerged %>%
  group_by(Number, Address, Time) %>%
  summarise(
    mean_av_bikes = mean(av_bikes),
    mean_predarima = mean(x),
    tot_stands = max(Bike_stands)
  ) %>%
  ggplot(aes(Time, mean_av_bikes, group = 1)) +
  theme_minimal() +
  geom_line(aes(y = tot_stands, colour = "Total stands"), linetype = 6) +
  geom_line(aes(colour = "Actual"), size = 1.1) +
  geom_line(aes(y = mean_predarima, group = 1, colour = "Predicted"), size = 1.1)

wtSt <- rf_df2[rf_df2[,"Number"]==56 & rf_df2[,"Date"] != "2016-09-12" ,]

nrow(wtSt)
nrow(wtSt[wtSt[,"Date"]=="2016-09-12",])

wtrain=wtSt[wtSt$Date<="2017-07-30",]
wtest=wtSt[wtSt$Date>"2017-07-30",]

wconstant_columns <- apply(wtSt, 2, is.constant)
if (any(wconstant_columns)) {
  print(constant_columns[2])
  #xregg <- xregg[, -which(constant_columns)[1]]
}

wtrainC=ts(wtrain,frequency = 48)

wtest2 = wtest[,-c(1:5,9:10,13:14)]
wtestC=ts(wtest2,frequency = 48)

arimaCols <- c("Weekday" , "Time" ,"prev_bike_num" , "prevWeek_bike_num", "season")

#arimaModA=suppressWarnings(auto.arima(trainC[,"av_bikes"],xreg=trainC[,arimaCols],stepwise=F, approximation=T))

warimaModA=(auto.arima(wtrainC[,"av_bikes"],xreg=wtrainC[,arimaCols],seasonal=FALSE, stepwise=F, approximation=T))
warimaModf=forecast(warimaModA, xreg=wtestC)
library(readr)
write_rds(warimaModA, "C:/MSc Materials/Dissertation/dublin_bikes-master/saved_data_frames/arima-mountst.rds")

wtestMerged <- merge(wtest, warimaModf$mean, by="row.names")

base_plotgbArimamst <- wtestMerged %>%
  group_by(Number, Address, Time) %>%
  summarise(
    mean_av_bikes = mean(av_bikes),
    mean_predarima = mean(x),
    tot_stands = max(Bike_stands)
  ) %>%
  ggplot(aes(Time, mean_av_bikes, group = 1)) +
  theme_minimal() +
  geom_line(aes(y = tot_stands, colour = "Total stands"), linetype = 6) +
  geom_line(aes(colour = "Actual"), size = 1.1) +
  geom_line(aes(y = mean_predarima, group = 1, colour = "Predicted"), size = 1.1)

count_ts = ts(test[, c('av_bikes')])

test$clean_cnt = tsclean(count_ts)

test2 <- arrange(test, Date, Time)

fit2arima <- auto.arima(test2$av_bikes, seasonal=FALSE)

fcast <- forecast(fit2arima, h=30)
plot(fcast)

acf(ts(diff(log10(test2$av_bikes))),main='')
pacf(ts(diff(log10(test2))),main='')

head(df2)

##################### PARETO DISTRIBUTION ##################
library(PtProcess)
library(actuar)
fit.pareto <- fitdist(normalized, "pareto", start=list(shape=2, scale=600))

plot(fit.pareto)

# distribution, cdf, quantile and random functions for Pareto distributions
dpareto <- function(x, xm, alpha) ifelse(x > xm , alpha*xm**alpha/(x**(alpha+1)), 0)
ppareto <- function(q, xm, alpha) ifelse(q > xm , 1 - (xm/q)**alpha, 0 )
qpareto <- function(p, xm, alpha) ifelse(p < 0 | p > 1, NaN, xm*(1-p)**(-1/alpha))
rpareto <- function(n, xm, alpha) qpareto(runif(n), xm, alpha)

pareto.mle <- function(x)
{
  xm <- min(x)
  alpha <- length(x)/(sum(log(x))-length(x)*log(xm))
  return( list(xm = xm, alpha = alpha))
}

pareto.test <- function(x, B = 1e3)
{
  a <- pareto.mle(x)

  # KS statistic
  D <- ks.test(x, function(q) ppareto(q, a$xm, a$alpha))$statistic

  # estimating p value with parametric bootstrap
  B <- 1e5
  n <- length(x)
  emp.D <- numeric(B)
  for(b in 1:B)
  {
    xx <- rpareto(n, a$xm, a$alpha);
    aa <- pareto.mle(xx)
    emp.D[b] <- ks.test(xx, function(q) ppareto(q, aa$xm, aa$alpha))$statistic
  }

  return(list(xm = a$xm, alpha = a$alpha, D = D, p = sum(emp.D > D)/B))
}

pareto.test(hueston)


#  James Rekow

identifySubgroupsVer2 = function(abdList, rollRange = 0.025){

  #  ARGS: rollRange - the maximum difference in overlap between two DOC points for which the two points
  #                    are still considered close enough that they are included in each others local
  #                    dissimilarity profiles (e.g. in computing rolling mean, etc.)
  #
  #  RETURNS: subgroupsGuess - vector of indices grouping input samples by subgroup. e.g. subgroupIxVec =
  #                            c(1, 1, 1, 2, 2) would indicate that samples 1:3 are in a subgroup together,
  #                            and samples 4 and 5 are in a separate subgroup together

  library(NbClust)
  source("computeInfoWeightMat.r")

  #  compute matrix of info weights
  infoMat = computeInfoWeightMat(abdList = abdList, rollRange = rollRange)

  nbcr = NbClust(data = infoMat + 10, method = "kmeans")

  subgroupsGuess = nbcr$Best.partition

  return(subgroupsGuess)

} #  end identifySubgroupsVer2 function


# Create stock price data series (use S&P500 over X previous years as baseline for market fluctuations, give stock beta of 1.X, maybe contact Sweet for help on how to simulate a stock's price movement this way)
# --->vector of S&P500 % changes, duplicate into new vector and multiple % changes by chosen Beta, randomly miss that Beta-adjusted vector by roughly +/-7bps, choose starting price then apply % change vector
# Create list of employees (with first/last names, department, title, level, hire date, etc.) [total employee count should grow over time, include term dates]
# Create vector of grant dates (options usually granted across the company in bulk)
# Create data.table of granted options, issuing only to employees hired and not terminated by that date, and issuing number of options based on employee level

# load necessary libraries
library("data.table");
library("lubridate");
library("ggplot2");
library("truncnorm");
library("zoo");

library("RODBC");
library("xlsx");
library("quantmod");
####
#### find package that has truncrnorm()
####

#####################################################################
##	Create stock price using input market data (S&P500)
#####################################################################
# set input variables
start.price <- 10.0;
beta <- 1.2;
beta.miss <- 0.0007;
start.date <- as.Date("1990-01-01");
months.pricing.data <- 25 * 12;

# import market csv file
setwd('C:/Users/zmueller/Documents/GitHub/sql-project/');
file.name <- 'data/stock-market/S&P500.csv';
# load csv into data.table
market <- data.table(read.csv(file.name));
# convert Date field to date type
market[, Date:=as.Date(Date)];
# set the key to order the data.table data
setkey(market, Date);
# remove the extraneous columns
market[, Open:=NULL];
market[, High:=NULL];
market[, Low:=NULL];
market[, Close:=NULL];
market[, Volume:=NULL];
# add in prior date's price and % change day over day
market[, Prior.Close:=c(0, Adj.Close[-.N])];
market[, Pct.Change:=((Adj.Close - Prior.Close)/Prior.Close)];

# extract relevant date range from market data
date.range <- seq(from = start.date, to = (start.date +
	months(months.pricing.data) - 1), by = "1 day");
stock <- market[J(date.range), nomatch=FALSE]; # use nomatch to filter to only dates with market data
# remove extra columns
stock[, Adj.Close:=NULL];
stock[, Prior.Close:=NULL];

# use stock market price data and input Beta to back into a stock price
##	multiply the market % change by the input Beta,
##	using a random factor of "missing" a perfect Beta
stock[, Pct.Change.B:=Pct.Change * beta
	+ rnorm(stock[,.N], mean = 0, sd = beta.miss)];
# add in starting stock price
##	set randomly around start.price by roughly 5%
stock[, price:=rnorm(1, mean = start.price, sd = 0.05)];
# calculate the cumulative product of the Beta-adjusted percent changes
stock[, Pct.Change.CumProd:=cumprod(1 + Pct.Change.B)];
# multiply the cumulative product output by the starting stock price
stock[, price:=Pct.Change.CumProd * price];
# show a quick plot of the data
qplot(stock[,Date], stock[,price]);
# remove extra columns
stock[, pct.change:=Pct.Change.B];
stock[, Pct.Change:=NULL];
stock[, Pct.Change.B:=NULL];
stock[, Pct.Change.CumProd:=NULL];

#####################################################################
##	Create fictitious list of employees, using First and Last name lists
#####################################################################
# import first and last name lists from csv files
setwd('C:/Users/zmueller/Documents/GitHub/sql-project/');
file.name <- 'data/lists/CSV_Database_of_First_Names.csv';
first.names <- data.table(read.csv(file.name));
file.name <- 'data/lists/CSV_Database_of_Last_Names.csv';
last.names <- data.table(read.csv(file.name));

# set inputs
start.headcount <- 10;
end.headcount <- 1000;
company.start.date <- min(stock[,Date]) # - years(5);

# add some randomization to the inputs
start.headcount <- round(rnorm(1, mean = start.headcount, sd = (start.headcount * 0.15)));
end.headcount <- round(rnorm(1, mean = end.headcount, sd = (end.headcount * 0.05)));
company.start.date <- company.start.date + round(rnorm(1, mean = 0, sd = 60), 0);

# create data.table of employees, randomly selecting from both first and last names
employees <- data.table(first.name = sample(first.names[, firstname],
	end.headcount, replace=TRUE), last.name = sample(last.names[, lastname],
	end.headcount, replace=TRUE));

# choose a random set (around years * 8) of dates between company.start.date and
##	the end date as batch hiring days.
end.date <- max(stock[, Date]);
hire.days <- round(rnorm(1, mean = (as.integer(end.date
	- company.start.date) / 365) * 8, sd = 10), 0);
hiring.dates <- sample(stock[,Date], hire.days);
hiring.dates <- hiring.dates[order(hiring.dates)];
hiring <- data.table(Date = hiring.dates);
setkey(hiring, Date);
hiring[, I:=.I];
hiring[stock, roll=TRUE][, sum(price), by = I];

##	Then, using the stock price data as a proxy, fill in each
##	employee's hiring date as one of the hiring dates randomly selected above
####	Hire count based on area under curve (AUC) between hire dates as percent of total AUC?
####	Approximate AUC calc with day's stock price (assume each closing price is equal to
####	only lasting effectively one day (rather than include weekends in x-axis for calc)
# use cumulative percent of AUC for easy join to hiring.dates
stock[, AUC.pct:=cumsum(price)/sum(price)];
hiring.prob <- stock[J(hiring.dates), AUC.pct][["AUC.pct"]];
hiring.prob <- diff(c(0, hiring.prob), lag = 1);
hiring.prob[1] <- 1 - sum(hiring.prob) + hiring.prob[1];

# using the calculated sampling percentages and hiring dates
##	create and fill in new field hire.date for all employees
dates <- sample(hiring.dates, employees[,.N], prob = hiring.prob, replace = TRUE);
employees[, hire.date:=dates];

# Terminations - use truncnorm to limit tenure between 1 year to 5 years
##	for employees who leave. Only a small percentage of employees are
##	assumed to be terminated or leave.
# fill employees data.table with termination dates
term.prob <- 0.1;
term.flags <- sample(c(TRUE, FALSE), employees[,.N],
	prob = c(term.prob, 1 - term.prob), replace = TRUE);
days.employed <- rtruncnorm(employees[,.N], a = 90, b = 365*5,
	mean = 365*2, sd = 180);
employees[, tenure.days:=round(term.flags * days.employed, 0)];
employees[, term.date:=as.Date(ifelse(tenure.days,
	hire.date + days(tenure.days), NA))];

# remove any termination dates that are after the last hiring date
last.hire.date <- max(hiring.dates);
employees[ term.date >= last.hire.date, term.date:=NA];
employees[, tenure.days:=NULL];


#!/usr/bin/env Rscript
#
# Calculate mean pairwise R^2 between variants in genes using a linear
# regression of all the variants in one gene on each variant in the
# other gene.
#
# Will spit out a bunch of warnings about "perfect fit" -- ignore these.
#

library(data.table)
library(dplyr)
library(dtplyr)

maf = function(g) {
    r = sum(g, na.rm=TRUE) / sum(!is.na(g))
    min(r, 1-r)
}

argv = commandArgs(trailingOnly=TRUE)
bedfile = argv[1]
genofile = argv[2]
min_maf = as.numeric(argv[3])
chunk = as.numeric(argv[4])
nchunks = as.numeric(argv[5])

genos = fread(genofile, header=TRUE, showProgress=FALSE)
mafs = apply(as.matrix(genos[, -(1:3)]), 1, maf)
genos = genos[mafs >= min_maf, ]

g = t(as.matrix(genos[, -(1:3), with=FALSE]))

genes = fread(bedfile, header=FALSE)
gene_ids = gsub('ID=(.+?);.+', '\\1', genes[[9]])
chunk_size = ceiling(nrow(genes) / nchunks)
first = (chunk - 1) * chunk_size + 1
last = chunk * chunk_size
if(last > nrow(genes)) { last = nrow(genes) }
## Note that issues with rounding to the nearest whole number mean
## that sometimes the last few chunks will be empty and cause an
## error.

result = matrix(nrow=(last-first+1), ncol=nrow(genes))
colnames(result) = gene_ids
rownames(result) = gene_ids[first:last]

k = 0
for(i in first:last) {
    for(j in 1:nrow(genes)) {
        if(!is.na(result[i-first+1, j])) {
            next
        }
        g1_vars = genos[['contig']] == genes[i][[1]] &
            genos[['pos']] >= genes[i][[4]] &
            genos[['pos']] <= genes[i][[5]]
        g2_vars = genos[['contig']] == genes[j][[1]] &
            genos[['pos']] >= genes[j][[4]] &
            genos[['pos']] <= genes[j][[5]]
        if(sum(g1_vars) && sum(g2_vars)) {
            g1 = g[, g1_vars, drop=FALSE]
            g2 = g[, g2_vars, drop=FALSE]
            r2_1 = 0
            r2_n1 = 0
            r2_2 = 0
            r2_n2 = 0
            for(l in 1:ncol(g2)) {
                r2_ = summary(lm(g2[, l] ~ g1))$adj.r.squared
                if(!is.na(r2_)) {
                    r2_1 = r2_1 + r2_
                    r2_n1 = r2_n1 + 1
                }
            }
            for(l in 1:ncol(g1)) {
                r2_ = summary(lm(g1[, l] ~ g2))$adj.r.squared
                if(!is.na(r2_)) {
                    r2_2 = r2_2 + r2_
                    r2_n2 = r2_n2 + 1
                }
            }
            if(r2_n1 > 0 && r2_n2 > 0) {
                r2 = ((r2_1 / r2_n1) + (r2_2 / r2_n2)) / 2
            } else {
                r2 = NaN
            }
        } else {
            r2 = NaN
        }
        result[i-first+1, j] = r2
        k = k + 1
        if(j >= first && j <= last) {
            result[j-first+1, i] = r2
            k = k + 1
        }
        if(k %% 10000 == 0) {
            cat(k, 'genes out of', nrow(result)*ncol(result), '\n', file=stderr())
        }
    }
}

write.table(result, file=stdout(), col.names=(chunk == 1),
            row.names=TRUE, quote=FALSE, sep='\t')


# Day 1: Sonar Sweep

get_day1_input_path <- function() {
    paste(getwd(), "/2021/Day 1/Day1_input.txt", sep = "")
}

part1 <- function() {
    readings <- readLines(get_day1_input_path())

    output <- character(length(readings))

    last_reading <- strtoi(readings[1])

    for (i in seq_len(length(readings))) {
        reading <- strtoi(readings[i])

        if (reading > last_reading) {
            output[i] <- "Increased"
        } else if (reading < last_reading) {
            output[i] <- "Decreased"
        } else {
            output[i] <- "No Change"
        }

        last_reading <- reading
    }

    cat("  Depth increased ", sum(output == "Increased"), " times!")
}

part2 <- function() {
    readings <- readLines(get_day1_input_path())

    output <- character(length(readings))

    last_reading <- get_three_reading_sum(readings, 1)

    for (i in seq_len(length(readings))) {

        # Ensure there are 3 numbers to sum
        if (length(readings) - i >= 2) {
            reading <- get_three_reading_sum(readings, i)

            if (reading > last_reading) {
                output[i] <- "Increased"
            } else if (reading < last_reading) {
                output[i] <- "Decreased"
            } else {
                output[i] <- "No Change"
            }

            last_reading <- reading
        }
    }

    cat("  Depth increased ", sum(output == "Increased"), " times!")
}

get_three_reading_sum <- function (readings, start_index) {
    sum(strtoi(readings[start_index]),
        strtoi(readings[start_index + 1]),
        strtoi(readings[start_index + 2]))
}

part1()
part2()


h <- length(x)/sum(1/x)


# linear model-head count
crossval.linear.hc <- function(number){
  set.seed(100)
  folds <- createFolds(phone_data_gt[,c("gt")], k = number,
                       list = TRUE, returnTrain = FALSE)
  fit_control <- trainControl(method = "repeatedcv", number = 10, repeats = 10)

  errors <- c()
  predictions <- c()
  real <- c()
  for (i in 1:number) {
    model <- train(gt~., data=phone_data_gt[-folds[[i]],],
                   method="leapSeq", tuneGrid = data.frame(nvmax=4),
                   trControl=fit_control)

    print(model)
    print(i)

    prediction <- predict(model, phone_data_gt[folds[[i]],])
    # error <- sqrt(mean((phone_data_gt[folds[[i]],]$gt - predictions)^2))
    error <- mean(abs(phone_data_gt[folds[[i]],]$gt - prediction))

    errors = append(error, errors)
    predictions = append(prediction, predictions)
    real = append(phone_data_gt[folds[[i]],]$gt, real)
  }

  return_value <- list("errors" = errors, "predictions" = predictions, "real" = real)
  return(return_value)
}

linear.hc <- crossval.linear.hc(10)
linear_df <- data.frame(linear.hc$real, linear.hc$predictions)
names(linear_df) <- c("real", "predictions")
# sort the data frame
linear_df <- linear_df[order(linear_df$real),]

y_min <- min(linear_df$real, linear_df$predictions)
y_max <- max(linear_df$real, linear_df$predictions)
plot(linear_df$predictions, col="red", type = "l", ylim=range(c(y_min,y_max)),
     ylab = "head count", xlab="index")
par(new=TRUE)
plot(linear_df$real, col="green", type="l", ylim=range(c(y_min,y_max)),
     axes = FALSE, xlab = "", ylab = "")
legend("topleft", inset=.05, c("observed","predicted"), fill=c("green", "red"), horiz=TRUE)

# linear model-device count
crossval.linear.dc <- function(number){
  set.seed(100)
  folds <- createFolds(phone_data_pr[,c("pr")], k = number,
                       list = TRUE, returnTrain = FALSE)
  fit_control <- trainControl(method = "repeatedcv", number = 10, repeats = 10)

  errors <- c()
  predictions <- c()
  real <- c()
  for (i in 1:number) {
    model <- train(pr~., data=phone_data_pr[-folds[[i]],],
                   method="leapSeq", tuneGrid = data.frame(nvmax=4),
                   trControl=fit_control)

    print(model)
    print(i)

    prediction <- predict(model, phone_data_pr[folds[[i]],])
    # error <- sqrt(mean((phone_data_pr[folds[[i]],]$pr - predictions)^2))
    error <- mean(abs(phone_data_pr[folds[[i]],]$pr - prediction))

    errors = append(error, errors)
    predictions = append(prediction, predictions)
    real = append(phone_data_pr[folds[[i]],]$pr, real)
  }

  return_value <- list("errors" = errors, "predictions" = predictions, "real" = real)
  return(return_value)
}

linear.dc <- crossval.linear.dc(10)
linear_df <- data.frame(linear.dc$real, linear.dc$predictions)
names(linear_df) <- c("real", "predictions")
# sort the data frame
linear_df <- linear_df[order(linear_df$real),]

y_min <- min(linear_df$real, linear_df$predictions)
y_max <- max(linear_df$real, linear_df$predictions)
plot(linear_df$predictions, col="red", type = "l", ylim=range(c(y_min,y_max)),
     ylab = "device count", xlab="index")
par(new=TRUE)
plot(linear_df$real, col="green", type="l", ylim=range(c(y_min,y_max)),
     axes = FALSE, xlab = "", ylab = "")
legend("topleft", inset=.05, c("observed","predicted"), fill=c("green", "red"), horiz=TRUE)

# knn - head count
crossval.knn.gt <- function(number){
  set.seed(100)
  folds <- createFolds(phone_data_gt[,c("gt")], k = number,
                       list = TRUE, returnTrain = FALSE)
  fit_control <- trainControl(method = "repeatedcv", number = 10, repeats = 10)

  errors <- c()
  predictions <- c()
  real <- c()
  for (i in 1:number) {
    model <- train(gt~., data=phone_data_gt[-folds[[i]],], method="knn",
                   trControl=fit_control, tuneGrid = data.frame(k=7))

    print(model)
    print(i)

    prediction <- predict(model, phone_data_gt[folds[[i]],])
    # error <- sqrt(mean((phone_data_gt[folds[[i]],]$gt - predictions)^2))
    error <- mean(abs(phone_data_gt[folds[[i]],]$gt - prediction))

    errors = append(error, errors)
    predictions = append(prediction, predictions)
    real = append(phone_data_gt[folds[[i]],]$gt, real)
  }

  return_value <- list("errors" = errors, "predictions" = predictions, "real" = real)
  return(return_value)
}

knn.hc <- crossval.knn.gt(10)
knn.df <- data.frame(knn.hc$real, knn.hc$predictions)
names(knn.df) <- c("real", "predictions")
# sort the data frame
knn.df <- knn.df[order(knn.df$real),]

y_min <- min(knn.df$real, knn.df$predictions)
y_max <- max(knn.df$real, knn.df$predictions)
plot(knn.df$predictions, col="red", type = "l", ylim=range(c(y_min,y_max)),
     ylab = "head count", xlab="index")
par(new=TRUE)
plot(knn.df$real, col="green", type="l", ylim=range(c(y_min,y_max)),
     axes = FALSE, xlab = "", ylab = "")
legend("topleft", inset=.05, c("observed","predicted"), fill=c("green", "red"), horiz=TRUE)

# knn - device count
crossval.knn.pr <- function(number){
  set.seed(100)
  folds <- createFolds(phone_data_pr[,c("pr")], k = number,
                       list = TRUE, returnTrain = FALSE)
  fit_control <- trainControl(method = "repeatedcv", number = 10, repeats = 10)

  errors <- c()
  predictions <- c()
  real <- c()
  for (i in 1:number) {
    model <- train(pr~., data=phone_data_pr[-folds[[i]],], method="knn",
                   trControl=fit_control, tuneGrid = data.frame(k=8))

    print(model)
    print(i)

    prediction <- predict(model, phone_data_pr[folds[[i]],])
    # error <- sqrt(mean((phone_data_pr[folds[[i]],]$pr - predictions)^2))
    error <- mean(abs(phone_data_pr[folds[[i]],]$pr - prediction))

    errors = append(error, errors)
    predictions = append(prediction, predictions)
    real = append(phone_data_pr[folds[[i]],]$pr, real)
  }

  return_value <- list("errors" = errors, "predictions" = predictions, "real" = real)
  return(return_value)
}

knn.dc <- crossval.knn.pr(10)
knn.df <- data.frame(knn.dc$real, knn.dc$predictions)
names(knn.df) <- c("real", "predictions")
# sort the data frame
knn.df <- knn.df[order(knn.df$real),]

y_min <- min(knn.df$real, knn.df$predictions)
y_max <- max(knn.df$real, knn.df$predictions)
plot(knn.df$predictions, col="red", type = "l", ylim=range(c(y_min,y_max)),
     ylab = "device count", xlab="index")
par(new=TRUE)
plot(knn.df$real, col="green", type="l", ylim=range(c(y_min,y_max)),
     axes = FALSE, xlab = "", ylab = "")
legend("topleft", inset=.05, c("observed","predicted"), fill=c("green", "red"), horiz=TRUE)

# svm - device count
library(e1071)
crossval.svm.pr <- function(number){
  library(caret)
  library(e1071)
  folds <- createFolds(phone_data_pr[,c("pr")], k = number, list = TRUE,
                       returnTrain = FALSE)

  errors <- c()
  predictions <- c()
  real <- c()
  for (i in 1:number) {
    model <- svm(pr~., phone_data_pr[-folds[[i]],], epsilon=0, cost=1)
    # print(model)
    prediction <- predict(model, phone_data_pr[folds[[i]],])
    # error <- sqrt(mean((phone_data_pr[folds[[i]],]$pr - predictions)^2))
    error <- mean(abs(phone_data_pr[folds[[i]],]$pr - prediction))

    errors = append(error, errors)
    predictions = append(prediction, predictions)
    real = append(phone_data_pr[folds[[i]],]$pr, real)
  }

  return_value <- list("errors" = errors, "predictions" = predictions, "real" = real)
  return(return_value)
}

svm.dc <- crossval.svm.pr(10)
svm.df <- data.frame(svm.dc$real, svm.dc$predictions)
names(svm.df) <- c("real", "predictions")
# sort the data frame
svm.df <- svm.df[order(svm.df$real),]

y_min <- min(svm.df$real, svm.df$predictions)
y_max <- max(svm.df$real, svm.df$predictions)
plot(svm.df$predictions, col="red", type = "l", ylim=range(c(y_min,y_max)),
     ylab = "device count", xlab="index")
par(new=TRUE)
plot(svm.df$real, col="green", type="l", ylim=range(c(y_min,y_max)),
     axes = FALSE, xlab = "", ylab = "")
legend("topleft", inset=.05, c("observed","predicted"), fill=c("green", "red"), horiz=TRUE)

# svm - head count
library(e1071)
crossval.svm.gt <- function(number){
  set.seed(100)
  folds <- createFolds(phone_data_gt[,c("gt")], k = number,
                       list = TRUE, returnTrain = FALSE)
  fit_control <- trainControl(method = "repeatedcv", number = 10, repeats = 10)

  errors <- c()
  predictions <- c()
  real <- c()
  for (i in 1:number) {
    model <- svm(gt~., phone_data_gt[-folds[[i]],], nu=0.5, cost=3,
                 type="nu-regression")

    # print(model)
    # print(i)

    prediction <- predict(model, phone_data_gt[folds[[i]],])
    # error <- sqrt(mean((phone_data_gt[folds[[i]],]$gt - predictions)^2))
    error <- mean(abs(phone_data_gt[folds[[i]],]$gt - prediction))

    errors = append(error, errors)
    predictions = append(prediction, predictions)
    real = append(phone_data_gt[folds[[i]],]$gt, real)
  }

  return_value <- list("errors" = errors, "predictions" = predictions, "real" = real)
  return(return_value)
}

svm.hc <- crossval.svm.gt(10)
svm.df <- data.frame(svm.hc$real, svm.hc$predictions)
names(svm.df) <- c("real", "predictions")
# sort the data frame
svm.df <- svm.df[order(svm.df$real),]

y_min <- min(svm.df$real, svm.df$predictions)
y_max <- max(svm.df$real, svm.df$predictions)
plot(svm.df$predictions, col="red", type = "l", ylim=range(c(y_min,y_max)),
     ylab = "head count", xlab="index")
par(new=TRUE)
plot(svm.df$real, col="green", type="l", ylim=range(c(y_min,y_max)),
     axes = FALSE, xlab = "", ylab = "")
legend("topleft", inset=.05, c("observed","predicted"), fill=c("green", "red"), horiz=TRUE)


#source("https://bioconductor.org/biocLite.R")
#biocLite("pasilla")
#biocLite("mixOmics")
#biocLite("DESeq2")

library("pasilla")
library("ggplot2")
library("reshape")
library("mixOmics")
library("RColorBrewer")
library("DESeq2")

datafile = system.file("extdata/pasilla_gene_counts.tsv", package = "pasilla")
rawCountTable = read.table(datafile, header = TRUE, row.names = 1)
condition = c("control", "control", "control", "control", "treated", "treated", "treated")
libType = c("single-end", "single-end", "paired-end", "paired-end", "single-end",
            "paired-end", "paired-end")
colnames(rawCountTable)[1:4] = paste0("control", 1:4)

# raw plot
ggplot(rawCountTable, aes(x = control1)) + geom_histogram(fill = "#525252", binwidth = 2000)

# log-normalized
pseudoCount = log2(rawCountTable + 1)
ggplot(pseudoCount, aes(x = control1)) + ylab(expression(log[2](count + 1))) +
  geom_histogram(colour = "white", fill = "#525252", binwidth = 0.6)

# boxplots
df = melt(pseudoCount, variable_name = "Samples")
df = data.frame(df, Condition = substr(df$Samples, 1, 7))
ggplot(df, aes(x = Samples, y = value, fill = Condition)) + geom_boxplot() + xlab("") +
  ylab(expression(log[2](count + 1))) + scale_fill_manual(values = c("#619CFF", "#F564E3"))

# histogram
ggplot(df, aes(x = value, colour = Samples, fill = Samples)) + ylim(c(0, 0.25)) +
  geom_density(alpha = 0.2, size = 1.25) + facet_wrap(~ Condition) +
  theme(legend.position = "top") + xlab(expression(log[2](count + 1)))

# MA plot
x = pseudoCount[, 1]
y = pseudoCount[, 2]

# M-values
M = x-y

# A-values
A = (x + y)/2
df = data.frame(A, M)
ggplot(df, aes(x = A, y = M)) + geom_point(size = 1.5, alpha = 1/5) +
  geom_hline(color = "blue3", yintercept=0) + stat_smooth(se = FALSE, method = "loess", color = "red3")

# Heatmap
mat.dist = pseudoCount
colnames(mat.dist) = paste(colnames(mat.dist), libType, sep = " : ")
mat.dist = as.matrix(dist(t(mat.dist)))
mat.dist = mat.dist/max(mat.dist)
hmcol = colorRampPalette(brewer.pal(9, "GnBu"))(16)
cim(mat.dist, color = rev(hmcol), symkey = FALSE, margins = c(9,9))

# PCA
rv = rowVars(as.matrix(pseudoCount))
ntop = 100
select = order(rv, decreasing = TRUE)[1:ntop]
pca = prcomp(t(pseudoCount[select, ]))

annot = AnnotatedDataFrame(data = data.frame(condition, libType,
                                             row.names = colnames(pseudoCount)))
expSet = new("ExpressionSet", exprs = as.matrix(pseudoCount), phenoData = annot)
plotPCA(DESeqTransform(expSet), intgroup = c("condition", "libType"))

pcoa = rda(as.matrix(pseudoCount))
biplot(pcoa)

# MDS
x = pseudoCount
s = rowMeans((x - rowMeans(x))^2)
o = order(s, decreasing = TRUE)
x = x[o, ]
x = x[1:ntop, ]
D[i, j] = sqrt(colMeans((x[, i] - x[, j])^2))

# Filtering
keep = rowSums(count) > 0
filtCount = pseudoCount[keep, ]
dim(count)


###########################################################
### CH-Heatmap-plot Class using heatmap2
###########################################################

# HC-heatmap with dendogram showing groups by states vs vars including
# average scores, spending, population
library(gplots)   # contains the heatmap.2 package
library(car)
States[1:3,] # look at the data

scaled <- scale(States[,-1]) # scale all but the first column to make information comparable
heatmap.2(scaled, # specify the (scaled) data to be used in the heatmap
          cexRow=0.5, cexCol=0.95, # decrease font size of row/column labels
          scale="none", # we have already scaled the data
          trace="none") # cleaner heatmap

# Take out the dendograms and density plot information as well as add cell information manually

# Use color brewer
library(RColorBrewer)
my_palette <- colorRampPalette(c('red','yellow','green'))(256)

scaled <- scale(States[,-1])    # scale all but the first column to make information comparable
heatmap.2(scaled,               # specify the (scaled) data to be used in the heatmap
          cexRow=0.5,
          cexCol=0.95,          # decrease font size of row/column labels
          col = my_palette,     # arguments to read in custom colors
          colsep=c(2,4,5),      # Adding on the separators that will clarify plot even more
          rowsep = c(6,14,18,25,30,36,42,47),
          sepcolor="black",
          sepwidth=c(0.01,0.01),
          scale="none",         # we have already scaled the data
          dendrogram="none",    # no need to see dendrograms in this one
          trace="none",         # cleaner heatmap
          par(cex.main=1.0),    # change title font size
          density.info="none",  # turn off denisty plot inside color legend
          main="<State Exam Scores>\n vs.\nState \nEducation Spending") # title


 DTGSNA Example Program Results

 S
       1.6E+00    1.7E+00    1.7E+00    1.4E+00

 DIF
       5.4E-01    1.5E-01    1.5E-01    1.2E-01

 Approximate error estimates for eigenvalues of (A,B)
       1.7E-15    1.6E-15    1.6E-15    2.0E-15

 Approximate error estimates for right eigenvectors of (A,B)
       5.0E-15    1.8E-14    1.8E-14    2.2E-14


require(rms)
set.seed(1)
x <- runif(100)
y <- abs(x - 0.5) + runif(100)
f <- ols(y ~ rcs(x, 5))
latex(f, file='')

require(rms)
x1 <- runif(200); x2 <- runif(200)
y <- sample(0:1, 200, TRUE)
f <- lrm(y ~ rcs(x1) + rcs(x2))
cat('\\documentclass{article}\\begin{document}\\usepackage{longtable}\n', file='/tmp/e.tex')
lat <- latex(f, file='/tmp/e.tex', append=TRUE)
sink('/tmp/e.tex', append=TRUE)
print(f, latex=TRUE)
sink()
cat('\\end{document}\n', file='/tmp/e.tex', append=TRUE)


library(mclust)

#Pogledamo kako sta količini korelirani
cor_kolicin <- cor(lokacija_narocil$trajanje, lokacija_narocil$razdalja)

#Pogledamo gostoto obeh spremenljivk
gostota_trajanja <- ggplot(lokacija_narocil, aes(x=lokacija_narocil$trajanje)) +
  geom_density() +
  scale_x_log10() +
  labs(title = "Gostota porazdelitve trajanja", x="Trajanje (log10)", y="Gostota")

gostota_razdalja <- ggplot(lokacija_narocil, aes(x=lokacija_narocil$razdalja)) +
  geom_density() +
  scale_x_log10() +
  labs(title = "Gostota porazdelitve razdalje", x="Razdalja (log10)", y="Gostota")

##Naredimo model linearne regresije in izpišemo glavne parametre
linearna_regresija <- lm(trajanje ~ razdalja, data=lokacija_narocil)
koeficienti <- linearna_regresija$coefficients
#print(linearna_regresija)
summary(linearna_regresija)


# ridge regression within levels of a factor
# result has "final.model" which contains a list "models" of
# ridge models indexed by category levels and a string "category" name
"train.ridge.by.category" <- function(x,y,category, verbose=0){
  # moved 'caret' loading here because it has been difficult to
  # install on some systems
  library('caret', warn.conflicts = F, quietly = T)

  results <- list()
  final.model <- list()
  final.model$models <- list()
  yhat <- y

  # preprocess data to center and scale
  preprocessor <- preProcess(x, method = c("center", "scale"))
  final.model$preprocessor <- preprocessor
  x <- predict(preprocessor,x)

  for(level in levels(category)){
    if(verbose > 0) cat(level,'')
    ix <- category == level
    if(sum(ix) >= 10){
      final.model$models[[level]] <- train(x[ix,],y[ix],method='ridge',
                                           tuneLength=4,trControl=trainControl(method='cv',number=5)
                                           )
      yhat[ix] <- predict(final.model$models[[level]],x[ix,])
    } else {
      yhat[ix] <- NA
    }
  }

  # train a general model for unrecognized levels
  if(verbose > 0) cat('general')
  final.model$general.model <- train(x,y,method='ridge',
                                       tuneLength=4,trControl=trainControl(method='cv',number=5)
                                     )

  if(verbose > 0) cat('\n')
  results$final.model <- final.model
  results$rmse <- sqrt(mean((yhat-y)^2))
  results$mape <- 100*mean(abs(yhat-y)/y)
  results$y <- y
  results$yhat <- yhat
  return(results)
}

# lm within levels of a factor
# "final.model" which contains a list "models" of
# ridge models indexed by category levels
"predict.ridge.by.category" <- function(final.model, newx, category){
  yhat <- numeric(nrow(newx))
  # preprocess data to scale and center
  newx <- predict(final.model$preprocessor,newx)
  for(level in levels(category)){
    ix <- category == level
    if(level %in% names(final.model$models)){
      model.i <- final.model$models[[level]] # get model for this category
    } else {
      model.i <- final.model$general.model # get model for this category
    }
    yhat[ix] <- predict(model.i,newx[ix,,drop=F])
  }
  return(yhat)
}


#-----------------------------------#
#### UBeTube Processing R Script ####
##   Script can be used to process UBeTube data. See UBeTube_Processing_Guide.pdf for detailed instructions.
##   By: Justin Johnson - University of Arizona
##   2020-09-21

# Load necessary packages

#install.packages(readxl)
#install.packages(tidyverse)
#install.packages(broom)
library(readxl)
library(tidyverse)
library(broom)

# Names of files to be imported and exported
calibrationfilename <- "calibration.xls"                  #Name of calibration dataset
timeeseriesfilename <- "example_dataset.xls"              #Name of time series dataset
ratingcurvefilename <- "ratingcurve.png"                  #Name of file calibration rating curve should be exported to
hydrographfilename <- "hydrograph.png"                    #Name of file hydrograph should be exported to

#Input values
h0 <- 35.7 #Height of bottom of slot relative to pressure transducer (cm)
d <- 10.16 #Interior diameter of UBeTube (cm)

#---------------------------------------------------------------------------------#
# NO CHANGES NEEDED TO CODE BELOW UNLESS CUSTOMIZING CALIBRATIONS OR PLOT OUTPUTS #

##-----------------##
#### CALIBRATION ####
##-----------------##

#Read in calibration data
calibration <- read_excel("calibration_data.xls",
                          sheet=1,
                          skip=1,
                          col_types = c("numeric", "numeric", "numeric"),
                          col_names=c("h0.mm", "hraw.mm", "Q.Lmin"))

#Converts height to cm from mm
calibration1 <- calibration %>%
  mutate(h.mm = hraw.mm-h0.mm,
         h.cm = h.mm/10)

#Runs power-law regression to predict discharge from stage.
ratingcurve.model <-nls(calibration1$Q.Lmin~a*calibration1$h.cm^b,
                        data=calibration1,
                        start=list(a=1,b=1))
ratingcurve.tidymodel <- tidy(ratingcurve.model)

#Extracts a and b estimates
a <- as.numeric(ratingcurve.tidymodel[1,2])
b <- as.numeric(ratingcurve.tidymodel[2,2])

#Creates label for plot with model results
label <- sprintf("Q == %.3g*h^%.3g", a, b)

#Plots rating curve
ratingcurve.plot <- ggplot(calibration1, aes(h.cm, Q.Lmin))+
  geom_point()+
  labs(x="h (cm)",
       y=bquote('Q (L·'*min^-1*')'))+
  geom_smooth(method = 'nls',
              formula = 'y~a*x^b',
              method.args = list(start= c(a = 1,b=1)),
              se=FALSE)+
  theme_classic()+
  annotate("text",
           x=0.6*median(calibration1$h.cm, na.rm=TRUE),
           y=median(calibration1$Q.Lmin, na.rm=TRUE),
           label= label,
           color="blue",
           parse=TRUE)

#Saves rating curve
ggsave(ratingcurvefilename,
       plot = ratingcurve.plot,
       width = 7,
       height = 7)

##-----------------##
#### TIME SERIES ####
##-----------------##

#Reads in time series dataset
UBeTube <- read_excel("example_dataset.xls",
                      sheet=1,
                      skip=3,
                      col_types = c("date", "numeric", "skip", "skip"),
                      col_names=c("time", "hraw.mm"))

#Wrangles time series data
UBeTube1 <- UBeTube %>%
  mutate(hraw.cm = hraw.mm/10, #Converts height to cm from mm
         time.sec = as.numeric(time, unit='sec'), #Converts time to seconds
         h.cm = hraw.cm-h0) #Determines height of water in UBeTube relative to h0

#Calculates outflow
UBeTube2 <- UBeTube1 %>%
  mutate(Q.Lmin=a*h.cm^b) #Calculates outflow based on Equation 1

#Calculates inflow
UBeTubeFinal <- UBeTube2 %>%
  mutate(S.cm3s = (pi*(d^2)*h.cm)/4, #Calculates volume of water stored in UBeTube
         S.Lmin = S.cm3s*60/1000, #Converts storage to L/min
         I.Lmin = (S.Lmin-lag(S.Lmin))/(time.sec-lag(time.sec))
         +((Q.Lmin+lag(Q.Lmin))/2)) #Calculates inflow using Equation 3

#Plots hydrograph
plot(UBeTubeFinal$time,UBeTubeFinal$I.Lmin, type="l",
     xlab="Time (hh:mm)",
     ylab= expression('Inflow (L·min' ^ {-1}*')'))

#Saves hydrograph
dev.copy(png,hydrographfilename,
         width=720,
         height=480)
dev.off()


source("R/EpiProgInf.r")
source("R/makebetas.R")

n.sims <-  500 # number of simulations
 n.epis <- 100 #number of simulated epidemics per simulation

 fs <- matrix(nrow=n.epis, ncol=n.sims) #matrix to hold final sizes
 pcts <- matrix(nrow=n.epis, ncol=n.sims) #matrix to hold proportion complete at time of simulation

 #initialize each model

 K.VC_linear <- fs
 K.VC_rpart <- fs
 K.VC_super <- fs
 K.norm_linear <-fs
 K.norm_rpart <-fs
 K.norm_super <- fs
 K.VC_alone <- fs
 K.norm_alone <- fs
 K.linear_alone <- fs
 K.rpart_alone <- fs
 K.super_alone <- fs

 for (i in 1:n.sims) {

   cat("iteration ", i, "\n")

  x <- runif(n.epis, 0, 3)
  fs[,i] <- rpois(n.epis, 1000*3^x)
  pcts[,i] <- runif(n.epis, .05,1)

  ecs <- gen.epicurves.ViboudChowell(pcts[,i], fs[,i], r = 1, p = 0.6)

  dat <- data.frame(K=2*sapply(ecs,sum),
                    x=x)

  K.VC_linear[,i] <- epiInf.EM(ecs, dat,
                               stat.mdl.linear.fit,
                               epi.mdl.ViboudChowell.fit2,
                               stat.mdl.linear.pred,
                               epi.mdl.ViboudChowell.pred2,
                               threshold = 1)$K

  K.VC_rpart[,i] <- epiInf.EM(ecs, dat,
                               stat.mdl.rpart.fit,
                               epi.mdl.ViboudChowell.fit2,
                               stat.mdl.rpart.pred,
                               epi.mdl.ViboudChowell.pred2,
                               threshold = 1)$K

   K.VC_super[,i] <- epiInf.EM(ecs, dat,
                               stat.mdl.sl.fit,
                               epi.mdl.ViboudChowell.fit2,
                               stat.mdl.sl.pred,
                               epi.mdl.ViboudChowell.pred2,
                               threshold = 1)$K

  K.norm_linear[,i] <- epiInf.EM(ecs, dat,
                               stat.mdl.linear.fit,
                               epi.mdl.normcurve.fit,
                               stat.mdl.linear.pred,
                               epi.mdl.normcurve.pred,
                               threshold = 1)$K

  K.norm_rpart[,i] <- epiInf.EM(ecs, dat,
                               stat.mdl.rpart.fit,
                               epi.mdl.normcurve.fit,
                               stat.mdl.rpart.pred,
                               epi.mdl.normcurve.pred,
                               threshold = 1)$K

   K.norm_super[,i] <- epiInf.EM(ecs, dat,
                               stat.mdl.sl.fit,
                               epi.mdl.normcurve.fit,
                               stat.mdl.sl.pred,
                               epi.mdl.normcurve.pred,
                               threshold = 1)$K

   K.VC_alone[,i] <- epi.mdl.ViboudChowell.init2(ecs)$K

   K.norm_alone[,i] <- epi.mdl.normcurve.init(ecs)$K

   tmp.dat <- dat
   tmp.dat$K <- sapply(ecs, sum)

   print("RPART STAT")
   K.rpart_alone[,i] <- stat.mdl.rpart.pred(stat.mdl.rpart.fit(tmp.dat))

   print("RPART LIN")
   K.linear_alone[,i] <- stat.mdl.linear.pred(stat.mdl.linear.fit(tmp.dat))

   print("RPART SUPER")
   K.super_alone[,i] <- stat.mdl.sl.pred(stat.mdl.sl.fit(tmp.dat))
 }

save(pcts, fs, K.VC_linear, K.VC_rpart, K.VC_super, K.norm_linear, K.norm_rpart, K.norm_super,
     K.VC_alone, K.norm_alone, K.rpart_alone, K.linear_alone, K.super_alone, file="VCSingleVarRuns100.RData")


install.packages('gamlss.dist')
library(gamlss.dist)

set.seed(123)

ZIP_rng <- rZIP(n=10, mu=6, sigma=0.5)
#=> [1] 0 6 0 8 9 0 2 8 3 0


source("./nimble_utilities.r")
mod_multi_country_mixture <- nimbleCode({

	for(p in 1:N_countries){

		s_xi[p]     ~ dinvgamma(1,1)
		s_lomega[p] ~ dinvgamma(1,1)
		s_alpha[p]  ~ dinvgamma(1,1)
		s_mu[p]     ~ dinvgamma(1,1)
		s_lsigma[p] ~ dinvgamma(1,1)
		s_eta1[p]   ~ dinvgamma(1,1)
		s_eta2[p]   ~ dinvgamma(1,1)

		# Drift parameters
		drift_xi[p] ~ dnorm(mean = 0, sd = 1)
		drift_lomega[p] ~ dnorm(mean = 0, sd = 1)
		drift_alpha[p] ~ dnorm(mean = 0, sd = 1)

		drift_mu[p] ~ dnorm(mean = 0, sd = 1)
		drift_lsigma[p] ~ dnorm(mean = 0, sd = 1)

		drift_eta1[p] ~ dnorm(mean = 0, sd = 1)
		drift_eta2[p] ~ dnorm(mean = 0, sd = 1)

		m_xi_0[p] ~ dnorm( mean = m_xi, sd = 1)
		m_lomega_0[p] ~ dnorm( mean = m_lomega, sd = 1)
		m_alpha_0[p] ~ dnorm( mean = m_alpha, sd = 1)
		m_mu_0[p] ~ dnorm( mean = m_mu, sd = 1)
		m_lsigma_0[p] ~ dnorm( mean = m_lsigma, sd = 1)
		m_eta1_0[p] ~ dnorm( mean = m_eta1, sd = 1)
		m_eta2_0[p] ~ dnorm( mean = m_eta2, sd = 1)

		# random walk. First observation
		xi[p,1] ~ dnorm(mean     =  m_xi_0[p], var = s_xi[p])
		lomega[p,1] ~ dnorm(mean =  m_lomega_0[p], var = s_lomega[p])
		alpha[p,1] ~ dnorm(mean  =  m_alpha_0[p], var = s_alpha[p])

		mu[p,1] ~ dnorm(mean     =  m_mu_0[p], var = s_mu[p])
		lsigma[p,1] ~ dnorm(mean =  m_lsigma_0[p], var = s_lsigma[p])

		eta1[p,1] ~ dnorm(mean = m_eta1_0[p], var = s_eta1[p])
		eta2[p,1] ~ dnorm(mean = m_eta2_0[p], var = s_eta2[p])
	}

	#++++++++++++++++++++++++++++++++++++++++++++++++++
	# Time recursion: multivariate random walk + drift
	#++++++++++++++++++++++++++++++++++++++++++++++++++

	for(p in 1:N_countries){
		for (tt in 2:Time){
			xi[p,tt] ~ dnorm(mean = drift_xi[p] + xi[p, tt-1], var = s_xi[p])
			lomega[p,tt] ~ dnorm(mean = drift_lomega[p] + lomega[p, tt-1], var = s_lomega[p])
			alpha[p,tt] ~ dnorm(mean = drift_alpha[p] + alpha[p, tt-1], var = s_alpha[p])

			mu[p,tt] ~ dnorm(mean = drift_mu[p] + mu[p, tt-1], var = s_mu[p])
			lsigma[p,tt] ~ dnorm(mean = drift_lsigma[p] + lsigma[p, tt-1], var = s_lsigma[p])

			eta1[p,tt] ~ dnorm(mean = drift_eta1[p] + eta1[p, tt-1], var = s_eta1[p])
			eta2[p,tt] ~ dnorm(mean = drift_eta2[p] + eta2[p, tt-1], var = s_eta2[p])

		}

	}

	# multinomial likelihood
	for(p in 1:N_countries){

		for(tt in 1:Time) {
			# We use a different parametrization here, cumulative logit
			# works better in practice
			w[p,3,tt] <- expit(eta1[p,tt] )
			w[p,2,tt] <- expit(eta2[p,tt]) * expit(-eta1[p,tt])
			w[p,1,tt] <- 1 - w[p,2,tt] - w[p,3,tt]
			#w[p,1,tt] <- expit(-eta2[p,tt]) * expit(-eta1[p,tt])

			probs[p,1:n,tt] <- link_func(x[1:n],w[p,1:3,tt],
						     mu[p,tt],lsigma[p,tt],
						     xi[p,tt],lomega[p,tt],alpha[p,tt])
			y[p,1:n,tt] ~ dmulti(probs[p,1:n,tt],N[p,tt])

		}

	}
})


incarceration_trends <- read.csv("https://raw.githubusercontent.com/vera-institute/incarceration-trends/master/incarceration_trends.csv")
incarceration_trends_jail_jurisdiction <- read.csv("https://raw.githubusercontent.com/vera-institute/incarceration-trends/master/incarceration_trends_jail_jurisdiction.csv")
# what is total jain popultion over time
# female vs male
# % female in jail in each state

library(ggplot2)
library(dplyr)
library(stringr)
library(tibble)
library(scales)
library(maps)
library(leaflet)
library(tidyverse)
library(usmap)

#summary table
#total population in jail every year
total <- incarceration_trends_jail_jurisdiction %>%
  group_by(year) %>%
  summarise(total = sum(total_jail_pop, na.rm = TRUE))
#highest total population in jail
high_total <- max(total$total)
    # highest  total population in jail year
high_total_year <- total %>%
  filter(total == max(total)) %>%
  pull(year)

#lowest total population in jail
low_total <- min(total$total)
#lowest  total population in jail year
low_total_year <- total %>%
  filter(total == min(total)) %>%
  pull(year)
#female population in jail every year
females <- incarceration_trends_jail_jurisdiction %>%
  group_by(year) %>%
  summarise(female = sum(female_jail_pop, na.rm = TRUE))
#highest female population in jail
high_total_female <- max(females$female)
# highest  female population in jail year
high_female_year <- females %>%
  filter(female == max(female, na.rm=TRUE)) %>%
  pull(year)

#lowest female population in jail
low_female <- min(females$female)
#lowest  female population in jail year
low_female_year <- females %>%
  filter(female == min(female)) %>%
  pull(year)
#male population in jail every year
males <- incarceration_trends_jail_jurisdiction %>%
  group_by(year) %>%
  summarise(male = sum(male_jail_pop, na.rm = TRUE))
#highest male population in jail
high_total_male <- max(males$male)
# highest  male population in jail year
high_male_year <- males %>%
  filter(male == max(male, na.rm=TRUE)) %>%
  pull(year)

#lowest male population in jail
low_male <- min(males$male)
#lowest male population in jail year
low_male_year <- males %>%
  filter(male == min(male)) %>%
  pull(year)
#jail admin in jail every year
variables <- incarceration_trends_jail_jurisdiction %>%
  group_by(year) %>%
  summarise(total_adm = sum(total_jail_adm, na.rm = TRUE))
#highest male population in jail
high_total_adm <- max(variables$total_adm)
# highest  male population in jail year
high_adm_year <- variables %>%
  filter(total_adm == max(total_adm, na.rm=TRUE)) %>%
  pull(year)

#lowest male population in jail
low_adm <- min(variables$total_adm)
#lowest male population in jail year
low_male_adm <- variables %>%
  filter(total_adm == min(total_adm)) %>%
  pull(year)
#number of population in jail in each state in year 1970
maps <- incarceration_trends%>%
  filter(year == "1970") %>%
  group_by(state) %>%
  summarize(state_pop = sum(total_pop))

total_population <- sum(maps$state_pop)

maps <- maps %>%
  mutate(percent = state_pop/total_population *100)
#state that has highest percent in 1970
high_state <- maps %>%
  filter(percent == max(percent, na.rm=TRUE)) %>%
  pull(state)
#highest state percent
high_state_pop <- max(maps$percent)
#state that has lowest percent
low_state <- maps %>%
  filter(percent == min(percent,na.rm=TRUE)) %>%
  pull(state)
#lowest state percent
low_state_pop <- min(maps$percent)
# trend over time chart of populations of genders in jail

df1 <- merge(total,females, sort = TRUE)
summarys <- merge(df1, males, sort = TRUE)

line_chart <- ggplot(summarys, aes(x=year, y= total)) +
  geom_line(aes(y=total, color = "total")) +
  geom_line(aes(y=male, color = "male")) +
  geom_line(aes(y=female, color = "female")) +
  xlab("number of people in jail") +
  ylab("year") +
  ggtitle("total population in jail based on gender")

#variable comparasion chart of jail population vs jail adm

df2 <- merge(total,variables, sort = TRUE)

comparasion <- ggplot(df2, aes(x=total, y=total_adm)) +
  geom_point() +
  xlab("total jail population") +
  ylab("total jail admin") +
  ggtitle("total population in jail vs total admin in jail")

#map
map_chart <- plot_usmap(data = maps, values = "percent", color = "blue") +
  scale_fill_continuous(
    low = "white", high = "blue", name = "percent of total population in jail of US(1970)", label = scales::comma
  ) + labs(title = "percentage of jail population in US") + theme(legend.position = "right")


library(MDPtoolbox)

data = mdp_example_forest(3,3,2,0.8)

print(data$P[,,1])
print(data$P[,,2])

print(data$R[,1])
print(data$R[,2])

mdp_check(data$P, data$R)

solver=mdp_policy_iteration(P=data$P, R=data$R, discount = 0.95)

print(solver$V)
print(solver$policy)
print(solver$iter)
print(solver$time)


library('lavaan')

setwd('~/git/sem_python/tests')
data <- read.csv('Demo_twolevel.csv')

model <- '
        level: 1
            fw =~ y1 + y2 + y3
            fw ~ x1 + x2 + x3
        level: 2
            fb =~ y1 + y2 + y3
            fb ~ w1 + w2
'

fit <- sem(model = model, data = Demo.twolevel, cluster = "cluster", auto.fix.first = FALSE, std.lv = TRUE)
summary(fit)