R Shiny: Coronavirus cases in Germany
Shiny app displaying the current Coronavirus cases in Germany based on data from the RKI website.
We will need the following packages for the app. Shiny, obviously. Leaflet for our background map and the tidyverse for data wrangling. To scrape the data from the website we need use the rvest packagae and use sf/raster and geos to crate the choropleth map.
library(shiny)
library(leaflet)
library(tidyverse)
library(rvest)
library(raster)
library(sf)
library(rgeos)
The main data that we use for the visualization comes from the official Robert-Koch-Institute Website which is updated regularly. To get relative values for each state in Germany we also need current population numbers which can be found here. I simply put the data into a tibble using the datapasta package.
pop <- tibble(
name = c("Baden-Württemberg","Bayern","Berlin",
"Brandenburg","Bremen","Hamburg","Hessen","Niedersachsen",
"Mecklenburg-Vorpommern","Nordrhein-Westfalen",
"Rheinland-Pfalz","Saarland","Sachsen","Sachsen-Anhalt",
"Schleswig-Holstein","Thüringen"),
Pop = c(11069533,13076721,3644826,2511917,
682986,1841179,6265809,7982448,1609675,17932651,4084844,
990509,4077937,2208321,2896712,2143145)
)
The UI basically consists out of two elements, we have the leafletOutput for our map and we will use an absolutePanel to display text based information. I also added a button to toggle the window, mainly to make the app more mobile friendly.
ui <- bootstrapPage(
absolutePanel(
id = "controls", class = "panel panel-default",
top = 120, left = 10, width = 300, height = "auto",fixed = TRUE, style = "z-index:500; background: #FFFFFF;padding: 8px;border: 1px solid #CCC;",
HTML('<button data-toggle="collapse" data-target="#panel">Informationen</button>'),
tags$div(id = 'panel', class="collapse",
tags$h2("SARS-CoV-2: Fallzahlen in Deutschland"),
tags$p("Hier sind ausschließlich Fälle aufgelistet, die dem RKI über den Meldeweg oder offizielle Quellen mitgeteilt wurden.
Da es sich um eine sehr dynamische Situation handelt, kann es zu Abweichungen zwischen der RKI-Tabelle und Angaben anderer Stellen,
etwa der betroffenen Bundesländer, kommen."),
h3(textOutput("gesamt")),
tags$hr(style="border-color: black;"),
tags$p("Quelle: Robert Koch Institut"),
p(textOutput("dateText")),
tags$p("Autor:"),
tags$a("Stefan Reifenberg", href="https://twitter.com/Reyfenberg"))
),
leafletOutput("mymap", width = "100%", height = 900)
)
The following part belongs to the server of our app. In order to update the timer displaying the last time we scraped the website we will use a textoutput which is regularly triggered by the autoInvalidate function. I set the timer to 300000 milliseconds which are 5 minutes to make sure we always display the latest data.
autoInvalidate <- reactiveTimer(300000)
observe({
autoInvalidate()
})
output$dateText <- renderText({
autoInvalidate()
paste("Stand:", Sys.time())
})
The next section features the most important part of our app. We use the reactivePoll function to regularly retrieve our data. The documentation of reactivePoll describes the function as following: reactivePoll works by pairing a relatively cheap “check” function with a more expensive value retrieval function. The check function will be executed periodically and should always return a consistent value until the data changes. When the check function returns a different value, then the value retrieval function will be used to re-populate the data. So we basically use the checkFunc to retrieve the current system time every 5 minutes. The time will be different every time which executes the valueFunc to retrieve the data from the website. The valueFunc gets a URL where the RKI posts their data and retrieves the data using the xml2::read_html() function from the rvest package. See the screenshot below to get the required xpath pointing to the table.
data <- reactivePoll(
intervalMillis = 300000,
session,
checkFunc = function(){
Sys.time()
},
valueFunc = function(){
url <- "https://www.rki.de/DE/Content/InfAZ/N/Neuartiges_Coronavirus/Fallzahlen.html"
corona <- url %>%
xml2::read_html() %>%
html_nodes(xpath='//*[@id="main"]/div[1]/table[1]') %>%
html_table()
corona <- corona[[1]]
}
)
We can now retrieve the data from the reactivePoll by calling the data() function and assign it to an object. Additional data wrangling is needed to get the data into the right format. We first remove the last row the dataset which holds the information for total corona cases across and we don’t need this information right now. After that we rename the second column as well as the “Bundesland” column. Afterwards we get rid of all parenthesis and whats inside them and also remove punctuation marks from the data. Finally we convert the column holding the numbers which are currently strings to a numeric format. Eventually we join the population dataset with the corona dataset and calculate the cases relative to the population for each state.
corona_data <- data()
corona_ger <- corona_data %>%
slice(1:(n()-1)) %>% # remove last row
rename_at(2,~"Faelle") %>%
rename(name = "Bundesland") %>%
dplyr::select(name,Faelle)
corona_ger$Faelle <- str_replace(corona_ger$Faelle, " \\(.*\\)", "")
corona_ger$Faelle <- str_replace(corona_ger$Faelle, "\\.", "")
corona_ger$Faelle <- as.numeric(corona_ger$Faelle)
# join dataframes
corona_ger <- inner_join(corona_ger, pop, by="name")
corona_ger <- corona_ger %>%
mutate(per_k = (Faelle/Pop)*10000)
To get the borders for the german states we will use the getData function from the raster package which we then join with our table data by name. Thats basically all we need to plot the map with our data. We can then add additional styling to the polygons and labels and so on.
pal_total <- colorNumeric( palette="viridis", domain = corona_ger$Faelle, na.color="transparent")
pal_rel <- colorNumeric( palette="viridis", domain = corona_ger$per_k, na.color="transparent")
DEU1 <- raster::getData("GADM", country="DEU", level=1)
deu_states <- st_as_sf(DEU1)
deu_states <- deu_states %>%
rename(name = "NAME_1")
corona_ger_sf <- left_join(deu_states, corona_ger, by = "name")
labels_total <- sprintf(
"<strong>%s</strong><br/>Fälle (total): %g",
corona_ger_sf$name, corona_ger_sf$Faelle
) %>% lapply(htmltools::HTML)
labels_points <- sprintf(
"<strong>%s</strong><br/>Fälle: %g",
cor_district$District, cor_district$cases
) %>% lapply(htmltools::HTML)
labels_rel <- sprintf(
"<strong>%s</strong><br/>Fälle (pro 10.000): %s",
corona_ger_sf$name, format(round(corona_ger_sf$per_k, 2), nsmall = 2)
) %>% lapply(htmltools::HTML)
leaflet(corona_ger_sf, cor_district, options = leafletOptions(zoomControl = FALSE)) %>%
setView(11, 50, zoom = 6) %>%
addProviderTiles(providers$Stamen.TonerLite,
options = providerTileOptions(noWrap = TRUE)
) %>%
addCircleMarkers(
group = "Einzelfälle",
lng = cor_district$Longitude,
lat = cor_district$Latitude,
radius = sqrt(cor_district$cases),
color = "#A04173",
stroke = TRUE, fillOpacity = 0.9,
label = labels_points,
labelOptions = labelOptions(
style = list("font-weight" = "normal", padding = "3px 8px"),
textsize = "15px",
direction = "auto")
) %>%
addPolygons(group = "Fälle total",
weight = 2,
fillColor = ~pal_total(Faelle),
fillOpacity = 0.6,
label = labels_total,
labelOptions = labelOptions(
style = list("font-weight" = "normal", padding = "3px 8px"),
textsize = "15px",
direction = "auto")) %>%
addPolygons(group = "Fälle pro 10.000 Einwohner",
weight = 2,
fillColor = ~pal_rel(per_k),
fillOpacity = 0.6,
label = labels_rel,
labelOptions = labelOptions(
style = list("font-weight" = "normal", padding = "3px 8px"),
textsize = "15px",
direction = "auto")) %>%
addLayersControl(
position = "topleft",
overlayGroups = c("Fälle total", "Fälle pro 10.000 Einwohner", "Einzelfälle"),
options = layersControlOptions(collapsed = FALSE)
) %>%
hideGroup(c("Fälle pro 10.000 Einwohner", "Einzelfälle"))
Full code can be found in this Github repo.