quarantine.Rmd

---
title: "DRAFT Quarantine Summary"
author: "`r paste('Brian Yandell,', format(Sys.time(), '%d %B %Y'))`"
output:
  word_document: default
  html_document:
    df_print: paged
---

```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = FALSE, message = FALSE, warning = FALSE,
                      fig.height = 2.75, fig.width = 7)
```

```{r}
library(tidyverse)
library(readxl)
kprint <- function(x) {
  if(interactive()) {
    print(x)
  } else {
    knitr::kable(x)
  }
}
```

## Quarantine Summary

These data come from housing summaries curated by Todd Shechter

```{r}
quar <-
  bind_rows(
isolation = 
  bind_rows(
    read_excel(("data/IQ Occ 10.16.20.xlsx"), sheet = "Sept",
               skip = 1, n_max = 9, .name_repair = "minimal") %>%
    select(1:33) %>%
    pivot_longer(-(1:2), names_to = "Date", values_to = "Count"),
    read_excel(("data/IQ Occ 10.16.20.xlsx"), sheet = "Oct",
               skip = 1, n_max = 9, .name_repair = "minimal") %>%
    select(1:32) %>%
    pivot_longer(-(1:2), names_to = "Date", values_to = "Count")) %>%
    rename(Location = "Isolation",
           Capacity = "Beds"),
quarantine = 
  bind_rows(
    read_excel(("data/IQ Occ 10.16.20.xlsx"), sheet = "Sept",
                   skip = 11, n_max = 7, .name_repair = "minimal") %>%
    select(1:33) %>%
    pivot_longer(-(1:2), names_to = "Date", values_to = "Count"),
    read_excel(("data/IQ Occ 10.16.20.xlsx"), sheet = "Oct",
                   skip = 11, n_max = 12, .name_repair = "minimal") %>%
    select(1:32) %>%
    pivot_longer(-(1:2), names_to = "Date", values_to = "Count")) %>%
    rename(Location = "Quarantine",
           Capacity = "Rooms"),
 .id = "stay") %>%
  mutate(Date = as.Date("2020-08-31") - 44074 + as.integer(Date)) %>%
  filter(!is.na(Count)) %>% 
  mutate(Summary = c("By Location","Total")[1 + (Location == "Total")])
```

```{r fig.height = 7}
ggplot(quar) +
  aes(Date, Count, col = Location) +
  facet_wrap(stay ~ Summary, scales = "free_y") +
  geom_line() +
  theme(legend.position = "none")
```

## Quarantine from UHS Randomized Data


```{r}
filename <- "data/uhs_rand.csv"
cdc_date <- read.csv(filename) %>%
  mutate(Event = factor(Event,
                        c("CollectionDate", "ResultDate",
                          "ConfirmedDate", "TracedDate")),
         Date = as.Date(Date),
         QuarantineStatus = ifelse(QuarantineStatus == "", "Negative", QuarantineStatus)) %>%
  filter(!is.na(Date),
         !is.na(Positive)) %>%
  arrange(RANDID, Date)
```

```{r}
# who moved off campus
off <- (
  cdc_date %>%
    filter(RANDHALL == -1 | Campus == "off") %>%
    distinct(RANDHALL, RANDHOUS, RANDROOM, RANDID))$RANDID
```


```{r}
cdc_date <- cdc_date %>%
  filter(RANDHALL != -1,
         Campus == "on")
```

```{r}
# Any off-campus were on-campus?
sum(cdc_date$RANDID %in% off)
```

```{r}
# Who moved to another on-campus spot?
moved <- (cdc_date %>%
  distinct(RANDHALL, RANDHOUS, RANDROOM, RANDID) %>%
  count(RANDID) %>%
  filter(n > 1))$RANDID
(tmp <- cdc_date %>%
  filter(RANDID %in% moved) %>%
  arrange(Date) %>%
  group_by(RANDHALL, RANDHOUS, RANDROOM, RANDID) %>%
  summarize(FirstDate = first(Date),
            LastDate = last(Date),
            Positive = max(Positive),
            .groups = "drop") %>%
  arrange(RANDID, FirstDate))
```

Number of people per room

```{r}
cdc_date %>%
  distinct(RANDHALL, RANDHOUS, RANDROOM, RANDID) %>%
  count(RANDHALL, RANDHOUS, RANDROOM) %>%
  count(n)
```

```{r}
# Rooms that seem to be triples
cdc_date %>%
  distinct(RANDHALL, RANDHOUS, RANDROOM, RANDID) %>%
  count(RANDHALL, RANDHOUS, RANDROOM) %>%
  filter(n == 3) %>%
  group_by(RANDHALL, RANDROOM) %>%
  summarize(RANDHOUS = paste(RANDHOUS, collapse = ","), .groups = "drop")
```

```{r}
# Triples that seem unfilled
cdc_date %>%
  distinct(RANDHALL, RANDHOUS, RANDROOM, RANDID) %>%
  count(RANDHALL, RANDHOUS, RANDROOM) %>%
  filter((RANDHALL == 5 & RANDROOM == c(5, 61)) |
           (RANDHALL == 16 & RANDROOM %in% c(28, 78)),
         n < 3)
```

```{r}
# Trying to track who has left campus
first_date <- cdc_date %>%
  arrange(Date) %>%
  group_by(RANDHALL, RANDHOUS, RANDROOM, RANDID) %>%
  summarize(Date = first(Date),
            Positive = max(Positive),
            QuarantineStatus = first(QuarantineStatus),
            .groups = "drop") %>%
  mutate(RANDHALL = as.character(RANDHALL),
         RANDCOL = ifelse(RANDHALL %in% c("10","16"), RANDHALL, "0"),
         IQ = ifelse(QuarantineStatus == "Isolation" & Positive == 1,
                     "Isolation Positive", QuarantineStatus),
         IQ = ifelse(IQ %in% c("Quarantine", "Isolation"), paste(IQ, "Negative"), IQ))
```

```{r}
ggplot(first_date) +
  aes(Date, group = RANDHALL, col = RANDCOL) +
  stat_ecdf(geom = "step") +
  facet_wrap( ~ IQ) +
  scale_color_manual(values = c("grey","red","blue")) +
  theme(legend.position = "none")
```

```{r}
# Trying to track who has left campus
last_date <- cdc_date %>%
  arrange(Date) %>%
  filter(Event %in% c("CollectionDate", "ResultDate", "ConfirmedDate")) %>%
  group_by(RANDHALL, RANDHOUS, RANDROOM, RANDID) %>%
  summarize(Date = last(Date),
            Positive = max(Positive),
            QuarantineStatus = last(QuarantineStatus),
            .groups = "drop") %>%
  mutate(RANDHALL = as.character(RANDHALL),
         RANDCOL = ifelse(RANDHALL %in% c("10","16"), RANDHALL, "0"),
         IQ = ifelse(QuarantineStatus == "Isolation" & Positive == 1,
                     "Isolation Positive", QuarantineStatus),
         IQ = ifelse(IQ %in% c("Quarantine", "Isolation"), paste(IQ, "Negative"), IQ),
         IQ = factor(IQ, c("Isolation Positive","Negative","Isolation Negative", "Quarantine Negative")),
         RANDCOL = factor(RANDCOL, c("0", "10","16"))) %>%
  arrange(RANDCOL, Date)
```

Many of the students who went into isolation did not return to their residence hall, based on their last test date. Regardless of whether they arrived with a previous COVID positive or turned positive while in the residence hall, most of them had left by about 15 September. There was a marked early departure of negative cases from the two quarantined residence halls. For quarantined students, the patterns were similar across the residence halls.

```{r fig.width = 5, fig.height = 5}
ggplot(last_date) +
  aes(Date, group = RANDHALL, col = RANDCOL) +
  stat_ecdf(data = last_date %>% filter(RANDCOL == "0"), geom = "step", size = 1) +
  stat_ecdf(data = last_date %>% filter(RANDCOL != "0"), geom = "step", size = 1) +
  facet_wrap(~ IQ) +
  scale_color_manual(values = c("grey","red","blue")) +
  theme(legend.position = "none") +
  ggtitle("Sellery and Witte vs other RH Last Testing (Departure?) Dates")
```

### Students who went into isolation

```{r}
# record by student
record <- split(cdc_date, cdc_date$RANDID)
record_pos <- record[names(record) %in% 
                       (last_date %>%
                          filter(QuarantineStatus == "Isolation",
                                 Positive == 1))$RANDID]
record_pos_neg <- 
  map(
    record_pos,
    function(x) {
      if(last(x$Positive == 0)) {
        x
      } else {
        NULL
      }})
record_pos_neg <- 
  bind_rows(
    record_pos_neg[!sapply(record_pos_neg, is.null)],
    .id = "RANDID")
record_pos <- 
  bind_rows(
    record_pos[!(names(record_pos) %in% record_pos_neg$RANDID)],
    .id = "RANDID")
```

Look at students who went into isolation, separated by whether their last test was negative or positive. Vertical lines at one and two weeks before last record date. Circles are collection dates; triangles are result dates. Red are negative; blue are positive.

```{r}
ggplot(record_pos_neg %>% 
         filter(Event %in% c("CollectionDate", "ResultDate")) %>%
         group_by(RANDID) %>%
           mutate(lastDate = last(Date)) %>%
         ungroup %>%
         arrange(lastDate) %>%
         mutate(ID = match(RANDID, unique(RANDID)))) +
  aes(Date, ID, col = factor(Positive), group = ID, shape = Event) +
  geom_vline(xintercept = max(last_date$Date) - c(7,14), linetype = "dashed", col = "darkgrey") +
  geom_point(size = 2) +
  geom_line() +
  theme(legend.position = "none") +
  ggtitle("Students Returning from Isolation")
```
```{r}
later <- (last_date %>%
  filter(Date > as.Date("2020-09-20")))$RANDID
```

```{r fig.height = 7}
ggplot(record_pos %>% 
         filter(Event %in% c("CollectionDate", "ResultDate"),
                !(RANDID %in% later)) %>%
         group_by(RANDID) %>%
           mutate(lastDate = last(Date)) %>%
         ungroup %>%
         arrange(lastDate) %>%
         mutate(ID = match(RANDID, unique(RANDID)))) +
  aes(Date, ID, col = factor(Positive), group = ID, shape = Event) +
  geom_vline(xintercept = max(last_date$Date) - c(7,14), linetype = "dashed", col = "darkgrey") +
  geom_point() +
  geom_line() +
  theme(legend.position = "none") +
  ggtitle("Students Whose Last Record was Positive and Before 20 Sep")
```

```{r fig.height = 10}
ggplot(record_pos %>% 
         filter(Event %in% c("CollectionDate", "ResultDate"),
                RANDID %in% later) %>%
         group_by(RANDID) %>%
           mutate(lastDate = last(Date)) %>%
         ungroup %>%
         arrange(lastDate) %>%
         mutate(ID = match(RANDID, unique(RANDID)))) +
  aes(Date, ID, col = factor(Positive), group = ID, shape = Event) +
  geom_vline(xintercept = max(last_date$Date) - c(7,14), linetype = "dashed", col = "darkgrey") +
  geom_point() +
  geom_line() +
  theme(legend.position = "none") +
  ggtitle("Students Whose Last Record was Positive and After 20 Sep")
```

```{r}
# record by student
record_neg <- record[names(record) %in% 
                       (last_date %>%
                          filter(QuarantineStatus == "Isolation",
                                 Positive == 0))$RANDID]
record_neg <- 
  bind_rows(
    record_neg,
    .id = "RANDID")
```

```{r fig.height = 7}
ggplot(record_neg %>% 
         filter(Event %in% c("CollectionDate", "ResultDate")) %>%
         group_by(RANDID) %>%
           mutate(lastDate = last(Date)) %>%
         ungroup %>%
         arrange(lastDate) %>%
         mutate(ID = match(RANDID, unique(RANDID)))) +
  aes(Date, ID, col = factor(Positive), group = ID, shape = Event) +
  geom_vline(xintercept = max(last_date$Date) - c(7,14), linetype = "dashed", col = "darkgrey") +
  geom_point() +
  geom_line() +
  theme(legend.position = "none") +
  ggtitle("Students labeled Isolation with all Negatives")
```

## Quarantine Detail

This part concerns data from Collin Pitts in his multi-sheet spreadsheet

```{r}
quar_sheets <- as.list(excel_sheets("data/De-identified Roster.xlsx"))
# Exempt had no column names. Added by hand.
quar_read <- function(sheet, col_types = NULL) {
  out <- read_excel("data/De-identified Roster.xlsx", sheet = sheet)
  col_types <- c(col_types, rep("text", ncol(out) - length(col_types)))
  out <- read_excel("data/De-identified Roster.xlsx", sheet = sheet, 
                    col_types = col_types, .name_repair = "minimal")
  out <- out[, names(out) != ""]
  names(out) <- make.names(names(out))
  out
}
```

```{r}
quar <- list()
quar$Isolation <- quar_read("Isolation",
                            col_types = c(rep("date",3),rep("text",2))) %>%
  rename(Anticipated.Return.to.Housing = "Anticipated.D.C")
quar$Exempt <- read_excel("data/De-identified Roster.xlsx", sheet = "Exempt", 
                          col_names = FALSE, col_types = "date") %>%
  select(4)
names(quar$Exempt)[1] <- names(quar$Isolation)[1]
quar$Quarantine <- quar_read("Quarantine",
                            col_types = c(rep("date",5),rep("text",4))) %>%
  select(1:9)
quar$Transfer <- quar_read("Quarantine to Isolation",
                            col_types = c(rep("date",4),rep("text",4))) %>%
  select(1:8)
quar <- quar %>%
  bind_rows(.id = "sheet") %>%
  mutate(Date.Added = as.Date(Date.Added),
         Test.Date = as.Date(Test.Date),
         Exposed = as.Date(Exposed),
         Anticipated.Return.to.Housing = as.Date(Anticipated.Return.to.Housing),
         Day.4.Test = as.Date(Day.4.Test),
         Day.8.Test = as.Date(Day.8.Test)) %>%
  filter(!(is.na(Date.Added) | Date.Added < as.Date("2020-01-01")))
tmp <- which(quar$Anticipated.Return.to.Housing < "2020-01-01")
quar$Anticipated.Return.to.Housing[tmp] <- as.Date(NA)
```

```{r eval=FALSE}
quar %>%
  count(sheet, Date.Added) %>%
  pivot_wider(names_from = "sheet", values_from = "n") %>%
  arrange(Date.Added)
```

```{r eval=FALSE}
quar %>%
  mutate(delay = as.numeric(Test.Date - Date.Added)) %>%
  select(sheet, Date.Added, Test.Date, delay)
```

## Quarantine Counts over Time

```{r}
quart <- quar %>%
  select(Exposed, Date.Added:Test.Date,Day.4.Test:Day.8.Test,sheet) %>%
  mutate(ID = rank(Date.Added, ties.method = "random")) %>%
  pivot_longer(Exposed:Day.8.Test, names_to = "State", values_to = "Date") %>%
  filter(!is.na(Date))
```

```{r}
quar_date <- quart %>%
  group_by(Date, sheet) %>%
  summarize(Exposed = sum(State == "Exposed"),
            Quarantined = sum(State == "Date.Added") -
              sum(State == "Anticipated.Return.to.Housing"),
            Exempt = sum(State == "Date.Added")) %>%
  ungroup %>%
  group_by(sheet) %>%
  mutate(cumExposed = cumsum(Exposed),
         cumQuarantined = cumsum(Quarantined),
         cumExempt = sum(Exempt) - cumsum(Exempt)) %>%
  ungroup
tmp <- quart %>%
  filter(sheet != "Exempt") %>%
  group_by(Date) %>%
  summarize(Exposed = sum(State == "Exposed"),
            Quarantined = sum(State == "Date.Added") - sum(State == "Anticipated.Return.to.Housing")) %>%
  ungroup %>%
  mutate(cumExposed = cumsum(Exposed),
         cumQuarantined = cumsum(Quarantined),
         sheet = "Overall")
quar_date <-
  bind_rows(
    quar_date,
    tmp) %>%
  mutate(Overall = c("By Quarantine Type", "Overall")[1 + (sheet == "Overall")])

```

```{r}
ggplot(quar_date %>% filter(!(sheet %in% c("Isolation","Exempt")))) +
  aes(Date, cumExposed, col = sheet) +
  geom_line(size = 2) +
  facet_wrap(~ Overall, scale = "free_y") +
  ylab("Exposed") +
  ggtitle("Number of Exposed Dorm Students")
```

```{r}
ggplot(quar_date %>% filter(sheet != "Exempt")) +
  aes(Date, cumQuarantined, col = sheet) +
  geom_line(size = 2) +
  facet_wrap(~ Overall, scale = "free_y") +
  ylab("Quarantined or Isolated") +
  ggtitle("Number of Dorm Students in Quarantine or Isolation")
```

```{r}
ggplot(quar_date %>% filter(sheet == "Exempt")) +
  aes(Date, cumExempt, col = sheet) +
  geom_line(size = 2) +
  facet_wrap(~ Overall, scale = "free_y") +
  theme(legend.position = "none") +
  ylab("Exempt") +
  ggtitle("Number Exempt due to Prior Infection")
```

## Delays

```{r}
ggplot(
  quar %>% 
    filter(sheet != "Exempt",
           !is.na(Test.Date))) +
  aes(Date.Added, Test.Date - Date.Added, col = sheet) +
  geom_smooth(method = "lm", se = FALSE) +
  geom_hline(yintercept = 0, col = "darkgray", size = 2) +
  ylab("Delay in days") +
  geom_jitter(alpha = 0.65, size = 2) +
  ggtitle("Delay between Date Added and Test Date")
```


```{r}
ggplot(
  quar %>% 
    filter(sheet != "Exempt", 
           !is.na(Exposed))) +
  aes(Date.Added, Date.Added - Exposed, col = sheet) +
  geom_smooth(method = "lm", se = FALSE) +
  geom_hline(yintercept = 0, col = "darkgray", size = 2) +
  ylab("Delay in days") +
  geom_jitter(alpha = 0.65, size = 2) +
  ggtitle("Delay between Exposure and Date Added")
```

```{r}
ggplot(
  quar %>% 
    filter(sheet != "Exempt", 
           !is.na(Exposed),
           !is.na(Test.Date))) +
  aes(Test.Date, Test.Date - Exposed, col = sheet) +
  geom_smooth(method = "lm", se = FALSE) +
  geom_hline(yintercept = 0, col = "darkgray", size = 2) +
  ylab("Delay in days") +
  geom_jitter(alpha = 0.65, size = 2) +
  ggtitle("Delay between Exposure and Test Date")
```

## Length of Stay in Quarantine or Isolation

```{r fig.height = 6}
ggplot(quar %>% filter(sheet != "Exempt", )) +
  aes(Date.Added, Anticipated.Return.to.Housing - Date.Added, col = sheet) +
  geom_smooth(method = "lm", se = FALSE) +
  geom_jitter(alpha = 0.65, size = 2) +
  ylab("Length in days") +
  ggtitle("Length of Anticipated Stay from Date Added")
```

\newpage

## Quarantine and Isolation Student Timeline

```{r}
quart <- quart %>%
  mutate(State = factor(State, c("Exposed", "Test.Date", "Date.Added", 
                                 "Day.4.Test", "Day.8.Test",
                                 "Anticipated.Return.to.Housing",
                                 "Exempt")))
```

```{r}
exposed <- sort((
  quart %>%
    filter(State == "Exposed"))$ID)
tested <- sort((
  quart %>%
    filter(State == "Test.Date"))$ID)
tested <- tested[!(tested %in% exposed)]
IDs <- rep(0, length(unique(quart$ID)))
IDs[exposed] <- seq_along(exposed)
IDs[tested] <- seq_along(tested)
IDs[-c(exposed, tested)] <- seq_len(sum(IDs == 0))
```

```{r}
ggplot(
  quart %>% 
    filter(ID %in% exposed) %>%
    mutate(ID = IDs[ID])) +
  aes(Date, ID, col = State, group = ID) +
  geom_point() +
  geom_path() +
  facet_wrap(~ sheet) +
  ggtitle("Exposed")
```


```{r}
ggplot(
  quart %>% 
    filter(!(ID %in% exposed),
           ID %in% tested) %>%
    mutate(ID = IDs[ID])) +
  aes(Date, ID, col = State, group = ID) +
  geom_point() +
  geom_path() +
  facet_wrap(~ sheet) +
  ggtitle("Tested but not Exposed")
```


```{r}
ggplot(
  quart %>% 
    filter(sheet != "Exempt",
           !(ID %in% exposed),
           !(ID %in% tested)) %>%
    mutate(ID = IDs[ID])) +
  aes(Date, ID, col = State, group = ID) +
  geom_point() +
  geom_path() +
  facet_wrap(~ sheet) +
  ggtitle("No Known Exposure or Initial Testing")
```


This document summarizes quarantine information. The R code file can be found in the [pandemic github repository](https://github.com/UW-Madison-DataScience/pandemic/blob/master/quarantine.Rmd).