#' 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)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.