library(gridExtra)
library(tidyverse)
library(deSolve)
library(ggplot2)
library(plotly)
library(shinythemes)
library(shinyjs)
#library(covdata)

## Configuration
theme_set(theme_minimal(base_size = 12))

## CONSTANTS

# Population size
N <- 1394000

# Rate at which person stays in the infectious compartment (disease specific and tracing specific)
gamma <- 0.14

# Initial number of infected people
n_init <- 1

x_max = 365
max_time <- 365
# # Grid where to evaluate
# max_time <- 365 # 150
# times <- seq(0, max_time, by = 0.1)

# R0 for the beta and gamma values
# R0 <- beta*N/gamma

# calculate beta
# Infectious contact rate - beta = R0/N*gamma and when R0  ~2.25 then  2.25/N*gamma
# beta <- 4.5e-07

# Function to compute the derivative of the ODE system
# -----------------------------------------------------------
#  t - time
#  y - current state vector of the ODE at time t
#  parms - Parameter vector used by the ODE system (beta, gamma)

diffsdp<-function(sdp)
{
  # Compute the square of integer `n`
  dif <- as.numeric(as.Date(sdp) - as.Date("2020-03-03"))
  return(dif)
}

sir <- function(t, y, parms,
                social_dist_period,
                reduction) {

  beta0 <- parms[1]
  gamma <- parms[2]

  #print(social_dist_period)

  if (t <= social_dist_period[1]) {
    beta_t = beta0;
    #cat('1. This is loop number',t)
  }
  else if (t >=social_dist_period[1] && t <= social_dist_period[2]) {
    beta_t =  beta0 * reduction[1];
    #cat('2. This is loop number',t)
  }
  else if (t >=social_dist_period[2] && t <= social_dist_period[3]) {
    beta_t =  beta0 * reduction[2];
    #cat('3. This is loop number',t)
  }
  else if (t >=social_dist_period[3] && t <= social_dist_period[4]) {
    beta_t =  beta0 * reduction[3];
    #cat('3. This is loop number',t)
  }
  else {
    beta_t =  beta0 * reduction[4];
    #cat('4. This is loop number',t)
  }

  # Reduce contact rate
  #beta_t <- if_else(t <= social_dist_period[1],
  #                  beta0,
  #                  if_else(t <= social_dist_period[2],
  #                          beta0 * reduction[1],
  #                          beta0 * reduction[2]
  #                  )
  #)

  S <- y[1]
  I <- y[2]
  R <- y[3]
  return(list(c(S = -beta_t * S * I,
                I =  beta_t * S * I - gamma * I,
                R =  gamma * I)))
}

## we assume that some globals exist...
solve_ode <- function(sdp, red, typ, beta, max_time) {

  # Grid where to evaluate
  times <- reactive({ seq(0, max_time, by = 0.1) })

  ode_solution <- lsoda(y = c(N - n_init, n_init, 0),
                        times = times(),
                        func  = sir,
                        parms = c(beta, gamma),
                        social_dist_period = sdp,
                        reduction = red) %>%
    as.data.frame() %>%
    setNames(c("t", "S", "I", "R")) %>%
    mutate(beta = beta,
           gama = gamma,
           R0 = N * beta / gamma,
           s  = S,
           i  = I,
           type = typ)

  daily <- ode_solution %>%
    filter(t %in% seq(0, max_time, by = 1)) %>%
    mutate(C = if_else(row_number() == 1, 0, lag(S, k = 1) - S),
           c = C)

  daily
}

# add results with intervention and plot
run <- function(sdp, red, r0, max_time) {
  #print(sdp)
  #print("sdp")
  #print(sdp2)
  #print("sdp2")
  print(red)
  shinyjs::logjs(red)
  #print("red")

  beta <- r0 / N * gamma

  ode_solution_daily <- solve_ode(
    sdp = c(0, max_time,max_time,max_time),  # social_dist_period
    red = c(1, 1, 1, 1),         # reduction
    typ = "If there was no Lockdown",
    beta = beta,
    max_time
  )

  # solve with interventions
  ode_solution2_daily <- solve_ode(
    sdp = sdp,
    red = red,
    typ = "with Lockdown",
    beta = beta,
    max_time
  )

  # solve with interventions
  #ode_solution3_daily <- solve_ode(
  #  sdp = sdp2,
  #  red = c(0.66, 0.8),
  #  typ = "with Lockdown2",
  #  beta = beta,
  #  max_time
  #)

  # Combine the two solutions into one dataset
  ode_df <- rbind(ode_solution_daily, ode_solution2_daily)

}

plot_lockdown <- function(ode_df, sdp) {
  #print("Plot Result")
  #print(sdp)
  #print(ode_df)
  #write.csv(x=ode_df, file="ode_df")
  max_time = 365
  # The final size in the two cases:
  final_sizes <- ode_df %>%
    group_by(type) %>%
    filter(row_number() == n()) %>%
    mutate("Proportion Infected" = scales::percent(1 - s, accuracy = 1)) %>%
    select("Proportion Infected", interventions = type) %>%
    arrange(desc(interventions))

  # Plot
  y_axis_fixed = FALSE
  if (y_axis_fixed) {
    y_max <- 0.09
  } else {
    y_max <- max(ode_df$c, na.rm = TRUE) * 1.05
  }
  y_arrow <- y_max * 0.975
  y_text  <- y_arrow + y_max * 0.01
  col_sdp <- "deeppink4"

  x_labs <- sort(c(0, 150, 200, 300, 365, sdp))
  start = as.Date("2020-03-03")
  ode_df$date <- as.Date(ode_df$t+start)

  pp <-ggplotly(
    ggplot(ode_df,
           aes(x = t,
               y = 0,
               xend = t,
               yend = c,
               color = type,
               name = date)) +
      geom_segment(alpha = 0.7) +
      geom_line(aes(x = t, y = c)) +
      labs(
        x = "Days from first known case",
        y = "Forecasts for Infected Daily",
        subtitle = "Daily new cases",
        caption  = "SIQ: Separate, Isolate and Quarantine period") +
      scale_x_continuous(labels = x_labs,
                         breaks = x_labs) +
      scale_y_continuous(limits = c(0, y_max), labels = scales::comma) +
      #scale_color_brewer(name = "Key",
      #                   type = "qual",
      #                   palette = 6,
      #                   guide = guide_legend(reverse = TRUE)) +
      # sdp
      #geom_hline(yintercept = 10900, color = "deeppink4") +
      geom_vline(xintercept = sdp, lty = 2, color = "gray30") +
      geom_text(aes(x = 10 + sdp[1] + (sdp[2] - sdp[1])/2,
                    y = y_text,
                    label = "With No Lockdown"),
                vjust = 0,
                color = col_sdp) +
      geom_text(aes(x = sdp[2] + 100,
                    y = y_text,
                    label = "With Lockdowns"),
                vjust = 0,
                color = "springgreen3") +
      geom_segment(aes(
        x = sdp[1],
        y = y_arrow,
        xend = sdp[2] * 0.99, # shorten
        yend = y_arrow
      ),
      size = 0.3,
      color = col_sdp,
      arrow = arrow(length = unit(2, "mm"))) +
      geom_segment(aes(
        x = sdp[2]*1.01, # shorten
        y = y_arrow,
        xend = max_time,
        yend = y_arrow
      ),
      size = 0.3,
      color = col_sdp,
      arrow = arrow(length = unit(2, "mm")))  +
      # Add final size as table
      annotation_custom(tableGrob(final_sizes,
                                  rows = NULL,
                                  theme = ttheme_minimal(
                                    core    = list(fg_params = list(hjust = 0, x = 0.1)),
                                    rowhead = list(fg_params = list(hjust = 0, x = 0))
                                  )),
                        xmin = max_time * 0.4,
                        xmax = max_time,
                        ymin = y_max * 0.8,
                        ymax = y_max * 0.8
      )
  )
  ggplotly(pp, tooltip="c")
}

plot_predict <- function(ode_df, sdp) {
  print(sdp)
  max_time = 365

  x_labs <- sort(c(0, 200, 300, 365, sdp))
  start = as.Date("2020-03-03")
  ends = as.Date("2020-03-03")
  ode_df$date <- as.Date(ode_df$t+start)
  #filtered <- subset(ode_df, type == "with SIQ")
  result <- filter(ode_df, type == "with Lockdown")
  result$Dead <-result$C * 0.005
  total_deaths = sum(result$Dead)
  total_cases = sum(result$C)
  total_detected_cases = sum(result$C) * 0.2
  y_max <- max(result$c, na.rm = TRUE) * 1.05
  y_arrow <- y_max * 0.975
  y_text  <- y_arrow + y_max * 0.01
  col_sdp <- "deeppink4"

  result = head(result, 365)
  names(result)[names(result) == "C"] <- "daily_infections"
  result$CumulativeCases <-cumsum(result$daily_infections)
  #print(result)

  pp1 <-ggplotly(
    ggplot(result, aes(date, daily_infections)) +
      geom_bar(stat="identity", na.rm = TRUE, fill = "darkturquoise") +
      labs(
        x = "Date",
        y = "Infected Daily") + #ggtitle("Predicted Daily Infections with Lockdown Interventions") +
        #title = "Predicted Daily Infections with Lockdown Interventions") +
      geom_vline(xintercept=as.numeric(ode_df$date[sdp]), colour="gray30",linetype="dotted") +
      scale_x_date(date_breaks = "1 month", date_minor_breaks = "1 week",
                   date_labels = "%B") + theme(axis.text.x = element_text(angle = 60, hjust = 1)) +
      theme(axis.text=element_text(size=8),
            axis.title=element_text(size=8)) +
      annotate(geom="text",x=start + 45,
               y=y_max, label="Full Lockdown",fontface="bold", color = "deeppink4") +
      annotate(geom="text",x=ends + sdp[2] + 4,
               y=y_max,label="Ph 1",fontface="bold",color = "deeppink4") +
      annotate(geom="text",x=ends + sdp[3] + 4,
               y=y_max,label="Ph 2",fontface="bold",color = "deeppink4") +
      annotate(geom="text",x=ends + sdp[4] + 4,
               y=y_max,label="Ph 3",fontface="bold",color = "deeppink4") +
      annotate(geom="text",x=ends + 300,
               y=y_max, label=sprintf("Total Cases = %s",toString(ceiling(total_cases))),fontface="bold",color = "red") +
    annotate(geom="text",x=ends + 300,
             y=y_max * .9, label=sprintf("Total Detected Cases = %s",toString(ceiling(total_detected_cases))),fontface="bold",color = "red") +
    annotate(geom="text",x=ends + 300,
             y=y_max * .8, label=sprintf("Total Dead = %s",toString(ceiling(total_deaths))),fontface="bold",color = "red")
      + scale_y_continuous(labels = scales::comma)

  )
  ggplotly(pp1, tooltip="daily_infections")
}

make_summary_table <- function(ode_df, sdp) {

  start = as.Date("2020-03-03")
  ends = as.Date("2020-03-03") + sdp[1]
  ode_df$date <- as.Date(ode_df$t+start)
  prediction <- filter(ode_df, type == "with Lockdown")

  prediction$Dead <-prediction$C * 0.005
  prediction$Detected_Cases <-prediction$C * 0.1

  summary <- prediction %>%mutate(Year_Month = format(date, "%Y-%m")) %>%
    group_by(Year_Month) %>%
    summarise(total_predicted_cases = ceiling(sum(C)), total_detected_cases = ceiling(sum(Detected_Cases)), total_predicted_deaths = ceiling(sum(Dead)))

  summary <- summary[order(summary$Year_Month),]

  return(summary)

}

plot_real <- function(ode_df, sdp) {
  guy  <- read.csv(file = 'Trinidad.csv')
  guy$date <- as.Date(guy$date)
  pp3 <-ggplotly(
    ggplot(guy, aes(x=date)) +
      geom_line(aes(y = cu_cases, color = "Cumulative Cases")) +
      geom_line(aes(y = cu_deaths, color = "Cumulative Deaths")) +
      geom_point(aes(y = cases, color = "Cases", alpha=1/3), shape=1) +
      geom_point(aes(y = deaths, color = "Deaths",alpha=1/3), shape = 4) +
      scale_colour_manual("",
                          breaks = c("Cumulative Cases", "Cumulative Deaths", "Cases","Deaths"),
                          values = c("turquoise3", "red", "turquoise3","red")) #+
    #scale_y_continuous(labels = scales::comma) + geom_vline(xintercept=as.numeric(ode_df$date[sdp]), colour="gray30") +
    #annotate(geom="text",x=start + 50,
    #         y=top,label="Lockdown starts",fontface="bold", color = "deeppink4") +
    #annotate(geom="text",x=ends + sdp[1] + 30,
    #         y=top,label="Phase 1",fontface="bold",color = "deeppink4") +
    #annotate(geom="text",x=ends + sdp[2] + 30,
    #         y=top,label="Phase 2",fontface="bold",color = "deeppink4")
  )

  ggplotly(pp3)
}

plot_cum <- function(ode_df, sdp) {

  max_time = 365

  x_labs <- sort(c(0, 200, 300, 365, sdp))
  start = as.Date("2020-03-03")
  ends = as.Date("2020-03-03") + sdp[1]
  ode_df$date <- as.Date(ode_df$t+start)
  #filtered <- subset(ode_df, type == "with SIQ")
  result <- filter(ode_df, type == "with Lockdown")
  y_max <- max(result$c, na.rm = TRUE) * 1.05
  y_arrow <- y_max * 0.975
  y_text  <- y_arrow + y_max * 0.01

  col_sdp <- "deeppink4"

  result = head(result, 365)
  names(result)[names(result) == "C"] <- "daily_infections"
  result$CumulativeCases <-cumsum(result$daily_infections)
  result$Dead <-result$daily_infections * 0.005
  result$CumulativeSus <-result$S - result$Dead
  result$CumulativeDead <-cumsum(result$Dead)
  result$CumulativeRec <- result$S - result$CumulativeCases
  top = head(result$CumulativeSus, n=1) * 1.1
  #top = result["CumulativeCases"].iloc[-1]
  #print(result)

  pp3 <-ggplotly(
    ggplot(result, aes(x=date)) +
      geom_line(aes(y = CumulativeCases, color = "Cases")) +
      geom_line(aes(y = CumulativeDead, color = "Dead")) +
      geom_line(aes(y = CumulativeSus, color = "Susceptible")) +
      geom_line(aes(y = R, color = "Recovered")) +
      scale_colour_manual("",
                          breaks = c("Cases", "Dead", "Susceptible","Recovered"),
                          values = c("steelblue", "darkred", "goldenrod", "green")) +
      #scale_color_discrete(name = "Descriptions", labels = c("CumulativeCases", "CumulativeDead", "CumulativeSus", "R")) +
      scale_y_continuous(labels = scales::comma) + geom_vline(xintercept=as.numeric(ode_df$date[sdp]), colour="gray30") +
      annotate(geom="text",x=start + 40,
               y=top,label="Lockdown",fontface="bold", color = "deeppink4") +
      annotate(geom="text",x=ends + sdp[2] - 26,
               y=top,label="Ph 1",fontface="bold",color = "deeppink4") +
      annotate(geom="text",x=ends + sdp[3] - 26,
               y=top,label="Ph 2",fontface="bold",color = "deeppink4") +
      annotate(geom="text",x=ends + sdp[4] - 26,
               y=top,label="Ph 3",fontface="bold",color = "deeppink4")
  )

  ggplotly(pp3, tooltip="CumulativeCases")
}

ui <- fluidPage(theme = shinytheme("flatly"),
  titlePanel("What Happens When T&T Re-Opens? An Interactive Covid-19 SIR Policy Simulator"),
  h4("Charts update in real-time, please allow ~5 seconds for charts to load"),
  hr(),
  sidebarLayout(
    sidebarPanel(
      h3("Phase 1 of Lockdown Removal"),
      br(),
      dateInput("end",
                "Set start date:",
                value = "2020-06-08",
                format = "dd/mm/yyyy"),
      br(),
      h4("Select Policy Choices"),
      checkboxInput("foo", label = "Food Establistments and related stores re-opened", value = TRUE),
      checkboxInput("non", label = "Manufacturing & Public Section re-started", value = TRUE),
      checkboxInput("bus", label = "Medium to low risk businesses and malls re-opened", value = TRUE),
      checkboxInput("res", label = "Medium to high risk businesses re-openes (resturants, bars, cinemas, salons, offices & gyms)", value = FALSE),
      checkboxInput("gat", label = "Mass Gatherings of 25+ allowed", value = FALSE),
      checkboxInput("sch", label = "Schools re-opened", value = FALSE),
      sliderInput("sda",
                  "Control Social Distance/Mask Wearing/Hand Washing Adherance (100% is everyone follows)",
                  min   = 1,
                  max   = 100,
                  value = 60,
                  step  = 1),
      hr(),
      h3("Phase 2 of Lockdown Removal"),
      br(),
      dateInput("end2",
                "Set start date:",
                value = "2020-06-22",
                format = "dd/mm/yyyy"),
      br(),
      h4("Select Policy Choices"),
      checkboxInput("foo2", label = "Food Establistments and related stores re-opened", value = TRUE),
      checkboxInput("non2", label = "Manufacturing & Public Section re-started", value = TRUE),
      checkboxInput("bus2", label = "Medium to low risk businesses and malls re-opened", value = TRUE),
      checkboxInput("res2", label = "Medium to high risk businesses re-openes (resturants, bars, cinemas, offices, salons & gyms)", value = TRUE),
      checkboxInput("gat2", label = "Mass Gatherings of 25+ allowed", value = TRUE),
      checkboxInput("sch2", label = "Schools re-opened", value = TRUE),
      sliderInput("sda2",
                  "Control Social Distance/Mask Wearing/Hand Washing Adherance (100% is everyone follows)",
                  min   = 1,
                  max   = 100,
                  value = 50,
                  step  = 1),
      hr(),
      h3("Phase 3 of Lockdown Removal"),
      br(),
      dateInput("end3",
                "Set start date:",
                value = "2020-08-17",
                format = "dd/mm/yyyy"),
      br(),
      h4("Select Policy Choices"),
      checkboxInput("foo3", label = "Food Establistments and related stores re-opened", value = TRUE),
      checkboxInput("non3", label = "Manufacturing & Public Section re-started", value = TRUE),
      checkboxInput("bus3", label = "Medium to low risk businesses and malls re-opened", value = TRUE),
      checkboxInput("res3", label = "Medium to high risk businesses re-openes (resturants, bars, cinemas, offices, salons & gyms)", value = FALSE),
      checkboxInput("gat3", label = "Mass Gatherings of 25+ allowed", value = FALSE),
      checkboxInput("sch3", label = "Schools re-opened", value = FALSE),
      sliderInput("sda3",
                  "Control Social Distance/Mask Wearing/Hand Washing Adherance (100% is everyone follows)",
                  min   = 1,
                  max   = 100,
                  value = 70,
                  step  = 1),
      #radioButtons("sda", label = h4("Control Social Distance Adherance (Mask Wearing etc)"),
      #             choices = list("0 to 30% People wear masks in public" = 7,
      #                            "30% to 70% People wear masks in public" = 13,
      #                            "70% to 100% People wear masks in public" = 16),
      #             selected = 13),
      #radioButtons("sdo", label = h4("Social Distancing Obeyed"),
      #             choices = list("0 to 30% People object 6ft spacing" = 7,
      #                            "30% to 70% People object 6ft spacing" = 13,
      #                            "70% to 100% People object 6ft spacing" = 15),
      #             selected = 13),
      #radioButtons("hwh", label = h4("Hand Washing and Basic Hygenine"),
      #             choices = list("0 to 30% People follow" = 7,
      #                            "30% to 70% People follow" = 13,
      #                           "70% to 100% People follow" = 15),
      #             selected = 13),
      br(),
      hr(),
      tags$div("Developed by Rajev Ratan"),
      tags$div("Version 2.1, 16-May-2020"),
      tags$a(href="https://caribbeandatafam.com/","Caribbean Data Fam"),

      br(),
      width = 3,
    ),

    mainPanel(

      # Output: Tabset w/ plot, summary, and table ----
      tabsetPanel(type = "tabs",
                  tabPanel("Forecasted Cases", plotlyOutput("chart1",  height = "auto", width = "auto"),
                           DT::dataTableOutput('table', width = "55%", height = "auto")),
                  tabPanel("Forecasted Cumulative Data", plotlyOutput("chart3",  height = "auto",width = "auto")),
                  tabPanel("Actual Data", plotlyOutput("chart2",  height = "auto",width = "100%")),
                  tabPanel("What if there were no Lockdowns?", plotlyOutput("chart4",  height = "auto",width = "auto"))
                  #tabPanel("Table", tableOutput("table"))
      ),

      #br(),
      #br(),
      #hr(),
      div(HTML("Parameters Used:")),
      div(HTML("R0 of 2.25")),
      div(HTML("Gamma = 0.2, beta <- 4.5e-07 ")),
      div(HTML("beta <- 4.5e-07 ")),
      div(HTML("Population = 1,394,000")),
      div(HTML("Initial Infect People = 2")),
      div(HTML("Day 0 is 3rd March 202")),
      br(),
      width = 9
    )

  )
)

server <- function(input, output) {

  res <- reactive({

    run(sdp = c(c(30, diffsdp(input$end)), diffsdp(input$end2),  diffsdp(input$end3)),
        #sdp2 = c(c(diffsdp(input$end)),c(diffsdp(input$end2))),
        #red = c(0.4, (100-(input$red_two)/1.5)/100),
        #test =  input$mask,
        red = c(0.3, (((100 - ((-13*as.integer(input$sch)) + (-13*as.integer(input$res)) + (-13*as.integer(input$gat)) +
                                 (-10*as.integer(input$bus))+ (-10*as.integer(input$foo)) +
                                 (-10*as.integer(input$non))  ))/100)- 0.7) * (1-(as.integer(input$sda)/300)),
                (((100 - ((-13*as.integer(input$sch2)) + (-13*as.integer(input$res2)) + (-13*as.integer(input$gat2)) +
                            (-10*as.integer(input$bus2))+ (-10*as.integer(input$foo2)) +
                            (-10*as.integer(input$non2))  ))/100)- 0.7) * (1-(as.integer(input$sda2)/300)),
                (((100 - ((-13*as.integer(input$sch3)) + (-13*as.integer(input$res3)) + (-13*as.integer(input$gat3)) +
                            (-10*as.integer(input$bus3))+ (-10*as.integer(input$foo3)) +
                            (-10*as.integer(input$non3))  ))/100)- 0.7) * (1-(as.integer(input$sda3)/300))),

        #(((100 - ((-5*as.integer(input$sch2)) + (-5*as.integer(input$res2)) + (-5*as.integer(input$gat2)) +
        #           (-5*as.integer(input$bus2))+ (-5*as.integer(input$foo2))+ (-5*as.integer(input$non2)) + (-1*(10-(as.integer(input$sda2)/10) )) ))/100)- 0.4)),
        #red2 = c(0(((100 - ((-5*as.integer(input$sch)) + (-5*as.integer(input$res)) + (-4*as.integer(input$gat)) +
        #                      (-3*as.integer(input$bus))+ (-3*as.integer(input$foo))+ (-3*as.integer(input$non)) + (-1*(7-(as.integer(input$sda)/10) )) ))/100)- 0.4),
        #         (((100 - ((-5*as.integer(input$sch2)) + (-5*as.integer(input$res2)) + (-4*as.integer(input$gat2)) +
        #                     (-3*as.integer(input$bus2))+ (-3*as.integer(input$foo2))+ (-3*as.integer(input$non2)) + (-1*(7-(as.integer(input$sda2)/10) )) ))/100)- 0.4)),
        r0  = 2.25,
        max_time = 365)
    #start  = input$start,
    #
    #)
  })

  output$table <- DT::renderDataTable(make_summary_table(res(), c(c(30,diffsdp(input$end),diffsdp(input$end2),diffsdp(input$end3))) ), options=list(scrollX=T))

  output$chart1 <- renderPlotly({
    plot_predict(res(), c(c(30,diffsdp(input$end),diffsdp(input$end2)), diffsdp(input$end3)) )
  })

  output$chart2 <- renderPlotly({
    plot_real(res(), c(c(30,diffsdp(input$end),diffsdp(input$end2)), diffsdp(input$end3)) )
  })

  output$chart3 <- renderPlotly({
    plot_cum(res(), c(c(30,diffsdp(input$end),diffsdp(input$end2)), diffsdp(input$end3)) )
  })

  output$chart4 <- renderPlotly({
    plot_lockdown(res(), c(c(30,diffsdp(input$end),diffsdp(input$end2)), diffsdp(input$end3)) )
  })

}

# Run the application
shinyApp(ui = ui, server = server)


# empirical likelihood for the mean
meanlike <- function(x){
 n<- length(x)

f1<- function(lambda,x){
     x/(n-lambda*x)
    }

 sx<- sort(x)
 nt<- 40
 nlam<-40
 th<- seq(1.01*sx[1],(sx[n-1]+.99*(sx[n]-sx[n-1])),len=nt)
 theta<- NULL
 loglik<- NULL
 for (i in 1:nt){
   a<- x-th[i]
   lam <- seq(n/min(a),n/max(a),len=nlam)
   lam <- lam[c(-1,-nlam)]
   glam <-outer(lam,a,'f1')
   glam<- c(glam %*% rep(1,n))
   lam0<- approx(glam,lam,xout=0)$y
   if (is.na(lam0)==F) {   # lam0 exists
      w <- 1/(n-lam0*a)
      if (min(w)>0 & max(w)<1){  # proper distribution
        ll<- sum(log(w))
        theta<- c(theta,th[i])
        loglik <- c(loglik,ll)
      }
   } # endif
 }# endfor

 loglik<- loglik - max(loglik)
 out <- list(theta= theta, loglik=loglik)
 return(out)
} # end function


#Example  :  2   Chapter :  2.3   pageno : 58
#Purpose of Elimination matrices
I<-matrix(c(1,0,0,0,1,0,0,0,1),ncol=3)
E31<-matrix(c(1,0,-4,0,1,0,0,0,1),ncol=3)
b<-matrix(c(1,3,9),ncol=1)
Ib<-I%*%b
print(Ib)
Eb<-E31%*%b
print(Eb)


omean <- function(v) {
  m <- mean(v)
  ifelse(is.na(m), 0, m)
}


# Synthetic Data Project
# Differential private algorithm using beta, binomial, and Laplace probabilities

# Authors:
# Version:  5/14/2017

# Copyright 2017

# Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
# associated documentation files (the "Software"), to deal in the Software without restriction, including
# without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the
# following conditions:

# The above copyright notice and this permission notice shall be included in all copies or substantial
# portions of the Software.

# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT
# LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
# IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
# SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

# import Laplace distribution functions
sys.source("LaplaceDistribution.r", env=environment())

#####################################################################################
#### DP algorithm
#####################################################################################

DP.threshold <- function (S, M, epsilon, alpha, nIter=250000) {

  ### add random Laplace noise to S
  ### note that this converts S to a real number
  ### since the Laplace distribution (double exponential) is symmetric about 0,
  ### nS maybe greater than or less than S
  ### also, nS can be negative or greater than M
  nS <- S + rlaplace(1, 0, 1/epsilon)

  ### Range of S
  RangeS <- 0:M

  ### Initial value of p
  ### shape parameters of (1, 1) correspond to the uniform(0, 1) distribution
  ### use supplied initial shape parameters
  ### p = rbeta(1, alpha[1], alpha[2])
  ### note that E[rbeta(n, shape1, shape2)] = shape1/(shape1+shape2)
  ### use of rbeta(1, S, M-S) would give a theoretical mean p of S/M,
  ### but S=0 requires rbeta() to return 0, in order to satisfy a mean value of 0.00
  ### once a supplied or randomly generated value of S becomes 0, all subsequent
  ### p and S values are 0
  ### similarly, S=50 requires rbeta() mean of 1.00, once supplied or generated S=50,
  ### all subsequent S values are 50
  ### adding initial beta parameters prevents expected value numerators of zero and
  ### gives mean of (S+alpha1)/(S+alpha1+alpha2) for S=M and should be unequal to 1.00
  p <- rbeta(1, S+alpha[1], M-S+alpha[2])

  ### generate Laplace density (using random nS) for each centrality value in 0:M
  dslap <- dlaplace(RangeS, nS, 1/epsilon)

  ### Gibbs interaction
  f.iter <- function(j) {
    # update S
    # product of binomial mass (using curent p) and Laplace density for each 0:M
    prob <- dbinom(RangeS, M, prob=p)*dslap
    # randomly select one S in 0:M
    # selection weights are probability products for each 0:M
    S <- sample(RangeS, 1, prob=prob)
    # update p
    # note that E(p) = (shape par 1)/(shape par 1 + shape par 2)
    # = (alpha[1]+S)/(alpha[1]+S + alpha[2]+M-S)
    # = (alpha[1]+S)/(alpha[1]+alpha[2]+M)
    # variance = ab/((a+b)^2*(a+b+1)), where a=shape par 1, b=shape par 2
    p <<- rbeta(1, S+alpha[1], M-S+alpha[2])
  }

  ### iterate MCMC and return all but first 1,000 generated values
  if(nIter<10000)
    nIter <- 10000
  sapply(1:nIter, f.iter)[1001:nIter]

}


library(tidyverse)
library(skimr)
library(ggplot2)
library(lubridate)
library(nycflights13)
library(plotly)
library(broom)
rm(list = ls())

# Inspeciona dados do pacote nycflights13----
View(airlines)
skim(flights)
skim(weather)

# Agrupa os voos por mês, calcula o número de voos por mês, resultando em 1 linha por grupo
voosMensais <- flights %>% group_by(month) %>% summarise(numVoos = n())
ggplot(voosMensais,aes(x = month,y = numVoos)) + geom_line()

# Agrupa os voos por mês e por empresa, calcula o número de voos por mês, resultando em 1 linha por grupo
voosMensaisPorEmpresa <- flights %>% group_by(carrier,month) %>% summarise(numVoos = n())
ggplot(voosMensaisPorEmpresa,aes(x = month,y = numVoos,color = carrier)) + geom_line()

# Realiza a juncao com a base de nomes de empresas
voosMensaisPorEmpresa <- voosMensaisPorEmpresa %>% left_join(airlines, by ="carrier")
ggplot(voosMensaisPorEmpresa,aes(x = month,y = numVoos,color = name)) + geom_line()

# Teste da função de junção - Olhar os resultados para entender o efeito.

# Juncao sem especificar as variaveis - A funcao assume que todas as variaveis de mesmo nome são consideradas, mostra mensagem
voosMensaisPorEmpresa <- voosMensaisPorEmpresa %>% left_join(airlines)

# O que aconteceu aqui? - Erro
voosMensaisPorEmpresa <- voosMensaisPorEmpresa %>% left_join(airlines, by ="carrier")

# Cria a variável Data a partir de ano, mes e dia
voos <- flights %>% mutate(Data = as.Date(ISOdate(year,month,day)))

# Agrupa os voos por data e aeroporto de origem, e calcula o número de voos e o atraso médio de partida para o dia
voosDiariosEAtrasos <- voos %>% group_by(Data,origin) %>% summarise(dep_delay = mean(dep_delay,na.rm = T),departures = n())

# Gráfico de atrasos por número de voos no dia para os 3 aeroportos da base
ggplot(voosDiariosEAtrasos,aes(x = departures,y = dep_delay,color = origin))+
  geom_point()+facet_wrap(~origin,nrow = 3)+ geom_smooth(method='lm', formula= y~x)

# Criacao de uma função - recebe os vetores x e y,  realiza a regressão e retorna a tabela de coeficientes como um tibble
# Em R, uma função é gravada em uma variável como outra qualquer
coefsRegressao <- function(y,x)
{
  regressao <-  lm(y ~x)
  resumoDaRegressao <-  summary(regressao)
  M <-  resumoDaRegressao$coefficients
  return(as_tibble(cbind(Variavel = rownames(M),M)))
}

# Agrupa os dados de voos diarios e atrasos por aeroporto e realiza a regressao dos valores por aeroporto,
voosDiariosEAtrasosRegressao <- voosDiariosEAtrasos %>% group_by(origin) %>% summarise(coefsRegressao(dep_delay,departures))

# Agrupa voos por hora e por aeroporto, e conta o número de voos em cada hora
voosPorHoraEAtrasos <- voos %>% group_by(time_hour  ,origin) %>%
  summarise(dep_delay = mean(dep_delay,na.rm = T),departures = n())

# gráfico do atraso em função do número de voos em cada hora
ggplot(voosPorHoraEAtrasos,aes(x = departures,y = dep_delay,color = origin))+ geom_point()+
  facet_wrap(~origin,nrow = 3)+ geom_smooth(method='lm', formula= y~x)

# guarda os coeficientes de regressão atraso por voos na hora
voosPorHoraEAtrasosRegressao <- voosPorHoraEAtrasos %>% group_by(origin) %>% summarise(coefsRegressao(dep_delay,departures))

# juncao da informação de voos e meteorologia. Liga cada voo aos dados meteorlogicos de sua hora de partida

# Rodar e verificar o resultado para perceber o problema de não ter incluido todas as variáveis relevantes
juncaoErrada <-  left_join(voos,weather, by= c("origin","time_hour"))

colnames(juncaoErrada) # Esta função retorna o vetor de nomes das colunas da data frame. Ajuda a ver o problema
colnames(juncaoErrada)[1]

# Também serve para renomear as colunas: (exemplos do que ela faz, a função rename do dplyr é bem mais adequada para isso)
colnames(juncaoErrada)[1] <-  "Ano"
colnames(juncaoErrada)

colnames(juncaoErrada)[colnames(juncaoErrada)=="Ano"] <- "year.x"
colnames(juncaoErrada)

# Incusive múltiplas colunas de vez  - pode vir a ser útil
colnames(juncaoErrada) <- paste0("V",1:ncol(juncaoErrada))
View(juncaoErrada)

# As funcoes paste e paste0 fazem concatenacao de strings e vetores de strings
# a diferenca entre as duas é que paste adiciona o separador entre as strings
teste<- paste0("Isto é ","um teste")
print(teste)
teste <- paste0("Isto é ", c("um teste","uma maneira de confundir a cabeça das pessoas"))
print(teste)
teste <- paste0(c("Isto é ","Isto não é "), c("um teste","uma maneira de confundir a cabeça das pessoas"))
print(teste)
teste <- paste0(" Teste ", 1:10)
print(teste)
teste <- paste("Teste", 1:10) # note a inclusão do espaço como separador
print(teste)
teste <- paste("Teste",1:10,sep = " - ") # separador determinado na chamada
print(teste)
teste <- paste0(" Teste ", 1:10,collapse = ",") # collapse junta todos os strngs em um só, com a string definida em collapse entre eles
print(teste)
teste <- paste(" Teste", 1:10,collapse = ",", sep = " - ")
print(teste)

rm(juncaoErrada) # remove a variável não utilizada - poupa memória

# Outro erro - este ainda mais grave. O que ocorreu aqui?
juncaoErrada2 <-  left_join(voos,weather, by= c("year","month","day","hour","time_hour"))

rm(juncaoErrada2)

# Juncao correta
voos <- left_join(voos,weather, by= c("year","month","day","hour","origin","time_hour"))

# juncao da base de voos com a base de avioes - Notar as variaveis year no resultado
teste <-  left_join(voos,planes,by = "tailnum")
rm(teste)

# Outro erro de juncao - Qual o problema desta juncao?
juncaoErrada3 <- left_join(voos,planes)
rm(juncaoErrada3)

# Força o R a  devolver memória de variáveis removidas. O R faz isso automaticamente na maior parte das vezes.
# Às vezes é bom quando se remove uma base muito grande, só para se assegurar que o tratamento da memória está send feito corretamente
gc()

# Solução
voos <- left_join(voos,planes %>% rename(yearPlane = year),by = "tailnum")

# Na base voos, acrescenta  as colunas : departuresPerDay , precipDay e departuresPerHour
# Note o uso de group_by seguido de mutate.
# Ao contrario do summarise, ele não utiliza uma função que resume cada grupo a um valor (ou um conjunto pequeno de valors)
# Em vez disso, retorna um valor para cada linha. O agrupamento faz com que o calculado dentro da função mutate
# leve em conta apenas as linhas da tabela contidas em cada grupo

# A funcao ungroup() desfaz o agrupamento, permitindo que linhas de código subsequentes tratem a tabela de maneira não agrupada
# O summarize já realiza o ungroup, mas não o mutate ou o filter
voos <- voos %>% group_by(Data,origin) %>% mutate(departuresPerDay = n(), precipDay = sum(precip,na.rm = T)) %>% ungroup() %>%
  group_by(time_hour,origin) %>% mutate(departuresPerHour = n()) %>% ungroup()

# Sem o group_by,  o que acontece com os valores de departuresPerDay , precipDay ?
voosErroDeAgrupamento <- voos %>% mutate(departuresPerDay = n(), precipDay = sum(precip,na.rm = T))  %>%
  group_by(time_hour,origin) %>% mutate(departuresPerHour = n()) %>% ungroup()

# A variável precipDay2 é a precipDay categorizada por faixas de valores de precipitação diária
# Note o uso da funcao cut, que requer a definicao do vetor breaks, com os limites de cada faixa
# Note também que utilizei  a funcao quantiles para gerar os limites das faixas
# Fiz tudo em uma linha para mostrar que é possível fazer isso em R
voos <- voos %>% mutate(precipDay2 = cut(precipDay,breaks = c(0,quantile(precipDay,c(.75,.8,.9,.95,1),na.rm = T)),include.lowest = T))

# Boxplot para cada faixa de precipitação por dia e atraso
ggplot(voos,aes(x= precipDay2, y = dep_delay)) + geom_boxplot()+ coord_cartesian(ylim = c(-10,50))

# Scatterplot com regressão - gráfico lento pq tem um ponto por voo
ggplot(voos, aes(x= precip, y = dep_delay, color = origin ))  + geom_point() +
  facet_wrap(~origin,nrow = 3)+ geom_smooth(method='lm', formula= y~x)

# Scatterplot com regressão - gráfico lento pq tem um ponto por voo
ggplot(voos, aes(x= seats, y = dep_delay))  + geom_point() +
facet_wrap(~origin,nrow = 3)+ geom_smooth(method='lm', formula= y~x)

# Regressão de variáveis relevantes para uma análise do atraso de partida dos voos
# A funcao I() permite que a expressão não seja convertida em símbolos da regressão. Assim, criamos as dummies:
# velocidade de vento maior que 14.96014
# temperatura menor que 32F (0 grau C)

# A função factor transforma em categórica uma variável numérica, de modo que, na regressão, temos uma dummy para cada valor
  m <-  lm(data = voos, dep_delay ~  precipDay2 + I(wind_speed>=14.96014) + I(temp<=32) + origin + departuresPerDay +
         departuresPerHour+  distance   + carrier + seats + factor(hour) +factor(month) )

# Sumário da regressão
summary(m)

# Calcula atraso médio por hora do dia
voos <-  voos %>% group_by(hour) %>% mutate(meanDepDelay = mean(dep_delay,na.rm = T)) %>% ungroup()

# Boxplot atraso vs hora do dia
ggplot(voos,aes(x = factor(hour),y = dep_delay,fill = meanDepDelay)) + geom_boxplot() + coord_cartesian(ylim = c(-10,50))

# Boxplot atraso vs mes
ggplot(voos,aes(x = factor(month),y = dep_delay)) + geom_boxplot() + coord_cartesian(ylim = c(-10,50))

# Uso da funcao filter apos agrupamento:
# para cada dia e cada aeroporto de origem, deixar apenas os voos cujos atrasos são maiores que o percentil 99 daquele dia
pioresVoosdeCadaDia <- voos %>% group_by(Data,origin) %>% filter(dep_delay >= quantile(dep_delay,.99,na.rm = T)) %>% ungroup()


# accesses the 'state' variable and stores it in an object called 'state'
states <- murder$state

# sorts the object alphabetically and redefines the object
states <- sort(states)

# reports the first value alphabetically
states[1]

# the following is a test created to replicate for 'population'

# accesses population values from the dataset and stores it in pop
pop <- murders$population

# sorts the object and saves it in the same object
pop <- sort(pop)

# reports the smallest population by size
pop[1]

# not too sure on how to explain this, I just started typing and it works

# accesses the population from the dataset and stores it in pop
pop <- murders$population

# use the command order to identify the vector of indices and places pop in an order and then stores it in the object ord
ord <- order(pop)

# finds the index number of the entry with the smallest population size
ord[1]

# finds the index of the smallest value for variable total
which.min(murders$total)

# finds the index of the smallest value for population
which.min(population)


                                   CCHHAAPPTTEERR  33

                              AArriitthhmmeettiicc FFuunnccttiioonnss

               This chapter describes FRANZ LISP's functions for doing
          arithmetic.  Often the same function is known by many names.
          For  example,  _a_d_d is also _p_l_u_s, and _s_u_m.  This is caused by
          our desire to be compatible with  other  Lisps.   The  FRANZ
          LISP  user should avoid using functions with names such as +
          and * unless their arguments are fixnums.  The Lisp compiler
          takes advantage of these implicit declarations.

               An  attempt  to  divide or to generate a floating point
          result outside of the range of floating point  numbers  will
          cause  a  floating  exception signal from the UNIX operating
          system.  The user can catch and process  this  interrupt  if
          desired (see the description of the _s_i_g_n_a_l function).

             33..11..  SSiimmppllee AArriitthhmmeettiicc FFuunnccttiioonnss

          ((aadddd ['n_arg1 ...]))
          ((pplluuss ['n_arg1 ...]))
          ((ssuumm ['n_arg1 ...]))
          ((++ ['x_arg1 ...]))

               RETURNS: the  sum of the arguments. If no arguments are
                        given, 0 is returned.

               NOTE: if the size of the partial sum exceeds the  limit
                     of a fixnum, the partial sum will be converted to
                     a bignum.  If any of the arguments  are  flonums,
                     the  partial  sum  will  be converted to a flonum
                     when that argument is processed  and  the  result
                     will thus be a flonum.  Currently, if in the pro-
                     cess of doing the addition a bignum must be  con-
                     verted  into  a  flonum  an  error  message  will
                     result.

          AArriitthhmmeettiicc FFuunnccttiioonnss                                     33--11

          AArriitthhmmeettiicc FFuunnccttiioonnss                                     33--22

          ((aadddd11 'n_arg))
          ((11++ 'x_arg))

               RETURNS: its argument plus 1.

          ((ddiiffff ['n_arg1 ... ]))
          ((ddiiffffeerreennccee ['n_arg1 ... ]))
          ((-- ['x_arg1 ... ]))

               RETURNS: the result of subtracting from n_arg1 all sub-
                        sequent arguments.  If no arguments are given,
                        0 is returned.

               NOTE: See the description of add for  details  on  data
                     type conversions and restrictions.

          ((ssuubb11 'n_arg))
          ((11-- 'x_arg))

               RETURNS: its argument minus 1.

          ((mmiinnuuss 'n_arg))

               RETURNS: zero minus n_arg.

          ((pprroodduucctt ['n_arg1 ... ]))
          ((ttiimmeess ['n_arg1 ... ]))
          ((** ['x_arg1 ... ]))

               RETURNS: the  product  of  all  of  its  arguments.  It
                        returns 1 if there are no arguments.

               NOTE: See the  description  of  the  function  _a_d_d  for
                     details  and  restrictions  to the automatic data
                     type coercion.

          ((qquuoottiieenntt ['n_arg1 ...]))
          ((// ['x_arg1 ...]))

               RETURNS: the result of dividing the first  argument  by
                        succeeding ones.

               NOTE: If  there  are  no arguments, 1 is returned.  See
                     the description of the function _a_d_d  for  details
                     and restrictions of data type coercion.  A divide
                     by zero will cause a floating exception interrupt
                     -- see the description of the _s_i_g_n_a_l function.

                                             Printed: October 16, 1993

          AArriitthhmmeettiicc FFuunnccttiioonnss                                     33--33

          ((**qquuoo 'i_x 'i_y))

               RETURNS: the integer part of i_x / i_y.

          ((DDiivviiddee 'i_dividend 'i_divisor))

               RETURNS: a  list  whose  car  is the quotient and whose
                        cadr is  the  remainder  of  the  division  of
                        i_dividend by i_divisor.

               NOTE: this is restricted to integer division.

          ((EEmmuullddiivv 'x_fact1 'x_fact2 'x_addn 'x_divisor))

               RETURNS: a  list  of the quotient and remainder of this
                        operation:
                        ((x_fact1 * x_fact2) + (sign extended) x_addn) / x_divisor.

               NOTE: this is useful for creating a  bignum  arithmetic
                     package in Lisp.

             33..22..  pprreeddiiccaatteess

          ((nnuummbbeerrpp 'g_arg))

          ((nnuummbbpp 'g_arg))

               RETURNS: t  iff  g_arg  is  a number (fixnum, flonum or
                        bignum).

          ((ffiixxpp 'g_arg))

               RETURNS: t iff g_arg is a fixnum or bignum.

          ((ffllooaattpp 'g_arg))

               RETURNS: t iff g_arg is a flonum.

          ((eevveennpp 'x_arg))

               RETURNS: t iff x_arg is even.

                                             Printed: October 16, 1993

          AArriitthhmmeettiicc FFuunnccttiioonnss                                     33--44

          ((ooddddpp 'x_arg))

               RETURNS: t iff x_arg is odd.

          ((zzeerroopp 'g_arg))

               RETURNS: t iff g_arg is a number equal to 0.

          ((oonneepp 'g_arg))

               RETURNS: t iff g_arg is a number equal to 1.

          ((pplluusspp 'n_arg))

               RETURNS: t iff n_arg is greater than zero.

          ((mmiinnuusspp 'g_arg))

               RETURNS: t iff g_arg is a negative number.

          ((ggrreeaatteerrpp ['n_arg1 ...]))
          ((>> 'fx_arg1 'fx_arg2))
          ((>>&& 'x_arg1 'x_arg2))

               RETURNS: t iff the arguments are in a strictly decreas-
                        ing order.

               NOTE: In  functions _g_r_e_a_t_e_r_p and _> the function _d_i_f_f_e_r_-
                     _e_n_c_e is used to compare adjacent values.  If  any
                     of  the arguments are non-numbers, the error mes-
                     sage will come from the _d_i_f_f_e_r_e_n_c_e function.  The
                     arguments  to _> must  be fixnums or both flonums.
                     The arguments to _>_& must both be fixnums.

          ((lleesssspp ['n_arg1 ...]))
          ((<< 'fx_arg1 'fx_arg2))
          ((<<&& 'x_arg1 'x_arg2))

               RETURNS: t iff the arguments are in a strictly increas-
                        ing order.

               NOTE: In  functions _l_e_s_s_p and _< the function _d_i_f_f_e_r_e_n_c_e
                     is used to compare adjacent values.   If  any  of
                     the  arguments are non numbers, the error message
                     will come  from  the  _d_i_f_f_e_r_e_n_c_e  function.   The
                     arguments  to  _< may be either fixnums or flonums
                     but must be the same type.  The arguments  to  _<_&
                     must be fixnums.

                                             Printed: October 16, 1993

          AArriitthhmmeettiicc FFuunnccttiioonnss                                     33--55

          ((== 'fx_arg1 'fx_arg2))

          ((==&& 'x_arg1 'x_arg2))

               RETURNS: t  iff the arguments have the same value.  The
                        arguments to = must be the either both fixnums
                        or  both flonums.  The arguments to =& must be
                        fixnums.

             33..33..  TTrriiggnnoommeettrriicc FFuunnccttiioonnss

                     Some of these funtcions are taken from  the  host
                math  library,  and  we take no further responsibility
                for their accuracy.

          ((ccooss 'fx_angle))

               RETURNS: the (flonum)  cosine  of  fx_angle  (which  is
                        assumed to be in radians).

          ((ssiinn 'fx_angle))

               RETURNS: the  sine  of fx_angle (which is assumed to be
                        in radians).

          ((aaccooss 'fx_arg))

               RETURNS: the (flonum) arc cosine of fx_arg in the range
                        0 to -n.

          ((aassiinn 'fx_arg))

               RETURNS: the  (flonum)  arc sine of fx_arg in the range
                        --n/2 to -n/2.

          ((aattaann 'fx_arg1 'fx_arg2))

               RETURNS: the (flonum) arc tangent of fx_arg1/fx_arg2 in
                        the range --n to -n.

             33..44..  BBiiggnnuumm//FFiixxnnuumm MMaanniippuullaattiioonn

                                             Printed: October 16, 1993

          AArriitthhmmeettiicc FFuunnccttiioonnss                                     33--66

          ((hhaaiippaarrtt bx_number x_bits))

               RETURNS: a fixnum (or bignum) which contains the x_bits
                        high bits of _(_a_b_s _b_x___n_u_m_b_e_r_) if x_bits is pos-
                        itive,  otherwise  it returns the _(_a_b_s _x___b_i_t_s_)
                        low bits of _(_a_b_s _b_x___n_u_m_b_e_r_).

          ((hhaauulloonngg bx_number))

               RETURNS: the number of significant bits in bx_number.

               NOTE: the result is equal to the least integer  greater
                     to or equal to the base two logarithm of one plus
                     the absolute value of bx_number.

          ((bbiiggnnuumm--lleeffttsshhiifftt bx_arg x_amount))

               RETURNS: bx_arg shifted left by x_amount.  If  x_amount
                        is  negative,  bx_arg will be shifted right by
                        the magnitude of x_amount.

               NOTE: If bx_arg is shifted right, it will be rounded to
                     the nearest even number.

          ((ssttiicckkyy--bbiiggnnuumm--lleeffttsshhiifftt 'bx_arg 'x_amount))

               RETURNS: bx_arg  shifted left by x_amount.  If x_amount
                        is negative, bx_arg will be shifted  right  by
                        the magnitude of x_amount and rounded.

               NOTE: sticky rounding is done this way: after shifting,
                     the low order bit is changed to 1 if any 1's were
                     shifted off to the right.

             33..55..  BBiitt MMaanniippuullaattiioonn

          ((bboooollee 'x_key 'x_v1 'x_v2 ...))

               RETURNS: the result of the bitwise boolean operation as
                        described in the following table.

               NOTE: If there are more than 3 arguments, then  evalua-
                     tion  proceeds  left  to  right with each partial
                     result becoming the new value of x_v1.  That is,
                          _(_b_o_o_l_e _'_k_e_y _'_v_1 _'_v_2 _'_v_3_) _=_= _(_b_o_o_l_e _'_k_e_y _(_b_o_o_l_e _'_k_e_y _'_v_1 _'_v_2_) _'_v_3_).
                     In the following table, * represents bitwise and,
                     + represents bitwise or, O+ represents bitwise xor
                     and  ~  represents  bitwise  negation  and is the
                     highest precedence operator.

          AArriitthhmmeettiicc FFuunnccttiioonnss                                     33--77

          +-------------------------------------------------------------------------------------------+
          |                                    (boole 'key 'x 'y)                                     |
          |                                                                                |
          +-------------------------------------------------------------------------------------------+
          | key         0          1          2         3         4          5          6         7   |
          |result       0        x * y     ~ x * y      y      x * ~ y       x        x O+ y     x + y |
          |                                                                                |
          |common                                                                                |
          |names                  and                          bitclear                xor       or   |
          |                                                                                |
          +-------------------------------------------------------------------------------------------+
          |                                                                                |
          | key         8          9         10        11         12        13         14        15   |
          |result   ~ (x + y)   ~(x O+ y)     ~ x     ~ x + y     ~ y      x + ~ y   ~ x + ~ y    -1   |
          |common                                                                                |
          |names       nor       equiv               implies                          nand            |
          +-------------------------------------------------------------------------------------------+

          ((llsshh 'x_val 'x_amt))

               RETURNS: x_val shifted left by x_amt if x_amt is  posi-
                        tive.   If x_amt is negative, then _l_s_h returns
                        x_val shifted right by the magnitude if x_amt.

               NOTE: This  always returns a fixnum even for those num-
                     bers whose magnitude is so large that they  would
                     normally be represented as a bignum, i.e. shifter
                     bits are lost.  For more  general  bit  shifters,
                     see _b_i_g_n_u_m_-_l_e_f_t_s_h_i_f_t and _s_t_i_c_k_y_-_b_i_g_n_u_m_-_l_e_f_t_s_h_i_f_t_.

          ((rroott 'x_val 'x_amt))

               RETURNS: x_val rotated left by x_amt if x_amt is  posi-
                        tive.   If  x_amt  is  negative, then x_val is
                        rotated right by the magnitude of x_amt.

             33..66..  OOtthheerr FFuunnccttiioonnss

                     As noted above, some of the  following  functions
                are  inherited  from  the  host math library, with all
                their virtues and vices.

                                             Printed: October 16, 1993

          AArriitthhmmeettiicc FFuunnccttiioonnss                                     33--88

          ((aabbss 'n_arg))
          ((aabbssvvaall 'n_arg))

               RETURNS: the absolute value of n_arg.

          ((eexxpp 'fx_arg))

               RETURNS: _e raised to the fx_arg power (flonum) .

          ((eexxpptt 'n_base 'n_power))

               RETURNS: n_base raised to the n_power power.

               NOTE: if either of the arguments are flonums, the  cal-
                     culation will be done using _l_o_g and _e_x_p.

          ((ffaacctt 'x_arg))

               RETURNS: x_arg factorial. (fixnum or bignum)

          ((ffiixx 'n_arg))

               RETURNS: a fixnum as close as we can get to n_arg.

               NOTE: _f_i_x  will  round  down.  Currently, if n_arg is a
                     flonum larger than the size  of  a  fixnum,  this
                     will fail.

          ((ffllooaatt 'n_arg))

               RETURNS: a flonum as close as we can get to n_arg.

               NOTE: if n_arg is a bignum larger than the maximum size
                     of a  flonum,  then  a  floating  exception  will
                     occur.

          ((lloogg 'fx_arg))

               RETURNS: the natural logarithm of fx_arg.

          ((mmaaxx 'n_arg1 ... ))

               RETURNS: the maximum value in the list of arguments.

                                             Printed: October 16, 1993

          AArriitthhmmeettiicc FFuunnccttiioonnss                                     33--99

          ((mmiinn 'n_arg1 ... ))

               RETURNS: the minimum value in the list of arguments.

          ((mmoodd 'i_dividend 'i_divisor))
          ((rreemmaaiinnddeerr 'i_dividend 'i_divisor))

               RETURNS: the  remainder  when  i_dividend is divided by
                        i_divisor.

               NOTE: The sign of the result will have the same sign as
                     i_dividend.

          ((**mmoodd 'x_dividend 'x_divisor))

               RETURNS: the balanced representation of x_dividend mod-
                        ulo x_divisor.

               NOTE: the  range  of  the  balanced  representation  is
                     abs(x_divisor)/2    to    (abs(x_divisor)/2)    -
                     x_divisor + 1.

          ((rraannddoomm ['x_limit]))

               RETURNS: a fixnum between 0 and x_limit - 1 if  x_limit
                        is  given.   If  x_limit  is  not  given,  any
                        fixnum,  positive  or   negative,   might   be
                        returned.

          ((ssqqrrtt 'fx_arg))

               RETURNS: the square root of fx_arg.

                                             Printed: October 16, 1993


 ZHBGVX Example Program Results

 Number of eigenvalues found =    2

 Eigenvalues
     0.1603  1.7712
 Selected eigenvectors
             1          2
 1      0.1908     0.0494
        0.0137    -0.0045

 2      0.1413     0.2505
        0.1012     0.4427

 3     -0.0437    -0.9705
       -0.0905     0.0679

 4     -0.2135     0.0606
        0.2880    -1.3227


rm(list=ls())

library('radolc')

#--- testing ADOLC's Hessian matrix product
fr <- function(x) {   ## Rosenbrock Banana function
  x1 <- x[1]
  x2 <- x[2]
  y <- 100 * (x2 - x1 * x1)* (x2 - x1 * x1) + (1 - x1)*(1 - x1)
  y }

trace_on(1)
x <- adolc_createList(2,2.0)
badouble_declareIndependent(x)
y <- fr(x)
badouble_declareDependent(y)
trace_off()

xx <- c(1.0,2.0)
V <- matrix(c(2.2, 1.4, 3.4, 7.4), nrow = 2, ncol = 2)
W <- matrix(rep(0.0,4), nrow = 2, ncol = 2)
hess_mat(1,2,2,xx,V,W)
# hess_mat(tag, n, q, x[n], V[n][q], W[n][q]) # result z = \nambla^2F(x)v
# tag: integer, tape identification
# n  : integer, number of independents n and m = 1
# q  : dimension of matrix (n*q)
# x[n]: independent vector x
# V[n][q]: matrix
# W[n][q]: resulting Hessian matrix product

print(W)

#Always detach the package
detach(package:radolc, unload=TRUE)


# Article submitted
# Fusion of Evidences in Intensities Channels for Edge Detection in PolSAR Images
# GRSL - IEEE Geoscience and Remote Sensing Letters
# Anderson A. de Borba, Maurı́cio Marengoni, and Alejandro C Frery
# Despriction (function)
# Finds the l(L, mu) using log-likelihood, (internal side)
# Input: L, mu > 0
#
# Output: l(L, mu) - log-likelihood
loglike <- function(param){
	L    <- param[1]
	mu   <- param[2]
	aux1 <- L * log(L)
  	aux2 <- L * sum(log(z[1: j])) / j
  	aux3 <- L * log(mu)
  	aux4 <- log(gamma(L))
  	aux5 <- (L / mu) * sum(z[1: j]) / j
  	ll   <- aux1 + aux2 - aux3 - aux4 - aux5
	return(ll)
	}


library(tree)
library(MASS)
library(tidyverse)
library(stringr)
set.seed(1)

df_train <- read.csv("/Users/glmarschmann/.julia/dev/DEBmicroTrait/files/isolates_batch_model_train.csv")
df_train$gramstain <- as.numeric(df_train$gramstain)
df_train$yield <- 1- df_train$yield

df_test <- read.csv("/Users/glmarschmann/.julia/dev/DEBmicroTrait/files/isolates_batch_model_test.csv")
df_test$gramstain <- as.numeric(df_test$gramstain)
df_test$yield <- 1- df_test$yield

# log transform data
logdf_train <- log(df_train) %>%
   filter(!is.nan(BGE))

logdf_test <- log(df_test) %>%
  filter(!is.nan(BGE))

# simple tree
train = sample(1:nrow(logdf_train), nrow(logdf_train))
tree.bge = tree(BGE~., logdf_train, subset=train)
summary(tree.bge)
plot(tree.bge)
text(tree.bge)

cv.bge = cv.tree(tree.bge)
plot(cv.bge$size, cv.bge$dev, type='b')

# pruning
prune.bge = prune.tree(tree.bge, best=5)
plot(prune.bge)
text(prune.bge, pretty=0)

yhat = predict(tree.bge, newdata=logdf_test)
bge.test = logdf_test["BGE"]
plot(yhat,bge.test$BGE)
abline(0,1)
mean((yhat-bge.test$BGE)^2)
sqrt(mean((yhat-bge.test$BGE)^2))

library(randomForest)

# bagging m=p
bag.bge = randomForest(BGE~., data=logdf_train, subset=train, mtry=13, importance=TRUE)
yhat.bag = predict(bag.bge, newdata=logdf_test)
plot(yhat.bag, bge.test$BGE)
abline(0,1)
mean((yhat.bag-bge.test$BGE)^2)
sqrt(mean((yhat.bag-bge.test$BGE)^2))

# random forest m=sqrt(p)
rf.bge = randomForest(BGE~., data=logdf_train, subset=train, importance=TRUE)
yhat.rf = predict(rf.bge, newdata=logdf_test)
mean((yhat.rf-bge.test$BGE)^2)
sqrt(mean((yhat.rf-bge.test$BGE)^2))

# predictor importance
importance(rf.bge)
varImpPlot(rf.bge)

# boosting
library(gbm)

boost.bge = gbm(BGE~., data=logdf_train, distribution="gaussian", n.trees=500)
#svg("/Users/glmarschmann/.julia/dev/DEBmicroTrait/final_manuscript/plots/batch_cue_regression_tree.svg")
summary(boost.bge)

# partial dependence
par(mfrow=c(1,2))
plot(boost.bge, i="genomesize")
plot(boost.bge, i="gc")

yhat.boost = predict(boost.bge, newdata=logdf_test, n.tress=500)
svg("/Users/glmarschmann/.julia/dev/DEBmicroTrait/final_manuscript/plots/batch_cue_regression_error.svg")
plot(yhat.boost, bge.test$BGE)
abline(0,1)
dev.off()
mean((yhat.boost-bge.test$BGE)^2)

print(pretty.gbm.tree(boost.bge, i.tree = boost.bge$n.trees))

# shrinkage parameter
boost.boston = gbm(medv~., data=Boston[train,], distribution="gaussian", n.trees=500, interaction.depth=4, shrinkage=0.2, verbose=F)
yhat.boost = predict(boost.boston, newdata=Boston[-train,], n.tress=500)
mean((yhat.boost-boston.test)^2)

df_all <- bind_rows(df_train, df_test)
df_low <- df_all %>% filter(BGE < 0.25)
df_high <- df_all %>% filter(BGE > 0.25)
lm.low <- lm(log(rho)~log(yield), df_low)
summary(lm.low)
lm.low.poly <- lm(log(rho)~poly(log(yield),3), df_low)
summary(lm.low.poly)

lm.high <- lm(log(rho)~log(yield), df_high)
summary(lm.high)
lm.high.poly <- lm(log(rho)~poly(log(yield),3), df_high)
summary(lm.high.poly)

write.csv(df_low, "/Users/glmarschmann/.julia/dev/DEBmicroTrait/files/isolates_batch_model_bge_low.csv")
write.csv(df_high, "/Users/glmarschmann/.julia/dev/DEBmicroTrait/files/isolates_batch_model_bge_high.csv")


#' @title calcOpenWaterEff
#'
#' @description Calculate the open water efficiency (\code{openWaterEff})
#' (dimensionless) using the Kristensen method with Harvald regressions.
#'
#' @param Rtot Total ship resistance (vector of numericals, kN) (see
#' \code{\link{calcKristTotalRes}} or \code{\link{calcHMTotalRes}})
#' @param thrustFactor Thrust deduction factor (vector of numericals,
#' dimensionless) (see \code{\link{calcKristThrustFactor}} or
#' \code{\link{calcHMThrustFactor}})
#' @param nProp Number of propellers (vector of numericals, see
#' \code{\link{calcPropNum}})
#' @param wakeFraction Wake fraction coefficient (vector of numericals,
#' dimensionless) (see \code{\link{calcKristWakeFrac}} or
#' \code{\link{calcHMWakeFraction}})
#' @param propDiam Propeller diameter (vector of numericals, m) (see
#' \code{\link{calcPropDia}})
#' @param shipSpeed Ship actual speed (vector of numericals, m/s) (see
#' \code{\link{calcSpeedUnitConversion}})
#' @param seawaterDensity Sea water density. Default = 1.025 (g/cm^3). Can
#' supply either a vector of numericals, a single number, or rely on the default
#'
#' @return \code{openWaterEff} (vector of numericals, dimensionless)
#'
#'@references
#'\href{https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}{Kristensen, H. O.
#'"Ship-Desmo-Tool." https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}
#'
#'@seealso \itemize{
#'\item \code{\link{calcKristTotalRes}}
#'\item \code{\link{calcHMTotalRes}}
#'\item \code{\link{calcKristThrustFactor}}
#'\item \code{\link{calcHMThrustFactor}}
#'\item \code{\link{calcPropNum}}
#'\item \code{\link{calcKristWakeFrac}}
#'\item \code{\link{calcHMWakeFraction}}
#'\item \code{\link{calcPropDia}}
#'\item \code{\link{calcSpeedUnitConversion}}}
#'
#' @examples
#'  calcOpenWaterEff(398.487,0.1894947,1,0.3199536,6.7,0,seawaterDensity=1.025)
#'
#' @export

calcOpenWaterEff<-function(Rtot,thrustFactor,nProp,wakeFraction,propDiam,shipSpeed,seawaterDensity=1.025){

   cth<- (8/pi)*Rtot/(1-thrustFactor)/nProp/seawaterDensity/((1-wakeFraction)*shipSpeed*propDiam)^2

openWaterEff<- ifelse(shipSpeed==0,
                  0,
                  ((2/(1+sqrt((cth)+1)))*pmax(0.65, 0.81-0.014*(cth)))
)

return(openWaterEff)

}


#
# census_income_data
#
library(conTree)
load('census_income_data.Rdata')
dx = 1:10000; dxt = 10001:16281
tree=contrast(xt[dx,],yt[dx],gblt[dx],type='prob')
nodesum(xt[dxt,],yt[dxt],gblt[dxt],tree)
nodeplots(xt[dxt,],yt[dxt],gblt[dxt],tree)
treesum(tree,c(7,29))
nx=getnodes(xt,tree)
plot(gblt[nx==7],gbpt[nx == 7],pch='.',xlab='GBTL',ylab='GBPT')
lines(c(0,1),c(0,1),col='red')
tree=contrast(xt[dx,],yt[dx],gblt,type='prob',tree.size=50)
lofcurve(xt[dxt,],yt[dxt],gblt[dxt],tree)
tree=contrast(xt[dx,],yt[dx],rft[dx,2],type='prob',tree.size=50)
u=lofcurve(xt[dxt,],yt[dxt],rft[dxt,2],tree,doplot=F)
lines(u$x,u$y,col='blue')
tree=contrast(xt[dx,],yt[dx],gbpt[dx],type='prob',tree.size=50)
u=lofcurve(xt[dxt,],yt[dxt],gbpt[dxt],tree,doplot=F)
lines(u$x,u$y,col='red')
modgbl=modtrast(x,y,gbl,type='prob',niter=200)
xval(x,y,gbl,modgbl,col='red')
xval(xt,yt,gblt,modgbl,col='green',doplot='next')
hblt=predtrast(xt,gblt,modgbl)
tree=contrast(xt[dx,],yt[dx],hblt[dx],type='prob')
nodeplots(xt[dxt,],yt[dxt],hblt[dxt],tree)
#
# age_data
#
load('age_data.Rdata')
hist(yage)
dl=1:5000 # training data
dt=5001:8856 # test data
set.seed(5)
zage=yage[sample.int(length(yage))]
treezage=contrast(xage[dt,],yage[dt],zage[dt],tree.size=9,min.node=200)
nodesum(xage[dt,],yage[dt],zage[dt],treezage)
nodeplots(xage[dt,],yage[dt],zage[dt],treezage)
res=yage - gbage
rbage=gbage + res[sample.int(length(res))]
treerbage=contrast(xage[dt,],yage[dt],rbage[dt],tree.size=9,min.node=200)
nodeplots(xage[dt,],yage[dt],rbage[dt],treerbage)
mdlrb=modtrast(xage[dl,],yage[dl],rbage[dl],min.node=200)
xval(xage[dl,],yage[dl],rbage[dl],mdlrb,col='red')
xval(xage[dt,],yage[dt],rbage[dt],mdlrb,col='green',doplot='next')
hrbage=predtrast(xage[dt,],rbage[dt],mdlrb)
treehrbage=contrast(xage[dt,],yage[dt],hrbage,tree.size=9,min.node=200)
nodeplots(xage[dt,],yage[dt],hrbage,treerbage)
lofcurve(xage[dt,],yage[dt],zage[dt],treezage)
u=lofcurve(xage[dt,],yage[dt],rbage[dt],treerbage,doplot=F)
lines(u$x,u$y,col='blue')
u=lofcurve(xage[dt,],yage[dt],hrbage,treehrbage,doplot=F)
lines(u$x,u$y,col='red')
obs=c(8843,5716,7831,6505,4949,7555,3202,6048,7134)
p=((1:500)-0.5)/500; qres=as.numeric(quantile(res,p))
par(mfrow=c(3,3))
for (k in 1:9) {
 plot(ydist(xage[obs[k],],gbage[obs[k]]+qres,mdlrb),p,type='l',xlim=c(13,100),
 xlab='Age',main=paste('Observation',as.character(obs[k])))
 points(yage[obs[k]],0,col='red')
title(paste('Observation',obs[k]))
}
par(mfrow=c(3,3))
for (k in 1:9) {
 hist(ydist(xage[obs[k],],gbage[obs[k]]+qres,mdlrb),xlim=c(13,100),nclass=10,
 xlab='Age',main=paste('Observation',as.character(obs[k])))
 points(yage[obs[k]],0,col='red')
 title(paste('Observation',obs[k]))
}
par(mfrow=c(1,1))
#
# air_quality_data
#
load('air_quality_data.Rdata')
c(mean(yco[zco<0]),mean(yco[zco>0]))
dl=1:6000   # learning
dt=6001:9357 # test
tree=contrast(xco[dl,],yco[dl],zco[dl],mode='twosamp',type='diffmean')
nodesum(xco[dt,],yco[dt],zco[dt],tree)
hist(pr2,nclass=100)
wp=rep(0,length(zco))
wp[zco>0]=1/pr2[zco>0]
wp[zco<0]=1/(1-pr2[zco<0])
wp=length(wp)*wp/sum(wp)
tree=contrast(xco[dl,],yco[dl],zco[dl],w=wp[dl],mode='twosamp',type='diffmean')
nodesum(xco[dt,],yco[dt],zco[dt],tree,w=wp[dt])
nodeplots(xco[dt,],yco[dt],zco[dt],tree,w=wp[dt])
avedisc=rep(0,1000)
set.seed(13)
for (k in 1:1000) {
 zcot=zco[sample.int(length(zco))]
 tre=contrast(xco[dl,],yco[dl],zcot[dl],mode='twosamp',type='diffmean')
 avedisc[k]=nodesum(xco[dt,],yco[dt],zcot[dt],tre)$avecri
 if(k%%10==1) cat('.')
}
cat('\n')
hist(avedisc,xlim=c(0,4))
points(c(2.937557,3.790423),c(0,0),col=c('blue','red'))
treesum(tree,c(11,25))
ycodt=yco[dt]
qqplot(ycodt[zco[dt]<0],ycodt[zco[dt]>0],pch='.')
lines(c(0,200),c(0,200),col='red')
tree=contrast(xco[dl,],yco[dl],zco[dl],w=wp[dl],mode='twosamp',tree.size=9)
nodeplots(xco[dt,],yco[dt],zco[dt],w=wp[dt],tree)


suppressPackageStartupMessages(library(kazaam))
comm.set.seed(1234, diff=TRUE)

tol = 5e-4

dx = ranshaq(rnorm, 10, 3)
dy_gaussian = ranshaq(runif, 10)
dy_logistic = ranshaq(function(i) sample(0:1, size=i, replace=TRUE), 10)
dy_poisson = ranshaq(function(i) sample(1:5, size=i, replace=TRUE), 10)

fit_gaussian = reg.fit(dx, dy_gaussian)
fit_logistic = logistic.fit(dx, dy_logistic)
fit_poisson = poisson.fit(dx, dy_poisson)

x = collapse(dx)
y_gaussian = collapse(dy_gaussian)
y_logistic = collapse(dy_logistic)
y_poisson = collapse(dy_poisson)

comm.print(all.equal(fit_gaussian$par, lm.fit(x, y_gaussian)$coefficients, check.attributes=FALSE, tol=tol))
comm.print(all.equal(fit_logistic$par, glm.fit(x, y_logistic, family=binomial(logit))$coefficients, check.attributes=FALSE, tol=tol))
comm.print(all.equal(fit_poisson$par, glm.fit(x, y_poisson, family=poisson(log))$coefficients, check.attributes=FALSE, tol=tol))

finalize()


library(pbdPAPI)
library(scribe)
rm(list = ls())

resample <- sample(1:nrow(iris), size=197000, replace=TRUE)
iris <- iris[resample, ]

id <- as.integer(iris[, 5])
X <- as.matrix(iris[, -5])
Mu <- t(sapply(1:3, function(k) colMeans(X[id == k,])))

### Profile K-means
m1.flops <- system.flops( m.1 <- kmeans(X, Mu, iter.max = n.iter, nstart = 1) )
m2.flops <- system.flops( m.2 <- kmeans(X, Mu, iter.max = n.iter, nstart = 1,
                                        algorithm = "Lloyd") )
m3.flops <- system.flops( m.3 <- kmeans(X, Mu, iter.max = n.iter, nstart = 1,
                                        algorithm = "Forgy") )
m4.flops <- system.flops( m.4 <- kmeans(X, Mu, iter.max = n.iter, nstart = 1,
                                        algorithm = "MacQueen") )

m1.flops
m2.flops
m3.flops
m4.flops

m1.cm <- system.cache( m.1 <- kmeans(X, Mu, iter.max = n.iter, nstart = 1) )
m2.cm <- system.cache( m.2 <- kmeans(X, Mu, iter.max = n.iter, nstart = 1,
                                     algorithm = "Lloyd") )
m3.cm <- system.cache( m.3 <- kmeans(X, Mu, iter.max = n.iter, nstart = 1,
                                     algorithm = "Forgy") )
m4.cm <- system.cache( m.4 <- kmeans(X, Mu, iter.max = n.iter, nstart = 1,
                                     algorithm = "MacQueen") )

### Use the scribe package (parte of the shinra meta-package) to plot results
#plot(m1.cm, m2.cl, m3.cm, m4.cm,
     #opnames=c("Hartigan-Wong", "Lloyd", "Forgy", "MacQueen")) +
    #ggtitle(paste0("Comparing the Performance of K-Means Algorithms\non ",
            #memuse::object.size(X), " of data"))


## Inversion for bedform migration rates and sediment flux in the ancient
## Eric Barefoot
## May 2018

## TODO
# clean up documentation more.
# complete the uncertainty routines.
# add the ability to also account for variance in data.

# This collection of functions provides functionality for calculating bedform migration rates using methods put out by Rob Mahon and Brandon McElroy in 2018

# describe inputs and other stuff needed

# Mahon et al. use a Bayesian approach for paleohydraulic inversion, meaning that the coefficients that they describe for the empirical fit each have a distribution. They provide uncertainties for the distribution in their Table 1.
# In this way, we can ascribe ranges for the coefficients, and potentially provide a range of estimates of paleoslope accordingly. I think this means we can have confidence intervals, but I'm not sure about that.
# Initially, the user is allowed to select a percentile, and that percentile will be chosen for each parameter.

# In the future, users should be allowed to vary each parameter individually.

# get libraries

library(tibble)

## Set values and lookup table for empirical constants.

param_names = c('alpha0', 'alpha1', 'alpha2', 'beta0', 'beta1', 'gamma', 'delta0', 'delta1')

params_vals = c(-2.08, 0.254, -1.09, 0.6113, 1.305, 2.9, 0.0513, 0.7744)

params_uncert = c(0.036, 0.016, 0.044, 0.144, 0.0515, 0.7, 0.0017, 0.0123)

pars = tibble(name = param_names, vals = params_vals, uncert = params_uncert)

## Define functions from Mahon et al. 2018

# a function for table lookup. just feed it the name of the constant you want.
fun_paramVal = function(pars_list, param_name, zscore = 0) {

  therow = pars_list[which(pars_list$name == param_name), ] # lookup the constant

  val = as.numeric(therow[2]) # extract the value
  dev = as.numeric(therow[3] * zscore) # extract the magnitude of deviation from mean at zscore.

  return(list(val = val, dev = dev))

}

# equation 1 from the paper.

#' Bedform-bedload equation
#'
#' \code{bedform_bedload} calculates the sediment flux through bedload in a river based on the height and migration rate of bedforms. From Simons et al. (1965), Implemented from Mahon et al. (2018)
#' @param hd The mean height of bedforms in meters.
#' @param V The dune migration rate in meters per second.
#' @param phi The porosity of the riverbed material. Default is 0.36.
#' @return Returns a vector \code{qs}, the sediment flux in m^3/s.
#' @export

bedform_bedload = function(hd, V, phi = 0.36) {

  qs = (1 - phi) * (hd * V) / 2

  return(qs)

}

# equation 2 from the paper.

#' Bedform velocity relation
#'
#' \code{bedform_velocity} estimates the velocity of a migrating bedform using a power law fit for slope. Implemented from Mahon et al. (2018)
#' @param S The dimensionless river slope.
#' @param beta0 Empirical constant. Value and associated uncertainty from Table 1 in Mahon + McElroy 2018.
#' @param beta1 Empirical constant. Value and associated uncertainty from Table 1 in Mahon + McElroy 2018.
#' @return Returns a vector \code{V}, the bedform migration rate in m/s.
#' @export

bedform_velocity = function(beta0, beta1, S) {

  logV = beta0 + beta1 * log10(S)

  V = 10^(logV)

  return(V)

}

# equation 3 from the paper

#' Bedform length to height relation
#'
#' \code{height_length} estimates the mean height of bedforms based on the mean bedform length. Implemented from Mahon et al. (2018)
#' @param L The mean bedform length.
#' @param delta0 Empirical constant. Value and associated uncertainty from Table 1 in Mahon + McElroy 2018.
#' @param delta1 Empirical constant. Value and associated uncertainty from Table 1 in Mahon + McElroy 2018.
#' @return Returns a vector \code{hd}, the bedform migration rate in m/s.
#' @export

height_length = function(delta0, delta1, L) {

  hd = delta0 * L ^ delta1

  return(hd)

}

# equation 4 from the paper

#' Paleoslope relation
#'
#' \code{paleo_slope} estimates the slope of an ancient river. Originally developed in Trmapush et al. 2014. Implemented from Mahon et al. (2018)
#' @param D50 The median bedload grain size. Determined from samples.
#' @param Hbf The mean bankfull flow depth. Determined from preserved barforms.
#' @param alpha0 Empirical constant. Value and associated uncertainty from Table 1 in Mahon + McElroy 2018.
#' @param alpha1 Empirical constant. Value and associated uncertainty from Table 1 in Mahon + McElroy 2018.
#' @param alpha2 Empirical constant. Value and associated uncertainty from Table 1 in Mahon + McElroy 2018.
#' @return Returns a vector \code{S}, the dimensionless paleoslope of the ancient river.
#' @export

paleo_slope = function(alpha0, alpha1, alpha2, D50, Hbf) {

  logS = alpha0 + alpha1 * log10(D50) + alpha2 * log10(Hbf)

  S = 10^logS

  return(S)

}

# equation 5 from the paper

#' Dune height from cosets relation
#'
#' \code{dune_height} estimates the height of dunes based on cross-stratification. Originally developed by Leclair and Bridge (2001). Implemented from Mahon et al. (2018)
#' @param Tsm The mean thickness of cross-bedded cosets. (see publication for more information)
#' @param gamma Empirical constant. Value and associated uncertainty from Table 1 in Mahon + McElroy 2018.
#' @return Returns a vector \code{hd}, the dune height in the ancient river.
#' @export

dune_height = function(gamma, Tsm) {

  hd = gamma * Tsm

  return(hd)

}

# self-contained function for calculating sediment flux rates from outcrops.
# have to have grain size measurements and bankfull depth estimates

#' Estimating sediment flux in ancient rivers.
#'
#' \code{ancient_1} estimates the sediment flux (\code{qs}) of ancient river deposits based on dune cross-stratification, bankfull depth reconstruction, and grain size. Implemented from Mahon et al. (2018). Original relations referenced therein.
#' @param Tsm The mean thickness of cross-bedded cosets. (see publication for more information)
#' @param D50 The median bedload grain size. Determined from samples.
#' @param Hbf The mean bankfull flow depth. Determined from preserved barforms.
#' @param uncert The uncertainty window for empirical parameters. The user should put in a confidence interval. A lower confidence interval will have a narrower error envelope, but will require more tenuous conclusion.
#' @return Returns a list with elements:
#' \code{S}, the river slope (dimensionless).
#' \code{hd}, the dune height in the ancient river (m).
#' \code{V}, the dune migration rate in the ancient river (m/s).
#' \code{qs}, the bedload flux in the ancient river (m^3/s).
#' If uncertainty is also requested, the output will include upper and lower bounds for confidence, \code{V_env} and \code{qs_env}
#' @export

ancient_1 = function(Tsm, D50, Hbf, uncert = NULL) {

  S_est = paleo_slope(
    alpha0 = fun_paramVal(pars, 'alpha0')$val,
    alpha1 = fun_paramVal(pars, 'alpha1')$val,
    alpha2 = fun_paramVal(pars, 'alpha2')$val,
    D50 = D50,
    Hbf = Hbf
  )
  hd_est = dune_height(gamma = fun_paramVal(pars, 'gamma')$val, Tsm)
  V_est = bedform_velocity(beta0 = fun_paramVal(pars, 'beta0')$val, beta1 = fun_paramVal(pars, 'beta1')$val, S_est)
  qs_est = bedform_bedload(hd = hd_est, V = V_est)

  if (is.null(uncert)) {

    return(list(S = S_est, hd = hd_est, V = V_est, qs = qs_est))

  } else {

    zscore = abs(qnorm(uncert/2))
    env = c(-zscore, zscore)

    V_env = c(
      bedform_velocity(fun_paramVal(pars, 'beta0', zscore = env[1]), fun_paramVal(pars, 'beta1', zscore = env[1]), S),
      bedform_velocity(fun_paramVal(pars, 'beta0', zscore = env[2]), fun_paramVal(pars, 'beta1', zscore = env[2]), S)
    )

    qs_env = c(
      bedform_bedload(hd, V_env[1]),
      bedform_bedload(hd, V_env[2])
    )

    return(list(V = V_est, qs = qs_est, V_env = V_env, qs_env = qs_env))

  }

}

# self-contained function for calculating dune migration rates in the modern.
# uses measured dune heights

#' Estimating sediment flux in modern rivers if bedform height is known.
#'
#' \code{modern_1} estimates the sediment flux (\code{qs}) of modern rivers based on bedform height and river slope. Implemented from Mahon et al. (2018).
#' @param hd The mean height of migrating bedforms.
#' @param S The reach-average slope of the river.
#' @param uncert The uncertainty window for empirical parameters. The user should put in a confidence interval. A lower confidence interval will have a narrower error envelope, but will require more tenuous conclusions.
#' @return Returns a list with elements:
#' \code{V}, the dune migration rate in the river (m/s).
#' \code{qs}, the bedload flux in the river (m^3/s).
#' If uncertainty is also requested, the output will include upper and lower bounds for confidence, \code{V_env} and \code{qs_env}
#' @export

modern_1 = function(hd, S, uncert = NULL) { # if bedforme height is known

  V_est = bedform_velocity(beta0 = fun_paramVal(pars, 'beta0')$val, beta1 = fun_paramVal(pars, 'beta1')$val, S)
  qs_est = bedform_bedload(hd = hd, V = V_est)

  if (is.null(uncert)) {

    return(list(V = V_est, qs = qs_est))

  } else {

    zscore = abs(qnorm(uncert/2))
    env = c(-zscore, zscore)

    V_env = c(
      bedform_velocity(fun_paramVal(pars, 'beta0', zscore = env[1]), fun_paramVal(pars, 'beta1', zscore = env[1]), S),
      bedform_velocity(fun_paramVal(pars, 'beta0', zscore = env[2]), fun_paramVal(pars, 'beta1', zscore = env[2]), S)
    )

    qs_env = c(
      bedform_bedload(hd, V_env[1]),
      bedform_bedload(hd, V_env[2])
    )

    return(list(V = V_est, qs = qs_est, V_env = V_env, qs_env = qs_env))

  }

}

# self-contained function for calculating dune migration rates in the modern.
# uses measured dune lengths
#' Estimating sediment flux in modern rivers if bedform height is unknown, but bedform length is known.
#'
#' \code{modern_2} estimates the sediment flux (\code{qs}) of modern rivers based on bedform length and river slope. Implemented from Mahon et al. (2018).
#' @param L The mean length of migrating bedforms.
#' @param S The reach-average slope of the river.
#' @param uncert The uncertainty window for empirical parameters. The user should put in a confidence interval. A lower confidence interval will have a narrower error envelope, but will require more tenuous conclusions.
#' @return Returns a list with elements:
#' \code{V}, the dune migration rate in the river (m/s).
#' \code{qs}, the bedload flux in the river (m^3/s).
#' If uncertainty is also requested, the output will include upper and lower bounds for confidence, \code{V_env} and \code{qs_env}
#' @export

modern_2 = function(L, S, uncert = NULL) { # if bedforme height is unknown, but length is known

  V_est = bedform_velocity(beta0 = fun_paramVal(pars, 'beta0')$val, beta1 = fun_paramVal(pars, 'beta1')$val, S = S)
  hd_est = height_length(delta0 = fun_paramVal(pars, 'delta0')$val, delta1 = fun_paramVal(pars, 'delta1')$val, L = L)
  qs_est = bedform_bedload(hd = hd_est, V = V_est)

  if (is.null(uncert)) {

    return(list(V = V_est, qs = qs_est))

  } else {

    zscore = abs(qnorm(uncert/2))
    env = c(-zscore, zscore)

    V_env = c(
      bedform_velocity(fun_paramVal(pars, 'beta0', zscore = env[1]), fun_paramVal(pars, 'beta1', zscore = env[1]), S),
      bedform_velocity(fun_paramVal(pars, 'beta0', zscore = env[2]), fun_paramVal(pars, 'beta1', zscore = env[2]), S)
    )

    qs_env = c(
      bedform_bedload(hd, V_env[1]),
      bedform_bedload(hd, V_env[2])
    )

    return(list(V = V_est, qs = qs_est, V_env = V_env, qs_env = qs_env))

  }

}


library(merkhet)
suppressMessages(library(float))
suppressMessages(library(fmlr))

m = n = 8000
seed = 1234
type = "float"

# ------------------------------------------------------------------------------
b = bench(sprintf("invert - %dx%d (%s) type=%s", m, n, as.character(howbig(m, n, type=type)), type))

tol = ifelse(type=="double", 1e-8, 1e-4)

x = cpumat(n, n, type)
x$fill_rnorm(seed)
xr = x$to_robj()

b$time({solve(xr)}, name="R")

b$time({linalg_invert(x)}, name="fmlr - CPU")

if (fml_gpu())
{
  c = card()
  xg = gpumat(c, type=type)
  cpu2gpu(x, xg)

  b$time({
    linalg_invert(xg)
    c$synch()
  }, name="fmlr - GPU")
}

b$print()


#install packages
install.packages("minpack.lm")
install.packages("boot")
library(minpack.lm)
library(boot)

# Exsampledata of mortalitybase, absolute frequency of deaths in age x
dx <- c(355,27,16,13,12,9,10,8,8,8,8,9,8,10,12,15,26,29,38,41,45,
        44,45,46,48,48,47,52,51,57,57,68,69,70,79,87,87,92,103,107,
        123,130,146,160,175,199,212,241,269,303,338,370,422,473,527,
        578,638,699,777,844,908,983,1073,1143,1232,1307,1369,1479,
        1513,1638,1742,1854,1939,2044,2170,2315,2473,2608,2803,3022,
        3210,3432,3600,3778,3887,3966,3951,3853,3706,3478,3220,2978,
        2631,2220,1883,1430,1116,830,588,399,260,381)

# Data of mortalitybase, absolute frequency of survivers in age x
lx <- rev(cumsum(rev(dx)))

#qx = obserevd probability of death between the ages of x and age x+1
qx <- dx/lx
logqx  <- log(dx/lx)

#w = limiting age of the mortality table/ database
w <- length(dx)-1
x<- 0:90
data <- data.frame(Y=rep(0:w, dx))

#Models:
in this example 4 models are used:

#Gompertzfunction S(x)
GompertzFuncS <- function(x, m, s) {
  return(exp(exp(-m/s)-exp((x-m)/s)))
}
#Inverse Gompertzfunction S(X)
InvGompertzFuncS <- function(x, m, s) {
  return((1-exp(-exp(-(x-m)/s)))/(1-exp(-exp(m/s))))
}
#Weibullfunction S(X)
WeibullFuncS <- function(x, m, s) {
  return(exp(-(x/m)^(m/s)))
}
#Inverse Weibullfunction S(X)
InvWeibullFuncS <- function(x, m, s) {
  return(1-exp(-(x/m)^(-m/s)))
}

#Aggregation of models:
#Function to combine all models in one S(X)
S <- function(x, psi1, psi2, psi3, psi4, m1, m2, m3, m4, s1, s2, s3, s4) {
  return(psi1 * GompertzFuncS(x, m1, s1) +
           psi2 * InvGompertzFuncS(x, m2, s2) +
           psi3 * WeibullFuncS(x, m3, s3) +
           psi4 * InvWeibullFuncS(x, m4, s4))
}
myS <- function(x, psi1, psi2, psi3, psi4, m1, m2, m3, m4, s1, s2, s3, s4) {
  return(psi1 * GompertzFuncS(x, m1, s1) +
           psi2 * InvGompertzFuncS(x, m2, s2) +
           psi3 * WeibullFuncS(x, m3, s3) +
           psi4 * InvWeibullFuncS(x, m4, s4))
}
#Function to define probability of death  ages of x and age x+1 X as Q(X) = 1- S(X+1)/S(x)
Q <- function(x, psi1, psi2, psi3, m1, m2, m3, m4, s1, s2, s3, s4) {
  psi4 <- 1 - psi1 - psi2 - psi3
  return(1 - (S(x+1, psi1, psi2, psi3, psi4, m1, m2, m3, m4, s1, s2, s3, s4)/
                S(x, psi1, psi2, psi3, psi4, m1, m2, m3, m4, s1, s2, s3, s4)))
}
#Function to return the logarithmic probability of death  ages of x and age x+1 as log(Q(X))
logQ <- function(x, psi1, psi2, psi3, m1, m2, m3, m4, s1, s2, s3, s4) {
  psi4 <- 1 - psi1 - psi2 - psi3
  return(log(1 - (myS(x+1, psi1, psi2, psi3, psi4, m1, m2, m3, m4, s1, s2, s3, s4)/
                    myS(x, psi1, psi2, psi3, psi4, m1, m2, m3, m4, s1, s2, s3, s4))))
}
#fitting of parameters on the statistical values qx
qx <- qx[0:91]
PaperFit <- nlsLM(qx  ~ Q(x, psi1, psi2, psi3, m1, m2, m3, m4, s1, s2, s3, s4),
                  start = list(psi1=0.97, psi2=0.01, psi3=0.01,
                               m1=85, m2=42, m3=.26, m4=23,
                               s1=11, s2=14, s3=1, s4=8),
                  weights = 1/abs(qx) , control = nls.control(maxiter=1000))
#fitting of parameters on the logarithmic statistical values qx using logQ
logqx <- logqx[0:91]
logPaperFit <- nlsLM(logqx ~ logQ(x, psi1, psi2, psi3, m1, m2, m3, m4, s1, s2, s3, s4),
                     start = list(psi1=0.97, psi2=0.01, psi3=0.01,
                                  m1=85, m2=42, m3=.26, m4=23,
                                  s1=11, s2=14, s3=1, s4=8), weights = 1/abs(logqx), control = nls.control(maxiter=1000))
qxPaperFit <- predict(PaperFit, data=data.frame(x=0:90))
logqxPaperFit <- predict(logPaperFit, data=data.frame(x=0:90))
##Visualization:
plot(x, logSterbewahrscheinlichkeit)
lines(x, logqxPaperFit, col="red")
#fitting of parameters on the logarithmic statistical values non parametric Bootstrap
bootfit <- function(data, indices) {
  d <- data[indices, ]
  # Bestimme für d die logqx Werte
  dx <- as.numeric(table(d))
  #lx = observed number of people alive, relative to an original cohort, at age x
  lx <- rev(cumsum(rev(dx)))
  #qx = obserevd probability of death between the ages of x and age x+1
  qx <- dx/lx
  #w = imiting age of the mortality table/ database
  w <- length(dx)-1
  #x= age
  x <- 0:90
  qx <- qx[0:91]
  PaperFit <- nlsLM(Sterbewahrscheinlichkeit ~ Q(x, psi1, psi2, psi3, m1, m2, m3, m4, s1, s2, s3, s4),
                       start = list(psi1=0.97, psi2=0.01, psi3=0.01,
                                    m1=85, m2=42, m3=.26, m4=23,
                                    s1=11, s2=14, s3=1, s4=8),
                       weights = 1/abs(qx), control = nls.control(maxiter=1000))
  qxPaperFit <- predict(PaperFit, data=data.frame(x=0:90))
  return(PaperFit$m$getPars())
}
logbootfit <- function(data, indices) {
  d <- data[indices, ]
  # Bestimme für d die logqx Werte
  dx <- as.numeric(table(d))
  #lx = observed number of people alive, relative to an original cohort, at age x
  lx <- rev(cumsum(rev(dx)))
  #qx = obserevd probability of death between the ages of x and age x+1
  qx <- dx/lx
  logqx  <- log(dx/lx)
  #w = imiting age of the mortality table/ database
  w <- length(dx)-1
  #x= age
  x <- 0:90
  logqx<- logqx[0:91]
  logPaperFit <- nlsLM(logqx ~ logQ(x, psi1, psi2, psi3, m1, m2, m3, m4, s1, s2, s3, s4),
                       start = list(psi1=0.97, psi2=0.01, psi3=0.01,
                                    m1=85, m2=42, m3=.26, m4=23,
                                    s1=11, s2=14, s3=1, s4=8),
                       weights = 1/abs(logqx), control = nls.control(maxiter=1000))
  logqxPaperFit <- predict(logPaperFit, data=data.frame(x=0:90))
  return(logPaperFit$m$getPars())
}
#call non parametric bootstrap
set.seed(2)
np_boot <- boot(data=data, statistic=bootfit, R=1000)
set.seed(1)
lognp_boot <- boot(data=data, statistic=logbootfit, R=1)
set.seed(2)

#plot results
lines(x, logqxPaperFit, col="red")
lines(x, logQ(x,9.862212e-01, 2.189063e-03, 7.514800e-03, 8.311480e+01, 3.440280e+01, 2.878187e+01, 2.196682e+01, 9.342605e+00, 6.470701e+00, 2.004074e+02, 5.208513e+00)
, col="blue")
lines(x, logQ(x, 0.917213634, 0.067941919, 0.004328894, 86.424663344,  57.935706039, 0.379915365, 34.177258127, 7.591399243, 4.847847541, 0.928726117, 4.373326151  ), col="red")


#!/usr/bin/env Rscript

############################################################
### 奇异矩阵(不可逆)
### 非奇异矩阵
############################################################

A = cbind(c(3,5), c(4,6))
## |A| 不为0 --> A可逆
det(A)


 bmi = read.csv("//Path//bmi.csv",head=TRUE) #Assign csv to variable
 bmi #Prints CSV
 medidan (bmi$bmi) #Print Dataset median
 mean (bmi$bmi) #Print Dataset mean
 sortedBMI = sort(bmi$bmi)
 sortedBMI #Print sorted
 quantile(sortedBMI)


library(ggvis)
library(tidyverse)
data("mtcars")

#############################
#Chapter 1
#The Grammar of Graphics
#############################

####Load ggvis and start to explore####
# Change the code below to plot the disp variable of mtcars on the x axis
mtcars %>% ggvis(~disp, ~mpg) %>% layer_points()
####

####ggvis and its capabilities####
# Change the code below to make a graph with red points
mtcars %>% ggvis(~wt, ~mpg, fill := "red") %>% layer_points()
# Change the code below draw smooths instead of points
mtcars %>% ggvis(~wt, ~mpg) %>% layer_smooths()
# Change the code below to make a graph containing both points and a smoothed summary line
mtcars %>% ggvis(~wt, ~mpg) %>% layer_points() %>% layer_smooths()
####

####ggvis grammar ~ graphics grammar####
# Adapt the code: show bars instead of points
pressure %>% ggvis(~temperature, ~pressure) %>% layer_bars()
# Adapt the code: show lines instead of points
pressure %>% ggvis(~temperature, ~pressure) %>% layer_lines()
# Extend the code: map the fill property to the temperature variable & size prop to the pressure
pressure %>% ggvis(~temperature, ~pressure,
                   size = ~pressure,
                   fill = ~temperature) %>%
  layer_points() %>%
  add_axis("y", title = "The Pressure (p)") %>%
  add_axis("x", title = "The Temperature")
####

#############################
#Chapter 2
#Lines and Syntax
#############################

####Three operators: %>%, = and :=####
# Rewrite the code with the pipe operator
faithful %>%
  ggvis( ~waiting, ~eruptions) %>%
  layer_points()
# Modify this graph to map the size property to the pressure variable
pressure %>%
  ggvis(~temperature, ~pressure, size = ~pressure) %>%
  layer_points()
# Modify this graph by setting the size property
pressure %>%
  ggvis(~temperature, ~pressure, size := 100) %>%
  layer_points()
# Fix this code to set the fill property to red
pressure %>%
  ggvis(~temperature, ~pressure,
        fill := "red") %>%
  layer_points()
####

####Referring to different objects###
#Which of the commands below will create a graph that has green points?
#Try to predict the answer before running the code.
red <- "green"
pressure$red <- pressure$temperature
# GRAPH A
pressure %>%
  ggvis(~temperature, ~pressure,
        fill = ~red) %>%
  layer_points()
# GRAPH B
pressure %>%
  ggvis(~temperature, ~pressure,
        fill = "red") %>%
  layer_points()
# GRAPH C
pressure %>%
  ggvis(~temperature, ~pressure,
        fill := red) %>%
  layer_points()
###ANSWER IS GRAPH C
####

####Properties for points####
  # You can manipulate many different properties when using layer_points(),
  # including x, y, fill, fillOpacity, opacity, shape, size, stroke, strokeOpacity, andstrokeWidth.
  # The shape property recognizes several different values:
  # circle (default), square, cross, diamond, triangle-up, and triangle-down.
# Add code, play with opacity
faithful %>%
  ggvis(~waiting, ~eruptions, size = ~eruptions,
        opacity := 0.5, fill := "blue",
        stroke := "black") %>%
  layer_points()
# Add code, play with fillOpacity
faithful %>%
  ggvis(~waiting, ~eruptions,
        fillOpacity = ~eruptions,
        size := 100, fill := "red",
        stroke := "red", shape:="cross") %>%
  layer_points()
####

####Properties for lines####
# Update the code
# pressure %>% ggvis(~temperature, ~pressure) %>% layer_points()
pressure %>%
  ggvis(~temperature, ~pressure,
        stroke := "red",  #this controls the color.
        strokeWidth := 2, # this controls the line width.
        strokeDash := 6) %>%  #this controls the length of the dashes.
  layer_lines()
####

####Path marks and polygons####
texas <- read_csv("texas.csv")
# Update the plot
#texas %>% ggvis(~long, ~lat) %>% layer_lines()
texas %>%
  ggvis(~long, ~lat,
        strokeDash := 5) %>%  #This will color your map!
  layer_paths(fill :="darkorange") #this will correctly plot the map of Texas.
####

####Display model fits####
?compute_model_prediction
#sample
faithful %>%
  compute_model_prediction(eruptions ~ waiting,
                           model = "lm")
# Compute the x and y coordinates for a loess smooth line that predicts mpg with the wt
mtcars %>%
  compute_smooth( mpg ~ wt)
####

####compute_smooth() to simplify model fits####
#sample
faithful %>%
  compute_smooth(eruptions ~ waiting) %>%
  ggvis(~pred_, ~resp_) %>%
  layer_lines()
# Extend with ggvis() and layer_lines()
#mtcars %>% compute_smooth(mpg ~ wt)
mtcars %>%
  compute_smooth(mpg ~ wt) %>%
  ggvis(~pred_, ~resp_) %>%
  layer_lines()
# Extend with layer_points() and layer_smooths()
#mtcars %>% ggvis(~wt, ~mpg)
mtcars %>%
  ggvis(~wt, ~mpg) %>%
  layer_points() %>%
  layer_smooths()
####

#############################
#Chapter 3
#Transformations
#############################

####Histograms (1)####
####

####Histograms (2)####
####

####Density plots####
####

####Shortcuts###
####

####ggvis and group_by####
####

####group_by() versus interaction()####
####


df <- read.csv(textConnection(
"C1,C2,C3,C4,C5
1,5,9,13,17
2,6,10,14,18
3,7,11,15,19
4,8,12,16,20"))

df$sum <- rowSums(df)
write.csv(df,row.names = FALSE)


library("rstudioapi")
setwd(dirname(getActiveDocumentContext()$path))

library(lctools)
data(GR.Municipalities)
inc<-GR.Municipalities$Income01
inc.hist<-hist(inc, breaks=10, col="blue",
               main="Income Histogram",
               xlab="Income class",
               ylab="Number of Municipalities")
inc.hist

b.plot<-boxplot( inc, col="blue", main="Income Boxplot")
b.plot

# IMPORTANT URL FOR GREEK GEODATA
# http://geodata.gov.gr/en/dataset

download.file("http://geodata.gov.gr/dataset/58c5af52-688a-4465-a466-51f319a8bcf3/resource/5af0f05f-119f-46a1-8e8d-b006159b5cd5/download/zhthshenergeiasnoikokyriwn.zip", "energy.zip")

#Αποσυμπίεση αρχείου
unzip("energy.zip")

#έλεγχος περιεχομένων φακέλου
Folders <- dir()

#έλεγχος περιεχομένων υποφακέλου
Files <- dir(Folders[3])

install.packages("rgdal")
 install.packages("classInt ")
 library(rgdal)
 library(classInt)
 library(RColorBrewer)
 library(maptools)

 en.map <- readOGR("./zhthsh_energeias_noikokyriwn","zhthsh_energeias_noikokyriwn")

# ####################
 library(lctools)
 data(GR.Municipalities)
 mydata<-GR.Municipalities

 #δημιουργία πλαισίου δεδομένων για ταυτόχρονη δημιουργία θηκογραμμάτων
 df<-data.frame(Male.Unempl.Rate= mydata$UnemrM01, Female.Unempl.Rate= mydata$UnemrF01)

 # δημιουργία θηκογραμμάτων και αποθήκευση των δεδομένων στο αντικείμενο b.plot
 b.plot<-boxplot(df, col="orange", main="Unemployment Boxplot")

 # εξαγωγή έκτροπων παρατηρήσεων και το φύλο που αφορούν
 outliers<-cbind(out=b.plot$out,sex=b.plot$group)

 #υπολογισμός ορίου από το οποίο και πάνω μια παρατήρηση θεωρείται έκτροπη, κατά φύλο
 out.limits <- aggregate(out ~ sex, data=outliers, min)

 #εξαγωγή έκτροπων παρατηρήσεων από τη βάση για τους άνδρες
 m.outliers<-mydata@data[which(mydata$UnemrM01>=out.limits$out[1]),]

 #προβολή α/α, ονόματος και ποσοστού ανεργίας ανδρών έκτροπων παρατηρήσεων
 m.outliers[,c(4,9)]

 #εξαγωγή εγγραφών από τη βάση που είναι έκτροπες παρατηρήσεις
 #για τις γυναίκες
 f.outliers<-mydata@data[which(mydata$UnemrF01>=out.limits$out[2]),]

 #προβολή α/α, ονόματος και ποσοστού ανεργίας γυναικών
 #έκτροπων παρατηρήσεων
 f.outliers[,c(4,10)]


# Let the underlying population proportion vary and just look at the distribution.

samples <- function(theta, sample_sizes) {
  # Assume each sample is of size 50
  res <- c()
  for(idx in seq_along(sample_sizes)) {
    res[idx] <- rbinom(n=1, size=sample_sizes[idx], theta)
  }

  res
}

run_simulation <- function(n, trap_counts, theta) {
  res = NULL
  for(i in 1:n) {
    experiment <- samples(theta=theta, sample_sizes=trap_counts)
    df <- data.frame(neg=sum(experiment == 0), pos=sum(experiment > 0))
    res = rbind(res, df)
  }

  res
}

run_simple <- function(theta) {
  # Looks like it should be ~.006
  species_data <- filter(trai, Species=="CULEX PIPIENS")
  presence <- table(temp$WnvPresent)
  names(presence) <- c("neg", "pos")
  print("Actual:")
  print(presence)

  print("Simulated:")
  print(run_simulation(10, species_data$NumMosquitos, theta))
}

##### Try 2 - likelihood function

likelihood <- function(data, theta) {
  # Calculates the P(data | theta)
  # = product of individual probabilities
  # The probability that a specific detection of wnv is
  # 1 - prob(no detection) and prob(no virus) = (1 - infection_rate)^n
  p_no_virus = (1 - theta)

  counts <- data$NumMosquitos
  wnv <- data$WnvPresent

  log_likelihood = 0
  p_detections = c()
  p_no_detections = c()
  for(idx in seq_along(counts)){
    count <- counts[idx]
    p_no_detection = p_no_virus ^ count
    p_detection = 1 - p_no_detection

    p_detections[idx] = p_detection
    p_no_detections[idx] = p_no_detection
  }

  df <- data.frame(neg=log(p_no_detections), pos=log(p_detections), data$WnvPresent, data$NumMosquitos)

  # Add the likelihood of presence on the detected with the absence in the non-detected
  likelihood = sum(df$pos[data$WnvPresent == 1]) + sum(df$neg[data$WnvPresent == 0])

  likelihood
}

run_likelihood <- function(species, year) {
  res = data.frame()

  for(y in year) {
    species_data <- filter(trai, Species==species, dYear==y)
    infection_rates = seq(.0001, .030, by=.001)
    likelihoods <- sapply(infection_rates, likelihood, data=species_data)
    row <- arrange(data.frame(species=species, year=y, p=infection_rates, likelihood=likelihoods), desc(likelihood))[1,]
    res <- rbind(res, row)
  }

  res
}

# Wow! They agree!
#print("Using naive simulation with theta=.006")
#run_simple(.0058)

print("Using likelihood")
p <- run_likelihood("CULEX PIPIENS", c(2007, 2009, 2011, 2013))
pr <- run_likelihood("CULEX PIPIENS/RESTUANS", c(2007, 2009, 2011, 2013))
r <- run_likelihood("CULEX RESTUANS", c(2007, 2009, 2011, 2013))

infection_rates <- rbind(p, pr, r)
infection_rates <- select(infection_rates, -likelihood)
# Results


#' Results of rolling dice
#'
#' @param n.iter The number of iterations in the monte carlo simulation (integer > 0)
#' @param n.dice The number of dice that should be rolled on each trial (integer > 0)
#' @param sides The number of sides on each die (integer > 0)
#' @param sum.dice Should the result be the sum of the dice on each iteration (defaults to \code{FALSE})
#' @param parallel Should the simulation take advantage of multiple cores (defaults to \code{TRUE} -
#'   highly recommended if \code{n.iter > 1e5})
#' @return If \code{sum.dice == TRUE} then the return is a vector of \code{n.iter} integer entries
#'   else the return is a \code{n.iter x n.dice} integer matrix
#' @export
#'
roll.dice = function(n.iter = 1e5, n.dice = 1, sides = 6,
                     sum.dice = FALSE, parallel = TRUE) {
  stopifnot(n.iter %% 1 == 0 & n.iter > 0)
  stopifnot(n.dice %% 1 == 0 & n.dice > 0)
  stopifnot(sides %% 1 == 0 & sides > 0)
  if(!parallel) {
    results = sapply(seq_len(n.iter), FUN = function(i) {sample(seq_len(sides), size = n.dice, replace = TRUE)})
  } else {
    results = do.call(cbind, mclapply(seq_len(n.iter), FUN = function(i) {sample(seq_len(sides), size = n.dice, replace = TRUE)}))
  }
  if(sum.dice & n.dice > 1) {return(colSums(results))}
  return(matrix(results, ncol = n.dice))
}