Commit f85acb8e authored by Renaud Lancelot's avatar Renaud Lancelot 🌍
Browse files

Changes in functions to handle vector layers of asministrative data, motivated...

Changes in functions to handle vector layers of asministrative data, motivated by the use of the GAUL data set of administrative country borders. Also, changes in the trend() function to account for special cases, and in the dmrplot function to improve data rendering.
parent cc8414c1
Pipeline #15359 passed with stage
in 4 minutes and 48 seconds
## get lockdown data https://covidtracker.bsg.ox.ac.uk/
## Blavatnik School of Government / Oxford Univ
## Oxford COVID-19 Government Response Tracker
stringency <- function(date_range = "2020-01-01/2020-05-31"){
web <- "https://covidtrackerapi.bsg.ox.ac.uk/"
api <- "api/v2/stringency/"
fjs <- paste(web,
api,
"date-range/",
date_range,
sep = "")
dat <- fromJSON(file = fjs)
## control to check for the existence of data
cond <- paste("length(x$date_value) > 0 &",
"length(x$country_code) > 0 &",
"length(x$deaths) > 0 &",
"length(x$stringency_actual) > 0 &",
"length(x$stringency) > 0 &",
"length(x$stringency_legacy) > 0 &",
"length(x$stringency_legacy_disp) > 0")
## get data when control os TRUE
Liste <- lapply(dat$data,
function(x)
do.call(
what = "rbind",
args = lapply(x,
function(x){
if(eval(parse(text = cond)))
data.frame(x)
else
NULL
})))
## stack
stringency <- do.call("rbind", Liste)
stringency$date <- as.Date(
substr(rownames(stringency), 1, 10))
rownames(stringency) <- seq(nrow(stringency))
## add country name
nam <- sapply(dat$countries,
function(x)
countryname(x))
code <- data.frame(name = standardise_country_names(nam),
country_code = dat$countries)
resu <- merge(stringency, code, by = "country_code")
return(resu[order(resu$name,
resu$date), ])
}
## get country borders for the whole world and get rid of the
## apostrophe in "Cote d'Ivoire"
get_world_map <- function(){
ans <- readOGR(dsn = "./data",
layer = "GAULCOUNTRY2013")
xname <- as.character(ans$ADM0_NAME)
pos <- grep(pattern = "Ivoire", x = xname)
xname[pos] <- "Cote dIvoire"
ans$name <- standardise_country_names(xname)
return(ans)
}
#' Simplify a vector layer
geosimplify <- function(x) {
sx <- gSimplify(x, tol=.025, topologyPreserve=T)
......@@ -13,11 +73,10 @@ region_of_interest <- function(x, context) {
e <- extend(extent(x), 1)
E <- as(e, "SpatialPolygons")
projection(E) <- projection(x)
return(raster::intersect(context, E))
return(geosimplify(raster::intersect(context, E)))
}
#' ECDC Covid19 data worldwide
#'
#' Returns the published file at a given date.
......@@ -56,7 +115,7 @@ ecdc_covid19 <- function(date) {
## Cleanup variable and country names
names(ans) <- c("date", "day", "month", "year", "cases", "deaths",
"country", "geoid", "code", "pop", "continent")
"country", "geoid", "code", "pop", "continent", "XXX")
ans$country <- gsub(pattern = "ô",
replacement = "o",
x = as.character(ans$country))
......@@ -87,31 +146,35 @@ standardise_country_names <- function(x) {
## Table of country name variants and their standardised name.
## Whenever a new country name causes conflict, update this table.
country_names_table <-
tribble(
~variant, ~standard_name,
"Syrian Arab Republic", "Syria",
"State of Palestine", "Occupied Palestinian Territory",
"Czechia", "Czech Republic",
"Republic of Moldova", "Moldova",
"Democratic Republic of the Congo", "Congo DR",
"Congo, DRC", "Congo DR",
"Congo DRC", "Congo DR",
"Congo, DR", "Congo DR",
"Republic of Congo", "Congo",
"Gambia", "The Gambia",
"Cote dIvoire", "Cote d'Ivoire",
"Côte d'Ivoire", "Cote d'Ivoire",
"Côte dIvoire", "Cote d'Ivoire",
"Cabo Verde", "Cape Verde",
"Guinea-Bissau", "Guinea Bissau",
"Guinea Bissau", "Guinea Bissau",
"Macedonia", "North Macedonia"
)
tibble::tribble(
~variant, ~standard_name,
"Syrian Arab Republic", "Syria",
"State of Palestine", "Occupied Palestinian Territory",
"Czechia", "Czech Republic",
"Republic of Moldova", "Moldova",
"Democratic Republic of the Congo", "Congo DR",
"Congo, DRC", "Congo DR",
"Congo DRC", "Congo DR",
"Congo, DR", "Congo DR",
"Congo - Kinshasa", "Congo DR",
"Republic of Congo", "Congo",
"Congo - Brazzaville", "Congo",
"Gambia", "The Gambia",
"Cote d'Ivoire", "Cote dIvoire",
"Côte dIvoire", "Cote dIvoire",
"Côte d'Ivoire", "Cote dIvoire",
"Côte d'Ivoire", "Cote dIvoire",
"Cabo Verde", "Cape Verde",
"Guinea-Bissau", "Guinea Bissau",
"Macedonia", "North Macedonia",
"U.K. of Great Britain and Northern Ireland", "United Kingdom",
"United kingdom", "united Kingdom",
"São Tomé and Príncipe", "Sao Tome and Príncipe",
"Sao Tome & Príncipe", "Sao Tome and Príncipe",
"São Tomé & Príncipe", "Sao Tome and Príncipe")
std_name <- function(x) {
if ( !is.na(idx <- match(x, country_names_table$variant)) ) {
x <- country_names_table$standard_name[idx]
x <- iconv(x, from="UTF-8", to="ASCII//TRANSLIT")
}
return(x)
}
......@@ -121,6 +184,7 @@ standardise_country_names <- function(x) {
)
}
#' Get ISO3 codes for a list of countries
get_iso3 <- function(x) {
codes <- ccodes()
......@@ -129,6 +193,17 @@ get_iso3 <- function(x) {
}
## get countrt names from the code (to manage the case of Kosovo=)
countryname <- function(x){
ifelse(x == "RKS",
"Kosovo",
countrycode::countrycode(
sourcevar = x,
origin = "iso3c",
destination = "country.name"))
}
#' Total population by country for a given year
#'
#' Population counts in thousands of people.
......@@ -236,13 +311,13 @@ dmrplot <- function(dmr, start = as.Date("2020-03-01"),
idv <- c("name", "date", "lockdown", "d2peak")
Z1 <- reshape2::melt(data = z,
id.vars = idv,
measure.vars = c("obsdr", "cumdr"))
measure.vars = c("fitdr", "cumdr"))
Z2 <- reshape2::melt(data = z,
id.vars = idv,
measure.vars = "fitdr")
measure.vars = "obsdr")
## incubation 5 d
## early deat 6 d after onset, late eath 46 d after
## median death 14 days onset
## early death 6 d after onset, late death 46 d after
## median death 14 days after onset
## left side at lockdown + 5 + 6, right side at lockdown + 5 + 46
## center at morkdown + 5 + (46 - 6) / 2
......@@ -279,15 +354,15 @@ dmrplot <- function(dmr, start = as.Date("2020-03-01"),
panel = function(x, y, subscripts, ...){
xnam <- unique(Z1$name[subscripts])
xvar <- unique(Z1$variable[subscripts])
if(xvar == "obsdr"){
## Add daily mortality rate
lpoints(x, y,
type = "h", col = grey(.8))
## add trend line
if(xvar == "fitdr"){
## add observed daily death rate
X <- Z2$date[Z2$name == xnam]
Y <- Z2$value[Z2$name == xnam]
o <- order(X)
llines(X[o], Y[o], col=2)
lpoints(X[o], Y[o],
type = "h", col = grey(.8))
## Add trend
llines(x, y, col = 2)
}
if(xvar == "cumdr"){
## annotation with mx(umdr)
......@@ -339,6 +414,7 @@ dmrplot <- function(dmr, start = as.Date("2020-03-01"),
## fn to compute the trend in mortality growth rate
trend <- function(x){
browser()
## use function "by" to loop over the country names
xnam <- unique(x$name)
xlock <- if(is.null(x$lockdown)) NA else unique(x$lockdown)
......@@ -369,10 +445,10 @@ trend <- function(x){
k <- length(seq(min(x$date), Sys.Date(), by="1 week"))
## fits a negative binomial additive model for death coints
fm <- try(gam(deaths ~ s(day, bs="cr", k = k) + offset(log(1000 * pop)),
fm <- try(gam(deaths ~ s(day, bs = "cr", k = k) + offset(log(1000 * pop)),
data = x, family = nb, link = "log",
optimizer = "perf"))
if(class(fm) == "try-error")
if(any(class(fm) == "try-error"))
return(NULL)
else{
pred <- predict(fm, se = T)
......@@ -398,14 +474,11 @@ trend <- function(x){
day <- as.numeric(x$date - min(x$date))
## daily mortality growth rate for the early stage of the epidemic
gr11 <- (dY[day == dlock + 11])
l0 <- length(gr11)
gr11 <- dY[day == dlock + 11]
## relative change in mortality growth rate, reference value = gr11
rgr19 <- 100 * dY[day = dlock + 19] / gr11
l19 <- length(rgr19)
rgr46 <- 100 * dY[day = dlock + 46] / gr11
l46 <- length(rgr46)
## negative growth rate
## ldpeak = day when growth rate became < 0 = mortality peak
......@@ -418,83 +491,87 @@ trend <- function(x){
## for regional consistency
## First death to the peak after lockdown
d2peak <- min(day[day >= dlock & dY < 0], na.rm = T)
l1 <- length(d2peak)
## lockdown to peak
ldpeak <- d2peak - dlock
l2 <- length(ldpeak)
## max fitted death rate
dr0 <- dmr[day == d2peak]
l3 <- length(dr0)
## decay
Y2 <- Y[day >= d2peak]
Ymax <- Y[day == d2peak]
l4 <- length(Y2)
d2 <- day[day >= d2peak] - d2peak
l5 <- length(d2)
## collects the results
fittedTrend <- data.frame(
name = x$name,
date = x$date,
day = day,
date1st = rep(min(x$date), nrow(x)),
obsdr = 100 * tapply(x$deaths,
x$day,
sum) / x$pop,
fitdr = dmr,
cumdr = cumsum(100 * tapply(x$deaths,
x$day,
sum) / x$pop),
pop = unique(x$pop),
lockdown = rep(xlock, nrow(x)),
d2peak = rep(if(l1 > 0) d2peak else NA, nrow(x)),
ldpeak = rep(if(l2 > 0) ldpeak else NA, nrow(x)),
Y = Y,
Ylo = lo,
Yhi = hi,
dY = dY,
dYlo = dlo,
dYhi = dhi)
## mortality decay
size <- unique(x$pop)
cond10 <- Y2 <= .90 * Ymax
cond20 <- Y2 <= .80 * Ymax
cond30 <- Y2 <= .70 * Ymax
cond40 <- Y2 <= .60 * Ymax
cond50 <- Y2 <= .50 * Ymax
cond60 <- Y2 <= .40 * Ymax
cond70 <- Y2 <= .30 * Ymax
cond80 <- Y2 <= .20 * Ymax
cond90 <- Y2 <= .10 * Ymax
cond95 <- Y2 <= .05 * Ymax
fittedParam <- data.frame(
name = unique(x$name),
lockdown = xlock,
d2peak = if(l1 > 0) d2peak else NA,
ldpeak = if(l2 > 0) ldpeak else NA,
maxdr = if(l3 > 0) dr0 else NA,
gr11 = if(l0 > 0) gr11 else NA,
rgr19 = if(l19 > 0) rgr19 else NA,
rgr46 = if(l46 > 0) rgr46 else NA,
T10 = if(any(cond10)) min(d2[cond10]) else NA,
T20 = if(any(cond20)) min(d2[cond20]) else NA,
T30 = if(any(cond30)) min(d2[cond30]) else NA,
T40 = if(any(cond40)) min(d2[cond40]) else NA,
T50 = if(any(cond50)) min(d2[cond50]) else NA,
T60 = if(any(cond70)) min(d2[cond60]) else NA,
T70 = if(any(cond80)) min(d2[cond70]) else NA,
T80 = if(any(cond90)) min(d2[cond80]) else NA,
T90 = if(any(cond90)) min(d2[cond90]) else NA,
T95 = if(any(cond95)) min(d2[cond95]) else NA)
l1 <- 0
if(!any(day >= dlock & dY < 0))
return(NULL)
else{
d2peak <- min(day[day >= dlock & dY < 0], na.rm = T)
l1 <- length(d2peak)
## lockdown to peak
ldpeak <- d2peak - dlock
## max fitted death rate
dr0 <- dmr[day == d2peak]
## decay
Y2 <- Y[day >= d2peak]
Ymax <- Y[day == d2peak]
d2 <- day[day >= d2peak] - d2peak
## collects the results
fittedTrend <- data.frame(
name = x$name,
date = x$date,
day = day,
date1st = rep(min(x$date), nrow(x)),
obsdr = 100 * tapply(x$deaths,
x$day,
sum) / x$pop,
fitdr = dmr,
cumdr = cumsum(100 * tapply(x$deaths,
x$day,
sum) / x$pop),
pop = unique(x$pop),
lockdown = rep(xlock, nrow(x)),
d2peak = rep(if(l1 > 0) d2peak else NA, nrow(x)),
ldpeak = rep(if(l1 > 0) ldpeak else NA, nrow(x)),
Y = Y,
Ylo = lo,
Yhi = hi,
dY = dY,
dYlo = dlo,
dYhi = dhi)
## mortality decay
size <- unique(x$pop)
cond10 <- Y2 <= .90 * Ymax
cond20 <- Y2 <= .80 * Ymax
cond30 <- Y2 <= .70 * Ymax
cond40 <- Y2 <= .60 * Ymax
cond50 <- Y2 <= .50 * Ymax
cond60 <- Y2 <= .40 * Ymax
cond70 <- Y2 <= .30 * Ymax
cond80 <- Y2 <= .20 * Ymax
cond90 <- Y2 <= .10 * Ymax
cond95 <- Y2 <= .05 * Ymax
issue <- l1 == 0
if(!issue){
fittedParam <- data.frame(
name = unique(x$name),
lockdown = xlock,
d2peak = d2peak,
ldpeak = ldpeak,
maxdr = dr0,
gr11 = gr11,
rgr19 = rgr19,
rgr46 = rgr46,
T10 = if(any(cond10)) min(d2[cond10]) else NA,
T20 = if(any(cond20)) min(d2[cond20]) else NA,
T30 = if(any(cond30)) min(d2[cond30]) else NA,
T40 = if(any(cond40)) min(d2[cond40]) else NA,
T50 = if(any(cond50)) min(d2[cond50]) else NA,
T60 = if(any(cond70)) min(d2[cond60]) else NA,
T70 = if(any(cond80)) min(d2[cond70]) else NA,
T80 = if(any(cond90)) min(d2[cond80]) else NA,
T90 = if(any(cond90)) min(d2[cond90]) else NA,
T95 = if(any(cond95)) min(d2[cond95]) else NA)
return(list(fittedTrend = fittedTrend,
fittedParam = fittedParam))
}
}
}
return(list(fittedTrend = fittedTrend,
fittedParam = fittedParam))
}
}
......@@ -545,10 +622,7 @@ grplot <- function(gr, nc, asp=2/3, cex=.7, dYlim=NA, nam){
1/max(x, na.rm = T))
nr <- ceiling(length(nam) / nc)
extrg <- extendrange(range(mydata$dY, na.rm=T))
if(is.na(dYlim))
ylim <- extrg
else
ylim <- dYlim
ylim <- if(any(is.na(dYlim))) extrg else dYlim
xyplot(dY ~ dayL | name,
data = mydata, subscripts = T,
ylim = ylim,
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment