R Langauge on R Views

Wordle Data Analysis

Mon, 21 Feb 2022 00:00:00 +0000

Arthur Holtz is a Senior FP&A Manager at Shipt, but don’t let the title mislead you — he spends most of his days buried in databases and R, analyzing data. This post is neither affiliated with nor endorsed by his employer.

Intro

By now, I’m sure most people are familiar with the viral game Wordle. If you’ve been living under a rock and have no idea what I’m talking about, I recommend playing it for yourself. The best way I can describe it is: Take the classic board game Mastermind, but play with words instead of colored pegs. It’s a fun little game that encourages sharing and comparing scores with your friends – which I think explains a lot of its popularity!

Speaking of comparing scores, my wife routinely gets a better score than I do, so I’ve been trying to come up with better strategies. A few weeks ago, YouTube recommended 3Blue1Brown’s fantastic video on information theory and Wordle strategy. After watching it, I felt inspired. I could do something along those lines! Granted, I’m nowhere near as sophisticated as the creator of that video, but I thought it would be a fun challenge to crack open the game’s script and see what I could do with its data. With all the background out of the way, let’s jump into it!

Getting Started

First, we will need to include a number of libraries for this analysis. Most of these should be familiar to anyone who works with R regularly so I won’t add more color here.

suppressMessages({
library(httr)
library(dplyr)
library(stringr)
library(ggplot2)
library(ggthemes)
library(scales)
library(tidyr)})

From the 3B1B video, I found out you can view the code powering Wordle simply by viewing the page source in your browser and finding the JavaScript. As of writing, that code is here. Now, I’ll admit, I don’t know much of anything about JavaScript, but that doesn’t really matter – the word list is stored in plain text as an array.

If you look through the code, you might notice there are actually 2 word lists: The first, called Ma, is a list of 2,309 words that Wordle uses for puzzle solutions (there used to be 2,315 but apparently the NYT removed a few). The second list, called Oa, is a list of words it will accept as valid guesses. Since Oa has a lot more obscure words that will never show up as the answer, for this exercise, I am focusing entirely on Ma.

The first thing I do is simply download the .js file and save it as a giant string of text, which I’m calling wordle_script_text. In the event the script or domain name ever changes, all you need to do is paste in the new URL here.

url = "https://www.nytimes.com/games/wordle/main.18637ca1.js"
wordle_script_text = GET(url) %>%
  content(as = "text", encoding = "UTF-8")

Parsing the Word List

Next, I’m doing something messy that deserves some more explanation. I couldn’t figure out a good way to programmatically extract the entire word list by looking for the start and end points of the array, so instead, I scrolled through it in a text editor and manually identified the first and last words (cigar and shave, respectively). Then I told R to look for those particular words and extract everything between the two. It’s not ideal since rearranging the word list would completely break the rest of my script, so I’m open to any suggestions here!

Anyway, that left me with a giant string of comma separated words. From there, I removed any escaped quotation marks and separated each word into its own element by splitting the string at each comma. Then I converted all of that to a data frame where each row is a word, renamed the column, and converted every word to upper case. I call this data frame word_list.

word_list = substr(
  wordle_script_text,
  # cigar is the first word
  str_locate(wordle_script_text, "cigar")[,"start"],
  # shave is the last word
  str_locate(wordle_script_text, "shave")[,"end"]) %>%
  str_remove_all("\"") %>%
  str_split(",") %>%
  data.frame() %>%
  select(word = 1) %>%
  mutate(word = toupper(word))

Now we have our word list!

##    word
## 1 CIGAR
## 2 REBUT
## 3 SISSY
## 4 HUMPH
## 5 AWAKE

Determining Overall Letter Frequency

From there, my first idea was to get a frequency diagram of how often each letter appears. After all, intuitively, you wouldn’t expect letters like “X” to show up very often so it doesn’t make a lot of sense to play a word with “X” in it (unless you have a good reason). In the code below, I’m taking word_list and converting it back to a character vector, splitting every single character into its own element, and converting to a data frame again. I’m calling this data frame letter_list.

At this point, I should clarify why I did filter(row_number() != 1). R added a c() when I converted to a vector, which I don’t want to count towards the letter counts. This filter removes that extra c.

Continuing with the rest of the code, I renamed the column, filtered for upper-case letters only, and summarized by letter counts in descending order.

letter_list = word_list %>%
  as.character() %>%
  str_split("") %>%
  data.frame() %>%
  filter(row_number() != 1) %>%
  select(letter = 1) %>%
  filter(letter %in% LETTERS) %>%
  group_by(letter) %>%
  summarize(freq = n()) %>%
  arrange(desc(freq))

And now we have our frequency by letter!

## # A tibble: 5 × 2
##   letter  freq
##   <chr>  <int>
## 1 E       1230
## 2 A        975
## 3 R        897
## 4 O        753
## 5 T        729

But this isn’t very easy to read. Let’s throw it into a plot. A few callouts here:

By default, ggplot sorts the x axis in alphabetical order. reorder forces ggplot to put the most frequent observations first.
I used stat = "identity" since we already summarized letter_list in the previous section.
I used expand = c(0,0) to make the bars stretch all the way to the axis.

ggplot(letter_list, aes(x = reorder(letter, (-freq)), y = freq)) +
  geom_bar(fill = "lightblue",
           stat = "identity") +
  geom_text(aes(x = reorder(letter, (-freq)),
                y = freq,
                label = comma(freq, accuracy = 1),
                vjust = 1),
            size = 2) +
  scale_y_continuous(labels = comma,
                     expand = c(0,0)) +
  theme_clean() +
  xlab("Letter") +
  ylab("Frequency") +
  labs(caption = "Generated by Arthur Holtz\nlinkedin.com/in/arthur-holtz/") +
  ggtitle("Letter Frequency in Wordle's Official Word List")

Much better! Looking at this plot, my naive strategy is to open with words containing letters on the left side of the plot. They’re much more likely to show up – but even if they don’t, knowing that is also valuable information. So maybe something like “TEARS” or “IRATE” (my wife’s favorite) is a good starter. One interesting thing to note is that this doesn’t match the overall letter frequency in English.

Determining Letter Frequency for Each Position

That’s all good to know, but I want more. Where do we go next? I got to thinking it would be helpful to know which letters are most likely to appear where.

To that end, I took word_list and split each letter into its own column. R added an empty column when I tried to do this, so I had to add an extra column (into = as.character(1:6)) and then remove the empty one and rename the others (the select). Ugh, whatever. I called this data frame ordered_letter_list.

ordered_letter_list = word_list %>%
  separate(word,
           sep = "",
           into = as.character(1:6)) %>%
  select(-1,
         "l_1" = 2,
         "l_2" = 3,
         "l_3" = 4,
         "l_4" = 5,
         "l_5" = 6)

Now we have a set of data that looks like this:

##   l_1 l_2 l_3 l_4 l_5
## 1   C   I   G   A   R
## 2   R   E   B   U   T
## 3   S   I   S   S   Y
## 4   H   U   M   P   H
## 5   A   W   A   K   E

I wanted to plot each of these letter positions on its own chart, so I first created a function called build_df that we can call in a for loop that only takes one column at a time and summarizes it with the most to least common letters.

build_df = function(df, col_name) {
  new_df = df %>%
    group_by(letter = eval(sym(col_name))) %>%
    summarize(freq = n()) %>%
    arrange(desc(freq))

  return(new_df)
}

Now we plug this function into a for loop to generate a plot for each letter position. Compared to the single plot before, there are some new things that are worth explaining:

I create an object called letter_# and I set its value to be ordered_letter_list, but only including the letter number in question.
Since we’re inside a for loop, ggplot won’t normally display plots. I wrap everything in print to make sure we can see the plots.

for (i in 1:5) {
  this_df = paste0("letter_", i)
  assign(this_df, build_df(ordered_letter_list, paste0("l_", i)))

  title = paste0("Letter # ", i, " Frequency in Wordle's Official Word List")

  print(ggplot(eval(sym(this_df)), aes(x = reorder(letter, (-freq)), y = freq)) +
    geom_bar(fill = "lightblue",
             stat = "identity") +
    geom_text(aes(x = reorder(letter, (-freq)),
                  y = freq,
                  label = comma(freq, accuracy = 1),
                  vjust = 1),
              size = 2) +
    scale_y_continuous(labels = comma,
                       expand = c(0,0)) +
    theme_clean() +
    xlab("Letter") +
    ylab("Frequency") +
    labs(caption = "Generated by Arthur Holtz\nlinkedin.com/in/arthur-holtz/") +
    ggtitle(title))
}

With these 5 additional charts in my arsenal, now I know not only which letters are most common in general, but also where they are most likely to appear. One thing I was really surprised to find was just how uncommon “S” is as the 5th letter — only 36 out of 2,309 words! My best guess is the creators deliberately removed a number of plural words so there wouldn’t be so many words ending in “S.” It’s also neat how the 5 most frequent letters for the 3rd position are the vowels.

Brute Forcing Words with the Best “Score”

After discussing the initial analysis above with my dad, we came up with another idea: What if we took every word and bumped it up against every other word in Wordle’s list, and scored the guesses based on how much information they reveal on average?

I created a data frame called ordered_letter_list_rev that’s mostly the same as ordered_letter_list, except I only took the first 50 words (I’ll explain why later) and I kept the full word as the first column.

ordered_letter_list_rev = substr(
  wordle_script_text,
  str_locate(wordle_script_text, "cigar")[,"start"],
  str_locate(wordle_script_text, "shave")[,"end"]) %>%
  str_remove_all("\"") %>%
  str_split(",") %>%
  data.frame() %>%
  select(word = 1) %>%
  mutate(word = toupper(word)) %>%
  head(50) %>%
  separate(word,
           sep = "",
           into = as.character(1:6),
           remove = FALSE) %>%
  select(-2,
         "l_1" = 3,
         "l_2" = 4,
         "l_3" = 5,
         "l_4" = 6,
         "l_5" = 7)

Here is what it looks like:

##    word l_1 l_2 l_3 l_4 l_5
## 1 CIGAR   C   I   G   A   R
## 2 REBUT   R   E   B   U   T
## 3 SISSY   S   I   S   S   Y
## 4 HUMPH   H   U   M   P   H
## 5 AWAKE   A   W   A   K   E

Next, I created a data frame called cross_joined where I joined ordered_letter_list_rev to itself without any matching criteria. This is why I did head(50) in the previous section — the resulting data frame will square the row count of the original data frame, and I wanted to start with a reasonable-sized subset. If you have access to cloud computing resources, the sheer amount of data is less of a concern, but I’m running this on a personal computer, so bear with me.

Since this self-join would leave us with duplicate column names, I used suffixes = c("_guess","_target") in the merge function to distinguish the guesses from the target words. I also filtered out any rows where the guess is the same as the target since these cases don’t give us any useful information.

Next came the scoring. My (somewhat arbitrary) idea was to give 3 points for getting the right letter in the right place, 1 point for the right letter in the wrong place, and 0 points for wrong letters. I know I did this part extremely inefficiently since there’s a lot of copy/pasted code. I tried searching Stack Overflow for how to do this properly but eventually realized I had spent more time searching than I would have spent using good ol’ copy/paste in the first place. Again, if you know a better way, I’m wide open to suggestions!

cross_joined = merge(ordered_letter_list_rev,
                     ordered_letter_list_rev,
                     by = NULL,
                     suffixes = c("_guess","_target")) %>%
  filter(word_guess != word_target) %>%
  mutate(
    l_1_score = case_when(
      l_1_guess == l_1_target ~ 3,
      l_1_guess == l_2_target ~ 1,
      l_1_guess == l_3_target ~ 1,
      l_1_guess == l_4_target ~ 1,
      l_1_guess == l_5_target ~ 1,
      TRUE ~ 0),
    l_2_score = case_when(
      l_2_guess == l_2_target ~ 3,
      l_2_guess == l_1_target ~ 1,
      l_2_guess == l_3_target ~ 1,
      l_2_guess == l_4_target ~ 1,
      l_2_guess == l_5_target ~ 1,
      TRUE ~ 0),
    l_3_score = case_when(
      l_3_guess == l_3_target ~ 3,
      l_3_guess == l_1_target ~ 1,
      l_3_guess == l_2_target ~ 1,
      l_3_guess == l_4_target ~ 1,
      l_3_guess == l_5_target ~ 1,
      TRUE ~ 0),
    l_4_score = case_when(
      l_4_guess == l_4_target ~ 3,
      l_4_guess == l_1_target ~ 1,
      l_4_guess == l_2_target ~ 1,
      l_4_guess == l_3_target ~ 1,
      l_4_guess == l_5_target ~ 1,
      TRUE ~ 0),
    l_5_score = case_when(
      l_5_guess == l_5_target ~ 3,
      l_5_guess == l_1_target ~ 1,
      l_5_guess == l_2_target ~ 1,
      l_5_guess == l_3_target ~ 1,
      l_5_guess == l_4_target ~ 1,
      TRUE ~ 0),
    total_score = l_1_score + l_2_score + l_3_score + l_4_score + l_5_score)

This gave me a data frame like this:

##   word_guess l_1_guess l_2_guess l_3_guess l_4_guess l_5_guess word_target
## 1      REBUT         R         E         B         U         T       CIGAR
## 2      SISSY         S         I         S         S         Y       CIGAR
## 3      HUMPH         H         U         M         P         H       CIGAR
## 4      AWAKE         A         W         A         K         E       CIGAR
## 5      BLUSH         B         L         U         S         H       CIGAR
##   l_1_target l_2_target l_3_target l_4_target l_5_target l_1_score l_2_score
## 1          C          I          G          A          R         1         0
## 2          C          I          G          A          R         0         3
## 3          C          I          G          A          R         0         0
## 4          C          I          G          A          R         1         0
## 5          C          I          G          A          R         0         0
##   l_3_score l_4_score l_5_score total_score
## 1         0         0         0           1
## 2         0         0         0           3
## 3         0         0         0           0
## 4         1         0         0           2
## 5         0         0         0           0

While exploring the data here, I noticed something strange. To illustrate, let’s take a look at the score breakdown for guessing MARRY when the target word is MAJOR.

##   l_1_score l_2_score l_3_score l_4_score l_5_score total_score
## 1         3         3         1         1         0           8

Notice letters 3 and 4 (both Rs) are getting 1 point each. That’s not right! There’s only one R in MAJOR so this guess should really only get 7 points. There were a number of other cases like this (ERASE was a major offender because it has 2 Es, which you might recall was the most common letter in Wordle overall). The scores for guesses like these are inflated, so I wouldn’t trust this scoring logic.

Conclusion

This is where I got stuck. It must be possible to only give points for repeat letters once if there is only one such letter in the answer — but how? I can’t figure it out without making a super-complicated case_when statement. If someone has a brilliant idea, I’d be thrilled to expand upon this analysis in a future update.

And where would you go next? Assuming I can solve the scoring problem, I’d also like to use the entire Oa word list as my guessing pool so I can find the most useful guesses, even if they won’t necessarily be the target word.

I hope you’ve enjoyed walking through Wordle’s code and word list with me! Even though I couldn’t complete all the analysis I originally set out to do, I’m just hoping the overall and by-location frequency analysis give me enough of an edge to do better than my wife!

Fake Survival Data for the Disease Progression Model

Thu, 08 Oct 2020 00:00:00 +0000

In a previous post, I showed some examples of simulating fake data from a few packages that are useful for common simulation tasks and indicated that I would be following up with a look at simulating survival data. A tremendous amount of work in survival analysis has been done in R¹ and it will take some time to explore what’s out there. In this first post, I am just going to jump into the ocean of ideas and see if I can fish out and interesting example.

Markov models are commonly used in Health Care Economics to model the progression of a disease, and the efficacy and potential benefits of various treatments. One popular approach is to consider cohorts of patients who move through the three states of being healthy (no disease progression), diseased (some level of disease progression) and dead.

The following figure illustrates the process. (I will explain the labeling on the arrows below).

These kinds of models are commonly called multi-state models in the survival literature. In the simplest case, disease progression might be modeled as a discrete time Markov chain where patients move from state-to-state according to a matrix of transition probabilities which govern how the process develops at discrete time intervals. However, for many studies, limiting transitions to discrete, uniform intervals is a little too simplistic. For example, in most cases, the exact time when a patient “progresses” from healthy to deceased is not observed. To account for this, modelers frequently consider Continuous Time Markov Chain which allow modeling the distribution of time spent in each state as well as the state-to-state transitions.

One way to define a continuous time Markov chain is as a continuous time process that takes values in a discrete state space and obeys the Markov property where the transition to a future state depends only on the present and not on the past.

A continuous-time stochastic process $X_{t}, t \geq 0$ with discrete state space S is a continuous-time Markov chain if: \[P(X_{t+s}=j \:|\: X_{s}=i), X_u = x_u, 0 \leq u < s) = P(X_{t+s}=j \: | \: X_{s}=i)\] \[ \forall s,t \geq 0 \:, i, j, x_{u} \in S, \: 0 \leq u < s \] If the process does not depend on the the particular value of s (the time when the process is in state i) then it is said to be time homogeneous. For a very readable account of how the definition above along with the assumption of time homogeneity ensure both the Markov property and that the time the process spends in the various states will be exponentially distributed, see Chapter 7 of Dobrow (2016).

One more bit of theory before we get to the example: unlike discrete time Markov chains, the development of a continuous time process is not driven by a transition matrix. Instead, state transition probabilities are generated by a matrix, Q, that gives the instantaneous rates of going from one state to another. Transition probabilities for any time, t, are then calculated from Q using matrix exponentiation.

\[P(t)=e^Q\] The following is the Q matrix for our three state disease progression model. Notice, that this is not a stochastic matrix: the rows sum to 0 not to 1. The basic idea is that the rate of flow into a state i is equal to the flow out of i. The final row is all zeroes in our Q matrix because death is an absorbing state and there are not transitions back to healthy from diseased.

\[Q = \begin{pmatrix} \ -(q_{12} + q_{13}) & q_{12} & q_{13}) \\ \ 0 & -q_{23} & q_{23} \\ \ 0 & 0 & 0 \end{pmatrix} \]

Armed with a little bit of theory, let’s see how continuous time Markov chains can be used both to simulate survival data and also to fit a model to the fake data.

Generating Simulated Survival Data

The following is essentially the example on page 12 of the pdf for the genSurv package² listed in the CRAN Survival Task View. This shows how to use the genTHMM() function to simulate data from a time homogeneous, continuous time Markov Chain. In the code below, the model.cens parameter indicates that censoring is accomplished via a uniform distribution over the interval [0, cens.par]. A covariate is generated by a uniform distribution over the interval [0, covar] and enters the model through the equation:

\[q_{i,j} = \lambda_{i,j} exp(\beta_{i,j} \cdot v)\] where $\lambda_{i,j}$ is the base rate, parameter rate for the genTHMM() function and $\beta_{i,j}$ are the regression coefficients, beta in the function. In the code below, we use the covariate output to create a sex covariate.

set.seed(1234)
thmmdata <- genTHMM( n=100, model.cens="uniform", # censorship model
                     cens.par = 20, 
                     beta = c(0.01,0.08,0.05),
                     covar = 1, 
                     rate = c(0.1,0.05,0.08) )
                     
df <- thmmdata %>% mutate(sex = if_else(covariate <= .5,0,1 ))
df <- df %>% mutate_if(is.numeric, round, 3)
head(df,11)

##    PTNUM   time state covariate sex
## 1      1  0.000     1     0.114   0
## 2      1  2.183     2     0.114   0
## 3      1  2.265     3     0.114   0
## 4      2  0.000     1     0.233   0
## 5      2  0.284     2     0.233   0
## 6      2  1.396     3     0.233   0
## 7      3  0.000     1     0.283   0
## 8      3  8.600     2     0.283   0
## 9      3 18.469     2     0.283   0
## 10     4  0.000     1     0.267   0
## 11     4  3.734     1     0.267   0

For more on the theory underlying the genSurv package have a look at the paper Meira-Mechado et al. (2009).

Fitting the Survival Model

The code in this section fits a continuous time, Markov chain survival model to the data generated above using the msm package³ and indicates how one might go about examining the output.

First, let’s look at the transitions between states that occurred for the simulated patients.

st <- statetable.msm(state, PTNUM,data = thmmdata)
st

##     to
## from  1  2  3
##    1 28 50 22
##    2  0 25 25

We see, for example, 50 progressed to the diseased state and 22 patient went directly from being healthy to dead. 25 patients who progressed to disease, subsequently died.

Next, we set up the Q matrix of instantaneous transition rates described above,

Q <- matrix(c(0, 1, 1, 0, 0 , 1, 0, 0 , 0), nrow = 3, byrow = TRUE)
rownames(Q) <- c("S1", "S2", "S3")
colnames(Q)  <- c("S1", "S2", "S3")
Q

##    S1 S2 S3
## S1  0  1  1
## S2  0  0  1
## S3  0  0  0

fit the model, and plot the survival curves for states S1 and S2 using the “old school” pre-built plot method.

fit <- msm( state ~ time, subject=PTNUM, data = df, 
            qmatrix = Q, gen.inits = TRUE, covariates = ~ sex)
plot(fit)

The default print method for the mode fit shows the transition intensities with the hazard ratio of the covariate.

fit

## 
## Call:
## msm(formula = state ~ time, subject = PTNUM, data = df, qmatrix = Q,     gen.inits = TRUE, covariates = ~sex)
## 
## Maximum likelihood estimates
## Baselines are with covariates set to their means
## 
## Transition intensities with hazard ratios for each covariate
##         Baseline                    sex                   
## S1 - S1 -0.28724 (-0.37477,-0.2202)                       
## S1 - S2  0.24020 ( 0.17891, 0.3225) 0.8992 (0.49769,1.625)
## S1 - S3  0.04703 ( 0.02057, 0.1076) 0.2106 (0.04132,1.073)
## S2 - S2 -0.09756 (-0.14312,-0.0665)                       
## S2 - S3  0.09756 ( 0.06650, 0.1431) 0.6558 (0.30473,1.411)
## 
## -2 * log-likelihood:  413.3 
## [Note, to obtain old print format, use "printold.msm"]

We can get the transition rates for sex = 0,

qmatrix.msm(fit, covariates = list(sex = 0))

##    S1                          S2                         
## S1 -0.3583 (-0.51092,-0.25130)  0.2537 ( 0.16167, 0.39804)
## S2 0                           -0.1211 (-0.20856,-0.07037)
## S3 0                           0                          
##    S3                         
## S1  0.1046 ( 0.04986, 0.21962)
## S2  0.1211 ( 0.07037, 0.20856)
## S3 0

and for sex = 1.

qmatrix.msm(fit, covariates = list(sex = 1))

##    S1                            S2                           
## S1 -0.25013 (-0.357720,-0.17490)  0.22810 ( 0.155472, 0.33464)
## S2 0                             -0.07945 (-0.136411,-0.04627)
## S3 0                             0                            
##    S3                           
## S1  0.02204 ( 0.005169, 0.09396)
## S2  0.07945 ( 0.046269, 0.13641)
## S3 0

and msm also allows us to calculate the transition function $P(t)$ for arbitrary times.

pmatrix.msm(fit, t= 13.3)

##         S1     S2     S3
## S1 0.02192 0.3182 0.6599
## S2 0.00000 0.2732 0.7268
## S3 0.00000 0.0000 1.0000

Finally, we look at the mean sojourn times for patients in the healthy and diseased states. Normally, for a process that can transition in and out of states this means the average time spent in the state each time it is visited. For our model, patients, only go forward through the chain, there is no getting better, so the sojourn for S2 is essentially the average amount of time patients spent in the diseased state.

sojourn.msm(fit)

##    estimates     SE     L      U
## S1     3.481 0.4725 2.668  4.542
## S2    10.251 2.0045 6.987 15.038

A Few Remarks

¹The work done in R on survival analysis, and partially embodied in the two hundred thirty-three packages listed in the CRAN Survival Analysis Task View, constitutes a fundamental contribution to statistics. There is enough material here for a lifetime of study. Even confining oneself to a tour of the eleven packages listed in the simulation section would be a significant undertaking.

² genSurv is a pretty bare bones package having just seven functions and little explanatory text. If it was not listed on the CRAN Task View, it would have been easy pass by. Nevertheless, I have only shown a small portion of what it can do.

³msm is an example of why R is a treasury of statistical knowledge. Not only does the package offer an impressive array of capabilities for analyzing multi-state Markov models in continuous time, the basic documentation, the package’s pdf, includes references to quite a few of the fundamental papers.

November 2019: "Top 40" New R Packages

Fri, 20 Dec 2019 00:00:00 +0000

One hundred forty-four new packages made it to CRAN in November. Here are my picks for the “Top 40” in eight categories: Computational Methods, Data, Genomics, Machine Learning, Statistics, Time Series, Utilities, and Visualization.

Computational Methods

calculus v0.1.1: Provides C++ optimized functions for numerical and symbolic calculus including symbolic arithmetic, tensor calculus, Einstein summation convention, Taylor series expansion, multivariate Hermite polynomials and much more.

Jaya v0.1.9: Implements a gradient-free algorithm, without hyperparameters, for solving both constrained and unconstrained optimization problems. See Rao (2016) for details and the vignette for how to use the package.

treenomial v1.1.1: Provides functions for creating and comparing polynomials that uniquely describe trees as introduced in Liu (2019). See README for information.

Data

eudract v0.9.0: Provides access to the European Clinical Trials Data Base ( EudraCT), which summarizes of all registered clinical trial results. The intent is to prevent non-reporting of negative results and provide open-access to results to inform future research. There is a vignette.

ozmaps v0.2.0: Provides maps of Australian coastline and administrative regions as well as simple functions for country or state maps of Australia, and in-built data sets of administrative regions from the Australian Bureau of Statistics. See README for examples.

presentes v0.1.0: Provides a compilation and digitization of the official registry of victims of state terrorism in Argentina during the last military coup. The original data comes from RUVTE-ILID (2019) research and the List of Victims.

VancouvR : Provides a wrapper for the City of Vancouver Open Data API. There is an Introduction.

wiesbaden v1.2.0: Implements an interface to retrieve and import data from different databases of the Federal Statistical Office of Germany (DESTATIS). There is a vignette.

Genomics

biocompute v1.0.3: Provides tools to create, validate, and export BioCompute Objects as described in King et al. (2019). There is an Introduction and a vignette on Authoring Biocompute Objects.

diem v1.0: Implements a novel semi-supervised machine learning classier DIEM, Debris Identification using Expectation Maximization, to identify debris-containing droplets from a droplet-based single cell/nucleus RNA-seq. See the vignette for details.

Machine Learning

azuremlsdk v0.5.7: Implements an interface to the Azure Machine Learning Software Development Kit enabling data scientists to train, deploy, automate, and manage machine learning models on the Azure Machine Learning service. There are vignettes on Setup and Installation.

hereR v0.2.0: Implements an interface to the HERE REST APIs which provide information on geocoding, routing directions, traffic flow, and weather forecasts. There are vignettes on Authentication, the Geocoder API, the Routing API, the Traffic API, and the Weather API.

hilbertSimilarity v0.4.3: Uses Hilbert Curves to develop the notion of Hilbert Similarity to quantify the similarity between samples in high dimensional data. There are vignettes on Comparing Samples and Identifying Treatment Effects.

orf v0.1.2: Implements the Ordered Forest estimator as developed in Lechner & Okasa (2019) to estimate the conditional probabilities of models with ordered categorical outcome (ordered choice models). See the vignette for details.

RPEClust v0.1.0: Implements the random projection ensemble clustering algorithm described in Anderlucci et al.(2019) and Raftery and Dean (2006).

Statistics

DiffXTables v0.0.2: Provides functions for statistical hypothesis testing of pattern heterogeneity via differences in underlying distributions across two or more contingency tables. It includes the comparative chi-squared test, the Sharma-Song test, and the heterogeneity test. See the vignette for details.

effectsize v0.0.1: Provides functions to work with indices of effect size and standardized parameters for a wide variety of models (See Lüdecke, Waggoner & Makowski (2019).) There are vignettes on Bayesian Models, Converting Between Incices, Automated Interpretation of Indices, Data Standardization and Parameter Standardization.

exPrior v1.0.1: Provides practitioners of statistics in geology, hydrology, etc. with a tool for deriving prior distributions for Bayesian inference. See the vignette.

fitHeavyTail v0.1.1: Implements robust estimation methods for the mean vector and covariance matrix from data (possibly containing NAs) under multivariate heavy-tailed distributions such as angular Gaussian, Cauchy, and Student’s t. See Sun et al. (2014), Sun et al. (2015), Liu and Rubin (1995) and Zhou et al. (2015) for background, and the vignette for examples.

mixl v1.1: Provides functions for simulated maximum likelihood estimation of multinomial logit models, mixed models, random coefficients and hybrid choice models. See Molloy et al. (2019) for details and the User Guide.

MKdescr v0.5: Provides functions to compute a standardized interquartile range (IQR), a Huber-type skipped mean as described in Hampel (1985), a robust coefficient of variation as described in Arachchige et al. (2019), a robust signal to noise ratio (SNR), and more. See the vignette.

MNLpred v0.0.1: Provides functions to return simulated predicted probabilities and first differences for multinomial logit models. The methodological approach is based on the principles laid out by King, Tomz, and Wittenberg (2000). See the vignette for examples.

pdqr v0.2.0: Provides functions to create, transform, and summarize custom discrete and continuous random variables with distribution functions that are analogues of p*(), d*(), q*(), and r*(). There are vignettes on Creating, Converting, Transforming, and Summarizing pdqr functions.

tensorregression v1.0: Implements the generalized tensor regression in Xu, Hu and Wang (2019) to solve tensor-response regression given covariates on multiple modes with alternating updating algorithm.

tidydice: v0.0.4: Provides functions for basic statistical experiments, that can be used for teaching introductory statistics. See the vignette.

tvgeom v1.0.1: Implements the probability mass, distribution, quantile, and random number generating functions for the time-varying right-truncated geometric distribution. See the vignette for background.

Time Series

gravitas v0.1.0: Provides tools for systematically exploring large quantities of temporal data across different temporal granularities (deconstructions of time) by visualizing probability distributions. There are vignettes on exploring probability distributions for cricket and for bivariate temporal franularities.

smoots v1.0.1: Provides nonparametric estimates of trend and its derivatives in equidistant time series with short-memory stationary errors. See Feng and Gries (2017) for the methods employed, and see README for an example.

tsfgrnn v0.1.0: Implements a general regression neural network (GRNN), a variant of a radial basis function network, for forecasting time series. See Martinez et al. (2019) and Yan (2012) for background and the vignette for examples.

Utilities

dipsaus v0.0.3: Provides enhancement functions that fall into four categories: shiny input widgets; high-performance computing using RcppParallel and future; functions to modify R calls and convert numbers, strings, and other objects; and utility functions to get system information such as CPU chipset, memory limit, etc. See the vignettes: Asynchronous Evaluator, R Expression Add-ons, Shiny Customized Widgets, and Utility Functions.

extraoperators v0.1.1: Provides operator functions for common tasks such as logical or relational comparisons, finding indices and subsetting. See the vignette for details.

gluedown v1.0.1: Provides functions to transition between R vectors and markdown text. Users can create vectors in R, glue strings together with the markdown syntax, and print formatted vectors directly to the document. This package primarily uses GitHub Flavored Markdown. There is a vignette on GitHub Flavored Markdown and another on Printing Markdown.

googlesheets4 v0.1.0: Provides functions for interacting with Google Sheets through the Sheets API v4. See README for help.

hdd v0.1.0: Provides a data class for importing and manipulating out of memory data sets. See the Introduction.

RVerbalExpressions v0.1.0: Provides tools to build regular expressions using grammar and functionality inspired by VerbalExpressions. See the vignette for examples.

shinyMobile v0.1.0: Provides tools for building shiny apps for iOS, Android, and desktop computers as well as beautiful shiny gadgets. shinyMobile is built on top of the latest ‘Framework7’ template. There is a Getting Started Guide and vignettes on Dark-Theme, Gadgets, Single-Layout, Split-Layout, Tabs-Layout, and Tools.

tidycwl v1.0.4: Implements the Common Workflow Language for describing data analysis workflows. See the vignette for details.

Visualization

barplot3d v1.0.1: Provides functions for creating 3D plots including sequence context plots used in DNA sequencing analysis. See the vignette for examples.

fplot v0.2.0: Provides functions to plot regular/weighted/conditional distributions by using formulas. See the vignette for examples.

robvis: v0.3.0: Provides functions for visualizing risk-of-bias assessments performed as part of a systematic review, providing tools for randomized controlled trials ( Sterne et al. (2019)), non-randomized studies of interventions ( Sterne et al (2016)), and diagnostic accuracy studies ( Whiting et al (2011)). There is a vignette.

tidyposterior's Bayesian Approach to Model Comparison

Mon, 16 Dec 2019 00:00:00 +0000

A task common to many machine learning workflows is to compare the performance of several models with respect to some metric such as accuracy or area under the ROC curve. Standard practice is to try out several different algorithms on a training data set and see which works better. Unfortunately, all to often, after this work has been done, model selection comes down to “eyeballing” several different ROC curves. If you find eyeballing a little too informal, then take a look at the tidyposterior package (part of the universe of ‘tidymodels`). The Getting Started vignette asks the question:

When looking at resampling results, are the differences between the models “real”?

and lays out a modelling approach to answering it that is grounded in Bayesian theory. This means that all of the information about the differences between two models to be compared will be summed up in a posterior distribution for the differences that will make it possible to calculate probabilities entirely based on the particular data at hand, the information encoded in the various priors, and the effect size that has been chosen because it is considered large enough to make a practical difference. Given an effect size chosen up front to represent a practical difference, the tidyposterior model will enable conclusions such as; there is a probability of .65 that, for all practical purposes, the two distributions are different.

There is no magic here. tidyposterior works through the mechanics of an Bayesian analysis with minimum input from the user (a situation that is possible because of the very constrained nature of comparison problem and the use of cross-validation statistics as input), but the result ultimately comes down to choosing an effect size that makes sense based on domain knowledge of the underlying experiment. For some studies, an effect of .05 might seem to be reasonable. In a situation where having an interpretable is worth more than a black-box prediction modelers may be willing to go higher. And, for studies where models may support life or death decisions something in the 2% range may be required.

The Getting Started guide provides end-to-end road map on using the tidyposterior functions to compare models, but it assumes quite a bit of background. Someone just getting started with Bayesian statistics or doing Bayesian statistics in R, might be more comfortable with a little more description of the landscape. For the rest of this post, I’ll be the tour guide and provide a little color commentary that you may find helpful as you walk through the vignette.

The first thing to point out is that the vignette begins after most of the heavy lifting for a model comparison study has already been done, and the information required to compare models has been wrapped up in the data frame precise_example.

As website for tidyposterior states:

precise_example contains the results of the classification analysis of a real data set using 10-fold CV. The holdout data sets contained thousands of examples and have precise performance estimates. Three models were fit to the original data and several performance metrics are included.

precise_example[,-1]

## # A tibble: 10 x 28
##    id    glm_Accuracy glm_Kappa glm_ROC glm_Sens glm_Spec glm_PRAUC
##    <chr>        <dbl>     <dbl>   <dbl>    <dbl>    <dbl>     <dbl>
##  1 Fold…        0.722     0.328   0.798    0.729    0.720     0.489
##  2 Fold…        0.696     0.290   0.778    0.720    0.691     0.456
##  3 Fold…        0.701     0.297   0.790    0.723    0.696     0.486
##  4 Fold…        0.704     0.316   0.795    0.763    0.691     0.497
##  5 Fold…        0.721     0.324   0.797    0.722    0.721     0.481
##  6 Fold…        0.711     0.303   0.780    0.706    0.712     0.484
##  7 Fold…        0.702     0.305   0.790    0.739    0.694     0.485
##  8 Fold…        0.718     0.321   0.784    0.729    0.715     0.477
##  9 Fold…        0.720     0.328   0.795    0.739    0.715     0.491
## 10 Fold…        0.719     0.324   0.796    0.728    0.717     0.488
## # … with 21 more variables: glm_Precision <dbl>, glm_Recall <dbl>,
## #   glm_F <dbl>, knn_Accuracy <dbl>, knn_Kappa <dbl>, knn_ROC <dbl>,
## #   knn_Sens <dbl>, knn_Spec <dbl>, knn_PRAUC <dbl>, knn_Precision <dbl>,
## #   knn_Recall <dbl>, knn_F <dbl>, nnet_Accuracy <dbl>, nnet_Kappa <dbl>,
## #   nnet_ROC <dbl>, nnet_Sens <dbl>, nnet_Spec <dbl>, nnet_PRAUC <dbl>,
## #   nnet_Precision <dbl>, nnet_Recall <dbl>, nnet_F <dbl>

The various statistics for the different models have been matched by setting a random number seed and using the same random sampling process for each fold. This is the kind of thing that can easily be done with the rsample or caret packages, but requires a bit of work otherwise.

The Getting Started vignette focuses on ROC, the area under the ROC Curve. A little bit of preprocessing produces “wide” and “long” (or stacked) versions of the ROC statistics. Note that information on the performance statistics contained in the data set can be found on the yardstick reference page.

This first bit of code selects the ROC for the different statistics and creates a stacked version of the data set.

rocs <- precise_example %>%
  select(id, contains("ROC")) %>%
  setNames(tolower(gsub("_ROC$", "", names(.)))) 
rocs

## # A tibble: 10 x 4
##    id       glm   knn  nnet
##    <chr>  <dbl> <dbl> <dbl>
##  1 Fold01 0.798 0.753 0.843
##  2 Fold02 0.778 0.744 0.827
##  3 Fold03 0.790 0.743 0.846
##  4 Fold04 0.795 0.755 0.852
##  5 Fold05 0.797 0.760 0.838
##  6 Fold06 0.780 0.747 0.852
##  7 Fold07 0.790 0.757 0.833
##  8 Fold08 0.784 0.754 0.832
##  9 Fold09 0.795 0.764 0.846
## 10 Fold10 0.796 0.748 0.847

rocs_stacked <- gather.rset(rocs)
head(rocs_stacked)

##       id model statistic
## 1 Fold01   glm    0.7981
## 2 Fold02   glm    0.7779
## 3 Fold03   glm    0.7901
## 4 Fold04   glm    0.7948
## 5 Fold05   glm    0.7972
## 6 Fold06   glm    0.7804

The first graph of the vignette plots the ROC cross-validation statistics for each fold. The fact that the lines are nearly all parallel indicates that there is probably a resampling effect, but it does look like there is a clear difference in the performance of the three models.

ggplot(rocs_stacked, aes(x = model, y = statistic, group = id, col = id)) + geom_line(alpha = .75) + theme(legend.position = "none")

The following plot makes the performance differences even more apparent. There is very little overlap of the kernel density estimates of the three distributions.

ggplot(rocs_stacked, aes(x = statistic, col = model, fill = model)) + 
  geom_histogram(aes(y=..density..), alpha=0.5, position="identity", bins = 35)+
  geom_density(alpha=.2) + xlim(min = .73, max = .87) +
  geom_rug()

Quantifying these differences is the point of our exercise. The strategy will be to fit a Bayesian model that explicitly accounts for the fold effects, and then compare the differences in posterior distributions to calculate the probability that the various distributions are indeed different.

Here, we fit the model with the tidyposterior function perf_mod(). Note that although the only parameter passed to perf_mod() is to set the seed, other options can be specified. A great deal of attention has been put into setting the defaults. I will explain the model perf_mod() executes below when we examine the resulting model object.

roc_model <- perf_mod(rocs, seed = 2824)

I have suppressed the voluminous output generated by fitting the model, but if you run it yourself, you will see that there was a lot going on under the covers. Four independent Markov chains were initiated for the stan Monte Carlo algorithm used to evaluate the model, each chain going through 1,000 warm up iterations and then another 1,000 to fit the model.

perf_mod()is based on the glmer() function from the rstanarm package. We can assess the rstanarm model object which is returned as part of perf_mod model object.

summary(roc_model$stan)

## 
## Model Info:
##  function:     stan_glmer
##  family:       gaussian [identity]
##  formula:      statistic ~ model + (1 | id)
##  algorithm:    sampling
##  sample:       4000 (posterior sample size)
##  priors:       see help('prior_summary')
##  observations: 30
##  groups:       id (10)
## 
## Estimates:
##                                     mean   sd   10%   50%   90%
## (Intercept)                       0.8    0.0  0.8   0.8   0.8  
## modelknn                          0.0    0.0  0.0   0.0   0.0  
## modelnnet                         0.1    0.0  0.0   0.1   0.1  
## b[(Intercept) id:Fold01]          0.0    0.0  0.0   0.0   0.0  
## b[(Intercept) id:Fold02]          0.0    0.0  0.0   0.0   0.0  
## b[(Intercept) id:Fold03]          0.0    0.0  0.0   0.0   0.0  
## b[(Intercept) id:Fold04]          0.0    0.0  0.0   0.0   0.0  
## b[(Intercept) id:Fold05]          0.0    0.0  0.0   0.0   0.0  
## b[(Intercept) id:Fold06]          0.0    0.0  0.0   0.0   0.0  
## b[(Intercept) id:Fold07]          0.0    0.0  0.0   0.0   0.0  
## b[(Intercept) id:Fold08]          0.0    0.0  0.0   0.0   0.0  
## b[(Intercept) id:Fold09]          0.0    0.0  0.0   0.0   0.0  
## b[(Intercept) id:Fold10]          0.0    0.0  0.0   0.0   0.0  
## sigma                             0.0    0.0  0.0   0.0   0.0  
## Sigma[id:(Intercept),(Intercept)] 0.0    0.0  0.0   0.0   0.0  
## 
## Fit Diagnostics:
##            mean   sd   10%   50%   90%
## mean_PPD 0.8    0.0  0.8   0.8   0.8  
## 
## The mean_ppd is the sample average posterior predictive distribution of the outcome variable (for details see help('summary.stanreg')).
## 
## MCMC diagnostics
##                                   mcse Rhat n_eff
## (Intercept)                       0.0  1.0  2691 
## modelknn                          0.0  1.0  2977 
## modelnnet                         0.0  1.0  3314 
## b[(Intercept) id:Fold01]          0.0  1.0  3389 
## b[(Intercept) id:Fold02]          0.0  1.0  1162 
## b[(Intercept) id:Fold03]          0.0  1.0  3683 
## b[(Intercept) id:Fold04]          0.0  1.0  2016 
## b[(Intercept) id:Fold05]          0.0  1.0  2888 
## b[(Intercept) id:Fold06]          0.0  1.0  3557 
## b[(Intercept) id:Fold07]          0.0  1.0  3332 
## b[(Intercept) id:Fold08]          0.0  1.0  1952 
## b[(Intercept) id:Fold09]          0.0  1.0  1929 
## b[(Intercept) id:Fold10]          0.0  1.0  3219 
## sigma                             0.0  1.0  1391 
## Sigma[id:(Intercept),(Intercept)] 0.0  1.0  1386 
## mean_PPD                          0.0  1.0  4180 
## log-posterior                     0.2  1.0   688 
## 
## For each parameter, mcse is Monte Carlo standard error, n_eff is a crude measure of effective sample size, and Rhat is the potential scale reduction factor on split chains (at convergence Rhat=1).

The default model constructed by perf_mod() specified by the R formula statistic ~ model + (1 | id) is a Bayesian, multi-level, varying intercept, linear regression model with an intercept, coefficients for the knn and nnet model effects, and an intercept for each of the cross-validation folds. This model might be written as:

Y_i = $\alpha$ + $\beta$X_i + b_[i]

in the one of the common notations used by Bayesians. (For example, see Gelman and Hill (2007).

rstanarm allows R users to build a wide range of Bayesian regression models using the stan engine without having to explicitly program in stan. That’s the good news. The bad news is that R’s formula interface takes some getting used to. A good source for learning the how to interpret formulas for the type of model we are considering here is the vignette for the lme4 package which implements Frequentist analog of this sort of model. (For an in depth discussion of the pros and cons of R formula interface see the Max Kuhn’s two posts on the subject: pros here and cons here .

You can examine the prior default prior distributions that were selected for this model as follows:

rstanarm::prior_summary(roc_model$stan)

## Priors for model 'roc_model$stan' 
## ------
## Intercept (after predictors centered)
##   Specified prior:
##     ~ normal(location = 0, scale = 10)
##   Adjusted prior:
##     ~ normal(location = 0, scale = 0.38)
## 
## Coefficients
##   Specified prior:
##     ~ normal(location = [0,0], scale = [2.5,2.5])
##   Adjusted prior:
##     ~ normal(location = [0,0], scale = [0.094,0.094])
## 
## Auxiliary (sigma)
##   Specified prior:
##     ~ exponential(rate = 1)
##   Adjusted prior:
##     ~ exponential(rate = 26)
## 
## Covariance
##  ~ decov(reg. = 1, conc. = 1, shape = 1, scale = 1)
## ------
## See help('prior_summary.stanreg') for more details

Now, that the model has been fit, we use the tidyposterior function tidy() to extract the posterior samples from the perf_mod() model object, examine the first few values and plot the posterior distributions for the three models being compared. (Note that you may also find the tidybayes package helpful in examining draws from the posterior distribution.)

roc_post <- tidy(roc_model)
glimpse(roc_post)

## Observations: 12,000
## Variables: 2
## $ model     <chr> "glm", "glm", "glm", "glm", "glm", "glm", "glm", "glm"…
## $ posterior <dbl> 0.7934, 0.7905, 0.7919, 0.7891, 0.7889, 0.7887, 0.7867…

Also, even though this is a relatively simple ANOVA type model, some model checking ought to be done to determine whether the model is good enough to be interpreted. This kind of checking can be done interactively with the shinystan application that can be launched with the command:

launch_shinystan(roc_model$stan)

The following screen capture from shinystan shows the diagnostics for the intercept for the seventh fold of the cross-validation. Note that the mixing (variability from high to low) in the top left graph which shows a trace of the Markov chain for this parameter looks quite good.

The vignette shows violin plots for each of the three models, but in order to make the comparison with the data plot above, I plot the distributions with histograms, kernel density, and rug plots.

roc_post2 <- as.data.frame(roc_post) # get object of class data.frame
ggplot(roc_post2, aes(x = posterior, col = model, fill = model)) + 
  geom_histogram(aes(y=..density..), alpha=0.5, position="identity", bins = 100)+
  geom_density(alpha=.2) + xlim(min = .74, max = .86) +
  geom_rug()

Notice that the distribution all look like pretty narrow, normal distributions. And although it sure looks like there is quite a bit of difference between the distributions of ROC values for the glm and nnet models, we can quantify the difference by setting up a contrast computing the posterior difference in RMSE for the two models as nnet - glm.

glm_v_nnet <- contrast_models(roc_model, "nnet", "glm")
head(glm_v_nnet)

##   difference model_1 model_2
## 1    0.04669    nnet     glm
## 2    0.04897    nnet     glm
## 3    0.05226    nnet     glm
## 4    0.05251    nnet     glm
## 5    0.05364    nnet     glm
## 6    0.05583    nnet     glm

Ideally, before beginning a modeling effort, one would have some idea about how different the models have to be in order to make any practical difference. Let’s suppose that there needs to be at least a 5% increase in ROC area between the two distributions for there to be a practical difference. We can compute this probability by setting the size parameter to the summary() function to 0.05.

summary(glm_v_nnet, size = 0.05)

## # A tibble: 1 x 9
##   contrast probability   mean  lower  upper  size pract_neg pract_equiv
##   <chr>          <dbl>  <dbl>  <dbl>  <dbl> <dbl>     <dbl>       <dbl>
## 1 nnet vs…           1 0.0511 0.0459 0.0563  0.05         0       0.351
## # … with 1 more variable: pract_pos <dbl>

The column labeled probability indicates that all of the density of the difference is positive. mean, lower and upper give the mean of the posterior difference distribution, and the lower and upper bounds plotted. pract_neg and prac_pos report the result of a calculation that uses the Highest Density Interval HDI, the narrowest interval containing some prespecified percentage of the probability density curve, to determine the Region of Practical Equivalence, ROPE. pract_neg indicates that none of the density is below the interval of meaningful difference and prac_pos indicates that 65% of the density is above the area of practical equivalence. The latter can be interpreted as saying that the probability that the two distributions are different for all practicable purposes is .65. Likewise, pract_equiv means that there is a 35% chance that the two distributions are practically equivalent.

ggplot(glm_v_nnet, size = .05)

The contrast_models() function is also flexible enough to perform multiple simultaneous contrasts. Here, we set up to contrast both the glm model against the nnet model and the knn model at the 5% level

models_contrast <- contrast_models(roc_model, list("knn","nnet"), list("glm", "glm"))
summary(models_contrast, size=.05)

## # A tibble: 2 x 9
##   contrast probability    mean   lower   upper  size pract_neg pract_equiv
##   <chr>          <dbl>   <dbl>   <dbl>   <dbl> <dbl>     <dbl>       <dbl>
## 1 knn vs …           0 -0.0377 -0.0430 -0.0325  0.05   0.00025       1.000
## 2 nnet vs…           1  0.0511  0.0459  0.0563  0.05   0             0.351
## # … with 1 more variable: pract_pos <dbl>

Note that first row of the table above and the following plot both indicate that there is no practical difference between the glm and knn models at the 5% level.

ggplot(models_contrast, size = .05)

Because the vignette also mentions accuracy, the fraction of correct predictions, we briefly repeat the above analysis using accuracy as the performance measure.

acc <- precise_example %>%
  select(id, contains("Accuracy")) %>%
  setNames(tolower(gsub("_Accuracy$", "", names(.)))) 
acc_model <- perf_mod(acc,seed = 2824)

The posterior distributions for accuracy are tightly clustered and indicate that the models yield different levels of performance for this measure.

acc_post <- as.data.frame(tidy(acc_model)) # get object of class data.frame
ggplot(roc_post2, aes(x = posterior, col = model, fill = model)) + 
  geom_histogram(aes(y=..density..), alpha=0.5, position="identity", bins = 50) +
  geom_density(alpha=.2) + xlim(min = .74, max = .86) +
  geom_rug()

And, the contrast_models() function that confirms the practical difference.

acc_models_contrast <- contrast_models(acc_model, list("knn","nnet"), list("glm", "glm"))
summary(acc_models_contrast, size=.05)

## # A tibble: 2 x 9
##   contrast probability    mean   lower   upper  size pract_neg pract_equiv
##   <chr>          <dbl>   <dbl>   <dbl>   <dbl> <dbl>     <dbl>       <dbl>
## 1 knn vs …           0 -0.239  -0.250  -0.229   0.05         1     0      
## 2 nnet vs…           1  0.0687  0.0583  0.0792  0.05         0     0.00175
## # … with 1 more variable: pract_pos <dbl>

ggplot(acc_models_contrast, size = .05)

Note that the nnet model comes out on top with respect to both ROC and accuracy, but there appears to be a practical differences in practical differences. A modeler who is primarily interested in accuracy as the performance metric would likely be more confident than a modeler who has selected ROC as the performance metric. This example should serve as a warning not to engage in performance measure hacking. Choose your performance measure before you compute anything.

For additional reading, look here for a short presentation by Max Kuhn on the key tidyposterior ideas, and see the the following papers for an in-depth look at the underlying theory: Benavoli et al. (2017) and Kruschke and Liddell (2017). For Bayesian analysis in general, and more on the ROPE concept see: Kruschke (2014). Doing Bayesian Data Analysis, Second Edition: A Tutorial with R, JAGS, and Stan (2 edition).

In-Database Logistic Regression with R

Wed, 04 Dec 2019 00:00:00 +0000

Roland Stevenson is a data scientist and consultant who may be reached on Linkedin.

In a previous article we illustrated how to calculate xgboost model predictions in-database. This was referenced and incorporated into tidypredict. After learning more about what the tidypredict team is up to, I discovered another tidyverse package called modeldb that fits models in-database. It currently supports linear regression and k-means clustering, so I thought I would provide an example of how to do in-database logistic regression.

Rather than focusing on the details of logistic regression, we will focus more on how we can use R and some carefully written SQL statements to iteratively minimize a cost function. We will also use the condusco R package, which allows us to iterate through the results of a query easily.

A Simple Logistic Regression Example

Let’s start with a simple logistic regression example. We’ll simulate an outcome $y$ based on the fact that $Pr(y=1) = \frac{e^{\beta x}}{1+e^{\beta x}}$. Here $\beta$ is a vector containing the coefficients we will later be estimating (including an intercept term). In the example below, our $x$ values are uniform random values between -1 and 1.

set.seed(1)

# the number of samples
n <- 1000

# uniform random on (-1,1)
x1 <- 2*runif(n)-1
x2 <- 2*runif(n)-1
x <- cbind(1, x1, x2)

# our betas
beta <- c(-1, -3.0, 5.0)

probs <- exp(beta %*% t(x))/(1+exp(beta %*% t(x)))

y <- rbinom(n,1,probs)

sim <- data.frame(id = seq(1:n), y = y, x1 = x1, x2 = x2)

mylogit <- glm(y ~ x1 + x2, data = sim, family = "binomial")
summary(mylogit)
mylogit$coefficients

As expected, the coefficients of our logistic model successfully approximate the parameters in our beta vector.

In-database Logistic Regression

Now, let’s see if we can find a way to calculate these same coefficients in-database. In this example, we’re going to use Google BigQuery as our database, and we’ll use condusco’s run_pipeline_gbq function to iteratively run the functions we define later on. To do this, we’ll need to take care of some initial housekeeping:

library(bigrquery)
library(whisker)
library(condusco)

# Uncomment and define your own config
# config <- list(
#   project = '<YOUR GBQ PROJECT>',
#   dataset = '<YOUR GBQ DATASET>',
#   table_prefix = '<A TABLE_PREFIX TO USE>'
# )

# a simple whisker.render helper function for our use-case
wr <- function(s, params=config){whisker.render(s,params)}

# put the simulated data in GBQ
insert_upload_job(
  project = wr('{{{project}}}'),
  dataset = wr('{{{dataset}}}'),
  table = "logreg_sim",
  values = sim,
  write_disposition = "WRITE_TRUNCATE"
)

Now, we’ll create the pipelines to do the logistic regression. Please note that the code below is quite verbose. While all of it is needed for the code to work, we’ll just focus on understanding how a couple of steps work. Once we understand one step, the rest is pretty easy. Feel free to skip ahead.

First, we create a pipeline that does two things:

create a main table containing all of our global settings
calls another pipeline (log_reg_stack) with the global settings as inputs

Importantly, note that all of the parameters (eg. {{{project}}}) are dynamically swapped out in the query below with the wr function and the params variables. So this pipeline dynamically creates a query based on the parameters passed to it. We will call this pipeline later to run the process.

#
# Pipeline: log_reg
#
log_reg <- function(params){
  
  print ("log_reg")

  query <- '
    CREATE OR REPLACE TABLE {{{dataset}}}.{{{table_prefix}}}_settings
    AS 
    SELECT
      "{{{project}}}" AS project,
      "{{{dataset}}}" AS dataset,
      "{{{data_table}}}" AS data_table,
      {{{max_steps}}} AS max_steps,
      {{{error_tol}}} AS error_tol,
      {{{learning_rate}}} AS learning_rate,
      "{{{id_column}}}"   AS id_column,
      "{{{label_column}}}" AS label_column,
      "{{{fieldnames}}}" AS fieldnames,
      "{{{constant_id}}}" AS constant_id,
      "{{{table_prefix}}}" AS table_prefix
  '
  
  query_exec(
    project = wr('{{{project}}}', params),
    query = wr(query, params),
    use_legacy_sql = FALSE
  )
  
  # Now run the log_reg_stack pipeline and pass the settings to it
  invocation_query <- '
    SELECT *
    FROM {{{dataset}}}.{{table_prefix}}_settings
  '
  run_pipeline_gbq(
    log_reg_stack,
    wr(invocation_query, params),
    wr('{{{project}}}', params),
    use_legacy_sql = FALSE
  )
}

The above pipeline calls another pipeline, log_reg_stack, which is defined below. log_reg_stack creates a table with the field names that we will use in the logistic regression and then runs log_reg_stack_field on each of the field names. Note that the invocation_query below contains a query that results in one or more rows containing a field name. run_pipeline_gbq takes the results and iterates over them, calling log_reg_stack_field on each one. Finally, it creates the _labels table and calls log_reg_setup, passing it the results of the global settings query.

#
# Pipeline: stack variables
#
log_reg_stack <- function(params){
  
  print ("log_reg_stack")
  
  # Table: _fieldnames 
  query <- "
    CREATE OR REPLACE TABLE {{{dataset}}}.{{{table_prefix}}}_fieldnames
    AS
    SELECT TRIM(fieldname) AS fieldname
    FROM (
      SELECT split(fieldnames,',') AS fieldname
      FROM (
          SELECT '{{{fieldnames}}}' AS fieldnames
      )
    ), UNNEST(fieldname) as fieldname
    GROUP BY 1
  "
  
  query_exec(
    project = wr('{{{project}}}', params),
    query = wr(query, params),
    use_legacy_sql = FALSE
  )
  
  # Run _stack_field
  query <- "
    DROP TABLE IF EXISTS {{{dataset}}}.{{{table_prefix}}}_stacked
  "
  
  tryCatch({
    query_exec(
      project = wr('{{{project}}}', params),
      query = wr(query, params),
      use_legacy_sql = FALSE
    )},
    error = function(e){
      print(e)
  })
    
  invocation_query <- "
    SELECT
      a.fieldname AS fieldname,  
      b.*
    FROM (  
      SELECT fieldname  
      FROM {{{dataset}}}.{{{table_prefix}}}_fieldnames  
      GROUP BY fieldname
    ) a  
    CROSS JOIN (  
      SELECT *  
        FROM {{{dataset}}}.{{{table_prefix}}}_settings
    ) b
  "
  run_pipeline_gbq(
    log_reg_stack_field,
    wr(invocation_query, params),
    wr('{{{project}}}', params),
    use_legacy_sql = FALSE
  )
  
  # Table: _labels
  query <- "
    CREATE OR REPLACE TABLE {{{dataset}}}.{{{table_prefix}}}_labels
    AS
    SELECT
      {{{id_column}}} AS id,
      {{{label_column}}} AS label
    FROM {{{data_table}}}
  "
  
  query_exec(
    project = wr('{{{project}}}', params),
    query = wr(query, params),
    use_legacy_sql = FALSE
  )
  
  
  # Run _setup
  invocation_query <- "
    SELECT *  
      FROM {{{dataset}}}.{{{table_prefix}}}_settings
  "
  run_pipeline_gbq(
    log_reg_setup,
    wr(invocation_query, params),
    wr('{{{project}}}', params),
    use_legacy_sql = FALSE
  )
  
}

The log_reg_stack_field and log_reg_setup pipelines are not particularly interesting. They do the groundwork needed to allow the log_reg_loop pipeline to iterate. The _stacked table contains the feature names and their values, and the _feature_stats and features_stacked_vni tables contains normalized values used later. Finally, the _fit_params table contains the value of the fit parameters that will be updated as we iteratively minimize the cost function in the loop. The log_reg_setup pipeline ends by calling log_reg_loop, passing it the results of the global settings query.

log_reg_stack_field <- function(params){
  
  print ("log_reg_stack_field")

  destination_table <- '{{{dataset}}}.{{{table_prefix}}}_stacked'

  query <- "
    SELECT {{{id_column}}} AS id,
      LTRIM('{{{fieldname}}}') AS feature_name,
      CAST({{{fieldname}}} AS FLOAT64) AS vi
    FROM {{{data_table}}}
  "
  
  query_exec(
    project = wr('{{{project}}}', params),
    query = wr(query, params),
    destination_table = wr(destination_table, params),
    use_legacy_sql = FALSE,
    write_disposition = 'WRITE_APPEND',
    create_disposition = 'CREATE_IF_NEEDED'
  )
  
}


log_reg_setup <- function(params){
  
  print ("log_reg_setup")
  
  query <- "
    CREATE OR REPLACE TABLE {{{dataset}}}.{{{table_prefix}}}_feature_stats
    AS
    SELECT feature_name,
      AVG(vi) AS mean,
      STDDEV(vi) AS stddev
    FROM {{{dataset}}}.{{{table_prefix}}}_stacked
    GROUP BY feature_name
  "
  
  query_exec(
    project = wr('{{{project}}}', params),
    query = wr(query, params),
    use_legacy_sql = FALSE
  )
  
  query <- "
    CREATE OR REPLACE TABLE {{{dataset}}}.{{{table_prefix}}}_features_stacked_vni
    AS
    SELECT
      a.id AS id,
      a.feature_name AS feature_name,
      CASE
        WHEN b.stddev > 0.0 THEN (vi - b.mean) / b.stddev
        ELSE vi - b.mean
      END AS vni
    FROM {{{dataset}}}.{{{table_prefix}}}_stacked a
    JOIN {{{dataset}}}.{{{table_prefix}}}_feature_stats b
      ON a.feature_name = b.feature_name
  "
  
  query_exec(
    project = wr('{{{project}}}', params),
    query = wr(query, params),
    use_legacy_sql = FALSE
  )
  
  query <- "
    INSERT INTO {{{dataset}}}.{{{table_prefix}}}_features_stacked_vni (id, feature_name, vni)     
    SELECT
      id,
      '{{{constant_id}}}' as feature_name,
      1.0 as vni
    FROM {{{dataset}}}.{{{table_prefix}}}_stacked
    GROUP BY 1,2,3
  "
  
  query_exec(
    project = wr('{{{project}}}', params),
    query = wr(query, params),
    use_legacy_sql = FALSE
  )
  
  query <- "
    CREATE OR REPLACE TABLE {{{dataset}}}.{{{table_prefix}}}_fit_params
    AS
    SELECT
      step,
      param_id,
      param_value,
      cost,
      stop,
      message
    FROM (
      SELECT 1 as step,
      feature_name as param_id,
      0.0 as param_value,
      1e6 as cost,
      false as stop,
      '' as message
      FROM {{{dataset}}}.{{{table_prefix}}}_stacked
      GROUP BY param_id
    ) UNION ALL (
      SELECT 1 as step,
      '{{{constant_id}}}' as param_id,
      0.0 as param_value,
      1e6 as cost,
      false as stop,
      '' as message
    )
  "
  
  query_exec(
    project = wr('{{{project}}}', params),
    query = wr(query, params),
    use_legacy_sql = FALSE
  )
  
  # Run _loop
  invocation_query <- "
    SELECT *  
      FROM {{{dataset}}}.{{{table_prefix}}}_settings
  "
  run_pipeline_gbq(
    log_reg_loop,
    wr(invocation_query, params),
    wr('{{{project}}}', params),
    use_legacy_sql = FALSE
  )
}

Next, we’ll create a loop pipeline that will iteratively calculate the cost function and update the _fit_params table with the latest update.

#
# Pipeline: loop
#
log_reg_loop <- function(params){
  
  print ("log_reg_loop")
  
  query <- "
    CREATE OR REPLACE TABLE {{{dataset}}}.{{{table_prefix}}}_x_dot_beta_i
    AS 
    SELECT
      a.id AS id,
      SUM(a.vni * b.param_value) AS x_dot_beta_i
    FROM {{{dataset}}}.{{{table_prefix}}}_features_stacked_vni a  
    RIGHT JOIN (
      SELECT param_id, param_value    
      FROM {{{dataset}}}.{{{table_prefix}}}_fit_params    
      WHERE STEP = (SELECT max(step) FROM {{{dataset}}}.{{{table_prefix}}}_fit_params)
    ) b
    ON a.feature_name = b.param_id
    GROUP BY 1
  "
  
  query_exec(
    project = wr('{{{project}}}', params),
    query = wr(query, params),
    use_legacy_sql = FALSE
  )
  
  query <- '
  INSERT INTO {{{dataset}}}.{{{table_prefix}}}_fit_params (step, param_id, param_value, cost, stop, message)
  SELECT  
    b.step + 1 as step,  
    b.param_id as param_id,  
    b.param_value - {{{learning_rate}}} * err as param_value,
    -1.0 * a.cost as cost,
    CASE
      WHEN ( abs((b.cost-(-1.0*a.cost))/b.cost) < {{{error_tol}}} ) OR (step+1 > {{{max_steps}}})  
        THEN true
      ELSE false  
      END AS stop,  
    CONCAT( "cost: ", CAST(abs((b.cost-(-1.0*a.cost))/b.cost) AS STRING), " error_tol: ", CAST({{{error_tol}}} AS STRING)) as message  
  FROM (  
    SELECT  
      param_id,  
      avg(err) as err,  
      avg(cost) as cost  
    FROM (  
      SELECT  
        a.id,
        param_id,
        (1.0/(1.0 + EXP(-1.0 * (c.x_dot_beta_i))) - CAST(label AS FLOAT64)) * vni as err,
        CAST(label AS FLOAT64) * LOG( 1.0/(1.0 + EXP(-1.0 * (c.x_dot_beta_i))) )   
          + (1.0-CAST(label AS FLOAT64))*(log(1.0 - (1.0/(1.0 + EXP(-1.0 * (c.x_dot_beta_i))))))  as cost
      FROM (  
        SELECT a.id as id,  
        b.param_id as param_id,
        a.vni as vni,
        b.param_value as param_value
        FROM {{{dataset}}}.{{{table_prefix}}}_features_stacked_vni a  
        JOIN (
          SELECT param_id, param_value    
          FROM {{{dataset}}}.{{{table_prefix}}}_fit_params    
          WHERE STEP = (SELECT max(step) FROM {{{dataset}}}.{{{table_prefix}}}_fit_params)
        ) b
        ON a.feature_name = b.param_id
        GROUP BY 1,2,3,4
      ) a
      JOIN {{{dataset}}}.{{{table_prefix}}}_labels b  
      ON a.id = b.id
      JOIN {{{dataset}}}.{{{table_prefix}}}_x_dot_beta_i c
      ON a.id = c.id
    )  
    GROUP BY param_id
  ) a
  JOIN (
    SELECT *
    FROM {{{dataset}}}.{{{table_prefix}}}_fit_params
    WHERE STEP = (SELECT max(step) FROM {{{dataset}}}.{{{table_prefix}}}_fit_params)
  ) b
  ON a.param_id = b.param_id
  '
  
  query_exec(
    project = wr('{{{project}}}', params),
    query = wr(query, params),
    use_legacy_sql = FALSE
  )
  
  
  # Loop or stop
  query <- "
      SELECT stop  AS stop
      FROM (
        SELECT *
          FROM {{{dataset}}}.{{{table_prefix}}}_fit_params
        ORDER BY step DESC
        LIMIT 1
      )
  "
  
  res <- query_exec(
    wr(query, params),
    wr('{{{project}}}', params),
    use_legacy_sql = FALSE
  )
  
  if(res$stop == FALSE){
    print("stop == FALSE")
    invocation_query <- '
      SELECT *
      FROM {{{dataset}}}.{{table_prefix}}_settings
    '
    run_pipeline_gbq(
      log_reg_loop,
      wr(invocation_query,  params),
      wr('{{{project}}}', params),
      use_legacy_sql = FALSE
    )
  }
  else {
    print("stop == TRUE")
    invocation_query <- '
      SELECT *
      FROM {{{dataset}}}.{{table_prefix}}_settings
    '
    run_pipeline_gbq(
      log_reg_done,
      wr(invocation_query,  params),
      wr('{{{project}}}', params),
      use_legacy_sql = FALSE
    )
  }
  
}

And finally, a log_reg_done pipeline that outputs the results:

#
# Pipeline: done
#
log_reg_done <- function(params){
  
  print ("log_reg_done")
  
  # Display results in norm'd coords
  query <- '
    SELECT "normalized coords parameters" as message,
      step,  
      param_id,  
      param_value 
    FROM {{{dataset}}}.{{{table_prefix}}}_fit_params
    WHERE step = (SELECT max(step) from {{{dataset}}}.{{{table_prefix}}}_fit_params)
  '
  
  res <- query_exec(
    wr(query, params),
    wr('{{{project}}}', params),
    use_legacy_sql = FALSE
  )
  
  print(res)
  
  # Display results in original coords
  query <- "
    CREATE OR REPLACE TABLE {{{dataset}}}.{{{table_prefix}}}_model_params_stacked
    AS 
    SELECT
      param_id,
      param_value_rescaled
    FROM (
      SELECT
        a.param_id AS param_id,
        a.param_value + b.constant_offset AS param_value_rescaled
      FROM (
        SELECT
          step,
          param_id,
          param_value
        FROM {{{dataset}}}.{{{table_prefix}}}_fit_params
        WHERE step = (SELECT max(step) from {{{dataset}}}.{{{table_prefix}}}_fit_params)
        AND param_id = 'CONSTANT'
      ) a
      JOIN (
        SELECT
          step,
          'CONSTANT' as param_id,
          sum(-1.0*param_value*mean/stddev) as constant_offset
        FROM {{{dataset}}}.{{{table_prefix}}}_fit_params a
        JOIN {{{dataset}}}.{{{table_prefix}}}_feature_stats b
          ON a.param_id = b.feature_name
        WHERE step = (SELECT max(step) FROM {{{dataset}}}.{{{table_prefix}}}_fit_params)
        GROUP BY 1,2
      ) b
      ON a.param_id = b.param_id
    ) UNION ALL (
      SELECT
        param_id,
        param_value/stddev as param_value_rescaled
      FROM {{{dataset}}}.{{{table_prefix}}}_fit_params a
      JOIN {{{dataset}}}.{{{table_prefix}}}_feature_stats b
      ON a.param_id = b.feature_name
      WHERE step = (SELECT max(step) FROM {{{dataset}}}.{{{table_prefix}}}_fit_params)
      GROUP BY 1,2
    )
  "
  
  res <- query_exec(
    wr(query, params),
    wr('{{{project}}}', params),
    use_legacy_sql = FALSE
  )
  
  print(res)
  
  
  # transpose the _model_params_stacked table
  invocation_query <- '
    SELECT
      a.list,
      b.*
    FROM (
      SELECT CONCAT("[", STRING_AGG(CONCAT("{\\"val\\": \\"",TRIM(fieldname), "\\"}")), "]") AS list
      FROM rstevenson.indb_logreg_001_fieldnames
    ) a
    CROSS JOIN (
      SELECT *
        FROM rstevenson.indb_logreg_001_settings
    ) b
  '
  
  run_pipeline_gbq(
    log_reg_model_params,
    wr(invocation_query, config),
    wr('{{{project}}}', config),
    use_legacy_sql = FALSE
  )
  
  print("DONE")
  
}

Our last pipeline, called at the end of the above pipeline, will transpose the stacked model params. In other words, it will output the parameters of the model in separate columns:

log_reg_model_params <- function(params){
  
  query <- "
    CREATE OR REPLACE TABLE {{{dataset}}}.{{{table_prefix}}}_model_params
    AS 
    SELECT
    {{#list}}
      MAX(CASE WHEN param_id='{{val}}' THEN param_value_rescaled END ) AS {{val}},
    {{/list}}
    MAX(CASE WHEN param_id='{{constant_id}}' THEN param_value_rescaled END ) AS {{constant_id}}
    FROM {{{dataset}}}.{{{table_prefix}}}_model_params_stacked
  ;"

  res <- query_exec(
    wr(query, params),
    wr('{{{project}}}', params),
    use_legacy_sql = FALSE
  )
  
  print(res)
}

Running the pipeline

We are now ready to run the log_reg pipeline. We’ll set up the invocation query with all of our global parameters. These will be stored in the _settings table and then, after stacking and setup, the pipeline will iterate through the loop to calculate the logistic regression coefficients.

# Run the log_reg pipeline with the following params (2D test)
invocation_query <- '
  SELECT
  "{{{project}}}" as project,
  "{{{dataset}}}" as dataset,
  "{{{table_prefix}}}" as table_prefix,
  "{{{dataset}}}.logreg_sim" as data_table,        
  "25"  as max_steps,
  "1e-6" as error_tol,
  "6.0"  as learning_rate,
  "id"   as id_column,
  "y"  as label_column,
  "x1, x2"  as fieldnames,
  "CONSTANT" as constant_id
'

cat(wr(invocation_query, config))

query_exec(wr(invocation_query, config), project=config$project, use_legacy_sql = FALSE)

run_pipeline_gbq(
  log_reg,
  wr(invocation_query, config),
  project = wr('{{{project}}}', config),
  use_legacy_sql = FALSE
)

After running the above, we should be able to query the table that holds the fitted parameters:

  query <- "
    SELECT *
    FROM {{{dataset}}}.{{{table_prefix}}}_model_params
  ;"

  query_exec(
    wr(query),
    wr('{{{project}}}'),
    use_legacy_sql = FALSE
  )

As expected, these results are pretty close to our original beta values.

Please keep in mind that this is not ready to be released into the wild. Further improvements include modifications to deal with categorical variables, output describing whether a logistic fit is statistically significant for a particular parameter, and options for controlling step-sizes. But it does show the concept of how an iterative process like logistic regression can be done while using the database to maintain state.

Prediction

Now that we have fit the logistic regression model and the model is stored in the database, we can predict values using the model. We just need a prediction pipeline:

#
# Pipeline: predict
#
log_reg_predict <- function(params){
  
  query <- '
  SELECT
    1/(1+exp(-1.0*(CONSTANT + {{#list}}a.{{val}}*b.{{val}} + {{/list}} + 0))) as probability
  FROM {{{dataset}}}.{{{table_prefix}}}_model_params a
  CROSS JOIN {{{data_table}}} b
  ORDER BY {{{id_column}}}
  '
  
  res <- query_exec(
    wr(query, params),
    wr('{{{project}}}', params),
    use_legacy_sql = FALSE
  )
  
}

Note that the above uses whisker to calculate the dot product $x\beta$ by expanding a JSON-formatted array of field names into {{#list}}a.{{val}}*b.{{val}} + {{/list}} code. In the code below, we will create a JSON-formatted array of field names. Now let’s run the predictions:

# Run the prediction pipeline with the following params
invocation_query <- '
  SELECT
    "{{{project}}}" as project,
    "{{{dataset}}}" as dataset,
    "{{{table_prefix}}}" as table_prefix,
    "{{{dataset}}}.logreg_sim" as data_table,
    "id" as id_column,
    CONCAT("[", STRING_AGG(CONCAT("{\\"val\\": \\"",TRIM(fieldname), "\\"}")), "]") AS list
  FROM {{{dataset}}}.{{{table_prefix}}}_fieldnames
'

predictions <- run_pipeline_gbq(
  log_reg_predict,
  wr(invocation_query, config),
  project = wr('{{{project}}}', config),
  use_legacy_sql = FALSE
)

Let’s test the rounded predictions to see how well they approximate the outcomes:

# inspect first 5 true probs vs. predicted probabilities
head(probs[1:5])
head(predictions[[1]]$probability[1:5])

# mean relative error between true probs and predicted probabilities 
mean((abs(probs-predictions[[1]]$probability))/probs)

Our model-based logistic regression model predicts the true probabilities with a mean relative error of about 7%.

Next steps

We have shown how to train and store a logistic regression model in a database. We can then predict outcomes given features that are also stored in the database without having to move data back and forth to a prediction server. In this particular example, it would likely be much faster to move the data to a computer and run the predictions there. However, certain use cases exist where in-database modeling could be an avenue for consideration. Further, since logistic models are fundamental to many types of tree and forest predictors, in-database logistic regression would be a necessary step in developing in-database tree methods. It remains to be seen if this approach can be easily translated into the tidyverse modeldb package.

A comparison of methods for predicting clothing classes using the Fashion MNIST dataset in RStudio and Python (Part 1)

Mon, 11 Nov 2019 00:00:00 +0000

Florianne Verkroost is a PhD candidate at Nuffield College at the University of Oxford. With a passion for data science and a background in mathematics and econometrics. She applies her interdisciplinary knowledge to computationally address societal problems of inequality.

In this series of blog posts, I will compare different machine and deep learning methods to predict clothing categories from images using the Fashion MNIST data. In this first blog of the series, we will explore and prepare the data for analysis. I will also show you how to predict the clothing categories of the Fashion MNIST data using my go-to model: an artificial neural network. To show you how to use one of RStudio’s incredible features to run Python from RStudio, I build my neural network in Python using the code in this Python script or this Jupyter notebook on my Github. In the second blog post, we will experiment with tree-based methods (single tree, random forests and boosting) and support vector machines to see whether we can beat the neural network in terms of performance. As Python cannot be run in this blog post, I will walk you through the results from this script produced earlier, but if you would also like to see how to embed Python code and results in R Markdown files, check out this Markdown file on my Github! The R code used for this blog is also included on my Github.

To start, we first set our seed to make sure the results are reproducible.

set.seed(1234)

Importing and exploring the data

The keras package contains the Fashion MNIST data, so we can easily import the data into RStudio from this package directly after installing it from Github and loading it.

library(devtools)
install.packages("keras")
#devtools::install_github("rstudio/keras")
library(keras)        
install_keras()  
fashion_mnist <- keras::dataset_fashion_mnist()

The resulting object named fashion_mnist is a nested list, consisting of lists train and test. Each of these lists in turn consists of arrays x and y. To look at the dimensions of these elements, we recursively apply the dim() function to the fashion_mnist list.

rapply(fashion_mnist, dim)

train.x1 train.x2 train.x3  train.y  test.x1  test.x2  test.x3   test.y 
   60000       28       28    60000    10000       28       28    10000

From the result, we observe that the x array in the training data contains 28 matrices each of 60000 rows and 28 columns, or in other words 60000 images each of 28 by 28 pixels. The y array in the training data contains 60000 labels for each of the images in the x array of the training data. The test data has a similar structure but only contains 10000 images rather than 60000. For simplicity, we rename these lists elements to something more intuitive (where x now represents images and y represents labels):

c(train.images, train.labels) %<-% fashion_mnist$train
c(test.images, test.labels) %<-% fashion_mnist$test

Every image is captured by a 28 by 28 matrix, where entry [i, j] represents the opacity of that pixel on an integer scale from 0 (white) to 255 (black). The labels consist of integers between zero and nine, each representing a unique clothing category. As the category names are not contained in the data itself, we have to store and add them manually. Note that the categories are evenly distributed in the data.

cloth_cats = data.frame(category = c('Top', 'Trouser', 'Pullover', 'Dress', 'Coat',  
                                     'Sandal', 'Shirt', 'Sneaker', 'Bag', 'Boot'), 
                                     label = seq(0, 9))

To get an idea of what the data entail and look like, we plot the first ten images of the test data. To do so, we first need to reshape the data slightly such that it becomes compatible with ggplot2. We select the first ten test images, convert them to data frames, rename the columns into digits 1 to 28, create a variable named y with digits 1 to 28 and then we melt by variable y. We need package reshape2 to access the melt() function. This results in a 28 times 28 equals 784 by 3 (y pixels (= y), x pixels (= variable) and the opacity (= value)) data frame. We bind these all together by rows using the rbind.fill() function from the plyr package and add a variable Image, which is a unique string repeated 784 times for each of the nine images containing the image number and corresponding test set label.

library(reshape2)
library(plyr)
subarray <- apply(test.images[1:10, , ], 1, as.data.frame)
subarray <- lapply(subarray, function(df){
  colnames(df) <- seq_len(ncol(df))
  df['y'] <- seq_len(nrow(df))
  df <- melt(df, id = 'y')
  return(df)
})
plotdf <- rbind.fill(subarray)
first_ten_labels <- cloth_cats$category[match(test.labels[1:10], cloth_cats$label)]
first_ten_categories <- paste0('Image ', 1:10, ': ', first_ten_labels)
plotdf['Image'] <- factor(rep(first_ten_categories, unlist(lapply(subarray, nrow))), 
                          levels = unique(first_ten_categories))

We then plot these first ten test images using package ggplot2. Note that we reverse the scale of the y-axis because the original dataset contains the images upside-down. We further remove the legend and axis labels and change the tick labels.

library(ggplot2)

ggplot() + 
  geom_raster(data = plotdf, aes(x = variable, y = y, fill = value)) + 
  facet_wrap(~ Image, nrow = 2, ncol = 5) + 
  scale_fill_gradient(low = "white", high = "black", na.value = NA) + 
  theme(aspect.ratio = 1, legend.position = "none") + 
  labs(x = NULL, y = NULL) + 
  scale_x_discrete(breaks = seq(0, 28, 7), expand = c(0, 0)) + 
  scale_y_reverse(breaks = seq(0, 28, 7), expand = c(0, 0))

Data Preparation

Next, it’s time to start the more technical work of predicting the labels from the image data. First, we need to reshape our data to convert it from a multidimensional array into a two-dimensional matrix. To do so, we vectorize each 28 by 28 matrix into a column of length 784, and then we bind the columns for all images on top of each other, finally taking the transpose of the resulting matrix. This way, we can convert a 28 by 28 by 60000 array into a 60000 by 784 matrix. We also normalize the data by dividing between the maximum opacity of 255.

train.images <- data.frame(t(apply(train.images, 1, c))) / max(fashion_mnist$train$x)
test.images <- data.frame(t(apply(test.images, 1, c))) / max(fashion_mnist$train$x)

We also create two data frames that include all training and test data (images and labels), respectively.

pixs <- 1:ncol(fashion_mnist$train$x)^2
names(train.images) <- names(test.images) <- paste0('pixel', pixs)
train.labels <- data.frame(label = factor(train.labels))
test.labels <- data.frame(label = factor(test.labels))
train.data <- cbind(train.labels, train.images)
test.data <- cbind(test.labels, test.images)

Artificial Neural Network

Now, let’s continue by building a simple neural network model to predict our clothing categories. Neural networks are artificial computing systems that were built with human neural networks in mind. Neural networks contain nodes, which transmit signals amongst one another. Usually the input at each node is a number, which is transformed according to a non-linear function of the input and weights, the latter being the parameters that are tuned while training the model. Sets of neurons are collected in different layers; neural networks are referred to as ‘deep’ when they contain at least two hidden layers. If you’re not familiar with artificial neural networks, then this free online book is a good source to start learning about them.

In this post, I will show you how artificial neural networks with different numbers of hidden layers compare, and I will also compare these networks to a convolutional network, which often performs better in the case of visual imagery. I will show you some basic models and how to code these, but will not spend too much time on tuning neural networks, for example when it comes to choosing the right amount of hidden layers or the number of nodes in each hidden layer. In essence, what it comes down to is that these parameters largely depend on your data structure, magnitude and complexity. The more hidden layers one adds, the more complex non-linear relationships can be modelled. Often, in my experience, adding hidden layers to a neural network increases their performance up to a certain number of layers, after which the increase becomes non-significant while the computational requirements and interpretation become more infeasible. It is up to you to play around a bit with your specific data and test how this trade-off works.

Although neural networks can easily built in RStudio using TensorFlow and Keras, I really want to show you one of the incredible features of RStudio where you can run Python in RStudio. This can be done in two ways: either we choose “Terminal” on the top of the output console in RStudio and run Python via Terminal, or we use the base system2() function to run Python in RStudio.

For the second option, to use the system2() command, it’s important to first check what version of Python should be used. You can check which versions of Python are installed on your machine by running python --version in Terminal. Note that with RStudio 1.1 (1.1.383 or higher), you can run in Terminal directly from RStudio on the “Terminal” tab. You can also run python3 --version to check if you have Python version 3 installed. On my machine, python --version and python3 --version return Python 2.7.16 and Python 3.7.0, respectively. You can then run which python (or which python3 if you have Python version 3 installed) in Terminal, which will return the path where Python is installed. In my case, these respective commands return /usr/bin/python and /Library/Frameworks/Python.framework/Versions/3.7/bin/python3. As I will make use of Python version 3, I specify the latter as the path to Python in the use_python() function from the reticulate package. We can check whether the desired version of Python is used by using the sys package from Python. Just make sure to change the path in the code below to what version of Python you desire using and where that version in installed.

library(reticulate)
use_python(python = '/Library/Frameworks/Python.framework/Versions/3.7/bin/python3')

sys <- import("sys")
sys$version

Now that we’ve specified the correct version of Python to be used, we can run our Python script from RStudio using the system2() function. This function also takes an argument for the version of Python used, which in my case is Python version 3. If you are using an older version of Python, make sure to change "python3" in the command below to "python2".

python_file <- "simple_neural_network_fashion_mnist.py"
system2("python3", args = c(python_file), stdout = NULL, stderr = "")

The source code used to build and fit the neural networks from the above script can be found in this Python script or this Jupyter notebook on my Github.. In this post, I will walk you through the results from this script produced earlier, but if you would also like to see how to embed Python code and results in R Markdown files, check out this file on my Github!

I will now guide you step by step through the script called in the command above. First, we load the required packages in Python and set the session seed for replicability.

We then load the fashion MNIST data from keras and we normalize the data by dividing by maximum opacity of 255.

We start by building a simple neural network containing one hidden layer. Note that as here we use the untransformed but normalized data, we need to flatten the 28 by 28 pixels input first. We add one hidden densely-connected layer which performs output = relu(dot(input, kernel) + bias), where the rectified linear unit (relu) activation function has been proven to work well. We set the number of nodes equal to 128, because this seems to work well in our case. The number of nodes could essentially be any of the numbers 32, 64, 128, 256 and 512, as these are in a sequence of multiples between the number of nodes in the output (= 10) and input (= 784) layers. The softmax layer then assigns predicted probabilities to each of the ten clothing categories, which is also why there are ten nodes in this layer.

After building the neural network, we compile it. We specify sparse_categorical_crossentropy as the loss function, which is suitable for categorical multi-class responses. The optimizer controls the learning rate; adam (adaptive moment estimation) is similar to classical stochastic gradient descent and usually a safe choice for the optimizer. We set our metric of interest to be the accuracy, or the percentage of correctly classified images. Hereafter, we fit the model onto our training data set using ten iterations through the training data (“epochs”). Here, 70% is used for training and 30% is used for validation.

Next, we print the results of the model in terms of training and testing loss and accuracy.

We can see that the neural network with one hidden layer already performs relatively well with a test accuracy of 87.09%. However, it seems like we are slightly overfitting (i.e. the model is fitted too well to a particular data set and therefore does not well extend to other data sets), as the training set accuracy (88.15%) is slightly higher than the test set accuracy. There are several ways to avoid overfitting in neural networks, such as simplifying our model by reducing the number of hidden layers and neurons, adding dropout layers that randomly remove some of the connections between layers, and early stopping when validation loss starts to increase. Later on in this post, I will demonstrate some of these methods to you. For further reading, I personally like this and this post showing how to avoid overfitting when building neural networks using keras. Instead, to see whether a deep neural network performs better at predicting clothing categories, we build a neural network with three hidden layers in a similar way as before.

It seems like the model with two additional layers does not perform better than the previous one with only one hidden layer, given that both the training (87.42%) and test set (86.03%) accuracies are lower and the loss (38.49) is higher. Let’s try whether adding another five hidden layers improves model performance, or whether we can include that increasing model complexity does not improve performance.

The model with eight hidden layers performs best in terms of training (88.21%) and test (87.58%) accuracy as well as loss (36.12). Nevertheless, the difference in performance between the first model with one hidden layer and the current model with eight hidden layers is only quite small. Although it seems that with so many hidden layers, we can model additional complexity that improves the accuracy of the model, we must ask ourselves whether increasing model complexity at the cost of interpretability and computational feasibility is worth this slight improvement in accuracy and loss.

Now that we have seen how the number of hidden layers affects model performance, let’s try and see whether increasing the number of epochs (i.e. the number of times the model iterates through the training data) from ten to fifty improves the performance of our first neural network with one hidden layer.

The three-layer model trained with fifty epochs has the highest train (89.32%) and test (88.68%) accuracies we have seen so far. However, the loss (54.73) is also about a third larger than we have seen before. Additionally, the model is also less time-efficient, given that the increase in accuracy is not substantial but the model takes significantly longer to fit. To better understand the trade-off between minimizing loss and maximizing accuracy, we plot model loss and accuracy over the number of epochs for the training and cross-validation data.

We observe that for the training data, loss decreases to zero while accuracy increases to one, as a result of overfitting. This is why we also check how the model performs on the cross-validation data, for which we observe that loss increases with the number of epochs while accuracy remains relatively stable. Using this figure, we can select an “optimal” number of epochs such that accuracy is maximized while loss is minimized. Looking at the cross-validation data accuracy, we see that the accuracy peak lays at around 20 epochs, for which loss is approximately 0.4. However, similar accuracies but much lower losses and modelling time are achieved with around 6 and 12 epochs, and so we might rather choose to train our model with around 6 or 20 epochs.

Regarding the model output, the predictions returned are probabilities per class or clothing category. We can calculate the majority vote by taking class that has the maximum of predicted probabilities of all classes. We can print the first ten elements of the majority_vote dictionary, which we can obtain as follows:

All except the fifth (number 4) prediction are correct. In the fifth prediction, a shirt (category 6) is being misclassified as a top (category 0).

Convolutional Neural Network

I also wanted to show you how to build a convolutional neural network and compare its performance to the neural networks presented earlier, mostly because convolutional neural networks have generally been shown to perform better on visual image data. Essentially, what happens in a convolutional neural network is that a smaller matrix (the “filter matrix” or “kernel”) slides over the full image matrix, moving pixel by pixel, multiplies the filter matrix with the part of the full image matrix covered by the filter matrix on that moment, sums up these values and then repeats this until the full image matrix has been covered. For a more extensive explanation on how convolutional neural networks, I refer you to this page or this page.

As we need to prepare our data slightly differently for a convolutional neural network, we reload the data and reshape the images to “flatten” them. The last “1” in the reshape dimensions stand for a greyscale, as we have images on a black-to-white scale. If we would have RGB images, we would change the “1” into a “3”.

We make sure the the values of the pixels, ranging from zero to 255, are of the float type and then we normalize the values as before.

The convolutional neural network cannot deal with categorical labels. Therefore, we transform the labels to binary vectors, where all vectors have length ten (as there are ten categories), a “1” at the index of the category and zeros elsewhere. For example, category 3 and 8 would be coded as [0, 0, 0, 1, 0, 0, 0, 0, 0, 0] and [0, 0, 0, 0, 0, 0, 0, 0, 1, 0], respectively. This transformation is referred to as “one hot encoding”.

Now, we can start building our convolutional neural network. The first layer Conv2D is a convolutional layer that takes a 2-dimensional matrix of 28 by 28 pixels in greyscale (1) as input. As before, we use 128 nodes in this layer, as the size of the data is not extremely large and we want to avoid making our model unnecessarily complex. The filter matrix is of size 3 by 3, which is quite standard. As before, we use the rectified linear (“relu”) activation function. The MaxPooling2D layer reduces the dimensionality (and thus required computational power) by outputting the maximum of the part of the input image that is captured by the filter matrix. The Flatten layer simply flattens the result from the previous layer into a vector. As we saw before, the softmax layer then assigns predicted probabilities to each of the ten clothing categories. Note that we use the same optimizer and metric as before, but that we now use “categorical_crossentropy” as the loss function instead of “sparse_categorical_crossentropy”. The reason for this is that the former works for one-hot encoded labels, whereas the other works for categorical labels.

We fit our model to the training data, where we set the batch_size argument equal to the number of neurons in the convolutional layers (= 128).

Although we are still overfitting, we observe that the convolutional neural network performs better than the neural networks we saw earlier, achieving a training set accuracy of 95.16% and a test set accuracy of 90.39%, and a lower loss of 28.70. This was to be expected, because convolutional neural networks have previously been shown to perform well on visual imagery data. Let’s see if we can reduce overfitting by reducing the number of neurons from 128 to 64, adding dropout layers and enabling early stopping. Note that the rate in the Dropout layer is the percentage of connections between layers that are being removed. the SpatialDropout2D is a special kind of dropout layer for convolutional neural networks, which drops certain multiplications of the filter matrix with parts of the original image before pooling across all movements over the original image.

When fitting our model, we also enable early stopping to reduce overfitting. Instead of going through all epochs specified, early stopping automatically stops the iterations through the epoch once it’s being noticed that the validation loss increases.

From the results, we observe that although the training and test accuracies have decreased, they are now much more similar than before. The test accuracy has not decreased substantially, but the training accuracy has, which means that overfitting is much less of a problem than before. Next, we can print the first ten predictions from the model and the first ten actual labels and compare them.

Comparing these predictions to the first ten labels in the data set, we observe that the first ten predictions are correct!

Next up…

Next up in this series of blog posts, I will experiment with tree-based methods and support vector machines to see if they perform as well as the neural network in predicting clothing categories in the Fashion MNIST data.

A First Look at Confidence Distributions

Tue, 05 Nov 2019 00:00:00 +0000

Using a probability distribution to characterize uncertainty is at the core of statistical inference. So, it seems natural to try to summarize the information about the parameters in statistical models with probability distributions. R. A. Fisher thought so. In fact, he expended a great deal of effort over more than thirty years, and put his professional reputation on the line trying to do so, with only limited success. Fisher’s central difficulty was that, in the Frequentist tradition to which he was committed, parameters are not random variables. They are fixed and immutable constituents of the statistical models describing the behavior of populations, which we must estimate because we generally only have access to samples from populations, not to the full populations themselves. Now Bayesians, of course, characterize parameters with probability distributions from the get-go. Parameters are given prior distributions and combined with the likelihood function generated by the data to produce posterior distributions that characterize the parameters. Fisher wanted the posterior distributions without having to assume the priors. This was a key motivating idea for his work on Fiducial probability.

A few statisticians apparently quietly worked on this program throughout the twentieth century, even though Fisher’s Fiducial ideas were mostly forgotten and not part of the mainstream statistical current. D. R. Cox (Cox (1958)), for example, pioneered the idea of constructing confidence distributions from confidence intervals, and Bradley Efron (Efron (1998)) expressed great optimism that Fisher’s work in this area would become important in the twenty-first century. (Efron’s paper is a masterpiece that summarizes a good bit of twentieth-century statistical research.)

Recently, however, there seems to have been a resurgence of Fisher’s ideas among statisticians interested in chasing the idea of an orthodox Frequentist view of parameter distributions. The 2013 paper of Xie and Singh lays out the modern theory of confidence distributions as a fundamental idea that organizes a great deal of statistical practice. In the initial Summary, the authors write:

. . .the concept of a confidence distribution subsumes and unifies a wide range of examples, from regular parametric (fiducial distribution) examples to bootstrap distributions, significance (p-value) functions, normalized likelihood functions, and, in some cases, Bayesian priors and posteriors.

Later in the paper, they go on to define a confidence distribution as:

A function H_n(·) = H_n(x, ·) on X × $\Theta$ → [0, 1] is called a confidence distribution (CD) for a parameter $\theta$, if
* R1) For each given x ∈ X , H_n(·) is a cumulative distribution function on $\Theta$;
* R2) At the true parameter value $\theta$ = $\theta$₀, H_n($\theta$₀) ≡ H_n(x, $\theta$₀), as a function of the sample

The simplest example of a confidence distribution I could find that is adequate to illustrate some of the key concepts comes from the book Confidence, Likelihood, Probability: Statistical Inference with Confidence Distributions by Schweder and Hjort. On page 62, the authors point out that the distribution of the p-value for the parameter $\theta$ describing the probability of success for a binomial trial can be considered as an approximate confidence distribution for $\theta$. The distribution is approximate because the distribution is discrete and the “half-correction” is used to improve the approximation. Note that because the p-values follow uniform distributions under the null hypothesis, it should be clear that the assumptions of the definition above are satisfied.

Suppose Y ~ Bin(n,$\theta$), then

C($\theta$) = P(Y > y₀) + .5 * P(Y = y₀) is a confidence distribution for $\theta$.

To illustrate this, we consider the experiment of realizing 8 successes in 20 trials and write a short helper function.

CD <- function(theta,n=20,y0=8){
            1 - sum(dbinom(x = seq(from = 0, to = y0), size = n, prob = theta)) + 
           .5 * dbinom(x = y0, size = n, prob = theta)}

Here, we compute the CDF and plot it.

library(tidyverse)
library(highcharter)
conf_dist <-  
  tibble(theta = seq(0, 1, by = .01)) %>%  
  mutate(probability = map_dbl(theta, CD))

hchart(conf_dist, "line", hcaes(x = theta, y = probability)) %>%
hc_title(text = "Confidence Distribution for Binomial Model",
         margin = 20, align = "left",
         style = list(color = "black", useHTML = TRUE)) %>%
hc_tooltip(valueDecimals=4, valuePrefix="cum prob = ")

This is nice, but to really see how computing the confidence distribution might be useful, we compute and plot the confidence curve introduced by Birnbaum in his 1961 paper.

conf_curve <-  
  conf_dist %>%  
  mutate(confidence = 2 * abs(.5 - probability))

hchart(conf_curve, "line", hcaes(x = theta, y = confidence)) %>%
  hc_title(text = "Confidence Curve for Binomial Model",
           margin = 20, align = "left",
           style = list(color = "black", useHTML = TRUE)) %>%
  hc_tooltip(valueDecimals=4, valuePrefix="conf level = ")

Pick a point on the left branch of the curve. The y value gives you the level of confidence and the x value is the lower bound of the corresponding confidence interval. Move horizontally across to the right branch to read off the upper end of the confidence interval. So reading up and down the curve you can read off the confidence intervals for any value of confidence.

As a check, we compute the 95% confidence interval for $\theta$ using the normal approximation to the binomial.

ub <- 8 / 20 + (1.96 / 20) * sqrt(8 * 12 / 20)
lb <- 8 / 20 - (1.96 / 20) * sqrt(8 * 12 / 20)
cat("95% CI = [" , lb , "," , ub, "]")

## 95% CI = [ 0.1853 , 0.6147 ]

If you are a Bayesian, there is a really amusing side to confidence distributions. In order to be clear that what they are doing with confidence distributions is in fact different from what Bayesians do when they choose priors, the champions of confidence distributions appeal to epistomology, the study of knowledge and justified belief. On page (xiv) of their book, Schweder and Hjort write:

The concept of confidence distribution is rather basic, but has proved difficult for statisticians to accept. The main reason is perhaps that confidence distributions represent epistemic probability obtained from the aleatory probability of the statistical model (i.e. the chance variation in nature and society), and to face both types of probability at the same time might be challenging. The traditional Bayesian deals only with subjective probability, which is epistemic when based on knowledge, and the frequentist of the Neyman-Wald school deals only with sampling variability, that is, aleatory probability.

Please indulge me while I unpack this. Aleatory probabilities are what nature and the world give us: the decay times of alpha particles, the valuable behaviors of large populations, etc. Hard-core frequentists will only allow themselves to compute aleatory probabilities. As soon as you compute a confidence distribution or even a confidence interval, you are working with epistemic probabilities: what you believe would be true under repeated sampling that may be impossible to actually carry out. But, you are justified in doing this because these epistemic probabilities are anchored in aleatory probabilities. When Bayesians base their choice of priors on rational beliefs based on plausible evidence, they are on the same epistemic footing as frequentists computing confidence intervals. When Bayesians are capricious in choosing their priors, they are not. Asking most statisticians to think about these things gives them headaches. Thus, quietly, in work that builds bridges, ends the Bayesian vs. Frequentist controversy.

Notes:
1. Schweder and Hjolt’s book is really worth owning. Not only does it offer a comprehensive account of confidence distributions and how they may be useful in practice, but it is also a good general reference on statistical inference.

If you are interested in exploring confidence distributions further, have a look at the pvaluefunctions and gmeta that are both on CRAN.

Building Interactive World Maps in Shiny

Wed, 09 Oct 2019 00:00:00 +0000

In this post, I will show you how to create interactive world maps and how to show these in the form of an R Shiny app. As the Shiny app cannot be embedded into this blog, I will direct you to the live app and show you in this post on my GitHub how to embed a Shiny app in your R Markdown files, which is a really cool and innovative way of preparing interactive documents. To show you how to adapt the interface of the app to the choices of the users, we’ll make use of two data sources such that the user can choose what data they want to explore, and that the app adapts the possible input choices to the users’ previous choices. The data sources here are about childlessness and gender inequality, which is the focus of my PhD research, in which I computationally analyse the effects of gender and parental status on socio-economic inequalities.

We’ll start by loading and cleaning the data, whereafter we will build our interactive world maps in R Shiny. Let’s first load the required packages into RStudio.

Importing, exploring and cleaning the data

Now, we can continue with loading our data. As we’ll make world maps, we need a way to map our data sets to geographical data containing coordinates (longitude and latitude). As different data sets have different formats for country names (e.g., “United Kingdom of Great Britain and Northern Ireland” versus “United Kingdom”), we’ll match country names to ISO3 codes to easily merge all data sets later on. Therefore, we first scrape an HTML table of country names, ISO3, ISO2 and UN codes for all countries worldwide. We use the rvest package using the XPath to indicate what part of the web page contains our table of interest. We use the pipe (%>%) from the magrittr package to feed our URL of interest into functions that read the HTML table using the XPath and convert that to a data frame in R. One can obtain the XPath by hovering over the HTML table in developer mode in the browser, and having it show the XPath.

The first element in the resulting list contains our table of interest, and as the first column is empty, we delete it. Also, as you can see from the HTML table in the link, there are some rows that show the letter of the alphabet before starting with a list of countries of which the name starts with that letter. As these rows contain the particular letter in all columns, we can delete these by deleting all rows for which all columns have equal values.

library(magrittr)
library(rvest)
url <- "https://www.nationsonline.org/oneworld/country_code_list.htm"
iso_codes <- url %>%
  read_html() %>%
  html_nodes(xpath = '//*[@id="CountryCode"]') %>%
  html_table()
iso_codes <- iso_codes[[1]][, -1]
iso_codes <- iso_codes[!apply(iso_codes, 1, function(x){all(x == x[1])}), ]
names(iso_codes) <- c("Country", "ISO2", "ISO3", "UN")
head(iso_codes)

##          Country ISO2 ISO3  UN
## 2    Afghanistan   AF  AFG 004
## 3  Aland Islands   AX  ALA 248
## 4        Albania   AL  ALB 008
## 5        Algeria   DZ  DZA 012
## 6 American Samoa   AS  ASM 016
## 7        Andorra   AD  AND 020

Next, we’ll collect our first data set, which is a data set on childlessness provided by the United Nations. We download the file from the link, save it locally, and then load it into RStudio using the read_excel() function in the readxl package.

library(readxl)
url <- "https://www.un.org/en/development/desa/population/publications/dataset/fertility/wfr2012/Data/Data_Sources/TABLE%20A.8.%20%20Percentage%20of%20childless%20women%20and%20women%20with%20parity%20three%20or%20higher.xlsx"
destfile <- "dataset_childlessness.xlsx"
download.file(url, destfile)
childlessness_data <- read_excel(destfile)

head(childlessness_data)

## # A tibble: 6 x 17
##   `United Nations… ...2  ...3  ...4  ...5  ...6  ...7  ...8  ...9  ...10
##   <chr>            <chr> <chr> <chr> <chr> <chr> <chr> <chr> <chr> <chr>
## 1 "TABLE  A.8. PE… <NA>  <NA>  <NA>  <NA>  <NA>  <NA>  <NA>  <NA>  <NA> 
## 2 Country          ISO … Peri… Refe… Perc… <NA>  <NA>  Perc… <NA>  <NA> 
## 3 <NA>             <NA>  <NA>  <NA>  35-39 40-44 45-49 35-39 40-44 45-49
## 4 Afghanistan      4     Earl… ..    ..    ..    ..    ..    ..    ..   
## 5 Afghanistan      4     Midd… ..    ..    ..    ..    ..    ..    ..   
## 6 Afghanistan      4     Late… 2010  2.6   2.6   2.1   93.8  94.5  94   
## # … with 7 more variables: ...11 <chr>, ...12 <chr>, ...13 <chr>,
## #   ...14 <chr>, ...15 <chr>, ...16 <chr>, ...17 <lgl>

We can see that the childlessness data are a bit messy, especially when it comes to the first couple of rows and column names. We only want to maintain the columns that have country names, periods, and childlessness estimates for different age groups, as well as the rows that refer to data for specific countries. The resulting data look much better. Note that when we convert the childlessness percentage columns to numeric type later on, the “..” values will automatically change to NA.

cols <- which(grepl("childless", childlessness_data[2, ]))
childlessness_data <- childlessness_data[-c(1:3), c(1, 3, cols:(cols + 2))]
names(childlessness_data) <- c("Country", "Period", "35-39", "40-44", "45-49")
head(childlessness_data)

## # A tibble: 6 x 5
##   Country     Period  `35-39` `40-44` `45-49`
##   <chr>       <chr>   <chr>   <chr>   <chr>  
## 1 Afghanistan Earlier ..      ..      ..     
## 2 Afghanistan Middle  ..      ..      ..     
## 3 Afghanistan Latest  2.6     2.6     2.1    
## 4 Albania     Earlier 7.2     5.5     5.2    
## 5 Albania     Middle  ..      ..      ..     
## 6 Albania     Latest  4.8     4.3     3.3

Our second data set is about measures of gender inequality, provided by the World Bank. We read this .csv file directly into RStudio from the URL link.

gender_index_data <- read.csv("https://s3.amazonaws.com/datascope-ast-datasets-nov29/datasets/743/data.csv")
head(gender_index_data)

##   Country.ISO3 Country.Name Indicator.Id
## 1          AGO       Angola        27959
## 2          AGO       Angola        27960
## 3          AGO       Angola        27961
## 4          AGO       Angola        27962
## 5          AGO       Angola        28158
## 6          AGO       Angola        28159
##                                                           Indicator
## 1                                   Overall Global Gender Gap Index
## 2                  Global Gender Gap Political Empowerment subindex
## 3                  Global Gender Gap Political Empowerment subindex
## 4                                   Overall Global Gender Gap Index
## 5 Global Gender Gap Economic Participation and Opportunity Subindex
## 6 Global Gender Gap Economic Participation and Opportunity Subindex
##   Subindicator.Type   X2006    X2007    X2008    X2009   X2010   X2011
## 1             Index  0.6038   0.6034   0.6032   0.6353  0.6712  0.6624
## 2              Rank 81.0000  92.0000 103.0000  36.0000 24.0000 24.0000
## 3             Index  0.0696   0.0696   0.0711   0.2007  0.2901  0.2898
## 4              Rank 96.0000 110.0000 114.0000 106.0000 81.0000 87.0000
## 5              Rank 69.0000  87.0000  87.0000  96.0000 76.0000 96.0000
## 6             Index  0.5872   0.5851   0.5843   0.5832  0.6296  0.5937
##   X2012   X2013    X2014   X2015   X2016   X2018
## 1    NA  0.6659   0.6311   0.637   0.643   0.633
## 2    NA 34.0000  38.0000  38.000  40.000  58.000
## 3    NA  0.2614   0.2402   0.251   0.251   0.206
## 4    NA 92.0000 121.0000 126.000 117.000 125.000
## 5    NA 92.0000 111.0000 116.000 120.000 113.000
## 6    NA  0.6163   0.5878   0.590   0.565   0.602

Luckily, these data are better structured than the childlessness data. The data contains gender inequality measures per year, and for convenience we add a new column with the values for the most recent year for which data are available. In this post, we’ll only look at the rank indicators rather than indices and normalized scores. We drop the Subindicator and IndicatorID columns using the select() function from the dplyr package, as we won’t need these further.

library(dplyr)
gender_index_data["RecentYear"] <- apply(gender_index_data, 1, function(x){as.numeric(x[max(which(!is.na(x)))])})
gender_index_data <- gender_index_data[gender_index_data$Subindicator.Type == "Rank", ] %>% 
  select(-Subindicator.Type, -Indicator.Id)
names(gender_index_data) <- c("ISO3", "Country", "Indicator", as.character(c(2006:2016, 2018)), "RecentYear")
head(gender_index_data)

##    ISO3 Country
## 2   AGO  Angola
## 4   AGO  Angola
## 5   AGO  Angola
## 7   AGO  Angola
## 9   AGO  Angola
## 11  AGO  Angola
##                                                                                           Indicator
## 2                                                  Global Gender Gap Political Empowerment subindex
## 4                                                                   Overall Global Gender Gap Index
## 5                                 Global Gender Gap Economic Participation and Opportunity Subindex
## 7                                                 Global Gender Gap Educational Attainment Subindex
## 9                                                    Global Gender Gap Health and Survival Subindex
## 11 Wage equality between women and men for similar work (survey data, normalized on a 0-to-1 scale)
##    2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2018 RecentYear
## 2    81   92  103   36   24   24   NA   34   38   38   40   58         58
## 4    96  110  114  106   81   87   NA   92  121  126  117  125        125
## 5    69   87   87   96   76   96   NA   92  111  116  120  113        113
## 7   107  119  122  127  125  126   NA  127  138  141  138  143        143
## 9     1    1    1    1    1    1   NA    1   61    1    1    1          1
## 11   NA   NA   NA   NA   NA   NA   NA   NA   NA   NA  135   94         94

Next, we load in our world data with geographical coordinates directly from the ggplot2 package. These data contain geographical coordinates of all countries worldwide, which we’ll later need to plot the worldmaps.

library(maps)
library(ggplot2)
world_data <- ggplot2::map_data('world')
world_data <- fortify(world_data)
head(world_data)

##     long   lat group order region subregion
## 1 -69.90 12.45     1     1  Aruba      <NA>
## 2 -69.90 12.42     1     2  Aruba      <NA>
## 3 -69.94 12.44     1     3  Aruba      <NA>
## 4 -70.00 12.50     1     4  Aruba      <NA>
## 5 -70.07 12.55     1     5  Aruba      <NA>
## 6 -70.05 12.60     1     6  Aruba      <NA>

To map our data, we need to merge the childlessness, gender gap index, and world map data. As I said before, these all have different notations for country names, which is why we’ll use the ISO3 codes. However, even between the ISO code data and the other data sets, there is discrepancy in country names. Unfortunately, to solve this, we need to manually change some country names in our data to match those in the ISO code data set. The code for doing so is long and tedious, so I won’t show that here, but for your reference you can find it here.

Now that the name changes for countries have been made, we can add the ISO3 codes to our childlessness and world map data. The gender gap index data already contain these codes, so there’s no need for us to add these there.

childlessness_data['ISO3'] <- iso_codes$ISO3[match(childlessness_data$Country, iso_codes$Country)]
world_data["ISO3"] <- iso_codes$ISO3[match(world_data$region, iso_codes$Country)]

Next, we melt the childlessness and gender gap index data into long format such that they will have similar shape and column names for merging. The melt() function is included in package reshape2. The goal here is to create variables that have different unique values for the different data, such that I can show you how to adapt the R Shiny app input to the users’ choices. For example, we’ll create a DataType column that has value Childlessness for the rows of the childlessness data and value Gender Gap Index for all rows of the gender gap index data. We’ll also create a column Period that contains earlier, middle and later periods for the childlessness data, and different years for the gender gap index data. As such, when the user chooses to explore the childlessness data, the input for the period will only contain the choices relevant to the childlessness data (i.e., earlier, middle, and later periods and no years). When the user chooses to explore the gender gap index data, they will only see different years as choices for the input of the period, and not earlier, middle, and later periods. The same goes for the Indicator column. This may sound slightly vague at this point, but we’ll see this in practice later on when building the R Shiny app.

library(reshape2)
childlessness_melt <- melt(childlessness_data, id = c("Country", "ISO3", "Period"), 
                           variable.name = "Indicator", value.name = "Value")
childlessness_melt$Value <- as.numeric(childlessness_melt$Value)
gender_index_melt <- melt(gender_index_data, id = c("ISO3", "Country", "Indicator"), 
                          variable.name = "Period", value.name = "Value")

After melting the data and ensuring they’re in the same format, we merge them together using the rbind() function, which we can do here because the data have the same column names.

childlessness_melt["DataType"] <- rep("Childlessness", nrow(childlessness_melt))
gender_index_melt["DataType"] <- rep("Gender Gap Index", nrow(gender_index_melt))
df <- rbind(childlessness_melt, gender_index_melt)

Creating an interactive world map

Next, it’s time to define the function that we’ll use for building our world maps. The inputs to this function are the merged data frame, the world data containing geographical coordinates, and the data type, period and indicator the user will select in the R Shiny app. We first define our own theme, my_theme(), for setting the aesthetics of the plot. Next, we select only the data that the user has selected to view, resulting in plotdf. We keep only the rows for which the ISO3 code has been specified (some countries, e.g., Channel Islands in the childlessness data, are not contained in the ISO code data). We then add the data the user wants to see to the geographical world data. Finally, we plot the world map. The most important part of this plot is that contained in the geom_polygon_interactive() function from the ggiraph package. This function draws the world map in white with grey lines, fills it up according to the value of the data selected (either childlessness or gender gap rank) in a red-to-blue color scheme set using the brewer.pal() function from the RColorBrewer package, and interactively shows in the tooltip the ISO3 code and value when hovering over the plot.

worldMaps <- function(df, world_data, data_type, period, indicator){
  
  # Function for setting the aesthetics of the plot
  my_theme <- function () { 
    theme_bw() + theme(axis.text = element_text(size = 14),
                       axis.title = element_text(size = 14),
                       strip.text = element_text(size = 14),
                       panel.grid.major = element_blank(), 
                       panel.grid.minor = element_blank(),
                       panel.background = element_blank(), 
                       legend.position = "bottom",
                       panel.border = element_blank(), 
                       strip.background = element_rect(fill = 'white', colour = 'white'))
  }
  
  # Select only the data that the user has selected to view
  plotdf <- df[df$Indicator == indicator & df$DataType == data_type & df$Period == period,]
  plotdf <- plotdf[!is.na(plotdf$ISO3), ]
  
  # Add the data the user wants to see to the geographical world data
  world_data['DataType'] <- rep(data_type, nrow(world_data))
  world_data['Period'] <- rep(period, nrow(world_data))
  world_data['Indicator'] <- rep(indicator, nrow(world_data))
  world_data['Value'] <- plotdf$Value[match(world_data$ISO3, plotdf$ISO3)]
  
  # Create caption with the data source to show underneath the map
  capt <- paste0("Source: ", ifelse(data_type == "Childlessness", "United Nations" , "World Bank"))
  
  # Specify the plot for the world map
  library(RColorBrewer)
  library(ggiraph)
  g <- ggplot() + 
    geom_polygon_interactive(data = world_data, color = 'gray70', size = 0.1,
                                    aes(x = long, y = lat, fill = Value, group = group, 
                                        tooltip = sprintf("%s<br/>%s", ISO3, Value))) + 
    scale_fill_gradientn(colours = brewer.pal(5, "RdBu"), na.value = 'white') + 
    scale_y_continuous(limits = c(-60, 90), breaks = c()) + 
    scale_x_continuous(breaks = c()) + 
    labs(fill = data_type, color = data_type, title = NULL, x = NULL, y = NULL, caption = capt) + 
    my_theme()
  
  return(g)
}

Building an R Shiny app

Now that we have our data and world mapping function ready and specified, we can start building our R Shiny app. (If you’re not familiar with R Shiny, I recommend that you to have a look at the Getting Started guide first.) We can build our app by specifying the UI and server components. In the UI, we include a fixed user input selection where the user can choose whether they want to see the childlessness or gender gap index data. We further include dynamic inputs for the period and indicators the user wants to see. As mentioned before, these are dynamic because the choices shown will depend on the selections made by the user on previous inputs. We then use the ggiraph package to output our interactive world map. We use the sidebarLayout() function to show the input selections on the left side and the world map on the right side, rather than the two stacked vertically.

Everything that depends on the inputs by the user needs to be specified in the server function, which in this case is not only the world map creation, but also the second and third input choices, since these depend on the previous inputs made by the user. For example, when we run the app later, we’ll see that when the user selects the childlessness data for the first input for data type, the third indicator input will only show age groups, and the text above the selector will also show “age group”, whereas when the user selects the gender gap index data, the third indicator will show different measures and the text above the selector will show “indicator” rather than “age group”.

Finally, we can run our app by either clicking “Run App” in the top of our RStudio IDE, or by running

shinyApp(ui = ui, server = server)

Below is a screen shot of the app. You can check out the live app here. In this post on my GitHub, you can also see how to embed a Shiny app in your R Markdown files, which is a really cool and innovative way of preparing interactive documents. Finally, the source code used to build the live app can also be found on my GitHub here.

Now try selecting different inputs and see how the input choices change when doing so. Also, don’t forget to try hovering over the world map to see different data values for different countries interactively!

Multiple Hypothesis Testing in R

Wed, 02 Oct 2019 00:00:00 +0000

In the first article of this series, we looked at understanding type I and type II errors in the context of an A/B test, and highlighted the issue of “peeking”. In the second, we illustrated a way to calculate always-valid p-values that were immune to peeking. We will now explore multiple hypothesis testing, or what happens when multiple tests are conducted on the same family of data.

We will set things up as before, with the false positive rate $\alpha = 0.05$ and false negative rate $\beta=0.20$.

library(pwr)
library(ggplot2)
set.seed(1)

mde <- 0.1  # minimum detectable effect
cr_a <- 0.25 # the expected conversion rate for group A
alpha <- 0.05 # the false positive rate
power <- 0.80 # 1-false negative rate

ptpt <- pwr.2p.test(h = ES.h(p1 = cr_a, p2 = (1+mde)*cr_a), 
           sig.level = alpha, 
           power = power
           )
n_obs <- ceiling(ptpt$n)

To illustrate the concepts in this article, we are going to use the same monte_carlo utility function that we used previously:

#
# monte carlo runs n_simulations and calls the callback function each time with the ... optional args
#
monte_carlo <- function(n_simulations, callback, ...){
  simulations <- 1:n_simulations

  sapply(1:n_simulations, function(x){
    callback(...)
  })
}

We’ll use the monte_carlo utility function to run 1000 experiments, measuring whether the p.value is less than alpha after n_obs observations. If it is, we reject the null hypothesis. We will set the effect size to 0; we know that there is no effect and that the null hypothesis is globally true. In this case, we expect about 50 rejections and about 950 non-rejections, since 50/1000 would represent our expected maximum false positive rate of 5%.

set.seed(1)

# make our "true" effect zero: the null hypothesis is always true
effect <- 0
cr_b <- (1+effect)*cr_a
observations <- 2*n_obs

reject_at_i <- function(observations, i){
  conversions_a <- rbinom(observations, 1, cr_a)
  conversions_b <- rbinom(observations, 1, cr_b)
  ( prop.test(c(sum(conversions_a[1:i]),sum(conversions_b[1:i])), c(i,i))$p.value ) < alpha
}

# run the simulation
rejected.H0 <- monte_carlo(1000, 
                           callback=reject_at_i,
                           observations=n_obs,
                           i=n_obs
                           )

# output the rejection table
table(rejected.H0)

## rejected.H0
## FALSE  TRUE 
##   939    61

In practice, we don’t usually test the same thing 1000 times; instead, we test it once and state that there is a maximum 5% chance that we have falsely said there was an effect when there wasn’t one¹.

The Family-Wise Error Rate (FWER)

Now imagine we test two separate statistics using the same source data, with each test constrained by the same $\alpha$ and $\beta$ as before. What is the probability that we will detect at least one false positive considering the results of both tests? This is known as the family-wise error rate (FWER² ³), and would apply to the case where a researcher claims there is a difference between the populations if any of the tests yields a positive result. It’s clear that this could present issues, as the family-wise error rate Wikipedia page illustrates:

Suppose the treatment is a new way of teaching writing to students, and the control is the standard way of teaching writing. Students in the two groups can be compared in terms of grammar, spelling, organization, content, and so on. As more attributes are compared, it becomes increasingly likely that the treatment and control groups will appear to differ on at least one attribute due to random sampling error alone.

What is the FWER for the two tests? To calculate the probability that at least one false positive will arise in our two-test example, consider that the probability that one test will not reject the null is $1-\alpha$. Thus, the probability that both tests will not reject the null is $(1-\alpha)^2)$ and the probability that at least one test will reject the null is $1-(1-\alpha)^2$. For $m$ tests, this generalizes to $1-(1-\alpha)^m$. With $\alpha=0.05$ and $m=2$, we have:

m<-2
1-(1-alpha)^m

## [1] 0.0975

Let’s see if we can produce the same result with a Monte Carlo simulation. We will run the Monte Carlo for n_trials and run n_tests_per_trial. For each trial, if at least one of the n_tests_per_trial results in a rejection of the null, we consider that the trial rejects the null. We should see that about 1 in 10 trials reject the null. This is implemented below:

set.seed(1)
n_tests_per_trial <- 2
n_trials <- 1000
rejects <- 0

for(i in 1:n_trials){
  # run the sim
  rejected.H0 <- monte_carlo(n_tests_per_trial,
                             callback=reject_at_i,
                             observations=n_obs,
                             i=n_obs
                             )
  if(!is.na(table(rejected.H0)[2])) {
    rejects <- rejects + 1
  }
}

# Calculate FWER
rejects/n_trials

## [1] 0.103

Both results show that evaluating two tests on the same family of data will lead to a ~10% chance that a researcher will claim a “significant” result if they look for either test to reject the null. Any claim there is a maximum 5% false positive rate would be mistaken. As an exercise, verify that doing the same on $m=4$ tests will lead to an ~18% chance!

A bad testing platform would be one that claims a maximum 5% false positive rate when any one of multiple tests on the same family of data show significance at the 5% level. Clearly, if a researcher is going to claim that the FWER is no more than $\alpha$, then they must control for the FWER and carefully consider how individual tests reject the null.

Controlling the FWER

There are many ways to control for the FWER, and the most conservative is the Bonferroni correction. The “Bonferroni method” will reject null hypotheses if $p_i \le \frac{\alpha}{m}$. Let’s switch our reject_at_i function for a p_value_at_i function, and then add in the Bonferroni correction:

set.seed(1)

p_value_at_i <- function(observations, i){
  conversions_a <- rbinom(observations, 1, cr_a)
  conversions_b <- rbinom(observations, 1, cr_b)

  prop.test(c(sum(conversions_a[1:i]),sum(conversions_b[1:i])), c(i,i))$p.value
}

n_tests_per_trial <- 2
n_trials <- 1000
rejects <- 0

for(i in 1:n_trials){
  # run n_tests_per_trial
  p_values <- monte_carlo(n_tests_per_trial,
                             callback=p_value_at_i,
                             observations=n_obs,
                             i=n_obs
                             )
  # Bonferroni: adjust the p-values and reject any cases with p-values <= alpha
  rejects <- rejects + sum(any(p_values*n_tests_per_trial <= alpha))

}

# Calculate FWER
rejects/n_trials

## [1] 0.055

With the Bonferroni correction, we see that the realized false positive rate is back near the 5% level. Note that we use any(...) to add 1 if any hypothesis is rejected.

Until now, we have only shown that the Bonferroni correction controls the FWER for the case that all null hypotheses are actually true: the effect is set to zero. This is called controlling in the weak sense. Next, let’s use R’s p.adjust function to illustrate the Bonferroni and Holm adjustments to the p-values:

set.seed(1)

n_tests_per_trial <- 2
n_trials <- 1000

res_bf <- c()
res_holm <- c()

for(i in 1:n_trials){

  # run n_tests_per_trial
  p_values <- monte_carlo(n_tests_per_trial,
                          callback=p_value_at_i,
                          observations=n_obs,
                          i=n_obs
                          )
  # Bonferroni: adjust the p-values and reject/accept
  bf_reject <- p.adjust(p_values, "bonferroni") <= alpha
  res_bf <- c(res_bf, sum(any(bf_reject)))

  # Holm: adjust the p-values and reject/accept
  holm_reject <- p.adjust(sort(p_values), "holm") <= alpha
  res_holm <- c(res_holm, sum(any(holm_reject)))

}

# Calculate FWER
sum(res_bf)/length(res_bf)

## [1] 0.055

sum(res_holm)/length(res_holm)

## [1] 0.055

We see that the Holm correction is very similar to the Bonferroni correction in the case that the null hypothesis is always true.

Strongly controlling the FWER

Both the Bonferroni and Holm corrections guarantee that the FWER is controlled in the strong sense, in which we have any configuration of true and non-true null hypothesis. This is ideal, because in reality, we do not know if there is an effect or not.

The Holm correction is uniformly more powerful than the Bonferroni correction, meaning that in the case that there is an effect and the null is false, using the Holm correction will be more likely to detect positives.

Let’s test this by randomly setting the effect size to the minimum detectable effect in about half the cases. Note the slightly modified p_value_at_i function as well as the null_true variable, which will randomly decide if there is a minimum detectable effect size or not for that particular trial.

Note that in the below example, we will not calculate the FWER using the same any(...) construct from the previous code segments. If we were to do this, we would see that the both corrections have the same FWER and the same power (since the outcome of the trial is then decided by whether at least one of the hypotheses was rejected for the trial). Instead, we will tabulate the result for each of the hypotheses. We should see the same false positive rate⁴, but great power for the Holm method.

set.seed(1)

p_value_at_i <- function(observations, i, cr_a, cr_b){
  conversions_a <- rbinom(observations, 1, cr_a)
  conversions_b <- rbinom(observations, 1, cr_b)

  prop.test(c(sum(conversions_a[1:i]),sum(conversions_b[1:i])), c(i,i))$p.value
}

n_tests_per_trial <- 2
n_trials <- 1000

res_bf <- c()
res_holm <- c()

for(i in 1:n_trials){
  null_true <- rbinom(1,1,prob = 0.5)
  effect <- mde * null_true
  cr_b <- (1+effect)*cr_a

  # run n_tests_per_trial
  p_values <- monte_carlo(n_tests_per_trial,
                          callback=p_value_at_i,
                          observations=n_obs,
                          i=n_obs,
                          cr_a=cr_a,
                          cr_b=cr_b
                          )
  # Bonferroni: adjust the p-values and reject/accept
  reject_bf <- p.adjust(p_values, "bonferroni") <= alpha
  for(r in reject_bf){
    res_bf <- rbind(res_bf, c(r, null_true))
  }

  # Holm: adjust the p-values and reject/accept
  reject_holm <- p.adjust(sort(p_values), "holm") <= alpha
  for(r in reject_holm){
    res_holm <- rbind(res_holm, c(r, null_true))
  }
  
}

# the rows of the table represent the test result
# while the columns represent the null truth
table_bf <- table(Test=res_bf[,1], Null=res_bf[,2])
table_holm <- table(Test=res_holm[,1], Null=res_holm[,2])

# False positive rate
fpr_bf <- table_bf['1','0']/sum(table_bf[,'0'])
fpr_holm <- table_holm['1','0']/sum(table_holm[,'0'])

print(paste0("FPR Bonferroni: ", round(fpr_bf,3), " FPR Holm: ", round(fpr_holm,3)))

## [1] "FPR Bonferroni: 0.029 FPR Holm: 0.029"

# Power
power_bf <- table_bf['1','1']/sum(table_bf[,'1'])
power_holm <- table_holm['1','1']/sum(table_holm[,'1'])

print(paste0("Power Bonferroni: ", round(power_bf,3), " Power Holm: ", round(power_holm,3)))

## [1] "Power Bonferroni: 0.713 Power Holm: 0.774"

# Comparing the Power of Holm vs. Bonferroni
print(paste0("Power Holm/Power Bonferroni: ", round(power_holm/power_bf,3)))

## [1] "Power Holm/Power Bonferroni: 1.084"

Indeed, we observe that while the realized false positive rates of both the Bonferroni and Holm methods are very similar, the Holm method has greater power. These corrections essentially reduce our threshold for each test so that across the family of tests, we produce false positives with a probability of no more than $\alpha$. This comes at the expense of a reduction in power from the optimal power ($1-\beta$).

We have illustrated two methods for deciding what null hypotheses in a family of tests to reject. The Bonferroni method rejects hypotheses at the $\alpha/m$ level. The Holm method has a more involved algorithm for which hypotheses to reject. The Bonferroni and Holm methods have the property that they do control the FWER at $\alpha$, and Holm is uniformly more powerful than Bonferroni.

This raises an interesting question: What if we are not concerned about controlling the probability of detecting at least one false positive, but something else? We might be more interested in controlling the expected proportion of false discoveries amongst all discoveries, known as the false discovery rate. As a quick preview, let’s calculate the false discovery rate for our two cases:

table_holm

##     Null
## Test   0   1
##    0 959 229
##    1  29 783

table_bf

##     Null
## Test   0   1
##    0 959 290
##    1  29 722

fdr_holm <- table_holm['1','0']/sum(table_holm['1',])
fdr_holm

## [1] 0.03571

fdr_bf <- table_bf['1','0']/sum(table_bf['1',])
fdr_bf

## [1] 0.03862

By choosing to control for a metric other than the FWER, we may be able to produce results with power closer to the optimal power ($1-\beta$). We will look at the false discovery rate and other measures in a future article.

Roland Stevenson is a data scientist and consultant who may be reached on LinkedIn.

And a maximum 20% chance that we said there wasn’t an effect when there was one.↩
Hochberg, Y.; Tamhane, A. C. (1987). Multiple Comparison Procedures. New York: Wiley. p. 5. ISBN 978-0-471-82222-6↩
A sharper Bonferroni procedure for multiple tests of significance ↩
Verify this by inspecting the table_bf and table_holm variables.↩

R/Medicine 2019 Workshops

Thu, 12 Sep 2019 00:00:00 +0000

R/Medicine 2019 kicked off on Thursday with two outstanding workshops. It was difficult to choose between the two, but fortunately both presenters developed rich sets of materials that are available online.

Alison Hill delivered R Markdown for Medicine with an elegant HTML exposition masterfully created to cultivate beginners while still engaging experienced R Markdown users.

Photo by Samuel Zeller on Unsplash

In four sections: (1) R Markdown Anatomy, (2) Outputs and Tables, (3) Graphics for Communication and (4) Data and Workflows she developed aspects of R Markdown aimed at statisticians and clinicians writing medical document which should also delight a wide audience of R Markdown users.

In the parallel session, Elizabeth (Beth) Atkinson distilled years of experience Wrangling survival data at the Mayo Clinic while presenting new functionality from version 3.0 of Terry Therneau’s Survival package which contains significant new material on multi-state models. (Version 3.0 is expected to make it to CRAN very soon, but if you can’t wait, you can install the new version from GitHub with: install_github("therneau/survival", dependencies=TRUE). Terry, who will be delivering the opening keynote presentation, also attended the workshop. It was a rare treat to hear Beth and Terry discuss best practices, pitfalls and common errors while fielding questions from the attendees. Beth assembled so much material it will take a “month of Sundays” to work through it all, but I doubt that there is a better source of material anywhere that makes the special difficulties of wrangling survival data more easily accessible. The following gem shows up early in the presentation.

R/Medicine is off to a great start.

Calculating Always-Valid p-values in R

Thu, 22 Aug 2019 00:00:00 +0000

In this post, we will develop a framework for always-valid inference based on the paper Always Valid Inference: Continuous Monitoring of A/B Tests (2019 Johari, Pekelis, Walsh). Using an always-valid p-value allows us to continuously monitor A/B tests, and potentially stop the test early in a valid way¹.

In section 5 of the paper, the authors propose their method for calculating always-valid p-values: the mixture sequential ratio probability test (mSPRT), first introduced by Robbins (1970). To keep this post brief, we will not do the paper’s theoretical foundations justice. Instead, we will focus on the most important equations, which we will use to produce always valid p-values in our R code. For those uninterested in the math, feel free to skip ahead.

The paper makes some basic assumptions about the data and its functional form: it is real valued and drawn from a single-parameter exponential family where tests are of the parameter $\theta$. The mSPRT is parameterized by mixing distribution $H$ over $\Theta$, an open interval that contains all $\theta$. Given an observed sample average $s_n$ at time $n$, the mixture likelihood ratio of $\theta$ against $\theta_0$ with respect to H is defined as:

$\Lambda_{n}^{H}(s_{n}) = \displaystyle\int_{\Theta}\bigg(\frac{f_{\theta}(s_{n})}{f_{\theta_{0}}(s_{n})}\bigg)^{n} dH(\theta)$

We are told to calculate the p-values as:

$p_{0} = 1; p_{n} = min\{p_{n-1}, 1/\Lambda_{n}^{H}\}$

So, if we have a mixing distribution $H(\theta)$ and iterate over it, we can calculate $\Lambda_{n}^{H}(s_{n})$ for the sample average we have observed at time $n$. If $\Lambda_{n}^{H}$ is ever greater than $\alpha$, our tolerance for the false positive rate $p_n$ will exceed $alpha$, and we can stop the test and reject the null hypothesis.

We will implement this for a simple comparison of two binomial distributions first, where some convenient results make $p_{n}$ easier to calculate. In section 6.1, the paper describes the deployment for two-stream p-values. In this case, we are looking at two streams of Bernoulli data: two streams of ones and zeros describing whether we observed a conversion or an abandonment in each stream.

The central limit theorem tells us that the distribution of the average number of conversions will be approximately normal after a large number of observations (say, more than 100). What we want to know is: is there a statistically significant difference between the measured averages of the two streams? Put another way: is the difference between the measured averages of the two streams significantly different from zero? It is this second formulation that we will implement.

We will skip the derivation for normal data and say that if we have two streams of Bernoulli data, $A_n$ and $B_n$, that each yield approximately normal average conversion rates $\mu_{A,n}$ and $\mu_{B,n}$ after $n$ observations, we can take $f_\theta(s_n) \approx N(\theta, \sigma^2)$ and use a normal mixing distribution $H=N(0,\tau^2)$ in $\Lambda_n^H$ to decide if $\theta_n$ is significantly different from zero. Conveniently, this mixing distribution yields a closed-form formula for $\Lambda_n^H$:

$\Lambda_n^H = \sqrt{\frac{\sigma_n^2}{\sigma_n^2+n\tau^2}} exp\bigg\{\frac{n^2\tau^2(\theta_n)^2}{2\sigma_n^2(\sigma_n^2+n\tau^2)}\bigg\}$

Let’s look at the variables in the above equation. We can calculate $\theta_n = \mu_{A,n}-\mu_{B,n}$ from our streams of Bernoulli data by calculating the average conversion rates at $n$ for each stream. We can also use the fact that the variance $\nu$ of a binomial distribution with mean $\mu$ is $\nu = \mu(1-\mu)$, and that the variance of the sum of two random binomials is the sum of their variances:

$\nu_{AB} = \nu_A + \nu_B = \mu_{A,n}(1-\mu_{A,n}) + \mu_{B,n}(1-\mu_{B,n}) = \sigma_n^2$.

One lingering issue is: how do we define $\tau^2$? The answer is that we can choose any $\tau^2$ we would like, though experience will show it is best if $\tau^2$ is on the order of $\sigma^2$. Later we will explore what different $\tau^2$ values yield, and how there is an optimal $\tau^2$ to choose.

Let’s convert the above into code:

# First we define the function that calculates lambda
# given n, the means at n of A and B, and tau_squared 
lambda <- function(n, mu_a_n, mu_b_n, tau_sq){
  v_n <- (mu_a_n*(1-mu_a_n) + mu_b_n*(1-mu_b_n))
  nts <- n*tau_sq
  if(v_n == 0){
    return(1.0)
  }
  else {
    return(
      sqrt((v_n)/(v_n+nts))*
        exp(
          ((n*nts)*(mu_a_n-mu_b_n)^2)/
            ((2.0*v_n)*(v_n+nts))
        )
    )
  }
}

# Next we will calculate the always valid p-values at each n
calc_avpvs <- function(n_obs, cr_a_obs, cr_b_obs, tau_sq = 0.1){
  p_n <- rep(1.0,n_obs)

  for (i in 2:n_obs) {
    mu_a_n <- mean(cr_a_obs[1:i])
    mu_b_n <- mean(cr_b_obs[1:i])
    p_n[[i]] <- min(p_n[[i-1]],1/lambda(i,mu_a_n, mu_b_n, tau_sq))
  }
  
  p_n
}

Now, let’s create a test example, similar to our previous post, and set an effect size that is twice the minimum detectable effect. In this case, we should expect that after having observed the “correct” number of observations given by the power calculation, there is a very high probability that we’ll see an effect.

library(pwr)
library(ggplot2)

## Warning: package 'ggplot2' was built under R version 3.5.2

set.seed(5)

mde <- 0.1  # minimum detectable effect
cr_a <- 0.25 # the expected conversion rate for group A
alpha <- 0.05 # the false positive rate
power <- 0.80 # 1-false negative rate

ptpt <- pwr.2p.test(h = ES.h(p1 = cr_a, p2 = (1+mde)*cr_a), 
                    sig.level = alpha, 
                    power = power
)
n_obs <- ceiling(ptpt$n)

# make our "true" effect 1.5x larger than the mde
# this should yield a conclusive test result
effect <- 1.5*mde
cr_b <- (1+effect)*cr_a
observations <- 2*n_obs

# two streams of {0,1} conversions
conversions_a <- rbinom(observations, 1, cr_a)
conversions_b <- rbinom(observations, 1, cr_b)

# now we'll calculate the always-valid p-values
avpvs <- calc_avpvs(observations, conversions_a, conversions_b)


# And we'll calculate "regular" p-values as well
tt <- sapply(10:observations, function(x){
  t.test(conversions_a[1:x],conversions_b[1:x])$p.value
})

tt <- data.frame(p.value = unlist(tt))

# for plots
conf_95 <- data.frame( x = c(-Inf, Inf), y = 0.95 )
obs_limit_line <- data.frame( x = n_obs, y = c(-Inf, Inf) )

# plot the evolution of p-values and always-valid p-values
ggplot(tt, aes(x=seq_along(p.value), y=1-p.value)) + 
  geom_line() + 
  geom_line(aes(x, y, color="alpha=5%"), linetype=3, conf_95) + 
  geom_line(aes(x, y, color="end of test"), linetype=4, obs_limit_line) +
  geom_line(data=data.frame(x=seq(1:observations),y=1-avpvs), aes(x=x,y=y, color="avpv")) +
  xlab("Observation (n)") +
  scale_color_discrete(name = "Legend") +
  ylim(c(0,1))

In this case, we see that by using the always valid p-value, we would be able to terminate early while still controlling the false positive rate at $\alpha$. Let’s look at what happens when there is no effect:

effect <- 0
cr_b <- (1+effect)*cr_a
observations <- 2*n_obs

# two streams of {0,1} conversions
conversions_a <- rbinom(observations, 1, cr_a)
conversions_b <- rbinom(observations, 1, cr_b)

# now we'll calculate the always-valid p-values
avpvs <- calc_avpvs(observations, conversions_a, conversions_b)

# And we'll calculate "regular" p-values as well
tt <- sapply(10:observations, function(x){
  t.test(conversions_a[1:x],conversions_b[1:x])$p.value
})
tt <- data.frame(p.value = unlist(tt))

# for plots
conf_95 <- data.frame( x = c(-Inf, Inf), y = 0.95 )
obs_limit_line <- data.frame( x = n_obs, y = c(-Inf, Inf) )

# plot the evolution of p-values and always-valid p-values
ggplot(tt, aes(x=seq_along(p.value), y=1-p.value)) + 
  geom_line() + 
  geom_line(aes(x, y, color="alpha=5%"), linetype=3, conf_95) + 
  geom_line(aes(x, y, color="end of test"), linetype=4, obs_limit_line) +
  geom_line(data=data.frame(x=seq(1:observations),y=1-avpvs), aes(x=x,y=y, color="avpv")) +
  xlab("Observation (n)") +
  scale_color_discrete(name = "Legend") +
  ylim(c(0,1))

In this case, we see a test in which the p-values oscillate near alpha. A “peeker” looking at this might have incorrectly called it a winner early on, however our always-valid p-values maintain the correct outcome.

Now set things up to have an effect 1.5 times the size of the minimum detectable effect and see what effect varying $\tau^2$ has. We’ll choose five different values at different orders of magnitude between 0.0001 and 1:

library(pwr)
library(ggplot2)
set.seed(5)

mde <- 0.1  # minimum detectable effect
cr_a <- 0.25 # the expected conversion rate for group A
alpha <- 0.05 # the false positive rate
power <- 0.80 # 1-false negative rate

ptpt <- pwr.2p.test(h = ES.h(p1 = cr_a, p2 = (1+mde)*cr_a), 
                    sig.level = alpha, 
                    power = power
)
n_obs <- ceiling(ptpt$n)
n_obs

## [1] 4860

# make our "true" effect 1.5x larger than the mde
# this should yield a conclusive test result
effect <- 1.5*mde
cr_b <- (1+effect)*cr_a
observations <- 2*n_obs

# two streams of {0,1} conversions
conversions_a <- rbinom(observations, 1, cr_a)
conversions_b <- rbinom(observations, 1, cr_b)

# now we'll calculate the always-valid p-values
avpvs_tsa <- calc_avpvs(observations, conversions_a, conversions_b, tau_sq = 0.0001)
avpvs_tsb <- calc_avpvs(observations, conversions_a, conversions_b, tau_sq = 0.001)
avpvs_tsc <- calc_avpvs(observations, conversions_a, conversions_b, tau_sq = 0.01)
avpvs_tsd <- calc_avpvs(observations, conversions_a, conversions_b, tau_sq = 0.1)
avpvs_tse <- calc_avpvs(observations, conversions_a, conversions_b, tau_sq = 1)

# And we'll calculate "regular" p-values as well
tt <- sapply(10:observations, function(x){
  t.test(conversions_a[1:x],conversions_b[1:x])$p.value
})
tt <- data.frame(p.value = unlist(tt))

# for plots
conf_95 <- data.frame( x = c(-Inf, Inf), y = 0.95 )
obs_limit_line <- data.frame( x = n_obs, y = c(-Inf, Inf) )

# plot the evolution of p-values and always-valid p-values
ggplot(tt, aes(x=seq_along(p.value), y=1-p.value)) + 
  geom_line() + 
  geom_line(aes(x, y, color="alpha=5%"), linetype=3, conf_95) + 
  geom_line(aes(x, y, color="end of test"), linetype=4, obs_limit_line) +
  geom_line(data=data.frame(x=seq(1:observations),y=1-avpvs_tsa), aes(x=x,y=y, color="avpv_0.0001")) +
  geom_line(data=data.frame(x=seq(1:observations),y=1-avpvs_tsb), aes(x=x,y=y, color="avpv_0.001")) +
  geom_line(data=data.frame(x=seq(1:observations),y=1-avpvs_tsc), aes(x=x,y=y, color="avpv_0.01")) +
  geom_line(data=data.frame(x=seq(1:observations),y=1-avpvs_tsd), aes(x=x,y=y, color="avpv_0.1")) +
  geom_line(data=data.frame(x=seq(1:observations),y=1-avpvs_tse), aes(x=x,y=y, color="avpv_1")) +
  xlab("Observation (n)") +
  scale_color_discrete(name = "Legend") +
  ylim(c(0,1))

It looks like we might be able to stop early if we use anything but the lowest and highest values for $\tau^2$.

Using always-valid p-values, particularly for small- or zero-sized effects, can be helpful in avoiding false positives. I’ve glossed over some important details that should be considered when working with non-normal data, but I hope this provides an introduction to an alternative way of evaluating binomial A/B tests. See Always Valid Inference: Continuous Monitoring of A/B Tests for more details.

Roland Stevenson is a data scientist and consultant who may be reached on LinkedIn.

For an even simpler approach, see what Etsy does.↩

Plumber Logging

Tue, 13 Aug 2019 00:00:00 +0000

The plumber R package is used to expose R functions as API endpoints. Due to plumber’s incredible flexibility, most major API design decisions are left up to the developer. One important consideration to be made when developing APIs is how to log information about API requests and responses. This information can be used to determine how plumber APIs are performing and how they are being utilized.

An example of logging API requests in plumber is included in the package documentation. That example uses a filter to log information about incoming requests before a response has been generated. This is certainly a valid approach, but it means that the log cannot contain details about the response since the response hasn’t been created yet. In this post we will look at an alternative approach to logging plumber APIs that uses preroute and postroute hooks to log information about each API request and its associated response.

Logging

In this example, we will use the logger package to generate the actual log entries. Using this package isn’t required, but it does provide some convenient functionality that we will take advantage of.

Since we will be registering hooks for our API, we will need both a plumber.R file and an entrypoint.R file. The plumber.R file contains the following:

# plumber.R
# A simple API to illustrate logging with Plumber

library(plumber)

#* @apiTitle Logging Example

#* @apiDescription Simple example API for implementing logging with Plumber

#* Echo back the input
#* @param msg The message to echo
#* @get /echo
function(msg = "") {
  list(msg = paste0("The message is: '", msg, "'"))
}

#* Plot a histogram
#* @png
#* @get /plot
function() {
  rand <- rnorm(100)
  hist(rand)
}

Now that we’ve defined two endpoints (/echo and /plot), we can use entrypoint.R to setup logging using preroute and postroute hooks. First, we need to configure the logger package:

# entrypoint.R
library(plumber)

# logging
library(logger)

# Specify how logs are written
log_dir <- "logs"
if (!fs::dir_exists(log_dir)) fs::dir_create(log_dir)
log_appender(appender_tee(tempfile("plumber_", log_dir, ".log")))

The log_appender() function is used to specify which appender method is used for logging. Here we use appender_tee() so that logs will be written to stdout and to a specific file path. We create a directory called logs/ in the current working directory to store the resulting logs. Every log file is assigned a unique name using tempfile(). This prevents errors that can occur if concurrent processes try to write to the same file.

Now, we need to create a helper function that we will use when creating log entries:

convert_empty <- function(string) {
  if (string == "") {
    "-"
  } else {
    string
  }
}

This function takes an empty string and converts it into a dash ("-"). We will use this to ensure that empty log values still get recorded so that it is easy to read the log files. We’re now ready to create our plumber router and register the hooks necessary for logging:

pr <- plumb("plumber.R")

pr$registerHooks(
  list(
    preroute = function() {
      # Start timer for log info
      tictoc::tic()
    },
    postroute = function(req, res) {
      end <- tictoc::toc(quiet = TRUE)
      # Log details about the request and the response
      log_info('{convert_empty(req$REMOTE_ADDR)} "{convert_empty(req$HTTP_USER_AGENT)}" {convert_empty(req$HTTP_HOST)} {convert_empty(req$REQUEST_METHOD)} {convert_empty(req$PATH_INFO)} {convert_empty(res$status)} {round(end$toc - end$tic, digits = getOption("digits", 5))}')
    }
  )
)

pr

We use the $registerHooks() method to register both preroute and postroute hooks. The preroute hook uses the tictoc package to start a timer. The postroute hook stops the timer and then writes a log entry using the log_info() function from the logger package. Each log entry contains the following information:

Log level: This is a distinction made by the logger package, and in this example the value is always INFO
Timestamp: The timestamp for when the response was generated and sent back to the client
Remote Address: The address of the client making the request
User Agent: The user agent making the request
Http Host: The host of the API
Method: The HTTP method attached to the request
Path: The specific API endpoint requested
Status: The HTTP status of the response
Execution Time: The amount of time from when the request received until the response was generated

This log format is loosely inspired by the NCSA Common log format.

Testing

Now that our API is all setup, it’s time to test to make sure logging works as expected. First, we need to start the API. The easiest way to do this is to click the Run API button that appears at the top of the plumber.R file in the RStudio IDE. Once the API is running, you’ll see a message in the console similar to the following:

Running plumber API at http://127.0.0.1:5762

Now that we know the API is running, we need to make a request. One of the easiest ways to make a request in this case is to open a web browser (like Google Chrome) and type the API address in the address bar followed by /plot. In this example, I would type http://127.0.0.1:5762/plot into the address bar of my browser. If all goes well, you should see a plot rendered in the browser. The RStudio console will display the log output:

INFO [2019-08-09 12:30:23] 127.0.0.1 "Mozilla/5.0 (Macintosh; Intel Mac OS X 10_14_6) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/76.0.3809.100 Safari/537.36" localhost:5762 GET /plot 200 0.158

A new logs/ directory will have been created in the current working directory and it will contain a file with the log entry. You can generate more log entries by refreshing your browser window.

Analyzing

Let’s say that we refreshed the browser window 1,000 times. The log file generated will contain an entry for each request. We can analyze this log file to find helpful information about the API. For example, we could plot a histogram of execution time:

library(ggplot2)

plumber_log <- readr::read_log("logs/plumber_fe3daed895d.log",
                               col_names = c("log_level",
                                             "timestamp",
                                             "remote_address",
                                             "user_agent",
                                             "http_host",
                                             "method",
                                             "path",
                                             "status",
                                             "execution_time"))

ggplot(plumber_log, aes(x = execution_time)) +
  geom_histogram() +
  theme_bw() +
  labs(title = "Execution Times",
       x = "Execution Time")

We could even build a Shiny application to monitor the logs/ directory and provide real-time visibility into API metrics!

The details of this Shiny application go beyond the scope of this post, but the source code is available here.

Plumber APIs published to RStudio Connect can use this pattern to log and monitor API requests. Details on this use case can be found in this repository

Conclusion

Plumber is an incredibly flexible package for exposing R functions as API endpoints. Logging information about API requests and responses provides visibility into API usage and performance. These log files can be manually inspected or used in connection with other tools (like Shiny) to provide real-time metrics around API use. The code used in this example along with additional information is available in this GitHub repository.

If you are interested in learning more about using plumber, logging, Shiny, and RStudio Connect, please visit community.rstudio.com and let us know!

James Blair is a solutions engineer at RStudio who focuses on tools, technologies, and best practices for using R in the enterprise.

Validating Type I and II Errors in A/B Tests in R

Wed, 31 Jul 2019 00:00:00 +0000

In this post, we seek to develop an intuitive sense of what type I (false-positive) and type II (false-negative) errors represent when comparing metrics in A/B tests, in order to gain an appreciation for “peeking”, one of the major problems plaguing the analysis of A/B test today.

To better understand what “peeking” is, it helps to first understand how to properly run a test. We will focus on the case of testing whether there is a difference between the conversion rates cr_a and cr_b for groups A and B. We define conversion rate as the total number of conversions in a group divided by the total number of subjects. The basic idea is that we create two experiences, A and B, and give half of the randomly-selected subjects experience A and half B. Then, after some number of users have gone through our test, we measure how many conversions happened in each group. The important question is: how many users do we need to have in groups A and B in order to measure a difference in conversion rates of a particular size?

To correctly run a test, one should first calculate the required sample size by doing a power calculation. This is easily done in R using the pwr library, which requires a few parameters: the desired significance level (the false positive rate), the desired statistical power (1-false negative rate), the minimum detectable effect, and the baseline conversion rate cr_a.

library(pwr)
mde <- 0.1  # minimum detectable effect
cr_a <- 0.25 # the expected conversion rate for group A
alpha <- 0.05 # the false positive rate
power <- 0.80 # 1-false negative rate

ptpt <- pwr.2p.test(h = ES.h(p1 = cr_a, p2 = (1+mde)*cr_a), 
           sig.level = alpha, 
           power = power
           )
n_obs <- ceiling(ptpt$n)

This result tells us that we need to observe 4860 subjects in each of the A and B test groups if we want to detect a difference of 10% in their conversion rates. Once we have observed that quantity, we can calculate whether there is a statistically significant difference between the two sets of observations via a t-test.

Given the parameters we included in our power calculation, there are two things to be aware of:

there is a 5% chance that our t-test will predict that there is a statistically significant difference when, in fact, there isn’t (a false positive). That is a result of our alpha parameter, which sets a false-positive rate of 5%.
there is a 20% chance that the t-test will predict no difference when there actually was a difference (a false negative). This is the false-negative rate (or 1-power), and is commonly referred to as beta.

Illustrating alpha and beta parameters

Let’s try to illustrate this through a simulation. We’ll simulate two sequences of conversions with conversion rates such that cr_b = (1+mde)*cr_a. We’ll then run a t-test comparing all of the available observations of the two groups each time we have a new pair of observations. If the p-value of the t-test is below 5%, we will reject the null-hypothesis that there is no difference between the distributions; hence, p.value < 0.05 implies there is a statistically significant difference between the conversion rates. Finally we’ll plot 1-p.value to represent “confidence” relative to where we are in the sequence. This essentially simulates what we would see if we were to continually monitor p-values as subjects convert or abandon. We add the 95% confidence line horizontally, as well as a vertical line at n_obs, the number of observations our power calculation says to use to conduct a t-test.

library(ggplot2)

## Warning: package 'ggplot2' was built under R version 3.5.2

set.seed(2)

# make our "true" effect larger than the mde
effect <- mde
cr_b <- (1+effect)*cr_a
observations <- 2*n_obs

# a sequence of {0,1} conversions
conversions_a <- rbinom(observations, 1, cr_a)
conversions_b <- rbinom(observations, 1, cr_b)

# Calculate p-values at each simultaneous observation of the a and b groups
tt <- sapply(10:observations, function(x){
  t.test(conversions_a[1:x],conversions_b[1:x])$p.value
})

tt <- data.frame(p.value = unlist(tt))

# for plots
conf_95 <- data.frame( x = c(-Inf, Inf), y = 0.95 )
obs_limit_line <- data.frame( x = n_obs, y = c(-Inf, Inf) )

# plot the evolution of p-value over time, if "peeking"
ggplot(tt, aes(x=seq_along(p.value), y=1-p.value)) + 
  geom_line() + 
  geom_line(aes(x, y, color="alpha=5%"), linetype=3, conf_95) + 
  geom_line(aes(x, y, color="end of test"), linetype=4, obs_limit_line) +
  xlab("Observation (day)") +
  scale_color_discrete(name = "Legend") +
  ylim(c(0,1))

We observe that in the above example, we would correctly have measured a difference in conversion rates for this particular simulation. However, we should expect that if we run this experiment 100 times, about 20 of those times will result in an incorrect negative prediction due to our false negative rate being 20% (power=80).

To test this, and other concepts in this article, we are going to create a utility function that will run a simulation repeatedly:

#
# monte carlo runs n_simulations and calls the callback function each time with the ... optional args
#
monte_carlo <- function(n_simulations, callback, ...){
  simulations <- 1:n_simulations

  sapply(1:n_simulations, function(x){
    callback(...)
  })
}

Now, we’ll use the monte_carlo utility function to run 1000 experiments, measuring whether the p.value is less than alpha after n_obs observations. If it is, we reject the null hypothesis. We expect about 800 rejections and about 200 non-rejections, since 200/1000 would represent our expected 20% false negative rate.

reject_at_i <- function(observations, i){
  conversions_a <- rbinom(observations, 1, cr_a)
  conversions_b <- rbinom(observations, 1, cr_b)
  ( t.test(conversions_a[1:i],
           conversions_b[1:i])$p.value ) < alpha
}

# run the sim
rejected.H0 <- monte_carlo(1000, 
                           callback=reject_at_i,
                           observations=n_obs,
                           i=n_obs
                           )

# output the rejection table
table(rejected.H0)

## rejected.H0
## FALSE  TRUE 
##   190   810

We will use the same functions to test the false positive rate. In this case, we want to set the two conversion rates to the same value, cr_a, and confirm that out of 1000 experiments, about 50 show up as having rejected the null hypothesis (and predict a difference in the conversion rates).

reject_at_i <- function(observations, i){
  conversions_a <- rbinom(observations, 1, cr_a)
  conversions_b <- rbinom(observations, 1, cr_a) # this is now the same conversion rate
  ( t.test(conversions_a[1:i],
           conversions_b[1:i])$p.value ) < alpha
}

# run the sim
rejected.H0 <- monte_carlo(1000, 
                           callback=reject_at_i,
                           observations=n_obs,
                           i=n_obs
                           )

# output the rejection table
table(rejected.H0)

## rejected.H0
## FALSE  TRUE 
##   962    38

Indeed, the results are as expected. We have shown that if we measure the results of our experiment when our power calculation tells us to, we can expect the false positive and false negative rates to reflect the values we have set in alpha and power.

Peeking

What happens if we don’t do a power calculation and instead monitor the conversions as they come in? This is what is termed “peeking”. In other words, to run a test correctly, you should only observe the results at one moment: when the power calculation has told you the test is complete. If you look at any moment prior to this, you are peeking at the results.

Peeking is widespread when it comes to analyzing experiments. In fact, some popular testing services peek continuously and automatically notify as soon as a p-value is below alpha. What you may notice, however, is that p-values can fluctuate around alpha multiple times before “choosing” a side, particularly where the size of an effect is small. Continuously monitoring p-values will inflate false positive rates. Let’s see what effect continuous peeking has on our false positive rates:

peeking_method <- function (observations, by=1){
  # create the conversions
  conversions_a <- rbinom(observations, 1, cr_a)
  conversions_b <- rbinom(observations, 1, cr_a)  # no effect

  reject <- FALSE;

  # for each simulation, calculate the running conversion rates and days to complete.
  # Break the first time we have run more than the required days to complete
  for (i in seq(from=by,to=observations,by=by)) {
    tryCatch(
      {
        reject <- ( t.test(conversions_a[1:i],conversions_b[1:i])$p.value ) < alpha
        if(reject){
          break;
        }
      }, error=function(e){
        print(e)
      }
    )
  }
  
  reject

}
# run the sim
rejected.H0 <- monte_carlo(1000,
                           callback=peeking_method,
                           observations=n_obs,
                           by=100
                           )


# output the rejection table
table(rejected.H0)

## rejected.H0
## FALSE  TRUE 
##   653   347

Indeed, even peeking every 100 sets of observations leads to an inflated false positive rate of about 30%! Peeking at test results to make decisions, and especially automating peeking to make decisions, is a big no-no.

In a subsequent article, we’ll explore an alternative way of measuring p-values that is not affected by peeking, based on sequential probability ratio tests.

Roland Stevenson is a data scientist and consultant who may be reached on LinkedIn.

An R Users Guide to JSM 2019

Fri, 19 Jul 2019 00:00:00 +0000

If you are like me, and rather last minute about making a plan to get the most out of a large conference, you are just starting to think about JSM 2019 which will begin in just a few days. My plans always begin with an attempt to sleuth out the R-related sessions. While in the past it took quite a bit of work to identify talks that were likely backed by R-based calculations, this is clearly no longer the case. In fact, because Stanford Professor Trevor Hastie will be delivering the prestigious Wald Lectures this year, R-backed work will be front and center.

Professor Hastie has made numerous, important contributions to statistical learning, machine learning, data science and statistical computing. Among the latter, is the glmnet package he co-authored with Jerome Friedman, Rob Tibshirani, Noah Simon, Balasubramanian Narasimhan and Junyang Qian which has become a fundamental resource.

The Wald Lectures will be delivered over three days in room CC Four Seasons 1 according to the following schedule:
* Lecture 1: Mon, 7/29/2019, 10:30 AM - 12:20 PM
* Lecture 2: Tue, 7/30/2019, 2:00 PM - 3:50 PM
* Lecture 3: Wed, 7/31/2019, 10:30 AM - 12:20 PM

If you want to do some preparation for the lectures, you might have a look at the book Statistical Learnig with Sparsity; The Lasso and Generalizations by Hastie, Tibshirani and Wainwright.

The rest of this post lists some R-related talks that can help you fill your days at JSM! I am sure my list is not complete. Please feel free to add anything I may have missed to the comments section following this post.

Sunday, July 28, 2019

Findings from Analysis and Visualization of the New York City Housing and Vacancy Survey Data - CC 501 - 3:20 PM - Nels Grevstad, Metropolitan State University of Denver; Rachel Rosebrook, Metropolitan State University of Denver; Lance Barto, Metropolitan State University of Denver; Gil Leibovich, Metropolitan State University of Denver; Elizabeth Foster, Metropolitan State University of Denver; ThienNgo Le, Metropolitan State University of Denver; Kelsey Smith, Metropolitan State University of Denver; Nathanael Whitney, Metropolitan State University of Denver; Zoe Girkin, Metropolitan State University of Denver; Ahern Nelson, Metropolitan State University of Denver; Karan Bhargava, Metropolitan State University of Denver; Alex Whalen-Wagner, Metropolitan State University of Denver; Gemma Hoeppner, Metropolitan State University of Denver; Larry Breeden, Metropolitan State University of Denver; Ayako Zrust, Metropolitan State University of Denver; Travis Rebhan, Metropolitan State University of Denver; Anayeli Ochoa, Metropolitan State University of Denver

Bayesian Uncertainty Estimation Under Complex Sampling - Speed: CC 502 - 3:00 PM - Matthew Williams, National Science Foundation; Terrance Savitsky, Bureau of Labor Statistics

Measuring Gentrification Over Time with the NYCHVS - Poster: CC Hall C - 4:00 PM - 4:45 PM Robert Montgomery, NORC; Quentin Brummet, NORC; Nola du Toit, NORC at the University of Chicago; Peter Herman, NORC at the University of Chicago; Edward Mulrow, NORC at the University of Chicago

A SHINY Markov Machine for Decision-Making in Major League Baseball - Part 1: CC105 - 2:45 PM and Part 2: CC Hall C - 4:00 PM to 4:45 PM Jason Osborne, North Carolina State University

Measuring Gentrification Over Time with the NYCHVS - CC 501 - 2:55 PM - Robert Montgomery, NORC; Quentin Brummet, NORC; Nola du Toit, NORC at the University of Chicago; Peter Herman, NORC at the University of Chicago; Edward Mulrow, NORC at the University of Chicago

A New Tidy Data Structure to Support Exploration and Modeling of Temporal Data - CC 301 - 3:25 PM - Earo Wang, Monash University; Dianne Cook, Monash University; Rob J Hyndman, Monash Univeristy

TensorFlow Versus H20, Predicting the SandP500 - CC 504 - 4:50 PM - Kenneth Davis

Model-Based Clustering Using Adjacent-Categories Logit Models via Finite Mixture Model - CC 504 - 5:05 PM - Lingyu Li, Victoria University of Wellington; Ivy Liu, Victoria University of Wellington; Richard Arnold, Victoria University of Wellington

The Estimable Luke Tierney – and Estimability in R - CC 501 - 5:20 PM - Russell V. Lenth, University of Iowa

Monday, July 29, 2019

Training Students Concurrently in Data Science and Team Science: Results and Lessons Learned from Multi-Institutional Interdisciplinary Student-Led Research Teams 2012-2018 -Poster: CC Hall C- 2:00 PM to 3:50 PM - Brent Ladd, Purdue University; Mark Ward, Purdue University

A Natural Language Processing Algorithm for Medication Extraction from Electronic Health Records Using the R Programming Language: MedExtractR - Pister: CC Hall C - 2:00 PM to 3:50 PM - Hannah L Weeks, Vanderbilt University; Cole Beck, Vanderbilt University Medical Center; Elizabeth McNeer, Vanderbilt University; Joshua C Denny, Vanderbilt University; Cosmin A Bejan, Vanderbilt University; Leena Choi, Vanderbilt University Medical Center

Conditional Probability and SQL for Data Science - Poster: CC Hall C - 10:30 AM to 12:20 PM - Eric Suess, CSU East Bay

R Markdown: a Software Ecosystem for Reproducible Publications - CC 107- 11:55 PM - Yihui Xie, RStudio, Inc.

Infusing Bayesian Strategies for Pharmaceutical Manufacturing and Development - CC 109- 12:05 PM - Bill Pikounis, Johnson & Johnson; Dwaine Banton, Janssen R&D; John Oleynick, Johnson & Johnson; Jyh-Ming Shoung, Janssen R&D

Tuesday, July 30, 2019

Controlling the False Discovery Proportion: a Simulation Study - Poster: CC Hall C - 10:30 AM to 12:20 PM HARLAN MCCAFFERY, University of Michigan; Chi Chang, Michigan State University

Give Your Statistician Colleague Iris Bulbs for Their House Warming! - CC 605 - 11:05 AM - Dianne Cook, Monash University

From Prediction Models to Shiny App: Creating a Tool for Contaminated Food Source Prediction in Salmonella and STEC Outbreaks - CC Hall C - 11:35 AM to 12:20 PM - Caroline Ledbetter, University of Colorado; Alice White, Colorado School of Public Health; Elaine Scallan Walter, Colorado School of Public Health; David Weitzenkamp, Colorado School of Public Health

Stats for Data Science - H-Centennial Ballroom G-H - Round Table: 12:30 PM to 1:50 PM - Daniel Kaplan, Macalester College

Experiences with Incorporating R into a Second-Level Biostatistics Course for MPH Students - CC Hall C - 2:00 PM to 2:45 PM - Christine Mauro, Columbia University; Nicholas Williams, Columbia University; Anjile An, Columbia University

From Prediction Models to Shiny App: Creating a Tool for Contaminated Food Source Prediction in Salmonella and STEC Outbreaks - CC 501 - 8:40 AM Caroline Ledbetter, University of Colorado; Alice White, Colorado School of Public Health; Elaine Scallan Walter, Colorado School of Public Health; David Weitzenkamp, Colorado School of Public Health

Tools for Evaluating Quality of State and Local Administrative Data - CC708 - 9:15AM - Zachary H Seeskin, NORC at the University of Chicago; Gabriel Ugarte, NORC at the University of Chicago; Rupa Datta, NORC at the University of Chicago

Wednesday, July 31, 2019

Ggvoronoi: Voronoi Tessellations in R - CC 105 - 11:20 AM -Thomas J Fisher, Miami University; Robert C Garrett, Miami University; Karsten Maurer, Miami University

Using R to Conduct Retrospective Analyzes of EHR and Imaging Data: a Case Study in MS - Poster: CC Hall C - 10:30 AM - 12:20 PM - Melissa Martin, University of Pennsylvania; Russell Shinohara, University of Pennsylvania

Generalized Causal Mediation and Path Analysis and Its R Package gmediation Talk: - CC 501 - 8:45 AM - and Poster: CC Hall C - 11:35 AM - 12:20 PM - Jang Ik Cho, Eli Lilly and Company; Jeffrey M Albert, Case Western Reserve University

Tidi_MIBI: a Tidy Pipeline for Microbiome Analysis and Visualization in R - Speed Talk: CC 501 - 10:15 AM and Poster: CC Hall C - 11:35 AM - 12:20 PM - Charlie Carpenter, University of Colorado-Biostatistics

Incorporating Spatial Statistics into Routine Analysis of Agricultural Field Trials - CC Hall C - 11:35 AM - 12:20 PM - Julia Piaskowski, University of Idaho; Chad Jackson, University of Idaho; Juliet Marshall, University of Idaho; William J Price, University of Idaho

Incorporating Spatial Statistics into Routine Analysis of Agricultural Field Trials - CC 501 - 10:05 AM - Julia Piaskowski, University of Idaho; Chad Jackson, University of Idaho; Juliet Marshall, University of Idaho; William J Price, University of Idaho

DemoR: Tools for Teaching and Presenting R Code - CC 302 - 10:35 AM - Kelly Bodwin, California Polytechnic State University; Hunter Glanz, California Polytechnic State University

Ghclass: An R Package for Managing Classes with GitHub - CC 302 - 10:50 AM - Colin Rundel, Duke University

Using and Building Shiny Apps for Teaching Introductory Biostatistics CC 504 - 11:05 AM - Adam Ciarleglio, The George Washington University

Using GitHub and RStudio to Facilitate Authentic Learning Experiences in a Regression Analysis Course - CC 302 - 11:05 AM - Maria Tackett, Duke University

A Generalized Additive Cox Model with L1-Penalty for Heart Failure Time-To-Event Outcomes and Comparison to Other Machine Learning Approaches - CC 712 - 3:20 PM - Matthias Kormaksson

Thursday, August 1, 2019

A Journey Teaching Applied Statistics for Health Sciences in an Asynchronous Team Based Learning Format Using Data Science Ideas - CC 110 - 8:50 AM - Ben Barnard

Noncentral Algorithm Assessments - CC 104 - 9:20 AM Jerry Lewis, Biogen Idec

Supplementary Code

In case you are wondering how I produced the plot above, here is the code which uses the cranly and dlstats packages to investigate CRAN.

library(tidyverse)
library(cranly)
library(dlstats)
# Get clean copy of CRAN
p_db <- tools::CRAN_package_db()
package_db <- clean_CRAN_db(p_db)
# Build package network
package_network <- build_network(package_db)

# Find Hastie packages
pkgs <- package_by(package_network, "Trevor Hastie")
# Find most downloaded Hastie packages
dstats <- cran_stats(pkgs)
topdown <- group_by(dstats,package) %>% 
           summarize(n=sum(downloads)) %>% 
           arrange(desc(n)) %>% filter(n > 100000)

# Plot the monthly downloads for Hastie's top 5 packages
shortlist <- select(topdown,package) %>% slice(1:5) 
toppkgs <- cran_stats(as.vector(shortlist$package))

ggplot(toppkgs, aes(end, downloads, group=package, color=package)) +
  geom_line() + geom_point(aes(shape=package)) + xlab("Monthly Downloads") + ggtitle("Trevor Hastie Packages")

Imagine your Data Before You Collect It

Mon, 01 Jul 2019 00:00:00 +0000

As data scientists, we are often presented with a dataset and are asked to use it to produce insights. We use R to wrangle, visualize, model, and produce tables and plots for sharing or publication. When we focus on the data in hand in this way, we don’t get to consider where the data came from. The sample size and the set of variables and their scales are fixed. Yet the procedures used to gather or generate them are hugely consequential for how we should analyze the data and also the quality of the insights we can ultimately deliver. Sampling procedures have implications for how the resulting data should be analyzed. For studies that seek to measure causal effects, it matters how some units come to be treated and others left untreated.

Because these processes are so important, we wanted to make a tool that would help data scientists and other researchers imagine their data before they collect it so that any changes to process can be made before it’s too late.

When the data is already collected, the tool allows you to imagine your data before you analyze it. When we make data wrangling and modeling decisions based on the results we find under each procedure, or using model fit statistics, we are vulnerable to the unconscious biases labeled the garden of forking paths or p-hacking that may lead us to select the analysis procedure that produces the best answer. We use the actual data because we don’t have a good substitute: data with the same structure and variables that we have collected.

This post introduces the fabricatr package, whose role in the DeclareDesign suite of packages is to simulate data structure and variables. See this RViews post introducing DeclareDesign and the philosophy behind it. fabricatr helps you to think about your data before you start analysis or even collection. What are the units? How are they structured? What measurements will you take? What are their ranges and how are they correlated? fabricatr can help you simulate mock data before you collect the real data, and test out different estimation strategies without worrying about biasing your inferences.

Imagining your data structure

Most simply, fabricatr will create a single-level data structure given a number of units.

library(fabricatr)
fabricate(N = 100, temp_fahrenheit = rnorm(N, mean = 80, sd = 20))

## Warning: `is_lang()` is deprecated as of rlang 0.2.0.
## Please use `is_call()` instead.
## This warning is displayed once per session.

## Warning: `lang_name()` is deprecated as of rlang 0.2.0.
## Please use `call_name()` instead.
## This warning is displayed once per session.

ID	temp_fahrenheit
001	56.6
002	46.3
003	90.5
004	75.1
005	85.1
006	102.8

Social science data is often hierarchical. For example, schools have classrooms that have students. fabricatr shines here with the add_level command. By default, new levels are nested within the levels above them.

library(fabricatr)
fabricate(
  # five schools
  school  = add_level(N = 5,
  n_classrooms = sample(10:15, N, replace = TRUE)),
  # 10 to 15 classrooms per school
  classroom  = add_level(N = n_classrooms),
  # 15 students per classroom
  student = add_level(N = 15)
  )

## Warning: `lang_modify()` is deprecated as of rlang 0.2.0.
## Please use `call_modify()` instead.
## This warning is displayed once per session.

school	n_classrooms	classroom	student
1	12	01	001
1	12	01	002
1	12	01	003
1	12	01	004
1	12	01	005
1	12	01	006

The real world often produces messy, overlapping hierarchies. For example, student data may be collected from middle school and also high school, in which case students are nested in two different schools, but those schools are not nested within each other. Here’s how to make such “cross-classified” data. The rho parameter governs how correlated primary_rank and secondary_rank should be.

dat <- 
fabricate(
  primary_schools = add_level(N = 5, primary_rank = 1:N),
  secondary_schools = add_level(N = 6, secondary_rank = 1:N, nest = FALSE),
  students = link_levels(N = 15, by = join(primary_rank, secondary_rank, rho = 0.9))
)

## `link_levels()` calls are faster if the `mvnfast` package is installed.

ggplot(dat, aes(primary_rank, secondary_rank)) + geom_point(position = position_jitter(width = 0.1, height = 0.1), alpha = 0.5) + theme_bw()

Similarly, you can create longitudinal data via cross_levels:

fabricate(
 students = add_level(N = 2),
 years = add_level(N = 20, year = 1981:2000, nest = FALSE),
 student_year = cross_levels(by = join(students, years))
)

students	years	year	student_year
1	01	1981	01
2	01	1981	02
1	02	1982	03
2	02	1982	04
1	03	1983	05
2	03	1983	06

Imagining your variables

R has lots of great tools for simulating variables. In some cases, though, common kinds of outcome variables are surprisingly tough to simulate. fabricatr collects a small number of functions to create variable types commonly used by social scientists, with simple syntax. We describe two examples here, but see our variable creation vignette for the rest.

Variables with intra-class correlation

With the data structure tools described above, you can construct data that has within-unit and between-unit variation, for example, variation within classrooms and variation across classrooms in test scores. However, many times you want to set the level of intra-class correlation (ICC) more precisely. We help with draw_normal_icc and draw_binary_icc.

dat <- 
  fabricate(
    N = 1000,
    clusters = sample(LETTERS, N, replace = TRUE),
    Y1 = draw_normal_icc(clusters = clusters, ICC = .2),
    Y2 = draw_binary_icc(clusters = clusters, ICC = .2)
  )
ICC::ICCbare(clusters, Y1, dat)

## [1] 0.09726701

ICC::ICCbare(clusters, Y2, dat)

## [1] 0.176036

Ordered outcomes

We provide a set of tools for discrete random variables (including ordered outcomes). We take a latent variable (i.e., test_ability) and transform it into an ordered variable (test_score).

dat <- 
fabricate(
  N = 100,
  test_ability = rnorm(N),
  test_score = draw_ordered(test_ability, breaks = c(-.5, 0, .5))
)
ggplot(dat, aes(test_ability, test_score)) + geom_point() + theme_bw()

fabricatr is compatible with almost any R variable creation function. We highlight other terrific R packages that help simulate social science-relevant variables in a vignette here.

Where to go next

This post is a high-level teaser for fabricatr’s functionality, but for a deeper introduction, check out the fabricatr getting started vignette. You can also download and print this cheatsheet.

You can install fabricatr from CRAN:

install.packages("fabricatr")
library(fabricatr)

Graeme Blair is an Assistant Professor of Political Science at UCLA.

Jasper Cooper is a Postdoctoral Research Associate at the Kahneman-Treisman Center for Behavioral Science and Public Policy at Princeton University.

Alexander Coppock is an Assistant Professor of Political Science at Yale University.

Macartan Humphreys is a Professor of Political Science at Columbia University and a Director of the research group “Institutions and Political Inequality” at the WZB Berlin Social Science Center.

Equal Size kmeans

Thu, 13 Jun 2019 00:00:00 +0000

We were recently presented with a problem where the decision maker wanted to understand how their data would naturally group together. The classic technique of k-means clustering was a natural choice; it’s well known, computationally efficient, and implemented in base R via the kmeans() function.

Our problem has a slight wrinkle: the decision maker wished to see the data grouped with (nearly) equal sizes. Now, a ‘true’ statistician would tell the client that the right thing to do from a theoretical perspective was to use native k-means results because some centers can simply have more nearby points than other centers. However, we are practitioners, and if the visualization provides additional information useful to the way people make decisions, we are not going to tell them they are wrong!

Approach

This is very similar to a mathematical optimization problem commonly faced by organizations like fire and police departments; specifically, ‘where trucks/patrol cars should be stationed to minimize response time’.

The general strategy is to decompose the hard problem into two easier sub-problems, to wit:

If we knew where the centroids were, determining group membership would be easy.
If we knew group membership, determining centroids would be trivial.

The key insight (and it really is all downhill from here) is to simply pretend that we have the solution to issue 1, and iterate between these two tasks until convergence is reached, that is - make a guess at where the centroids are, pick group members, then adjust the centroid based on group membership. This has the same ‘feel’ as mathematical induction, and we’ll name the steps accordingly.

Our example is based on mtcars a built-in R dataset, with three clusters of equal size.

First, some libraries:

library(magrittr); library(dplyr); library(ggplot2)

Basis Step

We have to start somewhere, and in this example, we will use an initial solution coming from the basic kmeans algorithm. Another approach would be to pick initial centroids at the ‘corners’ of the space, or to simply pick a few random data points as centroids:

data(mtcars)
k = 3
kdat = mtcars %>% select(c(mpg, wt))
kdat %>% kmeans(k) -> kclust

So far, so good. Now we’ll compute the distance matrix between each point and each centroid; this begins the

Assignment step

kdist = function(x1, y1, x2, y2){
  sqrt((x1-x2)^2 + (y1-y2)^2)
}
centers = kclust$centers

kdat %<>% 
  mutate(D1 = kdist(mpg, wt, centers[1,1], centers[1,2]))
kdat %<>% 
  mutate(D2 = kdist(mpg, wt, centers[2,1], centers[2,2]))
kdat %<>% 
  mutate(D3 = kdist(mpg, wt, centers[3,1], centers[3,2]))

From here, we assign clusters, which we do greedily, using a technique we like to call ‘little kids soccer’ - because this is the way kids generally pick teams - by going in order and picking the ‘best’ option available to them at the time. The algorithm interrogates each cluster in turn and picks the ‘closest’ unassigned member until each cluster is filled. There’s one minor wrinkle that needed to be worked out: the final round consists of the ones that are the ‘worst fits’ across all k clusters; in this case, the points choose the clusters.

kdat$assigned = 0
kdat$index = 1:nrow(kdat)
working = kdat
FirstRound = nrow(kdat) - (nrow(kdat) %% k)

for(i in 1:FirstRound){ 
  #cluster counts can be off by 1 due to uneven multiples of k. 
  j = if(i %% k == 0) k else (i %% k)
  itemloc = 
    working$index[which(working[,(paste0("D", j))] ==
    min(working[,(paste0("D",j))]))[1]]
  kdat$assigned[kdat$index == itemloc] = j
  working %<>% filter(!index == itemloc)
##The sorting hat says... GRYFFINDOR!!! 
}
for(i in 1:nrow(working)){
  #these leftover points get assigned to whoever's closest, without regard to k
  kdat$assigned[kdat$index ==
                  working$index[i]] = 
    which(working[i,3:5] == min(working[i, 3:5])) 
}

Next, we recalculate the centroids. It’s kind of smooth to simply use k-means with k = 1.

NewCenters <- kdat %>% filter(assigned == 1) %>% 
                        select(mpg, wt) %>%
                        kmeans(1) %$% centers

NewCenters %<>% rbind(kdat %>% 
                        filter(assigned == 2) %>%
                        select(mpg, wt) %>%
                        kmeans(1) %$% centers)

NewCenters %<>% rbind(kdat %>%
                        filter(assigned == 3) %>%
                        select(mpg, wt) %>%
                        kmeans(1) %$% centers)

NewCenters %<>% as.data.frame()

The result a single round is presented here:

kdat$assigned %<>% as.factor()
kdat %>% ggplot(aes(x = mpg, y = wt, color = assigned)) +
  theme_minimal() + geom_point() + 
  geom_point(data = NewCenters, aes(x = mpg, y = wt),
             color = "black", size = 4) + 
  geom_point(data = as.data.frame(centers), 
             aes(x = mpg, y = wt), color = "grey", size = 4)

Figure 1: Iterated k-means with one step

You will notice there is a single point assigned to Group 1 that is on the ‘frontier’ between Groups 2 and 3. This point appears to be misclassified, and the way to resolve this is to iterate the algorithm (see below).

You can see how coercing the size made the cluster centroids migrate - significantly in the case of the higher mpg cluster. Grey dots are the original centroid, black are the updated (equal size) centroid.

Functionalized and iterated

It is straightforward to ‘wrap’ the above code into a function (truncated here for brevity), which we call kMeanAdj. It and takes the incumbent centers, data, number of iterations, and $k$ as arguments. We may plot the result as follows:

x = kMeanAdj(NewCenters, kdat, iter = 3, k) 

x$Data$assigned %<>% as.factor()

x$Data %>% ggplot(aes(x = mpg, y = wt, color = assigned)) +
  theme_minimal() +  geom_point() +
  geom_point(data = x$centers, aes(x = mpg, y=wt),
             color = "black", size = 4)

Figure 2: Equal Size Clusters with 3 iterations

Iterating the algorithm over several steps ‘stabilizes’ both the groups and centers, yielding the desired characteristics.

Summary

Programming projects like this can sometimes feel like traveling by hot air balloon, in the sense that you don’t know which way you will be headed until you begin to travel. In this case, we did not initially anticipate the poor performance of our initial method in the case where k does not divide n. The only way to discover issues like this, of course, is to frequently prototype and test code. Overcoming this challenge added both to the fun and the reward of this exercise. Additionally, it showcases how the (robust) existing routines in the R language and popular packages may be rapidly combined with new ideas. This flexibility is what makes R a natural choice for both practitioners and theorists in Statistics and Operations Research.

Harrison Schramm, CAP, PStat, is a Senior Fellow at the Center for Strategic and Budgetary Assessments.

Carol DeZwarte, CAP, PMP, whose passion for advanced analytics predates it becoming a buzzword, is in Supply Chain Analytics at Wayfair.

reticulate, virtualenv, and Python in Linux

Mon, 10 Jun 2019 00:00:00 +0000

Roland Stevenson is a data scientist and consultant who may be reached on Linkedin.

reticulate is an R package that allows us to use Python modules from within RStudio. I recently found this functionality useful while trying to compare the results of different uplift models. Though I did have R’s uplift package producing Qini charts and metrics, I also wanted to see how things looked with Wayfair’s promising pylift package. Since pylift is only available in python, reticulate made it easy for me to quickly use pylift from within RStudio.

In the article below, I’ll show how I worked through the following circumstances:

Since pylift has only been tested on Python >= 3.6, and my system version of Python was 2.7, I needed to build and install Python 3.6 for myself, preferably within a self-contained virtual environment.
I wanted to install pylift in the virtual environment and set up reticulate in my R Project to work within that environment.
Finally, I needed to access pylift from an R Markdown document via the reticulate interface.

Setting up Python, virtualenv, and RStudio

Note: for consistency, I always use an instance created via r-studio-instance and a base project from r-studio-project.

Python 2.7 is the default on the systems I use (CentOS 6/7). Since I did not want to modify the system-level Python version, I installed Python 3.6.x at the user level in $HOME/opt and created a virtual environment using Python 3. I then activated the Python 3 environment and installed pylift. Finally, I ensured RStudio-Server 1.2 was installed, as it has advanced reticulate support like plotting graphs in line in R Markdown documents.

Below is a brief script that accomplishes the tasks in bash on CentOS 7:

cd ~
mkdir tmp
cd tmp
wget https://www.python.org/ftp/python/3.6.2/Python-3.6.2.tgz
tar -xzvf Python-3.6.2.tgz
cd Python-3.6.2
./configure --prefix=$HOME/opt/python-3.6.2 --enable-shared
make
make install
cd ~
export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:$HOME/opt/python-3.6.2/lib
virtualenv -p $HOME/opt/python-3.6.2/bin/python3 pylift
source pylift/bin/activate
cd pylift
git clone https://github.com/wayfair/pylift
cd pylift
pip install .
pip install -r requirements.txt
cd
wget https://s3.amazonaws.com/rstudio-ide-build/server/centos6/x86_64/rstudio-server-rhel-1.2.1335-x86_64.rpm
sudo yum install -y --nogpgcheck rstudio-server-rhel-1.2.1335-x86_64.rpm
sudo rstudio-server start

Some notes:

the --enable-shared option is required when building Python in order for reticulate to work
the LD_LIBRARY_PATH library also needs to be set prior to creating the virtual environment
we use virtualenv to create a virtual environment called “pylift” and then ensure that all Python packages are installed to that environment only (so as not to pollute any other environments we are working with)
we then clone the pylift source and install pylift along with all of its requirements via pip install -r requirements.txt
finally, we install the RStudio Server 1.2 Preview version in order to leverage its advanced reticulate features

Using Python from within RStudio via reticulate

Switching from bash to RStudio, we load reticulate and set it up to use the virtual environment we just created. Finally, and specific to pylift, we set matplotlib parameters so that we can plot directly in R.

library(reticulate)

Sys.setenv(LD_LIBRARY_PATH = paste0(Sys.getenv("HOME"),"/opt/python-3.6.2/lib"))
Sys.getenv("LD_LIBRARY_PATH")
use_virtualenv("/home/rstevenson/pylift", required=TRUE)
py_config()

# Currently this must be run in order for R-markdown plotting to work
matplotlib <- import("matplotlib")
matplotlib$use("Agg", force = TRUE)

Test that it works

The following replicates the first part of pylift tutorial: simulated data

import matplotlib.pyplot as plt
import numpy as np
t = np.arange(0.0, 2.0, 0.01)
s = 1 + np.sin(2*np.pi*t)
plt.plot(t,s)

When run, the above code chunk should display a sinusoidal graph below it.

import numpy as np, matplotlib as mpl, matplotlib.pyplot as plt, pandas as pd
from pylift import TransformedOutcome
from pylift.generate_data import dgp
# Generate some data.
df = dgp(N=10000, discrete_outcome=True)

# Specify your dataframe, treatment column, and outcome column.
up = TransformedOutcome(df, col_treatment='Treatment', col_outcome='Outcome', stratify=df['Treatment'])

# This function randomly shuffles your training data set and calculates net information value.
up.NIV()

The above Python chunk uses reticulate from within RStudio to interact with pylift in the context of a custom virtual environment, using a custom version of Python. This degree of customization and functionality should be useful to users who:

want to use a different Python version than they typically use while not affecting their typical setup by way of a virtual environment
want to install a Python module like pylift within a virtual environment so as not to affect any of their user- or system-level Python module installations
want to use reticulate from RStudio to access a custom virtual environment, Python version, and Python modules
wants to be able to delete the virtual environment and R-Project and have everything go back to the way it was
wants to be able to reproduce or share the environment exactly so that the workflow can be shared with others

Introducing DeclareDesign, a Platform for Research Design

Tue, 04 Jun 2019 00:00:00 +0000

Graeme Blair is an Assistant Professor of Political Science at UCLA.

Jasper Cooper is a Postdoctoral Research Associate at the Kahneman-Treisman Center for Behavioral Science and Public Policy at Princeton University.

Alexander Coppock is an Assistant Professor of Political Science at Yale University.

Macartan Humphreys is a Professor of Political Science at Columbia University and a Director of the research group “Institutions and Political Inequality” at the WZB Berlin Social Science Center.

Research design consists of a set of choices about what research procedures to use. For example, how many subjects to interview, which questions to ask them, and what to do in the analysis phase with the data that results from these choices. We do not have good tools for assessing whether the chosen procedures are good ones. DeclareDesign is an R package for learning about, implementing, and communicating research procedures, from data collection to data analysis.

Today, most data scientists take raw data as the starting point for analysis, and consider how best to import, tidy, transform, visualize, model, and communicate their results. Yet often during this process, we learn that our data can only provide limited answers to our questions. Perhaps the sample size is too small, we do not have enough observations from men and women to estimate gender differences, or we did not collect data on units’ geographic location, so we cannot merge to administrative data. We rely on rules of thumb or expert opinion to navigate the myriad research design choices we face. We select analysis strategies tailored to the data that we have before us rather than the data that could have arisen. In doing so, we risk introducing biases. Our practices can often lead to bad inferences and bad science.

To learn whether a research procedure is a good one, we need to know what the results would have been had the data turned out differently. With that knowledge, we can assess our data analysis procedures in terms of whether they will yield answers that are unbiased and precise. DeclareDesign helps us simulate different data sets that could result from our data collection procedures. With these simulated data, we can ask the question: is our set of procedures likely to yield unbiased, low-variance answers to our research questions? We can assess not only whether we should select difference-in-means or regression as our estimator, but also whether it would have been better to assign half of subjects to treatment in our A/B test, or more than half.

We’ve built a set of linked tools that help with each step of the research design process. In this post, we’ll talk about using DeclareDesign to declare and diagnose the properties of a full set of procedures. We’ll also introduce DesignLibrary, which helps you quickly get started learning about your research design for a set of common designs. In the coming weeks, we’ll talk about tools for simulating data (fabricatr), sampling cases and assigning A/B tests (randomizr), and estimating effects (estimatr).

library(DeclareDesign)
library(tidyverse)

A grammar of research designs

DeclareDesign implements a set of ideas laid out in our paper, forthcoming at the American Political Science Review. We think of any research design as having four parts:

A Model of the world.
An Inquiry about that model.
A Data strategy according to which data will be collected or brought into existence.
An Answer strategy according to which the data will be summarized to generate a guess about the inquiry.

Writing designs down is hard, and DeclareDesign can make that process simpler, more explicit, and reproducible.

Declaration Steps

In DeclareDesign, you declare each component of a research design using one of the declare_* functions.

`declare_*` function	MIDA	Description
`declare_population()`	M	Pre-treatment covariates
`declare_potential_outcomes()`	M	Relationships between treatments, covariates, and outcomes
`declare_estimand()`	I	Quantity of interest
`declare_sampling()`	D	(Possibly random) sampling procedure
`declare_assignment()`	D	(Possibly random) assignment procedure
`declare_reveal()`	D	Function that maps potential outcomes to realized outcomes
`declare_estimator()`	A	Estimation (and hypothesis testing, if applicable) procedure

Each declare_* function is a “function factory”, which means that each of these functions themselves returns a function. Each function takes data as an argument, and returns either data or statistics. Many R users are not used to having functions return functions, but this makes simulation very easy, and is not so odd once you get used to it. In the example below, we define the pop function using declare_population(). Each time we call the resulting pop function, we get a slightly different data set.

pop <- declare_population(N = 3, X = rnorm(N))
pop()

  ID         X
1  1 -2.120337
2  2 -1.156013
3  3  1.703992

pop()

  ID          X
1  1 -0.6172369
2  2  0.3183334
3  3 -1.3762445

Chaining steps together

A research design can be thought of as a series of steps. In DeclareDesign, we chain steps together using the + operator, which may be familiar to ggplot2 users. Each step takes the data generated in the step before it, and either returns statistics or passes that data on to the next step, having added new variables or changed the shape of the data. In the next example, we declare a workhorse research strategy used in many scientific fields, the two-arm randomized trial:

design <-
  
  # M -- Model
  declare_population(N = 100, X = rpois(N, 4), noise = rnorm(N)) +
  declare_potential_outcomes(Y ~ 0.2 * Z + 0.5 * X + noise) +
  
  # I -- Inquiry
  declare_estimand(ATE = mean(Y_Z_1 - Y_Z_0)) +
  
  # D -- Data Strategy
  declare_sampling(n = 50) +
  declare_assignment(m = 25) +
  declare_reveal(Y, Z) +
  
  # A -- Answer Strategy
  declare_estimator(Y ~ Z, model = difference_in_means, estimand = "ATE", label = "DIM")

Some points to note about this declaration:

design is a “design object,” which can then be used to learn all kinds of things about the design. We’ll turn to some common post-declaration functions in a moment.
“Potential outcomes” is a concept from the causal inference literature. Potential outcomes are the outcomes that each unit would express depending on the counterfactual level of some treatment. The revealed outcome is the observed outcome: treated subjects reveal their treated outcome and untreated subjects reveal their untreated outcome. The potential outcomes model of causality is deep. For users who are new to thinking in terms of potential outcomes, we promise it will get easier with time. The Wikipedia article is OK, but we would suggest Chapter 2 of this book if it’s available to you.
In the code above, the estimand and estimator steps are explicitly linked together – we define the average treatment effect (ATE) in terms of potential outcomes, and then in the estimation step, we tell the estimator that it is shooting at the ATE. This means that a design “knows” what question each estimator is trying to answer.
These declaration functions depend on the other packages in the DeclareDesign set of packages, which includes fabricatr, randomizr, and estimatr. We’ll introduce each of these packages in upcoming posts. The population and potential outcomes steps use fabricatr, the sampling and assignment use randomizr, and the estimator steps use estimatr.

What can you do with a design object?

The first thing you might want to do with a design object is draw_data. Take a look:

dat <- draw_data(design)
head(dat)

   ID X       noise    Y_Z_0    Y_Z_1 S_inclusion_prob Z Z_cond_prob
1 001 3 -0.09946134 1.400539 1.600539              0.5 1         0.5
2 002 3  0.42156668 1.921567 2.121567              0.5 1         0.5
3 003 3  0.24064949 1.740649 1.940649              0.5 0         0.5
4 005 5 -1.29990991 1.200090 1.400090              0.5 1         0.5
5 007 4  1.38503254 3.385033 3.585033              0.5 1         0.5
6 008 3  0.16181031 1.661810 1.861810              0.5 1         0.5
         Y
1 1.600539
2 2.121567
3 1.740649
4 1.400090
5 3.585033
6 1.861810

You can quickly generate simulated data that (if you did your declaration right!) is the same size and shape as the data your study will generate, once it’s run. Imagining your data ex ante gives you the chance to think about logistical, practical, theoretical, or analytic concerns that might otherwise be put off until far later in the design process.

Next up, you can take a look a the estimands and estimates produced by one run of your design:

draw_estimands(design)

  estimand_label estimand
1            ATE      0.2

draw_estimates(design)

  estimator_label term  estimate std.error statistic   p.value   conf.low
1             DIM    Z 0.1302799 0.3997006 0.3259437 0.7459163 -0.6738506
  conf.high      df outcome estimand_label
1 0.9344104 46.9193       Y            ATE

These functions give you a chance to ensure that your estimands and estimators make sense and are returning what you expect them to return. If a 0.2 average treatment effect is implausible in your research setting, change it!

You can also add steps to a design. Here, we’re adding another estimator that also shoots at the ATE, but this time adjusts for a pre-treatment covariate, X:

design <- design + declare_estimator(Y ~ Z + X, model = lm_robust, estimand = "ATE", label = "OLS")

Simulating designs

DeclareDesign has two functions for conducting simulations: simulate_design and diagnose_design. If your answer strategy returns estimates, $p$-values, and standard errors, and it is linked to an estimand, diagnose_design can tell you a lot about your design: its power, its coverage probability, its “true” standard error (the standard deviation of the estimates across repeat samples), the average standard error it returns, its bias, its root mean square error, the probability you get the sign of the estimand wrong, its false positive rate, and more. If you just want to simulate the design, simulate_design will return a data set in which each row is an estimator-estimand pair. Since we have two estimators, each run of the design produces two rows.

simulations <- simulate_design(design, sims = 500)
head(simulations)

  design_label sim_ID estimand_label estimand estimator_label term
1       design      1            ATE      0.2             DIM    Z
2       design      1            ATE      0.2             OLS    Z
3       design      2            ATE      0.2             DIM    Z
4       design      2            ATE      0.2             OLS    Z
5       design      3            ATE      0.2             DIM    Z
6       design      3            ATE      0.2             OLS    Z
     estimate std.error  statistic    p.value     conf.low conf.high
1 -0.73149295 0.4594131 -1.5922335 0.11789917 -1.655212062 0.1922262
2 -0.04367092 0.3435135 -0.1271301 0.89937977 -0.734730962 0.6473891
3  0.23917794 0.4454914  0.5368856 0.59384801 -0.656742583 1.1350985
4  0.62821514 0.3105686  2.0227904 0.04880466  0.003431732 1.2529986
5  0.27936681 0.3567281  0.7831365 0.43758754 -0.438821047 0.9975547
6  0.04149547 0.2894608  0.1433544 0.88662317 -0.540824504 0.6238154
        df outcome
1 47.98565       Y
2 47.00000       Y
3 47.58893       Y
4 47.00000       Y
5 45.69013       Y
6 47.00000       Y

The simulations data can then be used to summarize the design using ggplot2 and dplyr. For example, simulation is useful to understand the distribution of effect estimates; are they centered on the estimand? Is the distribution wide or narrow? Are there outliers that might indicate estimation issues?

summary_df <-
  simulations %>%
  group_by(estimator_label) %>%
  summarize(`Mean Estimate` = mean(estimate),
            `Mean Estimand` = mean(estimand)) %>%
  gather(key, value, `Mean Estimand`, `Mean Estimate`)

ggplot(simulations, aes(estimate)) +
  geom_histogram(bins = 30) +
  geom_vline(data = summary_df, aes(xintercept = value, color = key)) +
  facet_wrap( ~ estimator_label) + 
  theme_bw() +
  theme(strip.background = element_blank(),
        legend.position = "bottom")

Getting started quickly with DesignLibrary

You can get started by declaring a design in a single line of code with DesignLibrary.

library(DesignLibrary)
two_arm_design <- two_arm_designer(N = 1000)

DesignLibrary contains 15 common research designs that can be declared in this simple way. In each case, a set of function arguments are set up to define the core inputs to the design, such as sample size. For example, we can declare a pretest-posttest design in which data is collected before (pre) and after (post) a treatment is assigned. We define the sample size (N), the average treatment effect (ate), and the correlation in outcomes between the pre and post periods (rho):

prepost_design <- pretest_posttest_designer(N = 1000, ate = 5, rho = 0.25)

Using DeclareDesign in your data science workflow

Since the four helper packages can be used to simulate data, sample units, randomize treatments, and analyze data, we see at least seven ways you can get value out of using DeclareDesign in your everyday data-science workflow.

Simulate mock data (draw_data()).
Assess the properties of your design before you run it (diagnose_design()).
Front-load design decisions before data is collected (+ to declare it).
Compare the properties of several possible designs (compare_designs()).
Write a preanalysis plan or registered report (summary(design) to get started).
Describe your design in code in a paper or report (print_code(design)).
Learn about properties of someone else’s design (diagnose_design()).

Finally, you may find the DeclareDesign cheatsheet hosted by RStudio helpful.

Virtual Morel Foraging with R

Mon, 13 May 2019 00:00:00 +0000

Bryan Lewis is a mathematician, R developer and mushroom forager.

Morchella Americana by Bryan W. Lewis, see https://ohiomushroomsociety.wordpress.com/

It’s that time of year again, when people in the Midwestern US go nuts for morel mushrooms. Although fairly common in Western Pennsylvania, Ohio, Indiana, Illinois, Wisconsin, and, especially, Michigan¹, they can still be tricky to find due to the vagaries of weather and mysteries of morel reproduction.

Morels are indeed delicious mushrooms, but I really think a big part of their appeal is their elusive nature. It’s so exciting when you finally find some–or even one!–after hours and hours of hiking in the woods.

For all of you not fortunate to be in the Midwest in the spring, here is a not-so-serious note on virtual morel foraging. But really, this note explores ways you can mine image data from the internet using a cornucopia of data science software tools orchestrated by R.

Typical forays begin with a slow, deliberate hunt for mushrooms in the forest. Morels, like many mushrooms, may form complex symbiotic relationships with plants and trees, so seek out tree species that they like (elms, tulip tress, apple trees, and some others). Upon finding a mushroom, look around and closely observe its habitat, maybe photograph it, and perhaps remove the fruiting body for closer inspection and analysis, and maybe for eating. The mushroom you pick is kind of like a fruit - it is the spore-distributing body of a much larger organism that lives below the ground. When picking, get in the habit of carefully examining a portion of the mushroom below the ground because sometimes that includes important identifying characteristics. Later, use field guide keys and expert advice to identify the mushroom, maybe even examining spores under a microscope. Sometimes we might even send a portion of clean tissue in for DNA analysis (see, for instance, https://mycomap.com/projects). Then, finally, for choice edible mushrooms like morels, once you are sure of your bounty, cook and eat them!

Edible morels are actually pretty easy to identify in the field. There are a few poisinous mushrooms that kind of look like morels, but on closer inspection not really. Chief among them are the false morels or Gyromitra, some of which we will find below in our virtual foray!

Our virtual foray proceeds similarly as follows:

Virtually hunt for images of morel mushrooms on the internet.
Inspect each image for GPS location data.
Map the results!

Now, I know what you’re saying: most mushroom hunters - especially morel hunters - are secretive about their locations, and will strip GPS information from their pictures. And we will see that is exactly the case: only about 1% of the pictures we find include GPS data. But there are lots of pictures on the internet, so eventually even that 1% can be interesting to look at…

The Hunt

Our virtual mushroom foray begins as any real-world foray does, looking around for mushrooms! But instead of a forest, we’ll use the internet. In particular, let’s ask popular search engines to search for images of morels, and then inspect those images for GPS coordinates.

But how can we ask internet search engines to return image information directly to R? Unfortunately, the main image search engines like Google and Bing today rely on interactive JavaScript operation, precluding simple use of, say, R’s excellent curl package. Fortunately, there exists a tool for web browser automation called Selenium and, of course, a corresponding R interface package called RSelenium. RSelenium essentially allows R to use a web browser like a human, including clicking on buttons, etc. Using web browser automation is not ideal because we rely on fragile front-end web page/JavaScript interfaces that can change at any time instead of something well-organized like HTML, but we seem to be forced into this approach by the modern internet.

Our hunt requires that the Google Chrome browser is installed on your system², and of course you’ll need R! You’ll need at least the following R packages installed. If you don’t have them, install them from CRAN:

library(wdman)
library(RSelenium)
library(jsonlite)
library(leaflet)
library(parallel)
library(htmltools)

Let’s define two functions, one to search Microsoft Bing images, and another to search Google images. Each function takes an RSelenium browser and a search term as input, and returns a list of search result URLs.

bing = function(wb, search_term)
{
  url = sprintf("https://www.bing.com/images/search?q=%s&FORM=HDRSC2", search_term)
  wb$navigate(url)
  invisible(replicate(200, wb$executeScript("window.scrollBy(0, 10000)"))) # infinite scroll down to load more results...
  x = wb$findElements(using="class name", value="btn_seemore") # more results...
  if(length(x) > 0) x[[1]]$click()
  invisible(replicate(200, wb$executeScript("window.scrollBy(0, 10000)")))
  Map(function(x)
  {
    y = x$getElementAttribute("innerHTML")
    y = gsub(".* m=\\\"", "", y)
    y = gsub("\\\".*", "", y)
    y = gsub("&quot;", "\\\"", y)
    y = gsub("&amp;", "&", y)
    fromJSON(y)[c("purl", "murl")]
  }, wb$findElements(using = "class name", value = "imgpt"))
}
google = function(wb, search_term)
{
  url = sprintf("https://www.google.com/search?q=%s&source=lnms&tbm=isch", search_term)
  wb$navigate(url)
  invisible(replicate(400, wb$executeScript("window.scrollBy(0, 10000)")))
  Map(function(x)
  {
    ans = fromJSON(x$getElementAttribute("innerHTML")[[1]])[c("isu", "ou")]
    names(ans) = c("purl", "murl") # comply with Bing (cf.)
    ans
  }, wb$findElements(using = "xpath", value = '//div[contains(@class,"rg_meta")]'))
}

These functions emulate what a human would do by scrolling down to get more image results (both web sites us an ‘infinite scroll’ paradigm), and, in the Bing case, clicking a button. This is what I meant above when I said that this approach is fragile and not optimal - it’s quite possible that some small change in either search engine in the future will cause the above functions to not work.

Let’s finally run our virtual mushroom hunt! We set up a Google Chrome-based RSelenium web browser interface, and run some searches:

eCaps = list(chromeOptions = list( args = c('--headless', '--disable-gpu', '--window-size=1280,800')))
cr = chrome(port = 4444L)
wb = remoteDriver(browserName = "chrome", port = 4444L, extraCapabilities = eCaps)
wb$open()
foray = c(google(wb, "morels"),
          google(wb, "indiana morel"),
          google(wb, "michigan morel"),
          google(wb, "oregon morel"),
          bing(wb, "morels"),
          bing(wb, "morel mushrooms"),
          bing(wb, "michigan morels"))
wb$close()

Feel free to try out different search terms. The result is a big list of possible image URLs that just might contain pictures of morels with their coordinates. This particular foray result above, run in late April, 2019, returned about 2000 results.

Identification

Next, we scan every result for GPS coordinates using the nifty external command-line tool called exiftool and the venerable curl program. If you don’t have those tools, you’ll need to install them on your computer. They are available for most major operating systems. On Debian flavors of GNU/Linux like Ubuntu it’s really easy, just run:

sudo apt-get install exiftool curl

Once the curl and exiftool programs are installed, we can invoke them for each image URL result from R to efficiently scan through part of the image for GPS coordinates using these functions:

#' Extract exif image data
#' @param url HTTP image URL
#' @return vector of exif character data or NA
exif = function(url)
{
  tryCatch({
    cmd = sprintf("curl --max-time 5 --connect-timeout 2 -s \"%s\" | exiftool -fast2 -", url)
    system(cmd, intern=TRUE)
  }, error = function(e) NA)
}
#' Convert an exif GPS character string into decimal latitude and longitude coordinates
#' @param x an exif GPS string
#' @return a named numeric vector of lat/lon coordinates or NA
decimal_degrees = function(x)
{
  s = strsplit(strsplit(x, ":")[[1]][2], ",")[[1]]
  ans = Map(function(y)
            ifelse(y[4] == "S" || y[4] == "W", -1, 1) *
              (as.integer(y[1]) + as.numeric(y[2])/60 + as.numeric(y[3])/3600),
          strsplit(gsub(" +", " ", gsub("^ +", "", gsub("deg|'|\"", " ", s))), " "))
  names(ans) = c("lat", "lon")
  ans
}
#' Evaluate a picture and return GPS info if available
#' @param url image URL
#' @return a list with pic, date, month, label, lat, lon entries or NULL
forage = function(url)
{
  ex = exif(url)
  i = grep("GPS Position", ex)
  if(length(i) == 0) return(NULL)
  pos = decimal_degrees(ex[i])
  date = tryCatch(strsplit(ex[grep("Create Date", ex)], ": ")[[1]][2], error=function(e) NA)
  month = ifelse(is.na(date), NA, as.numeric(strftime(strptime(date, "%Y:%m:%d %H:%M:%S"), format="%m")))
  label = paste(date, "  source: ", url)
  list(pic=paste0("<img width=200 height=200 src='", url, "'/>"),
       date=date, month=month, label=label,
       lat=pos$lat, lon=pos$lon)
}

Now, there might be many search results to evaluate. Each evaluation is not very compute intensive. And the results are independent of each other. So why not run this evaluation step in parallel? R makes this easy to do, although with some differences between operating systems. The following works well on Linux or Mac systems. It will also run fine on Windows systems, but sequentially.

options(mc.cores = detectCores() + 2) # overload cpu a bit
print(system.time({
bounty = do.call(function(...) rbind.data.frame(..., stringsAsFactors=FALSE),
  mcMap(function(x)
  {
    forage(x$murl)
  }, foray)
)
}))
# Omit zero-ed out lat/lon coordinates
bounty = bounty[round(bounty$lat) != 0 & round(bounty$lon != 0), ]

The above R code runs through every image result, returning those containing GPS coordinates as observations in a data frame with image URL, date, month, label, and decimal latitude and longitude variables.

Starting with over 2,000 image results, I ended up with about 20 pictures with GPS coordinates. Morels are as elusive in the virtual world as the real one!

Finally, let’s plot each result colored by the month of the image on a map using the superb R leaflet package. You can click on each point to see its picture.

colors = c(January="#555555", February="#ffff00", March="#000000",
           April="#0000ff", May="#00aa00", June="#ff9900", July="#00ffff",
           August="#ff00ff", September="#55aa11", October="#aa9944",
           November="#77ffaa", December="#ccaa99")
clr = as.vector(colors[bounty$month])
map = addTiles(leaflet(width="100%"))
map = addCircleMarkers(map, data=bounty, lng=~lon, lat=~lat, fillOpacity=0.6,
         stroke=FALSE, fillColor=clr, label=~label, popup=~pic)
i = sort(unique(bounty$month))
map = addLegend(map, position="bottomright", colors=colors[i],
        labels=names(colors)[i], title="Month", opacity=1)
map

Click on the points to see their associated pictures…

Closing Notes

You may have noticed that not all of the pictures are of morels. Indeed, there are several foray group photos, a picture of a deer, and even a few pictures of (poisonous) false morel mushrooms.

What could be done about that? Well, if you are truly geeky and somewhat bored - OK very bored - you could train a deep neural network to identify morels, and then feed the above image results into that. Me, I prefer wasting my time wandering actual woods looking for interesting mushrooms… Even if there are no morels to find, wandering in the woods is almost always fun. It’s also worth pointing out that the false morel and morel habitats are often quite similar, so those false morel sightings spotted in the map above might actually be interesting places to forage.

To be sure, morels are found in many other places across the US and the world. But I mostly forage in the Midwest and know it best.↩
I tried first to use the phantomjs driver from R’s wdman package that doesn’t require an external web browser. But I could only get that to work for searching Microsoft Bing image results, not Google image search. Help or advice on getting phantomjs to work would be appreciated!↩

Reproducible Environments

Mon, 22 Apr 2019 00:00:00 +0000

Great data science work should be reproducible. The ability to repeat experiments is part of the foundation for all science, and reproducible work is also critical for business applications. Team collaboration, project validation, and sustainable products presuppose the ability to reproduce work over time.

In my opinion, mastering just a handful of important tools will make reproducible work in R much easier for data scientists. R users should be familiar with version control, RStudio projects, and literate programming through R Markdown. Once these tools are mastered, the major remaining challenge is creating a reproducible environment.

An environment consists of all the dependencies required to enable your code to run correctly. This includes R itself, R packages, and system dependencies. As with many programming languages, it can be challenging to manage reproducible R environments. Common issues include:

Code that used to run no longer runs, even though the code has not changed.
Being afraid to upgrade or install a new package, because it might break your code or someone else’s.
Typing install.packages in your environment doesn’t do anything, or doesn’t do the right thing.

These challenges can be addressed through a careful combination of tools and strategies. This post describes two use cases for reproducible environments:

Safely upgrading packages
Collaborating on a team

The sections below each cover a strategy to address the use case, and the necessary tools to implement each strategy. Additional use cases, strategies, and tools are presented at https://environments.rstudio.com. This website is a work in progress, but we look forward to your feedback.

Safely Upgrading Packages

Upgrading packages can be a risky affair. It is not difficult to find serious R users who have been in a situation where upgrading a package had unintended consequences. For example, the upgrade may have broken parts of their current code, or upgrading a package for one project accidentally broke the code in another project. A strategy for safely upgrading packages consists of three steps:

Isolate a project
Record the current dependencies
Upgrade packages

The first step in this strategy ensures one project’s packages and upgrades won’t interfere with any other projects. Isolating projects is accomplished by creating per-project libraries. A tool that makes this easy is the new renv package. Inside of your R project, simply use:

# inside the project directory
renv::init()

The second step is to record the current dependencies. This step is critical because it creates a safety net. If the package upgrade goes poorly, you’ll be able to revert the changes and return to the record of the working state. Again, the renv package makes this process easy.

# record the current dependencies in a file called renv.lock
renv::snapshot()

# commit the lockfile alongside your code in version control
# and use this function to view the history of your lockfile
renv::history()

# if an upgrade goes astray, revert the lockfile
renv::revert(commit = "abc123")

# and restore the previous environment
renv::restore()

With an isolated project and a safety net in place, you can now proceed to upgrade or add new packages, while remaining certain the current functional environment is still reproducible. The pak package can be used to install and upgrade packages in an interactive environment:

# upgrade packages quickly and safely
pak::pkg_install("ggplot2")

The safety net provided by the renv package relies on access to older versions of R packages. For public packages, CRAN provides these older versions in the CRAN archive. Organizations can use tools like RStudio Package Manager to make multiple versions of private packages available. The “snapshot and restore” approach can also be used to promote content to production. In fact, this approach is exactly how RStudio Connect and shinyapps.io deploy thousands of R applications to production each day!

Team Collaboration

A common challenge on teams is sharing and running code. One strategy that administrators and R users can adopt to facilitate collaboration is shared baselines. The basics of the strategy are simple:

Administrators setup a common environment for R users by installing RStudio Server.
On the server, administrators install multiple versions of R.
Each version of R is tied to a frozen repository using a Rprofile.site file.

By using a frozen repository, either administrators or users can install packages while still being sure that everyone will get the same set of packages. A frozen repository also ensures that adding new packages won’t upgrade other shared packages as a side-effect. New packages and upgrades are offered to users over time through the addition of new versions of R.

Frozen repositories can be created by manually cloning CRAN, accessing a service like MRAN, or utilizing a supported product like RStudio Package Manager.

Adaptable Strategies

The prior sections presented specific strategies for creating reproducible environments in two common cases. The same strategy may not be appropriate for every organization, R user, or situation. If you’re a student reporting an error to your professor, capturing your sessionInfo() may be all you need. In contrast, a statistician working on a clinical trial will need a robust framework for recreating their environment. Reproducibility is not binary!

To help pick between strategies, we’ve developed a strategy map. By answering two questions, you can quickly identify where your team falls on this map and identify the nearest successful strategy. The two questions are represented on the x and y-axis of the map:

Do I have any restrictions on what packages can be used?
Who is responsible for managing installed packages?

For more information on picking and using these strategies, please visit https://environments.rstudio.com. By adopting a strategy for reproducible environments, R users, administrators, and teams can solve a number of important challenges. Ultimately, reproducible work adds credibility, creating a solid foundation for research, business applications, and production systems. We are excited to be working on tools to make reproducible work in R easy and fun. We look forward to your feedback, community discussions, and future posts.