Calculates relative change of new corona cases between the previous two weeks.

corona_relative_change.R

library(covid19germany) # https://github.com/nevrome/covid19germany
library(data.table)
library(sf)
library(lubridate)
library(checkmate)
library(mlr3misc)
library(ggplot2)
library(plotly)
library(leaflet)

# for meaning of features see:
# https://npgeo-corona-npgeo-de.hub.arcgis.com/datasets/dd4580c810204019a7b8eb3e0b329dd6_0
url = "https://opendata.arcgis.com/datasets/dd4580c810204019a7b8eb3e0b329dd6_0.csv"
raw_data = data.table::fread(url)
raw_data[, Meldedatum := ymd_hms(Meldedatum)]
raw_data[, Datenstand := ymd_hms(Datenstand)]
raw_data[, Refdatum := ymd_hms(Refdatum)]
raw_data$Altersgruppe2 = NULL

cases_per_interval = function(sd, interval, type = "case") {
  assert_choice(type, c("case", "death", "revovery"))
  sd = sd[Refdatum %within% interval,]
  if (type == "case") {
    sd[NeuerFall %in% c(0,1), sum(AnzahlFall)]
  } else if (type == "death") {
    sd[NeuerTodesfall %in% c(0,1), sum(AnzahlTodesfall)]
  } else if (type == "recovery") {
    sd[NeuGenesen %in% c(0,1), sum(AnzahlGenesen)]
  }
}

cases_per_intervals = function(sd, intervals, type = "case") {
  map_int(intervals, cases_per_interval, sd = sd, type = type)
}

last_2_weeks = seq.Date(from = today() - days(14), to = today(), by = "7 day")
last_2_weeks_lag = seq.Date(from = today() - days(17), to = today() - days(3), by = "7 day")
quote_last_2_weeks = raw_data[, {
  res = cases_per_intervals(
    .SD, 
    int_diff(last_2_weeks_lag)
  )
  list(change_rate = res[2]/res[1], cases_this_week = res[2], cases_previous_week = res[1])
}, by = c("Landkreis", "IdLandkreis")]


# prepare plot
landkreise = covid19germany::get_RKI_spatial(resolution = "Landkreis")
tmp = merge(landkreise, quote_last_2_weeks, by = "IdLandkreis", sort = FALSE, all.x = TRUE, all.y = FALSE)
landkreise = cbind(landkreise, tmp[, c("change_rate", "cases_this_week", "cases_previous_week")])
#plot(landkreise["cases_pe_1"])

custom_gradient = function() {
  base_palette = rev(RColorBrewer::brewer.pal(11, "RdBu")) #from 0 to 1
  final_palette = colorRampPalette(base_palette, interpolate = "spline")(255)
  rng = log2(range(landkreise$change_rate))
  rng = pmin(rng, c(0.5, Inf))
  rng = pmax(rng, c(-Inf, 2))
  rescaler = function(x, ...) {
    ind = ifelse(
      x < 0, 
      scales::rescale(x, from = c(rng[1],0), to = c(0,0.5)), 
      scales::rescale(x, from = c(0,rng[2]), to = c(0.5,1))
    )
  }
  scale_fill_gradientn(colours = final_palette, rescaler = rescaler, trans = "log2", breaks = c(0.25, 0.5, 1, 2, 4))
}


g = ggplot(landkreise, aes(
  fill = change_rate, 
  text = paste0(
    BEZ, " ", GEN, "<br>",
    "Steigungsrate: ", round(change_rate,2), "<br>",
    "Letzte Woche: ", cases_previous_week, "<br>",
    "Diese Woche: ", cases_this_week))
)
g = g + geom_sf()
g = g + custom_gradient()
g = g + labs(
  fill = "Steigerungsrate", 
  title = "Relative Änderung der Fallzahlen", 
  subtitle = paste0(
    "Verlgeich neuer Fälle zw. ", 
    format(last_2_weeks_lag[1], "%d.%m"),
    "-",
    format(last_2_weeks_lag[2], "%d.%m"),
    " und ",
    format(last_2_weeks_lag[2], "%d.%m"),
    "-",
    format(last_2_weeks_lag[3], "%d.%m.%Y")
  ),
  caption = "3 Tage Verzögerung um RKI Verzug zu Berücksichtigen"
)
g = g + theme_bw()
g
ggsave(plot = g, filename = "corona_relative_change.png", device = "png", width = 10, height = 12, dpi = 150)

# plotly interactive
gly = ggplotly(g, tooltip = c("text"))
htmlwidgets::saveWidget(gly, "corona_relative_change.html")

# leaflet interactive

rng = log2(range(landkreise$change_rate))
rng = pmin(rng, c(0.5, Inf))
rng = pmax(rng, c(-Inf, 2))
pal = function(x) {
  colors = rev(RColorBrewer::brewer.pal(11, "RdBu"))
  x = log2(x)
  ind = ifelse(
    x < 0, 
    scales::rescale(x, from = c(rng[1],0), to = c(0,0.5)), 
    scales::rescale(x, from = c(0,rng[2]), to = c(0.5,1))
  )
  colors[pmin(pmax(1,floor(ind * 11)+1),11)]
}
attr(pal, "colorType") = "numeric"
attr(pal, "colorArgs") = list(na.color = "#333333")


lf = leaflet(landkreise) %>%
  addPolygons(
    color = "#444444", 
    weight = 1, 
    smoothFactor = 0.5,
    opacity = 1.0, 
    fillOpacity = 1.0,
    fillColor = ~pal(change_rate),
    highlightOptions = highlightOptions(color = "white", weight = 2,bringToFront = TRUE),
    label = ~paste0(BEZ, " ", GEN, "<br>",
              "Steigungsrate: ", round(change_rate,2), "<br>",
              "Woche ", format(last_2_weeks_lag[1], "%d.%m"), "-", format(last_2_weeks_lag[2], "%d.%m"), " : ", cases_previous_week, "<br>",
              "Woche ", format(last_2_weeks_lag[2], "%d.%m"), "-", format(last_2_weeks_lag[3], "%d.%m"), " : ", cases_this_week) %>% lapply(htmltools::HTML)
  ) %>% addLegend("bottomright", pal = pal, values = c(0.3,6), title = "Steigerungsrate",
            layerId = "colorLegend")
lf
htmlwidgets::saveWidget(lf, "corona_relative_change.html")