data = read.delim("scaling.tsv")
errors = read.delim("error-scaling.tsv")
errors$kb = errors$size/1000

pdf("scaling.pdf", width=6, height=2.5, pointsize=7)
layout(matrix(c(1,2), 1, 2, byrow=T), widths=c(1,1))

old = par(mar=c(5.1,4,2.1,2), lwd=0.2)

plot(size1 ~ compression, data[data$samples==10000,], log='xy',
     xlab=expression(1/delta), ylab="Size (kB)", ylim=c(100,100000),
     cex=1, bg=rgb(0,0,0,0.1), col=rgb(0,0,0,0.1), pch=21,
     yaxt='n')
axis(at=c(100,1000,10000,100000), labels=c("0.1", "1", "10", "100"), side=2)
box()

#points(size1 ~ compression, data[data$samples==100,], log='xy',
#     xlab=expression(1/delta), ylab="Size (kB)",
#       cex=0.5, bg=rgb(0,0,0,0.1), col=rgb(0,0,0,0.1), pch=21)
#
points(size1 ~ compression, data[data$samples==10,],
       cex=1, bg=rgb(0,0,0,0.1), col=rgb(0,0,0,0.1), pch=22)

legend(2, 9e4, c("10M samples", "10k samples"), pch=c(21,22))

c = seq(2,1100,by=1)
m10 = lm(log(size1) ~ log(compression), data[data$samples==10,])
m100 = lm(log(size1) ~ log(compression), data[data$samples==100,])
m10000 = lm(log(size1) ~ log(compression), data[data$samples==10000,])
lines(c, exp(predict(m10, newdata=data.frame(compression=c))), lty=2, col='lightgray')
#lines(c, exp(predict(m100, newdata=data.frame(compression=c))), lty=2, col='lightgray')
lines(c, exp(predict(m10000, newdata=data.frame(compression=c))), lty=2, col='lightgray')
par(old)

old = par(mar=c(5.1,4.2,2.1,2), lwd=0.2)
plot(size2/1000 ~ samples, data[data$compression==100,], log='x', ylim=c(0,22),
     xlab="Samples (x1000)", ylab="Size (kB)", xaxt='n',
     cex=1, bg=rgb(0,0,0,0.1), col=rgb(0,0,0,0.1), pch=21, main=expression(1/delta == 100))
axis(at=c(10,100,1000,10000), labels=c(10,100,1000,"10,000"), side=1)
points(size1/1000 ~ samples, data[data$compression==100,],
       cex=1, bg=rgb(0,0,0,0.1), col=rgb(0,0,0,0.1), pch=22)
ms2 = lm(size2/1000 ~ log(samples), data[data$compression==100,])
s = seq(10, 10000, by=10)
lines(s, predict(ms2, newdata=data.frame(samples=s)), lty=2, col='lightgray')

ms1 = lm(size1/1000 ~ log(samples), data[data$compression==100,])
lines(s, predict(ms1, newdata=data.frame(samples=s)), lty=2, col='lightgray')

samples = c(10,100,1000,10000)
mpSize = 6*((samples*1000) ^ 0.5 * 4)/1000
lines(samples, mpSize, lty=5, pch=23, type='b', lwd=0.8, col='grey')
points(samples, mpSize, lty=5, pch=23)

#box()

legend(9, 22, c("uncompressed", "compressed", "Munro-Paterson"), pch=c(21,22,23))

par(old)

dev.off()

pdf("error-scaling.pdf", width=6, height=2, pointsize=7)
layout(matrix(c(1,2,3), 1, 3, byrow=T), widths=c(1.18,1,1))

for (q in c(0.5, 0.01, 0.001)) {
  if (q == 0.5) {
    old = par(mar=c(5.1,4.5,2.1,2))
  } else {
    old = par(mar=c(5.1,0,2.1,2))
  }
  par(lwd=0.2)
  top = paste("q =", q)
  plot(error ~ kb, errors[errors$q == q,],
       ylim=c(-0.05, 0.05),
       pch=21, bg=rgb(0,0,0,.1), col=rgb(0,0,0,.1), log='x',
       xlab="t-digest size (kB)", ylab="Quantile error", cex.lab=1.5,
       yaxt='n', main=top)
  abline(h=0, col='lightgray')
  abline(h=0.01, col='lightgray', lty=2)
  abline(h=-0.01, col='lightgray', lty=2)

  box()
  if (q == 0.5) {
    axis(side=2)
  }
  text(20, 0.09, paste("q =",q))
  par(old)
}

dev.off()


###############################################################################
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
###############################################################################
# Binary Branch and Bound and it's adaption for QP problem
# Copyright (C) 1998-2000  Alberto Bemporad, Domenico Mignone - author's of the original Matlab version
# Copyright (C) 2011  Michael Kapler - adapted code to R
#
# For more information please visit my blog at www.SystematicInvestor.wordpress.com
# or drop me a line at TheSystematicInvestor at gmail
###############################################################################

###############################################################################
# Binary Branch and Bound algorithm adpated from
# miqp.m, a Matlab function for solving Mixed Integer Quadratic Programs
# by Alberto Bemporad, Domenico Mignone
# The routine was modified to work with large set of optimization problems.
#
# http://www.aut.ee.ethz.ch/~hybrid/miqp/
#' @export
###############################################################################
binary_branch_bound <- function
(
	index_binvar,		# index of binary[0/1] variables
	bbb_data, 			# data used for solving problems
	bbb_solve, 			# bbb_solve(bbb_data, binvar_lb, binvar_ub) - function to solve problems
	control = bbb_control()	# control the behavior of binary_branch_bound
)
{
# Output:
# xmin: minimizer of the cost function
# fmin: minimum value of the cost function
# counter: number of executions
# flag: integer flag characterizing the result, where:
#  if flag = 1 there exists a feasible solution
#  if flag = 5 the solution is not integer feasible
#  if flag = 7 no feasible solution exists

	fbest = Inf
	xbest = 0 * bbb_data$x0
	counter = 0
	nbinvar = length(index_binvar)
	flag = 7 	# by default it is infeasible

	# The Variable STACK will contain the subproblems
	stack = new.env()
		stack$data = list()
		stack$cost = c()
		stack$pointer = c()
	stack$data[[1]] = list(lb = bbb_data$lb,
							ub = bbb_data$ub,
							var = 1:nbinvar,
							path = rep(0,nbinvar),
							level = 0,
							fval = Inf)
	stack$cost = 0		# Array storing the cost of the problems, ordered in decreasing fashion (cost(1)=largest value)
	stack$pointer = 1	# pointer stores the order of the list

	control$proborder.selected = control$proborder

	if(F) {
		lb = bbb_data$lb
		ub = bbb_data$ub

		# presolve two default cases
		for( i in 0:1 ) {
			lb[] = i
			ub[] = i
			sol = match.fun(bbb_solve)(bbb_data, lb, ub)

			if( sol$ok ) {
				x = sol$x
				fval = sol$fval
	            xi = x[index_binvar]	# binary variables

				# found solution
				if ( max(abs( round(xi,0) - xi )) < control$bineps ) {
					fbest = fval
				    xbest = x
				    flag = 1
				    if( !control$silent ) cat('FOUND SOLUTION =', fbest, '\n');
				}
			}
		}
	}

	# Main Loop
	while ( length(stack$data) > 0 ) {
	    # Get the next subproblem from the STACK
		subprob = bbb_pop(stack)

		if( !control$silent ) {
			cat('-----------------------------------------------------', '\n')
			if( max(subprob$path) > 0 ) {
				temp.index = order(-subprob$path)[1 : sum(subprob$path > 0)]
				cat('\t',
					paste('b', temp.index, ' = ', subprob$lb[temp.index],sep='')
					, '\n')
			} else {
				cat(counter, '\t', 'FIRST NODE', '\n')
			}

			cat(counter, '\t', subprob$lb, '\t', subprob$var, '\t', subprob$fval, '\t', fbest, '\n')
			cat('\t', subprob$ub, '\n')
			cat('stack size =', len(stack$pointer), '\n')
		}

		if( is.finite( subprob$fval ) & is.finite( fbest ) & fbest <= subprob$fval ) {
			# skip this problem because fbest is alredy smaller
			if( !control$silent ) cat('SKIP this problem because a solution with lower FVAL already found\n')
		} else {

		    # Solve the qp
		    counter = counter + 1
			sol = match.fun(bbb_solve)(bbb_data, subprob$lb, subprob$ub)

			if( !sol$ok ) {
				if( !control$silent ) cat('NO SOLUTION EXISTS\n\n');
			} else {
				x = sol$x
				fval = sol$fval

				if( !control$silent ) {
					cat('SOLUTION OK', '\t', sol$fval, '\n')
					cat('\t', round(x[index_binvar[subprob$var]],3), '\n\n')
				}

		        if ( flag !=1 ) flag=5

		        # Check if value function is better than the value so far
		        if ( fval <= fbest ) {
			        if ( length(subprob$var ) == 0 ) {
			        	# found solution
						fbest = fval
			            xbest = x
			            flag = 1
						if( !control$silent ) cat('FOUND SOLUTION =', fbest, '\n');
					} else {
			            xi = x[index_binvar[subprob$var]]	# binary variables

			            # found solution
			            if ( max(abs( round(xi,0) - xi )) < control$bineps ) {
			                fbest = fval
			                xbest = x
			                flag = 1
			                if( !control$silent ) cat('FOUND SOLUTION =', fbest, '\n');
			            } else {
			                # split problem in 0/1 subproblems
			                branchvar = bbb_decision(xi,control)
			                probs = bbb_separate(subprob, branchvar, fval)
			                p0 = probs$p0
			                p1 = probs$p1

			                if( !control$silent ) cat('Branch on =', subprob$var[branchvar], '\n');

			                if( control$searchdir == 0 ) {
								cost=1/(subprob$level+1) 	# Depth first
							} else if( control$searchdir == 1 ) {
								cost=subprob$level+1		# Breadth first
							} else if( control$searchdir == 2 ) {
								cost=fval					# Best-first. This tends to go breadth-first
							} else if( control$searchdir == 3 ) {
								cost=fval/(subprob$level+1)	# This privilegiates deep nodes
							}

							if( control$proborder == 2 ) {
								control$proborder.selected = round(xi[branchvar],0)
							}

			                if( control$proborder.selected == 0 ) {
			                	bbb_push(stack, p1, p0, cost)
			                } else {
			                	bbb_push(stack, p0, p1, cost)
							}
						}
					}
				}
			}

		    # verbose
		    if( F ) {
		        cat('counter =', counter, '\n')
		        cat('fbest     =', fbest, '\n')
		        cat('stack$pointer =', stack$pointer, '\n')
		        cat('\n')
		    }
		}
	} #end while
	rm(list=ls(stack,all=TRUE), envir=stack)

	#xbest[index_binvar] = round(xbest[index_binvar],0) # ROUNDOFF binary solution
	return(list(xmin = xbest, fmin = fbest, counter = counter, flag = flag))
}

###############################################################################
# Decision: find next branching variable
###############################################################################
bbb_decision <- function
(
	xi,			# x for binary variables
	control		# control the behavior of binary_branch_bound
)
{
	if( control$branchvar == 0 ) {
		# first free variable is chosen as branching variable
        branchvar = 1
	} else if( control$branchvar == 1 ) {
        # variable with max frac part is chosen as branching variable
        branchvar = which.max( abs(xi-round(xi,0)) )	#pick up the first of with max value
	} else if( control$branchvar == 2 ) {
        # variable with min frac part is chosen as branching variable
        branchvar = which.min( abs(xi-round(xi,0)) )	#pick up the first of with min value
	} else {
		branchvar = 1
	}
	return(branchvar)
}

###############################################################################
# Pop: returns top element of the STACK and eliminate the element from the stack
###############################################################################
bbb_pop <- function(stack)
{
	i = stack$pointer[ length(stack$data) ]
	subprob   = stack$data[[i]]

	stack$pointer[ stack$pointer > i ] = stack$pointer[ stack$pointer > i ] - 1

	# remove last
	stack$data[[i]] = NULL
	length(stack$cost) = length(stack$data)
	length(stack$pointer) = length(stack$data)

	return(subprob)
}

###############################################################################
# Push: puts a subproblem onto the STACK
###############################################################################
bbb_push <- function
(
	stack, 		# stack structure
	element1, 	# element to push on stack
	element2,	# element to push on stack
	cost		# cost
)
{
	n = length(stack$data)

	# Determine position in STACK where problem is inserted, according to a best first strategy
	i = match(TRUE, stack$cost <= cost)		# EX: STACKCOST=[100 80 33 22 ^ 5 3 2], cost=10
	if( is.na(i) ) i = n else i = i - 1

	stack$data[[ (n+1) ]] = element1
	stack$data[[ (n+2) ]] = element2

	if(i == 0) {
		stack$pointer=c((n+1),(n+2), stack$pointer)
		stack$cost=c(cost,cost, stack$cost)
	} else {
		stack$pointer=c(stack$pointer[1:i], (n+1),(n+2), stack$pointer[-c(1:i)])
		stack$cost=c(stack$cost[1:i], cost, cost, stack$cost[-c(1:i)])
	}
}

###############################################################################
# Separate: generates 2 new suproblems from a given problem
###############################################################################
bbb_separate <- function
(
	prob,		# QP parent problem
	branchvar,	# branching variable
	fval		# fval for parent problem
)
{
	if(length(prob$var) >= 1) {
		p0 = prob
			p0$fval = fval
		    p0$level = prob$level + 1
		    p0$var = prob$var[-branchvar]
		    p0$path[ prob$var[branchvar] ] = 1 + max(p0$path)
		p1 = p0

		p0$lb[ prob$var[branchvar] ] = 0
		p0$ub[ prob$var[branchvar] ] = 0

		p1$lb[ prob$var[branchvar] ] = 1
		p1$ub[ prob$var[branchvar] ] = 1
	} else {
		stop('no more integer variables to branch on')
	}
	return( list(p0 = p0, p1 = p1) )
}


print("summary")

# A Taxa2Dist implementation with Postgres and MPI
# Instead of calculating the huge matrix in RAM, we break it into
# a number of submatrices, based on the available RAM we are given as input.
# Each processor is calculating a portion of the submatrix and saves it in the DB.
# If needed, we restore the result table-by-table and save the taxdist in a csv file
# The program has been tested to provide correct results
#false to save
# To run: mpiexec -np 2 ../bin/Rscript taxa2distPostgresMPIv2.r "aggGenera400.csv" 1000000 "/home/patkos/R-3.1.1/Datasets" "/home/patkos/R-3.1.1/TeoScripts" TRUE "T_tmp"

# clean previous results
rm(list=ls())

# Initial Parameters given by the user
args <- commandArgs(trailingOnly = TRUE)
datasetName <- args[1] # The name of the csv file
MAXmem <- as.numeric(args[2]) # The size of RAM in bytes
datasetPath <- args[3] # The directory (path) where the dataset is stored
outputPath <- args[4] # The directory (path) where we wish the output CSV to be stored
keepResult <- as.logical(args[5]) # If we wish
tempTblName <- args[6] # The unique name of the temporary tables stored in postgres

# load libraries
library(dplyr)
library(RPostgreSQL)
library(pbdMPI, quiet = TRUE)

init()

# TP: Get the size of the cluster
processors <- comm.size()
myrank <- comm.rank()

# create pointers to DB
LwDB <- src_postgres(dbname = "", user = "", password = "")

drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv, dbname = "", user = "", password = "")

# TP: The step will be the number of rows/columns assigned to each node
# TP: The rest are matrices that will be sent to each node
agg <- NULL
add <- NULL
out <- NULL

# TP: Only the master node performs these tasks
if (myrank == 0) {

if(!dbExistsTable(con, datasetName)){
  # set path to datasets, if not in DB already
  setwd(datasetPath)

  #aggs contains the aggregation file
  agg <- read.table(datasetName, header = TRUE, sep=",")

} else {
  # bring the dataset from the DB to memory
  aggDB <- tbl(LwDB, datasetName)
  agg <- as.data.frame(aggDB)
}

######## Inside Taxa2Dist
# These steps are the initialization operations of Taxa2Dist. Nothing changes here
varstep <- TRUE
check <- TRUE

rich <- apply(agg, 2, function(taxa) length(unique(taxa)))
S <- nrow(agg)
if (check) {
  keep <- rich < S & rich > 1
  rich <- rich[keep]
  agg <- agg[, keep]
}
i <- rev(order(rich))
agg <- agg[, i]
rich <- rich[i]
if (varstep) {
  add <- -diff(c(nrow(agg), rich, 1))
  add <- add/c(S, rich)
  add <- add/sum(add) * 100
}
else {
  add <- rep(100/(ncol(agg) + check), ncol(agg) + check)
}
if (!is.null(names(add)))
  names(add) <- c("Base", names(add)[-length(add)])
if (!check)
  add <- c(0, add)

# TP: Only matrices can be sent through pbdMPI so we transform 'add' to matrix
add <- matrix(add)

}

# TP: Broadcast the two matrices to all CPUs
agg.all <- bcast(agg, rank.source = 0)
add.all <- bcast(add, rank.source = 0)

### We first check if we have enough RAM to execute the actual vegan function
# N is the number of rows of our dataset
N <- nrow(agg.all)
# The number of elements that will be created by the outer product
elements <- N*N
# The total number of elements a matrix can have that fit in RAM
maxElements <- floor(((MAXmem-200)/8 ) /3 )

# We need to break the NxN matrix into submatrices, having m<=N rows and N columns
# As a result, the submatrix should have m = maxElements/N rows
m <- floor (maxElements/N )
if (m > N) {m <- N}

# The number of submamtrices
numOfMatrices <- ceiling(N/m)

comm.print("Number of submatrices that will be needed:")
comm.print( numOfMatrices)

# This is the number of rows in each submatrix that a processor is assigned to
step <- ceiling(m/processors)

if (numOfMatrices > 1) {
for (k in 1:(numOfMatrices-1)) {

# TP: Now, each node has a different set of data to work with
start <- ((k-1)*m) + myrank*step+1
end <- start+step-1
# TP: The last node has less elements that the rest, i.e., the remaining elements
if (myrank == processors-1) {end<-k*m}

#comm.print(object.size(agg.all), all.rank = TRUE)
#comm.print(start, all.rank = TRUE)
#comm.print(end, all.rank = TRUE)

#out <- matrix(add.all[1], nrow(agg.all), (end-start+1))
out <- matrix(add.all[1], (end-start+1), nrow(agg.all))

# TP: This is the main loop that is performed on each processor separately
for (i in 1:ncol(agg.all)) {
  out <- out + add.all[i + 1] * outer(agg.all[start:end, i], agg.all[, i], "!=")
}

  # Save it to the DB
  dbWriteTable(con, paste(tempTblName,k,"P",myrank), as.data.frame(as.vector(out)), append = F)

  # Continue with the rest of the rows, therefore reinitialize the matrix
  rm(out)
  out <- matrix(add.all[1], (end-start+1), nrow(agg.all))

} # end for k

} # end if

### Now the last matrix

######################################3

  # Do the same for the last matrix that may have less than m rows
  doneRows <- (numOfMatrices-1)*m
  m <- N-((numOfMatrices-1)*m)
  step <- ceiling(m/processors)
  start <- doneRows + myrank*step+1
  end <- start+step-1
  # TP: The last node has less elements that the rest, i.e., the remaining elements
  if (myrank == processors-1) {end<- N}
  rm(out)

  out <- matrix(add.all[1], (end-start+1), nrow(agg.all))
  for (i in 1:ncol(agg.all)) {
    out <- out + add.all[i + 1] * outer(agg.all[start:end, i], agg.all[, i], "!=")
  }

#comm.print(dim(out), all.rank = TRUE)

  # Save it to the DB
    dbWriteTable(con, paste(tempTblName,numOfMatrices,"P",myrank), as.data.frame(as.vector(out)), append = F)

  rm(out)

  ## Now, all our data is stored in Postgres in consecutive tables

  ######################################3

  ####### Write output to a CSV file
  ##
  if (!keepResult && myrank == 0) {

  setwd(outputPath)

  for (k in 1:numOfMatrices) {
    for (proc in 0:(processors-1)) {

  # Take a reference to the table
  outDB <- tbl(LwDB, paste(tempTblName,k,"P",proc))

  #dim(outDB)

  outputFrame <- head(outDB, n=nrow(outDB))
  colnames(outputFrame) <- c("index", "values")

  attach(outputFrame)
  setOfRows <- nrow(outDB)/N
  output <- matrix(values, setOfRows,N)
  detach(outputFrame)
  if (k>1 || proc >0) {
   write.table(output, file="taxa2DistPostgres.csv", row.names=FALSE, col.names=FALSE, , sep=",", append = TRUE)
  } else {
   write.table(output, file="taxa2DistPostgres.csv", row.names=FALSE, col.names=FALSE, , sep=",")
  }

  #output[upper.tri(output, diag = T)] <- 0
  #output <- as.dist(output)
  #output <- as.matrix(output)

  ##object.size(output)

     dbRemoveTable(con, paste(tempTblName,k,"P",proc))
	 rm(outDB)
	 rm(output)
	 rm(outputFrame)

  } # end for proc

  } # end for numOfMatrices

  } # end if myrank

	output <- c(N, numOfMatrices, processors, tempTblName)
    comm.print("Below are the size of the distance matrix, the num of submatrices created, the processors used and the submatrices name", rank.print = 0)
    comm.print(output, rank.print = 0)

## Closes the connection
dbDisconnect(con)

finalize()

 # For verification purposes, to show that the results are correct
  #################################
  #library(vegan)
  #setwd("/home/patkos/R-3.1.1/Datasets")
  #agg <- read.table(datasetNameInDB, header = TRUE, sep=",")
  #taxdis <- taxa2dist(agg, varstep=TRUE)
  #write.table(as.matrix(taxdis), file="/home/patkos/R-3.1.1/TeoScripts/taxdis.csv", row.names=FALSE, col.names=FALSE, , sep=",")

  #setwd("/home/patkos/R-3.1.1/TeoScripts")
  #taxdisCustom <- read.table("outDB.csv", header = FALSE, sep=",")
  #taxdisCustom[row(taxdisCustom) == col(taxdisCustom)] <- 0

  #dim(taxdisCustom)
  #comparison <- as.matrix(taxdis) - taxdisCustom
  #write.table(comparison, file="/home/patkos/R-3.1.1/TeoScripts/comparison.csv", row.names=FALSE, col.names=FALSE, , sep=",")

  #all.equal(as.matrix(taxdis), as.matrix(as.dist(taxdisCustom)))


# Copyright Syncfusion Inc. 2001 - 2016. All rights reserved.
# Use of this code is subject to the terms of our license.
# A copy of the current license can be obtained at any time by e-mailing
# licensing@syncfusion.com. Any infringement will be prosecuted under
# applicable laws.

# If you are not familiar with R you can obtain a quick introduction by downloading
# R Succinctly for free from Syncfusion - http://www.syncfusion.com/resources/techportal/ebooks/rsuccinctly
# R Succinctly is also included with this installation and is available here
# Installed Drive :\Program Files (x86)\Syncfusion\Essential Studio\XX.X.X.XX\Infrastructure\EBooks\R_Succintly.pdf OF R Succinctly
# Uncomment below lines to install necessary packages if not installed already
#install.packages("gbm")
#install.packages("devtools")
#install.packages("rJava")
#install_github(repo = "jpmml/r2pmml")
# install.packages("caret")

# Load below packages
library(caret) # This package is specifically loaded for Cars dataset shipped within it.
library(devtools)
library(gbm)
library(rJava)
library(r2pmml)

# Here we directly load the cars dataset installed with the "caret" package.
data(cars)
# Omit rows with missing values
cars = na.omit(cars)

# Code below demonstrates loading the same dataset from a CSV file shipped with our installer.
# Please check installed samples (Data) location to set actual working directory
# Uncomment below lines and comment out the code to read data from CSV file.
# setwd("C:/actual_data_location")
# cars= read.csv("Cars.csv")

# Divide dataset for training and test
trainData<-cars[1:643,]
testData<-cars[644:804,]

# Applying the GBM - laplace function to predict cens
cars_GBM =  gbm(Price~., data=trainData,distribution="laplace")

# Display the predicted results
# Predict "Price" column probability for test data set
carsTestProbabilities =predict.gbm(cars_GBM, newdata=testData, n.trees=100,type="response")
# Display predicted probabilities
carsTestProbabilities

# PMML generation
r2pmml(cars_GBM,"Cars.pmml")

# The code below is used for evaluation purpose.
# The model is applied for original cars data set and predicted results are saved in "ROutput.csv"
# "ROutput.csv" file used for comparing the R results with PMML Evaluation engine results

# Load Original "cars" dataset from "caret" package
data(cars)
# Omit rows with missing values
carsOriginal = na.omit(cars)

# Applying GBM to entire dataset and save the results in a CSV file
carsEntireProbabilities = predict.gbm(cars_GBM,carsOriginal,n.trees=100,type="response")

# Save predicted value in a data frame
result = data.frame(carsEntireProbabilities)
names(result) = c("Predicted_RetailPrice")

# Write the results in a CSV file
write.csv(result,"ROutput.csv",quote=F)


#' title: Model definitions
#'
#' @usage
#'
#' death(rho, parms)
#' colonization(rho, parms)
#' mortality(rho, parms)
#' growth(rho, parms)
#'
#' @details defining chances of death and colonization per location, depending on the global and local vegetation cover.
#'
#' @export
#'

death <- function(rho, parms = livestock$parms) {

  # set clustering zero if cover is zero
  cc = q_11(rho)/rho[[1]]
  cc[is.nan(cc)] <- 0

  # substitutions
  a = parms$a + parms$v * cc #* (1 - parms$p) * q_11(rho)
  a = a * rho[[1]]^(parms$q)  # density dependent search efficiency: fr type III
  h = parms$h #^(1 + parms$p * q_11(rho))
  L = parms$L * (1 -  parms$p * q_11(rho) )

  # individual death rate
  out <-  parms$m  + a * L / (1 + a * h * rho[[1]])

  out[out < 0] <- 0
  return(as.vector(out))

}

#' @export
mortality <- function(rho, parms = livestock$parms) {
  death(rho, parms) * rho[[1]]
}

#' @export

colonization <- function(rho, parms = livestock$parms)  {

  # substitutions
  b = parms$b + (1- parms$b) * parms$f * q_01(rho)  # facilitation
  r = parms$r * rho[[1]]^parms$alpha   # water runoff (not discussed)
  K = parms$K *  (1 - parms$c * q_01(rho))

  # individual colonization rate
  out <-   r * rho[[1]] * b * (1 - rho[[1]]/K ) / (1-rho[[1]])

  out[out < 0] <- 0
  return(as.vector(out))
}

#' @export
growth <- function(rho, parms = livestock$parms)  {
  colonization(rho, parms) * (1-rho[[1]])
}


#plot function group correlations
rm(list=ls())
library(data.table)
library(betareg)
library(PerformanceAnalytics)
source('NEFI_functions/crib_fun.r')
d <- data.table(readRDS('/fs/data3/caverill/NEFI_microbial/prior_data/ted_all_prior_data.rds'))
of_interest <- d[,.(Ectomycorrhizal,Arbuscular,Saprotroph,hydrophillic,hydrophobic)]
#setup data
of_interest <- lapply(of_interest,crib_fun)
of_interest <- lapply(of_interest,logit)
of_interest <- as.data.frame(of_interest)

png(filename='figures/ted_fungal_groups_correlations.png',width=10,height=10,units='in',res=300)
chart.Correlation(of_interest,  pch = 16, cex.labels = 2)
dev.off()

#Just plot of ECM vs. SAP.
png(filename='figures/ted_ECM.SAP_corr.png',width=5,height=5,units='in',res=300)
of_interest <- as.data.frame(of_interest)
par(mfrow= c(1,1),
    mai = c(0.1,0.1,0.1,0.1),
    oma = c(4,4,0,0))
plot(Saprotroph ~ Ectomycorrhizal, data = of_interest, cex = 0.7, pch = 16, ylab = NA, xlab = NA)
abline(lm(Saprotroph ~ Ectomycorrhizal, data = of_interest), lwd = 2)
r.sq <- summary(lm(Saprotroph ~ Ectomycorrhizal, data = of_interest))$r.sq
mtext(paste('r2=',round(r.sq,2)), side=3, line=-1.5, cex = 1.2, adj = 0.9)
mtext('Saprotroph Abundance'     , side = 2, line = 2.5, cex = 1.2)
mtext('Ectomycorrhizal Abundance', side = 1, line = 2.5, cex = 1.2)
dev.off()

testing_development/tedersoo_fits/plotting functional group correlations.r


gen_allom <- function(data,tau,fileName,zone=NULL,biome=NULL){
#
# Function that generates qunatile regression allometry for the data from
# Jucker et al 2016 paper on allometric relations for different biomes
#
# The function takes the Height and CD and performs logarithmic quantile
# regression on these. The model fits CD as a*H^b. The parameter tau sets which
# quantile of the data is to be used (eg 0.95 for 95-th qunatile). This is
# designed to be an upper bound for allometry. fileName then sets the prefix to
# be included in the output file eg "neotropical_tropic".
#
# When set, zone and biome subset the data to only use those data from a
# specific biogeographical zone and biome respectively.
#
# Arguments
#
#       data:           .csv file of data from paper
#       tau:            Quantile to be used (eg 0.95 for 95-th)
#       fileName:       prefix for file name of allometry table to be saved
#       zone:           Name of biogeographic zone as set out in the data
#       biome:          Name of biome as set out in the the data

        # Load Dependancies
        if(!require("quantreg")){
                install.packages("quantreg")
        }
        library(quantreg)

        # Subset relevant data if requested
        alo_data <- read.csv(data,stringsAsFactors = F)
        if(!is.null(zone)){
                reg_data <- subset(alo_data,alo_data$Biogeographic_zone == zone)
        } else {
                reg_data <- all_data
        }
        if(!is.null(biome)){
                biome_data <- subset(reg_data,reg_data$Biome == biome)
        } else {
                biome_data <- reg_data
        }

        # Build log-log quantile regression model
        mdl <- rq(formula = log(CD) ~ log(H), data = biome_data, tau = tau)
        max_H = max(biome_data$H)
        X <- 0:ceiling(max_H)
        Y = exp(mdl$coefficients[1])*X^(mdl$coefficients[2])

        # Save the results out as Crown Diameter and Radius respectively vs H
        write.table(cbind(X,Y),file=paste(fileName,'_HD_',as.character(round(100*tau)),".csv",sep=""),col.names = F,row.names = F,sep=",")
        write.table(cbind(X,Y/2),file=paste(fileName,'_HR_',as.character(round(100*tau)),".csv",sep=""),col.names = F,row.names = F,sep=",")
}


library("MASS") # for exponential fit

f <- file("stdin")
open(f)
data <- read.table(f, header=FALSE, col.names=c("spacing"))

exp_fit <- fitdistr(data$spacing, "exponential")
cat("lambda\n")
cat(sprintf("%g\n", exp_fit$estimate[["rate"]]))


# plot graphics for exercise #2

x_ms <- c(26, 27, 28)
y_ms <- c(17.446, 35.958, 73.986)
png(file="mergesort-serial.png", bg="transparent")
plot(x_ms, y_ms, main='Mergesort (serial)', xlab='k', ylab='tempo(s)', type='b', col='dark red', lwd=3)
dev.off()

x_mp <- c(26, 27, 28)
y_mp2 <- c(10.478, 19.763, 41.079)
y_mp4 <- c(10.341, 21.707, 40.459)
y_mp8 <- c( 9.981, 20.644, 42.551)
png(file="mergesort-parallel.png", bg="transparent")
plot(x_mp, y_mp2, main="Mergesort (paralelo)", xlab="k", ylab="tempo(s)", type='b', col='dark red', lwd=3)
lines(x_mp, y_mp4, type='b', col="green", lwd=3)
lines(x_mp, y_mp8, type='b', col="blue", lwd=3)
legend('topleft', c('2 threads', '4 threads', '8 threads'), lty=1, col=c('dark red', 'green', 'blue'))
dev.off()


'
Plots the unconditional models to show short and long term effects of
Life events.

'

rm(list=ls())
source("project_paths.r")
 require(dplyr)
 require(tidyverse)
 require(plm)
 require(lmtest)
 require(broom)
source(paste(PATH_IN_FINAL, "psth.R", sep="/"))

# good event names
good_events <- c(
  "Married", "Childbirth", "Money_gained",
  "Retired", "Pregnant", "Promoted",
  "Hired", "Moved", "Reconciled"
  )

# bad event names
bad_events <- c(
  "Widowed", "Separated", "Money_lost",
  "Health_shock", "Attacked", "Fired",
  "Family_harmed", "Friend_died", "Robbed"
  )

renamevents <- list(
    Widowed = "ledsc",
    Separated = "lesep",
    Money_lost = "lefnw",
    Jailed = "lejls",
    Attacked = "levio",
    Health_shock = "leins",
    Reconciled = "lercl",
    Fired = "lefrd",
    Family_harmed = "leinf",
    Robbed = "lepcm",
    Friend_died = "ledfr",
    Relative_died = "ledrl",
    Relative_jailed = "lejlf",
    Moved = "lemvd",
    Hired = "lejob",
    Promoted = "leprm",
    Retired = "lertr",
    Money_gained = "lefni",
    Pregnant = "leprg",
    Childbirth = "lebth",
    Married = "lemar"
    )

read_csv(
    paste(PATH_OUT_DATA, "unconditional_results.csv", sep="/"),
    col_types = cols(
        code = col_character(),
        term = col_character(),
        estimate = col_double(),
        std.error = col_double(),
        statistic = col_double(),
        p.value = col_double(),
        std.error = col_double(),
        df = col_double(),
        n = col_double(),
        N = col_double(),
        outcome = col_character(),
        upper = col_double(),
        lower = col_double()
        )
    ) %>%
  mutate(
      # term = factor(term, levels = timelevels, ordered = TRUE)
      # code = factor(code)
      code = fct_recode(code, !!!renamevents)
      ) -> results

# levels(results$code) <- renamevents

#### Plot coefficients from unconditional model ####
png(filename=paste(PATH_OUT_FIGURES, "unconditional_model_positive_events_plot.png", sep="/"))
figure1_str <- c('Unconditional effect of positive events on wellbeing')
psth(results, good_events, figure1_str)
dev.off()

png(filename=paste(PATH_OUT_FIGURES, "unconditional_model_negative_events_plot.png", sep="/"))
figure2_str <- c('Unconditional effect of negative events on wellbeing')
psth(results, bad_events, figure2_str)
dev.off()

######

#rm(list=ls())
#source("project_paths.r")
 require(dplyr)
 require(tidyverse)
 require(plm)
 require(lmtest)
 require(broom)
source(paste(PATH_IN_FINAL, "psth.R", sep="/"))

read_csv(
    paste(PATH_OUT_DATA, "unconditional_results_finance_and_safety.csv", sep="/"),
    col_types = cols(
        code = col_character(),
        term = col_character(),
        estimate = col_double(),
        std.error = col_double(),
        statistic = col_double(),
        p.value = col_double(),
        std.error = col_double(),
        df = col_double(),
        n = col_double(),
        N = col_double(),
        outcome = col_character(),
        upper = col_double(),
        lower = col_double()
        )
    ) %>%
  mutate(
      # term = factor(term, levels = timelevels, ordered = TRUE)
      # code = factor(code)
      code = fct_recode(code, !!!renamevents)
      ) -> results

# levels(results$code) <- renamevents

#### Plot coefficients from unconditional model ####
png(filename=paste(PATH_OUT_FIGURES, "unconditional_model_positive_events_financial_and_safety_plot.png", sep="/"))
figure1_str <- c('Unconditional effect of negative events on Sense of Financial \nSecurity and Safety')
psth(results, good_events, figure1_str)
dev.off()

png(filename=paste(PATH_OUT_FIGURES, "unconditional_model_negative_events_financial_and_safety_plot.png", sep="/"))
figure2_str <- c('Unconditional effect of negative events on Sense of Financial \nSecurity and Safety (HILDA 2002 to 2016)')
psth(results, bad_events, figure2_str)
dev.off()

read_csv(
    paste(PATH_OUT_DATA, "unconditional_results_finance_and_risk.csv", sep="/"),
    col_types = cols(
        code = col_character(),
        term = col_character(),
        estimate = col_double(),
        std.error = col_double(),
        statistic = col_double(),
        p.value = col_double(),
        std.error = col_double(),
        df = col_double(),
        n = col_double(),
        N = col_double(),
        outcome = col_character(),
        upper = col_double(),
        lower = col_double()
        )
    ) %>%
  mutate(
      # term = factor(term, levels = timelevels, ordered = TRUE)
      # code = factor(code)
      code = fct_recode(code, !!!renamevents)
      ) -> results

# levels(results$code) <- renamevents

#### Plot coefficients from unconditional model ####
png(filename=paste(PATH_OUT_FIGURES, "unconditional_model_positive_events_financial_security_and_risk_aversion_plot.png", sep="/"))
figure1_str <- c('Unconditional effect of positive events on Sense of Financial \nSecurity and Risk aversion ')
psth(results, good_events, figure1_str)
dev.off()

png(filename=paste(PATH_OUT_FIGURES, "unconditional_model_negative_events_financial_security_and_risk_aversion_plot.png", sep="/"))
figure2_str <- c('Unconditional effect of negative events on Sense of Financial \nSecurity  and Risk Aversion (HILDA 2002 to 2016)')
psth(results, bad_events, figure2_str)
dev.off()


##############################
## split-lapply combos
## Tutorial 01
##
## Karl Cottenie
##
## 2017-12-04
##
##############################
getwd()
setwd('/Users/Cam/Desktop/Code/RUsersGroup')

library(tidyverse)
library(viridis)

# Startup ends here

# Explore data set -----------------

serengeti = read_csv("http://datadryad.org/bitstream/handle/10255/dryad.86348/consensus_data.csv")
# For meta data on this data set, visit this link:
# http://datadryad.org/bitstream/handle/10255/dryad.86348/README.docx
head(serengeti)
summary(serengeti)

# Almost all data sets have grouping variables, and you want to repeat something for each of the groups
# Welcome to the world of split-lapply

# Split the data on the species identity, what is a list? -----
serengeti.Site = split(serengeti, serengeti$SiteID)
#splits it into 225
length(serengeti.Site)

# This is now a list with as each element a subset of the original data set
#double slice to see each lil bit
serengeti.Site[[1]] # this is how you inspect an element of the list

summary(serengeti.Site[[1]])

names(serengeti.Site) # each of the sub dataframes is named by the
						#site ID from when it was split off

# you can also call the different sites by their ID (the thing they were split by)
# So this can act like a sudo dictonary
serengeti.Site$B07
serengeti.Site[["B09"]]

### Pair: How many rows and columns are there in F08?
nrow(serengeti.Site$F08)
#1396

x = c(1,2,3,4,5,6)

x[2:4]

### Pair: What was the first and last day that the camera trap took pictures?

# difference between [] and [[]] for a list -----
serengeti.Site[1] #This is a list with one element!
summary(serengeti.Site[1])

### Pair: Can you predict what these two lines will do?
serengeti.Site[1:4] #sites one to four

serengeti.Site[1]

### Pair: Why do they behave differently?

# Apply some function of interest to all elements in a list, lapply ----
dim(serengeti)
dim(serengeti.Site) # dim only works for a matrix-like object
length(serengeti.Site) # this is how you check how many elements there are in a list
dim(serengeti.Site[[1]]) # how many pictures from the first site?
dim(serengeti.Site[[2]]) # how many pictures from the second site?

### Pair: before you run the next line, what word should replace the XXX:
dim(serengeti.Site[[length(serengeti.Site)]]) # how many pictures from the last site in the list?

# this is where the magic happens
lapply(serengeti.Site, dim)

# lapply: apply a function to a list
# the list: serengeti.Site
# the function: dim
dim(serengeti.Site[['V12']])
dim(serengeti.Site[['U10']])

### Pair: how would you check that the lapply line of code above worked correctly?

# apply some function of interest to all elements in a list, for loop -----
for(i in 1:length(serengeti.Site)){
    print(dim(serengeti.Site[[i]]))
}

# for: apply something to a sequence
# i in seq_along(serengeti.Site) is the sequence generator
# print(dim(serengeti.Site[[i]])) is the something, in this case asking for the dimensions

### Pair: why is the print() statement necessary?

# Applying some function to all elements in a list, and save the results -----

site.dim.lapply = lapply(serengeti.Site, dim)

site.dim.for = list()                                 # 1. output of the loop
for (i in seq_along(serengeti.Site)) {                # 2. sequence to loop through
  site.dim.for[[i]] = dim(serengeti.Site[[i]])        # 3. body of the function
  #print(dim(serengeti.Site[[i]]))                      # 4. body of function can be multiple lines
}

for(i in 1:length(site.dim.lapply)){
  print(site.dim.lapply[[i]] == site.dim.for[[i]])
}

site.dim.for[1]
site.dim.lapply[1]

for(i in 1:length(site.dim.lapply)){
  if(site.dim.lapply[[i]] != site.dim.for[[i]]){
      print('error')
  }
}

### Pair: how would you check that lapply and for-loop results are the same, using only the tools we have used so far?

# Homework 01: -----

serengeti.behaviours = serengeti[10:11] # a data frame/tibble is a list of columns/variables!
plot_by_species = split(serengeti[10:11], serengeti$Species)
to_plot = plot_by_species[1:10]

head(plot_by_species)
summary(serengeti.behaviours)

### Pair: apply the summary function to each of the different species

plot(serengeti.behaviours)

par(mfrow=c(2,5))
lapply(plot_by_species[1:10], plot)

### Pair: apply the plot function to the first 10 species
### Pair-intermediate: can you plot the species name as the title of the plot?

behaviour_name_plot = function(data){
  plot(data[[1]], main=names(data) )
}

#test
behaviour_name_plot(to_plot[2])

par(mfrow=c(2,5))

for(i in 1:10){
  behaviour_name_plot(to_plot[i])
}

apply_behaviour_name_plot = function(data, name_dat){
  plot(data[[1]], main=name_dat, xlab=names(data)[1], ylab=names(data[2]) )
}

par(mfrow=c(2,5))

mapply(apply_behaviour_name_plot, to_plot, names(to_plot))

#make a change


 E04MXJ Example Program Results

 MPSX INPUT LISTING
 ------------------
 Searching for indicator line
 Line          1: Found NAME indicator line
                  Query mode - Ignoring NAME data.
 Line          2: Found ROWS indicator line
                  Query mode - Counting ROWS data.
 Line          7: Found COLUMNS indicator line
                  Query mode - Counting COLUMNS data.
 Line         26: Found RHS indicator line
                  Query mode - Ignoring RHS data.
 Line         31: Found RANGES indicator line
                  Query mode - Ignoring RANGES data.
 Line         35: Found BOUNDS indicator line
                  Query mode - Counting BOUNDS data.
 Line         54: Found QUADOBJ indicator line
                  Query mode - Counting QUADOBJ data.
                  Query mode - End of QUADOBJ data. Exit

 MPSX INPUT LISTING
 ------------------
 Searching for indicator line
 Line          1: Found NAME indicator line
 Line          2: Found ROWS indicator line
 Line          7: Found COLUMNS indicator line
 Line         26: Found RHS indicator line
 Line         31: Found RANGES indicator line
 Line         35: Found BOUNDS indicator line
 Line         54: Found QUADOBJ indicator line
 Line         64: Found ENDATA indicator line

 Problem contains   9 variables and   4 linear constraints

 Final objective value =  -8.068E+00
 Optimal X =
                   2.00    -0.23    -0.27    -0.30    -0.10     2.00     2.00    -1.78    -0.46


#' Data Shape
#'
#' @param basemod baseline formula. `outcome ~ running variable`.
#' @param covmod one-sided formula with covariates on rhs.
#' @param data data.frame
#' @param subset subset condition.
#' @param weights weight variable.
#' @param cluster cluster variable.
#' @param order order of polynomial.
#' @param cutoff numeric of cutoff point.
#'   If missing, search `option("discRD.cutoff")`
#' @param assign assignment rule of treatment.
#'   If "greater",
#'   treated whose running variable is greater than or equal to cutoff.
#'   If "smaller",
#'   treated whose running variable is less than or equal to cutoff.
#'   If missing, search `option("discRD.assign")`
#' @param bw numeric vector of bandwidth.
#'   If specified, use data
#'   whose running variables are within this range will be used.
#'   If missing, use data from treatment and control groups
#'   where the running variable is closest to the cutoff
#' @param global logical (default is FALSE).
#'   Whether to use all observations.
#'
#' @importFrom stats update
#' @importFrom stats na.omit
#' @importFrom rlang enquo
#' @importFrom rlang eval_tidy
#' @importFrom stats model.frame
#'
#' @examples
#' \dontrun{
#' running <- sample(1:100, size = 1000, replace = TRUE)
#' cov1 <- rnorm(1000, sd = 2); cov2 <- rnorm(1000, mean = -1)
#' y0 <- running + cov1 + cov2 + rnorm(1000, sd = 10)
#' y1 <- 2 + 1.5 * running + cov1 + cov2 + rnorm(1000, sd = 10)
#' y <- ifelse(running <= 50, y1, y0)
#' bin <- ifelse(y > mean(y), 1, 0)
#' w <- sample(c(1, 0.5), size = 1000, replace = TRUE)
#' raw <- data.frame(y, bin, running, cov1, cov2, w)
#'
#' set_optDiscRD(discRD.cutoff = 50, discRD.assign = "smaller")
#' a <- clean_rd_data(y ~ running + cov1, data = raw, weights = w, order = 2)
#' str(a)
#' }
#'
#'
clean_rd_data <- function(basemod,
                          covmod,
                          data,
                          subset,
                          weights,
                          cluster,
                          order = 1,
                          cutoff,
                          assign,
                          bw,
                          global = TRUE) {
  ## make formula
  mod <- basemod
  if (!missing(covmod)) {
    mod <- update(mod, paste0(c(". ~ .", all.vars(covmod)), collapse = "+"))
  }

  ## weight, cluster and subset condition vector
  wv <- NULL
  if (!missing(weights)) {
    if (!rlang::is_call(weights)) weights <- rlang::enquo(weights)
    wv <- rlang::eval_tidy(weights, data)
  }

  gv <- NULL
  if (!missing(cluster)) {
    if (!rlang::is_call(cluster)) cluster <- rlang::enquo(cluster)
    gv <- rlang::eval_tidy(cluster, data)
  }

  tfv <- NULL
  if (!missing(subset)) {
    if (!rlang::is_call(subset)) subset <- rlang::enquo(subset)
    tfv <- rlang::eval_tidy(subset, data)
  }

  ## clean data by model.frame
  args <- list(
    formula = mod,
    data = data,
    subset = tfv,
    weights = wv,
    cluster = gv,
    na.action = na.omit
  )

  clean <- do.call("model.frame", args)

  # shape clean_dt to adopt RD desing easily
  running <- all.vars(basemod)[2]

  if (missing(cutoff)) {
    cutoff <- getOption("discRD.cutoff")
    message("Use cutoff value registered by global options")
  }

  if (missing(assign)) {
    assign <- getOption("discRD.assign")
    message("Use assignment rule registered by global options")
  }

  usedt <- clean
  usedt$x <- usedt[, running] - cutoff

  if (order > 1) {
    for (j in seq(2, order)) {
      lab <- paste0("x", j)
      usedt[[lab]] <- usedt$x ^ j
    }
  }

  if (assign == "greater") {
    usedt$d <- ifelse(usedt$x >= 0, 1, 0)
  } else if (assign == "smaller") {
    usedt$d <- ifelse(usedt$x <= 0, 1, 0)
  } else {
    stop("Unknown assignment rule is used.")
  }

  usedt <- usedt[, names(usedt) != running]

  # temporal output list
  output <- list()
  output$data <- usedt
  output$RD.info <- list(
    running.variable = running,
    cutoff = cutoff,
    assignment = assign
  )

  # subset by bandwidth if global = FALSE
  if (!global) {
    if (missing(bw)) {
      if (assign == "greater") {
        lwr <- max(usedt[usedt$d == 0, "x"])
        upr <- 0
      } else if (assign == "smaller") {
        lwr <- 0
        upr <- min(usedt[usedt$d == 0, "x"])
      }
    } else {
      if (length(bw) == 1) {
        lwr <- -abs(bw)
        upr <- abs(bw)
      } else {
        lwr <- bw[1]
        upr <- bw[2]
      }
    }

    output$data <- usedt[lwr <= usedt$x & usedt$x <= upr, ]
    output$bw.subset <- list(global = FALSE, bw = c(lwr, upr))
  } else {
    output$bw.subset <- list(global = TRUE)
  }

  output

}


# Common data problems that are encountered

# A. Data type constraints
# 1. Converting data types
# Glimpse at bike_share_rides
glimpse(bike_share_rides)

# Summary of user_birth_year
summary(bike_share_rides$user_birth_year)

# Convert user_birth_year to factor: user_birth_year_fct
bike_share_rides <- bike_share_rides %>%
  mutate(user_birth_year_fct = as.factor(bike_share_rides$user_birth_year))

# Assert user_birth_year_fct is a factor
assert_is_factor(bike_share_rides$user_birth_year_fct)

# Summary of user_birth_year_fct
summary(bike_share_rides$user_birth_year_fct)

# 2. Trimming strings
# dplyr, assertive, and stringr are loaded and bike_share_rides is available
bike_share_rides <- bike_share_rides %>%
  # Remove 'minutes' from duration: duration_trimmed
  mutate(duration_trimmed = str_remove(duration, "minutes"),
         # Convert duration_trimmed to numeric: duration_mins
         duration_mins = as.numeric(duration_trimmed))

# Glimpse at bike_share_rides
glimpse(bike_share_rides)

# Assert duration_mins is numeric
assert_is_numeric(bike_share_rides$duration_mins)

# Calculate mean duration
mean(bike_share_rides$duration_mins)

# B. Range constraints
# 1. Ride duration constraints
# Create breaks
breaks <- c(min(bike_share_rides$duration_min), 0, 1440, max(bike_share_rides$duration_min))

# Create a histogram of duration_min
ggplot(bike_share_rides, aes(duration_min)) +
  geom_histogram(breaks = breaks)

# duration_min_const: replace vals of duration_min > 1440 with 1440
bike_share_rides <- bike_share_rides %>%
  mutate(duration_min_const = replace(duration_min, duration_min > 1440, 1440))

# Make sure all values of duration_min_const are between 0 and 1440. If no value is displayed then the assertion has worked correctly for all values
assert_all_are_in_closed_range(bike_share_rides$duration_min_const, lower = 0, upper = 1440)

# 2. Confirm dates are in the past
library(lubridate)
# Convert date to Date type
bike_share_rides <- bike_share_rides %>%
  mutate(date = as.Date(bike_share_rides$date))

# Make sure all dates are in the past
assert_all_are_in_past(bike_share_rides$date)

# Filter for rides that occurred before or on today's date
bike_share_rides_past <- bike_share_rides %>%
  filter(bike_share_rides$date <= today())

# Make sure all dates from bike_share_rides_past are in the past
assert_all_are_in_past(bike_share_rides_past$date)

# C. Uniqueness constraints
# 1. Full duplicates
# Count the number of full duplicates
sum(duplicated(bike_share_rides))

# Remove duplicates
bike_share_rides_unique <- distinct(bike_share_rides, .keep_all = TRUE)

# Count the full duplicates in bike_share_rides_unique
sum(duplicated(bike_share_rides_unique))

# 2. Removing partial duplicates
# Find duplicated ride_ids
bike_share_rides %>%
  count(ride_id) %>%
  filter(n > 1)

# Remove full and partial duplicates
bike_share_rides_unique <- bike_share_rides %>%
  # Only based on ride_id instead of all cols
  distinct(ride_id, .keep_all = TRUE)

# Find duplicated ride_ids in bike_share_rides_unique
bike_share_rides_unique %>%
  # Count the number of occurrences of each ride_id
  count(ride_id) %>%
  # Filter for rows with a count > 1
  filter(n > 1)

# 3. Aggregating partial duplicates
bike_share_rides %>%
  # Group by ride_id and date
  group_by(ride_id, date) %>%
  # Add duration_min_avg column
  mutate(duration_min_avg = mean(duration_min) ) %>%
  # Remove duplicates based on ride_id and date, keep all cols
  distinct(ride_id, date, .keep_all = TRUE) %>%
  # Remove duration_min column
  select(-duration_min)


#' @title Remove redundant equivalent columns
#'
#' @description Find the equivalant columns of a data.frame. Keep the first
#' remove the rest.
#' @param x a data.frame that may have repeated, equivalent columns.
#' @param keep_cols a character vector of columsn that should be kept.
#' @param verbose should information about dropped columns be printed?
#' (default FALSE)
#' @examples
#'
#' iris$Sepal.Length2 <- 3 * iris$Sepal.Length + 3
#' remove_equiv_columns(iris)
#'
#' @return a data frame where redundant columns have been dropeed.
#' @importFrom crayon italic
#' @importFrom equivalent has_equiv_column
#' @export
remove_equiv_columns <- function(x, keep_cols = character(), verbose = FALSE) {
  ec <- has_equiv_column(x, keep_cols, verbose)
  if (verbose) {
    if (any(ec)) {
      equiv_col <- c()
      for (j in seq_len(ncol(x)-1)) {
        equiv_col <- vapply((j+1):ncol(x),
               function(cn) {
                 if (!(names(x)[cn] %in% keep_cols)) {
                   equiv(x[[j]], x[[cn]])
                 } else {
                   FALSE
                 }
               },
               NA)
        if (isTRUE(any(equiv_col))) {
          cat(italic("\tThe following column(s) equivalent to ",
                     names(x)[j], "\n\tand are getting dropped:\n\t\t",
                     paste(names(x[,-seq_len(j), drop = FALSE])[equiv_col],
                     sep = "", collapse = "\n\t\t"),
                     "\n", sep = ""), sep = "")
        }
      }
    } else {
      cat(italic("No equivalent columns found.\n"))
    }
  }
  x[, !ec]
}


pdf_file<-"pdf/timeseries_daily.pdf"
cairo_pdf(bg="grey98", pdf_file,width=10,height=8.27)

par(cex.axis=1.1,omi=c(1,0.5,0.95,0.5),mai=c(0.1,1.25,0.1,0.2),mgp=c(5,1,0),family="Lato Light",las=1)

# Import data

christmas<-read.csv(file="myData/allyears.calendar.byday.dat.a",head=F,sep=" ",dec=".")
attach(christmas)

# Create chart

plot(axes=F,type="n",xlab="",ylab="number of deaths",V1,V2)

# other elements

axis(1,tck=-0.01,col="grey",cex.axis=0.9,at=V1[c(1,length(V1))],labels=c("1 July","30 June"))
axis(2,at=py<-pretty(V2),labels=format(py,big.mark=","),cex.axis=0.9,col=par("bg"),col.ticks="grey81",lwd.ticks=0.5,tck=-0.025)
points(V1,V2,type="l")
points(lowess(V2,f=1/5),type="l",lwd=25,col=rgb(255,97,0,70,maxColorValue=255))
text(123,V2[179],"Christmas",cex=1.1)
arrows(157,V2[179],172,V2[179],length=0.10,angle=10,code=0,lwd=2,col=rgb(100,100,100,100,maxColorValue=255))
arrows(192,V2[185],220,V2[185],length=0.10,angle=10,code=0,lwd=2,col=rgb(100,100,100,100,maxColorValue=255))
text(240,V2[185],"New Year",cex=1.1)

# Titling

mtext("Death risk on Christmas and New Year 1979-2004 (USA)",3,line=1.5,adj=0,cex=2,family="Lato Black",outer=T)
mtext("Number of deaths before reaching the emergeny room, sums of years per day",3,line=-0.2,adj=0,cex=1.35,font=3,col="black",outer=T)
mtext("Source: David Phillips, Gwendolyn E. Barker, Kimberly E. Brewer, Christmas and New Year as risk factors for death, Social Science & Medicine 71 (2010) 1463-1471",1,line=3,adj=1,cex=0.75,font=3,outer=T)
dev.off()


# Generic data QA
#
# For each rdata file in a directory:
# 1. Read in all rdata files
# 2. For each column in each dataframe/datatable/list object added to the environment, report on:
#   a. The data type of the column
#   b. The number of non-null records
# 3. Flag datasets where any columns contain a significant amount of nulls (relative to the size of the dataset)
#    or where the dataset is itself empty.

# For factors: give number of factor levels. If < 20, call `table()` on levels. if > 100, flag dataset

vector_report = function(v, n, hist_threshold=20){
  # Report for a single vector, i.e. a column from a dataframe
  report = list()
  report$datatype = class(v)
  report$length = length(v)
  report$uniques = length(unique(v))
  if(report$uniques<=hist_threshold){
    report$table = table(v)
  }
  if(is.numeric(v)){
    #report$quantiles = quantile(v,c(0, .0275, .25, .5, .75, .975, 1))
    report$min = min(v, na.rm=TRUE)
    report$max = max(v, na.rm=TRUE)
    report$mean = mean(v, na.rm=TRUE)
    report$median = median(v, na.rm=TRUE)
    report$sd = sd(v, na.rm=TRUE)
  }

  report$bad_records = 0
  null = sum(is.null(v))
  if(null) {
    report$null = null
    report$bad_records = report$bad_records + null
  }
  na = sum(is.na(v))
  if(na) {
    report$na = na
    report$bad_records = report$bad_records + na
  }
  if(is.factor(v) | is.character(v)){
    empty = sum(v=="", na.rm=TRUE)
    if(length(empty)>0){
      report$empty = empty
      report$bad_records = report$bad_records + empty
    }
    chars = nchar(as.character(v))
    report$minchars  = min(chars)
    report$maxchars  = max(chars)
    report$meanchars = mean(chars)
  }

  if(is.factor(v)){
    report$nlevels = length(levels(v))
  }

  report$flag = flag_report(report, n)

  list(report)
}

flag_report = function(report, n, bad_perc=.25, max_factor_levels=100){
  flag = c()
  #if(report$bad >= bad_perc*report$length | report$bad >= bad_perc*n) flag = TRUE
  if(report$bad_records >= bad_perc*report$length | report$bad_records >= bad_perc*n) {
    if(report$bad_records == n){
      flag = c(flag, "Empty column")
    } else {
      flag = c(flag, paste("More than",bad_perc,"bad records."))
    }
  }
  if(report$length == 0){
    flag= c(flag, "Zero length column.") }
  if (report$datatype == "factor"){
    if(report$nlevels >= max_factor_levels){
      flag = c(flag, paste("Greater than",max_factor_levels,"factor levels."))}
    if(report$nlevels != report$uniques){  # This might not be a good flag
      flag = c(flag, "Number of factor levels is different from number of unique values in column.")
    }
  }
  flag
}

data_quality_report_DF = function(dataset, dataset_name){
  # For dataframes/datatables
  d = dim(dataset)
  n = nrow(dataset)
  report = list()
  report$object_name = dataset_name
  report$dim = d
  report$n = n
  if(n==0){
    report$flags="Empty Dataframe"
    return(report)
  }
  report$columns=list()
  flags = list()
  for(i in 1:ncol(dataset)){
    column_name = colnames(dataset)[i]
    col = dataset[,i]
    col_report = list()
    col_report$details = vector_report(col, n)
    # Flag bad column names
    if(length(grep("^V[0-9]*$",column_name))) col_report$details[[1]]$flag = c(col_report$details[[1]]$flag, "Default column name.")
    if(length(grep("^X[.][0-9]*$",column_name))) col_report$details[[1]]$flag = c(col_report$details[[1]]$flag, "Default column name.")
    # Add column to list of flagged columns if necessary. Should make this more detailed.
    if(length(col_report$details[[1]]$flag)>0){
      flags[column_name] = list(col_report$details[[1]]$flag)
    }
    col_report$column_name = colnames(dataset)[i]
    report$columns[col_report$column_name] = col_report$details
  }
  if(length(flags)>0) report$flags = flags
  report
}

data_quality_report = function(dataset, dataset_name = NULL, file=NULL, detailed=TRUE){
  #dataset_name =  get_name(dataset)
  if(is.data.frame(dataset)) {
    if(!is.null(file)){
      sink(file)
    }
    report = data_quality_report_DF(dataset, dataset_name)
    if(!detailed){report$columns=NULL}
    if(!is.null(file)){
      stringify_report(report)
      sink(NULL)
    }
  } else{
    warning("Datatype not supported")
  }
  report
}

stringify_report = function(report){
  # str Doesn't seem to care what parameters I use... :(
  str(report, give.length=FALSE, give.head=FALSE, no.list=TRUE
      ,indent.str = '  ', com.str = " "
  )
}

get_name = function(dataset) deparse(substitute(dataset))

report_on_all_env_objs = function(...){
  reports = list()
  for(obj_name in ls(.GlobalEnv)){
    obj=get(obj_name)
    print(c(obj_name, class(obj)))
    if(is.data.frame(obj)){
      reports[obj_name] = list(data_quality_report(obj, obj_name, ...))
    }
  }
  reports
}

dump_reports = function(reports, report_on_flags=TRUE, flags_only=FALSE, separate_files=TRUE, fname="data_quality_report.txt"){
  flags=list()
  for(i in 1:length(reports)){
    if(separate_files){
      object_name = names(reports)[i]
      report = reports[[i]]
      if(!flags_only){
        fname = paste(object_name, '.txt', sep='')
        sink(fname)
        stringify_report(report)
        sink(NULL)
        print(fname)
      }
      ############
      if(!is.null(report$flags)){flags[object_name] = list(report$flags) }
    } else {
      if(i==1) sink(fname)
      stringify_report(report)
    }
    if(!separate_files) sink(NULL)
  }
  if(report_on_flags){
    sink("__flagged_objects.txt")
    stringify_report(flags)
    sink(NULL)
  }
}

if(1==0){
  data(iris)
  #test = data_quality_report(iris)
  #stringify_report(test)
  #data_quality_report(matrix())
  ##################
  #rm(list=ls())
  setwd("Projects/Toy\ Projects/make_for_datascience")

  # Load all RData objs into environment
  #dummy_ = lapply(list.files(), function(x) tryCatch(load(file=x, envir=.GlobalEnv), except=function(e) print("except"), warning=function(w) print("warning")))

  # Calculate data quality reports
  reports = report_on_all_env_objs(detailed=TRUE)
  #dump_reports(reports, report_on_flags=TRUE)

  names(reports[['iris']]) # "object_name" "dim"         "n"           "columns"

  reports[['iris']][['object_name']] # iris
  reports[['iris']][['dim']] # 150 5
  reports[['iris']][['n']] # 150

  names(reports[['iris']][['columns']]) # "Sepal.Length" "Sepal.Width"  "Petal.Length" "Petal.Width"  "Species"

  names(reports[['iris']][['columns']][['Sepal.Length']])
  #[1] "datatype"    "length"      "uniques"     "min"         "max"         "mean"
  #[7] "median"      "sd"          "bad_records"

  names(reports[['iris']][['columns']][['Species']])
  # [1] "datatype"    "length"      "uniques"     "table"       "bad_records" "empty"
  # [7] "minchars"    "maxchars"    "meanchars"   "nlevels"

  # This is basically for pretty-printing everything
  stringify_report(reports)

  dump_reports(reports)

  source("common/src/eval/eval_db/dbapi.r")

  report = data_quality_report(iris)
  log_data_profile('iris', report, 'path/to/file', description="DQR test")

  # Test behavior and db logging for flags
  iris2 = iris
  iris2$bad_col = NA
  report2 = data_quality_report(iris2)
  report2$flags
  log_data_profile('iris2', report2, 'path/to/file', description="DQR test")

  dbGetQuery(conn, "select * from datasets")
  dbGetQuery(conn, "select * from fields")
  dbGetQuery(conn, "select * from field_stats")
  dbGetQuery(conn, "select * from field_flags")

  dbDisconnect(conn)
}


#------------------------------------------------------------------------------------------------------------
#	Quasi-Likelihood modeling
#	Li et al. (2010) Comparitive shotgun proteomics using spectral count data and quasi-likelihood modeling.
#	JPR. 9(8):4295-305. PMID: 20586475
#
#	Pulled from http://forge.fenchurch.mc.vanderbilt.edu/scm/viewvc.php/branches/IDPicker-3/QuasiTel%20V2.R?root=idpicker&view=log
#	Adapted by Joseph N. Brown, Ph.D.
#------------------------------------------------------------------------------------------------------------

quasitel <- function(data, group1, group2, weight=NULL, rm.SID=TRUE, rm.zero=FALSE, minavgcount=NULL)
{
    # should pass these as arguments instead
    option.contrasts <- getOption('contrasts')
    options(contrasts=c('contr.SAS', 'contr.treatment'))

    # make a grouping factor that will be applicable to the subsetted data
    group <- character()
    if (is.character(group1)) {
        group1 <- which(colnames(data) %in% group1)
    }
    if (is.character(group2)) {
        group2 <- which(colnames(data) %in% group2)
    }
    grp <- union(group1, group2)
    group[group2] <- "group2"
    group[group1] <- "group1"
    group <- factor(group[grp])
    gpl <- split(1:length(group), group)

    # subset the data and groups
    data <- subset(data, select=grp)
    #group1 <- gpl$group1
    #group2 <- gpl$group2

    # filter based on minimum count
    if (!is.null(minavgcount)) {
        grp12count <- apply(data, 1, mean)
        data <- subset(data, grp12count >= minavgcount)
    }

    #grp1zero <- apply(subset(data, select=group1), 1, sum) == 0
    #grp2zero <- apply(subset(data, select=group2), 1, sum) == 0
    #if (rm.zero) {
    #    # only keep features that are not both zero
    #    data <- subset(data, !(grp1zero | grp2zero))
    #} else {
    #    # or add a single count
    #    data[grp1zero, group1[1]] <- 1
    #    data[grp2zero, group2[1]] <- 1
    #}

    # prepare the weight
    if (is.null(weight)) {
        offset <- NULL
        wei <- sapply(gpl, length)
    } else {
        weight <- weight[colnames(data)]
        offset <- log(weight)
        wei <- sapply(gpl, function(x) { sum(weight[x]) })
    }

    Nprotein <- nrow(data)
    result <- matrix(numeric(), nrow=Nprotein, ncol=11)

    for (i in 1:Nprotein) {
        count <- as.numeric(data[i,])

        # poisson p-value
        g1a <- glm(count ~ group, offset=offset, family=poisson)
        g1 <- glm(count ~ 1, offset=offset, family=poisson)
        anovaP <- data.frame(anova(g1, g1a, test="Chisq"))
        Pvalues <- ifelse(anovaP[2,4] < 0.1e-15, 1, anovaP[2,5])

        # quasi p-value
        gquasi1a <- glm(count ~ group, offset=offset, family=quasi(link=log, variance=mu))
        gquasi1 <- glm(count ~ 1, offset=offset, family=quasi(link=log, variance=mu))
        anovaPq <- data.frame(anova(gquasi1, gquasi1a, test="F"))
        Pvaluesq <- ifelse(anovaPq[2,4] < 0.1e-15, 1, anovaPq[2,6])

        lambda <- exp(rev(cumsum(as.numeric(g1a$coef))))
        totcot <- round(wei * lambda, 0)
        rateratio <- log2(lambda[1] / lambda[2])

        sdl <- sapply(gpl, function(x) { sd(count[x]) })
        meanl <- sapply(gpl, function(x) { mean(count[x]) })
        cvl <- mapply("/", sdl, meanl)

        result[i, ] <- c(   totcot,     # 2 items
                            lambda,     # 2 items
                            rateratio,
                            Pvalues,    NA,
                            Pvaluesq,   NA,
                            cvl)        # 2 items
    }
    # fdr adjustment
    for (j in c(6, 8)) {
        result[, j+1] <- p.adjust(result[, j], method="fdr")
    }
    rownames(result) <- rownames(data)
    colnames(result) <- c(  "count1",   "count2",
                            "rates1",   "rates2",
                            "2log(rate1/rate2)",
                            "poisson.p", "poisson.fdr",
                            "quasi.p",  "quasi.fdr",
                            "cv1",      "cv2")
    options(contrasts=option.contrasts)
    result
}


library('bnlearn')

data('asia')

asia_data <- asia

#Visualiza previamente os meus dados carregados
View(asia_data)

#Para melhor compreender nosso dataset vamos renomear as nossas colunas
names(asia_data)[names(asia_data) == 'A'] <- 'Asia'
names(asia_data)[names(asia_data) == 'T'] <- 'Tuberculose'
names(asia_data)[names(asia_data) == 'S'] <- 'Fumante'
names(asia_data)[names(asia_data) == 'L'] <- 'Cancer_Pulmao'
names(asia_data)[names(asia_data) == 'E'] <- 'BronquiteOUCancer'
names(asia_data)[names(asia_data) == 'X'] <- 'Raio_X'
names(asia_data)[names(asia_data) == 'D'] <- 'Dispneia'
names(asia_data)[names(asia_data) == 'B'] <- 'Bronquite'

net <- hc(asia_data)

plot(net)

bn_fit <- bn.fit(net, data = asia_data)

cpquery(bn_fit, event = (Cancer_Pulmao == "yes"), evidence = (Fumante == "yes"))

cpquery(bn_fit, event = (Raio_X == "yes"), evidence = (Tuberculose == "no" & BronquiteOUCancer == "no"))


bp_fi <- function(r_times) {

  if (max(r_times) < 60) {
    trial_duration = 60
  } else {
    trial_duration = max(r_times)
  }

  nr = length(r_times)
  r = nr / trial_duration
  algorithm = numeric(nr)

    for (j in 1:(nr - 1)) {
      t1 = r_times[j]
      t2 = trial_duration - t1
      r1 = sum(r_times <= j) / j
      r2 = sum(r_times > j) / t2
      A = sum(t1 * abs(r1 - r), t2 * abs(r2 - r), na.rm = T)
    }

    argmax_A = which.max(A)
    bp = r_times[argmax_A]
    r1 = sum(r_times <= bp) / bp
    r2 = sum(r_times > bp) / (trial_duration - bp)

    data.frame(bp = bp, r1 = r1, r2 = r2)
}


# performance under-sampling

# Setting
```{r}

# reset
rm(list=ls(all=TRUE))

# library
library(data.table)
library(dplyr)
library(psych)
library(caret)
library(gam)
library(RSNNS)
library(e1071)
library(ranger)
library(randomForest)
library(xgboost)

# Directory
# Get data
Data <- fread("Data_demo.csv", encoding = "UTF-8" )
Data$V1 <- NULL

# Train Test
Data_train <- Data[TrainTest == "Train", , ] #*eligible
Data_train <- data.frame(Data_train)

Data_test <- Data[TrainTest == "Test", , ] #*eligible
Data_test <- data.frame(Data_test)

```

# define functions
```{r}

RMSE <- function(Obs, Pred){
	Dif <- Pred - Obs
	RMSE <- round(sqrt(mean(Dif**2)), 2)
	return(RMSE)
}

MAE <- function(Obs, Pred){
	Dif <- Pred - Obs
	MAE <- Dif %>% abs() %>% mean()	%>% round(., 2)
	return(MAE)
}

MAPE <- function(Obs, Pred){
	Dif <- Pred - Obs
	MAPE <- mean(abs(Dif/Obs)*100) %>% round(., 2)
	return(MAPE)
}

```

# Performance All SeverityAll in Train and Test
```{r}

# load model
Model_gam <- readRDS("gamSpline_temp.rds")

# get predicted values
Data_train$Pred_gam <- predict(Model_gam, Data_train)
summary(Data_train$Pred_gam)
Data_train$Pred_gam <- ifelse(Data_train$Pred_gam < 0, 0, Data_train$Pred_gam)
summary(Data_train$Pred_gam)

# get predicted values
Data_test$Pred_gam <- predict(Model_gam, Data_test)
summary(Data_test$Pred_gam)
Data_test$Pred_gam <- ifelse(Data_test$Pred_gam < 0, 0, Data_test$Pred_gam)
summary(Data_test$Pred_gam)

# load augued model
Data_MAPE <- fread("Out_MAPE_under.csv")

Data_MAPE <- rename(Data_MAPE,
	"Models" = "V1",
	"MAPE_train" = "V2",
	"MAPE_test" = "V3",
	"Percenterror_train" = "V4",
	"Percenterror_test" = "V5"
	)

Data_MAPE <- Data_MAPE[order(MAPE_train), , ]

Model_name <- as.character(Data_MAPE[, first(Models), ])

Temp_train <- c()
Temp_test <- c()

for(iii in 1:10){
Model_aug <- readRDS(paste(Model_name, "_", iii, ".rds", sep = ""))

# get predicted values
Temp_train <- cbind(Temp_train, predict(Model_aug, Data_train, pe = "raw"))

# get predicted values
Temp_test <- cbind(Temp_test, predict(Model_aug, Data_test, pe = "raw"))

}

Temp_train <- data.table(Temp_train)
Temp_train[, Pred := rowMeans(Temp_train), ]
Temp_train[, Pred := ifelse(Pred < 0, 0, Pred), ]
summary(Temp_train$Pred)

Temp_test <- data.table(Temp_test)
Temp_test[, Pred := rowMeans(Temp_test), ]
Temp_test[, Pred := ifelse(Pred < 0, 0, Pred), ]
summary(Temp_test$Pred)

#
Data_train <- data.table(Data_train)
Data_train[, Pred_aug := Temp_train$Pred, ]

Data_test <- data.table(Data_test)
Data_test[, Pred_aug := Temp_test$Pred, ]

# cutoff
Data_train[, Pred_sum_date := sum(Pred_aug), by = Date]
Data_test[, Pred_sum_date := sum(Pred_aug), by = Date]

Data_train[, Pred :=
	ifelse(Pred_sum_date < 150, Pred_gam,
	ifelse(Pred_sum_date < 300, (Pred_gam + Pred_aug)/2,
	Pred_aug)), ]

Data_test[, Pred :=
	ifelse(Pred_sum_date < 150, Pred_gam,
	ifelse(Pred_sum_date < 300, (Pred_gam + Pred_aug)/2,
	Pred_aug)), ]

# get performance
RMSE_train <- RMSE(Obs = Data_train$SeverityAll, Pred = Data_train$Pred)

MAE_train <- MAE(Obs = Data_train$SeverityAll, Pred = Data_train$Pred)

Cor_train <- paste(
	cor.test(Data_train$SeverityAll, Data_train$Pred)$estimate %>% round(., 2),
	" (",
	cor.test(Data_train$SeverityAll, Data_train$Pred)$conf.int[1] %>% round(., 2),
	" to ",
	cor.test(Data_train$SeverityAll, Data_train$Pred)$conf.int[2] %>% round(., 2),
	")",
	sep = ""
	)

# get performance
RMSE_test <- RMSE(Obs = Data_test$SeverityAll, Pred = Data_test$Pred)

MAE_test <- MAE(Obs = Data_test$SeverityAll, Pred = Data_test$Pred)

Cor_test <- paste(
	cor.test(Data_test$SeverityAll, Data_test$Pred)$estimate %>% round(., 2),
	" (",
	cor.test(Data_test$SeverityAll, Data_test$Pred)$conf.int[1] %>% round(., 2),
	" to ",
	cor.test(Data_test$SeverityAll, Data_test$Pred)$conf.int[2] %>% round(., 2),
	")",
	sep = ""
	)

# Summarize
Performance <- c(
	RMSE_train
	, RMSE_test

	, Cor_train
	, Cor_test
	)

HogeRMSE <- data.table(Performance)
HogeRMSE

fwrite(HogeRMSE, "Out_RMSE_aug_2stage.csv")

```

# MAPE by 24
```{r}

# Organized dataset
Data_train_MAPE <- Data_train %>%
	group_by(Date) %>%
	summarise(
		Obs = sum(SeverityAll),
		Pred = sum(Pred)
		) %>% data.table()

Data_train_MAPE[, Year := year(Date), ]

Data_train_MAPE[, Spike :=
	ifelse(Year == 2015 & Obs >= Data_train_MAPE[Year == 2015, quantile(Obs, 0.8), ], 1,
	ifelse(Year == 2016 & Obs >= Data_train_MAPE[Year == 2016, quantile(Obs, 0.8), ], 1,
	ifelse(Year == 2017 & Obs >= Data_train_MAPE[Year == 2017, quantile(Obs, 0.8), ], 1, 0)))
	, ]
Data_train_MAPE[, table(Spike), ]
Data_train_MAPE[, table(Spike), ] / nrow(Data_train_MAPE)

# get performance
MAPE_train <- MAPE(
	Obs = Data_train_MAPE[Spike == 1, Obs, ],
	Pred = Data_train_MAPE[Spike == 1, Pred, ]
	)

PE_train <- Data_train_MAPE[Spike == 1, round( (abs(sum(Pred) - sum(Obs)) / sum(Obs) ) * 100, 2), ]

# Organized dataset
Data_test_MAPE <- Data_test %>%
	group_by(Date) %>%
	summarise(
		Obs = sum(SeverityAll),
		Pred = sum(Pred)
		) %>% data.table()

Data_test_MAPE[, Year := year(Date), ]

Data_test_MAPE[, Spike :=
	ifelse(Year == 2018 & Obs >= Data_test_MAPE[Year == 2018, quantile(Obs, 0.8), ], 1, 0)
	, ]
Data_test_MAPE[, table(Spike), ]
Data_test_MAPE[, table(Spike), ] / nrow(Data_test_MAPE)

# get performance
MAPE_test <- MAPE(
	Obs = Data_test_MAPE[Spike == 1, Obs, ],
	Pred = Data_test_MAPE[Spike == 1, Pred, ]
	)

PE_est <- Data_test_MAPE[Spike == 1, round( (abs(sum(Pred) - sum(Obs)) / sum(Obs) ) * 100, 2), ]

# Summarize
Performance <- c(
	MAPE_train
	, MAPE_test

	, PE_train
	, PE_est
	)

HogeMAPE <- data.table(Performance)
HogeMAPE

fwrite(HogeMAPE, "Out_MAPE_24_aug_2stage.csv")

```

# Figure time series by 24h
```{r}
## Make figures
ggplot(data = Data_train, aes(x = Pred, y = SeverityAll)) +
	geom_point() +
	geom_smooth(method = lm) +
	scale_x_continuous(limits = c(0, 100), breaks = seq(0, 100, 10)) +
	scale_y_continuous(limits = c(0, 100), breaks = seq(0, 100, 10)) +
	xlab("") +
	ylab("") +
	theme_classic()
ggsave(paste("Out_plot_", "2stage", "_train.png", sep = ""), width = 4.2, height = 3.2) #*action

### Make figures taest
ggplot(data = Data_test, aes(x = Pred, y = SeverityAll)) +
	geom_point() +
	geom_smooth(method = lm) +
	scale_x_continuous(limits = c(0, 100), breaks = seq(0, 100, 10)) +
	scale_y_continuous(limits = c(0, 100), breaks = seq(0, 100, 10)) +
	xlab("") +
	ylab("") +
	theme_classic()
ggsave(paste("Out_plot_", "2stage", "_test.png", sep = ""), width = 4.2, height = 3.2) #*action

### Make Fig train
DataSum_train <- Data_train %>%
	group_by(Date) %>%
	summarise(
		SeverityAll = sum(SeverityAll),
		Pred = sum(Pred)
		) %>%
	data.table() %>%
	print()

DataSum_test <- Data_test %>%
	group_by(Date) %>%
	summarise(
		SeverityAll = sum(SeverityAll),
		Pred = sum(Pred)
		) %>%
	data.table() %>%
	print()

DataSum <- rbind(DataSum_train, DataSum_test)

DataSum[, Date:=as.Date(Date), ]
DataSum[, YearUse:=year(Date), ]
DataSum <- DataSum[order(Date), , ]
DataSum[, Day:=1:length(SeverityAll), by = YearUse]
DataSum

DataSum[Date == as.Date("2015-06-01"), , ]
DataSum[Date == as.Date("2015-07-01"), , ]
DataSum[Date == as.Date("2015-08-01"), , ]
DataSum[Date == as.Date("2015-09-01"), , ]

ggplot(data = DataSum, aes(x = Day), group=factor(YearUse)) +
	#geom_point(aes(y = SeverityAll), colour = "Black", alpha = 1.0) +
	geom_line(aes(y = SeverityAll, x=Day), colour = "Black", size = 0.4) +
	#geom_point(aes(y = Pred), colour = "Red", alpha = 1.0) +
	geom_line(aes(y = Pred, x=Day), colour = "Red", size = 0.4) +
	xlab("") +
	ylab("") +

	scale_y_continuous(
		limits = c(0, 450),
		breaks = seq(0, 450, 50)
		) +

	scale_x_continuous(
		label = c("Jun.", "Jul.", "Aug.", "Sep."),
		breaks = c(1, 31, 62, 93)
		) +
	theme(axis.text.x = element_text(angle = 90, hjust = 1)) +
	facet_grid(~YearUse) +
	theme_classic()

ggsave(paste("Out_time_24_", "2stage", ".png", sep = ""), width = 6.7 * 1.5, height = 3.5 * 0.66) #*action

HogeMAPE
HogeRMSE

Data_train[, RMSE(Obs = SeverityAll, Pred = Pred), by = ID] %>% print() %>% fwrite(., "Out_RMSE_city_hybrid_train.csv")

Data_test[, RMSE(Obs = SeverityAll, Pred = Pred), by = ID] %>% print() %>%  fwrite(., "Out_RMSE_city_hybrid_test.csv")

Data_test %>% group_by(ID) %>% summarise(Obs = sum(SeverityAll), Pred = sum(Pred)) %>% data.table() %>% print() %>%  fwrite(., "Out_heatmapdata_hybrid.csv")

fwrite(DataSum, paste("Out_data_figure2_", "hybrid", ".csv", sep = ""))

```


# author Anam HIra, Tony Liang
# date: 2022-03-28

"Script to create exploratory data visualisations and tables that are useful to help the consumer understand the dataset.

Usage: data_visualisation.r --df=<df> --out_dir=<out_dir>

Options:
        --df=<df>     Path (including filename) to training data
        --out_dir=<out_dir> Path to directory where the plots should be saved
        " -> doc
library(tidyverse)
library(docopt)
library(group8)

opt <- docopt(doc)
set.seed(123)
main <- function(df,out_dir) {
    if (!dir.exists(out_dir)) {
        dir.create(out_dir, recursive = TRUE)
  }

    data_training <- read_csv(df)
    # Mean
    user_means <- group8::summary_fun(data_training,mean)
    readr::write_csv(user_means, paste0(out_dir, "/means.csv"))

    # Max
    maximum <- group8::summary_fun(data_training, max)
    readr::write_csv(maximum,
            paste0(out_dir, "/maximum.csv"))
    # Min
    minimum <- group8::summary_fun(data_training, min)
    readr::write_csv(minimum,
            paste0(out_dir, "/minimum.csv"))

    # Obs
    observations <- data_training %>%
    summarize(n = n())
    readr::write_csv(observations,
            paste0(out_dir, "/observations.csv"))

    peg_stg <- group8::visualize_vars(data_training, STG, PEG, alpha = 0.4)

    ggplot2::ggsave("peg_stg.png", device = "png", path = out_dir, width = 5, height = 4)
}

main(opt[["--df"]], opt[["--out_dir"]])


require(keras)
require(RODBC)
require(mice)
ch <- odbcConnect("DBM_SANDBOX", believeNRows=FALSE)
nzdata <- sqlQuery(ch, paste("SELECT * FROM MODEL_12MO_VAL"))

head(nzdata)

vars <- c('SALES_R12','SALES_R24','SALES_R48','SALES_RLT',
          'FISHING_MARINE_SALES_LT','CAMPING_WATERSPORTS_SALES_LT','HUNTING_HUNTCLOTH_SALES_LT',
          'FOOTWEAR_SALES_LT','SHOOTING_SALES_LT','GIFT_SALES_LT','APPAREL_SALES_LT',
          'OTHER_SALES_LT','VISITS_LT',
          'DAYS_SINCE_PURCHASE','DAYS_AS_CUSTOMER','REWARDS_CUSTOMER',
          'YOY_TREND','SALES_TARGET_N12')

vars.x <- c('SALES_R12','SALES_R24','SALES_R48','SALES_RLT',
            'FISHING_MARINE_SALES_LT','CAMPING_WATERSPORTS_SALES_LT','HUNTING_HUNTCLOTH_SALES_LT',
            'FOOTWEAR_SALES_LT','SHOOTING_SALES_LT','GIFT_SALES_LT','APPAREL_SALES_LT',
            'OTHER_SALES_LT','VISITS_LT',
            'DAYS_SINCE_PURCHASE','DAYS_AS_CUSTOMER','REWARDS_CUSTOMER',
            'YOY_TREND')
vars.y <- c('SALES_TARGET_N12')

vars.x.num <-  c('SALES_R12','SALES_R24','SALES_R48','SALES_RLT',
                'FISHING_MARINE_SALES_LT','CAMPING_WATERSPORTS_SALES_LT','HUNTING_HUNTCLOTH_SALES_LT',
                'FOOTWEAR_SALES_LT','SHOOTING_SALES_LT','GIFT_SALES_LT','APPAREL_SALES_LT',
                'OTHER_SALES_LT','VISITS_LT',
                'DAYS_SINCE_PURCHASE','DAYS_AS_CUSTOMER',
                'YOY_TREND')

nzdata2 <- nzdata[ , vars ]

summary(nzdata2[ , vars.x.num])

var_diagnostics <- function(data, yvars, xvars){
  for(j in yvars){
    for(i in xvars){

      print(paste(i, 'contains', sum(is.na(data[,i])), 'empty values.'))

      # hist(data[ , i], breaks='FD',
      #      main=paste("Histogram of" , i))
      # plot(data[,i], data[,j], type = 'p', xlab=paste(i), ylab=paste(j))

      # corr <- cor.test(data[, i], data[ , j], method='pearson')
      #
      #
      # form <- paste(j, ' ~ ', i)
      # mod <- lm(formula = form, data=data)
      # sm <- summary(mod)
      # tpval <- sm$coefficients[2,4]
      # est <- sm$coefficients[2,1]
      # rsq <- sm$adj.r.squared
      #
      #
      #
      # if((rsq >= 0.05) & (tpval <= 0.1)) {
      #   print(paste(i,' Corr Coeff: ',corr$estimate, 'pval: ', corr$p.value))
      #   print(paste(i,' R2: ', rsq, ' Est: ', est, ' pval: ', tpval))
      # } #end if
    } #end inner for loop
  } #end outer for loot

} #end function

var_diagnostics(nzdata2, vars.y, vars.x)

nzdata2 <- nzdata2[!is.na(nzdata2$DAYS_AS_CUSTOMER), ]
nzdata2 <- nzdata2[!is.na(nzdata2$DAYS_SINCE_PURCHASE), ]

## Scale Data

scaled = scale(nzdata2, center = TRUE)

summary(scaled)

mahal <- mahalanobis(scaled[ , vars.x.num],
                     colMeans(scaled[ , vars.x.num], na.rm = TRUE),
                     cov(scaled[ , vars.x.num],
                         use = "pairwise.complete.obs"),
                     tol=1e-20)

cutoff <- qchisq(1-.001, length(vars.x.num))

summary(mahal < cutoff)

nooutliers <- subset(scaled, mahal < cutoff)

summary(nooutliers)

correl <- cor(nooutliers[ ,vars.x.num])
symnum(correl)

indices <- sample(1:nrow(nooutliers), size=0.80 *nrow(nooutliers))
train <- as.data.frame(nooutliers[indices, ])
test <- as.data.frame(nooutliers[-indices, ])

var_diagnostics <- function(data, yvars, xvars){
  for(j in yvars){
    for(i in xvars){

      hist(data[ , i], breaks='FD')

      # corr <- cor.test(data[, i], data[ , j], method='pearson')
      #
      #
      # form <- paste(j, ' ~ ', i)
      # mod <- lm(formula = form, data=data)
      # sm <- summary(mod)
      # tpval <- sm$coefficients[2,4]
      # est <- sm$coefficients[2,1]
      # rsq <- sm$adj.r.squared
      #
      #
      #
      # if((rsq >= 0.05) & (tpval <= 0.1)) {
      #   print(paste(i,' Corr Coeff: ',corr$estimate, 'pval: ', corr$p.value))
      #   print(paste(i,' R2: ', rsq, ' Est: ', est, ' pval: ', tpval))
      # } #end if
    } #end inner for loop
  } #end outer for loot

} #end function

var_diagnostics(train, vars.y, vars.x)

vars.x <- c('SALES_R12','SALES_R24','SALES_R48','SALES_RLT',
            'FISHING_MARINE_SALES_LT','CAMPING_WATERSPORTS_SALES_LT','HUNTING_HUNTCLOTH_SALES_LT',
            'VISITS_LT')

model <- keras_model_sequential()
model %>%
  layer_dense(units = 16, activation = 'relu', input_shape = c(8)) %>%
  layer_dense(units = 32, activation = 'relu') %>%
  layer_dense(units = 8, activation = 'relu') %>%
  layer_dense(units = 1)

  summary(model)

  model %>% compile(
    loss = 'mse',
    optimizer = optimizer_rmsprop(lr = 0.01)
  )

  train.x <- as.matrix(train[, vars.x])
  train.y <- as.matrix(train[, vars.y])

  history <- model %>% fit(x = train.x, y = train.y,
    epochs = 100, batch_size = 64,
    validation_split = 0.3,
    verbose = 1,
    shuffle = T
  )

  plot(history)


#Package dplyr

#adding collumn "rate" to the table murders
murders <- mutate(murders, rate=total/population*100000)

head(murders)

#FILTER the entire table by rates there are lower or equal to 0.71
filter(murders, rate <= 0.71)

#sometimes we work with tables with hundreds of columns;
#lets SELECT the ones we are working with
new_table <- select(murders, state, region, rate)

filter(new_table, rate <= 0.71)

#using the pipe to get all above in one row (dplyr)
murders %>% select(state, region, rate) %>% filter(rate <= 0.71)


1 : 67

my_vector1 <- 1 : 67
my_vector <-  c(-34, 64 ,-54, 543, 2543, 0 , -65 )

my_vector2

my_vector1 + 10

my_vector2[0]

my_vector2 == 0

v1 <- 1 : 50
v2 <- 60 : 100
v3 <- c(v1, v2)
print(v3)
print(my_vector[c(2,5,7,9,12,16,20)])
my_vector + 1;
print(my_vector)
my_sum <- sum(my_vector[my_vector > 0])
print(my_sum)


require(rms)
options(debug=TRUE)
set.seed(1)
n  <- 100
x1 <- runif(n)
x2 <- runif(n)
x3 <- runif(n)
x4 <- sample(0:4, n, TRUE)
x5 <- ordered(sample(1:3, n, TRUE), levels=1:3, labels=c('I','II','III'))
S  <- Surv(runif(n))
# f <- cph(S ~ x1 + pol(x2, 2) + rcs(x3, 4) + scored(x4) + x5)   # FAILS
options(contrasts=c('contr.treatment', 'contr.treatment'))
f <- cph(S ~ x1 + pol(x2, 2) + rcs(x3, 4) + scored(x4) + x5)
f


if (!require('stringr')) install.packages('stringr', quiet=TRUE)

#' Linear Programing Pretty Print
#'
#' \code{lpPrettyPrint} creates a list of prettly formated answers of an lp
#'
#' @param model a model object as returned by \code{\link{lpSolve::lp}}
lpPrettyPrint = function(model) {

  t1 = t(model$constraints)

  # extract the origional values
  d = dim(t1)
  lhs = t1[,1:(d[2]-2)]
  dir = dirnum2sym(t1[,(d[2]-1)])
  rhs = t1[,d[2]]
  dv = names(model$objective)
  if(is.null(dv)) { dv = sprintf("x%s",1:(d[2]-2)) }

  # objective function
  objfun = if(model$direction == 0) {"Minimize:"} else { "Maximize:"}
  objfun = paste(objfun, rbarpm(model$objective, dv, c("*","+")))

  # solution
  sol = paste(rbarpm(dv, model$solution, c("=",",")),"yealds", model$objval)

  # double check math
  lhs.res = vector(mode="numeric", length=d[1])
  for(i in 1:d[1]) {
    lhs.res[i] = rbarpmps(lhs[i,], dv)
  }
  dcm = cbind(lhs.res,dir,rhs)
  colnames(dcm) = c("lhs", "dir", "rhs")

  # double check result
  lhs.res = vector(mode="numeric", length=d[1])
  for(i in 1:d[1]) {
    lhs.res[i] = sum(lhs[i,]*model$solution)
  }
  dcr = cbind(lhs.res,dir,rhs)
  colnames(dcr) = c("result", "dir", "rhs")

  return(list(Objective=objfun, Solution=sol, DoubleCheckMath = dcm, DoubleCheckResult = dcr))
}

#' Linear Programing Pretty Print
#'
#' \code{lppp} alias for \code{\link{lpPrettyPrint}}
lppp = function(model){return(lpPrettyPrint(model))}

#' rbar paste macro for (a[i],op[1],b[i],op[2])
rbarpm = function(a, b, op) {

  l = length(a)
  res = vector(mode = "character", length = l)
  for(i in 1:l) {
    res[i] = paste(a[i], op[1], b[i], op[2], sep="")
  }
  res = paste(res, collapse = '')
  res = substr(res, 0, stringr::str_length(res)-1)

  return(res)
}
#' rbar paste macro for (a[i],"*",b[i],"+") that elimates terms when available
rbarpmps = function(a, b) {

  l = length(a)
  res = vector(mode = "character", length = l)
  for(i in 1:l) {
    if(a[i] == 0) {
      # blank out term
    }
    else if(a[i] == 1) {
      res[i] = paste(b[i], "+", sep="")
    }
    else {
      res[i] = paste(a[i], b[i], "+", sep="")
    }
  }
  res = paste(res, collapse = '')
  res = substr(res, 0, stringr::str_length(res)-1)

  return(res)
}
dirnum2sym = function(num) {

  sym = c("<=", ">=", "=")

  l = length(num)
  res = vector(mode="character", length=l)
  for(i in 1:l) {
    res[i] = sym[num[i]]
  }

  return(res)
}


# All the code for all the plots in one file.

# This code assumes you've downloaded and unzipped the file
#   exdata-data-NEI_data.zip in your working directory.  If you haven't it's
#   easy enough to write the code to check using file.exists etc

## This first line will likely take a few seconds. Be patient!
NEI <- readRDS("summarySCC_PM25.rds")
SCC <- readRDS("Source_Classification_Code.rds")

# Plot 1
Totals <- aggregate(formula = Emissions ~ year,
                    data = NEI,
                    FUN = sum)

png(filename = "plot1.png",
    width = 480,
    height = 480)

barplot(height = Totals$Emissions/10^6,
        names.arg=Totals$year,
        col = "lightblue",
        xlab = "Year",
        ylab = "Emissions (hundred thousand tons)",
        main = "Plot 1: Total PM2.5 Emissions From All US Sources",
        ylim = c(0,8))

dev.off()

# Plot 2
Balt <- NEI[NEI$fips == "24510",]
BaltTotal <- aggregate(formula = Emissions ~ year,
                       data = Balt,
                       FUN = sum)

png(filename = "plot2.png",
    width = 480,
    height = 480)

barplot(height = BaltTotal$Emissions/10^3,
        names.arg=BaltTotal$year,
        col = "lightblue",
        xlab = "Year",
        ylab = "Emissions (thousand tons)",
        main = "Plot 2: Total PM2.5 Emissions From Baltimore",
        ylim = c(0,4))

dev.off()

# Plot 3

library(ggplot2)

png(filename = "plot3.png",
    width = 640,
    height = 480)

ggplot(Balt, aes(factor(year), Emissions, fill=type)) +
  geom_bar(stat="identity") +
  theme_bw() +
  guides(fill=FALSE) +
  facet_grid(. ~ type, scales = "fixed", space="fixed") +
  labs(x="Year", y=expression("Total PM"[2.5]*" Emission (Tons)")) +
  labs(title=expression("PM"[2.5]*" Emissions, Baltimore City 1999-2008 by Source Type"))

dev.off()

# Plot 4
# Subsetting...
Combustion <- grepl("comb",
                    SCC$SCC.Level.One,
                    ignore.case = TRUE)

Coal <- grepl("coal",
              SCC$SCC.Level.Four,
              ignore.case = TRUE)

Coal.Comb <- (Coal & Combustion)

ccSCC <- SCC[Coal.Comb,]$SCC
ccNEI <- NEI[NEI$SCC %in% ccSCC,]

library(ggplot2)

png(filename = "plot4.png",
    width = 640,
    height = 480)

ggplot(ccNEI,aes(factor(year), Emissions/10^3)) +
  geom_bar(stat = "identity", fill = "grey") +
  theme_bw() +
  guides(fill = FALSE) +
  labs(x = "Year", y = expression("Total PM"[2.5]*" Emission (Thousand Tons)")) +
  labs(title = expression("PM"[2.5]*" Coal-Combustion Related Source Emissions Across US from 1999-2008"))

dev.off()

# Plot 5
# Subset as before, this time for motor vehicles
# Gather the subset of the NEI data which corresponds to vehicles
cars <- grepl("vehicle",
              SCC$SCC.Level.Two,
              ignore.case = TRUE)

carsSCC <- SCC[cars,]$SCC

carsNEI <- NEI[NEI$SCC %in% carsSCC,]

# Plot 5 cares only about Baltimore...

BaltCars <- carsNEI[carsNEI$fips == "24510",]

png(filename = "plot5.png",
    width = 640,
    height = 480)

ggplot(BaltCars,aes(factor(year), Emissions)) +
  geom_bar(stat = "identity", fill = "grey") +
  theme_bw() +
  guides(fill = FALSE) +
  labs(x = "Year", y = expression("Total PM"[2.5]*" Emission (Tons)")) +
  labs(title = expression("PM"[2.5]*" Motor Vehicle Related Source Emissions From Baltimore from 1999-2008"))

dev.off()

# Plot 6
# Add a city to BaltCars
BaltCars$city <- "Baltimore City"

# Now subset LA motor vehicle data
LACars <- carsNEI[carsNEI$fips == "06037",]
LACars$city <- "Los Angeles County"

# Bind both LA and Baltimore together

LA.Balt <- rbind(LACars, BaltCars)

png(filename = "plot6.png",
    width = 640,
    height = 480)

ggplot(LA.Balt,aes(factor(year), Emissions, fill = "city")) +
  geom_bar(stat = "identity", fill = "grey") +
  theme_bw() +
  guides(fill = FALSE) +
  facet_grid(scales = "free", space = "free", . ~ city) +
  labs(x = "Year", y = expression("Total PM"[2.5]*" Emission (Tons)")) +
  labs(title = expression("PM"[2.5]*" Motor Vehicle Related Source Emissions From LA County from 1999-2008"))

dev.off()