R/explore.R

In cpsievert/zikar: Tools for exploring publicly available Zika data

#' Shiny app for exploring zika data
#'
#' @export
#' @examples
#' explore()
#'

explore <- function() {

  data(zika)
  data(latLonDat)

  z <- zika %>%
    # some locations (e.g. "Brazil-Amapa") seem to consistenly report NAs
    dplyr::filter(!is.na(value)) %>%
    dplyr::left_join(latLonDat, by = "location") %>%
    dplyr::filter(!is.na(lat)) %>%
    # column to track selections
    dplyr::mutate(region = "All Regions")

  zSD <- SharedData$new(z, ~location, group = "A")

  zDiff <- z %>%
    group_by(location, country, region, report_type) %>%
    do(value = c(0, diff(.$value))) %>%
    ungroup() %>%
    unnest() %>%
    mutate(report_date = z$report_date)

  zDiffSD <- SharedData$new(zDiff, ~location, group = "A")

  countries <- unique(z[["country"]])
  countriesInSubplot <- setdiff(countries, "Colombia")
  locations <- unique(z[["location"]])

  # coloring palette for report types
  pal <- c(confirmed = "#e41a1c", suspected = "#377eb8")

  ui <- fluidPage(
    fluidRow(
      column(
        4,
        leafletOutput("map", height = 600)
      ),
      column(
        8,
        checkboxInput("cumulative", "Show cumulative counts", value = FALSE),
        tabsetPanel(
          tabPanel(
            "Time Series", plotlyOutput("timeSeries", height = 650), value = "all"
          ),
          tabPanel("Colombia", plotlyOutput("colombia"), value = "colombia"),
          tabPanel("Zoom", plotlyOutput("Zoom", height = 600), value = "density"),
          id = "tabset",
          selected = "all"
        ))
    )
  )

  server <- function(input, output, session, ...) {

    output$map <- renderLeaflet({
      latLonDat2 <- dplyr::semi_join(latLonDat, zika, by = "location")
      leaflet(latLonDat2) %>%
        addTiles() %>%
        fitBounds(~min(lng), ~min(lat), ~max(lng), ~max(lat)) %>%
        addCircleMarkers(
          lng = ~lng, lat = ~lat, label = ~location, layerId = ~location,
          color = "black", clusterOptions = markerClusterOptions()
        )
    })

    getZikaData <- reactive({
      need(input$cumulative, "Choose cumulative value")
      if (identical(input$cumulative, FALSE)) zDiffSD else zSD
    })

    output$timeSeries <- renderPlotly({
      # update map & possibly prompt google search on click
      res <- fitMapToLocation()
      #googleSearch()


      base <- getZikaData() %>%
        plot_ly(x = ~report_date, y = ~value, color = ~report_type,
                colors = pal, alpha = 0.5, text = ~location,
                source = "timeSeriesSubplot") %>%
        group_by(location)

      plots <- lapply(countriesInSubplot, function(cntry) {
        base %>%
          filter(country %in% cntry) %>%
          add_trace(type = "scatter", mode = "markers+lines",
                    hoverinfo = "x+y+text+name", marker = list(size = 6)) %>%
          layout(
            xaxis = list(title = ""),
            yaxis = list(
              title = cntry,
              titlefont = list(size = 14),
              tickfont = list(size = 12)
            )
          )
      })
      subplot(plots, nrows = 5, shareX = TRUE, titleY = TRUE, margin = 0.03) %>%
        highlight("plotly_hover") %>%
        layout(dragmode = "zoom", margin = list(t = 50))
    })

    # open a google search on click
    googleSearch <- reactive({
      d <- event_data("plotly_click", "timeSeriesSubplot")
      if (isTRUE(d$key %in% unique(zika$location))) {
        browseURL(sprintf("http://google.com/#q=%s", d$key))
      }
      invisible()
    })

    # A reactive expression that returns the locations that are
    # in bounds right now
    mapClickData <- reactive({
      id <- input$map_marker_click$id
      if (is.null(id)) {
        return(NULL)
      }
      getZikaData()$origData() %>% filter(location %in% id) %>% mutate(region = id)
    })

    fitMapToLocation <- reactive({
      d <- if (identical(input$tabset, "colombia")) {
        filter(z, country %in% "Colombia")
      } else if (identical(input$tabset, "all")) {
        filter(z, !country %in% "Colombia")
      }
      # if we click on a location's time-series, zoom to that location
      eventData <- event_data("plotly_click", "timeSeriesSubplot")
      if (isTRUE(eventData$key %in% locations)) {
        d <- filter(d, location %in% eventData$key)
      }
      latRng <- range(d$lat)
      lngRng <- range(d$lng)
      leafletProxy("map", session) %>%
        fitBounds(lngRng[1], latRng[1], lngRng[2], latRng[2])
    })

    output$colombia <- renderPlotly({
      res <- fitMapToLocation()

      getZikaData()$origData() %>%
        filter(country %in% "Colombia") %>%
        group_by(location) %>%
        SharedData$new(~location) %>%
        plot_ly(x = ~report_date, y = ~value,
                text = ~sub("Colombia-", "", location),
                hoverinfo = "text", alpha = 0.3) %>%
        add_trace(color = ~report_type, colors = pal, type = "scatter",
                  marker = list(size = 6), mode = "markers+lines") %>%
        layout(xaxis = list(title = ""), yaxis = list(title = "")) %>%
        toWebGL() %>%
        highlight("plotly_click", persistent = TRUE)
    })

    # reactive that returns the zika data which is within the map bounds
    mapZoomData <- reactive({
      bounds <- input$map_bounds
      if (is.null(bounds)) {
        return(NULL)
      }
      latRng <- range(bounds$north, bounds$south)
      lngRng <- range(bounds$east, bounds$west)
      idx <- with(z, latRng[1] <= lat & lat <= latRng[2] & lngRng[1] <= lng & lng <= lngRng[2])
      if (all(idx)) {
        return(NULL)
      }
      getZikaData()$origData() %>% filter(idx) %>% mutate(region = "Inside Map")
    })

    retrieveSelection <- reactive({
      zoomSelection <- mapZoomData()
      clickSelection <- mapClickData()
      d <- getZikaData()$origData()
      rbind(d, zoomSelection, clickSelection)
    })

    output$Zoom <- renderPlotly({

      pal <- c(`All Regions` = "black", `Inside Map` = "red")

      plot_area <- function(.) {
        plot_ly(., x = ~exp(x), y = ~y, color = ~region, colors = pal) %>%
          add_lines(alpha = 0.3, fill = "tozeroy") %>%
          layout(yaxis = list(title = ~unique(report_type)))
      }

      data <- retrieveSelection()

      s <- data %>%
        filter(value > 0) %>%
        group_by(report_type, region) %>%
        do(n = NROW(.), d = density(log(.$value), adjust = 3, n = 32)) %>%
        tidy(d) %>%
        ungroup() %>%
        #filter(y > 10^-3) %>%
        group_by(report_type) %>%
        do(p = plot_area(.)) %>%
        .[["p"]] %>%
        subplot(nrows = 2, shareX = TRUE, titleX = TRUE, titleY = TRUE) %>%
        layout(
          xaxis = list(
            type = "log", title = "Number of cases", range = c(-1.1, 5)
          )
        )

      medians <- data %>%
        group_by(report_date, region) %>%
        summarise(m = median(value, na.rm = TRUE)) %>%
        ungroup()

      p <- plot_ly(medians, x = ~report_date, y = ~m,
                   color = ~region, colors = pal) %>%
        add_lines() %>%
        layout(
          yaxis = list(title = "Median number of incidents"),
          xaxis = list(title = "")
        )

      subplot(s, p, nrows = 2, margin = 0.05, titleX = TRUE, titleY = TRUE) %>%
        layout(showlegend = FALSE)

    })

  }

  shinyApp(ui, server)

}