Weird Data Science

Bayes vs. the Invaders (Redivivus)

moth — Sat, 15 Nov 2025 10:50:27 +0000

Straying still further from whatever dubious graces it once presumed, academia’s luciferous descent into murky realms of huddled speculation continues unabated. Relocated, reconstituted, in ever-fading cycles, the Oxford Internet Institute at the University of Oxford once again saw fit to deprive its students of the peace and comfort of banal rationality through this fourth annual Halloween Lecture.

In the absence of fresh insight, this year’s lecture revisits the chilling implications of humanity’s contact with inexplicable aerial and marine phenomena, drawing from the faintest whispers of the ante-historical record through to the shimmering echoes of statistical reasoning. Through what means do visitors from beyond the void encroach on our night-time skies? What subtle deceptions underpin their visible geometries? What values lie behind their peculiar interests in certain uncomfortably-favoured regions?

Despite all safeguards, and in the face of numerous barely-perceptible currents opposing such efforts, this event was captured, stored, and released into a world still cruelly unprepared to face its findings.

More details, and the underlying code, for these findings can be found–for those unwary enough to look–in the series of entries beginning here.

Click here to view the video on YouTube.

Oxford Internet Institute Halloween Lecture
Bayes vs. the Invaders (Redivivus): A Bayesian Analysis of 70 Years of UFO Sightings
Prof. Joss Wright
Oxford. October 2025

The searing heat of summer retreats, cools, fades, surrendering its vitality to the flickering uncertainties of autumn. Nights draw close, like dimly-remembered friends clustering in our dreams. The spring leaves abandon their verdant dance, as they age, wither, and drift into a russet swirl of skeletal, wind-stirred fragments.

The dying seasons return, dragging with them time-hallowed fears and uneasy rumours, pooling around these darkly dreaming spires in a mire of primal superstition. The agonizingly brittle certainties of the modern enlightenment, our desperate faith in the gossamer fabrics of scientific progress, falter in the face of primal terrors that lurk implacably in the gloom.

In these darkening days, as faith in our treasured understanding dims, it is yet again time to turn our faces fully to the darkness. Halloween, slouching inexorably towards our minds, impels us as scholars to gather our methods, our theories, our data, our knowledge; and glean what light we can from the primordial glimmers of the unknown.

Unidentifiable aerial and marine phenomena. Impossible lights in the sky. Patterns of visitation and terror. Insidious influences from the hadal voids between the stars. Who–what–swoop and glide through the ink-black nights of our world, probing and testing our structures, our societies, our minds? From barely remembered history, to early reports of impossible objects, to blurrily evidenced documentation, data concerning flying arcane observations has grown and twisted, along with our capacity to lay them bare, to subject them to analysis, and to interrogate their secrets.

In this year’s OII Halloween Lecture, we will tremblingly revisit a Bayesian analysis of seventy years of UFO sightings, drawn from a dataset collected by the National UFO Reporting Center (NUFORC). Scepticism, fear, doubt, and most accepted standards of statistical rigour, will be cast aside in our unyielding and disquieting pursuit of an uncompromised truth.

2025-bayes_vs_invaders-redivivus

Numbers of the Beast: Sasquatch Distribution Modelling

moth — Mon, 21 Jul 2025 18:09:01 +0000

Dredged from the stygian depths of last year’s waning: a cruelly belated artefact of academia’s primordial descent. For a third time, the Oxford Internet Institute at the University of Oxford—scarcely willing, but falteringly unable to reflect on its own ill-fated decisions—chose to risk the sanity and statistical intuition of its students against the numerically unstable nightmares writhing beneath the tattered fabric of our waking world.

This third OII Halloween Lecture sinks bodily into the tortured mass of data concerning cryptozoological sightings in North America. Drawing on over a century of shadow-haunted sightings documenting the curiously repellant presence of the North America Sasquatch, or Bigfoot, we aim to identify the factors associated with its presence, delineate the confounding presence of other dread manifestations, and cast our minds globally for a faded glimpse of its remote and scarcely-conceived brethren.

In what can only generously be considered an act of gross negligence, this lecture was stored, at great risk to both its author and its audience, digitally. Technology has, once again, brought us closer than we might care to dread to secrets that we were never intended to taste.

A sharper, more visceral presentation of the baroque thinking underpinning these materials will follow, in an ever-spiralling series of posts on this site. Until then, however, incautious travellers may solemnly consider the below.

Click here to view the video on YouTube.

OII Halloween Lecture
Sasquatch Distribution Modelling: Investigating patterns of Bigfoot sightings in North America.
Prof. Joss Wright
Oxford. October 2024

The nights grow ever closer. Streetlights flicker, shrouded in the mists, striving to pierce the gloom. The warm certainties of summer give way to the cold, dark ambiguities of autumn. Rumour, myth, and legend rise, primeval, from the shadowed recesses of our collective consciousness, undermining our faith in the fragile congruities that structure our lives.

As summer surrenders to the inexorable tread of autumn, our resolve falters against the unknown horrors residing in the tenebrous peripheries of the world. As scientists, as scholars, our duty is to cling resolutely to our methods and our ideals in the face of encroaching darkness. Our tools may seem fragile in the face of the seething irrationality of the night, but we are called to peer, however tremulously, wherever our inquiries may lead us.

Lights streak across the sky. Stories are woven of twisted faces in the darkness, half-glimpsed creatures in ancient forests, strange encounters in the wilderness. From the earliest stirrings of humanity, to the patterns of complex arcana that silently control our lives today, folklore and legend have long reported phenomena that rebel against mundane description or understanding. As our technologies evolve, and our ability to collate, scrutinise, and manipulate data spiral beyond all restraint, we are ever more capable, if not indeed obliged, to bring the lens of science to bear on these harrowing mysteries.

To embrace this dark season, you are invited to the annual Oxford Internet Institute Halloween Lecture.

This year we will pursue one of the world’s most notorious cryptozoological phenomena, investigating over a century of data regarding sightings of the Sasquatch, or Bigfoot, of North America. In which regions are these cryptic precursors of humanity most commonly observed? What factors, whether environmental or physical, create habitats most suitable for the Sasquatch to thrive, hidden from the encroaching pressures of humanity? Where, were we bold enough to look, might we seek other populations of these elusive creatures?

In this lecture we will examine some of the history surrounding sightings of Bigfoot, and related cryptids. We will impetuously apply statistical methods to derive underlying patterns from reported sightings, and heedlessly strive to uncover their meaning and implications. What can we learn from the accumulated data about the habits of cryptic species living on the fringes of our world? Is the beast, as ever, closer to us than we wish to believe?

sasquatch_distribution_modelling

Readings from the Book

moth — Sun, 28 Jan 2024 16:27:02 +0000

Once again, the Oxford Internet Institute at the University of Oxford — through madness, or through omission brought on by horrified incredulity — saw fit to expose its students to the nightmarish patterns that descend, fractal-like, endlessly below the surface of mundane reality.

This second OII Halloween Lecture drew on the twisted meanderings we travellers have taken through the cryptic verbiage of the Voynich Manuscript. We aim to establish the dread authenticity of the text, by rousing its very statistical bones from the inscrutable fasciae of its pages. Walking a tightrope between careful statistical exploration and ever-burgeoning insanity, we further explore the structures that arise from the text, separating the untranslated knowledge in the book into coherent bodies for future study.

In yet another, almost criminially negligent, oversight, the OII’s 2024 Halloween Lecture was captured, frozen in space and time, for the detriment and despair of the unexpectant world.

Click here to view the video on YouTube.

For those not driven to blissful negation by the tortured ramblings of the above, the underlying materials for the talk are presented, with neither hope nor tremor, here.

illuminating_the_illuminated

Whisperings in the Academy

moth — Sun, 20 Nov 2022 13:12:43 +0000

The noblest of human endeavours is to enlighten the uninitiated consciousness; to bare its awareness before the endless and terrifying vistas that lie beyond darkness and ignorance.

In pursuit of such necessarily painful revelations the Oxford Internet Insitute at the University of Oxford — the unwitting host on which the investigations here parasitise — recently hosted an inaugural Halloween lecture. This oration drew on several years of dark explorations chronicled in this blog, to inculcuate into a new generation of unprepared and curious minds the horror and necessity of subjecting our reality to the insidious power of statistical science. Through what seems a dangerously careless oversight, this brief glimpse of truth was recorded and made available for posterity.

Click here to view the video on YouTube.

For the terminally inquisitive, the archival materials on which this work was drawn are presented here.

bayes_vs_invaders

Illuminating the Illuminated – Part Four: Tempora Mutantur | Changepoint Analysis of the Voynich Manuscript

moth — Fri, 21 Feb 2020 10:31:38 +0000

Our past interrogation of the Voynich Manuscript has deconstructed its esoteric symbols into a form more suitable for our ends, subjected its statistical properties to comparison with more mundane texts, and unearthed its hidden internal structures via the esoteric process of topic modelling. In this final post, we will build on the structures revealed in earlier posts to ask how, if at all, the Voynich Manuscript’s textual properties shift within the text itself. Are there significant discontinuities in the writing, indicating a separation of the manuscript into meaningful sections? Or is the text merely a homogenous mass more suggestive of a rote, mechanical, generative procedure?

To address this question we will delve once more into the arcana of machine learning, and draw out the technique of changepoint analysis. This procedure aims to identify one or more points in a series of observations at which the underlying process that generates the data has somehow altered.

Once more, we will operate within the warm embrace of Bayesian statistics and exploit the Stan modelling language as our means to cast light into the darkness¹.

On Shifting Sands

Changepoint analysis is an active field of endeavour, with deep subtleties in its application. For the purposes of this analysis we will focus on the comparatively simple problem of identifying a single changepoint amongst the teeming mass of the Voynich Manuscript’s strangely compelling glyphs.

Statistical analysis of changepoints has been applied to a number of historical texts. To provide a first, tantalising glimpse into a world characterised by authorship analysis and the dark arts of adversarial stylometry, we begin by reproducing the work of Riba and Ginebra in ascertaining the existence of a shift in authorship in the 15th century Catalan chivalric romance Tirant lo Blanc.

Briefly, Tirant lo Blanc was written by Joanot Martorel, a Valencian knight, whose untimely death left the manuscript unfinished. The work was completed and published by Martí Joan de Galba. The specific nature of his contributions have, however, been the subject of some debate: did he substantially compose parts of the text, or simply arrange and edit the work?

Riba and Ginebra proposed, in 2005, to identify any stylistic change in the work through a Bayesian analysis of the frequency of word lengths in the document. Their approach, built on a tradition of such analyses in the stylometry literature, relies on the fact that differing authors, even when attempting to mimic the style of another, unconsciously make different word choices. Most importantly, the relative frequency of shorter context free words is likely to differ between authors.

From a certain analytical perspective, each word in a sequence of text can be represented merely by its length, as in the analyses of our earlier posts. Taking this view to a probabilistic extreme, a text, therefore, can be considered as a sequence of draws from a categorical distribution of word lengths. We may consider the length of each word as resulting from rolls of some abstract, biased die with a number of sides equal to the number of possible word lengths in the prose. The full text, therefore, is itself a multinomial distribution in which the number of categories matches the possible lengths of words observed in the document, and the number of trials is the number of words in the text. The stylistic differences between authors, therefore, is known to be revealed most strongly in the relative frequency of the shorter words.

Having descended thus far, and with dark suspicions of an authorship change disrupting the contiguity of Martorel’s opus, we hypothesise that the entire volume may best be described by not one, but by two multinomial distributions over short word lengths: one for the earlier text of the original author, with a second describing the later contributions of his posthumous collaborator. The point of division between these distributions is the changepoint.

Winds of Change

To drag this concept from its abstract formulation to a tangible realisation, we turn to the Stan probabilistic programming language, The models here draw heavily on the Stan user’s guide changepoint section, which lays out the concepts underlying these approaches with horrifying clarity.

Perhaps the most unusual aspect of implementing this model is due to Stan’s inability to sample discrete parameters; in this case the location of the changepoint. As such the model must conceal a latent discrete parameter cunningly hidden in its construction. This may then be marginalised out to reveal the probability of each value of the latent parameter. The model we construct here, therefore, will provide us not simply with a point estimate of the most likely changepoint, but a set of probabilities for each possible changepoint.

As cryptically hinted above, our model of the Voynich text abstracts its prose to counts of word lengths found on each folio of the manuscript, resulting in a multinomial distribution of word lengths. For the changepoint, we hypothesise that there are not one, but two multinomials with different parameters falling on either side of some changepoint. Our goal is to identify the pivotal folio at which this underlying shift most likely occurs.

Representing this more formally, in the style used for generative Bayesian models, we can write the distribution of word lengths, $\Omega$, in terms of its hyperparameters as:

$$\begin{eqnarray}\
\Omega &\sim& \mathbf{Multinomial}( t < c~?~\theta_e : \theta_l )\\
\theta_e &\sim& \mathbf{Dirichlet}(\alpha)\\
\theta_l &\sim& \mathbf{Dirichlet}(\alpha)\\
c &\sim& \mathbf{Uniform}(0, 1)
\end{eqnarray}$$

The most crucial element for isolating the changepoint is the conditional operator in the first line. We treat the frequency of words of different lengths on a given folio as one point in a sequence, indexed by the value $t$. The conditional statement encodes that observed word lengths prior to some unknown point $t = c$ are drawn from a multinomial with one vector of parameters, $\theta_e$; from that folio onwards, word lengths are drawn according to a second multinomial with parameter vector $\theta_l$. When appropriately constructed, fitting the model produces a posterior distribution across the various possible $\theta_e$ and $\theta_l$ parameters for all possible changepoints. The folio at which the posterior probability of $c$ is highest is our best estimate of the changepoint, and is accompanied by estimates of $\theta_e$ and $\theta_l$ around that changepoint.

As mentioned above, we marginalise the discrete changepoint parameter, $c$, rather than sampling it directly. A full example of the concept, applied to a Poisson distribution, is given by the Stan Users’ Guide changepoint section. This key step moves the parameter $c$ from the full joint probability function of the model, resulting in a likelihood of word lengths according to the parameters $\theta_e$ and $\theta_l$, which can be calculated in Stan by summing over this likelihood for all possible values of $c$².

Reproducing, with only slight adaptations, the original Poisson example, our full joint probability would be:

$$p(\theta_e, \theta_l, c, \Omega) =
p(\theta_e)p(\theta_l)p(c)p(\Omega|\theta_e,\theta_l,c)$$

Marginalising out $c$, this can be represented as:

$$\begin{eqnarray}
p(\Omega|\theta_e, \theta_l) &=& \sum_{c=1}^Tp(c,\Omega|c,\theta_e,\theta_l)\\
&=& \sum_{c=1}^Tp(c)p(\Omega|c,\theta_e,\theta_l)
\end{eqnarray}$$

The result is that our Stan model can be constructed by sampling across values of $\theta_e$ and $\theta_l$ for all possible values of $c$. Due to the requirement to sum across all possible values of the discrete paramete, however, this subterfuge of marginalisation is restricted in general to bounded discrete parameters.

We can distill the above into a Stan model as given below.

Multinomial changepoint model

multinomial_changepoint.stan
[code language=”c”]

data {

int num_obs; // Number of observations (rows/pages) in data.
int num_cats; // Number of categories in data.
int y[num_obs, num_cats]; // Matrix of observations.

vector[num_cats] alpha; // Dirichlet prior values.

}

transformed data {

// Uniform prior across all time points for changepoint.
real log_unif;
log_unif = -log(num_obs);

}

parameters {

// Two sets of parameters.
// One (early) before changepoint, one (late) for after.
simplex[num_cats] theta_e;
simplex[num_cats] theta_l;

}

transformed parameters {

// // This code shows a slower, but easier to understand updating of log posterior via summation.
// vector[num_obs] lp;
// lp = rep_vector(log_unif, num_obs);
// for (s in 1:num_obs)
// for (t in 1:num_obs)
// lp[s] = lp[s] + multinomial_lpmf(y[t,] | t < s ? theta_e : theta_l);

// This approach relies on dynamic programming to reduce runtime from quadratic to linear in num_obs.
// See
vector[num_obs] log_p;
{
vector[num_obs + 1] log_p_e;
vector[num_obs + 1] log_p_l;

log_p_e[1] = 0;
log_p_l[1] = 0;

for( i in 1:num_obs ) {
log_p_e[i + 1] = log_p_e[i] + multinomial_lpmf(y[i,] | theta_e );
log_p_l[i + 1] = log_p_l[i] + multinomial_lpmf(y[i,] | theta_l );
}

log_p =
rep_vector( -log(num_obs) + log_p_l[num_obs + 1], num_obs) +
head(log_p_e, num_obs) – head(log_p_l, num_obs);
}
}

model {

// Priors
theta_e ~ dirichlet( alpha );
theta_l ~ dirichlet( alpha );

target += log_sum_exp( log_p );

}

generated quantities {

simplex[num_obs] changepoint_simplex; // Simplex of locations for changepoint.

// Convert the log posterior to a simplex.
changepoint_simplex = softmax( log_p );

}

[/code]

To launch the model in gentler waters, we apply it to Martorel and de Galba’s Tirant lo Blanc to discover where, if at all, de Galba’s major contributions to the text begin, and see the extent to which our Stan rendering reproduces the results of Riba and Ginebra’s analysis. As in their work we will focus only on those words with length shorter than 5 letters, where the key stylistic difference between authors makes itself apparent.

We place a relative uninformative Dirichlet prior on the multinomial $\theta_e$ and $\theta_l$ parameters, with the vector of $\alpha$ values set to one. This results in a uniform distribution across all possible simplexes. Note that this does not push the multinomial towards a uniform simplex, but instead that all possible simplexes are equally likely. $\alpha \ge 1$ produces increasingly uniform simplexes; $0 \le \alpha \le 1$ produces simplexes in which the probability mass is more likely to be concentrated in some given element.

With the resulting data and model in unison, we can see the results of this analytic process.

Tirant lo Blanc Changepoint

" data-image-caption="

Tirant lo Blanc Changepoint

Tirant lo Blanc Changepoint | (PDF Version)

Our multinomial automaton suggests a location for a significant stylistic changepoint in Tirant lo Blanc with the main concentration of probability mass around chapter 374. Perhaps unsurprisingly, but pleasingly, this is in close agreement with the earlier analysis of Riba and Ginebra, who placed their estimates between chapters 371 and 382.

Tirant lo Blanc analysis code

[code language=”r”]

library( tidyverse )
library( tidyselect )
library( magrittr )

library( rstan )

library( tidytext )

# Load Tirant data
message( "Reading raw Tirant data…" )
tirant_tbl <-
read_csv( "data/tirant_raw.csv", col_names=FALSE ) %>%
rename( chapter = X1, text = X2 ) %>%
mutate( page = as.numeric( rownames(.) ) )

# Tokenize
tirant_words <-
tirant_tbl %>%
unnest_tokens( word, text )

# Pivot the data wider to be presented to Stan as a matrix of multinomial samples.
tirant_lengths <-
tirant_words %>%
mutate( word_length = str_length( word ) ) %>%
mutate( word_length = ifelse( word_length > 9, 10, word_length )) %>%
group_by( page, word_length ) %>%
summarise( count = n( )) %>%
pivot_wider( names_from = word_length, values_from = count ) %>%
ungroup %>%
select( -c(page,"5","6","7","8","9","10") ) %>%
select(sort(peek_vars())) %>%
replace( is.na(.), 0 )

if( not( file.exists( "work/multinomial_changepoint_tirant_fit.rds" ) ) ) {

message( "Fitting multinomial model.")
tirant_multinom_fit <-
stan( "multinomial_changepoint.stan",
data=list(
num_obs=487,
num_cats=4,
y = as.matrix( tirant_lengths ),
alpha = rep( 1, 4 ) ),
iter=16000,
control=list(
adapt_delta=0.98,
max_treedepth=15 ) )

saveRDS( tirant_multinom_fit, "work/multinomial_changepoint_tirant_fit.rds" )

} else {
message( "Loading saved multinomial model.")
tirant_multinom_fit <- readRDS( "work/multinomial_changepoint_tirant_fit.rds" )
}

# Plot the calculated changepoint probabilities.
# (‘changepoint_simplex’).
mean_changepoint_prob <-
extract( tirant_multinom_fit )$changepoint_simplex %>%
as_tibble( .name_repair="unique" ) %>%
summarise_all( mean ) %>%
pivot_longer( everything() ) %>%
rowid_to_column()

# Save values for plotting
saveRDS( mean_changepoint_prob, file="work/mean_changepoint_prob_tirant.rds" )

[/code]

Tirant lo Blanc data file

Tirant lo Blanc formatted raw text data.

Tirant lo Blanc changepoint plot code

multinomial_changepoint_tirant_plot.r
[code language=”r”]

library( tidyverse )
library( magrittr )

library( ggthemes )
library( showtext )

library( grimoire ) #

# Fonts
font_add( "main_font", "resources/fonts/alchemy/1651 Alchemy/1651AlchemyNormal.otf")
font_add( "bold_font", "resources/fonts/alchemy/1651 Alchemy/1651AlchemyNormal.otf")

showtext_auto()

mean_changepoint_prob <-
readRDS( "work/mean_changepoint_prob_tirant.rds" )

changepoint_plot <-
ggplot( mean_changepoint_prob ) +
geom_col( aes( x=rowid, y=value ), fill=weird_colours["blood"] ) +
labs( x="Chapter", y="Probability of Changepoint" ) +
theme(
panel.background = element_rect(fill = "transparent", colour = "transparent"),
plot.background = element_rect(fill = "transparent", colour = "transparent"),
plot.title = element_text( family="bold_font", colour=weird_colours["ink"], size=22 ),
plot.subtitle = element_text( family="bold_font", colour=weird_colours["ink"], size=12 ),
axis.text = element_text( family="bold_font", colour=weird_colours["ink"], size=12 ),
axis.title.x = element_text( family="bold_font", colour=weird_colours["ink"], size=12 ),
axis.title.y = element_text( family="bold_font", angle=90, colour=weird_colours["ink"], size=12 ),
axis.line = element_line( colour=weird_colours["ink"] ),
panel.grid.major.x = element_blank(),
panel.grid.major.y = element_blank(),
panel.grid.minor.x = element_blank(),
panel.grid.minor.y = element_blank()
)

# grimoire::decorate_plot() from
parchment_plot <-
decorate_plot(
title="Tirant lo Blanc Chapter Changepoint Probability",
subtitle="http://www.weirddatascience.net | @WeirdDataSci",
plot=changepoint_plot,
bg_image="resources/img/parchment.jpg",
footer="Data: http://einesdellengua.com/tirantloweb/tirantloblanch.html" )

save_plot("output/multinomial_changepoint_tirant_plot.pdf",
parchment_plot,
base_width = 16,
base_height = 9,
base_aspect_ratio = 1.78 )

[/code]

Nos et mutamur in illis

The changepoint model realises the dark imaginings of our predecessors. What horrors might it reveal when applied to the Voynich Manuscript? Following the logic of the above analysis, we will focus initially on the shorter words in the Voynich corpus.

To improve model fit we will place a little more information in the prior, setting the $\alpha$ values for the Dirichlet prior to 0.6 to push the multinomial towards more concentrated probabilities. This reflects the gamma distribution of word length frequencies discussed in our earlier analysis. We also combine all single- and two-letter Voynich terms into a single category due to the small number of words falling into these categories³.

The model can now reveal where, if at all, a likely fracture resides in the textual assemblage of the Voynich Manuscript.

Voynich Manuscript changepoint plot

" data-image-caption="

Voynich Manuscript changepoint plot

Voynich Manuscript Changepoint | (PDF Version)

Voynich Manuscript word length analysis code

multinomial_changepoint_voynich.r
[code language=”r”]

library( tidyverse )
library( tidyselect )
library( magrittr )

library( rstan )

library( tidytext )

# Load Voynich data
message( "Reading raw Voynich data…" )
voynich_tbl <-
read_csv( "data/voynich_raw.csv", col_names=FALSE ) %>%
rename( folio = X1, text = X2 )

# Tokenize
voynich_words <-
voynich_tbl %>%
unnest_tokens( word, text )

# Calculate the lengths of words
voynich_pure_lengths <-
voynich_words %>%
transmute( word_length = str_length( word ) )

voynich_pure_lengths$count <- 1

# Pivot the data wider to be presented to Stan as a matrix of multinomial samples.
voynich_lengths <-
voynich_words %>%
mutate( word_length = str_length( word ) ) %>%
mutate( word_length = ifelse( word_length > 8, 9, word_length )) %>%
mutate( word_length = ifelse( word_length < 2, 2, word_length )) %>%
group_by( folio, word_length ) %>%
summarise( count = n( )) %>%
pivot_wider( names_from = word_length, values_from = count ) %>%
ungroup %>%
select( -c("folio", "5", "6", "7", "8", "9" )) %>%
select(sort(peek_vars())) %>%
replace( is.na(.), 0 )

if( not( file.exists( "work/multinomial_changepoint_voynich_fit.rds" ) ) ) {

message( "Fitting multinomial model.")
voynich_seed <- 1912
num_cats <- ncol( voynich_lengths )
voynich_multinomial_fit <-
stan( "multinomial_changepoint.stan",
data=list(
num_obs=226,
num_cats=num_cats,
y = as.matrix( voynich_lengths ),
alpha = rep( 0.6, num_cats ) ),
chains=4,
iter=8000, seed=voynich_seed,
control = list( adapt_delta=0.99,
max_treedepth=12 ) )

saveRDS( voynich_multinomial_fit, "work/multinomial_changepoint_voynich_fit.rds" )

} else {
message( "Loading saved multinomial model.")
voynich_multinomial_fit <- readRDS( "work/multinomial_changepoint_voynich_fit.rds" )
}

# Plot the calculated changepoint probabilities.
# (‘changepoint_simplex’).
mean_changepoint_prob <-
extract( voynich_multinomial_fit )$changepoint_simplex %>%
as_tibble( .name_repair="unique" ) %>%
summarise_all( mean ) %>%
pivot_longer( everything() ) %>%
rowid_to_column()

# Plot the calculated changepoint probabilities.
# (‘changepoint_simplex’).
mean_log_p <-
extract( voynich_multinomial_fit )$log_p %>%
as_tibble( .name_repair="unique" ) %>%
summarise_all( mean ) %>%
pivot_longer( everything() ) %>%
rowid_to_column()

# Save mean values for plotting
saveRDS( mean_changepoint_prob, file="work/mean_changepoint_prob_voynich.rds" )

[/code]

Voynich Manuscript data file

Voynich Manuscript formatted raw text data.

Voynich Manuscript changepoint plot code

multinomial_changepoint_voynich_plot.r
[code language=”r”]

library( tidyverse )
library( magrittr )

library( ggthemes )
library( showtext )

library( cowplot )
library( grimoire ) # https://github.com/weirddatascience/grimoire

# Fonts
font_add( "voynich_font", "resources/fonts/voynich/eva1.ttf")
font_add( "main_font", "resources/fonts/alchemy/1651 Alchemy/1651AlchemyNormal.otf")
font_add( "bold_font", "resources/fonts/alchemy/1651 Alchemy/1651AlchemyNormal.otf")

showtext_auto()

mean_changepoint_prob <-
readRDS( "work/mean_changepoint_prob_voynich.rds" )

changepoint_plot <-
ggplot( mean_changepoint_prob ) +
geom_col( aes( x=rowid, y=value ), fill=weird_colours["blood"] ) +
labs( x="Folio", y="Probability of Changepoint" ) +
theme(
panel.background = element_rect(fill = "transparent", colour = "transparent"),
plot.background = element_rect(fill = "transparent", colour = "transparent"),
plot.title = element_text( family="bold_font", colour=weird_colours["ink"], size=22 ),
plot.subtitle = element_text( family="bold_font", colour=weird_colours["ink"], size=12 ),
axis.text = element_text( family="bold_font", colour=weird_colours["ink"], size=12 ),
axis.title.x = element_text( family="bold_font", colour=weird_colours["ink"], size=12 ),
axis.title.y = element_text( family="bold_font", colour=weird_colours["ink"], angle=90, size=12 ),
axis.line = element_line( colour=weird_colours["ink"] ),
panel.grid.major.x = element_blank(),
panel.grid.major.y = element_blank(),
panel.grid.minor.x = element_blank(),
panel.grid.minor.y = element_blank()
)

# grimoire::decorate_plot() from
parchment_plot <-
decorate_plot(
title="Voynich Folio Word-Length Changepoint",
subtitle="http://www.weirddatascience.net | @WeirdDataSci",
plot=changepoint_plot,
bg_image="resources/img/parchment.jpg",
footer="Data: http://www.voynich.nu" )

save_plot("output/multinomial_changepoint_voynich_plot.pdf",
parchment_plot,
base_width = 16,
base_height = 9,
base_aspect_ratio = 1.78 )

[/code]

Our model appears to identify a potential changepoint in the frequency of short words in the Voynich Manuscript somewhere around Folio 33.

In contrast to the analysis of Tirant lo Blanc, we have no a priori suspicion that multiple authors were involved in the creation of the Voynich Manuscript. As such, we may hypothesise this changepoint as reflecting a simple stylistic shift, a shift in content, or, as with the previous analysis, a shift in authorship.

Mutatis Mutandis

Recalling the topic model from the previous post, and the manually-assigned topics hinted at by the diagrams in the manuscript, Folio 33 might not immediately arouse our suspicions as the most obvious candidate for such a shift in style, falling as it does some way through the manually-identified herbal section, and without an immediately apparent shift in the distribution of topics.

For simplicity of presentation and analysis we will work with the alternative 12-topic model suggested by the metrics in the previous post rather than the 34-topic model initially given there⁴. The distribution of topics in this model can be presented as those of the 34-topic model were in our previous post.

Voynich folio-topic heatmap

" data-image-caption="

Voynich folio-topic heatmap

Voynich Manuscript Folio Topic Heatmap | (PDF Version)

We might, then, ask whether the distribution of topics from this model itself has a changepoint. Having interrogated the distribution of word length frequencies, we can pose the same questions to the distribution of assignments produced by the topic model. Similarly to above: were we to conceive of the topic model assignment for each page as being the result of the roll of some biased die, is there a notable point in the document where the bias of that die seems to shift?

Framed as such, there is little more required to apply this model to the topic assignments. Our Stan model, dredged from its slumber, merely needs to be provided with the topic model folio assignment data.

Voynich Manuscript topic model changepoint

" data-image-caption="

Voynich Manuscript topic model changepoint

Voynich Manuscript topic model changepoint | (PDF Version)

Voynich Manuscript topic model changepoint code

multinomial_changepoint_voynich_topics.r
[code language=”r”]

library( tidyverse )
library( tidyselect )
library( magrittr )

library( rstan )
library( tidytext )

library( gtools ) # (Specifically for `mixedsort` to sort column names numerically.

# Number of topics in model
num_topics <- 12

# Load Voynich topic model data
message( "Reading Voynich topic model data…" )
voynich_tbl <-
readRDS( paste0( "work/topic_identity-", num_topics, ".rds" )) %>%
select( -c( "gamma", "section" ) ) %>%
ungroup

# Pivot the data wider to be presented to Stan as a matrix of samples from a multinomial.
voynich_lengths <-
voynich_tbl %>%
mutate( count=1 ) %>%
pivot_wider( names_from = topic, values_from = "count" ) %>%
select( -document ) %>%
select(mixedsort(peek_vars())) %>%
replace( is.na(.), 0 )

topic_fit_file <- paste0( "work/multinomial_changepoint_voynich_topic_fit-", num_topics, ".rds" )
if( not( file.exists( topic_fit_file ) ) ) {

message( "Fitting multinomial model.")
voynich_topic_multinom_fit <-
stan( "multinomial_changepoint.stan",
data=list(
num_obs=226,
num_cats=num_topics,
y = as.matrix( voynich_lengths ),
alpha = rep( 1, num_topics ) ),
iter=8000,
seed=19300319,
control=list( adapt_delta=0.9 ) )
saveRDS( voynich_multinom_fit, topic_fit_file )

} else {
message( "Loading saved multinomial model.")
voynich_multinom_fit <- readRDS( topic_fit_file )
}

# Extract the calculated changepoint probabilities to a simplex.
mean_changepoint_prob <-
extract( voynich_multinom_fit )$changepoint_simplex %>%
as_tibble( .name_repair="unique" ) %>%
summarise_all( mean ) %>%
pivot_longer( everything() ) %>%
rowid_to_column()

# Save values for plotting
saveRDS( mean_changepoint_prob, file=paste0( "work/mean_changepoint_prob_voynich_topic-", num_topics, ".rds" ) )

[/code]

Voynich Manuscript topic model changepoint plot code

multinomial_changepoint_voynich_topics_plot.r
[code language=”r”]

library( tidyverse )
library( magrittr )

library( ggthemes )
library( showtext )

library( cowplot )
library( grimoire ) # https://github.com/weirddatascience/grimoire

showtext_auto()

# Specify the number of topics in the model
num_topics <- 12

mean_changepoint_prob <-
readRDS( paste0("work/mean_changepoint_prob_voynich_topic-", num_topics, ".rds" ) )

# grimoire::decorate_plot() from
parchment_plot <-
decorate_plot(
title=paste0( "Voynich Folio Changepoint Probability – Topic Model (", num_topics, " topics)"),
subtitle="http://www.weirddatascience.net | @WeirdDataSci",
plot=changepoint_plot,
bg_image="resources/img/parchment.jpg",
footer="Data: http://www.voynich.nu",
rel_heights=c(0.1, 1, 0.05 ))

save_plot( paste0("output/multinomial_changepoint_voynich_topic-", num_topics, "_plot.pdf" ),
parchment_plot,
base_width = 16,
base_height = 9,
base_aspect_ratio = 1.78 )

[/code]

The location suggested for the topic model changepoint are surprisingly close to the results of the changepoint for the frequency counts of short words in the Voynich Manuscript. Whilst the changepoint probabilities are somewhat more diffuse in the topic model analysis, the most significant probability mass is centered around Folio 38, with much lower spikes extending out as far as Folio 55 and Folio 30.

In addition to the mutual support that these two analyses provide, it is notable that the major changpoint identified by both falls directly in the earlier portion of the first, major “herbal” section identified manually by Voynich scholars through inspection of the images accompanying the text. This suggests that that first section, at least in terms of textual content, is not as homogeneous as has previously been suggested. Future scholars investigating the structure of the Voynich Manuscript may therefore wish to direct more attention towards the earlier middle of the herbal section, around folios 30 to 40, to identify what dreadful changes may emerge at that point in the text.

We might naturally, but do not here, extend this analysis by shattering further the smooth unity of the Manuscript according to multiple changepoints. Such an extension is, as intimated in the guide, conceptually simple but computationally burdensome, as it requires recalculation of multiple potential distributions across an ever increasing number of parameters. As such, we leave this analysis, and the means to conduct it more efficiently, for the dim future.

Omnia mutantur, nihil interit

Our analysis has provided us with an abstracted location in the text at which our unsettling suspicions of change lie. The two folios arousing greatest curiosity are therefore Folio 33 and Folio 38, which we present here to reify our horror. It is worth highlighting, however, that the changepoint analysis says nothing specific about these two folios; the model identifies that the inexplicable scrawling prior to the changepoint differs significantly from the maddeningly incomprehensible glyphs following it, nothing more.

Voynich Folio 33

" data-image-caption="

Voynich Folio 33

Voynich Folio 33

Voynich Folio 38

" data-image-caption="

Voynich Folio 38

Voynich Folio 38

The statistical properties that we have uncovered in the Voynich Manuscript over the past four posts reveal something of its inner structure. It supports, but cannot prove, that the Manuscript is not a hoax, and that it the text is most likely drawn from some natural language.

The changepoint analyses in this post are a powerful tool for identifying evolution and mutation in data, and the demonstrated example of stylometric analysis to Martorel’s Tirant lo Blanc support their use in revealing points of fracture in texts, without reference to the source language.

With specific relevant to the Voynich Manuscript, both the word frequency changepoint and the topic model changepoint suggest that the manscript’s contents shift significantly at some point around Folios 30 to 40. Given the previous assignment of topics based on manual identification of images accompanying the text, this presents a new avenue of investigation for Voynich researchers.

We have resisted that tantalising draw of attempts to translate the Voynich Manuscript. The tools we have applied are more broadly statistical and aim at unveiling structures and revealing patterns in the text; whilst they may provide information towards deciphering the text, that particular conundrum is for the future.

There are, as we would always wish, many avenues left unexplored in this particular labyrinth. The topic model is crude, and more subtle disassemblies could well provide a more refined view. The word frequency patterns support natural language, but we have not made any effort to correlate them with known languages. We have treated words as a unit of analysis, but have not looked in detail at the structure of likely prefixes and suffixes; similar words with differing endings are particularly notable in the topic model, and analysis of these could reveal much more than we have dared to attempt.

There could be much to learn from assessing multiple changepoints in the Manuscript. The presentation of the volume certainly supports its composition of multiple disparate sections; perhaps identifying an inexorable sequence of stylistic shifts could unveil still more of this structure.

For now, however, our meandering journey into the dim twilight of the Voynich Manuscript has drawn to a close, leaving us still searching for illumination in the shadows of this most elegant enigma.

Continue to search, in fear of what you may find.

Code and data for this post: https://github.com/weirddatascience/weirddatascience/tree/master/20200220-voynich04-tempora_mutantur.

Footnotes

Illuminating the Illuminated – Part Three: Topics of Invention | Topic Modelling the Voynich Manuscript

moth — Tue, 24 Dec 2019 16:51:08 +0000

Our earlier experiments derived some of the darker statistics of the Voynich Manuscript supporting the conjecture, but not erasing all doubt, that the manuscript’s cryptic graphemes are drawn from some natural, or shudderingly unnatural, language.

Despite our beliefs regarding its authenticity, however, the statistical tools we have employed so far can tell us little about the structure, and almost nothing of the meaning, of the Voynich Manuscript. In this post, whilst shying away from the madness and confusion of attempting to translate MS 408, or of definitively identifying its language, we will delve into the extent to which modern natural language processing techniques can reveal its lesser secrets.

The mechanisms we will apply in this post are drawn from the world of topic modelling, an approach widely used in the processing of human language to identify eerily related documents within a corpus of text.

Topic modelling, in its most widely used form, lies in considering each given document as a nebulous admixture of unseen and unknowable topics. These topics, in effect, are themselves probability distributions of words that are likely to occur together. Each document, therefore, is characterised as a set of probability distributions that generate the observed words. This approach, known as Latent Dirichlet Allocation, dispassionately extracts the hidden structure of documents by deriving these underlying distributions.

For known languages, latent Dirichlet allocation extrudes a set of topics characterised by the high-probability words that they generate. These, in turn, can be subjected to human interpretation to identify the semantic underpinnings behind the topics.

To illustrate, we present a topic model of Margaret A. Murray’s seminal 1921 work “The Witch Cult in Western Europe”. There are many uneasy subtleties in producing such a model, into which we will not plunge at this early stage; at a quick glance, however, we can see that from Murray’s detailed research and interweaved arguments for a modern-day survival of an ancient witch cult in Europe, the algorithm can identify certain prevalent themes. The third topic, for example, appears to conjure terms related to the conflict between the accepted state religion and the ‘heathen’ witch cult. The ninth topic concerns itself with the witches’ marks, supposedly identified on the body of practitioners; while the tenth dwells on the clandestine meetings and sabbaths of the cult.

Topic plot for Murray’s “The Witch Cult in Western Europe”

" data-image-caption="

Topic plot for Murray’s “The Witch Cult in Western Europe”

Topic plot for Murray’s “The Witch Cult in Western Europe” | (PDF Version)

Witch Cult Topic Model Code

wcwe_topics.r
[code language=”r”]

library( tidyverse )
library( magrittr )

library( ggthemes )
library( showtext )

library( tidytext )
library( widyr )

library( stm )
library( quanteda )

library(cowplot)

# For reorder_within() for facets:
library( drlib )

# Fonts
font_add( "main_font", "/usr/share/fonts/TTF/weird/alchemy/1651 Alchemy/1651AlchemyNormal.otf")
font_add( "bold_font", "/usr/share/fonts/TTF/weird/alchemy/1651 Alchemy/1651AlchemyNormal.otf")

showtext_auto()

# Read (processed) text of Murray’s "The Witch Cult in Western Europe".
wcwe_raw <-
read_csv( "data/wcwe/wcwe_raw.csv", col_names=FALSE ) %>%
rename( text = X1 ) %>%
rowid_to_column( var = "chapter" )

# Tokenize
# (Remove words of 3 letters or less)
# Stemming and stopword removal apparently not so effective anyway,
# according to Schofield et al.:
wcwe_words <-
wcwe_raw %>%
unnest_tokens( word, text ) %>%
filter( !word %in% stop_words$word ) %>%
filter( str_length( word ) > 3 )

wcwe_word_counts <-
wcwe_words %>%
count( word, chapter, sort = TRUE )

# Generate the corpus
wcwe_dfm <-
wcwe_words %>%
count( chapter, word, sort=TRUE ) %>%
cast_dfm( chapter, word, n )

# Search for a number of topics and output goodness-of-fit measures.

# N=2 is the number of documents ‘held out’ for the goodness-of-fit measure.
# (The model is trained on the main body, then used to calculated the
# likelihood of the held-out documents.) N=2 is used here to produce
# approximately 10% of the corpus.

if( not( file.exists( "work/wcwe_topic_search_k.rds" ) ) ) {

message( "Seaching low-n topic models…" )

wcwe_k <-
searchK( wcwe_dfm, K=c(3:30), N=2 )

saveRDS( wcwe_k, "work/wcwe_topic_search_k.rds" )

} else {

wcwe_k <-
readRDS( "work/wcwe_topic_search_k.rds" )

}

# Plot semantic coherence against exclusivity for model selection
wcwe_k_plot <-
wcwe_k$results %>%
gather( key="variable", value="value", exclus, semcoh )

wcwe_k_semcoh_exclusive <-
ggplot( wcwe_k_plot, aes( x=K, y=value, group=variable) ) +
geom_line() +
facet_wrap( ~variable, ncol=1, scales="free_y" )

# Based on metrics of the above, calculate a 13-topic model
if( not( file.exists( "work/wcwe_topic_stm-13.rds" ) ) ) {

message( "Calculating 13-topic model…" )

wcwe_topic_model_13 <-
stm( wcwe_dfm, K=13, init.type="Spectral" )

# This takes a long time, so save output
saveRDS( wcwe_topic_model_13, "work/wcwe_topic_stm-13.rds" )

} else {

wcwe_topic_model_13 <- readRDS( "work/wcwe_topic_stm-13.rds" )

}

# Work with the 13-topic model for now
wcwe_topic_model <- wcwe_topic_model_13

### Convert output to a tidy tibble
wcwe_topic_model_tbl <-
tidy(wcwe_topic_model, matrix = "beta" )

wcwe_topics_top <-
wcwe_topic_model_tbl %>%
group_by(topic) %>%
top_n(10, beta) %>%
ungroup() %>%
arrange(topic, -beta)

gp <-
wcwe_topics_top %>%
mutate(term = reorder_within(term, beta, topic)) %>%
ggplot(aes(term, beta, fill = factor(topic))) +
geom_col(show.legend = FALSE, alpha=0.8 ) +
facet_wrap(~ topic, scales = "free") +
scale_x_reordered() +
coord_flip()

# Palette of ink colours obtained from screenshots of Diamine inks.
ink_colours <- c( "#753733", "#b6091d", "#e45025", "#232d1d",
"#224255", "#533f50", "#453437", "#7f2430",
"#254673", "#52120e", "#3d2535", "#25464b",
"#2f2a1c" )

gp <-
gp + scale_fill_manual( values=ink_colours )

topic_plot_13 <-
gp + labs( x="Term", y="Probability in Topic" ) +
theme (
plot.title = element_text( family="bold_font", size=16 ),
plot.subtitle = element_text( family="bold_font", size=12 ),
axis.text.y = element_text( family="bold_font", size=10 )
)

theme_set(theme_cowplot(font_size=4, font_family = "main_font" ) )

wcwe_topic_plot <-
topic_plot_13 +
theme (
axis.title.y = element_text( angle = 90, family="main_font", size=12 ),
axis.text.y = element_text( colour="#3c3f4a", family="main_font", size=10 ),
axis.title.x = element_text( colour="#3c3f4a", family="main_font", size=12 ),
axis.text.x = element_text( colour="#3c3f4a", family="main_font", size=10 ),
axis.line.x = element_line( color = "#3c3f4a" ),
axis.line.y = element_line( color = "#3c3f4a" ),
plot.title = element_blank(),
plot.subtitle = element_blank(),
plot.background = element_rect( fill = "transparent" ),
panel.background = element_rect( fill = "transparent" ), # bg of the panel
panel.grid.major.x = element_blank(),
panel.grid.major.y = element_blank(),
panel.grid.minor.x = element_blank(),
panel.grid.minor.y = element_blank(),
legend.text = element_text( family="bold_font", colour="#3c3f4a", size=10 ),
legend.title = element_blank(),
legend.key.height = unit(1.2, "lines"),
legend.position=c(.85,.5),
strip.background = element_blank(),
strip.text.x = element_text(size = 10, family="main_font")
)

# Cowplot trick for ggtitle
title <-
ggdraw() +
draw_label("\"The Witch Cult in Western Europe\" (Murray, 1921) Topic Model", fontfamily="bold_font", colour = "#3c3f4a", size=20, hjust=0, vjust=1, x=0.02, y=0.88) +
draw_label("http://www.weirddatascience.net | @WeirdDataSci", fontfamily="bold_font", colour = "#3c3f4a", size=12, hjust=0, vjust=1, x=0.02, y=0.40)

data_label <-
ggdraw() +
draw_label("Data: Murray, M. \"The Witch Cult in Western Europe\" (1921) | http://www.gutenberg.org/ebooks/20411", fontfamily="bold_font", colour = "#3c3f4a", size=8, hjust=1, x=0.98 )

tgp <-
plot_grid(title, wcwe_topic_plot, data_label, ncol=1, rel_heights=c(0.1, 1, 0.1))

wcwe_topic_plot <-
ggdraw() +
draw_image("img/parchment.jpg", scale=1.4 ) +
draw_plot(tgp)

ggsave( "output/wcwe_topic_plot_13.pdf", width=16, height=9 )

[/code]

As the plot above suggests, topic modelling is a tool to support our limited human understanding rather than a cold, mechanical source of objectivity and, as with much unsupervised machine learning, there are various subjective choices that must be made guided by the intended purpose of the analysis. Drawing together impercetible threads of relation in bodies of text, the approach suggests major themes and, crucially, can associate disparate areas of text that focus on similar concerns.

Topical Remedies

What, then, can we learn by bringing the oppressive weight of latent Dirichlet allocation to bear against a cryptic tome whose words, and indeed letters, resist our best efforts at interpretation?

Without understanding of individual words, we wil be unable to glean the semantic understanding of topics that was possible with Murray’s Witch Cult…. There is a chance, however, that the topic model can derive relations between separated sections of the manuscript — do certain early pages demonstrate a particular textual relationship to later pages? Do sections of the overall manuscript retain an apparent coherence of topics, with contiguous pages being drawn from a small range of similar topics? Which Voynich words fall under similar topics?

Preparations

Topic modelling typically requires text to undergo a certain level of formulaic preparation. The most common of such rituals are stemming, lemmatization, and stopword removal. Briefly, stemming and lemmatization aim to reduce confusion by rendering words to their purest essence. Stemming is a more crude heuristic, unsympathetically incising endings, and so truncating “dark”, “darker”, “darkest” simply to the atomic root word “dark”. Lemmatization requires more understanding, untangling parts of speech and context: that to curse is a verb while a curse is a noun; the two identical words should therefore be treated separately.

Stopword removal aims to remove the overwhelming proportion of shorter, structural words that are ubiquitous throughout any text, but are largely irrelevant to the overall topic: the, and, were, it, they, but, if…. Whilst key to our understanding of texts, these terms have no significance to the theme or argument of a text.

Undermining our scheme to perform topic modelling, therefore, is the lamentable fact that, without understanding of either the text or its structure, we are largely unable to perform any of these tasks satisfactorily. We have neither an understanding of the grammatical form of Voynich words allowing stemming or lemmatization, or a list of stopwords to excise.

Whilst stemming and lemmatization are unapproachable, at least within the confines of this post, we can effect a crude form of stopword removal through use of a common frequency analysis of the text. Stopwords are, in general, those words that are both most-frequently occuring in some corpus of documents and those that are found across the majority of documents in that language. The second criterion ensures that words occurring frequently in obscure and specialised texts are not considered of undue importance.

This overall statistic is known as term frequency-inverse document frequency, or tf-idf, and is widely used in information retrieval to identify terms of specific interest within certain documents that are not shared by the wider corpus. For our purposes, we wish to identify and elide those ubiquitous, frequent terms that occur across the entire corpus. To do so, given our lack of knowledge of the structure of the Voynich Manuscript, we will consider each folio as a separate document, and consider only the inverse document frequency as we are uninterested in how common a word within each document. To avoid words that most commonly appear across the manuscript, with a basis in the distribution of stop words in a range of known languages, we therefore remove the 200 words with lowest inverse document frequency scores⁵.

Having contorted the text into an appropriate form for analysis, we can begin the process of discerning its inner secrets. Our code relies on the tidytext and stm packages, allowing for easy manipulation of document structure and topic models⁶

Numerous Interpretations

Topic models are a cautionary example of recklessly unsupervised machine learning. As with most such approaches, there are a number of subjective choices to be made that affect the outcome. Perhaps the most influential is the selection of the number of topics that the model should generate. Whilst some approaches have been suggested to derive this number purely by analysis, in most cases it remains in the domain of the human supplicant. Typically, the number of topics is guided both by the structure of the text along with whatever arcane purpose the analysis might have. With our imposed lack of understanding, however, we must rely solely on crude metrics to make this most crucial of choices.

Several methods of assessment exist to quantify the fit of a topic model to the text. The two that we will employ, guided by the stm package are semantic coherence, which roughly expresses that words from a given topic should co-occur within a document; and exclusivity, which values models more highly when given words occur within topics with high frequency, but are also relatively exclusive to those topics.

We select an optimal number of topics by the simple process of calculating models with varying numbers of topics, and assessing when these two scores are maximised. For the Voynich Manuscript we observe that 34 topics appears to be initially optimal⁷.

Selection metrics for Voynich topic model topic numbers.

" data-image-caption="

Selection metrics for Voynich topic model topic numbers.

Selection metrics for Voynich topic model topic numbers. | (PDF Version)

The initial preparation of the code, the search through topic models of varying numbers, and the selection of the final 34 topic model is given in the code below alongside plotting code for the metrics diagram.

Voynich Manuscript Topic Modelling Code

voynich_topics-model.r
[code language=”r”]

library( tidyverse )
library( magrittr )

library( tidytext )
library( widyr )

library( stm )

# install_github("dgrtwo/drlib")
library( drlib )

# References:
#
#
#
#
#

voynich_raw <-
read_csv( "data/voynich_raw.txt", col_names=FALSE ) %>%
rename( folio = X1, text = X2 )

# Read in manually-identiied sections per folio, according to
#
voynich_sections <-
read_csv( "data/voynich_sections.txt", col_names=FALSE ) %>%
rename( folio = X1, section = X2 )

# Merge the above to note section for each folio alongside the text
voynich_tbl <-
left_join( voynich_sections, voynich_raw )

# Tokenize
# Remove words of 3 letters or less.
voynich_words <-
voynich_tbl %>%
unnest_tokens( word, text ) %>%
filter( str_length( word ) > 3 )

# Most common words
voynich_common <-
voynich_words %>%
count( word, sort=TRUE ) %>%
mutate( word = reorder( word, n ) )

# Counts of words per folio
voynich_word_counts <-
voynich_words %>%
count( word, folio, sort = TRUE )

# TF-IDF
voynich_tf_idf <-
voynich_word_counts %>%
bind_tf_idf( word, folio, n ) %>%
arrange( desc( tf_idf ) )

# Based on median stopword count of languages in NLTK
# (),
# remove the 200 lowest-scoring words.
voynich_stopwords <-
voynich_tf_idf %>%
arrange( idf ) %>%
select( word ) %>%
unique() %>%
head( 200 ) %>%
extract2( "word" )

voynich_words <-
voynich_words %>%
filter( !word %in% voynich_stopwords )

# Generate the corpus
voynich_dfm <-
voynich_words %>%
count( folio, word, sort=TRUE ) %>%
cast_dfm( folio, word, n )

# Search for a number of topics and output goodness-of-fit measures.

# N=20 is the number of documents ‘held out’ for the goodness-of-fit measure.
# (The model is trained on the main body, then used to calculated the
# likelihood of the held-out documents.) N=20 is used here to produce
# approximately 10% of the corpus.
if( not( file.exists( "work/voynich_topic_search_k.rds" ) ) ) {

message( "Seaching low-n topic models…" )

voynich_k <-
searchK( voynich_dfm, K=c(3:40), N=20 )

saveRDS( voynich_k, "work/voynich_topic_search_k.rds" )

} else {

voynich_k <-
readRDS( "work/voynich_topic_search_k.rds" )

}

# Based on the metrics above, use 34-topic model
if( not( file.exists( "work/voynich_topic_stm-34.rds" ) ) ) {

message( "Calculating 34-topic model…" )

# Setting K=0 uses (Lee and Minno, 2014) to select a number of topics
voynich_topic_model_34 <-
stm( voynich_dfm, K=34, init.type="Spectral" )

# This takes a long time, so save output
saveRDS( voynich_topic_model_34, "work/voynich_topic_stm-34.rds" )

} else {

voynich_topic_model_34 <- readRDS( "work/voynich_topic_stm-34.rds" )

}

# Based on the metrics above, also calculated a secondary 12-topic model
if( not( file.exists( "work/voynich_topic_stm-12.rds" ) ) ) {

message( "Calculating 12-topic model…" )

# Setting K=0 uses (Lee and Minno, 2014) to select a number of topics
voynich_topic_model_12 <-
stm( voynich_dfm, K=12, init.type="Spectral" )

# This takes a long time, so save output
saveRDS( voynich_topic_model_12, "work/voynich_topic_stm-12.rds" )

} else {

voynich_topic_model_12 <- readRDS( "work/voynich_topic_stm-12.rds" )

}

# Work initially with the 34-topic model
voynich_topic_model <- voynich_topic_model_34

## Convert output to a tidy tibble
voynich_topic_model_tbl <-
tidy(voynich_topic_model, matrix = "beta" )

voynich_terms <-
tidy(voynich_topic_model, matrix = "gamma" )

# Select the top six terms in each topic for display
voynich_topics_top <-
voynich_topic_model_tbl %>%
group_by(topic) %>%
top_n(6, beta) %>%
ungroup() %>%
arrange(topic, -beta)

# Produce a per-folio topic identification.
# Document – topic – score
topic_identity <-
voynich_terms %>%
group_by( document ) %>%
top_n( 1, gamma ) %>%
arrange( document ) %>%
ungroup

# Reinsert manually-identified section information (derived from
# illustrations).
topic_identity$section <- voynich_tbl$section

saveRDS( topic_identity, "work/topic_identity.rds" )

[/code]

Topic Metric Selection Plotting Code

voynich_topics-plot_metric.r
[code language=”r”]

library( tidyverse )
library( magrittr )

library( ggthemes )
library( showtext )

library( ggplot2 )
library( cowplot )

# References:
#
#
#
#
#

font_add( "voynich_font", "/usr/share/fonts/TTF/weird/voynich/eva1.ttf")
font_add( "main_font", "/usr/share/fonts/TTF/weird/alchemy/1651 Alchemy/1651AlchemyNormal.otf")
font_add( "bold_font", "/usr/share/fonts/TTF/weird/alchemy/1651 Alchemy/1651AlchemyNormal.otf")

showtext_auto()

# Read topic model search
voynich_k <-
readRDS( "work/voynich_topic_search_k.rds" )

# Plot semantic coherence against exclusivity for model selection
voynich_k_plot <-
voynich_k$results %>%
as_tibble %>%
rename( "Semantic Coherence"=semcoh, "Exclusivity"=exclus ) %>%
gather( key="variable", value="value", "Semantic Coherence", "Exclusivity" ) %>%
rename( "Topic Count"=K, "Value"=value )

# We will use cowplot, so set the theme here.
theme_set(theme_cowplot(font_size=4, font_family = "main_font" ) )

# Plot semantic coherence against exclusivity.
# (Highlight the selected 34-topic point.)
voynich_k_semcoh_exclusive <-
ggplot( voynich_k_plot, aes( x=`Topic Count`, y=Value, group=variable) ) +
geom_line( colour="#8a0707" ) +
facet_wrap( ~variable, ncol=1, scales="free_y" ) +
geom_vline( xintercept=34, colour="#228b22", linetype="longdash" ) +
scale_x_continuous(breaks=c( seq(0, 40, 10), 34 ) ) +
theme (
axis.title.y = element_text( angle = 90, family="main_font", size=12 ),
axis.title.x = element_text( colour="#3c3f4a", family="main_font", size=12 ),
axis.text.x = element_text( colour="#3c3f4a", family="main_font", size=10 ),
axis.text.y = element_text( colour="#3c3f4a", family="main_font", size=10 ),
axis.line.x = element_line( color = "#3c3f4a" ),
axis.line.y = element_line( color = "#3c3f4a" ),
plot.title = element_blank(),
plot.subtitle = element_blank(),
plot.background = element_rect( fill = "transparent" ),
panel.background = element_rect( fill = "transparent" ), # bg of the panel
panel.grid.major.x = element_blank(),
panel.grid.major.y = element_blank(),
panel.grid.minor.x = element_blank(),
panel.grid.minor.y = element_blank(),
legend.text = element_text( family="bold_font", colour="#3c3f4a", size=10 ),
legend.title = element_blank(),
legend.key.height = unit(1.2, "lines"),
legend.position=c(.85,.5),
strip.background = element_blank(),
strip.text.x = element_text(size = 10, family="main_font")
)

# Cowplot trick for ggtitle
title <-
ggdraw() +
draw_label("Vonich Manuscript Topic Selection Metrics", fontfamily="bold_font", colour = "#3c3f4a", size=20, hjust=0, vjust=1, x=0.02, y=0.88) +
draw_label("http://www.weirddatascience.net | @WeirdDataSci", fontfamily="bold_font", colour = "#3c3f4a", size=12, hjust=0, vjust=1, x=0.02, y=0.40)

data_label <-
ggdraw() +
draw_label("Data: http://www.voynich.nu", fontfamily="bold_font", colour = "#3c3f4a", size=8, hjust=1, x=0.98 )

tgp <-
plot_grid(title, voynich_k_semcoh_exclusive, data_label, ncol=1, rel_heights=c(0.1, 1, 0.1))

voynich_topic_selection_plot <-
ggdraw() +
draw_image("img/parchment.jpg", scale=1.4 ) +
draw_plot(tgp)

ggsave( "output/voynich_topic_selection_metrics.pdf", width=16, height=9 )

[/code]

With these torturous steps on our path finally trodden, our path leads at last to a model deriving the underlying word generating probabilities of the Voynich Manuscript. In each facet, the highest-probability words in each topic are shown in order.

Voynich Manuscript Topic Model (34 topics)

" data-image-caption="

Voynich Manuscript Topic Model (34 topics)

Voynich Manuscript Topic Model (34 topics) | (PDF Version)

Topic Model Plotting Code

voynich_topics-plot_topics.r
[code language=”r”]

library( tidyverse )
library( magrittr )

library( ggthemes )
library( showtext )

library( tidytext )

# install_github("dgrtwo/drlib")
library( drlib )

library( ggplot2 )
library( cowplot )

showtext_auto()

# ####################
# ## 34 Topic Model ##
# ####################

# Work with the 34-topic model
voynich_topic_model <-
readRDS( "work/voynich_topic_stm-34.rds" )

## Convert output to a tidy tibble
voynich_topic_model_tbl <-
tidy(voynich_topic_model, matrix = "beta" )

voynich_terms <-
tidy(voynich_topic_model, matrix = "gamma" )

# Select the top six terms in each topic for display
voynich_topics_top <-
voynich_topic_model_tbl %>%
group_by(topic) %>%
top_n(6, beta) %>%
ungroup() %>%
arrange(topic, -beta)

# We will use cowplot, so set the theme here.
theme_set(theme_cowplot(font_size=4, font_family = "main_font" ) )

# Plot each topic as a geom_col(). Use drlib’s ‘reorder_within’ to order bars
# within each facet. (Note that the scale_x_reordered() is needed to fix
# (flipped!) x-axis labels in the output.)
#
gp <-
voynich_topics_top %>%
mutate(term = reorder_within(term, beta, topic)) %>%
ggplot(aes(term, beta, fill = factor(topic))) +
geom_col( alpha=0.8, show.legend = FALSE) +
theme( axis.text.y = element_text( family="voynich_font", size=10 ) ) +
facet_wrap(~ topic, scales = "free") +
scale_x_reordered() +
coord_flip() +
labs( x="Term", y="Probability in Topic" )

# Theming
gp <-
gp +
theme (
axis.title.y = element_text( margin = margin(t = 0, r = 12, b = 0, l = 0), angle = 90, family="main_font", size=12 ),
axis.title.x = element_text( margin = margin(t = 12, r = 0, b = 0, l = 0), colour="#3c3f4a", family="main_font", size=12 ),
axis.text.x = element_text( colour="#3c3f4a", family="main_font", size=6 ),
axis.line.x = element_line( color = "#3c3f4a" ),
axis.line.y = element_line( color = "#3c3f4a" ),
plot.title = element_blank(),
plot.subtitle = element_blank(),
plot.background = element_rect( fill = "transparent" ),
panel.background = element_rect( fill = "transparent" ), # bg of the panel
panel.grid.major.x = element_blank(),
panel.grid.major.y = element_blank(),
panel.grid.minor.x = element_blank(),
panel.grid.minor.y = element_blank(),
legend.text = element_text( family="bold_font", colour="#3c3f4a", size=10 ),
legend.title = element_blank(),
legend.key.height = unit(1.2, "lines"),
legend.position=c(.85,.5),
strip.background = element_blank(),
strip.text.x = element_text(size = 10, family="main_font")
)

# Palette of ink colours (based on screenshots of Diamine inks).
ink_colours <- c( "#753733", "#b6091d", "#e45025", "#232d1d",
"#224255", "#533f50", "#453437", "#7f2430",
"#254673", "#52120e", "#3d2535", "#25464b",
"#2f2a1c" )

# Create a vector of selections from the palette, one for each topic.
ink_palette <-
sample( ink_colours, size=34, replace=TRUE )

# Add fill colours to plot.
gp <-
gp + scale_fill_manual( values=ink_palette )

# Cowplot trick for ggtitle
title <-
ggdraw() +
draw_label("Vonich Manuscript Topic Model (34 Topics)", fontfamily="bold_font", colour = "#3c3f4a", size=20, hjust=0, vjust=1, x=0.02, y=0.88) +
draw_label("http://www.weirddatascience.net | @WeirdDataSci", fontfamily="bold_font", colour = "#3c3f4a", size=12, hjust=0, vjust=1, x=0.02, y=0.40)

data_label <-
ggdraw() +
draw_label("Data: http://www.voynich.nu", fontfamily="bold_font", colour = "#3c3f4a", size=8, hjust=1, x=0.98 )

tgp <-
plot_grid(title, gp, data_label, ncol=1, rel_heights=c(0.1, 1, 0.1))

voynich_topic_plot <-
ggdraw() +
draw_image("img/parchment.jpg", scale=1.4 ) +
draw_plot(tgp)

ggsave( "output/voynich_topic_plot_34.pdf", width=16, height=9 )

[/code]

Of Man and Machine

The topic model produces a set of topics in the form of probability distributions generating words. The association of each topic to a folio in the Voynich Manuscript represents these probabilistic assignments based solely on the distribution of words in the text. There is a secondary topic identification, however, tentatively proposed by scholars of the manuscript. The obscure diagrams decorating almost every folio provide their own startling implications as to the themes detailed in the undeciphered prose.

We might wish to ask, then: do the topic assignments generated by the machine reflect the human intepretation? To what extent do pages decorated with herbal illuminations follow certain machine-identified topics compared with those assigned to astronomical charts?

The illustration-based thematic sections of the Voynich Manuscript fall into eight broad categories, according to Zandbergen. These sections are, briefly:

Herbal, detailing a range of unidentified plants, comprising most of the first half of the manuscript;
astronomical, focusing on stars, planets, and astronomical symbols;
cosmological, displaying obscure circular diagrams of a similar form to the astronomical;
astrological, in which small humans are displayed mostly in circular diagrams alongside zodiac signs;
biological, characterised by small drawings of human figures, often connected by tubes;
pharmaceutical, detailing parts of plants and vessels for their preparation;
starred text, divided into short paragraphs marked with a star, with no other illustrations; and
text only pages.

With these contextual descriptions, we can examine the relationship between the speculative assignments of the topic model against the suggestions of the diagrams.

Voynich Manuscript Folio Topic Heatmap

" data-image-caption="

Voynich Manuscript Folio Topic Heatmap

Voynich Manuscript Folio Topic Heatmap | (PDF Version)

Voynich Manuscript Topic Model Folio Heatmap Plotting Code

voynich_topics-plot_heatmap.r
[code language=”r”]

library( tidyverse )
library( magrittr )

library( ggthemes )
library( showtext )

# install_github("dgrtwo/drlib")
library( drlib )

library( ggplot2 )
library( cowplot )

font_add( "main_font", "/usr/share/fonts/TTF/weird/alchemy/1651 Alchemy/1651AlchemyNormal.otf")
font_add( "bold_font", "/usr/share/fonts/TTF/weird/alchemy/1651 Alchemy/1651AlchemyNormal.otf")

showtext_auto()

# Set the number of topics
n_topics <- 34

# Load the appropriate topic model
voynich_topic_model <-
readRDS( paste0( "work/voynich_topic_stm-", n_topics, ".rds" ))

theme_set(theme_cowplot(font_size=4, font_family = "main_font" ) )

# Load folio topic identity assignments
topic_identity <-
readRDS( "work/topic_identity.rds" )

# Cowplot
theme_set(theme_cowplot(font_size=4, font_family = "main_font" ) )

# Plot topic heatmap
topic_heatmap <-
topic_identity %>%
ggplot( aes( x=document, y=topic, fill=section ) ) +
geom_tile( colour="#3c3f4a", alpha=0.8, size=0.4 ) +
scale_fill_brewer( palette="Dark2", direction=1, name="Section", labels=c("Astrological", "Astronomical", "Biological", "Cosmological", "Herbal", "Pharmaceutical", "Starred Text", "Text Only" ) ) +
ggtitle( "Voynich Folio Topic Assignments", paste( n_topics, "Topic Model" )) +
labs( x="Folio", y="Topic" ) +
theme (
plot.title = element_text( family="bold_font", size=22 ),
plot.subtitle = element_text( family="bold_font", size=12 ),
panel.grid.major.x = element_blank(),
panel.grid.major.y = element_blank(),
panel.grid.minor.x = element_blank(),
panel.grid.minor.y = element_blank(),
) +
scale_y_continuous(labels = seq( 1, n_topics, 1 ), breaks = seq( 1, n_topics, 1 ), minor_breaks = seq(0.5 , n_topics+.5, 1) ) +
scale_x_continuous(minor_breaks = seq(0.5 , 226.5, 5) )

gp <-
topic_heatmap +
theme (
axis.title.y = element_text( margin = margin(t = 0, r = 12, b = 0, l = 0), angle = 90, family="main_font", size=12 ),
axis.title.x = element_text( colour="#3c3f4a", family="main_font", size=12 ),
axis.text.x = element_text( colour="#3c3f4a", family="main_font", size=10 ),
axis.text.y = element_text( colour="#3c3f4a", family="main_font", size=10 ),
axis.line.x = element_line( color = "#3c3f4a" ),
axis.line.y = element_line( color = "#3c3f4a" ),
plot.title = element_blank(),
plot.subtitle = element_blank(),
plot.background = element_rect( fill = "transparent" ),
panel.background = element_rect( fill = "transparent" ), # bg of the panel
legend.text = element_text( family="bold_font", colour="#3c3f4a", size=10 ),
legend.title =element_text( family="bold_font", colour="#3c3f4a", size=12 ),
legend.key.height = unit(1.2, "lines"),
strip.background = element_blank(),
strip.text.x = element_text(size = 10, family="main_font")
)

# Cowplot trick for ggtitle
title <-
ggdraw() +
draw_label("Voynich Manuscript Topic Heatmap", fontfamily="bold_font", colour = "#3c3f4a", size=20, hjust=0, vjust=1, x=0.02, y=0.88) +
draw_label("http://www.weirddatascience.net | @WeirdDataSci", fontfamily="bold_font", colour = "#3c3f4a", size=12, hjust=0, vjust=1, x=0.02, y=0.40)

data_label <-
ggdraw() +
draw_label("Data: http://www.voynich.nu", fontfamily="bold_font", colour = "#3c3f4a", size=8, hjust=1, x=0.98 )

tgp <-
plot_grid(title, gp, data_label, ncol=1, rel_heights=c(0.1, 1, 0.1))

voynich_topic_heatmap <-
ggdraw() +
draw_image("img/parchment.jpg", scale=1.4 ) +
draw_plot(tgp)

ggsave( "output/voynich_folio_topic_heatmap.pdf", width=16, height=9 )

[/code]

The colours in the above plot represent the manual human interpretation, whilst the location on the y-axis shows the latent Dirichlet allocation topic assignment.

We might have harboured the fragile hope that such a diagram would have demonstrated a clear confirmatory delineation between the sectional diagrammatic breakdown of the Voynich Manuscript. At a first inspection, however, the topics identified by the analysis appear almost uniformly distributed across the pages of the manuscript.

The topic model admits to a number of assumptions, not least the selection of stopwords through to the number of topics in the model. We must also be cautious: the apparent distribution of topics over the various sections may be deceptive. For the moment, we can present this initial topic model as a faltering first step in our descent into the hidden structures of the Voynich Manuscript. The next, and final, post in this series will develop both the statistical features and the topic model towards a firmer understanding of whether the apparent shift in theme suggest by the illustrations is statistically supported by the text.

Until then, read deeply but do not trust what you read.

Footnotes

Illuminating the Illuminated – Part Two: Ipsa Scientia Potestas Est | Power Laws in the Voynich Manuscript

moth — Mon, 28 Oct 2019 09:42:02 +0000

In the previous post in this series we coyly unveiled the tantalising mysteries of the Voynich Manuscript: an early 15th century text written in an unknown alphabet, filled with compelling illustrations of plants, humans, astronomical charts, and less easily-identifiable entities.

Stretching back into the murky history of the Voynich Manuscript, however, is the lurking suspicion that it is a fraud; either a modern fabrication or, perhaps, a hoax by a contemporary scribe.

One of the more well-known arguments for the authenticity of the manuscript, in addition to its manufacture with period parchment and inks, is that the text appears to follow certain statistical properties associated with human language, and which were unknown at the time of its creation.

The most well-known of these properties is that the frequency of words in the Voynich Manuscript have been claimed to follow a phenomenon known as Zipf’s Law, whereby the frequency of a word’s occurrence in the text is inversely proportional to its rank in the list of words ordered by frequency.

In this post, we will scrutinise the extent to which the expected statistical properties of natural languages hold for the arcane glyphs presented by the Voynich manuscript.

Unnatural Laws

Zipf’s Law is an example of a discrete power law probability distribution. Power laws have been found to lurk beneath a sinister variety of ostensibly natural phenomena, from the relative size of human settlements to the diversity of species descended from a particular ancestral freshwater fish.

In its original context of human langauge, Zipf’s Law states that the most common word in a given language is likely to be roughly twice as common as the second most common word, and three times as common as the third most common word. More precisely, this law holds for much of the corpus, as the law tends to break down somewhat at both the most-frequent and least-frequent words in the corpus⁸. Despite this, we will focus on the original, simpler Zipfian characterisation in this analysis.

The most well-known, if highly flawed, method to determine whether a distribution follows a power law is to plot it with both axes expressed as a log-scale: a so-called log-log plot. A power law, represented in such a way, will appear linear. Unfortunately, a hideous menagerie of other distributions will also appear linear in such a setting.

More generally, it is rarely sensible to claim that any natural phenomenon follows a given distribution or model, but instead to demonstrate that a distribution presents a useful model for a given set of observations. Indeed, it is possible to fit any set of observations to a power law, with the assumption that the fit will be poor. Ultimately, we can do little more than demonstrate that a given model is the best simulacrum of observed reality, subject to the uses to which it will be put. Certainly, a more Bayesian approach would advocate building a range of models, demonstrating that the power law is most accurate. All truth, it seems, is relative.

Faced with the awful statistical horror of the universe, we are reduced to seeking evidence against a phenomenon’s adherence to a given distribution. Our first examination, then, is to see whether the basic log-log plot supports or undermines the Voynich Manuscript.

Fitted Power Law of Voynich Corpus

" data-image-caption="

Fitted Power Law of Voynich Corpus

" data-medium-file="https://www.weirddatascience.net/wp-content/uploads/2019/10/voynich_power_law.png" data-large-file="https://www.weirddatascience.net/wp-content/uploads/2019/10/voynich_power_law.png" src="http://www.weirddatascience.net/wp-content/uploads/2019/10/voynich_power_law.png" alt="Fitted Power Law of Voynich Corpus" width="1920" height="1080" class="size-full wp-image-953" />

Fitted Power Law of Voynich Corpus | (PDF Version)

A crude visual analysis certainly supports the argument that, for much of the upper half of the Voynich corpus, there is a linear relationship on the log-log plot consistent with Zipf’s Law. As mentioned, however, this superficial appeal to our senses leaves a gnawing lack of certainty in the conclusion. We must turn to less fallible tools.

The poweRlaw package for R is designed specifically to exorcise these particular demons. This package attempts to fit a power law distribution to a series of observations, in our case the word frequencies observed in the corpus of Voynich text. With the fitted model, we then attempt to disprove the null hypothesis that the data is drawn from a power law. If this attempt to betray our own model fails, then we attain an inverse enlightenment: there is insufficient evidence that the model is not drawn from a power law.

This is an inversion of the more typical frequentist null hypothesis scenario. Typically, in such approaches, we hope for a low p-value, typically below 0.05 or even 0.001, showing that the chance of the observations being consistent with the null hypothesis is extremely low. For this test, we instead hope that our p-value is insufficiently low to make such a claim, and thus that a power law is consistent with the data.

The diagram above shows a fitted parameterisation of the power law according to the poweRlaw package. In addition to the visually appealing fit of the line, the weirdly inverted logic of the above test provides a p-value of 0.151. We thus have as much confidence as we can have, via this approach, that a power law is a reasonable model for the text in the Voynich corpus.

Voynich Power Law Fit and Plot

voynich_powerlaw.r
[code language=”r”] library( tidyverse )
library( magrittr )

library( ggthemes )
library( showtext )

library( tidytext )
library( drlib )

library( poweRlaw )

library(cowplot)
library(magick)

showtext_auto()

message( "Reading raw Voynich data…" )
voynich_tbl <-
read_csv( "data/voynich_raw.txt", col_names=FALSE ) %>%
rename( folio = X1, text = X2 )

# Tokenize
voynich_words <-
voynich_tbl %>%
unnest_tokens( word, text )

# Most common words
message( "Calculating Voynich language statistics…" )
voynich_common <-
voynich_words %>%
count( word, sort=TRUE ) %>%
mutate( word = reorder( word, n ) ) %>%
mutate( freq = n / sum(n) )

voynich_word_counts <-
voynich_words %>%
count( word, folio, sort = TRUE )

# (Following the poweRlaw vignette)
# Create a discrete power law distribution object from the word counts
voynich_powerlaw <-
voynich_common %>%
extract2( "n" ) %>%
displ$new()

# Estimate the lower bound
voynich_powerlaw_xmin <-
estimate_xmin( voynich_powerlaw )

# Set the parameters of the voynich_powerlaw to the estimated values
voynich_powerlaw$setXmin( voynich_powerlaw_xmin )

# Estimate parameters of the power law distribution
voynich_powerlaw_est <-
estimate_pars( voynich_powerlaw )

# Calculate p-value of power law. See Section 4.2 of "Power-Law Distributions in Empirical Data" by Clauset et al.
# If the p-value is _greater_ than 0.1 then we cannot rule out a power-law distribution.
voynich_powerlaw_bootstrap_p <-
bootstrap_p(voynich_powerlaw, no_of_sims=1000, threads=7 )
# p=0.143 power law cannot be ruled out

# Parameter uncertainty via boostrapping
voynich_powerlaw_bootstrap <-
bootstrap( voynich_powerlaw, no_of_sims=1000, threads=7 )

# Plot data and power law fit
voynich_powerlaw_plot_data <-
plot( voynich_powerlaw, draw = F ) %>%
mutate(
log_x = log( x ),
log_y = log( y ) )

voynich_powerlaw_fit_data <-
lines( voynich_powerlaw, col=2, draw = F ) %>%
mutate(
log_x = log( x ),
log_y = log( y )
)

# Plot the fitted power law data.
gp <-
ggplot( voynich_powerlaw_plot_data ) +
geom_point( aes( x = log( x ), y =log( y ) ), colour="#8a0707" ) +
geom_line( data= voynich_powerlaw_fit_data,
aes(
x = log( x ),
y = log( y ) ), colour="#0b6788") +
labs(
x = "Log Rank",
y = "Log Frequency" )

gp <-
gp +
theme(
panel.background = element_rect(fill = "transparent", colour = "transparent"),
plot.background = element_rect(fill = "transparent", colour = "transparent"),
plot.title = element_text( family="bold_font", colour="#3c3f4a", size=22 ),
plot.subtitle = element_text( family="bold_font", colour="#3c3f4a", size=12 ),
axis.text = element_text( family="bold_font", colour="#3c3f4a", size=12 ),
axis.title.x = element_text( family="bold_font", colour="#3c3f4a", size=12 ),
axis.title.y = element_text( family="bold_font", colour="#3c3f4a", size=12 ),
axis.line = element_line( colour="#3c3f4a" ),
panel.grid.major.x = element_blank(),
panel.grid.major.y = element_blank(),
panel.grid.minor.x = element_blank(),
panel.grid.minor.y = element_blank()
)

# Remove legend from internal plot
theme_set(theme_cowplot(font_size=4, font_family = "main_font" ) )

# Cowplot trick for ggtitle
title <-
ggdraw() +
draw_label(
"Fitted Power Law of Voynich Corpus",
fontfamily="bold_font",
colour = "#3c3f4a",
size=20,
hjust=0, vjust=1,
x=0.02, y=0.88 ) +
draw_label(
"http://www.weirddatascience.net | @WeirdDataSci",
fontfamily="main_font",
colour = "#3c3f4a",
size=12,
hjust=0, vjust=1,
x=0.02, y=0.40 )

data_label <-
ggdraw() +
draw_label(
"Data: http://www.voynich.nu",
fontfamily="main_font",
colour = "#3c3f4a",
size=14, hjust=1,
x=0.98 )

# Combine plots
tgp <-
plot_grid(
title,
gp,
data_label,
ncol=1,
rel_heights=c( 0.1, 1, 0.1 ) )

# Add parchment underlay
parchment_plot <-
ggdraw() +
draw_image("img/parchment.jpg", scale=1.4 ) +
draw_plot(tgp)

save_plot("output/voynich_power_law.pdf",
parchment_plot,
base_width = 16,
base_height = 9,
base_aspect_ratio = 1.78 )
[/code]

Led further down twisting paths by this initial taste of success, we can now present the Voynich corpus against other human-language corpora to gain a faint impression of how similar or different it is to known languages. The following plot compares the frequency of words in the Voynich Manuscript to those of the twenty most popular languages in Wikipedia, taken from the dataset available here.

Voynich Manuscript Rank Frequency Distribution against Wikipedia Corpora

" data-image-caption="

Voynich Manuscript Rank Frequency Distribution against Wikipedia Corpora

" data-medium-file="https://www.weirddatascience.net/wp-content/uploads/2019/10/voynich_wikipedia_plot.png" data-large-file="https://www.weirddatascience.net/wp-content/uploads/2019/10/voynich_wikipedia_plot.png" src="http://www.weirddatascience.net/wp-content/uploads/2019/10/voynich_wikipedia_plot.png" alt="Voynich Manuscript Rank Frequency Distribution against Wikipedia Corpora" width="1920" height="1080" class="size-full wp-image-956" />

Voynich Manuscript Rank Frequency Distribution against Wikipedia Corpora | (PDF Version)

Wikipedia Word Frequency Plot

Data:

Wikipedia Language Corpora: https://www.datos.gov.co/en/Ciencia-Tecnolog-a-e-Innovaci-n/Multilingual-Wikipedia-2015-word-frequencies-32-la/jmxq-gzgh/data

voynich_zipf_wikipedia.r
[code language=”r”]

library( tidyverse )
library( magrittr )

library( ggthemes )
library( showtext )

library( tidytext )
library( drlib )

library(cowplot)
library(magick)

message( "Reading raw Voynich data…" )
voynich_tbl <-
read_csv( "data/voynich_raw.txt", col_names=FALSE ) %>%
rename( folio = X1, text = X2 )

# Tokenize
# (Remove words of 3 letters or less)
# Stemming and stopword removal apparently not so effective anyway,
# according to Schofield et al.:
voynich_words <-
voynich_tbl %>%
unnest_tokens( word, text )

# Plot a log-log plot of Voynich word frequencies.
voynich_word_counts <-
voynich_words %>%
count( word, folio, sort = TRUE )

# Load other languages.
# Select frequency counts.
# Convert to long format, then normalise per-language.
message( "Loading common language statistics…" )
wiki_language <-
read.csv( "data/Multilingual_Wikipedia_2015_word_frequencies__32_languages_X_5_million_words.csv" ) %>%
head( 10000 ) %>%
as_tibble %>%
select( matches( "*_FREQ" ) ) %>%
gather( key = "language", value = "count" ) %>%
mutate( language = str_replace( language, "_FREQ", "" ) ) %>%
group_by( language ) %>%
transmute( freq = count / sum( count ) ) %>%
ungroup

wiki_language_words <-
read.csv( "data/Multilingual_Wikipedia_2015_word_frequencies__32_languages_X_5_million_words.csv" ) %>%
head( 10000 ) %>%
as_tibble

# Combine with Voynich, assigning it the unassigned ISO 3166-1 alpha-2 code "vy"
message( "Combining common and Voynich language statistics…" )
voynich_language <-
voynich_common %>%
transmute( language = "vy", freq = freq )

# Combine, then add per-language rank information
message( "Processing common and Voynich language statistics…" )
all_languages <-
bind_rows( wiki_language, voynich_language ) %>%
mutate( colour = ifelse( str_detect( `language`, "vy" ), "red", "grey" ) ) %>%
group_by( language ) %>%
transmute( log_rank=log( row_number() ), log_freq=log( freq ), colour ) %>%
ungroup

# Plot a log-log plot of all language word frequencies.
message( "Plotting common and Voynich language statistics…" )
voynich_wikipedia_plot <-
all_languages %>%
ggplot( aes( x=log_rank, y=log_freq, colour=colour) ) +
geom_point( alpha=0.4, shape=20 ) +
scale_color_manual( values=c("#3c3f4a", "#8a0707" ) ) +
theme (
axis.title.y = element_text( angle = 90, family="main_font", size=12 ),
axis.text.y = element_text( colour="#3c3f4a", family="main_font", size=12 ),
axis.title.x = element_text( colour="#3c3f4a", family="main_font", size=12 ),
axis.text.x = element_text( colour="#3c3f4a", family="main_font", size=12 ),
axis.line.x = element_line( color = "#3c3f4a" ),
axis.line.y = element_line( color = "#3c3f4a" ),
plot.title = element_blank(),
plot.subtitle = element_blank(),
plot.background = element_rect( fill = "transparent" ),
panel.background = element_rect( fill = "transparent" ) # bg of the panel
) +
#scale_colour_viridis_d( option="cividis", begin=0.4 ) +
guides( colour="none" ) +
labs( y="Log Frequency",
x="Log Rank" )

theme_set(theme_cowplot(font_size=4, font_family = "main_font" ) )

# Cowplot trick for ggtitle
title <- ggdraw() +
draw_label(
"Voynich Manuscript Rank Frequency Distribution against Wikipedia Corpora",
fontfamily="bold_font", colour = "#3c3f4a", size=20,
hjust=0, vjust=1, x=0.02, y=0.88 ) +
draw_label("http://www.weirddatascience.net | @WeirdDataSci",
fontfamily="bold_font", colour = "#3c3f4a", size=12,
hjust=0, vjust=1, x=0.02, y=0.40 )

data_label <-
ggdraw() +
draw_label("Data from: http://www.voynich.nu | http://wikipedia.org",
fontfamily="bold_font", colour = "#3c3f4a", size=12,
hjust=1, x=0.98 )

tgp <-
plot_grid(title, voynich_wikipedia_plot, data_label, ncol=1, rel_heights=c(0.1, 1, 0.1))

voynich_wikipedia_plot <-
ggdraw() +
draw_image("img/parchment.jpg", scale=1.4 ) +
draw_plot(tgp)

save_plot("output/voynich_wikipedia_plot.pdf",
voynich_wikipedia_plot,
base_width = 16,
base_height = 9,
base_aspect_ratio = 1.78 )
[/code]

The Voynich text seems consistent with the behaviour of known natural languages from Wikipedia. The most striking difference being the clustering of Voynich word frequencies in the lower half of the diagram, resulting from the smaller corpus of words in the Voynich Manuscript. This causes, in particular, lower-frequency words to occur an identical number of times, resulting in vertical leaps in the frequency graph towards the lower end.

To highlight this phenomenon, we can apply a similar technique to another widely-translated short text: the United Nations Declaration of Human Rights.

Voynich Manuscript Rank Frequency Distribution against UNDHR Translations

" data-image-caption="

Voynich Manuscript Rank Frequency Distribution against UNDHR Translations

" data-medium-file="https://www.weirddatascience.net/wp-content/uploads/2019/10/voynich_udhr_plot.png" data-large-file="https://www.weirddatascience.net/wp-content/uploads/2019/10/voynich_udhr_plot.png" src="http://www.weirddatascience.net/wp-content/uploads/2019/10/voynich_udhr_plot.png" alt="Voynich Manuscript Rank Frequency Distribution against UNDHR Translations" width="1920" height="1080" class="size-full wp-image-954" />

Voynich Manuscript Rank Frequency Distribution against UNDHR Translations | (PDF Version)

UNDHR Word Frequency Plot

voynich_zipf_udhr.r
[code language=”r”]

library( tidyverse )
library( magrittr )

library( ggthemes )
library( showtext )

library( tidytext )

library(cowplot)
library(magick)

showtext_auto()

message( "Reading raw Voynich data…" )
voynich_tbl <-
read_csv( "data/voynich_raw.txt", col_names=FALSE ) %>%
rename( folio = X1, text = X2 )

voynich_word_counts <-
voynich_words %>%
count( word, folio, sort = TRUE )

# UDHR corpus comparison (smaller text)
udhr_corpus_files <- list.files("data/udhr/udhr_txt", pattern="*.txt", full.names=TRUE )

# Helper function to read in a text file and calculate a frequency tablle
table_frequency_mapper <- function( x ) {

# Read file and extract language code from filename
udhr_text <- read_lines( x, skip=6, skip_empty_rows=TRUE )
language <- basename( x ) %>% str_replace( "udhr_", "" ) %>% str_replace( ".txt", "" )

# Tokenize and remove punctuation
udhr_words <-
udhr_text %>%
str_flatten %>%
str_remove_all( "[.,]" ) %>%
str_split( "\\s+" ) %>%
extract2( 1 ) %>%
{ tibble( word=. ) }

# Most common words
udhr_common <-
udhr_words %>%
count( word, sort=TRUE ) %>%
mutate( word = reorder( word, n ), language )

}

voynich_corpus <-
voynich_language %>%
transmute( language, log_rank=log( row_number() ), log_freq=log( freq ), colour="Voynich Text" )

udhr_corpus <-
udhr_corpus_files %>%
map( table_frequency_mapper ) %>%
bind_rows %>%
group_by( language ) %>%
transmute( log_rank=log( row_number() ), log_freq=log( n / sum(n) ), colour="Known UDHR Language" ) %>%
ungroup

voynich_udhr_corpus <-
bind_rows( udhr_corpus, voynich_corpus )

voynich_udhr_frequency_plot <-
voynich_udhr_corpus %>%
ggplot( aes( x=log_rank, y=log_freq, colour=colour) ) +
geom_point( alpha=0.4, shape=19 ) +
scale_color_manual( values=c( "Known UDHR Language" = "#3c3f4a", "Voynich Text" = "#8a0707" ) ) +
theme (
axis.title.y = element_text( angle = 90, family="main_font", size=12 ),
axis.text.y = element_text( colour="#3c3f4a", family="main_font", size=12 ),
axis.title.x = element_text( colour="#3c3f4a", family="main_font", size=12 ),
axis.text.x = element_text( colour="#3c3f4a", family="main_font", size=12 ),
axis.line.x = element_line( color = "#3c3f4a" ),
axis.line.y = element_line( color = "#3c3f4a" ),
plot.title = element_blank(),
plot.subtitle = element_blank(),
plot.background = element_rect( fill = "transparent" ),
panel.background = element_rect( fill = "transparent" ), # bg of the panel
panel.grid.major.x = element_blank(),
panel.grid.major.y = element_blank(),
panel.grid.minor.x = element_blank(),
panel.grid.minor.y = element_blank(),
legend.text = element_text( family="bold_font", colour="#3c3f4a", size=10 ),
legend.title = element_blank(),
legend.key.height = unit(1.2, "lines"),
legend.position=c(.85,.5)
) +
labs( y="Log Frequency",
x="Log Rank" )

theme_set(theme_cowplot(font_size=4, font_family = "main_font" ) )

# Cowplot trick for ggtitle
title <-
ggdraw() +
draw_label("Voynich Manuscript Rank Frequency Distribution against UNDHR Translations", fontfamily="bold_font", colour = "#3c3f4a", size=20, hjust=0, vjust=1, x=0.02, y=0.88) +
draw_label("http://www.weirddatascience.net | @WeirdDataSci", fontfamily="bold_font", colour = "#3c3f4a", size=12, hjust=0, vjust=1, x=0.02, y=0.40)

data_label <-
ggdraw() +
draw_label("Data from: http://www.voynich.nu | http://unicode.org/udhr/", fontfamily="bold_font", colour = "#3c3f4a", size=12, hjust=1, x=0.98 )

tgp <-
plot_grid(title, voynich_udhr_frequency_plot, data_label, ncol=1, rel_heights=c(0.1, 1, 0.1))

voynich_udhr_plot <-
ggdraw() +
draw_image("img/parchment.jpg", scale=1.4 ) +
draw_plot(tgp)

save_plot("output/voynich_udhr_plot.pdf",
voynich_udhr_plot,
base_width = 16,
base_height = 9,
base_aspect_ratio = 1.78 )

[/code]

A Refined Randomness

The above arguments might at first appear compelling. The surface incomprehensibility of the Voynich Manuscript succumbs to the deep currents of statistical laws, and reveals an underlying pattern amongst the chaos of the text.

Sadly, however, as with all too many arguments in the literature regarding power law distributions arising in nature, there is a complication to this argument that again highlights the difference between proof and the failure to disprove. Certainly, if a power law had proved incompatible with the Voynich Manuscript then we would have doubted its authenticity. With its apparent adherence to such a distribution, however, we have taken only one hesitant step towards confidence.

Rugg has argued that certain random mechanisms can produce text that adheres to Zipf’s Law, and has demonstrated a simple mechanical procedure for doing so. A more compelling argument is presented, without reference to the Voynich Manuscript, by Li. (1992)⁹, who demonstrates that a text drawn entirely at random from any given alphabet of symbols that includes a space will result in a text adhering to some form of Zipf-like distribution. We cannot hang our confidence on such a slender thread.

Shifted Parameters

While Zipf’s Law has been shown to hold for human language text, and a text that does not demonstrate it is certainly suspect, it is far from being the only telltale statistical property of natural language. We have already briefly examined sequences of repeated words in the text; we will now delve further.

Another curious distortion of human languages is that they demonstrate a preference for shorter words. The precise mechanism that results in this apparently universal property is unclear, but likely relates somehow to efficiency of communication. Regardless of the deeper causality, in most natural language texts there is a markedly higher frequency of short words than longer words.

As demonstrated by Sigurd, Eeg-Olofsson, and van Weijer, (2004)¹⁰, however, the very shortest words are not the most common. Instead, at least for English, Swedish, and German, words between 3 and 5 letters in length dominate. This property can be accurately modelled by an appropriately parameterised Gamma distribution.

Notably, and conveniently, this property will not hold for random texts as described above. These purely stochastic texts would be expected to produce, in the long term, a monotonically-decreasing function as word length increases.

To demonstrate this effect, we can simulate a purely random text along the lines discussed by Li, and show its correspondingly naïve descending plot.

Word-Length Frequency Plot of Randomly-Generated Text

" data-image-caption="

Word-Length Frequency Plot of Randomly-Generated Text

" data-medium-file="https://www.weirddatascience.net/wp-content/uploads/2019/10/random_length_frequency_plot.png" data-large-file="https://www.weirddatascience.net/wp-content/uploads/2019/10/random_length_frequency_plot.png" src="http://www.weirddatascience.net/wp-content/uploads/2019/10/random_length_frequency_plot.png" alt="Word-Length Frequency Plot of Randomly-Generated Text" width="1920" height="1080" class="size-full wp-image-949" />

Word-Length Frequency Plot of Randomly-Generated Text | (PDF Version)

Word-Length Frequency Plot of Randomly Generated Text

random_text_frequencies.r
[code language=”r”]

library( ggplot2 )
library( tidyverse )
library( magrittr )

library( cowplot )

library( showtext )

library( tidytext )

showtext_auto()

# Vector of symbols (letters) from which to sample.
# Note that a blank space is included as a symbol.
symbol_vector <-
c(
"a","b","c","d","e","f","g","h","i",
"j","k","l","m","n","o","p","q","r",
"s","t","u","v","w","x","y","z"," " )

# Create a corpus of the same number of symbols as our transcription
# of the Voynich Manuscript
random_corpus <-
sample( symbol_vector, size = 16777216, replace = TRUE ) %>%
paste( collapse="" ) %>%
enframe( name=NULL ) %>%
unnest_tokens( word, value )

# Most common words
message( "Calculating word-length frequency statistics…" )
random_length_freq <-
random_corpus %>%
mutate( length = str_length( word ) ) %>%
count( length ) %>%
mutate( freq = n / sum(n) )

# Identify the lengths of words individually as a vector for distribution fitting
random_lengths <-
random_corpus %>%
mutate( length = str_length( word ) ) %>%
extract2( "length" )

# Plot length frequency curve.
gp <-
ggplot( random_length_freq, aes( x = length, y = freq ) ) +
geom_line( colour="#8a0707" ) +
geom_text( colour="#8a0707", label="\u2720", family = "unicode_font", size=4 ) +
labs(
x = "Word Length",
y = "Frequency" )

# Theme plot
gp <-
gp +
theme(
panel.background = element_rect(fill = "transparent", colour = "transparent"),
plot.background = element_rect(fill = "transparent", colour = "transparent"),
plot.title = element_text( family="bold_font", colour="#3c3f4a", size=22 ),
plot.subtitle = element_text( family="bold_font", colour="#3c3f4a", size=12 ),
axis.text = element_text( family="bold_font", colour="#3c3f4a", size=12 ),
axis.title.x = element_text( family="bold_font", colour="#3c3f4a", size=12 ),
axis.title.y = element_text( family="bold_font", colour="#3c3f4a", size=12 ),
axis.line = element_line( colour="#3c3f4a" ),
panel.grid.major.x = element_blank(),
panel.grid.major.y = element_blank(),
panel.grid.minor.x = element_blank(),
panel.grid.minor.y = element_blank()
)

# Remove legend from internal plot
theme_set(theme_cowplot(font_size=4, font_family = "main_font" ) )

# Cowplot trick for ggtitle
title <-
ggdraw() +
draw_label(
"Word Length Frequency Plot of Random Corpus",
fontfamily="bold_font",
colour = "#3c3f4a",
size=20,
hjust=0, vjust=1,
x=0.02, y=0.88 ) +
draw_label(
"http://www.weirddatascience.net | @WeirdDataSci",
fontfamily="main_font",
colour = "#3c3f4a",
size=12,
hjust=0, vjust=1,
x=0.02, y=0.40 )

# Combine plots
tgp <-
plot_grid(
title,
gp,
ncol=1,
rel_heights=c( 0.1, 1 ) )

# Add parchment underlay
parchment_plot <-
ggdraw() +
draw_image("img/parchment.jpg", scale=1.4 ) +
draw_plot(tgp)

save_plot("output/random_length_frequency_plot.pdf",
parchment_plot,
base_width = 16,
base_height = 9,
base_aspect_ratio = 1.78 )

[/code]

As can be seen, the word-length frequency of this random text forms a comfortingly simple exponential curve, with pseudo-words of one letter being by far the most common. It is also notable that, at the far reaches of the probability distribution, this cacophonous experiment will produce words of almost four-hundred letters in length. While adherence to Zipf’s Law would have misled us into supporting this as an apparently natural language, even a cursory glance at this plot would have convinced us otherwise.

How, then, does the Voynich Manuscript adhere to the expected Gamma distribution of Sigurd et al.? We can employ the excellent fitdistrplus package to peel back this particular veil.

Voynich Word-Length Frequency with Fitted Gamma Distribution

" data-image-caption="

Voynich Word-Length Frequency with Fitted Gamma Distribution

" data-medium-file="https://www.weirddatascience.net/wp-content/uploads/2019/10/voynich_length_frequency_plot.png" data-large-file="https://www.weirddatascience.net/wp-content/uploads/2019/10/voynich_length_frequency_plot.png" src="http://www.weirddatascience.net/wp-content/uploads/2019/10/voynich_length_frequency_plot.png" alt="Voynich Word-Length Frequency with Fitted Gamma Distribution" width="1920" height="1080" class="size-full wp-image-951" />

Voynich Word-Length Frequency with Fitted Gamma Distribution | (PDF Version)

The word-length frequency distribution of the Voynich Manuscript clearly demonstrates a preference for four-letter words, not only breaking free of the confines of pure randomness, but also corresponding broadly with observed frequency patterns of the languages tested by Sigurd et al.

Fitting Gamma distribution to Voynich Manuscript corpus

voynich_gamma.r
[code language=”r”]

library( tidyverse )
library( magrittr )

library( ggthemes )
library( showtext )

library( tidytext )

library( fitdistrplus )

library(cowplot)
library(magick)

# References:
#
# https://en.wikipedia.org/wiki/Gamma_distribution

showtext_auto()

message( "Reading raw Voynich data…" )
voynich_tbl <-
read_csv( "data/voynich_raw.txt", col_names=FALSE ) %>%
rename( folio = X1, text = X2 )

# Tokenize
voynich_words <-
voynich_tbl %>%
unnest_tokens( word, text )

# Most common words
message( "Calculating Voynich language word-length frequency statistics…" )
voynich_length_freq <-
voynich_words %>%
mutate( length = str_length( word ) ) %>%
count( length ) %>%
mutate( freq = n / sum(n) )

# Identify the lengths of words individually as a vector for distribution fitting
voynich_lengths <-
voynich_words %>%
mutate( length = str_length( word ) ) %>%
extract2( "length" )

# Fit a gamma distribution to the observed frequencies

# Extract frequency counts for lengths
gamma_fit <-
fitdist( voynich_lengths, "gamma" )

# Plot length frequency curve.
gp <-
ggplot( voynich_length_freq, aes( x = length, y = freq ) ) +
geom_line( aes( colour="Voynich" ) ) +
geom_text( colour="#8a0707", label="\u2720", family = "unicode_font", size=6 ) +
labs(
x = "Word Length",
y = "Frequency" )

# Overlay fitted gamma distribution
gp <-
gp +
stat_function(
fun=dgamma,
args=list(
shape = gamma_fit$estimate["shape"],
rate = gamma_fit$estimate["rate"] ),
aes( colour = "Fitted Gamma" ) )

# Label gamma line and original data.
# (The ‘breaks’ argument to scale_colour_manual reorders the lines manually,
# otherwise they will be ordered alphabetically. This is useful for combined
# plots where there isn’t a colour factor variable that can be reordered.)
gp <-
gp +
scale_colour_manual(
values = c("Fitted Gamma" = "#0b6788", "Voynich" = "#8a0707" ),
breaks = c("Voynich", "Fitted Gamma" )
)

gp <-
gp +
theme(
panel.background = element_rect(fill = "transparent", colour = "transparent"),
plot.background = element_rect(fill = "transparent", colour = "transparent"),
plot.title = element_text( family="bold_font", colour="#3c3f4a", size=22 ),
plot.subtitle = element_text( family="bold_font", colour="#3c3f4a", size=12 ),
axis.text = element_text( family="bold_font", colour="#3c3f4a", size=12 ),
axis.title.x = element_text( family="bold_font", colour="#3c3f4a", size=12 ),
axis.title.y = element_text( family="bold_font", colour="#3c3f4a", size=12 ),
axis.line = element_line( colour="#3c3f4a" ),
legend.text = element_text( family="bold_font", colour="#3c3f4a", size=10 ),
legend.title = element_blank(),
legend.position=c(.85,.5),
legend.key.width = unit(1.6, "lines"),
legend.key.height = unit(1.2, "lines"),
panel.grid.major.x = element_blank(),
panel.grid.major.y = element_blank(),
panel.grid.minor.x = element_blank(),
panel.grid.minor.y = element_blank()
)

# Remove legend from internal plot
theme_set(theme_cowplot(font_size=4, font_family = "main_font" ) )

# Cowplot trick for ggtitle
title <-
ggdraw() +
draw_label(
"Word Length Frequency Plot of Voynich Corpus",
fontfamily="bold_font",
colour = "#3c3f4a",
size=20,
hjust=0, vjust=1,
x=0.02, y=0.88 ) +
draw_label(
"http://www.weirddatascience.net | @WeirdDataSci",
fontfamily="main_font",
colour = "#3c3f4a",
size=12,
hjust=0, vjust=1,
x=0.02, y=0.40 )

data_label <-
ggdraw() +
draw_label(
"Data: http://www.voynich.nu",
fontfamily="main_font",
colour = "#3c3f4a",
size=14, hjust=1,
x=0.98 )

# Combine plots
tgp <-
plot_grid(
title,
gp,
data_label,
ncol=1,
rel_heights=c( 0.1, 1, 0.1 ) )

# Add parchment underlay
parchment_plot <-
ggdraw() +
draw_image("img/parchment.jpg", scale=1.4 ) +
draw_plot(tgp)

save_plot("output/voynich_length_frequency_plot.pdf",
parchment_plot,
base_width = 16,
base_height = 9,
base_aspect_ratio = 1.78 )

[/code]

Twisting Paths

These analyses can only present a dim outline of the text itself, and we resist the awful temptation to attempt any form of decipherment. Certainly, the evidence here seems convincing enough that the Voynich Manuscript does represent a human language, but the statistics presented here are of little use in such an effort. It is likely, of course, that the most frequent words in the manuscript may, under certain assumptions, correspond to the most common words or particles in many languages — the definite article, the indefinite article, conjunctions, pronouns, and similar. Without deeper knowledge of the language, however, and with the range of scribing conventions and shortcuts commonplace in texts of the period, these techniques are too limited to do more than tantalise us with what we may never know.

Credible Conclusions

Subjecting the text of the Voynich Manuscript to the crude frequency analyses presented here can support, although not prove, the view that the manuscript, regardless of its true content, is not simply random gibberish. Nor is the text likely to be the result of a simple mechanical process designed without knowledge of the statistical patterns of human languages. Neither is it likely to be any form of cryptogram more sophisticated than the simplest ciphers, as these would have tended to compromise the statistical properties that we have observed.

The demonstrable following of Zipf’s Law, and the adherence to a Gamma distribution of similar shape to known languages, strongly suggests that the text is likely a representation of some natural language.

In the next post we will attempt blindly to wrench more secrets from the text itself through application of modern textual analysis techniques. Until then the Voynich Manuscript remains, silently obscure, beyond the reach of our faltering science.

Footnotes

Illuminating the Illuminated Part One: A First Look at the Voynich Manuscript

moth — Thu, 26 Sep 2019 20:15:16 +0000

The Voynich Manuscript

While the world abounds with strange phenomena ripe for analysis in their raw state, there is a peculiar pleasure in scrutinising arcane information curated and obscured by the human mind.

The Voynich Manuscript is one of the most well-known and studied volumes of occult knowledge. The book’s most recent history involves its purchase in 1912 by Wilfrid Voynich, a rare book dealer, from a sale of manuscripts by the Society of Jesus at the Villa Mondragone, Frascati. Following several fruitless years of attempts to decipher the manusript and discover its origin, or to interest others in it, Wilfrid Voynich died. The book passed through a number of other hands before being donated to Yale University by the noted rare book dealer Hans P. Kraus in 1969. It now resides in Yale’s Beinecke Rare Book and Manuscript Library with the designation MS 408.

Written almost entirely in an unknown script, barring a small number of words apparently in Latin and High German, the manuscript is compellingly illustrated with depictions of plants, herbs, human figures, astronomical and astrological symbols. The manuscript has resisted all attempts at interpretation by cryptographers, historians, and linguists.

Voynich Manuscript – Folio 178

" data-image-caption="

Voynich Manuscript – Folio 178

" data-medium-file="https://www.weirddatascience.net/wp-content/uploads/2019/09/voynich_folio_178.jpg" data-large-file="https://www.weirddatascience.net/wp-content/uploads/2019/09/voynich_folio_178.jpg" src="http://www.weirddatascience.net/wp-content/uploads/2019/09/voynich_folio_178.jpg" alt="Voynich Manuscript Folio 178" width="7486" height="3715" class="size-full wp-image-910" />

Voynich Manuscript – Folio 178

From a linguistic and cryptographic perspective, this lack of success in interpretation is not surprising. The two-hundred or so folios of the manuscript, while beautifully illuminated, present a sadly limited corpus of text for the purposes of traditional analysis.

In this short series of posts we will subject the Voynich Manuscript to a range of text analysis techniques, delving into its structure, gain horrific insight into its composition, and skeptically assessing its credibility. The manuscript has been subjected to almost fifty years of furtive attempts by cryptographers, including the US National Security Agency and a menagerie of others from the distinguished to the deranged. We will crudely mimic some earlier results, and hopefully add our own confusion to the roiling mass of current research into the Voynich Manuscript.

Authenticity

Since its discovery, and throughout the ongoing unsuccessful attempts to decipher its contents, many have questioned the authenticity of the Voynich Manuscript. The theory that the entire book is a hoax, either by contemporary scribes or by more modern players, has been raised repeatedly over the years.

Radiocarbon dating in 2010 asserted that the manuscript’s parchment likely dates from the early 15th century; the volume of parchment in the manuscript, and its consistency across the document, make it unlikely, although not impossible, that the book is a modern-day hoax.

Other supporting evidence has drawn from early mentions of the manuscript in correspondence. According to http://www.voynich.nu, which presents a far more detailed and thorough description of the research around the manuscript and its history than we could hope to offer here, the first extant mention of the manuscript can be found in a 1639 letter from Athanasius Kircher in Rome, replying to a letter forwarded from Georgius Barschius of Prague by the mathematician Theodor Moretus.

The letter refers to a “book of mysterious steganography” (“libellum… …steganographici mysterisi”) illustrated with pictures of plants, stars and chemical secrets that Kirscher had not yet had time to decipher. Barschius had sought out Kirscher’s expertise due to his fame at the time for claiming to have, erroneously as it later transpired, deciphered the hieroglyphic writing system of the Ancient Egyptian language. Later correspondence between Barschius and Kirscher appears, according to Zandbergen¹¹, to suggest strongly that the mysterious book in question is the Voynich Manuscript based on its description.

A Statistical Argument: Zipf’s Law

We now turn from historical sources to darker, more statistical realms. There is compelling support for the notion that, regardless of the true meaning of the book, its contents are drawn from a human language and are neither random symbols nor any form of sophisticated cipher.

One of the pillars of this argument is that certain statistical properties of the Voynich Manuscripts text strongly resemble those of natural, human languages, and which are unlikely, although not impossible, to arise from random text, artificially generated text, or most forms of encipherment.

The most well-known of these statistical properties is the apparent adherence of the manuscript to Zipf’s Law. This law, made famous by the US linguist George Zipf, observes that in corpora of natural languages, the frequency of a word is inversely proportional to its rank when words from a corpus are ordered by frequency. More plainly: the most common word in a language is likely to be n times more common than the second most common word; the second word will be roughly n times more common than the third word, and so on. Whilst merely an approximation, this law can be seen to hold for most human languages, and for a range of other natural phenomena.

Random gibberish, on the other hand, would most likely not follow Zipf’s Law, although carefully crafted gibberish certainly could. Rugg has demonstrated that a simple mechanical procedure can produce randomised text that adhered to Zipf’s Law, although the example he provides is both somewhat contrived and also presupposes a knowledge of this statistical quirk of human languages in the first place. Given that the physical makeup of the Voynich Manuscript dates to the early 15th Century, some four centuries before Zipf popularised this mathematical assessment of human languages, the argument that it is a contemporary act of calligraphic glossolalia seems strained.

Similarly, most forms of cryptography beyond the simplest substitution ciphers would also skew the text away from Zipf’s Law. It is notable that the Voynich Manuscript predates even works such as Trithemius‘s Steganographia, or the Book of Soyga and its magic tables of letters that so obsessed John Dee.

In contrast, however, it has been claimed that other features of the text raise doubts. One of the most commonly stated counter-arguments to the natural hypothesis of the Voynich text is that some words are repeated an unnatural number of times. Depending on the transcription, individual words have been reported to be repeated up to five times. Whilst this is not an impossible occurrence in human lanugage, it is highly irregular.

The next post in this short series will focus on the Voynich Manuscript’s adherence, or lack thereof, to Zipf’s Law in full. Following that, we will see the extent to which other forms of modern textual analysis can be applied to dissect the arcane and unrelenting secrets of MS 408.

This post, however, will describe the contortions required to render the Voynich text suitable for our particular form of scrutiny.

Assumptions

Given the format and presentation of the text, we make several assumptions about the writing system contained in the Voynich Manuscript:

It is written in an alphabet, or potentially an abjad or even an abugida¹², and not a logographic system. That the text is not logographic is justified by the small number of individual symbols. The distinction between the other systems is sufficiently subtle that it will not affect our analyses¹³.
The manuscript is written from left to right, and not the reverse, vertically, boustrophedon. This is uncontroversial and apparent from even a cursory inspection of the text itself; the horizontal flow of the writing is clear, with lines clearly starting at the left margin and ending before the right. The text is separated into paragraphs, of which the final line is justified to the left.

Data

Due to the diligent activity of several generations of Voynich researchers, the text of the manuscript has been transcribed into a machine-readable format. As the alphabet is unknown, there are minor uncertainties in rendering the text, leading to a number of similar but competing transcriptions. The subtle details of the various transcription efforts, and their history, are available at: http://www.voynich.nu/transcr.html, with the raw data available at http://www.voynich.nu/data/. We have settled on the v101 transliteration by Glen Claston, rendered in the Intermediate Voynich Transliteration File Format (IVTFF) of Zandbergen. This is one of the more recent and widely-used transcriptions, and has the added advantage of being supported by the availability of a TrueType font. The underlying file is available here: http://www.voynich.nu/data/GC_ivtff_s.txt.

Crude Manipulations

We perform the following steps to make the data usable for our analyses. For many scenarios, we would develop a generalisable set of steps to allow conversion of many documents to an appropriate form. Until and unless, however, a new cache of documents in the same language are found, it is simpler and easier to perform these one-time steps manually.

Firstly, we delete from the text all incomplete words, as marked in the IVTFF format. This includes:

all text in angle brackets
all words containing ?’s
all words containing []

Secondly, we tokenize the text and remove punctuation. The transcription of the Voynich manuscript that we have chosen uses the following punctuation:

“.” is a space
“,” is a potential space. For simplicity, we do not treat these as a space.

Finally, we organize the document in an appropriate form to be imported into an R data frame, or tidyverse tibble.

The above steps were performed in the Vim text editor, and the commands used are reproduced in the code below:

Show Vim text manipulation commands.

[code]

# Delete all commented lines
:\%g/\^\#.\*/d

# Remove blank lines
:\%g/\^\$/d

# Remove "," — assume that potential spaces are /not/ spaces.
:\%s/,//g

# Replace each folio’s page marker (initial for each page)
# with its contents, followed by a comma. ( -\> f1r,)
:\%s/\^\s*\<.{-}\>\$/\rfRos,/
:\%s/\^\<(f\[0-9\]*\[r\|v\]\[0-9\]*)\>\s*\<.{-}\>\$/\r\1,/

# Remove all \<\> entries (non-greedy)
:\%s/\<.{-}\>\s*//g

# Join all paragraphs (all newlines followed by a character
# other than a newline are removed).
:\%s/\n(\[\^\\n\])/.\\1/
:\%s/\^.f/f/
:\%s/,./,/

# Replace "high ascii" rare characters from the IVTFF with their
# ASCII representation. ()
:\%s/@(\[0-9\]{-});/=nr2char(submatch(1))/g

# Replace full stops with spaces
:\%s/./ /g

[/code]

The resulting raw data file is available here. This file can be read into R simply by use of the read.csv function:

voynich_tbl <- 
	read_csv( "data/voynich_raw.txt", col_names=FALSE ) %>%
	rename( folio = X1, text = X2 )

As a first, horrifying glance into the forms of analysis that this allows, we can now use our raw data to identify the most repeated words in the manuscript, according to our transcription. The following R code extracts the entirety of the text and encodes it as a run length encoding. This conveniently results in a sequential list of words and the number of times that each is repeated in sequence. We can then simply extract the largest number of repetitions for each word in the corpus:

Count longest word repetition sequences in the Voynich Manuscript.

[code language=”r”]

library( tidyverse )
library( magrittr )

# Count the number of repeated words in the Voynich Manuscript text.

# Load the raw data
voynich_tbl <-
read_csv( "data/voynich_raw.txt", col_names=FALSE ) %>%
rename( folio = X1, text = X2 )

# Extract the text as a vector of words
voynich_vector <-
voynich_tbl %>%
extract2( "text" ) %>%
paste( sep=" ", collapse=" " ) %>%
str_split( " " ) %>%
unlist

# Create a run length encoding object from the vector
voynich_rle <-
voynich_vector %>%
rle

# Convert rle object to a data frame and report the maximum number of repeated
# cases for each word
voynich_repetitions <-
voynich_rle %>%
unclass %>%
as.data.frame %>%
group_by( values ) %>%
summarise( max_repetitions = max( lengths ) ) %>%
ungroup %>%
arrange( desc( max_repetitions ) )

[/code]

This simple analysis shows that, in the transcription we have chosen, the longest sequences of repeated words are only three words in length, occuring a total of five times in the text. While there are many other arguments against the potential validity of the Voynich Manuscript, word repetition does in itself present a compelling reason to doubt that the text is a human language.

We have now reduced the strange and beautiful elegance of the Voynich Manuscript’s centuries-old illuminations to a crude, utilitarian abstraction. With this particular act of artistic and literary desecration complete, in the next post we will examine Zipf’s Law in more detail, and interrogate the extent to which this law supports or undermines the text’s authenticity.

Footnotes

Bayes vs. the Invaders! Part Four: Convergence

moth — Sun, 28 Apr 2019 08:38:43 +0000

Sealed and Buried

In the previous three posts¹⁴ in our series delving into the cosmic horror of UFO sightings in the US, we have descended from the deceptively warm and sunlit waters of basic linear regression, through the increasingly frigid, stygian depths of Bayesian inference, generalised linear models, and the probabilistic programming language Stan.

In this final post we will explore the implications of the murky realms in which we find ourselves, and consider the awful choices that have led us to this point. We will therefore look, with merciful brevity, at the foul truth revealed by our models, but also consider the arcane philosophies that lie sleeping beneath.

Deviant Interpretations

Our crazed wanderings through dark statistical realms have led us eventually to a varying slope, varying intercept negative binomial generalised linear model, whose selection was justified over its simpler cousins via leave-one-out cross-validation (LOO-CV). By interrogating the range of hyperparameters of this model, we could reproduce an alluringly satisfying visual display of the posterior predictive distribution across the United States:

Varying intercept and slope negative binomial GLM of UFO sightings against population.

Varying intercept and slope negative binomial GLM of UFO sightings against population. (PDF Version)

Further, our model provides us with insight into the individual per-state intercept $\alpha$ and slope $\beta$ parameters of the underlying linear model, demonstrating that there is variation between the rate of sightings in US states that cannot be accounted for by their ostensibly human population.

Varying slope and intercept negative binomial GLM parameter plot.

Varying slope and intercept negative binomial GLM parameter plot for UFO sightings model. (PDF Version)

Interpreting these parameters, however, is not as quite as simple as in a basic linear model¹⁵. Most importantly our negative binomial GLM employs a log link function to relate the linear model to the data:

$$\begin{eqnarray}
y &\sim& \mathbf{NegBinomial}(\mu, \phi)\\
\log(\mu) &=& \alpha + \beta x\\
\alpha &\sim& \mathcal{N}(0, 1)\\
\beta &\sim& \mathcal{N}(0, 1)\\
\phi &\sim& \mathbf{HalfCauchy}(2)
\end{eqnarray}$$

In a basic linear regression, $y=\alpha+\beta x$, the $\alpha$ parameter can be interpreted as the value of $y$ when $x$ is 0. Increasing the value of $x$ by 1 results in a change in the $y$ value of $\beta$. We have, however, been drawn far beyond such naive certainties.

The $\alpha$ and $\beta$ coefficients in our negative binomial GLM produce the $\log$ of the $y$ value: the mean of the negative binomial in our parameterisation.

With a simple rearrangement, we can being to understand the grim effects of this transformation:

$$\begin{array}
_ & \log(\mu) &=& \alpha + \beta x\\
\Rightarrow &\mu &=& \operatorname{e}^{\alpha + \beta x}\\
\end{array}$$

If we set $x=0$:

$$\begin{eqnarray}
\mu_0 &=& \operatorname{e}^{\alpha}
\end{eqnarray}$$

The mean of the negative binomial when $x$ is 0 is therefore $\operatorname{e}^{\alpha}$. If we increase the value of $x$ by 1:

$$\begin{eqnarray}
\mu_1 &=& \operatorname{e}^{\alpha + \beta}\\
&=& \operatorname{e}^{\alpha} \operatorname{e}^{\beta}
\end{eqnarray}$$

Which, if we recall the definition of the underlying mean of our model’s negative binomial, $\mu_0$, above, is:
$$\mu_0 \operatorname{e}^{\beta}$$

The effect of an increase in $x$ is therefore multiplicative with a log link: each increase of $x$ by 1 causes the mean of the negative binomial to be further multiplied by $\operatorname{e}^{\beta}$.

Despite this insidious complexity, in many senses our naive interpretation of these values still holds true. A higher value for the $\beta$ coefficient does mean that the rate of sightings increases more swiftly with population.

With the full, unsettling panoply of US States laid out before us, any attempt to elucidate their many and varied deviations would be overwhelming. Broadly, we can see that both slope and intercepts are generally restricted to a fairly close range, with the 50% and 95% credible intervals notably overlapping in many cases. Despite this, there are certain unavoidable abnormalities from which we cannot, must not, shrink:

Only Pennsylvania presents a slope ($\beta$) parameter that could be considered as potentially zero, if we consider its 95% credible interval. The correlation between population and number of sightings is otherwise unambiguously positive.
Delaware, whilst presenting a wide credible interval for its slope ($\beta$) parameter, stands out as suffering from the greatest rate of change in sightings as its population increases.
Both California and Utah, present suspiciously narrow credible intervals on their slope ($\beta$) parameters. The growth in sightings as the population increases therefore demonstrates a worrying consistency although, in both cases, this rate is amongst the lowest of all the states.

We can conclude, then, that while the total number of sightings in Delaware are currently low, any increase in numbers of residents there appears to possess a strange fascination for visitors from beyond the inky blackness of space. By contrast, whilst our alien observers have devoted significant resources to monitoring Utah and California, their apparent willingness to devote further effort to tracking those states’ burgeoning populations is low.

Trembling Uncertainty

One of the fundamental elements of the Bayesian approach is its willing embrace of uncertainty. The output of our eldritch inferential processes are not point estimates of the outcome, as in certain other approaches, but instead posterior predictive distributions for those outcomes. As such, if when we turn our minds to predicting new outcomes based on previously unseen data, our outcome is a distribution over possible values rather than a single estimate. Thus, at the dark heart of Bayesian inference is a belief in the truth that all uncertainty be quantified as probability distributions.

The Bayesian approach as inculcated here has a predictive bent to it. These intricate methods lend themselves to forecasting a distribution of possibilities before the future unveils itself. Here, we gain a horrifying glimpse into the emerging occurrence of alien visitations to the US as its people busy themselves about their various concerns, scrutinised and studied, perhaps almost as narrowly as a man with a microscope might scrutinise the transient creatures that swarm and multiply in a drop of water.

Unavoidable Choices

The twisted reasoning underlying this series of posts has been not only in indoctrinating others into the hideous formalities of Bayesian inference, probabilistic programming, and the arcane subtleties of the Stan programming language; but also as an exercise in exposing our own minds to their horrors. As such, there is a tentative method to the madness of some of the choices made in this series that we will now elucidate.

Perhaps the most jarring choice has been to code these models in Stan directly, rather than using one of the excellent helper libraries that allow for more concise generation of the underlying Stan code. Both brms and rstanarm possess the capacity to spawn models such as ours with greater simplicity of specification and efficiency of output, due to a number of arcane tricks. As an exercise in internalising such forbidden knowledge, however, it is useful to address reality unshielded by such swaddling conveniences.

In fabricating models for more practical reasons, however, we would naturally turn to these tools unless our unspeakable demands go beyond their natural scope. As a personal choice, brms is appealing due to its more natural construction of readable per-model Stan code to be compiled. This allows for the grotesque internals of generated models to be inspected and, if required, twisted to whatever form we desire. rstanarm, by contrast, avoids per-model compilation by pre-compiling more generically applicable models, but its underlying Stan code is correspondingly more arcane for an unskilled neophyte.

The Stan models presented in previous posts have also been constructed as simply as possible and have avoided all but the most universally accepted tricks for improving speed and stability¹⁶. Most notably, Stan presents specific functions for GLMs based on the Poisson and negative binomial distributions that apply standard link functions directly. As mentioned, we consider it more useful for personal and public indoctrination to use the basic, albeit log-form parameterisations.

Last Rites

In concluding the dark descent of this series of posts on Bayesian inference, generalised linear models, and the unearthly effects of extraterrestrial visitions on humanity, we have applied numerous esoteric techniques to identify, describe, and quantify the relationship between human population and UFO sightings. The enigmatic model constructed throughout this and the previous three entries darkly implies that, while the rate of inexplicable aerial phenomena is inextricably and positively linked to humanity’s unchecked growth, there are nonetheless unseen factors that draw our non-terrestrial visitors to certain populations more than others, and that their focus and attention is ever more acute.

This series has inevitably fallen short of a full and meaningful elucidation of the techniques of Bayesian inference and Stan. From this first step on such a path, then, interested students of the bizarre and arcane would be well advised to draw on the following esoteric resources:

Until then, watch the skies and archive your data.

Footnotes

Bayes vs. the Invaders! Part Three: The Parallax View

moth — Wed, 17 Apr 2019 13:35:56 +0000

The Parallax View

In the previous post of this series unveiling the relationship between UFO sightings and population, we crossed the threshold of normality underpinning linear models to construct a generalised linear model based on the more theoretically satisfying Poisson distribution.

On inspection, however, this model revealed itself to be less well suited to the data than we had, in our tragic ignorance, hoped. While it appeared, on visual inspection, to capture some features of the data, the predictive posterior density plot demonstrated that it still fell short of addressing the subtleties of the original.

In this post, we will seek to overcome this sad lack in two ways: firstly, we will subject our models to pitiless mathematical scrutiny to assess their ability to describe the data. With our eyes irrevocably opened to these techniques, we will construct an ever more complex armillary with which to approach the unknowable truth.

Critical Omissions of Information

Our previous post showed the different fit of the Poisson model to the data from the simple Gaussian linear model. When presented with a grim array of potential simulacra, however, it is crucial to have reliable and quantitative mechanisms to select amongst them.

The eldritch procedure most suited to this purpose, model selection, in our framework, draws on information criteria that express the relative effectiveness of models at creating sad mockeries of the original data. The original and most well-known such criterion is the Akaike Information Criterion, which has, in turn, spawned a multitude of successors applicable in different situations and with different properties. Here, we will make use of Leave-One-Out Cross Validation (LOO-CV)¹⁷ as the most applicable to the style of model and set of techniques applied here.

It is important to reiterate that these approaches do not speak to an absolute underlying truth; information criteria allow us to choose between models, assessing which has most closely assimilated the madness and chaos of the data. For LOO-CV, this results in an expected log predictive density (elpd) for each model. The model with the lowest elpd is the least-warped mirror of reality amongst those we subject to scrutiny.

There are many fragile subtleties to model selection, of which we will mention only two here. Firstly, in general, the greater the number of predictors or variables incorporated into a model, the more closely it will be able to mimic the original data. This is problematic, in that a model can become overfit to the original data and thus be unable to represent previously unseen data accurately — it learns to mimic the form of the observed data at the expense of uncovering its underlying reality. The LOO-CV technique avoids this trap by, in effect, withholding data from the model to assess its ability to make accurate inferences on previously unseen data.

The second consideration in model selection is that the information criteria scores of models, such as (elpd) in LOO-CV, are subject to standard error in their assessment; the score itself is not a perfect metric of model performance, but a cunning approximation. As such we will only consider one model to have outperformed its competitors if the difference in their relative elpd is several times greater than this standard error.

With this understanding in hand, we can now ruthlessly quantify the effectiveness of the Gaussian linear model against the Poisson generalised linear model.

Gaussian vs. the Poisson

The original model presented before our subsequent descent into horror was a simple linear Gaussian, produced through use of ggplot2‘s geom_smooth function. To compare this meaningfully against the Poisson model of the previous post, we must now recreate this model using the, now hideously familar, tools of Bayesian modelling with Stan.

Show Gaussian model specification code.

population_model_normal.stan
[code language=”c”]

data {

// Number of rows (observations)
int observations;

// Predictor (population of state)
vector[ observations ] population;

// Response (counts)
real counts[observations];

}

parameters {

// Intercept
real< lower=0 > a;

// Slope
real< lower=0 > b;

// Standard deviation
real< lower=0 > sigma;
}

model {

// Priors
a ~ normal( 0, 5 );
b ~ normal( 0, 5 );
sigma ~ cauchy( 0, 2.5 );

// Model
counts ~ normal( a + population * b, sigma );

}

generated quantities {

// Posterior predictions
vector[observations] counts_pred;

// Log likelihood (for LOO)
vector[observations] log_lik;

for (n in 1:observations) {

log_lik[n] = normal_lpdf( counts[n] | a + population[n]*b, sigma );
counts_pred[n] = normal_rng( a + population[n]*b, sigma );

}

[/code]

With both models straining in their different directions towards the light, we apply LOO-CV cross validation to assess their effectiveness at predicting the data.

Show LOO-CV comparison code.

LOO-CV R-code snippet. Full code is at the end of this post.
[code language=”R”]

…
# Compare models with LOO
log_lik_normal <- extract_log_lik(fit_ufo_pop_normal, merge_chains = FALSE)
r_eff_normal <- relative_eff(exp(log_lik_normal))
loo_normal <- loo(log_lik_normal, r_eff = r_eff_normal, cores = 2)

log_lik_poisson <- extract_log_lik(fit_ufo_pop_poisson, merge_chains = FALSE)
r_eff_poisson <- relative_eff(exp(log_lik_poisson))
loo_poisson <- loo(log_lik_poisson, r_eff = r_eff_poisson, cores = 2)
…

[/code]

> compare( loo_normal, loo_poisson )
elpd_diff        se 
  -8576.1     712.5

The information criterion shows that the complexity of the Poisson model does not, in fact, produce a more effective model than the false serenity of the Gaussian¹⁸. The negative elpd_diff of the compare function supports the first of the two models, and the magnitude being over twelve times greater than the standard error leaves little doubt that the difference is significant. We must, it seems, look further.

With these techniques for selecting between models in hand, then, we can move on to constructing ever more complex attempts to dispel the darkness.

Trials without End

The Poisson distribution, whilst appropriate for many forms of count data, suffers from fundamental limits to its understanding. The single parameter of the Poisson, $\lambda$, enforces that the mean and variance of the data are equal. When such comforting falsehoods wither in the pale light of reality, we must move beyond the gentle chains in which the Poisson binds us.

The next horrific evolution, then, is the negative binomial distribution, which similarly speaks to count data, but presents a dispersion parameter ($\phi$) that allows the variance to exceed the mean¹⁹.

With our arcane theoretical library suitably expanded, we can now transplant the still-beating Poisson heart of our earlier generalised linear model with the more complex machinery of the negative binomial:

As with the Poisson, our negative binomial generalised linear model employs a log link function to transform the linear predictor. The Stan code for this model is given below.

Show negative binomial model specification code.

population_model_negbinomial.stan
[code language=”c”]

data {

// Number of rows (observations)
int observations;

// Predictor (population of state)
vector[ observations ] population_raw;

// Response (counts)
int counts[observations];

}

transformed data {

// Center and scale the predictor
vector[ observations ] population;
population = ( population_raw – mean( population_raw ) ) / sd( population_raw );

}

parameters {

// Negative binomial dispersion parameter
real phi;

// Intercept
real a;

// Slope
real b;

}

transformed parameters {

vector[observations] mu;
mu = a + b*population;

}

model {

// Priors
a ~ normal( 0, 1 );
b ~ normal( 0, 1 );
phi ~ cauchy( 0, 5 );

// Model
// Uses the log version of the neg_binomial_2 to avoid
// manual exponentiation of the linear predictor.
// (This avoids numerical problems in the calculations.)
counts ~ neg_binomial_2_log( mu, phi );

}

generated quantities {

vector[observations] counts_pred;
vector[observations] log_lik;

for (n in 1:observations) {

log_lik[n] = neg_binomial_2_log_lpmf( counts[n] | mu[n], phi );
counts_pred[n] = neg_binomial_2_log_rng( mu[n], phi );

}

[/code]

With this model fit, we can compare its whispered falsehoods against both the original linear Gaussian model and the Poisson GLM:

Show LOO-CV comparison code.

Code snippet for calculating the LOO-CV elpd for three models. The full R code for building and comparing all models is listed at the end of this post.

[code] [code language="R"] …
# Compare models with LOO
log_lik_normal <- extract_log_lik(fit_ufo_pop_normal, merge_chains = FALSE)
r_eff_normal <- relative_eff(exp(log_lik_normal))
loo_normal <- loo(log_lik_normal, r_eff = r_eff_normal, cores = 2)

log_lik_poisson <- extract_log_lik(fit_ufo_pop_poisson, merge_chains = FALSE)
r_eff_poisson <- relative_eff(exp(log_lik_poisson))
loo_poisson <- loo(log_lik_poisson, r_eff = r_eff_poisson, cores = 2)

log_lik_negbinom <- extract_log_lik(fit_ufo_pop_negbinom, merge_chains = FALSE)
r_eff_negbinom <- relative_eff(exp(log_lik_negbinom))
loo_negbinom <- loo(log_lik_negbinom, r_eff = r_eff_negbinom, cores = 2)
…
[/code]

> compare( loo_poisson, loo_negbinom )
elpd_diff        se 
   8880.8     721.9

With the first comparison, it is clear that the sinuous flexibility offered by the dispersion parameter, $\phi$, of the negative binomial allows that model to mould itself much more effectively to the data than the Poisson. The elpd_diff score is positive, indicating that the second of the two compared models is favoured; the difference is over twelve times the standard error, giving us confidence that the negative binomial model is meaningfully more effective than the Poisson.

Whilst superior to the Poisson, does this adaptive capacity allow the negative binomial model to render the naïve Gaussian linear model obsolete?

> compare( loo_normal, loo_negbinom )
elpd_diff        se 
    304.7      30.9

The negative binomial model subsumes the Gaussian with little effort. The elpd_diff is almost ten times the standard error in favour of the negative binomial GLM, giving us confidence in choosing it. From here on, we will rely on the negative binomial as the core of our schemes.

Overlapping Realities

The improvements we have seen with the negative binomial model allow us to discard the Gaussian and Poisson models with confidence. It is not, however, sufficient to fill the gaping void induced by our belief that the sightings of abnormal aerial phenomena in differing US states vary differently with their human population.

To address this question we must ascertain whether allowing our models to unpick the individual influence of states will improve their predictive ability. This, in turn, will lead us into the gnostic insanity of hierarchical models, in which we group predictors in our models to account for their shadowy underlying structures.

Limpid Pools

The first step on this path is to allow part of the linear function underpinning our model, specifically the intercept value, $\alpha$, to vary between different US states. In a simple linear model, this causes the line of best fit for each state to meet the y-axis at a different point, whilst maintaining a constant slope for all states. In such a model, the result is a set of parallel lines of fit, rather than a single global truth.

This varying intercept can describe a range of possible phenomena for which the rate of change remains constant, but the baseline value varies. In such hierarchical models we employ a concept known as partial pooling to extract as much forbidden knowledge from the reluctant data as possible.

A set of entirely separate models, such as the per-state set of linear regressions presented in the first post of this series, employs a no pooling approach: the data of each state is treated separately, with an entirely different model fit to each. This certainly considers the uniqueness of each state, but cannot benefit from insights drawn from the broader range of data we have available, which we may reasonably assume to have some relevance.

By contrast, the global Gaussian, Poisson, and negative binomial models presented so far represent complete pooling, in which the entire set of data is considered a formless, protean amalgam without meaningful structure. This mindless, groping approach causes the unique features of each state to be lost amongst the anarchy and chaos.

A partial pooling approach instead builds a global mean intercept value across the dataset, but allows the intercept value for each individual state to deviate according to a governing probability distribution. This both accounts for the individuality of each group of observations, in our case the state, but also draws on the accumulated wisdom of the whole.

We now construct a partially-pooled varying intercept model, in which the parameters and observations for each US state in our dataset is individually indexed:

$$\begin{eqnarray}
y &\sim& \mathbf{NegBinomial}(\mu, \phi)\\
\log(\mu) &=& \alpha_i + \beta x\\
\alpha_i &\sim& \mathcal{N}(\mu_\alpha, \sigma_\alpha)\\
\beta &\sim& \mathcal{N}(0, 1)\\
\phi &\sim& \mathbf{HalfCauchy}(2)
\end{eqnarray}$$

Note that the intercept parameter, $\alpha$, in the second line is now indexed by the state, represented here by the subscript $i$. The slope parameter, $\beta$, remains constant across all states.

This model can be rendered in Stan code as follows:

Show Gaussian model specification code.

population_model_negbinomial_var_intercept.stan
[code language=”c”]

data {

// Number of rows (observations)
int observations;

// Number of states
int< lower=0 > states;

// Vector detailing the US state in which each observation (count of
// counts in a year) occurred
int< lower=1, upper=states > state[ observations ];

// Predictor (population of state)
vector[ observations ] population_raw;

// Response (counts)
int counts[ observations ];

}

transformed data {

// Center and scale the predictor
vector[ observations ] population;
population = ( population_raw – mean( population_raw ) ) / sd( population_raw );

}

parameters {

// Per-state intercepts
vector[ states ] a;

// Mean and SD of distribution from which per-state intercepts are drawn
real< lower=0 > mu_a;
real< lower=0 > sigma_a;

// Negative binomial dispersion parameter
real< lower=0 > phi;

// Slope
real b;

}

transformed parameters {

// Calculate location parameter for negative binomial incorporating
// per-state indicator.
vector[ observations ] eta;

for( i in 1:observations ) {
eta[i] = a[ state[i] ] + population[i] * b;
}
}

model {

mu_a ~ normal(0, 1);
sigma_a ~ cauchy(0, 2);

// Priors
a ~ normal ( mu_a, sigma_a );
b ~ normal( 0, 1 );
phi ~ cauchy( 0, 2 );

// Model
counts ~ neg_binomial_2_log( eta, phi );

}

generated quantities {

vector[observations] counts_pred;
vector[observations] log_lik;

vector[observations] mu;
mu = exp( eta );

for (n in 1:observations) {

log_lik[n] = neg_binomial_2_log_lpmf( counts[n] | eta[n], phi );
counts_pred[n] = neg_binomial_2_log_rng( eta[n], phi );

}

[/code]

Once the model has twisted itself into the most appropriate form for our data, we can now compare it against our previous completely-pooled model:

Show LOO-CV comparison code.

Code snippet for comparing models via LOO-CV. Full code at the end of this post.

[code] …
# Compare models with LOO
log_lik_negbinom_var_intercept <- extract_log_lik(fit_ufo_pop_negbinom_var_intercept, merge_chains = FALSE)
r_eff_negbinom_var_intercept <- relative_eff(exp(log_lik_negbinom_var_intercept))
loo_negbinom_var_intercept <- loo(log_lik_negbinom_var_intercept, r_eff = r_eff_negbinom_var_intercept, cores = 2)
…
[/code]

> compare( loo_negbinom, loo_negbinom_var_intercept )
elpd_diff        se 
    363.2      28.8

Our transcendent journey from the statistical primordial ooze continues: the varying intercept model is favoured over the completely-pooled model by a significant margin.

Sacred Geometry

Now that our minds have apprehended a startling glimpse of the implications of the varying intercept model, it is natural to consider taking a further terrible step and allowing both the slope and the intercept to vary²⁰.

With both the intercept and slope of the underlying linear predictor varying, an additional complexity raises its head: can we safely assume that these parameters, the intercept and slope, vary independently of each other, or may there be arcane correlations between them? Do states with a higher intercept also experience a higher slope in general, or is the opposite the case? Without prior knowledge to the contrary, we must allow our model to determine these possible correlations, or we are needlessly throwing away potential information in our model.

For a varying slope and intercept model, therefore, we must now include a correlation matrix, $\Omega$, between the parameters of the linear predictor for each state in our model. This correlation matrix, as with all parameters in a Bayesian framework, must be expressed with a prior distribution from which the model can begin its evaluation of the data.

With deference to the authoritative quaint and curious volume of forgotten lore we will use an LKJ prior for the correlation matrix without further discussion of the reasoning behind it.

$$\begin{eqnarray}
y &\sim& \mathbf{NegBinomial}(\mu, \phi)\\
\log(\mu) &=& \alpha_i + \beta x_i\\
\begin{bmatrix}
\alpha_i\\
\beta_i
\end{bmatrix} &\sim& \mathcal{N}(
\begin{bmatrix}
\mu_\alpha\\
\mu_\beta
\end{bmatrix}, \Omega )\\
\Omega &\sim& \mathbf{LKJCorr}(2)\\
\phi &\sim& \mathbf{HalfCauchy}(2)
\end{eqnarray}$$

This model has grown and gained a somewhat twisted complexity compared with the serene austerity of our earliest linear model. Despite this, each further step in the descent has followed its own perverse logic, and the progression should clear. The corresponding Stan code follows:

Show negative binomial varying intercept and slope model specification code.

population_model_negbinomial_var_intercept_slope.stan
[code]

data {

// Number of rows (observations)
int observations;

// Number of states
int< lower=0 > states;

// Vector detailing the US state in which each observation (count of
// counts in a year) occurred
int< lower=1, upper=states > state[ observations ];

// Predictor (population of state)
vector[ observations ] population_raw;

// Response (counts)
int counts[ observations ];

}

transformed data {

// Center and scale the predictor
vector[ observations ] population;
population = ( population_raw – mean( population_raw ) ) / sd( population_raw );

}

parameters {

// Per-state intercepts and slopes
vector[ states ] state_intercept;
vector[ states ] state_slope;

// Baseline intercept and slope from which each group deviates.
real pop_intercept;
real pop_slope;

// Per-state standard deviations for intercept and slope
vector< lower=0 >[2] state_sigma;

// Negative binomial dispersion parameter
real< lower=0 > phi;

// Parameter correlation matrix
corr_matrix[2] omega;

}

transformed parameters {

vector[2] vec_intercept_slope[ states ];
vector[2] mu_intercept_slope;

// Location parameter
vector[observations] eta;

// Per-state intercepts and slopes
for( i in 1:states ) {

vec_intercept_slope[ i, 1] = state_intercept[i];
vec_intercept_slope[ i, 2] = state_slope[i];

}

// Population slope and intercept
mu_intercept_slope[1] = pop_intercept;
mu_intercept_slope[2] = pop_slope;

// Calculation negbinomial location parameter
for( i in 1:observations ) {
eta[i] = state_intercept[ state[i] ] + state_slope[ state[i]] * population[ i ];
}

}

model {

// Priors
omega ~ lkj_corr(2);
phi ~ cauchy(0, 3 );
state_sigma ~ cauchy( 0, 3 );

pop_intercept ~ normal( 0, 1 );
pop_slope ~ normal( 0, 1 );

vec_intercept_slope ~ multi_normal( mu_intercept_slope, quad_form_diag( omega, state_sigma ) );

// Model
counts ~ neg_binomial_2_log( eta, phi );

}

generated quantities {

vector[observations] counts_pred;
vector[observations] log_lik;

for (n in 1:observations) {

log_lik[n] = neg_binomial_2_log_lpmf( counts[n] | eta[n], phi );
counts_pred[n] = neg_binomial_2_log_rng( eta[n], phi );

}

[/code]

The ultimate test of our faith, then, is whether the added complexity of the partially-pooled varying slope, varying intercept model is justified. Once again, we turn to the ruthless judgement of the LOO-CV:

Show LOO-CV comparison code.

Code snippet for calculating the LOO-CV elpd. The full R code for building and comparing all models in this post is listed at the end.

[code language=”R”] …
log_lik_negbinom_var_intercept_slope <- extract_log_lik(fit_ufo_pop_negbinom_var_intercept_slope, merge_chains = FALSE)
r_eff_negbinom_var_intercept_slope <- relative_eff(exp(log_lik_negbinom_var_intercept_slope))
loo_negbinom_var_intercept_slope <- loo(log_lik_negbinom_var_intercept_slope, r_eff = r_eff_negbinom_var_intercept_slope, cores = 2)
…
[/code]

> compare( loo_negbinom_var_intercept, loo_negbinom_var_intercept_slope )
elpd_diff        se 
     13.3       2.4

In this final step we can see that our labours in the arcane have been rewarded. The final model is once again a significant improvement over its simpler relatives. Whilst the potential for deeper and more perfect models never ends, we will settle for now on this.

Mortal Consequences

With our final model built, we can now begin to examine its mortifying implications. We will leave the majority of the subjective analysis for the next, and final, post in this series. For now, however, we can reinforce our quantitative analysis with visual assessment of the posterior predictive distribution output of our final model.

Posterior predictive density plot of varying intercept, varying slope negative binomial model of UFO sightings.

Posterior predictive density plot of varying intercept, varying slope negative binomial GLM of UFO sightings. (PDF Version)

Show posterior predictive plotting code.

bayes_plots.r
(Includes code to generate traceplot and posterior predictive distribution plot.)
[code language=”R”]

library( tidyverse )
library( magrittr )
library( lubridate )

library( ggplot2 )
library( showtext )
library( cowplot )

library( rstan )
library( bayesplot )
library( tidybayes )

# Load UFO data
ufo_population_sightings <-
readRDS("work/ufo_population_sightings.rds")

# UFO reporting font
font_add( "main_font", "/usr/share/fonts/TTF/weird/Tox Typewriter.ttf")
font_add( "bold_font", "/usr/share/fonts/TTF/weird/Tox Typewriter.ttf")
showtext_auto()

# Plots, posterior predictive checking, LOO.

# (Visualisations only produced for varying slope/intercept model, as a result
# of LOO checking.

# Bayesplot needs to be told which theme to use as a default.
theme_set( theme_weird() )

# Read the fitted model
fit_ufo_pop_negbinom_var_intercept_slope <-
readRDS( "work/fit_ufo_pop_negbinom_var_intercept_slope.rds" )

## Model checking visualisations

# Extract posterior estimates from the fit (from the generated quantities of the stan model)
counts_pred_negbinom_var_intercept_slope <- as.matrix( fit_ufo_pop_negbinom_var_intercept_slope, pars = "counts_pred" )

# First, as always, a traceplot
tp <-
traceplot(
fit_ufo_pop_negbinom_var_intercept_slope,
pars = c("pop_intercept", "pop_slope", "phi" ),
ncol=1 ) +
scale_colour_viridis_d( name="Chain", direction=-1 ) +
theme_weird()

title <-
ggdraw() +
draw_label("Traceplot of Key Parameters", fontfamily="main_font", colour = "#cccccc", size=20, hjust=0, vjust=1, x=0.02, y=0.88) +
draw_label("http://www.weirddatascience.net | @WeirdDataSci", fontfamily="main_font", colour = "#cccccc", size=12, hjust=0, vjust=1, x=0.02, y=0.40)

titled_tp <-
plot_grid(title, tp, ncol=1, rel_heights=c(0.1, 1)) +
theme(
panel.background = element_rect(fill = "#222222", colour = "#222222"),
plot.background = element_rect(fill = "#222222", colour = "#222222"),
)

save_plot("output/traceplot.pdf",
titled_tp,
base_width = 16,
base_height = 9,
base_aspect_ratio = 1.78 )

# Posterior predictive density. (Visual representation of goodness of fit.)
gp_ppc <-
ppc_dens_overlay(
y = extract2( ufo_population_sightings, "count" ),
yrep = counts_pred_negbinom_var_intercept_slope ) +
theme_weird()

title <-
ggdraw() +
draw_label("Posterior Predictive Density Plot", fontfamily="main_font", colour = "#cccccc", size=20, hjust=0, vjust=1, x=0.02, y=0.88) +
draw_label("http://www.weirddatascience.net | @WeirdDataSci", fontfamily="main_font", colour = "#cccccc", size=12, hjust=0, vjust=1, x=0.02, y=0.40)

titled_gp_ppc <-
plot_grid(title, gp_ppc, ncol=1, rel_heights=c(0.1, 1)) +
theme(
panel.background = element_rect(fill = "#222222", colour = "#222222"),
plot.background = element_rect(fill = "#222222", colour = "#222222"),
)

save_plot("output/posterior_predictive.pdf",
titled_gp_ppc,
base_width = 16,
base_height = 9,
base_aspect_ratio = 1.78 )

[/code]

In comparison with earlier attempts, the varying intercept and slope model visibly captures the overall shape of the distribution with terrifying ease. As our wary confidence mounts in the mindless automaton we have fashioned, we can now examine its predictive ability on our original data.

Varying intercept and slope negative binomial GLM of UFO sightings against population.

Varying intercept and slope negative binomial GLM of UFO sightings against population. (PDF Version)

Show negative binomial varying intercept and slope plot code.

population_plot.r
[code]

library( tidyverse )
library( magrittr )
library( lubridate )

library( ggplot2 )
library( showtext )
library( cowplot )

library( rstan )
library( bayesplot )
library( tidybayes )
library( modelr )

# Load UFO data and model
ufo_population_sightings <-
readRDS("work/ufo_population_sightings.rds")

fit_ufo_pop_negbinom_var_intercept_slope <-
readRDS("work/fit_ufo_pop_negbinom_var_intercept_slope.rds")
#readRDS("work/fit_ufo_pop_normal_var_intercept_slope.rds")

# UFO reporting font
font_add( "main_font", "/usr/share/fonts/TTF/weird/Tox Typewriter.ttf")
font_add( "bold_font", "/usr/share/fonts/TTF/weird/Tox Typewriter.ttf")
showtext_auto()

# Plots, posterior predictive checking, LOO
theme_set( theme_weird() )

## Model checking visualisations

## Create per-state predictive fit plots

# Convert fitted model (stanfit) object to a tibble
fit_tbl <-
summary(fit_ufo_pop_negbinom_var_intercept_slope)$summary %>%
as.data.frame() %>%
mutate(variable = rownames(.)) %>%
select(variable, everything()) %>%
as_tibble()

counts_predicted <-
fit_tbl %>%
filter( str_detect(variable,’counts_pred’) )

ufo_population_sightings_pred <-
ufo_population_sightings %>%
ungroup() %>%
mutate( count_mean = counts_predicted$mean,
lower = counts_predicted$`25%`,
upper = counts_predicted$`75%`)

# (Using mean and SD of fit summary)
predictive_plot <-
ggplot( ufo_population_sightings_pred ) +
geom_point( aes( x=population, y=count, colour=state ), size=0.6, alpha=0.8 ) +
geom_line(aes( x=population, y=count_mean, colour=state )) +
geom_ribbon(aes(x=population, ymin = lower, ymax = upper, fill=state), alpha = 0.25) +
labs( x="Population (Thousands)", y="Annual Sightings" ) +
scale_fill_viridis_d( name="State" ) +
scale_colour_viridis_d( name="State" ) +
theme(
axis.title.y = element_text( angle=90 ),
legend.position = "none" )

# Construct full plot, with title and backdrop.
title <-
ggdraw() +
draw_label("UFO Sightings against State Population (1990-2014)", fontfamily="main_font", colour = "#cccccc", size=20, hjust=0, vjust=1, x=0.02, y=0.88) +
draw_label("Negative Binomial Hierarchical GLM. Varying slope and intercept. 50% credible intervals.", fontfamily="main_font", colour = "#cccccc", size=12, hjust=0, vjust=1, x=0.02, y=0.48) +
draw_label("http://www.weirddatascience.net | @WeirdDataSci", fontfamily="main_font", colour = "#cccccc", size=12, hjust=0, vjust=1, x=0.02, y=0.16)

data_label <- ggdraw() +
draw_label("Data: http://www.nuforc.org | Tool: http://www.mc-stan.org", fontfamily="main_font", colour = "#cccccc", size=12, hjust=1, x=0.98 )

predictive_plot_titled <-
plot_grid(title, predictive_plot, data_label, ncol=1, rel_heights=c(0.1, 1, 0.1)) +
theme(
panel.background = element_rect(fill = "#222222", colour = "#222222"),
plot.background = element_rect(fill = "#222222", colour = "#222222"),
)

save_plot("output/predictive_plot.pdf",
predictive_plot_titled,
base_width = 16,
base_height = 9,
base_aspect_ratio = 1.78 )

[/code]

The purpose of our endeavours is to show whether or not the frequency of extraterrestrial visitations is merely a sad reflection of the number of unsuspecting humans living in each state. After seemingly endless cryptic calculations, our statistical machinery implies that there are deeper mysteries here: allowing the relationship between sightings and the underlying linear predictors to vary by state more perfectly predicts the data. There are clearly other, hidden, factors in play.

More than that, however, our final model allows us to quantify these differences. We can now retrieve from the very bowels of our inferential process the per-state distribution of paremeters for both the slope and intercept of the linear predictor.

Varying slope and intercept negative binomial GLM parameter plot.

Varying slope and intercept negative binomial GLM parameter plot for UFO sightings model. (PDF Version)

Show per-state intercept and slope plotting code.

slope_intercept_plot.r
[code language=”R”]

library( tidyverse )
library( magrittr )
library( lubridate )

library( ggplot2 )
library( showtext )
library( cowplot )

library( rstan )
library( bayesplot )
library( tidybayes )
library( modelr )

# Load UFO data and model
ufo_population_sightings <-
readRDS("work/ufo_population_sightings.rds")

fit_ufo_pop_negbinom_var_intercept_slope <-
readRDS("work/fit_ufo_pop_negbinom_var_intercept_slope.rds")
#readRDS("work/fit_ufo_pop_normal_var_intercept_slope.rds")

# UFO reporting font
font_add( "main_font", "/usr/share/fonts/TTF/weird/Tox Typewriter.ttf")
font_add( "bold_font", "/usr/share/fonts/TTF/weird/Tox Typewriter.ttf")
showtext_auto()

# Plots, posterior predictive checking, LOO
theme_set( theme_weird() )

# Use teal colour scheme
color_scheme_set( "teal")

## Model checking visualisations

# US state data
us_state_factors <-
levels( factor( ufo_population_sightings$state ) )

# US state names for nice plotting
# Data:
state_code_data <-
read_csv( file="data/us_states.csv" ) %>%
filter( code %in% us_state_factors )

# Rename variables back to state names
posterior_intercepts <-
as.data.frame( fit_ufo_pop_negbinom_var_intercept_slope ) %>%
as_tibble %>%
select(starts_with(‘state_intercept’) ) %>%
rename_all( ~us_state_factors ) %>%
rename_all( ~extract2( state_code_data, "us_state" ) )

# Rename variables back to state names
posterior_slopes <-
as.data.frame( fit_ufo_pop_negbinom_var_intercept_slope ) %>%
as_tibble %>%
select(starts_with(‘state_slope’) ) %>%
rename_all( ~us_state_factors ) %>%
rename_all( ~extract2( state_code_data, "us_state" ) )

# Posterior draws combined
posterior_slopes_long <-
posterior_slopes %>%
gather( value = "slope" )

posterior_intercepts_long <-
posterior_intercepts %>%
gather( value = "intercept" )

posterior_draws_long <-
bind_cols( posterior_intercepts_long, posterior_slopes_long ) %>%
select( -key1 ) %>%
transmute( state = key, intercept, slope )

# Interval plots (slope and intervals)
# Plot intercept parameters for varying intercept and slope model
gp_intercept <-
mcmc_intervals( posterior_intercepts ) +
ggtitle( "Intercepts" ) +
theme_weird()

# Plot slope parameters for varying intercept and slope model
# (Remove y-axis labels as this will be aligned with the intercept plot.)
gp_slope <-
mcmc_intervals( posterior_slopes ) +
ggtitle( "Slopes" ) +
theme_weird() +
theme(
axis.text.y = element_blank()
)

gp_slope_intercept <-
plot_grid( gp_intercept, gp_slope, ncol=2 )

# Construct full plot, with title and backdrop.
title <-
ggdraw() +
draw_label("Per-State UFO Intercepts and Slopes", fontfamily="main_font", colour = "#cccccc", size=20, hjust=0, vjust=1, x=0.02, y=0.88) +
draw_label("Mean value, 50% credible interval, and 95% credible interval shown.", fontfamily="main_font", colour = "#cccccc", size=12, hjust=0, vjust=1, x=0.02, y=0.48) +
draw_label("http://www.weirddatascience.net | @WeirdDataSci", fontfamily="main_font", colour = "#cccccc", size=12, hjust=0, vjust=1, x=0.02, y=0.16)

data_label <- ggdraw() +
draw_label("Data: http://www.nuforc.org | Tool: http://www.mc-stan.org", fontfamily="main_font", colour = "#cccccc", size=12, hjust=1, x=0.98 )

gp_slope_intercept_titled <-
plot_grid(title, gp_slope_intercept, data_label, ncol=1, rel_heights=c(0.1, 1, 0.1)) +
theme( panel.background = element_rect(fill = "#222222", colour = "#222222"),
plot.background = element_rect(fill = "#222222", colour = "#222222"))

save_plot("output/ufo_per-state_intercepts-slopes.pdf",
gp_slope_intercept_titled,
base_width = 16,
base_height = 9,
base_aspect_ratio = 1.78 )

[/code]

It is important to note that, while we are still referring to the $\alpha$ and $\beta$ parameters as the slope and intercept, their interpretation is more complex in a generalised linear model with a $\log$ link function than in the simple linear model. For now, however, this diagram is sufficient to show that the horror visited on innocent lives by our interstellar visitors is not purely arbitrary, but depends at least in part on geographical location.

With this malign inferential process finally complete we will turn, in the next post, to a trembling interpretation of the model and its dark implications for our collective future.

Model Fitting and Comparison Code Listing

Show full model fitting and LOO-CV comparison code.

This code fits the range of models developed in this series, relying on the individual Stan source code files, and runs the LOO-CV comparisons discussed in this post.

population_model.r
[code] library( tidyverse )
library( magrittr )

library( ggplot2 )
library( showtext )

library( rstan )
library( tidybayes )
library( loo )

# Load UFO data
ufo_population_sightings <-
readRDS("work/ufo_population_sightings.rds")

## Simple Models
## Complete Pooling — all states considered identical.

# Fit model of UFO sightings (Normal)
if( not( file.exists( "work/fit_ufo_pop_normal.rds" ) ) ) {

message("Fitting basic Normal model.")

fit_ufo_pop_normal <-
stan( file="model/population_model_normal.stan",
data=list(
observations = nrow( ufo_population_sightings ),
population = extract2( ufo_population_sightings, "population" ),
counts = extract2( ufo_population_sightings, "count" )
)
)

saveRDS( fit_ufo_pop_normal, "work/fit_ufo_pop_normal.rds" )

message("Basic Normal model fitted.")

} else {

fit_ufo_pop_normal <- readRDS( "work/fit_ufo_pop_normal.rds" )

}

# Fit model of UFO sightings (Poisson)
if( not( file.exists( "work/fit_ufo_pop_poisson.rds" ) ) ) {

message("Fitting basic Poisson model.")

fit_ufo_pop_poisson <-
stan( file="model/population_model_poisson.stan",
data=list(
observations = nrow( ufo_population_sightings ),
population_raw = extract2( ufo_population_sightings, "population" ),
counts = extract2( ufo_population_sightings, "count" )
)
)

saveRDS( fit_ufo_pop_poisson, "work/fit_ufo_pop_poisson.rds" )

message("Basic Poisson model fitted.")

} else {

fit_ufo_pop_poisson <- readRDS( "work/fit_ufo_pop_poisson.rds" )

}

# Fit model of UFO sightings (Negative Binomial)
if( not( file.exists( "work/fit_ufo_pop_negbinom.rds" ) ) ) {

message("Fitting basic negative binomial model.")

fit_ufo_pop_negbinom <-
stan( file="model/population_model_negbinomial.stan",
data=list(
observations = nrow( ufo_population_sightings ),
population_raw = extract2( ufo_population_sightings, "population" ),
counts = extract2( ufo_population_sightings, "count" ) )
)

saveRDS( fit_ufo_pop_negbinom, "work/fit_ufo_pop_negbinom.rds" )

message("Basic negative binomial model fitted.")

} else {

fit_ufo_pop_negbinom <- readRDS( "work/fit_ufo_pop_negbinom.rds" )

}

## Multilevel Models
## Partial Pooling (Varying Intercept)

if( not( file.exists( "work/fit_ufo_pop_negbinom_var_intercept.rds" ) ) ) {

message("Fitting varying intercept negative binomial model.")

fit_ufo_pop_negbinom_var_intercept <-
stan( file="model/population_model_negbinomial_var_intercept.stan",
data=list(
observations = nrow( ufo_population_sightings ),
population_raw = extract2( ufo_population_sightings, "population" ),
counts = extract2( ufo_population_sightings, "count" ),
states = length( unique( ufo_population_sightings$state ) ),
state = as.numeric( factor( ufo_population_sightings$state ) )
),
chains=4, iter=2000,
control = list(max_treedepth = 15, adapt_delta=0.9)
)

saveRDS( fit_ufo_pop_negbinom_var_intercept, "work/fit_ufo_pop_negbinom_var_intercept.rds" )

message("Varying intercept negative binomial model fitted.")

} else {

fit_ufo_pop_negbinom_var_intercept <- readRDS( "work/fit_ufo_pop_negbinom_var_intercept.rds" )

}

### Partial Pooling (Varying intercept and slope.)

if( not( file.exists( "work/fit_ufo_pop_negbinom_var_intercept_slope.rds" ) ) ) {

message("Fitting varying intercept and slope negative binomial model")

fit_ufo_pop_negbinom_var_intercept_slope <-
stan( file="model/population_model_negbinomial_var_intercept_slope.stan",
data=list(
observations = nrow( ufo_population_sightings ),
population_raw = extract2( ufo_population_sightings, "population" ),
counts = extract2( ufo_population_sightings, "count" ),
states = length( unique( ufo_population_sightings$state ) ),
state = as.numeric( factor( ufo_population_sightings$state ) )
),
chains=4, iter=2000,
control = list(max_treedepth = 12, adapt_delta=0.8)
)

saveRDS( fit_ufo_pop_negbinom_var_intercept_slope, "work/fit_ufo_pop_negbinom_var_intercept_slope.rds" )

message("Varying intercept and slope negative binomial model fitted.")

} else {

fit_ufo_pop_negbinom_var_intercept_slope <- readRDS( "work/fit_ufo_pop_negbinom_var_intercept_slope.rds" )

}

# Hierarchical normal. (Linear regression)
if( not( file.exists( "work/fit_ufo_pop_normal_var_intercept_slope.rds" ) ) ) {

message("Fitting varying intercept and slope normal model")

fit_ufo_pop_normal_var_intercept_slope <-
stan( file="model/population_model_normal_var_intercept_slope.stan",
data=list(
observations = nrow( ufo_population_sightings ),
population_raw = extract2( ufo_population_sightings, "population" ),
counts = extract2( ufo_population_sightings, "count" ),
states = length( unique( ufo_population_sightings$state ) ),
state = as.numeric( factor( ufo_population_sightings$state ) )
),
chains=4, iter=2000,
control = list(max_treedepth = 15, adapt_delta=0.9)
)

saveRDS( fit_ufo_pop_normal_var_intercept_slope, "work/fit_ufo_pop_normal_var_intercept_slope.rds" )

message("Varying intercept and slope normal model fitted.")

} else {

fit_ufo_pop_normal_var_intercept_slope <- readRDS( "work/fit_ufo_pop_normal_var_intercept_slope.rds" )

}

## Notify by text
message("All models fit.")

# Compare models with LOO
log_lik_normal <- extract_log_lik(fit_ufo_pop_normal, merge_chains = FALSE)
r_eff_normal <- relative_eff(exp(log_lik_normal))
loo_normal <- loo(log_lik_normal, r_eff = r_eff_normal, cores = 2)

log_lik_poisson <- extract_log_lik(fit_ufo_pop_poisson, merge_chains = FALSE)
r_eff_poisson <- relative_eff(exp(log_lik_poisson))
loo_poisson <- loo(log_lik_poisson, r_eff = r_eff_poisson, cores = 2)

log_lik_negbinom_var_intercept <- extract_log_lik(fit_ufo_pop_negbinom_var_intercept, merge_chains = FALSE)
r_eff_negbinom_var_intercept <- relative_eff(exp(log_lik_negbinom_var_intercept))
loo_negbinom_var_intercept <- loo(log_lik_negbinom_var_intercept, r_eff = r_eff_negbinom_var_intercept, save_psis = TRUE)

log_lik_negbinom_var_intercept_slope <- extract_log_lik(fit_ufo_pop_negbinom_var_intercept_slope, merge_chains = FALSE)
r_eff_negbinom_var_intercept_slope <- relative_eff(exp(log_lik_negbinom_var_intercept_slope))
loo_negbinom_var_intercept_slope <- loo(log_lik_negbinom_var_intercept_slope, r_eff = r_eff_negbinom_var_intercept_slope, save_psis = TRUE)

normal_poisson_comparison <- compare( loo_normal, loo_poisson )
poiss_negbinom_comparison <- compare( loo_poisson, loo_negbinom )
negbinom_negbinom_var_intercept_comparison <- compare( loo_negbinom, loo_negbinom_var_intercept )
negbinom_var_intercept_negbinom_var_intercept_slope_comparison <- compare( loo_negbinom_var_intercept, loo_negbinom_var_intercept_slope )

saveRDS( normal_poisson_comparison, "work/normal_poisson_comparison.rds" )
saveRDS( poiss_negbinom_comparison, "work/poiss_negbinom_comparison.rds" )
saveRDS( negbinom_negbinom_var_intercept_comparison, "work/negbinom_negbinom_var_intercept_comparison.rds" )
saveRDS( negbinom_var_intercept_negbinom_var_intercept_slope_comparison, "work/negbinom_var_intercept_negbinom_var_intercept_slope_comparison.rds" )

[/code]