General remarks

This analysis is based on the daily updated numbers of confirmed infections provided by the European Centre for Disease Prevention and Control.

#library(XLConnect)1
#library(readxl)
#download.file(url="https://www.ecdc.europa.eu/en/publications-data/download-todays-data-geographic-distribution-worldwide-2020-06-22",destfile="data.xlsx")
#data <- read_xlsx("data.xlsx")
data <- read.csv("https://opendata.ecdc.europa.eu/covid19/casedistribution/csv", na.strings = "", fileEncoding = "UTF-8-BOM")
countries <- c("AUS","AUT","BEL","BRA","CAN","CZE","DNK","EST","CHE","FIN","FRA","DEU","HUN","ISL","IRL","ISR","ITA","JPN","NLD","NZL","NOR","POL","PRT","RUS","SVK","KOR","ESP","SWE","TUR","GBR","USA","ARG","CHL","URY","CUB","PER","MEX","ECU","ZAF","SGP","UKR","BLR","ROU","PAN","IRN","KWT","ARE","EGY","SAU","QAT","BGR","SLV","GRC","ALB","SRB","HRV","BOL","COL","ETH","IND")
data <- data[data$countryterritoryCode%in%countries,c(1:6,9:11)]
nentries <- dim(data)[1]
udates <- unique(data[,1])
ndates <- length(udates)
udates <- udates[ndates:1]
nc <- length(countries)
pop <- numeric(nc)
cases <- deaths <- matrix(0,ndates,nc)
for(i in 1:nentries){
   j <- (1:ndates)[udates==data$dateRep[i]]
   k <- (1:nc)[countries==data$countryterritoryCode[i]]
   cases[j,k] <- data$cases[i]
   deaths[j,k] <- data$deaths[i]
   pop[k] <- data$popData2019[i]/1000
}
pop[44] <- 4246.44 # data value for Panama  is wrong
cases[186,30] <- 0 #UK
cases1 <- apply(cases,2,cumsum)
rate <- sweep(cases1,2,pop,"/")[-(1:61),] # remove data before March 1
rate[rate < 1e-4] <- 1e-4
diffrate <- apply(rate,2,diff)

For modeling we use local polynomial regression as implemented in function locpoly in R package KernSmooth. We employ a Gaussian kernel with bandwidth (kernel standard deviation) 1.5 days for estimating rates and 2.5 for estimating derivatives. Polynomial orders are 1 and 2, respectiviley, to minimize boundary bias. dates are in days after March 1.

Please note that the estimated curves for small number of reported cases carry a high variability. This is especially due for early dates and states with low population (ISL, EST). Problems in the data like underreporting and reporting bias around weekends are not modeled.

Active cases

Active cases are here defined as cases that were reported within the last 14 days. This is more conservative than the rule used, e.g., by RKI (corresponding to approxi3mately the last 11 days) and was chosen to minimize effects due to a weekly cycly of reporting biases observed in the data. 1

ieurope1 <- c(2,3,9,11,12,17,19,23,27,30)
ieurope2 <- c(6,7,8,10,13,15,21,22,25,28)
ieurope3 <- c(43,51:56,14,41,42)
iworld1 <- c(1,5,16,18,20,24,26,29,31,60)
iworld2 <- c(4,32:40)
iworld3 <- c(44:50,57:59)
bw <- 1.5
dbw <- 2.5
dates <- 1:(ndates-61) # exclude info before March 1
inc <- 14
rlcurves <- dlcurves <- list(NULL)
rlylim <- dlylim <- NULL
for (i in 1:nc) {
rlcurves[[i]]<- locpoly(dates,log(pmax(1e-4,diff(c(rep(0,inc),rate[,i]),inc))),bandwidth=bw,degree=1) 
rlylim <- range(rlylim,rlcurves[[i]]$y)
dlcurves[[i]] <- locpoly(dates,log(pmax(1e-4,diff(c(rep(0,inc),rate[,i]),inc))),bandwidth=dbw,drv=1,degree=2) 
dlylim <- range(dlylim,dlcurves[[i]]$y)
}
rlylim1 <- dlylim1 <- NULL
for(i in ieurope1){
   rlylim1 <- range(rlylim1,rlcurves[[i]]$y)
   dlylim1 <- range(dlylim1,dlcurves[[i]]$y)
}
rlylim2 <- dlylim2 <- NULL
for(i in ieurope2){
   rlylim2 <- range(rlylim2,rlcurves[[i]]$y)
   dlylim2 <- range(dlylim2,dlcurves[[i]]$y)
}
rlylim2a <- dlylim2a <- NULL
for(i in ieurope3){
   rlylim2a <- range(rlylim2a,rlcurves[[i]]$y)
   dlylim2a <- range(dlylim2a,dlcurves[[i]]$y)
}
rlylim3 <- dlylim3 <- NULL
for(i in iworld1){
   rlylim3 <- range(rlylim3,rlcurves[[i]]$y)
   dlylim3 <- range(dlylim3,dlcurves[[i]]$y)
}
rlylim4 <- dlylim4 <- NULL
for(i in iworld2){
   rlylim4 <- range(rlylim4,rlcurves[[i]]$y)
   dlylim4 <- range(dlylim4,dlcurves[[i]]$y)
}
rlylim5 <- dlylim5 <- NULL
for(i in iworld3){
   rlylim5 <- range(rlylim5,rlcurves[[i]]$y)
   dlylim5 <- range(dlylim5,dlcurves[[i]]$y)
}

The left plot provides estimates of the logarithmic rate of of active cases while the right hand site displays its first derivative.

par(mfrow=c(1,2),mar=c(3,3,3,1),mgp=c(2,1,0))
plot(dates,rate[,1],ylim = rlylim1,type="n",xlab="day starting March 1",ylab="")
for(i in 1:10)
  lines(rlcurves[[ieurope1[i]]]$x,rlcurves[[ieurope1[i]]]$y,col=i,lty=1+(i-1)%/%8)
legend(1,rlylim1[2],countries[ieurope1],col=c(1:10),lty=c(1+(0:9)%/%8),lwd=rep(1,10))
title("log(Active cases per 1000 inhabitants)")

plot(dates,c(0,diffrate[,1]),ylim = dlylim1,type="n",xlab="day starting March 1",ylab="")
for(i in 1:10) lines(dlcurves[[ieurope1[i]]]$x,dlcurves[[ieurope1[i]]]$y,col=i,lty=1+(i-1)%/%8)
title("Changes log(Active cases per 1000 inhabitants)")
for(lvl in seq(-.2,.1,.05)) lines(range(dates),c(lvl,lvl),lty=3)

par(mfrow=c(1,2),mar=c(3,3,3,1),mgp=c(2,1,0))
plot(dates,rate[,1],ylim= rlylim2,type="n",xlab="day starting March 1",ylab="")
for(i in 1:10)
  lines(rlcurves[[ieurope2[i]]]$x,rlcurves[[ieurope2[i]]]$y,col=i,lty=1+(i-1)%/%8)
legend(1,rlylim2[2],countries[ieurope2],col=c(1:10),lty=c(1+(0:9)%/%8),lwd=rep(1,10))
title("log(Active cases per 1000 inhabitants)")

plot(dates,c(0,diffrate[,1]),ylim = dlylim2,type="n",xlab="day starting March 1",ylab="")
for(i in 1:10) lines(dlcurves[[ieurope2[i]]]$x,dlcurves[[ieurope2[i]]]$y,col=i,lty=1+(i-1)%/%8)
title("Changes log(Active cases per 1000 inhabitants)")
for(lvl in seq(-.2,.1,.05)) lines(range(dates),c(lvl,lvl),lty=3)

par(mfrow=c(1,2),mar=c(3,3,3,1),mgp=c(2,1,0))
plot(dates,rate[,1],ylim= rlylim2a,type="n",xlab="day starting March 1",ylab="")
for(i in 1:10)
  lines(rlcurves[[ieurope3[i]]]$x,rlcurves[[ieurope3[i]]]$y,col=i,lty=1+(i-1)%/%8)
legend(1,rlylim2a[2],countries[ieurope3],col=c(1:10),lty=c(1+(0:9)%/%8),lwd=rep(1,10))
title("log(Active cases per 1000 inhabitants)")

plot(dates,c(0,diffrate[,1]),ylim = dlylim2a,type="n",xlab="day starting March 1",ylab="")
for(i in 1:10) lines(dlcurves[[ieurope3[i]]]$x,dlcurves[[ieurope3[i]]]$y,col=i,lty=1+(i-1)%/%8)
title("Changes log(Active cases per 1000 inhabitants)")
for(lvl in seq(-.2,.1,.05)) lines(range(dates),c(lvl,lvl),lty=3)

par(mfrow=c(1,2),mar=c(3,3,3,1),mgp=c(2,1,0))
plot(dates,rate[,1],ylim = rlylim3,type="n",xlab="day starting March 1",ylab="")
for(i in 1:10)
  lines(rlcurves[[iworld1[i]]]$x,rlcurves[[iworld1[i]]]$y,col=i,lty=1+(i-1)%/%8)
legend(1,rlylim3[2],countries[iworld1],col=c(1:10),lty=c(1+(0:9)%/%8),lwd=rep(1,10))
title("log(Active cases per 1000 inhabitants)")

plot(dates,c(0,diffrate[,1]),ylim = dlylim3,type="n",xlab="day starting March 1",ylab="")
for(i in 1:10) lines(dlcurves[[iworld1[i]]]$x,dlcurves[[iworld1[i]]]$y,col=i,lty=1+(i-1)%/%8)
title("Changes log1(Active cases per 1000 inhabitants)")
for(lvl in seq(-.2,.1,.05)) lines(range(dates),c(lvl,lvl),lty=3)

par(mfrow=c(1,2),mar=c(3,3,3,1),mgp=c(2,1,0))
plot(dates,rate[,1],ylim = rlylim4,type="n",xlab="day starting March 1",ylab="")
for(i in 1:10)
  lines(rlcurves[[iworld2[i]]]$x,rlcurves[[iworld2[i]]]$y,col=i,lty=1+(i-1)%/%8)
legend(1,rlylim4[2],countries[iworld2],col=c(1:10),lty=c(1+(0:9)%/%8),lwd=rep(1,10))
title("log(Active cases per 1000 inhabitants)")

plot(dates,c(0,diffrate[,1]),ylim = dlylim4,type="n",xlab="day starting March 1",ylab="")
for(i in 1:10) lines(dlcurves[[iworld2[i]]]$x,dlcurves[[iworld2[i]]]$y,col=i,lty=1+(i-1)%/%8)
title("Changes log(Active cases per 1000 inhabitants)")
for(lvl in seq(-.2,.1,.05)) lines(range(dates),c(lvl,lvl),lty=3)

par(mfrow=c(1,2),mar=c(3,3,3,1),mgp=c(2,1,0))
plot(dates,rate[,1],ylim = rlylim5,type="n",xlab="day starting March 1",ylab="")
for(i in 1:10)
  lines(rlcurves[[iworld3[i]]]$x,rlcurves[[iworld3[i]]]$y,col=i,lty=1+(i-1)%/%8)
legend(1,rlylim5[2],countries[iworld3],col=c(1:10),lty=c(1+(0:9)%/%8),lwd=rep(1,10))
title("log(Active cases per 1000 inhabitants)")

plot(dates,c(0,diffrate[,1]),ylim = dlylim5,type="n",xlab="day starting March 1",ylab="")
for(i in 1:10) lines(dlcurves[[iworld3[i]]]$x,dlcurves[[iworld3[i]]]$y,col=i,lty=1+(i-1)%/%8)
title("Changes log(Active cases per 1000 inhabitants)")
for(lvl in seq(-.2,.1,.05)) lines(range(dates),c(lvl,lvl),lty=3)

Some derived quantities

The following figure shows quantities derived as functions of the logarithmic rate of active cases and its derivative. The latter value is closely related to R, i.e., \(R \approx exp(C*value)\) with \(C\approx 4\). Please note that what is shown is not the R reported by, e.g., the RKI and that the value provided here is calculated from a different model. Also note that the amount and criteria of testing used differ substantially between countries which makes comparisons difficult.

par(mfrow=c(1,2),mar=c(3,3,3,1),mgp=c(2,1,0))
plot(dates,rate[,1],ylim = exp(rlylim1),type="n",xlab="day starting March 1",ylab="")
for(i in 1:10)
  lines(rlcurves[[ieurope1[i]]]$x,exp(rlcurves[[ieurope1[i]]]$y),col=i,lty=1+(i-1)%/%8)
  legend(1,exp(rlylim1[2]),countries[ieurope1],col=1:10,lty=1+(0:9)%/%8,lwd=rep(1,10))
title(paste("Active cases per 1000 inhabitants",as.character(udates[ndates])))

plot(dates,c(0,diffrate[,1]),ylim = c(0.5,3),type="n",xlab="day starting March 1",ylab="")
for(i in 1:10) lines(dlcurves[[ieurope1[i]]]$x,exp(4*dlcurves[[ieurope1[i]]]$y),col=i,lty=1+(i-1)%/%8)
title("Approximate reproduction rate R")
lines(range(dates),c(1,1),lty=2,col=2)
for(lvl in seq(.5,1.2,.1)[-6]) lines(range(dates),c(lvl,lvl),lty=3)

par(mfrow=c(1,2),mar=c(3,3,3,1),mgp=c(2,1,0))
plot(dates,rate[,1],ylim = exp(rlylim2),type="n",xlab="day starting March 1",ylab="")
for(i in 1:10)
  lines(rlcurves[[ieurope2[i]]]$x,exp(rlcurves[[ieurope2[i]]]$y),col=i,lty=1+(i-1)%/%8)
  legend(1,exp(rlylim2[2]),countries[ieurope2],col=1:10,lty=1+(0:9)%/%8,lwd=rep(1,10))
title(paste("Active cases per 1000 inhabitants",as.character(udates[ndates])))

plot(dates,c(0,diffrate[,1]),ylim = c(0.4,3),type="n",xlab="day starting March 1",ylab="")
for(i in 1:10) lines(dlcurves[[ieurope2[i]]]$x,exp(4*dlcurves[[ieurope2[i]]]$y),col=i,lty=1+(i-1)%/%8)
title("Approximate reproduction rate R")
lines(range(dates),c(1,1),lty=2,col=2)
for(lvl in seq(.5,1.2,.1)[-6]) lines(range(dates),c(lvl,lvl),lty=3)

par(mfrow=c(1,2),mar=c(3,3,3,1),mgp=c(2,1,0))
plot(dates,rate[,1],ylim = exp(rlylim2a),type="n",xlab="day starting March 1",ylab="")
for(i in 1:10)
  lines(rlcurves[[ieurope3[i]]]$x,exp(rlcurves[[ieurope3[i]]]$y),col=i,lty=1+(i-1)%/%8)
  legend(1,exp(rlylim2a[2]),countries[ieurope3],col=1:10,lty=1+(0:9)%/%8,lwd=rep(1,10))
title(paste("Active cases per 1000 inhabitants",as.character(udates[ndates])))

plot(dates,c(0,diffrate[,1]),ylim = c(0.4,3),type="n",xlab="day starting March 1",ylab="")
for(i in 1:10) lines(dlcurves[[ieurope3[i]]]$x,exp(4*dlcurves[[ieurope3[i]]]$y),col=i,lty=1+(i-1)%/%8)
title("Approximate reproduction rate R")
lines(range(dates),c(1,1),lty=2,col=2)
for(lvl in seq(.5,1.2,.1)[-6]) lines(range(dates),c(lvl,lvl),lty=3)

par(mfrow=c(1,2),mar=c(3,3,3,1),mgp=c(2,1,0))
plot(dates,rate[,1],ylim = exp(rlylim3),type="n",xlab="day starting March 1",ylab="")
for(i in 1:10)
  lines(rlcurves[[iworld1[i]]]$x,exp(rlcurves[[iworld1[i]]]$y),col=i,lty=1+(i-1)%/%8)
  legend(1,exp(rlylim3[2]),countries[iworld1],col=1:10,lty=1+(0:9)%/%8,lwd=rep(1,10))
title(paste("Active cases per 1000 inhabitants",as.character(udates[ndates])))

plot(dates,c(0,diffrate[,1]),ylim = c(0.4,3),type="n",xlab="day starting March 1",ylab="")
for(i in 1:10) lines(dlcurves[[iworld1[i]]]$x,exp(4*dlcurves[[iworld1[i]]]$y),col=i,lty=1+(i-1)%/%8)
title("Approximate reproduction rate R")
lines(range(dates),c(1,1),lty=2,col=2)
for(lvl in seq(.5,1.2,.1)[-6]) lines(range(dates),c(lvl,lvl),lty=3)

par(mfrow=c(1,2),mar=c(3,3,3,1),mgp=c(2,1,0))
plot(dates,rate[,1],ylim = exp(rlylim4),type="n",xlab="day starting March 1",ylab="")
for(i in 1:10)
  lines(rlcurves[[iworld2[i]]]$x,exp(rlcurves[[iworld2[i]]]$y),col=i,lty=1+(i-1)%/%8)
  legend(1,exp(rlylim4[2]),countries[iworld2],col=1:10,lty=1+(0:9)%/%8,lwd=rep(1,10))
title(paste("Active cases per 1000 inhabitants",as.character(udates[ndates])))

plot(dates,c(0,diffrate[,1]),ylim = c(0.5,3),type="n",xlab="day starting March 1",ylab="")
for(i in 1:10) lines(dlcurves[[iworld2[i]]]$x,exp(4*dlcurves[[iworld2[i]]]$y),col=i,lty=1+(i-1)%/%8)
title("Approximate reproduction rate R")
lines(range(dates),c(1,1),lty=2,col=2)
for(lvl in seq(.5,1.2,.1)[-6]) lines(range(dates),c(lvl,lvl),lty=3)

par(mfrow=c(1,2),mar=c(3,3,3,1),mgp=c(2,1,0))
plot(dates,rate[,1],ylim = exp(rlylim5),type="n",xlab="day starting March 1",ylab="")
for(i in 1:10)
  lines(rlcurves[[iworld3[i]]]$x,exp(rlcurves[[iworld3[i]]]$y),col=i,lty=1+(i-1)%/%8)
  legend(1,exp(rlylim5[2]),countries[iworld3],col=1:10,lty=1+(0:9)%/%8,lwd=rep(1,10))
title(paste("Active cases per 1000 inhabitants",as.character(udates[ndates])))

plot(dates,c(0,diffrate[,1]),ylim = c(0.5,3),type="n",xlab="day starting March 1",ylab="")
for(i in 1:10) lines(dlcurves[[iworld3[i]]]$x,exp(4*dlcurves[[iworld3[i]]]$y),col=i,lty=1+(i-1)%/%8)
title("Approximate reproduction rate R")
lines(range(dates),c(1,1),lty=2,col=2)
for(lvl in seq(.5,1.2,.1)[-6]) lines(range(dates),c(lvl,lvl),lty=3)

The following figure illustrates the current status. Countries that occur on the right side currently have a high infection load. Note that the estimated reproduction rate is highly variable for small (by population) states dispayed in the left. For vountries in the upper in the upper right we observe a very dynamic and deteriorating situation.

arate <- arepr  <- numeric(nc)
larate <- larepr <- matrix(0,7,nc)
lweek <- trunc(401/ndates*((ndates-7):(ndates-1)))

for(i in 1:60) {
   arate[i] <- exp(rlcurves[[i]]$y[401])
   larate[,i] <- exp(rlcurves[[i]]$y[lweek])
   arepr[i] <- exp(4*dlcurves[[i]]$y[401])
   larepr[,i] <- exp(4*dlcurves[[i]]$y[lweek])
}
par(mfrow=c(1,1),mar=c(3,3,3,.1),mgp=c(2,1,0))
ylim <- pmax(.5,range(arepr))
plot(arate,arepr,col=rep(1:6,10)[1:60], ylim = ylim, xlab="Active cases per 1000 inhabitants", 
                        ylab="Approximate reproduction rate", log="xy")
for(i in 1:60){
  lines(c(larate[,i],arate[i]),c(larepr[,i],arepr[i]),col=rep(1:6,10)[i])
  text(arate[i],arepr[i],countries[i],pos=3,col=rep(1:6,10)[i])
}
title(paste("Situation on",as.character(udates[ndates])))

Circles illustrate the current situation with coordinates given by (smoothed) infections over the last 2 weeks (x-axis) and estimated reproduction number (y-axis). Lines follow the situation over the last week. Note that the x-axis is on a log scale.