This morning I added a new feature to the blog posts: an R script that automatically generates and applies tags, allowing users to find old posts on (potentially, roughly) similar topics. Because of some difficulties setting up a chronological archive, I was worried old posts would be lost down the memory hole. This new feature should help prevent that.

My previous blogs had tags; you can see some of the remains of Tumblr’s tagging system at the bottom of many migrated posts. But the tags had to be added manually. This added a step to the publication process, and made me worried about inconsistent tags. What if I recently adopted a new tag that applied to some old posts? I’d have to scroll back through the archive to find them, which was both very tedious and prone to human error.

The new script solves these problems by automatically selecting tags and applying them across all posts at the same time. After writing a post, all I need to do is run a one-line command in the terminal. As a side effect, the tags will change, highlighting different arrays of topics as I add posts to the blog.

In the rest of this post, I want to explain the logic behind the tag selection process by walking through the code of the autotagging script. The post also includes a discussion of a metric I use for “high-information” terms, which I call .

The script uses two R packages: tidyverse, a suite of packages of data wrangling; and tidytext, a text mining package designed for use with the tidyverse. After loading these packages, the rest of the following chunk loads the content of every post on the blog into a single dataframe structure.

library(tidyverse)
## ── Attaching packages ────────────────────────────────── tidyverse 1.2.1 ──
## ✔ ggplot2 3.0.0     ✔ purrr   0.2.5
## ✔ tibble  1.4.2     ✔ dplyr   0.7.6
## ✔ tidyr   0.8.1     ✔ stringr 1.3.1
## ✔ readr   1.1.1     ✔ forcats 0.3.0
## ── Conflicts ───────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag()    masks stats::lag()
library(tidytext)

post_folder = '../_posts/'  # Just `_posts/` in the actual script
post_files = list.files(post_folder) %>%
    str_c(post_folder, .)

dataf = tibble(path = post_files) %>%
    mutate(post_id = row_number()) %>%
    rowwise() %>%
    mutate(raw_text = read_file(path)) %>%
    ungroup()

str(dataf)
## Classes 'tbl_df', 'tbl' and 'data.frame':	42 obs. of  3 variables:
##  $ path    : chr  "../_posts/2012-03-14-friedersdorf-the-sex-friendly-case-against-free-birth-control-part-i.md" "../_posts/2012-03-14-friedersdorf-the-sex-friendly-case-against-free-birth-control-part-ii.md" "../_posts/2012-04-21-the-agroecological-argument-for-eating-meat.md" "../_posts/2012-05-23-fetishism-and-innate-differences.md" ...
##  $ post_id : int  1 2 3 4 5 6 7 8 9 10 ...
##  $ raw_text: chr  "---\nlayout: post\ntitle: \"Friedersdorf: The Sex-Friendly Case Against Free Birth Control, part I\"\ntags: [bi"| __truncated__ "---\nlayout: post\ntitle: \"Friedersdorf: The Sex-Friendly Case Against Free Birth Control, part II\"\ntags: [b"| __truncated__ "---\nlayout: post\ntitle: \"The Agroecological Argument for Eating Meat\"\ntags: [animal,data,eating,meat,stude"| __truncated__ "---\nlayout: post\ntitle: \"Fetishism and Innate Differences\"\n---\n\n\n(Going through my folder of notes and "| __truncated__ ...

Next we use tidytext to parse the text of each post into individual terms or tokens.

tokens_df = unnest_tokens(dataf, token, raw_text)
tokens_df
## # A tibble: 57,530 x 3
##    path                                                  post_id token    
##    <chr>                                                   <int> <chr>    
##  1 ../_posts/2012-03-14-friedersdorf-the-sex-friendly-c…       1 layout   
##  2 ../_posts/2012-03-14-friedersdorf-the-sex-friendly-c…       1 post     
##  3 ../_posts/2012-03-14-friedersdorf-the-sex-friendly-c…       1 title    
##  4 ../_posts/2012-03-14-friedersdorf-the-sex-friendly-c…       1 frieders…
##  5 ../_posts/2012-03-14-friedersdorf-the-sex-friendly-c…       1 the      
##  6 ../_posts/2012-03-14-friedersdorf-the-sex-friendly-c…       1 sex      
##  7 ../_posts/2012-03-14-friedersdorf-the-sex-friendly-c…       1 friendly 
##  8 ../_posts/2012-03-14-friedersdorf-the-sex-friendly-c…       1 case     
##  9 ../_posts/2012-03-14-friedersdorf-the-sex-friendly-c…       1 against  
## 10 ../_posts/2012-03-14-friedersdorf-the-sex-friendly-c…       1 free     
## # ... with 57,520 more rows

To develop tags, we want to identify “highly meaningful terms” across the cropus of parsed blog posts. In text mining, a measure called TF-IDF is frequently used for this task. TF-IDF is calculated for each term-document combination. The TF-IDF of term in document is

  • the number of times occurs in (the term frequency), divided by
  • the (log) number of documents in which occurs at least once (the document frequency).

Intuitively, TF-IDF tries to identify words that are common in a particular document (high term frequency) but also only occur in a few documents (low document frequency). In English, words like “the” and “and” tend to have high term frequencies but also very high document frequencies, so their TF-IDF scores tend to be low. Misspelled words like “mipelled” have low document frequency, but also low term frequency, so again their TF-IDF scores tend to be low. Terms with a high TF-IDF should, the thought goes, be distinctive to a given document.

The problem with TF-IDF is that it’s difficult to make this intuitive account more precise. It can also be difficult to interpret, because the units are occurrences per log documents. Is 3 occurrences per log documents high or low? That depends on things like the number and length of documents in the corpus. In addition, TF-IDF is calculated for term-document pairs, not for individual terms. A word will have the same IDF value across the entire corpus, but will have different TF values as it occurs a different number of times across different documents.

For these reasons, in my text mining work I’ve switched to an information-based measure. To understand this one, note first that we have blog posts. Suppose we draw one of these blog posts at random. The probability of drawing any given post is . The entropy of this probability distribution tells us the number of binary bits (0s and 1s) we need to give a unique ID for each blog post.

In the case of my blog before writing this post, the entropy is .

Now suppose that, after drawing a post at random, we draw a single word from the post at random (without peeking at exactly which post we’ve drawn). The probability that we’ve drawn any given post is now . The information gain of the word is the difference between up above and the entropy of this new distribution :

We can think of as the number of bits of information, relative to the full post ID, that we’ve gained from knowing the word. corresponds to inverse document frequency (dividing by the document frequency) in TF-IDF: it tells us how unique that word is to each document. A term like “the” will tend to have near 0 (it doesn’t give us any new information); a more distinctive term like “virtue” (only some of my posts are about virtue ethics) will have a relatively high , perhaps 4 or even 5 (it tells us a lot about which particular posts we might have).

To calculate an overall score for each term, we multiply by the (log) total times the term occurs across the entire corpus. Suppose “virtue” occurs 100 times across all blog posts, and has an information gain of 3 bits. Then we have . The units here are orders of magnitude-bits. An increase of 1 of these units means that a word occurs as frequently or provides 1 added bit of information. I call the resulting measure (not writing the log for readability).

The following block calculates for the distribution , as baseline, then calculates the information gain and .

baseline = log2(nrow(dataf))

info_df = tokens_df %>%
    count(token, post_id) %>%
    group_by(token) %>%
    arrange(token) %>%
    mutate(p = n / sum(n), 
           H_term = -p*log2(p)) %>%
    summarize(n = sum(n), 
              H = sum(H_term), 
              delta_H = baseline - H,
              ndH = log10(n)*delta_H)

str(info_df)
## Classes 'tbl_df', 'tbl' and 'data.frame':	6887 obs. of  5 variables:
##  $ token  : chr  "__squarespace_cacheversion" "_data" "_jmp0_" "_market" ...
##  $ n      : int  1 1 1 1 1 1 24 1 1 1 ...
##  $ H      : num  0 0 0 0 0 ...
##  $ delta_H: num  5.39 5.39 5.39 5.39 5.39 ...
##  $ ndH    : num  0 0 0 0 0 ...

This next block isn’t included in the script; it generates a plot showing the distribution of scores for a sample of 500 terms. Each point represents a single term; the x-axis is the (log) number of total occurrences across the corpus, color indicates the information gain , and the y-axis is the overall score.

set.seed(2018-10-25)
info_df %>%
    sample_n(500) %>%
    ggplot(aes(log10(n), color = delta_H, 
                                ndH, label = token)) +
    geom_text() +
    theme_minimal()

Informally, the score does a good job of identifying characteristic words for different kinds of posts, such as “data,” “developing,” and “feminism.”

The overall shape of the plot also shows how balances information gain and frequency. Some terms like “yourself” and “x’s” have a high information gain (more than 4 bits — remember that the maximum is about 5.4), but occur fewer than 10 times and so have a low . Extremely common terms (many more than 100 occurrences across a set of 42 posts) have very little information. The highest-scoring term, “market,” has both high information (4.3) and occurs 71 times.

All together, the score picks out a set of high-information, moderate-frequency terms in the middle of the plot, much like TF-IDF. In contrast with TF-IDF, it uses information theory for theoretical support and produces a relatively interpretable value.

The last step in the script is to select a vocabulary of terms to use as tags, identify them in the posts, and write the tags into the Markdown files.

To select the vocabulary, we simply take the terms with the highest scores. Because the blog is fairly small, it’s not unreasonable to take as many terms as there are blog posts (42 tags 42 tags). As the blog grows, I’ll probably want to trim this down to set a hard cap. Alternatively, I might want to select a number of tags such that each post has at least 1 tag and no post has more than, say, 5 tags. For now, though, I’ll just use the simpler logic of the top 42 terms.

vocab =  top_n(info_df, nrow(dataf), ndH)

Then we’ll filter the list of tokens down to these tags, collapse the tags into a list, and convert the list into the string that will go in the header of the Markdown files.

tags_df = tokens_df %>%
    filter(token %in% vocab$token) %>%
    count(path, post_id, token) %>%
    group_by(path, post_id) %>%
    summarize(tags = list(token)) %>%
    mutate(tags_str = map_chr(tags, str_c, collapse = ','), 
           tags_str = str_c('tags: [', tags_str, ']')) %>%
    ungroup()
str(tags_df, max.level = 1)
## Classes 'tbl_df', 'tbl' and 'data.frame':	40 obs. of  4 variables:
##  $ path    : chr  "../_posts/2012-03-14-friedersdorf-the-sex-friendly-case-against-free-birth-control-part-i.md" "../_posts/2012-03-14-friedersdorf-the-sex-friendly-case-against-free-birth-control-part-ii.md" "../_posts/2012-04-21-the-agroecological-argument-for-eating-meat.md" "../_posts/2012-07-23-two-conceptions-of-human-nature.md" ...
##  $ post_id : int  1 2 3 5 6 7 8 9 10 11 ...
##  $ tags    :List of 40
##  $ tags_str: chr  "tags: [birth]" "tags: [birth,medicine,preventative]" "tags: [animal,data,meat,students,vegetarianism]" "tags: [market,rights]" ...

Finally we’ll write these files back to disk. Each post has a header section that looks something like this:

---
title: "Post title goes here"
style: post
tags: [monkey,zoo]
---

We’ll separate this header section from the body by searching for the ---, add the tags, then put everything back together and write to disk. (Except we won’t actually write the results out to disk here.)

right_join(dataf, tags_df) %>%
    separate(raw_text, into = c('null', 'header', 'body'), 
             sep = '---', extra = 'merge') %>% 
    ## Remove old tags
    mutate(header = str_replace(header, 
                                'tags: \\[[^\\]]+\\]', 
                                '')) %>% 
    mutate(combined = str_c('---', 
                            header, 
                            tags_str, '\n',
                            '---', 
                            body)) %>%
    # pull(combined) %>% {cat(.[[1]])}
    rowwise() #%>%
## Joining, by = c("path", "post_id")
## Source: local data frame [40 x 8]
## Groups: <by row>
## 
## # A tibble: 40 x 8
##    path      post_id null  header    body      tags  tags_str   combined  
##  * <chr>       <int> <chr> <chr>     <chr>     <lis> <chr>      <chr>     
##  1 ../_post…       1 ""    "\nlayou… "\n\n\n[… <chr… tags: [bi… "---\nlay…
##  2 ../_post…       2 ""    "\nlayou… "\n\n\n[… <chr… tags: [bi… "---\nlay…
##  3 ../_post…       3 ""    "\nlayou… "\n\n\nT… <chr… tags: [an… "---\nlay…
##  4 ../_post…       5 ""    "\nlayou… "\n\n\nI… <chr… tags: [ma… "---\nlay…
##  5 ../_post…       6 ""    "\nlayou… "\n\n\nI… <chr… tags: [ci… "---\nlay…
##  6 ../_post…       7 ""    "\nlayou… "\n\n\nI… <chr… tags: [an… "---\nlay…
##  7 ../_post…       8 ""    "\nlayou… "\n\n\nI… <chr… tags: [an… "---\nlay…
##  8 ../_post…       9 ""    "\nlayou… "\n\n\nT… <chr… tags: [bi… "---\nlay…
##  9 ../_post…      10 ""    "\nlayou… "\n\n\n\… <chr… tags: [an… "---\nlay…
## 10 ../_post…      11 ""    "\nlayou… "\n\n\n(… <chr… tags: [de… "---\nlay…
## # ... with 30 more rows
    #mutate(written = map2(combined, path, write_lines))