codice gp scaduti

gp-scadenti.R

require(scales)
require(tidyverse)
require(rjson)
library(scales)


Sys.setlocale(locale="it_IT.UTF-8")

last_update <-
  fromJSON(file = "https://raw.githubusercontent.com/italia/covid19-opendata-vaccini/master/dati/last-update-dataset.json")
last_update <- substr(last_update[[1]], 1, 19)
last_update <- gsub("T", " ", last_update)
last_update <- as.POSIXct(last_update)

addUnits <- function(n) {
  labels <- ifelse(abs(n) < 1000, n,  # less than thousands
                   ifelse(abs(n)  < 1e6, paste0(round(n/1e3), 'mila'),  # in thousands
                          ifelse(abs(n)  < 1e9, paste0(round(n/1e6, 1), ' milioni'),  # in millions
                                 ifelse(abs(n)  < 1e12, paste0(round(n/1e9), 'B'), # in billions
                                        ifelse(abs(n) < 1e15, paste0(round(n/1e12), 'T'), # in trillions
                                               'too big!'
                                        )))))
  return(labels)
}

# Define server logic required to draw a histogram

data <-
  readr::read_csv(
    "https://raw.githubusercontent.com/italia/covid19-opendata-vaccini/master/dati/somministrazioni-vaccini-latest.csv"
  )



data2 <-
  data %>%
  filter(1 == 1
         & fascia_anagrafica %in% c("12-19","20-29",
                                    "30-39", "40-49","50-59", "60-69",
                                    "70-79", "80-89", "90+"
                                    ))

n <- 6
data3 <-
  arrange(data2, as.Date(data_somministrazione)) %>%
  mutate(
    data_somministrazione = as.Date(data_somministrazione),
    eleggibili = (
      seconda_dose +
        pregressa_infezione +
        ifelse(data2$fornitore == "Janssen", data2$prima_dose, 0)
    ),
    eleggibili_rule = ifelse(1 == 1, 1, 0),
    data_eleggibile = data_somministrazione + 30 * as.integer(5),
    data_scad_gp = data_somministrazione + round(30 * as.integer(n)),
    boosted = dose_addizionale_booster,
    cum_eleggibili = cumsum(eleggibili),
    cum_boosted = cumsum(boosted)
  ) %>%
  select(
    data_somministrazione,
    eleggibili,
    data_eleggibile,
    data_scad_gp,
    boosted,
    cum_eleggibili,
    cum_boosted,
    fascia_anagrafica
  )


eligible <-
  data3 %>% select(fascia_anagrafica, data_eleggibile, eleggibili) %>%
  group_by(fascia_anagrafica, data_eleggibile) %>%
  summarise(eleggibili = sum(eleggibili))


gp <-
  data3 %>% select(data_scad_gp, fascia_anagrafica, eleggibili) %>%
  group_by(fascia_anagrafica, data_scad_gp) %>%
  summarise(eleggibili = sum(eleggibili))

boosted <-
  data3 %>% select(data_somministrazione, fascia_anagrafica, boosted) %>%
  group_by(fascia_anagrafica, data_somministrazione) %>%
  summarise(boosted = sum(boosted))

  diff_gp <- 
    gp %>%
      left_join(
        boosted,
        by = c(
          "data_scad_gp" = "data_somministrazione",
          "fascia_anagrafica" = "fascia_anagrafica"
        )
      ) %>%
      arrange(data_scad_gp) %>%
      ungroup() %>%
    group_by(fascia_anagrafica) %>%
    arrange(fascia_anagrafica,data_scad_gp) %>% 
      mutate(
        cumsum_eleggibili = cumsum(eleggibili),
        cumsum_boosted = cumsum(boosted)) %>% 
    mutate(
        gap_lead = cumsum_boosted - cumsum_eleggibili
      ) %>%
      filter(cumsum_boosted > 0) %>% 
    filter(gap_lead < 0) %>%
    ungroup() %>% 
    group_by(data_scad_gp, fascia_anagrafica) %>% 
    summarise(deficit = sum(gap_lead))
    #filter(fascia_anagrafica == "12-19")
y1 <- -sum(diff_gp$deficit[diff_gp$data_scad_gp == as.Date("2022-01-01")])
yarr <- -sum(diff_gp$deficit[diff_gp$data_scad_gp == (as.Date(last_update)-2)])
labarr <- paste0("Se la scadenza del GP fosse stata ridotta a 6 mesi\n il giorno",
                 format(as.Date(last_update) - 2, format="%e %B"),
                 ", ne sarebbero scaduti almeno ", addUnits(yarr), "\n (escludendo guarigioni e decessi)")

p <-   diff_gp %>% 
    filter(data_scad_gp >= as.Date("2021-12-31")) %>% 
    filter(data_scad_gp <= as.Date(last_update) -1) %>% 
             ggplot(mapping = aes(data_scad_gp, -deficit, fill=fascia_anagrafica)  ) + 
    geom_bar(stat = "identity", width = 0.4) +
    geom_segment(aes(x = as.Date("2022-01-01"),
                     xend = as.Date("2022-02-01"),
                     y = y1,
                     yend = 0), col="dark grey", lty=2)+
    geom_curve(aes(xend = as.Date(last_update) - 1 ,
                 yend = yarr,
                 x = as.Date("2022-01-20"),
                 y = 2000000),
                 curvature = .05,
                 arrow = arrow(length = unit(0.03, "npc")))+
    ggthemes::theme_few() +
    xlab("Data") +
    ylab("GP scaduti") + 
    theme(legend.position=c(0.033, 0.227),
          legend.title = element_blank(),
          legend.text = element_text(size=9),
          legend.background = element_rect(colour="grey", size=0.2) ) + 
    scale_x_date(date_breaks = "months", date_labels = "%b %d") +
    ggtitle(paste0("Quanti Green Pass risulterebbero scaduti, se la scadenza diventasse ",n," mesi?")) +
    labs(fill="Fascia anagrafica",
         subtitle = "Ipotesi: terze dosi somministrate nello stesso ordine delle seconde. <br>
         A colori più scuri corrispondono età più avanzate.",
         caption = paste0("last update:", last_update,"//@processNamed")) +
    scale_fill_brewer() + scale_y_continuous(labels = scales::comma) + 
    theme(text = element_text(size = 22))   +
    scale_x_date(date_breaks = "months", date_labels = "%d %b",
                 limits=c(as.Date("2021-12-31"), as.Date("2022-02-01"))) +
    scale_y_continuous(labels = scales::label_comma(big.mark = '.', 
                                                    decimal.mark = ','))+
    theme(plot.subtitle = element_markdown())+
    theme( panel.grid.major.y = element_line(size = (0.2), colour="grey"),
           panel.grid.minor.y = element_line(size=0.2, colour="grey", linetype = "dotted")) +
    geom_text(mapping=aes(x = as.Date("2022-01-21"),
                          y = 1800000, label = labarr), size = 5)
    
p