#' Function for the method of Independent Evolution
#'
#' This function allows computing rescaled branch lengths according to inferred phenotypic evolution and ancestral states using the method of Independent Evolution as described in Smaers & Vinicius (2009)
#' @param data numeric vector with elements in the same order as tiplabels in the tree
#' @return dataframe with rescaled branch lengths (rBL) for all branches in the tree
#' @details This function poses the following restrictions on the input data: no polytomies in the tree, no duplicated values, no zero values, and no negative values in the data. The algorithm was designed to deal with linear data (unlogged). This function is now deprecated; 'mvBM' should be used instead.
#' @export

ie<-function(data,tree){
data_original<-data
            N=length(data)
      #Make phylo matrix and list nodes
            matrix=tree$edge
            phy.matrix=data.frame(tree$edge,tree$edge.length,data[matrix[,2]])
            names(phy.matrix)=c("Anc","Desc","Length","Value")
            phy.matrix.length=nrow(phy.matrix)
            nodes_extant=1:N
            nodes_extinct=(N+1):(N+(N-1))
            nodes_all=1:(N+(N-1))

#CODE

#1. CALCULATE AP BRANCH LENGTHS
            matrix_lengths=dist.nodes(tree)
#2. CALCULATE AP-values

      values=phy.matrix$Value[which(phy.matrix$Desc<=N)]
      extant_values=data.frame(values,nodes_extant)

      AP_values=c()

      for(j in nodes_extinct){
            #calculate nominator
                  nominator=c()
                        for(i in nodes_extant){
                              nominator=rbind(nominator,(extant_values[i,1]/matrix_lengths[i,j]))
                                              }
            #calculate denominator
                  denominator=c()
                        for(i in nodes_extant){
                              denominator=rbind(denominator,(1/matrix_lengths[i,j]))
                                              }
            #save AP
                  AP=sum(nominator)/sum(denominator)
                  AP_values=rbind(AP_values,AP)
                             }

      AP=c()
      AP=cbind(AP,AP_values)
      AP=cbind(AP,nodes_extinct)
      AP=as.data.frame(AP)
      colnames(AP)=c("value","nodes")

#3. CALCULATE ANCESTRAL STATES

nodes_extinct_reverse=sort(nodes_extinct,decreasing=TRUE)
            ancestral_states=c()
            ancestors=c()
            results=c()
            results_rBLs=c()
            results_branchlength=c()
            results_node_anc=c()
            results_node_desc=c()

for(i in nodes_extinct_reverse) {
        #calculating ancestral states
            sister_species=which(phy.matrix$Anc==i)

            X1=phy.matrix$Value[sister_species[1]]
            X2=phy.matrix$Value[sister_species[2]]
            AP_desc=AP$value[which(AP$nodes==i)]

            BL1=phy.matrix$Length[sister_species[1]]
            BL2=phy.matrix$Length[sister_species[2]]

            S1=abs(abs(X1-X2)/mean(c(X1,X2)))
            S2=abs(abs(X2-AP_desc)/mean(c(X2,AP_desc)))
            S3=abs(abs(X1-AP_desc)/mean(c(X1,AP_desc)))

            T1=((S1+S3)-S2)/2
            T2=((S1+S2)-S3)/2
            T3=((S2+S3)-S1)/2

            rBL1=T1*((BL1/(BL1+BL2))*2)
            rBL2=T2*((BL2/(BL1+BL2))*2)

            A=((X1/rBL1)+(X2/rBL2))/((1/rBL1)+(1/rBL2))

        #Saving results

            desc1=phy.matrix$Desc[sister_species[1]]
            desc2=phy.matrix$Desc[sister_species[2]]

            value_desc1=phy.matrix$Value[which(phy.matrix$Desc==desc1)]
            value_desc2=phy.matrix$Value[which(phy.matrix$Desc==desc2)]

            phy.matrix$Value[which(phy.matrix$Desc==i)]=A

        #building results dataframe
            results_node_anc=rbind(results_node_anc,i)
            results_node_anc=rbind(results_node_anc,i)
            results_node_desc=rbind(results_node_desc,desc1)
            results_node_desc=rbind(results_node_desc,desc2)
            results_rBLs=rbind(results_rBLs,rBL1)
            results_rBLs=rbind(results_rBLs,rBL2)
            results_branchlength=rbind(results_branchlength,BL1)
            results_branchlength=rbind(results_branchlength,BL2)
                                }

      #'results' dataframe
      results<-c()
      results=cbind(results,results_node_anc)
      results=cbind(results,results_node_desc)
      results=cbind(results,results_branchlength)
      results=cbind(results,results_rBLs)
      colnames(results)=c("node_anc","node_desc","BL","rBLs")

      #ancestors
      results<-results[order(match(results[,2],phy.matrix[,2])),]
      rownames(results)<-c(1:length(results[,1]))
      results<-as.data.frame(results)

      return(results)

}


library(jsonlite)
library(ggplot2)
library(zoo)
library(readr)
library(colorspace)
library(gridExtra)

library(plotly)
library(htmlwidgets)

library(sf)
sf_use_s2(FALSE)

library(lubridate)
library(plyr)

library(dplyr)

library(tidyr)
library(lubridate)

library(reshape2)

Sys.setlocale("LC_TIME", "hr_HR.UTF-8")

# get last_date_
load('data/latest/last_date_.Rda')

# get age data
json_data <- fromJSON('data/latest/last_data_po_osobama.json')

step <- 5
n <- 180

population_by_age <- read.csv(file = 'data/cro_population_by_age.csv')

json_data <- json_data %>%  mutate(dob = ifelse(dob < 1901, NA, dob))

json_data$Datum <- as.Date(json_data$Datum, format="%Y-%m-%d")

min_date = min(json_data$Datum)
max_date = max(json_data$Datum)

json_data <- json_data[order(json_data$Datum),]

json_data$dob <- as.Date(paste0(json_data$dob, '-01-01'), format="%Y-%m-%d")

json_data$age <- round(time_length(difftime(json_data$Datum, json_data$dob), "years"))

json_data$age_group <- findInterval(json_data$age, seq(0, 85, by=step))

labels <- paste0(seq(0, 85, by=step), '-', seq(step - 1, 85, by=step), sep='')

labels[length(labels)] = '85+'

counties <- unique(json_data[c("Zupanija")])

f <- list(size = 13, color = "black")

p <- list()
a <- list()
i <- 0

p_change <- list()

for(county in c(sort(counties$Zupanija), 'Hrvatska')) {
  if (county == '') {
    next
  }

  i <- i + 1

  if (county == 'Hrvatska') {
    current_county_data <- json_data
  }
  else {
    current_county_data <- json_data[json_data$Zupanija == county, ]
  }

  json_d <- current_county_data %>% group_by(Datum, age_group) %>% tally()

  age_reshaped <- pivot_wider(json_d, names_from = age_group, values_from = n) %>%
    mutate_at(vars(-("Datum")), ~replace(., is.na(.), 0))

  missing_cols <- setdiff(as.character(c(1:length(labels))), names(age_reshaped))

  age_reshaped[missing_cols] <- 0

  age_reshaped <- age_reshaped[c('Datum', as.character(1:length(labels)))]

  # add missing dates
  missing_rows <- as.Date(setdiff(seq.Date(min_date, max_date, by="day"), age_reshaped$Datum))
  missing_data <- data.frame(missing_rows)
  colnames(missing_data)[1] <- "Datum"

  age_reshaped <- rbind.fill(age_reshaped, missing_data)
  age_reshaped[is.na(age_reshaped)] <- 0

  # sort by date
  age_reshaped <- age_reshaped[order(age_reshaped$Datum),]

  # calc 7 day sums
  age_reshaped_sum7 <- as.data.frame(rollapply(age_reshaped[, names(age_reshaped) != "Datum"], 7, sum, fill=0, align="right"))

  current_population <-c(population_by_age[1:nrow(population_by_age) - 1, c(i + 1)])

  age_reshaped_sum7[, 1:ncol(age_reshaped_sum7)] <- sweep(age_reshaped_sum7[, 1:ncol(age_reshaped_sum7)], 2, current_population / 100000, `/`)
  #
  # change column names to age groups
  colnames(age_reshaped_sum7)[1:length(labels)] <- labels

  age_reshaped_sum7$Datum <- age_reshaped$Datum

  # remove last few days as data might not be complete
  age_reshaped_sum7 <- head(age_reshaped_sum7, n=nrow(age_reshaped_sum7) - 1)

  data_to_plot <- tail(age_reshaped_sum7, n=n)

  d <- melt(data_to_plot, id.vars="Datum")

  colnames(d)[2:3] <- c('Dobna_skupina', 'Broj_zadnjih_7_data')

  my_breaks <-c(0, 50, 100, 200, 400, 800, 1600, 3200)
  my_labels <-c('0', '50', '100', '200', '400', '800', '1600', '3200+')

  p[[i]] <- ggplot(d, aes_string('Datum', colnames(d)[2], fill='Broj_zadnjih_7_data')) +
    geom_tile() +
    ylab("Dobna skupina") +
    scale_fill_distiller(palette="Spectral", oob = scales::squish, name='Ukupno\nu 7 dana\nna 100000\nstanovnika',
                         limits = c(0, 3200), labels=my_labels, breaks=my_breaks) +
    theme_minimal()

  p[[i]] <- ggplotly(p[[i]])

  a[[i]] <- list(
    text = county,
    font = f,
    xref = "paper",
    yref = "paper",
    yanchor = "bottom",
    xanchor = "center",
    align = "center",
    x = 0.5,
    y = 1,
    showarrow = FALSE
  )

  p[[i]] <- p[[i]] %>%
    layout(annotations = a[i])
}

last_date <- strftime(data_to_plot$Datum[nrow(data_to_plot)], "%d.%m.%Y.")

from_date <- dmy(last_date) - days(n - 1)
from_date <- paste(day(from_date), month(from_date), year(from_date), sep='.')

s <- subplot(p, nrows = 5, margin=c(0.02,0.02,0.02,0.02), titleY = TRUE) %>%
  add_annotations(x = 0.7,
                  y = 0.07,
                  text = paste('COVID 19 u Hrvatskoj: Pregled broja zaraženih po dobnim skupinama (', from_date, ' - ', last_date ,')\n\nBoje prikazuju ukupan broj zaraženih u zadnjih 7 dana, normalizirano na 100000 stanovnika u svakoj dobnoj skupini.\nSvaka županija prikazana je na istoj skali. Crvena boja označava veći broj slučajeva.\n\nGenerirano: ', format(Sys.time() + as.difftime(1, units="hours"), '%d.%m.%Y. %H:%M:%S h'), '\nIzvor podataka: koronavirus.hr (broj slučajeva), dzs.hr (broj stanovnika po dobnim skupinama, podaci iz 2019.)\n\nAutor: Petar Palašek', sep=''),
                  font = f,
                  xref = "paper",
                  yref = "paper",
                  align='left',
                  ax = 0,
                  ay = 0)

s

orca(s, file = paste('img/', last_date_, '_per_age_group.png', sep = ''), width = 27 * 72, height = 13 * 72)

saveWidget(s, file = "html/index_per_age.html", title = paste("COVID 19 u Hrvatskoj: Pregled broja zaraženih po dobnim skupinama (", last_date, ")", sep=""))


plotfit <- function(xx,
                    yy,
                    byvar      = NA,
                    xlabel     = NULL,
                    ylabel     = NULL,
                    bylabel    = NULL,
                    bynom      = NULL,
                    multifit   = FALSE,
                    grid       = TRUE,
                    color      = c('black', 'red', 'green3', 'cyan', 'blue',
                                   'darkorchid1', 'violet'),
                    pch        = 1,       # identify symbol style (1=open circle, 16=closed circle)
                    xlimspec   = NULL,
                    ylimspec   = NULL,
                    vlines     = NA,
                    main       = NULL,
                    equation   = TRUE,
                    interval   = 'conf',   # 'pred', 'mean', 'line', 'noline'
                    alpha      = 0.05,
                    sided      = 2,
                    bg         = "grey90",
                    legendloc  = NA,
                    outputfile = NULL,
                    suppress   = 'no') {

    ## usage: plotfit3(mtcars, 'mpg', 'disp', 'cyl')

    ## vlines   = vector where: 1st two entries correspond to 1st byvar
    ##                        : 2nd two entries correspond to 2nd byvar, etc.
    ## equation = TRUE writes equation as subtext under main title

    ## interval = 'conf' (default) plots mean fit and confidence limits
    ##          = 'pred' plots mean fit and prediction limits
    ##          = 'mean' plots mean fit only (and points)
    ##          = 'line' plots connect the dot lines
    ##          = 'noline' does not plot mean fit or limits (points only)

    ##-----------------------------------------------------------------------------
    ## pull label from the name of the vector if not specified otherwise
    if (is.null(xlabel)) xlabel   <- deparse(substitute(xx))
    if (is.null(ylabel)) ylabel   <- deparse(substitute(yy))
    if (is.null(bylabel)) bylabel <- deparse(substitute(byvar))

    ##-----------------------------------------------------------------------------
    ## if bynom vector is specified, map byvar to closest bynom value for color and legend
    if (!is.null(bynom[1])) {

        if (length(bynom) == 1) {
            ## number of colors specified rather than a vector
            ## split range evenly into this number
            end1 <- min(byvar, na.rm=TRUE)
            end2 <- max(byvar, na.rm=TRUE)
            bynom <- seq(end1, end2, length.out = bynom)
        }

        ## find closest bynom value for each byvar value
        ## [1] used in function to select the 1st (lower) closest value if more than 1 found
        byvarnom <- unlist( purrr::pmap(list(x = byvar),
                                        function(x) DescTools::Closest(bynom, x)[1]) )
        if (length(byvarnom) > length(byvar)) {
            ## should no longer reach this error with addition of [1] in above function
            cat('\n##############################################\n')
            cat(  'FATAL ERROR: bynom results in one or more     \n')
            cat(  '             byvar values with multiple       \n')
            cat(  '             closesest points. Try again with \n')
            cat(  '             different bynom # or vector.)    \n')
            cat('\n##############################################\n\n')
            return()
        }

        ## replace byvar with byvarnom for plotting purposes
        byvar <- byvarnom

    }

    ##-----------------------------------------------------------------------------
    ## put data into dataframe and remove any pairs that do not have values
    xxcol  <- 1
    yycol  <- 2
    bycol  <- 3
    colcol <- 4
    if (is.na(byvar[1])) {
        df       <- na.omit( data.frame(xx, yy) )
        ## expand byvar=NA for every point
        df$byvar <- NA
    } else {
        df    <- na.omit( data.frame(xx, yy, byvar) )
        byvar <- df$byvar
    }
    ## write points back out
    xx <- df$xx
    yy <- df$yy

    if (length(color) == length(xx)) {
        ## color provided for each datapoint
        ## create cols dataframe with byvar and color columns
        df$color <- color
        cols     <- select(df, byvar, color)

    } else {
        ## color palette provided rather than defining one color for each point
        ## sort the dataframe by byvar
        df <- df[order(df$byvar),]
        ## expand color vector to identify color for every point
        cols  <- data.frame(byvar=unique(c(as.character(df$byvar))))
        if (nrow(cols) <= length(color)) {
            ## palette has sufficient unique colors for plot
            cols$color <- color[1:nrow(cols)]
        } else {
            ## too many colors for palette so ramp
            ## define color palette
            pal   <- colorRampPalette(color)
            ncol  <- length(unique(byvar))
            color <- pal(ncol)
            ## to see colors
            ## scales::show_col(use)
            ## add column for color to dataframe
            cols$color <- color
        }
        ## merge with the original dataframe to add column for color
        df <- merge(df, cols, by="byvar")
        ## put order of columns back
        df <- data.frame(xx=df$xx, yy=df$yy, byvar=df$byvar, color=df$color)
    }
    ## sort the dataframe by byvar
    df    <- df[order(df$byvar),]
    ## replace inputs with sorted order inputs
    xx    <- df$xx
    yy    <- df$yy
    byvar <- df$byvar
    ## following was added to drop unwanted levels
    ## without it, the legend was wrong because it used the levels
    ## which had the colors in the wrong order
    df$color <- as.character(df$color)
    color <- df$color

    ##-----------------------------------------------------------------------------
    ## handle byvar
    if (is.na(byvar[1])) {
        ## no byvar specified so single colored points
        colorpoints <- FALSE
        legendnames <- NA
        nfit <- 1
    } else if (isFALSE(multifit)) {
        ## byvar was specified so want colored points
        colorpoints <- TRUE
        ## but do not want multifit
        legendnames <- unique(byvar)
        nfit <- 1
    } else {
        ## byvar was specified so want colored points
        colorpoints <- TRUE
        ## want 1 fit for each unique byvar
        legendnames <- unique(byvar)
        nfit  <- length(legendnames)
    }

    ##-----------------------------------------------------------------------------
    ## define plot parameters
    xmax   <- max(xlimspec, xx, xx, vlines, na.rm=TRUE)
    xmin   <- min(xlimspec, xx, xx, vlines, na.rm=TRUE)
    ylimspec <- range(ylimspec, yy, yy, na.rm=TRUE)
    if (isTRUE(colorpoints) & is.na(legendloc)) {
        ## make extra room for legend
        xmax_plot <- xmax + (xmax-xmin)*0.2
    } else {
        xmax_plot <- xmax
    }
    xlimspec <- range(xmin, xmax_plot)

    ##-----------------------------------------------------------------------------
    ## setup for output jpeg file
    if (!missing(outputfile)) jpeg(filename=outputfile)

    ## change background of plot to specified color
    par(bg=bg)

    ## create empty plot
    plot(xx, yy, type='n',
         xlim=xlimspec,  ylim=ylimspec,
         xlab=xlabel,  ylab=ylabel,
         main=main)

    if (isTRUE(grid)) grid(col='gray70')

    ##-----------------------------------------------------------------------------
    ## add points not used in fit
    ## not programmed

    ##-----------------------------------------------------------------------------
    ## add points, fits and vlines
    eq      <- NA
    lineloc <- 1.5
    for (i in 1:nfit) {

        ## extract subset of data for ith byvar
        if (nfit == 1) {
            ## no byvar specified
            dfi <- df
        } else {
            ## byvar is specified
            dfi <- df[df[[bycol]] == legendnames[i],]
        }

        ## fit is over range of data for current byvar
        ## lines extended to max(vlines, data)
        vpair <- c(vlines[i*2-1], vlines[i*2])
        if (interval != 'noline') {
            ## add fit to plot
            out   <- addfit(dfi[[xxcol]], dfi[[yycol]], col=cols$color[i], pch=pch, vlines=vpair,
                            interval=interval, alpha=alpha, sided=sided)
            eq[i] <- out$equation

            if (i == 1) {
                if (nfit == 1) {
                    fitname <- NA
                } else {
                    fitname <- legendnames[i]
                }
                fits <- data.frame(fit       = fitname,
                                   slope     = out$slope,
                                   intercept = out$intercept,
                                   rise      = out$rise)
            } else {
                fits  <- rbind(fits, data.frame(fit       = legendnames[i],
                                                slope     = out$slope,
                                                intercept = out$intercept,
                                                rise      = out$rise))
            }
        }

        ## color points even though there is only one fit
        if (isTRUE(colorpoints) & nfit == 1) {
            points(xx, yy, col=color)
        }

        if (isTRUE(equation) & interval != 'line') {
            ## add the fit equations under main title
            ## subtitle <- list(eq1, eq2)
            ## mtext(subtitle, side=3, line=c(0.75, 0), cex=.75, col=color)
            lineloc = lineloc - 0.75
            mtext(eq[i], side=3, line=lineloc, cex=0.75, col=cols$color[i])
        }
    }

    ##-----------------------------------------------------------------------------
    ## add legend
    ## determine legend location by slope of all data
    if (isTRUE(colorpoints)) {
        if (is.na(legendloc)) {
            if (diff(range(xx)) > 0) {
                ## xx has more than 1 value so possible to define slope
                fitall       <- lm(yy~xx, data=df)
                fitall_slope <- fitall$coefficients[[2]]
                if (fitall_slope > 0) {
                    legendloc <- 'bottomright'
                } else {
                    legendloc <- 'topright'
                }
            } else {
                ## xx hsa only 1 value so not possible to define slope
                ## put legend at bottom right
                legendloc <- 'bottomright'
            }
        }
        legend(legendloc, title=bylabel, col=cols$color, legend=legendnames, pch=1)
    }

    ## for output jpeg file
    if (!missing(outputfile)) dev.off()

    ## change background back to base R default
    par(bg="white")

    ##-----------------------------------------------------------------------------
    if (suppress == 'no') {
        ## return fitted equations
        if (nfit > 1) {
            ## more than one equation so return as a list
            eq <- as.list(eq)
            names(eq) <- legendnames
        }
        legendprint <- data.frame(legendnames, color = cols$color)
        if (interval == 'nolne') {
            return(list(legend = legendprint))
        } else {
            return(list(fits = fits, legend = legendprint))
        }
    }

}

testplots <- function() {
    source('/home/dlhjel/GitHub_repos/R-setup/setup.r')
    df <- mtcars
    plotspace(1,3)
    plotfit(df$hp, df$mpg)
    plotfit(df$hp, df$mpg, df$cyl)
    with(df, plotfit(hp, mpg, cyl))

    plotspace(1,2)
    plotfit(df$hp, df$mpg, df$cyl, multifit=TRUE)
    plotfit(df$hp,         df$mpg,         df$cyl,
            'horsepower', 'miles per gal', 'cylinders',
            multifit=TRUE,
            vlines=c(50,120,  NA,NA,   100,350),
            xlimspec=c(0,500),
            main='my title')

    df1 <- df
    df1$type <- 'type1'
    df2     <- df1
    df2$hp  <- df1$hp + 100
    df2$mpg <- df1$mpg * 1.1 + rnorm(1, 10, 1)
    df2$type <- 'type2'
    df <- rbind(df1, df2)

    plotspace(1,2)
    plotfit(df$hp, df$mpg, df$type)
    plotfit(df$hp, df$mpg, df$type, multifit=TRUE, vlines=c(30,350,  100,450))

    df[58:64,]$type <- 'type is 3'
    plotfit(df$hp, df$mpg, df$type)
    out <- plotfit(df$hp, df$mpg, df$type, multifit=TRUE)

    plotspace(1,3)
    plotfit(df$mpg, df$disp, df$drat)
    plotfit(df$mpg, df$disp, df$drat, bynom=5)
    plotfit(df$mpg, df$disp, df$drat, bynom=c(2.76, 3.302, 3.845, 4.387, 4.93))

    plotspace(1,3)
    plotfit(mtcars$wt, mtcars$mpg, mtcars$qsec)
    with(mtcars, plotfit(wt, mpg, qsec, bynom=seq(14, 24, 2)))
    with(mtcars, plotfit(wt, mpg, qsec, bynom=seq(14, 24, 2),
                         color=c('black', 'darkviolet', 'blue', 'green', 'red')))
}


# 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("reshape2")

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

# Here we directly load the tips dataset installed with the "reshape2" package.
data(tips)

# rename column names in tips dataset
tipsOriginal <- setNames(tips, c("Total_Bill", "Tip_Amount", "Sex", "Smoker", "Day", "Time", "Size"))

# Omit rows with missing values
tipsOriginal = na.omit(tipsOriginal)

# 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")
# tips= read.csv("Tips.csv")

# Divide dataset for training and test
trainData<-tipsOriginal[1:195,]
testData<-tipsOriginal[196:244,]

# Applying GBM - gaussian function to predict tip
tips_GBM = gbm(Tip_Amount~., data=trainData,distribution="gaussian")

# Display the predicted results and create cross table to check on accuracy
# Predict "tip" column probability for test data set
tipsTestProbabilities = predict.gbm(tips_GBM,type = "response", n.trees=100, newdata=testData)
# Display predicted probabilities
tipsTestProbabilities

# PMML generation
r2pmml(tips_GBM ,"Tips.pmml")

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

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

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

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


 ZCPOSV Example Program Results

 Solution
    ( 1.0000,-1.0000) (-0.0000, 3.0000) (-4.0000,-5.0000) ( 2.0000, 1.0000)


rm(list=ls())
library(viridis)
library(dplyr)
library(ggplot2)
library(tidyr)
library(scales)
library(gridExtra)
library(ggpubr)

# To use for fills, add
#scale_fill_manual(values=cbPalette)
# To use for line and point colors, add
#scale_colour_manual(values=cbPalette)

#scale_color_viridis(discrete=TRUE)

dGLSofAvg <- function(numeratorConstraint,maxLikes){

  # Rename column name for numberator in calculation.
  colnames(maxLikes)[colnames(maxLikes)==numeratorConstraint] <- "numeratorConstraint"

  # Start a list of dGLS values for all loci in dataset
  numLoci <- length(maxLikes$numeratorConstraint)

  # Make lists and add to data frame with locus names, constraint name, and 0 values
  numeratorList <- rep(c(numeratorConstraint), times=numLoci)
  outdGLSList <- vector(mode="numeric",length=numLoci)

  # Make dataframe
  outdGLSdf <- subset(maxLikes, select = c('Locus'))
  outdGLSdf$Hypothesis <- numeratorList
  outdGLSdf$dGLSavg <- outdGLSList
  outdGLSdf$dGLSmax <- outdGLSList

  # create a dataset of alternate constraints only to average over
  drops <- c("Locus","numeratorConstraint")
  df <- maxLikes[,!(names(maxLikes) %in% drops)]

  # for locus in dataset
  for (i in 1:nrow(outdGLSdf)){

    # Get all alternate maxinal likehoods
    othermaxLikes <- as.numeric(df[i,])

    # Maximum of alternate maxLH
    a <- max(othermaxLikes)

    # Calculate average across alternate constraints
    avgOthermaxLikes <- mean(othermaxLikes)
    # Calculate average across alternate constraints
    avgOtherMargLikes <- a+log(sum(exp(othermaxLikes-a)))-log(length(names(df)))

    # Calculate dGLS based on average of other LH values
    outdGLSdf[i,3] <- maxLikes$numeratorConstraint[i]-avgOthermaxLikes
   # Calculate dGLS based on maximum of other LH values
    outdGLSdf[i,4] <- maxLikes$numeratorConstraint[i]-a}

  return(outdGLSdf)
}

writeCSV <- function (outData,outFile){
  write.csv(outData, file=outFile, row.names=FALSE)
}

setwd("/Users/ChatNoir/Projects/Squam/Graphs/dGLS")
mLdGLS <- read.table("StreicherdGLSSummary.txt",header=TRUE)

# Read in table of marginal Likelihoods
mL <- read.table("StreicherdGLSSummary.txt",header=TRUE)
mLTox <- mL[,!(names(mL) %in% c("Sclero"))]
names(mL)
mLaiS <- mL[,!(names(mL) %in% c("ToxAngIg"))]
mLsaS <- mL[,!(names(mL) %in% c("ToxSnIg"))]
mLsiS <- mL[,!(names(mL) %in% c("ToxSnAng"))]

# Get list of dGLS for each relationship, using an average of all other constraints as a composite hypothesis.

SclerodGLS <- dGLSofAvg("Sclero",mL)
SaiBF <- dGLSofAvg("Sclero",mLaiS)
SsaBF <- dGLSofAvg("Sclero",mLsaS)
SsiBF <- dGLSofAvg("Sclero",mLsiS)
# differences only within tox constraints
ToxAngIgdGLStx  <- dGLSofAvg("ToxAngIg",mLTox)
ToxSnAngdGLStx  <- dGLSofAvg("ToxSnAng",mLTox)
ToxSnIgdGLStx <- dGLSofAvg("ToxSnIg",mLTox)
# all
ToxAngIgdGLS  <- dGLSofAvg("ToxAngIg",mL)
ToxSnAngdGLS  <- dGLSofAvg("ToxSnAng",mL)
ToxSnIgdGLS <- dGLSofAvg("ToxSnIg",mL)

# Combine and factor
alldGLS <- bind_rows(SclerodGLS,ToxAngIgdGLS,ToxSnAngdGLS,ToxSnIgdGLS)
toxdGLS <- bind_rows(ToxAngIgdGLStx,ToxSnAngdGLStx,ToxSnIgdGLStx)
alldGLS$Hypothesis <- factor(alldGLS$Hypothesis, levels=c("Sclero","ToxAngIg","ToxSnAng","ToxSnIg"))
toxdGLS$Hypothesis <- factor(toxdGLS$Hypothesis, levels=c("ToxAngIg","ToxSnAng","ToxSnIg"))
toxdGLS <- toxdGLS %>% separate(Locus, c("LocusType","LocusNumber"), "-", remove = FALSE)

# Absolute values, averages of differences

mLablsAve <- mL %>% mutate(absAvg=(abs(Sclero-ToxAngIg)+
                        abs(Sclero-ToxSnAng)+
                        abs(Sclero-ToxSnIg)+
                        abs(ToxAngIg-ToxSnAng)+
                        abs(ToxAngIg-ToxSnIg)+
                        abs(ToxSnAng-ToxSnIg))/6) %>% select(Locus,absAvg)

# Support counts

toxdGLS <- mutate(toxdGLS, Supportavg = case_when(dGLSavg >= 0.5 ~ "Strong > 0.5",
                                                  dGLSavg > -0.5 & dGLSavg < 0.5 ~ "Ambiguous",
                                                  dGLSavg <= -0.5 ~ "Strong_Against < -0.5")) %>%
  mutate(Percentile = ntile(desc(dGLSavg),100))%>% mutate(locusRank=dense_rank(desc(dGLSavg)))
alldGLS <- mutate(alldGLS, Supportavg = case_when(dGLSavg >= 0.5 ~ "Strong > 0.5",
                                                  dGLSavg > -0.5 & dGLSavg < 0.5 ~ "Ambiguous",
                                                  dGLSavg <= -0.5 ~ "Strong_Against < -0.5")) %>%
  mutate(Percentile = ntile(desc(dGLSavg),100))%>% mutate(locusRank=dense_rank(desc(dGLSavg)))

toxSupport <- toxdGLS %>% group_by(Hypothesis,Supportavg) %>% dplyr::summarise(counts=n())
toxSupport$Supportavg <- factor(toxSupport$Supportavg, levels=c("Strong_Against < -0.5","Ambiguous","Strong > 0.5"))
allSupport <- alldGLS %>% group_by(Hypothesis,Supportavg) %>% dplyr::summarise(counts=n())
allSupport$Supportavg <- factor(allSupport$Supportavg, levels=c("Strong_Against < -0.5","Ambiguous","Strong > 0.5"))

# SAve R data here

#writeCSV(tvsSupport,"Streicher_tvsdGLSavg_support_avg.csv")
#writeCSV(toxSupport,"Streicher_toxdGLSavg_support_avg.csv")
#writeCSV(allSupport,"alldGLSavg_support.csv")

# Loci Lists

# Loci sig support for Sclero over Tox
# Loci sig support for Tox over Sclero
# Loci sig support for AI over other Tox
# Loci sig support for SA over other Tox
# Loci sig support for SI over other Tox
alldGLS.SC.loci <- alldGLS %>% select(Locus, dGLSavg, Hypothesis, Percentile, locusRank) %>%
  filter(Hypothesis=="Sclero") %>%
  filter(dGLSavg >= 0.5) %>% select(-Hypothesis)
alldGLS.AI.loci <- alldGLS %>% select(Locus, dGLSavg,Hypothesis,Percentile, locusRank) %>%
  filter(Hypothesis=="ToxAngIg") %>%
  filter(dGLSavg >= 0.5) %>% select(-Hypothesis)
alldGLS.SA.loci <- alldGLS %>% select(Locus, dGLSavg,Hypothesis,Percentile, locusRank) %>%
  filter(Hypothesis=="ToxSnAng") %>%
  filter(dGLSavg >= 0.5) %>% select(-Hypothesis)
alldGLS.SI.loci <- alldGLS %>% select(Locus, dGLSavg,Hypothesis,Percentile, locusRank) %>%
  filter(Hypothesis=="ToxSnIg") %>%
  filter(dGLSavg >= 0.5) %>% select(-Hypothesis)

toxdGLS.AI.loci <- toxdGLS %>% select(Locus, dGLSavg,Hypothesis,Percentile) %>%
  filter(Hypothesis=="ToxAngIg") %>%
  filter(dGLSavg >= 0.5) %>% select(-Hypothesis)
toxdGLS.SA.loci <- toxdGLS %>% select(Locus, dGLSavg,Hypothesis,Percentile) %>%
  filter(Hypothesis=="ToxSnAng") %>%
  filter(dGLSavg >= 0.5) %>% select(-Hypothesis)
toxdGLS.SI.loci <- toxdGLS %>% select(Locus, dGLSavg,Hypothesis,Percentile) %>%
  filter(Hypothesis=="ToxSnIg") %>%
  filter(dGLSavg >= 0.5) %>% select(-Hypothesis)

#writeCSV(tvsdGLS.SC.loci,"Streicher_tvsdGLS.SC.loci.avg.csv")
#writeCSV(tvsdGLS.TX.loci,"Streicher_tvsdGLS.TX.loci.avg.csv")
#writeCSV(toxdGLS.AI.loci,"Streicher_tvsdGLS.AI.loci.avg.csv")
#writeCSV(toxdGLS.SA.loci,"Streicher_tvsdGLS.SA.loci.avg.csv")
#writeCSV(toxdGLS.SI.loci,"Streicher_tvsdGLS.SI.loci.avg.csv")

############## Plots ############## ############## ############## ############## ##############

quartz()

############## Saved Plots ############## ############## ############## ############## ##############
tvsList <- c("orange","#482173FF")
myList <- c("orange","#38598CFF","#2BB07FFF","#C2DF23FF")
#show_col(myList)

# Streicher_dGLS_Histogram_All

myList <- c("orange","#38598CFF","#2BB07FFF","#C2DF23FF")
avg <- ggplot(alldGLS, aes(x=dGLSavg, fill=Hypothesis, color=Hypothesis)) +
  geom_histogram(binwidth = 0.5, alpha=1, position="dodge") +
  geom_vline(xintercept=c(0.5),color=c("black"), linetype="dashed", size=0.5) +
  scale_color_manual(values=myList) + scale_fill_manual(values=myList) +
  labs(x="dGLS Hypoth vs average")
avg.trunc <- ggplot(alldGLS, aes(x=dGLSavg, fill=Hypothesis, color=Hypothesis)) +
  geom_histogram(binwidth = 0.5, alpha=1, position="dodge") +
  geom_vline(xintercept=c(0.5),color=c("black"), linetype="dashed", size=0.5) +
  scale_color_manual(values=myList) + scale_fill_manual(values=myList) +
  labs(x="dGLS Hypoth vs avg") + xlim(-15,15)
avg.trunc
all <- ggarrange(avg,avg.trunc, ncol=1, nrow=2, common.legend = TRUE, legend="right")
avg
quartz()
all
ggsave("Streicher_dGLS_Histogram_All_avg.jpg", plot=all, width = 20, height = 20, units = "cm")

# Streicher_dGLS_Histogram_Tox - not useful visual

myList <- c("orange","#38598CFF","#2BB07FFF","#C2DF23FF")
txList <- c("#38598CFF","#2BB07FFF","#C2DF23FF")

avg <- ggplot(toxdGLS, aes(x=dGLSavg, fill=Hypothesis, color=Hypothesis)) +
  geom_histogram(binwidth = 0.5, alpha=1, position="dodge") +
  geom_vline(xintercept=c(0.5),color=c("black"), linetype="dashed", size=0.5) +
  scale_color_manual(values=txList) + scale_fill_manual(values=txList) +
  labs(x="dGLS Hypoth vs average")
max <- ggplot(toxdGLS, aes(x=dGLSmax, fill=Hypothesis, color=Hypothesis)) +
  geom_histogram(binwidth = 0.5, alpha=1, position="dodge") +
  geom_vline(xintercept=c(0.5),color=c("black"), linetype="dashed", size=0.5) +
  scale_color_manual(values=txList) + scale_fill_manual(values=txList) +
  labs(x="dGLS Hypoth vs maximum")
all <- ggarrange(avg,max, ncol=2, nrow=1, common.legend = TRUE, legend="right")
all
avg.trunc <- ggplot(toxdGLS, aes(x=dGLSavg, fill=Hypothesis, color=Hypothesis)) +
  geom_histogram(binwidth = 0.5, alpha=1, position="dodge") +
  geom_vline(xintercept=c(0.5),color=c("black"), linetype="dashed", size=0.5) +
  scale_color_manual(values=txList) + scale_fill_manual(values=txList) +
  labs(x="dGLS Hypoth vs average")  + xlim(-15,15)
avg.trunc
ggsave("Streicher_dGLS_Histogram_Tox_trunc.jpg", plot=avg.trunc, width = 30, height = 20, units = "cm")

# Streicher_dGLS_Violin_avg
data_summary <- function(x) {
  m <- mean(x)
  ymin <- m-sd(x)
  ymax <- m+sd(x)
  return(c(y=m,ymin=ymin,ymax=ymax))
}
tvs <- ggplot(tvsdGLS, aes(x=Hypothesis, y=dGLSavg, color=Hypothesis)) +
  geom_violin(trim=TRUE) + scale_color_manual(values=tvsList) + stat_summary(fun.data=data_summary)
tox <- ggplot(toxdGLS, aes(x=Hypothesis, y=dGLSavg, color=Hypothesis)) +
  geom_violin(trim=TRUE) + scale_color_manual(values=myList) + stat_summary(fun.data=data_summary)
tox.trunc <- ggplot(toxdGLS, aes(x=Hypothesis, y=dGLSavg, color=Hypothesis)) +
  geom_violin(trim=TRUE) + scale_color_manual(values=myList) + stat_summary(fun.data=data_summary) +
  ylim(-2,2)
tox.trunc

#ggsave("Streicher_dGLS_Violin_TvS_avg.jpg", plot=tvs, width = 20, height = 20, units = "cm")
#ggsave("Streicher_dGLS_Violin_Tox_avg.jpg", plot=tox, width = 20, height = 20, units = "cm")
#ggsave("Streicher_dGLS_Violin_Tox_avgtrunc.jpg", plot=tox.trunc, width = 20, height = 20, units = "cm")

# Streicher_dGLS_Classic_avg

tvsList <- c("orange","#482173FF")

max <- ggplot(data=SclerodGLS) +
  geom_bar(stat = "identity", position = position_dodge()) +
  theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank()) +
  aes(x=reorder(Locus,-dGLSmax,sum),y=dGLSmax,color = dGLSmax < 0, fill = dGLSmax < 0) +
  scale_color_manual(values=c("orange","#482173FF")) + scale_fill_manual(values=c("orange","#482173FF"))+
  labs(y="dGLS Hypoth vs maximum")
avg <- ggplot(data=SclerodGLS) +
  geom_bar(stat = "identity", position = position_dodge()) +
  theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank()) +
  aes(x=reorder(Locus,-dGLSavg,sum),y=dGLSavg,color = dGLSavg < 0, fill = dGLSavg < 0) +
  scale_color_manual(values=c("orange","#482173FF")) + scale_fill_manual(values=c("orange","#482173FF"))+
  labs(y="dGLS Hypoth vs average")
avg

all <- ggarrange(avg,max, ncol=1, nrow=2, common.legend = TRUE, legend=FALSE)
all
ggsave("Streicher_dGLS_Classic_TvS_avg.jpg", plot=avg, width = 30, height = 20, units = "cm")

toxList <- c("#38598CFF","#2BB07FFF","#C2DF23FF")

avgAI <- ggplot(data=ToxAngIgdGLStx) +
  geom_bar(stat = "identity", position = position_dodge()) +
  theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank()) +
  aes(x=reorder(Locus,-dGLSavg,sum),y=dGLSavg,color = dGLSavg < 0, fill = dGLSavg < 0) +
  scale_color_manual(values=c("#38598CFF","grey40")) + scale_fill_manual(values=c("#38598CFF","grey40"))+
  labs(y="dGLS Hypoth vs Average", title="(Anguimorph,Iguania)")  + scale_y_continuous(breaks=seq(-17,17, 2), limits=c(-17,17))
#avgAI
avgSA <- ggplot(data=ToxSnAngdGLStx) +
  geom_bar(stat = "identity", position = position_dodge()) +
  theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank()) +
  aes(x=reorder(Locus,-dGLSavg,sum),y=dGLSavg,color = dGLSavg < 0, fill = dGLSavg < 0) +
  scale_color_manual(values=c("#2BB07FFF","grey40")) + scale_fill_manual(values=c("#2BB07FFF","grey40"))+
  labs(y="dGLS Hypoth vs Average", title="(Snakes,Anguimorph)")  + scale_y_continuous(breaks=seq(-17,17, 2), limits=c(-17,17))
#maxSA
avgSI <- ggplot(data=ToxSnIgdGLStx) +
  geom_bar(stat = "identity", position = position_dodge()) +
  theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank()) +
  aes(x=reorder(Locus,-dGLSavg,sum),y=dGLSavg,color = dGLSavg < 0, fill = dGLSavg < 0) +
  scale_color_manual(values=c("#C2DF23FF","grey40")) + scale_fill_manual(values=c("#C2DF23FF","grey40"))+
  labs(y="dGLS Hypoth vs Average", title="(Snakes,Iguania)")  + scale_y_continuous(breaks=seq(-17,17, 2), limits=c(-17,17))
#avgSI

all <- ggarrange(avgAI, avgSA, avgSI, ncol=1, nrow=3, common.legend = TRUE, legend=FALSE)
all
#ggsave("Streicher_dGLS_Classic_Tox_avg.jpg", plot=all, width = 20, height = 40, units = "cm")


# 1-20-10 Qunhua Li
#
# This program first plots correspondence curve and IDR threshold plot
# (i.e. number of selected peaks vs IDR) for each pair of sample
#
# usage:
# Rscript batch-consistency-plot-merged.r [npairs] [output.dir] [input.file.prefix 1, 2, 3 ...]
# [npairs]: integer, number of consistency analyses
#          (e.g. if 2 replicates, npairs=1, if 3 replicates, npairs=3
# [output.dir]: output directory for plot
# [input.file.prefix 1, 2, 3]: prefix for the output from batch-consistency-analysis2. They are the input files for merged analysis see below for examples (i.e. saved.file.prefix). It can be multiple files
#

args <- commandArgs(trailingOnly=T)
npair <- args[1] # number of curves to plot on the same figure
output.file.prefix <- args[2] # file name for plot, generated from script at the outer level
df.txt <- 10
ntemp <- as.numeric(npair)
saved.file.prefix <- list() # identifier of filenames that contain the em and URI results
source("functions-all-clayton-12-13.r")

uri.list <- list()
uri.list.match <- list()
ez.list <- list()
legend.txt <- c()
em.output.list <- list()
uri.output.list <- list()

for(i in 1:npair){
  saved.file.prefix[i] <- args[2+i]

  load(paste(saved.file.prefix[i], "-uri.sav", sep=""))
  load(paste(saved.file.prefix[i], "-em.sav", sep=""))

  uri.output.list[[i]] <- uri.output
  em.output.list[[i]] <- em.output

  ez.list[[i]] <- get.ez.tt.all(em.output, uri.output.list[[i]]$data12.enrich$merge1,
                                uri.output.list[[i]]$data12.enrich$merge2) # reverse =T for error rate

  # URI for all peaks
  uri.list[[i]] <- uri.output$uri.n
  # URI for matched peaks
  uri.match <- get.uri.matched(em.output$data.pruned, df=df.txt)
  uri.list.match[[i]] <- uri.match$uri.n

  file.name <- unlist(strsplit(as.character(saved.file.prefix[i]), "/"))

  legend.txt[i] <- paste(i, "=", file.name[length(file.name)])

}

plot.uri.file <- paste(output.file.prefix, ".pdf", sep="")

############# plot and report output
# plot correspondence curve for each pair,
# plot number of selected peaks vs IDR
# plot all into 1 file
pdf(paste(output.file.prefix, ".pdf", sep=""), width=15, height=7)
par(mfcol=c(2,3), mar=c(5,6,4,2)+0.1)
plot.uri.group(uri.list, NULL, file.name=NULL, c(1:npair), title.txt="all peaks")
plot.uri.group(uri.list.match, NULL, file.name=NULL, c(1:npair), title.txt="matched peaks")
plot.ez.group(ez.list, plot.dir=NULL, file.name=NULL, legend.txt=c(1:npair), y.lim=c(0, 0.6))
plot(0, 1, type="n", xlim=c(0,1), ylim=c(0,1), xlab="", ylab="", xaxt="n", yaxt="n") # legends
legend(0, 1, legend.txt, cex=0.6)

dev.off()


\name{psm_analysis}
\alias{psm_analysis}

\title{
Van Westendorp Price Sensitivity Meter Analysis (PSM)
}

\description{
\code{psm_analysis()} performs an analysis of consumer price
  preferences and price sensitivity known as \bold{van
  Westendorp Price Sensitivity Meter (PSM)}. It takes respondent's
  price preferences (from survey data) as an input and estimates
  acceptable price ranges and price points. For a description of
  the method see the \emph{Details} section.
}

\usage{
psm_analysis(
  toocheap, cheap, expensive, tooexpensive,
  data = NA,
  validate = TRUE,
  interpolate = FALSE,
  interpolation_steps = 0.01,
  intersection_method = "min",
  pi_cheap = NA, pi_expensive = NA,
  pi_scale = 5:1,
  pi_calibrated = c(0.7, 0.5, 0.3, 0.1, 0))
}

\arguments{
  \item{toocheap, cheap, expensive, tooexpensive}{If a
  data.frame/matrix/tibble is provided in the \code{data}
  argument: names of the variables in the data.frame/matrix
  that contain the survey data on the respondents' "too cheap",
  "cheap", "expensive" and "too expensive" price preferences.

  If no data.frame/matrix/tibble is provided in the \code{data}
  argument: numeric vectors that directly include this
  information. If numeric vectors are provided, it is assumed
  that they are sorted by respondent ID (the preferences for
  respondent \code{n} are stored at the \code{n}-th position in
  all vectors).

  If the \code{toocheap} price was not assessed, a
  variable/vector of NAs can be used instead. This
  variable/vector needs to have the same length as the other
  survey information. If \code{toocheap} is NA for all cases,
  it is possible to calculate the Point of Marginal
  Expensiveness and the Indifference Price Point, but it is
  impossible to calculate the Point of Marginal Cheapness and
  the Optimal Price Point.}
  \item{data}{data.frame, matrix or tibble that contains the
  function's input data. \code{data} input is not mandatory:
  Instead of using a data.frame/matrix/tibble as an input, it
  is also possible to provide the data directly as vectors in
  the "too cheap", "cheap", "expensive" and "too expensive"
  arguments.}
  \item{validate}{logical. should only respondents with
  consistent price preferences (too cheap < cheap < expensive
  < too expensive) be considered in the analysis?}
  \item{interpolate}{logical. should interpolation of the price
  curves be applied between the actual prices given by the
  respondents? If interpolation is enabled, the output appears
  less bumpy in regions with sparse price information. If the
  sample size is sufficiently large, interpolation should not
  be necessary.}
  \item{interpolation_steps}{numeric. if \code{interpolate} is
  \code{TRUE}: the size of the interpolation steps. Set by
  default to 0.01, which should be appropriate for most goods
  in a price range of 0-50 USD/Euro.}
  \item{intersection_method}{"min" (default), "max", "mean" or
  "median". defines the method how to determine the price
  points (range, indifference price, optimal price) if there
  are multiple possible intersections of the price curves.
  "min" uses the lowest possible prices, "max" uses the
  highest possible prices, "mean" calculates the mean among
  all intersections and "median" uses the median of all
  possible intersections}
  \item{pi_cheap, pi_expensive}{Only required for the Newton
  Miller Smith extension. If \code{data} argument is provided:
  names of the variables in the data.frame/matrix/tibble that
  contain the survey data on the respondents' purchase intent
  at their individual cheap/expensive price.}
  \item{pi_scale}{Only required for the Newton Miller Smith
  extension. Scale of the purchase intent variables pi_cheap and
  pi_expensive. By default assuming a five-point scale with 5
  indicating the highest purchase intent.}
  \item{pi_calibrated}{Only required for the Newton Miller Smith
  extension. Calibrated purchase probabilities that are assumed
  for each value of the purchase intent scale. Must be the same
  order as the pi_scale variable so that the first value of
  pi_calibrated corresponds to the first value in the pi_scale
  variable. Default values are taken from the Sawtooth Software
  PSM implementation in Excel: 70\% for the best value of the
  purchase intent scale, 50\% for the second best value,
  30\% for the third best value (middle of the scale), 10\%
  for the fourth best value and 0\% for the worst value.}
}

\details{
The Price Sensitivity Meter method for the analysis of consumer
price preferences was proposed by the Dutch economist Peter van
Westendorp in 1976 at the ESOMAR conference. It is a
survey-based approach that has become one of the standard price
acceptance measurement techniques in the market research
industry and is still widely used for during early-stage product
development.

Price acceptance and price sensitivity are measured in van
Westendorp's approach by four open-ended survey questions:

\itemize{
\item At which price on this scale are you beginning to
experience \dots (test-product) as cheap?
\item At which price on this scale are you beginning to
experience \dots (test-product) as expensive?
\item At which price on this scale you are beginning to
experience \dots (test-product) as too expensive -- so that you
would never consider buying it yourself?
\item At which price on this scale you are beginning to
experience \dots (test-product) as too cheap -- so that you say
"at this price the quality cannot be good"?
}

Respondents with inconsistent price preferences (e.g. "cheap"
price larger than "expensive" price) are usually removed from
the data set. This function has built-in checks to detect
invalid preference structures and removes those respondents from
the analysis by default.

To analyze price preferences and price sensitivity, the method
uses cumulative distribution functions for each of the
aforementioned price steps (e.g. "how many respondents think
that a price of \code{x} \emph{or more} is expensive?"). By
convention, the distributions for the "too cheap" and the
"cheap" price are inverted. This leads to the interpretation
"how many respondents think that a price of \emph{up to}
\code{x} is (too) cheap?".

The interpretation is built on the analysis of the intersections
of the four cumulative distribution functions for the different
prices (usually via graphical inspection). The original paper
describes the four intersections as follows:

\itemize{
\item \bold{Point of Marginal Cheapness (MGP)}: Below this price
point, there are more respondents that consider the price as
"too cheap" than respondents who consider it as "not cheap"
(intersection of "too cheap" and "not cheap"). This is interpreted
as the lower limit of the range of acceptable prices.
\item \bold{Point of Marginal Expensiveness (MEP)}. Above this
price point, there are more respondent that consider the price
as "too expensive" than there are respondents who consider it as
"not expensive" (intersection of "not expensive" and "too
expensive"). This is interpreted as the upper limit of the
range of acceptable prices.
\item \bold{Indifference Price Point (IDP)}: The same number of
respondents perceives the price as "cheap" and "expensive"
(intersection of "cheap" and "expensive"). In van Westendorp's
interpretation, this is either the median price paid in the
market or the price of an important market-leader.
\item \bold{Optimal Price Point (OPP)}: The same number of
respondents perceives the product as "too cheap" and "too
expensive" (intersection of "too cheap" and "too expensive").
van Westendorp argues that this is the value for which the
respondents' resistance against the price is particularly low.
}

Besides those four intersections, van Westendorp's article
advises to analyze the cumulative distribution functions for
steep areas which indicate price steps.

To analyze trial rates and estimate revenue forecasts,
Newton/Miller/Smith have extended van Westendorp's original
model by adding two purchase intent questions that are asked for
the respondent's "cheap" and "expensive" price. The purchase
probability at the respondent's "too cheap" and "too expensive"
price are defined as \code{0}. The main logic is that the "too
expensive" price point is prohibitively expensive for the
respondent and a price at the "too cheap" price level raises
doubts about the product quality.

By combining the standard van Westendorp questions with those
two additional purchase intent questions, it becomes possible to
summarize the purchase probabilities across respondents (using
linear interpolation for the purchase probabilities between each
respondent's cornerstone prices). The maximum of this curve is
then defined as the price point with the highest expected trial
rate. Moreover, by multiplying the trial rate with the price, it
also becomes possible to estimate a price with the highest
expected revenue.

It has to be noted that the van Westendorp Price Sensitivity
Meter is useful in some cases, but does not answer every
pricing-related question. It may be a good tool to assess very
broadly if the consumers' price perceptions exceed the actual
production costs. For more complex analyses (e.g. defining
specific prices for different products to avoid cannibalization
and drive at the same time incremental growth), other
methodological approaches are needed.
}

\value{
The function output consists of the following elements:

    \item{\code{data_input}:}{\code{data.frame} object. Contains
    the data that was used as an input for the analysis.}
    \item{\code{validated}:}{\code{logical} object. Indicates
    whether the \code{"validate"} option has been used (to
    exclude cases with intransitive price preferences).}
    \item{\code{invalid_cases}:}{\code{numeric} object. Number
    of cases with intransitive price preferences.}
    \item{\code{total_sample}:}{\code{"numeric"} object.
    Total sample size of the input sample \emph{before}
    assessing the transitivity of individual price preferences.}
    \item{\code{data_vanwestendorp}:}{\code{data.frame} object.
    Output data of the Price Sensitivity Meter analysis.
    Contains the cumulative distribution functions for the four
    price assessments (too cheap, cheap, expensive, too
    expensive) for all prices.}
    \item{\code{pricerange_lower}:}{\code{numeric} object. Lower
    limit of the acceptable price range as defined by the
    Price Sensitivity Meter, also known as \bold{point of
    marginal cheapness}: Intersection of the "too cheap" and the
    "not cheap" curves.}
    \item{\code{pricerange_upper}:}{\code{numeric} object. Upper
    limit of the acceptable price range as defined by the Price
    Sensitivity Meter, also known as \bold{point of marginal
    expensiveness}: Intersection of the "too expensive" and the
    "not expensive" curves.}
    \item{\code{idp}:}{\code{numeric} object. \bold{Indifference
    Price Point} as defined by the Price Sensitivity Meter:
    Intersection of the "cheap" and the "expensive" curves.}
    \item{\code{opp}:}{\code{numeric} object. \bold{Optimal
    Price Point} as defined by the Price Sensitivity Meter:
    Intersection of the "too cheap" and the "too expensive"
    curves.}
    \item{\code{NMS}:}{\code{logical} object. Indicates whether
    the additional analyses of the Newton Miller Smith Extension
    were performed.}
    \item{\code{weighted}:}{\code{logical} object. Indicates
    if weighted data was used in the analysis. Outputs from
    \code{psm_analysis()} always have the value \code{FALSE}.
    When data is weighted, use the function
    \code{\link{psm_analysis_weighted}.}}
    \item{\code{data_nms}:}{\code{data.frame} object. Output of
    the Newton Miller Smith extension: calibrated mean
    purchase probabilities for each price point.}
    \item{\code{pi_scale}:}{\code{data.frame} object. Shows the
    values of the purchase intent variable and the
    corresponding calibrated purchase probabilities as defined
    in the function input for the Newton Miller Smith
    extension.}
    \item{\code{price_optimal_trial}:}{\code{numeric} object.
    Output of the Newton Miller Smith extension: Estimate for
    the price with the highest trial rate.}
    \item{\code{price_optimal_revenue}:}{\code{numeric} object.
    Output of the Newton Miller Smith extension:
    Estimate for the price with the highest revenue (based on
    the trial rate).}
}

\references{
  Van Westendorp, P (1976) "NSS-Price Sensitivity Meter (PSM) --
  A new approach to study consumer perception of price"
  \emph{Proceedings of the ESOMAR 29th Congress}, 139--167. Online
  available at \url{https://www.researchworld.com/a-new-approach-to-study-consumer-perception-of-price/}.

  Newton, D, Miller, J, Smith, P, (1993) "A market acceptance
  extension to traditional price sensitivity measurement"
  \emph{Proceedings of the American Marketing Association
  Advanced Research Techniques Forum}.

  Sawtooth Software (2016) "Templates for van Westendorp PSM for
  Lighthouse Studio and Excel". Online available at
  \url{https://sawtoothsoftware.com/resources/software-downloads/tools/van-westendorp-price-sensitivity-meter}
}

\seealso{
The function \code{psm_analysis_weighted()} performs the same
analyses for weighted data.
}

\examples{

set.seed(42)

# standard van Westendorp Price Sensitivity Meter Analysis
# input directly via vectors

tch <- round(rnorm(n = 250, mean = 5, sd = 0.5), digits = 2)
ch <- round(rnorm(n = 250, mean = 8.5, sd = 0.5), digits = 2)
ex <- round(rnorm(n = 250, mean = 13, sd = 0.75), digits = 2)
tex <- round(rnorm(n = 250, mean = 17, sd = 1), digits = 2)

output_psm_demo1 <- psm_analysis(toocheap = tch,
  cheap = ch,
  expensive = ex,
  tooexpensive = tex)

# additional analysis with Newton Miller Smith Extension
# input via data.frame

pint_ch <- sample(x = c(1:5), size = length(tex),
  replace = TRUE, prob = c(0.1, 0.1, 0.2, 0.3, 0.3))

pint_ex <- sample(x = c(1:5), size = length(tex),
  replace = TRUE, prob = c(0.3, 0.3, 0.2, 0.1, 0.1))

data_psm_demo <- data.frame(tch, ch, ex, tex, pint_ch, pint_ex)

output_psm_demo2 <- psm_analysis(toocheap = "tch",
  cheap = "ch",
  expensive = "ex",
  tooexpensive = "tex",
  pi_cheap = "pint_ch",
  pi_expensive = "pint_ex",
  data = data_psm_demo)

summary(output_psm_demo2)
}


## 1. Lists: Objects That Can Contain Multiple Data Types ##

harvard <- c(1,1,1,1,3)
stanford <- c(2,9,3,4,10)
MIT <- c(3,3,2,2,1)
cambridge <- c(4,2,6,13,48)
oxford <- c(5,7,12,9,15)
columbia <- c(6,13,13,12,4)
# Type your code below
category_names <- c("world_rank", "quality_of_education", "influence", "broad_impact", "patents")
university_matrix <- rbind(harvard, stanford, MIT, cambridge, oxford, columbia)
colnames(university_matrix) <- category_names

## 2. Creating a List ##

university_clubs <- list("ballroom dancing","rugby","bird watching", "pottery")
mit_list <- list("MIT", c(3,3,2,2,1), TRUE)
mit_named_list <- list(name = "MIT", ranking = c(3,3,2,2,1), is_in_usa = TRUE)

## 3. Anatomy of a List ##

club_title <- c("Chess Club")
club_description <- c("Meets two nights a week for members to play chess. Snacks are provided.")
club_dues <- c(50, 20, 15)
meeting_days <- c("Monday", "Wednesday")
meeting_times <- c("6:00 pm", "8:00 pm")

# Type your code below
club_meetings <- rbind(meeting_days, meeting_times)
chess_club <- list(club_title, club_description, club_dues, club_meetings)

## 4. Getting/Setting Names to List Objects ##

club_meetings <- rbind(meeting_days, meeting_times)
chess_club <- list(club_title, club_description, club_dues, club_meetings)
chess_club_names <- c("club_title", "club_description", "club_dues", "club_meetings")
# Type your code below
names(chess_club) <- chess_club_names

## 5. Indexing Lists ##

meeting_matrix <- chess_club[[4]]
club_second_due <- chess_club[[c(3,2)]]

## 6. Modifying List Elements ##

chess_club[[c(3, 3)]] <- 5
chess_club[[c(3, 3)]]

## 7. Appending Elements to Lists ##

first_years <- c(12, 15)
names(first_years) <- c("fall", "spring")
# Type your code below
first_years <- c(12, 15)
names(first_years) <- c("fall", "spring")
# Type your code below
chess_club[["first_years"]] <- first_years
chess_club$first_years[[2]]

## 8. Removing Elements from a List ##

chess_club <- list("club_title" = c("Chess Club"),
                   "club_description" = c("Meets two nights a week for members to play chess. Snacks are provided."),
                   "club_dues" = c(50, 20, 15),
                   "club_meetings" = rbind(c("Monday", "Wednesday"),  c("6:00 pm", "8:00 pm")),
                   "first_years" = c("fall" = 12, "spring" = 15))
# Type your code below
chess_club_without_1 <- chess_club[-1]
chess_club_without_34 <- chess_club[c(-3, -4)]

## 9. Combining Lists ##

university_clubs <- list(rugby_club = rugby_club,
                         ballroom_dancing = ballroom_dancing,
                         chess_club = chess_club)

Data Analyst in R/Step 1 - Introduction to R/2. Data Structures in R/3. Lists in R.r


data <- read.table("./users-p-v.dat", header=T, sep="|")
#counts <- table(data$Provider, data$Lifestyle)
counts <- table(data$Lifestyle, data$Provider)
#counts <- table(data$Vegan)
#counts <- table(data["Vegan"], data["Vegetarisch"],
#				data["Karnistisch"])
png(filename="./users-p-v.png", height=500, width=500, bg="white")
desc = paste("Verteilung der", sum(counts), "Tester*innen auf die
			 Anbieter*innen inkl. Lebensweise", sep = " ")

print(table(data$Provider))
print(counts)

barplot(counts, main=desc, col=c("#c05b59", "#468848", "#c09853"),
		legend = rownames(counts))
title(xlab="Anbieter*in")
title(ylab="Anzahl Tester*innen")
# TODO: add legende
#barplot(counts, main=desc, col=c("#468848", "#c09853", "#c05b59"))

#, names.arg=(unique(sort(data$Provider))))
#,
#		col=c("darkblue","red","green","yellow"))
#barplot(counts, main=desc, names.arg=(data$Provider),
#		col=c("#171515", "#cf3e2c", "#45619d", "#00aced"))


# Goal:
#       A stock is traded on 2 exchanges.
#       Price data is missing at random on both exchanges owing to non-trading.
#       We want to make a single price time-series utilising information
#          from both exchanges. I.e., missing data for exchange 1 will
#          be replaced by information for exchange 2 (if observed).

# Let's create some example data for the problem.
e1 <- runif(15)                         # Prices on exchange 1
e2 <- e1 + 0.05*rnorm(15)               # Prices on exchange 2.
cbind(e1, e2)
# Blow away 5 points from each at random.
e1[sample(1:15, 5)] <- NA
e2[sample(1:15, 5)] <- NA
cbind(e1, e2)

# Now how do we reconstruct a time-series that tries to utilise both?
combined <- e1                          # Do use the more liquid exchange here.
missing <- is.na(combined)
combined[missing] <- e2[missing]        # if it's also missing, I don't care.
cbind(e1, e2, combined)
# There you are.

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/b10.r


library("testthat")
library("waddR")

##########################################################################
##                    WASSERSTEIN.TEST FUNCTION                         ##
##########################################################################
test_that("Input Validation for wasserstein test", {
  invalid_method <- "TS"
  expect_error(wasserstein.test(rnorm(199, 20, 0.4),
                                rnorm(239, 19, 2),
                                method=invalid_method))
})

test_that("Correctness of wasserstein test", {
  set.seed(42)
  x<- rnorm(100,20,3)
  y <- rnorm(134, 30,10)
  output <- wasserstein.test(x, y, method="ASY", permnum=1000)
  expect_known("value", output,
               file="known.values/testresult_correctness_wasserstein_test_1")
})

test_that("Example Run of Wasserstein Test", {
  v<-rnorm(500)
  w<-rnorm(500,1,2)
  names.sp <- c("d.wass", "d.wass^2", "d.comp^2", "d.comp", "location", "size",
                "shape", "rho", "pval", "p.ad.gpd", "N.exc", "perc.loc",
                "perc.size", "perc.shape", "decomp.error")
  names.asy <- c("d.wass","d.wass^2","d.comp^2","d.comp",
                 "location","size","shape","rho","pval","perc.loc",
                 "perc.size","perc.shape","decomp.error")

  expect_named(wasserstein.test(v, w, method="SP", permnum=10),
               expected=names.sp, ignore.order=TRUE)
  expect_named(wasserstein.test(v, w, method="ASY"),
               expected=names.asy, ignore.order=TRUE)

  # example from the wasserstein_test vignette that displayed an error
  set.seed(24)
  ctrl <- rnorm(300 ,0 ,1)
  set.seed(24)
  dd1 <- rnorm(300, 1, 1)

  expect_named(wasserstein.test(ctrl, dd1, method="SP", permnum=10000),
               expected=names.sp, ignore.order=TRUE)

})


## File: simulaciones-tubos.r
## Description: Estudio de simulacion para evaluar calidad de predicciones por
##              tubos de los estimadores de densidad H, FP, Kde, BagHistFP,
##              BagHist, Rash, ASH.

library(devtools)
#install("../CppFunctions")
library(CppFunctions)
source("functions2.r")
library(iterators)
library(parallel)
library(doParallel)
library(foreach)

rm(list = ls())
source("functions2.R")

# LAS FUNCIONES ESTAN COMENTADAS PORQUE SE EXPORTAN DEL functions2.R
# tube_hist <- function(data, nbr = 50, B = 10, conf = c(0.05, 0.95)) {
#   # A chaque etape, on prend un nouveau jeu de donn?es, on construit un
#   # histogramme, on pr?dit et on agr?ge.
#
#   xx <- data$train
#   grille <- data$test
#   n <- length(xx)
#   mat <- matrix(ncol = length(grille), nrow = B)
#
#   for (i in 1:B) {
#     xb  = xx[sample(n, replace = TRUE)]
#     mybreaks <- mybreaks(xb, nbr)
#     hs2 = hist(xb, breaks = mybreaks, plot = FALSE)
#
#     mat[i, ] <- predict.hist(hh = hs2, x = grille)
#   }
#
#   punctual <- colMeans(mat, na.rm = TRUE)
#   tube     <- baseboot(data$test, punctual, mat, conf = conf)
#
#   return(list(punctual = punctual, bunch = mat, tube = tube))
# }
#
# tube_fp <- function(data, nbr = 50, B = 10, conf = c(0.05, 0.95)) {
#   # A chaque etape, on prend un nouveau jeu de donn?es, on construit un
#   # histogramme, on pr?dit et on agr?ge.
#
#   xx <- data$train
#   grille <- data$test
#   n <- length(xx)
#   mat <- matrix(ncol = length(grille), nrow = B)
#
#   for (i in 1:B) {
#     xb  = xx[sample(n, replace = TRUE)]
#     mybreaks <- mybreaks(xb, nbr)
#     hs2 = hist(xb, breaks = mybreaks, plot = FALSE)
#
#     mids <- hs2$mids
#     delta <- diff(mybreaks)[1]
#     # This avoids NA on prediction for test data between the min on grille
#     # and the min obs value on xb
#     newmids <- c(min(mids) - delta, mids, max(mids) + delta)
#
#     mat[i, ] <- approxfun(x = newmids, y = c(0, hs2$density, 0))(grille)
#   }
#
#   # NAs occur when test data falls beyond the FP's support. They may safetly
#   # be replaced by 0s
#   mat[is.na(mat)] <- 0
#
#   punctual <- colMeans(mat, na.rm = TRUE)
#   tube     <- baseboot(data$test, punctual, mat, conf = conf)
#
#   return(list(punctual = punctual, bunch = mat, tube = tube))
# }
#
# tube_KDE <- function(data, nbr = 50, B = 10, conf = c(0.05, 0.95)) {
#   # A chaque etape, on prend un nouveau jeu de donn?es, on construit un
#   # histogramme, on pr?dit et on agr?ge.
#
#   xx <- data$train
#   grille <- data$test
#   n <- length(xx)
#   mat <- matrix(ncol = length(grille), nrow = B)
#
#   for (i in 1:B) {
#     xb  = xx[sample(n, replace = TRUE)]
#     mat[i, ] <- onekdeucv(xx = xb, grille = grille)
#   }
#
#   punctual <- colMeans(mat, na.rm = TRUE)
#   tube     <- baseboot(data$test, punctual, mat, conf = conf)
#
#   # usando la escala raiz  => escala invariante al usar quantiles
# #  tube     <- baseboot(data$test, sqrt(punctual), sqrt(mat))
# #  tube[tube < 0] <- 0
# #  tube <- tube^2
#
#   return(list(punctual = punctual, bunch = mat, tube = tube))
# }
#
#
# tube_KDEsm <- function(data) { # only at 90% (hard coded)
#   fit <- sm::sm.density(data$train, h = bw.ucv(data$train), display = "none",
#                         eval.grid = TRUE, eval.points = data$test)
#   return(list(punctual = fit$estimate,
#               tube = rbind(fit$lower, fit$upper)))
# }
#
#
# tube_wass <- function(data, alpha = 0.1, nbr = 50, plot = FALSE, ...) {
#   xb  <- data$train
#   n   <- length(data$train)
#
#   hs <- hist(xb, breaks = mybreaks(xb, nbr),
#              warn.unused = FALSE, probability = TRUE, plot = plot, ...)
#
#   m   <- length(hs$counts)
#   c   <- qnorm(p = 1 - alpha / 2 / m) * sqrt(m / n)
#
#   ln1    <- c(pmax(sqrt(hs$density) - c, 0)^2, 0)
#   un1    <- c((sqrt(hs$density) + c)^2       , 0)
#
#   hs2 <- predict.hist(hs, data$test)
#
#   ln2    <- pmax(sqrt(hs2) - c, 0)^2
#   un2    <- (sqrt(hs2) + c)^2
#
#   if (plot) {
#     lines(data$test, ln2, type = 's', col = 4, lwd = 2)
#     lines(data$test, un2, type = 's', col = 4, lwd = 2)
#   }
#
#   return(list(punctual = hs2,
#               tube = rbind(ln2, un2)))
# }

## 0. Simulate data ####
#dd <- list(train = rnorm(1000), test = sort(rnorm(1000)))
#oo <- tube_wass(dd, plot = TRUE,ylim = c(0, 2))
#lines(dd$test, oo$punctual, col = 2, lwd = 2)
#lines(dd$test, oo$tube[1, ], type = 's', col = 4, lwd = 2)
#lines(dd$test, oo$tube[2, ], type = 's', col = 4, lwd = 2)
#curve(dchisq(x, 3), add = TRUE, col = 2, lwd = 2)

# error_tube(oo$punctual, oo$tube)
# uno <- gendata(1, 200)
# bis <- tube_KDE(uno)
# error_tube(bis$punctual, bis$tube)
#
# ter <- BagHistfp(uno, B = 100)
#
# qter <- tube_wass(uno)
#
# error_tube(ter$punctual,
#            baseboot(uno$test, ter$punctual, na.omit(ter$bunch)))
# error_tube(ter$punctual,
#            npheuristic(uno$test, ter$punctual, na.omit(ter$bunch)))
# error_tube(ter$punctual,
#            kfwe(uno$test, ter$punctual, na.omit(ter$bunch), k = 5))
# error_tube(qter$punctual, qter$tube)

## By default all the CI are at 90% (hard coded on sm.density)
simulaciones = function(n = 100,    # data size
                        M = 50,     # number of replicata
                        B = 150){   # number of bootstrapt samples
  estimators <- c("Hist", "FP", "Kde", "Kde_sm", "Kde_M") #, "wass")
  densities  <- c("normal", "chi2", "mix1", "bart", "triangular", "rara1", "rara2", "rara3")

    vars2export <- c("BagHistfp", "Bagkde", "bropt", "broptfp", "dtriangle",
                     "dberdev", "error", "ind", "rnorMix", "MW.nm14", "dnorMix",
                     "MW.nm16", "baseboot" , "tube_fp", "tube_KDEsm","cteboot",
                     "gendata", "kde", "mel", "melange", "mybreaks", "onekdeucv",
                     "predict.hist", "predict.hist.x.V2",   "rash", "rberdev", "error_tube",
                     "riskhist", "riskfp","rtriangle", "simulaciones", "tube_hist", "tube_KDE")
  res <- foreach(i = 1:M, .combine = rbind.data.frame,.export = vars2export,
                 .packages = c("sm", "CppFunctions")) %:%
    foreach(ll = c(1, 3, 5, 8, 11, 13, 20, 21), .combine = rbind) %dopar% {

      dd   <- gendata(ll, n)

      estim_hist  <- tube_hist(dd, B = B) #tubo_Hist(dd, B = B)
      estim_fp    <- tube_fp(dd,  B = B)
      estim_kde   <- tube_KDE(dd, B = B)
      estim_kdesm <- tube_KDEsm(dd)
      estim_kdeM  <- cteboot(dd$test, estim_kde$punctual, estim_kde$bunch)
#      estim_wass  <- tube_wass(dd)

      #tube2 <- baseboot(dd$test, estim_fp$punctual, estim_fp$bunch)
      #tube3 <- npheuristic(dd$test, estim_fp$punctual, estim_fp$bunch)

      uno    <- c( i, ll, 1, error_tube(dd$dobs,  estim_hist$tube))
      dos    <- c( i, ll, 2, error_tube(dd$dobs,  estim_fp$tube))
      tres   <- c( i, ll, 3, error_tube(dd$dobs, estim_kde$tube))
      cuatro <- c( i, ll, 4, error_tube(dd$dobs, estim_kdesm$tube))
      cinco  <- c( i, ll, 5, error_tube(dd$dobs, estim_kdeM))
#      seis   <- c( i, ll, 6, error_tube(dd$dobs,  estim_wass$tube))

      rbind(uno, dos, tres, cuatro, cinco) #, seis)
    }

  colnames(res) <- c("nb_iter", "density", "estimator", "coverage", "min_width",
                     "mean_width", "max_width")
  rownames(res) <- NULL
  res$density   <- factor(res$density, labels = densities)
  res$estimator <- factor(res$estimator, labels = estimators)
  return(res)
}

registerDoParallel(detectCores()) #detectCores())

#system.time(S <- simulaciones(n = 200, M = 20, B = 10))
system.time(S <- simulaciones(n = 500, M = 100, B = 200))

# save(S, file = "~/simulationcestubos-S.Rdata")

Sres <- aggregate(S[, c(1, 4:7)],
                 by = list(density = S$density, estimator = S$estimator), mean)

xtable::xtable(Sres[order(Sres$density), ], digits = 3)
plot(Sres$coverage, Sres$mean_width, pch = 19, col = as.integer(Sres$estimator))

tab1 <- 100 * xtabs(coverage ~ density + estimator, data = Sres)[, -5]
tab2 <- xtabs(mean_width ~ density + estimator, data = Sres)[, -5]

xtable::xtable(round(cbind(tab1, tab2), 2))


### Prepare the environment

# Change env timezone to UTC make xts subsetting work
Sys.setenv(TZ='UTC')

# Load the required libraries
library(stats)
library(xts)
library(vRODBC)
library(distributedR)
library(Metrics)
library(HPdclassifier)
library(HPdregression)
library(e1071)

# Start Distributed R (ignore error if already started)
tryCatch(
  {
    distributedR_start()
  },  error= function(e) {
    if (!grepl('is already running', e$message)) stop(e)
  }
)

# Connect to the Database we configured in odbc.ini
con <- odbcConnect("VerticaGasDSN")

# Function to create the SQL query to load the data.
get_query <- function(table_name) {
  # The SQL query will use Vertica's FIRST_VALUE analytic function to get the closing value for the month
  # regardless if we're working with monthly, weekly or daily values. Vertica is *very* efficient in this
  # kind of work and can saves us from loading unnecessary fine grained data into R's memory.

  # We'll detect the data column name from meta-data
  data_col <- names(sqlQuery(con, paste('select * from', table_name, 'limit 0')))[2]

  # Note that the query will run the FIRST_VALUE function on a DESC ordered by date set because we want the closing value.
  # We's run in ASC order if we were interested in the opening value.
  sub_query <- paste("select year(date) as y,  month(date) as m,",
                     "first_value(", data_col, ") over(partition by year(date), month(date) order by date desc) closing",
                     "from", table_name)

  # The data is not grouped, so we'll wrap our query to group our data by year and month. Additionaly we're going to return
  # the (year, month) information in the xts "yearmon" representation format (year + (month_number-1)/12)
  query <- paste("select y + (m-1)/12 as yearmon, max(closing) as closing from",
                 "(", sub_query, ") as subq",
                 "group by 1 order by 1")
  return(query)
}

# We'll create a load_data function to fully load a table from Vertica into Distributed R
load_data <- function(con, table_name) {

  d <- sqlQuery(con, get_query(table_name))

  # Detect zero, assing to NA, create xts object and interpolate.
  d[2][d[2]==0] <- NA
  d.x <- xts(d[2], order.by=as.yearmon(d$yearmon))
  d.x <- na.approx(d.x)
  return (d.x)
}

## Do load the data

# Data 1: Weekly U.S. Ending Stocks of Crude Oil and Petroleum Products (Thousand Barrels)
crude_stock <- load_data(con, "crude_oil_and_petroleum")

# Data 2: Weekly U.S. Ending Stocks of Total Gasoline (Thousand Barrels)
gas_stock <- load_data(con, "total_gasoline")

# Data 3: Cushing, OK Crude Oil Future Contract 1 (Dollars per Barrel)
# Contract 1 reflect "next delivery" price of crude oil. We could use Contract 3 price from EIA
# for a better model, but we'll stick to the dataset we already have.
crude_price <- load_data(con, "crude_oil_future_contract")

# Data 4: US Regular Conventional Gasoline Retail Prices (Dollars per Gallon)
gas_price <- load_data(con, "us_regular_conventional_gasoline_price")

# Data 5: U.S. Field Production of Crude Oil (Thousand Barrels)
# Note: there's a typo in table name
crude_prod <- load_data(con, "us_field_production_of_curde_oil")

# Data 6:  U.S. Total Gasoline All Sales/Deliveries by Prime Supplier
gas_sales <- load_data(con, "total_gasoline_by_prime_supplier")

# close DB handle
odbcCloseAll()

# We want to predict the gas price in 3 months. So we'll also create a data set where move the dates 3 months to the past.
idx_3m <- index(gas_price) - 3/12  # each month in yearmon objects is 1/12
gas_price_3m <- xts(coredata(gas_price), order.by = idx_3m)

# Stock levels have a seasonal component that we should remove to improve our prediction. We'll use the
# "decompose" function from "stats" package and remove the "seasonal" part from our data.
crude_stock <-(xts(as.ts(crude_stock) / decompose(as.ts(crude_stock), type = 'mult')$seasonal,
                   order.by=index(crude_stock)))

gas_stock <- (xts(as.ts(gas_stock) / decompose(as.ts(gas_stock), type = 'mult')$seasonal,
                  order.by=index(gas_stock)))

# We'll merge the data into a single xts object, filter for complete cases only and adjust their names.
# The last value is the response data. We'll also remove the objects from environment to save memory
dset <- merge(crude_price, crude_prod, crude_stock, gas_sales, gas_stock, gas_price, gas_price_3m)
dset <- dset[complete.cases(dset)]
names(dset) <- c("crude_price", "crude_prod", "crude_stock", "gas_sales", "gas_stock", "gas_price", "gas_price_3m")
rm(crude_price, crude_prod, crude_stock, gas_sales, gas_stock, gas_price, gas_price_3m)

# Now we'll split the data into training and test sets from start to "2010-Dec"
# First of all, we'll detect the earliest start date by applying the "start"
# function to our dataset ignoring NA values. Then we find the max start date
# and convert it back to "yearmon" object
dset.train <- as.data.frame(dset["/2010"])
dset.test <- as.data.frame(dset["2011/"])

# We'll create a two Random Forest models, one using all variables and another using selected variables we know from testing that gives us
# a better prediction, defined as a lower CV(RMSE). We'll use Distributed R's "hprandomForest" function available from HPdclassifier package.
# Though it's labelled as a "classifier", it can be used for regression too.

# First we'll calculate the number of executors and prepare our "actual" data to compare to predictions
# The number of executors is, ideally a bit lower the number of Distributed R instances. We can get the info from the distributedR_status
# function.

nExecutor <- sum(distributedR_status()$Inst)
actuals <- dset.test$gas_price_3m

# We'll create a "model runner" function to simply the testing using a number of different predictor variables. The function
# return a list containing $model: the created model, $predictions: the predicted values, $rmse: the RMSE "CV(RMSE)".
# The RMSE is the Root Mean Squared Error of predictions and we'll use that to judge how "predictive" our model is. The lower the
# value, the better

# Use Distributed R Random Forest function, a parallelized version of the algorithm
build_randomForest <- function (predictors) {
  time <- system.time({
    # train the model
    X = dset.train[predictors]
    Y = dset.train$gas_price_3m
    my_model <- hpdrandomForest(x = X, y = Y, nExecutor = nExecutor, importance = T)

    # test the model
    predicted_vals <- predict(my_model, dset.test[predictors])
    model_rmse <- rmse(actuals, predicted_vals)
  })
  return(list("model" = my_model, "predictions" = predicted_vals, "rmse" = model_rmse, "time" = time[3]))
}

# Use Distributed R glm function, a parallelized version of the algorithm for Generalized Linear Models
build_glm <- function(predictors) {
  time <- system.time({
    # Train the model. Since we're not supplying the number of blocks, the function will strip
    # the data across the cluster by default.
    X = as.darray(as.matrix(dset.train[predictors]))
    Y = as.darray(as.matrix(dset.train$gas_price_3m))
    my_model <- hpdglm(responses = Y, predictors = X, family = gaussian(link=identity))

    # test the model
    predicted_vals <- predict(my_model, as.matrix(dset.test[predictors]))
    model_rmse <- rmse(actuals, predicted_vals)
  })
  return(list("model" = my_model, "predictions" = predicted_vals, "rmse" = model_rmse, "time" = time[3]))
}

# Create a Support Vector Regression model for the data. We want to optimize the epsilon parameter
# so we're using a "nu-regression" type. Note that HP has not yet implemented a distributed version of
# this algorithm, so we're using the non-distributed version provided on e1071 package.
build_svm <- function(predictors) {
  time <- system.time ({
    # Train the model. Since we're not supplying the number of blocks, the function will strip
    # the data across the cluster by default.
    X = as.matrix(dset.train[predictors])
    Y = as.matrix(dset.train$gas_price_3m)

      my_model <- svm(y = Y, X, type = 'nu-regression', kernel = 'linear')

    # test the model
    predicted_vals <- predict(my_model, as.matrix(dset.test[predictors]))
    model_rmse <- rmse(actuals, predicted_vals)
  })
  return(list("model" = my_model, "predictions" = predicted_vals, "rmse" = model_rmse, "time" = time[3]))
}

# Model 0: Naïve "no-change" model. It assumes the gasoline price in 3 months will be equal to current price.
# The no-change model is usually used to control if our costlier models do improve over the simplest approach to forecasting.
r0 <- list()
r0$time <- system.time({
  r0$predictions <- dset.test$gas_price
  r0$rmse <- rmse(actuals, r0$predictions)
})[3]

# Model 1: RF model using all variables. The RF model is good for this kind of exploratory work since it can calculate
# the "importance" of each variable and let us take somewhat unimportant data out of the training set and maybe improve
# our models.
predictors_all <- names(dset.test)[names(dset.test) != "gas_price_3m"]
r1 <- build_randomForest(predictors_all)
importance <- r1$model$importance
print("Variable importance from Random Forest model with all variables:")
print(importance)

# We'll select only a few predictors we judge more relevant for our model. Then we'll create the remaining models
predictors = c("crude_price", "crude_stock", "gas_price")

# Model 2: create a RF model based exclusively on selected variables
r2 <- build_randomForest(predictors)

# Model 3: GLM Gaussian model based exclusively on selected variables
r3 <- build_glm(predictors)

# Model 4: Support Vector Regression model based on selected variables.
r4 <- build_svm(predictors)

# Let's analyse the RMSE and Execution time of all models
RMSE <- c(r0$rmse, r1$rmse, r2$rmse, r3$rmse, r4$rmse)
EXEC_TIME <- c(r0$time, r1$time, r2$time, r3$time, r4$time)
models_summary <- data.frame("RMSE" = RMSE, "Execution Time" = EXEC_TIME)
row.names(models_summary) <- c("Naive", "Random Forest (all vars)", "Random Forest (key vars)", "GLM Gaussian", "SVR")
print("")
print("Comparison of models")
print(models_summary)

# Our models improve slightly over the Naive approach - ~0.35 RMSE against ~0.37. We're picking the Ramdom Forest
# model to output our results.

test.output <- cbind(dset.test[predictors], prediction_gas_price_3m=r2$predictions, actual_gas_price_3m=actuals)
write.csv(test.output, file="output.csv")
print("Output written to 'output.csv' file in the current directory.")


sample0to19 <- function() sample(0L:19L, 1,replace=TRUE)
repeat
{
  result1 <- sample0to19()
  if (result1 == 10L)
  {
    print(result1)
    break
  }
  result2 <- sample0to19()
  cat(result1, result2, "\n")
}


library(ggplot2)
library(dplyr)
library(plyr)

download.file('https://d396qusza40orc.cloudfront.net/repdata%2Fdata%2FStormData.csv.bz2','storm.csv.bz2',method = "auto", quiet=FALSE)

#unzip("storm.zip")

my_data <- read.csv("storm.csv.bz2")
#str(my_data)
#dim(my_data)

vars <- c( "EVTYPE", "FATALITIES", "INJURIES", "PROPDMG", "PROPDMGEXP", "CROPDMG", "CROPDMGEXP")
data <- my_data[, vars]

sum(is.na(data$FATALITIES))
sum(is.na(data$INJURIES))
sum(is.na(data$PROPDMG))
sum(is.na(data$CROPDMG))
sum(is.na(data$PROPDMGEXP))
sum(is.na(data$CROPDMGEXP))

data$EVENT <- "OTHER"
data$EVENT[grep("HAIL", data$EVTYPE, ignore.case = TRUE)] <- "HAIL"
data$EVENT[grep("HEAT", data$EVTYPE, ignore.case = TRUE)] <- "HEAT"
data$EVENT[grep("FLOOD", data$EVTYPE, ignore.case = TRUE)] <- "FLOOD"
data$EVENT[grep("WIND", data$EVTYPE, ignore.case = TRUE)] <- "WIND"
data$EVENT[grep("STORM", data$EVTYPE, ignore.case = TRUE)] <- "STORM"
data$EVENT[grep("SNOW", data$EVTYPE, ignore.case = TRUE)] <- "SNOW"
data$EVENT[grep("TORNADO", data$EVTYPE, ignore.case = TRUE)] <- "TORNADO"
data$EVENT[grep("WINTER", data$EVTYPE, ignore.case = TRUE)] <- "WINTER"
data$EVENT[grep("RAIN", data$EVTYPE, ignore.case = TRUE)] <- "RAIN"
#sort(table(data$EVENT), decreasing = TRUE)

data$PROPDMGEXP <- as.character(data$PROPDMGEXP)

data$PROPDMGEXP[is.na(data$PROPDMGEXP)] <- 0

data$PROPDMGEXP[!grepl("K|M|B", data$PROPDMGEXP, ignore.case = TRUE)] <- 0

data$PROPDMGEXP[grep("K", data$PROPDMGEXP, ignore.case = TRUE)] <- "3"
data$PROPDMGEXP[grep("M", data$PROPDMGEXP, ignore.case = TRUE)] <- "6"
data$PROPDMGEXP[grep("B", data$PROPDMGEXP, ignore.case = TRUE)] <- "9"
data$PROPDMGEXP <- as.numeric(as.character(data$PROPDMGEXP))
data$property.damage <- data$PROPDMG * 10^data$PROPDMGEXP

data$CROPDMGEXP <- as.character(data$CROPDMGEXP)
data$CROPDMGEXP[is.na(data$CROPDMGEXP)] <- 0
data$CROPDMGEXP[!grepl("K|M|B", data$CROPDMGEXP, ignore.case = TRUE)] <- 0
data$CROPDMGEXP[grep("K", data$CROPDMGEXP, ignore.case = TRUE)] <- "3"
data$CROPDMGEXP[grep("M", data$CROPDMGEXP, ignore.case = TRUE)] <- "6"
data$CROPDMGEXP[grep("B", data$CROPDMGEXP, ignore.case = TRUE)] <- "9"
data$CROPDMGEXP <- as.numeric(as.character(data$CROPDMGEXP))
data$crop.damage <- data$CROPDMG * 10^data$CROPDMGEXP

Death <- aggregate(data$FATALITIES, by = list(data$EVENT), FUN = sum)
colnames(Death) <- c("EVENT", "Death")
Death <- Death[order(Death$Death, decreasing = TRUE),][1:10,]

ggplot() + geom_bar(data = Death, aes(x = EVENT,
    y = Death, fill = interaction(Death, EVENT)), stat = "identity",
    show.legend = F) + theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
    xlab("Event") + ylab("Death") + ggtitle("Top 10 weather events causing Fatalities")

INJURIES <- aggregate(data$INJURIES, by = list(data$EVENT), FUN = sum)
colnames(INJURIES) <- c("EVENT", "INJURIES")
INJURIES <- INJURIES[order(INJURIES$INJURIES, decreasing = TRUE),][1:10,]

ggplot() + geom_bar(data = INJURIES, aes(x = EVENT, y = INJURIES, fill = interaction(INJURIES, EVENT)), stat = "identity",
                    show.legend = F) + theme(axis.text.x = element_text(angle = 45, hjust = 1)) + xlab("Event") +
ylab("Injuries") + ggtitle("Top 10 weather events causing Injuries")

Property <- aggregate(data$property.damage, by = list(data$EVENT), FUN = sum)
colnames(Property) <- c("EVENT", "Property")
Property <- Property[order(Property$Property, decreasing = TRUE),][1:10,]

ggplot() + geom_bar(data = Property, aes(x = EVENT, y = Property, fill = interaction(Property, EVENT)), stat = "identity",
                    show.legend = F) + theme(axis.text.x = element_text(angle = 45, hjust = 1)) + xlab("Event") +
ylab("Property Demage") + ggtitle("Top 10 weather events causing Property Damages")

Crop <- aggregate(data$crop.damage, by = list(data$EVTYPE), FUN = sum)
colnames(Crop) <- c("EVENT", "Crop")
Crop <- Crop[order(Crop$Crop, decreasing = TRUE),][1:10,]

ggplot() + geom_bar(data = Crop, aes(x = EVENT, y = Crop, fill = interaction(Crop, EVENT)), stat = "identity",
                    show.legend = F) + theme(axis.text.x = element_text(angle = 45, hjust = 1)) + xlab("Event") +
ylab("Crop Damage") + ggtitle("Top 10 weather events causing Crop Damages")


# analysis file
library(dplyr)
library(ggplot2)
library(stringr)
library(tidyr)
library(leaflet)
library(plotly)
library(knitr)
library(styler)
library(lintr)

shootings_df <- read.csv("data/shootings-2018.csv", stringsAsFactors = F)

# Summary Information

# Number of shootings
shootings_count <- nrow(shootings_df)

# Lives lost
lives_lost <- shootings_df %>%
  select(num_killed) %>%
  sum()

# City impacted most
most_impacted_city <- shootings_df %>%
  group_by(city) %>%
  summarize(shooting_count = n()) %>%
  arrange(-shooting_count) %>%
  filter(shooting_count == max(shooting_count)) %>%
  pull(city)

most_impacted_city_count <- shootings_df %>%
  group_by(city) %>%
  summarize(shooting_count = n()) %>%
  arrange(-shooting_count) %>%
  filter(shooting_count == max(shooting_count)) %>%
  pull(shooting_count)

# First insight
most_impacted_state <- shootings_df %>%
  group_by(state) %>%
  summarize(count = n()) %>%
  arrange(-count) %>%
  filter(count == max(count)) %>%
  pull(state) %>%
  paste(collapse = " and ")

most_impacted_state_count <- shootings_df %>%
  group_by(state) %>%
  summarize(count = n()) %>%
  arrange(-count) %>%
  filter(count == max(count)) %>%
  select(count) %>%
  pull(1) %>%
  head(1)

# Second insight
get_month <- shootings_df %>%
  select(date) %>%
  pull(date) %>%
  as.Date("%B %d, %Y") %>%
  format("%B")

most_impacted_month_count <- shootings_df %>%
  mutate(month = get_month) %>%
  group_by(month) %>%
  summarize(shooting_count = n()) %>%
  arrange(-shooting_count) %>%
  filter(shooting_count == max(shooting_count, na.rm = T)) %>%
  pull(shooting_count)

most_impacted_month <- shootings_df %>%
  mutate(month = get_month) %>%
  group_by(month) %>%
  summarize(shooting_count = n()) %>%
  arrange(-shooting_count) %>%
  filter(shooting_count == max(shooting_count, na.rm = T)) %>%
  pull(month)

# Summary Table

aggregate_table <- shootings_df %>%
  mutate(month = get_month) %>%
  group_by(month) %>%
  summarize(
    Total_Shootings = n(),
    Total_Killed = sum(num_killed, na.rm = T),
    Total_Injured = sum(num_injured, na.rm = T),
    Avg_Lat = mean(lat, na.rm = T),
    Avg_Lng = mean(long, na.rm = T)
  ) %>%
  arrange(-Total_Shootings)

aggregate_info <- kable(aggregate_table,
  col.names = c(
    "Month", "Total Shootings", "Total Killed",
    "Total Injured", "Average Latitude", "Average Longitude"
  ),
  digits = 2,
  caption = "Aggregate Table based on Months"
)

# Particular Incident
particular_incident <- shootings_df %>%
  filter(num_killed == max(num_killed))

incident_date <- particular_incident %>%
  pull(date)

incident_state <- particular_incident %>%
  pull(state)

incident_city <- particular_incident %>%
  pull(city)

incident_address <- particular_incident %>%
  pull(address)

incident_injured <- particular_incident %>%
  pull(num_injured)

incident_killed <- particular_incident %>%
  pull(num_killed)

# Interactive Map
description_table <- shootings_df %>%
  mutate(description = paste0(
    city, ", ", state, ": ", "
",
    "Date: ", date, "
",
    "Address: ", address, "
",
    "Total Injured: ", num_injured, "
",
    "Total Killed: ", num_killed
  ))

interactive_map <- leaflet(data = description_table) %>%
  addProviderTiles("CartoDB.Positron") %>%
  setView(lng = -95, lat = 37.0902, zoom = 3.7) %>%
  addCircles(
    lat = ~lat,
    lng = ~long,
    popup = ~description,
    radius = ~ (num_killed * 5000),
    stroke = F,
  )

interactive_map

# Plot
# Which states had the most shootings (encode months)?
# Based on the the top 3 states with the most shootings
# where total deaths were at least one, which month had the most deaths?
plot_table <- shootings_df %>%
  mutate(month = get_month) %>%
  group_by(month, state) %>%
  summarize(
    Total_Shootings = n(),
    Total_Killed = sum(num_killed, na.rm = T),
    Total_Injured = sum(num_injured, na.rm = T)
  ) %>%
  filter(state == "California" | state == "Illinois" | state == "Florida") %>%
  filter(Total_Killed > 0)

top_3 <- shootings_df %>%
  mutate(month = get_month) %>%
  group_by(state) %>%
  summarise(Total_Shootings = n()) %>%
  arrange(-Total_Shootings) %>%
  head(3) %>%
  pull(state)

deadliest_months <- ggplot(
  data = plot_table,
  aes(Month = month, Killed = Total_Killed)
) +
  geom_col(mapping = aes(
    x = reorder(month, Total_Killed),
    y = Total_Killed,
    fill = state
  )) +
  coord_flip() +
  scale_color_brewer(palette = "Set3") +
  labs(
    x = "Months (Deaths >= 1)",
    y = "Total Deaths",
    title = paste0(
      "Based on the the top 3 states with the most shootings, ",
      "which month had the most deaths?"
    )
  )

plotly_graph <- ggplotly(deadliest_months,
  tooltip = c("Month", "Killed", "state")
)
plotly_graph


#' myFun
#'
# Description
#' This function sums up two numbers.
#'
#' @details
#' \code{data} contains the transaction data. The data set must contain a
#'             column labeled "Customer" that allows unique customer identification
#'             and a column labeled "TransDate", indicating the purchase date.
#'             The column "PurchAmount" specifies the total spending per purchase.
#'
# Arguments
#' @param arg1 A number
#' @param arg2 A number with default value
#'
# Returned values
#' @return The sum of \code{arg1} and \code{arg2}
#'
# Examples
#' @examples
#' myFun(1, 1)
#' myFun(10, 1)
#'
#' @export

myFun<- function(arg1, arg2=1){

  res <- arg1+arg2
  return(res)

}


#' Read Sample Lines of Text File
#'
#' The function will read approximately p*nlines lines of a flat text
#' file. So if \code{p=.1}, then we will get roughly (probably not exactly)
#' 10% of the data.  This is the analogue of the base R function
#' \code{readLines()}.
#'
#' @details
#' This function scans over the test of the input file and at each step, randomly
#' chooses whether or not to include the current line into a downsampled file.
#' Each selected line is placed in a temporary file, before being read into R
#' via \code{readLines()}.  Additional arguments to this function (those other
#' than \code{file}, \code{p}, and \code{verbose}) are passed to \code{readLines()},
#' and so if their behavior is unclear, you should examine the \code{readLines()}
#' help file.
#'
#' If \code{verbose=TRUE}, then something like:
#'
#' \code{Read 12207 lines (0.001\%) of 12174948 line file.}
#'
#' will be printed to the terminal.  This counts the header (if there is one)
#' as one of the lines read and as one of the lines possible.
#'
#' @param file
#' Location of the file (as a string) to be subsampled.
#' @param n
#' As in \code{readLines()}.
#' @param p
#' Proportion to retain; should be a numeric value between 0 and 1.
#' @param nskip
#' Number of lines to skip.
#' @param nmax
#' Max number of lines to read.  If nmax==0, then there is no read cap.
#' @param verbose
#' Logical; indicates whether or not linecounts of the input file and the number
#' of lines sampled should be printed.
#' @param ...
#' Additional arguments passed to \code{readLines()}.
#'
#' @return
#' A character vector, as with \code{readLines()}.
#'
#' @examples
#' library(filesampler)
#' file = system.file("rawdata/small.csv", package="filesampler")
#' sample_lines(file, p=.05)
#'
#' @export
sample_lines = function(file, n=-1L, p=.1, nskip=0, nmax=0, verbose=FALSE, ...)
{
  check.is.int(n)

  if (p == 0)
    return(character(0))

  if (n > 0 && n < nskip)
    return(character(0))

  outfile = tempfile()
  file_sample_prop(verbose=verbose, header=FALSE, nskip=nskip, nmax=nmax, p=p, infile=file, outfile=outfile)

  data = readLines(outfile, n=n, ...)
  unlink(outfile)
  data
}


# Code for making distribution inputs for nodiv analysis with hummingbird range maps
# for nodiv, need A) site x species matrix and B) geographic extent shape file

# load libraries
library(raster)
library(maptools)
library(reshape2)

# set working directory
# MLwd = "D:/MarisaLimfiles/Make_sitexsp_matrix/for sitexsp"
MLwd = "C:/Users/mcwlim/Desktop/StonyBrook/GrahamLab/Dissertation idea materials/THESIS PROJECTS/Div-Biogeo project/"
setwd(MLwd)

# ---------------- 1. load bioclim layer ----------------
# Note: just using it to set the correct grid cell numbers (doesn't matter what the actual values are)
#myvars <- "bio1.bil"
myvars <- "wc10/bio1.bil"
myvars <- stack(myvars)
plot(myvars)
myvars

myvars2 <- aggregate(myvars, fact=3) #fact=6 makes the res=c(1,1); fact=3 makes the res=c(0.5,0.5)
myvars2
plot(myvars2)

# ---------------- 2. crop extent to just N. America and S. America ----------------
myex<-extent(c(-165, -30, -60, 75))
myvarscrop <- crop(myvars2, myex)
class(myvarscrop) # this is a rasterlayer
res(myvarscrop)
myvarscrop
plot(myvarscrop)

# ---------------- 3. make presence/absence 1/0 matrix ----------------
siteXsp <- function(){
  #lists all NatureServe files with .shp extension name (n=338 files)
  #NSfolder = "Trochilidae"
  NSfolder = "Trochilidae2014/Trochilidae"
  shpfilenames <- list.files(paste(NSfolder,sep="/"),pattern=".shp",full.name=T,recursive=T)

  # use this statement when testing subset of the data, otherwise comment out
  # shpfilenames <- shpfilenames[1:10]

  # this gets the sitexsp matrix of 0s and 1s
  rasters <- list()
  d <- data.frame("Species"="species")
  for (i in 1:length(shpfilenames)){
    speciesrange <- readShapePoly(shpfilenames[i])
    rasters[[i]] <- rasterize(speciesrange, myvarscrop, field=1, background=0)
    keepname <- data.frame(Species=speciesrange$SCINAME[1])
    d <- rbind(d, keepname)
    print(i)
  }
  s <- stack(rasters)
  x <- as.data.frame(s)
  d <- d[-1,]
  drename <- strsplit(x=as.character(d), split = " ")
  drename2 <- sapply(drename, function(x){
    paste(x[[1]], x[[2]], sep="_")
  })
  colnames(x) <- drename2

  # #   use these to check that the ranges are properly mapping onto the extent
  #   plot(s) # note: this plots the map of the species on the overall extent
  #   plot(x) # note: this is really slow, it just shows that there are 0s and 1s

  # write.csv(x, "hbird_sitexsp_matrix.csv")

  # version without cells that are presence only (e.g., ocean)
  m <- as.matrix(x, rownames.force=T) #use rownames.force=T to keep the cellIDs
  m1 <- m[apply(m, MARGIN=1, FUN=sum)>0, ] #MARGIN=1 means rows

  # write.csv(m1, "hbird_sitexspmat_sub.csv")
  write.csv(m1, "C:/Users/mcwlim/Dropbox/resultsfromSarahcomputer/nodesigfiles/hbird_sitexspmat_sub.csv")

}
siteXsp()

# mysitexspmat <- read.csv("hbird_sitexsp_matrix.csv") # really big file!! will take some time to load
# mysitexspmat <- read.csv("hbird_sitexspmat_sub.csv")
mysitexspmat <- read.csv("C:/Users/mcwlim/Dropbox/resultsfromSarahcomputer/nodesigfiles/hbird_sitexspmat_sub.csv")
head(mysitexspmat)
colnames(mysitexspmat)[1] <- "cellIDs"
dim(mysitexspmat)
mysitexspmat[1:5,1:5]

#check that there are presences!
length(mysitexspmat[mysitexspmat$Urosticte_ruficrissa == "1", 339])
length(mysitexspmat[mysitexspmat$Metallura_tyrianthina == "1", 251])
length(mysitexspmat[mysitexspmat$Selasphorus_rufus == "1", 312])

head(mysitexspmat[mysitexspmat$Loddigesia_mirabilis == "1",230]) #range too small? has 0 presences...

# ---------------- 4. Get cell coords ----------------
cell_coords <- function(){
  # get cell IDs
  cellcoords <- xyFromCell(myvarscrop, cell=1:ncell(myvarscrop))
  # Then, use the xy coords where species is present to get the cell position IDs in the var raster
  cellIDs <- cellFromXY(myvarscrop, cellcoords)

  # this gets the cellIDs and XY coordinates
  mycoords <- data.frame("cellIDs"=cellIDs, "X"=cellcoords[,1], "Y"=cellcoords[,2])

  # make it match the cellIDs in the sitexsp matrix
  mycells <- data.frame(cellIDs=mysitexspmat$cellIDs)
  # mycells <- data.frame(cellIDs=mysitexspmat2$cellIDs)
  dim(mycells)
  dim(mycoords)
  mycoords2 <- merge(mycoords, mycells, by.y="cellIDs")
  dim(mycoords2)
  # head(mycoords2)

  # round coords to integer
  mycoords2_rounded <- data.frame(cellIDs=mycoords2$cellIDs, X=round(mycoords2$X), Y=round(mycoords2$Y))

  # write.csv(mycoords, "cell_coords.csv")
  # write.csv(mycoords2, "cell_coords2.csv")
  # write.csv(mycoords2_rounded, "cell_coords_rounded.csv")
  write.csv(mycoords2_rounded, "C:/Users/mcwlim/Dropbox/resultsfromSarahcomputer/nodesigfiles/cell_coords_rounded.csv")
}
cell_coords()

#mycellcoords <- read.csv("cell_coords.csv")
#head(mycellcoords)

#mycoords_rounded <- read.csv("cell_coords_rounded.csv")
mycoords_rounded <- read.csv("C:/Users/mcwlim/Dropbox/resultsfromSarahcomputer/nodesigfiles/cell_coords_rounded.csv")
head(mycoords_rounded)

# ---------------- 5. Make shape file of extent ----------------
# writeRaster(myvarscrop, "myvarscrop.grd", overwrite=TRUE)
writeRaster(myvarscrop, "C:/Users/mcwlim/Dropbox/resultsfromSarahcomputer/nodesigfiles/myvarscrop.grd", overwrite=TRUE)