log_prefix <- "shiny_module_estructura_nodos.r"
# shiny_module_estructura_nodos
# bajar datos
# listado en crudo
# densidad de grado
# histogramas todas vars
# densidades todas vars
estructura_nodos_ui <- function(id, # escencial para poder armar el componente
                         label = "Estructura de Nodos") {

    ns <- NS(id) # namespace para como se va a llamar

    # recordar todos los ids dben ponerse como ns('id_de_cosa')
    tagList( # dentro de taglist puedo escribir libremente como lo hice antes
        # - metricas de cada subgrafo

        tabsetPanel(type = "tabs",
                    id=ns("estructura_nodos_tabs"),
                    # bajar datos
                    # listado en crudo

# UI - tab DATOS ----------------------------------------------------------

                    tabPanel("Datos",div(
                        br(),
                        downloadButton (outputId = ns("est_nodos_download"),
                                        label = "Bajar est. nodos"),
                        br(),
                        br(),
                        DT::dataTableOutput(ns('est_nodos_table'))
                    )),

# UI - Distribución de grado --------------------------------------------------

                    # densidad de grado
                    tabPanel("Distribución de grado",div(
                        plotlyOutput(ns('est_nodos_densidad'))
                    )),

                    # densidad de grado
                    tabPanel("Distribución de Grado ( log / log )",div(
                        plotlyOutput(ns('est_nodos_densidad_log_log'))
                    )),

# UI - histogramas variables ----------------------------------------------

                    # histogramas todas vars
                    tabPanel("Histograma variables",div(
                        pickerInput(
                            inputId = ns("est_nodos_histo_vars"),
                            label = "Variables",
                            choices = estructura_red_nodos_vars_compara_simu_list,
                            options = list(
                                placeholder = 'Seleccionar Variable',
                                onInitialize = I('function() { this.setValue(""); }'),
                                'actions-box' = TRUE,
                                size = 10,
                                'selected-text-format' = "count > 3",
                                'deselect-all-text' = "Ninguno",
                                'select-all-text' = "Todos",
                                'none-selected-text' = "Sin Selección",
                                'count-selected-text' = "{0} seleccionados."
                            ),
                            multiple = FALSE
                        ),
                        br(),
                        plotlyOutput(ns('est_nodos_histogramas_vars'))
                    )),

# UI - densidades variables -----------------------------------------------
                    # densidades todas vars
                    tabPanel("Densidades variables",div(
                        pickerInput(
                            inputId = ns("est_nodos_densidades_vars"),
                            label = "Variables",
                            choices = estructura_red_nodos_vars_compara_simu_list,
                            options = list(
                                placeholder = 'Seleccionar Variable',
                                onInitialize = I('function() { this.setValue(""); }'),
                                'actions-box' = TRUE,
                                size = 10,
                                'selected-text-format' = "count > 3",
                                'deselect-all-text' = "Ninguno",
                                'select-all-text' = "Todos",
                                'none-selected-text' = "Sin Selección",
                                'count-selected-text' = "{0} seleccionados."
                            ),
                            multiple = FALSE
                        ),
                        br(),
                        plotOutput(ns('est_nodos_densidades_vars'))
                    ))
        )# fin tabset panel

    ) # fin taglist del componente
}

estructura_nodos_server <- function(input, output, session, # parametros de shiny
                             current_grafo#, # grafo actual
) {

# SERVER: estructura nodos - DATOS ------------------------------------------------

    est_nodos_list_reactive <- reactive({
        grafo_reactive_tmp <- current_grafo

        # estructura_red_df <- metricas_nodos_grafo(grafo_reactive_tmp) %>%
        #
        #     rename('Autor' = autor,
        #            'Grado' = degree,
        #            'Betweeness' = betweeness,
        #            'Eigen Centrality' = eigen_centrality,
        #            'Closeness' = closeness,
        #            'Page Rank' = page_rank,
        #            '# Triangulos' = count_triangles,
        #            'Fuerza Colaboración' = fuerza_colaboracion)
        estructura_red_df <- metricas_nodos_grafo(grafo_reactive_tmp)
        # print(igraph::vcount(current_grafo))

        estructura_red_df
    })

    estructura_red_grafo_dt <- reactive({

        nodos_reactive_renamed <- est_nodos_list_reactive() %>%
                rename('Autor' = autor,
                       'Grado' = degree,
                       'Intermediación' = betweeness,
                       'Centrarlidad Autovector' = eigen_centrality,
                       'Cercanía' = closeness,
                       'Page Rank' = page_rank,
                       '# Triángulos' = count_triangles,
                       'Fuerza Colaboración' = fuerza_colaboracion)

        dt_return <- DT::datatable(options = list(language = list(url = '//cdn.datatables.net/plug-ins/1.10.11/i18n/Spanish.json')),
                                   nodos_reactive_renamed,
                                   escape = FALSE,
                                   rownames = FALSE,
                                   selection = 'none') %>%
            formatRound('Intermediación',4) %>%
            formatRound('Centrarlidad Autovector',4) %>%
            formatRound('Cercanía',7) %>%
            formatRound('Page Rank',4) %>%
            formatRound('Fuerza Colaboración',4)

        dt_return
    })

    output$est_nodos_table <- DT::renderDataTable({
        # ver inconexos, ver, top 10 , ver last 10 o last N , sin contar inconexos.
        # todo eso sale de la tabla.
        # hay que agregar tooltips de inteprretacion.
        estructura_red_grafo_dt()
    })

    # exportar nodos
    output$est_nodos_download <- downloadHandler(
        filename = paste('est_nodos_data-', Sys.Date(), '.csv', sep=''), content = function(file) {
            write.csv(est_nodos_list_reactive(), file,row.names = FALSE)
        })

# SERVER: estructura nodos - Distribución de Grado -------------------------------------

    est_nodos_dist_grados_reactive <- reactive({
        degree_distrib <- degree_distribution(current_grafo) %>%
            as_tibble() %>%
            rename(degree_distribution=value) %>%
            tibble::rownames_to_column("grado") %>%
            mutate(grado=as.integer(grado)) %>%
            arrange(grado)
    })

    # est_nodos_densidad
    output$est_nodos_densidad <- renderPlotly({
        pl <- est_nodos_dist_grados_reactive() %>%
                ggplot(aes(x=grado,y=degree_distribution)) +
                geom_col() +
                labs(title="Distribución de Grado",
                     y="probabilidad de grado")+
                theme_light()
        # pl
        ggplotly(pl)
    })

    # est_nodos_densidad_log_log
    output$est_nodos_densidad_log_log <- renderPlotly({
        pl <- est_nodos_dist_grados_reactive() %>%
                ggplot(aes(x=grado,y=degree_distribution+1)) +
                geom_point() +
                scale_x_log10()+
                scale_y_log10()+
                labs(title="Distribución de Grado ( log / log )",
                     subtitle="distribución+1 para arreglo de infinito",
                     x="grado",
                     y="probabilidad de grado")+
                theme_light()
        # pl
        ggplotly(pl)
    })

# SERVER: estructura nodos - histogramas vars -----------------------------------

    est_nodos_histo_vars_opts_reactive <- reactive({
        # no toma globales, hay que pasarlo por parametro
        ret <- estructura_red_nodos_vars_compara_simu_list # es global
        # ret <- listado_variables_seleccion
        ret
    })

    observe({
        # req(input$anio)
        # input$temporal_estructura_refrescar_boton
        updateSelectizeInput(session, "est_nodos_histo_vars",
                             choices = est_nodos_histo_vars_opts_reactive())
    })

    est_nodos_list_long_reactive <- reactive({
        metricas_nodos_long <- est_nodos_list_reactive() %>%
            tidyr::gather(metrica,valor,-autor) %>%
            as_tibble()
        metricas_nodos_long
    })

    # est_nodos_histogramas_vars

    output$est_nodos_histogramas_vars <- renderPlotly({

        # metrica_seleccionada <- "degree"
        # metrica_seleccionada <- "fuerza_colaboracion"
        # metrica_seleccionada <- "closeness"
        # metrica_seleccionada <- "count_triangles"
        metrica_seleccionada <- input$est_nodos_histo_vars

        pl <- est_nodos_list_long_reactive() %>%
            filter(metrica==metrica_seleccionada) %>%
            ggplot(aes(valor)) +
            geom_histogram() +
            labs(title=paste0("Histograma de ",metrica_seleccionada),
                 #x= metrica_seleccionada,
                 y= "cantidad nodos")+
            theme_light()
        # pl
        ggplotly(pl)
    })
# SERVER: estructura nodos - densidades vars ------------------------------------

    observe({
        # req(input$anio)
        # input$temporal_estructura_refrescar_boton
        updateSelectizeInput(session, "est_nodos_densidades_vars",
                             choices = est_nodos_histo_vars_opts_reactive())
    })

    # est_nodos_densidades_vars
    output$est_nodos_densidades_vars <- renderPlot({

        # metrica_seleccionada <- "degree"
        # metrica_seleccionada <- "fuerza_colaboracion"
        # metrica_seleccionada <- "closeness"
        # metrica_seleccionada <- "count_triangles"
        metrica_seleccionada <- input$est_nodos_densidades_vars

        pl <-  est_nodos_list_long_reactive() %>%
            filter(metrica==metrica_seleccionada) %>%
            ggplot(aes(valor)) +
            geom_density_line() +
            labs(title=paste0("Densidad de ",metrica_seleccionada),
                # x= metrica_seleccionada,
                 y= "cantidad nodos")+
            theme_light()
        pl
        # ggplotly(pl)
    })
}
flog.info(paste0(log_prefix,"  - LOADED"))


#train_data <-read.csv('C:\\Users\\fu\\Documents\\kaggle\\titanic\\train.csv')
#head(train_data)
#titanic sink

#get train data
train_data<-read.csv('C:\\Users\\fu\\Documents\\kaggle\\titanic\\train.csv')

#pick vip attributes
train_data.pick <- train_data
train_data.pick
train_data.pick$PassengerId = NULL
train_data.pick$Name = NULL
train_data.pick$Embarked = NULL
train_data.pick$Ticket = NULL
train_data.pick$Fare = NULL
names(train_data.pick)

##clean data
summary(train_data.pick$Survived) #1=yes 0=no
summary(train_data.pick$Pclass)

#female -> 1, male -> 2
summary(train_data.pick$Sex)
v = NULL
for ( i in 1:nrow(train_data.pick)) {
  #print(train_data.pick$Sex[i])
  if(train_data.pick$Sex[i]=='male'){
    v <- c(v,1)
  }
  else{
    v <- c(v,2)
  }
}
train_data.pick['nSex'] = v
train_data.pick$Sex =NULL
names(train_data.pick)

summary(train_data.pick$nSex)
summary(train_data.pick$Age)
#na
t_mean<-mean(na.omit(train_data.pick$Age) )
for (i in 1:nrow(train_data.pick)){
  #print(is.na(train_data.pick$Age[i]))
  #print(i)
  if(is.na(train_data.pick$Age[i])==TRUE){
    train_data.pick$Age[i]<-t_mean
  }
}
summary(train_data.pick$Age)
summary(train_data.pick$SibSp)
summary(train_data.pick$Parch)

#Cabin to number
summary(train_data.pick$Cabin)
nCabin <- NULL
for (i in 1:nrow(train_data.pick)){
  t<-as.character(train_data.pick$Cabin[i])
  contain_alpha <- grepl("[[:alpha:]]",t)
  if ( contain_alpha ){
    alpha_t <- gsub("\\d+|NA", "", t)
    code_t <- utf8ToInt(substr(gsub("\\d+|NA", "", t),1,1))-64
  }else {
    code_t <- 0
  }
  nCabin <- c(nCabin,code_t)
}
train_data.pick["nCabin"] <-nCabin
train_data.pick$Cabin<-NULL

#SUPPORT VECTOR MACHINE#
library(e1071)#svm

#learning from training
svmmodel<-svm(as.factor(Survived)~., data=train_data.pick, method="C-classification", kernel="radial",cross=5, probability=TRUE)

#get test data
test_data<-read.csv('C:\\NotBackedUp\\fu\\temp\\Titanic Sink\\data\\test.csv')

#pick vip attributes
test_data.pick <- test_data
test_data.pick$PassengerId = NULL
test_data.pick$Name = NULL
test_data.pick$Embarked = NULL
test_data.pick$Ticket = NULL
test_data.pick$Fare = NULL
names(test_data.pick)

##clean data
summary(test_data.pick$Survived)
summary(test_data.pick$Pclass)

#female -> 1, male -> 2
summary(test_data.pick$Sex)
v = NULL
for ( i in 1:nrow(test_data.pick)) {
  #print(train_data.pick$Sex[i])
  if(test_data.pick$Sex[i]=='male'){
    v <- c(v,1)
  }
  else{
    v <- c(v,2)
  }
}
test_data.pick['nSex'] = v
test_data.pick$Sex =NULL
names(test_data.pick)

summary(test_data.pick$nSex)
summary(test_data.pick$Age)
#na
t_mean<-mean(na.omit(test_data.pick$Age) )
for (i in 1:nrow(test_data.pick)){
  if(is.na(test_data.pick$Age[i])==TRUE){
    test_data.pick$Age[i]<-t_mean
  }
}
summary(test_data.pick$Age)
summary(test_data.pick$SibSp)
summary(test_data.pick$Parch)

#Cabin to number
summary(test_data.pick$Cabin)
nCabin <- NULL
for (i in 1:nrow(test_data.pick)){
  t<-as.character(test_data.pick$Cabin[i])
  contain_alpha <- grepl("[[:alpha:]]",t)
  if ( contain_alpha ){
    alpha_t <- gsub("\\d+|NA", "", t)
    code_t <- utf8ToInt(substr(gsub("\\d+|NA", "", t),1,1))-64
  }else {
    code_t <- 0
  }
  nCabin <- c(nCabin,code_t)
}
test_data.pick["nCabin"] <-nCabin
test_data.pick$Cabin<-NULL
test_data.pick$nCabin

#predicting the test data
svmmodel.predict<-predict(svmmodel,test_data.pick,decision.values=TRUE)
svmmodel.probs<-attr(svmmodel.predict,"decision.values")
svmmodel.class<-svmmodel.predict[1:nrow(test_data.pick)]

svmmodel.truth
svmmodel.class

#analyzing result
truth<-read.csv('C:\\NotBackedUp\\fu\\temp\\Titanic Sink\\data\\gender_submission.csv')
svmmodel.truth<-truth$Survived

library(SDMTools)#confusion
svmmodel.confusion<-confusion.matrix(svmmodel.truth,svmmodel.class)
svmmodel.accuracy<-prop.correct(svmmodel.confusion) #/t
svmmodel.recall <- #tf/t

  svmmodel.confusion
#roc analysis for test data
svmmodel.prediction<-prediction(svmmodel.probs,svmmodel.labels)
svmmodel.performance<-performance(svmmodel.prediction,"tpr","fpr")
svmmodel.auc<-performance(svmmodel.prediction,"auc")@y.values[[1]]

final_result<-test_data[1:2]
final_result['Survived']<-svmmodel.class
final_result$Pclass<-NULL

write.csv(final_result,quote = FALSE,
          "C:\\NotBackedUp\\fu\\temp\\Titanic Sink\\data\\my_submission.csv",
          row.names=FALSE
)


x <- 1
for(i in 1:10)
{
   x <- look.and.say(x)
   print(x)
}


# Demo 3: T tests and ANOVA
# Example script for handout
# Heini Saarimäki 2.10.2014

# -----

# 1. Data preparations and descriptive statistics

# ---

# 1.2 Load and prepare your data

setwd('Z:/Desktop/Demo3')

deprivation <- read.csv('http://becs.aalto.fi/~heikkih3/deprivation.csv')

# Look at the data:

head(deprivation)		# 10 variables
dim(deprivation)		# 47 rows (i.e. 47 participants, one per row)

summary(deprivation)

# categorical variables ID, age and education are not yet coded as factors
# --> change ID, age and education to factors

deprivation$ID <- factor(deprivation$ID)
deprivation$age <- factor(deprivation$age)
deprivation$education <- factor(deprivation$education)

summary(deprivation)	# looks allright now

# look for missing values:

summary(deprivation)
boxplot(deprivation[5:7])	# take boxplot for digit symbol scores at all time points
boxplot(deprivation[8:10])	# similar boxplot for benton error scores

# no very extreme outliers (at least no wrongly coded missing values)
# so no missing values in the data, no need to correct these

# when you're happy with how the data looks like, use attach:

attach(deprivation)

# ---

# 1.3 Describe your data

# check frequencies for each group in all categorical variables:

summary(deprivation[2:4])

# you can also check for contingency tables:

table(age,education)
table(age, ht_group)
table(education, ht_group)

# table of descriptive statistics for continuous variables:

library('psych')			# load package 'psych' to get describe function
describe(deprivation[5:10])	# take descriptive statistics

# if you want to save the descriptive stats table for further use:

deprivation.descriptives <- describe(deprivation[5:10])
write.csv(deprivation.descriptives, "deprivation_descriptives.csv")

# plot continuous variables:

layout(matrix(c(1,2,3,4,5,6),3,2))		# create 6-cell display first
boxplot(digitsymbol_1, ylim=c(0,80), main="Digit symbol score, time 1")
boxplot(digitsymbol_2, ylim=c(0,80), main="Digit symbol score, time 2")
boxplot(digitsymbol_3, ylim=c(0,80), main="Digit symbol score, time 3")
boxplot(bentonerror_1, ylim=c(0,14), main="Benton error score, time 1")
boxplot(bentonerror_2, ylim=c(0,14), main="Benton error score, time 2")
boxplot(bentonerror_3, ylim=c(0,14), main="Benton error score, time 3")

# -----

# 2. Distributions

# 2.1 Normal distribution

# the original distribution of 10000 samples of random integers between 0 and 10 is uniform:

hist(runif(10000)*10, main="")  # here, runif function creates your simulated values

# calculate mean for 10000 samples of 5 integers between 0 and 10 using for-loop:

means <- numeric(10000)
for (i in 1:10000) {means[i] <- mean(runif(5)*10) }

# finally, see how these means are normally distributed:

hist(means, ylim=c(0,1600))

# let's add a normal curve:

h <- hist(means, freq=F, ylim=c(0,0.35))
x <- seq(min(h$breaks),max(h$breaks), by=0.1)
y <- dnorm(x, mean=mean(means), sd=sd(means))
lines(x,y,col="red", lty="dashed", lwd=3)

# ---

# 2.2 Student's t-distribution

# create a vector that includes simulated values between -4 and 4:

simu <- seq(-4,4,0.01)

# draw a normal distribution:

plot(simu, dnorm(simu),  type="l", lty=2, ylab="Probability density", xlab="Deviates")

# add t-distributions for different sample sizes

lines(simu, dt(simu, df=5), col="red")		# sample size 5
lines(simu, dt(simu, df=10), col="green")		# sample size 10
lines(simu, dt(simu, df=20), col="yellow")	# sample size 20
lines(simu, dt(simu, df=30), col="blue")		# sample size 30
lines(simu, dt(simu, df=100), col="grey")		# sample size 100

# notice that when sample size increases to 30 and beyond, t-distribution resembles normal distribution

# ---

# 2.3 F-distribution

# create a vector that includes simulated values between 0 and 4

simu2 <- seq(0,4,0.01)

# draw an F-distribution with degrees of freedom 1 and 1:

plot(simu2, df(simu2, 1,1), type="l", lty=2, ylab="Probability density", xlab="Deviates")

# try changing each degrees of freedom:

lines(simu2, df(simu2, 1,10), col="red")		# df1 = 1, df2 = 10
lines(simu2, df(simu2, 1,40), col="magenta")	# df1 = 1, df2 = 40

lines(simu2, df(simu2, 2,40), col="blue")		# df1 = 2, df2 = 40
lines(simu2, df(simu2, 3,40), col="cyan")		# df1 = 3, df2 = 40
lines(simu2, df(simu2, 4,40), col="green")	# df1 = 4, df2 = 40

# -----

# 3. Tests for normality

# descriptive statistics:

describe(deprivation[5:10])		# look for mean, median, skewness
# for normality, mean should be close to median and skewness close to 0

# histograms:

layout(matrix(c(1,2,3,4,5,6), 3,2))			# set layout to 6-cell
hist(digitsymbol_1, main="Digit symbol 1")
hist(digitsymbol_2, main="Digit symbol 2")
hist(digitsymbol_3, main="Digit symbol 3")
hist(bentonerror_1, main="Benton error 1")
hist(bentonerror_2, main="Benton error 2")
hist(bentonerror_3, main="Benton error 3")

# note the skewness in Benton error scores

# use quantile-quantile plots (observed values = dots should be close to line)

qqnorm(digitsymbol_1)
qqline(digitsymbol_1)

# tests for normality:

# Kolmogorov-Smirnov for Digit symbol score time 1:
ks.test(digitsymbol_1, "pnorm", mean=mean(digitsymbol_1), sd=sd(digitsymbol_1))
# suggests normality

# Shapiro-Wilk:
shapiro.test(digitsymbol_1)
# suggests normality

# ---

# 3.1 Exercises

# Question 1

layout(matrix(c(1,2,3,4,5,6), 3,2))			# set layout to 6-cell
qqnorm(digitsymbol_1, main="Digit symbol 1")
qqline(digitsymbol_1)
qqnorm(digitsymbol_2, main="Digit symbol 2")
qqline(digitsymbol_2)
qqnorm(digitsymbol_3, main="Digit symbol 3")
qqline(digitsymbol_3)
qqnorm(bentonerror_1, main="Benton error 1")
qqline(bentonerror_1)
qqnorm(bentonerror_2, main="Benton error 2")
qqline(bentonerror_2)
qqnorm(bentonerror_3, main="Benton error 3")
qqline(bentonerror_3)

# all variables look relatively normally distributed

# -

# Question 2

# Digit symbol time point 1:
ks.test(digitsymbol_1, "pnorm", mean=mean(digitsymbol_1), sd=sd(digitsymbol_1))
shapiro.test(digitsymbol_1)
# --> normally distributed

# Digit symbol time point 2:
ks.test(digitsymbol_2, "pnorm", mean=mean(digitsymbol_2), sd=sd(digitsymbol_2))
shapiro.test(digitsymbol_2)
# --> normally distributed

# Digit symbol time point 3:
ks.test(digitsymbol_3, "pnorm", mean=mean(digitsymbol_3), sd=sd(digitsymbol_3))
shapiro.test(digitsymbol_3)
# --> normally distributed

# Benton error time point 1:
ks.test(bentonerror_1, "pnorm", mean=mean(bentonerror_1), sd=sd(bentonerror_1))
shapiro.test(bentonerror_1)
# --> normally distributed

# Benton error time point 2:
ks.test(bentonerror_2, "pnorm", mean=mean(bentonerror_2), sd=sd(bentonerror_2))
shapiro.test(bentonerror_2)
# --> KS suggests normality SW does not

# Benton error time point 3:
ks.test(bentonerror_3, "pnorm", mean=mean(bentonerror_3), sd=sd(bentonerror_3))
shapiro.test(bentonerror_3)
# --> KS suggests normality SW does not

# Benton error scores at times 2 and 3 might not be normally distributed.
# For t tests and ANOVA we assume normality, so this assumption might not
# be fulfilled in these two variables.
# You might want to consider non-parametric tests.

# However, here for practice purpose, we consider all variables normally distributed.

# -----

# 4 T tests

# --

# 4.1 One-sample t test

# compare sample mean to population mean:

summary(digitsymbol_1)		# sample mean 42.23, population mean 40

# is this difference statistically significant?
# use one-sample t-test:

t.test(digitsymbol_1, mu=40)

# --> mean of our sample does not differ from population mean (t(46)=1.33, p>.05)

# ---

# 4.2 Independent samples t-test

# take t test for age differences in Digit symbol score time 1:

t.test(digitsymbol_1 ~ age)	# categorical variable after ~

# --> mean in the two age groups does not differ (t(35)=0.27, p>.05)

# without correction for equality of variances:

t.test(digitsymbol_1 ~ age, var.equal=T)

# in this case the results are the same regardless of the equality variances assumption

# visualize results:

boxplot(digitsymbol_1 ~ age, xlab="Age group", ylab="Digit symbol score")

# ---

# 4.3 Repeated-measures t-test

# take t test for Digit score differences between time points 1 and 2:

t.test(digitsymbol_1, digitsymbol_2, paired=T)

# --> no differences between time points 1 and 2 (t(46)=-0.79, p>.05)

# visualize results:

boxplot(digitsymbol_1, digitsymbol_2, ylab="Digit symbol score", xlab="Time point")

# ---

# 4.4 Exercises

# Question 3

# (i) Differences in Digit symbol baseline performance between hormone treatment groups?

t.test(digitsymbol_1 ~ ht_group)

# --> no differences (t(44)=-0.17, p>.05)

# (ii) Differences in Benton error baseline performance between hormone treatment groups?

t.test(bentonerror_1 ~ ht_group)

# --> control group has higher number of errors (t(45)=3.01, p<.01)

# use boxplot to visualize this result:

boxplot(bentonerror_1 ~ ht_group, xlab="Hormone treatment", ylab="Benton error score")

# -

# Question 4

# (i) Differences in Digit symbol scores between times 1 and 3

t.test(digitsymbol_1, digitsymbol_3, paired=T)
boxplot(digitsymbol_1, digitsymbol_3, xlab="Time point", ylab="Digit symbol score")

# --> test scores are higher at time 3 (t(46)=-6.94, p<.001)
# interpretation: test scores improve due to learning? (from 1st to 3rd measurement)

# (ii) Differences in Digit symbol scores between times 2 and 3

t.test(digitsymbol_2, digitsymbol_3, paired=T)
boxplot(digitsymbol_2, digitsymbol_3, xlab="Time point", ylab="Digit symbol score")

# --> test scores are higher at time 3 (t(46)=-10.60, p<.001)
# interpretation: test scores improve after a night of normal sleep

# -

# Question 5

# (i) Differences in Benton error scores between times 1 and 2

t.test(bentonerror_1, bentonerror_2, paired=T)

# --> no differences (t(46)=1.53, p>.05)
# interpretation: no effect of sleep deprivation on error rate (maybe learning effect cancels this effect?)

# (ii) Differences in Benton error scores between times 1 and 3

t.test(bentonerror_1, bentonerror_3, paired=T)
boxplot(bentonerror_1,bentonerror_3, xlab="Time point", ylab="Benton error score")

# --> error rates are lower at time 3 (t(46)=5.83, p<.001)
# interpretation: error rates improve due to learning? (from 1st to 3rd measurement)

# (iii) Differences in Benton error scores between times 2 and 3

t.test(bentonerror_2, bentonerror_3, paired=T)
boxplot(bentonerror_2, bentonerror_3, xlab="Time point", ylab="Benton error score")

# --> error rates are lower at time 3 (t(46)=5.99, p<.001)
# interpretation: test scores improve after a night of normal sleep

# -----

# 5. Analysis of variance

# --

# 5.1 One-way ANOVA

# Does baseline performance in Digit symbol task vary between education groups?

A1 <- aov(digitsymbol_1 ~ education)
summary(A1)

# --> no differences between groups (F(2,44)=2.16, p>.05)

model.tables(A1, "means")	# mean score for each group

# visualize results:

boxplot(digitsymbol_1 ~ education, xlab = "Education group", ylab="Digit symbol score",	main="Baseline Digit symbol score by education group", col="grey")

# get diagnostic plots:

layout(matrix(c(1,2,3,4),2,2))
plot(A1)

# --

# 5.1.1 ANOVA assumptions

# test for homogeneity of variances:

install.packages('car')
library('car')
leveneTest(digitsymbol_1 ~ education)
bartlett.test(digitsymbol_1 ~ education)

# variances are equal in Digit symbol task at time point 1

# --

# 5.1.2 Visualizing results

# familiar box plot:

boxplot(digitsymbol_1 ~ education)

# means with confidence intervals:

install.packages('gplots')
library('gplots')
plotmeans(digitsymbol_1 ~ education, ylim=c(10,70), n.label=FALSE)

# ---

# 5.2 Two-way between subject ANOVA

# Does Digit symbol baseline performance differ between age and hormone treatment groups?

A2 <- aov(digitsymbol_1 ~ age*ht_group)
summary(A2)
model.tables(A2, "means")
layout(matrix(c(1,2,3,4),2,2))
plot(A2)

# --> no age main effect (F(1,43)=0.08, p>.05)
# --> no hormone treatment main effect (F(1,43)=0.89, p>.05)
# --> age and hormone treatment have a significant interaction effect (F(1,43)=6.81, p<.05)

# visualize results:

boxplot(digitsymbol_1 ~ age*ht_group, col=c("green", "grey"))	# not very clear..

interaction.plot(age, ht_group, digitsymbol_1, type="b", col=c(1:3),
	leg.bty="o", leg.bg="beige", lwd=2, pch=c(18,24,22),
	xlab="Age group", ylab="Digit symbol score", main="Interaction plot")

# --

# 5.2.1 Type of Sums of Squares

library(car)
Anova(A2, type=3)			# ANOVA with type 3 sums of squares

# --

# 5.2.2 Post-hoc comparisons

# Test where are the differences you found in ANOVA between age and hormone treatment effects:

pairwise.t.test(digitsymbol_1, education, p.adj="none")
pairwise.t.test(digitsymbol_1, education, p.adj="bonf")	# Bonferroni correction
pairwise.t.test(digitsymbol_1, education, p.adj="holm")	# Holm correction

TukeyHSD(A1)								# Tukey's test

# ---

# 5.3 Exercises

# Question 6

# Does hormone treatment affect Digit symbol baseline differently in different education groups?

anova1 <- aov(digitsymbol_1~ht_group*education)
summary(anova1)

# --> no it does not, because interaction effect is nonsignificant (F(2,41)=1.24, p>.05)
# --> education and hormone treatment do not affect Digit symbol baseline performance (non-significant main effects)

# -

# Question 7

# Do education and age together affect the Digit symbol baseline performance?

anova2 <- aov(digitsymbol_1 ~ age*education)
summary(anova2)

# --> no they don't (only a trend towards significance in interaction effect) (F(2,41)=2.73, p>.05)
# --> age and education do not affect Digit symbol baseline performance (non-significant main effects)

# -

# Question 8

# Age, education and hormone treatment effects in Benton task baseline performance?

anova3 <- aov(bentonerror_1 ~ age*education*ht_group)
summary(anova3)

# --> only hormone treatment has a main effect on Benton task score (F(1,35)=10.21, p<.01)
# --> age and education do not have main effects
# --> age and education have an interaction effect (F(2,35)=3.66, p<.05)
# --> education and hormone treatment group have an interaction effect (F(2,35)=3.46, p>.05)

# visualize results:

boxplot(bentonerror_1 ~ ht_group, xlab="Hormone treatment group", ylab="Benton errors")
# --> hormone treatment group makes less errors than control group at baseline

interaction.plot(education,age,bentonerror_1)
# --> higher education improves scores (=less errors) in younger group, opposite trend in older group (!?)

interaction.plot(education,ht_group, bentonerror_1)
# --> higher education improves scores in hormone treatment group, slightly opposite in control group

# -----

# 6. Exercises

# Load in data:
naming <- read.csv('http://becs.aalto.fi/~heikkih3/naming_wide.csv')

# Get familiar with the data:
head(naming)
summary(naming)
dim(naming)

# It seems that the factors (sex, reading_time) are already coded as factors.
# No missing values (actually NA's from previous weeks have been removed totally!)
# Note that now 'ms' variable is split to 'ms.regular' and 'ms.regular
# - this explains why data has only half the rows from previous weeks:
# now one participant has all the variables in a single row.

detach()			# detach all previous data frames
attach(naming)		# attach naming data frame

# -

# Question 9

t.test(iq, mu=100)

# --> intelligence does not differ from the population mean (t(997)=0, p>.05).

# -

# Question 10

t.test(iq ~ sex)

# --> no sex differences in intelligence (t(961)=1.07, p>.05).

# -

# Question 11

t.test(hrs ~ sex)

# --> no sex differences in hours spent on reading (t(972)=0.29, p>.05).

# -

# Question 12

anova.1 <- aov(iq ~ reading_time)
summary(anova.1)

# --> no differences between reading categories in intelligence (F(2,995)=0.03, p>.05).

# -

# Question 13

t.test(ms.regular, ms.exception, paired=T)
mean(ms.regular)
mean(ms.exception)
boxplot(ms.regular, ms.exception, xlab="Word type (1=regular, 2=exceptional))", ylab="Time (ms)")

# --> reading times are shorter for regular words (t(997)=-68.8, p<.001).

# -

# Question 14

# Regular words:

anova.2 <- aov(ms.regular ~ reading_time)
summary(anova.2)
boxplot(ms.regular ~ reading_time)

# take a closer look at the differences using post-hoc comparison:
pairwise.t.test(ms.regular, reading_time, p.adj="bonf")
tapply(ms.regular, reading_time, mean)
tapply(ms.regular, reading_time, sd)

# --> there are differences between reading categories (based on hours spent on reading)
# in time taken to read regular words (F(2,995)=3.52, p<.05).
# --> post-hoc comparisons using a Bonferroni corrected pairwise t-test
# revealed that the differences are between the highest reading category (mean=993, sd=70.39)
# and the lowest one (mean=1009, sd=79).

# Exceptional words:

anova.3 <- aov(ms.exception ~ reading_time)
summary(anova.3)
boxplot(ms.exception ~ reading_time)

# take a closer look at the differences using post-hoc comparison:
pairwise.t.test(ms.exception, reading_time, p.adj="bonf")
tapply(ms.exception, reading_time, mean)
tapply(ms.exception, reading_time, sd)

# --> there are differences between reading categories (based on hours spent on reading)
# in time taken to read exceptional words (F(2,995)=38.99, p<.001).
# --> post-hoc comparisons using a Bonferroni corrected pairwise t-test
# revealed that all groups differ from each other:
# highest group (mean=1173, sd=76) has higher scores than the two other groups,
# and middle group (mean=1203, sd=79) has higher scores than the lowest group (mean=1228, sd=76).

# -

# Question 15

# Regular words:

anova.4 <- aov(ms.regular ~ sex * reading_time)
summary(anova.4)

# interaction plot:
interaction.plot(reading_time, sex, ms.regular)

# --> sex does not modify the effect of reading time in
# time taken to read regular words

# Exceptional words:

anova.5 <- aov(ms.exception ~ sex * reading_time)
summary(anova.5)

# interaction plot:
interaction.plot(reading_time, sex, ms.exception)

t.test(ms.exception ~ sex)
boxplot(ms.exception ~ sex)

# neither does sex modify the effect of reading time in
# time taken to read exceptional words

# -----


\name{hc_offset-HilbertCurve-method}
\alias{hc_offset,HilbertCurve-method}
\alias{hc_offset}
\title{
Adjust positions
}
\description{
Adjust positions
}
\usage{
\S4method{hc_offset}{HilbertCurve}(object, x)
}
\arguments{

  \item{object}{A \code{\link{HilbertCurve-class}} object.}
  \item{x}{positions.}

}
\details{
Since internally positions are transformed to positive integers, if input positions
are specified as negative values when initializing the Hilbert curve, a shift will be recorded
internally and positions are transformed to positive value automatically.
}
\value{
A positive numeric value.
}
\author{
Zuguang Gu <z.gu@dkfz.de>
}
\examples{
hc = HilbertCurve(-100, 100)
hc_offset(hc, c(-100, -50, 0, 50, 100))
}


#!/usr/bin/env Rscript
args = commandArgs(trailingOnly=TRUE)

data <- read.csv(args[1])

x <- data$x
y <- data$y

png('r_orig.png')
plot(x, y, main = "Scatter in R")

png('r_lm.png')
plot(x, y, main = "Scatter in R with regression")
abline(lm(y ~ x))


wtd.cors <- function(x, y=NULL, weight=NULL){
  if(is.null(y)){
    y <- x
  }
  q <- as.matrix(x)
  r <- as.matrix(y)
  if(is.null(weight)){
    weight <- rep(1, dim(q)[1])
  }
  x <- q[!is.na(weight),]
  y <- r[!is.na(weight),]
  weight <- weight[!is.na(weight)]
  out <- .Call("wcorr", as.matrix(x), as.matrix(y), as.double(weight), NAOK=TRUE, PACKAGE="weights")
  ## C code for this package was contributed by Marcus Schwemmle
  if(!is.null(colnames(x)))
     rownames(out) <- colnames(x)
  if(!is.null(colnames(y)))
     colnames(out) <- colnames(y)
  out
}


dupl_sp <- function(z){
  #Combining duplicate names in food webs
      x <- rownames(z)
      x2 <- colnames(z)
      y <- z
      y <- aggregate(y~x,FUN=sum)
      rownames(y) <- y[,1]
      y <- y[,2:ncol(y)]
      colnames(y) <- x2
      y <- aggregate(t(y)~x2,FUN=sum)
      rownames(y) <- y[,1]
      y <-t(y[,2:ncol(y)])
      for(i in 1:nrow(y)){
        for(j in 1:ncol(y)){
          if(y[i,j] > 0) {y[i,j] <- 1} else {NULL}
        }
      }
      z <- y
      return(z)
    }


#!/usr/bin/Rscript
args <- commandArgs(TRUE)
infile_name <-args[1]
outfile_name <-args[2]
text_for_the_title <-args[3]

jpeg(outfile_name,width=1000,height=480, quality = 90)

a<-read.table(infile_name)
x<-a[,2]
y<-a[,3]

plot(x,y,xlim=c(0,max(x)),ylim=c(0,max(y)), type='l',main = text_for_the_title,xlab="position (bp)",ylab="coverage", xaxt='n', xaxs = "i", yaxs = "i", col="red")
#adding ticks to the X axis, one tick per 1000 bp.
x_marks_large=seq(0, max(x), by=1000)
axis(1, at=x_marks_large, labels=x_marks_large, col.axis="black", las=0, cex.axis=1.0, tck=-.02)


## Test from Matt Shotwell - rounding issue in describe.vector when values
## have very different magnitudes

require(Hmisc)
set.seed(42)
x <- c(runif(1000), runif(2)*1e7)
d <- describe(x)
d

# Test with a large number of distinct character values
set.seed(1)
k <- paste0('kkkkkkkkkk', round(runif(1000) * 200))
describe(k)
describe(k, listunique=1000, listnchar=2)


require(Hmisc)
x <- data.frame(x1=c('a','b^2','c'), x2=1:3 + .25)
format.df(x, dec=1)
cat(latexTabular(x, headings=c('$x_{1}$', '$x_{2}$'), translate=FALSE, hline=2))
cat(latexTabular(x, dec=1))


"gallinas" <-
structure(list(provincia = structure(c(1, 1, 2, 2, 3, 3, 4, 4,
5, 5, 6, 6, 7, 7, 8, 8, 9, 9, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6,
6, 7, 7, 8, 8, 9, 9), .Label = c("Avila", "Burgos", "Leon", "Palencia",
"Salamanca", "Segovia", "Soria", "Valladolid", "Zamora"), class = "factor"),
    agno = structure(c(1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1,
    2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2,
    1, 2, 1, 2), .Label = c("1999", "2000"), class = c("ordered",
    "factor")), tipo = structure(c(2, 2, 2, 2, 2, 2, 2, 2, 2,
    2, 2, 2, 2, 2, 2, 2, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
    1, 1, 1, 1, 1, 1, 1, 1), .Label = c("camperas", "selectas"
    ), class = "factor"), cabezas = c(125, 146, 1463, 1465, 109,
    110, 282, 330, 163, 176, 564, 559, 65, 62, 3652, 3652, 48,
    48, 55, 40, 85, 80, 296, 285, 1, 1, 40, 26.3, 40, 38, 7,
    6.5, 28, 28, 158, 152.9), hue.ave = c(285, 285, 250, 250,
    252, 255, 265, 270, 250, 285, 250, 250, 250, 250, 265, 265,
    295, 295, 150, 150, 160, 160, 165, 170, 164, 165, 150, 160,
    160, 160, 150, 150, 150, 150, 205, 200), docenas = c(2969,
    3477, 30479, 30520, 2289, 2338, 6228, 7425, 3400, 4166, 11750,
    11646, 1354, 1299, 80654, 80654, 1189, 1189, 688, 500, 1133,
    1066, 4070, 4038, 16, 17, 500, 351, 533, 507, 88, 82, 350,
    350, 2694, 2550)), .Names = c("provincia", "agno", "tipo",
"cabezas", "hue.ave", "docenas"), row.names = c("1", "2", "3",
"4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15",
"16", "17", "18", "19", "20", "21", "22", "23", "24", "25", "26",
"27", "28", "29", "30", "31", "32", "33", "34", "35", "36"), class = "data.frame")


##################################################################################################################
####  Purpose: Final Project - Classification - ANN
####  Group: Ravi P., Derek P., Aneesh K., Ninad K.
####  Date: 11/28/2018
####  Comment:
####    setwd("~/Stevens/Fall2018/CS513_Knowledge_Discovery/Final Project/Classification")
####
##################################################################################################################
setwd("~/Stevens/Fall2018/CS513_Knowledge_Discovery/Final Project/Classification")

#### 0. Cleaning Environment ####

rm(list = ls())

#### 1. Importing Data and Libraries ####
library(neuralnet)

df_train <- read.csv("./data/train_new.csv")
df_test <- read.csv("./data/test_new.csv")

#### 2. Removing Column ####
df_train <- df_train[,-1]
df_test <- df_test[,-1]

levels(df_test$SimpleColor) <- levels(df_train$SimpleColor)

#### 3. Neural Net ####

df_train$OutcomeType <- as.integer(df_train$OutcomeType)
df_train$AnimalType <- as.integer(df_train$AnimalType)
df_train$SimpleColor <- as.integer(df_train$SimpleColor)
df_train$Gender <- as.integer(df_train$Gender)
df_train$AgeinDays <- as.integer(df_train$AgeinDays)
df_train$HasName <- as.integer(df_train$HasName)
df_train$IsNeutered <- as.integer(df_train$IsNeutered)
df_train$IsMix <- as.integer(df_train$IsMix)

df_test$OutcomeType <- as.integer(df_test$OutcomeType)
df_test$AnimalType <- as.integer(df_test$AnimalType)
df_test$SimpleColor <- as.integer(df_test$SimpleColor)
df_test$Gender <- as.integer(df_test$Gender)
df_test$AgeinDays <- as.integer(df_test$AgeinDays)
df_test$HasName <- as.integer(df_test$HasName)
df_test$IsNeutered <- as.integer(df_test$IsNeutered)
df_test$IsMix <- as.integer(df_test$IsMix)

df_ann <- neuralnet(OutcomeType~ AnimalType + AgeinDays + HasName + IsNeutered + IsMix, data = df_train,linear.output = T, hidden=c(30,15,5))

# + IsMix + Gender

#### 4. Error Checking ####
plot(df_ann)
summary(df_ann)

net_result <- compute(df_ann, df_test[,c("OutcomeType", "AnimalType", "AgeinDays", "HasName","IsNeutered", "IsMix")])
ann <- as.numeric(net_result$net.result)
ANN_cat<-ifelse(ann<1.5,1,
        ifelse(ann<2.5,2,
        ifelse(ann<3.5,3,
        ifelse(ann<4.5,4,
        ifelse(ann<5.5,5,6)))))

table(df_test$OutcomeType, ANN_cat)

wrong <- (df_test$OutcomeType != ANN_cat)
wrong
rate<-sum(wrong)/length(wrong)
rate


library(grid)

rowMax.units <- function(u, nrow){ # rowMax with a fake matrix of units
  matrix.indices <- matrix(seq_along(u), nrow=nrow)
  do.call(unit.c, lapply(seq(1, nrow), function(ii) {
   max(u[matrix.indices[ii, ]])
  }))
}

colMax.units <- function(u, ncol){ # colMax with a fake matrix of units
  matrix.indices <- matrix(seq_along(u), ncol=ncol)
  do.call(unit.c, lapply(seq(1, ncol), function(ii) {
   max(u[matrix.indices[, ii]])
  }))
}

makeTableGrobs <- function(e, ncol, nrow, equal.width = F, equal.height=F,
        just = c("center", "center"),
        padding.h = unit(4, "mm"), padding.v=unit(4, "mm"),
        gpar.text = gpar(col="black", cex=1),
        gpar.fill = gpar(fill = "grey95", col="white")) {

 n <- length(e) # number of labels

 if(missing(ncol) & missing(nrow)){
 nm <- n2mfrow(n)      # pretty default layout
 ncol = nm[1]
 nrow = nm[2]
}

makeOneLabel <- function(label.ind){
textGrob(label=e[label.ind], gp=gpar.text, name=paste("cells-label-",label.ind, sep=""))
}

makeOneCell <- function(label.ind){
rectGrob(gp=gpar.fill, name=paste("cells-fill-",label.ind, sep=""))
}

  lg <- lapply(seq_along(e), makeOneLabel) # list of text grobs
  lf <- lapply(seq_along(e), makeOneCell) # list of rect grobs

  wg <- lapply(lg, grobWidth) # list of grob widths
  hg <- lapply(lg, grobHeight) # list of grob heights

  widths.all <- do.call(unit.c, wg) # all grob widths
  heights.all <- do.call(unit.c, hg)    #all grob heights

  widths <- colMax.units(widths.all, ncol) + padding.h  # all column widths
  heights <- rowMax.units(heights.all, nrow) + padding.v # all row heights

  if(equal.width)
    widths <- rep(max(widths), length(widths))
  if(equal.height)
    heights <- rep(max(heights), length(heights))

  gcells = frameGrob(name="table.cells", vp = "cells",
    layout = grid.layout(nrow, ncol, width=widths, height=heights, just=just) )

  label.ind <- 1   # index running accross labels

  for (ii in seq(1, ncol, 1)) {
    for (jj in seq(1, nrow, 1)) {

      gcells = placeGrob(gcells, lf[[label.ind]], row=jj, col=ii)
      gcells = placeGrob(gcells, lg[[label.ind]], row=jj, col=ii)

      label.ind <- label.ind + 1
    }
  }

  gl = gList( gcells)

  gl
}

exprGrob <- function(e, ncol=n2mfrow(length(e))[2], nrow=n2mfrow(length(e))[1], ...) {
   gTree(e=e, ncol=ncol, nrow=nrow, cl="expr", ...)
}

drawDetails.expr <- function(x, recording=TRUE){
grid.draw(gTree(children=makeTableGrobs(x$e, x$ncol, x$nrow),
                childrenvp=viewport(name="cells")))

}

grid.expr <- function(...){
  grid.draw(exprGrob(...))

}


#
# Exemplo 1
#

# Condicao if
x <- c(-2, -1, 0, 1, 2)
for (i in seq_len(length(x))) {
    valor <- x[i]^2
    # se o valor for igual a zero
    if (valor == 0) {
        # atribui o valor para raiz
        raiz <- x[i]
    }
}
raiz


# Data Management for Project 8/2/15

library(ggplot2)
library(PDS)
library(dplyr)
DF <- tbl_df(NESARC) %>%
  filter(S3AQ1A ==1 & S3AQ3B1 == 1 & CHECK321 == 1 & AGE <= 25) %>%
  select(contains("S3AQ8"))
DF[] <- lapply(DF, as.character)
DF[] <- lapply(DF, as.numeric)
myfix <- function(x){ifelse(x %in% c(2, 9), 0, ifelse(x == 1, 1, NA))}
DF2 <- apply(DF, 2, myfix)
DF2 <- as.data.frame(DF2)
DF2$NumberNicotineSymptoms <- apply(DF2, 1, sum, na.rm = TRUE)
nesarc <- tbl_df(NESARC) %>%
  filter(S3AQ1A ==1 & S3AQ3B1 == 1 & CHECK321 == 1 & AGE <= 25) %>%
  rename(Ethnicity = ETHRACE2A, Age = AGE, MajorDepression = MAJORDEPLIFE,
         Sex = SEX, TobaccoDependence = TAB12MDX, DailyCigsSmoked = S3AQ3C1) %>%
  select(Ethnicity, Age, MajorDepression, TobaccoDependence, DailyCigsSmoked, Sex)
nesarc <- data.frame(nesarc, NumberNicotineSymptoms = DF2$NumberNicotineSymptoms)
nesarc <- tbl_df(nesarc)
# Code 99 properly
nesarc$DailyCigsSmoked[nesarc$DailyCigsSmoked == 99] <- NA
nesarc$DCScat <- cut(nesarc$DailyCigsSmoked, breaks = c(0, 5, 10, 15, 20, 98), include.lowest = FALSE)
# Label stuff
nesarc$Ethnicity <- factor(nesarc$Ethnicity,
                           labels = c("Caucasian", "African American",
                                      "Native American", "Asian", "Hispanic"))
nesarc$TobaccoDependence <- factor(nesarc$TobaccoDependence,
                                   labels = c("No Nicotine Dependence",
                                              "Nicotine Dependence"))
nesarc$Sex <- factor(nesarc$Sex, labels =c("Female", "Male"))
nesarc$MajorDepression <- factor(nesarc$MajorDepression,
                                 labels =c("No Depression", "Yes Depression"))
#
dim(nesarc)
####################
xtabs(~ MajorDepression +  DCScat + TobaccoDependence, data = nesarc)
prop.table(xtabs(~ TobaccoDependence +  DCScat +
                   MajorDepression, data = nesarc), 2)

tapply(nesarc$DailyCigsSmoked, list(nesarc$MajorDepression, nesarc$TobaccoDependence), mean, na.rm = TRUE)
####################
ggplot(data = nesarc, aes(x = MajorDepression, fill = TobaccoDependence)) +
  geom_bar(position = "fill") +
  theme_bw() +
  labs(x = "", y = "Fraction",
       title = "Fraction of young adult daily smokers\nwith and without nicotine addiction\nby depression status") +
  scale_fill_manual(values = c("green", "red"), name = "Tobacco Addiction Status") +
  guides(fill = guide_legend(reverse = TRUE))

####
mod1 <- aov(DailyCigsSmoked ~ TobaccoDependence,
            data = nesarc[nesarc$MajorDepression == "No Depression", ])
summary(mod1)
mod2 <- aov(DailyCigsSmoked ~ TobaccoDependence,
            data = nesarc[nesarc$MajorDepression == "Yes Depression", ])
summary(mod2)
mod3 <- aov(DailyCigsSmoked ~ TobaccoDependence + MajorDepression, data = nesarc)
summary(mod3)
mod4 <- aov(DailyCigsSmoked ~ TobaccoDependence*MajorDepression, data = nesarc)
summary(mod4)
#######################
?interaction.plot
tapply(nesarc$DailyCigsSmoked, list(nesarc$TobaccoDependence, nesarc$MajorDepression),
       mean, na.rm = TRUE)
# Need to write function t ignore NA values
mean.rm.na <- function(x){mean(x, na.rm=TRUE)}
# Ok....note lines do not cross....but not the most beautiful graph
interaction.plot(nesarc$MajorDepression, nesarc$TobaccoDependence,
                 nesarc$DailyCigsSmoked, fun = mean.rm.na)
###
ggplot(data = nesarc, aes(x = MajorDepression, y = DailyCigsSmoked, shape = TobaccoDependence,
                            group = TobaccoDependence, linetype = TobaccoDependence)) +
  stat_summary(fun.y = mean, na.rm = TRUE, geom = "point") +
  stat_summary(fun.y = mean, na.rm = TRUE, geom = "line") +
  labs(y = "Mean Daily Cigarettes Smoked", x = "") +
  guides(fill = guide_legend(reverse = TRUE)) +
  theme_bw()
###

###################
library(grid)
library(PDS)
library(ggplot2)
mod.lm <- lm(Distance ~ Age, data = signdist)
summary(mod.lm)
predict(mod.lm, newdata = data.frame(Age = 60))
#############################################################
PV <- predict(mod.lm, newdata = data.frame(Age = 60))
PV
ggplot(data = signdist, aes(x = Age, y = Distance)) +
   geom_point(color = "purple") +
   theme_bw() +
   labs(x = "Drivers Age (years)", y = "Sign Legibility Distance (feet)") +
   geom_smooth(method = "lm", se = FALSE) +
   geom_line(data = data.frame(Age = c(60, 60),
                               Distance = c(280, PV)),
             arrow = arrow(type = "closed", angle = 15), color = "red") +
  geom_line(data = data.frame(Age = c(60, 19), Distance = c(PV, PV)),
            arrow = arrow(type = "closed", angle = 15, ends = "first"), color = "red")

### Else
library(ggplot2)
ggplot(data = nesarc[(!is.na(nesarc$TobaccoDependence) &
                        !is.na(nesarc$DCScat)), ],
       aes(x = DCScat, fill = TobaccoDependence)) +
  geom_bar(position = "fill") +
  theme_bw() +
  labs(x= "Daily Smoking Frequency", y = "Fraction") +
  guides(fill = guide_legend(reverse = TRUE)) +
  facet_grid(MajorDepression ~ .)
#####

# Models
mod.aov <- aov(DailyCigsSmoked ~ TobaccoDependence + MajorDepression + TobaccoDependence:MajorDepression, data = nesarc)
summary(mod.aov)
mod2.aov <- aov(DailyCigsSmoked ~ MajorDepression, data = nesarc)
summary(mod2.aov)


source('./r_files/flatten_HTML.r')

############### Library Declarations ###############
libraryRequireInstall("ggplot2");
libraryRequireInstall("plotly");
libraryRequireInstall("dplyr");
####################################################

################### Actual code ####################
#g = qplot(`Petal.Length`, data = iris, fill = `Species`, main = Sys.time());

if(!exists("x") || !exists("y") || !exists("z")) # invalid input

{
        validToPlot <- FALSE

        pbiWarning1 <- "X, Y AND Z values are required"

        #pbiWarning <- cutStr2Show(pbiWarning1, strCex = sizeWarn/6, partAvailable = 0.9)
        pbiWarning <- pbiWarning1

} else {

        validToPlot <- TRUE

        dataset <- data.frame(x,y,z)
        names(dataset) <- c(names(x), names(y), names(z))
}

if(validToPlot)

{

        #droplines
        dl_set <- dataset
        names(dl_set) <- c("x", "y", "z")
        dl_set$id <- seq_len(nrow(dl_set))
        dl <- replicate(2, dl_set, simplify = F)
        dlz <- dl
        dlz[[2]]$z <- min(dl_set$z)
        dlz <- group2NA(bind_rows(dlz), "id")
        dlx <- dl
        dlx[[2]]$x <- min(dl_set$x)
        dlx <- group2NA(bind_rows(dlx), "id")
        dly <- dl
        dly[[2]]$y <- min(dl_set$y)
        dly <- group2NA(bind_rows(dly), "id")

        size_var_exists <- FALSE
        if(exists("size"))

        {
                size_var_exists <- TRUE
                dataset <- data.frame(dataset,size)
                names(dataset)[ncol(dataset)] <- names(size)
        } else {
                dataset$size <- 1
        }

        color_var_exists <- FALSE
        if(exists("color"))

        {
                color_var_exists <- TRUE
                dataset <- data.frame(dataset,color)
                names(dataset)[ncol(dataset)] <- names(color)
        }

        colNames <- names(dataset)
        m <- list(
                l = 0,
                r = 0,
                b = 0,
                t = 0,
                pad = 1
        )
        p <- plot_ly() %>%
                add_markers(data = dataset,
                            x = as.formula(paste0("~`", colNames[1], "`")),
                            y = as.formula(paste0("~`", colNames[2], "`")),
                            z = as.formula(paste0("~`", colNames[3], "`")),
                            size = if (size_var_exists) as.formula(paste0("~`", colNames[4], "`")),
                            marker = list(sizemode = "diameter"),
                            sizes = c(5,20),
                            color = if (color_var_exists) as.formula(paste0("~`", colNames[5], "`")),
                            colors = c('#BF382A', '#0C4B8E')) %>%
                layout(margin=m) %>%
        add_paths(data = dlz, x = ~x, y = ~y, z = ~z, color=I("grey"), showlegend=F, text="test") %>%
        add_paths(data = dlx, x = ~x, y = ~y, z = ~z, color=I("grey"), showlegend=F, text="test") %>%
        add_paths(data = dly, x = ~x, y = ~y, z = ~z, color=I("grey"), showlegend=F, text="test")

};

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

############# Create and save widget ###############
#p = ggplotly(g);
internalSaveWidget(p, 'out.html');
####################################################


#Session notes can be found at the link below
#https://nbviewer.jupyter.org/github/corybaird/PLCY_Code_2020_winter/blob/main/Code_sessions/Session_1/Session_1_Notes.ipynb

##A.3.1 Import libraries

#Step 1

#install.packages('dplyr')
#install.packages('gapminder')

#Step 2

library('dplyr')
library('gapminder')

gapminder = gapminder

##A.3.2 Import data
gapminder %>% head(5)

### 1. DPLYR review

#1.1 Select
## Pipe operator shortcut on mac is command+shift+M

gapminder %>%
select(country, year, gdpPercap)

#1.2 Filter
#1.2.1 Filter by 1 condition
gapminder %>%
filter(continent==2007)

#1.2.2 Filter by 2 conditions
gapminder %>%
filter(year>1990 & year<2007) %>%
head(2)

#1.3 Mutate
gapminder = gapminder %>%
mutate(gdp_log = log(gdpPercap))

#1.4 Summarize
gapminder  %>%
summarise(mean_pop = mean(pop),
         median_pop = median(pop))

#1.4.1 Summarize and filter, chain two functions
gapminder  %>%
filter(year==2007) %>%
summarise(mean_pop = mean(pop))

#1.5 Groupby
gapminder  %>%
group_by(continent) %>%
summarise(mean_gdp = mean(gdpPercap))

### 2. Data check

#2.1 Data types: str(DF_NAME)
str(gapminder)

#2.2 Summary stats: summary(DF_NAME)
summary(gapminder)

#2.3 Check for NA: is.na()
gapminder %>%
is.na() %>%
  any()

#2.4 Drop na: na.omit
#add na then drop

#2.4.1 Add NA row at the bottom of dataset
gapminder = gapminder %>% rbind(c(NA,NA, NA, NA, NA, NA))
gapminder %>% tail(2)

#2.4.2 Re-check for na
gapminder %>%
is.na() %>%
any()

#2.4.3 na.omit()
gapminder = gapminder %>%
na.omit()

### 3. Data Manipulation

#3.1 Dummy variable
gapminder_2007 = gapminder %>% filter(year==2007)

gapminder_2007 %>% head(5)

#3.1.1 Add dummy for high-income countries
gapminder_2007 = gapminder_2007 %>%
mutate(highinc_dummy = as.numeric(gdpPercap>10000))

gapminder_2007  %>% head(2)

#3.1.2 Dummies are useful for summary stats
gapminder_2007  %>%
group_by(highinc_dummy) %>%
summarise(gdp_mean = mean(gdpPercap),
         pop_mean = mean(pop))

#3.2 Mapping values
gapminder_2007  %>%
mutate(highinc_dummy_factor = recode(highinc_dummy, '0'='Low', '1'='High')) %>%
tail(2)

#3.3 Cut-off dummies
cutoffs = c(seq(40, 100, by = 10))
cutoffs

gapminder_2007 = gapminder_2007  %>%
mutate(cut_variable =
         cut(gapminder_2007$lifeExp, cutoffs,
             include.lowest=TRUE))

gapminder_2007 %>% head(3)

gapminder_2007 %>%
group_by(cut_variable) %>%
summarise(mean_gdp = mean(gdpPercap))

### 4. Misc

#4.1 Rename column
gapminder_2007 = gapminder_2007  %>% rename('gdp'='gdpPercap')

#4.2 Unique
gapminder_2007 %>%
select(continent) %>%
unique()

#4.3 Table(row, column)
df_polity = read.csv('https://raw.githubusercontent.com/corybaird/PLCY_610_public/master/Discussion_sections/Disc4_PS2/demo.csv')
df_polity %>% head(2)

#4.3.1 Frequency table
freq_table = df_polity %>% select(wealth, regime) %>% table()
freq_table

#add row and column names for freq table
rownames(freq_table) = c('Wealth 1', 'Wealth 2', 'Wealth 3')
colnames(freq_table) = c('Regime 1', 'Regime 2', 'Regime 3')
freq_table

#4.3.2 Proportion table
prop.table(freq_table)

#4.4 Filter list
country_list = c('Albania', 'Italy', 'France', 'Belgium')
gapminder_2007  %>% filter(country %in% country_list)

#4.5 Case when

gapminder_2007 %>%
mutate(language = case_when(country=='Spain'~'Spanish',
                           country=='Italy' ~ 'Italian',
                           country=='United Kingdom'~'English')) %>% na.omit()

#4.6 Count
gapminder_2007  %>% count(highinc_dummy)

#4.7 Export data
#gapminder_2007 %>% write.csv('FILENAME.csv')
#gapminder_2007 %>% write.xlsx('FILENAME.xlsx')

### 5. Merge

#5.1 Merge rows
df_1 = gapminder_2007[1:3, ]
df_1

df_2 = gapminder_2007[5:7, ]
df_2

#5.1.1 rbind
rbind(df_1, df_2)

#5.2 Merge columns
df_1 = gapminder_2007[1:3, c('year','lifeExp')]
df_1
df_2 = gapminder_2007[5:7, c('continent','country')]
df_2

cbind(df_1, df_2)

#5.3 Merge rows and columns
#5.3.1 Case data
url = 'https://raw.githubusercontent.com/nytimes/covid-19-data/master/us-counties.csv'
nyt_cases_df = read.csv(url)
nyt_cases_df  %>% head(3)

#5.3.2 Mask data
url = 'https://raw.githubusercontent.com/nytimes/covid-19-data/master/mask-use/mask-use-by-county.csv'
nyt_mask_df = read.csv(url)
nyt_mask_df %>% head(3)

#5.3.3 Merge
#5.3.3.1 For the column merge on make sure the name is the same in both data sets
nyt_mask_df = nyt_mask_df %>% rename('fips'='COUNTYFP')

nyt_mask_df %>% names()
nyt_cases_df %>% names()

merge(nyt_cases_df, nyt_mask_df, by='fips')

### End


pdf_file<-"pdf/maps_germany_shp_onb_zipcode.pdf"
cairo_pdf(bg="grey98", pdf_file,width=16,height=9)

par(mar=c(0,0,0,0),oma=c(1,1,1,0), mfcol=c(1,2),family="Lato Light",las=1)
library(maptools)
library(rgdal)
library(RColorBrewer)

# Import data and prepare chart

myX<-readShapeSpatial("myData/ONB_Grenzen/ONB_Grenzen.shp")
myColour<-sample(1:7,length(myX),replace=T)

# Create chart and other elements

plot(myX,col=brewer.pal(7,"Greens")[myColour],border=F)
mtext(paste("N=", format(length(myX), big.mark=","), sep=""),side=3,line=-6,adj=0,cex=1.7)
mtext("Local Network Area \nborders",side=3,line=-4,adj=0,cex=1.7)
mtext("Source: http://bundesnetzagentur.de",side=1,line=-1,adj=0,cex=1.3)

# Import data and prepare chart

myY<-readShapeSpatial("myData/PLZ/post_pl.shp",proj4string=CRS("+proj=longlat"))
myX <- spTransform(myY, CRS=CRS("+proj=merc"))
myColour<-sample(1:7,length(myX),replace=T)

# Create chart and other elements

plot(myX,col=brewer.pal(7,"Oranges")[myColour],border=F)
mtext(paste("N=", format(length(myX), big.mark=","), sep=""),side=3,line=-6,adj=0,cex=1.7)

# Titling

mtext("Zip Code \nborders",side=3,line=-4,adj=0,cex=1.7)
mtext("Source: http://arnulf.us/PLZ",side=1,line=-1,adj=0,cex=1.3)
dev.off()


subroutine initad(j,nadj,madj,x,y,ntot,eps,ntri,nerror)

# Initial adding-in of a new point j.
# Called by addpt.

implicit double precision(a-h,o-z)
dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot)
integer tau(3)
integer tadj(1000)

# Find the triangle containing vertex j.
call trifnd(j,tau,nedge,nadj,madj,x,y,ntot,eps,ntri,nerror)
if(nerror > 0) return

# If the new point is on the edge of a triangle, detach the two
# vertices of that edge from each other.  Also join j to the vertex
# of the triangle on the reverse side of that edge from the `found'
# triangle (defined by tau) -- given that there ***is*** such a triangle.
if(nedge!=0) {
        ip = nedge
        i  = ip-1
        if(i==0) i = 3 # Arithmetic modulo 3.
        call pred(k,tau(i),tau(ip),nadj,madj,ntot,nerror)
	if(nerror > 0) return
        call succ(kk,tau(ip),tau(i),nadj,madj,ntot,nerror)
	if(nerror > 0) return
        call delet(tau(i),tau(ip),nadj,madj,ntot,nerror)
	if(nerror > 0) return
        if(k==kk) call insrt(j,k,nadj,madj,x,y,ntot,nerror,eps)
	if(nerror > 0) return
}

# Join the new point to each of the three vertices.
do i = 1,3 {
	call insrt(j,tau(i),nadj,madj,x,y,ntot,nerror,eps)
	if(nerror > 0) return
}
if(j==580) {
    nj = nadj(j,0)
    do jc = 1,nj {
        tadj(jc) = nadj(j,jc)
    }
    call intpr("Initial adjacency list of point 580:",-1,tadj,nj)
}

return
end


#' poda
#'
#' Calculate the partial pressure of oxygen in function of altitude.
#'
#' @param t numeric Air temperature in degC.
#' @param rh numeric Air Relative humidity in percentage.
#' @param pair numeric Local air pressure in hPa.
#' @return partial pressure of oxygen
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  poda, oxygen, altitude.
#'
#' @export
#'
#'
#'
#'

poda=function(t,rh,pair) {
                         ct$assign("t", as.array(t))
                         ct$assign("rh", as.array(rh))
                         ct$assign("p", as.array(pair))
                         ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){res[i]=poda(t[i],rh[i],p[i])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


# Listing 17.7 은 가급적 돌리지 말것. 많은 시간이 소요되며 잘 반영되지 않음.
# 본 코드를 수행하기 위해서는
# 원본 데이터를 아래와 같이 변형해야 함 head(kbo)참조.

# 원 데이터는 두팀이 한row에 있으며 모든 자료가 같은 row를 차지하고 있음.
# 팀명으로 홈 어웨이를 구분(hOrA)하고 같은 row의 자료를 아래로 Rbind하여 위 데이터셋을 만들어야 함.
# 마지막에 있는 코드는 각 분류방법에 대한 정확도와 민감도를 나타냄. 가장 좋은 것은 역시 랜덤포레스트.

# install.packages(c("rpart", "party", "randomForest", "e1071", "rpart.plot", "readr"))
# install.packages("partykit")
library(rpart)
library(party)
library(randomForest)
library(e1071)
library(rpart.plot)
library(readr)
library(readxl)

kbo <- read_csv("kbolist_re.csv")
head(kbo)

df <- kbo[-1]
df$winOrloss <- factor(df$winOrloss, levels=c(1,0),
                   labels=c("win", "loss"))

set.seed(1234)
train <- sample(nrow(df), 0.7*nrow(df))
df.train <- df[train,]
df.validate <- df[-train,]
table(df.train$winOrloss)
# win loss
# 2443 2422
table(df.validate$winOrloss)
# win loss
# 1032 1053

# Listing 17.2 - Logistic regression with glm()
fit.logit <- glm(winOrloss~., data=df.train, family=binomial())
summary(fit.logit)
##############################################################################################
# Call:
#   glm(formula = winOrloss ~ ., family = binomial(), data = df.train)
#
# Deviance Residuals:
#   Min       1Q   Median       3Q      Max
# -2.0658  -1.0863  -0.5907   1.0797   2.0736
#
# Coefficients:
#   Estimate Std. Error z value Pr(>|z|)
# (Intercept)  0.307633   0.160909   1.912 0.055897 .
# hOrA        -0.414391   0.060146  -6.890 5.59e-12 ***
#   inning      -0.232867   0.098284  -2.369 0.017821 *
#   tajasu       0.214432   0.054491   3.935 8.31e-05 ***
#   tugusu      -0.000244   0.003561  -0.069 0.945372
# tasu        -0.160913   0.047018  -3.422 0.000621 ***
#   anta         0.013630   0.033197   0.411 0.681376
# fourball    -0.181790   0.057509  -3.161 0.001572 **
#   homerun      0.083115   0.044310   1.876 0.060690 .
# samjin      -0.009144   0.016582  -0.551 0.581337
# siljum       0.130653   0.049832   2.622 0.008744 **
#   jacheck     -0.041126   0.048831  -0.842 0.399676
# score       -0.096739   0.008490 -11.395  < 2e-16 ***
#   ---
#   Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
#
# (Dispersion parameter for binomial family taken to be 1)
#
# Null deviance: 6744.2  on 4864  degrees of freedom
# Residual deviance: 6326.0  on 4852  degrees of freedom
# AIC: 6352
#
# Number of Fisher Scoring iterations: 4
##############################################################################################
prob <- predict(fit.logit, df.validate, type="response")
logit.pred <- factor(prob > .5, levels=c(FALSE, TRUE),
                     labels=c("win", "loss"))
logit.perf <- table(df.validate$winOrloss, logit.pred,
                    dnn=c("Actual", "Predicted"))
logit.perf
#prob
#     Predicted
# Actual win loss
#  win  686  346
#  loss 359  694
##############################################################################################

# Listing 17.3 - Creating a classical decision tree with rpart()
library(rpart)
set.seed(1234)
dtree <- rpart(winOrloss ~ ., data=df.train, method="class",
               parms=list(split="information"))
dtree$cptable
plotcp(dtree)

dtree.pruned <- prune(dtree, cp=.0125)

library(rpart.plot)
#?prp()
prp(dtree.pruned, type = 2, extra = 104,
    fallen.leaves = TRUE, main="Decision Tree")

dtree.pred <- predict(dtree.pruned, df.validate, type="class")
dtree.perf <- table(df.validate$winOrloss, dtree.pred,
                    dnn=c("Actual", "Predicted"))
dtree.perf

# Listing 17.4 - Creating a conditional inference tree with ctree()
library(party)
fit.ctree <- ctree(winOrloss~., data=df.train)
plot(fit.ctree, main="Conditional Inference Tree")

ctree.pred <- predict(fit.ctree, df.validate, type="response")
ctree.perf <- table(df.validate$winOrloss, ctree.pred,
                    dnn=c("Actual", "Predicted"))
ctree.perf

library(partykit)
plot(as.party(dtree.pruned))

# Listing 17.5 - Random forest
library(randomForest)
set.seed(1234)
fit.forest <- randomForest(winOrloss~., data=df.train,
                           na.action=na.roughfix,
                           importance=TRUE)
fit.forest
importance(fit.forest, type=2)
forest.pred <- predict(fit.forest, df.validate)
forest.perf <- table(df.validate$winOrloss, forest.pred,
                     dnn=c("Actual", "Predicted"))
forest.perf

varImpPlot(fit.forest)

# Listing 17.6 - A support vector machine
library(e1071)
set.seed(1234)
fit.svm <- svm(winOrloss~., data=df.train)
fit.svm
svm.pred <- predict(fit.svm, na.omit(df.validate))
svm.perf <- table(na.omit(df.validate)$winOrloss,
                  svm.pred, dnn=c("Actual", "Predicted"))
svm.perf

# Listing 17.7 Tuning an RBF support vector machine (this can take a while)
# many time spend..... if you have a dull, please cancel this process.
#set.seed(1234)
#tuned <- tune.svm(winOrloss~., data=df.train,
#                  gamma=10^(-6:1),
#                  cost=10^(-10:10))
#tuned
#fit.svm <- svm(winOrloss~., data=df.train, gamma=.01, cost=1)
#svm.pred <- predict(fit.svm, na.omit(df.validate))
#svm.perf <- table(na.omit(df.validate)$winOrloss,
#                  svm.pred, dnn=c("Actual", "Predicted"))
#svm.perf

# Listing 17.8 Function for assessing binary classification accuracy
performance <- function(table, n=2){
  if(!all(dim(table) == c(2,2)))
    stop("Must be a 2 x 2 table")
  tn = table[1,1]
  fp = table[1,2]
  fn = table[2,1]
  tp = table[2,2]
  sensitivity = tp/(tp+fn)
  specificity = tn/(tn+fp)
  ppp = tp/(tp+fp)
  npp = tn/(tn+fn)
  hitrate = (tp+tn)/(tp+tn+fp+fn)
  result <- paste("Sensitivity = ", round(sensitivity, n) ,
                  "\nSpecificity = ", round(specificity, n),
                  "\nPositive Predictive Value = ", round(ppp, n),
                  "\nNegative Predictive Value = ", round(npp, n),
                  "\nAccuracy = ", round(hitrate, n), "\n", sep="")
  cat(result)
}

# Listing 17.9 - Performance of breast cancer data classifiers
performance(dtree.perf)
performance(ctree.perf)
performance(forest.perf)
performance(svm.perf)


# Clear environment
rm(list = ls())

# Import libraries
library(ggplot2)
library(dplyr)

# Read in data
disbursements <- read.csv("JULY-SEPT-2020-SOD-SUMM-GRID-FINAL.csv",
                          header=TRUE, sep=",")

# Data wrangling
disbursements_ordered_by_program_perc_top_10 <- disbursements %>%
  group_by(disbursements$PROGRAM) %>%
  summarise(sum=sum(QTD.AMOUNT)) %>%
  arrange(desc(sum)) %>%
  mutate(perc=100*sum/sum(sum)) %>%
  top_n(10, perc)

disbursements_interns <- filter(disbursements,
                                disbursements$PROGRAM=="INTERN ALLOWANCES") %>%
  group_by(ORGANIZATION) %>%
  summarise(sum=sum(QTD.AMOUNT)) %>%
  arrange(desc(sum))

# Amount spent on intern allowances by office, top ten chart
ggplot(top_n(disbursements_interns, 10, sum),
       aes(x=reorder(ORGANIZATION, -sum), y=sum)) +
  geom_bar(stat="identity") +
  theme(axis.text.x=element_text(angle=90, vjust=0.5, hjust=1)) +
  xlab("Office") +
  ylab("Money spent on intern allowances") +
  ggtitle("Amount spent on intern allowances by office, top ten") +
  theme(plot.title=element_text(hjust = 0.5)) +
  geom_text(aes(label=sum), position=position_dodge(width=0.9), vjust=-0.25)

ggsave("intern_allowances.png",
  width = 8,
  height = 8,
  units = "in")

# Percentage of disbursements by program, top ten chart
ggplot(disbursements_ordered_by_program_perc_top_10,
  aes(x=reorder(`disbursements$PROGRAM`, -perc), y=perc)) +
  geom_bar(stat="identity") +
  theme(axis.text.x = element_text(angle=90, vjust=0.5, hjust=1)) +
  xlab("Program") + ylab("Percentage of disbursements") +
  ggtitle("Percentage of disbursements by program, top ten") +
  theme(plot.title=element_text(hjust=0.5)) +
  geom_text(aes(label=round(perc, digits=2)),
            position=position_dodge(width=0.9), vjust=-0.25)

ggsave("disbursements_by_program.png",
  width = 8,
  height = 8,
  units = "in")


#' @export
#'
#' @title checkConvergence - Check the convergence of a mcmc.list object
#'
#' @description Run various diagnostic procedures in the \code{coda} package
#' to check convergence of a set of mcmc chains.
#'
#' @param obj An mcmc.list object from the \code{rjags} package.  These are output
#' by the \code{coda.samples} function. This mcmc.list must contain 2 or more chains.
#'
#' @param quiet Whether to print any output on screen.
#'
#' @details This routine runs the Gelman and Rubin (1992) diagnostic for
#' a set of MCMC chains by calling \code{gelman.diag} in the \code{coda} package.
#'
#' @return A list with the following components
#' \itemize{
#'   \item converged: If the uppper limits of the  'potential scale
#'   reduction factors' associated with all parameters are less than
#'   \code{criterion}, the chain is declared converged and this is TRUE.
#'   Otherwise, this component of the returns is FALSE.
#'   \item Rhats: the 'potential scale reduction factors' or Rhats
#'   associated with all parameters.
#'  }
#'
#' @author Trent McDonald
#'
#' @references
#' Gelman, A and Rubin, DB (1992) Inference from iterative simulation
#' using multiple sequences, Statistical Science, 7, 457-511.
#'
#' @seealso \code{\link{gelman.diag}}, \code{\link{checkIsConverged}}
#'
#' @examples
#' \dontrun{
#' jags = jags.model(file="someJAGSFile.txt",
#'    data=someJAGS.data, inits=someJAGS.inits,
#'    n.chains=3,n.adapt=100)
#' update(jags, n.iter=1000)
#' out = coda.samples(jags,
#'    variable.names=c("someParameter"),
#'    n.iter=1000,
#'    thin=2)
#'
#' conf <- chechIsConverged(out)
#' }

checkIsConverged <- function(obj, criterion=1.1, quiet=FALSE){

  Rhats <- gelman.diag(obj)
  if(!quiet){
    cat(paste0(paste(rep("-",4),collapse="")," Checking convergence:\n"))
    print(Rhats)
  }
  vnames <- dimnames(Rhats$psrf)[[1]]
  Rhats <- Rhats$psrf[,"Upper C.I."]
  names(Rhats) <- vnames
  if( any(Rhats > criterion, na.rm=TRUE) ){
    if(!quiet){
      cat("The following coefficients probably did not converge (Rhat > 1.1):\n")
      print(names(Rhats)[Rhats > criterion])
      cat("Try increasing nburns and/or nthins or informing the coefficient's priors.\n")
    }
    ans <- FALSE
  } else {
    if(!quiet){
      cat("The model converged. All Rhats < 1.1\n")
    }
    ans <- TRUE
  }

  ans <- list(converged=ans, Rhats=Rhats)

}


library(ggplot2)
library(ggthemes)
library(waffle)

source('colors.r')

pdf('../pdfs/modality_waffle_1968-2007.pdf',width=4.7778,height=1.256)

data = read.csv(file='../cleaned_data.csv', sep=',', header = TRUE)
reset <- par(mar=rep(0,4))

info <- c(`Major`=71, `Minor`=29)
# info <- c(`Major`=71, `Minor`=29)
modality <- waffle(info, rows=5, size=0.5, legend_pos='none', colors=c('#fcde05', grays[3]))

par(reset)
print(modality)
par(reset)
dev.off()


library(dHRUM)
nHrus <- 1
Areas <- runif(nHrus,min = 1,max  = 10)
IdsHrus <- paste0("ID",seq(1:length(Areas)))
dhrus <- initdHruModel(nHrus,Areas,IdsHrus)
prec=c(1,2,3)
temp=c(1,2,3)
setSoilStorTypeToAlldHrus(dHRUM_ptr = dhrus, c("COLLIE_V2"), c("ID1"))
gwStorTypesVec <- c("LINBY_RES")
setGWtypeToAlldHrus(dHRUM_ptr = dhrus, gwStorTypesVec, c("ID1"))
setPTInputsToAlldHrus(dhrus, Prec = prec, Temp = temp, as.Date("1990/01/30"))
ParDF = data.frame( B_SOIL = 1.6, C_MAX = 100, B_EVAP = 2,  KS = 0.1, KF = 0.2, ADIV = 0.3, CDIV = 0.03,
                    SDIV = 0.03, CAN_ST = 2, STEM_ST = 2, CSDIV = 0.3, TETR = 5, DDFA = 0.5, TMEL = 0, RETCAP = 10,
                    D_BYPASS = 0.8, THR = 10, KS2 = 0.1, FOREST_FRACT = 0.3,
                    FC = 100)
setParamsToAlldHrus(dHRUM_ptr = dhrus,as.numeric(ParDF[1,]),names(ParDF))
calcPetToAllHrus(dHRUM_ptr = dhrus,50.1,"Hamon")
#calcHBInAlldHrus(dHRUM_ptr = dhrus)
#gatherHBdata(dHRUM_ptr = dhrus)
outDF <- dHRUMrun(dHRUM_ptr = dhrus)
outDf <- data.frame(outDF$outDta)
names(outDf) <- outDF$VarsNams
plot(outDf$SOIS, type = 'l')
plot(outDf$EVBS, type = 'l')
plot(outDf$PERC, type = 'l')


#!/usr/local/bin/Rexec
########### set arguments list ###############################
args<-commandArgs();
args_start=grep("--args",args)+1;
if  (length(args_start)>0 && args_start < length(args) ) {
  args<-args[args_start:length(args)]
} else {
  args=c()
}
#############################################################
rm(list=ls())

mwpp<-function(tau1,tau2,k)
{
  r=tau2/tau1;
  s1=exp((r+1)/r);
  deltat = 0;

  if(tau1>=tau2)
  {
    dw     = -k^2*(2*r-2*r*exp(r+1)+r^2-1)/(tau1*exp(r+1)*(r+1)^3)
  } else if(tau1<tau2)
  {
    dw     = -k^2*(2*r-2*r*s1-r^2+1)/(tau1*s1*(r+1)^3)
  }
  return(c(deltat,dw))
}

mwnp<-function(tau1,tau2,k)
{
  r=tau2/tau1;
  s1=exp(r+1);

  deltat = tau1* ( 3*r*s1 -r  +r^2*s1 -r^2 +2 )/( (r*s1 + 1)*(r+1));
  dw     = k^2*(r*s1+1)*exp(-(r+4*r*s1+3*r^2*s1+r^3*s1+3)/((r*s1+1)*(r+1)))/(tau1*(r+1)^2);

  return(c(deltat,dw))
}

mwnn<-function(tau1,tau2,k)
{
  r=tau2/tau1;

  deltat=0;
  dw=0;

  if(tau1>=tau2)
  {
    deltat = -tau1*(r^2+r-2)/(r+1)
    dw     = k^2*exp(-(r+3)/(r+1))/(tau1*(r+1)^2)
  } else
  {
    deltat = tau1*(-2*r^2+r+1)/(r+1)
    dw     = k^2*(3*r-1)*exp(-(2*r^2+3*r-1)/(r*(r+1)))/(tau1*(r+1)^3)
  }

  return(c(deltat,dw))
}

mwpn<-function(tau1,tau2,k)
{
  r=tau2/tau1;
  s1=exp((r+1)/r)

  deltat = -(r*tau1*( s1 -r +3*r*s1 +2*r^2 -1 ))/( (r + s1)*(r+1));
  dw     = k^2*(r+s1)*exp(-(s1+3*r*s1+4*r^2*s1+r^2+3*r^3)/(r*(r+s1)*(r+1)))/(tau1*(r+1)^2);

  return(c(deltat,dw));
}

mwps<-function(tau1,tau2,k)
{
  r=tau2/tau1;
  s1=exp((r+1)/r);

  deltat = r*tau1* ( 2*r -2*r*s1 -r^2 +1 )/( (r+s1)*(r+1));
  dw     = k^2*r*(r+s1)*exp(-( s1+2*r*s1+3*r^2*s1+2*r^3 ) /(r*(r+s1)*(r+1)) )/((r+1)^2);
  return(c(deltat,dw))
}

mwsp<-function(tau1,tau2,k)
{
  r=tau2/tau1;
  s1=exp((r+1));

  deltat = -tau1* ( 2*r -2*r*s1 +r^2 -1 )/( (r*s1+1)*(r+1));
  dw     = k^2*(r*s1+1)*exp(-( 3*r*s1+2*r^2*s1+r^3*s1+2 ) /((r*s1+1)*(r+1)) )/((r+1)^2);

  return(c(deltat,dw))
}

mwns<-function(tau1,tau2,k)
{
  r=tau2/tau1;
  if(tau1>=tau2)
  {
    deltat = 2*tau1/(r+1);
    dw     = k^2*r*exp(-(2/(r+1)))/(r+1)^2;
  }
  else
  {
    deltat = tau1*(-r^2+2*r+1)/(r+1);
    dw     = k^2*r^2*exp(-(2*r/(r+1)))/(r+1)^2;
  }

  return(c(deltat,dw))
}

mwsn<-function(tau1,tau2,k)
{
  r=tau2/tau1;
  if(tau1>=tau2)
  {
    deltat = -tau1*(r^2+2*r-1)/(r+1);
    dw     = k^2*exp(-(2/(r+1)))/(r+1)^2;
  }
  else
  {
    deltat = -2*r^2*tau1/(r+1);
    dw     = k^2*r*exp(-(2*r/(r+1)))/(r+1)^2;
  }

  return(c(deltat,dw))
}

dwnnh<-function(deltat,tau1,tau2,k)
{
  y =
  exp(-(deltat+tau1+tau2)/tau1)*
  k^2*
  (-tau1^2+2*tau1*tau2+tau2^2+deltat*(tau1+tau2)
   )/
  (tau1+tau2)^3;

  return(y);
}

dwnnl<-function(deltat,tau1,tau2,k)
{
  y =
  -exp(-(-deltat+tau1+tau2)/tau2)*
  k^2*
  (-tau1^2-2*tau1*tau2+tau2^2+deltat*(tau1+tau2)
   )/
  (tau1+tau2)^3;
  return(y);
}

dwnph<-function(deltat,tau1,tau2,k)
{
  y =
  exp(-(deltat+tau1+tau2)/tau1)*
  k^2*
  (
   exp(1+tau2/tau1)*
   tau2*(-2*tau1^2+deltat*(tau1+tau2))+
   tau1*(-tau1^2+2*tau1*tau2+tau2^2+deltat*(tau1+tau2))
   )/
  (tau1*(tau1+tau2)^3);
  return(y);
}

dwnpl<-function(deltat,tau1,tau2,k)
{

  y =
  -exp(-(deltat*tau2+(tau1+tau2)^2)/(tau1*tau2))*
  k^2*
  (
   exp(1+(tau1/(tau2)))*
   (tau1^2-2*tau1*tau2-tau2^2-deltat*(tau1+tau2))+
   exp(((deltat+tau2)*(tau1+tau2))/(tau1*tau2))*
   (tau1^2+2*tau1*tau2-tau2^2-deltat*(tau1+tau2))
   )/ ((tau1+tau2)^3);
  return(y);
}

dwnsh<-function(deltat,tau1,tau2,k)
{

  y =
  exp(-deltat/tau1)*
  k^2*
  tau2*(tau1*(-tau1+tau2)+deltat*(tau1+tau2))/
  (tau1+tau2)^3;

  return(y);
}

dwnsl<-function(deltat,tau1,tau2,k)
{

  y =
  exp(-(-deltat+tau1+tau2)/tau2)*
  k^2*
  tau2*(-deltat*(tau1+tau2)+tau1*(tau1+3*tau2))/
  (tau1+tau2)^3;

  return(y);
}

dwpnh<-function(deltat,tau1,tau2,k)
{

  y =
  exp(-(deltat*tau2+(tau1+tau2)^2)/(tau1*tau2))*
  k^2*
  (
   exp(1+((tau1)/(tau2)))*
   (tau1^2-2*tau1*tau2-tau2^2-deltat*(tau1+tau2))+
   exp(((deltat+tau2)*(tau1+tau2))/(tau1*tau2))*
   (tau1^2+2*tau1*tau2-tau2^2-deltat*(tau1+tau2))
   )/
  ((tau1+tau2)^3);
  return(y);
}

dwpnl<-function(deltat,tau1,tau2,k)
{

  y =
  -exp(-(-deltat+tau1+tau2)/(tau2))*
  k^2*
  (
   tau2*(-tau1^2-2*tau1*tau2+tau2^2+deltat*(tau1+tau2))+
   exp(1+((tau1)/(tau2)))*
   tau1*(2*tau2^2+deltat*(tau1+tau2))
   )/
  (tau2*((tau1+tau2)^3));

  return(y);
}

dwpph<-function(deltat,tau1,tau2,k)
{

  y =
  exp(-1-deltat/(tau1)-(tau1)/(tau2))*
  k^2*
  (
   -exp(1+tau1/tau2)*
   tau2*(-2*tau1^2+deltat*(tau1+tau2))+
   exp(deltat*(1/tau1+1/tau2))*
   tau1*(-tau1^2-2*tau1*tau2+tau2^2+deltat*(tau1+tau2))
   )/
  (tau1*(tau1+tau2)^3);
  return(y);
}

dwppl<-function(deltat,tau1,tau2,k)
{
  y =
  exp(-(deltat+tau1+tau2)/(tau1))*
  k^2*
  (
   -tau2*(-tau1^2+2*tau1*tau2+tau2^2+deltat*(tau1+tau2))+
   exp(((deltat+tau2)*(tau1+tau2))/(tau1*tau2))*
   tau1*(2*tau2^2+deltat*(tau1+tau2))
   )/
  (tau2*((tau1+tau2)^3));

  return(y);
}

dwppml<-function(deltat,tau1,tau2,k)
{

  y =
  exp(-(-deltat+tau1+tau2)/tau2)*
  k^2*
  (tau2*(-tau1^2-2*tau1*tau2+tau2^2 +
         deltat*(tau1+tau2))+
   exp(1+tau1/tau2)*
   tau1*(2*tau2^2+deltat*(tau1+tau2))
   )/(tau2*(tau1+tau2)^3);

  return(y);
}

dwppmr<-function(deltat,tau1,tau2,k)
{
  y =
  exp(-(deltat+tau1+tau2)/tau1)*
  k^2*
  (
   -deltat*(tau1+tau2)*
   (tau1+exp(1+tau2/tau1)*tau2)+
   tau1*(tau1^2+2*(-1+exp(1+tau2/tau1))*tau1*tau2-tau2^2)
   )/
  (tau1*(tau1+tau2)^3);

  return(y);
}

dwpsh<-function(deltat,tau1,tau2,k)
{

  y =
  exp(-1-deltat/tau1-tau1/tau2)*
  k^2*
  tau2* (
         exp(1+tau1/tau2)*(tau1*(tau1-tau2)-deltat*(tau1+tau2))+
         exp(deltat*(1/tau1+1/tau2))*
         (-deltat*(tau1+tau2)+tau1*(tau1+3*tau2))
         )/
  (tau1+tau2)^3;

  return(y);
}

dwpsl<-function(deltat,tau1,tau2,k)
{

  y =
  -exp(-(-deltat+tau1+tau2)/tau2)*
  k^2*
  (
   exp(1+tau1/tau2)*
   tau1*(tau2*(-tau1+tau2)+deltat*(tau1+tau2))+
   tau2*(deltat*(tau1+tau2)-tau1*(tau1+3*tau2))
   )/
  (tau1+tau2)^3;
  return(y);
}

dwsnh<-function(deltat,tau1,tau2,k)
{

  y =
  exp(-((deltat+tau1+tau2)/tau1))*
  k^2*
  tau1*(deltat*(tau1+tau2)+tau2*(3*tau1+tau2))/
  (tau1+tau2)^3;

  return(y);
}

dwsnl<-function(deltat,tau1,tau2,k)
{
  y =
  -exp(deltat/tau2)*
  k^2*
  tau1*(tau2*(-tau1+tau2)+deltat*(tau1+tau2))/
  (tau1+tau2)^3;

  return(y);
}

dwsph<-function(deltat,tau1,tau2,k)
{

  y =
  exp(-(deltat+tau1+tau2)/tau1)*
  k^2*
  (
   exp(1+tau2/tau1)*
   tau2*(tau1*(-tau1+tau2)+deltat*(tau1+tau2))+
   tau1*(deltat*(tau1+tau2)+tau2*(3*tau1+tau2))
   )/
  (tau1+tau2)^3;

  return(y);
}

dwspl<-function(deltat,tau1,tau2,k)
{

  y =
  exp(-((deltat+tau1+tau2)/tau1))*
  k^2*
  tau1*(
        deltat*tau1+
        deltat*tau2+
        3*tau1*tau2+
        tau2^2+
        exp((deltat+tau2)*(tau1+tau2)/(tau1*tau2))*
        (tau2*(-tau1+tau2)+deltat*(tau1+tau2)))/
  (tau1+tau2)^3;

  return(y);
}

icomponents<-function(
                width=4,
                height=6,
                name='',
                EPS=FALSE,
                dt=.01,
                tau1=1,
                tau2=1,
                k=1,
                gpp=0,
                gnp=0,
                gpn=0,
                gnn=0,
                eps=0,
                esp=0,
                ens=0,
                esn=0)
{

  id=diag(8);

  gap=.01;
  range=seq(-20,20,gap);
  trange=length(range);
  tt=1:trange;
  w=rep(0,length(range));

  if ( tau1 >= tau2 ) {
    t = 1;
    for (deltat in range)
    {
      if ( deltat <= -tau2 )
      {
        w[t] =
        gnn*dwnnl(deltat,tau1,tau2,k)   +
        gpn*dwpnl(deltat,tau1,tau2,k)  +
        esn*dwsnl(deltat,tau1,tau2,k)  +
        ens*dwnsl(deltat,tau1,tau2,k) +
        eps*dwpsl(deltat,tau1,tau2,k);
      } else if ( deltat <= 0 )
      {
        w[t] =
        gpp*dwppl(deltat,tau1,tau2,k)  +
        gnn*dwnnl(deltat,tau1,tau2,k)  +
        gpn*dwpnh(deltat,tau1,tau2,k)  +
        esn*dwsnh(deltat,tau1,tau2,k)  +
        ens*dwnsl(deltat,tau1,tau2,k)  +
        esp*dwspl(deltat,tau1,tau2,k)  +
        eps*dwpsl(deltat,tau1,tau2,k);
      } else if ( deltat <= (tau1 - tau2) )
      {
        w[t] =
        gpp*dwppmr(deltat,tau1,tau2,k)  +
        gnn*dwnnl(deltat,tau1,tau2,k)   +
        gpn*dwpnh(deltat,tau1,tau2,k)   +
        esn*dwsnh(deltat,tau1,tau2,k)  +
        ens*dwnsl(deltat,tau1,tau2,k)  +
        esp*dwsph(deltat,tau1,tau2,k)  +
        eps*dwpsh(deltat,tau1,tau2,k);
      } else if ( deltat <= tau1 )
      {
        w[t] =
        gpp*dwpph(deltat,tau1,tau2,k)  +
        gnn*dwnnh(deltat,tau1,tau2,k)  +
        gnp*dwnpl(deltat,tau1,tau2,k)  +
        esn*dwsnh(deltat,tau1,tau2,k)  +
        ens*dwnsl(deltat,tau1,tau2,k)  +
        esp*dwsph(deltat,tau1,tau2,k)  +
        eps*dwpsh(deltat,tau1,tau2,k);
      } else
      {
        w[t] =
        gnn*dwnnh(deltat,tau1,tau2,k)  +
        gnp*dwnph(deltat,tau1,tau2,k)  +
        esn*dwsnh(deltat,tau1,tau2,k)  +
        ens*dwnsh(deltat,tau1,tau2,k) +
        esp*dwsph(deltat,tau1,tau2,k);
      }
      t = t + 1;
    }
  }
  else
  {
    t = 1;
    for (deltat in range)
    {
      if ( deltat <= -tau2 )
      {
        w[t] =
        gnn*dwnnl(deltat,tau1,tau2,k)   +
        gpn*dwpnl(deltat,tau1,tau2,k)   +
        esn*dwsnl(deltat,tau1,tau2,k)   +
        ens*dwnsl(deltat,tau1,tau2,k)   +
        eps*dwpsl(deltat,tau1,tau2,k);
      } else if ( deltat <= (tau1 - tau2) )
      {
        w[t] =
        gpp*dwppl(deltat,tau1,tau2,k)   +
        gnn*dwnnl(deltat,tau1,tau2,k)   +
        gpn*dwpnh(deltat,tau1,tau2,k)   +
        esn*dwsnh(deltat,tau1,tau2,k)   +
        ens*dwnsl(deltat,tau1,tau2,k)   +
        esp*dwspl(deltat,tau1,tau2,k)   +
        eps*dwpsl(deltat,tau1,tau2,k);
      } else if ( deltat <= 0 )
      {
        w[t] =
        gpp*dwppml(deltat,tau1,tau2,k)  +
        gnn*dwnnh(deltat,tau1,tau2,k)   +
        gnp*dwnpl(deltat,tau1,tau2,k)   +
        esn*dwsnh(deltat,tau1,tau2,k)   +
        ens*dwnsl(deltat,tau1,tau2,k)   +
        esp*dwspl(deltat,tau1,tau2,k)   +
        eps*dwpsl(deltat,tau1,tau2,k);
      } else if ( deltat <= tau1 )
      {
        w[t] =
        gpp*dwpph(deltat,tau1,tau2,k)   +
        gnn*dwnnh(deltat,tau1,tau2,k)   +
        gnp*dwnpl(deltat,tau1,tau2,k)   +
        esn*dwsnh(deltat,tau1,tau2,k)   +
        ens*dwnsl(deltat,tau1,tau2,k)   +
        esp*dwsph(deltat,tau1,tau2,k)   +
        eps*dwpsh(deltat,tau1,tau2,k);
      } else
      {
        w[t] =
        gnn*dwnnh(deltat,tau1,tau2,k)   +
        gnp*dwnph(deltat,tau1,tau2,k)   +
        esn*dwsnh(deltat,tau1,tau2,k)   +
        ens*dwnsh(deltat,tau1,tau2,k)   +
        esp*dwsph(deltat,tau1,tau2,k);
      }
      t = t + 1;
    }
  }

  graphics.off();

  xgap=range[length(range)]/4;
  xlim=c((range[1]-4*xgap),range[length(range)]+3*xgap)
  ylim=c(-3*max(w)/10,max(w)+3*(max(w)/10))
  axlim=c((range[1]-xgap/2),range[length(range)]+xgap/2)
  aylim=c(-3*max(w)/10,max(w)+3*(max(w)/10))

  if(EPS==TRUE) {
    postscript(
               paste('integral_component_',name,'.eps',sep=''),
               onefile=FALSE,
               horizontal=FALSE,
               width=width,height=height,
               pointsize=11,
               family="Times");
  }

  par(mar=c(100,100,1,1)*.005)

  plot(
       range,
       w,
       type='l',
       frame.plot=FALSE,
       axes=FALSE,
       xlab='',
       ylab='',
       lwd=1,
       xlim=xlim,
       ylim=ylim,
       family="serif")
  polygon(c(range[1],range,range[length(range)]),c(0,w,0), col='#DDDDDD',border=NA)
  lines(range,w,lwd=1);

  d<-c()
  d<-rbind(d,c(rbind(axlim,aylim*0)))
  d<-rbind(d,c(rbind(axlim*0,aylim)))
  arrows(d[,1],d[,2],d[,3],d[,4],lwd=1,length=.08,code=3);

  rr = (aylim[2]-aylim[1])/2;

  kappa=(k/100)/2;

  arrows(
         axlim[1]-10,
         rr-kappa,
         axlim[1]-10,
         rr+kappa,
         ,lwd=.5,length=.01,angle=90,code=3);
  text(axlim[1]-8,(aylim[2]-aylim[1])/2,expression( paste("") %prop% italic(kappa)),adj=c(.1,.5),cex=1)

  arrows(
         axlim[2]+6,
         rr+rr/8,
         (axlim[2]+6)-tau1,
         rr+rr/8,
         ,lwd=.5,length=.01,angle=90,code=3);
  text(axlim[2]+10,
         rr+rr/8,
       expression(italic(tau[1])),adj=c(.5,.5),cex=1)
  arrows(
         axlim[2]+6,
         rr-rr/8,
         (axlim[2]+6)-tau2,
         rr-rr/8,
         ,lwd=.5,length=.01,angle=90,code=3);
  text(axlim[2]+10,
         rr-rr/8,
       expression(italic(tau[2])),adj=c(.5,.5),cex=1)

  lmax<-c('pp','np','pn','nn','ps','sp','ns','sn')
  cc<-sum(c(gpp,gnp,gpn,gnn,eps,esp,ens,esn)*1:8);

  #ssubs=substitute(w[index],list(index=lmax[cc]));
  ssubs="w";
  text(-1.2*xgap,ylim[2]-(1/20)*ylim[2],substitute(bolditalic(paste(Delta,index,sep='')),list(index=ssubs)),cex=1)
  text(axlim[2]+6,0,expression(italic(paste(Delta,t))),adj=c(.5,.5),cex=1)
  text(axlim[1]-12,0,expression(italic(-paste(Delta,t))),adj=c(.5,.5),cex=1)

  # if(tau2>tau1) {
    # txt=expression(italic(tau[1]<tau[2]));
  # } else if(tau1>tau2) {
    # txt=expression(italic(tau[2]<tau[1]));
  # }
  # else {
    # txt=expression(italic(tau[1]==tau[2]));
  # }
  # text(4*xgap,ylim[2]-(1/20)*ylim[2],txt,cex=1)
#
  p=c(0,0);
  if(gnp==1)
  {
    p=mwnp(tau1,tau2,k);
  } else if(gnn==1) {
    p=mwnn(tau1,tau2,k);
  } else if(gpp==1) {
    p=mwpp(tau1,tau2,k);
  } else if(gpn==1) {
    p=mwpn(tau1,tau2,k);
  } else if(eps==1) {
    p=mwps(tau1,tau2,k);
  } else if(esp==1) {
    p=mwsp(tau1,tau2,k);
  } else if(ens==1) {
    p=mwns(tau1,tau2,k);
  } else if(esn==1) {
    p=mwsn(tau1,tau2,k);
  }

  tc<-c(axlim[2]-axlim[2]*1/8,aylim[2]-aylim[2]*1/8);
  gap=c(axlim[2]*1/32,aylim[2]*1/32)

  #text(p[1]+3*gap[1],p[2],substitute(italic(M[index]),list(index=lmax[cc])),adj=c(.1,.1),cex=2)

  points(p[1],p[2],cex=.5,pch=21,bg='#999999');

  if(EPS==TRUE) {
    dev.off();
  }

}

allcomponents<-function()
{

  labels=c('gpp','gnp','gpn','gnn','eps','esp','ens','esn')
  taus=c('t2t1','tt','t1t2')

  k=1
  for(tau2 in c(2,3,4))
  {
    for(x in 1:8)
    {

      cmp=rep(0,8);
      cmp[x]=1;
      icomponents(tau1=3,tau2=tau2,
                  EPS=TRUE,
                  width=1.7,height=1,
                  name=paste(labels[x],'_',taus[k],sep=''),
                  gpp=cmp[1],
                  gnp=cmp[2],
                  gpn=cmp[3],
                  gnn=cmp[4],
                  eps=cmp[5],
                  esp=cmp[6],
                  ens=cmp[7],
                  esn=cmp[8])
    }
    k=k+1;
  }

}


df1 <- read.csv('/Users/saugat/Downloads/2006.csv')
df2 <- read.csv('/Users/saugat/Downloads/2007.csv')
df3 <- read.csv('/Users/saugat/Downloads/2008.csv')

rm(df1, df2, df3)

myDataFile <- rbind(df1, df2, df3)

sum(myDataFile$Origin == 'LAX')

# This has lot of zero values
myTable1 <- table(myDataFile$Origin, myDataFile$Dest)
dim(myTable1)

# Does the same as myTable1 but efficiently
myTable2 <- table(paste(myDataFile$Origin, myDataFile$Dest))
dim(myTable2)

sum(myDataFile$Origin == 'BOS' & myDataFile$Dest == 'DEN' & myDataFile$Year == 2007)
sum(myDataFile$Origin == 'IND' & myDataFile$Dest == 'ORD')

plot(myTable1)
dotchart(myTable1)

v <- myTable1['IND', ]

v[v != 0]
dotchart(sort(v[v > 4000]))

airportsDataFile <- read.csv('/Users/saugat/Downloads/airports.csv')
w <- paste(airportsDataFile$airport, airportsDataFile$city, airportsDataFile$state, sep=", ")
names(w) <- airportsDataFile$iata

head(w)
table(airportsDataFile$city == 'Chicago')

caliAirports <- subset(airportsDataFile, state == 'CA')

# Not sure why this is showing "factor"
class(caliAirports$iata)

c <- table(myDataFile$Origin)[as.character(caliAirports$iata)]
length(c[!is.na(c)])

activeAirports <- function(userState) {
  airports <- subset(airportsDataFile, state == userState)
  a <- table(myDataFile$Origin)[as.character(airports$iata)]
  subset(airportsDataFile, iata %in% names(a[!is.na(v)]))
}

activeAirports('CA')
activeAirports('IL')

sapply(state.abb, function(x) dim(activeAirports(x))[1])

planeDataFile <- read.csv('/Users/saugat/Downloads/airports.csv')

sum(myDataFile$TailNum == 'N556AS', na.rm = TRUE)

ddmmyy <- paste(myDataFile$DayofMonth, month.abb[myDataFile$Month], myDataFile$Year)
tail(sort(tapply(myDataFile$Origin, ddmmyy, length)))


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

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

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

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

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

dev.off()


source('common/src/utils/apply_transformations.r')

petals = read.csv("common/data/raw/iris_petals.csv")

feats = names(petals)
ignore_cols = c("Flower.Id")
feats = feats[-which(feats %in% ignore_cols)]

transformations = list(
  log1p = log1p,
  cubd = function(x) x^3
)

addl_features = apply_transformations(petals, feats, transformations)

petal_features = cbind(petals, addl_features)
save(petal_features, file='common/data/processed/petal_features.rdata')


#' Creates square landscape on which community will be simulated.
#'
#' @param size Size of square landscape.
#' @param roughness Level of spatial autocorrelation.
#'
#' @return Landscape
#' @export
#'
#' @examples
#' sim_arena(size = 256, roughness = 0.75)

sim_arena <- function(size = 256, roughness = 0.75){
  size <- size + 2
  md <- NLMR::nlm_mpd(ncol = size, nrow = size, roughness = roughness, torus = T)
  val <- raster::values(md)
  mat <- matrix(val, nrow = sqrt(length(val)))
  if ((size %% 2) == 0){
    mat <- mat[-nrow(mat), -ncol(mat)] * 100
  } else {
    mat <- mat * 100
  }

  return(mat)
}


theme_set(theme_bw(18))

setwd("~/cogsci/projects/stanford/projects/overinformativeness/models/6_qualitative_nom_L0/")
source("rscripts/helpers.R")

d = read.table(file="listenerOutput.csv",sep=",", header=F, quote="")
colnames(d) = c("t_sub","d_sub","t_basic","d_basic","t_super","d_super","Utterance","Referent","Probability")

agr = d %>%
  filter(Referent == "target" & Utterance == "sub" & t_basic == 1 & d_basic == 1) %>%
  select(t_sub,d_sub,t_basic,d_basic,Utterance,Probability) #%>%
  # gather(Utterance,Mentioned,-t_t, -t_d1) %>%
  # group_by(Utterance,t_t, t_d1) %>%
  # summarise(Probability=mean(Mentioned),ci.low=ci.low(Mentioned),ci.high=ci.high(Mentioned))
agr = as.data.frame(agr)
# agr$YMin = agr$Probability - agr$ci.low
# agr$YMax = agr$Probability + agr$ci.high
head(agr)

ggplot(agr, aes(x=t_sub,y=d_sub,color=Probability)) +
  geom_point(size=8,shape=15) +
  scale_colour_gradientn(colors=rev(rainbow(4,start=0,end=4/6)),name="Probability of\ntarget choice") +
  xlab("Target typicality") +
  ylab("Distractor typicality")
ggsave("L0probs.png",width=5.6,height=3.5)#,dpi=1400)

# t_t = targetTypicality
# t_d1 = distr1Typicality (=distr2Typicality)
# p_l_t = literal listener probability to pick target
# p_l_d1 = literal listener probability to pick distractor1
# p_l_d2 = literal listener probability to pick distractor2


library(ggplot2)

# Input data & output figure
fn_i <- '../data/bnc_10K_lz77_sentences.txt'
fn_o <- 'bnc_10K_lz77_sentences.pdf'

# Plot
pdf(fn_o, height=6, width=8)
p <- ggplot(data=read.table(header=T, file=fn_i), aes(x=length, y=ratio))
p <- p + geom_line() + geom_point()
p <- p + xlab("Sequence length (characters)")
p <- p + ylab("Compression Ratio (original / compressed)")
p <- p + theme_bw()
p
dev.off()


sapply(mapply(compose,f1,f2),do.call,list(.5))


# 4. faza: Analiza podatkov

#Samostojni grafi
SkupnaTabela$Drzava <- factor(SkupnaTabela$Drzava,levels=SkupnaTabela %>% arrange(Visina.place) %>% .$Drzava,
                             ordered = TRUE)

pobarvane_drzave = c("Switzerland","Slovenia", "Egypt")
indeksi_barv=which(rev(levels(SkupnaTabela$Drzava))%in%pobarvane_drzave)
barve = c(rep(NA,nrow(SkupnaTabela)))
barve[indeksi_barv] = "red"

grafBDP <- ggplot(data =SkupnaTabela) +
  geom_bar(aes(x= reorder(Drzava, Vrednost.BDP), y=Vrednost.BDP,fill=barve),stat = "Identity", show.legend = F)+
  coord_flip() +
  theme(axis.text.x = element_text(angle = 90, hjust = 1),text = element_text(size=7)) +
  xlab("Država") + ylab("Vrednost BDP") + ggtitle("Vrednost BDP za države po svetu")

grafPlace <-ggplot(data=SkupnaTabela) +
  geom_bar(aes(x=Drzava, y=Visina.place,fill=barve),stat = "Identity", show.legend = F)+
  coord_flip() +
  theme(axis.text.x = element_text(angle = 90, hjust = 1),text = element_text(size=7)) +
  xlab("Država") + ylab("Višina plače") + ggtitle("Višina plače v državah po svetu")

#Iskal povezave med grafi

grafPlaceBDP <- ggplot(SkupnaTabela, aes(x = Visina.place, y = Vrednost.BDP)) +
  geom_point() +
  geom_smooth(method = loess) +
  xlab("Višina plače") + ylab("Vrednost BDP")

grafStarostPlace <- ggplot(SkupnaTabela, aes(x = Povprecje.let, y = Visina.place)) +
  geom_point() +
  geom_smooth(method = loess) +
  xlab("Starost") + ylab("Višina plače")

grafPlaceIzobrazba <- ggplot(SkupnaTabela, aes(x = Visina.place, y = Indeks.izobrazbe)) +
  geom_point() +
  geom_smooth(method =  loess) +
  xlab("višina plače") + ylab("Indeks izobrazbe")

grafPlaceKriminal <- ggplot(SkupnaTabela, aes(x = Visina.place, y = Stopnja.kriminala)) +
  geom_point() +
  geom_smooth(method =  loess) +
  xlab("Višina plače") + ylab("Stopnja kriminala")

grafPlaceZivljenjskistroski <- ggplot(SkupnaTabela, aes(x = Visina.place, y = Zivljenjski.stroski)) +
  geom_point() +
  geom_smooth(method =  loess)  +
  xlab("Višina plače") + ylab("Indeks življenjskih stroškov")

grafIzobrazbaZivljenjskistroski <- ggplot(SkupnaTabela, aes(x = Indeks.izobrazbe , y = Zivljenjski.stroski )) +
  geom_point() +
  geom_smooth(method =  loess) +
  xlab("Indeks izobrazbe") + ylab("Indeks življenjskih stroškov")

grafStarostIzobrazba <- ggplot(SkupnaTabela, aes(x = Povprecje.let, y = Indeks.izobrazbe )) +
  geom_point() +
  geom_smooth(method = loess) +
  xlab("Starost") + ylab("Indeks izobrazbe")