2026 marks a new year and with it the time and opportunity to re-visit my personal website. I have been using some version of R Markdown for quite some time now. Initially, I started with the vanilla R Markdown website in 2017 or thereabouts and it worked very well with limited blogging functionality. From there I went to the first initiation of distill, then known as "radix". Radix worked well and had much of the early functionality that Distill made more robust. Yes, there were some limitations (e.g., the search feature didn't exist) but the ideas were certainly there.

While mostly seamless, there were some hiccups but nothing serious. Then I moved to the quarto generator from R Markdown. This was not without some issues, mainly that I didn't do a great job at ensuring that old blog posts were 100% reproducible and future proof. A lot of what I wrote about in the early days was about new packages that I had come across or early ideas. Obviously as time went by not all of these tools were maintained so when I went to render everything, quarto choked on me.

This problem with backwards compatibility only increased with time. As my log of blog posts both grew and became dated (or integrated more Bayesian workflows that took a long time to run and built a cache that I couldn't continue to host on the shrinking storage space on my old computer), quarto failed more often. Once those failures happen enough, you start to look for alternatives and do things different.

New Approaches

I realised that I needed something a little lighter than a full quarto blog going forward. There were some initial forays into simpler websites (including this php generated blog fed by markdown documents) that didn't go too far. Last year, I started in earnest looking at a custom Rust generated blog. I liked the idea of having something custom with limited features that was static-ish. Constant development and addition of features is fantastic if they are backwards compatible, but that's not often the case with software that isn't your own (and especially build for a public looking for new innovations). That idea led to this website iteration which is based on arne's work. The look isn't quite what I wanted, but it gave me some ideas for really nice features like fully text search powered by sqllite, a mixture of md, jmd (julia), and R Markdown. It also helped me formalise a strategy to try and keep each blog post relatively self-contained and render to an index.md to ensure that they would be renderable.

Rather than continue to iterate in 2026, I just started with a few Claude agents and vibe-coded this new blog together. It took several days and some manual tweaks, but I really like it. It provides much of the major functionality that I want and should be fairly stable while accepted a variety of inputs. We'll see how far this goes and I will continue to work through re-directs. What this has taught me is that you can build some pretty slick products with AI, but the power comes in knowing what you want (e.g., I know enough Rust, a good bit of html, css, javascript, etc) and being able to communicate implementations to make something. Not knowing how these things work and using the AI resources can be fraught because you can't figure out where things go wrong and what the approaches are to fix them. Maybe this won't matter as much, much these tools are like expensive powertools--if you don't know how to use a table saw you can cut your arm off, but in the hands of a craftsman you can make a nice table.

Cheer's to 2026.

@online{dewitt2026,
  author = {Michael E. DeWitt},
  title = {A New Rust HTML Site Generator},
  date = {2026-01-08},
  url = {https://michaeldewittjr.com/blog/2026-01-08-a-new-rust-html-site-generator/},
  langid = {en}
}
Copy

using Pkg
Pkg.activate(".")
using LinearAlgebra

A = [1 2; 3 4]

2×2 Matrix{Int64}:
 1  2
 3  4

eigen(A)

LinearAlgebra.Eigen{Float64, Float64, Matrix{Float64}, Vector{Float64}}
values:
2-element Vector{Float64}:
 -0.3722813232690143
  5.372281323269014
vectors:
2×2 Matrix{Float64}:
 -0.824565  -0.415974
  0.565767  -0.909377

@online{dewitt2026,
  author = {Michael E. DeWitt},
  title = {Testing Julia},
  date = {2026-01-04},
  url = {https://michaeldewittjr.com/blog/2026-01-04-testing-julia/},
  langid = {en}
}
Copy

My website is a window into my programming journey. I started my website around 2016/2017 time frame when I was getting to be a fairly competent programmer and wanted to branch out into having a more public presence. This was aided by leaving a private company where everything I did was considered proprietary and confidential.

@online{dewitt2024,
  author = {Michael E. DeWitt},
  title = {A Rust-based, custom static site generator},
  date = {2024-01-14},
  url = {https://michaeldewittjr.com/blog/2024-01-14-custom-static-site-generators/},
  langid = {en}
}
Copy

First we can load some julia packages:

using Plots
using Distributions
2+2

4

The we can use them:

mydist = Normal(10,1)
plot(rand(mydist, 1000))

@online{dewitt2024,
  author = {Michael E. DeWitt},
  title = {Testing Julia Weave with the Rust Blog},
  date = {2024-01-09},
  url = {https://michaeldewittjr.com/blog/2024-01-09-testing-julia-weave-with-the-rust-blog/},
  langid = {en}
}
Copy

Will this work?

Some R

hist(rnorm(1000), breaks = 30, main = "A histogram!")

We’ll try a different bit of code here:

plot(ecdf(rnorm(1000)))

Let’s try LaTeX

$$\Sigma_{n=i}^{\infty}$$

DeWitt (2020)

References

References

@online{dewitt2024,
  author = {Michael E. DeWitt},
  title = {Testing the use of quarto to generate markdown},
  date = {2024-01-03},
  url = {https://michaeldewittjr.com/blog/2024-01-03-testing-the-use-of-quarto-to-generate-markdown/},
  langid = {en}
}
Copy

function sir_ode!(du,u,p,t)
    (S,I,R,C) = u
    (β,c,γ, δ) = p
    N = S+I+R
    infection = β*c*I*S/N
    recovery = γ*I
    wane = δ * R
    @inbounds begin
        du[1] = -infection + wane
        du[2] = infection - recovery
        du[3] = recovery - wane
        du[4] = infection 
    end
    nothing
end;


tmax = 365.0
tspan = (0.0,tmax)
obstimes = 1.0:1.0:tmax
u0 = [5990.0,10.0,0.0,0.0] # S,I.R,C
p = [0.05,10.0,0.20, 1.0/180]; # β, c, γ, δ


prob_ode = ODEProblem(sir_ode!,u0,tspan,p);


sol_ode = solve(prob_ode,
            Tsit5(),
            saveat = 1.0);

@model bayes_sir(y) = begin
  # Calculate number of timepoints
  l = length(y)
  i₀  ~ Uniform(0.0,.2)
  β ~ Uniform(0, .1)
  immunity ~ Uniform(90,365)

  I = i₀*6000.0
  u0=[6000.0-I,I,0.0,0.0]
  p=[β,10.0,0.2, 1.0/immunity]
  tspan = (0.0,float(l))
  prob = ODEProblem(sir_ode!,
          u0,
          tspan,
          p)
  sol = solve(prob,
              Tsit5(),
              saveat = 1.0)
  sol_C = Array(sol)[4,:] # Cumulative cases
  sol_X = sol_C[2:end] - sol_C[1:(end-1)]
  l = length(y)
  for i in 1:l
    y[i] ~ Poisson(ifelse(sol_X[i] <0 , 1e-6, sol_X[i] ))
  end
end;

mod = bayes_sir(Y[1:200]);

ode_nuts = sample(mod, NUTS(0.65),10000);

const temperature_steps = 4
using MCMCTempering
sampler2 = NUTS()
tempered_sampler = tempered(sampler2, temperature_steps)

chain = sample(mod, tempered_sampler, n_samples; discard_initial = n_adapts)

@online{dewitt2022,
  author = {Michael E. DeWitt},
  title = {Parallel Tempering in Julia},
  date = {2022-08-28},
  url = {https://michaeldewittjr.com/blog/2022-08-28-parallel-tempering-in-julia/},
  langid = {en}
}
Copy

A = [0  .0043 .1132 0;
.9775 0.9111  0 0;
0 0.0736  0.9534 0;
 0 0 .0452  0.9804]

eA = eigen(A)
λ = maximum(eigvals(A))
w = eigvecs(A)[:,end]/sum(eigvecs(A)[:,end])

@online{dewitt2022,
  author = {Michael E. DeWitt},
  title = {Matrix Algebra with Julia},
  date = {2022-08-15},
  url = {https://michaeldewittjr.com/blog/2022-08-15-matrix-algebra-with-julia/},
  langid = {en}
}
Copy

This post is exploring the use of Julia, Turing, and ODEs and largely expands on the work from Simon Frost's awesome epirecipes.

Getting Started with Julia

Julia as a statistical programming language/environment has some really neat properties.

:::{.column-margin} Speed, generally speed. :::

Turing also has some neat elements when it comes to probabilistic computing/programming. The key feature that interests me is the ability to switch between sampling approaches (e.g., Gibbs, Hamiltonian Monte Carlo, no u-turn sampling, sequential) while keeping the same syntax and model structure. While I absolutely love Stan and have spent many hours learning and the syntax (and it is actively developed, highly optimized, etc), I sometimes wish I could explore other sampling approaches due to strange posteriors (especially when it comes to times when SMC might be better).

The Approach

This is a pretty vanilla post, in which we will first create some fake data from a known distribution and then fit said data. As always, we will bring in the required packages.

using DifferentialEquations
using Random
using Distributions
using Turing
using DataFrames
using StatsPlots

Now we can generate a simple three compartment model, with S (susceptibles), I, (infected), and R (recovered).

Additionally:

• On average 10 contacts are made per day
• The contact rate is 0.05 (probability of passing infection to any given contact)
• Those who are infected recover on average every 5 days
• Immunity lasts for a 180 days on average before people become susceptible again
• Population size of 6,000 individuals
• Standard mass-action approach

Something that looks like the following:

using Luxor
using MathTeXEngine

Drawing(200, 200, "sirs.png")
origin()
setline(10)
Luxor.arrow(Point(-40,0),Point(0,0))
Luxor.arrow(Point(-0,0),Point(40,0))
fontsize(15)
Luxor.text(L"S",Point(-40,20), halign = :center)

Luxor.text(L"I",Point(0,20), halign = :center)
Luxor.text(L"R",Point(40,20), halign = :center)
fontsize(12)
Luxor.text(L"β*c",Point(-20,10), halign = :center)
Luxor.text(L"γ",Point(20,10), halign = :center)
Luxor.text(L"δ",Point(0,-15), halign = :center)

loopx = 30
loopy = 40
adjx = 6
adjy = -2
Luxor.arrow(
    Point(40,0) + Point(-adjx,adjy),
    Point(40,0) + Point(-loopx,-loopy),
    Point(-40,0)+ Point(loopx,-loopy),
    Point(-40,0)+Point(adjx,adjy)
)
finish()

function sir_ode!(du,u,p,t)
    (S,I,R,C) = u
    (β,c,γ, δ) = p
    N = S+I+R
    infection = β*c*I*S/N
    recovery = γ*I
    wane = δ * R
    @inbounds begin
        du[1] = -infection + wane
        du[2] = infection - recovery
        du[3] = recovery - wane
        du[4] = infection 
    end
    nothing
end;


tmax = 365.0
tspan = (0.0,tmax)
obstimes = 1.0:1.0:tmax
u0 = [5990.0,10.0,0.0,0.0] # S,I.R,C
p = [0.05,10.0,0.20, 1.0/180]; # β, c, γ, δ


prob_ode = ODEProblem(sir_ode!,u0,tspan,p);


sol_ode = solve(prob_ode,
            Tsit5(),
            saveat = 1.0);

We can then visualize our expected cases:

C = Array(sol_ode)[4,:] # Cumulative cases
X = C[2:end] - C[1:(end-1)];


Random.seed!(1234)
Y = rand.(Poisson.(X));


bar(obstimes,Y,legend=false)
plot!(obstimes,X,legend=false)

Note the second wave of cases occuring as immunity begins to wane.

Solve Using Turing

Now we build our model in Turing, using our prior defined ODE. Note that I included a check on the ODE output to try and catch values less than one, otherwise the sampler would reject the solution (because Poisson distributions cannot have a rate parameters less than 0).

@model bayes_sir(y) = begin
  # Calculate number of timepoints
  l = length(y)
  i₀  ~ Uniform(0.0,.2)
  β ~ Uniform(0, .1)
  immunity ~ Uniform(90,365)

  I = i₀*6000.0
  u0=[6000.0-I,I,0.0,0.0]
  p=[β,10.0,0.2, 1.0/immunity]
  tspan = (0.0,float(l))
  prob = ODEProblem(sir_ode!,
          u0,
          tspan,
          p)
  sol = solve(prob,
              Tsit5(),
              saveat = 1.0)
  sol_C = Array(sol)[4,:] # Cumulative cases
  sol_X = sol_C[2:end] - sol_C[1:(end-1)]
  l = length(y)
  for i in 1:l
    y[i] ~ Poisson(ifelse(sol_X[i] <0 , 1e-6, sol_X[i] ))
  end
end;

mod = bayes_sir(Y[1:200]);

ode_nuts = sample(mod, NUTS(0.65),10000);

describe(ode_nuts)

Now let's see if we were able to recover our parameters:

plot(ode_nuts)
posterior = DataFrame(ode_nuts);
beta_hat = mean(posterior[!,:β])
immunity_hat = mean(posterior[!, :immunity])
println("Estimate for  β: ", beta_hat)
println("Estimate for immunity duration: ", immunity_hat)
println("Estimate for initial proportion infected: ", mean(posterior[!, :i₀]))

Not too bad! Now we can simulate the dynamics going forward:

function predict(y,chain)
    # Length of data
    l = length(y)
    # Length of chain
    m = length(chain)
    # Choose random
    idx = sample(1:m)
    i₀ = chain[:i₀][idx]
    β = chain[:β][idx]
    immunity = chain[:immunity][idx]
    I = i₀*6000.0
    u0=[6000.0-I,I,0.0,0.0]
    p=[β,10.0,0.2, 1.0/immunity]
    tspan = (0.0,float(l))
    prob = ODEProblem(sir_ode!,
            u0,
            tspan,
            p)
    sol = solve(prob,
                Tsit5(),
                saveat = 1.0)
    out = Array(sol)
    sol_X = [0.0; out[4,2:end] - out[4,1:(end-1)]]
    hcat(sol_ode.t,out',sol_X)
end;


Xp = []
for i in 1:365
    pred = predict(Y,ode_nuts)
    push!(Xp,pred[2:end,6])
end


scatter(obstimes,Y,legend=false, ylims = [0,600])
plot!(obstimes,Xp,legend=false, color = "grey50", alpha = .2)

Conclusions

This shows a very intuitive approach towards compartmental modeling in a Bayesian framework using Julia.

@online{dewitt2022,
  author = {Michael E. DeWitt},
  title = {Turing and ODEs},
  date = {2022-08-13},
  url = {https://michaeldewittjr.com/blog/2022-08-13-turing-and-odes/},
  langid = {en}
}
Copy

This is just a short blurb to mention the r3dmol package which allows users to render the 3D representation of pdb files of different biological structures.

Example with Neisseria gonorrhoeae

I am interested in generating some of the structures of Neisseria gonorrhoeae, the pathogen responsible for the sexually transmitted infection, gonorrhea. I can go over to the protein data bank and do a search and find some of the available structures.

ng_pdb <- "https://files.rcsb.org/download/4R1I.pdb"

download.file(ng_pdb, destfile = "4R1I.pdb")

ng_pdb <- readLines("4R1I.pdb")

Now for the magical part:

library("r3dmol")
m1 <- r3dmol(                         # Set up the initial viewer
  viewer_spec = m_viewer_spec(
    cartoonQuality = 10,
    lowerZoomLimit = 50,
    upperZoomLimit = 350
  )
) %>%
  m_add_model(                  # Add model to scene
    data = ng_pdb,
    format = "pdb"
  ) %>%
  m_zoom_to() %>%               # Zoom to encompass the whole scene
  m_set_style(                  # Set style of structures
    style = m_style_cartoon(
      color = "#00cc96"
    )
  )%>%
  m_set_style(                  # Set style of specific selection
    sel = m_sel(ss = "s"),      # (selecting by secondary)
    style = m_style_cartoon(
      color = "#636efa",
      arrows = TRUE
    )
  ) %>%
  m_set_style(                  # Style the alpha helix
    sel = m_sel(ss = "h"),      # (selecting by alpha helix)
    style = m_style_cartoon(
      color = "#ff7f0e"
    )
  ) %>%
  m_rotate(                     # Rotate the scene by given angle on given axis
    angle = 90,
    axis = "y"
  ) %>%
  m_spin()   

m1

It’s that easy! Now if you want to represent the structure with the ball and stick representation, you can do so:

m1 %>% 
 m_set_style(style = m_style_stick()) 

@online{dewitt2022,
  author = {Michael E. DeWitt},
  title = {3D Structural Biology},
  date = {2022-07-04},
  url = {https://michaeldewittjr.com/blog/2022-07-04-3d-structural-biology/},
  langid = {en}
}
Copy

The EPA recently issued updated guidance on acceptable levels of two so-called forever chemicals in the drinking water Perfluorooctanoic acid (PFOA) and perfluorinated alkylated substances (PFAS). These substances are used in non-stick applications and have become pervasive in every day life. Unfortunately, these substances are extraordinarily stable and don’t easy degrade in nature, are not captured by waste-water processing, and have been found for years in human serum. The EPA has been slowly lowering the acceptable levels in drinking water as the science evolves. As is the case with many long-term environment studies it takes a long time to gather observational data (with unknown effect sizes), but unsurprising to anyone they have found that even a little of these chemicals could have negative effects on human health.

So where are we?

By law, municipalities are supposed to post their drinking water composition so that the public knows what they are putting into their body. A hallmark of a developed society is having safe drinking water. One of the easiest to get to websites is the drinking water page for Greensboro, NC. Unfortunately for Greensboro, some industry friends have not been friends of the public and have been known to dump forever chemicals. We can use the standard tooling to pull down and visualize these data.

library(tidyverse)
library(rvest)
theme_set(cowplot::theme_cowplot())

First, I’ll denote my website and use the awesome html_table feature to extract the tables on the website. I’ll be left with two tables representing the two treatment facilities that service Greensboro,NC.

url <- 'greensboro-nc.gov/departments/water-resources/water-system/pfos-pfoa-updates/pfos-pfoa-sample-results'

ses <- session(url = url)

ses_tabs <- html_table(ses)

names(ses_tabs) <- c("Lake Brandt Raw Water - Mitchell Water Treatment Plant Source",
                     "Mitchell Water Treatment Plant Point of Entry")

ses_tabs <- lapply(ses_tabs, function(x) {
  setNames(x, c("date", "substance", "result", "unit"))}
  )

Now we can examine those tables and see that in the second table we captured some headers that need not be there. We can zip those away and the format and bind these tables.

str(ses_tabs)

List of 2
 $ Lake Brandt Raw Water - Mitchell Water Treatment Plant Source: tibble [44 × 4] (S3: tbl_df/tbl/data.frame)

$ ..$ date : chr [1:44] "11/29/23" "11/29/23" "11/7/23" "11/7/23" ... $ ..$ substance: chr [1:44] "Perfluorooctanesulfonic acid (PFOS)" "Perfluorooctanoic acid (PFOA)" "Perfluorooctanesulfonic acid (PFOS)" "Perfluorooctanoic acid (PFOA)" ... $ ..$ result : num [1:44] 39 5.3 83 7.8 5.8 37 5.2 32 35 5.5 ... $ ..$ unit : chr [1:44] "n/gL (ppt)" "n/gL (ppt)" "n/gL (ppt)" "n/gL (ppt)" ... $ $ Mitchell Water Treatment Plant Point of Entry : tibble [45 × 4] (S3: tbl_df/tbl/data.frame) $ ..$ date : chr [1:45] "Date sample\n taken" "11/29/23" "11/29/23" "11/7/23" ... $ ..$ substance: chr [1:45] "" "Perfluorooctanesulfonic acid (PFOS)" "Perfluorooctanoic acid (PFOA)" "Perfluorooctanesulfonic acid (PFOS)" ... $ ..$ result : chr [1:45] "Result" "34" "4.7" "39" ... $ ..$ unit : chr [1:45] "Unit" "ng/L (ppt)" "ng/L (ppt)" "ng/L (ppt)" ... $ Now we bind and format with map call and a function to coerce the columns to the correct type.

ses_tabs[[2]] <- ses_tabs[[2]][-1,]

ses_tabs <- map(ses_tabs, function(x){
  x %>% 
    mutate(date = lubridate::mdy(date),
           result = as.numeric(result),
           unit = as.character(unit))
})

ses_tabs <- bind_rows(ses_tabs, .id = "source")

head(ses_tabs %>% 
       select(date,substance,result))

# A tibble: 6 × 3
  date       substance                           result
  <date>     <chr>                                <dbl>
1 2023-11-29 Perfluorooctanesulfonic acid (PFOS)   39  
2 2023-11-29 Perfluorooctanoic acid (PFOA)          5.3
3 2023-11-07 Perfluorooctanesulfonic acid (PFOS)   83  
4 2023-11-07 Perfluorooctanoic acid (PFOA)          7.8
5 2023-10-24 Perfluorooctanesulfonic acid (PFOS)    5.8
6 2023-10-24 Perfluorooctanoic acid (PFOA)         37  

Note that they say that a nanogram per Liter (ng/L) is equivalent to a part per trillion (ppt) which is a standard unit for acceptable contamination levels.

Let’s see what we’re drinking

We can start with a simple graph of these two chemicals over time.

ses_tabs$compound <- with(ses_tabs, stringr::str_extract(string = substance, "PFOA|PFOS"))
$ses_tabs$wwtp <- with(ses_tabs, stringr::str_extract(string = source, "Lake Brandt|Mitchell"))
$
fig1 <- ses_tabs %>% 
  ggplot(aes(date, result, color = wwtp))+
  geom_line()+
  theme(legend.position = "bottom")+
  facet_wrap(~compound)+
  labs(
    title = 'Forever Chemical Concentrations in Greensboro, NC',
    y = "parts per trillion",
    x = NULL)+
  scale_x_date(date_labels = "%b %Y")+
  MetBrewer::scale_color_met_d("Demuth")

fig1

Now the critical point is are these ok? According to the EPA again, the new limits are:

I don’t need to draw any lines on the graph to saw that we are likely exceeding those limits with a high confidence.

Where it going?

Unfortunately, we don’t have a done of historical data upon which to build a model. The last two years of data are not available and earlier years are locked into pdfs. Regardless, we can fit a trend line.

dat_ts <- ses_tabs %>% 
  filter(compound=="PFOS" & wwtp == "Mitchell") %>% 
  group_by(date) %>% 
  filter(result == max(result)) %>% 
  ungroup()

dat_ts %>% 
  ggplot(aes(date, result))+
  geom_point()+
  geom_smooth(method = "lm")+
  labs(
    title = "PFOS Concentration at the Mitchell WWTP",
    y = "ppt",
    x = NULL,
    subtitle = "Linear Trend"
  )+
  geom_hline(yintercept = 0.02, col = "red", lty =2)

Only have seven irregularly spaced data points makes this trend line a stretch. Additionally, we don’t have a good sense of the measurement error or the effect of seasonality on these measures, so it is tough to say what the trend i, but the major conclusion is that the concentration is well above the recommendation.

@online{dewitt2022,
  author = {Michael E. DeWitt},
  title = {Forever Chemicals in the Water},
  date = {2022-07-03},
  url = {https://michaeldewittjr.com/blog/2022-07-03-forever-chemicals-in-the-water/},
  langid = {en}
}
Copy

tl;dr; porting to Quarto was not terrible. Also moving from GitHub pages to Netlify at the same time was a bit much.

I finally made the jump to Quarto. I had been following the project and using it for several different projects here, here, amongst some private personal projects. The primary driver for the website change was that some posts failed to build under distill and I couldn’t seem to render any new blog posts due to issues with building the listing. I like Quarto in general and find that the outputs are extremely stable (less issues with $\LaTeX$, Microsoft Word) and the defaults are nice for books.

There have been better and more detailed posts about each of these steps both here and Danielle Navarro’s awesome tutorial. Those links are much more comphrensive than anything that I would write, but I’ll give some broadstrokes.

Some More Background on Blogging

My first real blogging platform¹ was radix, an early iteration on what would become distill. I absolutely loved radix and had a nice simple stand-alone blog site in addition to my Rmarkdown built github pages home site. Radix eventually became distill and was no longer under development, so I made the transition. This was pretty seamless as I just imported old websites where possible or changed extensions. Quarto would be a new test.

A reproducibility test

Moving to quarto I copied to folder structure I had for my distill website. I decided that I would go ahead and rename all my source rmd files to qmd and then render then a-new with Quarto. Well, I learned that you likely need to use renv to manage your package versions. I had over 60 different posts starting in 2018. Syntax had changed, some packages weren’t available, etc. All and all there weren’t a ton of failures, but enough that I know I really need to adopt a strategy to maintain versions on blog posts. Note that quarto had the _freeze: true argument that can be set in order to render only on change, but this doesn’t future-proof yourself.

Now to Netlifly

I have been using github pages for a long time. They offer so much ease of use when it comes to spitting out a website, but I wanted to get away from google analytics and have a little more control over hosting (and Netlifly has some cool options with forms and secured pages). I followed the guidance from the quarto docs as well as some other resources on the web to set-up my site and move my github pages site. On the github site, the meant removing the CNAME file and removing custom domains from the username.github.io repo.

Redirect City

Having four years of Github pages on the internet definitely has provided some challenges in making sure old links work. Use the _redirect file liberally, I used the guidance here to redirect some of my old github pages from my personal website to the github pages versions. It seems to work, but I am still getting some 404s on occasion.

Additionally, because I had multiple versions of my blog still floating (radix, distill) dumped redirects at the index of these old websites to make sure everything landed at the right location (just an example):

<!DOCTYPE html>
<meta charset="utf-8">
<title>Redirecting to https://michaeldewittjr.com/index.html</title>
<meta http-equiv="refresh" content="0; URL=https://michaeldewittjr.com/index.html/">
<link rel="canonical" href="https://michaeldewittjr.com/">

So far

So far so good, but time will tell. I still need to learn the renv magic at the post level to make sure that another port will go smoothly.

@online{dewitt2022,
  author = {Michael E. DeWitt},
  title = {Moving to quarto},
  date = {2022-06-05},
  url = {https://michaeldewittjr.com/blog/2022-06-05-moving-to-quarto/},
  langid = {en}
}
Copy

It would appear that once the independent review board looked at the initial data they balked and are now holding off until the results of the April submission.

Only a Bayesian Can Save Us Now

This post really was stirred by Lucy D’Agostino McGowan’s twitter post as shown below. Bayesian analysis allows us to include prior information. It would seem that a clinical trial in the midst of:

• Massive vaccinations across the world
• Continuous evaluation of vaccine efficiency (a la the United Kingdom amongst others)
• New variants which are antigenically different that the lineages on which the vaccines were based

…should take advantage of Bayesian data analysis.

Reviving a Prior Analysis

I am going to take code from a prior blogpost where Bayesian analysis was used to look at Paxlovid, another Pfizer product.

First we visualize our data using the approximations that Dr McGowan gave us:

library(cmdstanr)
library(tidybayes)
library(posterior)
library(ggplot2)
library(dplyr)
library(ggdist)
theme_set(theme_bw())
dat_trials <- tibble::tribble(
  ~"cases", ~"arm_n", ~"arm",
  23, 1552, "treatment",
  27, 776, "control"

) %>%
  mutate(prop = cases/arm_n)


dat_trials %>%
  ggplot(aes(arm, prop))+
  geom_point()+
  scale_y_continuous(labels = scales::percent)+
  labs(
    title = "Percent of Arm Cases",
    y = "Percent",
    x = NULL
  )

We can also calculate the frequentist confidence intervals:¹

ARV <- 23/1552; ARU <- 27/776

RR <- ARV/ARU

(VE <- 1 - RR)

[1] 0.5740741

bounds <- data.frame(upper = exp(log(RR) + 1.96 * sqrt((1-ARV)/23 +(1-ARU)/27)),
lower = exp(log(RR) - 1.96 * sqrt((1-ARV)/23 +(1-ARU)/27)),
VE = VE) %>% 
    select(VE, lower, upper)

bounds %>% 
    knitr::kable(digits = 2)

Yikes, so based on these frequentist statistics, the Pfizer vaccine fails.

Enter Bayes

Pfizer initially used Bayesian data analysis on their original submission for the 18 and older vaccine. I think it would be worthwhile to re-examine these data under similar priors and see what our results indicate. First we can recycle our previous trial code which considers our prior on the relative risk as well as calculates the net effect.

writeLines(readLines("trial.stan"))

//based on https://www.robertkubinec.com/post/vaccinepval/
// Which is based on https://rpubs.com/ericnovik/692460
data {
  int<lower=1> r_c; // num events, control
  int<lower=1> r_t; // num events, treatment
  int<lower=1> n_c; // num cases, control
  int<lower=1> n_t; // num cases, treatment
  array[2] real a;   // prior values for treatment effect

}
parameters {
  real<lower=0, upper=1> p_c; // binomial p for control
  real<lower=0, upper=1> p_t; // binomial p for treatment
}
transformed parameters {
  real RR  = 1 - p_t / p_c;  // Relative effectiveness
}
model {
  (RR - 1)/(RR - 2) ~ beta(a[1], a[2]); // prior for treatment effect
  r_c ~ binomial(n_c, p_c); // likelihood for control
  r_t ~ binomial(n_t, p_t); // likelihood for treatment
}
generated quantities {
  real effect   = p_t - p_c;      // treatment effect
  real log_odds = log(p_t / (1 - p_t)) - log(p_c / (1 - p_c));
}

Exploring Priors

Pfizer initially used some pretty weak, pessimistic priors. The bulk of the distribution is < 0.2, which would indicate that the vaccine is not effective. We can start with these and see what happens.

curve(dbeta(x, shape1 = .700102, shape2 = 1), 
      from = 0, to = 1, 
      ylab = "Density", xlab = "Relative Risk Reduction",
      main = "Prior Distribution", adj = 0)

It is also interesting to look numerically where the bulk of the distribution lies (which in this case is very wide):

qbeta(p = c(.05,.95), .700102, 1)

[1] 0.01385659 0.92935409

Let’s fit the model:

mod <- cmdstan_model(file.path("trial.stan"))

dat <- list(
  n=sum(dat_trials$arm_n),
$       r_c=dat_trials[2,]$cases,
$       r_t=dat_trials[1,]$cases,
$       n_c=dat_trials[2,]$arm_n,
$       n_t=dat_trials[1,]$arm_n,
$       a=c(.700102,1)
)
fit <- mod$sample(dat, refresh = 0)
$```

    Running MCMC with 4 sequential chains...

    Chain 1 finished in 0.0 seconds.
    Chain 2 finished in 0.0 seconds.
    Chain 3 finished in 0.0 seconds.
    Chain 4 finished in 0.0 seconds.

    All 4 chains finished successfully.
    Mean chain execution time: 0.0 seconds.
    Total execution time: 0.6 seconds.

I’m going to write a quick helper function for summarising results from
the fitted model.

``` r
pull_cis <- function(x){
    x$draws(variables = "RR") %>%
$    as_draws_df() %>% 
    summarise(mean = mean(RR),
                        median = median(RR),
                        q025 = quantile(RR, 0.025),
                        q975 = quantile(RR, 0.975)) %>% 
    mutate(variable = "RR") %>% 
    select(variable, mean, median, contains("q")) %>% 
    knitr::kable(digits = 2)
}

Using these initial priors we get the following results:

pull_cis(fit)

These don’t look too bad! The 95% credible intervals are similar, though a nudge higher, than the frequentist confidence intervals

Let’s see if we hit the lower endpoint of 30% risk reductions (and really what fraction of the draws are greater than 30%).

draws <- fit$draws(variables = "RR") %>% 
$    as_draws_df()
mean(as.numeric(draws$RR>.3))
$```

    [1] 0.96775

So that’s a bit interesting in that there is a 96.8% posterior
probability that the vaccine efficiency is greater than 30% (which is
the lower limit of approval). Additionally, there is a 74% posterior
probability given these data that the vaccine efficiency (relative risk
reduction) is greater than 50%

We can graph these results to display the same information visually.

``` r
draws %>%
  #median_qi(VE, .width = c(.5, .89, .995)) %>%
  ggplot(aes(y = "RR", x = RR)) +
  stat_halfeye()+
  scale_color_brewer()+
  coord_cartesian(expand = FALSE)+
  labs(
    title = "Posterior Distribution of Relative Risk Reduction",
    subtitle = "Pfizer BNT162B2 for Under 5 Years Old"
  )

So What?

One key point is that these raw data are inferred from the reporting that there were around 50 cases so these are crude approximations. Regardless this analysis shows that we shouldn’t throw the proverbial baby out with the bathwater. This looks like a vaccine that would meet the endpoints and is showing expected effectiveness given the changing terrain of the pandemic. Of course there are other competing concerns out there–like if a booster is needed would this EUA interrupt that process? Would an EUA cause people to doubt the process (honestly the FDA messed this one up going back and forth with Pfizer on this)? Are there data that have yet to be made public (e.g., faster nAbs waning)? Regardless, this analysis shows that being a Bayesian in these contexts is likely warranted.

Note: Edited 2022-02-12 for typos (per paragraph 1)…

Note2: Moved Bayesian credible intervals to 95% to be consistent with frequentist 95% CIs- Thanks @statstaci5.

Note3: Correct hospitalizations to cases. I have hospitalizations on the brain most of the time. Thanks @LucyStats!

I really need to open up this github repo for this reason but alas….

@online{dewitt2022,
  author = {Michael E. DeWitt},
  title = {Pfizer BNT162b2 for Under 5s},
  date = {2022-02-11},
  url = {https://michaeldewittjr.com/blog/2022-02-11-pfizer-bnt162b2-for-under-5s/},
  langid = {en}
}
Copy

The Centers for Disease Control and Prevention updated their COVID-19 guidelines for isolation and quarantine^[Remember, isolate if you are positive, quarantine if you are a contact.] on December 27, 2021 and received some strong backlash. The updates were certainly needed as the prior guidelines were last updated in December 2020 or so when a vaccine was not available and there were many additional unknowns. In the meantime the United States is in the midst of a Delta wave of infections and growing presence of the Omicron variant, the latter appearing to be more fit and better at escaping vaccine or infection derived immunity. This means that many people are in quarantine and isolation at all levels which is causing issues to basic services (e.g., hospitals down critical staff, flights canceled due to crews in quarantine/isolation, day care centers, schools, other commerce activities, end even college football bowl games). While generally there is agreement that the guidelines needed to be updated based on availability of vaccines and boosters, there is some disagreement on the language and the lack of a testing component.

The key phrase that is causing consternation is below:

The change is motivated by science demonstrating that the majority of SARS-CoV-2 transmission occurs early in the course of illness, generally in the 1-2 days prior to onset of symptoms and the 2-3 days after. Therefore, people who test positive should isolate for 5 days and, if asymptomatic at that time, they may leave isolation if they can continue to mask for 5 days to minimize the risk of infecting others. --full text available here

What you might notice in that sentence is that there are no links to the "science." The United Kingdom Health Security Agency (UKHSA) puts out 40+ pages of technical reports and easy to read threat matrices each week. This is in addition to a beautiful website with a clean and well functioning and documented API to pull the data. While the structure is different in the United States (e.g., no national health service), a few sources linked to the "science" would have been helpful. Just mentioning "the facts and the science" is not super helpful and this appeal to the unknown "research" is often an approach that misinformation trolls use.

Dr Tony Fauci, President Biden's Chief Medical Officer, clarified a little further on one of the morning talk shows:

The reason is that with the sheer volume of new cases that we are having and that we expect to continue with omicron, one of the things we want to be careful of is that we don’t have so many people out, Fauci told CNN's Jim, Acosta

This strikes a more nuanced tone than the statement in the CDC media release. There needs to be a balance between the risks of onward transmission and the harms of having basic services fail or operate in a degraded mode. This is a health policy decision.

On Wednesday, Walensky acknowledged that the CDC’s decision to alter the recommended isolation period “really had a lot to do with what we thought people would be able to tolerate.”Dr Walensky on CNN

And on NPR

Yeah, I really am glad you asked that question. So of course, we can't take science into a vacuum. We have to put science in the context of how it can be implemented in a functional society, so we always do that. Your question, though, is really important. And that is, you know, the vast majority of transmission happens in that first five days. And there's probably a little bit that might happen after those five days, which is why we've really put in the strong recommendation to mask those last five days. Dr Walenksy on NPR

And on the question of testing:

The antigen test is another question that has arrived, and interestingly, we actually do not know the predictive value of the antigen test later in the course of disease with regard to transmissibility.

It's a bit unfortunate that they didn't do the research or commission the research on viral cultures, antigen tests, PCR tests, etc over time in even a small number of partcipants. I know that this will vary amongst different populations due to different levels of immunity and immune systems, but directionaly this could have been informative. It seems like this kind of basic epidemiology research fits the bill for something sponsored by the NIH and importantly was going to be a natural question in response to the policy shift.

Where Engineering Thinking Comes in

My training in engineering has come to shape the way that I view the world in unexpected ways. One component of my engineering education that seems salient to today is the idea of balancing risks and being clear about assumptions. For example, in chemical engineering one of the common acts is to design a chemical reactor (or some kind of chemical driven process). You are given a budget and an end goal and you design away. You could make all of the pipes out of titanium which could be very safe, but very expensive and you won't have the budget to build the process. Because of this you design the process, maybe make a few sensitivity analysis on materials or design changes. Eventually, you present the design and make clear the operating parameters and sensitivities (and in some aspects you stamp it with your Professional Engineer stamp if you have earned this designation (as a result of testing and years of apprenticing)).

I think this last moment is what is critical--that you make a design choice and make that choice (and repercussion) known. You do the math, but then make a decision and make it clear that is was decision under constraints. I think that's where the CDC is learning (as news evolves) that they have to make these decisions very clear.

The risk of not making all of the assumptions and decision points clear is that the CDC is accused of being arbitrary in guidance. That is not good. We do not want to think of our public health agencies as making guidance that is politically expediant, but what that takes is putting the facts out there and the trade offs.

For instance in the paper below we can see what the risk of positive contacts leaving isolation early could be (or quarantine depending). Then the CDC can say that given these probabilities we recommend this policy (nicely sourced).

https://www.medrxiv.org/content/10.1101/2021.06.11.21258735v1

To put it into engineering design terms, in order to have the public health at the maximal level, we recommend this guidance. Then for those for whom a risk tolerance is lower or there is higher risk, they can adjust with the CDC guidance functioning as the floor.

It's All About Trade-Offs

The hard part about policy is that everything is about trade-offs. We just have to be clear where the science ends (e.g. what is known, what is unknown, and what our confidence is in these data) and where policy and trade-offs are being made.

@online{dewitt2022,
  author = {Michael DeWitt},
  title = {An Engineering Mindset to Public Health},
  date = {2022-01-01},
  url = {https://michaeldewittjr.com/blog/2022-01-01-an-engineering-mindset-to-public-health/},
  langid = {en}
}
Copy

Paxlovid is a new antiviral (protease inhibitor) that when paired with ritonavir provides excellent protection against hospitalization for those patients infected with SARS-CoV-2. Pfizer, the manufacturer, had two endpoints. The first endpoint was for “High Risk” patients and a secondary endpoint for “Standard Risk” patients. I thought it was neat that BioNTech/Pfizer used a Bayesian analysis for their BNT162b2 vaccine and was a little surprised when I saw a frequentist p-value for their second endpoint:

From their press release.

A follow-on analysis at 80% of enrolled patients was consistent with these findings. In this analysis, 0.7% of those who received PAXLOVID were hospitalized following randomization (3/428 hospitalized with no deaths), compared to 2.4% of patients who received placebo and were hospitalized or died (10/426 hospitalized with no deaths); p=0.051.

Oh no, p < 0.05, let’s throw away the drug for standard patients. This seems like a perfect time to do a Bayesian analysis and see what our uncertainty could be regarding the effect in this seemingly underpowered arm of the trial (e.g., we would have liked to have seem more people in this cohort because the smallest reasonable effect we would like would be say a 20% reduction in relative risk or even less as our hospitals fill with patients).

Reanalysis

First we need to recreate the data:

library(cmdstanr)
library(tidybayes)
library(posterior)
library(ggplot2)
library(dplyr)
library(ggdist)

dat_trials <- tibble::tribble(
  ~"hospitalized", ~"arm_n", ~"arm",
  3, 428, "treatment",
  10, 426, "control"

) %>%
  mutate(prop = hospitalized/arm_n)


dat_trials %>%
  ggplot(aes(arm, prop))+
  geom_point()+
  scale_y_continuous(labels = scales::percent)+
  labs(
    title = "Percent of Arm Hospitalized",
    y = "Percent",
    x = NULL
  )+
  theme_classic()

Seems like there is an effect! We can also reproduce the frequentist analysis:

prop.test(x = c(3,10), n = c(428,426),
          alternative = "less", correct = TRUE)

    2-sample test for equality of proportions with continuity correction

data:  c(3, 10) out of c(428, 426)
X-squared = 2.8407, df = 1, p-value = 0.04595
alternative hypothesis: less
95 percent confidence interval:
 -1.000000000 -0.000353954
sample estimates:
     prop 1      prop 2 
0.007009346 0.023474178 

Ok, so p < 0.05 in this is weird. Maybe they did some multiple testing adjustment? Moving on….

Enter Stan

I am going to use the following Stan code that was posted on this blog which in turn originated from this blog.

Nothing too crazy, it this code, it just fits our observed data to binomial distributions and we can look at the relative effect and the absolute effect

writeLines(readLines("trial.stan"))

//based on https://www.robertkubinec.com/post/vaccinepval/
// Which is based on https://rpubs.com/ericnovik/692460
data {
  int<lower=1> r_c; // num events, control
  int<lower=1> r_t; // num events, treatment
  int<lower=1> n_c; // num cases, control
  int<lower=1> n_t; // num cases, treatment
  array[2] real a;   // prior values for treatment effect

}
parameters {
  real<lower=0, upper=1> p_c; // binomial p for control
  real<lower=0, upper=1> p_t; // binomial p for treatment
}
transformed parameters {
  real RR  = 1 - p_t / p_c;  // Relative effectiveness
}
model {
  (RR - 1)/(RR - 2) ~ beta(a[1], a[2]); // prior for treatment effect
  r_c ~ binomial(n_c, p_c); // likelihood for control
  r_t ~ binomial(n_t, p_t); // likelihood for treatment
}
generated quantities {
  real effect   = p_t - p_c;      // treatment effect
  real log_odds = log(p_t / (1 - p_t)) - log(p_c / (1 - p_c));
}

Additionally, we need to supply a prior. I am going to use exactly the same priors that Pfizer/BioNTech for their vaccine as a starting point:

curve(dbeta(x, shape1 = .700102, shape2 = 1), 
      from = 0, to = 1, 
      ylab = "Density", xlab = "Relative Risk Reduction",
      main = "Prior Distribution")

This distribution places more density on the drug not having an effect, so we are being a bit pessimistic.

Run the Code

mod <- cmdstan_model(file.path(
    "trial.stan"))

dat <- list(
  n=sum(dat_trials$arm_n),
$       r_c=dat_trials[2,]$hospitalized,
$       r_t=dat_trials[1,]$hospitalized,
$       n_c=dat_trials[2,]$arm_n,
$       n_t=dat_trials[1,]$arm_n,
$       a=c(.700102,1)
)
fit <- mod$sample(dat, refresh = 0)
$```

### Analyzing the Results

First we can look at our summaries (note that I did look at the chains
for mixing and we have adequate samples in the tails).

``` r
fit$summary() %>% 
$  select(variable, median, mean, q5,q95, rhat) %>% 
  knitr::kable(digits = 2)

So it seems like there is evidence of an effect (a relative risk reduction of 20-89%)!

draws <- fit$draws() %>% as_draws_df()
$

draws %>%
  #median_qi(VE, .width = c(.5, .89, .995)) %>%
  ggplot(aes(y = "RR", x = RR)) +
  stat_halfeye()+
  scale_color_brewer()+
  theme_classic()+
  coord_cartesian(expand = FALSE)+
  labs(
    title = "Posterior Distribution of Relative Risk Reduction"
  )

Ok, so looks again like the bulk of the posterior distribution is a positive effect. If I said I were only interested in a drug that had a 30% relative risk reduction, I could do the following:

mean(as.numeric(draws$RR>.3))
$```

<span class="katex-display"><span class="katex"><span class="katex-mathml"><math xmlns="http://www.w3.org/1998/Math/MathML" display="block"><semantics><mrow><mn>1</mn></mrow><annotation encoding="application/x-tex">1</annotation></semantics></math></span><span class="katex-html" aria-hidden="true"><span class="base"><span class="strut" style="height:0.6444em;"></span><span class="mord">1</span></span></span></span></span> 0.921

Ok so 92% isn’t bad! In the middle of a pandemic with patients appearing
(with standard risk factors) and an oral treatment option, I would take
that probability. I could also look at what the absolute effect would
mean on hospitalizations:

``` r
draws %>%
  ggplot(aes(y = "", x = effect*1000)) +
  stat_halfeye()+
  scale_color_brewer()+
  theme_classic()+
  coord_cartesian(expand = FALSE)+
  labs(
    title = "Hospitalizations Avoided per 1,000 Patients",
    y = "Density",
    x = "Hospitalizations Avoided"
  )

If I could prevent 0-40 hospitalizations with a cheap-ish treatment, I would take it. A reminder that if I admit 20 patients and they each stay 4-5 days, I have tied up a ton of “bed days.”

Summary

The important point here is the Bayesian analysis provides a way to do these kinds of analysis and not throw away data when endpoints are not met. In this case the “standard risk” patients would likely profit from the drug.

@online{dewitt2021,
  author = {Michael E. DeWitt},
  title = {Can Bayesian Analysis Save Paxlovid?},
  date = {2021-12-15},
  url = {https://michaeldewittjr.com/blog/2021-12-15-can-bayesian-analysis-save-paxlovid/},
  langid = {en}
}
Copy

I just want to explore if there is any predictive power. First, I’ll pull the data down and plot it for Greensboro, NC.

library(data.table)

dat <- fread("https://raw.githubusercontent.com/conedatascience/covid-data/master/data/timeseries/waste-water.csv")

o <- dat[grepl(pattern = "Greens", wwtp_name)]

o[,date_n:=as.numeric(date_new)]
o[,log_copies := log10(sars_cov2_normalized)]
o <- o[!is.na(log_copies)]

plot(log_copies~date_new, o, type = "l", adj = 0, 
         xlab = '', main = "SARS-CoV-2 RNA Copies - Greensboro NC")

Now I’m going to get into dangerous territory and fit a Bayesian spline to these data and then predict out to look at the trend.

library(mgcv)
fit <- bam(log_copies ~ s(date_n, k = 7, bs = "cs"), data = o)
plot(fit)

Ok, now let’s do that prediction:

pred_matrix <- data.frame(date = seq.Date(min(o$date_new), 
$                                                                                    length.out = 365, by = "day"))
pred_matrix<span class="katex"><span class="katex-mathml"><math xmlns="http://www.w3.org/1998/Math/MathML"><semantics><mrow><mi>d</mi><mi>a</mi><mi>t</mi><msub><mi>e</mi><mi>n</mi></msub><mo>&lt;</mo><mo>−</mo><mi>a</mi><mi>s</mi><mi mathvariant="normal">.</mi><mi>n</mi><mi>u</mi><mi>m</mi><mi>e</mi><mi>r</mi><mi>i</mi><mi>c</mi><mo stretchy="false">(</mo><mi>p</mi><mi>r</mi><mi>e</mi><msub><mi>d</mi><mi>m</mi></msub><mi>a</mi><mi>t</mi><mi>r</mi><mi>i</mi><mi>x</mi></mrow><annotation encoding="application/x-tex">date_n &lt;- as.numeric(pred_matrix</annotation></semantics></math></span><span class="katex-html" aria-hidden="true"><span class="base"><span class="strut" style="height:0.8444em;vertical-align:-0.15em;"></span><span class="mord mathnormal">d</span><span class="mord mathnormal">a</span><span class="mord mathnormal">t</span><span class="mord"><span class="mord mathnormal">e</span><span class="msupsub"><span class="vlist-t vlist-t2"><span class="vlist-r"><span class="vlist" style="height:0.1514em;"><span style="top:-2.55em;margin-left:0em;margin-right:0.05em;"><span class="pstrut" style="height:2.7em;"></span><span class="sizing reset-size6 size3 mtight"><span class="mord mathnormal mtight">n</span></span></span></span><span class="vlist-s">​</span></span><span class="vlist-r"><span class="vlist" style="height:0.15em;"><span></span></span></span></span></span></span><span class="mspace" style="margin-right:0.2778em;"></span><span class="mrel">&lt;</span><span class="mspace" style="margin-right:0.2778em;"></span></span><span class="base"><span class="strut" style="height:1em;vertical-align:-0.25em;"></span><span class="mord">−</span><span class="mord mathnormal">a</span><span class="mord mathnormal">s</span><span class="mord">.</span><span class="mord mathnormal">n</span><span class="mord mathnormal">u</span><span class="mord mathnormal">m</span><span class="mord mathnormal" style="margin-right:0.02778em;">er</span><span class="mord mathnormal">i</span><span class="mord mathnormal">c</span><span class="mopen">(</span><span class="mord mathnormal">p</span><span class="mord mathnormal">re</span><span class="mord"><span class="mord mathnormal">d</span><span class="msupsub"><span class="vlist-t vlist-t2"><span class="vlist-r"><span class="vlist" style="height:0.1514em;"><span style="top:-2.55em;margin-left:0em;margin-right:0.05em;"><span class="pstrut" style="height:2.7em;"></span><span class="sizing reset-size6 size3 mtight"><span class="mord mathnormal mtight">m</span></span></span></span><span class="vlist-s">​</span></span><span class="vlist-r"><span class="vlist" style="height:0.15em;"><span></span></span></span></span></span></span><span class="mord mathnormal">a</span><span class="mord mathnormal">t</span><span class="mord mathnormal" style="margin-right:0.02778em;">r</span><span class="mord mathnormal">i</span><span class="mord mathnormal">x</span></span></span></span>date)

pred_matrix$pred <- predict(fit, newdata = pred_matrix)
$
plot(log_copies~date_new, o, type = "l", 
         xlim = c(min(o$date_new), Sys.Date()+14), 
$         xlab = '', main = "SARS-CoV-2 RNA Copies - Greensboro NC")
lines(pred_matrix<span class="katex"><span class="katex-mathml"><math xmlns="http://www.w3.org/1998/Math/MathML"><semantics><mrow><mi>d</mi><mi>a</mi><mi>t</mi><mi>e</mi><mo separator="true">,</mo><mi>p</mi><mi>r</mi><mi>e</mi><msub><mi>d</mi><mi>m</mi></msub><mi>a</mi><mi>t</mi><mi>r</mi><mi>i</mi><mi>x</mi></mrow><annotation encoding="application/x-tex">date, pred_matrix</annotation></semantics></math></span><span class="katex-html" aria-hidden="true"><span class="base"><span class="strut" style="height:0.8889em;vertical-align:-0.1944em;"></span><span class="mord mathnormal">d</span><span class="mord mathnormal">a</span><span class="mord mathnormal">t</span><span class="mord mathnormal">e</span><span class="mpunct">,</span><span class="mspace" style="margin-right:0.1667em;"></span><span class="mord mathnormal">p</span><span class="mord mathnormal">re</span><span class="mord"><span class="mord mathnormal">d</span><span class="msupsub"><span class="vlist-t vlist-t2"><span class="vlist-r"><span class="vlist" style="height:0.1514em;"><span style="top:-2.55em;margin-left:0em;margin-right:0.05em;"><span class="pstrut" style="height:2.7em;"></span><span class="sizing reset-size6 size3 mtight"><span class="mord mathnormal mtight">m</span></span></span></span><span class="vlist-s">​</span></span><span class="vlist-r"><span class="vlist" style="height:0.15em;"><span></span></span></span></span></span></span><span class="mord mathnormal">a</span><span class="mord mathnormal">t</span><span class="mord mathnormal" style="margin-right:0.02778em;">r</span><span class="mord mathnormal">i</span><span class="mord mathnormal">x</span></span></span></span>pred, col = "red")

So it appears that there will be an increasing amount of RNA in the wastewater in Greensboro.

guilford_cases <- nccovid::get_covid_state(select_county = "Guilford",
                                                                                     reporting_adj = TRUE)
setDT(guilford_cases)

For fun (because of the reporting delay) I will plot the rolling average cases on this same plot. We can see that the cases did in fact increase, but much more rapidly than our projection would have suggested.

guilford_cases <- guilford_cases[date>=min(o$date_new)]
$
plot(log_copies~date_new, o, type = "l", 
         xlim = c(min(o$date_new), Sys.Date()+14), 
$         xlab = '', main = "SARS-CoV-2 RNA Copies - Greensboro NC")
lines(pred_matrix<span class="katex"><span class="katex-mathml"><math xmlns="http://www.w3.org/1998/Math/MathML"><semantics><mrow><mi>d</mi><mi>a</mi><mi>t</mi><mi>e</mi><mo separator="true">,</mo><mi>p</mi><mi>r</mi><mi>e</mi><msub><mi>d</mi><mi>m</mi></msub><mi>a</mi><mi>t</mi><mi>r</mi><mi>i</mi><mi>x</mi></mrow><annotation encoding="application/x-tex">date, pred_matrix</annotation></semantics></math></span><span class="katex-html" aria-hidden="true"><span class="base"><span class="strut" style="height:0.8889em;vertical-align:-0.1944em;"></span><span class="mord mathnormal">d</span><span class="mord mathnormal">a</span><span class="mord mathnormal">t</span><span class="mord mathnormal">e</span><span class="mpunct">,</span><span class="mspace" style="margin-right:0.1667em;"></span><span class="mord mathnormal">p</span><span class="mord mathnormal">re</span><span class="mord"><span class="mord mathnormal">d</span><span class="msupsub"><span class="vlist-t vlist-t2"><span class="vlist-r"><span class="vlist" style="height:0.1514em;"><span style="top:-2.55em;margin-left:0em;margin-right:0.05em;"><span class="pstrut" style="height:2.7em;"></span><span class="sizing reset-size6 size3 mtight"><span class="mord mathnormal mtight">m</span></span></span></span><span class="vlist-s">​</span></span><span class="vlist-r"><span class="vlist" style="height:0.15em;"><span></span></span></span></span></span></span><span class="mord mathnormal">a</span><span class="mord mathnormal">t</span><span class="mord mathnormal" style="margin-right:0.02778em;">r</span><span class="mord mathnormal">i</span><span class="mord mathnormal">x</span></span></span></span>pred, col = "red")
par(new = TRUE)
plot(cases_daily_roll_sum~date, guilford_cases, xlab = "", ylab = "",
         xlim = c(min(o$date_new), Sys.Date()+14),axes = FALSE)
$```

![](./unnamed-chunk-5-1.png)

In this next section I was curious if there was a strong
cross-correlation with a particular lag. In theory it would be nice if
we could say that we see RNA copies increasing and that gives us an
alert some period before we see cases. This way health systems could
prepare.

``` r
cor_list <- list()
for(i in 1:30){
    d <- copy(o)[,lag_cases:=shift(x = cases_new_cens_per10k, 
                                                                 i, 
                                                                 type = "lead")][!is.na(lag_cases)]
    cor_list[[i]] <- with(d, cor(lag_cases,log_copies, 
                                                             method = "spearman"))
}

overall_cor <- do.call(rbind, cor_list)
plot(1:30, overall_cor, main = "Analysis of Lags Between RNA Copies and Cases",
         ylab = "Spearman Correlation", xlab = "Lag Number")
abline(h = 0, lty ="dashed")

For this analysis it seems that there isn’t any large warnings…with the highest correlation being a 1 day lead. However there could be a rough 1-4 day advanced warning. Nothing too long term warning as what others have suggested.

@online{dewitt2021,
  author = {Michael E. DeWitt},
  title = {Waste Water Monitoring and COVID-19},
  date = {2021-11-22},
  url = {https://michaeldewittjr.com/blog/2021-11-22-waste-water-monitoring-and-covid-19/},
  langid = {en}
}
Copy

The argument being made was that those persons who were infected with the AY4.2 variant were less likely to present with traditional COVID-19-like symptoms. This is problematic for a variety of reasons, mainly that we have been told for months what to look for as far as symptomology. Additionally, we have protocols in clinics and hospitals to triage patients, especially when testing resources are scarce. There is also a time component – if people don’t exhibit symptoms (that they think are COVID-19) or soon, they may unwittingly transmit the infection.

So Let’s Recreate the Analysis

Just for fun, I think it would be nice to re-analyze these data. I’ll make them here:

suppressPackageStartupMessages(library(tidyverse))
library(brms)

sx <- tribble(
  ~"variant", ~"sx", ~"n",
  "AY.4", 224, 484,
  "AY4.2", 33, 99,
  "AY.43", 34, 40,
  "AY.44", 7, 13,
  "AY.5", 13, 21,
  "AY.6", 7, 13,
  "B1.617.2", 50, 108
  ) %>% 
  mutate(variant_use = gsub(pattern = "\\.", "_", variant)) %>% 
  group_by(variant_use) %>% 
  nest() %>% 
  mutate(ci = map(data, ~broom::tidy(
    PropCIs::exactci(.x<span class="katex"><span class="katex-mathml"><math xmlns="http://www.w3.org/1998/Math/MathML"><semantics><mrow><mi>s</mi><mi>x</mi><mo separator="true">,</mo><mi mathvariant="normal">.</mi><mi>x</mi></mrow><annotation encoding="application/x-tex">sx, .x</annotation></semantics></math></span><span class="katex-html" aria-hidden="true"><span class="base"><span class="strut" style="height:0.625em;vertical-align:-0.1944em;"></span><span class="mord mathnormal">s</span><span class="mord mathnormal">x</span><span class="mpunct">,</span><span class="mspace" style="margin-right:0.1667em;"></span><span class="mord">.</span><span class="mord mathnormal">x</span></span></span></span>n, conf.level = .95)))) %>% 
  unnest(cols = c(data, ci))

As always, it is a good practice to graph the data. I have added some exact confidence intervals as well given the large differences in sample size amongst the variants.

sx$prop <- with(sx, sx/n)
$
sx %>% 
  ggplot(aes(reorder(variant,prop)))+
  geom_pointrange(aes(y = prop, ymin = conf.low, ymax = conf.high))+
  theme_classic()+
  coord_flip()+
  labs(
    title = "Proportion of Patients with COVID-19 Sx by Variant",
    subtitle = "95% Confidence Intervals Shown"
  )

Frequentist Approach

Now we can model this using the MLE frequentist approach. Note the fancy binomial syntax given that we are looking at successes, here defined as having COVID-19 like symptoms, out of those testing positive.

We can then use the emmeans package to look at the contrasts.

fit <- glm(cbind(sx, n) ~ variant, data = sx, family = binomial())


library(emmeans)

o <- emmeans(fit, "variant", type = "response")
pwpm(o, diffs = TRUE)

            AY.4   AY.43   AY.44    AY.5    AY.6   AY4.2 B1.617.2
AY.4     [0.316]  0.1731  0.9999  0.9847  0.9999  0.7360   1.0000
AY.43      0.544 [0.459]  0.9767  0.9894  0.9767  0.0382   0.3522
AY.44      0.860   1.579 [0.350]  1.0000  1.0000  0.9660   0.9999
AY.5       0.748   1.373   0.870 [0.382]  1.0000  0.7303   0.9900
AY.6       0.860   1.579   1.000   1.150 [0.350]  0.9660   0.9999
AY4.2      1.388   2.550   1.615   1.857   1.615 [0.250]   0.8766
B1.617.2   1.000   1.836   1.163   1.337   1.163   0.720  [0.316]

Row and column labels: variant
Upper triangle: P values   null = 1  adjust = "tukey"
Diagonal: [Estimates] (prob)   type = "response"
Lower triangle: Comparisons (odds.ratio)   earlier vs. later

We can see from these contrasts that nothing really stands out. One important line in the printout is the “adjust = tukey”. One issue with multiple hypothesis tests in the frequentist framework is the need to adjust your alpha, or Type 1 error threshold when you do multiple significance tests. The classical adjustment is Bonferroni adjustments, but these are much more conservative than Tukey adjustments. Regardless, the more tests you do in this framework, the higher your threshold is.

Bayesian Hypothesis Testing

One of the many advantages of Bayesian hypothesis testing is that you don’t have to worry about multiple comparisons (there is even a Gelman paper titled something like that). There are spurious findings that can occur (enter Type M and Type S errors rather than Type 1 and Type 2 errors), but by comparing samples from the posterior distribution you can analyze exactly what your research question is.

So we can do this by building a similar model as before:

fit_bayes <- brm(sx | trials(n) ~ variant, data = sx, refresh =0,
                                 family = binomial(), backend = "cmdstanr", file = "local.rds")

summary(fit_bayes)

 Family: binomial 
  Links: mu = logit 
Formula: sx | trials(n) ~ variant 
   Data: sx (Number of observations: 7) 
  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
         total post-warmup draws = 4000

Population-Level Effects: 
                Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
Intercept          -0.15      0.09    -0.33     0.03 1.00     4274     3524
variantAY.43        1.95      0.47     1.09     2.95 1.00     3826     2585
variantAY.44        0.31      0.59    -0.83     1.47 1.00     3416     2847
variantAY.5         0.66      0.46    -0.22     1.58 1.00     3511     2850
variantAY.6         0.32      0.59    -0.84     1.48 1.00     3499     3113
variantAY4.2       -0.55      0.24    -1.01    -0.08 1.00     3842     2747
variantB1.617.2    -0.00      0.22    -0.43     0.42 1.00     4210     2843

Draws were sampled using sample(hmc). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).

And now run our hypothesis test. Theoretically, we could have made this a random effects model, but for ease, I won’t.

hypothesis(fit_bayes, "variantAY4.2 < variantB1.617.2")

Hypothesis Tests for class b:
                Hypothesis Estimate Est.Error CI.Lower CI.Upper Evid.Ratio
1 (variantAY4.2)-(v... < 0    -0.55      0.29    -1.03    -0.07      33.19
  Post.Prob Star
1      0.97    *
---
'CI': 90%-CI for one-sided and 95%-CI for two-sided hypotheses.
'*': For one-sided hypotheses, the posterior probability exceeds 95%;
for two-sided hypotheses, the value tested against lies outside the 95%-CI.
Posterior probabilities of point hypotheses assume equal prior probabilities.

Now we can see in this framework that there does appear to be evidence of a difference in the fraction of those patients presenting with traditional COVID-19 symptoms!

@online{dewitt2021,
  author = {Michael E. DeWitt},
  title = {Advantage of Bayesian Hypothesis Testing},
  date = {2021-11-19},
  url = {https://michaeldewittjr.com/blog/2021-11-19-advantage-of-bayesian-hypothesis-testing/},
  langid = {en}
}
Copy

A prominant scientist has been posting his highlights of pre-prints on twitter during the course of the pandemic and occasionally, I come across one that makes me scratch my head. I think that the move to open and rapid science through pre-prints has been good, but not without issues. Review (and open review especially) makes work better and is an important part of science and progress.

One paper that stood out to me was by Suthar et al. (2021) in which the authors look at the neutralizing antibody tires (nAbs) amongst T-cell response in those persons who were vaccinated with the Pfizer SARS-CoV-2 Vaccines (BNT162b2 vaccine). The authors found: “substantial waning of antibody response and T-cell Immunity” in those who were vaccinated. Naturally, this could be concerning because antibodies and T-cells are important in fighting infection and could help us understand the endgame of this first epidemic of SARS-CoV-2 (e.g., vaccine induced reduction of transmission, symptomatic disease, severe outcomes, and associated periodicity given time since last vaccine). However, there is the open question of what is the best correlate of protection (e.g., we know that antibodies wane with time, but the ability to produce antibodies in the face of a new infection from memory B-cells is also very important) (Corbett et al. 2021)

So Look at the Data

As mentioned, along with the bad things about pre-prints (media jumping on sensationalist findings, people seeking acclaim by making bold statements that are not rigorously founded in fact, general review help, etc) is that much of the data are available for secondary analysis. With the article in question, I could find some of the original data analyzed by the authors from a prior publication. We can start to look at these data ourselves:

library(data.table)
library(tidyverse)
theme_set(ggdist::theme_ggdist())
dat <- readxl::read_excel("nAbs.xlsx")

dat %>%
  gather(day, value, -PID, -Gender) %>%
  mutate(day = as.numeric(str_extract(string = day, "\\d+")))->dat_long

knitr::kable(dat, digits = 1)

So it appears that there are 57 unique participants. Some participants were lost to follow-up and the final date range is kind of wide (90-120 days).

One of the most important steps in any analysis is to graph the data to gain a general understanding of the trends and shape of the data.

dat_long %>%
  ggplot(aes(day, value, group = PID))+
  geom_line()+
  facet_wrap(~PID)+
  labs(
    title = "Antibody Titres by Participate"
  )

One things that stands out to me is participant 2015. This individual has nAbs that are much higher than the other participants.

dat_long %>% 
  mutate(tst = ifelse(PID==2015,"PID: 2015","All Others")) %>% 
  group_by(tst, day) %>% 
  summarise(mu = mean(value, na.rm=TRUE)) %>% 
  spread(day,mu) %>% 
  knitr::kable(digits = 1, caption = "Mean Value of nAbs by Group")

Mean Value of nAbs by Group

If this were me, I would go back and check those data just in case someone got a little too happy when titrating (been there). Regardless, accepting this level of variability in the individual, these kind of data lend themselves well to hierarchical modeling.

So What’s the Half Life?

We can model the half life of the nAbs in the participants using the multilevel model framework with lme4. I will subset the data to include only the levels after the peak antibody level and include a random effect for the participant (since we know that there is within-person variability and serial dependence).

library(lme4)

fit_lme <- lmer(log(value) ~ day + (1|PID), data = subset(dat_long, day >21))

(half_life <- -log(2)/confint(fit_lme)[4,])

   2.5 %   97.5 % 
46.31701 84.74999 

So based on this model, the half-life for nAbs is between 46.3 and 84.7 days.

nab_out <- function(t,hl){
  2^(-t/hl)
}

sim_dat <- tibble(day = 1:365) %>% 
  mutate(lower_bound = nab_out(day, half_life[1]),
         upper_bound = nab_out(day, half_life[2]))
sim_dat %>%   
  ggplot(aes(x = day))+
  geom_ribbon(aes(ymin = lower_bound,
                  ymax = upper_bound), 
              fill = "orange", alpha = .5)+
  geom_hline(yintercept = .25, col = "red", lty = "dashed")+
  labs(
    title = "Simulated Decay of nAbs",
    y  = "Percent of Maximum nAbs",
    x = "Day After Peak nAbs"
  )

So it appears that in roughly 3-6 months after maximum antibody levels a given vaccinated person would have 1/4 of nAb titres.

days_until_perc <- function(target, hl){
  -log(target)*hl/log(2)
}

round(days_until_perc(.25, half_life)/30,1)

 2.5 % 97.5 % 
   3.1    5.6 

The big question of course is first, does this matter and in what context (protection vs infection where high levels of nAbs make sense vs symptomatic disease where a trained immune system is all that is required (thinking memory B and T cells)) and what concentration is enough at each level.

Is 5% of peak is enough then we have between 6 months and a year, perhaps in time for a teaser from infection to boost nAbs.

round(days_until_perc(.05, half_life)/30,1)

 2.5 % 97.5 % 
   6.7   12.2 

What about compartmental models?

This is not my forte, but it would seem that compartmental models would be a good way to approach this problem. We would have to fix some parameters due to the data available but one could imagine that a decent data generating process could look like (at least as far as I understand how mRNA vaccines work):

1. Inoculum is added to the blood stream via vaccination
2. A latent phase for vaccinated individual’s cells to produce the spike protein which would be a function of the volume of inoculum and the number of cells encountered. The inoculum also has some decay function.
3. A phase where the encoded protein is in the bloodstream and recognized by the immune system as a foreign body which ramps up the innate and humoral immune response.
4. Eventually the spike proteins would be cleared at some rate as the immune response increases

I started down this path and then realized that I would need to make some assumptions for some of the parameters (transition rates between compartments). Being that I do not have reasonable priors for these rates, I decided not to code up this mdoel.

Other Method

I read another paper on waning immunity on coronaviruses that had much more longitudinal data (Townsend et al. 2021). The key model in the paper was locked away in a proprietary Mathematica Notebook that couldn’t open without buying the software. I coded the below model based on their methods, but we will find is that we do not have enough data to fit a very good model.

rw("decay.stan")

data {
    int<lower=1> N; // Number of Samples
    int<lower=1> J; //Number of participants
    vector [N] nAbs; //The concentration of the antibodies
    vector [N] time; //The concentration of the antibodies
}

parameters{
    real omega;
    real hl;
    real<lower=0> sigma;
}

transformed parameters {
    vector[N] theta;  //vac effect
    theta[1:N] = omega + (1- omega)  * exp(-hl*time[1:N]);
}

model {
    hl ~ normal(0,2);
    omega ~ normal(0,1);
    nAbs ~ normal(theta, sigma);
}

library(cmdstanr)

mod_ex <- cmdstan_model("decay.stan")

dat_stan_base <- dat_long %>% 
  filter(!is.na(value)) %>% 
  filter(day>21)

stan_dat <- list(
  N = nrow(dat_stan_base),
  J = length(unique(dat_stan_base$PID)),
$  nAbs = dat_stan_base$value,
$  time = dat_stan_base$day
$)

fit_ex <- mod_ex$sample(stan_dat, 
$                        refresh = 0, iter_sampling = 500,
                                                iter_warmup = 200,
                        adapt_delta = .98,
                        max_treedepth = 15)

Running MCMC with 4 parallel chains...

Chain 2 finished in 0.4 seconds.
Chain 4 finished in 0.3 seconds.
Chain 1 finished in 0.8 seconds.
Chain 3 finished in 1.3 seconds.

All 4 chains finished successfully.
Mean chain execution time: 0.7 seconds.
Total execution time: 1.7 seconds.

Not a great fit as we are trying to draw a complicated curve through basically two points and there are (infinitely) many ways to do this.

fit_ex$summary(variables = c("omega", "hl", "sigma"))
$```

    # A tibble: 3 × 10
      variable    mean median      sd   mad     q5     q95  rhat ess_bulk ess_tail
      <chr>      <num>  <num>   <num> <num>  <num>   <num> <num>    <num>    <num>
    1 omega     -0.624  -1.09   0.940 0.873 -1.68    0.627  2.01     5.95     16.0
    2 hl        -0.789  -1.22   1.12  0.438 -1.65    1.97   3.96     4.35     11.5
    3 sigma    198.      2.06 341.    1.74   0.217 836.     3.56     4.42     11.1

## Viral Titre?

A model that is somewhat of a compromise between the compartmental model
which captures more of the underlying biological process and the
hierarchical model which fit the within-host variability is to model the
viral decay with a direct functional form. This is similar to the
approach performed by Singanayagam et al.
([2021](#ref-Singanayagam_2021)) who use this functional form for
estimated RNA copies from Cycle Threshold values. The issues, as before,
is that we only have a few observations per person and I don’t have
strong priors, but this model is closer to what we see in the graphs
where the titre increases to some point and then decay afterwards.
Ideally we would have some additional measures for the participants.

This can be modeled by the following equations:

<span class="katex-display"><span class="katex"><span class="katex-mathml"><math xmlns="http://www.w3.org/1998/Math/MathML" display="block"><semantics><mrow><mi>v</mi><mo stretchy="false">(</mo><mi>τ</mi><mo stretchy="false">)</mo><mo>=</mo><msub><mi>v</mi><mrow><mi>m</mi><mi>a</mi><mi>x</mi></mrow></msub><mfrac><mrow><mo stretchy="false">(</mo><mi>a</mi><mo>+</mo><mi>b</mi><mo stretchy="false">)</mo></mrow><mrow><mi>b</mi><msup><mi>e</mi><mrow><mo>−</mo><mi>a</mi><mo stretchy="false">(</mo><mi>τ</mi><mo>−</mo><msub><mi>τ</mi><mrow><mi>m</mi><mi>a</mi><mi>x</mi></mrow></msub><mo stretchy="false">)</mo></mrow></msup><mo>+</mo><mi>a</mi><msup><mi>e</mi><mrow><mi>b</mi><mo stretchy="false">(</mo><mi>τ</mi><mo>−</mo><msub><mi>τ</mi><mrow><mi>m</mi><mi>a</mi><mi>x</mi></mrow></msub><mo stretchy="false">)</mo></mrow></msup></mrow></mfrac></mrow><annotation encoding="application/x-tex">v(\tau) = v_{max} \frac{(a+b)}{be^{-a(\tau-\tau_{max})}+ae^{b(\tau-\tau_{max})}}</annotation></semantics></math></span><span class="katex-html" aria-hidden="true"><span class="base"><span class="strut" style="height:1em;vertical-align:-0.25em;"></span><span class="mord mathnormal" style="margin-right:0.03588em;">v</span><span class="mopen">(</span><span class="mord mathnormal" style="margin-right:0.1132em;">τ</span><span class="mclose">)</span><span class="mspace" style="margin-right:0.2778em;"></span><span class="mrel">=</span><span class="mspace" style="margin-right:0.2778em;"></span></span><span class="base"><span class="strut" style="height:2.2143em;vertical-align:-0.7873em;"></span><span class="mord"><span class="mord mathnormal" style="margin-right:0.03588em;">v</span><span class="msupsub"><span class="vlist-t vlist-t2"><span class="vlist-r"><span class="vlist" style="height:0.1514em;"><span style="top:-2.55em;margin-left:-0.0359em;margin-right:0.05em;"><span class="pstrut" style="height:2.7em;"></span><span class="sizing reset-size6 size3 mtight"><span class="mord mtight"><span class="mord mathnormal mtight">ma</span><span class="mord mathnormal mtight">x</span></span></span></span></span><span class="vlist-s">​</span></span><span class="vlist-r"><span class="vlist" style="height:0.15em;"><span></span></span></span></span></span></span><span class="mord"><span class="mopen nulldelimiter"></span><span class="mfrac"><span class="vlist-t vlist-t2"><span class="vlist-r"><span class="vlist" style="height:1.427em;"><span style="top:-2.296em;"><span class="pstrut" style="height:3em;"></span><span class="mord"><span class="mord mathnormal">b</span><span class="mord"><span class="mord mathnormal">e</span><span class="msupsub"><span class="vlist-t"><span class="vlist-r"><span class="vlist" style="height:0.814em;"><span style="top:-2.989em;margin-right:0.05em;"><span class="pstrut" style="height:2.7em;"></span><span class="sizing reset-size6 size3 mtight"><span class="mord mtight"><span class="mord mtight">−</span><span class="mord mathnormal mtight">a</span><span class="mopen mtight">(</span><span class="mord mathnormal mtight" style="margin-right:0.1132em;">τ</span><span class="mbin mtight">−</span><span class="mord mtight"><span class="mord mathnormal mtight" style="margin-right:0.1132em;">τ</span><span class="msupsub"><span class="vlist-t vlist-t2"><span class="vlist-r"><span class="vlist" style="height:0.1645em;"><span style="top:-2.357em;margin-left:-0.1132em;margin-right:0.0714em;"><span class="pstrut" style="height:2.5em;"></span><span class="sizing reset-size3 size1 mtight"><span class="mord mtight"><span class="mord mathnormal mtight">ma</span><span class="mord mathnormal mtight">x</span></span></span></span></span><span class="vlist-s">​</span></span><span class="vlist-r"><span class="vlist" style="height:0.143em;"><span></span></span></span></span></span></span><span class="mclose mtight">)</span></span></span></span></span></span></span></span></span><span class="mspace" style="margin-right:0.2222em;"></span><span class="mbin">+</span><span class="mspace" style="margin-right:0.2222em;"></span><span class="mord mathnormal">a</span><span class="mord"><span class="mord mathnormal">e</span><span class="msupsub"><span class="vlist-t"><span class="vlist-r"><span class="vlist" style="height:0.814em;"><span style="top:-2.989em;margin-right:0.05em;"><span class="pstrut" style="height:2.7em;"></span><span class="sizing reset-size6 size3 mtight"><span class="mord mtight"><span class="mord mathnormal mtight">b</span><span class="mopen mtight">(</span><span class="mord mathnormal mtight" style="margin-right:0.1132em;">τ</span><span class="mbin mtight">−</span><span class="mord mtight"><span class="mord mathnormal mtight" style="margin-right:0.1132em;">τ</span><span class="msupsub"><span class="vlist-t vlist-t2"><span class="vlist-r"><span class="vlist" style="height:0.1645em;"><span style="top:-2.357em;margin-left:-0.1132em;margin-right:0.0714em;"><span class="pstrut" style="height:2.5em;"></span><span class="sizing reset-size3 size1 mtight"><span class="mord mtight"><span class="mord mathnormal mtight">ma</span><span class="mord mathnormal mtight">x</span></span></span></span></span><span class="vlist-s">​</span></span><span class="vlist-r"><span class="vlist" style="height:0.143em;"><span></span></span></span></span></span></span><span class="mclose mtight">)</span></span></span></span></span></span></span></span></span></span></span><span style="top:-3.23em;"><span class="pstrut" style="height:3em;"></span><span class="frac-line" style="border-bottom-width:0.04em;"></span></span><span style="top:-3.677em;"><span class="pstrut" style="height:3em;"></span><span class="mord"><span class="mopen">(</span><span class="mord mathnormal">a</span><span class="mspace" style="margin-right:0.2222em;"></span><span class="mbin">+</span><span class="mspace" style="margin-right:0.2222em;"></span><span class="mord mathnormal">b</span><span class="mclose">)</span></span></span></span><span class="vlist-s">​</span></span><span class="vlist-r"><span class="vlist" style="height:0.7873em;"><span></span></span></span></span></span><span class="mclose nulldelimiter"></span></span></span></span></span></span>

The a and b parameters can be fit and influence the rate of increase and
decrease of nAb tire (or virus titre for that matter).

``` r
nab_kinetics <- function(v_max, a,b,t,tmax){
  v_max * (a+b)/(b*exp(-a*(t-tmax))+a*exp(b*(t-tmax)))
}

plot(nab_kinetics(50, a = .8, b= .1, t = 1:70, tmax = 20), type = "l",
     ylab = "nAb Titre", main = "Simulated Results")

We need to comport our data to provide the ability to identify the individual maximums and times for each participant.

long_model_dat <- dat_long %>% 
    filter(!is.na(value)) %>% 
    group_by(PID) %>% 
    mutate(v_max = max(value)) %>% 
    mutate(t_max =  max((v_max == value)*day))%>% 
    ungroup() %>% 
    mutate(id = as.integer(as.factor(PID)))

And our model:

rw("rise.stan")

functions{
    real viral_kinetics (real v_max, real a, real b, real t, real t_max){
        return(v_max * (a + b) / (b * exp(-a*(t - t_max)) + a * exp(b*(t-t_max))));
    }
}

data {
    int<lower=1> N; // Number of records
    int<lower=0> id[N]; //Participant IDs
    vector<lower=0> [N] nAbs_max; // Maximum Ab concentration
    vector<lower=0> [N] nAbs; //The concentration of the antibodies
    vector [N] time; //The concentration of the antibodies
    vector [N] t_max; //The concentration of the antibodies
    real prior_a_mu;
    real prior_b_mu;
    real prior_a_sd;
    real prior_b_sd;
    int pred_window;
}

parameters {
    real<lower=0> a;
    real<lower=0> b;
    real<lower=0> sigma;
}

transformed parameters{
    vector<lower=0>[N] mu;
    
    for( i in 1:N){
        mu[i] = viral_kinetics(nAbs_max[id[i]], a, b, time[id[i]], t_max[id[i]]);
    }
    
}
model {
    a ~ normal(prior_a_mu, prior_a_sd);
    b ~ normal(prior_b_mu, prior_b_sd);
    sigma ~ normal(0,1);
    
    nAbs ~ normal(mu, sigma);
}

generated quantities{
    vector[pred_window] yhat;
    vector[pred_window] mu_pred;
    real avg_nabs_max = mean(nAbs_max);
    real avg_tmax = mean(t_max);
    
    for(i in 1:pred_window){
        mu_pred[i] = viral_kinetics(avg_nabs_max, a, b, i, avg_tmax);
        yhat[i] = normal_rng(mu_pred[i], sigma);
    }
    
}

We can fit the model in the usual ways:

mod_titre <- cmdstan_model("rise.stan")

titre_dat <- list(
    N = nrow(long_model_dat),
    id = long_model_dat$id,
$    nAbs_max = long_model_dat$v_max,
$nAbs = long_model_dat$value,
$    time= long_model_dat$day,
$    t_max = long_model_dat$t_max,
$    prior_a_mu = .8,
    prior_b_mu = .1,
    prior_a_sd = .05,
    prior_b_sd = .05,
pred_window = 180
)

set.seed(336)

fit_titre <- mod_titre$sample(data = titre_dat, 
$                                                            refresh = 0, adapt_delta = .99,
                                                            max_treedepth = 15)

Running MCMC with 4 parallel chains...

Chain 4 finished in 4.0 seconds.
Chain 1 finished in 4.2 seconds.
Chain 2 finished in 4.2 seconds.
Chain 3 finished in 4.6 seconds.

All 4 chains finished successfully.
Mean chain execution time: 4.2 seconds.
Total execution time: 4.8 seconds.

fit_titre$summary(variables = c("a", "b", "sigma"))
$```

    # A tibble: 3 × 10
      variable   mean median     sd    mad      q5    q95  rhat ess_bulk ess_tail
      <chr>     <num>  <num>  <num>  <num>   <num>  <num> <num>    <num>    <num>
    1 a         0.800  0.800 0.0505 0.0505  0.718   0.883  1.00    2327.    2255.
    2 b         0.102  0.101 0.0460 0.0479  0.0297  0.179  1.00    1706.     980.
    3 sigma    91.9   91.9   0.494  0.498  91.1    92.7    1.00    2905.    1739.

Note that there is a fair bit of variance in our model represented by
zero. Additionally, we have some values of the predicted titre below
zero. We could resolve this by changing the distribution to use a
distribution that is always positive like a lognormal distribution. This
would require some careful transformation of our data and associated
parameters. We’ll stick with this formulation for now.

We can now visualize our results from this model.

``` r
library(posterior)
library(ggdist)
 pred_nab <- tidybayes::gather_draws(fit_titre$draws(variables = "yhat"),yhat[i] ) %>%
$    dplyr::ungroup() %>%
    dplyr::group_by(i) %>% 
    ggdist::median_qi(.value, .width = c(.5, .8, .95)) 
 
 
pred_nab %>% 
    ggplot(aes(i, .value))+
    geom_lineribbon(aes(ymin = .lower, ymax = .upper))+
    scale_fill_brewer()+
    labs(
        title = "Estimated Quantity of nAbs with Viral Evolution Model",
        y = "Quantity",
        x = "Days",
        fill = "Proportion of Scenarios"
    )+
    geom_hline(yintercept = 0, col = "orange", lty = "dashed")+
    theme(legend.position = "top")

Again, we see evidence of detectable tire above 180 days, but there is a decent bit of variability.

Conclusions

If we had additional measurements per person and some additional information on the kinetics, In the time it took me to write this post several other papers have come out with much more information that would be fun to analyze that find that immunity is likely long lasting (Mateus et al., n.d.; Grifoni et al. 2021).

References

@online{dewitt2021,
  author = {Michael E. DeWitt},
  title = {Neutralizing Antibody Titres},
  date = {2021-10-11},
  url = {https://michaeldewittjr.com/blog/2021-10-11-neutralizing-antibody-titres/},
  langid = {en}
}
Copy

$$R0 = \frac{\beta(\alpha,N)}{\alpha+\mu+\gamma(\alpha,N)}$$

Where contact rate and recovery time are both some functions of the population density and the virulence of the pathogen. For example a highly virulent pathogen may result in fewer contacts per person and a shorter recovery time (because it kills the host faster).

Simulating What This Means

' I think it is always good to explore these relationships through simulation just to see the impacts.

First we can define some functions for $\beta$ and $\gamma$. In both cases, we can say that they are monotonically decreasing with virulence ($\alpha$). Thinking here that for the modelled pathogen if the mortality rate increases the period of time that you are infectious decreases at some rate and similarly you are less likely to have many additional contacts. This could be a bad assumption depending on the pathogen, but for exploratory purposes let's go with it.

library(tidyverse)
library(patchwork)

beta_star <- function(beta, alpha){
  beta * exp(-alpha)
}

gamma_star <- function(gamma, alpha){
  log_curve <- function(k, x, x0){
    1/(1+exp(-k*(x-x0)))
  }
  
  recovery_time <- 1/gamma
    
    recovery_time_star <- recovery_time * (.5+log_curve(-2,alpha,.02))
    
    1/recovery_time_star
  
}

Now we can create a simulation grid to explore these functions:

p1 <- expand.grid(beta = .2,
       alpha = seq(.01,.5,.01)) %>% 
  mutate(beta_star = beta_star(beta, alpha)) %>% 
  ggplot(aes(alpha, beta_star))+
  geom_line()+
  labs(
    title = "Effect of Virulence on Contact Rate",
    subtitle = "With Fixed Contact Rate",
    y = expression(beta~" (Contact Rate)"),
    x = expression(alpha~" (Virulence)")
  )+
  theme_bw()

p2<-expand.grid(gamma = .1,
       alpha = seq(.01,.5,.01)) %>% 
  mutate(gamma_star = gamma_star(gamma, alpha)) %>% 
  ggplot(aes(alpha, 1/gamma_star))+
  geom_line()+
  labs(
    title = "Effect of Virulence on Recovery Rate",
    subtitle = "With Fixed Contact Rate",
    y = "Recovery Time (Days)",
    x = expression(alpha~" (Virulence)")
  )+
  theme_bw()

#| image: true
p1+p2

Impact on R0

We can pull all of this together into a function for R0 as described initially by Anderson and May (ignoring the impact of population density, N, in this case):

r0 <- function(beta, alpha=.01, mu = 1/(365*75), gamma = 1/7){
  # Beta is Some function of Virulence, alpha
 
  beta_star_in <- beta_star(beta,alpha)
  
  gamma_star_in <- gamma_star(gamma, alpha)
  
  beta_star_in/(alpha + mu + gamma_star_in)
  
}

We can then explore the surface generate over a range of virulence and contact rates.

sim_grid <- expand.grid(beta = seq(.01,2,.01),
            alpha = seq(.001,.2,.001))

pred <- with(sim_grid, r0(beta,alpha))

dat <- cbind(sim_grid, r0 = pred)

ggplot(data= dat, aes(beta, alpha, fill = r0))+
         geom_raster()+
  scale_fill_viridis_c()+
  theme_classic()+
  coord_cartesian(expand = FALSE)+
  labs(
    y = expression(alpha~" (Virulence)"),
    x = expression(beta~" (Contact Rate)"),
    fill = expression(R[0]), 
    title = expression(R[0]~" as a function of Virulence and Contact Rate")
  )

We can see that there is a transmission advantage for having a high contact rate and a lower virulence, but it exists on a spectrum with local maximums for a given contact rate. This is just a simple simulation using artificially generated functions. This analysis would be better informed with real data, but it is worthwhile endeavor to explore these relationships as we talk about evolution of the SARS-CoV-2 virus.

@online{dewitt2021,
  author = {Michael E. DeWitt},
  title = {Thinking About Viral Evolution},
  date = {2021-10-09},
  url = {https://michaeldewittjr.com/blog/2021-10-09-thining-about-viral-evolution/},
  langid = {en}
}
Copy

In the R programming environment, you have access to configuration files, typically your .Rprofile and your .Renviron. RStudio has a more thorough write-up available at this link. On the start of a new R session your Environment file is available through a Sys.getenv call. Rprofiles are basically “sourced” in the active R session on start and everything in the Rprofile is available within the session. Generally speaking, your environment file is for definitions (like a typical dotfile) which variables given values in the form of:

SECRET="ThisIsAnAPIKeyOrSecret"

You can then access this file with the following function call in R

Sys.getenv("SECRET")

If I had something like:

options(stringsAsFactors = TRUE)

bleh <- function(){
print("Bleh!")
}

In my R session, strings would be treated as factors and I would have access to the function bleh.

Using a function that is only available to you is not very being very nice to your collaborators or your future self.

So Why am I Writing This

Putting helper functions for your convenience in your Rprofile can be handy. This includes helpers to create files for you (related to project workflow) or tasks that relate to the workflow and not to the reproducibility of the work. They aren’t needed to re-create the outputs of the analysis.

There is an argument to be made that these functions should be wrapped in a package for others to be use. Putting these functions in a package also allows for better testing, continuous integration, and documentation; not to mention that packages can be more easily shared. So why put the function in your Rprofile? Sometimes I use R for quick data visualizations and don’t want to create project and my typical formal project structure. I might read a paper and it elicits a questions that I want to explore further (but then I throw away the script).

A script I have in my R file for exactly this purpose is shown below. The gist is it create an R script in the R directory by default that includes some of the packages that I use frequently. In this way I get a script with a header I will likely use.

cr <- function(x, dir_use = "R"){
  loc <- getwd()

  dirloc <- file.path(loc, dir_use)
  if(!dir.exists(dirloc)){
    dir.create(dirloc)
  }

  filnm <- sprintf("%s.R", x)

  if(file.exists(file.path(dirloc,filnm))){
    cli::cli_alert_warning("File exists.")
  } else {
    file.create(file.path(dirloc, filnm))

    cli::cli_alert_success("Created {filnm} in {dir_use}")

    cat("#' Purpose:\nlibrary(tidyverse)\nlibrary(data.table)\n",  
    file = file.path(dirloc, filnm))
  }
  
  if(interactive()){
    rstudioapi::navigateToFile(file.path(dirloc, filnm))
  }

  return(invisible(NULL))

}

In theory I could put this function in a package and then export it with the Rprofile so that it is already available. Maybe that represents the best of both worlds.

The key take away is that this function produces something that is indepedent of the main analysis and not needed to reproduce what is in the R script.

As another note, you can edit your Rprofile with:

usethis::edit_r_profile()

@online{dewitt2021,
  author = {Michael E. DeWitt},
  title = {RProfiles},
  date = {2021-10-06},
  url = {https://michaeldewittjr.com/blog/2021-10-06-rprofiles/},
  langid = {en}
}
Copy

The format of the show is composed of three rounds; the first and third rounds have themes/genre of baked good that the contestants knew about in advance and could decide (and practice) what they wanted to make. The second/middle round is composed of a “technical” challenge where the bakers have all given the same ingrediants and instructions and asked to make something of which they had no prior knowledge. Unlike the other rounds, the judges judge each bake blindly in the technical (and of course the contestants make the same dish).

Enter the Pyschometrics

This set-up is perfect for understanding how well the judges can estimate “ability” to use a psychometric term. Because we have contestants facing the same exact challenge and being judged blindly, we can use pyschometric tools to judge the “ability” of the baker and the “difficulty” of the challenge. There is a lot of noise on these measures due to the fact that contestants are eliminated after each show meaning that they do not get a chance at each challenge, but it will give a little bit of insight the ability of the bakers. We can then compare the outcomes of each round with the judged “technical” ability.

IRT and CRM

High stakes tests like the GRE and GMAT use something called Item Response Theory (IRT) to measure “ability.” The tests work by matching item difficulty (or how hard a question is) to the test-taker’s latent ability (tendency to get the right answer). Test takers should get the correct answer for those items where their ability is greater than the item difficulty, should get those items wrong where the difficulty is greater than their ability, and some distribution due to the measurement error in both ability and difficulty.

The key contribution of IRT over classical test theory (in my opinion) is that there is some latent noise in the test question/item.

IRT typically required a single “correct” answer. When we are looking at the rating of Bakers from 1 to N bakers, we need to observe the continuous data of the data. Enter the Continuous Response Models which allow us to use the principles of IRT for continuous data. In particular we will use Samejima’s continuous response model for the ranking of contestants.

Analysis Plan

So now we can lay out our analysis plan:

• Get the baking results
• Run the CRM to understand and rank baker ability
• Compare the modelled ability to the actual results

Getting the Data

The first part in this analysis is getting the data. Luckily, Wikipedia, the grandest resource on the interweb, provides these data in a regular pattern.

First, we will load the usual suite of packages for webscraping and analysis.

library(tidyverse)
library(rvest)
library(data.table)
library(cmdstanr)

To run an initial test, I am just going to pull Season 3.

url <- "https://en.m.wikipedia.org/wiki/The_Great_British_Bake_Off_(series_3)"
content <- read_html(url)
tables <- content %>% html_table(fill = TRUE)

We can see that there are 18 available. The second table gives us the biographies of the contestants:

knitr::kable(tables[[2]])

With a little bit of work, we can turn the third table into a nice representation of the results.

tables[[3]] %>%
  as.data.table() %>%
  .[-1,1:11] %>%
  setNames(c("baker", sprintf("%s",1:10))) %>%
  melt(id.vars = "baker") %>%
  .[,round_num:=as.numeric(variable)] %>%
  filter(!value %in% c("", "SB")) %>%
  mutate(perf = sprintf("%s %s", value, round_num))->performance

knitr::kable(performance)

Now the more challenging part is to parse all of the results. I am going to use some loops and index variables because I can’t think of a more expediant way to do it.

Importantly, each baker will appear for as many challenges in which they participated. This means someone who was eliminated after the first show will only have one record (enter measurement error) and those who participated in later rounds will appear multiple times.

technicals <- list()
z <- 1
for(i in seq_along(tables)){
  x <- tables[[i]]

  interesting <- grepl(pattern = "Baker|Technical", names(x))

  if(sum(interesting)<2){
    next()
  }

  y <- x[,interesting]

  names(y) <- c("baker", "technical")

  y$technical_no <- z
$
  technicals[[i]] <- y
  z <- 1+z

}

out_long<- do.call(rbind, technicals)

setDT(out_long)

knitr::kable(head(out_long,10))

Now with a little nore parsing we can extract the result and associated rank of the bakers.

out_long[,rank := as.numeric(stringr::str_extract(technical, "\\d+"))]

out_long[,rank_ordered:=12 - rank]

out_long[,baker_id := as.integer(as.factor(baker))]

knitr::kable(head(out_long,10))

Modelling the Data

In completely transparency, I utilized code from https://cengiz.me/posts/crm-stan/ which provided an excellent starting point for the analysis.

The code is lightly modified (just to tighten some priors) because of the

writeLines(readLines("irt.stan"))

 // From https://cengiz.me/posts/crm-stan/
 data{
    int  J;                    //  number of items
    int  I;                    //  number of individuals
    int  N;                //  number of observed responses
  array [N] int  item;          //  item id
  array[N] int  id;            //  person id
  array[N] real Y;             //  vector of transformed outcome
 }

  parameters {

    vector[J] b;                 // vector of b parameters forJ items
      real mu_b;                 // mean of the b parameters
      real<lower=0> sigma_b;     // standard dev. of the b parameters

    vector<lower=0>[J] a;       // vector of a parameters for J items
      real mu_a;                 // mean of the a parameters
      real<lower=0> sigma_a;     // standard deviation of the a parameters

    vector<lower=0>[J] alpha;   // vector of alpha parameters for J items
      real mu_alpha;             // mean of alpha parameters
      real<lower=0> sigma_alpha; // standard deviation of alpha parameters

    vector[I] theta;             // vector of theta parameters for I individuals
  }

  model{

     mu_b     ~ normal(0,5);
     sigma_b  ~ normal(0,1);
         b    ~ normal(mu_b,sigma_b);

     mu_a    ~ normal(0,5);
     sigma_a ~ normal(0,2.5);
         a   ~ normal(mu_a,sigma_a);

     mu_alpha ~ normal(0,5);
     sigma_alpha ~ cauchy(0,2.5);
         alpha   ~ normal(mu_alpha,sigma_alpha);

     theta   ~ normal(0,1);      // The mean and variance of theta is fixed to 0 and 1
                                 // for model identification

      for(i in 1:N) {
        Y[i] ~ normal(alpha[item[i]]*(theta[id[i]]-b[item[i]]),alpha[item[i]]/a[item[i]]);
       }
   }

Now we just compile the model and format our data:

mod <- cmdstan_model("irt.stan")

dat_stan <- list(
  J = length(unique(out_long$technical_no)),
$  I = length(unique(out_long$baker_id)),
$  N = nrow(out_long),
  item = out_long$technical_no,
$  id = out_long$baker_id,
$  Y = out_long$rank_ordered
$)

baker_list <- out_long %>%
  select(baker_id,baker) %>%
  unique()

We can then fit the model with our data.

fit <- mod$sample(dat_stan,
$                  parallel_chains = 4,
                  max_treedepth = 15, adapt_delta = .99, refresh = 0)

Running MCMC with 4 parallel chains...

Chain 3 finished in 73.7 seconds.
Chain 4 finished in 79.1 seconds.
Chain 2 finished in 80.1 seconds.
Chain 1 finished in 111.4 seconds.

All 4 chains finished successfully.
Mean chain execution time: 86.1 seconds.
Total execution time: 111.5 seconds.

We’re interested here in theta which represents the ability of the bakers.

combined_out <- fit$summary(variables = "theta") %>%
$  mutate(baker_id = as.numeric(stringr::str_extract(variable, "\\d+"))) %>%
  left_join(baker_list)

out_come_with_rank  <- combined_out %>%
  arrange(desc(median)) %>%
  mutate(outcome_modelled = row_number()) %>%
  select(outcome_modelled, baker) %>%
  left_join(performance) %>%
  mutate(outcome_realized = case_when(
    value == "Runner-up"~2,
    value == "WINNER"~1,
    TRUE~13-round_num
  ))

knitr::kable(out_come_with_rank)

Now we can see what the correlation of ability performance is:

(correlation_analysis <-out_come_with_rank %>%
  select(
    outcome_modelled,outcome_realized
  ) %>%
  as.matrix() %>%
  cor() %>%
  .[1,2] %>%
  round(.,2))

[1] NA

Not too bad! It would seem that there is evidence that the performance in the technical is correlated with the final result (thank goodness).

combined_out %>%
  ggplot(aes(reorder(baker,median), median))+
  geom_pointrange(aes(ymin = q5, ymax =q95))+
  geom_point()+
  coord_flip()+
  theme_classic() +
  geom_text(data = performance,
             aes(x = baker, y = 0,
                 label = perf), inherit.aes = FALSE,
            hjust = 0,nudge_x = .2 , size = 2)+
  labs(
    title = "Who Was the Most Skilled Baker in Season 3?",
    subtitle = glue::glue("Using Samejima’s Continuous Response Model (CRM)\nBased on Technical Round Performance\nTechnical Performance Correlation to Final Results {correlation_analysis}"),
    caption = glue::glue("Data: Wikipedia\n See {url}"),
    x = NULL,
    y = "Skill"
  ) ->p
p

out_come_with_rank %>%
  select(baker,outcome_modelled,outcome_realized) %>%
  mutate(color_use= ifelse(outcome_modelled >outcome_realized,
                           "Better than Skill", "Worse than Skill")) %>%
  ggplot(aes(y = reorder(baker, outcome_modelled)))+
  geom_point(aes(x = outcome_modelled), color = "orange")+
  geom_point(aes(x = outcome_realized), color = "blue")+
  geom_segment(aes(x = outcome_modelled,
                   xend = outcome_realized, yend = baker,
                   color = color_use))+
  theme_classic()+
  labs(
    title = "Comparison Between Outcome and Modelled Skill",
    color = "Outcome",
    y = NULL,
    x = "Rank"
  )+
  scale_color_manual(values = c("green", "red"))+
  scale_x_continuous(breaks = seq(1,12,1))->p2

p2

Next Steps

This analysis only covers one season. It would be neat to come back and do all of the seasons to get a feel for the level of difficulty of the different rounds (i.e., was the technical in round 3 of similar difficulty in each season). Additionally it would be neat to see if this relationship between the technical score and final outcome held up in each season.

@online{dewitt2021,
  author = {Michael E. DeWitt},
  title = {How Discerning is the Technical Challenge in GBBO?},
  date = {2021-09-23},
  url = {https://michaeldewittjr.com/blog/2021-09-23-how-discerning-is-the-technical-challenge-in-gbbo/},
  langid = {en}
}
Copy

While there were some fantastic quotes and inside insights that people working in health would appreciate, the key point is that everything hinges on a capable government. It rests on a government that wishes to act in good faith to preserve life. Once that is lost, then the whole response, no matter how well positioned to be successful, will fail. That's what happened in the UK and that's what happened in the US. There is also something to be said about the intersection of science and politics and how they merge into policy. I struggle personally, not with the science, but when science meets politics to become policy. Most of the time the science is clear. Even when the science isn't clear, the uncertainty, in some way, is clear. But pushing that messaging into policy is always a rough road, when leadership wants certainty ("ranges are for cattle, give me a number" as is attributed to LBJ).

If I remember to add the quotes, I'll do so.

@online{dewitt2021,
  author = {Michael DeWitt},
  title = {Spike},
  date = {2021-08-11},
  url = {https://michaeldewittjr.com/blog/2021-08-11-spike/},
  langid = {en}
}
Copy

Say you get a simple question like, how does the mortality rate from COVID-19 for our county (if you live in the United States and not Louisiana) compare to other counties in the state? Seems like a straightforward question right? Well not really. The first question is rate compared to what?

• Case fatality rate where we look at reported deaths for COVID-19 divided by reported cases for COVID-19?
• Deaths per some population measure like reported deaths per 100k residents in the county
• Do we look at excess all-cause mortality (looking at expected deaths versus actual deaths).

Then of course we have the traditional biases of:

• Testing was limited early on in the pandemic so there is a risk of an undercount of both cases and deaths in the pandemic (so now the numbers of reported deaths and reported cases are likely too low).
• Deaths and cases suffer from different reporting delays. This is just the nature of official statistics and testing lag in that a case may take several days to be registered, then logged. With death something similar happens from the time the death occurs, to the death certificate, to the death being registered in the state and national statistics.
• Deaths typically are delayed from cases. With COVID-19, someone might not succumb to the disease for 21 days after hospitalization, so this delay effect may skew official statistics. Similarly, there is a lot of censoring of data where the outcome of those hospitalized for COVID-19 is not yet known.
• Treatments varied over time, so one county suffering a wave of patients might have treated them differently later in the pandemic as treatment options became available (monoclonal antibody therapy comes to mind).
• Mismatches between where death certificates are filed versus where a resident lives could also be an issue. If everyone who is really sick is transfered to a higher level care center in another county, it might appear that counties with higher acuity hospitals have the worst rates in the state.

And these are the first things to come to mind.

Answering the question

The correct answer, is that we don’t know. For the SARS-CoV-2 pandemic, it will take some time for all of the official statistics to catch up. Additionally, there are some things we will never be able to completely quantitfy like those cases and deaths missed early in the pandemic. We can estimate them through sero-studies and excess death calculation, but these will be mostly model based and unknown.

So we still have to try to do our best to estimate them.

library(tidyverse)
library(data.table)
theme_set(ggdist::theme_ggdist())
dat <- nccovid::get_county_covid_demographics()

top_10 <- nccovid::nc_population[order(july_2020, decreasing = TRUE)] %>% 
  .[2:6] %>% 
  .$county
$
cases_2020 <- dat[county %in%top_10 & lubridate::year(week_of) < 2021, 
    .(cases = sum(cases)), by = c("county", "metric")]
deaths_2020 <- dat[county %in%top_10 & week_of < as.Date("2021-02-01"), 
    .(deaths = sum(deaths)), by = c("county", "metric")]

combined_top_10 <- merge(cases_2020,
                         deaths_2020, by = c("county", "metric")) %>% 
  .[,cfr := deaths/cases] %>% 
  group_nest(county, metric) %>% 
  mutate(ci_lo = map_dbl(data,
                       ~PropCIs::exactci(x = .$deaths, 
$                                         .<span class="katex"><span class="katex-mathml"><math xmlns="http://www.w3.org/1998/Math/MathML"><semantics><mrow><mi>c</mi><mi>a</mi><mi>s</mi><mi>e</mi><mi>s</mi><mo separator="true">,</mo><mi mathvariant="normal">.</mi><mn>95</mn><mo stretchy="false">)</mo></mrow><annotation encoding="application/x-tex">cases, .95)</annotation></semantics></math></span><span class="katex-html" aria-hidden="true"><span class="base"><span class="strut" style="height:1em;vertical-align:-0.25em;"></span><span class="mord mathnormal">c</span><span class="mord mathnormal">a</span><span class="mord mathnormal">ses</span><span class="mpunct">,</span><span class="mspace" style="margin-right:0.1667em;"></span><span class="mord">.95</span><span class="mclose">)</span></span></span></span>conf.int[1])) %>% 
   mutate(ci_hi = map_dbl(data,
                       ~PropCIs::exactci(x = .$deaths, 
$                                         .<span class="katex"><span class="katex-mathml"><math xmlns="http://www.w3.org/1998/Math/MathML"><semantics><mrow><mi>c</mi><mi>a</mi><mi>s</mi><mi>e</mi><mi>s</mi><mo separator="true">,</mo><mi mathvariant="normal">.</mi><mn>95</mn><mo stretchy="false">)</mo></mrow><annotation encoding="application/x-tex">cases, .95)</annotation></semantics></math></span><span class="katex-html" aria-hidden="true"><span class="base"><span class="strut" style="height:1em;vertical-align:-0.25em;"></span><span class="mord mathnormal">c</span><span class="mord mathnormal">a</span><span class="mord mathnormal">ses</span><span class="mpunct">,</span><span class="mspace" style="margin-right:0.1667em;"></span><span class="mord">.95</span><span class="mclose">)</span></span></span></span>conf.int[2])) %>% 
  unnest(cols = c(data))

combined_top_10 %>% 
  as.data.table() %>% 
  .[!metric %in% c("Missing", "Suppressed")] %>% 
  ggplot(aes(county, cfr))+
  geom_point()+
  geom_pointrange(aes(ymin = ci_lo, ymax = ci_hi))+
  facet_grid(metric~., scales = "free")+
  coord_flip()+
  scale_y_continuous(labels = scales::percent_format(2))

@online{dewitt2021,
  author = {Michael E. DeWitt},
  title = {Comparing Mortality Rates is Hard},
  date = {2021-05-09},
  url = {https://michaeldewittjr.com/blog/2021-05-09-comparing-mortality-rates-is-hard/},
  langid = {en}
}
Copy

This post was spurred by the following tweet by Eric Topol and an associated response.

Did we get lucky with great vaccines? Some would say yes, we got results that far exceeded expectations in a very accelerated timeline. Is that the definition of luck?

From OED the first definition of luck is:

Success or failure apparently brought by chance rather than through one’s own actions.

So developing sophisticated science that is safe and effective right when the world needs it defined as “apparently bought about by chance rather than through one’s own actions.” I think, paraphrasing Aaron Eckhert’s “Harvey Dent”, we make our own luck. That is not to discount that there is some degree of stochasticicity in some our actions and results. Additionally, there is the effect of being at the right place at the right time, but I would call this more serendipity than luck.

The rest of this post will basically center on the idea that saying something is lucky undermines the hard work and efforts of all of those involved in any kind of achievement. What appears to be luck is often experience and education preparing a group of people to better solve problems. Plus a “lucky” solution can be found by leveraging experience and knowledge to better define the problem so that the solution just seems to “appear.” Additionally, the idea of luck is inconsistent because no one believes all failures are due to bad luck. Finally the idea that things are lucky seems to lead one to the hero scientist narrative when in reality science and discoveries tend.

Counterfactual - Failures are Just Bad Luck

When making a claim it is useful to carry it to its logical extremes and examine all of its properties. If making a reliable product is luck, then failing to do so is bad luck. If that isn’t true, then making a useful product is sometimes luck, the what qualifies as luck? It’s luck only when there isn’t a legacy of research, a big well of money to fund current research, a relatively well defined problem, some of the most brilliant minds in the world working with singular passion day and night to develop a solution? Yeah, so you get where I’m going. I like the quote spuriously attributed to Thomas Jefferson, that the harder one works the more luck one seems to have.

Hard Work and Success

The point of this post is to say that telling someone that they were lucky is undermining their hard work and the work upon which they relied. This view tacitly embraces the scientist as lucky hero, Flemming style, in the lab and stumbles upon some great discovery that works marvelously. Maybe that happens, but that undermines the fact that the scientist (or more likely group of scientists) with years of training were in the lab in the first place doing experiments and had the foresight to recognize a discovery. Serendipity has a roll perhaps, but I wouldn’t say it’s all luck. Kind of like the Apollo 13 crew was lucky, but lucky that the had some brilliant minds working the problems, engineering solutions, and communicating with them to get home.

Well Defined Problems

Finding the solution to a well defined problems is one of the easier tasks in my opinion. The narrower the scope, the more one can leverage knowledge and experience. A lifetime ago I worked in manufacturing. One thing I learned is that working with rubber is challenging, especially when you want it to go where you tell it to. Rubber has varying “tack” or the coefficient of friction changes over time as different chemicals migrate to the surface (e.g., how sticky it is changes with time). Worse this property can vary depending on storage conditions and where it is in the storage unit. Plus, you have all the normal manufacturing variation from upstream processes (like the calendering process where sheets are made).

All of this is context for a project of which I was the leader. My colleagues and I had done many studies on the material properties and on the manufacturing processes upstream and downstream in order to generate a process improvement.

We working with the engineering teams in order to specify a modification that would solve a particular issue given all of our studies. When the time came to put in the modification, it didn’t work. The reason we were doing this performance improvement modification was to improve quality and output in a capacity constrained shop. Finding that the modification didn’t work during a shutdown in which the shop would need to start the next day was alarming. But we started to work the problem with all the operators, mechanics, engineering, methods–everyone. We started to lay out everything we knew, what the facts were, what studies had shown up. Eventually we defined the problem we needed to solve in a smaller box. Once we did that, one of the mechanics, an old Polish emigre, said, “I know what we can do, I did something to solve this years ago.” We mocked up what he told us, and bam, it worked! Not only did it work, it worked better than we had hoped. With the engineers in the room, we made the mock-up even better. Were we lucky? Well, we had done all of the research, we had all the experts around the table, we discussed the problems and defined exactly the issue and what we needed to happen, and once we did that, we had a guy who was a real expert remember something related to exactly that problem come up with a solution. Was that luck?

I think everything that we did made us successful. Because we had done the studies, we knew what we were working with and what performance criteria we needed to achieve. Because we had experience around the table, we had histories of machine modifications and years of observation on what might work (and also importantly what wouldn’t). Because we all discussed together exactly what we knew, what we didn’t, what problem we needed to solve, we had half of the solution defined in our new problem definition. Take away any of the hard work or any one member of the team who contributed something along the lines during solution development and it wouldn’t work. Why didn’t the first solution, the original modification not work. Bad luck? Nope, it was a prototype. It was a solution that failed, but in its failure gave us more data on what wouldn’t work and thus limited the solution space further. Hard work and perseverance led to a solution.

This is also why when people take away hard luck from the solution, the lone scientist hero comes up. Anyone can be lucky. However, hard work requires dedication, effort, and practice. Science is rarely done in a vacuum. You stand on the shoulders of the greats and learn from first principles, reading the literature, exploring what was done and what the next steps could be. Science and engineering are team sports.

@online{dewitt2021,
  author = {Michael DeWitt},
  title = {The Myth of Luck and the Lone Scientist},
  date = {2021-05-08},
  url = {https://michaeldewittjr.com/blog/2021-05-08-the-myth-of-luck-and-the-lone-scientist/},
  langid = {en}
}
Copy

Matt uses Bayesian Structural Time Series implemented in the bsts package(which I really like) in order to make a more nuanced analysis. Additionally, because we know that the percent vaccinated is monotonically increasing and bounded between 0 and 1, we can make some transforms to our data.

North Carolina

I along with some work colleauges have been maintaining a package called nccovid (available at remotes::install_github("conedatascience/nccovid)) which allows for ready access to North Carolina COVID-19 related data. This does not represent the views of my employer.

Data Prep

First I am going to pull in the needed packages:

library(tidyverse)
library(lubridate)
library(ggdist)
library(tidybayes)
library(bsts)
library(patchwork)
library(tidyverse)
library(posterior)
theme_set(theme_ggdist())

And now we can pull in the North Carolina data:

dat <- nccovid::get_vaccinations()

nc_oa <- dat[,.(people_partial_vax = sum(people_partial_vax, na.rm = TRUE),
                                         population = sum(population, na.rm = TRUE)), by = "date"] %>% 
  .[,vax:=people_partial_vax/population] %>% 
  .[order(date)]

It’s good to plot these data just to make sure they “feel” right.

nc_oa %>% 
  ggplot(aes(date, vax))+
  geom_line()+
  labs(
    title = "Cumulative Percent of North Carolinians Vaccinated",
    caption = "Data: North Carolina Department of Health and Human Services\nAnalysis: @medewittjr",
    y = "Percent Vaccinated"
  )+
  scale_y_continuous(labels = scales::percent)+
  geom_smooth(method = "lm", color = "red",alpha = .1, lty = "dashed")

So we can see that linear fit for North Carolina likely isn’t valid, at least not in the last few weeks. Regardless, we have out data for the next steps of the analysis.

Data Transformation

As I mentioned earlier and a critical point of this analysis is that we know a few things about vaccinations. Firstly, vaccinations are non-reversible and are thus monotonically increasing (e.g., they can only increase). Additionally, depending on the definition you take, the percentage of the population vaccinated with a first dose is bound between 0 and 1.

With these features in mind, we can use a logit transform on our vaccinations and then fit that on our data.

nc_log_diff <- nc_oa %>%
  group_by(people_partial_vax) %>% 
  mutate(id = row_number()) %>% 
  filter(id == min(id)) %>% 
  dplyr::select(-id) %>% 
  ungroup() %>% 
  mutate(log_diff_vax = c(NA, log(diff(qlogis(vax))))) %>%
  slice(-1)

Now we can fit the model using the priors that Matt used.

fit = with(nc_log_diff, bsts(log_diff_vax, 
  state.specification = list() %>%
    AddSemilocalLinearTrend(log_diff_vax,
      level.sigma.prior = SdPrior(0.5, 1),
      slope.mean.prior = NormalPrior(0,0.5),
      initial.level.prior = NormalPrior(0,0.5),
      initial.slope.prior = NormalPrior(0,0.5),
      slope.sigma.prior = SdPrior(0.5, 1),
      slope.ar1.prior = Ar1CoefficientPrior(0, 0.5)
    ) %>%
    AddSeasonal(log_diff_vax, 7, 
      sigma.prior = SdPrior(0.5, 1)
    ),
  prior = SdPrior(0.5, 1),
  niter = 40000,
  seed = 336 
))

=-=-=-=-= Iteration 0 Sat Jan 13 15:59:50 2024 =-=-=-=-=
=-=-=-=-= Iteration 4000 Sat Jan 13 16:00:10 2024 =-=-=-=-=
=-=-=-=-= Iteration 8000 Sat Jan 13 16:00:30 2024 =-=-=-=-=
=-=-=-=-= Iteration 12000 Sat Jan 13 16:00:50 2024 =-=-=-=-=
=-=-=-=-= Iteration 16000 Sat Jan 13 16:01:10 2024 =-=-=-=-=
=-=-=-=-= Iteration 20000 Sat Jan 13 16:01:30 2024 =-=-=-=-=
=-=-=-=-= Iteration 24000 Sat Jan 13 16:01:49 2024 =-=-=-=-=
=-=-=-=-= Iteration 28000 Sat Jan 13 16:02:09 2024 =-=-=-=-=
=-=-=-=-= Iteration 32000 Sat Jan 13 16:02:30 2024 =-=-=-=-=
=-=-=-=-= Iteration 36000 Sat Jan 13 16:02:50 2024 =-=-=-=-=

Diagnostics (that I did not know could be leveraged from posterior. just a really great package).

draws <- as_draws(do.call(cbind, fit[startsWith(names(fit), "trend") | startsWith(names(fit), "sigma")]))
summary(draws, median, mad, quantile2, default_convergence_measures()) %>% 
  knitr::kable(digits = 3)

All of the Gelman-Rubin statistics look good as well as the effective sample sizes, so I’m happy with what I see. However, it is always good to visualize the outputs as well:

bayesplot::mcmc_trace(draws)

Trace plots look pretty good as well.

Predictions

Now we can predict out with our model for 180 days.

forecast_days <- 180

fits <- nc_log_diff %>%
  add_draws(colSums(aperm(fit$state.contributions, c(2, 1, 3))))
$
predictions <- nc_log_diff %$%
$  tibble(date = max(date) + days(1:forecast_days)) %>%
  add_draws(predict(fit, horizon = forecast_days)$distribution, value = "log_diff_vax")
$```

Now we need to convert our predictions back into percentages:

``` r
pred_vax = predictions %>%
  group_by(.draw) %>%
  mutate(
    vax = plogis(cumsum(c(
      qlogis(tail(nc_log_diff$vax, 1)) + exp(log_diff_vax[[1]]),
$      exp(log_diff_vax[-1])
    )))
  )

Results

Now we can visualize the outputs. We see that there is a high degree of uncertainty regarding what proportion of the population will likely be vaccinated in the coming 180 days.

widths = c(.5, .8, .95)
pred_vax %>%
  ggplot(aes(date, vax)) +
  stat_lineribbon(.width = widths, color = "#08519c") +
  scale_fill_brewer()+
  geom_line(data = nc_oa, size = 1)+
  labs(
    title = "Percent vaccinated (at least partially vaccinated)",
    subtitle = "For the State of North Carolina",
    y = NULL,
    x = NULL
  )+
  scale_y_continuous(limits = c(0,1), labels = scales::percent_format())

The next big question is what will be our likely vaccine coverage. If we want to target 80% of the population vaccinated, which is aggressive, but needed if $R0$ of SARS-CoV-2 is close to 4-4.5 and the vaccine effectiveness is between 90-95%.

prob <- pred_vax %>%
  group_by(date) %>%
  summarise(prob_vax_gt_x = mean(vax > .80)) %>%
  ggplot(aes(date, prob_vax_gt_x)) +
  geom_line(color = "#08519c", size = 1) +
  theme_ggdist() +
  geom_hline(yintercept = 0.5, alpha = 0.25) +
  scale_y_continuous(limits = c(0,1), labels = scales::percent_format()) +
  labs(
    subtitle = "Pr(Percent vaccinated > 80%)",
    y = NULL,
    x = NULL
  )

prob

Sadly, it looks like that is a low probability outcome.

What about a county?

Just for fun I want to run through a single North Carolina County and see if there is any difference.

# Oddly one day showed a decrease...government records....
forsyth_log_diff <- dat[county=="Forsyth",c("county", 
                                            "people_partial_vax",
                                            "population",
                                            "date")] %>%
  .[,vax:=people_partial_vax/population] %>% 
  group_by(people_partial_vax) %>% 
  mutate(id = row_number()) %>% 
  filter(id == min(id)) %>% 
  dplyr::select(-id) %>% 
  ungroup() %>% 
  mutate(log_diff_vax = c(NA, log(diff(qlogis(vax))))) %>%
  filter(!is.na(log_diff_vax)) %>% 
  slice(-1)

fit = with(forsyth_log_diff, bsts(log_diff_vax, 
  state.specification = list() %>%
    AddSemilocalLinearTrend(log_diff_vax,
      level.sigma.prior = SdPrior(0.5, 1),
      slope.mean.prior = NormalPrior(0,0.5),
      initial.level.prior = NormalPrior(0,0.5),
      initial.slope.prior = NormalPrior(0,0.5),
      slope.sigma.prior = SdPrior(0.5, 1),
      slope.ar1.prior = Ar1CoefficientPrior(0, 0.5)
    ) %>%
    AddSeasonal(log_diff_vax, 7, 
      sigma.prior = SdPrior(0.5, 1)
    ),
  prior = SdPrior(0.5, 1),
  niter = 40000,
  seed = 336 
))

=-=-=-=-= Iteration 0 Sat Jan 13 16:03:50 2024 =-=-=-=-=
=-=-=-=-= Iteration 4000 Sat Jan 13 16:04:10 2024 =-=-=-=-=
=-=-=-=-= Iteration 8000 Sat Jan 13 16:04:29 2024 =-=-=-=-=
=-=-=-=-= Iteration 12000 Sat Jan 13 16:04:49 2024 =-=-=-=-=
=-=-=-=-= Iteration 16000 Sat Jan 13 16:05:09 2024 =-=-=-=-=
=-=-=-=-= Iteration 20000 Sat Jan 13 16:05:29 2024 =-=-=-=-=
=-=-=-=-= Iteration 24000 Sat Jan 13 16:05:48 2024 =-=-=-=-=
=-=-=-=-= Iteration 28000 Sat Jan 13 16:06:07 2024 =-=-=-=-=
=-=-=-=-= Iteration 32000 Sat Jan 13 16:06:26 2024 =-=-=-=-=
=-=-=-=-= Iteration 36000 Sat Jan 13 16:06:45 2024 =-=-=-=-=

fits <- forsyth_log_diff %>%
  add_draws(colSums(aperm(fit$state.contributions, c(2, 1, 3))))
$
predictions <- forsyth_log_diff %$%
$  tibble(date = max(date) + days(1:forecast_days)) %>%
  add_draws(predict(fit, horizon = forecast_days)$distribution, value = "log_diff_vax")
$
pred_vax = predictions %>%
  group_by(.draw) %>%
  mutate(
    vax = plogis(cumsum(c(
      qlogis(tail(forsyth_log_diff$vax, 1)) + exp(log_diff_vax[[1]]),
$      exp(log_diff_vax[-1])
    )))
  )

pred_vax %>%
  ggplot(aes(date, vax)) +
  stat_lineribbon(.width = widths, color = "#08519c") +
  scale_fill_brewer()+
  geom_line(data = forsyth_log_diff, size = 1)+
  labs(
    title = "Percent vaccinated (at least partially vaccinated)",
    subtitle = "For the Forsth County, North Carolina",
    y = NULL,
    x = NULL
  )+
  scale_y_continuous(limits = c(0,1), labels = scales::percent_format())

pred_vax %>%
  group_by(date) %>%
  summarise(prob_vax_gt_x = mean(vax > .80)) %>%
  ggplot(aes(date, prob_vax_gt_x)) +
  geom_line(color = "#08519c", size = 1) +
  theme_ggdist() +
  geom_hline(yintercept = 0.5, alpha = 0.25) +
  scale_y_continuous(limits = c(0,1), labels = scales::percent_format()) +
  labs(
    title = "Pr(Percent vaccinated > 80%)",
    subtitle = "For Forsyth County, North Carolina",
    y = NULL,
    x = NULL
  )

Hmm, not too much better

knitr::include_graphics("notbad.gif")

@online{dewitt2021,
  author = {Michael E. DeWitt},
  title = {Time to Vaccinate},
  date = {2021-05-07},
  url = {https://michaeldewittjr.com/blog/2021-05-07-time-to-vaccinate/},
  langid = {en}
}
Copy

The argument is very similar to the famous “man in the arena” speech by Teddy Roosevelt, in that the one who fights the battle, who lives with the toils, knows the terrain. Even in the Toyota Manufacturing Way, deference is given to those that live in the Gemba, the place where the work happens, rather than the experts.

The World is Complicated and Messy

So what prompted this post? The below tweet from Nate Silver, the editor in chief of the data journalism/poll and sport focused fivethirtyeight site, made in regard to the United State’s Food and Drug Administration’s decision to recommend pausing distribution of the Johnson & Johnson/ Janssen SARS-CoV-2 vaccine.

Having an opinion on things is not against the law. Quite frankly, having an opinion and feeling compelled to share it is why Twitter exists in the first place. Later Mr Silver talks about how this is a silly decision due to the gross number of adverse events (n = 6) compared to the total number of doses given (N = 7 Million Doses). Drugs are complicated and there is a monitoring process that detected these so called adverse events which triggered this action from the regulatory bodies.

Where Things Get Complicated

The J&J vaccine really is a wonder drug in the fight against the pandemic. It is a single shot dose and is easy to handle, meaning that you can often access regions that may have poor infrastructure (both infrastructure as in roads/travel/distance/rural areas as well as health care access) and do not have to worry about the loss to follow-up with the two dose regimes. Because of these features, this vaccine was often the go-to for marginalized communities that may suffer from access. Issuing any kind of notice about safety then is a double edged sword where vaccine confidence could be harmed (which is not good in the face of a global pandemic) as well as reducing trust in a key group of people (i.e., the same marginalized people who were sent this vaccine also have a tremendous history with the medicine establishment) who likely need this vaccine the most because of economic conditions that have forced them back to work or living conditions (congregate, multi-general homes) while a high degree of infection still exists. So what do you do? Do you stay quiet and study while potentially more (relatively rare) events occur or do you try and be cautious and transparent and hope that in the long run this move will reinforce the notion that we have safety process and that those processes do work to keep people safe.

The FDA went with the transparency now. This is where Mr Silver has a gripe. The risk of dying from an infection from SARS-CoV-2 for certain demographics is much, much higher than having an adverse event (at face value).

But, the plot thicken when the ACIP group looked into the adverse events, they found that the outcomes occurred in a very specific demographic. Importantly, the details indicate that the observed rate is not 6 out of 7 million, but more like 6 out of 1.7 million. Still rare, but when you want to vaccinate billions of people, the differences stack up.

So it’s details like this, doing the homework, getting into the details, doing the case analysis, that separates the pundits from the people in the field.

Pundits and Sophists

So here’s where the skin in the game point comes to play. Nate can put whatever he wants on Twitter. If he has a bad take, people may choose not to follow him on twitter or go to his website, sure. People aren’t opening hospitals or setting up refrigerated trucks repurposed as morgues with his projections. States aren’t using his polls to change policy (maybe, but certainly not during the pandemic). All of his forecasting work is really for both sport and political sport (Eitan Hersh has a great book on political engagement vs hobbyism with the polling horse race certainly falling into the latter ). Granted some research has shown that his polls (and those like it) may have a negative influence on voter turnout, but that’s for another day. He can say what he wants and no real decisions are made for which someone can say, “because you said x, we did y, and now you are accountable.”

IF the FDA says or does something stupid, those are the people who regular our food and drugs. They have all kinds of prerogatives to never mess up. If someone says something is safe and it turns out to be less safe than marketed, that’s on them. You can see it, you can point to it (I took this shot and it messed me up). Getting sick from a raging virus is harder to point to an agency or a person behind a desk at an agency and say, “because you said this was OK and I believed you and now I got hurt.” SARS-CoV-2 is a known.

Because the FDA had skin in the game, they had to err on the side of transparency and caution. Does it suck that people who could benefit from the vaccine (e.g., the elderly) might not? Absolutely. It is awful and another tragedy and will continue to impact those marginalized communities the most. Would not saying something that would later blow up into a big news story about the FDA covering up an investigation into vaccine induced clotting disorders destroy faith in a regulatory agency be a good reason to err on the side of caution. Yeah.

In the Arena

When I started my first job, I had a ton of confidence. I was good at math and pretty decent at building models. A project came a long where I built the model based on some assumptions that I had been given and it said we didn’t need to make this big capital investment. The company deferred the investment, I was viewed as a hero and all great things. However, as time passes, it turns out that one of the key, critical assumptions that I had been given (from an “expert”) was false. The expert had overstated the performance (more like gave me the target performance rather than actual achieved). If someone in the field had actually gone and seen the machine that was used as the benchmark they would have known that this performance was impossible. The outcome of this event was that even if we reactivated the project, it would be 18 months before we would have what we needed, and by the way we reallocated the capital to support other ambitions. The plant was left with a headache for those two years.

I wasn’t blamed for “bad analysis”. However, I (along with my teammates) had to live with my mistake. I never let myself forget each time I had to face an issue that was directly related to the outcomes of my analysis. I took a pundit’s input at face value, rather than doing the homework and talking to those who were on the group with the process. After that I vowed to never trust a pundit or professed expert and would go see for myself or seek the wisdom of those doing the job. It might have taken a little longer and perceived as a conservative shift, but better decisions were made and more thoughtful analysis provided after that day. Interestingly, by developing expertise in sniffing out what was real, you could know when to be more aggressive vs when to operate in the known, precisely because you took the time to develop expertise.

Which Leads to the Pandemic

One of the craziest things in this pandemic, working in health care was the run on purple top wipes.

Early in the pandemic, when we were instituting and modeling our materials use, the question came up about our burn rate on disinfectant wipes used to clean rooms and equipment. Tell me how works into some kind of fancy model of the pandemic. While all these new twitter experts and anyone who could write code was trying to model how many deaths or cases there would be in a month, the most pressing issue within a real hospital was when would we run out of a particular wipe or how many people would show up in my ED and how many nurses, doctors, sanitation support, etc would I need in order to serve them in a given town (not the US or even at the state level). If you’re the person making the projections and you give bad information, someone might not get care who needs it. And there is a face a name behind that persons, not a twitter handle doom-scrolling on a weeknight.

Similarly, you have to take the input from someone who lives day in and day out talking through vaccine hesitancy or rebuilding trust with the health profession. It takes time and you have to listen and see with your eyes open. Spent a few weeks shadowing these people (shadowing nights in a busy ED will certainly open your eyes to what happens in the world in a real way).

Not Credentialism

I’m not writing this to support credentials or credentialism/gatekeeping. We all don’t need to have PhDs and MDs or some kind of advanced degrees to contribute (I don’t have a PhD or MD). Everyone brings something different to the table and can provide insight. Interdisciplinary discussions are vitally important in moving the conservation and analysis forward and results in better decisions being taken. However, if you come to the table, you have to do your homework. That could be in the form of reading books, articles, listening to reputable experts, interviewing boots on the ground, working through the problems, whatever, you have to do the homework. Experience and the experience of others is invaluable. Act like you have skin in the game and that everything you say you will be accountable for. You have to respect the science and approach the conversation with respect. Measures are messy, the world is certainly not simple, science is hard, trust is easily lost, and communication is challenging.

@online{dewitt2021,
  author = {Michael E. DeWitt},
  title = {Skin in the Game},
  date = {2021-04-15},
  url = {https://michaeldewittjr.com/blog/2021-04-15-skin-in-the-game/},
  langid = {en}
}
Copy

Preview Image from shinyproxy.io

One of the neat things about ShinyProxy is that it allows you to package your Shiny applications into Docker containers and then serve them up via centralised “App Store” like front-end with all the goodies you might want (authentication, logging, etc). You get the bonus of building these containers in a container (so some dependency management) and scaling of containers with whatever backend you need.

The deployment with a Shiny package or even a Flask application is very straightforward and well documented on their website, but what about simple html webpages generated from R Markdown or even entire websites. In my experience, there is a middle ground for html reports for single topic issues and larger website frameworks for larger packages. In an enterprise setting you still want to be able to serve all of these products to customers with authentication. So how can we do it?

Generate a Consistent Output Location

No matter what your output, send it to a consistent directory (my favourite is a “docs” directory that contains all my outputs). This can be the output from a single file or an entire website (thinking here something generated from R Markdown, Blogdown, Bookdown, etc).

Tell the Container to Host the Website

Initially, I had tried to write a container as a full Apache webserver, then write out the docs files to the webserver. That was until I realised the power of the {servr} package to abstract that functionality away and keep me in the R domain. The real clue was in this question and it dawned on me to let R do the work for us. We only need to be consistent in our output location and file format and make sure that ShinyProxy knows where to serve the site (and R inside the container).

For Static Htmls Packages

Below can work for generally every kind of output.

FROM openanalytics/r-base

# install required R packages
RUN install.r servr

# install pandoc
RUN wget https://github.com/jgm/pandoc/releases/download/2.6/pandoc-2.6-1-amd64.deb
RUN dpkg -i pandoc-2.6-1-amd64.deb

COPY docs /root/docs/

# use default port for shinyproxy apps, so you don't have to add port in application.yml
EXPOSE 3838  

CMD ["R", "-e", "servr::httd('/root/docs', port = 3838, host = '0.0.0.0')"]

For Bookdown

If you wanted to rebuild and serve a bookdown generated book you could do the following:

FROM openanalytics/r-base

# install required R packages
RUN install.r bookdown servr

# install pandoc
RUN wget https://github.com/jgm/pandoc/releases/download/2.6/pandoc-2.6-1-amd64.deb
RUN dpkg -i pandoc-2.6-1-amd64.deb

COPY docs /root/docs/

# use default port for shinyproxy apps, so you don't have to add port in application.yml
EXPOSE 3838  

CMD ["R", "-e", "bookdown::serve_book('/root/docs', port = 3838, host = '0.0.0.0')"]

Conclusion

You can see from the above Dockerfile, the solution is pretty easy and allows you to quickly containerise your reporting in addition to application.

@online{dewitt2020,
  author = {Michael E. DeWitt},
  title = {ShinyProxy Serving Websites},
  date = {2020-10-03},
  url = {https://michaeldewittjr.com/blog/2020-10-03-shinyproxy-serving-websites/},
  langid = {en}
}
Copy

$${k + r - 1 \choose k} * (1-p)^r*p^k$$

That is at least the textbook definition. Typically we encounter the negative binomial distribution as a way to deal with over-dispersed Poisson processes (and thus is really a mixture model of gamma and poison distributions).

Basic Reproduction Number and Dispersion

In outbreaks and epidemics we are typically interested in the basic reproduction number, $R_0$, which represents the average number of secondary infections caused by an index infection in a fully susceptible population. One could simulate such a branching process using a Poisson branching process.

Borrowing some simulation code from Althaus (2015) we can first simulate transmission chains with a Poisson distribution and an R of .8.

R0 <- 2.5
k <- 1

gamma_params <- epitrix::gamma_mucv2shapescale(mu = 3,cv = .5)

serial_interval <- distcrete::distcrete(name = "gamma", gamma_params$scale,
$                                        shape =gamma_params$shape,
$                                        w = 0)
# Set seed for random number generator
set.seed(645)
# Number of simulation runs
runs <- 1e2
# Number of initial cases
seed <- 1
# Initialize plot
plot(NA,xlim=c(0,100),ylim=c(0,100),xlab="Time (days)",
ylab="Cumulative number of cases",frame=FALSE)
# Set color scheme for different trajectories
cols <- sample(terrain.colors(runs))
# Simulate outbreak trajectories
for(i in 1:runs) {
  cases <- seed
  t <- rep(0, seed)
  times <- t
  while (cases > 0) {
    secondary <- rpois(cases,.8)
    t.new <- numeric()
    for (j in 1:length(secondary)) {
      t.new <-
        c(
          t.new,
          t[j] + serial_interval$r(secondary[j])
$        )
    }
    cases <- length(t.new)
    t <- t.new
    times <- c(times, t.new)
  }
  lines(sort(times),
        1:length(times),
        col = cols[i],
        lwd = 1)
  points(max(times), length(times), col = cols[i], pch = 16)
}

Super-Spreading

One of the buzzwords with the SARS-CoV-2 Pandemic has been super-spreading, and there is evidence that super-spreading events play a large role in the transmission of SARS-CoV-2 (Endo et al. 2020). Super-spreading refers to those index cases which transmit to a larger number of people than would have been expected (Lloyd-Smith et al. 2005). Larger than expected is a bit of a loose definition, do have a way of measuring this using our reproduction number (or even the basic reproduction number). Now it is true that the reproduction number and basic reproduction number are both estimated themselves from the data with associated measurement and missing data problems, but this is a thought exercise so let’s assume we know them.

We measure the degree of super-spreading using the dispersion parameter called k (or $\phi$). The closer the dispersion parameter is to 1, the more Poisson-like is the branching process. Conversely, as k the dispersion parameter approaches 0, the more super-spreading events there will be. We can see this as we incease the number of samples that the negative binomial with $\phi$ converges to the mean of Poisson distribution, while the smaller $\phi$ does not converge.

sims <- data.frame(
ran_poi <- purrr::map_dbl(1:1000, ~mean(rpois(.x, R0))),
ran_nb <-  purrr::map_dbl(1:1000, ~mean(rnbinom(.x, 1, mu = R0))),
ran_nb_ss <- purrr::map_dbl(1:1000, ~mean(rnbinom(.x, .1, mu = R0)))
)

matplot(sims, type = "l",
       main = "Convergence of Mean",
       xlab = "Samples", ylab = "Mean", adj = 0, ylim = c(0,10))
legend("topright", fill = c(1,2,3),legend = c("Poisson", 
                                        "NB with K=1", 
                                        "NB with k=.1"))

With the same reproduction number, but a dispersion of 0.1, we can see that some of the transmission chains are much larger. Thus is could be said that super-spreading transmission might be slow to take hold (easy to have chains that terminate quickly), but it can start wildfires; this tranmission pattern and its effect on controlling epidemics is discussed in Fraser et al. (2004).

gamma_params <- epitrix::gamma_mucv2shapescale(mu = 3,cv = .5)

serial_interval <- distcrete::distcrete(name = "gamma", gamma_params$scale,
$                                        shape =gamma_params$shape,
$                                        w = 0)
# Set seed for random number generator
set.seed(645)
# Number of simulation runs
runs <- 1e2
# Number of initial cases
seed <- 1
# Initialize plot
plot(NA,xlim=c(0,100),ylim=c(0,100),xlab="Time (days)",
ylab="Cumulative number of cases",frame=FALSE)
# Set color scheme for different trajectories
cols <- sample(terrain.colors(runs))
# Simulate outbreak trajectories

collector <- list()
for(i in 1:runs) {
  cases <- seed
  t <- rep(0, seed)
  times <- t
  while (cases > 0) {
    secondary <-
      rnbinom(cases,
              .1,
              mu = .9)
    t.new <- numeric()
    for (j in 1:length(secondary)) {
      t.new <-
        c(
          t.new,
          t[j] + serial_interval$r(
$            secondary[j]
          )
        )
    }
    cases <- length(t.new)
    t <- t.new
    times <- c(times, t.new)
  }
  collector[[i]] <- length(times) 
  lines(sort(times),
        1:length(times),
        col = cols[i],
        lwd = 1)
  points(max(times), length(times), col = cols[i], pch = 16)
}

transmission_chains <- do.call(rbind, collector) - 1
hist(transmission_chains, 
     breaks = 30, 
     main = "Number of Secondary Cases", 
     adj = 0, col = "steelblue", xlab = "Secondary Cases")

Proportion Responsible

Again, borrowing code from Endo et al. (2020) to estimate the proportion of infections that are responsible for a given proportion of cases.

nb_fit <- fitdistrplus::fitdist(data =as.vector(transmission_chains), distr = "nbinom" )

prop_responsible=function(R0,k,prop){
    qm1=qnbinom(1-prop,k+1,mu=R0*(k+1)/k)
    remq=1-prop-pnbinom(qm1-1,k+1,mu=R0*(k+1)/k)
    remx=remq/dnbinom(qm1,k+1,mu=R0*(k+1)/k)
    q=qm1+1
    1-pnbinom(q-1,k,mu=R0)-dnbinom(q,k,mu=R0)*remx
}

prop_responsible(nb_fit<span class="katex"><span class="katex-mathml"><math xmlns="http://www.w3.org/1998/Math/MathML"><semantics><mrow><mi>e</mi><mi>s</mi><mi>t</mi><mi>i</mi><mi>m</mi><mi>a</mi><mi>t</mi><mi>e</mi><mo stretchy="false">[</mo><mo stretchy="false">[</mo><mn>2</mn><mo stretchy="false">]</mo><mo stretchy="false">]</mo><mo separator="true">,</mo><mi>n</mi><msub><mi>b</mi><mi>f</mi></msub><mi>i</mi><mi>t</mi></mrow><annotation encoding="application/x-tex">estimate[[2]],nb_fit</annotation></semantics></math></span><span class="katex-html" aria-hidden="true"><span class="base"><span class="strut" style="height:1.0361em;vertical-align:-0.2861em;"></span><span class="mord mathnormal">es</span><span class="mord mathnormal">t</span><span class="mord mathnormal">ima</span><span class="mord mathnormal">t</span><span class="mord mathnormal">e</span><span class="mopen">[[</span><span class="mord">2</span><span class="mclose">]]</span><span class="mpunct">,</span><span class="mspace" style="margin-right:0.1667em;"></span><span class="mord mathnormal">n</span><span class="mord"><span class="mord mathnormal">b</span><span class="msupsub"><span class="vlist-t vlist-t2"><span class="vlist-r"><span class="vlist" style="height:0.3361em;"><span style="top:-2.55em;margin-left:0em;margin-right:0.05em;"><span class="pstrut" style="height:2.7em;"></span><span class="sizing reset-size6 size3 mtight"><span class="mord mathnormal mtight" style="margin-right:0.10764em;">f</span></span></span></span><span class="vlist-s">​</span></span><span class="vlist-r"><span class="vlist" style="height:0.2861em;"><span></span></span></span></span></span></span><span class="mord mathnormal">i</span><span class="mord mathnormal">t</span></span></span></span>estimate[[1]],.8)

[1] 0.02311288

References

@online{dewitt2020,
  author = {Michael E. DeWitt},
  title = {Negative Binomial Distribution and Epidemics},
  date = {2020-08-30},
  url = {https://michaeldewittjr.com/blog/2020-08-30-negative-binomial-distribution-and-epidemics/},
  langid = {en}
}
Copy

library(cmdstanr)
library(magrittr)
library(ggplot2)
library(data.table)
library(deSolve)

Compartment models are commonly used in epidemiology to model epidemics. Compartmental model are composed of differential equations and captured some “knowns” regarding disease transmission. Because these models seek to simulate/ model the epidemic process directly, they are are somewhat more resistant to some biases (e.g. missing data). Strong-ish assumptions must be made regarding disease transmission and varying level of detail can be included in order to make the models closer to reality.

This post is largely an extension of Bayesian workflow for disease transmission modeling in Stan.

Data Generating Process

First we need to define our data generating process. Here we will start with a four compartment model with no births or deaths. This will represent an immunizing infection with a latent phase.

library(DiagrammeR)

a_graph <-
  create_graph(directed = TRUE) %>%
  add_node(label = "S", 
           node_aes = node_aes(fill = "orange")) %>% 
  add_node(label = "E",
           node_aes = node_aes(fill = "orange")) %>%
  add_node(label = "I",
           node_aes = node_aes(fill = "orange"))%>%
  add_node(label = "R",
           node_aes = node_aes(fill = "orange")) %>%
  add_edge(from = 1, to = 2) %>% 
  add_edge(from = 2, to = 3) %>% 
  add_edge(from = 3, to = 4)
render_graph(a_graph, layout = "nicely")

Simulate an Epidemic with Knowns

Now we can build this hypothetical epidemic using the “deSolve” package from R. Ideally, we will be able to recover our model parameters using our Bayesian model. This gives us confidence in fitting real data that we observe. This is a key step in the Bayesian workflow where we generate fake data, fit the fake data, and then examine the fit to ensure that we recover the real parameter before we fit our observed data.

seir_model = function (current_timepoint, state_values, parameters)
{
  # create state variables (local variables)
  S = state_values [1]        # susceptibles
  E = state_values [2]        # exposed
  I = state_values [3]        # infectious
  R = state_values [4]        # recovered
  N = state_values [1] + state_values [2] + state_values [3] +state_values [4]
  
  with ( 
    as.list (parameters),     # variable names within parameters can be used 
         {
           # compute derivatives
           dS = (-beta * S * I)/N
           dE = (beta * S * I)/N - (delta * E)
           dI = (delta * E) - (gamma * I)
           dR = (gamma * I)
           
           # combine results
           results = c (dS, dE, dI, dR)
           list (results)
         }
    )
}

beta_value <- 1/3
gamma_value <- 1/10
delta_value <- 1/4

parameter_list <- c (beta = beta_value, gamma = gamma_value, delta = delta_value)
times <- 1:120
initial_values <- c(S= 1000-2, E = 2, I =0, R = 0)
output = lsoda (initial_values, times, seir_model, parameter_list)

matplot(output[,2:5], main = "Observed Epidemic", type = "l", adj =0)

We can extract the daily incidence using the following equation. This represents what would typically be reported by authorities. To make it more realistic, it would be good to convolve the cases with a delay distribution to indicate the lag we observe in case reporting. A deconvolution step could then be written into Stan in order to account for this delay distribution.

cases <-  ceiling(output[,2] - shift(output[,2],-1))
cases <- cases[-length(cases)]

Now let’s calculate our basic reproduction number or $R_0$

beta_value/gamma_value

Build Model in Stan

Now we can build the model in Stan as shown below. Ideally, I would write the ODE solver using the new syntax, but I’ll leave that to next time. We can see that the differential equations have been built into the “sir” function.

mod <- cmdstan_model(file.path("sir.stan"))

mod$print()
$```

### Build Dataset

Now we can prep our dataset for Stan.

``` r
# total count
N <- 1000;

# times
n_days <- length(cases) +1
t <- seq(0, n_days, by = 1)
t0 = 0
t <- t[-1]

#initial conditions
i0 <- 1
e0 <- 0
s0 <- N - i0
r0 <- 0
y0 = c(S = s0, E = e0, I = i0, R = r0)

Run the Model

Then we can run it using CmdStanR.

# number of MCMC steps
niter <- 2000

n_pred <- 21

data_sir<- list(n_days = n_days, 
                        y0 = y0,
                        t0 = t0, ts = t, 
                        N = N, cases = cases,
                        n_pred = n_pred,delta_mu=.2,
                        ts_pred = seq(n_days+1, n_days+n_pred, by = 1)
                        )

fit <- mod$sample(data = data_sir,
$                  adapt_delta = .9,
                  chains = 2, 
                  max_treedepth = 12,
                  parallel_chains = 2,
                  iter_sampling = niter/2,
                  refresh = 0,
                  iter_warmup = niter/2)

fit_sir<- rstan::read_stan_csv(fit$output_files())
$
rstan::extract(fit_sir, "y_pred")->y_pred

str(y_pred)
med_estimates <- colMeans(y_pred[[1]])

Review Model Outputs

Let’s see if we recovered our actual parameters (yes, it appears so)!

pars=c('theta', "R0", "recovery_time")
fit$summary(variables = pars)
$```

## Visualise the Epidemic Curve

Finally, we can visualise our model outputs and see if we capture our
actual cases. Additionally, I am using ggdist to capture the full range
of possibilities as discussed in [in my previous blog
post](https://michaeldewittjr.com/dewitt_blog/posts/2020-08-09-ggdist-and-epidemic-curves/.)

``` r
library(rstan)
library(ggdist)
library(dplyr)

extract(fit_sir, pars = "pred_cases")[[1]] %>%
  as.data.frame() %>%
  mutate(.draw = 1:n()) %>%
  tidyr::gather(key,value, -.draw) %>%
  mutate(step = readr::parse_number(stringr::str_extract(key,"\\d+"))) %>%
  group_by(step) %>%
  curve_interval(value, .width = c(.5, .8, .95)) %>%
  ggplot(aes(x = step, y = value)) +
  geom_hline(yintercept = 1, color = "gray75", linetype = "dashed") +
  geom_lineribbon(aes(ymin = .lower, ymax = .upper)) +
  scale_fill_brewer() +
  labs(
    title = "Simulated SIR Curve for Infections",
    y = "Cases"
  )+
  geom_point(data = tibble(cases = cases, t = 1:length(cases)),
             aes(t, cases), inherit.aes = FALSE, colour = "orange")+
  theme_minimal()

Looks like this model adequately captured our fake data! Part 2 will fit some real data.

@online{dewitt2020,
  author = {Michael E. DeWitt},
  title = {Bayesian SIR},
  date = {2020-08-28},
  url = {https://michaeldewittjr.com/blog/2020-08-28-bayesian-sir/},
  langid = {en}
}
Copy

First, I’ll load the cmstanr package which has become my favourite way to interface with Stan.

library(cmdstanr)

Now we can compile a simple optimization scenario which could be a pretty classic production function where you get 2 dollars for widget x and four dollars for wiget y:

$$\text{optimize } 2$$x + 4y \ \text{subject to:} \ 0\le x \le 10 \ 0\le y \le 20 \

There are also contraints on how many units you can make of each.

m <- cmdstan_model(file.path("optim.stan"))

Now print the code:

writeLines(readLines("optim.stan"))

//Test program for optimization

data{
  
}

parameters{
  real<lower=0,upper=10> x;
  real<lower=0,upper=20> y;
}
model{
  target += 2*x +4*y;
}

Run the model:

fit <- m$sample(refresh = 0)
$```

Summarise the outputs:

``` r
fit$print()
$out <- fit$draws(inc_warmup = FALSE, variables = c("x", "y"))
$out_x <- rowMeans(as.data.frame(out[,,1]))
out_y <- rowMeans(as.data.frame(out[,,2]))

 variable  mean median   sd  mad    q5   q95 rhat ess_bulk ess_tail
     lp__ 94.71  95.06 1.14 0.83 92.35 95.80 1.00     1291     1438
     x     9.48   9.64 0.51 0.36  8.47  9.97 1.00     1771     1099
     y    19.75  19.82 0.24 0.18 19.24 19.99 1.00     1923     1360

Graph the outputs:

op <- par(mfrow = c(1,2))
op
hist(out_x, breaks = 30, main = "Posterior Draws of X", col = "blue")
abline(v = mean(out_x), lwd = 2, col = "red")
hist(out_y, breaks = 30, main = "Posterior Draws of Y", col = "blue")
abline(v = mean(out_y), lwd = 2, col = "red")

Pretty neat that it works.

Alternatively, you could use the optimize function from CmdStan, but this is a bit of a contrite example. More discussion on this is available at this post. Additionally it is important that the target syntax increments the log-density. In our case it doesn’t matter, but in others it might.

A Second Example

Just to play a bit, I want to add some data. Say we have the same function to optimize to maximize revenue, but instead of making any value of x and y, we have some production data with variability. Perhaps these can be real output from our operating process (machines breakdown and life happens, so a higher value might not be reasonable.)

m2 <- cmdstan_model(file.path("optim2.stan"))

Edit 2022-06-02, I realized I didn’t show the code in earlier versions.

writeLines(readLines("optim2.stan"))

//Test program for optimization

data{
  int<lower=1> N; //number of obs
  vector[N] y_in; // observed y
  vector[N] x_in; // observed x
  real<lower=0> sd_y;
  real<lower=0> sd_x;
}

parameters{
  real<lower=0,upper=100> x;
  real<lower=0,upper=200> y;
}
model{
  y_in ~ normal(y, sd_y);
  x_in ~ normal(x, sd_x);
  
  target += 2*x +4*y;
}

dat <- list(
  y_in = rnorm(100, 7, 1.2),
  x_in = rnorm(100, 23, 5),
  sd_x = 5L,
  sd_y = 2L,
  N = 100L
)

fit2 <- m2$sample(data = dat, refresh = 0)
$```

Now we can see the results:

``` r
fit2$print()
$```

     variable  mean median   sd  mad    q5   q95 rhat ess_bulk ess_tail
         lp__ 10.53  10.82 0.95 0.70  8.65 11.45 1.00     1854     2462
         x    23.97  23.97 0.50 0.51 23.16 24.79 1.00     3721     2765
         y     7.20   7.20 0.19 0.19  6.88  7.52 1.00     3569     2629

``` r
out <- fit2$draws(inc_warmup = FALSE, variables = c("x", "y"))
$out_x <- rowMeans(as.data.frame(out[,,1]))
out_y <- rowMeans(as.data.frame(out[,,2]))
op <- par(mfrow = c(1,2))
op
hist(out_x, breaks = 30, main = "Posterior Draws of X", col = "blue")
abline(v = mean(out_x), lwd = 2, col = "red")
hist(out_y, breaks = 30, main = "Posterior Draws of Y", col = "blue")
abline(v = mean(out_y), lwd = 2, col = "red")

The results from the second model represent the influence of the data from our actual manufacturing process. This can be valuable when trying to optimize these kinds of problems when the true data generating process is available to us.

@online{dewitt2020,
  author = {Michael E. DeWitt},
  title = {Optimisation with Stan},
  date = {2020-08-27},
  url = {https://michaeldewittjr.com/blog/2020-08-27-optimisation-with-stan/},
  langid = {en}
}
Copy

There has been a lot written already about this topic, and I certainly won’t add anymore than has already been written. Regardless, I would like to just do some

library(rstan)
library(cmdstanr)
library(ggplot2)
theme_set(theme_minimal())

First, I’ll start with the model from Gelman and Carpenter and make a few tweaks, and then explore the results.

writeLines(readLines("seroprevalence.stan"))

// The input data is a vector 'y' of length 'N'.
data {
  int<lower = 0> y_sample;
  int<lower = 0> n_sample;
  real sensitivity;
  real specificity;
  real sensitivity_sd;
  real specificity_sd;
}

// The parameters accepted by the model. Our model
// accepts two parameters 'mu' and 'sigma'.
parameters {
  real<lower=0, upper = 1> p;
  real<lower=0, upper = 1> spec;
  real<lower=0, upper = 1> sens;
}

// The positivites observed are a function of 
// sensitivity and specificity of test then
// drawn from a bininomial distribution
model {
  real p_sample = p * sens + (1 - p) * (1 - spec);
  y_sample ~ binomial(n_sample, p_sample);
  
  // Use Priors for Sensitivity and Specificity
  // Truncated Normal Because That's What is 
  // Available
  
  spec ~ normal(specificity, specificity_sd);
  sens ~ normal(sensitivity, sensitivity_sd);
  
}

I made a slight tweak in that the sensitivity and specificity mean and variance are set by the user rather than estimating them from data. Most of the time we don’t have data like these in the hospital where we swab someone multiple times and know the ground “truth.” This would be the equivalent of reading these testing stats off of the proverbial box.

We can go ahead and compile our model using cmdstan_model. You’ll note that I am using the cmdstanr package rather than rstan for compiling and sampling from Stan. This decision is intentional…mainly because I chronically have issues with upgrading rstan on every platform. cmstand seeks to ameliorate this by being a thin wrapper to the command line version of stan. It’s an easy switch, but there are a few differences.

mod <- cmdstan_model("seroprevalence.stan")

Wake Forest University Baptist Medical Center is doing a large study for seroprevalence in North Carolina so that is a good place to start.

They list 19,057 study participants, but this is a multi-part study where not all the persons receive a test kit to test for antibodies. The participants receive a daily questionaire for symptoms and SARS-CoV-2 positive contacts (it doesn’t use that language, just Covid-19 but recall that’s the disease and not the virus). Let’s just assume 25% of the participants receive a test kit. Based on their numbers 9% on average (8-10%) have tested positive. This is somewhat inline with existing seroprevalence studies (Stringhini et al. 2020; Pollán et al. 2020; Havers et al. 2020).

Running Through Scenarios

So I looked up the sensitivity and specificity for the antibody test being used in this study (Scanwell) and plugged in those initial values.¹

postitives <- 19057*.09*.25
n <- as.integer(19057*.25)

dat_medium_sensi <- list(
    y_sample = as.integer(postitives),
    n_sample = n,
    sensitivity = .863,
    specificity = .999,
    sensitivity_sd = .01,
    specificity_sd= .01
)

fit_medium_sensi <- mod$sample(data = dat_medium_sensi,chains = 2,
$                  iter_warmup = 500, refresh = 0,
                  iter_sampling = 1000, 
                  adapt_delta = .95)

Running MCMC with 2 chains, at most 4 in parallel...

Chain 1 finished in 0.1 seconds.
Chain 2 finished in 0.1 seconds.

Both chains finished successfully.
Mean chain execution time: 0.1 seconds.
Total execution time: 0.5 seconds.

So let’s see where this gives us:

knitr::kable(fit_medium_sensi$summary("p")[,c("mean", "q5", "q95")], digits = 3)
$```

|  mean |    q5 |   q95 |
|------:|------:|------:|
| 0.096 | 0.081 | 0.108 |

``` r
bayesplot::mcmc_hist(fit_medium_sensi$draws("p"))+
$  labs(
    title = "Posterior Draws for P",
    subtitle = "Seroprevalence"
  )+
  geom_vline(xintercept = .09, lty = "dashed", colour = "red")

Which puts us right in the error range that Wake reported. That’s good.

Now let’s test to see what happens if we losen the test. Let’s say that the sensivity is lower…closer to 65% which some reason (could be that many people have below antibody titers below the lower detection threshold. This means that there would be false negative).

dat_low_sensi <- list(
    y_sample = as.integer(postitives),
    n_sample = n,
    sensitivity = .65,
    specificity = .999,
    sensitivity_sd = .05,
    specificity_sd= .01
)

fit_low_sensi <- mod$sample(data = dat_low_sensi,chains = 2,
$                  iter_warmup = 500, refresh = 0,
                  iter_sampling = 1000, 
                  adapt_delta = .95)

Running MCMC with 2 chains, at most 4 in parallel...

Chain 1 finished in 0.1 seconds.
Chain 2 finished in 0.1 seconds.

Both chains finished successfully.
Mean chain execution time: 0.1 seconds.
Total execution time: 0.3 seconds.

Now we can look at the results:

knitr::kable(fit_low_sensi$summary("p")[,c("mean", "q5", "q95")], digits = 3)
$```

|  mean |    q5 |   q95 |
|------:|------:|------:|
| 0.129 | 0.104 | 0.154 |

Yikes! Here we see that we could be under-estimating prevalence.

``` r
bayesplot::mcmc_hist(fit_low_sensi$draws("p"))+
$  labs(
    title = "Posterior Draws for P",
    subtitle = "Seroprevalence"
  )+
  geom_vline(xintercept = .09, lty = "dashed", colour = "red")

Now maybe another scenario, is that the sensitivity is the same as the “box” value, but there is some additional noise from testing error.

dat_medi_low_sensi <- list(
    y_sample = as.integer(postitives),
    n_sample = n,
    sensitivity = .85,
    specificity = .999,
    sensitivity_sd = .05,
    specificity_sd= .01
)

fit_medi_low_sensi <- mod$sample(data = dat_medi_low_sensi,
$                            chains = 2,
                  iter_warmup = 500, refresh = 0,
                  iter_sampling = 1000, 
                  adapt_delta = .95)

Running MCMC with 2 chains, at most 4 in parallel...

Chain 1 finished in 0.1 seconds.
Chain 2 finished in 0.1 seconds.

Both chains finished successfully.
Mean chain execution time: 0.1 seconds.
Total execution time: 0.1 seconds.

bayesplot::mcmc_hist(fit_medi_low_sensi$draws("p"))+
$  labs(
    title = "Posterior Draws for P",
    subtitle = "Seroprevalence"
  )+
  geom_vline(xintercept = .09, lty = "dashed", colour = "red")

We could still be missing some folks.

Specificity?

Just for completeness, it is worth looking at what happens if specificity degrades. This is generally unlikely in many of these tests (especially the case in PCR tests where if there is viral RNA present, it will grow..e.g. if you have a positive tests you are positive).

dat_low_spec <- list(
    y_sample = as.integer(postitives),
    n_sample = n,
    sensitivity = .85,
    specificity = .90,
    sensitivity_sd = .05,
    specificity_sd= .01
)

fit_low_spec <- mod$sample(data = dat_low_spec,
$                            chains = 2,
                  iter_warmup = 500, refresh = 0,
                  iter_sampling = 1000, 
                  adapt_delta = .95)

Running MCMC with 2 chains, at most 4 in parallel...

Chain 1 finished in 0.1 seconds.
Chain 2 finished in 0.1 seconds.

Both chains finished successfully.
Mean chain execution time: 0.1 seconds.
Total execution time: 0.1 seconds.

bayesplot::mcmc_hist(fit_low_spec$draws("p"))+
$  labs(
    title = "Posterior Draws for P",
    subtitle = "Seroprevalence"
  )+
  geom_vline(xintercept = .09, lty = "dashed", colour = "red")

Yikes! This shows the importance of having high specificity!!!

References

@online{dewitt2020,
  author = {Michael E. DeWitt},
  title = {Sensitivity and Specificity},
  date = {2020-08-09},
  url = {https://michaeldewittjr.com/blog/2020-08-09-sensitivity-and-specificity/},
  langid = {en}
}
Copy

Prep

JuliaCall is a great R package that allows you to call Julia from R.

import Pkg; Pkg.add("Distributions")
import Pkg; Pkg.add("Plots")
import Pkg; Pkg.add("LsqFit")
import Pkg; Pkg.add("PyPlot")

To start, we can take the following Agent Based SIR model from https://raw.githubusercontent.com/epirecipes/sir-julia/master/script/abm/abm.jl which provides a done of great epimodels in a couple of different languages. Regardless, the set-up of this program is very well done. We have agents who can take on one of three states, S, I, R. The probability of an infectious encounter is 5% and agents have an average of 10 contacts per period. The infectious period is 9 days. In theory, if we wanted to add some additional detail we could add a quarantine state and captured the effect of having some portion of agents move to quarantine and no longer transmit. That will be for another day.

using Agents
using Random
using DataFrames
using Distributions
using DrWatson
using StatsPlots
using BenchmarkTools


function rate_to_proportion(r::Float64,t::Float64)
    1-exp(-r*t)
end;


mutable struct Person <: AbstractAgent
    id::Int64
    status::Symbol
end


function init_model(β::Float64,c::Float64,γ::Float64,N::Int64,I0::Int64)
    properties = @dict(β,c,γ)
    model = ABM(Person; properties=properties)
    for i in 1:N
        if i <= I0
            s = :I
        else
            s = :S
        end
        p = Person(i,s)
        p = add_agent!(p,model)
    end
    return model
end;


function agent_step!(agent, model)
    transmit!(agent, model)
    recover!(agent, model)
end;


function transmit!(agent, model)
    # If I'm not susceptible, I return
    agent.status != :S && return
    ncontacts = rand(Poisson(model.properties[:c]))
    for i in 1:ncontacts
        # Choose random individual
        alter = random_agent(model)
        if alter.status == :I && (rand() ≤ model.properties[:β])
            # An infection occurs
            agent.status = :I
            break
        end
    end
end;


function recover!(agent, model)
    agent.status != :I && return
    if rand() ≤ model.properties[:γ]
            agent.status = :R
    end
end;


susceptible(x) = count(i == :S for i in x)
infected(x) = count(i == :I for i in x)
recovered(x) = count(i == :R for i in x);


δt = 0.1
nsteps = 400
tf = nsteps*δt
t = 0:δt:tf;


β = 0.05
c = 10.0*δt
γ = rate_to_proportion(0.11,δt);


N = 1000
I0 = 10;

abm_model = init_model(β,c,γ,N,I0)


to_collect = [(:status, f) for f in (susceptible, infected, recovered)]
abm_data, _ = run!(abm_model, agent_step!, nsteps; adata = to_collect);


abm_data[!,:t] = t;

Looking at a single iteration:

out <- JuliaCall::julia_eval("abm_data")

out %>% 
  ggplot(aes(step, infected_status))+
  geom_line()+
  labs(
    title = "Single Run of Agent Based SIR Model"
  )

Ok, that’s good, but in reality, we want to run the same model many times in order to get a range of possible values. I’ll do this with a simple function. Ideally, we could use glue to make some of the parameters inputs to our function so that we could model the effect of changing the number of contacts from 10 per day to 5 per day which could signify physical distancing.

run_simulation <- function(contacts = 10, contacts_after_int = 5){
  contacts_in <- formatC(contacts, digits = 1)
  contacts_after_int_in <- formatC(contacts_after_int, digits = 1)
julia_script <- glue::glue("
using Agents
using Random
using DataFrames
using Distributions
using DrWatson
using StatsPlots
using BenchmarkTools
function rate_to_proportion(r::Float64,t::Float64)
    1-exp(-r*t)
end;


mutable struct Person <: AbstractAgent
    id::Int64
    status::Symbol
end


function init_model(β::Float64,c::Float64,γ::Float64,N::Int64,I0::Int64)
    properties = @dict(β,c,γ)
    model = ABM(Person; properties=properties)
    for i in 1:N
        if i <= I0
            s = :I
        else
            s = :S
        end
        p = Person(i,s)
        p = add_agent!(p,model)
    end
    return model
end;


function agent_step!(agent, model)
    transmit!(agent, model)
    recover!(agent, model)
end;


function transmit!(agent, model)
    # If I'm not susceptible, I return
    agent.status != :S && return
    ncontacts = rand(Poisson(model.properties[:c]))
    for i in 1:ncontacts
        # Choose random individual
        alter = random_agent(model)
        if alter.status == :I && (rand() ≤ model.properties[:β])
            # An infection occurs
            agent.status = :I
            break
        end
    end
end;


function recover!(agent, model)
    agent.status != :I && return
    if rand() ≤ model.properties[:γ]
            agent.status = :R
    end
end;


susceptible(x) = count(i == :S for i in x)
infected(x) = count(i == :I for i in x)
recovered(x) = count(i == :R for i in x);


δt = 0.1
nsteps = 400
tf = nsteps*δt
t = 0:δt:tf;


β = 0.03
co = δt> 14.0 ? {contacts_in} : {contacts_after_int_in}
c = co*δt
γ = rate_to_proportion(0.11,δt);


N = 1000
I0 = 10;

abm_model = init_model(β,c,γ,N,I0)


to_collect = [(:status, f) for f in (susceptible, infected, recovered)]
abm_data, _ = run!(abm_model, agent_step!, nsteps; adata = to_collect);


abm_data[!,:t] = t;
")
tmp <- tempfile(fileext = ".jl")
cat(julia_script, file = tmp)

julia_source(tmp)
out <- JuliaCall::julia_eval("abm_data")
out
}

Now we can run it a few times with a few different contact rates. Just to make things interesting, I am adding the option to but a before and after contact rate to allow people to simulate different intervention and the effect of waiting.

We have no social distancing, moderate distancing, and severe social distancing.

out_fill_none <- map(1:25, ~run_simulation(contacts = 10, 
                                         contacts_after_int = 10))

out_fill_10 <- map(1:25, ~run_simulation(contacts = 10, 
                                         contacts_after_int = 7))
out_fill_05 <- map(1:25, ~run_simulation(contacts = 10, 
                                         contacts_after_int = 2))

And then we can visualise our outputs (of course using our curve statistics to better capture the range of possibilities).

steps10 <- out_fill_10 %>% 
  bind_rows(.id = ".draws") %>% 
  group_by(step) %>% 
  curve_interval(infected_status, .width = c(.5, .8, .95)) %>% 
  mutate(contact = 7)
steps05 <- out_fill_05 %>% 
  bind_rows(.id = ".draws") %>% 
  group_by(step) %>% 
  curve_interval(infected_status, .width = c(.5, .8, .95)) %>% 
  mutate(contact = 5)
step_none <- out_fill_none %>% 
  bind_rows(.id = ".draws") %>% 
  group_by(step) %>% 
  curve_interval(infected_status, .width = c(.5, .8, .95)) %>% 
  mutate(contact = 10)

steps10 %>% 
  bind_rows(steps05) %>% 
  bind_rows(step_none) %>% 
  ggplot(aes(x = step, y = infected_status, group = contact)) +
  geom_hline(yintercept = 1, color = "gray75", linetype = "dashed") +
  geom_lineribbon(aes(ymin = .lower, ymax = .upper)) +
  scale_fill_brewer() +
  labs(
    title = "Simulated SIR Curve for Infections",
    subtitle = "Using an Agent Based Model",
    y = "Infected Individuals"
  )

It’s amazing but not unsurprising to see the impact of reducing the number of contacts per day on disease transmission.

@online{dewitt2020,
  author = {Michael E. DeWitt},
  title = {julia ABM SIR},
  date = {2020-08-09},
  url = {https://michaeldewittjr.com/blog/2020-08-09-julia-abm-sir/},
  langid = {en}
}
Copy

This little post is based on a recent paper by Juul et al. (2020). For infectious disease modelling we are often running many scenarios through the models. Why? Because there are many parameters to estimate, but very few things that we actually observe (cases by day or incidence) so in some sense our models all suffer from identifiability issues. Additionally, many of the parameters that we do measure have some uncertainty around them. For this reason it is very common to run models with different parameters estimates or distributions in order to understand a range of possible values. A simple way to summarise these models is through point-wise quantiles through time. The genius of Juul’s paper is that this can underestimate many outcomes because it might pick up the beginning of one epidemic curve and miss the peak.

Enter curve estimates. These measures actually look at the curves proper through the trajectory rather than at discrete time points. Here we can rank the entire curve and capture the contribution of the curve rather than the point-wise estimate.

To see this let’s run a simple example from the odin package (FitzJohn 2019). Additionally, the amazing ggdist (Kay 2020) provides an easy way to summarise curves.

sir_model <- system.file("examples/discrete_stochastic_sir_arrays.R", package = "odin")

writeLines(readLines(sir_model))

## Core equations for transitions between compartments:
update(S[]) <- S[i] - n_SI[i]
update(I[]) <- I[i] + n_SI[i] - n_IR[i]
update(R[]) <- R[i] + n_IR[i]

## Individual probabilities of transition:
p_SI[] <- 1 - exp(-beta * I[i] / N[i])
p_IR <- 1 - exp(-gamma)

## Draws from binomial distributions for numbers changing between
## compartments:
n_SI[] <- rbinom(S[i], p_SI[i])
n_IR[] <- rbinom(I[i], p_IR)

## Total population size
N[] <- S[i] + I[i] + R[i]

## Initial states:
initial(S[]) <- S_ini
initial(I[]) <- I_ini
initial(R[]) <- 0

## User defined parameters - default in parentheses:
S_ini <- user(1000)
I_ini <- user(1)
beta <- user(0.2)
gamma <- user(0.1)

## Number of replicates
nsim <- user(100)
dim(N) <- nsim
dim(S) <- nsim
dim(I) <- nsim
dim(R) <- nsim
dim(p_SI) <- nsim
dim(n_SI) <- nsim
dim(n_IR) <- nsim

x <- odin(sir_model)

── R CMD INSTALL ───────────────────────────────────────────────────────────────
* installing *source* package ‘discrete.stochastic.sir.arraysb3edd559’ ...
** using staged installation
** libs
/usr/local/opt/llvm/bin/clang  -I"/Library/Frameworks/R.framework/Versions/4.1/Resources/include" -DNDEBUG   -I/usr/local/include   -fPIC  -Wall -g -O2  -UNDEBUG -Wall -pedantic -g -O0 -c odin.c -o odin.o
In file included from odin.c:2:
In file included from /Library/Frameworks/R.framework/Versions/4.1/Resources/include/R.h:76:
/Library/Frameworks/R.framework/Versions/4.1/Resources/include/R_ext/Memory.h:48:17: warning: a function declaration without a prototype is deprecated in all versions of C [-Wstrict-prototypes]
   48 | int     R_gc_running();
      |                     ^
      |                      void
In file included from odin.c:2:
In file included from /Library/Frameworks/R.framework/Versions/4.1/Resources/include/R.h:78:
/Library/Frameworks/R.framework/Versions/4.1/Resources/include/R_ext/Random.h:61:25: warning: a function declaration without a prototype is deprecated in all versions of C [-Wstrict-prototypes]
   61 | Sampletype R_sample_kind();
      |                         ^
      |                          void
In file included from odin.c:4:
In file included from /Library/Frameworks/R.framework/Versions/4.1/Resources/include/Rinternals.h:51:
/Library/Frameworks/R.framework/Versions/4.1/Resources/include/R_ext/Rdynload.h:38:26: warning: a function declaration without a prototype is deprecated in all versions of C [-Wstrict-prototypes]
   38 | typedef void * (*DL_FUNC)();
      |                          ^
      |                           void
In file included from odin.c:4:
/Library/Frameworks/R.framework/Versions/4.1/Resources/include/Rinternals.h:1228:21: warning: a function declaration without a prototype is deprecated in all versions of C [-Wstrict-prototypes]
 1228 | SEXP R_GetCurrentEnv();
      |                     ^
      |                      void
/Library/Frameworks/R.framework/Versions/4.1/Resources/include/Rinternals.h:1229:26: warning: a function declaration without a prototype is deprecated in all versions of C [-Wstrict-prototypes]
 1229 | const char *R_curErrorBuf();
      |                          ^
      |                           void
/Library/Frameworks/R.framework/Versions/4.1/Resources/include/Rinternals.h:1306:19: warning: a function declaration without a prototype is deprecated in all versions of C [-Wstrict-prototypes]
 1306 | void R_init_altrep();
      |                   ^
      |                    void
/Library/Frameworks/R.framework/Versions/4.1/Resources/include/Rinternals.h:1321:22: warning: a function declaration without a prototype is deprecated in all versions of C [-Wstrict-prototypes]
 1321 | SEXP R_MakeUnwindCont();
      |                      ^
      |                       void
7 warnings generated.
/usr/local/opt/llvm/bin/clang  -I"/Library/Frameworks/R.framework/Versions/4.1/Resources/include" -DNDEBUG   -I/usr/local/include   -fPIC  -Wall -g -O2  -UNDEBUG -Wall -pedantic -g -O0 -c registration.c -o registration.o
In file included from registration.c:1:
In file included from /Library/Frameworks/R.framework/Versions/4.1/Resources/include/R.h:76:
/Library/Frameworks/R.framework/Versions/4.1/Resources/include/R_ext/Memory.h:48:17: warning: a function declaration without a prototype is deprecated in all versions of C [-Wstrict-prototypes]
   48 | int     R_gc_running();
      |                     ^
      |                      void
In file included from registration.c:1:
In file included from /Library/Frameworks/R.framework/Versions/4.1/Resources/include/R.h:78:
/Library/Frameworks/R.framework/Versions/4.1/Resources/include/R_ext/Random.h:61:25: warning: a function declaration without a prototype is deprecated in all versions of C [-Wstrict-prototypes]
   61 | Sampletype R_sample_kind();
      |                         ^
      |                          void
In file included from registration.c:2:
In file included from /Library/Frameworks/R.framework/Versions/4.1/Resources/include/Rinternals.h:51:
/Library/Frameworks/R.framework/Versions/4.1/Resources/include/R_ext/Rdynload.h:38:26: warning: a function declaration without a prototype is deprecated in all versions of C [-Wstrict-prototypes]
   38 | typedef void * (*DL_FUNC)();
      |                          ^
      |                           void
In file included from registration.c:2:
/Library/Frameworks/R.framework/Versions/4.1/Resources/include/Rinternals.h:1228:21: warning: a function declaration without a prototype is deprecated in all versions of C [-Wstrict-prototypes]
 1228 | SEXP R_GetCurrentEnv();
      |                     ^
      |                      void
/Library/Frameworks/R.framework/Versions/4.1/Resources/include/Rinternals.h:1229:26: warning: a function declaration without a prototype is deprecated in all versions of C [-Wstrict-prototypes]
 1229 | const char *R_curErrorBuf();
      |                          ^
      |                           void
/Library/Frameworks/R.framework/Versions/4.1/Resources/include/Rinternals.h:1306:19: warning: a function declaration without a prototype is deprecated in all versions of C [-Wstrict-prototypes]
 1306 | void R_init_altrep();
      |                   ^
      |                    void
/Library/Frameworks/R.framework/Versions/4.1/Resources/include/Rinternals.h:1321:22: warning: a function declaration without a prototype is deprecated in all versions of C [-Wstrict-prototypes]
 1321 | SEXP R_MakeUnwindCont();
      |                      ^
      |                       void
7 warnings generated.
/usr/local/opt/llvm/bin/clang -dynamiclib -Wl,-headerpad_max_install_names -undefined dynamic_lookup -single_module -multiply_defined suppress -L/Library/Frameworks/R.framework/Versions/4.1/Resources/lib -L/usr/local/lib -o discrete.stochastic.sir.arraysb3edd559.so odin.o registration.o -F/Library/Frameworks/R.framework/Versions/4.1 -framework R -Wl,-framework -Wl,CoreFoundation
installing to /private/var/folders/0x/6bnjy4n15kz8nbfbbwbyk3pr0000gn/T/Rtmpo81zqq/devtools_install_12a5098da5a2/00LOCK-file12a5072af16eb/00new/discrete.stochastic.sir.arraysb3edd559/libs
** checking absolute paths in shared objects and dynamic libraries
* DONE (discrete.stochastic.sir.arraysb3edd559)

fit <- x()

sampz <- as.data.frame(fit$run(step = 100))
$```

Now that we have values, a simple analysis would look like the
following:

``` r
val_long <- sampz %>% 
  select(step, contains("I")) %>% 
  tidyr::gather(key, value, -step) %>% 
  mutate(.draw = readr::parse_number(stringr::str_extract(key,"\\d+")))

sumz_point <- val_long %>% 
  group_by(step) %>% 
  summarise(q05 = quantile(value, probs = .05),
            q95 = quantile(value, probs = .95))

val_long %>% 
  ggplot(aes(step, y = value, group = .draw))+
  geom_line(alpha = .2)+
  geom_ribbon(data = sumz_point, 
              aes(x = step, ymin = q05, ymax = q95), 
              inherit.aes = FALSE, fill = "orange", alpha =.2)+
  labs(
    title = "Simulated SIR Curve for Infections"
  )

If we take the curve distribution approach we can see the following

p <- val_long %>% 
  group_by(step) %>%
  curve_interval(value, .width = c(.5, .8, .95)) %>%
  ggplot(aes(x = step, y = value)) +
  geom_hline(yintercept = 1, color = "gray75", linetype = "dashed") +
  geom_lineribbon(aes(ymin = .lower, ymax = .upper)) +
  scale_fill_brewer() +
  labs(
    title = "Simulated SIR Curve for Infections"
  )

p

Now when we lay these ontop of one another, we see the issue with using the time interval method:

p+
  geom_ribbon(data = sumz_point, 
              aes(x = step, ymin = q05, ymax = q95), 
              inherit.aes = FALSE, fill = "orange", alpha =.5)

We see that using the fixed time method we underestimate the peak much of the time! This is very dangerous and important when setting policy and establishing needs.

References

@online{dewitt2020,
  author = {Michael E. DeWitt},
  title = {ggdist and Epidemic Curves},
  date = {2020-08-09},
  url = {https://michaeldewittjr.com/blog/2020-08-09-ggdist-and-epidemic-curves/},
  langid = {en}
}
Copy

Introduction

I just wanted to write up a quick exponential growth model for my county. I have been saddened that the local department of public health has been underestimating the power of exponential growth.

Setting Up the Model

Just using some of the numbers that have been floating around (and cited in some recent literature that when I am not tired I will cite¹) one can quickly simulate possible infections.

To build the model, I am going to take a reproductive rate of 2.28. Additionally, we can add some noise to this estimate in order to simulate 1,000 different scenarios. We know that we have two initial cases (more now as I write), so we’ll take that as $x_0$

So we take the following model:

$$y_{infected}=x_0*(R_0)^t$$ Where:

$$x_0 = \text{initial number of cases}$$ $$R_0 = \text{Reproductive Number}$$ $$t = \text{time period}$$

Additionally, for this simulation we will assume:

$$R_0 \sim N(2.28,.5)$$

The Normal distribution might not be the best probability distribution to assume for this number (here’s where a split or two piece distribution would make sense because we know it might not be much lower but could be much higher.), but it will be a good start at least to get a sign and magnitude feel for the situation.

library(dplyr)
library(ggplot2)
r0 <- rnorm(1000, 2.28,.5)

possibilities <- vector()
for(i in seq_along(r0)){
  possibilities <- cbind(possibilities, 2*r0[i]^(1:28))
}

results <- tibble(
  avg = apply(possibilities, MARGIN = 1, FUN = mean),
  q05 = apply(possibilities, MARGIN = 1, FUN = quantile, probs = .05),
  q95 = apply(possibilities, MARGIN = 1, FUN = quantile, probs = 0.95),
  day = 1:28
  
)



p<- results %>% 
  ggplot(aes(day))+
  geom_pointrange(aes(ymin = q05, y = avg, ymax = q95))+
  geom_hline(yintercept = 380000, lty = "dashed", color = "red")+
  scale_y_log10()+
  scale_x_continuous(breaks = c(1,7,14,21, 28))+
  annotate(geom = "text", x = 5, y = 5000000, size = 3, label = "Forsyth County Population ~380,000")+
  labs(
    title = "Covid-19 Could Spread to Entire County in Less Than Two Weeks",
    subtitle = "Based on 2 initial cases and no containment\nExponential Growth Model 1,000 simulations with normally distributed value of R0 centered at 2.28",
    y = "# Of Infected Persons (Log 10 Scale)",
    x = "Days Since Initial Infection",
    caption = "Data: Zhang, S, Diao M, et al (2020)"
  )

p

Now when we talk about flattening the curve, if we can reduce the reproductive rate mean value from above 2 to one, we can see the following:

r0 <- rnorm(1000, 1,.5)

abatement <- vector()
for(i in seq_along(r0)){
  abatement <- cbind(abatement, 2*r0[i]^(1:28))
}

results_abetment <- tibble(
  avg = apply(abatement, MARGIN = 1, FUN = mean),
  q05 = apply(abatement, MARGIN = 1, FUN = quantile, probs = .05),
  q95 = apply(abatement, MARGIN = 1, FUN = quantile, probs = 0.95),
  day = 1:28
  
)

p+
  geom_pointrange(data = results_abetment,
                  aes(ymin = q05, y = avg, ymax = q95), color = "blue")

This is a much better situation. Regardless, we are still looking at a lot of sick people. The entire county could quite possibly be infected within the month, but at least there is some delay to allow our health system to compensate and put plans into place.

Hospital Capacity

Which really is the main point of it all: massive increases in the sick put huge stress on the hospitals and health care systems in general.

In Forsyth county we have two main hospitals Novant Forsyth (921 registered beds) and Wake Forest Baptist Medical Center (885 registered beds). All in that gives us 1806 beds. In reality, most hospitals operate at 80% capacity be it through staffing decisions (or inability to find nursing, etc) or through protection of surge capacity for just these types of issues.

Flow

For the sake of this simulation let’s assume that about 20% of the staffed beds turn over each day. Additionally, assume that there is some additional admit/discharge capacity. Here I mean how fast can the hospital actually process people (e.g. it takes time to move a patient, find a bed for them, go through the admission process. On the discharge there is some time spend arranging for placement, finding transportation, etc).

Now we can simulate the rough census or volume of patients in the hospital at any given time using the following simulation.

This is a very rough approximation of a hospital operations.

We have:

• Total number of beds
• Total number of staffed beds
• Our flow (generally speaking 20% of the hospital turns over per day)
• Convert flow to an hourly rate (which we will assume is Poisson distributed )
• Processing rate (which we will assume in normally distributed)
• Time horizon, here 28 days

Now we can run the basic simulation.

set.seed(42)
n_beds <- 921 + 885

staffed_beds <- n_beds * 0.8

flow_per_day <- staffed_beds * .2

flow_rate <- flow_per_day/24

intake_outtake_rate <- flow_rate

horizon_t <- 28*24

queue <- vector()
queue[1] <- staffed_beds*.8
for(i in 2:horizon_t){
  admits <- rpois(1, flow_rate)
  discharges <- rnorm(1, intake_outtake_rate, .1*intake_outtake_rate)
  queue[i] <- queue[i-1]+admits-discharges
}

This gives us the following census evolution.

plot(queue, ylim= c(800, 2000), ylab = "Inpatient Census", xlab = "time", main = "Forsyth County: Census Evolution in Normal State")
abline(h=staffed_beds, lty = "dashed", col = "blue")
abline(h=n_beds, lty = "dashed", col = "orange")

Pretty stable, without saturating the system.

Now a Pandemic

Now we can our above pandemic simulation. Let’s also assume that each patient stays for 7 days. This means that we admit patients for seven days before they are discharged.

hospitalization_rate <- .05
covid_discharges <- rep(lag(results$avg, 
$                            n = 7, default = 0)/24, 
                        each = 24)*hospitalization_rate

covid_admissions <- rep(results$avg/24, each = 24)*hospitalization_rate
$
queue_pan <- vector()
queue_pan[1] <- staffed_beds*.8
for(i in 2:horizon_t){
  admits <- rpois(1, flow_rate) + covid_admissions[i]
  discharges <- rnorm(1, intake_outtake_rate, .1*intake_outtake_rate) - covid_discharges[i]
  queue_pan[i] <- queue_pan[i-1]+admits-discharges
}

saturation <- round(which(queue_pan>n_beds)[1]/24)

We can see very quickly that saturates the healthcare system (actually the number patients outnumbers the number of beds available by day 9).

plot(queue_pan, ylim= c(800, 2000), 
     ylab = "Inpatient Census", 
     xlab = "time", 
     main = "Forsyth County: Census Evolution with Pandemic")
abline(h=staffed_beds, lty = "dashed", col = "blue")
abline(h=n_beds, lty = "dashed", col = "orange")

Now here is where it is important to flatten the curve. If we can lower the reproductive rate through the normal pathways: hand washing, social distancing, etc, we can see we will still have an issue:

hospitalization_rate <- .05
covid_discharges <- rep(lag(results_abetment$avg, 
$                            n = 7, default = 0)/24, 
                        each = 24)*hospitalization_rate

covid_admissions <- rep(results_abetment$avg/24, 
$                        each = 24)*hospitalization_rate

queue_pan <- vector()
queue_pan[1] <- staffed_beds*.8
for(i in 2:horizon_t){
  admits <- rpois(1, flow_rate) + covid_admissions[i]
  discharges <- rnorm(1, intake_outtake_rate, .1*intake_outtake_rate) - covid_discharges[i]
  queue_pan[i] <- queue_pan[i-1]+admits-discharges
}

saturation <- round(which(queue_pan>n_beds)[1]/24)

We can see that we still saturate the system by day 14, but at least we have a few more days. In reality, all of these models are approximations and are only realistic for short-term initial dynamics.

plot(queue_pan, ylim= c(800, 2000), 
     ylab = "Inpatient Census", xlab = "time")
abline(h=staffed_beds, lty = "dashed", col = "blue")
abline(h=n_beds, lty = "dashed", col = "orange")

Conclusion

Pandemics are real, and locally we can control our own destiny. We need to be cautious and exercise care when dealing with these kinds of things and do our part to “flatten the curve”.

@online{dewitt2020,
  author = {Michael E. DeWitt},
  title = {Flatten the Curve},
  date = {2020-03-13},
  url = {https://michaeldewittjr.com/blog/2020-03-13-flatten-the-curve/},
  langid = {en}
}
Copy

Like it or not, there are a lot of Windows shops out there. However, many super useful tools are Linux native and don’t really bridge into the Windows world (for good reason). That being said Windows and Microsoft (I think) are acknowledging this gap and have provided the Windows Linux Subsystem as a bridge between these two dominate platforms. This allows us little people to take advantage of some of the high powered tools available.

Special Thanks

This post stands on the back of a lot of really well written articles which I will link to. Additionally, the code here is good as of Feb 2020 so things are always subject to change.

Start with WLS

Assuming you are on a Windows box, you’ll need to enable Windows Linux Subsystem. This will allow you to run a lightweight virtual machine that also has access to your root machine file system if you so choose. The instructions are pretty decent at this link, but here are the high points.

Enable WSL

You need to enable your features via Powershell in administrator mode. If you are on a server or VM, you can do this by adding the features using the usual methods by selecting the additional features.

Enable-WindowsOptionalFeature -Online -FeatureName Microsoft-Windows-Subsystem-Linux

Get the Distro

Now you can download your distribution of choice (I like Ubuntu 18.04). There is some weirdness with some of the versions, so be careful what you choice. For instance when I installed Ubuntu 16LTS I could not upgrade to Python3.6, which I needed, so I had to burn it down and install another.

Invoke-WebRequest -Uri https://aka.ms/wsl-ubuntu-1804 -OutFile Ubuntu.appx -UseBasicParsing
Add-AppxPackage .\Ubuntu.appx

Burn it Down? Huh?

So this is a little aside. Sometimes you mess up and the instal doesn’t go as expected. It is surprisingly hard to remove an old distribution and restart (though some tutorials say that it is). Here is a trick, again in powershell

wslconfig /l

Which will allow you to see what is installed. If you want to reset your distribution, which I had to do, do the following:

wslconfig /u Ubuntu18-04

This will unlist the distribution and you can install it afresh, otherwise it will continue to live on in your system.

Now Start Ubuntu

Assuming your install went ok, now go to the start button (or whatever it is called now) and type “Ubuntu”. You should see the familiar logo. Select it and it will run. You’ll also have to name yourself (which can be anything you want).

As always a good practice it to give your new Ubuntu instance an update and upgrade:

sudo apt updade && sudo apt upgrade

Additionally, and this is important, you want to automount your Windows directories. You can typically access them via /mnt/c/Users..., but a lot of programs don’t like this and won’t run from a mounted drive. because of this you will need to update a configuration file:¹

sudo nano /etc/wsl.conf

Then type the following into the configuration file:

[automount]
root = /
options = "metadata"

Now write out the file CTRL + O, then exit with CTRL + X

Now if you type the following, you should see your C drive listed in the directories:

ls /l

Postgres

Postgres is an open source database, which works great with Airflow and is relatively easy to use. Aiflow will run out of the box on a local sqlite database, but it always seems to get corrupted and have IO errors which are hard to depug.

Installing Postgres

In the Ubuntu terminal type the following to get postgres²

sudo apt-get install postgresql

The user account for postgres is postgres (easy enough to remember)

You’ll need to make a password by the following:

sudo passwd postgres

Then close Ubuntu and open it back up. Type the following to see if the server is running:

sudo service postgresql start

Create a Postgres User and Database

First we’ll create a user for the postgres database. This is how Airflow will connect:

sudo -u postgres createuser airflow
sudo -u postgres createdb airflowdb

Now you want to jump into the postgres database that you started and provide rights and a password to airflow

sudo -u postgres psql

Now in the pqsl area (looks like psql=#)

alter user airflow with encrypted password 'securepassword';
grant all privileges on database airflowdb to airflow ; 
GRANT ALL PRIVILEGES ON ALL TABLES IN SCHEMA public TO airflow;

Now you can hit CTRL + Z and exit the postgres prompt. Congrats, you now have an airflowdb postgres database.

To verify that everything went as expected, again in the command line type:

psql -d airflow

Then in the airflow prompt type:

\conninfo

Note the port that it is serving on (typically 5432, but could be something different for you). Exit out back to the bash terminal.

Config for Postgres

Now, thanks to this post we will update some configuration files so that Airflow and postgres can communicate.

First we need to change the pg_hba.conf file. Note that you may need to change your path depending on what version of postgres you have.

sudo nano /etc/postgresql/10/main/pg_hba.conf

Now that you have that file open, chage the IPv4 connections to as follows:

host all all 0.0.0.0/0 trust

Write out those changes and then exit. Now restart the server with:

sudo service postgresql restart

Now one more configuration file change, this time at:

sudo nano /etc/postgresql/9.5/main/postgresql.conf

Here change the listen_addresses field to look like that below:

listen_addresses = ‘*’ # for Airflow connection

Then restart the server once more:

sudo service postgresql restart

Now Airflow

Wow, we went through a good bit just to get here. Worry not though, almost done.

Change Airflowhome

First we need to make sure that Airflow goes to a real drive on the local machine and not in the WLS. To ensure this happens, I like to add the path to my .bashrc file.

sudo nano ~/.bashrc

Find an empty line and include the line below, changing the “user_name” for whatever username you have. Important here is that you have write access and know that the dags for airflow will be in this case under the AirflowHome directory on your C drive.

export AIRFLOW_HOME=/c/Users/user_name/AirflowHome

Write out this change and then exit with the normal keystrokes. Additionally, source your bashrc file or exit Ubuntu and re open it.

Python?

It is important to make sure that we have a version of Python 3.6 or newer. This ships with Ubuntu 18-04, but worth checking with the following:

python --version

If we don’t have python then we will need to install it with:

sudo apt get python3

If we do have it, we need to verify that we have pip

pip3 --version

If not, install it as above.

Install Airflow (finally)

Now that all the pre-reqs have been accomplished we can install airflow with the following:

pip3 install apache-airflow[postgres, mssql, celery, rabbitmq]

This will install Airflow as well as all the packages that support connecting to postgres, MS Sql and running multiple operators. Depending what packages you have, this might take a bit.

Configuring Airflow

Once everything is installed, we need to update the configuration for airflow to point it to our prefered destinations.

We an do this with:

sudo nano ${AIRFLOW_HOME}/airflow.cfg
$```

(This also tests that our path was successful).

Once there we need to alter two fields.

1.  Update our database to our fancy postgres instance as shown below:

``` markdown
sql_alchemy_conn = postgresql+psycopg2://airflow:secure_password@localhost:5432/airflowdb

2. Change our executor to:

executor = LocalExecutor

In theory we should be able to use the CeleryExecutor, but I wasn’t sucessful with it and didn’t want to fight that anymore.

You should scan through this configuration file to see if everything is correct and if you want to make any changes. For example you might want to change the timezone as the author of this post did

default_timezone = America/New_York

Serving it Up

Now you can exit the configuration file by writing out your changes.

Now you can start serving Airflow with the following:

airflow initdb

Now the database has been initialized. Next step is to start the scheduler:

airflow scheduler

This will start the scheduler (and it might take up the whole window with logs, so just open another instance of Ubunutu).

Then start the webserver:

airflow webserver

Again, this might take another terminal over completely, but don’t worry. If everything worked, you should be able to navigate to localhost:8080 and see your Airflow instance running in your favourite browser.

This will have the default dags loaded by default, so you should see several dags. Turn one of the tutorials one, then manually trigger the DAG to see how it works.

Running A Dag on the Local Machine

The whole prupose of Airflow is to schedule tasks. Ideally, you can use all of your windows credentials, Active Directory, looking at you and manipulate files on shared drives. Here’s where it gets tricky; you will call your Windows host machine to run your tasks in your DAG files.

An Example

I manage my dags through a Git repository. This provides me all the power of version control and lets other users submit PRs with new DAGs. If need to make changes, I just push to my local repository with my new dag or changed dag. Airflow then pulls this repository on a schedule, checks them, and turns any shell scripts into executables.

# -*- coding: utf-8 -*-

from builtins import range
from datetime import timedelta
import airflow
from airflow.models import DAG
from airflow.operators.bash_operator import BashOperator
from airflow.operators.dummy_operator import DummyOperator

args = {
    'owner': 'michael',
    'start_date': airflow.utils.dates.days_ago(2),
}

dag = DAG(
    dag_id='pull_scheduler_updates',
    default_args=args,
    schedule_interval='2 4 * * *',
    dagrun_timeout=timedelta(minutes=20),
)

update_repo = BashOperator(
    task_id='update_repo',
    bash_command='cd /c/Users/mike/AirflowHome; /c/Program\ Files/Git/cmd/git.exe checkout -f; /c/Program\ Files/Git/cmd/git.exe pull origin master; ',
    dag=dag,
)

convert_unix = BashOperator(
    task_id='convert_to_unix',
    bash_command='cd /c/Users/mike/AirflowHome/src; find . -type f -print0 | xargs -0 dos2unix; ',
    dag=dag,
)

make_exec = BashOperator(
    task_id='make_exec',
    bash_command="cd /c/Users/mike/AirflowHome/src; ls -l | awk '{k=0;for(i=0;i<=8;i++)k+=((substr($1,i+2,1)~/[rwx]/) *2^(8-i));if(k)printf(\"%0o \",k);print}'; ",
$    dag=dag,
)

update_repo >>  convert_unix
convert_unix >> make_exec

if __name__ == "__main__":
    dag.cli()

The important part here to note is that I am changing directory to a place on my C drive, then calling Windows Git explicitly from my host system files. This allows my Windows machine to handle this process and not count on Ubuntu WLS to execute these tasks.

Similarly, if I had a shell script that looked like the following:

echo "starting"
echo $(pwd)
$
# Set Location
cd /c/Users/mike/cool_project
/c/Program\ Files/R/R-3.6.1/bin/x64/Rscript.exe really_long_script.R

echo "Done!"

This would allow me to call R directly on the host machine to run my long script. Ideally, I would set common system commands as alias (eg. Rscript = /c/Program Files/R/R-3.6.1/bin/x64/Rscript.exe or something like this). I might go down that road, but not right now (or I will put it at the top of the bash script and have templates).

echo "starting"
echo $(pwd)
$Rscript = /c/Program\ Files/R/R-3.6.1/bin/x64/Rscript.exe
# Set Location
cd /c/Users/mike/cool_project
$(Rscript) really_long_script.R
$
echo "Done!"

Creating variables with the path names is what I have done in Makefiles (because I am old school and love GNUmake). In this way I can still navigate to a directory and issue the make command in the DAG.

Rmarkdown

One thing to consider when dealing with RMarkdown is that you need to explicitly define the path the pandoc when the script is being run by Airflow.

Sys.setenv(RSTUDIO_PANDOC="C:/Program Files/RStudio/bin/pandoc")

This typically my scripts for R being run by Airflow will look like:

echo "starting"
echo $(pwd)
$Rscript = /c/Program\ Files/R/R-3.6.1/bin/x64/Rscript.exe

# Set Location
cd /c/Users/mike/cool_project
$(Rscript) -e 'Sys.setenv(RSTUDIO_PANDOC="C:/Program Files/RStudio/bin/pandoc"); rmarkdown::render("cool_report.Rmd")'
$
echo "Done!"

Issues…

Sometimes Airflow will die or you will submit a bad DAG and get things messed up. Don’t worry, there are plenty of tricks:

1. Reset your database

airflow resetdb

This will clear out and reset your database. For extra reset power, go ahead and use the airflow initdb.

You might need to start the server and the scheduler again as well.

2. Kill orphan processes. I have found that if something fails while Airflow is running a process, it can get hung up and won’t resart correctly.³

When that happens you might need to kill the processes manually, then restart the airflow database, scheulder, and webserver.

ps -aux | grep scheduler

Will list the processes. Scan them and see if anything needs to be killed as shown below.

kill -9 3400

Update DAGs. If you don’t automatically update the DAGs as I have done and are waiting for a new DAG to appear, you can try the following on the bash shell:

python3 -c "from airflow.models import DagBag; d = DagBag();"

Conclusion

Airflow is great and I love it. You will have to learn how to use it with Windows, but the pain is worth it for the convenience and transparency of your job.

@online{dewitt2020,
  author = {Michael E. DeWitt},
  title = {Airflow on Windows Linux Subsystem},
  date = {2020-03-04},
  url = {https://michaeldewittjr.com/blog/2020-03-04-airflow-on-windows-linux-subsystem/},
  langid = {en}
}
Copy

Blog Posts in the Pipeline

I have a few projects that started in 2019 that I need to complete in 2019. As this blog is dedicated mostly to methods (while this site is dedicated to community based projects), I want to re-start by “Stan a Day” program. Last year I tried to implement some kind of algorithm in Stan, or at least work in Stan directly everyday. I had some success (e.g. here), but I would like to pursue this in 2020.

On this site…

I bought a few books that I would like to implement in Stan with some toy data (e.g. Bayesian Cost-Effectiveness Analysis and The Oxford Handbook of Bayesian Econometrics). If I can at least generate a few implementations of some of the models in these books, I’ll be happy.

Another blog post that has yet to be written is a simulation study on method employed on a paper I read. In this paper they used Lasso regression to select for predictors and then fed them into another model and then repeated this process many times. I have already done some simulation studies on this, but I want to write up the results before I give additional details.

On NC Triad Research

I started a community-focused site in 2019. The idea was to do more community salient analysis on one site, leaving this site as somewhat rambly. I think that community focused research and analysis is incredibly powerful, and it would be fun to look at local news and policy with the most advanced analytical tools. Perhaps the analysis can be presented to city council to make local changes, or in the least serve as a resource for others.

I have a few fun blog posts in mind for the site regardless:

• An investigation of the money left on the table from not maximizing Medicaid enrollments. This requires a good bit of data scraping, time series analysis with spatial effects. Regardless of one’s opinion of Medicaid¹, it is “free” money from the government.

• A post on differences in assessed taxes across the different wards in Winston-Salem. There might be nothing there, but on the other hand, then could be something.

• I’ve been gathering data for two years on another topic, so until it’s posted, I’ll keep the last series of blog posts to myself.

Happy 2020 and more to come!

@online{dewitt2020,
  author = {Michael E. DeWitt},
  title = {2020 Plans},
  date = {2020-01-01},
  url = {https://michaeldewittjr.com/blog/2020-01-01-2020-plans/},
  langid = {en}
}
Copy

The Data

Our friends at fivethirtyeight have not publically shared the polls that they have aggregated, so I will use my own aggregations.

suppressPackageStartupMessages(library(tidyverse))
theme_set(theme_minimal())
dat <- read_csv("https://gist.githubusercontent.com/medewitt/74ad210ea8cd3e5870e44a8b3b2e7d64/raw/116273bc73830331bd6b8c1fdd9e48d5ccb8cc8d/impeachment.csv")

base_path <- file.path("posts", "2019-10-08-how-about-impeachment")

Multiple Polls on Multiple Days?

In order to build the data for Stan, it is necessary to make some wide data frame. Additionally, I need to calculate some standard errors. Just a reminder for those at home, the standard error for a binomial distribution is:

$$SE = \sqrt\frac{p(1-p)}{n}$$

As I did last time, I’m also going to use some of the new pivot_* functions from {tidyr}. They are great! These tools bring back some of the functionality that was missing when {tidyr} emerged from {reshape2}. It would probably be better to use the MOE as specified by the pollster to get the true design effect, but just to crank this out, I am not going to do that.

library(lubridate)
dat_range <- crossing(seq(min(dat$date, na.rm = TRUE),
$                 max(mdy("11/1/2019")),
                     "1 day") %>% 
  enframe(name = NULL) %>% 
  set_names("date_range"), pollster = unique(dat$pollster))
$
formatted_data <- dat %>% 
  mutate(my_end = date) %>% 
  select(my_end, approve, n = n, pollster) %>% 
  mutate(polling_var = sqrt(.5 * (1-.5)/n)*100) %>% 
  right_join(dat_range, by = c("my_end" = "date_range", "pollster")) 

formatted_data[is.na(formatted_data)] <- -9

sigma <- formatted_data %>% 
  select(my_end, pollster, polling_var) %>%
  pivot_wider(names_from = pollster, 
              values_from = polling_var,
              values_fn = list(polling_var = max)) %>% 
  select(-my_end) %>% 
  as.matrix()

y <- formatted_data %>% 
  select(my_end, pollster, approve) %>%
  pivot_wider(names_from = pollster, 
              values_from = approve,
              values_fn = list(yes = max)) %>% 
  select(-my_end) %>% 
  as.matrix()

Our Model

This is the same model from this blog post and this one courtsey of James Savage and Peter Ellis.

// Base Syntax from James Savage at https://github.com/khakieconomics/stanecon_short_course/blob/80263f84ebe95be3247e591515ea1ead84f26e3f/03-fun_time_series_models.Rmd
//and modification inspired by Peter Ellis at https://github.com/ellisp/ozfedelect/blob/master/model-2pp/model-2pp.R

data {
  int polls; // number of polls
  int T; // number of days
  matrix[T, polls] Y; // polls
  matrix[T, polls] sigma; // polls standard deviations
  real inflator;         // amount by which to multiply the standard error of polls
  real initial_prior;
  real random_walk_sd;
  real mu_sigma;
}
parameters {
  vector[T] mu; // the mean of the polls
  real<lower = 0> tau; // the standard deviation of the random effects
  matrix[T, polls] shrunken_polls;
}
model {
  // prior on initial difference
  mu[1] ~ normal(initial_prior, mu_sigma);
  tau ~ student_t(4, 0, 5);
  // state model
  for(t in 2:T) {
    mu[t] ~ normal(mu[t-1], random_walk_sd);
  }
  
  // measurement model
  for(t in 1:T) {
    for(p in 1:polls) {
      if(Y[t, p] != -9) {
        Y[t,p]~ normal(shrunken_polls[t, p], sigma[t,p] * inflator);
        shrunken_polls[t, p] ~ normal(mu[t], tau);
      } else {
        shrunken_polls[t, p] ~ normal(0, 1);
      }
    }
  }
}

Prep the Data

Now we can put the data in the proper format for Stan. I’m also going to supply the 2016 voteshare as the initial prior. This is probably a favourable place to start.

library(rstan)
rstan_options(auto_write = TRUE)
options(mc.cores = parallel::detectCores())
approval_data <- list(
  T = nrow(y),
  polls = ncol(sigma),
  Y = y,
  sigma = sigma,
  initial_prior = 40, # Rough dissapproval ratings
  random_walk_sd = 0.2,
  mu_sigma = 1,
  inflator =sqrt(2)
)

Run the Model

Now we can run the model. This might take a little while, but we have relatively sparse data and few instances per pollster, so it is what it is.

getwd()
sstrump <- stan_model(file.path(base_path, "sstrump.stan"))

trump_model <- sampling(sstrump, 
                    data = approval_data, 
                    iter = 2000,
                    refresh = 0,
                    chains = 2,
                    control = list(adapt_delta = .99,
                                     max_treedepth = 15))

Did It Converge?

I’m just going to look quickly at some of the Rhat values. I see that some of my ESS are a little lower than I would like. This isn’t completely surprising given the sparsity of data (57 different polls).

summary(trump_model, pars = "mu")$summary[1:15,]
$```

## Now Let’s see…

Now we can extract the model fit and see how it looks!

``` r
mu_trump <- extract(trump_model, pars = "mu", permuted = T)[[1]] %>% 
  as.data.frame

names(mu_trump) <- unique(dat_range$date_range)
$
mu_ts_trump <- mu_trump %>% reshape2::melt() %>% 
  mutate(date = as.Date(variable)) %>% 
  group_by(date) %>% 
  summarise(median = median(value),
            lower = quantile(value, 0.025),
            upper = quantile(value, 0.975),
            candidate = "Trump")

More to Come

Our model has fairly wide credible intervals, which is to be expected, but the last few point estimates are clear…something is happening. And it looks like something that happened about a week or two has started to move the trend….

mu_ts_trump %>% 
  ggplot(aes(date, median))+
  geom_line(color = "#E91D0E")+
  geom_ribbon(aes(ymin = lower, ymax = upper), alpha = .2)+
  labs(
    title = "Support for Impeachment of President Trump",
    subtitle = "Based on State-Space Modeling\nInitial Prior: 40%",
    caption = "Data: https://github.com/fivethirtyeight/data/tree/master/polls",
    y = "Approval",
    x = NULL
  )+
  geom_vline(xintercept = as.Date(Sys.Date()), color = "orange")+
  geom_point(data = dat, (aes(date, approve)))

@online{dewitt2019,
  author = {Michael E. DeWitt},
  title = {How About Impeachment?},
  date = {2019-10-08},
  url = {https://michaeldewittjr.com/blog/2019-10-08-how-about-impeachment/},
  langid = {en}
}
Copy

The Data

I am going to get some approval polling data from fivethirtyeight. I sincerely appreciate that they put this data out for others to use. Do I wish it had some weights and more data cooked into it? Absolutely. Do I have the resources to do something better? No, I do not. But anyways, thanks fivethirtyeight!

suppressPackageStartupMessages(library(tidyverse))
theme_set(theme_minimal())
dat <- read_csv("https://projects.fivethirtyeight.com/polls-page/president_approval_polls.csv")
base_path <- file.path("posts", "2019-09-26-approval-rating-now")

Multiple Polls on Multiple Days?

In order to build the data for Stan, it is necessary to make some wide data frame. Additionally, I need to calculate some standard errors. Just a reminder for those at home, the standard error for a binomial distribution is:

$$SE = \sqrt\frac{p(1-p)}{n}$$

I’m also going to use some of the new pivot_* functions from {tidyr}. They are great! These tools bring back some of the functionality that was missing when {tidyr} emerged from {reshape2}.

library(lubridate)
dat_range <- crossing(seq(min(mdy(dat$end_date)),
$                 max(mdy("11/1/2019")),
                     "1 day") %>% 
  enframe(name = NULL) %>% 
  set_names("date_range"), pollster = unique(dat$pollster))
$
formatted_data <- dat %>% 
  mutate(my_end = lubridate::mdy(end_date)) %>% 
  select(my_end, yes, sample_size, pollster) %>% 
  mutate(polling_var = sqrt(.5 * (1-.5)/sample_size)*100) %>% 
  right_join(dat_range, by = c("my_end" = "date_range", "pollster")) 

formatted_data[is.na(formatted_data)] <- -9

sigma <- formatted_data %>% 
  select(my_end, pollster, polling_var) %>%
  pivot_wider(names_from = pollster, 
              values_from = polling_var,
              values_fn = list(polling_var = max)) %>% 
  select(-my_end) %>% 
  as.matrix()

y <- formatted_data %>% 
  select(my_end, pollster, yes) %>%
  pivot_wider(names_from = pollster, 
              values_from = yes,
              values_fn = list(yes = max)) %>% 
  select(-my_end) %>% 
  as.matrix()

Our Model

This is the same model from this blog post courtesy of James Savage and Peter Ellis.

// Base Syntax from James Savage at https://github.com/khakieconomics/stanecon_short_course/blob/80263f84ebe95be3247e591515ea1ead84f26e3f/03-fun_time_series_models.Rmd
//and modification inspired by Peter Ellis at https://github.com/ellisp/ozfedelect/blob/master/model-2pp/model-2pp.R

data {
  int polls; // number of polls
  int T; // number of days
  matrix[T, polls] Y; // polls
  matrix[T, polls] sigma; // polls standard deviations
  real inflator;         // amount by which to multiply the standard error of polls
  real initial_prior;
  real random_walk_sd;
  real mu_sigma;
}
parameters {
  vector[T] mu; // the mean of the polls
  real<lower = 0> tau; // the standard deviation of the random effects
  matrix[T, polls] shrunken_polls;
}
model {
  // prior on initial difference
  mu[1] ~ normal(initial_prior, mu_sigma);
  tau ~ student_t(4, 0, 5);
  // state model
  for(t in 2:T) {
    mu[t] ~ normal(mu[t-1], random_walk_sd);
  }
  
  // measurement model
  for(t in 1:T) {
    for(p in 1:polls) {
      if(Y[t, p] != -9) {
        Y[t,p]~ normal(shrunken_polls[t, p], sigma[t,p] * inflator);
        shrunken_polls[t, p] ~ normal(mu[t], tau);
      } else {
        shrunken_polls[t, p] ~ normal(0, 1);
      }
    }
  }
}

Prep the Data

Now we can put the data in the proper format for Stan. I’m also going to supply the 2016 voteshare as the initial prior. This is probably a favourable place to start.

library(rstan)
rstan_options(auto_write = TRUE)
options(mc.cores = parallel::detectCores())
approval_data <- list(
  T = nrow(y),
  polls = ncol(sigma),
  Y = y,
  sigma = sigma,
  initial_prior = 46, # 2016 Election Results
  random_walk_sd = 0.2,
  mu_sigma = 1,
  inflator =sqrt(2)
)

Run the Model

Now we can run the model. Caution, this takes a good while to run…oh how I miss having a cluster….

sstrump <- stan_model(file.path(base_path, "sstrump.stan"))
trump_model <- sampling(sstrump, 
                    data = approval_data, 
                    iter = 1000,
                    refresh = 0,
                    chains = 2,
                    control = list(adapt_delta = .95,
                                     max_treedepth = 15))

Did It Converge?

I’m just going to look quickly at some of the Rhat values. I see that some of my ESS are a little lower than I would like. This isn’t completely surprising given the sparsity of data (57 different polls).

print(trump_model, pars = "mu")

Now Let’s see…

Now we can extract the model fit and see how it looks!

mu_trump <- extract(trump_model, pars = "mu", permuted = T)[[1]] %>% 
  as.data.frame

names(mu_trump) <- unique(dat_range$date_range)
$
mu_ts_trump <- mu_trump %>% reshape2::melt() %>% 
  mutate(date = as.Date(variable)) %>% 
  group_by(date) %>% 
  summarise(median = median(value),
            lower = quantile(value, 0.025),
            upper = quantile(value, 0.975),
            candidate = "Trump")

Partisanship…

Looks like despite a dip in late 2017, Mr. Trump’s approval rating is remarkably stable (as a reminder, it looks like the lowest ever was 25% for President G.W. Bush). It will be curious to see how this changes as more information comes out regarding Mr. Trumps actions with Ukraine.

mu_ts_trump %>% 
  ggplot(aes(date, median))+
  geom_line(color = "#E91D0E")+
  geom_ribbon(aes(ymin = lower, ymax = upper), alpha = .2)+
  labs(
    title = "President Trump's Approval Rating",
    subtitle = "Based on State-Space Modeling\nInitial Prior: 46%",
    caption = "Data: https://github.com/fivethirtyeight/data/tree/master/polls",
    y = "Approval",
    x = NULL
  )+
  geom_vline(xintercept = as.Date(Sys.Date()), color = "orange")

@online{dewitt2019,
  author = {Michael E. DeWitt},
  title = {Approval Rating Now?},
  date = {2019-09-26},
  url = {https://michaeldewittjr.com/blog/2019-09-26-approval-rating-now/},
  langid = {en}
}
Copy

Always Be Integrating Over Your Loss Function

This is a line that I heard and saw from a talk that James Savage at an NYC R Conference¹ in which he discussed the importance of integrating over your loss function. I think that this is an infinitely important topic. Statisticians, myself included, often marvel over the the most parsimonious model with the highest explained variance or best predictive power. Additionally, when it comes to assessment and verifying the impact of an intervention, ensuring that one has accounted for as many of the confounding factors is important for uncovering the LATE or ATE (depending on the context).

However, each of these approaches leaves out of the most important parts of the equation: the practical implications of the error. We live in a world that is messy. People are multitudes and not all things that count can be counted and included in a model. Additionally, we may find that some of our interventions aren’t slam dunks. For example a treatment effect may only be positive only 75% of the time. What does that mean for policy? Should we scrap the program because we didn’t reach the almighty 95% threshold?²

Enter the Loss Function

Loss functions allow us to quantify the cost of doing something. What is lost opportunity for pursuing a given outcome and how does this relate to the value generated by the given intervention.³ While this also takes some time to think through and generate, representing the impact through a loss function is a great exercise.

Bayesian inference provides a great way to marry our loss function with our model of the intervention. With Bayesian inference, we have the wonderful ability to draw from our posterior distribution. These draws represent the distribution around our intervention effect. By evaluating the loss function at these draws we can then generate a distribution of our potential losses. You can then integrate over these losses and see what the net loss would be. If it is favorable, then by definition it is a good approach and one that minimizes loss.

The Advantage

With Bayesian modeling you can introduce subjective knowledge through priors. This allows for powerful modeling in the presence of smaller samples and noiser effects. Additionally, because parameters are interpretted and random values, we can speak in terms of distributions. By drawing from these posteriors and evaluating our loss function, we capture the “many worlds” of the intervention and provide a much clearer picture of the loss.

A Trivial Example

Here I am going to step through a simple example. This is a little trivial, but it will illustrate Bayesian inference, loss function generation, and evaluation.

Data Generating Process

As always we start with a data generating process. Let’s assume that we are measuring the effect of some intervention $\tau$ in the presence of a confounder, $x$ and some response $y$, with normally distributed errors. Mathematically we can write this as:

$$y \sim N(\alpha+\beta_1x_i+\tau, \sigma^2)$$

Generate Fake Data

Now that we have a model for the above DGP, we can generate some fake data in R.

set.seed(42)
n <- 100L # Participants
x <- rnorm(n, 5, 1)
treat <- rep(c(0,1), n/2) # Half Receive 
treat_effect <- 1
beta_1 <- 5
alpha <- 1
y <- rnorm(n, x * beta_1 + treat_effect * treat + alpha)

Now we have our fake data following our DGP above. From the Density we don’t really see too much of a shift.

tibble(x, treat, y) %>% 
  ggplot(aes(y, fill = as.factor(treat)))+
  geom_density(alpha = .2)

Building Our Loss Function

Now we can build our loss function. This is a bit contrite, but it indicates that if the treatment effect is zero or non-zero there is a penalty of 20.

my_loss <- function(x){
  if(x > 1){
    -1/log(x)
  } else if (x >0 ) {
    x
  }else{
    20
  }
}

I always find it is a little easier to graph these things:

loss_vals <- map_dbl(seq(-3,3,.1), my_loss)
plot(seq(-3,3,.1), loss_vals, main = "Loss Function", xlab = "Treatment Effect")

Building The Model in Stan

Now we can build our model in Stan using rstan. I will add a function that will echo the loss function specified above. On each draw it will calculate our loss.

reg_analysis_text <- "
functions{
 /**
 * loss_function
 *
 * @param x a vector of outputed values 
 */
  real loss_function(real x){
    //Build output vector
    real output;
    
      if(x>1)
        output = -1/log(x);
      else if (x > 0 )
        output = x;
      else
        output = 20;
        
    return output;
    }
}

data {
  int<lower=0> N;
  vector[N] x;
  vector[N] status;
  vector[N] y;
}

// The parameters accepted by the model. Our model
// accepts two parameters 'mu' and 'sigma'.
parameters {
  real alpha;
  real beta;
  real treatment;
  real<lower=0> sigma;
}

// The model to be estimated. We model the output
// 'y' to be normally distributed with mean 'mu'
// and standard deviation 'sigma'.
model {
  y ~ normal(alpha + beta * x + treatment * status, sigma);
}

generated quantities{
  real loss = loss_function(treatment);
}
"

writeLines(reg_analysis_text, tmp <- tempfile(fileext = ".stan"))

reg_analysis <- rstan::stan_model(tmp)

Then we can format our data for stan.

stan_dat <- list(
  N = n,
  x = x,
  y = y,
  status = treat
)

And then we can run our model:

fit1 <- sampling(reg_analysis, data = stan_dat, 
                 chains = 2, iter = 1000, refresh = 0)

Here we would normally do some diagnosistics, but we know that we have properly captured the model, so I will skip this step.

Make Our Inferences

Now let’s look at our parameter estimates. Everything looks good and we were able to capture our original parameter values.

print(fit1)

Inference for Stan model: anon_model.
2 chains, each with iter=1000; warmup=500; thin=1; 
post-warmup draws per chain=500, total post-warmup draws=1000.

            mean se_mean    sd   2.5%    25%    50%    75%  97.5% n_eff Rhat
alpha       0.70    0.02  0.48  -0.26   0.39   0.69   1.02   1.65   585 1.01
beta        5.03    0.00  0.09   4.85   4.97   5.03   5.09   5.21   618 1.01
treatment   1.14    0.01  0.18   0.78   1.01   1.13   1.27   1.48   642 1.00
sigma       0.93    0.00  0.07   0.80   0.88   0.92   0.97   1.09   559 1.00
loss      -14.39    2.14 66.72 -77.09  -8.54  -4.34  -2.44   0.99   972 1.00
lp__      -41.31    0.08  1.46 -45.22 -41.98 -41.00 -40.24 -39.45   372 1.01

Now more importantly, lets pull out our treatment effect and loss values:

results <- data.frame(
treat <-fit1 %>% 
  extract("treatment") %>% 
  as.vector(),
loss <- fit1 %>% 
  extract("loss") %>% 
  as.vector()
)

Integrating Over Our Loss Function

Here we can summarise our estimated treatment effect and its associated distribution, recall our loss function, and then examine our loss function evaluated at our values of treatment effect.

par(mfrow = c(1,3))
hist(results$treatment, main = "Histogram of Treatment Effect", col = "grey", breaks = 30)
$plot(seq(-3, 3, .1), loss_vals, main = "Loss Function")
plot(x = results<span class="katex"><span class="katex-mathml"><math xmlns="http://www.w3.org/1998/Math/MathML"><semantics><mrow><mi>t</mi><mi>r</mi><mi>e</mi><mi>a</mi><mi>t</mi><mi>m</mi><mi>e</mi><mi>n</mi><mi>t</mi><mo separator="true">,</mo><mi>y</mi><mo>=</mo><mi>r</mi><mi>e</mi><mi>s</mi><mi>u</mi><mi>l</mi><mi>t</mi><mi>s</mi></mrow><annotation encoding="application/x-tex">treatment, y =  results</annotation></semantics></math></span><span class="katex-html" aria-hidden="true"><span class="base"><span class="strut" style="height:0.8095em;vertical-align:-0.1944em;"></span><span class="mord mathnormal">t</span><span class="mord mathnormal">re</span><span class="mord mathnormal">a</span><span class="mord mathnormal">t</span><span class="mord mathnormal">m</span><span class="mord mathnormal">e</span><span class="mord mathnormal">n</span><span class="mord mathnormal">t</span><span class="mpunct">,</span><span class="mspace" style="margin-right:0.1667em;"></span><span class="mord mathnormal" style="margin-right:0.03588em;">y</span><span class="mspace" style="margin-right:0.2778em;"></span><span class="mrel">=</span><span class="mspace" style="margin-right:0.2778em;"></span></span><span class="base"><span class="strut" style="height:0.6944em;"></span><span class="mord mathnormal">res</span><span class="mord mathnormal">u</span><span class="mord mathnormal">lt</span><span class="mord mathnormal">s</span></span></span></span>loss, main = "Treatment vs Loss")

Finally, we can sum our evaluted loss function and see where we land:

sum(results$loss)
$```

<pre>
[1] -14390.76
</pre>

What does it mean? Based on our loss function and treatment effect, it
has a negative loss. So it is a slam dunk!

[^1]: You can watch the talk
    [here](https://www.youtube.com/watch?v=XX1IWVVpZ7A)

[^2]: Here you can take this as 95% confidence intervals, 95% credible
    intervals, whatever you choose. [Richard
    McElreath](https://xcelab.net/rm/) has some interesting/ funny
    criticisms of vestiges of our digits (literally ten fingers).

[^3]: In the case of prediction problems this could be the penalty for a
    false positive or conversely penalties for false negatives.

@online{dewitt2019,
  author = {Michael E. DeWitt},
  title = {Integrating Over Your Loss Function},
  date = {2019-09-18},
  url = {https://michaeldewittjr.com/blog/2019-09-18-integrating-over-your-loss-function/},
  langid = {en}
}
Copy

With all of the media coverage, I have grown very nostalgic regarding the Apollo space program.¹ It always amazes me to read the stories about the science and engineering that were sparked off by the space race.²

I do not underestimate the courage of the men who strapped themselves on the top of a Saturn V rocket. However, I think that the folks in mission control also deserve their due as well.³ At the end of the day, they were responsible for what happened. IF an error came up on the computer, they had to make the call to go ahead or abort the mission. I heard to day on the amazing “13 Minutes to the Moon” podcast that the average age of the control room was something like 27 years old. Another comment struct me from one of those interviewed:

We didn’t know failure, because we had never done something like this

I think that sentiment is just amazing. Being smart, fearless, and taking responsibility. It is truly an engineering marvel. And as Jerry Bostic, FDO Flight Controller says⁴:

One of their questions was “Weren’t there times when everybody, or at least a few people, just panicked?” My answer was “No, when bad things happened, we just calmly laid out all the options, and failure was not one of them. We never panicked, and we never gave up on finding a solution.”

Why it Matters

This scene from Apollo 13 made me want to study engineering:

The idea of solving a problem, under duress, under a time limit, with people counting on you, just made me say, while I was sitting with my grandmother in the movie theatre, “I want to do that!”.

Each time I watch that scene I am still mesmerized and reinvigorated regarding science and engineering. Really just problem solving. Those moments when there is not option but to “solve the problem.” It’s just magical. You are required to be a team player, to put all of your training and experience together and channel it in a creative way to solve a new problem. It doesn’t get any better than that…at least for an engineer.

How It Relates to Programming

I think that this spirit was also around when people were tackling problems at Bell Labs a little after the space program ended. In a world where memory was expensive and computational power was limited, engineers and scientists at Bell Labs had to get creative. This led to things like UNIX, C, SED, AWK, S, C++, etc…. And still today we use these tools because they are so efficient.⁵

Predating the above tools look at the relevance of FORTRAN today:

Just fantastic stuff.

@online{dewitt2019,
  author = {Michael E. DeWitt},
  title = {Remembering Apollo},
  date = {2019-07-19},
  url = {https://michaeldewittjr.com/blog/2019-07-19-remembering-apollo/},
  langid = {en}
}
Copy

A motivating examples

The Winston-Salem county court house publishes the court calendar roughly once a week. Unfortunately, the file that is made available is a terrible line-printed file. The data are not structured in a nice form, so it requires some parsing if one wants to do any kind of analysis on it.

This becomes especially challenging if you have a lot of data (which in this case I do), with many files over several years. This is a great opportunity to use our friends from AWK to help parse and wrangle these data.

Data Example

Below is a picture of the data file. As you can see there is some repeatability with line spacing, but basically free form text.

head -n 40 court.txt

  RUN DATE: 06/19/19                                                        PAGE   1
                             IN THE GENERAL COURT OF JUSTICE
  LOCATION: WINSTON-SALEM        DISTRICT COURT DIVISION       COUNTY OF FORSYTH

          COURT DATE: 06/24/19        TIME: 09:00 AM        COURTROOM NUMBER: 003C

                  DOMESTIC COURT

                     JUDGE PRESIDING :
                     COURTROOM CLERK :
                     PROSECUTOR      :
                                     :
                                     :
                                     :
                                     :

  NO.  FILE NUMBER DEFENDANT NAME        COMPLAINANT       ATTORNEY               CONT
  *************************************************************************************

     1  18CR 060594 AARON,JOHN,AARON      SLOAN,J        SFF ATTY:GREENWOOD,DYLAN   3
                    BOND:      $2,000 SEC

$ (M)DV PROTECTIVE ORDER VIOL (M) PLEA: VER: CLS:A1 P: L: DOM VL: Y JUDGMENT:

     2  19CR 055098 ADAMO,ALICE,MARY      MOLINA,E       SFF
                   ********  DEFENDANT NEEDS TO BE FINGERPRINTED
                    BOND:             WPA
        (M)SIMPLE ASSAULT                   PLEA:                VER:
        CLS:2  P:   L:      DOM VL: Y   JUDGMENT:




     3  19CR 052889 ANDRADE,TRICIA        NOLAN,CHRISTOP     P.D.:STEWART,LARAQUE   2
                    BOND:      $1,500 UNS

$ (M)MISDEMEANOR STALKING PLEA: VER:

Parsing the Defendant Names

Here I am going to use AWK to use five spaces as the file separator, the pull the first record on each line (here the line with details about the case and the defendant). I then pipe this to another AWK line where I pull out the second, third, and fourth words and tab delineate them. Additionally, I remove any blank lines.

cat court.txt | awk 'BEGIN{ FS = "      "} <span class="katex-error" title="ParseError: KaTeX parse error: Expected &#x27;}&#x27;, got &#x27;EOF&#x27; at end of input: 1 ~ /,/ {print" style="color:#cc0000">1 ~ /,/ {print</span>1}' | 
awk '<span class="katex-error" title="ParseError: KaTeX parse error: Expected &#x27;}&#x27;, got &#x27;EOF&#x27; at end of input: …~ /,/ NF {print" style="color:#cc0000">1 ~ /,/ NF {print</span>2 <span class="katex"><span class="katex-mathml"><math xmlns="http://www.w3.org/1998/Math/MathML"><semantics><mrow><mn>3</mn><mi mathvariant="normal">&quot;</mi><mstyle mathcolor="#cc0000"><mtext>\t</mtext></mstyle><mi mathvariant="normal">&quot;</mi></mrow><annotation encoding="application/x-tex">3 &quot;\t&quot;</annotation></semantics></math></span><span class="katex-html" aria-hidden="true"><span class="base"><span class="strut" style="height:1em;vertical-align:-0.25em;"></span><span class="mord">3&quot;</span><span class="mord text" style="color:#cc0000;"><span class="mord" style="color:#cc0000;">\t</span></span><span class="mord">&quot;</span></span></span></span>4}' |
awk 'NF > 0' > defendants

head defendants

18CR060594  AARON,JOHN,AARON
19CR055098  ADAMO,ALICE,MARY
19CR052889  ANDRADE,TRICIA
19CR055097  BAHLER,MICHELLE,KATHE
19CR053129  CRAFT,SHEILA,RUTH
17CR053102  GADSON,DAQUAN,MONTA
18CR056597  GADSON,DAQUAN,MONTA
18CR051024  GREEN,ALPHONSO,GWANTA
19CR052451  HALL,JOHN,SEBASTIAN
19CR053503  HALL,JOHN,SEBASTIAN

I can then do something similar to parse the complainants.

cat court.txt | awk 'BEGIN{ FS = " "} <span class="katex-error" title="ParseError: KaTeX parse error: Expected &#x27;}&#x27;, got &#x27;EOF&#x27; at end of input: 5 ~ /,/ {print" style="color:#cc0000">5 ~ /,/ {print</span>5}' > complaints 

See below.

head complaints

SLOAN,J
MOLINA,E
NOLAN,CHRISTOP
MOLINA,E
AMMONS,D
WILLIAMS,SHAWK
WILKES,TYEKA,R
DOBSON,KEONA,E
MARSHALL,G
HAMPTON,KAITLY

Now I can read them in and parse them together

@online{dewitt2019,
  author = {Michael E. DeWitt},
  title = {On the use of command line tools},
  date = {2019-06-22},
  url = {https://michaeldewittjr.com/blog/2019-06-22-on-the-use-of-command-line-tools/},
  langid = {en}
}
Copy

               levelName
1  data analysis project
2   ¦--data             
3   ¦--data-raw         
4   ¦--libs             
5   ¦--munge            
6   ¦--src              
7   ¦--outputs          
8   ¦--reports          
9   ¦--README.Rmd       
10  ¦--makefile         
11  °--project.Rproj    

The next logical questions is what is going on in each of these different directories.

data/ data-raw

All analysis projects start with data. Well technically they start with a research question, but the data really are what allow any kind of analysis to continue. In these two folders I will put the raw data (e.g. the data received from someone, or from a data source, scraped from the web, etc). These primary sources will typically go into the the data-raw folder. Any data where manipulations have been done will go into the data folder. These are typically the outputs from the munge operations which will be discussed earlier. I used to be more tyrannical and would only put raw data in the data folder, but I have come to realise that it is nice to have a folder for pure raw data and a folder for the munged data.

libs

This is a folder for the project specific helper functions that you find yourself developing for a project. Perhaps you need a little helper function to clean up information from a website or something for some weird regular expression challenge–here’s where they go.

munge

Munging is as it sounds, where the code you write to ingest and digest the data lies. I typically will number the the files for each step of the operation such that it looks like:

|-munge
|--01-import.R
|--02-clean.R
|--03-matching.R

Or something to this effect. Regardless files 01 and 02 are nearly always present and named as above. Breaking the munging operation into steps also helps with the debugging processes.

src

Our source files are really the analysis files that we run. I try to name these as descriptive as possible with the first section indicating what my output is, the second a number for the order of operations I want it processed, and then something descriptive. For example if I were generating some summary crosstabs, a few figures,and some regressions it might look like the following:

|-src
|--figs-1-summary_choices.R
|--reg-1-salary_vs_voting.R
|--reg-2-education_vs_income.R
|--xtabs-1-overall_participation.R
|--xtabs-2-part_by_demogs.R

Of course this changes by the need, but at least this is my general naming convention.

outputs

This is the folder where outputted figures, fitted models, and summary tables generated during the analysis goes. Ideally anything in this folder could be deleted and could be reproduced from the code found in the above folders.

reports

This one is relatively self explanatory–the final report or series of summary reports goes in this folder. Ideally everything is an Rmd. Here you will also often find a my_bib.bib file which contains the bibtex citations for the bibliography. Also of note that for single summary documents I prefer the bookdown::pdf_document2 engine rather than the standard rmarkdown::pdf_document because the former supports all of the great features available in bookdown including chunk references a la \@ref(tab:my-tab-name).

readme’s

Readme files are incredibly important. They provide the ability to provide long-form comments about the project, about the data sets, about the context of the analysis etc. Anything too long to belong in a comment should be in a readme. Additionally, this is a note to orient others new to the project to your work. Decisions you made about your approach or analysis can be included in here. At a minimum, include one file in the root directory that describes what the origin of the request was, where the data came from, the primary research question, and the overall approach of the project. As needed add readmes to the data-raw folder and others where needed.

makefile

This is one of the most important files in a project and I honestly have not been using it for long. Makefiles have been around a long time, and as all good things do, it came out of Bell Labs.¹ With the makefile you can set a series of targets that allows you to build your entire project with a single command make. Similarly as things change make will look for target items (“targets”) or items that depend on earlier items. If an upstream item changes, all downstream dependencies will be run on the make command. Make can do a ton more, such as clean up all outputs files and allow you to re-run the entire project. It also can run shell commands as specified. Just a generally powerful language. My standard makefile looks like that below:²

# Usually, only these lines need changing
RDIR= .
MUNGEDIR= ./munge
SRCDIR= ./src
REPORTDIR= ./report

# List files for dependencies
MUNGE_RFILES := <span class="katex"><span class="katex-mathml"><math xmlns="http://www.w3.org/1998/Math/MathML"><semantics><mrow><mo stretchy="false">(</mo><mi>w</mi><mi>i</mi><mi>l</mi><mi>d</mi><mi>c</mi><mi>a</mi><mi>r</mi><mi>d</mi></mrow><annotation encoding="application/x-tex">(wildcard</annotation></semantics></math></span><span class="katex-html" aria-hidden="true"><span class="base"><span class="strut" style="height:1em;vertical-align:-0.25em;"></span><span class="mopen">(</span><span class="mord mathnormal" style="margin-right:0.02691em;">w</span><span class="mord mathnormal">i</span><span class="mord mathnormal" style="margin-right:0.01968em;">l</span><span class="mord mathnormal">d</span><span class="mord mathnormal">c</span><span class="mord mathnormal">a</span><span class="mord mathnormal" style="margin-right:0.02778em;">r</span><span class="mord mathnormal">d</span></span></span></span>(MUNGEDIR)/*.R)
SRC_RFILES := <span class="katex"><span class="katex-mathml"><math xmlns="http://www.w3.org/1998/Math/MathML"><semantics><mrow><mo stretchy="false">(</mo><mi>w</mi><mi>i</mi><mi>l</mi><mi>d</mi><mi>c</mi><mi>a</mi><mi>r</mi><mi>d</mi></mrow><annotation encoding="application/x-tex">(wildcard</annotation></semantics></math></span><span class="katex-html" aria-hidden="true"><span class="base"><span class="strut" style="height:1em;vertical-align:-0.25em;"></span><span class="mopen">(</span><span class="mord mathnormal" style="margin-right:0.02691em;">w</span><span class="mord mathnormal">i</span><span class="mord mathnormal" style="margin-right:0.01968em;">l</span><span class="mord mathnormal">d</span><span class="mord mathnormal">c</span><span class="mord mathnormal">a</span><span class="mord mathnormal" style="margin-right:0.02778em;">r</span><span class="mord mathnormal">d</span></span></span></span>(SRCDIR)/*.R)
REPORT_RFILES := <span class="katex"><span class="katex-mathml"><math xmlns="http://www.w3.org/1998/Math/MathML"><semantics><mrow><mo stretchy="false">(</mo><mi>w</mi><mi>i</mi><mi>l</mi><mi>d</mi><mi>c</mi><mi>a</mi><mi>r</mi><mi>d</mi></mrow><annotation encoding="application/x-tex">(wildcard</annotation></semantics></math></span><span class="katex-html" aria-hidden="true"><span class="base"><span class="strut" style="height:1em;vertical-align:-0.25em;"></span><span class="mopen">(</span><span class="mord mathnormal" style="margin-right:0.02691em;">w</span><span class="mord mathnormal">i</span><span class="mord mathnormal" style="margin-right:0.01968em;">l</span><span class="mord mathnormal">d</span><span class="mord mathnormal">c</span><span class="mord mathnormal">a</span><span class="mord mathnormal" style="margin-right:0.02778em;">r</span><span class="mord mathnormal">d</span></span></span></span>(REPORTDIR)/*.Rmd)

# Indicator files to show R file has run
MUNGE_OUT_FILES:= $(MUNGE_RFILES:.R=.Rout)

$ SRC_OUT_FILES:= $(SRC_RFILES:.R=.Rout) $ REPORT_OUT_FILES:= $(REPORT_RFILES:.R=.pdf) $ # Run everything all: $(SRC_OUT_FILES)$(MUNGE_OUT_FILES)

# Run Munging Operation
<span class="katex"><span class="katex-mathml"><math xmlns="http://www.w3.org/1998/Math/MathML"><semantics><mrow><mo stretchy="false">(</mo><mi>M</mi><mi>U</mi><mi>N</mi><mi>G</mi><mi>E</mi><mi>D</mi><mi>I</mi><mi>R</mi><mo stretchy="false">)</mo><mi mathvariant="normal">/</mi></mrow><annotation encoding="application/x-tex">(MUNGEDIR)/%.Rout:</annotation></semantics></math></span><span class="katex-html" aria-hidden="true"><span class="base"><span class="strut" style="height:1em;vertical-align:-0.25em;"></span><span class="mopen">(</span><span class="mord mathnormal" style="margin-right:0.10903em;">M</span><span class="mord mathnormal" style="margin-right:0.10903em;">U</span><span class="mord mathnormal" style="margin-right:0.05764em;">NGE</span><span class="mord mathnormal" style="margin-right:0.02778em;">D</span><span class="mord mathnormal" style="margin-right:0.07847em;">I</span><span class="mord mathnormal" style="margin-right:0.00773em;">R</span><span class="mclose">)</span><span class="mord">/</span></span></span></span>(MUNGEDIR)/%.R
    @echo starting muninging
     R CMD BATCH --vanilla $<

$ @echo finished munging

# Run Analysis Operation
<span class="katex"><span class="katex-mathml"><math xmlns="http://www.w3.org/1998/Math/MathML"><semantics><mrow><mo stretchy="false">(</mo><mi>S</mi><mi>R</mi><mi>C</mi><mi>D</mi><mi>I</mi><mi>R</mi><mo stretchy="false">)</mo><mi mathvariant="normal">/</mi></mrow><annotation encoding="application/x-tex">(SRCDIR)/%.Rout:</annotation></semantics></math></span><span class="katex-html" aria-hidden="true"><span class="base"><span class="strut" style="height:1em;vertical-align:-0.25em;"></span><span class="mopen">(</span><span class="mord mathnormal" style="margin-right:0.07153em;">SRC</span><span class="mord mathnormal" style="margin-right:0.02778em;">D</span><span class="mord mathnormal" style="margin-right:0.07847em;">I</span><span class="mord mathnormal" style="margin-right:0.00773em;">R</span><span class="mclose">)</span><span class="mord">/</span></span></span></span>(SRCDIR)/%.R
    @echo starting analysis
     R CMD BATCH --vanilla $<

$ # Compile Report $(REPORTDIR)/$(REPORTDIR)/%.Rmd @echo compiling report Rscript -e "rmarkdown::render('$<')" $ # Clean up clean: rm -fv $(MUNGE_OUT_FILES) $ rm -fv $(SRC_OUT_FILES) $ rm -fv $(REPORT_OUT_FILES) $ .PHONY: all clean

Of course, this is a general approach, but this is my every evolving attempt to document my approach.

Alternative Approachs

Just to mention a few alternative approachs:

• ProjectTemplate which in many ways inspired my own view on templating projects

• rrtools which structures analysis projects in the form of an R project. It offers some nice components regarding use of continuous integration and allows the default components of R to ensure dependencies are loaded. I might try to integrate this into my own work at some point for these features.

@online{dewitt2019,
  author = {Michael E. DeWitt},
  title = {Defining a Project Workflow},
  date = {2019-06-10},
  url = {https://michaeldewittjr.com/blog/2019-06-10-defining-a-project-workflow/},
  langid = {en}
}
Copy

One of the challenges in any kind of prediction problem is understand the impact of a) not identifying the target and b) the impact of falsely indentifying the target. To put it into context, if you are trying to use an algorithm to indentify those with ebola, whats the risk of missing someone (they could infect others with the disease) vs identifying someone who does not have the disease as having the disease (they get quarantined and have their life disrupted). Which is worse? That isn’t a statistical question, it is a context, and even an ethical question (ok, yes, you could also apply a loss function here and use that to find a global minimum value should it exist, but then again that is a choice).

Typically we use two terms to talk about this problem, sensitivity (of all “targets” how many did the model correctly identify) and specificity (of those who were not targets, what proportion were correctly identified as not a target).

Data Generating Process

As always, I want to build some simulated data to understand this problem. Let’s assume that we are trying to identify methanol levels in moonshine. Moonshine is typically homemade, illicit, high alcohol spirits. The alcohol level is increase through distillation. Ethanol, the desired alcohol boils at something like 78 deg C while methanol boils at 65 deg C. Methanol has some toxic side effects so you really don’t want any in your cocktail. So let’s make some fake data with some measurements.

n <- 500

pot_temp <- rnorm(n, 78, 10)
mash_wt <- rnorm(n, 50, 2)
ambient_temp <- rnorm(n, 30, 7)
ambient_humidity <- rnorm(n, 82, 12)

methanol_content <- ifelse(pot_temp <65, .5 * mash_wt - ambient_humidity*(ambient_humidity)/1000, 
                           .2* mash_wt - ambient_humidity*(ambient_humidity)/1000)

moonshine_data <- tibble(pot_temp,
                         mash_wt,
                         ambient_temp,
                         ambient_humidity,
                         methanol_content)

Let’s also assume that methanol content greater than 17 is toxic (these numbers are completely made up).

moonshine_data <- moonshine_data %>% 
  mutate(toxicity = ifelse(methanol_content > 17, 1,0))

So Let’s see what we have in our data:

moonshine_data %>% 
  count(toxicity) %>% 
  mutate(perc = n/sum(n) )%>%
  mutate(perc = scales::percent(perc)) %>% 
  knitr::kable(booktab = TRUE, col.names = c("Toxicity", "Count", "Percent"),
               caption = "Incidence of Toxicity in Total Data Set")

Incidence of Toxicity in Total Data Set

Yikes! We have a raw case problem. Given our data, what we are targetting doesn’t happen very often. So let’s see what happens when we try to model this:

dat_training <- sample_frac(moonshine_data, .7)
dat_testing <- setdiff(moonshine_data, dat_training)

We could build a very simple binomial regression, but it could guess that every sample will pass and be correct >90% of the time!

dat_training %>% 
  count(toxicity) %>% 
  mutate(perc = n/sum(n) )%>%
  mutate(perc = scales::percent(perc)) %>% 
  knitr::kable(booktab = TRUE, col.names = c("Toxicity", "Count", "Percent"),
               caption = "Incidence of Toxicity in Training Data")

Incidence of Toxicity in Training Data

[1] 0.001554292

Let’s see what our model extracted:

coef(fit_1, s = "lambda.min")

5 x 1 sparse Matrix of class "dgCMatrix"
                          s1
(Intercept)      59.38473176
ambient_humidity -0.14553668
ambient_temp     -0.05737951
mash_wt          -0.06357545
pot_temp         -0.67084896

library(yardstick)

preds_1 <- predict(fit_1, newx = as.matrix(select(dat_testing,
                                     ambient_humidity:pot_temp)), type = "class")

preds_2 <- predict(fit_1, newx = as.matrix(select(dat_testing,
                                     ambient_humidity:pot_temp)), type = "response")

new_dat <- tibble(truth = dat_testing[["toxicity"]], pred = preds_1) %>% 
  mutate_all(factor, label = c("Positive", "Negative"), levels = c(1,0)) %>% 
  bind_cols(num_pred = preds_2[,1])


table(new_dat<span class="katex"><span class="katex-mathml"><math xmlns="http://www.w3.org/1998/Math/MathML"><semantics><mrow><mi>p</mi><mi>r</mi><mi>e</mi><mi>d</mi><mo separator="true">,</mo><mi>n</mi><mi>e</mi><msub><mi>w</mi><mi>d</mi></msub><mi>a</mi><mi>t</mi></mrow><annotation encoding="application/x-tex">pred, new_dat</annotation></semantics></math></span><span class="katex-html" aria-hidden="true"><span class="base"><span class="strut" style="height:0.8889em;vertical-align:-0.1944em;"></span><span class="mord mathnormal">p</span><span class="mord mathnormal">re</span><span class="mord mathnormal">d</span><span class="mpunct">,</span><span class="mspace" style="margin-right:0.1667em;"></span><span class="mord mathnormal">n</span><span class="mord mathnormal">e</span><span class="mord"><span class="mord mathnormal" style="margin-right:0.02691em;">w</span><span class="msupsub"><span class="vlist-t vlist-t2"><span class="vlist-r"><span class="vlist" style="height:0.3361em;"><span style="top:-2.55em;margin-left:-0.0269em;margin-right:0.05em;"><span class="pstrut" style="height:2.7em;"></span><span class="sizing reset-size6 size3 mtight"><span class="mord mathnormal mtight">d</span></span></span></span><span class="vlist-s">​</span></span><span class="vlist-r"><span class="vlist" style="height:0.15em;"><span></span></span></span></span></span></span><span class="mord mathnormal">a</span><span class="mord mathnormal">t</span></span></span></span>truth)

           Positive Negative
  Positive        7        3
  Negative        2      138

metrics(new_dat, truth, pred) %>% 
  bind_rows(sens(new_dat, truth, pred)) %>% 
  bind_rows(spec(new_dat, truth, pred)) %>% 
  knitr::kable(digits = 2, caption = "Estimates from Elastic Net Fit")

Estimates from Elastic Net Fit

So the estimates looks good for sensitivity meaning that the model only correctly identified a little over half of the toxic batches. Is this good enough? Well for a consumer with no knowledge about the potential risk, I don’t think so. The next steps then would be to tune the model to improve the sensitivity in order to reach an acceptable level. This could be as easy as accepting a higher false positive rating. We can look at this with the ROC curve.

roc_curve(new_dat, truth = truth, num_pred) %>% 
  ggplot(aes(1-sensitivity, specificity))+
  geom_line()+
  theme_minimal()

Still not great. So then what do we do? Accept a higher false positive rate? Or now to we build a better model with different data? What if we could inform the brewer about the process parameters that matter. Then we could fix the problem at the source. Perhaps that’s the best bet….

@online{dewitt2019,
  author = {Michael E. DeWitt},
  title = {Finding the Needle in the Haystack},
  date = {2019-06-09},
  url = {https://michaeldewittjr.com/blog/2019-06-09-finding-the-needle-in-the-haystack/},
  langid = {en}
}
Copy

I have always been interested in state space modeling. It is really interesting to see how this modeling strategy works in the realm of opinion polling. Luckily I stumbled across an example that James Savage put together for a workshop series on Econometrics in Stan. Additionally, while I was writing this blog post by happenstance Peter Ellis put out a similar state space Bayesian model for the most recent Australian elections. His forecasts were by far the most accurate out there and predicted the actual results. I wanted to borrow and extend from his work as well.

Collect the Data

This is the original data collection routine from James Savage’s work.

library(tidyverse)
library(rvest)
library(rstan)
library(lubridate)

options(mc.cores = parallel::detectCores())

# The polling data
realclearpolitics_all <- read_html("http://www.realclearpolitics.com/epolls/2016/president/us/general_election_trump_vs_clinton-5491.html#polls")
# Scrape the data
polls <- realclearpolitics_all %>% 
  html_node(xpath = '//*[@id="polling-data-full"]/table') %>% 
  html_table() %>% 
  filter(Poll != "RCP Average")

Develop a helper function.

# Function to convert string dates to actual dates
get_first_date <- function(x){
  last_year <- cumsum(x=="12/22 - 12/23")>0
  dates <- str_split(x, " - ")
  dates <- lapply(1:length(dates), function(x) as.Date(paste0(dates[[x]], 
                                                              ifelse(last_year[x], "/2015", "/2016")), 
                                                       format = "%m/%d/%Y"))
  first_date <- lapply(dates, function(x) x[1]) %>% unlist
  second_date <- lapply(dates, function(x) x[2])%>% unlist
  data_frame(first_date = as.Date(first_date, origin = "1970-01-01"), 
             second_date = as.Date(second_date, origin = "1970-01-01"))
}

Continue cleaning.

# Convert dates to dates, impute MoE for missing polls with average of non-missing, 
# and convert MoE to standard deviation (assuming MoE is the full 95% one sided interval length??)
polls <- polls %>% 
  mutate(start_date = get_first_date(Date)[[1]],
         end_date = get_first_date(Date)[[2]],
         N = as.numeric(gsub("[A-Z]*", "", Sample)),
         MoE = as.numeric(MoE))%>% 
  select(end_date, `Clinton (D)`, `Trump (R)`, MoE) %>% 
  mutate(MoE = ifelse(is.na(MoE), mean(MoE, na.rm = T), MoE),
         sigma = MoE/2) %>% 
  arrange(end_date) %>% 
  filter(!is.na(end_date))

# Stretch out to get missing values for days with no polls
polls3 <- left_join(data_frame(end_date = seq(from = min(polls$end_date), 
$                                              to= as.Date("2016-08-04"), 
                                              by = "day")), polls) %>% 
  group_by(end_date) %>%
  mutate(N = 1:n()) %>%
  rename(Clinton = `Clinton (D)`,
         Trump = `Trump (R)`)

I wanted to extend the data frame with blank values out until closer to the election. This is that step.

polls4 <- polls3 %>% 
  full_join(
    tibble(end_date = seq.Date(min(polls3$end_date), 
$                               as.Date("2016-11-08"), by = 1)))

# One row for each day, one column for each poll on that day, -9 for missing values
Y_clinton <- polls4 %>% reshape2::dcast(end_date ~ N, value.var = "Clinton") %>% 
  dplyr::select(-end_date) %>% 
  as.data.frame %>% as.matrix
Y_clinton[is.na(Y_clinton)] <- -9
Y_trump <- polls4 %>% reshape2::dcast(end_date ~ N, value.var = "Trump") %>% 
  dplyr::select(-end_date) %>% 
  as.data.frame %>% as.matrix
Y_trump[is.na(Y_trump)] <- -9

# Do the same for margin of errors for those polls
sigma <- polls4 %>% reshape2::dcast(end_date ~ N, value.var = "sigma")%>% 
  dplyr::select(-end_date)%>% 
  as.data.frame %>% as.matrix
sigma[is.na(sigma)] <- -9

Our Model

I have modified the model slightly to add the polling inflator that Peter Ellis uses in order to account for error outside of traditional polling error. There is a great deal of literature about this point in the Total Survey Error framework. Basically adding this inflator allows for additional uncertainty to be put into the model.

writeLines(readLines("model.stan"))

// From James Savage at https://github.com/khakieconomics/stanecon_short_course/blob/80263f84ebe95be3247e591515ea1ead84f26e3f/03-fun_time_series_models.Rmd

//and modification inspired by Peter Ellis at https://github.com/ellisp/ozfedelect/blob/master/model-2pp/model-2pp.R

// saved as models/state_space_polls.stan
data {
  int polls; // number of polls
  int T; // number of days
  matrix[T, polls] Y; // polls
  matrix[T, polls] sigma; // polls standard deviations
  real inflator;         // amount by which to multiply the standard error of polls
  real initial_prior;
  real random_walk_sd;
  real mu_sigma;
}
parameters {
  vector[T] mu; // the mean of the polls
  real<lower = 0> tau; // the standard deviation of the random effects
  matrix[T, polls] shrunken_polls;
}
model {
  // prior on initial difference
  mu[1] ~ normal(initial_prior, mu_sigma);
  tau ~ student_t(4, 0, 5);
  // state model
  for(t in 2:T) {
    mu[t] ~ normal(mu[t-1], random_walk_sd);
  }
  
  // measurement model
  for(t in 1:T) {
    for(p in 1:polls) {
      if(Y[t, p] != -9) {
        Y[t,p]~ normal(shrunken_polls[t, p], sigma[t,p] * inflator);
        shrunken_polls[t, p] ~ normal(mu[t], tau);
      } else {
        shrunken_polls[t, p] ~ normal(0, 1);
      }
    }
  }
}

Compile The Model

state_space_model <- stan_model("model.stan")

Prep the Data

clinton_data <- list(
  T = nrow(Y_clinton),
  polls = ncol(Y_clinton),
  Y = Y_clinton,
  sigma = sigma,
  initial_prior = 50,
  random_walk_sd = 0.2,
  mu_sigma = 1,
  inflator =sqrt(2)
)

trump_data <- list(
  T = nrow(Y_trump),
  polls = ncol(Y_trump),
  Y = Y_trump,
  sigma = sigma,
  initial_prior = 40,
  random_walk_sd = 0.2,
  mu_sigma = 1,
  inflator =sqrt(2)
)

Run the Model

clinton_model <- sampling(state_space_model, 
                      data = clinton_data, 
                      iter = 600, 
                      refresh = 0, chains = 2, 
                      control = list(adapt_delta = .95,
                                     max_treedepth = 15))

trump_model <- sampling(state_space_model, 
                    data = trump_data, 
                    iter = 600, 
                    refresh = 0, chains = 2,
                    control = list(adapt_delta = .95,
                                     max_treedepth = 15))

Inferences

# Pull the state vectors
mu_clinton <- extract(clinton_model, pars = "mu", permuted = T)[[1]] %>% 
  as.data.frame
mu_trump <- extract(trump_model, pars = "mu", permuted = T)[[1]] %>% 
  as.data.frame
# Rename to get dates
names(mu_clinton) <- unique(paste0(polls4$end_date))
$names(mu_trump) <- unique(paste0(polls4$end_date))
$```

``` r
# summarise uncertainty for each date
mu_ts_clinton <- mu_clinton %>% reshape2::melt() %>% 
  mutate(date = as.Date(variable)) %>% 
  group_by(date) %>% 
  summarise(median = median(value),
            lower = quantile(value, 0.025),
            upper = quantile(value, 0.975),
            candidate = "Clinton")

mu_ts_trump <- mu_trump %>% reshape2::melt() %>% 
  mutate(date = as.Date(variable)) %>% 
  group_by(date) %>% 
  summarise(median = median(value),
            lower = quantile(value, 0.025),
            upper = quantile(value, 0.975),
            candidate = "Trump")

Which gives us the following:

actual_voteshare <- tibble(date = as.Date("2016-11-08"),
                           value = c(48.2, 46.1),
                           candidate = c("Clinton", "Trump"))

bind_rows(mu_ts_clinton, mu_ts_trump) %>% 
  ggplot(aes(x = date)) +
  geom_ribbon(aes(ymin = lower, ymax = upper, fill = candidate),alpha = 0.1) +
  geom_line(aes(y = median, colour = candidate)) +
  ylim(20, 70) +
  scale_colour_manual(values = c("blue", "red"), "Candidate") +
  scale_fill_manual(values = c("blue", "red"), guide = F) +
  geom_point(data = polls4, aes(x = end_date, y = `Clinton`), size = 0.2, colour = "blue") +
  geom_point(data = polls4, aes(x = end_date, y = Trump), size = 0.2, colour = "red") +
  xlab("Date") +
  ylab("Implied vote share") +
  ggtitle("Poll aggregation with state-space smoothing", 
          subtitle= paste("Prior of 50% initial for Clinton, 40% for Trump on", min(polls4$end_date)))+
$  theme_minimal()+
  geom_point(data = filter(actual_voteshare, candidate == "Clinton"), 
             aes(date, value), colour = "blue", size = 2)+
  geom_point(data = filter(actual_voteshare, candidate == "Trump"), 
             aes(date, value), colour = "red", size = 2)

So the outcome was not totally out of the bounds of a good predictive model!

@online{dewitt2019,
  author = {Michael E. DeWitt},
  title = {State Space Models for Poll Prediction},
  date = {2019-05-18},
  url = {https://michaeldewittjr.com/blog/2019-05-18-state-space-models-for-poll-prediction/},
  langid = {en}
}
Copy

There was a recent bill introduced in the North Carolina General Assembly to reorganise the city counsel by two Republican state members of the General Assembly. The status quo is that there are a total of eight wards, each with a seat on the city counsel. The mayor votes only when there is a tie. As things are, the current city counsel is composed of four Black individuals and four white men, with a white man as mayor. The proposal from the General Assembly is to collapse several of the ward seats into five wards and then create three permanent at-large city counsel positions. Additionally, the mayor would have a vote on all matters, not just in ties.

There is a lot going on here that this post cannot unpack. The biggest issue is truely the political landscape in North Carolina where the Supreme Court of the United States of America is actively hearing a case on gerrymandering where a member of the general assembly admitted to voter packing. Additionally, Winston-Salem has an interesting relationship with racial and political sorting. All of these elements are at play with this new proposed structure. Additionaly, the members whose wards would be collapsed would be the three Black women who are currently on the city counsel. This paired with reducing terms to two hears makes it logistically harder to run campaigns (shorter term lengths mean more campaigning, at-large positions favor people with cash to campaign all over the city, etc). Just a lot happening that can’t be completely unpacked. See here for more details.

Analysis

I am going to take some historical voting records and see given the new ward proposal how the seats would have fallen. Again, this is a quick analysis and more work could defitely be done on this.

library(tidyverse)
library(lubridate)

Current State

proposed_wards <- tribble(
  ~"new_ward", ~"pct_label", ~"current_ward",
  "Ward 1", "032", "",
  "Ward 1", "033", "",
  "Ward 1", "092", "",
  "Ward 1", "101", "",
  "Ward 1", "131", "",
  "Ward 1", "132", "",
  "Ward 1", "201", "",
  "Ward 1", "203", "",
  "Ward 1", "204", "",
  "Ward 1", "205", "",
  "Ward 1", "206", "",
  "Ward 1", "207", "",
  "Ward 1", "801", "",
  "Ward 1", "802", "",
  "Ward 1", "903", "",
  "Ward 1", "904", "",
  "Ward 1", "905", "",
  "Ward 1", "906", "",
  "Ward 1", "907", "",
  "Ward 1", "908", "",
  "Ward 1", "909", "",
  
  "Ward 2", "031", "",
  "Ward 2", "032", "",
  "Ward 2", "033", "",
  "Ward 2", "034", "",
  "Ward 2", "081", "",
  "Ward 2", "082", "",
  "Ward 2", "083", "",
  "Ward 2", "111", "",
  "Ward 2", "201", "",
  "Ward 2", "203", "",
  "Ward 2", "204", "",
  "Ward 2", "206", "",
  "Ward 2", "207", "",
  "Ward 2", "301", "",
  "Ward 2", "302", "",
  "Ward 2", "303", "",
  "Ward 2", "304", "",
  "Ward 2", "305", "",
  "Ward 2", "306", "",
  "Ward 2", "401", "",
  "Ward 2", "402", "",
  "Ward 2", "403", "",
  "Ward 2", "404", "",
  
  "Ward 3", "16", "",
  "Ward 3", "011", "",
  "Ward 3", "012", "",
  "Ward 3", "013", "",
  "Ward 3", "015", "",
  "Ward 3", "042", "",
  "Ward 3", "043", "",
  "Ward 3", "063", "",
  "Ward 3", "082", "",
  "Ward 3", "401", "",
  "Ward 3", "405", "",
  "Ward 3", "501", "",
  "Ward 3", "502", "",
  "Ward 3", "503", "",
  "Ward 3", "504", "",
  "Ward 3", "505", "",
  "Ward 3", "507", "",
  
  "Ward 4", "042", "",
  "Ward 4", "122", "",
  "Ward 4", "506", "",
  "Ward 4", "601", "",
  "Ward 4", "602", "",
  "Ward 4", "603", "",
  "Ward 4", "604", "",
  "Ward 4", "605", "",
  "Ward 4", "606", "",
  "Ward 4", "607", "",
  "Ward 4", "702", "",
  "Ward 4", "703", "",
  "Ward 4", "704", "",
  "Ward 4", "705", "",
  "Ward 4", "709", "",
  
  "Ward 5", "071", "",
  "Ward 5", "072", "",
  "Ward 5", "074", "",
  "Ward 5", "123", "",
  "Ward 5", "131", "",
  "Ward 5", "133", "",
  "Ward 5", "701", "",
  "Ward 5", "705", "",
  "Ward 5", "706", "",
  "Ward 5", "707", "",
  "Ward 5", "708", "",
  "Ward 5", "803", "",
  "Ward 5", "804", "",
  "Ward 5", "805", "",
  "Ward 5", "806", "",
  "Ward 5", "807", "",
  "Ward 5", "808", "",
  "Ward 5", "809", "",
  "Ward 5", "901", "",
  "Ward 5", "902", "",
)

And now because the records of each primary are made public, I will download them and read them in. Excuse the messiness; I imagine there is an easier way to do this, but the NC Board of Elections elected to change their output format between the years, so it is quicker just to read the files in one at a time as there aren’t too many of them. All of the data are available here if you would like to play along.

my_files <- list.files(file.path( 
"data"), full.names = T, pattern = "results_")

Now to read them in, fix a few things and then combine them. I will write a quick helper function though…

clean_ncbe <- function(df){
  df %>% 
  janitor::clean_names() %>% 
  rename(contest_name = contest, 
         choice_party = party) %>% 
  select(county, precinct, contest_name, contest_type, 
         total_votes, choice, choice_party)
}

Now to read them in.¹

results_2010 <- read_csv(my_files[[1]])%>% 
  clean_ncbe()
results_2011 <- read_csv(my_files[[2]])%>% 
  clean_ncbe()
results_2012 <- read_csv(my_files[[2]])%>% 
  clean_ncbe()
z <- lapply( my_files[4:8], function(x) data.table::fread(x, sep = "\t"))

z <- data.table::rbindlist(z, fill =TRUE) %>% 
  janitor::clean_names()

We can then put the data together as follows:

all_results <-bind_rows(results_2010, results_2011, 
                        results_2012, z)

This data frame includes all precinct level reporting for each election. For the sake of this analysis I want to reduce my scope down to just Forsyth County, the home county of Winston-Salem.

forsyth_results <- all_results %>% 
  filter(grepl("FORSYTH",county)) %>% 
  mutate(precinct = str_extract(precinct, "\\d{2,}")) %>% 
  left_join(proposed_wards, by = c("precinct" = "pct_label")) %>% 
  mutate(my_date = lubridate::mdy(election_date),
         election = lubridate::year(my_date))

Upon inspection of the data it is interesting to note that straight party tickets were once allowed. This practice was outlawed by the North Carolina General Assembly in 2013 (Lynch n.d.).

Further, if I just wanted to look look a city counsel elections, the subject of this analysis I could do the following actions.

city_consel_elections <- forsyth_results %>% 
  filter(grepl("WARD", contest_name)) %>% 
  filter(!grepl("HIGH POINT", contest_name))

Just as a reminder the last city counsel elections occured in 2016. Previous legislation moved the city counsel elections to presidential election years. Additionaly, citizens have the option of writing in candidates, so that can explain some of the votes for “others.”

Looking at the overall 2016 city counsel elections we can see the following:

city_consel_elections %>% 
  mutate(choice_party = ifelse(is.na(choice_party), "Other", choice_party)) %>% 
  group_by(election, choice_party) %>% 
  summarise(total_vote = sum(total_votes, na.rm = T)) %>% 
  spread(choice_party, total_vote, 0) %>% 
  mutate(DEM_vote_share = scales::percent(DEM / (DEM + REP + V1))) %>% 
  knitr::kable(caption = "Vote Share Overall, 2016 City Counsel Elections")

So all in all Winston-Salem has a strong lean towards the Democratic Party. Digging deeper we can look at the individual wards.

city_consel_elections %>% 
  mutate(choice_party = ifelse(is.na(choice_party)|choice_party=="", "Other", choice_party)) %>% 
  group_by(election, contest_name, choice_party) %>% 
  summarise(total_vote = sum(total_votes, na.rm = T)) %>% 
  spread(choice_party, total_vote, 0) %>% 
  ungroup() %>% 
  mutate(contest_name = str_remove(contest_name, "WINSTON SALEM CITY COUNCIL - ")) %>% 
  mutate(DEM_vote_share = scales::percent(DEM / (DEM + REP + Other))) %>% 
  knitr::kable(caption = "Vote Share By Ward, 2016 City Counsel Elections")

|election| contest_name| DEM| Other | REP | DEM_vote_share | |2016 |EAST WARD |11673| 204 | 0 | 98.28% | |2016 |NORTH WARD |15454| 209 | 0 | 98.67% | |2016 |NORTHEAST WARD |13276| 397 |0 | 97.10% | |2016 |NORTHWEST WARD |9410| 21 | 5984 | 61.04% | |2016 |SOUTH WARD |9832 |38| 4374 | 69.03% | |2016 |SOUTHEAST WARD| 9044| 184 | 0 98.01% | |2016 |SOUTHWEST WARD| 12008 | 295 | 0| 97.60%| |2016 |WEST WARD| 0 |308 |13302 |0.00%|

We can see pretty easily from this analysis that Winston-Salem is pretty solidly democratic, with the exception of the West ward where not a single vote was cast of a democratic candidate. The only truly competitive districts were the South and Northwest wards which still strongly favoured democratic candidates. However, one of the major take-aways here is that there is evidence of strong population sorting occuring with solidly democratic neighborhoods and solidly republican neighborhoods.

New Proposal

So let’s see how this all plays out under the new proposed wards. If take the 2016 election and group by Wards we see that there still will only be one strong Republican ward, Ward 5. One thing that occludes a stronger take on this is that absentee ballots are not assigned to a precinct.

city_consel_elections %>% 
  mutate(choice_party = ifelse(is.na(choice_party)|choice_party=="", "Other", choice_party)) %>% 
  group_by(election, new_ward, choice_party) %>% 
  summarise(total_vote = sum(total_votes)) %>% 
  spread(choice_party, total_vote) %>% 
  ungroup() %>% 
  mutate(DEM_vote_share = scales::percent(DEM / (DEM + REP + Other))) %>% 
  knitr::kable(caption = "Vote Share By Ward, 2016 City Counsel Elections")

And we can see that while many absentee votes are democratic the margins could say some of the above districts to be more competitive. Because of this it is probably worth looking and historical voting.

city_consel_elections %>% 
  mutate(choice_party = ifelse(is.na(choice_party)|choice_party=="", "Other", choice_party)) %>% 
  group_by(contest_name, choice_party) %>% 
  summarise( total_ab = sum(absentee_by_mail)) %>% 
  mutate(percent = scales::percent(total_ab/sum(total_ab))) %>% 
  mutate(metric = paste0(percent, " n= ", total_ab)) %>% 
  select(-total_ab, -percent) %>% 
  spread(choice_party, metric) %>% 
  knitr::kable(caption = "Breakdown of Absentee Ballots, 2016 City Counsel Elections")

NC Voter History

nc_voter_vistory <- read_tsv("data/ncvhis34.txt")

Additionally, let’s use the 2016 presidential election using the voter history files from the NC Board of Elections here.

nc_voter_vistory %>% 
  left_join(proposed_wards) %>% 
  filter(!is.na(new_ward)) %>% 
  filter(election_desc == "11/08/2016 GENERAL") %>% 
  filter(!is.na(voted_party_desc)) %>% 
  mutate(voted_party_desc = ifelse(voted_party_desc=="LIBERTARIAN",
                                   "REPUBLICAN", voted_party_desc)) %>% 
  group_by(new_ward, voted_party_desc) %>% 
  summarise (n = n()) %>% 
  mutate(vote_share = round(n/sum(n)*100,0)) %>% 
  knitr::kable(caption = "Vote Share By New Ward, 2016 Voters Party Affiliations")

Again, what is interesting here is that all but one of the Wards start with a clearly identified Democratic plurality.

Voter Efficiency

While not the best metric we can look at the efficiency gap. So looking at the current situation we see that there is a:

city_consel_elections %>% 
  mutate(choice_party = ifelse(choice_party %in% c("DEM", "REP"), choice_party,
                               "other")) %>% 
  group_by(election, contest_name, choice_party) %>% 
  summarise(total_vote = sum(total_votes, na.rm = T)) %>% 
  spread(choice_party, total_vote, 0) %>% 
  mutate(winning = (DEM+other+REP)/2+1) %>% 
  rowwise() %>% 
  mutate(DEM_wasted_vote = ifelse(DEM - winning<0,DEM,DEM - winning),
         REP_wasted_vote = ifelse(REP - winning<0,REP,REP - winning)) %>% 
  ungroup() %>% 
  summarise(total_voter= sum(REP+other +DEM),
            wasted_dem = sum(DEM_wasted_vote),
            wasted_rep = sum(REP_wasted_vote)) -> current_eff

scales::percent((current_eff<span class="katex"><span class="katex-mathml"><math xmlns="http://www.w3.org/1998/Math/MathML"><semantics><mrow><mi>w</mi><mi>a</mi><mi>s</mi><mi>t</mi><mi>e</mi><msub><mi>d</mi><mi>r</mi></msub><mi>e</mi><mi>p</mi><mo>−</mo><mi>c</mi><mi>u</mi><mi>r</mi><mi>r</mi><mi>e</mi><mi>n</mi><msub><mi>t</mi><mi>e</mi></msub><mi>f</mi><mi>f</mi></mrow><annotation encoding="application/x-tex">wasted_rep-current_eff</annotation></semantics></math></span><span class="katex-html" aria-hidden="true"><span class="base"><span class="strut" style="height:0.8889em;vertical-align:-0.1944em;"></span><span class="mord mathnormal" style="margin-right:0.02691em;">w</span><span class="mord mathnormal">a</span><span class="mord mathnormal">s</span><span class="mord mathnormal">t</span><span class="mord mathnormal">e</span><span class="mord"><span class="mord mathnormal">d</span><span class="msupsub"><span class="vlist-t vlist-t2"><span class="vlist-r"><span class="vlist" style="height:0.1514em;"><span style="top:-2.55em;margin-left:0em;margin-right:0.05em;"><span class="pstrut" style="height:2.7em;"></span><span class="sizing reset-size6 size3 mtight"><span class="mord mathnormal mtight" style="margin-right:0.02778em;">r</span></span></span></span><span class="vlist-s">​</span></span><span class="vlist-r"><span class="vlist" style="height:0.15em;"><span></span></span></span></span></span></span><span class="mord mathnormal">e</span><span class="mord mathnormal">p</span><span class="mspace" style="margin-right:0.2222em;"></span><span class="mbin">−</span><span class="mspace" style="margin-right:0.2222em;"></span></span><span class="base"><span class="strut" style="height:0.8889em;vertical-align:-0.1944em;"></span><span class="mord mathnormal">c</span><span class="mord mathnormal">u</span><span class="mord mathnormal">rre</span><span class="mord mathnormal">n</span><span class="mord"><span class="mord mathnormal">t</span><span class="msupsub"><span class="vlist-t vlist-t2"><span class="vlist-r"><span class="vlist" style="height:0.1514em;"><span style="top:-2.55em;margin-left:0em;margin-right:0.05em;"><span class="pstrut" style="height:2.7em;"></span><span class="sizing reset-size6 size3 mtight"><span class="mord mathnormal mtight">e</span></span></span></span><span class="vlist-s">​</span></span><span class="vlist-r"><span class="vlist" style="height:0.15em;"><span></span></span></span></span></span></span><span class="mord mathnormal" style="margin-right:0.10764em;">ff</span></span></span></span>wasted_dem)/current_eff$total_voter)
$```

<pre>
"-17%"
</pre>

And if we move to the proposed organization we see:

``` r
forsyth_results %>% 
  filter(!is.na(new_ward)) %>% 
  filter(grepl(x = contest_name, "PRESIDENT")) %>% 
  mutate(choice_party = ifelse(choice_party %in% c("DEM", "REP"), choice_party,
                               "other")) %>% 
  group_by(election, new_ward, choice_party) %>% 
  summarise(total = sum(total_votes)) %>% 
  ungroup() %>% 
  spread(choice_party, total) %>% 
  mutate(election = ifelse(is.na(election), 2012, election)) %>% 
  mutate(DEM_share = DEM/ (DEM+other+REP)) %>% 
  mutate(winning = (DEM+other+REP)/2+1) %>% 
  rowwise() %>% 
  mutate(DEM_wasted_vote = ifelse(DEM - winning<0,DEM,DEM - winning),
         REP_wasted_vote = ifelse(REP - winning<0,REP,REP - winning)) %>% 
    ungroup() %>% 
  summarise(total_voter= sum(REP+other +DEM),
            wasted_dem = sum(DEM_wasted_vote),
            wasted_rep = sum(REP_wasted_vote))->efficiency

scales::percent((efficiency<span class="katex"><span class="katex-mathml"><math xmlns="http://www.w3.org/1998/Math/MathML"><semantics><mrow><mi>w</mi><mi>a</mi><mi>s</mi><mi>t</mi><mi>e</mi><msub><mi>d</mi><mi>r</mi></msub><mi>e</mi><mi>p</mi><mo>−</mo><mi>e</mi><mi>f</mi><mi>f</mi><mi>i</mi><mi>c</mi><mi>i</mi><mi>e</mi><mi>n</mi><mi>c</mi><mi>y</mi></mrow><annotation encoding="application/x-tex">wasted_rep-efficiency</annotation></semantics></math></span><span class="katex-html" aria-hidden="true"><span class="base"><span class="strut" style="height:0.8889em;vertical-align:-0.1944em;"></span><span class="mord mathnormal" style="margin-right:0.02691em;">w</span><span class="mord mathnormal">a</span><span class="mord mathnormal">s</span><span class="mord mathnormal">t</span><span class="mord mathnormal">e</span><span class="mord"><span class="mord mathnormal">d</span><span class="msupsub"><span class="vlist-t vlist-t2"><span class="vlist-r"><span class="vlist" style="height:0.1514em;"><span style="top:-2.55em;margin-left:0em;margin-right:0.05em;"><span class="pstrut" style="height:2.7em;"></span><span class="sizing reset-size6 size3 mtight"><span class="mord mathnormal mtight" style="margin-right:0.02778em;">r</span></span></span></span><span class="vlist-s">​</span></span><span class="vlist-r"><span class="vlist" style="height:0.15em;"><span></span></span></span></span></span></span><span class="mord mathnormal">e</span><span class="mord mathnormal">p</span><span class="mspace" style="margin-right:0.2222em;"></span><span class="mbin">−</span><span class="mspace" style="margin-right:0.2222em;"></span></span><span class="base"><span class="strut" style="height:0.8889em;vertical-align:-0.1944em;"></span><span class="mord mathnormal">e</span><span class="mord mathnormal" style="margin-right:0.10764em;">ff</span><span class="mord mathnormal">i</span><span class="mord mathnormal">c</span><span class="mord mathnormal">i</span><span class="mord mathnormal">e</span><span class="mord mathnormal">n</span><span class="mord mathnormal" style="margin-right:0.03588em;">cy</span></span></span></span>wasted_dem)/efficiency$total_voter)
$```

<pre>

“16%” \</pre?\>

So no real change in the efficiency gap.

<div id="refs" class="references csl-bib-body hanging-indent"
entry-spacing="0">

<div id="ref-lynch_elimination_nodate" class="csl-entry">

Lynch, Harry. n.d. “Elimination of Straight-Ticket Voting Could Leave
More Ballots Incomplete.” *Newsobserver*. Accessed April 8, 2019.
<https://www.newsobserver.com/news/politics-government/election/article95286262.html>.

</div>

</div>

[^1]: Reall what I should be doing here is writing a function that
    inspects what kind of delimiter is being used in the file and then
    import accordingly. However, I’m a bit lazy at the moment and not
    going to do that. The plus sides for doing that method is most
    importantly it is more reprocible and scalable should I go back and
    look at previous data. Additionally, I could do a `map` function to
    read and apply the newly written function rather than writing
    piecemeal as I am now.

@online{dewitt2019,
  author = {Michael E. DeWitt},
  title = {Re-districting in Winston-Salem},
  date = {2019-04-08},
  url = {https://michaeldewittjr.com/blog/2019-04-08-re-districting-in-winston-salem/},
  langid = {en}
}
Copy

One important concept to discuss is that of omited variable bias. This occurs when you have endogenous predictors that you do not adequately control for in your analysis.

Fake Data Simulation

As with all analysis it is best to begin with a fake data simulation in order to build intuition about the problem. In this example suppose that we have some relationship that we would like to test where X predicts Y. Additionally, let’s suppose that there is some variable that affects by X and Y called Z.

library(DiagrammeR)

grViz("
digraph boxes_and_circles {

  # a 'graph' statement
  graph [overlap = true, fontsize = 10]

  # several 'node' statements
  node [shape = box,
        fontname = Helvetica]
  U; X; Y; Z;

  node [shape = circle,
        fixedsize = true,
        width = 0.9] // sets as circles
  U; X; Y; Z;

  # several 'edge' statements
  U->X X->Y Z->Y Z->X
}
")

Create the Fake Data

n <- 1000

U <- rnorm(n, 5, 1)

Z <- rnorm(n, 1, 1)

X <- rnorm( n, U + 1* Z, 1)

Y <- rnorm(n ,X + 1*Z, 1)

Let’s inspect out data and see what kind of relationship we would expect:

plot(X, Y)

So if we were to do a naive linear regression of X on Y we would get the following results:

fit1 <- lm(Y ~ X)

arm::display(fit1)

lm(formula = Y ~ X)
            coef.est coef.se
(Intercept) -1.17     0.14  
X            1.36     0.02  
---
n = 1000, k = 2
residual sd = 1.28, R-Squared = 0.78

It’s a pretty good fit, but let’s look at when we include our omitted variable.

fit2 <- lm(Y ~ X + Z)
arm::display(fit2)

lm(formula = Y ~ X + Z)
            coef.est coef.se
(Intercept) -0.05     0.12  
X            1.00     0.02  
Z            1.04     0.04  
---
n = 1000, k = 3
residual sd = 0.99, R-Squared = 0.87

So here we see that when we include our omitted variable our R² increases and our coefficient estimates change slightly, though the biggest change is a shrinking of our standard errors.

All this to say that it is good to inspect for omitted variable and more importantly to do the fake data simulations to see how sensitive your model is to them.

@online{dewitt2019,
  author = {Michael E. DeWitt},
  title = {Omitted Variable Bias},
  date = {2019-04-07},
  url = {https://michaeldewittjr.com/blog/2019-04-07-omitted-variable-bias/},
  langid = {en}
}
Copy

I recently got a question about using MRP and I thought it would be worthwhile to share some of the additional explanation of using this approach with a simulated data set. Simulating your data and testing your method is a really good way to understand if your model is sensitive enough to detect differences. This kind of fake data simulation will allow you to see if your model fails, before using it production or in the field where the cost of failure is high.

Population Data

I’m going to generate some synthetic data for this example. This will represent our population and provide a benchmark for “truth.” The data are completely made up and don’t represent anything in particular.

These data represent a population of 1 million persons, of binary gender, four different races, living in the US. Again, the proportions are made up.

library(tidyverse)
set.seed(336)
n <- 1e6

gender <- sample(c("Female", "Male"), n, replace = TRUE, prob = c(.5,.5))

race <- sample(c("Asian", "Black", "Hispanic", "White"), 
               n, replace = TRUE, prob = c(.1, .2, .3, .4))

state <- sample(state.abb, n, replace = T)

Let’s imagine that each person has a probability , $\theta$ of supporting a given opinion. Again, let’s suppose that the probability of support is partially determined by some combination of gender, race, location, and of course some random noise.

base_prob <- ifelse(gender=="Female", .7, .3)
base_prob <- ifelse(race=="Asian", base_prob-.1, base_prob)
base_prob <- ifelse(state %in% c("SC", "NC", "GA", "TX", "FL"), 
                    base_prob-.1, base_prob)
base_prob <- base_prob + rnorm(n, 0, .01)
true_opinion <- rbinom(n, 1, base_prob)

population_data <-tibble(
    gender = gender,
    race = race,
    state = state,
    true_opinion = true_opinion
  ) %>% 
  left_join(tibble(state.abb, division = state.division), by = c("state" = "state.abb"))

Now I’m going to draw my sample for my analysis. This would represent a completely random sample of my population.

survey <- sample_n(population_data, 500)

Multi-Level Regression

Now we can step into the first component of MRP, the multi-level or hierarchical regression modeling. Here based on literature and inference that race, gender, state, and census division may be important, or help me make inference on the probability of supporting the given option. Additionally, I will use partial pooling to help make inferences for some of the small cell sizes that exist in my survey. I can build that given equation using brms.

library(brms)

my_equation <- bf(true_opinion ~ (1 | race * gender) + (1 | state) + (1 | division))

Now to see what priors I have to set. This step is important as building the above model with lots of variables may have difficulty converging.

get_prior(my_equation, data = survey)

                prior     class      coef       group resp dpar nlpar lb ub
 student_t(3, 0, 2.5) Intercept                                            
 student_t(3, 0, 2.5)        sd                                        0   
 student_t(3, 0, 2.5)        sd              division                  0   
 student_t(3, 0, 2.5)        sd Intercept    division                  0   
 student_t(3, 0, 2.5)        sd                gender                  0   
 student_t(3, 0, 2.5)        sd Intercept      gender                  0   
 student_t(3, 0, 2.5)        sd                  race                  0   
 student_t(3, 0, 2.5)        sd Intercept        race                  0   
 student_t(3, 0, 2.5)        sd           race:gender                  0   
 student_t(3, 0, 2.5)        sd Intercept race:gender                  0   
 student_t(3, 0, 2.5)        sd                 state                  0   
 student_t(3, 0, 2.5)        sd Intercept       state                  0   
 student_t(3, 0, 2.5)     sigma                                        0   
       source
      default
      default
 (vectorized)
 (vectorized)
 (vectorized)
 (vectorized)
 (vectorized)
 (vectorized)
 (vectorized)
 (vectorized)
 (vectorized)
 (vectorized)
      default

Now I can set my priors for the different coefficients in my model.

my_priors <- c(
      set_prior("normal(0,0.2)", class = "sd", group = "race:gender"),
      set_prior("normal(0,0.2)", class = "sd", group = "race"),
      set_prior("normal(0,0.2)", class = "sd", group = "gender"),
      set_prior("normal(0,0.2)", class = "sd", group = "state"),
      set_prior("normal(0,0.2)", class = "sd", group = "division")
    )

Now we can run the model in brms.

fit <- brm(my_equation, survey, prior = my_priors, 
           chains = 2, iter = 1000, cores = 2, family = bernoulli(),
           silent = TRUE, backend = "cmdstan")

Running MCMC with 2 parallel chains...

Chain 1 Iteration:   1 / 1000 [  0%]  (Warmup) 
Chain 2 Iteration:   1 / 1000 [  0%]  (Warmup) 
Chain 1 Iteration: 100 / 1000 [ 10%]  (Warmup) 
Chain 2 Iteration: 100 / 1000 [ 10%]  (Warmup) 
Chain 1 Iteration: 200 / 1000 [ 20%]  (Warmup) 
Chain 2 Iteration: 200 / 1000 [ 20%]  (Warmup) 
Chain 2 Iteration: 300 / 1000 [ 30%]  (Warmup) 
Chain 1 Iteration: 300 / 1000 [ 30%]  (Warmup) 
Chain 2 Iteration: 400 / 1000 [ 40%]  (Warmup) 
Chain 1 Iteration: 400 / 1000 [ 40%]  (Warmup) 
Chain 2 Iteration: 500 / 1000 [ 50%]  (Warmup) 
Chain 2 Iteration: 501 / 1000 [ 50%]  (Sampling) 
Chain 1 Iteration: 500 / 1000 [ 50%]  (Warmup) 
Chain 1 Iteration: 501 / 1000 [ 50%]  (Sampling) 
Chain 2 Iteration: 600 / 1000 [ 60%]  (Sampling) 
Chain 1 Iteration: 600 / 1000 [ 60%]  (Sampling) 
Chain 2 Iteration: 700 / 1000 [ 70%]  (Sampling) 
Chain 1 Iteration: 700 / 1000 [ 70%]  (Sampling) 
Chain 2 Iteration: 800 / 1000 [ 80%]  (Sampling) 
Chain 1 Iteration: 800 / 1000 [ 80%]  (Sampling) 
Chain 2 Iteration: 900 / 1000 [ 90%]  (Sampling) 
Chain 2 Iteration: 1000 / 1000 [100%]  (Sampling) 
Chain 2 finished in 2.6 seconds.
Chain 1 Iteration: 900 / 1000 [ 90%]  (Sampling) 
Chain 1 Iteration: 1000 / 1000 [100%]  (Sampling) 
Chain 1 finished in 2.9 seconds.

Both chains finished successfully.
Mean chain execution time: 2.7 seconds.
Total execution time: 3.1 seconds.

Now we can visualise the outputs.

library(tidybayes)

fit %>%
  gather_draws(`sd_.*`, regex=TRUE) %>%
  ungroup() %>%
  mutate(group = stringr::str_replace_all(.variable, c("sd_" = "","__Intercept"=""))) %>%
  ggplot(aes(y=group, x = .value)) + 
  ggridges::geom_density_ridges(aes(height=..density..),
                                rel_min_height = 0.01, stat = "density",
                                scale=1.5)

Additionally, we should do some additional posterior checks which includes checking our Rhat values for convervenges and our effective sample size. Additionally, some posterior predictive checks would also be helpful to ensure that our model is performing well. I won’t do that here, but it is a good practice to do those things.

We can also check some of the intercepts to see if the model detected some of the changes that we introduced.

library(bayesplot)
posterior <- as.matrix(fit)

mcmc_areas(posterior,
           pars = c("r_race[Asian,Intercept]",
                    "r_gender[Female,Intercept]",
                    "r_state[SC,Intercept]"),
           prob = 0.8) 

It looks like the model picked up the gender differences as well as the specific difference for Asians. However, it looks like the model did not do a great job discriminating on differences for South Carolina. We could explore this further, but it is important to check that our model is performing as expected.

Create the Census Data

Now we step into the post-stratification step. Here we have the population values from our fake data. In reality you would probably use estimates from a census. Here we are interested in predicting state level opinion, so we we want to stratify at that level. If we wanted to make inferences about a different level we would stratify to that given level. I’m going to do both state level overall and race within state for this example.

head(
  post_strat_values <- population_data %>%
    group_by(division, state, race, gender) %>%
    summarise(n = n()) %>%
    group_by(state) %>% # The level at which you want to measure support
    mutate(perc = n / sum(n)) %>%
    ungroup() %>% 
    group_by(state, race) %>% 
    mutate(perc_2 = n/ sum(n)) %>% 
    ungroup(),
    25)

# A tibble: 25 × 7
   division    state race     gender     n   perc perc_2
   <fct>       <chr> <chr>    <chr>  <int>  <dbl>  <dbl>
 1 New England CT    Asian    Female   958 0.0475  0.478
 2 New England CT    Asian    Male    1047 0.0519  0.522
 3 New England CT    Black    Female  2061 0.102   0.509
 4 New England CT    Black    Male    1989 0.0986  0.491
 5 New England CT    Hispanic Female  3053 0.151   0.499
 6 New England CT    Hispanic Male    3060 0.152   0.501
 7 New England CT    White    Female  3997 0.198   0.499
 8 New England CT    White    Male    4009 0.199   0.501
 9 New England MA    Asian    Female   999 0.0493  0.493
10 New England MA    Asian    Male    1026 0.0506  0.507
# ℹ 15 more rows

Now we can add some draws from the posterior distribution to our dataset and then make inferences on them.

pred<-fit %>%
  add_predicted_draws(newdata=post_strat_values, allow_new_levels=TRUE, ndraws = 100) %>%
  mutate(individual_support = .prediction) %>% 
   rename(support = .prediction) %>%
  mean_qi() %>%
  mutate(state_support = support * perc) %>% # Post-stratified by state
  mutate(state_race = support *perc_2) # Post-stratified by gender within state

Now we can do whatever we want to do with regard to inferences:

by_state_estimated <- pred %>%
  group_by(state) %>%
  summarise(estimated_support = sum(state_support)) %>%
  left_join(population_data %>%
              group_by(state) %>%
              summarise(true_support = mean(true_opinion)))

by_state_estimated_2 <- pred %>%
  group_by(state) %>%
  summarise(estimated_support = sum(state_support)) %>%
  left_join(population_data %>%
              group_by(state) %>%
              summarise(true_support = mean(true_opinion))) %>% 
  left_join(survey %>%
              group_by(state) %>%
              summarise(survey_support = mean(true_opinion))) %>% 
  gather(method, prediction, -true_support, - state)

Now we can look to see how our prediction did for the population, though we missed the Southern states. Probably because our decision to partial pool on division was a bad one given the effects we introduced at the state level did not necessarily coincide with the census division.

by_state_estimated %>% 
ggplot(aes(true_support, estimated_support, label = state))+
  geom_label()+
  geom_abline(slope = 1)+
  theme_minimal()+
  xlim(.35,.55)+
  ylim(.35,.55)

But we can at least be calmed by the fact that if we made direct prediction from our survey we would have been way wrong!

by_state_estimated_2 %>% 
  ggplot(aes(prediction, true_support, color = method, label = state))+
  geom_label()+
  geom_abline(slope = 1)+
  theme_minimal()+
  xlim(.35,.55)+
  ylim(.35,.55)

Looking at support by Race within a given community requires that we use a different post-stratification variable which we created earlier.

(by_state_race_estimated <- pred %>%
  group_by(state, race) %>%
  summarise(estimated_support = sum(state_race)) %>%
  left_join(population_data %>%
              group_by(state, race) %>%
              summarise(true_support = mean(true_opinion))))

# A tibble: 200 × 4
# Groups:   state [50]
   state race     estimated_support true_support
   <chr> <chr>                <dbl>        <dbl>
 1 AK    Asian                0.487        0.396
 2 AK    Black                0.499        0.494
 3 AK    Hispanic             0.470        0.496
 4 AK    White                0.481        0.508
 5 AL    Asian                0.458        0.388
 6 AL    Black                0.511        0.500
 7 AL    Hispanic             0.535        0.492
 8 AL    White                0.509        0.498
 9 AR    Asian                0.481        0.395
10 AR    Black                0.473        0.496
# ℹ 190 more rows

@online{dewitt2019,
  author = {Michael E. DeWitt},
  title = {MRP Redux},
  date = {2019-04-05},
  url = {https://michaeldewittjr.com/blog/2019-04-05-mrp-redux/},
  langid = {en}
}
Copy

I worked on something that started in R and then I wanted to speed it up. MCMC is generally a slow process in base R because it can’t be parallelised easily as each state depends on the previous state. Rcpp is a wonderful avenue to speed things up.

The problem

The purpose of this exercise is to build a Metropolis-Hastings sampler in R. The goal is to return the posterior mean of $\theta$ given a vector of values, a likelihood function, and a prior distribution.

Data Generating Process

As always we hypothesise a likelihood function and then a prior.

Likelihood

$$f(x_i,...,x_n|\theta)=\frac{1}{\pi^n(1+\Pi_{i=1}^n(x_i-\theta)^2)} \ for \ -\infty<x<\infty$$

Prior Distribution

$$p(\theta)=\frac{1}{\sqrt{2\pi}}exp(-\theta^2/2)$$

Input Values

We have been provided the following draws from the distribution:

x <- c(1.0, -3.4, 2.8, -0.5, 4.7, -1.9, 0.8, 3.2, -5.2, -0.9)

M-H Sampler

Now to build the Metropolis Hastings sampler we build the corresponding R functions.

prior <- function(theta){
  1/sqrt(2*pi)*exp(-theta^2/2)
}

And an associated check to make sure it is providing logical values:

(test_prior <- prior(theta = .1))

[1] 0.3969525

Then we build the likelihood function. In order to prevent integer underflow I have converted the function to log-likelihood. I then exponentiate the final value. The log-likelihood is then describved as

$$l(x_i,...x_n|\theta) = log(1) - (n\log(pi)+\Sigma_{i=1}^nlog(1+(x_i-\theta)^2))$$

The value from the log-likelihood can then be exponentiated in order to arrive at the likelihood.

likelihood <- function(x, theta){
  if(!is.vector(x)){
    stop("Please supply a vector to this function")
  }
  # Log-likelihood
  a <- log(1)-(length(x)*log(pi) + sum(log(1+(x-theta)^2)))
  
  # Convert to likelihood
  exp(a)

}

And finally we build the sampler.

theta_sampler <- function(x, niter, theta_start_val, theta_proposal_sd){
  
  theta <- rep(0, niter)
  theta[1] <- theta_start_val
  
  for(i in 2:niter){
    current_theta <- theta[i-1]
    
    # Random Step
    new_theta <- current_theta + rnorm(1,0, theta_proposal_sd)
    
    # MH Ratio
    r <- prior(theta = new_theta) * likelihood(theta = new_theta, x = x)/
      (prior(theta = current_theta)* likelihood(theta = current_theta, x = x))
    
    # Decide to keep proposed theta or take a step
    if(runif(1)<r){
      theta[i] <- new_theta
    } else{
      theta[i] <- current_theta
    }
  }
  return(theta)
}

We can then sample from the posterior distribution given the initial values and our data.

set.seed(336)
out <- theta_sampler(x = x, niter = 5000, theta_start_val = 0, theta_proposal_sd = .5)

We can then graph our associated draws.

hist(out[1000:5000], 
     main = "Histogram of Posterior Draws of theta", 
     xlab = expression(Posterior~Value~of~theta),
     breaks = 30)
abline(v = mean(out[1000:5000]), col = "red", lwd = 2)

The posterior mean of $\theta$ is:

mean(out)

[1] 0.1280924

C++ Version

This is just an experiment to see if I can make the program a little faster using Rcpp.

C++ Code

This code is nearly identical to the R code, just utilising C++. Astute readers will see that I really could drop some of the constants in the prior and the likelihood function because they will fall out when calculating the MH ratio, r. Additionally, it is worth noting that I have converted the equations to a log scale to avoid computations on very small numbers.

writeLines(readLines("mh_sampler.cpp"))

#include <Rcpp.h>
using namespace Rcpp;

// [[Rcpp::export]]
double Priorcpp(double theta) {
  return 1/sqrt(2*M_PI)*exp(-pow(theta,2)/2);
}

// [[Rcpp::export]]
double Likelihoodcpp(NumericVector x, double theta) {
  double likelihood;
  double loglike;
  int n = x.size();
  
  loglike = log(1) - (n*log(M_PI)+sum(log(1+pow((x-theta),2))));
  likelihood = exp(loglike);
  return likelihood;
}

// [[Rcpp::export]]

NumericVector make_posterior(NumericVector x, int niter, 
                             double theta_start_val, double theta_proposal_sd){
  NumericVector theta(niter);
  double current_theta;
  double new_theta;
  double r;
  double rand_val;
  double thresh;
  
  theta[0] = theta_start_val;
  
  for(int i = 1; i < niter; i++){
    
    current_theta = theta[i-1];
    
    rand_val = rnorm(1,0, theta_proposal_sd)[0];
    
    new_theta = current_theta + rand_val;
    
    
    r = Priorcpp(new_theta) * Likelihoodcpp(x, new_theta)/
      (Priorcpp(current_theta)* Likelihoodcpp(x, current_theta));
    
    
    thresh = runif(1)[0];
    
    theta[i] = new_theta;
    
    
    if(thresh<r){
      theta[i] = new_theta;
    } else{
      theta[i] = current_theta;
    }
    
    
  }
  return theta;
}

Compilation and Testing

Now we need to compile the functions.

library(Rcpp)
Rcpp::sourceCpp("mh_sampler.cpp")

First we meed to test that the prior and likelihood functions return equivalent values between base R and C++.

all.equal(
prior(theta = .1),
Priorcpp(theta = .1)
)

[1] TRUE

So Priors are returning the same values.

all.equal(
likelihood(x = x, .1),
Likelihoodcpp(x = x, theta = .1)
)

[1] TRUE

The likelihoods are returning the samples values. Now we have confidence that our C++ function is returning the same values.

Inference using C++

Now we can go ahead and draw from the posterior distribution using our sampler.

set.seed(336)
out2 <- make_posterior(x = x, niter = 5000, theta_start_val = 0, 
                       theta_proposal_sd = .5)

hist(out2[1000:5000],
     main = "Histogram of Posterior Draws of theta", 
     xlab = expression(Posterior~Value~of~theta),
     breaks = 30)
abline(v = mean(out2[1000:5000]), col = "red", lwd =2)

The mean value, 0.127 is very similar to the base R version (some differences could be some differences in the random number generators used). However, we we compare the benchmark times we see that the C++ version of the sampler is roughly 20x faster.

Benchmarking Performance

microbenchmark::microbenchmark(
  Rcpp = make_posterior(x = x, niter = 5000, 
                        theta_start_val = 0, theta_proposal_sd = .5),
  base= theta_sampler(x = x, niter = 5000, 
                      theta_start_val = 0, theta_proposal_sd = .5))

Unit: milliseconds
 expr       min        lq     mean    median       uq       max neval
 Rcpp  2.654015  2.999578  5.14137  3.887183  5.40355  23.17418   100
 base 47.604533 54.824241 76.17792 62.180993 84.70032 227.59704   100

@online{dewitt2019,
  author = {Michael E. DeWitt},
  title = {Speeding Things Up with Rcpp},
  date = {2019-04-04},
  url = {https://michaeldewittjr.com/blog/2019-04-04-speeding-things-up-with-rcpp/},
  langid = {en}
}
Copy

This is a useful package to use latex notation in {ggplot2}. I saw this on twitter and wish I had written down the originator for proper citation but I forgot at the time.

library(tidyverse)
library(latex2exp)

example_data <-tibble(ability = seq(-3,3, .1)) %>% 
  mutate(result = plogis(ability*2))

example_data %>% 
  ggplot(aes(ability, result))+
  geom_line()+
  labs(
    x = TeX("<span class="katex"><span class="katex-mathml"><math xmlns="http://www.w3.org/1998/Math/MathML"><semantics><mrow><mi>a</mi><mi>b</mi><mi>i</mi><mi>l</mi><mi>i</mi><mi>t</mi><mi>y</mi><mo stretchy="false">(</mo><mspace linebreak="newline"></mspace><mi>t</mi><mi>h</mi><mi>e</mi><mi>t</mi><mi>a</mi><mo stretchy="false">)</mo></mrow><annotation encoding="application/x-tex">ability(\\theta)</annotation></semantics></math></span><span class="katex-html" aria-hidden="true"><span class="base"><span class="strut" style="height:1em;vertical-align:-0.25em;"></span><span class="mord mathnormal">abi</span><span class="mord mathnormal" style="margin-right:0.01968em;">l</span><span class="mord mathnormal">i</span><span class="mord mathnormal">t</span><span class="mord mathnormal" style="margin-right:0.03588em;">y</span><span class="mopen">(</span></span><span class="mspace newline"></span><span class="base"><span class="strut" style="height:1em;vertical-align:-0.25em;"></span><span class="mord mathnormal">t</span><span class="mord mathnormal">h</span><span class="mord mathnormal">e</span><span class="mord mathnormal">t</span><span class="mord mathnormal">a</span><span class="mclose">)</span></span></span></span>")
  )+
  theme_bw()

plogis(3)

[1] 0.9525741

exp(3)/(1+exp(3))

[1] 0.9525741

@online{dewitt2019,
  author = {Michael E. DeWitt},
  title = {Latex in ggplot2},
  date = {2019-04-03},
  url = {https://michaeldewittjr.com/blog/2019-04-03-latex-in-ggplot2/},
  langid = {en}
}
Copy

This blogpost is a reproduction of this. Multi-level regression with post-stratification (MRP) is one of the more powerful predictive strategies for opinion polling and election forecasting. It combines the power of multi-level modeling which anticipate and predict group and population level effects which have good small N predictive properties with post-stratification which helps to temper the predictions to the demographics or other variables of interest. This method has been put out by Andrew Gelman et al and there is a good deal of literature on the subject.

This blog post then seeks to reproduce an example made by Tim Mastny using the brms package and tidyverse tooling.

Reproduction

library(tidyverse)
library(lme4)
library(brms)
library(rstan)
#remotes::install_github("hrbrmstr/albersusa")
#library(albersusa)
library(cowplot)

rstan_options(auto_write=TRUE)
options(mc.cores=parallel::detectCores())

Data

All the data required to reproduce this example is located here

marriage.data <- foreign::read.dta('gay_marriage_megapoll.dta',
                                   convert.underscore=TRUE)
Statelevel <- foreign::read.dta("state_level_update.dta",
                                convert.underscore = TRUE)
Census <- foreign::read.dta("poststratification 2000.dta",
                            convert.underscore = TRUE)

Tidy and Munge

In this section the data are being cleaned

# add state level predictors to marriage.data
Statelevel <- Statelevel %>% rename(state = sstate)

marriage.data <- Statelevel %>%
  select(state, p.evang, p.mormon, kerry.04) %>%
  right_join(marriage.data)

# Combine demographic groups
marriage.data <- marriage.data %>%
  mutate(race.female = (female * 3) + race.wbh) %>%
  mutate(age.edu.cat = 4 * (age.cat - 1) + edu.cat) %>%
  mutate(p.relig = p.evang + p.mormon) %>%
  filter(state != "")

Buildign the Post-stratifications

In this step Tim is

# change column names for natural join with marriage.data
Census <- Census %>% 
  rename(state = cstate,
         age.cat = cage.cat,
         edu.cat = cedu.cat,
         region = cregion)

Census <- Statelevel %>%
  select(state, p.evang, p.mormon, kerry.04) %>%
  right_join(Census)

Census <- Census %>%
  mutate(race.female = (cfemale * 3 ) + crace.WBH) %>%
  mutate(age.edu.cat = 4 * (age.cat - 1) + edu.cat) %>%
  mutate(p.relig = p.evang + p.mormon)

Now the fully Bayesian model can be built with the associated group level effects specified.

bayes.mod <- brm(yes.of.all ~ (1 | race.female) + (1 | age.cat) + (1 | edu.cat)
  + (1 | age.edu.cat) + (1 | state) + (1 | region)
  + p.relig + kerry.04,
data = marriage.data, family = bernoulli(),
prior = c(
  set_prior("normal(0,0.2)", class = "b"),
  set_prior("normal(0,0.2)", class = "sd", group = "race.female"),
  set_prior("normal(0,0.2)", class = "sd", group = "age.cat"),
  set_prior("normal(0,0.2)", class = "sd", group = "edu.cat"),
  set_prior("normal(0,0.2)", class = "sd", group = "age.edu.cat"),
  set_prior("normal(0,0.2)", class = "sd", group = "state"),
  set_prior("normal(0,0.2)", class = "sd", group = "region")
), iter = 1000, chains = 2, cores = 2, silent = TRUE
)

Examine the model output. If this were for a paper or a real prediction it would be important to run the model through a few more iterations with further diagnostic plots to ensure convergence.

summary(bayes.mod)

Do some visualisations

library(tidybayes)

bayes.mod %>%
  gather_draws(`sd_.*`, regex=TRUE) %>%
  ungroup() %>%
  mutate(group = stringr::str_replace_all(.variable, c("sd_" = "","__Intercept"=""))) %>%
  ggplot(aes(y=group, x = .value)) + 
  ggridges::geom_density_ridges(aes(height=..density..),
                                rel_min_height = 0.01, stat = "density",
                                scale=1.5)

Now Bring them Together

The next step then is to combine the predictions from the Bayesian HLM with the postratified values. This can then be used to estimate support.

ps.bayes.mod <- bayes.mod %>%
  add_predicted_draws(newdata=Census, allow_new_levels=TRUE) %>%
  rename(support = .prediction) %>%
  mean_qi() %>%
  mutate(support = support * cpercent.state) %>%
  group_by(state) %>%
  summarise(support = sum(support))

ps.bayes.mod %>% 
  knitr::kable()

With uncertainity

Now we can add some additional quantification of uncertainity by adding multiple draws from the posterior distribution.

pred<-bayes.mod %>%
  add_predicted_draws(newdata=Census, allow_new_levels=TRUE, n = 10) %>%
  rename(support = .prediction) %>%
  mutate(support = support * cpercent.state)%>%
  group_by(state, add = TRUE) %>%
  mean_qi()

@online{dewitt2018,
  author = {Michael E. DeWitt},
  title = {MRP using brms},
  date = {2018-11-07},
  url = {https://michaeldewittjr.com/blog/2018-11-07-mrp-using-brms/},
  langid = {en}
}
Copy

The mission is to reproduce the figures in the following article:

https://cran.r-project.org/web/packages/hts/vignettes/hts.pdf

Load Required Libraries

library(hts)

Note on Formatting Data

This is important to understand in regard to how to format the data.

# bts is a time series matrix containing the bottom-level series
# The first three series belong to one group, and the last two
# series belong to a different group
# nodes is a list containing the number of child nodes at each level.
bts <- ts(5 + matrix(sort(rnorm(500)), ncol=5, nrow=100))

y <- hts(bts, nodes=list(2, c(3, 2)))

The Data

infantgts

Grouped Time Series 
4 Levels 
Number of groups at each level: 1 2 8 16 
Total number of series: 27 
Number of observations per series: 71 
Top level series: 
Time Series:
Start = 1933 
End = 2003 
Frequency = 1 
 [1] 4426 4795 4501 4813 4572 4627 4726 4897 5367 5435 5458 4819 4741 5143 5231
[16] 4978 4621 4672 4910 4823 4743 4546 4571 4630 4751 4586 4915 4667 4700 4861
[31] 4652 4403 4124 4065 4205 4293 4507 4620 4809 4465 4088 3974 3341 3161 2834
[46] 2732 2557 2438 2365 2485 2349 2184 2473 2162 2131 2143 2018 2149 1851 1848
[61] 1598 1524 1466 1467 1352 1261 1413 1292 1313 1271 1207

Use a bottom’s up forcasting method. There are several options from which to choose:

• comb optimal combination
• bu bottom’s up
• mo middle out forecast
• tdgsa Top-down forecasts based on the average historical proportions (Gross-Sohl method A)
• tdgsf same as above but with averages
• tdfp top down forecast using proportions

# Forecast 10-step-ahead using the bottom-up method
infantforecast <- forecast(infantgts, h=10, method="bu")

Now we can plot them:

# plot the forecasts including the last ten historical years
plot(infantforecast, include=2)

allts_infant <- aggts(infantgts)
allf <- matrix(nrow=10, ncol=ncol(allts_infant))
# Users can select their preferred time-series forecasting method
# for each time series
for(i in 1:ncol(allts_infant)){
  allf[,i] <- forecast(auto.arima(allts_infant[,i]), h=10, PI=FALSE)$mean
$}

allf <- ts(allf, start=2004)
# combine the forecasts with the group matrix to get a gts object
g <- matrix(c(rep(1, 8), rep(2, 8), rep(1:8, 2)), nrow = 2, byrow = T)
y.f <- combinef(allf, groups = g)

# set up the training sample and testing sample
data <- window(infantgts, start=1933, end=1993)
test <- window(infantgts, start=1994, end=2003)
forecast <- forecast(data, h=10, method="bu")
# calculate ME, RMSE, MAE, MAPE, MPE and MASE
accuracy.gts(forecast, test)

           Total  Sex/female    Sex/male   State/NSW   State/VIC  State/QLD
ME   -229.976631 -51.6732083 -178.303422 -61.6997671 -52.3224384 -54.247885
RMSE  239.316716  54.8648206  186.952910  72.0726053  55.6797769  58.364656
MAE   229.976631  51.6732083  178.303422  61.6997671  52.3224384  54.247885
MAPE   17.383377   8.8573610   24.108196  14.8044550  17.2578539  19.807669
MPE   -17.383377  -8.8573610  -24.108196 -14.8044550 -17.2578539 -19.807669
MASE    1.192825   0.5536415    1.634811   0.6922188   0.7123545   1.170397
        State/SA  State/WA  State/NT  State/ACT  State/TAS NSW female
ME   -27.9688770 -34.22604 2.4214262 -10.200366  8.2673186 18.1060219
RMSE  31.4104773  37.80624 4.4008195  12.277985 14.1318898 29.4705103
MAE   28.3351016  34.22604 3.8128557  10.200366 11.2456064 22.6345181
MAPE  35.8611517  30.49142 9.3990903  58.625236 25.6532905 11.8532079
MPE  -35.5481392 -30.49142 5.5716727 -58.625236 16.2664231  9.1030614
MASE   0.9229675   1.18361 0.3087333   1.577376  0.4954012  0.5199353
      VIC female QLD female   SA female   WA female   NT female  ACT female
ME   -19.2448216 -30.927587 -11.8395741  -9.4619072  -3.6619739   1.2229746
RMSE  22.4856212  34.825359  12.7759741  12.2693801   5.4356560   4.3972340
MAE   19.2448216  30.927587  11.8395741  11.0295258   4.1036140   3.8000000
MAPE  15.1713621  27.492021  34.9177563  23.1348356  31.0793050  49.8490801
MPE  -15.1713621 -27.492021 -34.9177563 -20.8629247 -29.2280894 -15.2907568
MASE   0.5338369   1.059769   0.6720666   0.6308594   0.5766202   0.9047619
     TAS female   NSW male    VIC male    QLD male     SA male    WA male
ME    4.1336593 -79.805789 -33.0776168 -23.3202978 -16.1293029 -24.764134
RMSE  7.0659449  85.657539  35.4311830  27.7367318  20.5563716  28.118008
MAE   5.6228032  79.805789  33.0776168  23.3202978  17.9634424  25.771308
MAPE 25.6532905  34.527431  19.3380825  15.3395187  43.6968568  42.005272
MPE  16.2664231 -34.527431 -19.3380825 -15.3395187 -41.2835155 -40.987925
MASE  0.4954012   1.431922   0.7569249   0.9676472   0.9396744   1.577835
       NT male    ACT male   TAS male
ME    6.083400  -11.423341  4.1336593
RMSE  8.673554   12.089644  7.0659449
MAE   7.729126   11.423341  5.6228032
MAPE 34.820043  106.448479 25.6532905
MPE  22.160616 -106.448479 16.2664231
MASE  1.120163    2.269538  0.4954012

fcasts <- forecast(htseg1, h = 10, method = "comb", fmethod = "arima",
weights = "sd", keep.fitted = TRUE, parallel = TRUE)

@online{dewitt2018,
  author = {Michael E. DeWitt},
  title = {Hierarchical Time Series with hts},
  date = {2018-10-28},
  url = {https://michaeldewittjr.com/blog/2018-10-28-hierarchical-time-series-with-hts/},
  langid = {en}
}
Copy

Synthethic methods are a method of causal inference that seeks to combine traditional difference-in-difference types studies with time series cross sectional differences with factor analysis for uncontrolled/ unobserved measures. This method has been growing our of work initially from Abadie (Abadie, Diamond, and Hainmueller 2011a) and growing in importance/ research for state level policy analysis. It is interesting from the fact that it combines some elements of factor analysis to develop predictors and regression analysis to try to capture explained and unexplained variance.

Package

library(tidyverse)
library(gsynth)
library(panelView)

Method Assumptions

This methodology makes several critical assumptions.

1. The model takes the functional form of $$Y_{i,t}=\delta_{i,t}D_{i,t}+x_{i,t}^\prime\beta+\lambda_i^{\prime}f_i+\epsilon_{i,t}$$
2. Strict exogeneity (e.g. the error terms are indepdent to D, X, $\lambda$ and f)
3. Weak serial dependence of the error terms
4. Regularity of conditions

The method then uses bootstrapping for confidence intervals.

There is some basic data available in the package

data(gsynth)

The data that will be initially used will be the simdata dataset

It can be examined via the panelView package:

panelview(Y ~ D, data = simdata,  index = c("id","time")) 

Modeling

out <- gsynth(Y ~ D + X1 + X2, data = simdata, 
                  index = c("id","time"), force = "two-way",
                  CV = TRUE, r = c(0, 5), se = TRUE, 
                  inference = "parametric", nboots = 1000,
                  parallel = FALSE)

Cross-validating ... 
 r = 0; sigma2 = 1.84865; IC = 1.02023; PC = 1.74458; MSPE = 2.37280
 r = 1; sigma2 = 1.51541; IC = 1.20588; PC = 1.99818; MSPE = 1.71743
 r = 2; sigma2 = 0.99737; IC = 1.16130; PC = 1.69046; MSPE = 1.14540*
 r = 3; sigma2 = 0.94664; IC = 1.47216; PC = 1.96215; MSPE = 1.15032
 r = 4; sigma2 = 0.89411; IC = 1.76745; PC = 2.19241; MSPE = 1.21397
 r = 5; sigma2 = 0.85060; IC = 2.05928; PC = 2.40964; MSPE = 1.23876

 r* = 2


Simulating errors .............
Bootstrapping ...
..........

print(out)

Call:
gsynth.formula(formula = Y ~ D + X1 + X2, data = simdata, index = c("id", 
    "time"), force = "two-way", r = c(0, 5), CV = TRUE, se = TRUE, 
    nboots = 1000, inference = "parametric", parallel = FALSE)

Average Treatment Effect on the Treated:
        Estimate  S.E. CI.lower CI.upper p.value
ATT.avg    5.544 0.262     5.03    6.057       0

   ~ by Period (including Pre-treatment Periods):
          ATT   S.E. CI.lower CI.upper   p.value n.Treated
-19  0.392160 0.5468  -0.6796  1.46396 4.733e-01         0
-18  0.276548 0.4461  -0.5979  1.15098 5.354e-01         0
-17 -0.275393 0.5428  -1.3392  0.78841 6.119e-01         0
-16  0.441201 0.4389  -0.4191  1.30150 3.148e-01         0
-15 -0.889595 0.4914  -1.8527  0.07348 7.023e-02         0
-14  0.593891 0.4633  -0.3142  1.50199 1.999e-01         0
-13  0.528749 0.4132  -0.2811  1.33860 2.007e-01         0
-12  0.171569 0.5975  -0.9994  1.34258 7.740e-01         0
-11  0.610832 0.4474  -0.2661  1.48774 1.722e-01         0
-10  0.170597 0.4516  -0.7146  1.05581 7.056e-01         0
-9  -0.271892 0.5871  -1.4226  0.87886 6.433e-01         0
-8   0.094843 0.5037  -0.8924  1.08204 8.506e-01         0
-7  -0.651976 0.5567  -1.7430  0.43904 2.415e-01         0
-6   0.573686 0.4783  -0.3638  1.51113 2.304e-01         0
-5  -0.469686 0.5150  -1.4792  0.53978 3.618e-01         0
-4  -0.077766 0.5287  -1.1140  0.95850 8.831e-01         0
-3  -0.141785 0.5473  -1.2144  0.93085 7.956e-01         0
-2  -0.157100 0.4186  -0.9776  0.66341 7.075e-01         0
-1  -0.915575 0.4856  -1.8673  0.03616 5.936e-02         0
0   -0.003309 0.3638  -0.7164  0.70975 9.927e-01         0
1    1.235962 0.7289  -0.1927  2.66458 8.995e-02         5
2    1.630264 0.5615   0.5297  2.73079 3.691e-03         5
3    2.712178 0.5508   1.6326  3.79178 8.487e-07         5
4    3.466758 0.7437   2.0092  4.92431 3.136e-06         5
5    5.740132 0.5367   4.6882  6.79203 0.000e+00         5
6    5.280035 0.5741   4.1548  6.40529 0.000e+00         5
7    8.436485 0.4843   7.4874  9.38561 0.000e+00         5
8    7.839902 0.6408   6.5839  9.09592 0.000e+00         5
9    9.455115 0.5450   8.3869 10.52329 0.000e+00         5
10   9.638509 0.5035   8.6517 10.62527 0.000e+00         5

Coefficients for the Covariates:
    beta    S.E. CI.lower CI.upper p.value
X1 1.022 0.03004    0.963    1.081       0
X2 3.053 0.02958    2.995    3.111       0

out$est.att
$```

                 ATT      S.E.   CI.lower    CI.upper      p.value n.Treated
    -19  0.392159788 0.5468489 -0.6796443  1.46396386 4.732961e-01         0
    -18  0.276547958 0.4461493 -0.5978887  1.15098460 5.353532e-01         0
    -17 -0.275392926 0.5427657 -1.3391941  0.78840827 6.118824e-01         0
    -16  0.441201288 0.4389354 -0.4190963  1.30149888 3.148187e-01         0
    -15 -0.889595124 0.4913755 -1.8526735  0.07348322 7.023098e-02         0
    -14  0.593890957 0.4633226 -0.3142046  1.50198651 1.999097e-01         0
    -13  0.528749012 0.4131945 -0.2810973  1.33859533 2.006643e-01         0
    -12  0.171568737 0.5974650 -0.9994412  1.34257868 7.739889e-01         0
    -11  0.610832288 0.4474116 -0.2660784  1.48774295 1.721720e-01         0
    -10  0.170597468 0.4516495 -0.7146193  1.05581419 7.056379e-01         0
    -9  -0.271891657 0.5871305 -1.4226462  0.87886293 6.433030e-01         0
    -8   0.094842558 0.5036802 -0.8923526  1.08203768 8.506422e-01         0
    -7  -0.651975701 0.5566512 -1.7429921  0.43904067 2.414998e-01         0
    -6   0.573686472 0.4782973 -0.3637590  1.51113193 2.303589e-01         0
    -5  -0.469685905 0.5150445 -1.4791545  0.53978268 3.618041e-01         0
    -4  -0.077766449 0.5287181 -1.1140349  0.95850205 8.830650e-01         0
    -3  -0.141784521 0.5472736 -1.2144212  0.93085211 7.955779e-01         0
    -2  -0.157100323 0.4186374 -0.9776145  0.66341385 7.074627e-01         0
    -1  -0.915575087 0.4855890 -1.8673120  0.03616184 5.936318e-02         0
    0   -0.003308833 0.3638145 -0.7163722  0.70975454 9.927435e-01         0
    1    1.235962010 0.7289023 -0.1926602  2.66458419 8.995247e-02         5
    2    1.630264312 0.5615032  0.5297382  2.73079044 3.691436e-03         5
    3    2.712177702 0.5508277  1.6325753  3.79178010 8.486982e-07         5
    4    3.466757691 0.7436652  2.0092007  4.92431464 3.135799e-06         5
    5    5.740132310 0.5366920  4.6882353  6.79202929 0.000000e+00         5
    6    5.280034526 0.5741182  4.1547836  6.40528546 0.000000e+00         5
    7    8.436484821 0.4842566  7.4873594  9.38561026 0.000000e+00         5
    8    7.839901526 0.6408388  6.5838805  9.09592251 0.000000e+00         5
    9    9.455114684 0.5449999  8.3869345 10.52329485 0.000000e+00         5
    10   9.638509457 0.5034590  8.6517480 10.62527087 0.000000e+00         5

``` r
out$est.avg
$```

            Estimate     S.E. CI.lower CI.upper p.value
    ATT.avg 5.543534 0.262005 5.030014 6.057054       0

``` r
out$est.beta
$```

           beta       S.E.  CI.lower CI.upper p.value
    X1 1.021890 0.03004240 0.9630082 1.080772       0
    X2 3.052994 0.02957771 2.9950231 3.110966       0

The default plot:

``` r
plot(out) +
  theme(plot.title = element_text(size = 12))

Modified:

plot(out, theme.bw = TRUE) +
  theme(plot.title = element_text(size = 12))

With the raw data:

plot(out, type = "raw", theme.bw = TRUE)+
  theme(plot.title = element_text(size = 12))

plot(out,type = "raw", legendOff = TRUE, ylim=c(-10,40), main="")+
  theme(plot.title = element_text(size = 12))

plot(out, type = "counterfactual", raw = "none", main="")+
  theme(plot.title = element_text(size = 12))

plot(out, type = "counterfactual", raw = "band", xlab = "Time", 
     ylim = c(-5,35), theme.bw = TRUE)+
  theme(plot.title = element_text(size = 12))

plot(out, type = "counterfactual", raw = "all")+
  theme(plot.title = element_text(size = 12))

plot(out, type = "factors", xlab = "Time")+
  theme(plot.title = element_text(size = 12))

Voter Turnout

Now I am going to try to reproduce the results from Xu’s paper $$xu_generalized_2017$$ and implemented in his package (Xu and Liu 2018).

Data

Model

The paper builds two models, one will only the impact of voter education, another with additional controls. For the sake of time I will build the model with all of the controls used.

out <- gsynth(turnout ~ policy_edr + policy_mail_in + policy_motor, data = turnout, 
                  index = c("abb","year"), force = "two-way",
                  CV = TRUE, r = c(0, 5), se = TRUE, 
                  inference = "parametric", nboots = 1000,
                  parallel = FALSE)

Cross-validating ... 
 r = 0; sigma2 = 77.99366; IC = 4.82744; PC = 72.60594; MSPE = 22.13889
 r = 1; sigma2 = 13.65239; IC = 3.52566; PC = 21.67581; MSPE = 12.03686
 r = 2; sigma2 = 8.56312; IC = 3.48518; PC = 19.23841; MSPE = 10.31254*
 r = 3; sigma2 = 6.40268; IC = 3.60547; PC = 18.61783; MSPE = 11.48390
 r = 4; sigma2 = 4.74273; IC = 3.70145; PC = 16.93707; MSPE = 16.28613
 r = 5; sigma2 = 4.02488; IC = 3.91847; PC = 17.05226; MSPE = 15.78683

 r* = 2


Simulating errors .............
Bootstrapping ...
..........

The model completed and appeared that it did well. Now to examine the figures to see if they match:

plot(out)

Now we can look at the estimated average treatment

out$est.avg %>% 
$  knitr::kable()

plot(out, type = "counterfactual", raw = "all")+
  theme(plot.title = element_text(size = 12))

Now with Synth

Now I want to try to replicate the previous case study used in Synth (Abadie, Diamond, and Hainmueller 2011b) and see if it is possible.

library(Synth)

I am going to recode some variable in order to fit with the methods used in gsynth. The Synth package uses a dataprep function in order to format the data into the requirements.

data("basque")
basque_treat <- basque %>% 
  mutate(treat = ifelse(grepl(pattern = "Basque", x = regionname) & year > 1969,1,0))
head(basque_treat) %>% 
  knitr::kable()

out_basque <- gsynth(gdpcap ~ treat, data = basque_treat, index = c("regionname","year"), force = "two-way",
                  CV = TRUE, r = c(0, 5), se = TRUE, 
                  inference = "parametric", nboots = 1000,
                  parallel = FALSE, )

Cross-validating ... 
 r = 0; sigma2 = 0.15833; IC = -1.31080; PC = 0.14556; MSPE = 0.02963
 r = 1; sigma2 = 0.02499; IC = -2.64303; PC = 0.04627; MSPE = 0.00994
 r = 2; sigma2 = 0.00985; IC = -3.07772; PC = 0.02745; MSPE = 0.00755*
 r = 3; sigma2 = 0.00581; IC = -3.12683; PC = 0.02166; MSPE = 0.00981
 r = 4; sigma2 = 0.00395; IC = -3.05355; PC = 0.01843; MSPE = 0.00329
 r = 5; sigma2 = 0.00256; IC = -3.04564; PC = 0.01435; MSPE = 0.00260

 r* = 5


Simulating errors .............
Bootstrapping ...
..........

Let’s check the results

plot(out_basque)+
  theme(plot.title = element_text(size = 12))

plot(out_basque, type = "counterfactual", raw = "all")+
  theme(plot.title = element_text(size = 12))

Interesting that this method lands on a slightly different estimate than the previous paper. I think that this is due to some missing covariates. It appears that gsynth doesn’t handle missing data too well, which is ok.

Thoughts

I think that a combination of Bayesian Hierarchical modeling with structural timeseries modeling could get somewhere close to the method, and take advantage of specifying knowns, group effects, etc. But the method is neat and a good way to do some quick analysis.

References

@online{dewitt2018,
  author = {Michael E. DeWitt},
  title = {Replicating gsynth},
  date = {2018-10-28},
  url = {https://michaeldewittjr.com/blog/2018-10-28-replicating-gsynth/},
  langid = {en}
}
Copy

So taking his work and looking at a between person and within person design let’s copy his code and build the fake data.

library("dplyr")
library("rstan")
library("rstanarm")
library("arm")
options(mc.cores = parallel::detectCores())

## 2.  Simulate a data structure with N_per_person measurements on each of J people

J <- 50  # number of people in the experiment
N_per_person <- 10 # number of measurements per person
person_id <- rep(1:J, rep(N_per_person, J))
index <- rep(1:N_per_person, J) 
time <- index - 1  # time of measurements, from 0 to 9
N <- length(person_id)
a <- rnorm(J, 0, 1)
b <- rnorm(J, 1, 1)
theta <- 1
sigma_y <- 1

## 3.  Simulate data from a between-person experiment

z <- sample(rep(c(0,1), J/2), J)
y_pred <- a[person_id] + b[person_id]*time + theta*z[person_id]*time
y <- rnorm(N, y_pred, sigma_y)
z_full <- z[person_id]
exposure <- z_full*time
data_1 <- data.frame(time, person_id, exposure, y)

## 4.  Simulate data from a within-person experiment:  for each person, do one treatment for the first half of the experiment and the other treatment for the second half.

z_first_half <- z
T_switch <- floor(0.5*max(time))
z_full <- ifelse(time <= T_switch, z_first_half[person_id], 1 - z_first_half[person_id])
for (j in 1:J){
  exposure[person_id==j] <- cumsum(z_full[person_id==j])
}
y_pred <- a[person_id] + b[person_id]*time + theta*exposure
y <- rnorm(N, y_pred, sigma_y)
data_2 <- data.frame(time, person_id, exposure, y)

Just for clarity I am going to show a few records of the two different data sets:

Sample of Between Persons Data

data_2 %>% 
  head() %>% 
  knitr::kable(caption = "Sample of Within Persons Data")

Sample of Within Persons Data

Now we can plot the data:

par(mfrow=c(2, 2))
par(mar=c(3,3,3,1), mgp=c(1.5, .5, 0), tck=-.01)

plot(range(time), range(data_1<span class="katex"><span class="katex-mathml"><math xmlns="http://www.w3.org/1998/Math/MathML"><semantics><mrow><mi>y</mi><mo separator="true">,</mo><mi>d</mi><mi>a</mi><mi>t</mi><msub><mi>a</mi><mn>2</mn></msub></mrow><annotation encoding="application/x-tex">y, data_2</annotation></semantics></math></span><span class="katex-html" aria-hidden="true"><span class="base"><span class="strut" style="height:0.8889em;vertical-align:-0.1944em;"></span><span class="mord mathnormal" style="margin-right:0.03588em;">y</span><span class="mpunct">,</span><span class="mspace" style="margin-right:0.1667em;"></span><span class="mord mathnormal">d</span><span class="mord mathnormal">a</span><span class="mord mathnormal">t</span><span class="mord"><span class="mord mathnormal">a</span><span class="msupsub"><span class="vlist-t vlist-t2"><span class="vlist-r"><span class="vlist" style="height:0.3011em;"><span style="top:-2.55em;margin-left:0em;margin-right:0.05em;"><span class="pstrut" style="height:2.7em;"></span><span class="sizing reset-size6 size3 mtight"><span class="mord mtight">2</span></span></span></span><span class="vlist-s">​</span></span><span class="vlist-r"><span class="vlist" style="height:0.15em;"><span></span></span></span></span></span></span></span></span></span>y), xlab="time", ylab="y", type="n", bty="l", main="Between-person design:\nControl group")
for (j in 1:J){
  ok <- data_1$person_id==j
$  if (z[j] == 0){
    points(time[ok], data_1$y[ok], pch=20, cex=.5)
$    lines(time[ok], data_1$y[ok], lwd=.5, col="blue")
$  }
}
plot(range(time), range(data_1<span class="katex"><span class="katex-mathml"><math xmlns="http://www.w3.org/1998/Math/MathML"><semantics><mrow><mi>y</mi><mo separator="true">,</mo><mi>d</mi><mi>a</mi><mi>t</mi><msub><mi>a</mi><mn>2</mn></msub></mrow><annotation encoding="application/x-tex">y, data_2</annotation></semantics></math></span><span class="katex-html" aria-hidden="true"><span class="base"><span class="strut" style="height:0.8889em;vertical-align:-0.1944em;"></span><span class="mord mathnormal" style="margin-right:0.03588em;">y</span><span class="mpunct">,</span><span class="mspace" style="margin-right:0.1667em;"></span><span class="mord mathnormal">d</span><span class="mord mathnormal">a</span><span class="mord mathnormal">t</span><span class="mord"><span class="mord mathnormal">a</span><span class="msupsub"><span class="vlist-t vlist-t2"><span class="vlist-r"><span class="vlist" style="height:0.3011em;"><span style="top:-2.55em;margin-left:0em;margin-right:0.05em;"><span class="pstrut" style="height:2.7em;"></span><span class="sizing reset-size6 size3 mtight"><span class="mord mtight">2</span></span></span></span><span class="vlist-s">​</span></span><span class="vlist-r"><span class="vlist" style="height:0.15em;"><span></span></span></span></span></span></span></span></span></span>y), xlab="time", ylab="y", type="n", bty="l", main="Between-person design:\nTreatment group")
for (j in 1:J){
  ok <- data_1$person_id==j
$  if (z[j] == 1){
    points(time[ok], data_1$y[ok], pch=20, cex=.5)
$    lines(time[ok], data_1$y[ok], lwd=.5, col="red")
$  }
}
plot(range(time), range(data_1<span class="katex"><span class="katex-mathml"><math xmlns="http://www.w3.org/1998/Math/MathML"><semantics><mrow><mi>y</mi><mo separator="true">,</mo><mi>d</mi><mi>a</mi><mi>t</mi><msub><mi>a</mi><mn>2</mn></msub></mrow><annotation encoding="application/x-tex">y, data_2</annotation></semantics></math></span><span class="katex-html" aria-hidden="true"><span class="base"><span class="strut" style="height:0.8889em;vertical-align:-0.1944em;"></span><span class="mord mathnormal" style="margin-right:0.03588em;">y</span><span class="mpunct">,</span><span class="mspace" style="margin-right:0.1667em;"></span><span class="mord mathnormal">d</span><span class="mord mathnormal">a</span><span class="mord mathnormal">t</span><span class="mord"><span class="mord mathnormal">a</span><span class="msupsub"><span class="vlist-t vlist-t2"><span class="vlist-r"><span class="vlist" style="height:0.3011em;"><span style="top:-2.55em;margin-left:0em;margin-right:0.05em;"><span class="pstrut" style="height:2.7em;"></span><span class="sizing reset-size6 size3 mtight"><span class="mord mtight">2</span></span></span></span><span class="vlist-s">​</span></span><span class="vlist-r"><span class="vlist" style="height:0.15em;"><span></span></span></span></span></span></span></span></span></span>y), xlab="time", ylab="y", type="n", bty="l", main="Within-person design:\nControl, then treatment")
for (j in 1:J){
  ok <- person_id==j
  if (z[j] == 0) {
    points(time[ok], data_2$y[ok], pch=20, cex=.5)
$    lines(time[ok&time<=T_switch], data_2$y[ok&time<=T_switch], lwd=.5, col="blue")
$    lines(time[ok&time>=T_switch], data_2$y[ok&time>=T_switch], lwd=.5, col="red")
$  }
}
plot(range(time), range(data_1<span class="katex"><span class="katex-mathml"><math xmlns="http://www.w3.org/1998/Math/MathML"><semantics><mrow><mi>y</mi><mo separator="true">,</mo><mi>d</mi><mi>a</mi><mi>t</mi><msub><mi>a</mi><mn>2</mn></msub></mrow><annotation encoding="application/x-tex">y, data_2</annotation></semantics></math></span><span class="katex-html" aria-hidden="true"><span class="base"><span class="strut" style="height:0.8889em;vertical-align:-0.1944em;"></span><span class="mord mathnormal" style="margin-right:0.03588em;">y</span><span class="mpunct">,</span><span class="mspace" style="margin-right:0.1667em;"></span><span class="mord mathnormal">d</span><span class="mord mathnormal">a</span><span class="mord mathnormal">t</span><span class="mord"><span class="mord mathnormal">a</span><span class="msupsub"><span class="vlist-t vlist-t2"><span class="vlist-r"><span class="vlist" style="height:0.3011em;"><span style="top:-2.55em;margin-left:0em;margin-right:0.05em;"><span class="pstrut" style="height:2.7em;"></span><span class="sizing reset-size6 size3 mtight"><span class="mord mtight">2</span></span></span></span><span class="vlist-s">​</span></span><span class="vlist-r"><span class="vlist" style="height:0.15em;"><span></span></span></span></span></span></span></span></span></span>y), xlab="time", ylab="y", type="n", bty="l", main="Within-person design:\nTreatment, then control")
for (j in 1:J){
  ok <- person_id==j
  if (z[j] == 1) {
    points(time[ok], data_2$y[ok], pch=20, cex=.5)
$    lines(time[ok&time<=T_switch], data_2$y[ok&time<=T_switch], lwd=.5, col="red")
$    lines(time[ok&time>=T_switch], data_2$y[ok&time>=T_switch], lwd=.5, col="blue")
$    for (i in 1:N_per_person) {
      ok2 <- ok & index==i
    }
  }
}

And then start the analysis using our HLM:

fit_1 <- stan_glmer(y ~ (1 + time | person_id) + time + exposure, data=data_1)
fit_2 <- stan_glmer(y ~ (1 + time | person_id) + time + exposure, data=data_2)

Between Persons Design Summary

print(fit_1)

stan_glmer
 family:       gaussian [identity]
 formula:      y ~ (1 + time | person_id) + time + exposure
 observations: 500
------
            Median MAD_SD
(Intercept) -0.1    0.2  
time         0.9    0.2  
exposure     1.3    0.3  

Auxiliary parameter(s):
      Median MAD_SD
sigma 1.0    0.0   

Error terms:
 Groups    Name        Std.Dev. Corr 
 person_id (Intercept) 1.1           
           time        1.1      -0.09
 Residual              1.0           
Num. levels: person_id 50 

------
* For help interpreting the printed output see ?print.stanreg
* For info on the priors used see ?prior_summary.stanreg

Within Persons Design Summary

print(fit_2)

stan_glmer
 family:       gaussian [identity]
 formula:      y ~ (1 + time | person_id) + time + exposure
 observations: 500
------
            Median MAD_SD
(Intercept) 0.0    0.2   
time        1.0    0.1   
exposure    1.0    0.1   

Auxiliary parameter(s):
      Median MAD_SD
sigma 1.0    0.0   

Error terms:
 Groups    Name        Std.Dev. Corr
 person_id (Intercept) 1.0          
           time        1.1      0.05
 Residual              1.0          
Num. levels: person_id 50 

------
* For help interpreting the printed output see ?print.stanreg
* For info on the priors used see ?prior_summary.stanreg

The big take away for both is that the standard error for the within person experiment is less than that of the between person. This is great. The other interesting thing is that if theta ($\theta$) changes, then this standard error will be the same. Yikes! So smaller effect with the same standard error means a weakened confidence in the effect. You can only go so far with modeling and design and must move into understanding the causal pathway.

In Andrew’s words

Except in the simplest settings, setting up a fake-data simulation requires you to decide on a bunch of parameters. Graphing the fake data is in practice a necessity in order to understand the model you’re simulating and to see where to improve it. For example, if you’re not happy with the above graphs—they don’t look like what your data really could look like—then, fine, change the parameters.

In very simple settings you can simply suppose that the effect size is 0.1 standard deviations and go from there. But once you get to nonlinearity, interactions, repeated measurements, multilevel structures, varying treatment effects, etc., you’ll have to throw away that power calculator and dive right in with the simulations.

@online{dewitt2018,
  author = {Michael E. DeWitt},
  title = {the power of fake data simulations},
  date = {2018-09-24},
  url = {https://michaeldewittjr.com/blog/2018-09-24-the-power-of-fake-data-simulations/},
  langid = {en}
}
Copy

This post takes the example provided in Kosuke Imai’s Quantitative Social Science: An Introduction. It provides some exploration of network analysis through looking at the florentine dataset which counts the marraige relationships between several Florentine families in the 15th century. My historical side knows that our analysis should show that the $$Medici Family$$ should appear at the center of all of the political intrigue. Let’s see if the analysis plays out.

Formatting the Data

The florentine data set comes as a dataframe. In order to work with igraph it will need to be converted to a matrix with named columns and rows. That conversion can be done here:

Starting Table

Now we need to manipulate the dataframe to turn it into a matrix object so that we can pass it to the igraph package.

florentine_g <- florentine %>% 
  filter(FAMILY != "PUCCI") %>% 
  select(-PUCCI) %>% 
  select(-FAMILY) %>% 
  as.matrix()

row.names(florentine_g) <- florentine[-12,1] %>% as.vector()

Now we need to pass this object to igraph. The path is undirected because there is no ordinality to this data. It does not encode if one family proposed the marriage to the other group. If this were the case then there could be some directedness to the graph. In this case there isn’t so that is the parameter we will pass.

florentine_g <- graph.adjacency(florentine_g, mode = "undirected", diag = FALSE)

Now we can plot based on several features:

• degree

• closeness

• betweeness

• PageRank

Visualising the Network

plot(florentine_g, vertex.size = betweenness(florentine_g), main = "Betweeness")

plot(florentine_g, vertex.size = closeness(florentine_g)*1000, main = "Closeness")

plot(florentine_g, vertex.size = degree(florentine_g)*10, main = "Degree")

The Numeric Outputs

floretine_networks <- data_frame(
  family = names(closeness(florentine_g)),
  closeness = closeness(florentine_g),
  degree = degree(florentine_g),
  betweeness = betweenness(florentine_g)
) %>% 
  arrange(-closeness)

kable(floretine_networks)

Additionally, the “pagerank” algorithm can be used.

plot(florentine_g, vertex.size = page.rank(graph = florentine_g, directed = FALSE)$vector*100)
$```

![](./unnamed-chunk-6-1.png)

@online{dewitt2018,
  author = {Michael E. DeWitt},
  title = {a foray into network analysis},
  date = {2018-09-16},
  url = {https://michaeldewittjr.com/blog/2018-09-16-a-foray-into-network-analysis/},
  langid = {en}
}
Copy

library(AER)

Binary Depedent Modeling

data("SwissLabor")

head(SwissLabor)

  participation   income age education youngkids oldkids foreign
1            no 10.78750 3.0         8         1       1      no
2           yes 10.52425 4.5         8         0       1      no
3            no 10.96858 4.6         9         0       0      no
4            no 11.10500 3.1        11         2       0      no
5            no 11.10847 4.4        12         0       2      no
6           yes 11.02825 4.2        12         0       1      no

swiss_probit <- glm(participation ~ . + I(age^2), data = SwissLabor, family = binomial(link = "probit"))

summary(swiss_probit)

Call:
glm(formula = participation ~ . + I(age^2), family = binomial(link = "probit"), 
    data = SwissLabor)

Deviance Residuals: 
    Min       1Q   Median       3Q      Max  
-1.9191  -0.9695  -0.4792   1.0209   2.4803  

Coefficients:
            Estimate Std. Error z value Pr(>|z|)    
(Intercept)  3.74909    1.40695   2.665  0.00771 ** 
income      -0.66694    0.13196  -5.054 4.33e-07 ***
age          2.07530    0.40544   5.119 3.08e-07 ***
education    0.01920    0.01793   1.071  0.28428    
youngkids   -0.71449    0.10039  -7.117 1.10e-12 ***
oldkids     -0.14698    0.05089  -2.888  0.00387 ** 
foreignyes   0.71437    0.12133   5.888 3.92e-09 ***
I(age^2)    -0.29434    0.04995  -5.893 3.79e-09 ***
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

(Dispersion parameter for binomial family taken to be 1)

    Null deviance: 1203.2  on 871  degrees of freedom
Residual deviance: 1017.2  on 864  degrees of freedom
AIC: 1033.2

Number of Fisher Scoring iterations: 4

Visualisation of the Data

par(mfrow=c(1,3))
plot(participation ~ age, data = SwissLabor, ylevels = 2:1)
plot(participation ~ education, data = SwissLabor, ylevels = 2:1)
plot(participation ~ foreign, data = SwissLabor, ylevels = 2:1)

Retrieving Average Marginal Effects

Average of the sample marginal effects is determined by the following:

fav <- mean(dnorm(predict(swiss_probit, type = "link")))
fav * coef(swiss_probit)

 (Intercept)       income          age    education    youngkids      oldkids 
 1.241929965 -0.220931858  0.687466185  0.006358743 -0.236682273 -0.048690170 
  foreignyes     I(age^2) 
 0.236644422 -0.097504844 

library(margins)

Goodness of Fit

This can be evauluated with a pseudo R^2 called _McFadden’s pseudo-R^2.

$$R^2 = 1- \frac{l(\hat\beta)}{l(\bar y)}$$

swiss_probit0 <- update(swiss_probit, formula = . ~ 1)
1-as.vector(logLik(swiss_probit)/logLik(swiss_probit0))

[1] 0.1546416

table( true = SwissLabor$participation, pred = round(fitted(swiss_probit)))
$```

         pred
    true    0   1
      no  337 134
      yes 146 255

``` r
library(ROCR)

pred <- prediction(predictions = fitted(swiss_probit), labels = SwissLabor$participation)
$
par(mfrow = c(1,2))
plot(performance(pred, "acc"))
plot(performance(pred, "tpr", "fpr"))
abline(0,1, lty = 2)

Residuals and Diagnostics

coeftest(swiss_probit, vcov. = sandwich)

z test of coefficients:

             Estimate Std. Error z value  Pr(>|z|)    
(Intercept)  3.749091   1.327072  2.8251  0.004727 ** 
income      -0.666941   0.127292 -5.2395 1.611e-07 ***
age          2.075297   0.398580  5.2067 1.922e-07 ***
education    0.019196   0.017935  1.0703  0.284479    
youngkids   -0.714487   0.106095 -6.7344 1.646e-11 ***
oldkids     -0.146984   0.051609 -2.8480  0.004399 ** 
foreignyes   0.714373   0.122437  5.8346 5.391e-09 ***
I(age^2)    -0.294344   0.049527 -5.9430 2.798e-09 ***
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Count Data

data("RecreationDemand")

head(RecreationDemand)

  trips quality ski income userfee  costC   costS   costH
1     0       0 yes      4      no  67.59  68.620  76.800
2     0       0  no      9      no  68.86  70.936  84.780
3     0       0 yes      5      no  58.12  59.465  72.110
4     0       0  no      2      no  15.79  13.750  23.680
5     0       0 yes      3      no  24.02  34.033  34.547
6     0       0 yes      5      no 129.46 137.377 137.850

rd_poisson <- glm(trips ~ ., data = RecreationDemand, family = poisson())
coeftest(rd_poisson)

z test of coefficients:

              Estimate Std. Error  z value  Pr(>|z|)    
(Intercept)  0.2649934  0.0937222   2.8274  0.004692 ** 
quality      0.4717259  0.0170905  27.6016 < 2.2e-16 ***
skiyes       0.4182137  0.0571902   7.3127 2.619e-13 ***
income      -0.1113232  0.0195884  -5.6831 1.323e-08 ***
userfeeyes   0.8981653  0.0789851  11.3713 < 2.2e-16 ***
costC       -0.0034297  0.0031178  -1.1001  0.271309    
costS       -0.0425364  0.0016703 -25.4667 < 2.2e-16 ***
costH        0.0361336  0.0027096  13.3353 < 2.2e-16 ***
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Overdispersion??

dispersiontest(rd_poisson)

    Overdispersion test

data:  rd_poisson
z = 2.4116, p-value = 0.007941
alternative hypothesis: true dispersion is greater than 1
sample estimates:
dispersion 
    6.5658 

Yup

dispersiontest(rd_poisson, trafo = 2)

    Overdispersion test

data:  rd_poisson
z = 2.9381, p-value = 0.001651
alternative hypothesis: true alpha is greater than 0
sample estimates:
   alpha 
1.316051 

Negative Binomial

library(MASS)
rd_nb <- glm.nb(trips ~ ., data = RecreationDemand)
coeftest(rd_nb)

z test of coefficients:

              Estimate Std. Error  z value  Pr(>|z|)    
(Intercept) -1.1219363  0.2143029  -5.2353 1.647e-07 ***
quality      0.7219990  0.0401165  17.9976 < 2.2e-16 ***
skiyes       0.6121388  0.1503029   4.0727 4.647e-05 ***
income      -0.0260588  0.0424527  -0.6138   0.53933    
userfeeyes   0.6691676  0.3530211   1.8955   0.05802 .  
costC        0.0480087  0.0091848   5.2270 1.723e-07 ***
costS       -0.0926910  0.0066534 -13.9314 < 2.2e-16 ***
costH        0.0388357  0.0077505   5.0107 5.423e-07 ***
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

(rd_results <- rbind(poisson = logLik(rd_poisson), negative_binomial = logLik(rd_nb)))

                        [,1]
poisson           -1529.4313
negative_binomial  -825.5576

Improvement!

rbind(
  obs = table(RecreationDemand$trips)[1:10], exp = round(sapply(0:9, function(x)sum(dpois(x, fitted(rd_poisson)))))
$)

      0   1  2  3  4  5  6  7  8 9
obs 417  68 38 34 17 13 11  2  8 1
exp 277 146 68 41 30 23 17 13 10 7

This model is under-predicting the zero number of trips. Perhaps it is time to use a zero-inflated model that will help to correct this undercounting.

$$f_{zeroinfl}(y) = p_i * I_{0}(y)+(1-p_i)*f_{count}(y;\mu_i)$$

Thus the linear predictor portion uses all of the independent variables and the inflation component to be a function of quality and income.

library(pscl)

rd_zinb <- zeroinfl(trips ~ . | quality + income, data = RecreationDemand, dist = "negbin")

summary(rd_zinb)

Call:
zeroinfl(formula = trips ~ . | quality + income, data = RecreationDemand, 
    dist = "negbin")

Pearson residuals:
     Min       1Q   Median       3Q      Max 
-1.08868 -0.20032 -0.05687 -0.04525 39.95749 

Count model coefficients (negbin with log link):
             Estimate Std. Error z value Pr(>|z|)    
(Intercept)  1.096094   0.257075   4.264 2.01e-05 ***
quality      0.169019   0.053135   3.181 0.001468 ** 
skiyes       0.500479   0.134496   3.721 0.000198 ***
income      -0.069203   0.043802  -1.580 0.114130    
userfeeyes   0.542557   0.282819   1.918 0.055062 .  
costC        0.040427   0.014522   2.784 0.005372 ** 
costS       -0.066202   0.007746  -8.547  < 2e-16 ***
costH        0.020609   0.010235   2.014 0.044061 *  
Log(theta)   0.189859   0.113134   1.678 0.093312 .  

Zero-inflation model coefficients (binomial with logit link):
            Estimate Std. Error z value Pr(>|z|)    
(Intercept)   5.7184     1.5596   3.667 0.000246 ***
quality      -8.3596     3.9380  -2.123 0.033768 *  
income       -0.2516     0.2847  -0.884 0.376832    
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 

Theta = 1.2091 
Number of iterations in BFGS optimization: 26 
Log-likelihood:  -722 on 12 Df

Let’s check the fit!

rbind(
  obs = table(RecreationDemand$trips)[1:10], 
$  exp = round(colSums(predict(rd_zinb, type = "prob")[,1:10]))
)

      0  1  2  3  4  5  6  7 8 9
obs 417 68 38 34 17 13 11  2 8 1
exp 433 47 35 27 20 16 12 10 8 7

Looks a great deal better!

Hurdle Models

Useful for an excessive number of zeros (or a small number of zeros). This is more widely used in economics according to the text. The hurdle consists of two parts

• Binary part given by a count distribution that is right censored at y = 1 (e.g. is the hurdle crossed)
• A count part given by a left-truncated distribution at y = 1 (e,g, if y > 0, how large is y)

rd_hurdle <- hurdle(trips ~ . | quality + income, data = RecreationDemand, dist = "negbin")

rbind(
  obs = table(RecreationDemand$trips)[1:10], 
$  exp = round(colSums(predict(rd_hurdle, type = "prob")[,1:10]))
)

      0  1  2  3  4  5  6 7 8 9
obs 417 68 38 34 17 13 11 2 8 1
exp 417 74 42 27 19 14 10 8 6 5

Censored Depdent Variables

A Tobit model posits that Gaussian linear predictor exists for a latent variable, $y_0$ exists. IT is reported only if the latent variable is positive.

Thus:

$$y_i^0= x_i^T\beta+\epsilon_i$$ $$y_i = \begin{cases} y_i, y_i^0 >0\ 0, y_i^0 \le 0 \end{cases},$$

data("Affairs")

head(Affairs)

   affairs gender age yearsmarried children religiousness education occupation
4        0   male  37        10.00       no             3        18          7
5        0 female  27         4.00       no             4        14          6
11       0 female  32        15.00      yes             1        12          1
16       0   male  57        15.00      yes             5        18          6
23       0   male  22         0.75       no             2        17          6
29       0 female  32         1.50       no             2        17          5
   rating
4       4
5       4
11      4
16      5
23      3
29      5

plot(affairs ~ gender, data = Affairs)

aff_tob <- tobit(affairs ~ age + yearsmarried + religiousness + occupation + rating, data = Affairs)

summary(aff_tob)

Call:
tobit(formula = affairs ~ age + yearsmarried + religiousness + 
    occupation + rating, data = Affairs)

Observations:
         Total  Left-censored     Uncensored Right-censored 
           601            451            150              0 

Coefficients:
              Estimate Std. Error z value Pr(>|z|)    
(Intercept)    8.17420    2.74145   2.982  0.00287 ** 
age           -0.17933    0.07909  -2.267  0.02337 *  
yearsmarried   0.55414    0.13452   4.119 3.80e-05 ***
religiousness -1.68622    0.40375  -4.176 2.96e-05 ***
occupation     0.32605    0.25442   1.282  0.20001    
rating        -2.28497    0.40783  -5.603 2.11e-08 ***
Log(scale)     2.10986    0.06710  31.444  < 2e-16 ***
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Scale: 8.247 

Gaussian distribution
Number of Newton-Raphson Iterations: 4 
Log-likelihood: -705.6 on 7 Df
Wald-statistic: 67.71 on 5 Df, p-value: 3.0718e-13 

linearHypothesis(aff_tob, c("age = 0", "occupation = 0"), vcov = sandwich)

Linear hypothesis test

Hypothesis:
age = 0
occupation = 0

Model 1: restricted model
Model 2: affairs ~ age + yearsmarried + religiousness + occupation + rating

Note: Coefficient covariance matrix supplied.

  Res.Df Df  Chisq Pr(>Chisq)  
1    596                       
2    594  2 4.9078    0.08596 .
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Age and occupation are joinly weakyl significant.

Ordinal Response Variables

library(MASS)
data("BankWages")

bank_polr <- polr(job~ education + minority, data = BankWages, subset = gender == "male", Hess = TRUE)
coeftest(bank_polr)

z test of coefficients:

                 Estimate Std. Error z value  Pr(>|z|)    
education        0.869998   0.093071  9.3476 < 2.2e-16 ***
minorityyes     -1.056438   0.411994 -2.5642   0.01034 *  
custodial|admin  7.951359   1.076932  7.3833 1.544e-13 ***
admin|manage    14.172125   1.474364  9.6124 < 2.2e-16 ***
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

@online{dewitt2018,
  author = {Michael E. DeWitt},
  title = {models of microeconomics},
  date = {2018-09-16},
  url = {https://michaeldewittjr.com/blog/2018-09-16-models-of-microeconomics/},
  langid = {en}
}
Copy

He sets up a small data set:

df <- ts(c(2735.869,2857.105,2725.971,2734.809,2761.314,2828.224,2830.284,
  2758.149,2774.943,2782.801,2861.970,2878.688,3049.229,3029.340,3099.041,
  3071.151,3075.576,3146.372,3005.671,3149.381), start=c(2016,8), frequency=12)

Which only has 20 months of data in it. He then applies a time series linear model with 2 sine/ cosine pair terms.

library(forecast)
library(ggplot2)
decompose_df <- tslm(df ~ trend + fourier(df, 2))

We can see the coefficients of the model here:

summary(decompose_df)

Call:
tslm(formula = df ~ trend + fourier(df, 2))

Residuals:
     Min       1Q   Median       3Q      Max 
-100.572  -33.513    5.743   24.430   79.728 

Coefficients:
                    Estimate Std. Error t value Pr(>|t|)    
(Intercept)         2637.357     24.862 106.080  < 2e-16 ***
trend                 24.541      2.077  11.816 1.14e-08 ***
fourier(df, 2)S1-12   76.553     17.105   4.475 0.000523 ***
fourier(df, 2)C1-12   -4.281     17.105  -0.250 0.806010    
fourier(df, 2)S2-12   36.931     16.203   2.279 0.038850 *  
fourier(df, 2)C2-12   10.402     16.802   0.619 0.545780    
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Residual standard error: 50.98 on 14 degrees of freedom
Multiple R-squared:  0.917, Adjusted R-squared:  0.8874 
F-statistic: 30.94 on 5 and 14 DF,  p-value: 4.307e-07

From there tou can see the trends for each of the components.

trend <- coef(decompose_df)[1] + coef(decompose_df)['trend']*seq_along(df)
components <- cbind(
  data = df,
  trend = trend,
  season = df - trend - residuals(decompose_df),
  remainder = residuals(decompose_df)
)
autoplot(components, facet=TRUE)

out <-forecast(decompose_df, newdata = df)
autoplot(out)

@online{dewitt2018,
  author = {Michael E. DeWitt},
  title = {Analysis of Short Time Series},
  date = {2018-07-19},
  url = {https://michaeldewittjr.com/blog/2018-07-19-analysis-of-short-time-series/},
  langid = {en}
}
Copy

What’s in an API?

An API is an application programming interface. It is basically a set of instructions for interfacing with a server. When working with web data you don’t need to render an entire website for viewing- you just want to get some raw data. You can do this through the API (often a REST) and talk to the server directly. Within this API you send a set of instructions that says what data you want and in what form you want it in. Then it sends you the data.

library(DiagrammeR)

mermaid("
graph LR
  Server-->Browser
Browser -->Server
  Browser-->Viewer
  Server-->API
  API-->Server
", height = 200)

What about internally?

Often times in the business world, we don’t necessarily access internal data though a REST API (unless you are Amazon) ¹.

If your company does internal APIs that is wonder. Quite honestly they aren’t too hard to set up and with a little help from plumber a data scientist could use R to set an API up. Not the best idea but it still stands, it can be done.

But what about common drives

This is where I have developed some APIs for myself and others. Perhaps data is stored in flatfiles on a common drive. Instead of everyone mapping to the drive at the start of each script, write a package to function like your own API, something like:

get_internal_data <- function(data_set){
  path <-"path/to/internal/directory"
  
  available_files <- list.files(path, pattern = ".csv$") %>% 
$    gsub(pattern = ".csv", replacement = "", .)
  
  if(!data_setv %in% available_files){
    stop("Data set not available")
  }
  
  df <- read_csv(file.path(path, data_set))
  
  df
}

Now anyone can use your function to call a data set. This saves some typing, and if you use the absolute mappings then this makes it easier to share internal code. Additionally, you could wrap this function, perhaps with several other to different data sources into a package. That package can then be shared and everyone will have easy access to the data. If the storage of items changes, then you can update the package details (via a version control system) and have everyone load the new package. This automatically changes the internals so their function to access the data is redirected to the new location!

This same kind of method could be used for accessing internal databases. Set you the connection and it provides you the tools to work with internal tools in an API-like fashion.

@online{dewitt2018,
  author = {Michael E. DeWitt},
  title = {make your own api},
  date = {2018-07-12},
  url = {https://michaeldewittjr.com/blog/2018-07-12-make-your-own-api/},
  langid = {en}
}
Copy

benchmarks <- function(y, h) {
  require(forecast)
  # Compute four benchmark methods
  fcasts <- rbind(
    N = snaive(y, h)$mean,
$    E = forecast(ets(y), h)$mean,
$    A = forecast(auto.arima(y), h)$mean,
$    T = thetaf(y, h)$mean)
$  colnames(fcasts) <- seq(h)
  method_names <- rownames(fcasts)
  # Compute all possible combinations
  method_choice <- rep(list(0:1), length(method_names))
  names(method_choice) <- method_names
  combinations <- expand.grid(method_choice) %>% tail(-1) %>% as.matrix()
  # Construct names for all combinations
  for (i in seq(NROW(combinations))) {
    rownames(combinations)[i] <- paste0(method_names[which(combinations[i, ] > 0)], 
      collapse = "")
  }
  # Compute combination weights
  combinations <- sweep(combinations, 1, rowSums(combinations), FUN = "/")
  # Compute combinations of forecasts
  return(combinations %*% fcasts)
}

library(Mcomp)
library(tidyverse)
# Compute "symmetric" percentage errors and scaled errors
errors <- map(M3[1:20], function(u) {
  train <- u$x
$  test <- u$xx
$  f <- benchmarks(train, u$h)
$  error <- -sweep(f, 2, test)
  pcerror <- (200 * abs(error) / sweep(abs(f), 2, abs(test), FUN = "+")) %>%
    as_tibble() %>%
    mutate(Method = rownames(f)) %>%
    gather(key = h, value = sAPE, -Method)
  scalederror <- (abs(error) / mean(abs(diff(train, lag = frequency(train))))) %>%
    as_tibble() %>%
    mutate(Method = rownames(f)) %>%
    gather(key = h, value = ASE, -Method)
  return(list(pcerror = pcerror, scalederror = scalederror))
})
# Construct a tibble with all results
M3errors <- tibble(
    Series = names(M3[1:20]),
    Period = map_chr(M3[1:20], "period"),
    se = map(errors, "scalederror"),
    pce = map(errors, "pcerror")) %>%
  unnest() %>%
  select(-h1, -Method1) %>%
  mutate(h = as.integer(h), 
         Period = factor(str_to_title(Period), 
                         levels = c("Monthly","Quarterly","Yearly","Other")))

accuracy <- M3errors %>%
  group_by(Period, Method, h) %>%
  summarize(MASE=mean(ASE), sMAPE=mean(sAPE)) %>%
  ungroup()

# Find names of original methods
original_methods <- unique(accuracy[["Method"]])
original_methods <- original_methods[str_length(original_methods)==1L]
# Compute summary table of accuracy measures
accuracy_table <- accuracy %>%
  group_by(Method,Period) %>%
  summarise(
    sMAPE = mean(sMAPE, na.rm = TRUE),
    MASE = mean(MASE, na.rm = TRUE) ) %>%
  arrange(MASE) %>% ungroup()
best <- accuracy_table %>% filter(MASE==min(MASE))
accuracy_table <- accuracy_table %>%
  filter(Method %in% original_methods | Method %in% best$Method) %>%
$  arrange(Period, MASE) %>%
  select(Period, Method, sMAPE, MASE)
knitr::kable(accuracy_table)

order <- accuracy_table %>% group_by(Method) %>% 
  summarise(MASE = mean(MASE)) %>% arrange(MASE) %>%
  pull("Method") %>% rev()
accuracy %>%
  gather(key = "Measure", value = "accuracy", sMAPE, MASE) %>%
  filter(Method %in% unique(accuracy_table$Method)) %>%
$  mutate(Method = factor(Method, levels=order)) %>%
  ggplot(aes(x = h, y = accuracy), group = Method) +
    geom_line(aes(col = Method)) + 
    facet_grid(rows = vars(Measure), cols=vars(Period), scale = "free") +
    xlab("Forecast horizon") + ylab("Forecast accuracy")

eat_ensemble <- function(y, h = ifelse(frequency(y) > 1, 2*frequency(y), 10)) {
  require(forecast)
  fets <- forecast(ets(y), h)
  farima <- forecast(auto.arima(y), h)
  ftheta <- thetaf(y, h)
  comb <- fets
  comb<span class="katex"><span class="katex-mathml"><math xmlns="http://www.w3.org/1998/Math/MathML"><semantics><mrow><mi>m</mi><mi>e</mi><mi>a</mi><mi>n</mi><mo>&lt;</mo><mo>−</mo><mo stretchy="false">(</mo><mi>f</mi><mi>e</mi><mi>t</mi><mi>s</mi></mrow><annotation encoding="application/x-tex">mean &lt;-(fets</annotation></semantics></math></span><span class="katex-html" aria-hidden="true"><span class="base"><span class="strut" style="height:0.5782em;vertical-align:-0.0391em;"></span><span class="mord mathnormal">m</span><span class="mord mathnormal">e</span><span class="mord mathnormal">an</span><span class="mspace" style="margin-right:0.2778em;"></span><span class="mrel">&lt;</span><span class="mspace" style="margin-right:0.2778em;"></span></span><span class="base"><span class="strut" style="height:1em;vertical-align:-0.25em;"></span><span class="mord">−</span><span class="mopen">(</span><span class="mord mathnormal" style="margin-right:0.10764em;">f</span><span class="mord mathnormal">e</span><span class="mord mathnormal">t</span><span class="mord mathnormal">s</span></span></span></span>mean + farima<span class="katex"><span class="katex-mathml"><math xmlns="http://www.w3.org/1998/Math/MathML"><semantics><mrow><mi>m</mi><mi>e</mi><mi>a</mi><mi>n</mi><mo>+</mo><mi>f</mi><mi>t</mi><mi>h</mi><mi>e</mi><mi>t</mi><mi>a</mi></mrow><annotation encoding="application/x-tex">mean + ftheta</annotation></semantics></math></span><span class="katex-html" aria-hidden="true"><span class="base"><span class="strut" style="height:0.6667em;vertical-align:-0.0833em;"></span><span class="mord mathnormal">m</span><span class="mord mathnormal">e</span><span class="mord mathnormal">an</span><span class="mspace" style="margin-right:0.2222em;"></span><span class="mbin">+</span><span class="mspace" style="margin-right:0.2222em;"></span></span><span class="base"><span class="strut" style="height:0.8889em;vertical-align:-0.1944em;"></span><span class="mord mathnormal" style="margin-right:0.10764em;">f</span><span class="mord mathnormal">t</span><span class="mord mathnormal">h</span><span class="mord mathnormal">e</span><span class="mord mathnormal">t</span><span class="mord mathnormal">a</span></span></span></span>mean)/3
  comb$method <- "ETS-ARIMA-Theta Combination"
$  return(comb)
}
USAccDeaths %>% eat_ensemble() %>% autoplot()

@online{dewitt2018,
  author = {Michael E. DeWitt},
  title = {Forecasting Benchmarks},
  date = {2018-07-11},
  url = {https://michaeldewittjr.com/blog/2018-07-11-forecasting-benchmarks/},
  langid = {en}
}
Copy

Similarly, I work with a lot of survey data. Classical test theory has some issues and having a robust construct validated through item response theory would be a good way to develop a more stable construct. Psychology/ sociological constructs are hard. This kind of research is just difficult with small signals and lots of noise in all of the measures. For this reason complicated methods are needed (generally speaking). This is why Bayesian methods and hierarchical modeling approaches are coming to vogue in the social sciences.

Anyways, back to IRT.

library(ltm)
library(mirt)
library(tidyverse)

I am going to load the mirt and ltm packages for use here (Chalmers 2012), (Rizopoulos 2006). The primary data set with Science. Here a preview of the data in the dataset of 392 respondents and 4 items.

head(Science) %>% knitr::kable()

Classical Methods

In a clasical methodology we could do some factor analysis and see how many latent variables we have in the items. I’ll use the n_factors function from the psycho package. This function applies ten different factor methods and then shows how many of the methods support a given number of factors.

library(psycho)

efa <-Science %>% 
  mutate_if(is.factor, as.numeric) %>% 
   qgraph::cor_auto(., forcePD = FALSE) %>% 
  nFactors::nScree(eigen(.)$values)
$
efa$Analysis
$```

      Eigenvalues      Prop      Cumu Par.Analysis  Pred.eig     OC Acc.factor
    1   2.0188352 0.5047088 0.5047088            1 1.1236282 (< OC)         NA
    2   0.9088057 0.2272014 0.7319102            1 0.7072366         0.7944225
    3   0.5931986 0.1482996 0.8802099            1        NA         0.2015691
    4   0.4791606 0.1197901 1.0000000            1        NA                NA
          AF
    1 (< AF)
    2       
    3       
    4       

Here the plurality of the methods shows that there is one factor in the
items with the plurality of the votes (supported by 8/10 methods).

We could also look at Cronbach’s <span class="katex"><span class="katex-mathml"><math xmlns="http://www.w3.org/1998/Math/MathML"><semantics><mrow><mi>α</mi></mrow><annotation encoding="application/x-tex">\alpha</annotation></semantics></math></span><span class="katex-html" aria-hidden="true"><span class="base"><span class="strut" style="height:0.4306em;"></span><span class="mord mathnormal" style="margin-right:0.0037em;">α</span></span></span></span> or tau equivalence
reliability. This metric is subject to the number of items and the
average item intercorrelation so it can be “cheated” but it is useful to
perform.

``` r
a<-Science %>% 
  mutate_if(is.factor, as.numeric) %>% 
  psych::alpha()
a$total %>% knitr::kable()
$```

|     | raw_alpha | std.alpha |   G6(smc) | average_r |     S/N |       ase |     mean |        sd |  median_r |
|:----|----------:|----------:|----------:|----------:|--------:|----------:|---------:|----------:|----------:|
|     |  0.597724 | 0.6029445 | 0.5514024 | 0.2751706 | 1.51854 | 0.0328745 | 2.917092 | 0.5007807 | 0.2987043 |

So alpha isn’t great. Ideally this value is \> 0.7.

## IRT

Now let’s go to IRT! For this instance there isn’t a **correct** answer
per say like on the SAT. That being said a correct answer is viewed as
the most difficult item in regard to the latent trait, typically one end
of the scale (strong agree or disagree or frequent).

So now using a graded response model:

``` r
lmod <- ltm::grm(Science, IRT.param = FALSE)

summary(lmod)

Call:
ltm::grm(data = Science, IRT.param = FALSE)

Model Summary:
   log.Lik      AIC      BIC
 -1608.871 3249.742 3313.282

Coefficients:
$Comfort

$ value beta.1 -4.863 beta.2 -2.639 beta.3 1.466 beta 1.041

$Work

$ value beta.1 -2.924 beta.2 -0.901 beta.3 2.267 beta 1.226

$Future

$ value beta.1 -5.243 beta.2 -2.217 beta.3 1.967 beta 2.299

$Benefit

$ value beta.1 -3.347 beta.2 -0.991 beta.3 1.688 beta 1.094

Integration:
method: Gauss-Hermite
quadrature points: 21 

Optimization:
Convergence: 0 
max(|grad|): 0.0092 
quasi-Newton: BFGS 

Equivalently, you can do this in mirt.

(mmod <- mirt(Science, 1, verbose=FALSE))

Call:
mirt(data = Science, model = 1, verbose = FALSE)

Full-information item factor analysis with 1 factor(s).
Converged within 1e-04 tolerance after 36 EM iterations.
mirt version: 1.38.1 
M-step optimizer: BFGS 
EM acceleration: Ramsay 
Number of rectangular quadrature: 61
Latent density type: Gaussian 

Log-likelihood = -1608.87
Estimated parameters: 16 
AIC = 3249.739
BIC = 3313.279; SABIC = 3262.512
G2 (239) = 213.56, p = 0.8804
RMSEA = 0, CFI = NaN, TLI = NaN

Now we can just look at the items and get a feel for the difficulty.

coef(mmod, simplify=TRUE)$items
$```

                  a1       d1        d2        d3
    Comfort 1.041755 4.864154 2.6399417 -1.466013
    Work    1.225962 2.924003 0.9011651 -2.266565
    Future  2.293372 5.233993 2.2137728 -1.963706
    Benefit 1.094915 3.347920 0.9916289 -1.688260

Now the really cool thing is to look at the item characteristic curves.

``` r
plot(mmod)

And the individual ICCs…

plot(mmod, type = "trace")

I hope to go into detail soon, but what these plots allow us to see if the individual item difficulty and the items ability to discrinimate a latent trait. This means how well can it separate out the latent factor from each item. And all this to say, once the items have been validated you can easily score the participants for the presence of the latent factor (yahoo!).

fscores(mmod) %>% 
  as_data_frame() %>% 
  rownames_to_column(var = "subject") %>%
  head() %>% 
  knitr::kable()

References

@online{dewitt2018,
  author = {Michael E. DeWitt},
  title = {IRT and the Rasch Model},
  date = {2018-07-11},
  url = {https://michaeldewittjr.com/blog/2018-07-11-irt-and-the-rasch-model/},
  langid = {en}
}
Copy

library(fpp2)
library(purrr)
library(dplyr)

I am going to test a few different methods:

• Mean forecasting

• Random Walk (last value is forecast with an addition)

• Seasonal Naive (last seasons value is next guess)

• Naive (Previous value is forecast)

beer2 <- window(ausbeer, start= 1992, end = c(2007,4))

beer_fit1 <- meanf(beer2, h=10)
beer_fit2 <- rwf(beer2, h=10)
beer_fit3 <- snaive(beer2, h=10)
beer_fit4 <- naive(beer2, h=10)

Let’s see how we did on the forecast.

beer3 <- window(ausbeer, start =2008)

models <- list(mean_forecast = beer_fit1, rand_walk = beer_fit2, seasonal_naive = beer_fit3,
               naive = beer_fit4)
map(models, accuracy, beer3)

$mean_forecast

$ ME RMSE MAE MPE MAPE MASE ACF1 Training set 0.000 43.62858 35.23438 -0.9365102 7.886776 2.463942 -0.10915105 Test set -13.775 38.44724 34.82500 -3.9698659 8.283390 2.435315 -0.06905715 Theil's U Training set NA Test set 0.801254

$rand_walk

$ ME RMSE MAE MPE MAPE MASE Training set 0.4761905 65.31511 54.73016 -0.9162496 12.16415 3.827284 Test set -51.4000000 62.69290 57.40000 -12.9549160 14.18442 4.013986 ACF1 Theil's U Training set -0.24098292 NA Test set -0.06905715 1.254009

$seasonal_naive

$ ME RMSE MAE MPE MAPE MASE ACF1 Training set -2.133333 16.78193 14.3 -0.5537713 3.313685 1.0000000 -0.2876333 Test set 5.200000 14.31084 13.4 1.1475536 3.168503 0.9370629 0.1318407 Theil's U Training set NA Test set 0.298728

$naive

$ ME RMSE MAE MPE MAPE MASE Training set 0.4761905 65.31511 54.73016 -0.9162496 12.16415 3.827284 Test set -51.4000000 62.69290 57.40000 -12.9549160 14.18442 4.013986 ACF1 Theil's U Training set -0.24098292 NA Test set -0.06905715 1.254009

Seasonal Naive looks like it won!

plot(beer_fit3)

@online{dewitt2018,
  author = {Michael E. DeWitt},
  title = {Exploring forecast},
  date = {2018-07-08},
  url = {https://michaeldewittjr.com/blog/2018-07-08-exploring-forecast/},
  langid = {en}
}
Copy

The hard part is then to know what is slowing you down. Perhaps you have optimised everything that you know how to do, use purrr and apply statements, move some code to cpp. Now what next?

Enter profvis

library("profvis")

Profvis provides a way to visualise the memory allocation and speed of each of your code. This includes simple things:

profvis({
  fit <- lm(mpg ~ wt + disp , data = mtcars)
  Sys.sleep(10)
  preds <- predict(fit)
})

Now we can see that the plotting function takes the majority of the time.

This is a super trivial example, but knowledge of tools like this help for streamlining code, especially when pushing it to users. Sometimes you don’t know where the hang-up in your code is and this can help you understand what is happening.

Then you can pull in other tools like microbenchmark or bench to time the different methods of improvement.

@online{dewitt2018,
  author = {Michael E. DeWitt},
  title = {Speed it up!},
  date = {2018-07-06},
  url = {https://michaeldewittjr.com/blog/2018-07-06-speed-it-up/},
  langid = {en}
}
Copy

When working with time series analysis, the benefits of Bayesian methods are also great. Bayes provides a way to use an hierarchical modeling approach, and assign probabilities to the outcomes. This super direct way of using uncertainity makes it a nice foil to 95% confidence intervals.

I have take the examples from StichFix’s blog where they contrast the methods of ARIMA and Bayesian Structural Times Series Modeling.

Arima

Autoregressive integrated moving average modeling technique with differencing = 1, and moving average term of 1.

library(lubridate)
library(bsts)
library(dplyr)
library(ggplot2)
library(forecast)


### Load the data
data("AirPassengers")
Y <- window(AirPassengers, start=c(1949, 1), end=c(1959,12))

### Fit the ARIMA model
arima <- arima(log10(Y), 
               order=c(0, 1, 1), 
               seasonal=list(order=c(0,1,1), period=12))

### Actual versus predicted
d1 <- data.frame(c(10^as.numeric(fitted(arima)), # fitted and predicted
                   10^as.numeric(predict(arima, n.ahead = 12)$pred)),
$                   as.numeric(AirPassengers), #actual values
                   as.Date(time(AirPassengers)))
names(d1) <- c("Fitted", "Actual", "Date")


### MAPE (mean absolute percentage error)
MAPE <- filter(d1, year(Date)>1959) %>% summarise(MAPE=mean(abs(Actual-Fitted)/Actual))

### Plot actual versus predicted
ggplot(data=d1, aes(x=Date)) +
  geom_line(aes(y=Actual, colour = "Actual"), size=1.2) +
  geom_line(aes(y=Fitted, colour = "Fitted"), size=1.2, linetype=2) +
  theme_bw() + theme(legend.title = element_blank()) + 
  ylab("") + xlab("") +
  geom_vline(xintercept=as.numeric(as.Date("1959-12-01")), linetype=2) +
  ggtitle(paste0("ARIMA -- Holdout MAPE = ", round(100*MAPE,2), "%")) + 
  theme(axis.text.x=element_text(angle = -90, hjust = 0))

Bayesian Structural Model

A different approach would be to use a Bayesian structural time series model with unobserved components. This technique is more transparent than ARIMA models and deals with uncertainty in a more elegant manner. It is more transparent because its representation does not rely on differencing, lags and moving averages. You can visually inspect the underlying components of the model. It handles uncertainty in a better way because you can quantify the posterior uncertainty of the individual components, control the variance of the components, and impose prior beliefs on the model. Last, but not least, any ARIMA model can be recast as a structural model.

The model form thus takes:

$$Y_t = \mu + x_t\beta+S_t + e_t$$

$$e_t \sim N(0,\sigma^2_e)$$

$$\mu_{t+1} = \mu_t + v_t$$

$$v_t \sim N(0, \sigma^2_v$$

Here xt denotes a set of regressors, St represents seasonality, and μt is the local level term. The local level term defines how the latent state evolves over time and is often referred to as the unobserved trend. This could, for example, represent an underlying growth in the brand value of a company or external factors that are hard to pinpoint, but it can also soak up short term fluctuations that should be controlled for with explicit terms. Note that the regressor coefficients, seasonality and trend are estimated simultaneously, which helps avoid strange coefficient estimates due to spurious relationships (similar in spirit to Granger causality, see 1). In addition, due to the Bayesian nature of the model, we can shrink the elements of β to promote sparsity or specify outside priors for the means in case we’re not able to get meaningful estimates from the historical data (more on this later).

library(lubridate)
library(bsts)
library(dplyr)
library(ggplot2)

### Load the data
data("AirPassengers")
Y <- window(AirPassengers, start=c(1949, 1), end=c(1959,12))
y <- log10(Y)


### Run the bsts model
ss <- AddLocalLinearTrend(list(), y)
ss <- AddSeasonal(ss, y, nseasons = 12)
bsts.model <- bsts(y, state.specification = ss, niter = 500, ping=0, seed=2016)

### Get a suggested number of burn-ins
burn <- SuggestBurn(0.1, bsts.model)

### Predict
p <- predict.bsts(bsts.model, horizon = 12, burn = burn, quantiles = c(.025, .975))

### Actual versus predicted
d2 <- data.frame(
    # fitted values and predictions
    c(10^as.numeric(-colMeans(bsts.model$one.step.prediction.errors[-(1:burn),])+y),  
$    10^as.numeric(p$mean)),
$    # actual data and dates 
    as.numeric(AirPassengers),
    as.Date(time(AirPassengers)))
names(d2) <- c("Fitted", "Actual", "Date")

### MAPE (mean absolute percentage error)
MAPE <- filter(d2, year(Date)>1959) %>% summarise(MAPE=mean(abs(Actual-Fitted)/Actual))

### 95% forecast credible interval
posterior.interval <- cbind.data.frame(
  10^as.numeric(p$interval[1,]),
$  10^as.numeric(p$interval[2,]), 
$  subset(d2, year(Date)>1959)$Date)
$names(posterior.interval) <- c("LL", "UL", "Date")

### Join intervals to the forecast
d3 <- left_join(d2, posterior.interval, by="Date")

### Plot actual versus predicted with credible intervals for the holdout period
ggplot(data=d3, aes(x=Date)) +
  geom_line(aes(y=Actual, colour = "Actual"), size=1.2) +
  geom_line(aes(y=Fitted, colour = "Fitted"), size=1.2, linetype=2) +
  theme_bw() + theme(legend.title = element_blank()) + ylab("") + xlab("") +
  geom_vline(xintercept=as.numeric(as.Date("1959-12-01")), linetype=2) + 
  geom_ribbon(aes(ymin=LL, ymax=UL), fill="grey", alpha=0.5) +
  ggtitle(paste0("BSTS -- Holdout MAPE = ", round(100*MAPE,2), "%")) +
  theme(axis.text.x=element_text(angle = -90, hjust = 0))

credible.interval <- cbind.data.frame(
  10^as.numeric(apply(p$distribution, 2,function(f){quantile(f,0.75)})),
$  10^as.numeric(apply(p$distribution, 2,function(f){median(f)})),
$  10^as.numeric(apply(p$distribution, 2,function(f){quantile(f,0.25)})),
$  subset(d3, year(Date)>1959)$Date)
$names(credible.interval) <- c("p75", "Median", "p25", "Date")

credible.interval %>% knitr::kable(digits = 0)

You can also extract the different components

library(lubridate)
library(bsts)
library(ggplot2)
library(reshape2)

### Set up the model
data("AirPassengers")
Y <- window(AirPassengers, start=c(1949, 1), end=c(1959,12))
y <- log10(Y)
ss <- AddLocalLinearTrend(list(), y)
ss <- AddSeasonal(ss, y, nseasons = 12)
bsts.model <- bsts(y, state.specification = ss, niter = 500, ping=0, seed=2016)

### Get a suggested number of burn-ins
burn <- SuggestBurn(0.1, bsts.model)

### Extract the components
components <- cbind.data.frame(
  colMeans(bsts.model$state.contributions[-(1:burn),"trend",]),                               
$  colMeans(bsts.model$state.contributions[-(1:burn),"seasonal.12.1",]),
$  as.Date(time(Y)))  
names(components) <- c("Trend", "Seasonality", "Date")
components <- melt(components, id="Date")
names(components) <- c("Date", "Component", "Value")

### Plot
ggplot(data=components, aes(x=Date, y=Value)) + geom_line() + 
  theme_bw() + theme(legend.title = element_blank()) + ylab("") + xlab("") + 
  facet_grid(Component ~ ., scales="free") + guides(colour=FALSE) + 
  theme(axis.text.x=element_text(angle = -90, hjust = 0))

And of course use Bayes for variable selection using the spike and slab method (I was trained to call it stochastic variable selection…but whatever)

library(lubridate)
library(bsts)
library(ggplot2)
library(reshape2)

### Fit the model with regressors
data(iclaims)
ss <- AddLocalLinearTrend(list(), initial.claims$iclaimsNSA)
$ss <- AddSeasonal(ss, initial.claims$iclaimsNSA, nseasons = 52)
$bsts.reg <- bsts(iclaimsNSA ~ ., state.specification = ss, data =
                initial.claims, niter = 500, ping=0, seed=2016)

### Get the number of burn-ins to discard
burn <- SuggestBurn(0.1, bsts.reg)

### Helper function to get the positive mean of a vector
PositiveMean <- function(b) {
  b <- b[abs(b) > 0]
  if (length(b) > 0) 
    return(mean(b))
  return(0)
}

### Get the average coefficients when variables were selected (non-zero slopes)
coeff <- data.frame(melt(apply(bsts.reg$coefficients[-(1:burn),], 2, PositiveMean)))
$coeff$Variable <- as.character(row.names(coeff))
$ggplot(data=coeff, aes(x=reorder(Variable,value), y=value)) + 
  coord_flip()+
  geom_bar(stat="identity", position="identity") + 
  theme(axis.text.x=element_text(angle = -90, hjust = 0)) +
  xlab("") + ylab("") + ggtitle("Average coefficients")

### Inclusion probabilities -- i.e., how often were the variables selected 
inclusionprobs <- melt(colMeans(bsts.reg$coefficients[-(1:burn),] != 0))
$inclusionprobs$Variable <- as.character(row.names(inclusionprobs))
$ggplot(data=inclusionprobs, aes(x=reorder(Variable, value), y=value)) + 
  geom_bar(stat="identity", position="identity") + 
  theme(axis.text.x=element_text(angle = -90, hjust = 0)) + 
  coord_flip()+
  xlab("") + ylab("") + ggtitle("Inclusion probabilities")

library(lubridate)
library(bsts)
library(ggplot2)
library(reshape2)

### Fit the model with regressors
data(iclaims)
ss <- AddLocalLinearTrend(list(), initial.claims$iclaimsNSA)
$ss <- AddSeasonal(ss, initial.claims$iclaimsNSA, nseasons = 52)
$bsts.reg <- bsts(iclaimsNSA ~ ., state.specification = ss, data =
                initial.claims, niter = 500, ping=0, seed=2016)

### Get the number of burn-ins to discard
burn <- SuggestBurn(0.1, bsts.reg)

### Get the components
components.withreg <- cbind.data.frame(
  colMeans(bsts.reg$state.contributions[-(1:burn),"trend",]),
$  colMeans(bsts.reg$state.contributions[-(1:burn),"seasonal.52.1",]),
$  colMeans(bsts.reg$state.contributions[-(1:burn),"regression",]),
$  as.Date(time(initial.claims)))  
names(components.withreg) <- c("Trend", "Seasonality", "Regression", "Date")
components.withreg <- melt(components.withreg, id.vars="Date")
names(components.withreg) <- c("Date", "Component", "Value")

ggplot(data=components.withreg, aes(x=Date, y=Value)) + geom_line() + 
  theme_bw() + theme(legend.title = element_blank()) + ylab("") + xlab("") + 
  facet_grid(Component ~ ., scales="free") + guides(colour=FALSE) + 
  theme(axis.text.x=element_text(angle = -90, hjust = 0))

And of course adding priors

library(lubridate)
library(bsts)
library(ggplot2)
library(reshape2)

data(iclaims)

prior.spikes <- c(0.1,0.1,0.1,0.1,0.1,0.1,0.1,0.1,0.1,1,0.1)
prior.mean <- c(0,0,0,0,0,0,0,0,0,0.6,0)

### Helper function to get the positive mean of a vector
PositiveMean <- function(b) {
  b <- b[abs(b) > 0]
  if (length(b) > 0) 
    return(mean(b))
  return(0)
}

### Set up the priors
prior <- SpikeSlabPrior(x=model.matrix(iclaimsNSA ~ ., data=initial.claims), 
                        y=initial.claims$iclaimsNSA, 
$                        prior.information.weight = 200,
                        prior.inclusion.probabilities = prior.spikes,
                        optional.coefficient.estimate = prior.mean)
                        
### Run the bsts model with the specified priors
data(iclaims)
ss <- AddLocalLinearTrend(list(), initial.claims$iclaimsNSA)
$ss <- AddSeasonal(ss, initial.claims$iclaimsNSA, nseasons = 52)
$bsts.reg.priors <- bsts(iclaimsNSA ~ ., state.specification = ss, 
                        data = initial.claims, 
                        niter = 500, 
                        prior=prior, 
                        ping=0, seed=2016)


### Get the average coefficients when variables were selected (non-zero slopes)
coeff <- data.frame(melt(apply(bsts.reg.priors$coefficients[-(1:burn),], 2, PositiveMean)))
$coeff$Variable <- as.character(row.names(coeff))
$ggplot(data=coeff, aes(x=Variable, y=value)) + 
  geom_bar(stat="identity", position="identity") + 
  theme(axis.text.x=element_text(angle = -90, hjust = 0)) + 
  xlab("") + ylab("")

So with all of this said we can build Bayesian structural time series models easily, adding prior information, use variable selection and accurately indicate our uncertainity about future predictions. This is pretty powerful stuff. It is also why these techniques are used for anomaly detection and causal inference.

@online{dewitt2018,
  author = {Michael E. DeWitt},
  title = {Bayesian Time Series Analysis with bsts},
  date = {2018-07-05},
  url = {https://michaeldewittjr.com/blog/2018-07-05-bayesian-time-series-analysis-with-bsts/},
  langid = {en}
}
Copy