# Tidy data using R pipes

# A. gather()
# Used to convert tame (wide) data structure to tidy (long) data structure

# 1. Gather & plot
tidy_ratings <- ratings %>%
    # Gather and convert episode to factor.
    # factor_key: maintains the original order of columns
    # na.rm: removes the missing values from value
	gather(key = "episode", value = "viewers_7day", -series,
           factor_key = TRUE, na.rm = TRUE) %>%
	# Sort in ascending order by series and episode
    arrange(series, episode) %>%
	# Create new variable using row_number()
    mutate(episode_count = row_number())

# Plot viewers by episode and series
ggplot(tidy_ratings, aes(x = episode_count,
                y = viewers_7day,
                fill = series)) +
    geom_col()

# 2. Gather & plot non-sequential columns
week_ratings <- ratings2  %>%
	# Select 7-day viewer ratings
    select(series, ends_with("7day")) %>%
	# Gather 7-day viewers by episode
    gather(episode, viewers_7day, ends_with("7day"), na.rm = TRUE, factor_key = TRUE)

# Plot 7-day viewers by episode and series
ggplot(week_ratings, aes(x = episode,
                         y = viewers_7day,
                         group = series)) +
    geom_line() +
    facet_wrap(~series)

# B. Separate()
# 1. Separate a column
# tidyr, dplyr, and readr packages
# Create week_ratings
week_ratings <- ratings2 %>%
    select(series, ends_with("7day")) %>%
    gather(episode, viewers_7day, ends_with("7day"),
           na.rm = TRUE) %>%
    separate(episode, into = "episode", extra = "drop") %>%
    mutate(episode = parse_number(episode))

# Edit your code to color by series and add a theme
ggplot(week_ratings, aes(x = episode, y = viewers_7day,
                         group = series, color = series)) +
    geom_line() +
    facet_wrap(~series) +
    guides(color = FALSE) +
    theme_minimal()

# 2. Unite columns
ratings3 <- ratings2  %>%
	# Unite and change the separator
	unite(viewers_7day, viewers_millions, viewers_decimal, sep = "") %>%
	# Adapt to cast viewers as a number
	mutate(viewers_7day = as.numeric(viewers_7day))

# Print to view
ratings3

# 3. Spread rows into columns
# Create tidy data with 7- and 28-day viewers
tidy_ratings_all <- ratings2 %>%
    gather(episode, viewers, ends_with("day"), na.rm = TRUE) %>%
    separate(episode, into = c("episode", "days")) %>%
    mutate(episode = parse_number(episode),
           days = parse_number(days))

tidy_ratings_all %>%
	# Count viewers by series and days
    count(series, days, wt = viewers) %>%
	# Adapt to spread counted values
    spread(days, n, sep = "_")

# C. Tidy mulitple sets of columns
# 1. Tidy 1
# Fill in blanks to get premiere/finale data
tidy_ratings <- ratings %>%
    gather(episode, viewers, -series, na.rm = TRUE) %>%
    mutate(episode = parse_number(episode)) %>%
    group_by(series) %>%
    filter(episode == 1 | episode == max(episode)) %>%
    ungroup()

# 2. Tidy 2
# Recode first/last episodes
first_last <- tidy_ratings %>%
  mutate(episode = recode(episode, `1` = "first", .default = "last"))

# Fill in to make slope chart
ggplot(first_last, aes(x = episode, y = viewers, color = series)) +
  geom_point() +
  geom_line(aes(group = series))

# Switch the variables mapping x-axis and color. This created a dumbell chart which was a better display of the data
ggplot(first_last, aes(x = series, y = viewers, color = episode)) +
  geom_point() + # keep
  geom_line(aes(group = series)) + # keep
  coord_flip() # keep

# 3. Tidy 3
# Calculate relative increase in viewers
bump_by_series <- first_last %>%
  spread(episode, viewers) %>%
  mutate(bump = (last - first) / first)

# Fill in to make bar chart of bumps by series
ggplot(bump_by_series, aes(x = series, y = bump)) +
  geom_col() +
  scale_y_continuous(labels = scales::percent) # converts to %


# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - Mean number of species/ author over the years
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
print(paste0(Sys.time(), " --- Mean number of species/ author over the years"))

# Using the data.frame of each describer and number of species they described,
# the mean and median number of species were obtained for each decade.
spp_per_auth <- df_describers_year[,
    list(mean=mean(N), median=median(N)),
    by=c("date.decade")][order(date.decade)]

df_describers_year[date.decade=="1750s"]

plot_spp_per_auth_per_decade <-
    ggplot(data=spp_per_auth, aes(x=date.decade, y=mean)) +
        geom_bar(stat='identity') +
        xlab("\nDecade") + ylab("Mean number of species \ndescribed per PTE per year\n") +
        theme + scale_fill_grey()

ggsave(
    paste0(dir_plot, 'fig-3.png'),
    plot_spp_per_auth_per_decade, units="cm", width=21, height=5, dpi=300
)

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - Number of authors/ publication over the years
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
print(paste0(Sys.time(), " --- Number of authors/ publication over the years"))

n_auth <- df[, c("date", "date.decade", "idx", "full.name.of.describer")] %>%
    separate_rows(full.name.of.describer, sep="; ")
n_auth <- data.table(n_auth)[order(idx)]
n_auth <- n_auth[, list(N=.N), by=c("date", "date.decade", "idx")]
n_auth$N <- as.character(n_auth$N)

calc_median <- function(x){
  return(c(y = -5, label = length(x)))
  # experiment with the multiplier to find the perfect position
}

median_auth_per_sp_decade <- n_auth[, list(median_n_auth=median(as.numeric(N))),
                                      by='date.decade'][order(date.decade)]

plot_n_auth_per_decade <-
    ggplot(data=n_auth, aes(x=date.decade, fill=N)) +
        geom_bar(position = "fill") +
        xlab("\nDecade") + ylab("Proportion of number \nof PTEs per species description\n") +
        theme + scale_fill_grey()

ggsave(paste0(dir_plot, 'fig-4.png'), plot_n_auth_per_decade, units="cm", width=21, height=5, dpi=300)


library(tidyverse)
library(urbnmapr)
library(viridis)

# Add Data
county.gdp <- readr::read_csv("bea_county_gdp.csv", quote="\'", col_names=T)

# Calculate per capita measures
county.gdp$pc.gdp.2012 <- county.gdp$allindustries_2012/county.gdp$pop_2012
county.gdp$pc.gdp.2013 <- county.gdp$allindustries_2013/county.gdp$pop_2013
county.gdp$pc.gdp.2014 <- county.gdp$allindustries_2014/county.gdp$pop_2014
county.gdp$pc.gdp.2015 <- county.gdp$allindustries_2015/county.gdp$pop_2015

# Create full names for future labels
county.gdp$full_name <- ifelse(county.gdp$state_name=="AK",
  str_c(county.gdp$county_name,", ", county.gdp$state_name),
  ifelse(county.gdp$state_name=="LA",
    str_c(county.gdp$county_name, " Parish",", ", county.gdp$state_name) ,str_c(county.gdp$county_name, " County",", ", county.gdp$state_name)))

county.gdp$int <- paste(county.gdp$specialize,county.gdp$metro, sep=".")
# Scatter Plot
p.2015 <- ggplot(county.gdp) +
  aes(x = log(pop_2015), y = log(pc.gdp.2015)) +
  geom_point(alpha = 0.75, size = 1.5, aes(shape = int, color = int)) +
  geom_text(aes(label=ifelse(log(pc.gdp.2015)>5.75,as.character(full_name),'')), hjust=0, vjust=0, nudge_x = 0.05, nudge_y = 0.05, size = 3, family="Open Sans Condensed Light") +
  geom_text(aes(label=ifelse(log(pc.gdp.2015)<2,as.character(full_name),'')), hjust=0, vjust=0, nudge_x = 0.05, nudge_y = 0.05, size = 3, family="Open Sans Condensed Light") +
  geom_smooth(method = "lm", se = FALSE, size=0.5, color="#2b2b2b", alpha=0.5) +
  # Shape and color
  scale_color_brewer(name = "Metro & Specialization",
    palette="Paired")+
  scale_shape_manual(name = "Metro & Specialization",
    values = rep(16:17,6)) +
  scale_x_continuous(breaks = c(6,8,10,12,14,16)) +
  guides(col = guide_legend(nrow = 2, title.position = "top")) +
  # Theming
  labs(
    title="County-level Gross Domestic Product",
    subtitle="Log per capita GDP & log population, All U.S. counties, 2015",
    caption="Author: Chris Goodman (@cbgoodman), Data: U.S. Bureau of Economic Analysis (experimental), U.S. Census Bureau & U.S. Department of Agricutlure Economic Research Service.",
    y="Log of Per Capita GDP",
    x="Log of Population") +
  theme_minimal(base_family="Open Sans Condensed Light") +
  theme(
    legend.position = "bottom",
    legend.title.align = 0.5,
    legend.text.align = 0) +
  # light, dotted major y-grid lines only
  theme(panel.grid=element_line())+
  theme(panel.grid.major.y=element_line(color="#2b2b2b", linetype="dotted", size=0.15))+
  theme(panel.grid.major.x=element_blank())+
  theme(panel.grid.minor.x=element_blank())+
  theme(panel.grid.minor.y=element_blank())+
  # light x-axis line only
  theme(axis.line=element_line())+
  theme(axis.line.y=element_blank())+
  theme(axis.line.x=element_blank())+
  # tick styling
  theme(axis.ticks=element_line())+
  theme(axis.ticks.x=element_blank())+
  theme(axis.ticks.y=element_blank())+
  theme(axis.ticks.length=unit(5, "pt"))+
  # x-axis labels
  theme(axis.text.x=element_text(size=10, hjust=0.95,vjust=0.2))+
  # breathing room for the plot
  theme(plot.margin=unit(rep(0.5, 4), "cm"))+
  # move the y-axis tick labels over a bit
  theme(axis.text.y=element_text(margin=margin(r=-5)))+
  theme(axis.text.x=element_text(margin=margin(r=-5)))+
  # make the plot title bold and modify the bottom margin a bit
  theme(plot.title=element_text(family="Open Sans Condensed Bold", margin=margin(b=15)))+
  # make the subtitle italic
  theme(plot.subtitle=element_text(family="Open Sans Condensed Light Italic"))+
  theme(plot.caption=element_text(size=8, hjust=0, margin=margin(t=15)))
ggsave(plot=p.2015, "gdp-2015-grouped.png", width=10, height=7, units="in", dpi="retina")

summary(lm(data=county.gdp, log(pc.gdp.2015)~log(pop_2015)))

# Mapping
county.gdp.data <- left_join(county.gdp, counties, by = "county_fips")

#################################################
# Pretty Breaks
pretty.breaks <- c(24,31,40,52)
# find min and max values of pop growth
minVal <- min(county.gdp.data$pc.gdp.2015, na.rm = T)
maxVal <- max(county.gdp.data$pc.gdp.2015, na.rm = T)
# compute pop growth labels
labels <- c()
brks <- c(minVal, pretty.breaks, maxVal)
# round the labels (actually, only the extremes)
labels <- c()
for(idx in 1:length(brks)){
  labels <- c(labels, paste0(round(brks[idx], 2),
  " – ",
  round(brks[idx + 1], 2)))
}
# Minus one label to remove the odd ending one
labels <- labels[1:length(labels)-1]

# Create new variable for fill
county.gdp.data$brks <- cut(county.gdp.data$pc.gdp.2015,
  breaks = brks,
  labels = labels,
  include.lowest = T)

p <- ggplot() +
  # County Map
  geom_polygon(data = county.gdp.data,
    mapping = aes(x = long, y = lat, group = group,
    fill = county.gdp.data$brks),
    #color = alpha("white", 1 / 2),
    #size = 0.2
  ) +
  # State Map
  geom_polygon(data = urbnmapr::states, mapping = aes(long, lat, group = group),
    fill = NA, color = "#ffffff", size = 0.25, alpha=0.5) +
  # Projection
  coord_map(projection = "polyconic") +
  scale_fill_viridis(
    option = "viridis",
    name = "Per capita GDP",
    discrete = T,
    direction = 1,
    begin=0.1,
    #end=0.9,
    guide = guide_legend(
      keyheight = unit(5, units = "mm"),
      title.position = 'top',
      #reverse = F
  )) +
  # Theming
  theme_minimal(base_family = "Open Sans Condensed Light") +
  theme(
    legend.position = "bottom",
    legend.text.align = 0,
    legend.title.align = 0.5,
    plot.margin = unit(c(.5,.5,.2,.5), "cm")) +
  theme(
    axis.line = element_blank(),
    axis.text.x = element_blank(),
    axis.text.y = element_blank(),
    axis.ticks = element_blank(),
    axis.title.x = element_blank(),
    axis.title.y = element_blank(),
    panel.grid.major = element_blank(),
    panel.grid.minor = element_blank(),
    ) +
  theme(plot.title=element_text(family="Open Sans Condensed Bold", margin=margin(b=15))) +
  theme(plot.subtitle=element_text(family="Open Sans Condensed Light Italic")) +
  theme(plot.margin=unit(rep(0.5, 4), "cm")) +
  labs(x = "",
       y = "",
       title = "County-level Gross Domestic Product",
       subtitle = "Per capita GDP ($1,000s), U.S. counties, 2015",
       caption = "Author: Chris Goodman (@cbgoodman), Data: U.S. Bureau of Economic Analysis (experimental) & U.S. Census Bureau.")

ggsave(plot=p, "county-gdp-15.png", width=10, height=8, units="in", dpi="retina")


# https://github.com/mulargui/Kaggle---Walmart-forecast-challenge

#working directory
setwd("C:/mauricio/Dropbox/vagrant/apps/Kaggle---Walmart-forecast-challenge")

library("dplyr")

#load data
dftrain <- read.csv("train.csv", header=TRUE)
dftest <- read.csv("test.csv", header=TRUE)

#Add Seasonality Column based on factor of Date
dftrain[,"Seasonality"] <- (as.numeric(dftrain$Date) %% 52) + 1
dftest[,"Seasonality"] <- ((as.numeric(dftest$Date) + 143) %% 52) + 1

#Add Year column
dftrain[,"Year"] <- (as.numeric(format(as.Date(dftrain$Date), "%Y")))
dftest[,"Year"] <- (as.numeric(format(as.Date(dftest$Date), "%Y")))

#Add previous year column to the test dataset
dftest[,"PYear"] <- dftest$Year - 1

#adjust sales in weeks 47, 48 and 49 in 2011 to have same number of sale days in week 49 than in 2012
dfchristmas <- dftrain %>% filter(Year == 2011) %>% filter((Seasonality == 47) | (Seasonality == 48) | (Seasonality == 49))

# for every store (45)
for (i in 1:45)
{
	#for every department (99)
	for (j in 1:99)
	{
			#do we have train data?
			dfsample <- dfchristmas %>%
				filter(Store == i) %>%
				filter(Dept == j)
			if(nrow(dfsample) < 3) next
			inc_sales <- sum(dfsample$Weekly_Sales) / 21
			#inc_sales <- sum(dfsample$Weekly_Sales) * 2 / 8
			old <- dfsample$Weekly_Sales[(dfsample$Seasonality == 47)]
			dftrain$Weekly_Sales[(dftrain$Store==i)&(dftrain$Dept == j)&(dftrain$Seasonality == 47)&(dftrain$Year == 2011)] <- old - inc_sales
			old <- dfsample$Weekly_Sales[(dfsample$Seasonality == 48)]
			dftrain$Weekly_Sales[(dftrain$Store==i)&(dftrain$Dept == j)&(dftrain$Seasonality == 48)&(dftrain$Year == 2011)] <- old - inc_sales
			old <- dfsample$Weekly_Sales[(dfsample$Seasonality == 49)]
			dftrain$Weekly_Sales[(dftrain$Store==i)&(dftrain$Dept == j)&(dftrain$Seasonality == 49)&(dftrain$Year == 2011)] <- old + (2 * inc_sales)
	}
}

#Weekly_Sales are last year sales
dfresult <- merge(dftest, dftrain, by.x = c("Store","Dept", "Seasonality", "PYear"),
	by.y = c("Store","Dept", "Seasonality", "Year"), all.x = TRUE)

#for depts with no data use 0 sales
dfresult$Weekly_Sales[is.na(dfresult$Weekly_Sales)] <- 0

#preparing the submission file
#Adding a column with store_department_date
dfresult[,"Id"] <- paste(dfresult$Store, dfresult$Dept, format(as.Date(dfresult$Date.x), "%Y-%m-%d" ), sep = "_")

#save results in a csv file
write.csv(file = "Solution9.csv", x = subset(dfresult, select = c(Id, Weekly_Sales)), row.names=FALSE)


mtcars

nrow(mtcars)
ncol(mtcars)

head(mtcars)
head(mtcars, n=3)

tail(mtcars)
tail(mtcars, n= 3)

x <- mtcars[4,3]
x
x <- mtcars["Hornet 4 Drive", "disp"]
x
x <- mtcars["Hornet 4 Drive",]$disp
x

y<- mtcars[[3]]
y
y<- mtcars[["disp"]]
y
y<- mtcars$disp
y

mtcars[[3]][2] <- 0
mtcars

filter <- (mtcars$cyl > 6) & (mtcars$am == 0)
filter
jaki.rucni <- mtcars[filter,]
jaki.rucni

filter <- (mtcars$cyl > 6) & (mtcars$am == 0)
filter
jaki.rucni <- mtcars[filter, c("cyl", "hp", "disp")]
jaki.rucni


if (!require("rWBclimate")) install.packages("rWBclimate")
if (!require("ggplot2")) install.packages("ggplot2")

##### country list
country.list <- c("VNM","THA","KHM","LAO")

#country.dat <- get_historical_precip(country.list,"year")
country.dat <- get_historical_temp(country.list,"year")

ggplot(country.dat,aes(x=year,y=data,group=locator)) +
  geom_point() +
  geom_path() +
  ylab("Average annual precipitation") +
  theme_bw() +
  xlab("Year") +
  stat_smooth(se=F,colour="red") +
  facet_wrap(~locator,scale="free")


parse_model_identifier <- function(string) {

    #' Parses model identifier into a list of parameters

    #' Parses a specific model identifier into a list of parameter.
    #'
    #' @param string The string that is to be decomposed into a list of
    #' parameters.

    model_params <- list()
    string <- strsplit(string, "-")[[1]]

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

        if (i == 1) {

            model_params$dataset <- substr(string[i], 1, 2)     #
            model_params$ll <- substr(string[i], 3, 3)
            # "Y" for using lat lon / "N" for using country distribution

        } else {

            first_letter <- substr(string[i], 1, 1)

            if (first_letter == "E" ) { # taxonomic effort
                model_params$te <-
                  as.numeric(substr(string[i], 2, nchar(string[i])))
            }

            if (first_letter == "C") { # chains
                model_params$chains <-
                  as.numeric(substr(string[i], 2, nchar(string[i])))
            }

            if (first_letter == "I") { # iterations
                model_params$iter <-
                  as.numeric(substr(string[i], 2, nchar(string[i])))
            }

            if (first_letter == "A") { # adapt delta
                model_params$ad <-
                  as.numeric(substr(string[i], 2, nchar(string[i])))
            }

            if (first_letter == "T") { # tree depth
                model_params$td <-
                  as.numeric(substr(string[i], 2, nchar(string[i])))
            }

        }
    }

    model_params
}

# Test
# string <- "BMY-C4-I5000-A0.99-T15"
# parse_model_identifier(string)

initialize_model_params <- function(model_params, custom=NA) {

    #' Parses list of model params and initializes necessary folders
    #'
    #' Parses list of model params into a model identifier and
    #' initializes necessary folders. Returns the model folder directory.
    #' @model_params list The list that contains a list of model parameters.

	model_identifier <- paste0(
		model_params$dataset, model_params$ll, "-",
		"E", as.character(model_params$te), "-",
		"C", as.character(model_params$chains), "-",
		"I", as.character(model_params$iter), "-",
		"A", as.character(model_params$ad), "-",
		"T", as.character(model_params$td)
	)

	# Define model folder
	dir_model_folder <- paste0(dir_analysis_edie_model, "/",
							   model_identifier, "/")
	if(!is.na(custom)) dir_model_folder <- custom

	# Create folders
	dir.create(dir_model_folder)
	dir.create(file.path(dir_model_folder, 'output'))

	# Create log files
	filepath_log <- paste0(dir_model_folder, "/model.log")
	if (!file.exists(filepath_log)) file.create(filepath_log)

	warnings_log <- paste0(dir_model_folder, "/warnings.log")
	if (!file.exists(warnings_log)) file.create(warnings_log)

	c(dir_model_folder,
	  filepath_log,
	  warnings_log,
	  model_identifier)

}

write_to_log <- function(w, warn_log_fp) {

    #' Writes warning to warning logfile

    #' Writes warning to logfile in specified path.
	#'
    #' @param w Warning output from a try-catch block.
    #' @param warn_log_fp Warning log filepath. Should be a .log file.

    write(conditionMessage(w), file = warn_log_fp, append = TRUE)
}

sample_model_posterior_parameters <- function(model) {

    #' Samples from model's posterior
    #'
    #' Returns a list of sampled model parameters
	#'
    #' @param model Model dumped from rstan

    outs <- extract(model, permuted = TRUE) # posterior

    # ACP

	# t=1
    phi <- apply(outs$phi, 2, function(x) sample(x, 1))

	# t>1

	# Autoregressive terms
    alp <- apply(outs$alpha, 2, function(x) sample(x, 1))
    bet <- apply(outs$beta, 2, function(x) sample(x, 1))

    # Regression portion
    coef0 <- apply(outs$delta[, , 1], 2, function(x) sample(x, 1))
    coef1 <- apply(outs$delta[, ,2], 2, function(x) sample(x, 1))

    # markov
    gam <- apply(outs$gamma, 2, function(x) sample(x, 1))
    eta <- apply(outs$eta, 2, function(x) sample(x, 1))

	list(
		phi=phi,

		gam=gam,
		eta=eta,
		coef0=coef0,
		coef1=coef1,

		alp=alp,
		bet=bet
	)

}

posterior_sim <- function(data, model) {

	#' Sample from posterior parameters for checking model fit
	#'
	#' Return sampled counts for each year by group
	#'
	#' @param over If over = T, use negative binomial, otherwise use
	#' zero-inflated Poisson

	# Sample from model posterior
	mp <- sample_model_posterior_parameters(model)
	list2env(mp, .GlobalEnv); rm(mp)

	# Number of groups
	p <- data$P

	# Starting counts of the different groups
	initial <- sapply(seq(p), function(pp) data$counts[pp, data$str[pp]])

	# By group
	sims <- list()
	for(ii in seq(p)) {

		# Offset segment starts at first year
		start <- data$str[ii]
		end <- data$end[ii]
		toff <- data$off[ii, ][start:end]

		# By time point

		# Initialize parameters
		lambda <- c()
		theta <- c()
		oo <- c()

		# Set first time point
		lambda[1] <- phi[ii]
		theta[1] <- 0
		oo[1] <- initial[ii]

		# Set subsequent time points
		for(jj in seq(2, end - start + 1)) {

			lambda[jj] <- exp(coef0[ii] + coef1[ii] * jj) +
						  alp[ii] * oo[jj - 1] +
						  bet[ii] * lambda[jj - 1]

			z <- ifelse(oo[jj - 1] == 0, 1, 0)

			theta[jj] <- (z * gam[ii]) +
						 ((1 - z) * eta[ii])

			oo[jj] <- gamlss.dist::rZIP(
				1,
				mu = (toff[jj] + 1) * lambda[jj],
				sigma = theta[jj]
			)

		}

		oo <- c(rep(0, start - 1), oo) # pad with 0s
		sims[[ii]] <- oo

	}

	sims
}

posterior_forecast <- function(data, ftime, model) {

	#' Make predictions for time series
	#'
	#' Given a model, make predictions based on a predefined timestep
	#'
	#' @param data Data as output by initial data processing step
	#' i.e. count_info.data.R
	#' @param ftime Number of years to predict
	#' @param model rStan model i.e. fit.data

	# Sample from model posterior
	mp <- sample_model_posterior_parameters(model)
	list2env(mp); rm(mp)

	# Number of groups
	p <- data$P

	# Initial number of species for each group
	initial <- sapply(seq(p), function(pp) data$counts[ pp, data$str[pp]])

	# By group
	out <- list()
	for(ii in seq(p)) {

		start <- data$str[ii]
		end <- data$end[ii]

		# Offset starts at first naming year
		all_toff <- data$off[ii, ][start:end]
		len <- length(all_toff)

		# Generate offset segment by sampling past ftime of offsets
		# TODO: use naive method from
		# https://otexts.com/fpp2/simple-methods.html
		toff <- sample(all_toff[(len-ftime):len], ftime, replace = TRUE)

		# By time point

		# Initialize parameters
		lambda <- c()
		theta <- c()
		oo <- data$counts[ii, end] # final year's count
		co <- c() # empty expected count vec

		# Set first time point
		lambda[1] <- oo
		theta[1] <- 0
		co[1] <- oo[1]

		# set subsequent time points
		for(jj in 2:ftime) {

			lambda[jj] <- exp(coef0[ii] + coef1[ii] * jj) +
						  alp[ii] * oo[jj - 1] +
						  bet[ii] * lambda[jj - 1]

			z <- ifelse(oo[jj - 1] == 0, 1, 0)

			theta[jj] <- (z * gam[ii]) +
					     ((1 - z) * eta[ii])

			co[jj] <- gamlss.dist::rZIP(
				1,
				mu = (toff[jj] + 1) * lambda[jj],
				sigma = theta[jj]
			)

			oo[jj] <- co[jj] # current count becomes next expected count

		}

		out[[ii]] <- co
	}

	out
}


setwd('/Users/Cam/Desktop/Code/bin/kaggle_code/california_housing')
library(tidyverse)
library(reshape2)
library(boot)
library(randomForest)

housing = read.csv('./housing.csv')

housing$total_bedrooms[is.na(housing$total_bedrooms)] = median(housing$total_bedrooms , na.rm = TRUE)

housing$mean_bedrooms = housing$total_bedrooms/housing$households
housing$mean_rooms = housing$total_rooms/housing$households

drops = c('total_bedrooms', 'total_rooms')

housing = housing[ , !(names(housing) %in% drops)]

categories = unique(housing$ocean_proximity)
#split the categories off
cat_housing = data.frame(ocean_proximity = housing$ocean_proximity)

for(cat in categories){
    cat_housing[,cat] = rep(0, times= nrow(cat_housing))
}
head(cat_housing) #see the new columns on the right

for(i in 1:length(cat_housing$ocean_proximity)){
    cat = as.character(cat_housing$ocean_proximity[i])
    cat_housing[,cat][i] = 1
}

cat_columns = names(cat_housing)
keep_columns = cat_columns[cat_columns != 'ocean_proximity']
cat_housing = select(cat_housing,one_of(keep_columns))
drops = c('ocean_proximity','median_house_value')
housing_num =  housing[ , !(names(housing) %in% drops)]

scaled_housing_num = scale(housing_num)

cleaned_housing = cbind(cat_housing, scaled_housing_num, median_house_value=housing$median_house_value)

set.seed(19) # Set a random seed so that same sample can be reproduced in future runs

sample = sample.int(n = nrow(cleaned_housing), size = floor(.8*nrow(cleaned_housing)), replace = F)
train = cleaned_housing[sample, ] #just the samples
test  = cleaned_housing[-sample, ] #everything but the samples

train_y = train[,'median_house_value']
train_x = train[, names(train) !='median_house_value']

test_y = test[,'median_house_value']
test_x = test[, names(test) !='median_house_value']

########
# Random Forest Model
########
rf_model = randomForest(train_x, y = train_y , ntree = 500, importance = TRUE)

names(rf_model) #these are all the different things you can call from the model.

importance_dat = rf_model$importance
importance_dat

sorted_predictors = sort(importance_dat[,1], decreasing=TRUE)
sorted_predictors

oob_prediction = predict(rf_model) #leaving out a data source forces OOB predictions

#you may have noticed that this is avaliable using the $mse in the model options.
#but this way we learn stuff!
train_mse = mean(as.numeric((oob_prediction - train_y)^2))
oob_rmse = sqrt(train_mse)
oob_rmse

y_pred_rf = predict(rf_model , test_x)
test_mse = mean(((y_pred_rf - test_y)^2))
test_rmse = sqrt(test_mse)
test_rmse # ~48620

######
# XG Boost
######
# http://cran.fhcrc.org/web/packages/xgboost/vignettes/xgboost.pdf
library(xgboost)

#put into the xgb matrix format
dtrain = xgb.DMatrix(data =  as.matrix(train_x), label = train_y )
dtest = xgb.DMatrix(data =  as.matrix(test_x), label = test_y)

# these are the datasets the rmse is evaluated for at each iteration
watchlist = list(train=dtrain, test=dtest)

# try 1 -off a set of paramaters I know work pretty well generally

bst = xgb.train(data = dtrain,
				max.depth = 8,
				eta = 0.3,
				nthread = 2,
				nround = 1000,
				watchlist = watchlist,
				objective = "reg:linear",
				early_stopping_rounds = 50)

# try a 'slower learning' model. The up and down weights for each iteration are smaller
# we also use more iterations

bst_slow = xgb.train(data = dtrain,
						max.depth=6,
						eta = 0.01,
						nthread = 2,
						nround = 10000,
						watchlist = watchlist,
						objective = "reg:linear",
						early_stopping_rounds = 50)

# note the best iteration is not the last iteration.
XGBoost_importance = xgb.importance(feature_names = names(train_x), model = bst_slow)
XGBoost_importance[1:10]

# rmse: 45225.968750 # max.depth=5
#last week: $48620 with random forest
# an improvement of ~$3400 in average error. Wait! What we have done here is fit to the training set (leading to model overfit). Need to work with a validation set, then only at the end evaluate the model performance against the test set.

####
# Proper use - validation set
####

#validation set - Another subset of our data that is witheld from the training algorithm, but compared against at each iteration to see how

#make validation set

set.seed(19) # Set a random seed so that same sample can be reproduced in future runs

sample = sample.int(n = nrow(train), size = floor(.8*nrow(train)), replace = F)

train_t = train[sample, ] #just the samples
valid  = train[-sample, ] #everything but the samples

train_y = train_t[,'median_house_value']
train_x = train_t[, names(train_t) !='median_house_value']

valid_y = valid[,'median_house_value']
valid_x = valid[, names(train_t) !='median_house_value']

gb_train = xgb.DMatrix(data = as.matrix(train_x), label = train_y )
gb_valid = xgb.DMatrix(data = as.matrix(valid_x), label = valid_y)

# train xgb, evaluating against the validation
watchlist = list(train = gb_train, valid = gb_valid)

bst_slow = xgb.train(data= gb_train,
						max.depth = 10,
						eta = 0.01,
						nthread = 2,
						nround = 10000,
						watchlist = watchlist,
						objective = "reg:linear",
						early_stopping_rounds = 50)

# error, need the matrix format
y_hat = predict(bst_slow, test_x)

# recall we ran the following to get the test data in the right format:
# dtest = xgb.DMatrix(data =  as.matrix(test_x), label = test_y)
# here I have it with the label taken off, just to remind us its external data xgb would ignore the label though during predictions
dtest = xgb.DMatrix(data =  as.matrix(test_x))

#test the model on truly external data

y_hat_valid = predict(bst_slow, dtest)

test_mse = mean(((y_hat_valid - test_y)^2))
test_rmse = sqrt(test_mse)
test_rmse
# ~47507.09 This is higher then on the first run through, but we can be confident that the improved score is not due to overfit thanks to our use of a validation set! point out that this is evidence of how a lower rmse isn't necessarily better, as we now have more confidence in external predictions.2.3% improvement over a basic random forest... is it worth the effort? The answer to this question always depends on the purpose of the model.

###
# Grid search first principles
###

max.depths = c(3, 5, 7, 9)
etas = c(0.01, 0.001, 0.0001)

best_params = 0
best_score = 0

count = 1
for( depth in max.depths ){
	for( num in etas){

		bst_grid = xgb.train(data = gb_train,
								max.depth = depth,
								eta=num,
								nthread = 2,
								nround = 10000,
								watchlist = watchlist,
								objective = "reg:linear",
								early_stopping_rounds = 50,
								verbose=0)

		if(count == 1){
			best_params = bst_grid$params
			best_score = bst_grid$best_score
			count = count + 1
			}
		else if( bst_grid$best_score < best_score){
			best_params = bst_grid$params
			best_score = bst_grid$best_score
		}
	}
}

best_params
best_score
#valid-rmse: 47033.28

# max_depth of 9, eta of 0.01
bst_tuned = xgb.train( data = gb_train,
						max.depth = 9,
						eta = 0.01,
						nthread = 2,
						nround = 10000,
						watchlist = watchlist,
						objective = "reg:linear",
						early_stopping_rounds = 50)

y_hat_xgb_grid = predict(bst_tuned, dtest)

test_mse = mean(((y_hat_xgb_grid - test_y)^2))
test_rmse = sqrt(test_mse)
test_rmse # test-rmse: 46675
# By tuning the hyperparamaters we have moved to a 4% improvement over random forest

#######
# tweak the hyperparamaters using a grid search
# The caret package (short for classification and regression training)
######

library(caret)

# look up the model we are running to see the paramaters
modelLookup("xgbLinear")

# set up all the pairwise combinations

xgb_grid_1 = expand.grid(nrounds = c(1000,2000,3000,4000) ,
							eta = c(0.01, 0.001, 0.0001),
							lambda = 1,
							alpha = 0)
xgb_grid_1

#here we do one better then a validation set, we use cross validation to
#expand the amount of info we have!
xgb_trcontrol_1 = trainControl(method = "cv",
								number = 5,
								verboseIter = TRUE,
								returnData = FALSE,
								returnResamp = "all",
								allowParallel = TRUE)

######
#below a grid-search, cross-validation xgboost model in caret
######
# train the model for each parameter combination in the grid, using CV to evaluate on multiple folds. Make sure your laptop is plugged in or RIP battery.

# note how this is now the caret train function
?train

xgb_train_1 = train(x = as.matrix(train_x),
					y = train_y,
					trControl = xgb_trcontrol_1,
					tuneGrid = xgb_grid_1,
					method = "xgbLinear",
					max.depth = 5)

names(xgb_train_1)
xgb_train_1$bestTune
xgb_train_1$method
summary(xgb_train_1)

#alternatively, you can 'narrow in' on the best paramaters by taking a range of options around the best values found and seeing if high resolution tweaks can provide even further improvements.

xgb_cv_yhat = predict(xgb_train_1 , as.matrix(test_x))

test_mse = mean(((xgb_cv_yhat - test_y)^2))
test_rmse = sqrt(test_mse)
test_rmse # 46641... pretty close to the 'by hand' grid search!

#Cam's hypothesis - not using 'early stopping rounds' here so the model isn't cutting out at the exact best point. re-running this with a validation setup as opposed to a cv setup would allow us to implement a grid search efficiently and wind up with the best hyperparamaters. I shall leave this as a follow up exercise for the curious.

########
# Ensemble the models together,
# strategy for when accuracy is more important then knowing the best predictors
########

y_pred_rf #random forest
y_hat_valid #xgBoost with validation
y_hat_xgb_grid #xgBoost grid search
xgb_cv_yhat #xgBoost caret cross validation

length(y_hat_xgb_grid)

blend_pred = (y_hat * .25) + (y_pred_rf * .25) + (xgb_cv_yhat * .25) + (y_hat_xgb_grid * .25)
length(blend_pred)

length(blend_pred) == length(y_hat_xgb_grid)

blend_test_mse = mean(((blend_pred - test_y)^2))
blend_test_rmse = sqrt(blend_test_mse)
blend_test_rmse # 45205 by averaging just 4 predictors we have dropped the rmse a few percent lower then the best scoring of the 4 models. This does come at a cost though, we now can't make accurate inferrences about the best predictors!

#next step - you can grid search the weights of the ensemble to try and drop the rmse further!

#######
# Unrelated note
#######
# install.packages("devtools")
# devtools::install_github("brooke-watson/BRRR")

##  [1] "twochainz"  "twochainz1" "bigboi"     "biggie"     "bigsean"
##  [6] "bigsean1"   "bigsean2"   "bigsean3"   "bigsean4"   "bigsean5"
## [11] "bigshaq"    "birdman"    "birdman1"   "birdman2"   "busta"
## [16] "chance"     "desiigner"  "diddy"      "drake"      "drake1"
## [21] "drummaboy"  "fetty"      "flava"      "future"     "gucci"
## [26] "gucci1"     "gucci2"     "jayz"       "jayz1.wav"  "kendrick"
## [31] "khaled"     "khaled1"    "khaled2"    "khaled3"    "liljon"
## [36] "liljon1"    "nicki"      "pitbull"    "ross"       "ross1"
## [41] "schoolboy"  "snoop"      "soulja"     "takeoff"    "tpain.wav"
## [46] "traviscott" "treysongz"  "trick"      "waka"       "weezy"
## [51] "yg"

library('BRRR')
skrrrahh(0) #random
skrrrahh('tpain')
skrrrahh('ross')
skrrrahh('future')
skrrrahh('traviscott')
skrrrahh('desiigner')
skrrrahh('bigshaq')
skrrrahh('twochainz1')
skrrrahh('bigsean3')

#demo the machine learning benefit by running after an xgboost training line.


## Color palettes
# Better version of rainbow() color palette for real data
RGBcolorpal1=hsv(1/(1+exp(seq(-3.8,3.8,length=1000))),1,1)[300:1000]

# Original VGA 16 colors
VGA16colors=c("#000000","#000080","#008000","#008080","#800000","#800080","#808000","#C0C0C0","#808080","#0000FF","#00FF00","#00FFFF","#FF0000","#FF00FF","#FFFF00","#FFFFFF")

# Default hue color palette for ggplot2
ggplotColourHuePallette = function(n=10, h=c(0, 360)+15, c=100, l=65) {
    if((diff(h)%%360) < 1) h[2]=h[2]-360/n
    hcl(h = (seq(h[1], h[2], length = n)), c = c, l = l)
}

# Draw color gradient of x-values
colored_column = function(x, mark=rep(FALSE,length(x)), minx=min(x), maxx=max(x), colmin="blue", colmax="yellow", res=100) {
    ramp = colorRamp(c(colmin, colmax))
    image(x=1, y=1:(length(x)), z=matrix(x,ncol=length(x),nrow=1), axes=F, xlab="", ylab="", col=rgb(ramp(seq(0,1,length=res)),max=255), zlim=c(minx, maxx))
    for(i in 1:length(x)) {
        if(mark[i]) {
            rect(0.6, i-0.5, 1.4, i+0.5, lwd=2)
        }
    }
}

# Scatter plot with marginal histograms
plotxy_marginhists = function(x, y, margins=c(5,5), border=1, h.axis=TRUE, h1.axis=h.axis, h2.axis=h.axis, h.b=20, h1.b=h.b, h2.b=h.b, h.col=8, h1.col=h.col, h2.col=h.col, log="", ...) {
    lmat = matrix(c(2,4,1,3), ncol=2)
    layout(lmat, widths=c(4/5, 1/5), heights=c(1/5, 4/5))

    par(mar=c(0,0,0,0))
    plot(1:1,axes=F,type="n",xlab="",ylab="")

    df = data.frame(x,y)
    if(grepl("x", log)) { df = df[df[,1]>0,] }
    if(grepl("y", log)) { df = df[df[,2]>0,] }
    x = df[,1]
    y = df[,2]

    hx = hist(x, plot=F, breaks=h1.b)
    hy = hist(y, plot=F, breaks=h2.b)
    if(grepl("x", log)) { hx = hist(log(x), plot=F, breaks=h1.b) }
    if(grepl("y", log)) { hy = hist(log(y), plot=F, breaks=h2.b) }

    par(mar=c(0,margins[2],1,1))
    barplot(hx$counts, axes=F, ylim=c(0, max(hx$counts)), space=0, col=h1.col, border=border)
    if(h1.axis) { axis(2) }

    par(mar=c(margins[1],0,1,1))
    barplot(hy$counts, axes=F, xlim=c(0, max(hy$counts)), space=0, col=h2.col, border=border, horiz=TRUE)
    if(h2.axis) { axis(1) }

    par(mar=c(margins[1],margins[2],1,1))
    plot(x, y, log=log, ...)
}

# MA-plot
plot_MA=function(x, y, sig=rep(FALSE,length(x)), ...) {
    x[x<1]=NA
    y[y<1]=NA
    dat=na.omit(cbind(x,y))
    M=log(dat[,1], 2)-log(dat[,2], 2)
    A=0.5*(log(dat[,1],2) + log(dat[,2], 2))
    sigclr=rep(NA,length(x))
    sigclr[sig==TRUE & M>0]=3
    sigclr[sig==TRUE & M<0]=2
    plot(A,M,cex=0.5,pch=1,col=1, ...)
    points(A,M,cex=0.5,pch=20,col=sigclr)
    abline(h=0,col=4)
}

# Density histogram plot
# x2 is optional weights
# multiple lines in same plot with newplot=F
fuzzyhist=function(x,x2=rep(1,length(x)),d=1,n=100,newplot=TRUE,ylab="",...) {
    y=rep(0,length=n)
    z=seq(min(x,na.rm=T),max(x,na.rm=T),length=n)
    rng=max(x,na.rm=T)-min(x,na.rm=T)
    for(i in 1:n) { y[i]=sum((exp(-abs(z[i]-x)*d))*x2,na.rm=T) }
    bs=n/(rng*sum(y,na.rm=T))
    if(newplot) {
        plot(z,y*bs,type="l",ylab=ylab,...)
    } else {
        lines(z,y*bs,...)
    }
}

# Multi-dimensional scaling plot
plotMDS=function(x, cex=0.5, ...) {
    mds=cmdscale(dist(t(x)),k=2)
    plot(mds[,1],mds[,2],xlab="Dimension 1",ylab="Dimension 2",type="n", ...)
    text(mds,names(x), cex=cex)
}

# PCA plot
plotPCA=function(x, cex=0.5, ...) {
    pcafit=prcomp(t(x))
    v1 = round(summary(pcafit)$importance[2,1],2)*100
    v2 = round(summary(pcafit)$importance[2,2],2)*100
    vc = v1 + v2
    plot(pcafit$x[,1], pcafit$x[,2], xlab=paste("PC1 (",v1,"%)",sep=""), ylab=paste("PC2 (",v2,"%)",sep=""), main=paste("PCA ",title," (",vc,"%)",sep=""), type="n", ...)
    text(pcafit$x[,1], pcafit$x[,2], labels=names(x), cex=cex)
}

# Rarefaction curve plot
rarefaction_curve=function(counts, d=100, iter=10, at=seq(1,sum(counts),length=d)) {
    labels = 1:(length(counts))
    probs = counts / sum(counts)
    rmat = matrix(NA, nrow=iter, ncol=length(at))
    for(i in 1:iter) {
        for(j in 1:length(at)) {
            if(ceiling(at[j]) > sum(counts)+1) {
                rmat[i,j] = NA
            } else {
                s = sample(labels, size=ceiling(at[j]), replace=T, prob=probs)
                rmat[i,j] = length(levels(factor(s)))
            }
        }
    }
    rvec = apply(rmat, 2, mean)
    rvec
}

# 2D Kernal density plot
drawAbundHeatmap = function(fin, fout) {
    res=500
    x=read.table(file=fin, header=F)
    jpeg(filename=fout, width=res, height=res, quality=100)
    par(mar=c(0,0,0,0))
    kd=kde2d(x[,1],30000-x[,2],n=res,lims=c(0,30000,0,30000),h=c(2000,2000))
    image(kd$x,kd$y,sqrt(kd$z),col=RGBcolorpal1[150:700])
    dev.off()
}

plotCrossCorr = function(x1, x2, title=NULL, method="kendall") {
    require(ggplot2)
    df = NULL
    for(i in 1:ncol(x1)) {
        for(j in 1:ncol(x2)) {
            ijrow = c(colnames(x1)[i], colnames(x2)[j], cor(x1[,i], x2[,j], method=method), cor.test(x1[,i], x2[,j], method="kendall")$p.value, 1, NA)
            if(is.null(df)){
                df = ijrow
            } else {
                df = rbind(df, ijrow)
            }
        }
    }
    df = data.frame(row.names=NULL, df)
    colnames(df) = c("Env","Taxa","Correlation","Pvalue","AdjPvalue","Significance")
    df$Pvalue = as.numeric(as.character(df$Pvalue))
    df$AdjPvalue = as.numeric(as.character(df$AdjPvalue))
    df$Correlation = as.numeric(as.character(df$Correlation))
    df$AdjPvalue = p.adjust(df$Pvalue, method="BH")
    df$Significance<-cut(df$AdjPvalue, breaks=c(-Inf, 0.001, 0.01, 0.05, Inf), label=c("***", "**", "*", ""))

    p = ggplot(aes(x=Env, y=Taxa, fill=Correlation), data=df) +
        geom_tile() + scale_fill_gradient2(limits=c(-1,1), low="#2C7BB6", mid="white", high="#D7191C") +
        theme(axis.text.x = element_text(angle = 90, hjust = 1, vjust=0.5)) +
        geom_text(aes(label=Significance), color="black", size=3) +
        labs(y=NULL, x=NULL, fill=method)
    if(!is.null(title)) {
        p = p + ggtitle(title)
    }
    print(p)
}

## The following plots assume: df, kfit, pcafit, apres
#
# read in the data into df, where the first column is the labels, choose a number of clusters k (here k=4)
# kfit = kmeans(df[,-1], 4)
# pcafit = prcomp(df[,-1])
# plotPcaKmeans(pcafit, kfit, df[,1], "PCA, kmeans(4)")
#
# library(apcluster)
# apres = apcluster(negDistMat(r=2), df[,-1], details=TRUE, q=0)
# plotPcaAPcluster(pcafit, apres, df[,1])

plotPcaAPcluster = function(pcafit, apres, lab=NA, title="") {
    v1 = round(summary(pcafit)$importance[2,1],2)*100
    v2 = round(summary(pcafit)$importance[2,2],2)*100
    vc = v1 + v2
    plot(apres, cbind(pcafit$x[,1],pcafit$x[,2]), xlab=paste("PC1 (",v1,"%)",sep=""), ylab=paste("PC2 (",v2,"%)",sep=""), main=paste("PCA ",title," (",vc,"%)",sep=""))
    text(pcafit$x[,1], pcafit$x[,2], labels=lab, cex=0.5, col=1)
}

plotPcaKmeans = function(pcafit, kfit, lab, title="") {
    clrpal = c(2,3,4,6)
    v1 = round(summary(pcafit)$importance[2,1],2)*100
    v2 = round(summary(pcafit)$importance[2,2],2)*100
    vc = v1 + v2
    plot(pcafit$x[,1],pcafit$x[,2],xlab=paste("PC1 (",v1,"%)",sep=""),ylab=paste("PC2 (",v2,"%)",sep=""),main=paste("PCA ",title," (",vc,"%)",sep=""),pch=5,col=8)
    text(pcafit$x[,1],pcafit$x[,2],labels=lab,cex=0.5,col=clrpal[kfit$cluster])
}

plotPCAfit = function(pcafit, lab, title="", col=8, pch=5, ...) {
    v1 = round(summary(pcafit)$importance[2,1],2)*100
    v2 = round(summary(pcafit)$importance[2,2],2)*100
    vc = v1 + v2
    plot(pcafit$x[,1], pcafit$x[,2], xlab=paste("PC1 (",v1,"%)",sep=""), ylab=paste("PC2 (",v2,"%)",sep=""), main=paste("PCA ",title," (",vc,"%)",sep=""), pch=pch, col=col)
    text(pcafit$x[,1], pcafit$x[,2], labels=lab, cex=0.5, col=col)
}

plotPcaBiplot = function(pcafit, lab, vec.lines=T, title="") {
    labvar=rownames(pcafit$r)
    v1 = round(summary(pcafit)$importance[2,1],2)*100
    v2 = round(summary(pcafit)$importance[2,2],2)*100
    vc = v1 + v2
    plot(pcafit$x[,1],pcafit$x[,2],xlab=paste("PC1 (",v1,"%)",sep=""),ylab=paste("PC2 (",v2,"%)",sep=""),main=paste("PCA ",title," (",vc,"%)",sep=""),type="n",xlim=c(min(pcafit$x[,1]),max(pcafit$x[,1]))*1.1,ylim=c(min(pcafit$x[,2]),max(pcafit$x[,2]))*1.1)
    text(pcafit$x[,1],pcafit$x[,2],labels=lab,cex=0.5,col=1)
    par(new=T)
    plot(pcafit$r[,1],pcafit$r[,2],type="n",axes=F,xlab="",ylab="",xlim=c(min(pcafit$r[,1]),max(pcafit$r[,1]))*1.4,ylim=c(min(pcafit$r[,2]),max(pcafit$r[,2]))*1.4)
    axis(3)
    axis(4)
    if(vec.lines) {
        for(i in 1:(length(pcafit$r[,1]))) {
            lines(c(0,pcafit$r[i,1]), c(0,pcafit$r[i,2]), col=8)
        }
    }
    text(pcafit$r[,1]*1.1,pcafit$r[,2]*1.1,labels=labvar,cex=0.5,col=2)
}

##Draws a log10/log10 plot of data with proper grid lines
#Minexp and Maxexp set plot limits as round exponents of power 10, default to range of x,y data given
#Can set any other plotting parameters: (col, pch, xlab, ylab, main, etc.), but defaults to pch=20 filled circles
#Set gridlinecol to primary and secondary colors, defaults to 1=black, 8=gray
#Set gridlinetype to primary and secondary line types, defaults to 1=solid, 1=solid
#    (You might like gridlinetype=c(1,2) or c(1,3) for dashed or dotted secondary lines

loglog10plot=function(x,y,minexp=NA,maxexp=NA,gridlinecol=c(1,8),gridlinetype=c(1,1),pch=20,...) {
    if(is.na(minexp)) { minexp=round(log(min(min(x),min(y)),10))-1 }
    if(is.na(maxexp)) { maxexp=round(log(max(max(x),max(y)),10))+1 }
    logx=log(x,10)
    logy=log(y,10)

    if(maxexp<minexp+1) { maxexp=minexp+1 }
    axispos=10^minexp
    axislab=10^minexp
    axistick=1
    tickcol=gridlinecol[1]
    ticktype=gridlinetype[1]

    for(i in minexp:(maxexp-1)) {
        axispos=c(axispos,seq(10^i,10^(i+1),length=10)[2:10])
        axislab=c(axislab,rep(NA,8),10^(i+1))
        axistick=c(axistick,rep(2,8),1)
        tickcol=c(tickcol,rep(gridlinecol[2],8),gridlinecol[1])
        ticktype=c(ticktype,rep(gridlinetype[2],8),gridlinetype[1])
    }

    plot(logx,logy,axes=F,type="n",xlim=c(minexp,maxexp),ylim=c(minexp,maxexp),...)
    axis(1,at=log(axispos,10),labels=axislab)
    axis(2,at=log(axispos,10),labels=axislab)

    # Secondary grid lines
    for(i in 1:(length(axispos))) {
        if(axistick[i]==2) {
            lines(c(minexp,maxexp),c(log(axispos[i],10),log(axispos[i],10)),col=tickcol[i],lty=ticktype[i])
            lines(c(log(axispos[i],10),log(axispos[i],10)),c(minexp,maxexp),col=tickcol[i],lty=ticktype[i])
        }
    }
    # Primary grid lines
    for(i in 1:(length(axispos))) {
        if(axistick[i]==1) {
            lines(c(minexp,maxexp),c(log(axispos[i],10),log(axispos[i],10)),col=tickcol[i],lty=ticktype[i])
            lines(c(log(axispos[i],10),log(axispos[i],10)),c(minexp,maxexp),col=tickcol[i],lty=ticktype[i])
        }
    }
    # Draw points on top of grid
    points(logx,logy,pch=pch,...)
}

#Example:
# (data must be positive to be logged)
#
# x=5^rnorm(1000)
# y=x*2^rnorm(1000)
#
# loglog10plot(x,y,xlab="Something",ylab="Other Stuff",main="Other Stuff vs. Something",col=2,pch=1)
#
# loglog10plot(x,y,minexp=-3,maxexp=3,gridlinecol=c(1,8),gridlinetype=c(1,3))
#

## Arranges the rows in metrix mat into a 2-dimensional space by correlation of vectors
vectorSort2D = function(mat, xrange=c(floor(sqrt(nrow(mat)))-1, ceiling(sqrt(nrow(mat)))+1)) {
    require(som)
    cortot.best = NA
    dfasgn.best = NA
    for(xdim in seq(xrange[1], xrange[2], by=1)) {
        msize = nrow(mat)
        ydim = ceiling(msize / xdim)
        xsize = xdim * ydim

        xsom = som(mat, xdim=xdim, ydim=ydim, topol="rect")

        cmat=matrix(nrow=msize*xsize,ncol=3)
        v=0
        for(i in 1:msize) { for(j in 1:xsize) { v=v+1; cmat[v,1]=i; cmat[v,2]=j; cmat[v,3]=cor(xsom$data[i,], xsom$code[j,]) }}

        cmat.s = cmat[order(cmat[,3], decreasing=T),]
        masgn = rep(0, msize)
        xasgn = rep(0, xsize)
        cortot = 0
        for(i in 1:(nrow(cmat.s))) {
            if(xasgn[cmat.s[i,2]] == 0 & masgn[cmat.s[i,1]] == 0) {
                xasgn[cmat.s[i,2]] = cmat.s[i,1]
                masgn[cmat.s[i,1]] = cmat.s[i,2]
                cortot = cortot + cmat.s[i,3]
            }
        }
        if(is.na(cortot.best) | cortot > cortot.best) {
            cortot.best = cortot
            dfasgn.best = data.frame(xasgn, xsom$code.sum$x, xsom$code.sum$y)
            names(dfasgn.best) = c("row","x","y")
        }
    }
    dfasgn.best
}

vectorSort2D.plot = function(mat, dfasgn) {
    dfasgn.s = dfasgn[order(dfasgn$y, dfasgn$x),]
    xdim = max(dfasgn$x)+1
    ydim = max(dfasgn$y)+1
    par(mfrow=c(ydim,xdim), mar=c(0.2,0.2,2.0,0.2))
    for(i in 1:(nrow(dfasgn.s))) {
        if(dfasgn.s$row[i] > 0) {
            plot(mat[dfasgn.s$row[i],], type="n", axes=F, xlab="", ylab="", main=rownames(mat)[dfasgn.s$row[i]])
            rect(par("usr")[1], par("usr")[3], par("usr")[2], par("usr")[4], col="#F0F0F0", border=NA)
            lines(mat[dfasgn.s$row[i],])
        } else {
            plot(1,1,type="n",axes=F,xlab="",ylab="")
        }
    }
}


# Test execution time of cluster sandwich covariance estimator with logistic models
# GEE using a working independence binary logistic regression model
# 1,000,000 records on 100,000 subjects, 10 covariates
# Times are on a Lenovo X1 laptop running Linux
require(rms)
set.seed(1)
n <- 1000000
subjects <- 100000
y <- sample(0:1, n, TRUE)
x <- matrix(runif(10*n), ncol=10)
id <- sample(1:subjects, n, TRUE)
# Fit binary logistic model with working independence structure
system.time(f <- lrm(y ~ x, x=TRUE, y=TRUE))   # 4s
# g will have betas from f but with robust covariance matrix
system.time(g <- robcov(f, id))                # 1.4s
diag(vcov(f)) / diag(vcov(g))

# Check robcov's ability to ignore duplicate data
m <- n / subjects
set.seed(1)
y <- rep(sample(0 : 1, subjects, replace=TRUE), each=m)
id <- rep(1 : subjects, each=m)
j <- 1
x <- matrix(NA, nrow=n, ncol=10)
for(i in 1 : subjects) {
    x[j : (j + m - 1), ] <- matrix(rep(runif(10), each=m), nrow=m)
    j <- j + m
}
f <- lrm(y ~ x, x=TRUE, y=TRUE)
g <- robcov(f, id)
diag(vcov(f) / vcov(g))


#' Effective sample size
#'
#' Version of effectiveSize from coda package, modified for ease of use with DynamicLatticeBasis package.
#' @param x A matrix of MCMC out, with rows correspondings to variables and columns to iterations.
#' @return Effective sample sizes for each variable
#' @export
#' @examples
#' data(BXno3way)
#' res <- Xsampler(A=BXno3way$A,y=BXno3way$y,lambda=BXno3way$lambda,Model="Poisson",Method="Gibbs",tune.par=0.5,combine=TRUE)
#' effectiveSize(res$X)

effectiveSize <- function (x) {
  require(coda)
  if (is.mcmc.list(x)) {
    ess <- do.call("rbind", lapply(x, effectiveSize))
    ans <- apply(ess, 2, sum)
  }
  else {
    x <- as.mcmc(x)
    x <- as.matrix(x)
    variances <- apply(x, 2, var)
    indx <- variances > 0
    spec <- numeric(ncol(x))
    if (sum(indx) >0 ) spec[indx] <- spectrum0.ar(x[,indx])$spec
    ans <- ifelse(spec==0, 0, nrow(x) * variances/spec)
  }
  return(ans)
}


#########################################################################
## Tools to analyze results from the cluster

select_lambda <- function(parm, quant, n_select) {
  p <- ncol(parm)
  n <- nrow(parm)
  quantile_parm <- rep(NA, p)
  for (i in 1:p) quantile_parm[i] <- sort(parm[, i])[quant * n]
  selected <- sort(quantile_parm, decreasing = T)[1:n_select]
  which(quantile_parm %in% selected)
}

construct_plot_data <- function(parm, nIter, nChains, names) {
  iteration <- rep(1:nIter, nChains)
  chain <- rep(1:nChains, each = nIter)
  posterior.sample <- data.frame(parm, iteration, as.factor(chain))
  # names(posterior.sample) <- c(paste0("log_lambda[", index, "]"), "iteration", "chain")
  names(posterior.sample) <- names
  posterior.sample <- posterior.sample %>%
    gather(key = parameter, value = value, -chain, -iteration)
}

trace_plot <- function(posterior.sample) {
  trace.plot <- ggplot(data = posterior.sample,
                       aes(x = iteration, y = value, color = chain)) +
    geom_line() + theme_bw() + facet_wrap(~ parameter)
  print(trace.plot)
}

density_hist <- function(posterior.sample, bins = 30) {
  density.plot <- ggplot(data = posterior.sample,
                         aes(x = value, color = chain, fill = chain)) +
    geom_histogram(alpha = 0.25, position = "identity", bins = bins) +
    theme_bw() + facet_wrap(~ parameter) +
    theme(text = element_text(size = 15))
  print(density.plot)
}

quant_select_plot <- function(parm, quant, threshold = 3.5) {
  index <- 1:ncol(parm)
  parm_quant <- apply(parm, 2, quantile, quant)
  ggplot(data = data.frame(index = index, parm_quant = parm_quant),
         aes(x = index, y = parm_quant)) + geom_point(size = 0.25) +
    geom_text(aes(label = ifelse(parm_quant > threshold, index, '')),
              hjust = 0, vjust = 0) +
    theme_bw() + theme(text = element_text(size = 18))
}

quant_select_plot2 <- function(parm1, parm2, quant, threshold = 3.5, alpha = 0.05,
                               x = 0.95, y = 0.8, index_offset = 0) {
  index <- c(1:ncol(parm1), 1:ncol(parm2)) + index_offset
  parm_quant <- c(apply(parm1, 2, quantile, quant),
                  apply(parm2, 2, quantile, quant))
  method <- c(rep("(full) HMC", ncol(parm1)), rep("HMC + Laplace", ncol(parm2)))

  ggplot(data = data.frame(index = index, parm_quant = parm_quant, method = method),
         aes(x = index, y = parm_quant, color = method)) +
    geom_text(aes(label = ifelse(parm_quant > threshold, index, '')),
              hjust = 0, vjust = 0) +
    geom_point(size = 0.25, alpha = alpha) +
    theme_bw() +
    theme(
      legend.position = c(x, y),
      legend.justification = c("right", "top"),
      legend.box.just = "right",
      legend.margin = margin(6, 6, 6, 6),
      text = element_text(size = 15)
    ) + xlab("covariate index") + ylab("90th quantile")
}

summary_table <- function(log_lambda, tau, caux, index) {
  standard_post <- data.frame(log_lambda, tau, caux)
  names(standard_post) <- c(paste0("log_lambda[", index, "]"),
                            "tau", "caux")
  standard_post <- as_draws(standard_post)
  draw_summary <- summarise_draws(standard_post)
  time <- time <- sum(colSums(get_elapsed_time(stanfit))) +
    sum(colSums(get_elapsed_time(stanfit2)))
  draw_summary$eff_bulk <- draw_summary$ess_bulk / time
  draw_summary$eff_tail <- draw_summary$ess_tail / time
  draw_summary
}

sample_comparison_plot <- function(plot_data) {
  ggplot(data = plot_data) +
    geom_histogram(aes(x = value, fill = method), alpha = 0.5, color = "black",
                   bins = 30, position = "identity") + theme_bw() +
    facet_wrap(~key, scale = "free", ncol = 1, labeller = "label_parsed") +
    theme(
      legend.title = element_blank(),
      legend.position = c(1, 0.79),
      legend.justification = c("right", "top"),
      legend.box.just = "right",
      legend.margin = margin(6, 6, 6, 6),
      text = element_text(size = 18)
    )
}

eff_comparison_plot <- function(plot_data, x = 0.95, y = 0.98) {
  ggplot(data = plot_data,
         aes(x = parameter, y = eff, fill = method)) +
    geom_bar(stat = "identity", width = 0.3, alpha = 0.8, position = "dodge") +
    # facet_wrap(~ parameter, scale = "free", nrow = 1) +
    theme_bw() + theme(text = element_text(size = 10)) + coord_flip() +
    ylab("ESS / s") + xlab(" ") +
    theme(
      legend.position = c(x, y),
      legend.justification = c("right", "top"),
      legend.box.just = "right",
      legend.margin = margin(6, 6, 6, 6)
    )
}


library(tidyverse)
movdt <- read_csv('C:/GitHub/Proofcheck/jupyter/movie_metadata.csv')
movdt2 <- select_if(movdt,is.numeric)
movdt2 <- movdt2 %>% mutate(profit=gross>budget) %>% select(-c(gross,budget))
movdt2 <- movdt2[complete.cases(movdt2),]

fit <- glm(profit~.,data=movdt2,family='binomial')
summary(fit)


#
# this app uses Gradient Boosted Tree to predict the remaining useful life of turbine engines
# download data to hdfs in datadir from NASA: https://ti.arc.nasa.gov/c/6/

  datadir <- "/user/pliu/CMAPSS/"
	hdfsFS <- RxHdfsFileSystem()

# import training data
	train_raw <- RxTextData(file = paste(datadir, "train_FD001.txt", sep=""), fileSystem = hdfsFS)
	train_rawds <- rxImport(inData = train_raw)
	colnames <- c("id","cycle","setting1","setting2","setting3","s1","s2","s3","s4","s5","s6","s7",
	               "s8","s9","s10","s11","s12","s13","s14","s15","s16","s17","s18","s19","s20","s21")
	names(train_rawds) <- colnames

	library(plyr)
# find the max cycle value per engine id
	train_maxcycle <- ddply(train_rawds,~id,summarise,max=max(cycle))
	train_labled <- merge(train_rawds,train_maxcycle,by=c("id"))
# remaining useful life (RUL) = max cycle - current cycle
	train_labled$RUL <- train_labled$max - train_labled$cycle
	train_labled <- train_labled[,-which(names(train_labled) == "max")]
# the features we will build the model on, and the label
	train_df <- train_labled[, c("cycle", "s9", "s11", "s14", "s15", "RUL")]

# configure the model, specifying label column vs features
	formula <- as.formula("RUL ~ cycle + s9 + s11 + s14 + s15")
# train the model
	bt <- rxBTrees(
    formula = formula,
    data = train_df,
    minBucket = 10,
    minSplit = 10,
    learningRate = 0.2,
    seed = 5,
    nTree = 100,
    lossFunction = "gaussian"  # this loss function doesn't exist in Spark
    )

# import test data, same structure as training data
	test_raw <- RxTextData(file = paste(datadir, "test_FD001.txt", sep=""), fileSystem = hdfsFS)
	test_rawds <- rxImport(inData = test_raw)
	names(test_rawds) <- colnames
# only need to predict the RUL from the latest cycle
	test_maxcycle <- merge(aggregate(cycle~id,test_rawds,function(x) x[which.max(x)]),test_rawds)
# order the data by engine id to be merged with the ground truth for test data in the RUL data file
	test_ordered = test_maxcycle[with(test_maxcycle, order(id)), ]
	test_ds <- test_ordered[, c("cycle", "s9", "s11", "s14", "s15")]

# import ground truth for test data, assuming engine 1 to N, that can be concat with the ordered testing data
	rul_raw <- RxTextData(file = paste(datadir, "RUL_FD001.txt", sep=""), fileSystem = hdfsFS)
	rul_rawds <- rxImport(inData = rul_raw)
	names(rul_rawds) <- "RUL"
	test_df <- cbind(test_ds, rul_rawds)

# predict on the test data using the model
	predictions <- rxPredict(modelObject = bt, data = test_df)

# define evaluation function that computes error metrics
	evaluate_model <- function(observed, predicted) {
	  mean_observed <- mean(observed)
	  se <- (observed - predicted)^2
	  ae <- abs(observed - predicted)
	  sem <- (observed - mean_observed)^2
	  aem <- abs(observed - mean_observed)
	  mae <- mean(ae)
	  rmse <- sqrt(mean(se))
	  rae <- sum(ae) / sum(aem)
	  rse <- sum(se) / sum(sem)
	  rsq <- 1 - rse
	  metrics <- c("Mean Absolute Error" = mae,
	               "Root Mean Squared Error" = rmse,
	               "Relative Absolute Error" = rae,
	               "Relative Squared Error" = rse,
	               "Coefficient of Determination" = rsq)
	  return(metrics)
	}

# evaluate how well the prediction did compared to ground truth using the evaluation function
	boosted_metrics <- evaluate_model(
		observed = test_df$RUL,
	  predicted = predictions$RUL_Pred)
# root mean square error is 27.3259527

# save the model to local file system, not hdfs
  saveRDS(bt, "/home/pliu/btmodel.rds")

# print out result dataframe
	result <- cbind(test_df$RUL, predictions$RUL_Pred)
	result_df <- as.data.frame(result)
	colnames <- c("RUL", "RUL_Pred")
	names(result_df) <- colnames
	result_df


par(mfrow=c(1,1))
gt <- make_tree(1000, mode="undirected")
plot(gt)
radius <- 1:100
plot(radius, sapply(radius, function(n) {ego_size(gt, n, nodes=64)}), pch=3)


## Replication Code for
# A. Abadie, A. Diamond, and J. Hainmueller. 2014.
# Comparative Politics and the Synthetic Control Method
# American Journal of Political Science.

rm(list=ls())
library(foreign)
library("Synth")
library(xtable)

# Load Data
d <- read.dta("repgermany.dta")

## Table 1 & 2, Figure 1, 2, & 3

## pick v by cross-validation
# data setup for training model
dataprep.out <-
  dataprep(
           foo = d,
           predictors    = c("gdp","trade","infrate"),
           dependent     = "gdp",
           unit.variable = 1,
           time.variable = 3,
           special.predictors = list(
            list("industry", 1971:1980, c("mean")),
            list("schooling",c(1970,1975), c("mean")),
            list("invest70" ,1980, c("mean"))
           ),
           treatment.identifier = 7,
           controls.identifier = unique(d$index)[-7],
           time.predictors.prior = 1971:1980,
           time.optimize.ssr = 1981:1990,
           unit.names.variable = 2,
           time.plot = 1960:2003
         )

# fit training model
synth.out <-
  synth(
        data.prep.obj=dataprep.out,
        Margin.ipop=.005,Sigf.ipop=7,Bound.ipop=6
        )

# data prep for main model
dataprep.out <-
 dataprep(
  foo = d,
  predictors    = c("gdp","trade","infrate"),
  dependent     = "gdp",
  unit.variable = 1,
  time.variable = 3,
  special.predictors = list(
    list("industry" ,1981:1990, c("mean")),
    list("schooling",c(1980,1985), c("mean")),
    list("invest80" ,1980, c("mean"))
  ),
  treatment.identifier = 7,
  controls.identifier = unique(d$index)[-7],
  time.predictors.prior = 1981:1990,
  time.optimize.ssr = 1960:1989,
  unit.names.variable = 2,
  time.plot = 1960:2003
)

# fit main model with v from training model
synth.out <- synth(
  data.prep.obj=dataprep.out,
  custom.v=as.numeric(synth.out$solution.v)
  )

#### Table 2
synth.tables <- synth.tab(
                          dataprep.res = dataprep.out,
                          synth.res = synth.out
                          ); synth.tables

# Replace means for OECD sample (computed externally using proper pop weighting)
synth.tables$tab.pred[,3]          <- c(8021.1,31.9,7.4,34.2,44.1,25.9)
colnames(synth.tables$tab.pred)[3] <- "Rest of OECD Sample"
rownames(synth.tables$tab.pred) <- c("GDP per-capita","Trade openness",
                                     "Inflation rate","Industry share",
                                     "Schooling","Investment rate")

xtable(round(synth.tables$tab.pred,1),digits=1)

#### Table 1
# synth weights
tab1 <- data.frame(synth.tables$tab.w)
tab1[,1] <- round(tab1[,1],2)
# regression weights
X0 <- cbind(1,t(dataprep.out$X0))
X1 <- as.matrix(c(1,dataprep.out$X1))
W     <- X0%*%solve(t(X0)%*%X0)%*%X1
Wdat  <- data.frame(unit.numbers=as.numeric(rownames(X0)),
                    regression.w=round(W,2))
tab1  <- merge(tab1,Wdat,by="unit.numbers")
tab1  <- tab1[order(tab1[,3]),]

xtable(cbind(tab1[1:9,c(3,2,4)],
             tab1[10:18,c(3,2,4)]
             )
       )

#### Figure 1: Trends in Per-Capita GDP: West Germany vs. Rest of the OECD Sample
Text.height <- 23000
Cex.set <- .8
#pdf(file = "ger_vs_oecd.pdf", width = 5.5, height = 5.5, family = "Times",pointsize = 12)
plot(1960:2003,dataprep.out$Y1plot,
     type="l",ylim=c(0,33000),col="black",lty="solid",
     ylab ="per-capita GDP (PPP, 2002 USD)",
     xlab ="year",
     xaxs = "i", yaxs = "i",
     lwd=2
     )
lines(1960:2003,aggregate(d[,c("gdp")],by=list(d$year),mean,na.rm=T)[,2]
      ,col="black",lty="dashed",lwd=2) # mean 2
abline(v=1990,lty="dotted")
legend(x="bottomright",
       legend=c("West Germany","rest of the OECD sample")
      ,lty=c("solid","dashed"),col=c("black","black")
      ,cex=.8,bg="white",lwd=c(2,2))
arrows(1987,Text.height,1989,Text.height,col="black",length=.1)
text(1982.5,Text.height,"reunification",cex=Cex.set)
#dev.off()

#### Figure 2: Trends in Per-Capita GDP: West Germany vs. Synthetic West Germany
#pdf(file = "ger_vs_synthger2.pdf", width = 5.5, height = 5.5, family = "Times",pointsize = 12)
synthY0 <- (dataprep.out$Y0%*%synth.out$solution.w)
plot(1960:2003,dataprep.out$Y1plot,
     type="l",ylim=c(0,33000),col="black",lty="solid",
     ylab ="per-capita GDP (PPP, 2002 USD)",
     xlab ="year",
     xaxs = "i", yaxs = "i",
     lwd=2
     )
lines(1960:2003,synthY0,col="black",lty="dashed",lwd=2)
abline(v=1990,lty="dotted")
legend(x="bottomright",
       legend=c("West Germany","synthetic West Germany")
      ,lty=c("solid","dashed"),col=c("black","black")
      ,cex=.8,bg="white",lwd=c(2,2))
arrows(1987,Text.height,1989,Text.height,col="black",length=.1)
text(1982.5,Text.height,"reunification",cex=Cex.set)
#dev.off()

### Figure 3: Per-Capita GDP Gap Between West Germany and Synthetic West Germany
#pdf(file = "ger_vs_synthger_gaps2.pdf", width = 5.5, height = 5.5, family = "Times",pointsize = 12)
gap <- dataprep.out$Y1-(dataprep.out$Y0%*%synth.out$solution.w)
plot(1960:2003,gap,
     type="l",ylim=c(-4500,4500),col="black",lty="solid",
     ylab =c("gap in per-capita GDP (PPP, 2002 USD)"),
     xlab ="year",
     xaxs = "i", yaxs = "i",
     lwd=2
     )
abline(v=1990,lty="dotted")
abline(h=0,lty="dotted")
arrows(1987,1000,1989,1000,col="black",length=.1)
text(1982.5,1000,"reunification",cex=Cex.set)
#dev.off()

### Figure 4: Placebo Reunification 1975 - Trends in Per-Capita GDP: West Germany vs. Synthetic West Germany

# data prep for training model
dataprep.out <-
  dataprep(
    foo = d,
    predictors    = c("gdp","trade","infrate"),
    dependent     = "gdp",
    unit.variable = 1,
    time.variable = 3,
    special.predictors = list(
      list("industry",1971, c("mean")),
      list("schooling",c(1960,1965), c("mean")),
      list("invest60" ,1980, c("mean"))
    ),
    treatment.identifier = 7,
    controls.identifier = unique(d$index)[-7],
    time.predictors.prior = 1960:1964,
    time.optimize.ssr = 1965:1975,
    unit.names.variable = 2,
    time.plot = 1960:1990
  )

# fit training model
synth.out <- synth(
  data.prep.obj=dataprep.out,
  Margin.ipop=.005,Sigf.ipop=7,Bound.ipop=6
)

# data prep for main model
dataprep.out <-
  dataprep(
    foo = d,
    predictors    = c("gdp","trade","infrate"),
    dependent     = "gdp",
    unit.variable = 1,
    time.variable = 3,
    special.predictors = list(
      list("industry" ,1971:1975, c("mean")),
      list("schooling",c(1970,1975), c("mean")),
      list("invest70" ,1980, c("mean"))
    ),
    treatment.identifier = 7,
    controls.identifier = unique(d$index)[-7],
    time.predictors.prior = 1965:1975,
    time.optimize.ssr = 1960:1975,
    unit.names.variable = 2,
    time.plot = 1960:1990
  )

# fit main model
synth.out <- synth(
  data.prep.obj=dataprep.out,
  custom.v=as.numeric(synth.out$solution.v)
)

Cex.set <- 1
#pdf(file = "2intimeplacebo1975.pdf", width = 5.5, height = 5.5, family = "Times",pointsize = 12)
plot(1960:1990,dataprep.out$Y1plot,
     type="l",ylim=c(0,33000),col="black",lty="solid",
     ylab ="per-capita GDP (PPP, 2002 USD)",
     xlab ="year",
     xaxs = "i", yaxs = "i",
     lwd=2
     )
lines(1960:1990,(dataprep.out$Y0%*%synth.out$solution.w),col="black",lty="dashed",lwd=2)
abline(v=1975,lty="dotted")
legend(x="bottomright",
       legend=c("West Germany","synthetic West Germany")
      ,lty=c("solid","dashed"),col=c("black","black")
      ,cex=.8,bg="white",lwd=c(2,2))
arrows(1973,20000,1974.5,20000,col="black",length=.1)
text(1967.5,20000,"placebo reunification",cex=Cex.set)
#dev.off()

### Figure 5: Ratio of post-reunification RMSPE to pre-reunification RMSPE: West Germany and control countries.

# loop across control units
storegaps <-
  matrix(NA,
        length(1960:2003),
        length(unique(d$index))-1
        )
rownames(storegaps) <- 1960:2003
i <- 1
co <- unique(d$index)

for(k in unique(d$index)[-7]){

  # data prep for training model
  dataprep.out <-
    dataprep(
      foo = d,
      predictors    = c("gdp","trade","infrate"),
      dependent     = "gdp",
      unit.variable = 1,
      time.variable = 3,
      special.predictors = list(
        list("industry",1971:1980, c("mean")),
        list("schooling"   ,c(1970,1975), c("mean")),
        list("invest70" ,1980, c("mean"))
      ),
      treatment.identifier = k,
      controls.identifier = co[-which(co==k)],
      time.predictors.prior = 1971:1980,
      time.optimize.ssr = 1981:1990,
      unit.names.variable = 2,
      time.plot = 1960:2003
    )

  # fit training model
  synth.out <-
   synth(
    data.prep.obj=dataprep.out,
    Margin.ipop=.005,Sigf.ipop=7,Bound.ipop=6
   )

  # data prep for main model
dataprep.out <-
    dataprep(
      foo = d,
      predictors    = c("gdp","trade","infrate"),
      dependent     = "gdp",
      unit.variable = 1,
      time.variable = 3,
      special.predictors = list(
        list("industry" ,1981:1990, c("mean")),
        list("schooling",c(1980,1985), c("mean")),
        list("invest80" ,1980, c("mean"))
      ),
      treatment.identifier = k,
      controls.identifier = co[-which(co==k)],
      time.predictors.prior = 1981:1990,
      time.optimize.ssr = 1960:1989,
      unit.names.variable = 2,
      time.plot = 1960:2003
    )

# fit main model
synth.out <- synth(
   data.prep.obj=dataprep.out,
   custom.v=as.numeric(synth.out$solution.v)
  )

 storegaps[,i] <-
   dataprep.out$Y1-
   (dataprep.out$Y0%*%synth.out$solution.w)
 i <- i + 1
} # close loop over control units
d <- d[order(d$index,d$year),]
colnames(storegaps) <- unique(d$country)[-7]
storegaps <- cbind(gap,storegaps)
colnames(storegaps)[1] <- c("West Germany")

# compute ratio of post-reunification RMSPE
# to pre-reunification RMSPE
rmse <- function(x){sqrt(mean(x^2))}
preloss <- apply(storegaps[1:30,],2,rmse)
postloss <- apply(storegaps[31:44,],2,rmse)

#pdf("2ratio_post_to_preperiod_rmse2a.pdf")
dotchart(sort(postloss/preloss),
         xlab="Post-Period RMSE / Pre-Period RMSE",
         pch=19)
#dev.off()

### Figure 6: Leave-one-out distribution of the synthetic control for West Germany

# loop over leave one outs
storegaps <-
  matrix(NA,
        length(1960:2003),
        5)
colnames(storegaps) <- c(1,3,9,12,14)
co <- unique(d$index)[-7]

for(k in 1:5){

# data prep for training model
omit <- c(1,3,9,12,14)[k]
  dataprep.out <-
    dataprep(
      foo = d,
      predictors    = c("gdp","trade","infrate"),
      dependent     = "gdp",
      unit.variable = 1,
      time.variable = 3,
      special.predictors = list(
        list("industry",1971:1980, c("mean")),
        list("schooling"   ,c(1970,1975), c("mean")),
        list("invest70" ,1980, c("mean"))
      ),
      treatment.identifier = 7,
      controls.identifier = co[-which(co==omit)],
      time.predictors.prior = 1971:1980,
      time.optimize.ssr = 1981:1990,
      unit.names.variable = 2,
      time.plot = 1960:2003
    )

  # fit training model
  synth.out <- synth(
    data.prep.obj=dataprep.out,
    Margin.ipop=.005,Sigf.ipop=7,Bound.ipop=6
  )

# data prep for main model
dataprep.out <-
  dataprep(
    foo = d,
    predictors    = c("gdp","trade","infrate"),
    dependent     = "gdp",
    unit.variable = 1,
    time.variable = 3,
    special.predictors = list(
      list("industry" ,1981:1990, c("mean")),
      list("schooling",c(1980,1985), c("mean")),
      list("invest80" ,1980, c("mean"))
    ),
    treatment.identifier = 7,
    controls.identifier = co[-which(co==omit)],
    time.predictors.prior = 1981:1990,
    time.optimize.ssr = 1960:1989,
    unit.names.variable = 2,
    time.plot = 1960:2003
  )

  # fit main model
  synth.out <- synth(
    data.prep.obj=dataprep.out,
    custom.v=as.numeric(synth.out$solution.v)
  )
  storegaps[,k] <- (dataprep.out$Y0%*%synth.out$solution.w)
} # close loop over leave one outs

Text.height <- 23000
Cex.set <- .8
#pdf(file = "1jackknife2.pdf", width = 5.5, height = 5.5, family = "Times",pointsize = 12)
plot(1960:2003,dataprep.out$Y1plot,
     type="l",ylim=c(0,33000),col="black",lty="solid",
     ylab ="per-capita GDP (PPP, 2002 USD)",
     xlab ="year",
     xaxs = "i", yaxs = "i",lwd=2
     )

abline(v=1990,lty="dotted")
arrows(1987,23000,1989,23000,col="black",length=.1)
 for(i in 1:5){
  lines(1960:2003,storegaps[,i],col="darkgrey",lty="solid")
  }
lines(1960:2003,synthY0,col="black",lty="dashed",lwd=2)
lines(1960:2003,dataprep.out$Y1plot,col="black",lty="solid",lwd=2)
text(1982.5,23000,"reunification",cex=.8)
legend(x="bottomright",
       legend=c("West Germany",
                "synthetic West Germany",
                "synthetic West Germany (leave-one-out)")
      ,lty=c("solid","dashed","solid"),
      col=c("black","black","darkgrey")
      ,cex=.8,bg="white",lwdc(2,2,1))
#dev.off()

### Table 3: Synthetic Weights from Combinations of Control Countries
rm(list=ls())
library(gtools)
library(kernlab)

# data prep for training model
d <- read.dta("repgermany.dta")
dataprep.out <-
  dataprep(
    foo = d,
    predictors    = c("gdp","trade","infrate"),
    dependent     = "gdp",
    unit.variable = 1,
    time.variable = 3,
    special.predictors = list(
      list("industry", 1971:1980, c("mean")),
      list("schooling",c(1970,1975), c("mean")),
      list("invest70" ,1980, c("mean"))
    ),
    treatment.identifier = 7,
    controls.identifier = unique(d$index)[-7],
    time.predictors.prior = 1971:1980,
    time.optimize.ssr = 1981:1990,
    unit.names.variable = 2,
    time.plot = 1960:2003
  )

# fit training model
synth.out <-
  synth(
    data.prep.obj=dataprep.out,
    Margin.ipop=.005,Sigf.ipop=7,Bound.ipop=6
  )

# data prep for main model
dataprep.out <-
  dataprep(
    foo = d,
    predictors    = c("gdp","trade","infrate"),
    dependent     = "gdp",
    unit.variable = 1,
    time.variable = 3,
    special.predictors = list(
      list("industry" ,1981:1990, c("mean")),
      list("schooling",c(1980,1985), c("mean")),
      list("invest80" ,1980, c("mean"))
    ),
    treatment.identifier = 7,
    controls.identifier = unique(d$index)[-7],
    time.predictors.prior = 1981:1990,
    time.optimize.ssr = 1960:1989,
    unit.names.variable = 2,
    time.plot = 1960:2003
  )

# fit main model with v from training model
synth.out <- synth(
  data.prep.obj=dataprep.out,
  custom.v=as.numeric(synth.out$solution.v)
)

synth.tables <- synth.tab(
  dataprep.res = dataprep.out,
  synth.res = synth.out
)

table3 <- list()
synth.tables$tab.w[,1] <- round(synth.tables$tab.w[,1],2)
table3[[5]] <-synth.tables$tab.w[order(-1*synth.tables$tab.w[,1]),2:1][1:5,]

# compute loss for all combinations
# of 4, 3, 2, 1 sized donor pools

# get W and v
solution.w <- round(synth.out$solution.w,3)
V <- diag(as.numeric(synth.out$solution.v))

# compute scaled Xs
nvarsV <- dim(dataprep.out$X0)[1]
big.dataframe <- cbind(dataprep.out$X0, dataprep.out$X1)
divisor <- sqrt(apply(big.dataframe, 1, var))
scaled.matrix <-
  t(t(big.dataframe) %*% ( 1/(divisor) *
  diag(rep(dim(big.dataframe)[1], 1)) ))
X0.scaled <- scaled.matrix[,c(1:(dim(dataprep.out$X0)[2]))]
X1.scaled <- as.matrix(scaled.matrix[,dim(scaled.matrix)[2]])

dn <- d[d$year==1970,c("country","index")]
dn <- dn[order(dn$index),]
dn <- dn[-7,]

table2store <- matrix(NA,nrow(dataprep.out$X1),4)
fig7store   <- matrix(NA,length(1960:2003),4)

# loop through number of controls
for(pp in 4:1){
  store       <- combinations(length(unique(d$index)[-7]),
                              r=pp, v=unique(d$index)[-7])
  store.loss  <- matrix(NA,nrow=nrow(store),1)
  store.w     <- matrix(NA,nrow=nrow(store),pp)
  store.c     <- store.w

# loop through combinations
  for(k in 1:nrow(store)){
    # index positions of control units
    posvector <- c()
    for(i in 1:pp){
      posvector <- c(posvector,which(dn$index==store[k,i]))
    }

  # run quad optimization
    X0temp <- X0.scaled[ , posvector ]
    H <- t(X0temp) %*% V %*% (X0temp)
    c <- -1*c(t(X1.scaled) %*% V %*% (X0temp) )

    if(pp == 1){
      solution.w <- matrix(1)
    } else {
        res <- ipop(c = c, H = H, A = t(rep(1, length(c))),
                    b = 1, l = rep(0, length(c)),
                    u = rep(1, length(c)), r = 0,
                    margin = 0.005,sigf = 7, bound = 6)
        solution.w <- as.matrix(primal(res))
    }
    loss.w <- t(X1.scaled - X0temp %*% solution.w) %*% V %*% (X1.scaled - X0temp %*% solution.w)

    store.loss[k] <- loss.w
    store.w[k,]   <- t(solution.w)
    store.c[k,]   <- dn$country[posvector]
  } # close loop over combinations

# get best fitting combination
  dat <- data.frame(store.loss,
                    store,
                    store.c,
                    store.w
                    )
  colnames(dat) <- c("loss",
                     paste("CNo",1:pp,sep=""),
                     paste("CNa",1:pp,sep=""),
                     paste("W",1:pp,sep="")
                     )
  dat <- dat[order(dat$loss),]
  Countries <- dat[1,paste("CNo",1:pp,sep="")]
  Cweights  <- as.numeric(dat[1,paste("W",1:pp,sep="")])

  outdat <-  data.frame(unit.names=as.vector(
   (t(as.vector(dat[1,paste("CNa",1:pp,sep="")])))),
                    w.weights=round(Cweights,2))

table3[[pp]]<- outdat[order(-1*outdat$w.weights),]

 # get posvector for fitting
  posvector <- c()
  if(pp == 1 ){
    posvector <- c(posvector,which(dn$index==Countries))
  } else {
    for(i in 1:pp){
      posvector <- c(posvector,which(dn$index==Countries[1,i]))
    }
  }

  X0t <- as.matrix(dataprep.out$X0[,posvector])%*% as.matrix(Cweights)
  table2store[,(4:1)[pp]] <- X0t

  fig7store[,(4:1)[pp]] <-
   dataprep.out$Y0[,posvector]%*%as.matrix(Cweights)

} # close loop over number of countries

# Table 3
table3

# Table 4
synth.tables$tab.pred[,3] <- c(8021.1,31.9,7.4,34.2,44.1,25.9)
table4 <- round(
  cbind(synth.tables$tab.pred[,1:2],
        table2store,
        synth.tables$tab.pred[,3]),1)
rownames(table4) <- c("GDP per-capita","Trade openness",
                      "Inflation rate","Industry share",
                      "Schooling","Investment rate")
colnames(table4)[2:7] <- c(5:1,"OECD Sample")
table4

## Figure 7: Per-Capita GDP Gaps Between West Germany and Sparse Synthetic Controls
Text.height <- 23000
Cex.set <- .8

par(mfrow=c(2,2))
for(pp in 4:1){
#pdf(file = paste("2ger_vs_synth","CValt",pp,".pdf",sep=""), width = 5.5, height = 5.5, family = "Times",pointsize = 12)
  plot(1960:2003,dataprep.out$Y1,
       type="l",ylim=c(0,33000),col="black",lty="solid",
       ylab ="per-capita GDP (PPP, 2002 USD)",
       xlab ="year",
       xaxs = "i", yaxs = "i",
       lwd=2,
       main=paste("No. of control countries: ",pp,sep="")
       )
  lines(1960:2003,fig7store[,c(4:1)[pp]],col="black",lty="dashed",lwd=2)
  abline(v=1990,lty="dotted")
  legend(x="bottomright",
         legend=c("West Germany","synthetic West Germany")
         ,lty=c("solid","dashed"),col=c("black","black")
         ,cex=.8,bg="white",lwd=c(2,2))
  arrows(1987,Text.height,1989,Text.height,col="black",length=.1)
  text(1982.5,Text.height,"reunification",cex=Cex.set)
  #dev.off()
}


model_initializeR <- function(data, data_init, init_pars, model = "Multinomial", period_start,
                  alpha_p = 0.5, alpha_u = 0.7, beta_1 = 0.6, beta_2 = 0.7, delta_1 = 0.3, delta_2 = 0.7,
                  lambda = 1 / (66.26 * 365), mu = 1 / (66.26 * 365), D_d = 17.8, De = 5.2,
                  Dr = 17.8, f = 0.15, mCFR = NULL, init.exposed.ratio = 3, init.confirmed.ratio = 0.0588,
                  auto.initialize = TRUE,opt_num=100, override = FALSE, ... ){
  if(data_init[1]==0){
    stop("Please enter a non-zero value for the initial number of  total confirmed cases. A suggestion is replace 0 by 1 ")
  }
  if(model=="Multinomial"){
    obsP = data$Confirmed
    obsR = data$Recovered
    obsD = data$Deceased

  }
  else if(model=="Poisson"||model=="Binomial"){
    obsP=data$Confirmed
  }

  if(is.null(mCFR)) mCFR = tail(cumsum(obsD) / cumsum(obsD+obsR),1)

  mu_c = mCFR/D_d
  Dr = Dr/(1-mCFR)

  ## Fixed parameters

  fix_pars = c(alpha_p = alpha_p, alpha_u = alpha_u, beta_1 = beta_1, beta_2 = beta_2, delta_1 = delta_1,
               delta_2 = delta_2, lambda = lambda, mu = mu, mu_c = mu_c, De = De, Dr = Dr, f = f, N = N)

  ## Initializing parameters

  ## Initial states

  #initial number of ascertained cases
  P0  = data_init[1] - data_init[2] - data_init[3]
  #initial number of ascertained recoveries
  RR0 = data_init[2]
  #initial number of ascertained deaths
  DR0 = data_init[3]
  #initi number of false negatives
  F0 = round(f/(1-f) * P0)
  #initial number of unascertained infectious cases
  U0 =round( (P0 + F0) * (1-init.confirmed.ratio)/init.confirmed.ratio)
  #initial number of ascertained recoveries
  RR0 = data_init[2]
  #initial number of unascertained recoveries
  RU0 = round(((1-init.confirmed.ratio)/init.confirmed.ratio + f/(1-f)) * RR0)
  #initial number of ascertained deaths
  DR0 = data_init[3]
  #initial number of unascertained deaths
  DU0 = round(((1-init.confirmed.ratio)/init.confirmed.ratio + f/(1-f)) * DR0)
  #initial number of latent cases, De=5.3
  E0 = init.exposed.ratio*(U0 + P0 + F0)
  #initial number of susceptible individuals
  S0 = N - (E0 + U0 + P0 + F0 + RU0 + RR0 + DU0 + DR0)
  # initial states c(S = S0, E = E0, U = U0, P = P0, F = F0, RU = RU0, RR = RR0, DU = DU0, DR = DR0)
  yinit = c("S" = S0, "E" = E0, "U" = U0, "P" = P0, "F" = F0, "RU" = RU0, "RR" = RR0, "DU" = DU0, "DR" = DR0)

  if(period_start[1] != 1){
    period_start = c(1, period_start)
  }

  n_period=length(period_start)
  if(auto.initialize){
    init_pars = par_initializeR(data = data, data_init = data_init, init_pars = init_pars, fix_pars = fix_pars,
                                opt_num = opt_num,period_start=period_start,init_state_num = yinit, model = model,
                                ...)[3:(2*n_period+2)]
    cat(" " , fill = TRUE)
    cat("MLE estimates : " , fill = TRUE)
    cat("beta = (", paste0(round(init_pars[1:n_period],2), collapse = ", "), ")", fill = TRUE)
    cat("r = (", paste0(round(init_pars[n_period + 1:n_period],3), collapse = ", "), ")", fill = TRUE)
    cat(" " , fill = TRUE)
  }
  else{
    if(is.null(init_pars) && !override){
      stop("Please enter the initial Parameters")
    }
  }

  if(length(period_start) != length(init_pars)/2 && !override)
    stop("Number of periods is not equal to number of initial parameters")

  return(list("init_pars" = init_pars, "fix_pars" = fix_pars, "init_state_num" = yinit, "period_start" = period_start))

}


library(MASS)

comp <- function(x) { 1 - x}

a <- fractions(0.59)
b <- fractions(0.91)
c <- fractions(0.44)

h <- a*comp(b) + comp(a)*b
a_h <- (a*comp(b))/h
k <- a*comp(b)*comp(c) + comp(a)*b*c
a_k <- (a*comp(b)*comp(c))/k

print(h)
print(a_h)
print(a_k)


#****************************************************************************************************
#                Libraries ####
#****************************************************************************************************
library("magrittr")
library("plyr") # needed for ldply; must be loaded BEFORE dplyr
library("tidyverse")
options(tibble.print_max = 60, tibble.print_min = 60) # if more than 60 rows, print 60 - enough for states
# ggplot2 tibble tidyr readr purrr dplyr stringr forcats
library("readxl")
library("knitr")
library("scales")

#****************************************************************************************************
#                Globals ####
#****************************************************************************************************

#****************************************************************************************************
#                Get data ####
#****************************************************************************************************
# D:\Dropbox\OSPC - Shared\IRS_pubuse_2011
pufdir <- "D:/Dropbox/OSPC - Shared/IRS_pubuse_2011/"
puf.fn <- "puf2011.csv"

puf <- read_csv(paste0(pufdir, puf.fn),
                col_types = cols(.default= col_double()),
                n_max=-1)
names(puf) <- str_to_lower(names(puf))

pufnames <- read_csv("./data/pufvars.csv")
pufnames

#****************************************************************************************************
#                Create cdf of weighted income tax liability ####
#****************************************************************************************************
df <- puf %>%
  filter(!recid %in% 999996:999999) %>%
  mutate(wt=s006 / 100) %>%
  select(recid, wt, e06500, e00100) %>%
  arrange(e00100) %>%
  mutate(cum.pct=cumsum(wt * e06500) / sum(wt * e06500))

# compute line segments

capt <- "- x-axis (AGI) is log10 scale\n- For display purposes x-axis is truncated at left to only show AGI >= $10,000"
gtitle <- "Cumulative distribution of weighted total income tax (e06500) vs. Adjusted gross income in 2011 PUF"
gsub <- "Aggregate records excluded before calculating distribution"

sq10 <- c(0, 10e3, 25e3, 50e3, 100e3, 250e3, 500e3, 750e3, 1e6, 1.5e6, 2e6, 3e6, 4e6, 5e6, 10e6, 25e6, 50e6, 100e6)
xlabs <- scales::comma(sq10 / 1e3)
xscale.l10 <- scale_x_log10(name="AGI in $ thousands", breaks=sq10, labels=xlabs)

# geom_segment(aes(x = x1, y = y1, xend = x2, yend = y2, colour = "segment"), data = df)

sz <- 1
df %>%
  filter(e00100 > 10e3) %>%
  ggplot(aes(e00100, cum.pct)) +
  geom_line(size=1.5, colour="blue") +
  geom_vline(xintercept=250e3, linetype="dashed", colour="red", size=sz) +
  geom_hline(yintercept=.56, linetype="dashed", colour="red", size=sz) +
  geom_vline(xintercept=1e6, linetype="dashed", colour="grey", size=sz) +
  geom_hline(yintercept=.8, linetype="dashed", colour="grey", size=sz) +
  geom_vline(xintercept=3.2e6, linetype="dashed", colour="green", size=sz) +
  geom_hline(yintercept=.9, linetype="dashed", colour="green", size=sz) +
  theme_bw() +
  ggtitle(gtitle, subtitle=gsub) +
  labs(caption=capt) +
  scale_y_continuous(name="Cumulative proportion of the sum of weighted total income tax (e06500)", breaks=c(seq(0, .9, .05), seq(.92, 1, .02))) +
  xscale.l10 +
  theme(axis.text.x=element_text(angle=45, size=10, hjust=1, colour="black")) +
  theme(plot.caption = element_text(hjust=0, size=rel(.8)))

# scale_x_continuous(name="Adjusted gross income", limits=c(0, NA), breaks=c(0, 50e3, 100e3, 250e3, 500e3, 750e3, 1e6)) +


# event day vs tmin
library(lmerTest)
library(lme4)
xx <- st_set_geometry(dplyr::select(hp_afv, event_day, tmin),NULL) %>% mutate(product = "viirs", fire = "hot_pot")%>%
  rbind(st_set_geometry(dplyr::select(hp_afm, event_day, tmin),NULL) %>% mutate(product = "modis", fire = 'hot_pot'))%>%
   rbind(st_set_geometry(dplyr::select(camp_afm, event_day, tmin),NULL) %>% mutate(product = "modis", fire = "camp"))%>%
  rbind(st_set_geometry(dplyr::select(camp_afv, event_day, tmin),NULL) %>% mutate(product = "viirs", fire = "camp"))

ggplot(xx, aes(x=as.factor(event_day), y=tmin)) +
  geom_boxplot() +
  facet_wrap(~product+fire,dir = "v")

m=lme4::lmer(tmin~event_day + (1|fire), xx)
summary(m)