data(ctdmeta)
data(inflows)
data(tides)
data(wll)
data(habgrids)
data(willowcreek)

shinyServer(function(input, output, session){

reactivehab = reactiveValues(grid = habgrids)
  observe({
    if(input$navbar == "stop")
      stopApp()
  })

########## Explore Transect ###################################################

########## side bar ###########

  # drop-down selection box for transect date
  output$transect_date = renderUI({
    selectInput("transect_date", "Select transect", size = 10, selected = 1,
      selectize = FALSE, choices = setNames(seq(nrow(ctdmeta)),
        paste(strftime(ctdmeta$start, "%Y-%m-%d"),
          paste0(strftime(ctdmeta$start, "%H:%M"), "--",
            strftime(ctdmeta$end, "%H:%M")),
          paste0("(", ctdmeta$code,")")))
    )
  })

 # prep for flow/tide/wll plots
  intervalstart = reactive(ctdmeta[input$transect_date, "start"] - 3.5*86400)
  intervalend = reactive(ctdmeta[input$transect_date, "start"] + 3.5*86400)
  x.scale = reactive(scale_x_datetime("", limits = c(intervalstart(),
    intervalend())))
  transect.lines = reactive({
    d = data.frame(date = as.numeric(ctdmeta[input$transect_date, "start"]),
      availability = ifelse(ctdmeta[input$transect_date, "numcasts"] < 12,
        "partial", "complete"))
    list(
      geom_vline(data = d, aes(xintercept = date, linetype = availability)),
      scale_linetype_manual(values = c("complete" = "solid",
        "partial" = "dashed"), guide = FALSE)
    )
  })

  # plot the flows
  inflowdata = reactive(filter(inflows, datetime >= intervalstart(),
    datetime <= intervalend(), gauge == "russian river"))
  output$transect_flows = renderPlot({
    ggplot(inflowdata(), aes(x = datetime, y = flow)) +
    geom_line(color = "#377eb8") + ggtitle("Russian River Flow") +
    transect.lines() + ylab("inflow (m3/s)") + x.scale()
  })

  # plot the tides
  tidedata = reactive(filter(tides, datetime >= intervalstart(),
    datetime <= intervalend()))
  output$transect_tides = renderPlot({
    ggplot(tidedata(), aes(x = datetime, y = height)) +
    geom_line(color = "#377eb8") + ggtitle("Point Reyes Tide Height") +
    transect.lines() + ylab("tide height (MLLW, m)") + x.scale()
  })

  # plot the water level
  wlldata = reactive(filter(wll2, mtime >= intervalstart(),
    mtime <= intervalend()))
  output$transect_wll = renderPlot({
    ggplot(wlldata(), aes(x = mtime, y = wll)) +
    geom_line(color = "#377eb8") + ggtitle("Water surface elevation at Jenner") +
    transect.lines() + ylab("water surface elevation (NGVD29, m)") + x.scale()
  })

########## main panel ##########

  # get the grid for selected transect
  transectdate = reactive(strftime(ctdmeta[input$transect_date, "start"],
    "%Y-%m-%d", tz = "US/Pacific"))
  transectid = reactive(ctdmeta[input$transect_date, "id"])
  griddata = reactive(mutate_(filter(reactivehab$grid, date == transectdate(),
    id == transectid()), habitat = input$habitat_type))

  # plot settings
  plot.settings = list(
    xlim(min(habgrids$dist), max(habgrids$dist)),
    ylim(-15.8, 3.3),
    ylab("elevation above NAVD29 (m)"),
    xlab("distance from river mouth (m)")
  )
  overall.colors = c(
    "optimal" = "#66c2a5",
    "growth limited" = "#ffff99",
    "impaired" = "#fdbf6f",
    "energy demanding" = "#cab2d6",
    "growth limited, impaired" = "#fb9a99",
    "growth limited, energy demanding" = "#6a3d9a",
    "impaired, energy demanding" = "#ff7f00",
    "growth limited, impaired, energy demanding" = "#b15928",
    "unsuitable" = "#000000"
  )
  ta.colors = setNames(brewer.pal(4, "RdYlGn"), c("unsuitable",
    "negative/no growth", "positive growth", "optimal growth"))
  sa.colors = setNames(c("#c51b7d", "#f1b6da", "#92c5de", "#2166ac"),
    c("marine", "brackish", "isotonic", "freshwater"))
  oa.colors = setNames(brewer.pal(4, "BrBG"), c("unsuitable",
    "severe impairment", "some impairment", "minimal impairment"))
  depth.colors = setNames(brewer.pal(5, "BuPu"), c("littoral",
    "surface limnetic", "epibenthic", "subsurface limnetic", "profundal")
)
  habitat.colors = reactive({
    switch(input$habitat_type,
      "habitat.fwa" = scale_fill_manual("Overall habitat quality",
        values = overall.colors, drop = FALSE),
      "habitat.swa" = scale_fill_manual("Overall habitat quality",
        values = overall.colors, drop = FALSE),
      "ta.qual" = scale_fill_manual("Temperature quality",
        values = ta.colors, drop = FALSE),
      "sa.qual" = scale_fill_manual("Salinity quality",
        values = sa.colors, drop = FALSE),
      "oa.qual" = scale_fill_manual("Dissolved oxygen quality",
        values = oa.colors, drop = FALSE),
      "ta" = scale_fill_distiller("Temperature\n", type = "div",
        palette = "RdYlBu", guide = "colourbar"),
      "sa" = scale_fill_distiller("Salinity\n", type = "div",
        palette = "PRGn", guide = "colourbar"),
      "oa" = scale_fill_distiller("Dissolved Oxygen\n", type = "div",
        palette = "BrBG", direction = 1, guide = "colourbar")
    )
  })

landmarkdat = data.frame(landmark = c("Penny Island", "CA-1 Bridge",
  "Heron Rookery","Mos. Rd. Bridge"), dist = c(1250, 3800, 8000, 10600),
  elev = 3.3)
landmarks = geom_label(data = landmarkdat, aes(x = dist, y = elev,
  label = landmark), inherit.aes = FALSE)

  # plot the main grid
  habitat.plot = reactive(ggplot(griddata(), aes(x = dist, y = elev,
      fill = habitat)) + geom_raster() + landmarks +
      plot.settings + habitat.colors() +
      theme(legend.position = "none")
  )
  output$grid_plot = renderPlot({
    habitat.plot()
  })

  # plot the categories
  cat.settings = list(
    scale_y_continuous("total volume (m3)\n", labels = comma),
    theme(axis.text.x = element_blank(), axis.title.x = element_blank(),
      axis.ticks.x = element_blank())
  )

  catdata = reactive(summarize(group_by(griddata(), date, habitat),
    volume = sum(volume.total)))

  cat.plot = reactive(ggplot(arrange(catdata(), -as.numeric(habitat)),
    aes(x = date, y = volume, fill = habitat)) +
    geom_bar(stat = "identity", position = "stack") +
    habitat.colors() + cat.settings + theme(legend.position = "left")
  )
  output$category_bar = renderPlot({
    cat.plot()
  })

  # overall volume
  depthvoldata = reactive({
    depthvoldata = gather(summarize(group_by(griddata(), date, habitat),
      volume.littoral = sum(volume.littoral),
      volume.limnetic = sum(volume.limnetic),
      volume.epibenthic = sum(volume.epibenthic),
      volume.sublimnetic = sum(volume.sublimnetic),
      volume.profundal = sum(volume.profundal)
      ), depth.cat, volume, -habitat, -date)
  depthvoldata["depth.cat"] = factor(depthvoldata$depth.cat,
      levels = c("volume.littoral", "volume.limnetic", "volume.epibenthic",
        "volume.sublimnetic", "volume.profundal"),
      labels = c("littoral", "surface limnetic", "epibenthic",
        "subsurface limnetic", "profundal"))
  depthvoldata
  })
  vol.depth = reactive(ggplot(arrange(depthvoldata(), -as.numeric(depth.cat)),
    aes(x = date, y = volume, fill = depth.cat)) +
    geom_bar(stat = "identity") +
    scale_fill_manual("depth category", values = depth.colors,
      drop = FALSE) + cat.settings +
    theme(axis.text.y = element_blank(), axis.title.y = element_blank(),
      axis.ticks.y = element_blank())

  )
  output$depth_vol = renderPlot({
    vol.depth()
  })

  # plot by depth
  depthdata = reactive({
    depthdata = summarize(group_by(gather(griddata(), depth.zone,
      volume, volume.littoral, volume.limnetic, volume.epibenthic,
      volume.sublimnetic, volume.profundal), date, depth.zone, habitat),
      volume = sum(volume))
    depthdata["depth.zone"] = factor(depthdata$depth.zone,
      levels = c("volume.littoral", "volume.limnetic", "volume.epibenthic",
        "volume.sublimnetic", "volume.profundal"),
      labels = c("littoral", "surface limnetic", "epibenthic",
        "subsurface limnetic", "profundal"))
    depthdata
  })

  cat.depth = reactive(ggplot(arrange(depthdata(), -as.numeric(habitat)),
    aes(x = date, y = volume, fill = habitat)) +
    geom_bar(stat = "identity", position = "stack") +
    habitat.colors() + cat.settings + theme(legend.position = "none") +
    facet_wrap(~ depth.zone, nrow = 1) + theme(axis.title.y = element_blank())
  )

  output$depth_cat = renderPlot({
    cat.depth()
  })

########### Explore Periods ###################################################

########## side bar ###########

  output$period = renderUI({
    selectInput("period_date", "Select transects", size = 10, selected = c(1,2),
      multiple = TRUE, selectize = FALSE, choices = setNames(seq(nrow(ctdmeta)),
        paste(strftime(ctdmeta$start, "%Y-%m-%d"),
          paste0(strftime(ctdmeta$start, "%H:%M"), "--",
            strftime(ctdmeta$end, "%H:%M")),
          paste0("(", ctdmeta$code,")")))
    )
  })

 # prep for flow/tide/wll plots
  periodrange = reactive(sort(input$period_date))
  periodstart = reactive(ctdmeta[periodrange()[1], "start"] - 3.5*86400)
  periodend = reactive(ctdmeta[rev(periodrange())[1], "start"] + 3.5*86400)
  periodinflow = reactive(filter(inflows, datetime >= periodstart(),
    datetime <= periodend(), gauge == "russian river"))
  periodtide = reactive(filter(tides, datetime >= periodstart(),
    datetime <= periodend()))
  periodwll = reactive(filter(wll2, mtime >= periodstart(),
    mtime <= periodend()))
  period.x.scale = reactive(scale_x_datetime("", limits = c(periodstart(),
    periodend())))

  region.setting = reactive({
    d = data.frame(date = as.numeric(ctdmeta[periodrange(), "start"]),
      availability = ifelse(ctdmeta[periodrange(), "numcasts"] < 12,
        "partial", "complete"))
    list(
      geom_vline(data = d, aes(xintercept = date, linetype = availability)),
      scale_linetype_manual(values = c("complete" = "solid",
        "partial" = "dashed"), guide = FALSE)
    )
  })

  # plot the flows
  output$period_flows = renderPlot({
    ggplot(periodinflow(), aes(x = datetime, y = flow)) +
    geom_line(color = "#377eb8") + ggtitle("Russian River Flow") +
    ylab("inflow (m3/s)") + period.x.scale() + region.setting()
  })

  # plot the tides
  output$period_tides = renderPlot({
    ggplot(periodtide(), aes(x = datetime, y = height)) +
    geom_line(color = "#377eb8") + ggtitle("Point Reyes Tide Height") +
    ylab("tide height (MLLW, m)") + period.x.scale() + region.setting()
  })

  # plot the water level
  output$period_wll = renderPlot({
    ggplot(periodwll(), aes(x = mtime, y = wll)) +
    geom_line(color = "#377eb8") + ggtitle("Water Surface Elevation at Jenner") +
    ylab("water surface elevation (NGVD29, m)") + period.x.scale() + region.setting()
  })

########## main panel ##########

  # get the grid for selected period
  perioddate = reactive(strftime(ctdmeta[periodrange(), "start"],
    "%Y-%m-%d", tz = "US/Pacific"))
  periodtime = reactive(ctdmeta[periodrange(), "start"])
  periodid = reactive(ctdmeta[periodrange(), "id"])
  periodgrids = reactive(mutate_(filter(reactivehab$grid, date %in% as.Date(perioddate()),
    id %in% periodid()), habitat = input$period_habitat_type))

    period.habitat.colors = reactive({
    switch(input$period_habitat_type,
      "habitat.fwa" = overall.colors,
      "habitat.swa" = overall.colors,
      "ta.qual" = ta.colors,
      "sa.qual" = sa.colors,
      "oa.qual" = oa.colors
    )
  })

  # overall habitat plots
  overall.gathered = reactive({
    hablevels = levels(periodgrids()$habitat)
    overall = summarize(group_by(periodgrids(), date, id,
      habitat, code, days.since.closure),
      volume = sum(volume.total))
    ovlevels = as.character(unique(overall$habitat))
    overall.spread = spread_(overall, "habitat", "volume", fill = 0)
    overall.spread["total.volume"] = rowSums(overall.spread[ovlevels])
    overall.gathered = gather_(overall.spread, "habitat", "volume",
      gather_cols = ovlevels)
    overall.gathered["habitat"] = factor(overall.gathered$habitat,
      levels = hablevels)
    overall.gathered["volume.frac"] = overall.gathered$volume/
                                      overall.gathered$total.volume
    overall.gathered = left_join(overall.gathered,
      unique(periodgrids()[c("date", "id", "wse")]), by = c("date", "id"))
    overall.gathered = left_join(overall.gathered,
      data.frame(date = as.Date(perioddate()), id = periodid(),
        datetime = periodtime()), by = c("date", "id"))
    overall.gathered
  })
  output$period_overall = renderPlot({
    if(input$plot_type == "stacked area"){
      ggplot(arrange(overall.gathered(), -as.numeric(habitat)),
        aes(x = datetime, y = volume, fill = habitat)) +
        geom_area(position = "stack") + scale_x_datetime("") +
        scale_fill_manual("", values = period.habitat.colors(), drop = FALSE) +
        theme(legend.position = "left") +
        scale_y_continuous(name = "Volume (m3)", labels = comma) +
        region.setting()
    } else{
      ggplot(arrange(overall.gathered(), -as.numeric(habitat)),
        aes(x = factor(datetime), y = volume, fill = habitat)) + xlab("") +
        geom_bar(stat = "identity", position = "stack") +
        scale_fill_manual("", values = period.habitat.colors(), drop = FALSE) +
        theme(legend.position = "left") +
        scale_y_continuous(name = "Volume (m3)", labels = comma)
    }
  })

  # depth plots
  alldepth = reactive({
    alldepth = summarize(group_by(gather(periodgrids(), depth.zone,
      volume, volume.littoral, volume.limnetic, volume.epibenthic,
      volume.sublimnetic, volume.profundal), date, id,
      depth.zone, code, days.since.closure),
      volume = sum(volume))
    alldepth["depth.zone"] = factor(alldepth$depth.zone, ordered = TRUE,
      levels = c("volume.littoral", "volume.limnetic", "volume.epibenthic",
        "volume.sublimnetic", "volume.profundal"),
      labels = c("littoral", "surface limnetic", "epibenthic",
        "subsurface limnetic", "profundal"))
    alldepth = left_join(alldepth,
      unique(periodgrids()[c("date", "id", "wse")]), by = c("date", "id"))
    alldepth = left_join(alldepth,
      data.frame(date = as.Date(perioddate()), id = periodid(),
        datetime = periodtime()), by = c("date", "id"))
    alldepth
  })

  output$period_alldepth = renderPlot({
    if(input$plot_type == "stacked area"){
      ggplot(arrange(alldepth(), -as.numeric(depth.zone)),
        aes(x = datetime, y = volume, fill = depth.zone)) +
        geom_area(position = "stack") + scale_x_datetime("") +
        scale_fill_manual("", values = depth.colors, drop = FALSE) +
        theme(legend.position = "left") +
        scale_y_continuous(name = "Volume (m3)", labels = comma) +
        region.setting()
    } else{
      ggplot(arrange(alldepth(), -as.numeric(depth.zone)),
        aes(x = factor(datetime), y = volume, fill = depth.zone)) + xlab("") +
        geom_bar(stat = "identity", position = "stack") +
        scale_fill_manual("", values = depth.colors, drop = FALSE) +
        theme(legend.position = "left") +
        scale_y_continuous(name = "Volume (m3)", labels = comma)
    }
  })

  # stratified habitat plots
  bydepth.gathered = reactive({
    hablevels = levels(periodgrids()$habitat)
    bydepth = summarize(group_by(gather(periodgrids(), depth.zone,
      volume, volume.littoral, volume.limnetic, volume.epibenthic,
      volume.sublimnetic, volume.profundal), date, id,
      habitat, depth.zone, code, days.since.closure),
      volume = sum(volume))
    ovlevels = as.character(unique(bydepth$habitat))
    bydepth.spread = spread_(bydepth, "habitat", "volume", fill = 0)
    bydepth.spread["total.volume"] = rowSums(bydepth.spread[ovlevels])
    bydepth.gathered = gather_(bydepth.spread, "habitat", "volume",
      gather_cols = ovlevels)
    bydepth.gathered["habitat"] = factor(bydepth.gathered$habitat,
      levels = hablevels)
    bydepth.gathered["volume.frac"] = bydepth.gathered$volume/
                                      bydepth.gathered$total.volume
    bydepth.gathered = left_join(bydepth.gathered,
      unique(periodgrids()[c("date", "id", "wse")]), by = c("date", "id"))
    bydepth.gathered = left_join(bydepth.gathered,
      data.frame(date = as.Date(perioddate()), id = periodid(),
        datetime = periodtime()), by = c("date", "id"))
    bydepth.gathered["depth.zone"] = factor(bydepth.gathered$depth.zone,
      levels = c("volume.littoral", "volume.limnetic", "volume.epibenthic",
        "volume.sublimnetic", "volume.profundal"),
      labels = c("littoral", "surface limnetic", "epibenthic",
        "subsurface limnetic", "profundal"))
    bydepth.gathered
  })
  output$period_bydepth = renderPlot({
    if(input$plot_type == "stacked area"){
      ggplot(arrange(bydepth.gathered(), -as.numeric(habitat)),
        aes(x = datetime, y = volume, fill = habitat)) +
        geom_area(position = "stack") + scale_x_datetime("") +
        scale_fill_manual("", values = period.habitat.colors(), drop = FALSE) +
        theme(legend.position = "none") +
        scale_y_continuous(name="Volume (m3)", labels = comma) +
        region.setting() + facet_wrap(~ depth.zone, ncol = 1, scales = "free_y")
    } else{
      ggplot(arrange(bydepth.gathered(), -as.numeric(habitat)),
        aes(x = factor(datetime), y = volume, fill = habitat)) + xlab("") +
        geom_bar(stat = "identity", position = "stack") +
        scale_fill_manual("", values = period.habitat.colors(), drop = FALSE) +
        theme(legend.position = "none") +
        scale_y_continuous(name="Volume (m3)", labels = comma) +
        facet_wrap(~ depth.zone, ncol = 1, scales = "free_y")
    }
  })

########## Perturbate Transect ###################################################

########## main panel ##########
  output$perturb_date = renderUI({
    selectInput("perturb_date", "Select transect", size = 10, selected = 1,
      selectize = FALSE, choices = setNames(seq(nrow(ctdmeta)),
        paste(strftime(ctdmeta$start, "%Y-%m-%d"),
          paste0(strftime(ctdmeta$start, "%H:%M"), "--",
            strftime(ctdmeta$end, "%H:%M")),
          paste0("(", ctdmeta$code,")")))
    )
  })

  # get the grid for selected transect
  perturbdate = reactive(strftime(ctdmeta[input$perturb_date, "start"],
    "%Y-%m-%d", tz = "US/Pacific"))
  perturbid = reactive(ctdmeta[input$perturb_date, "id"])
  perturbdata = reactive({
    res = mutate_(filter(reactivehab$grid, date == perturbdate(),
    id == perturbid()), habitat = input$perturb_var)
    updateSliderInput(session, "window_dist",
      min = min(res$dist), max = max(res$dist), step = 100,
      value = c(min(res$dist), max(res$dist)))
    updateSliderInput(session, "window_elev",
      min = min(res$elev), max = max(res$elev), step = 0.1,
      value = c(min(res$elev), max(res$elev)))
    res
    })

  perturb.habitat.colors = reactive({
    switch(input$perturb_var,
      "ta" = scale_fill_distiller("Temperature", type = "div",
        palette = "RdYlBu", guide = "colourbar"),
      "sa" = scale_fill_distiller("Salinity", type = "div",
        palette = "PRGn", guide = "colourbar"),
      "oa" = scale_fill_distiller("Dissolved Oxygen", type = "div",
        palette = "RdYlGn", guide = "colourbar", direction = -1)
    )
  })

  perturb.plot = reactive(ggplot(perturbdata(), aes(x = dist, y = elev,
      fill = habitat)) + geom_raster() +
      plot.settings + perturb.habitat.colors()
  )

  perturb.window = reactive({
    d = data.frame(dist = rep(input$window_dist, each = 2),
      elev = c(input$window_elev, rev(input$window_elev)))
    geom_polygon(data = d, fill = NA, color = "black")
  })

  output$perturb_plot = renderPlot({
    perturb.plot() + perturb.window()
  })

  observeEvent(input$perturb_action, {
    perturbmask = ( reactivehab$grid$date == perturbdate() ) &
      ( reactivehab$grid$id == perturbid() ) &
      ( reactivehab$grid$dist >= min(input$window_dist) ) &
      ( reactivehab$grid$dist <= max(input$window_dist) ) &
      ( reactivehab$grid$elev >= min(input$window_elev) ) &
      ( reactivehab$grid$elev <= max(input$window_elev) )
    reactivehab$grid[perturbmask, input$perturb_var] = reactivehab$grid[[input$perturb_var]][perturbmask] + input$perturb_val
    classfun = switch(input$perturb_var,
      sa = habitatblueprint:::classify_sa,
      ta = habitatblueprint:::classify_ta,
      oa = habitatblueprint:::classify_oa)
    reactivehab$grid[perturbmask, paste0(input$perturb_var, ".qual")] = classfun(reactivehab$grid[[input$perturb_var]][perturbmask])
    reactivehab$grid[perturbmask, "habitat.fwa"] = habitatblueprint:::classify_freshwater(reactivehab$grid$ta.qual[perturbmask],
      reactivehab$grid$sa.qual[perturbmask], reactivehab$grid$oa.qual[perturbmask])
    reactivehab$grid[perturbmask, "habitat.swa"] = habitatblueprint:::classify_saltwater(reactivehab$grid$ta.qual[perturbmask],
      reactivehab$grid$sa.qual[perturbmask], reactivehab$grid$oa.qual[perturbmask])
  })

  observeEvent(input$perturb_reset, {
    reactivehab$grid = habgrids
  })

########## Willow Creek ###################################################

########## side panel ##########

  output$wc_period = renderUI({
    dateRangeInput("wc_date", "Select dates",
      min = min(as.Date(willowcreek$date)),
      max = max(as.Date(willowcreek$date)) + 1,
      start = min(as.Date(willowcreek$date)),
      end = max(as.Date(willowcreek$date)) + 1)
  })

 # prep for flow/tide/wll plots
  wcrange = reactive(as.POSIXct(sort(input$wc_date), tz = "UTC"))
  wcstart = reactive(wcrange()[1] - 3.5*86400)
  wcend = reactive(wcrange()[2] + 3.5*86400)
  wcinflow = reactive(filter(inflows, datetime >= wcstart(),
    datetime <= wcend(), gauge == "russian river"))
  wctide = reactive(filter(tides, datetime >= wcstart(),
    datetime <= wcend()))
  wcwll = reactive(filter(wll2, mtime >= wcstart(),
    mtime <= wcend()))
  wc.x.scale = reactive(scale_x_datetime("", limits = c(wcstart(),
    wcend())))

  # plot the flows
  output$wc_flows = renderPlot({
    ggplot(wcinflow(), aes(x = datetime, y = flow)) +
    geom_line(color = "#377eb8") + ggtitle("Russian River Flow") +
    ylab("inflow (m3/s)") + wc.x.scale()
  })

  # plot the tides
  output$wc_tides = renderPlot({
    ggplot(wctide(), aes(x = datetime, y = height)) +
    geom_line(color = "#377eb8") + ggtitle("Point Reyes Tide Height") +
    ylab("tide height (MLLW, m)") + wc.x.scale()
  })

  # plot the water level
  output$wc_wll = renderPlot({
    ggplot(wcwll(), aes(x = mtime, y = wll)) +
    geom_line(color = "#377eb8") + ggtitle("Water Surface Elevation at Jenner") +
    ylab("water surface elevation (NGVD29, m)") + wc.x.scale()
  })

########## main panel ##########

  # get subset of willow creek data
  wcselect = reactive({
    daterange = willowcreek$time >= wcrange()[1] &
      willowcreek$time <= wcrange()[2]
    d = willowcreek[daterange,]
    d["habitat"] = d[[input$wc_var]]
    d
  })

  wc.habitat.fills = reactive({
    switch(input$wc_var,
      "habitat.fwa" = scale_fill_manual("Overall habitat quality",
        values = overall.colors, drop = FALSE),
      "habitat.swa" = scale_fill_manual("Overall habitat quality",
        values = overall.colors, drop = FALSE),
      "ta.qual" = scale_fill_manual("Temperature quality",
        values = ta.colors, drop = FALSE),
      "sa.qual" = scale_fill_manual("Salinity quality",
        values = sa.colors, drop = FALSE),
      "oa.qual" = scale_fill_manual("Dissolved oxygen quality",
        values = oa.colors, drop = FALSE),
      "ta" = scale_fill_distiller("Temperature\n", type = "div",
        palette = "RdYlBu", guide = "colourbar"),
      "sa" = scale_fill_distiller("Salinity\n", type = "div",
        palette = "PRGn", guide = "colourbar"),
      "oa" = scale_fill_distiller("Dissolved Oxygen\n", type = "div",
        palette = "BrBG", direction = 1, guide = "colourbar")
    )
  })

  wc.habitat.colors = reactive({
    switch(input$wc_var,
      "habitat.fwa" = scale_color_manual("Overall habitat quality",
        values = overall.colors, drop = FALSE),
      "habitat.swa" = scale_color_manual("Overall habitat quality",
        values = overall.colors, drop = FALSE),
      "ta.qual" = scale_color_manual("Temperature quality",
        values = ta.colors, drop = FALSE),
      "sa.qual" = scale_color_manual("Salinity quality",
        values = sa.colors, drop = FALSE),
      "oa.qual" = scale_color_manual("Dissolved oxygen quality",
        values = oa.colors, drop = FALSE),
      "ta" = scale_color_distiller("Temperature\n", type = "div",
        palette = "RdYlBu", guide = "colourbar"),
      "sa" = scale_color_distiller("Salinity\n", type = "div",
        palette = "PRGn", guide = "colourbar"),
      "oa" = scale_color_distiller("Dissolved Oxygen\n", type = "div",
        palette = "BrBG", direction = 1, guide = "colourbar")
    )
  })

  wc.habitat.fill = reactive({
    switch(input$wc_var,
      "habitat.fwa" = scale_fill_manual("Overall habitat quality",
        values = overall.colors, drop = FALSE),
      "habitat.swa" = scale_fill_manual("Overall habitat quality",
        values = overall.colors, drop = FALSE),
      "ta.qual" = scale_fill_manual("Temperature quality",
        values = ta.colors, drop = FALSE),
      "sa.qual" = scale_fill_manual("Salinity quality",
        values = sa.colors, drop = FALSE),
      "oa.qual" = scale_fill_manual("Dissolved oxygen quality",
        values = oa.colors, drop = FALSE),
      "ta" = scale_color_distiller("Temperature\n", type = "div",
        palette = "RdYlBu", guide = "colourbar"),
      "sa" = scale_color_distiller("Salinity\n", type = "div",
        palette = "PRGn", guide = "colourbar"),
      "oa" = scale_color_distiller("Dissolved Oxygen\n", type = "div",
        palette = "BrBG", direction = 1, guide = "colourbar")
    )
  })

  output$wc_overall = renderPlot({
    if (input$wc_var %in% c("ta", "sa", "oa")) {
      ggplot(wcselect(), aes(x = time,
          y = volume.total, group = 1L, color = habitat)) +
        geom_line() + wc.habitat.colors() +
        scale_x_datetime("") +
        theme(legend.position = "left") +
        scale_y_continuous(name = "Volume (m3)", labels = comma)
    } else {
      wchab = gather(
        spread(
          select(wcselect(), time, volume.total, habitat),
            habitat, volume.total, fill = 0
        ),
        habitat, volume.total, -time
      )
      ggplot(wchab, aes(x = time,
          y = volume.total, fill = habitat)) +
        geom_area() + wc.habitat.fill() +
        scale_x_datetime("") +
        theme(legend.position = "left") +
        scale_y_continuous(name = "Volume (m3)", labels = comma)
    }
  })

  output$wc_depth = renderPlot({
    wcdepth = ungroup(summarize(group_by(gather(wcselect(), depth.zone,
      volume, volume.littoral, volume.limnetic, volume.epibenthic,
      volume.sublimnetic, volume.profundal), time,
      depth.zone), volume = sum(volume)))
    wcdepth["depth.zone"] = factor(wcdepth$depth.zone, ordered = TRUE,
      levels = c("volume.littoral", "volume.limnetic", "volume.epibenthic",
        "volume.sublimnetic", "volume.profundal"),
      labels = c("littoral", "surface limnetic", "epibenthic",
        "subsurface limnetic", "profundal"))
    ggplot(wcdepth, aes(x = time, y = volume, fill = depth.zone)) +
      geom_area(position = "stack") + scale_x_datetime("") +
      scale_fill_manual("", values = depth.colors, drop = FALSE) +
      theme(legend.position = "left") +
      scale_y_continuous(name = "Volume (m3)", labels = comma)
  })

})


rm(list = ls())
setwd(dirname(parent.frame(2)$ofile))

library(plyr)
library(dplyr)
library(tidyr)
library(readr)
require(MASS)
library(KScorrect) # citation("KScorrect")

source('./_function_task_expand_name.r')
source('./_function_task_table.r')
source('./_compute_summary.r')

best.range = 5000

best.model.step.fn = function (errors) {
  best.step = max(length(errors) - best.range, 0) + which.min(tail(errors, best.range))
  if (length(best.step) == 0) {
    return(length(errors))
  } else {
    return(best.step)
  }
}

first.solved.step = function (steps, errors, threshold) {
  index = first(which(errors < threshold))
  if (is.na(index)) {
    return(NA)
  } else {
    return(steps[index])
  }
}

eps = read_csv('../results/function_task_static_mse_expectation.csv') %>%
  filter(simple == FALSE & parameter == 'default') %>%
  mutate(
    operation = revalue(operation, operation.full.to.short),
  ) %>%
  select(operation, threshold)

dat = expand.name(
  read_csv('../results/function_task_static.csv', col_types=cols(sparse.error.max=col_double()))
) %>%
  merge(eps)

dat.last = dat %>%
  group_by(name) %>%
  #filter(n() == 201) %>%
  summarise(
    threshold = last(threshold),
    best.model.step = best.model.step.fn(metric.valid.interpolation),
    interpolation.last = metric.valid.interpolation[best.model.step],
    extrapolation.last = metric.test.extrapolation[best.model.step],
    interpolation.step.solved = first.solved.step(step, metric.valid.interpolation, threshold),
    extrapolation.step.solved = first.solved.step(step, metric.test.extrapolation, threshold),
    sparse.error.max = sparse.error.max[best.model.step],
    solved = replace_na(metric.test.extrapolation[best.model.step] < threshold, FALSE),
    model = last(model),
    operation = last(operation),
    seed = last(seed),
    size = n()
  )

dat.last = read_csv('../paper/results/sft-last.csv')

dat.last.rate = dat.last %>%
  group_by(model, operation) %>%
  group_modify(compute.summary) %>%
  ungroup()

dat.last.dist.paramaters = merge(dat.last, dat.last.rate) %>%
  group_by(model, operation) %>%
  group_modify(function (df, ...) {

    if (with(df, length(unique(extrapolation.step.solved[solved]))) > 10) {
      converged.at.p.value = with(df, LcKS(
        extrapolation.step.solved[solved], "pgamma",
        parallel = TRUE,#,
        #(last(converged.at.mean) * last(converged.at.mean)) / last(converged.at.sigma.2),
        #last(converged.at.mean) / last(converged.at.sigma.2)
      ))$p.value
    } else {
      converged.at.p.value = NA
    }

    if (sum(df$solved) > 1) {
      sparse.error.p.value = with(df, ks.test(
        sparse.error.max[solved], "pbeta",
        last(sparse.error.mean) * 2 * last(sparse.error.v),
        (1 - last(sparse.error.mean) * 2) * last(sparse.error.v)
      ))$p.value
    }

    return(with(df, data.frame(
      converged.at.sigma.2 = last(converged.at.sigma.2),
      converged.at.p.value = converged.at.p.value,
      converged.at.mean = last(converged.at.mean),
      converged.at.lower = last(converged.at.lower),
      converged.at.upper = last(converged.at.upper),

      sparse.error.v = last(sparse.error.v),
      sparse.error.mean = last(sparse.error.mean),
      sparse.error.lower = last(sparse.error.lower),
      sparse.error.upper = last(sparse.error.upper)
    )))
  })


ANPP<-read.csv('LUCAS_ANPP_calcs_ER73_Stagg_201906.csv')
BNPP<-read.csv('LUCAS_BNPP_calcs_ER73_Stagg_201906.csv')
PrevCal<-read.csv('LUCAS_Stocks_ER73_Stagg_201906.csv')
PrevID<-as.character(PrevCal[,1])

#reconcile naming conventions
xx<-which(PrevID=="BA")
zz<-which(PrevID!="BA")
PrevID[xx]<-'BA-01-04'
PrevID2<-PrevID
for(i in 1:length(zz)){
  if(as.numeric(PrevID[zz[i]])>1000)PrevID2[zz[i]]<-as.character(paste('CRMS',as.character(as.numeric(PrevID[zz[i]])),sep=''))
  if(as.numeric(PrevID[zz[i]])<1000)PrevID2[zz[i]]<-as.character(paste('CRMS0',as.character(as.numeric(PrevID[zz[i]])),sep=''))
}

#Get Marsh Type for ANPP BNPP
ANPPtype<-rep(NA,dim(ANPP)[1])
for(i in 1:dim(ANPP)[1]){
  ANPPtype[i]<-as.character(PrevCal$Wetland.Subclass.LUCAS[which(PrevID2==ANPP[i,1])[1]])
}

BNPPtype<-rep(NA,dim(BNPP)[1])
for(i in 1:dim(ANPP)[1]){
  BNPPtype[i]<-as.character(PrevCal$Wetland.Subclass.LUCAS[which(PrevID2==BNPP[i,1])[1]])
}

#to start and end with winter (min living biomass), use Production listed under T3-T6
#Camille already has calculated, so simply need to sum interval productions

#########Notes on calculations#############
#Changes calculated according to Smalley 1959
#four cases based on Live.Change.g and Dead.Change.g being positive or negative, respectively
#reduces to NPP = max(ANPP$Live.Change.g+max(ANPP$Dead.Change.g,0),0)
#Change in live, plus any positive change in dead material
#if result is negative, NPP is zero (it can't be negative in this algorithm)
#conservative estimate of NPP, always zero or postive but probably underestimates losses and thus production when production is high
#you can check this by uncommenting following two lines, they should print zeros
#print(sum(as.numeric(ANPP$Interval.Production.g)-max(as.numeric(ANPP$Live.Change.g)+max(as.numeric(ANPP$Dead.Change.g),0),0),na.rm=T))
#print(sum(as.numeric(BNPP$Interval.Production.g)-max(as.numeric(BNPP$Live.Change.g)+max(as.numeric(BNPP$Dead.Change.g),0),0),na.rm=T))

ANPPsites<-unique(ANPP[,1])
ANPPannual<-matrix(NA,length(ANPPsites)*5,4)
for(i in 1:length(ANPPsites)){
  xx<-which(ANPP[,1]==ANPPsites[i]&(ANPP$Event=='T3'|ANPP$Event=='T4'|ANPP$Event=='T5'|ANPP$Event=='T6'))
  ANPPannual[((i-1)*5+1):((i-1)*5+5),1]<-as.character(ANPP[xx[1],1])
  ANPPannual[((i-1)*5+1):((i-1)*5+5),2]<-ANPPtype[xx[1]]
  for(j in 1:5){
    ANPPannual[((i-1)*5+j),3]<-j
    xxx<-which(ANPP[,1]==ANPPsites[i]&(ANPP$Event=='T3'|ANPP$Event=='T4'|ANPP$Event=='T5'|ANPP$Event=='T6')&as.numeric(ANPP[,2])==j)
    ANPPannual[((i-1)*5+j),4]<-sum(as.numeric(ANPP$Interval.Production.g[xxx])/as.numeric(ANPP$Plot.Area.m2[xxx]))*.5
  }
}

BNPPsites<-unique(BNPP[,1])
BNPPannual<-matrix(NA,length(BNPPsites)*5,4)
for(i in 1:length(BNPPsites)){
  xx<-which(BNPP[,1]==BNPPsites[i]&(BNPP$Event=='T3'|BNPP$Event=='T4'|BNPP$Event=='T5'|BNPP$Event=='T6'))
  BNPPannual[((i-1)*5+1):((i-1)*5+5),1]<-as.character(BNPP[xx[1],1])
  BNPPannual[((i-1)*5+1):((i-1)*5+5),2]<-BNPPtype[xx[1]]
  for(j in 1:5){
    BNPPannual[((i-1)*5+j),3]<-j
    xxx<-which(BNPP[,1]==BNPPsites[i]&(BNPP$Event=='T3'|BNPP$Event=='T4'|BNPP$Event=='T5'|BNPP$Event=='T6')&as.numeric(BNPP[,2])==j)
    BNPPannual[((i-1)*5+j),4]<-sum(as.numeric(BNPP$Interval.Production.g[xxx])/as.numeric(BNPP$Core.Area.m2[xxx]))*.5
  }
}

colnames(ANPPannual)<-c('Site','Wetland_Type','Transect','ANPP.g.m-2.y-1')
colnames(BNPPannual)<-c('Site','Wetland_Type','Transect','BNPP.g.m-2.y-1')

write.csv(ANPPannual,'ANPPannual.csv',row.names=F)
write.csv(BNPPannual,'BNPPannual.csv',row.names=F)


# R script for plotting ROC curve for different tableau search methods
# Alex Stivala
# July 2008
# Reduced version to make clearer in grayscale (showing only those that
# don't overlap too much).
# $Id: plotsearchroc_folds_00_reduced.r 1946 2008-10-04 05:14:43Z astivala $

#
# globals
#

colorvec=c('black','black','black','black','black','black')
ltyvec=c(1,2,5,4,5,6)
namevec=c('beta-grasp', 'Immunoglobulin', 'TIM-barrel', 'Plait (ferredoxin)', 'Key-barrel')

#
# main
#

betagrasp <- read.table('d1ubia_.tsrchn.tt.rtab', header=TRUE)
immunoglobulin <- read.table('d1ae6h1.tsrchn.orderpen0.typepen0.rtab', header=TRUE)
timbarrel <- read.table('d1tima_.tsrchn.orderpen0.typepen0.rtab', header=TRUE)
plait <- read.table('d1bhne_.tsrchn.orderpen0.typepen0.rtab', header=TRUE)
keybarrel <- read.table('d1tttb1.tsrchn.orderpen0.typepen0.rtab', header=TRUE)

# EPS suitable for inserting into LaTeX
postscript('searchroc_folds_reduced.eps',onefile=FALSE,paper="special",horizontal=FALSE,
           width = 9, height = 6)

plot(c(0,1),c(0,1),type='l',xlim=c(0,1),ylim=c(0,1),xlab="False Positive Rate",ylab="True Positive Rate",lty=3,main='ROC curves for numeric version against ASTRAL 95% seq id SCOP as truth')

lines(betagrasp$fpr, betagrasp$tpr, col=colorvec[1], lty=ltyvec[1])
lines(immunoglobulin$fpr, immunoglobulin$tpr, col=colorvec[2], lty=ltyvec[2])
lines(timbarrel$fpr, timbarrel$tpr, col=colorvec[3], lty=ltyvec[3])
lines(plait$fpr, plait$tpr, col=colorvec[4], lty=ltyvec[4])
lines(keybarrel$fpr, keybarrel$tpr, col=colorvec[5], lty=ltyvec[5])

legend('bottomright', col=colorvec, lty=ltyvec, legend=namevec)

dev.off()


# Import the basin delineation as a spatialpolygonsdataframe (.spdf)
# each polygon has a unique ID (PID) and represents the intersection between countries and catchments (i.e., basin country units - bcus)
basin.spdf = readOGR( paste( getwd(), 'input', sep = '/' ), paste( basin, 'bcu', sep = '_' ), verbose = FALSE )
basin.spdf$BASIN = basin
bcus = as.character( basin.spdf@data$PID )
node = c( 	bcus,
			unique( as.character( basin.spdf@data$BASIN ) ) )

# Get river names and groupings from csv
map_rivers_to_pids.df = data.frame( read.csv( 'input/indus_map_rivers_to_pids.csv', stringsAsFactors = FALSE ) )
basin.spdf@data = merge( basin.spdf@data, map_rivers_to_pids.df, by = 'PID' )

# Fixed demands in each regions
demand_fixed.df = read.csv( "input/indus_demands_new.csv", stringsAsFactors=FALSE )

# Historical capacity of technologies
hist_new_cap.df = read.csv( "input/historical_new_cap.csv", stringsAsFactors=FALSE ) %>%
					dplyr::select( -units )

# Capacity factor of renewable technologies
capacity_factor_sw.df = read.csv("input/LF/load_factor_sw.csv", stringsAsFactors=FALSE) %>%
							mutate( time = as.character( time ) )

# Max potential of renewable technologies
max_potential_sw.df = read.csv("input/LF/max_capacity_sw.csv", stringsAsFactors=FALSE)

# Fuel costs
fossil_fuel_cost_var0 = read.csv("input/fuel_cost/cost_variation_gams.csv", stringsAsFactors=FALSE) %>%
							mutate(year_all = as.numeric(year_all)) %>% rename(value = variation)

# Dam storage capacity
dam_storage_capacity.df = read.csv("input/storage/dam_storage_capacity_GRANDv1.1_M_m3_PID.csv", stringsAsFactors=FALSE) %>%
	rename(value = value, node = node)
# avg_storage_multiplier for setting avg level of storage at thebeginning and end of timesteps
avg_storage_multiplier = read.csv('input/storage/average_storage_multiplier.csv', stringsAsFactors=FALSE)

# storage evaporation losses

evap_losses.df = read.csv('input/storage/evapo_loss_reservoir_per_unit_volume.csv', stringsAsFactors = F) %>%
  filter(scenario == climate_scenario & model == climate_model)

# to sefine rule curves
rule_curves.df = read.csv('input/storage/rule_curves_values.csv', stringsAsFactors = F)

# Transmission capacity and routes
transmission_routes.df = read.csv("input/basin_transmission/existing_routes.csv", stringsAsFactors=FALSE) %>%
							mutate(tec = paste0('trs_',tec)) %>%
              dplyr::select( -units )

# Air pollution emision factors from MESSAGE IAM - convert from Mt per GW per year to ton per MW per day
air_pollution_factors.df = read.csv('input/MESSAGE_SSP2_emission_factor.csv', stringsAsFactors=FALSE) %>%
	mutate( val = round( val * 1e3 / 365, digits = 5 ) )

# GWPs for converting pollutants to CO2eq - 100-year time frame
gwp.df = data.frame( 	BCA = 460, # IPCC AR5
						CH4 = 28,
						CO = 0,
						N2O = 265,
						NH3 = 0,
						NOx = 0,
						OCA = -69,
						SO2 = 0,
						VOC = 0,
						CO2 = 1 )
gwp.df = data.frame( emission = names( gwp.df ), gwp = unlist( gwp.df )  )

# Distance between nodes
distance.df = read.csv('input/PID_distances_km.csv', stringsAsFactors=FALSE)

# Water resource data
water_resources.df = read.csv( paste0( 'input/basin_water_resources/basin_water_resources_',climate_model,'_',climate_scenario,'.csv' ), stringsAsFactors=FALSE ) %>%
	dplyr::rename( node = PID )
if (grepl('extreme',sc)){
  water_resources.df1 = water_resources.df %>% select(node,contains('2015'),contains('2020'))
  # Water resource data
  water_resources.df2 = read.csv( paste0( 'input/basin_water_resources/basin_water_resources_',climate_model,'_',climate_scenario,'_extreme.csv' ), stringsAsFactors=FALSE ) %>%
    dplyr::rename( node = PID ) %>% select(-node,-contains('2015'),-contains('2020'))
  water_resources.df = water_resources.df1 %>% bind_cols(water_resources.df2)
}

environmental_flow.df = read.csv( paste0('input/basin_water_resources/basin_environmental_flow_',climate_model,'_',climate_scenario,'.csv'), stringsAsFactors=FALSE ) %>%
	dplyr::rename( node = PID ) %>%
  gather('key','value',2:73) %>%
  mutate(time = as.numeric(gsub('.*\\.','',key))) %>%
  mutate(year_all = as.numeric(gsub('.*\\_','',gsub('\\..*$','',key)) )) %>%
  mutate(value = 1e3 * value, units = 'mcm_per_day') %>%
  dplyr::select(node,year_all,time,value,units)

# Water canal linkages
canals.df = read.csv( 'input/indus_bcu_canals.csv', stringsAsFactors=FALSE )

# Groundwater energy intensity
gw_ei.df = read.csv( 'input/gw_energy_intensity.csv', stringsAsFactors=FALSE )

# basin_irrigation_transfers
basin_irrigation_transfers.df = read.csv( 'input/basin_irrigation_transfers.csv', stringsAsFactors=FALSE )

# piped water access and wastewater treatment fractions
basin_water_connections.df = read.csv( 'input/indus_water_connections_sdg.csv', stringsAsFactors=FALSE ) %>%
								filter( SSP == 'SSP2' )

# fractions of groundwater pumps that are electric (assuming remaining fraction is diesel powered)
electric_share_of_irrigation.df = read.csv( 'input/irrigation_electricity_fraction.csv', stringsAsFactors=FALSE ) %>%
									rename( node = PID )

# land availability [km2] source GAEZ to be multiplyby 100 if we want hectare
land_availability.df = read.csv( 'input/land_availability_map.csv', stringsAsFactors=FALSE ) %>%
  mutate(value = value * 1.2 )

# crop related data: costs, yields, initial capacity source GAEZ, some is in Mha
crop_input_data.df = read.csv( 'input/crop_input_data.csv', stringsAsFactors=FALSE )
crop_names = unique(crop_input_data.df$crop)

# crop related data:  costs, CF, lifetime. Sources: Ansir
crop_tech_data.df = read.csv( 'input/crop_tech_data.csv', stringsAsFactors=FALSE )

# irrigation technologies related data: costs, CF, lifetime. Sources: Ansir
irr_tech_data.df = read.csv( 'input/irr_tech_data.csv', stringsAsFactors=FALSE )

# historical irrigation water withdrawals activities
hist_irr_water_act = read.csv( "input/historical_irrigation_withdrawals_act.csv", stringsAsFactors=FALSE ) %>%
  filter(scenario == climate_scenario, model == climate_model) %>% dplyr::select(node, tec, time, value)

# crop water requirements: Source iteraction with CWATM: historical, rcp2.6 and rcp6.0 scenarios - in MCM_per_day_per_Mha
crop_water.df = read.csv('input/crop_irrigation_water_calibrated.csv', stringsAsFactors=FALSE) %>%
  filter(scenario == climate_scenario, model == climate_model) %>% dplyr::select( crop, node, year, time, value)

# crop import and export in 2020 for portion of countries in the basin
imp_exp.df = read.csv('input/land_maps_crop_yields/FAO_prices/basin_crop_import_export.csv',stringsAsFactors = F)

# import fertilizer use by crop type and region data
fertilizer_by_crop.df = read.csv('input/indus_fertilizer_dat.csv', stringsAsFactors=FALSE)

# match to PID using provincial level fertilizer data
prov.spdf = readOGR( paste( getwd(), 'input', sep = '/' ), paste( basin, 'prov_bcu', sep = '_' ), verbose = FALSE )
prov.sp = gUnaryUnion(prov.spdf,prov.spdf@data$ADMIN)
r=raster()
res(r)=0.25
prov.raster = rasterize( prov.sp, crop(r,extent(prov.spdf)) )
mapr = raster::extract(prov.raster,as(basin.spdf,'SpatialPolygons'),byid=TRUE)
mapr = bind_rows( lapply( 1:length(mapr), function(iii){ data.frame( PID = basin.spdf@data$PID[iii], region = names(prov.sp)[as.numeric(names(which.max(table(unlist( mapr[[iii]] )))))] ) } ) )
mapr$region[ which( grepl( 'IND', mapr$PID ) ) ] = 'IND'
mapr$region[ which( grepl( 'CHN|AFG|Northern_Areas', mapr$region ) ) ] = 'PAK|NWFP'
fertilizer_by_crop.df = left_join( mapr, fertilizer_by_crop.df ) %>% dplyr::select( crop, irrigation, PID, fertilizer, unit, value, min, max )

# import fertlizer emissions data and merge with crop data
fertilizer_emissions.df = left_join( fertilizer_by_crop.df,
	read.csv('input/fertilizer_emissions.csv', stringsAsFactors=FALSE) %>% dplyr::select( fertilizer, out, value, unit ) %>%
		rename( value2 = value, unit2 = unit ) ) %>%
		mutate( value3 = round( value * value2, digits = 5 ), unit3 = 'kg/ha', emission = out ) %>%
		dplyr::select( PID, crop, fertilizer, irrigation, emission, value3, unit3 ) %>% rename( value = value3, unit = unit3 )

# Get adjacent and downstream bcus
gt = gTouches( basin.spdf, byid=TRUE )
adjacent.list = lapply( 1:length(basin.spdf), function( iii ){ return( basin.spdf@data$PID[ which( gt[,iii] ) ] ) } )
downstream.list = lapply( 1:length(basin.spdf), function( iii ){ if( !is.na( basin.spdf@data$DOWN[iii] ) ){ return( basin.spdf@data$PID[ which( as.character( basin.spdf@data$PID ) == as.character( basin.spdf@data$DOWN[iii] ) ) ] ) }else{ return( 'SINK' ) } } )
names(adjacent.list) = basin.spdf@data$PID
names(downstream.list) = basin.spdf@data$PID
flow_routes = sapply( 1:length( downstream.list ), function( iii ){ paste( names( downstream.list )[[ iii ]], downstream.list[[ iii ]], sep = '|' ) } )
adj1 = unlist( sapply( 1:length( adjacent.list ), function( iii ){ paste( names( adjacent.list )[[ iii ]], adjacent.list[[ iii ]], sep = '|' ) } ) )
adj2 = unlist( sapply( 1:length( adjacent.list ), function( iii ){ paste( adjacent.list[[ iii ]], names( adjacent.list )[[ iii ]], sep = '|' ) } ) )
inds = NULL
for(iii in 1:length(adj2)){ jjj = which( adj1 == adj2[iii] ) ; if( jjj > iii ){ inds = c(inds,jjj) } }
adjacent_routes = adj1[ -1 * inds ]

# Identify basin units along coast - limit to approx. 1.5 degrees from coastline (about 150km near equator)
coast = crop( spTransform( readShapeLines('input/ne_10m_coastline.shp', proj4string = crs(basin.spdf)), crs(basin.spdf) ), extent( buffer( basin.spdf, 0.1 ) ) )
cdist = gDistance(coast, basin.spdf, byid = TRUE)
coast_pid = unlist( lapply( 1:nrow(cdist), function(b){ if( length( which( cdist[b,] < 1.5 ) ) > 0 ){ return( as.character( basin.spdf@data$PID[b] ) ) }else{ return( NULL ) } } ) )
coast_pid = c(coast_pid, 'AFG_2','IND_4','IND_2','CHN_1')
# Electricity trade routes for regions outside the basin were identified from basin map
# electricity_export_routes = c( 	"PAK_2|PAK",
#                                 "PAK_4|PAK",
#                                 "PAK_5|PAK",
#                                 "PAK_6|PAK",
#                                 "PAK_10|PAK",
#                                 "PAK_12|PAK",
#                                 "PAK_13|CHN",
#                                 "CHN_2|CHN",
#                                 "CHN_1|CHN",
#                                 "CHN_3|CHN",
#                                 "AFG_2|AFG",
#                                 "AFG_1|AFG",
#                                 "PAK_7|AFG",
#                                 "PAK_8|AFG",
#                                 "PAK_10|IND",
#                                 "IND_4|IND" )

# take only existing lines in 2015 as transmission lines to the rest of the basin

electricity_export_routes = gsub('.*trs_','', (transmission_routes.df %>%
                               filter(gsub('.*_','',gsub('.*\\|','',tec)) %in% c('AFG', 'CHN','IND','PAK') & value > 0))$tec )

all_elec_routes = c(adjacent_routes,electricity_export_routes)

electricity_import_routes = electricity_export_routes

# Interbasin transfersto India potentially missed in irrigation implementation
# Identified manually as 1) node that transfers water out to India via Indira Ghandhi canal etc.; and
# 2) node the contains Keenjhar Lake and 583 MGD link to Karachi for potable water supply
interbasin_transfer.df = data.frame( 	node = c('IND_4','PAK_4'),
										min_flow = c( 1e-6, 2.2) )	# for IND4 the irrigation representation includes diversions outisde of the basin; PAK4 is tranfers for Karachi of 583 MGD; AFG_2 set arbitrarily

# Commodity types for demand
type_commodity = data.frame( 	withdrawal = 'freshwater',
								return = 'freshwater',
								electricity = 'electricity' )

# Level types for demand
type_level = data.frame( 	withdrawal = c( 'irrigation_final', 'urban_final', 'industry_final', 'rural_final' ),
							return = c(NA, 'urban_waste', 'industry_waste', 'rural_waste' ),
							electricity = c('irrigation_final', 'urban_final', 'industry_final', 'rural_final' ),
							row.names =  c('irrigation','urban','industry','rural')  )

# Exogenous demands
demand.df = demand_fixed.df %>%
				filter( scenario == SSP , sector != 'crop') %>%
				mutate( commodity = unlist( type_commodity[ type ] ) ) %>%
				mutate( level = unlist( sapply( 1:length(type),function(iii){ type_level[ sector[iii], type[iii] ] } ) ) ) %>%
				mutate( year_all = as.numeric( year ) ) %>%
				mutate( time = as.numeric( month ) ) %>%
				rename( node = pid ) %>%
        # remove demand freshwater at the irrigation_final level
        filter(level != 'irrigation_final') %>%
				dplyr::select( node, level, commodity, year_all, time, value )

# Convert water demand units from m3 per day to million m3 per day (mcm_per_day)
demand.df$value[ which( demand.df$commodity == 'freshwater' ) ] = demand.df$value[ which( demand.df$commodity == 'freshwater' ) ]

# Convert return flows to negative to represent inflow into the system
demand.df$value[ which( grepl( 'waste', demand.df$level ) ) ] = -1 * demand.df$value[ which( grepl( 'waste', demand.df$level ) ) ]

# Add units
demand.df$units = NA
demand.df$units[ which( demand.df$commodity == 'freshwater' ) ] = 'mcm_per_day'
demand.df$units[ which( demand.df$commodity == 'electricity' ) ] = 'MW'

# Round
demand.df$value = round( demand.df$value, digits = 2 )

# Add runoff into PIDs as an additional demand (inflow) into pids
nms = names( water_resources.df )[ grepl( 'runoff_km3_per_day', names( water_resources.df ) ) ]
inflow.df = do.call( rbind, lapply( 1:nrow(water_resources.df), function( iii ){
	data.frame( node = as.character( water_resources.df$node[ iii ] ),
				level = 'inflow',
				commodity = 'freshwater',
				year_all = as.numeric( unlist( strsplit( unlist( strsplit( nms, '[.]' ) )[ seq(1,2*length(nms),by=2) ], '_' ) )[ seq( 5, 5*length( nms ),by=5) ] ),
				time = as.numeric( unlist( strsplit( nms, '[.]' ) )[ seq(2,2*length(nms),by=2) ] ),
				value = -1*round( 1e3 * unlist( water_resources.df[ iii, nms ] ) , digits = 2 ),
				units = 'mcm_per_day')	} ) )
row.names( inflow.df ) = 1:nrow(inflow.df)
inflow.df = inflow.df %>% dplyr::select( node, commodity, level, year_all, time, value ,units)
demand.df = rbind( demand.df, inflow.df )

# Add recharge into PIDs as an additional demand (inflow) into pids
nms = names( water_resources.df )[ grepl( 'recharge_km3_per_day', names( water_resources.df ) ) ]
recharge.df = do.call( rbind, lapply( 1:nrow(water_resources.df), function( iii ){
	data.frame( node = as.character( water_resources.df$node[ iii ] ),
				level = 'aquifer',
				commodity = 'renewable_gw',
				year_all = as.numeric( unlist( strsplit( unlist( strsplit( nms, '[.]' ) )[ seq(1,2*length(nms),by=2) ], '_' ) )[ seq( 5, 5*length( nms ),by=5) ] ),
				time = as.numeric( unlist( strsplit( nms, '[.]' ) )[ seq(2,2*length(nms),by=2) ] ),
				value = -1*round( 1e3 * unlist( water_resources.df[ iii, nms ] ) , digits = 2 ),
				units = 'mcm_per_day')	} ) )
row.names( recharge.df ) = 1:nrow(recharge.df)
recharge.df = recharge.df %>% dplyr::select( node, commodity, level, year_all, time, value ,units)
demand.df = rbind( demand.df, recharge.df )

# check total inflow
# From Laghari et al 2012:
# Basin long term average surface water availability
# is in the order 239 km3 (Hoekstra and Mekonnen, 2011) to
# 258 km3 (Gupta and Deshpande, 2004; Kreutzmann, 2011; Sharma et al., 2008). In India, surface water availability is
# 73 km3 (Gupta and Deshpande, 2004; Sharma et al., 2008) and the Pakistani part accounts for 175 km3
# (Briscoe and Qamar, 2007) or 185 km3 (Kreutzmann, 2011). This includes 165 km3
# from the 3 western rivers (Indus, Chenab, and Jehlum) and 10 km3
# from the eastern rivers (Ravi, Beas, and Sutlej). Afghani surface water availability is 25 km3
# (Qureshi, 2011) and is included in the latter Pakistani volumes. Replenishable groundwater resources in India are
# 27 km3 (Sharma et al., 2008) and in Pakistan 63 km3
# (Briscoe and Qamar, 2007; Qureshi, 2011).
infl = c( demand.df %>%
	filter( level == 'inflow' ) %>%
	left_join( ., data.frame( time = 1:12, days = c(31,28.25,31,30,31,30,31,31,30,31,30,31) ) ) %>%
	group_by( year_all ) %>%
	summarise( value_km3 = round( sum( value * days )*-1/1e3 ) ) %>%
	as.data.frame() )
print( 'runoff' )
print(infl)	# about 240 km3 per year - looks good with the numbers stated above
rech = c( demand.df %>%
	filter( level == 'aquifer' ) %>%
	left_join( ., data.frame( time =1:12, days = c(31,28.25,31,30,31,30,31,31,30,31,30,31) ) ) %>%
	group_by( year_all ) %>%
	summarise( value_km3 = round( sum( value * days )*-1/1e3 ) ) %>%
	as.data.frame() )
print( 'recharge' )
print( rech )	# seems low ( 8km3 per year ) but I gues is not really including the recharge from irrigation.

# Add inter-basin irrigation transfers as demand taken straight from the river
# transfer.df = do.call( rbind, lapply( 1:nrow(basin_irrigation_transfers.df), function( iii ){
	# do.call( rbind, lapply( unique(demand.df$year_all), function( yyy ){
		# data.frame( node = as.character( basin_irrigation_transfers.df$PID[ iii ] ),
					# level = 'river_in',
					# commodity = 'freshwater',
					# year_all = yyy,
					# time = time,
					# value = round( unlist( basin_irrigation_transfers.df[ iii, which( grepl( paste(time, collapse='|'), names( basin_irrigation_transfers.df ) ) ) ] ) , digits = 2 ),
					# units = 'mcm_per_day')
				# } ) )
			# } ) )
# row.names( transfer.df ) = 1:nrow(transfer.df)
# transfer.df = transfer.df %>% dplyr::select( node, commodity, level, year_all, time, value ,units)
# demand.df = rbind( demand.df, transfer.df )

# Aggregate demands occurring for same commodity and level
demand.df$level = as.character( demand.df$level )
demand.df$commodity = as.character( demand.df$commodity )
demand.df$commodity[ which( as.character( demand.df$level ) == 'urban_waste' ) ] = 'wastewater'
demand.df$level[ which( as.character( demand.df$level ) == 'urban_waste' ) ] = 'urban_final'
demand.df$commodity[ which( as.character( demand.df$level ) == 'rural_waste' ) ] = 'wastewater'
demand.df$level[ which( as.character( demand.df$level ) == 'rural_waste' ) ] = 'rural_final'
demand.df$commodity[ which( as.character( demand.df$level ) == 'industry_waste' ) ] = 'wastewater'
demand.df$level[ which( as.character( demand.df$level ) == 'industry_waste' ) ] = 'industry_final'
demand.df = demand.df %>%
	group_by(node,level,commodity,year_all,time,units) %>%
	summarise( value = round( sum( value ), digits = 2 ) ) %>%
	ungroup( ) %>% data.frame( )

# scale manufacturing sector water demands in India for now
demand.df = demand.df %>%
  mutate(value = if_else(level == 'industry_final' & units == 'mcm_per_day' & grepl( 'IND', node ), 0.1 * value , value) )

# Land demand
land_demand.df = land_availability.df %>%
  expand(land_availability.df,year_all) %>%
  mutate(level = 'area') %>%
  mutate(commodity = 'crop_land') %>%
  mutate(value = value) %>% #in Mha
  crossing(time = time ) %>%
  dplyr::select(node,level,commodity,year_all,time,units,value)

# add land availability
demand.df = bind_rows(demand.df %>% mutate( time = as.character( time ) ), land_demand.df)

# yield demand, assumption as multiple of historical yield
# we have historical demand of 2000 (GAEZ) projected with FAO national production levels and SSP population growth
yield_demand.df = demand_fixed.df %>%
  filter( scenario == SSP , sector == 'crop') %>%
  mutate( level = 'raw' ,year_all = as.numeric(year), time = 'year') %>%
  mutate( commodity = paste0( type, '_yield' ) ) %>%
  mutate( value = value ) %>%       # ktons
  rename(node = pid) %>%
  dplyr::select( node,level,commodity,year_all,time,units,value ) %>%
  # mutate( node = unlist( strsplit( as.character( node ), '_' ) )[seq(1,2*length(node),by=2)] ) %>%
  group_by(node,level,commodity,year_all,time,units) %>%
  summarise(value = sum(value)) %>% ungroup() %>% data.frame()

# add yield demamd
demand.df = demand.df %>%
  mutate(time = as.character(time)) %>%
  bind_rows(yield_demand.df)

# from 1975 to 1990 in 1990, MW
hist_new_cap.df = hist_new_cap.df %>%  mutate(year_all = as.numeric(year_all))
hist_new_cap.df$tec[hist_new_cap.df$tec == "solar_pv"] = "solar_pv_1"
hist_new_cap.df$tec[hist_new_cap.df$tec == "wind"] = "wind_1"

# fuel var cost
miss_val = expand.grid(commodity = unique(fossil_fuel_cost_var0$commodity),year_all = year, value = 0,stringsAsFactors = FALSE)
fossil_fuel_cost_var = fossil_fuel_cost_var0 %>%
	bind_rows(anti_join(miss_val,fossil_fuel_cost_var0, by = c("commodity", "year_all"))) %>%
	filter(year_all %in% year) %>% arrange(commodity,year_all)

# transmission costs million USD per MW, see file Indus_transmission_cost.xlsx - cost of 1.31 USD / kW per km -  in line with WECC data from SWITCH model
mean_dist_to_border = mean(distance.df$dist)/2
trs_inv_cost.df = distance.df %>% mutate( value = round( 1e-3 * dist*1.31, digits = 3 ) ) %>% dplyr::select(-dist) %>%
	bind_rows( data.frame( tec = electricity_export_routes, value = round( 1e-3 * mean_dist_to_border*1.31, digits = 3 ) ) )

# transmission efficiency assuming losses of 0.006% per km (aligned with Parkinson et al. 2016 EST)
trs_eff.df = distance.df %>% mutate( value = round( 0.01 * dist*0.006, digits = 3 ) ) %>% dplyr::select(-dist) %>%
	bind_rows( data.frame( tec = electricity_export_routes, value = round( 0.01 * 2 * mean_dist_to_border*0.006, digits = 3 ) ) )

# Hurdle rates for transmission outside of the same country
trs_hurdle.df = do.call( rbind, lapply( trs_inv_cost.df$tec, function( iii ){
	ci = unlist( strsplit( iii, '[|]' ) )[1]
	co = unlist( strsplit( iii, '[|]' ) )[2]
	if( unlist( strsplit( ci, '_' ) )[1] != unlist( strsplit( co, '_' ) )[1] | length( unlist( strsplit( co, '_' ) ) ) == 10 ){ hurdle = 10 }else{
	  if( unlist( strsplit( ci, '_' ) )[1] == unlist( strsplit( co, '_' ) )[1] & length( unlist( strsplit( co, '_' ) ) ) == 1 ){ hurdle = 0.05 }else{ hurdle = 0 } }
	return( data.frame( tec = iii, hurdle = hurdle ) )
	} ) ) # %>%
  # mutate(hurdle = if_else(tec == 'PAK_10|IND',10,hurdle))

# Canal costs million USD per MCM per day -  costs taken from Parkinson et al. (2016) - approx. 6.70 USD per MCM per day per km
can_inv_cost.df = distance.df %>% mutate( value = round( dist*6.70, digits = 0 ) ) %>% dplyr::select(-dist)

# aggregate canals with same in and out regions
canals_agg.df = canals.df %>%
	mutate(route = paste(PID_i,PID_o,sep = '|')) %>%
	group_by(route) %>%
	summarise(capacity_m3_per_sec = sum(capacity_m3_per_sec)) %>% ungroup() %>% data.frame()

##### Check consistency, demand and supply/output of techs ######
# can be done in a more automatic way in the future

yield_dem_comb = unique(yield_demand.df %>% dplyr::select(commodity,node)) %>%
  mutate(commodity = gsub('_yield','',commodity)) %>%
  rename(tec = commodity) %>% arrange(tec)

irr_yield_comb = crop_input_data.df %>% filter( par == 'irrigation_yield') %>% rename(tec = crop) %>%
  dplyr::select(tec,node) %>% unique() %>% arrange(tec) %>%
  # mutate(node = gsub('_.*','',node)) %>%
  unique()

diff_y_demand = dplyr::setdiff(yield_dem_comb,irr_yield_comb) %>% # they have the same combinations
  mutate(commodity = paste0(tec,'_yield')) %>% dplyr::select(-tec)
#print('exclude these elments from demand, or consider checking the supply side')
#print(diff_y_demand)
demand.df <- demand.df %>% anti_join(diff_y_demand)

# Adjust to year_all definition
demand.df <- demand.df %>% filter(year_all <= lastyear)

## data for biomass
# kton residues per hectare Lal 2004
residue_data = data.frame(crop = c('cotton','fodder','pulses','rice','sugarcane','wheat','maize'),
                          res_yield = c(6.7e3 , 8.4e3 , 6.48e3 , 6.7e3 , 5.6e3 , 5e3, 10.1e3), #kt/Mha
                          mode = c(1:7),
                          liquid = c(0 ,1 , 0, 1, 1, 1, 1),
                          ethanol_ratio = c(NA, 0.67, NA, 0.7, 0.153, 0.67, 0.67),    # kt ethanol/ kt biomass
                          var_eth_cost = c(NA, 0.316, NA, 0.410, 0.291, 0.621, 0.43)) #2010 M$/kt straw biomass


do_sampling_stratified_timeseries<-function(sampDes, sampOpt, dataset, sampId){

	# resamples stations from strata (time series)
	# Nuno Prista, SLU Aqua, Sweden
	# Developed @ KustMonitoring Review 2019 based on extensive work done under WKBIOPTIM1 and WKBIOPTIM2
	# 2019-05-01 # 1st of May?! seriously?! this is shameful and not to repeat - long live May day [https://en.wikipedia.org/wiki/May_Day]

# creates storage object
ls_out_sims<-sapply(as.character(colnames(sampOpt$samp_sizes)[grepl(colnames(sampOpt$samp_sizes), pat="SampSize")]), function(x) NULL)

strata_var<-sampDes$strata_var

# check compatibility between sampling_design and sampling_options
	if (sampDes$stratified == TRUE & (sampOpt$stratified==FALSE | (sampOpt$stratified==TRUE & sampOpt$strata_var!=sampDes$strata_var)))
		{
		stop (cat("\n ATT: sampling_design not compatible with sampling_options \n\n "))
		}

# check on columns
	if(sampOpt$stratified==TRUE)
		{
		if(!strata_var %in% colnames(dataset)) {stop (cat("\n ATT: check strata_var - not found in colnames(dataset) \n\n "))}
		}

# check on sample sizes
	if(sampOpt$replacement==FALSE)
		{
		#if(any(sampOpt$samp_sizes>nrow(dataset)) & sampOpt$sample_all_available==FALSE) {stop (cat("\n ATT: samp_sizes >  population size with replace = FALSE AND sample_all_available = FALSE\n\n"))}
		if(sampOpt$stratified==TRUE){if (any(sampDes$samp_sizes$OrigSampSizes<sampOpt$samp_sizes[,grepl(colnames(sampOpt$samp_sizes), pat="SampSize")]) & sampOpt$sample_all_available==FALSE) {stop (cat("\n ATT: samp_sizes >  strata size with replace = FALSE AND sample_all_available = FALSE\n\n"))}}
		}

	for (j in 4:ncol(sampOpt$samp_sizes))
	{

	# creates a list to hold results of simulations (each leaf is a simulation of size j)
		out<-sapply(as.character(1:sampOpt$n_sims), function(x) NULL)

	# extracts vector of sample sizes
		samp_size_vector <-	sampOpt$samp_sizes[[j]]
		names(samp_size_vector)<-sampOpt$samp_sizes[[1]]

	for(i in 1:sampOpt$n_sims)
		{
		#if(i==1) cat("sims:"); cat(i,",", sep=""); if(i==max(sampOpt$n_sims)) cat("\n")
			if(sampOpt$stratified==FALSE)
				{
				stop("sampOpt$stratified==FALSE: not defined")
				}
			if(sampOpt$stratified==TRUE)
				{
				# note: 1st element is sampSize name
				out[[i]]<-c(colnames(sampOpt$samp_sizes)[j], sampleFromAGroup(x=dataset[[sampId]], y=dataset[,strata_var], nsize = samp_size_vector, samp_options = sampOpt))
				}
		}
		#cat("\n")
			ls_out_sims[[colnames(sampOpt$samp_sizes)[j]]]<-out
	}

ls_out_sims

}


library(GenomicRanges)
library(BSgenome.Dmelanogaster.UCSC.dm6)

flybase_txs <- function() {
  txs <- readRDS("flybase/fb.transcripts.r6.21.rds")
  valid.chrs <- c("chr2L", "chr2R", "chr3L","chr3R", "chr4", "chrX")
  txs <- subset(txs, chr %in% valid.chrs)
  txs
}

flybase_txs_granges <- function() {
  genes <- flybase_txs()
  genes.gr <- with(genes, GRanges(ranges     = IRanges(start=start, end=end),
                                  seqnames   = chr,
                                  strand     = ifelse(strand == 1, "+", "-"),
                                  fb_tx_id   = fb_tx_id,
                                  fb_gene_id = fb_gene_id,
                                  fb_symbol  = fb_symbol,
                                  gene_type  = type))
  genes.gr
}

# Assigns the nearest gene by TSS (overlapping gene takes precedence over nearest TSS)
assign_nearest_gene <- function(gr, txs.gr=flybase_txs_granges()) {

  tss.gr <- resize(txs.gr, 1)

  dtn      <- as.data.frame(distanceToNearest(gr, tss.gr, ignore.strand=TRUE))
  dtn.gene <- subset(as.data.frame(distanceToNearest(gr, txs.gr, ignore.strand=TRUE)), distance == 0)

  mcols(gr)$nearest_gene_id <- ""
  mcols(gr)$nearest_gene    <- ""
  mcols(gr)$distance_to_tss <- NA
  mcols(gr)$inside_gene <- ""

  mcols(gr)$nearest_gene_id[dtn$queryHits] <- mcols(tss.gr)$fb_gene_id[dtn$subjectHits]
  mcols(gr)$nearest_gene[dtn$queryHits]    <- mcols(tss.gr)$fb_symbol[dtn$subjectHits]
  mcols(gr)$inside_gene[dtn$queryHits] <- FALSE
  mcols(gr)$distance_to_tss[dtn$queryHits] <- dtn$distance

  mcols(gr)$nearest_gene_id[dtn.gene$queryHits] <- mcols(txs.gr)$fb_gene_id[dtn.gene$subjectHits]
  mcols(gr)$nearest_gene[dtn.gene$queryHits]    <- mcols(txs.gr)$fb_symbol[dtn.gene$subjectHits]
  mcols(gr)$inside_gene[dtn.gene$queryHits] <- TRUE
  mcols(gr)$distance_to_tss[dtn.gene$queryHits] <- dtn$distance[match(dtn.gene$queryHits, dtn$queryHits)]

  gr
}
distance_to_nearest_promoter <- function(gr, txs.gr=flybase_txs_granges()) {

  tss.gr <- resize(txs.gr, 1)

  as.data.frame(distanceToNearest(gr, tss.gr, ignore.strand=TRUE))

}


## Make file for inclusion of stomach observations in likelihood
#################################################################

stom<-Read.stomach.data.start()
###############################################################
#Number of stomachs;
ns<-unique(subset(stom,select=c(Area,Predator,Predator.no,Predator.length,Predator.length.class,Year,Quarter, N.haul)))

tapply(ns$N.haul,list(ns$Area,ns$Predator.length,ns$Year,ns$Quarter,ns$Predator),sum,na.rm=T)

ns$one<-1
ns$pp<-paste(ns$Predator.length.class,'-',ns$Predator.length,sep='')
tab<-tapply(ns$N.haul,list(ns$Area,ns$Predator.length.class,ns$Year,ns$Quarter,ns$Predator.no),sum,na.rm=T)
tab[is.na(tab)]<-0
#tab[tab>0]<-1
tab
dt<-dim(tab)
cat("# Table for inclusion of stomach data in likelihood. 0=no use, >=1 use data\n",file = file.path(data.path,'incl_stom.in'))

for (d in (1:dt[1])) {
  cat(paste("# AREA: ",d,'\n#################################################\n'),file = file.path(data.path,'incl_stom.in'),append=T)
  cat("# ", as.numeric(unlist(dimnames(tab)[1])),'\n',file = file.path(data.path,'incl_stom.in'),append=T)
for (p in (1:dt[5])) {
 for (q in (1:dt[4])) {
  cat(paste("# ",  sp.names[p]," quarter:",q,'\n'),file = file.path(data.path,'incl_stom.in'),append=T)
  cat("# ", as.numeric(unlist(dimnames(tab)[2])),'\n',file = file.path(data.path,'incl_stom.in'),append=T)
  write.table(tab[d,,,q,p],row.names = FALSE,col.names=F,file = file.path(data.path,'incl_stom.in'),append=T)
  }
}}


suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(ggplot2))
suppressPackageStartupMessages(library(patchwork))

source("viz_themes.R")
source("plotting_functions.R")
source("data_functions.R")

output_figure_base <- file.path("figures", "figure1")
extensions <- c(".png", ".pdf")

# The threshold indicats above the 95% percentile of carefully-controlled null distribution
threshold <- 0.05
plot_thresh <- -log10(threshold)

results_dir <- file.path("../1.Data-exploration/Profiles_level4/")
well_specific_null <- TRUE

cell_painting_pr_pval <- load_percent_replicating_nonparametric_pvals(
    assay="cellpainting",
    results_dir=results_dir,
    cp_file_indicator="",
    well_specific_null=well_specific_null
)

l1000_pr_pval <- load_percent_replicating_nonparametric_pvals(
    assay="l1000",
    results_dir=results_dir,
    l1000_file_indicator="",
    well_specific_null=well_specific_null
)

if (well_specific_null) {
    pr_pval_df <- dplyr::bind_rows(
        cell_painting_pr_pval %>%
            dplyr::mutate(
                assay="Cell Painting",
                normalization="spherized",
                category="all_data"
            ),
        l1000_pr_pval %>%
            dplyr::mutate(
                assay="L1000",
                normalization="non_spherized",
                category="all_data"
            )
    ) %>%
        dplyr::mutate(pass_thresh = p_value < threshold) %>%
        dplyr::mutate(neg_log_10_p_val = -log10(p_value)) %>%
        dplyr::mutate(dose = dose_recode)

    pr_pval_df$dose <- dplyr::recode_factor(pr_pval_df$dose_recode, !!!dose_rename)
    pr_pval_df$dose <- factor(pr_pval_df$dose, levels = dose_order)
    pr_pval_df$neg_log_10_p_val[pr_pval_df$neg_log_10_p_val == Inf] = 3.5

} else {
    pr_pval_df <- dplyr::bind_rows(
        cell_painting_pr_pval,
        l1000_pr_pval
    ) %>%
        dplyr::mutate(pass_thresh = p_value < threshold) %>%
        dplyr::mutate(neg_log_10_p_val = -log10(p_value))

    pr_pval_df$dose <- factor(pr_pval_df$dose, levels = dose_order)
    pr_pval_df$neg_log_10_p_val[pr_pval_df$neg_log_10_p_val == Inf] = 3.5
}

# Note, this number of compounds represents:
# "how many compounds were measured in both assays at ALL doses".
print(length(unique(pr_pval_df$compound)))

output_file <- file.path("results", "compound_scores.tsv")
readr::write_tsv(pr_pval_df, output_file)

print(dim(pr_pval_df))
head(pr_pval_df)

table(pr_pval_df$no_of_compounds, pr_pval_df$assay)

percent_replicating_df <- pr_pval_df %>%
    dplyr::group_by(assay, dose) %>%
    dplyr::mutate(percent_replicating = paste0(100 * round((sum(pass_thresh) / length(pass_thresh)), 2), "%")) %>%
    dplyr::select(dose, assay, percent_replicating) %>%
    dplyr::distinct()

percent_replicating_df

panel_a_gg <- (
    ggplot(pr_pval_df, aes(x = median_score, y = neg_log_10_p_val))
    + geom_point(aes(color = no_of_compounds), alpha = 0.05)
    + geom_text(data = percent_replicating_df, aes(label = percent_replicating, x = 0.65, y = 2.5))
    + facet_grid("assay~dose")
    + geom_hline(linetype = "dashed", color = "blue", yintercept = plot_thresh)
    + theme_bw()
    + figure_theme
    + scale_color_continuous(
        "Number of\nreplicates\nper compound",
        values = scales::rescale(c(0, 0.5, 1, 1.5, 2, 3, 6)),
        limits = c(2, 10),
        type = "viridis"
    )
    + xlab("Median pairwise Pearson correlation between replicate profiles")
    + ylab("Non-parametric -log10 p value")
)

panel_a_gg

pr_summary_df <- pr_pval_df %>%
    dplyr::select(compound, dose, well, assay, normalization, category, median_score) %>%
    dplyr::distinct() %>%
    reshape2::dcast(compound + dose + well ~ assay + normalization + category, value.var = "median_score")  %>%
    dplyr::left_join(
        pr_pval_df %>%
            dplyr::filter(assay == "Cell Painting") %>%
            dplyr::select(compound, dose, well, no_of_compounds, pass_thresh, p_value, neg_log_10_p_val),
        by = c("compound", "dose", "well")
    ) %>%
    dplyr::left_join(
        pr_pval_df %>%
            dplyr::filter(assay == "L1000") %>%
            dplyr::select(compound, dose, well, no_of_compounds, pass_thresh, p_value, neg_log_10_p_val),
        by = c("compound", "dose", "well"),
        suffix = c("_cp", "_l1000")
    ) %>%
    dplyr::rename(
        `median_pairwise_correlation_cp` = `Cell Painting_spherized_all_data`,
        `median_pairwise_correlation_l1000` = `L1000_non_spherized_all_data`
    ) %>%
    dplyr::mutate(pass_both = pass_thresh_cp + pass_thresh_l1000) %>%
    dplyr::mutate(pass_both = ifelse(pass_both == 2, TRUE, FALSE)) %>%
    dplyr::select(
        compound,
        well,
        dose,
        median_pairwise_correlation_cp,
        median_pairwise_correlation_l1000,
        pass_thresh_cp,
        pass_thresh_l1000,
        pass_both
    ) %>%
    dplyr::group_by(compound) %>%
    dplyr::mutate(
        total_reproducible_cp = sum(pass_thresh_cp),
        total_reproducible_l1000 = sum(pass_thresh_l1000),
        total_reproducible = total_reproducible_cp + total_reproducible_l1000
    ) %>%
    dplyr::ungroup()

print(length(unique(pr_summary_df$compound)))
head(pr_summary_df, 2)

panel_b_gg <- (
    ggplot(
        pr_summary_df %>%
            # Remove compounds measured in different wells inconsistently
            dplyr::filter(!(compound %in% c("dexamethasone", "temsirolimus"))),
        aes(x = median_pairwise_correlation_cp, y = median_pairwise_correlation_l1000))
    + geom_point(aes(color = total_reproducible), size = 0.5, alpha = 0.5)
    + facet_grid("~dose")
    + geom_abline(intercept = 0, slope = 1, linetype = "dashed", color = "black")
    + figure_theme
    + scale_color_gradient("How many total\ndoses is the\ncompound\nreproducible in\nboth assays?", low = "blue", high = "red")
    + xlab("Cell Painting\nMedian pairwise replicate correlation")
    + ylab("L1000\nMedian pairwise replicate correlation")
)

panel_b_gg

significant_compounds_df <- pr_summary_df %>%
    dplyr::select(compound, well, dose, pass_thresh_cp, pass_thresh_l1000, pass_both) %>%
    tidyr::drop_na()

total_compounds <- length(unique(significant_compounds_df$compound))
print(total_compounds)

head(significant_compounds_df, 3)

pass_thresh_summary_df <- significant_compounds_df %>%
    dplyr::group_by(dose) %>%
    dplyr::mutate(
        num_pass_cellpainting = sum(pass_thresh_cp),
        num_pass_l1000 = sum(pass_thresh_l1000),
        num_pass_both = sum(pass_both)
    ) %>%
    dplyr::ungroup() %>%
    dplyr::select(dose, num_pass_cellpainting, num_pass_l1000, num_pass_both) %>%
    dplyr::distinct() %>%
    dplyr::mutate(
        unique_pass_cellpainting = num_pass_cellpainting - num_pass_both,
        unique_pass_l1000 = num_pass_l1000 - num_pass_both
    )

pass_thresh_summary_df

# Prep data and text for plotting
cell_painting_rect <- pass_thresh_summary_df %>%
    dplyr::select(dose, num_pass_cellpainting, unique_pass_cellpainting, num_pass_both) %>%
    dplyr::rename(c(ymax_bar = num_pass_cellpainting, unique_pass = unique_pass_cellpainting)) %>%
    dplyr::mutate(
        ymin_bar = 0,
        xmin_bar = seq(0, (length(unique(pass_thresh_summary_df$dose)) - 1) * 2, 2),
        xmax_bar = seq(1, (length(unique(pass_thresh_summary_df$dose))) * 2, 2),
        assay = "Cell Painting",
        label_text_y = 300,
        updated_ymin_bar = ymin_bar,
        updated_ymax_bar = ymax_bar - num_pass_both
    )

l1000_rect <- pass_thresh_summary_df %>%
    dplyr::mutate(ymax_bar = num_pass_cellpainting + unique_pass_l1000) %>%
    dplyr::select(dose, ymax_bar, unique_pass_cellpainting, unique_pass_l1000, num_pass_both) %>%
    dplyr::rename(c(ymin_bar = unique_pass_cellpainting, unique_pass = unique_pass_l1000)) %>%
    dplyr::mutate(
        xmin_bar = seq(0, (length(unique(pass_thresh_summary_df$dose)) - 1) * 2, 2),
        xmax_bar = seq(1, (length(unique(pass_thresh_summary_df$dose))) * 2, 2),
        assay = "L1000",
        label_text_y = ymax_bar - 25,
        updated_ymin_bar = ymin_bar + num_pass_both,
        updated_ymax_bar = ymax_bar
    )

both_rect <- cell_painting_rect %>%
    dplyr::select(dose, xmin_bar, xmax_bar, updated_ymin_bar, updated_ymax_bar) %>%
    dplyr::left_join(
        l1000_rect %>%
        dplyr::select(dose, xmin_bar, xmax_bar, updated_ymin_bar, updated_ymax_bar),
        by = c("dose", "xmin_bar", "xmax_bar"),
        suffix = c("_cp", "_l1000")
    ) %>%
    dplyr::mutate(
        updated_ymin_bar = updated_ymax_bar_cp,
        updated_ymax_bar = updated_ymin_bar_l1000,
        assay = "Both"
    ) %>%
    dplyr::select(dose, xmin_bar, xmax_bar, assay, updated_ymin_bar, updated_ymax_bar)

full_rect <- dplyr::bind_rows(cell_painting_rect, l1000_rect, both_rect)

num_pass_both_text <- full_rect %>%
    dplyr::filter(assay == "Cell Painting") %>%
    dplyr::select(dose, xmin_bar, ymax_bar, num_pass_both) %>%
    dplyr::left_join(
        full_rect %>%
            dplyr::filter(assay == "L1000") %>%
            dplyr::select(dose, ymin_bar) %>%
            dplyr::rename(c(ymin_l1000_bar = ymin_bar)),
        by = "dose"
    ) %>%
    dplyr::mutate(label_text_y = ymin_l1000_bar + (num_pass_both / 2))

# What percentage of compounds passed the threshold?
percentile_pass_df <- pass_thresh_summary_df %>%
    dplyr::mutate(
        num_pass_total = unique_pass_l1000 + unique_pass_cellpainting + num_pass_both,
        num_pass_percentile = paste("Total:\n", round(num_pass_total / total_compounds, 2) * 100, "%")
    ) %>%
    dplyr::select(dose, num_pass_percentile, num_pass_total)

# Prep legend order
full_rect <- full_rect %>%
    dplyr::left_join(percentile_pass_df, by = "dose")

full_rect$assay <- factor(full_rect$assay, levels = c("L1000", "Both", "Cell Painting"))

updated_assay_colors <- c(assay_colors, "Both" = "#DF74F0")

panel_c_gg <- (
    ggplot(full_rect)
    + geom_rect(
        aes(
            fill = assay,
            ymin = updated_ymin_bar,
            ymax = updated_ymax_bar,
            xmin = xmin_bar,
            xmax = xmax_bar
        ),
        alpha = 0.5
    )
    + geom_text(aes(x = xmin_bar + 0.5, y = label_text_y, label = unique_pass))
    + geom_text(data = num_pass_both_text, aes(x = xmin_bar + 0.5, y = label_text_y, label = num_pass_both))
    # Select only L1000 below to not duplicate text
    + geom_text(
        data = full_rect %>% dplyr::filter(assay == "L1000"),
        aes(x = xmin_bar + 0.5, y = ymax_bar + 70, label = num_pass_percentile),
        size = 3
    )
    + scale_fill_manual("Compounds\nreproducible\nin assay", values = updated_assay_colors)
    + theme_bw()
    + figure_theme
    + scale_x_continuous(labels = num_pass_both_text$dose, breaks = seq(0.5, length(num_pass_both_text$dose) * 2, 2))
    + ylab("Total number of compounds over 95% threshold\nof matched non-replicate median distribution")
    + xlab("")
    + ylim(0, max(full_rect$num_pass_total, na.rm = TRUE) + 100)

)

panel_c_gg

left_panel <- (panel_a_gg / panel_b_gg) + plot_layout(heights = c(2, 1))

figure_1_gg <- (
    ( left_panel | panel_c_gg)
    + plot_layout(widths = c(2, 1))
    + plot_annotation(tag_levels = "a")
)

for (extension in extensions) {
    output_file <- paste0(output_figure_base, extension)
    ggplot2::ggsave(output_file, figure_1_gg, width = 16, height = 6, dpi = 500)
}

figure_1_gg


#' Translate an expression to sql.
#'
#' @section Base translation:
#' The base translator, \code{base_sql},
#' provides custom mappings for \code{!} (to NOT), \code{&&} and \code{&} to
#' \code{AND}, \code{||} and \code{|} to \code{OR}, \code{^} to \code{POWER},
#' \code{\%>\%} to \code{\%}, \code{ceiling} to \code{CEIL}, \code{mean} to
#' \code{AVG}, \code{var} to \code{VARIANCE}, \code{tolower} to \code{LOWER},
#' \code{toupper} to \code{UPPER} and \code{nchar} to \code{length}.
#'
#' \code{c} and \code{:} keep their usual R behaviour so you can easily create
#' vectors that are passed to sql.
#'
#' All other functions will be preserved as is. R's infix functions
#' (e.g. \code{\%like\%}) will be converted to their sql equivalents
#' (e.g. \code{LIKE}). You can use this to access SQL string concatenation:
#' \code{||} is mapped to \code{OR}, but \code{\%||\%} is mapped to \code{||}.
#' To suppress this behaviour, and force errors immediately when dplyr doesn't
#' know how to translate a function it encounters, using set the
#' \code{dplyr.strict_sql} option to \code{TRUE}.
#'
#' You can also use \code{sql} to insert a raw sql string.
#'
#' @section SQLite translation:
#' The SQLite variant currently only adds one additional function: a mapping
#' from \code{sd} to the SQL aggregation function \code{stdev}.
#'
#' @param ...,dots Expressions to translate. \code{sql_translate}
#'   automatically quotes them for you.  \code{sql_translate_} expects
#'   a list of already quoted objects.
#' @param con An optional database connection to control the details of
#'   the translation. The default, \code{NULL}, generates ANSI SQL.
#' @param vars A character vector giving variable names in the remote
#'   data source. If this is supplied, \code{translate_sql} will call
#'   \code{\link{partial_eval}} to interpolate in the values from local
#'   variables.
#' @param vars_group,vars_order Grouping and ordering variables used for
#'   windowed functions.
#' @param window Use \code{FALSE} to suppress generation of the \code{OVER}
#'   statement used for window functions. This is necessary when generating
#'   SQL for a grouped summary.
#' @export
#' @examples
#' # Regular maths is translated in a very straightforward way
#' translate_sql(x + 1)
#' translate_sql(sin(x) + tan(y))
#'
#' # Note that all variable names are escaped
#' translate_sql(like == "x")
#' # In ANSI SQL: "" quotes variable _names_, '' quotes strings
#'
#' # Logical operators are converted to their sql equivalents
#' translate_sql(x < 5 & !(y >= 5))
#' # xor() doesn't have a direct SQL equivalent
#' translate_sql(xor(x, y))
#'
#' # If is translated into case when
#' translate_sql(if (x > 5) "big" else "small")
#'
#' # Infix functions are passed onto SQL with % removed
#' translate_sql(first %like% "Had*")
#' translate_sql(first %is% NULL)
#' translate_sql(first %in% c("John", "Roger", "Robert"))
#'
#'
#' # And be careful if you really want integers
#' translate_sql(x == 1)
#' translate_sql(x == 1L)
#'
#' # If you have an already quoted object, use translate_sql_:
#' x <- quote(y + 1 / sin(t))
#' translate_sql_(list(x))
#'
#' # Translation with known variables ------------------------------------------
#'
#' # If the variables in the dataset are known, translate_sql will interpolate
#' # in literal values from the current environment
#' x <- 10
#' translate_sql(mpg > x)
#' translate_sql(mpg > x, vars = names(mtcars))
#'
#' # By default all computations happens in sql
#' translate_sql(cyl == 2 + 2, vars = names(mtcars))
#' # Use local to force local evaluation
#' translate_sql(cyl == local(2 + 2), vars = names(mtcars))
#'
#' # This is also needed if you call a local function:
#' inc <- function(x) x + 1
#' translate_sql(mpg > inc(x), vars = names(mtcars))
#' translate_sql(mpg > local(inc(x)), vars = names(mtcars))
#'
#' # Windowed translation --------------------------------------------
#' # Known window functions automatically get OVER()
#' translate_sql(mpg > mean(mpg))
#'
#' # Suppress this with window = FALSE
#' translate_sql(mpg > mean(mpg), window = FALSE)
#'
#' # vars_group controls partition:
#' translate_sql(mpg > mean(mpg), vars_group = "cyl")
#'
#' # and vars_order controls ordering for those functions that need it
#' translate_sql(cumsum(mpg))
#' translate_sql(cumsum(mpg), vars_order = "mpg")
translate_sql <- function(...,
                          con = NULL,
                          vars = character(),
                          vars_group = NULL,
                          vars_order = NULL,
                          window = TRUE) {
  dots <- lazyeval::lazy_dots(...)

  translate_sql_(dots,
    con = con,
    vars = vars,
    vars_group = vars_group,
    vars_order = vars_order,
    window = window
  )
}

#' @export
#' @rdname translate_sql
translate_sql_ <- function(dots,
                           con = NULL,
                           vars = character(),
                           vars_group = NULL,
                           vars_order = NULL,
                           window = TRUE) {
  expr <- lazyeval::as.lazy_dots(dots, env = parent.frame())
  if (!any(has_names(expr))) {
    names(expr) <- NULL
  }

  if (length(vars) > 0) {
    # If variables are known, partially evaluate input
    expr <- partial_eval2(expr, vars)
  } else {
    # Otherwise just extract expressions, ignoring the environment
    # from which they came
    expr <- lapply(expr, "[[", "expr")
  }
  variant <- sql_translate_env(con)

  if (window) {
    old_con <- set_partition_con(con)
    on.exit(set_partition_con(old_con), add = TRUE)

    old_group <- set_partition_group(vars_group)
    on.exit(set_partition_group(old_group), add = TRUE)

    old_order <- set_partition_order(vars_order)
    on.exit(set_partition_order(old_order), add = TRUE)
  }

  pieces <- lapply(expr, function(x) {
    if (is.atomic(x)) return(escape(x, con = con))

    env <- sql_env(x, variant, con, window = window)
    escape(eval(x, envir = env))
  })

  sql(unlist(pieces))
}

sql_env <- function(expr, variant, con, window = FALSE,
                    strict = getOption("dplyr.strict_sql")) {
  stopifnot(is.sql_variant(variant))

  # Default for unknown functions
  if (!strict) {
    unknown <- setdiff(all_calls(expr), names(variant))
    default_env <- ceply(unknown, default_op, parent = emptyenv())
  } else {
    default_env <- new.env(parent = emptyenv())
  }

  # Known R -> SQL functions
  special_calls <- copy_env(variant$scalar, parent = default_env)
  if (!window) {
    special_calls2 <- copy_env(variant$aggregate, parent = special_calls)
  } else {
    special_calls2 <- copy_env(variant$window, parent = special_calls)
  }

  # Existing symbols in expression
  names <- all_names(expr)
  name_env <- ceply(names, function(x) escape(ident(x), con = con),
    parent = special_calls2)

  # Known sql expressions
  symbol_env <- copy_env(base_symbols, parent = name_env)
  symbol_env
}

default_op <- function(x) {
  assert_that(is.string(x))
  infix <- c("::", "$", "@", "^", "*", "/", "+", "-", ">", ">=", "<", "<=",
    "==", "!=", "!", "&", "&&", "|", "||", "~", "<-", "<<-")

  if (x %in% infix) {
    sql_infix(x)
  } else if (grepl("^%.*%$", x)) {
    x <- substr(x, 2, nchar(x) - 1)
    sql_infix(x)
  } else {
    sql_prefix(x)
  }
}

all_calls <- function(x) {
  if (!is.call(x)) return(NULL)

  fname <- as.character(x[[1]])
  unique(c(fname, unlist(lapply(x[-1], all_calls), use.names = FALSE)))
}

all_names <- function(x) {
  if (is.name(x)) return(as.character(x))
  if (!is.call(x)) return(NULL)

  unique(unlist(lapply(x[-1], all_names), use.names = FALSE))
}

# character vector -> environment
ceply <- function(x, f, ..., parent = parent.frame()) {
  if (length(x) == 0) return(new.env(parent = parent))
  l <- lapply(x, f, ...)
  names(l) <- x
  list2env(l, parent = parent)
}


library(tidyverse)
library(lubridate)
library(xml2)

berlingskeBarometerURLBase <- "http://www.berlingske.dk/upload/webred/bmsandbox/opinion_poll"

berlingskeBarometerOverviewFilename <- "overview.xml"

parseBerlingskeOverviewInstitute <- function(node) {

  years <- node$xmls %>% map(function(x) x$year[[1]]) %>% as.integer()
  id <- node$id
  name <- node$name[[1]]

  tibble(Year = years) %>% mutate(Id = as.integer(id), InstituteName = name)

}

berlingske_parse_entry <- function(e) {

  party_name <- ""
  party_shortname <- ""
  party_letter <- ""

  if(length(e$party$name)>=1) party_name <- e$party$name[[1]]
  if(length(e$party$letter)>=1) party_letter <- e$party$letter[[1]]

  tibble(PartyId = as.integer(e$party$id[[1]]),
         PartyName = party_name,
         PartyLetter = party_letter,
         SupportRaw = as.double(e$percent)/100
        )
}

berlingske_parse_poll <- function(p) {

    updated <- p$datetime[[1]]

    if(length(p$updated)>=1) updated <- p$updated[[1]]

    if(updated == "0000-00-00 00:00:00") updated = p$datetime[[1]]

    respondents <- NA
    if(length(p$respondents)>=1) respondents <- p$respondents[[1]]
    if(!is.na(respondents)) {if (respondents == 0) respondents <- NA}

    results_raw <- map_dfr(p$entries, berlingske_parse_entry) %>% filter(PartyName != "")

    #Rescale, so that it adds up to 100%
    support_raw_sum <- results_raw %>% summarise(sum(SupportRaw)) %>% pull()
    results <- results_raw %>% mutate(Support = SupportRaw/support_raw_sum)

    tibble(Date = as_date(p$datetime[[1]]),
           Updated = as_datetime(updated),
           Respondents = as.integer(respondents),
           Results = list(results)
           )
}

berlingske_pollsets_available <- function(year = NULL, instituteName = NULL, instituteId = NULL) {

  overview_url <- paste(berlingskeBarometerURLBase,berlingskeBarometerOverviewFilename,sep="/")

  overview_xmldoc <- read_xml(overview_url)

  listdoc <- as_list(overview_xmldoc)

  pollfiles <- listdoc %>% map_dfr(parseBerlingskeOverviewInstitute)

  if (!is.null(year)) {
    pollfiles <- pollfiles %>% filter(Year == year)
  }

  if (!is.null(instituteId)) {
    pollfiles <- pollfiles %>% filter(Id == instituteId)
  }

  if (!is.null(instituteName)) {
    pollfiles <- pollfiles %>% filter(InstituteName == instituteName)
  }

  pollfiles
}

berlingskeSimplify <- function(listdoc) {

  listdoc$polls %>% map_dfr(berlingske_parse_poll)

}

berlingske_pollset <- function(year, instituteId) {

  paste(paste(berlingskeBarometerURLBase,year,instituteId,sep="/"),".xml",sep="") %>%
    map(read_xml) %>%
    map(as_list) %>%
    map(berlingskeSimplify)

}

berlingskeBarometerPolls <- function(year = NULL, instituteName = NULL, instituteId = NULL) {

  berlingske_pollsets_available(year, instituteName, instituteId) %>%
    mutate(Polls = berlingske_pollset(Year, Id)) %>%
    unnest(Polls)

}