scraping – 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

Bayes vs. the Invaders! Part One: The 37th Parallel

moth — Wed, 03 Apr 2019 13:03:10 +0000

Introduction

From our earlier studies of UFO sightings, a recurring question has been the extent to which the frequency of sightings of inexplicable otherworldly phenomena depends on the population of an area. Intuitively: where there are more people to catch a glimpse of the unknown, there will be more reports of alien visitors.

Is this hypothesis, however, true? Do UFO sightings closely follow population or are there other, less comforting, factors at work?

In this short series of posts, we will build a statistical model of UFO sightings in the United States, based on data previously scraped from the National UFO Reporting Centre and see how well we can predict the rate of UFO sightings based on state population.

This series of posts is part tutorial and part exploration of a set of modelling tools and techniques. Specifically, we will use Generalized Linear Models (GLMs), Bayesian inference, and the Stan probabilistic programming language to unveil the relationship between unsuspecting populations of US states and the dread sightings of extraterrestrial truth that they experience.

Data

As mentioned, we will rely on data from NUFORC for extraterrestrial sightings.

For population data, we can rely on the the FRED database for historical US state-level census data. The combination of these datasets provides us with a count of UFO sightings per year for each state, and the population of that state in that year.

The downloading and scraping code is included here:

Show scraping code.

ZSH script to download via `curl`
[code language=”bash”] #!/bin/zsh
# Download US state-level population datasets from FRED
# State series names are stored in the file ‘series_names’ (downloaded from fred.stlouisfed.org)
#
#
# The per-series requests is included below.

export IFS=$’\n’

# Download
for state_series in $(cat series_names); do

curl -o "output/$state_series.csv" "https://fred.stlouisfed.org/graph/fredgraph.csv?bgcolor=%23e1e9f0&chart_type=line&drp=0&fo=open%20sans&graph_bgcolor=%23ffffff&height=450&mode=fred&recession_bars=on&txtcolor=%23444444&ts=12&tts=12&width=1168&nt=0&thu=0&trc=0&show_legend=yes&show_axis_titles=yes&show_tooltip=yes&id=$state_series&scale=left&cosd=1900-01-01&coed=2018-01-01&line_color=%234572a7&link_values=false&line_style=solid&mark_type=none&mw=3&lw=2&ost=-99999&oet=99999&mma=0&fml=a&fq=Annual&fam=avg&fgst=lin&fgsnd=2009-06-01&line_index=1&transformation=lin&vintage_date=2019-03-04&revision_date=2019-03-04&nd=1900-01-01"

done
[/code]

Necessary ‘series_names’ file:
[code language=”text”] WAPOP
GAPOP
CAPOP
MOPOP
DSPOP
ILPOP
TXPOP
NYPOP
FLPOP
ALPOP
COPOP
WIPOP
AZPOP
MIPOP
NCPOP
MAPOP
CTPOP
LAPOP
OHPOP
AKPOP
TNPOP
MNPOP
NJPOP
NMPOP
ARPOP
MDPOP
PAPOP
NVPOP
IAPOP
ORPOP
T5POP
DCPOP
HIPOP
NDPOP
KYPOP
VAPOP
IDPOP
KSPOP
INPOP
WVPOP
RIPOP
SCPOP
MSPOP
DEPOP
MTPOP
MEPOP
NEPOP
OKPOP
WYPOP
UTPOP
NHPOP
VTPOP
SDPOP
[/code]

R code to combine data into tidy format
[code language=”r”] library( tidyverse )

# Read all CSV files
census_files <- list.files( "output", full.names=TRUE )

# Join all data into a single table
census_data <-
census_files %>%
map( read_csv ) %>% # Read each file, forming a list with an element for each
reduce( full_join, by="DATE" ) %>% # Reduce (left to right) running a full join
dplyr::arrange( DATE ) %>% # Sort by date
gather( key="state", value="population", -DATE ) %>% # Gather to long format
transmute( date=DATE, state=str_replace( state, "POP", "" ), population ) # Rename and tidy variables and names

# Output to an .rds
saveRDS( census_data, "data/annual_population.rds" )

[/code]

For ease, we will treat each year’s count of sightings as independent from the previous year’s — we do not make an assumption that the number of sightings in each year is based on the number of sightings in the previous year, but is rather due to the unknowable schemes of alien minds. (If extraterrestrials visitors were colonising areas in secrecy rather than making sporadic visits, and thus being seen repeatedly, we might not want to make such a bold assumption.) Each annual count will be treated as an individual, independent data point relating population to count, with each observation tagged by state.

For simplicity, particularly in building later models, we will restrict ourselves to sightings post 1990, roughly reflecting a period in which the NUFORC data sees a significant increase in reporting and thus relies less on historical reports. (NUFORC’s phone hotline has existed since 1974, and its web form since 1998.)

An Awful Simplicity

To begin, we start with the most basic form of model: a simple linear relationship between the count of sightings and the population of the state at that time. If sightings were purely dependent on population, it might be reasonable to assume that such a model would fit the data fairly well.

This relationship can be plotted with relative ease using the geom_smooth() function of ggplot2 in R. For opening our eyes to the awful truth contained in the data, this is a useful first step.

Global linear regression of UFO sightings against population.

Global linear regression of UFO sightings against population. (PDF Version)

While this graph does seem to support the argument that sightings increase with population in general, a closer inspection shows that the individual data points are clearly clustered. If we highlight the location of each data point, colouring points by US state, this becomes clearer:

Global linear regression of UFO sightings against population with per-state colours.

Global linear regression of UFO sightings against population with per-state colours. (PDF Version)

This strongly suggests that, in preference to the simple linear model across all sightings, we might instead fit a linear model individually to each state:

Per-state linear regression of UFO sightings against population,

Per-state linear regression of UFO sightings against population. (PDF Version)

The code to produce the above graphs from the NUFORC and FRED data is given below:

Show data preparation and visualization code.

Prepare and combine datasets:
[code language=”r”] library( tidyverse )
library( magrittr )
library( lubridate )

# Prepare data for model fitting (and plotting)

# Load US population and UFO datasets
ufo <- read_csv( "data/ufo_spatial.csv" )
census <- readRDS( "data/annual_population.rds" )

# Process UFO data to per-state counts per year.
# Drop Puerto Rico as we don’t have census data. (Also, very few sightings — 33 in dataset.)
ufo_state_annual <-
ufo %>%
# US only
filter( country == "us" ) %>%
# Apologies to Puerto Rico.
filter( state != "pr" ) %>%
# Convert date to year, drop all other variables except state.
transmute( date = year( as.POSIXct( datetime, format="%m/%d/%Y %H:%M" ) ), state=str_to_upper( state ) ) %>%
# Group by year
group_by( date, state ) %>%
# Sum sightings
summarize( count = n() )

# Process census suitable for joining with UFO sightings.
# Drop "DS" state entry — ("Department of State"?)
census <-
census %>%
filter( state != "DS" ) %>%
mutate( date=year( date ) )

# Join datasets
ufo_population_sightings <-
full_join( ufo_state_annual, census )

# Missing data implies zero sightings.
# Restrict to post-1990 to avoid a high proportion of very small numbers of
# sightings.
ufo_population_sightings <-
ufo_population_sightings %>%
mutate( count = replace_na( count, 0 ) ) %>%
filter( !is.na( population ) ) %>%
filter( date >= 1990 ) %>%
filter( date <= 2014 )

saveRDS( ufo_population_sightings, "work/ufo_population_sightings.rds" )
[/code]

Fit linear trend in data via geom_smooth() using a linear model.
[code language=”r”] library( tidyverse )
library( magrittr )
library( lubridate )

library( ggplot2 )
library( showtext )
library( RColorBrewer )

library( cowplot )

# 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")
showtext_auto()

# Combined plot ignoring states.
ufo_pop_plot <-
ggplot( ufo_population_sightings, aes( x=population, y=count ) ) +
geom_point( colour="#0b6788", size=0.6, alpha=0.8 ) +
geom_smooth( method="lm", colour="#3cd070" ) + # UFO green
xlab( "Population" ) +
ylab( "Sightings per annum" ) +
theme_weird() +
theme(
axis.title.y = element_text( angle=90 )
)

# 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("http://www.weirddatascience.net | @WeirdDataSci", fontfamily="main_font", colour = "#cccccc", size=12, hjust=0, vjust=1, x=0.02, y=0.40)

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

ufo_pop_titled <-
plot_grid(title, ufo_pop_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/lm_ufo_population_sightings-combined.pdf",
ufo_pop_titled,
base_width = 16,
base_height = 9,
base_aspect_ratio = 1.78 )

# Combined plot colouring states.
ufo_pop_plot_states <-
ggplot( ufo_population_sightings, aes( x=population, y=count ) ) +
geom_point( aes( colour=state ), size=0.6, alpha=0.8 ) +
geom_smooth( method="lm", colour="#3cd070" ) + # UFO green
xlab( "Population" ) +
ylab( "Sightings per annum" ) +
scale_colour_manual( values=rep( brewer.pal( name="Set3", n=12 ), times=5 ) ) +
theme_weird() +
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("(Per-state sightings)", fontfamily="main_font", colour = "#cccccc", size=16, 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", fontfamily="main_font", colour = "#cccccc", size=12, hjust=1, x=0.98 )

ufo_pop_states_titled <-
plot_grid(title, ufo_pop_plot_states, 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/lm_ufo_population_sightings-state.pdf",
ufo_pop_states_titled,
base_width = 16,
base_height = 9,
base_aspect_ratio = 1.78 )

# Combined plot colouring states with per-state trend lines.
ufo_pop_plot_states_trends <-
ggplot( ufo_population_sightings, aes( x=population, y=count ) ) +
geom_point( aes( colour=state ), size=0.6, alpha=0.8 ) +
geom_smooth( method="lm", aes( colour=state ) ) +
xlab( "Population" ) +
ylab( "Sightings Per Annum" ) +
scale_colour_manual( values=rep( brewer.pal( name="Set3", n=12 ), times=5 ) ) +
theme_weird() +
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("(Per-state trends)", fontfamily="main_font", colour = "#cccccc", size=16, 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", fontfamily="main_font", colour = "#cccccc", size=12, hjust=1, x=0.98 )

ufo_pop_states_trends_titled <-
plot_grid(title, ufo_pop_plot_states_trends, 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/lm_ufo_population_sightings-trends.pdf",
ufo_pop_states_trends_titled,
base_width = 16,
base_height = 9,
base_aspect_ratio = 1.78 )

[/code]

Result

The plots shown here strongly indicate that the rate of dread interplanetary visitations per capita varies differently per state. It seems, therefore, that while the number of sightings is generally proportional to population, the specific relationship is state-dependent.

This simple linear model is, however, entirely unsatisfactory in describing the data, despite its support for the argument that different states have different underlying rates of sightings.

In the next post, therefore, we will delve deeper into the unsettling relationships between UFO sightings and the innocent humans to which they are drawn. To do so, we will have to consider a class of techniques that go beyond the normal distribution that underpins key assumptions of the simple linear models used here, and so move into the eldritch world of generalized linear models.

Missing Links: Density of Bigfoot Sightings in North America

moth — Sun, 14 Oct 2018 22:15:40 +0000

Sightings of Homo sapiens cognatus, or Homo sylvestris, are well-recorded, with a particular prevalence in North America. Bigfoot, otherwise known as the Sasquatch, is one of the most widely-reported cryptids in the world; it is the subject of documentaries, film, music, and countless books.

The Bigfoot Field Research Organisation has compiled a detailed database of Bigfoot sightings going back to the 1920s. Each sighting is dated, located to the nearest town or road, and contains a full description of the sighting. In many cases, sightings are accompanied by a follow-up report from the organisation itself.

As previously with UFO sightings and paranormal manifestations, our first step is to retrieve the data and parse it for analysis. Thankfully, the bfro.net dataset is relatively well-formatted; reports are broken down by region, with each report following a mainly standard format.

As before, we rely on the rvest package in R to explore and scrape the website. In this case, the key elements were to retrieve each state’s set of reports from the top level page, and retrieve the link for each report. Conveniently, these are in a standard format; the website also allows a printer-friendly mode that greatly simplifies scraping.

The scraping code is given here:

Show scraping code.

[code language=”r”]

library(tidyverse)
library(progress)
library(rvest)

# Base URLs for scraping
index_url <- "https://www.bfro.net/GDB/"
base_url <- "https://www.bfro.net"
report_base_url_pattern <- "https:\\/\\/www.bfro.net\\/GDB\\/show_report.asp\\?id="

# Retrieve list of state-level county report pages
get_state_listing_urls <- function( url ) {

read_html( url ) %>%
html_nodes( ‘a’ ) %>%
html_attr( ‘href’ ) %>%
str_match( ‘.*state_listing.asp\\?state=.*’ ) %>%
na.omit %>%
unique %>%
{ paste0( base_url, . ) }

}

# Return all URLs pointing to a county-level list of reports
get_county_report_urls <- function( url ) {

read_html( url ) %>%
html_nodes( ‘a’ ) %>%
html_attr( ‘href’ ) %>%
str_match( ‘.*show_county_reports.asp\\?state=.*’ ) %>%
na.omit %>%
unique %>%
{ paste0( index_url, . ) }

}

# Return all URLs pointing to a report in this page.
get_report_urls <- function( url ) {

read_html( url ) %>%
html_nodes( ‘a’ ) %>%
html_attr( ‘href’ ) %>%
str_match( ‘.*show_report.asp\\?id=[0-9]+’ ) %>%
na.omit %>%
unique %>%
{ paste0( index_url, . ) }

}

progressive_get_county_report_urls <- function( url, progress_bar ) {

progress_bar$tick()$print()
cat( paste(url, "\n") , file="work/progress.log", append=TRUE )
chime()
get_county_report_urls( url )

}

progressive_get_report_urls <- function( url, progress_bar ) {

progress_bar$tick()$print()
cat( paste(url, "\n") , file="work/progress.log", append=TRUE )
get_report_urls( url )

}

# Pull the report listing from a page.
store_report <- function( url ) {

report_id <-
url %>%
str_replace( report_base_url_pattern, "" ) %>%
str_replace( "/", "-" ) %>%
str_replace( ".html", "" )

#message( paste0("Processing report ", report_id, "… " ), appendLF=FALSE )

# Check if this report has already been stored.
if( file.exists( paste0( "data/", report_id, ".rds" ) ) ) {
message( paste0( "Report already retrieved: ", report_id ) )
return()
}

url_pf <- paste0( url, "&PrinterFriendly=True" )

report <-
tryCatch(
{
# Fetch and parse HTML of current page.
read_html( url_pf ) %>%
as.character
},
error=function( cond ) {
message( paste( "URL caused an error:", url ))
message( "Error message:")
message( cond )
return( NULL )
},
warning=function( cond ) {
message( paste( "URL caused a warning:", url ))
message( "Warning message:")
message( cond )
return( NULL )
},
finally={
}
)

# Write report result to disk
saveRDS( report, paste0("data/", report_id, ".rds") )

}

# Progressive version of store_report
progressive_store_report <- function( url, progress_bar ) {

progress_bar$tick()$print()
cat( paste(url, "\n") , file="work/progress.log", append=TRUE )
store_report( url )

}

# The key to this is that links of the form
# <https://www.bfro.net/GDB/show_county_reports.asp?state=…>
# link to each state’s data. At the top level, then, we can just get all links matching that form.

# At each sub-page, the links are:
# <https://www.bfro.net/GDB/show_report.asp?id=…>
# We can just pull all of those for each state.
# NOTE: There are also non-US reports linked like this directly from the main GDB page.

# Finally, it seems that adding "&PrinterFriendly=True" will strip a lot of
# unnecessary formatting.

# From the top-level page, get every URL that matches ‘show_county_reports.asp?state=’, make
# the list unique, then download the pages.

# Get all non-US state indices
message("Getting state report lists…", appendLF=FALSE )
bfro_state_indices <- get_state_listing_urls( index_url )
message("done." )
saveRDS( bfro_state_indices, "work/bfro_state_indices.rds" )

# Get all US county-level indices
message("Getting county-level report urls… " )
pb <- progress_estimated( length( bfro_state_indices ) )
bfro_county_urls <-
bfro_state_indices %>%
map( progressive_get_county_report_urls, pb ) %>%
unlist %>%
unique
saveRDS( bfro_county_urls, "work/bfro_county_urls.rds" )

# Get URLs of US reports from county pages.
# (Final subset line handles cases where pages are empty of reports, but
# contain other links such as media articles.)
pb <- progress_estimated( length( bfro_county_urls ) )
bfro_report_urls <-
bfro_county_urls %>%
map( progressive_get_report_urls, pb ) %>%
unlist %>%
unique %>%
str_subset( "GDB\\/." )
saveRDS( bfro_report_urls, "work/bfro_report_urls.rds" )

# Store all US reports
pb <- progress_estimated( length( bfro_report_urls ) )
bfro_report_urls %>%
map( progressive_store_report, pb )

# Get all non-US indices
message("Getting non-US top-level report lists…", appendLF=FALSE )
bfro_nonus_indices <-
get_county_report_urls( index_url ) %>%
str_replace( "GDB\\/\\/", "\\/" )
message("done." )
saveRDS( bfro_nonus_indices, "work/bfro_nonus_indices.rds" )

# Get URLs of US reports from county pages
message("Getting non-US report lists…", appendLF=FALSE )
pb <- progress_estimated( length( bfro_nonus_indices ) )
bfro_nonus_report_urls <-
bfro_nonus_indices %>%
map( progressive_get_report_urls, pb ) %>%
unlist %>%
unique %>%
str_subset( "GDB\\/." )
saveRDS( bfro_nonus_report_urls, "work/bfro_nonus_report_urls.rds" )

# Store all US reports
pb <- progress_estimated( length( bfro_nonus_report_urls ) )
bfro_nonus_report_urls %>%
map( progressive_store_report, pb )

[/code]

With each page retrieved, we step through and parse each report. Again, each page is fairly well-formatted, and uses a standard set of tags for date, location, and similar. The report parsing code is given here:

Show parsing code.

[code language=”r”]

# NOTES

# Process entire list to check for standardised headers. These are in capitals, and located in tags.

# Report starts with:
# 
# (Look up what these mean.)
# Some following types contain general summary information, eg:
# " Submitted by witness on Thursday, November 1, 2007."
# Following fields are in span tags separated by paragraph tags, eg:
# YEAR: 2007
# STATE and COUNTY fields are typically links; we should pull their text. (I can’t see a good reason to parse links to anything other than the link text for our purposes.)

library(tidyverse)
library(magrittr)
library(progress)
library(rvest)
library(lubridate)

# Exploratory functions

# List all capitalised fields seen in any file
list_all_fields <- function() {

filenames <- list.files( "data", pattern="*.rds", full.names=TRUE)

# In each file, select the classes, match the uppercase field names, and extract text.
all_fields <-
filenames %>%
map( list_report_fields ) %>%
unlist %>%
unique

saveRDS( all_fields, "work/fields.rds" )

return( all_fields )

}

fields_to_colnames <- function( fields ) {

# In total there are 18 fields reported in the data, with the final one
# being an apparently miscoded date and place from a report.

# Format the text appropriately for dataframe column names
fields %>%
head( 17 ) %>%
str_remove( ":" ) %>%
str_replace_all( " ", "_" ) %>%
str_to_lower()

}

list_report_fields <- function( report ) {

to_process <- readRDS( report )

bfro_fields <- NULL

if( !is.null( to_process ) ) {
bfro_fields <-
to_process %>%
read_html %>%
html_nodes( "span" ) %>%
html_nodes(xpath = ‘//*[@class="field"]’) %>%
html_text %>%
str_subset( "[A-Z]+:" )
}

return( bfro_fields )
}

# Extract node date
parse_report_data <- function( report_data ) {

# report_data should be an xml_nodeset

# Metadata
metadata_list <-
report_data %>%
html_text %>%
str_subset( "^[A-Z ]+: " ) %>%
str_split_fixed( ": ", 2 ) %>%
as.tibble %>%
spread( key=V1, value=V2 ) %>%
set_colnames( fields_to_colnames( colnames(.) ) )

# Extra details
extra_text <-
report_data %>%
html_text %>%
str_remove( "^[A-Z ]+:.*" ) %>%
str_flatten( " " ) %>%
str_trim

# Add extra details as a column
metadata_list$extra <- extra_text

# Note whether date is rough or accurately reported
metadata_list$rough_date <- FALSE

# "Fix" missing date or month columns
if( "date" %in% colnames( metadata_list ) == FALSE ) {
metadata_list$date <- "1"
metadata_list$rough_date <- TRUE
}

if( "month" %in% colnames( metadata_list ) == FALSE ) {
metadata_list$month <- "January"
metadata_list$rough_date <- TRUE
}

# Combine date columns (year, month, date) to a true date.
metadata_list <-
metadata_list %>%
mutate( year = str_replace( year, ".*([0-9]{4}).*", "\\1" ) ) %>%
mutate( date = paste0( year, "-", month, "-", date ), year=NULL, month=NULL ) %>%
mutate( date = as.POSIXct( date, format="%Y-%B-%d" ) )

}

# Read a file and pass to `post_get_all_thread`
process_file <- function( filename ) {

# Read stored file
to_process <- readRDS( filename )

# Don’t process null files
if( is.null( to_process ) )
return( NULL )

if( length( to_process ) == 0 )
return( NULL )

# Produce an xml_nodeset for parsing
xml_thread <-
to_process %>%
read_html %>%
html_nodes( "p" )

parse_report_data( xml_thread )

}

# Progressive version of process_file
progressive_process_file <- function( filename, progress_bar ) {

progress_bar$tick()$print()
cat( paste(filename, "\n") , file="progress.log", append=TRUE )

report <-
tryCatch(
{
process_file( filename )
},
error=function( cond ) {
message( paste( "File caused an error:", filename ))
message( "Error message:")
message( cond )
return( NULL )
},
warning=function( cond ) {
message( paste( "URL caused a warning:", url ))
message( "Warning message:")
message( cond )
return( NULL )
},
finally={
}
)

return( report )

}

## Processing starts here

# Read all .rds data files and process into a thread
filenames <- list.files("data", pattern="*.rds", full.names=TRUE)
pb <- progress_estimated( length( filenames ) )

# Begin logging
cat( "Processing… ", file="progress.log", append=FALSE )

bfro_tbl <-
filenames %>%
map( progressive_process_file, pb ) %>%
bind_rows

saveRDS( bfro_tbl, "data/bfro_processed.rds" )

[/code]

With each report parsed into a form suitable for analysis, the final step in scraping the site is to geolocate the reports. As in previous posts, we rely on Google’s geolocation API. For each report, we extract an appropriate address and parse it into a set of latitude and longitude coordinates. For the purposes of this initial scrape we restrict ourselves to North America, which compromises a large majority of reports on bfro.net. Geolocation code is included below. (Note that a Google Geolocation API key is required for this code to run.)

Show geolocation code.

[code language=”r”]

library(googleway)
library(progress)
library(tidyverse)
library(magrittr)

# weird.data.science Google API key (Geocoding API enabled)
key <- <INSERT API KEY HERE>

# Load bfro tibble
bfro_data <- readRDS( "data/bfro_processed.rds" )

# Geocode entries

# BFRO entries contain some, all, or none of:
# country, province, state, county, nearest_town

# Country is only used for Canada, in which case a province is given.
# Country and province are NA for the US.

# Best plan, then is to create a string of (nearest_town, province, country) for Canadian results, and (nearest_town, county, state, "US") for US results.

# Bound the request to be only in North America.
# (Used: <https://boundingbox.klokantech.com>)
# (SW->NE latitude and longitude.)
bounding_box <- list( c( -170.3, 24.4),
c( -52.3, 83.3) )

form_location_string <- function( country, province, state, county, nearest_town ) {

location_string <- NA

# US case, then Canadian
if( is.na( country ) )
location_string <- paste0( nearest_town, ", ", county, ", ", state, ", US" )
else
location_string <- paste0( nearest_town, ", ", province, ", ", ", Canada" )

# Strip double commas caused by NA values and remove bracketed clauses.
location_string %<>%
str_remove_all( "\$[^\$]*\\)" ) %>%
str_replace_all( ", , ", ", " ) %>%
str_replace_all( " ,", "," ) %>%
str_remove_all( "NA, " )

}

# Create a safe version of google_geocode
safe_geocode <- safely( google_geocode )

# Wrap google_geocode with a progress bar call.
# Also, optionally remove any bracketed substrings entirely (strip_brackets)
progressive_geocode <- function( location_string, progress_bar ) {

# Write status to log file.
progress_bar$tick()$print()

cat( paste0( location_string, "\n" ), file="progress.log", append=TRUE )

result <-
safe_geocode(
address = location_string,
key = key,
bounds = bounding_box,
simplify = TRUE )

# Note that this can be NULL
return( result$result )

}

# Logging and output
## Clear the screen first
cat(c("\033[2J","\033[0;0H"))
cat("Geolocating entries…\n")
cat( "Geolocating entries…\n", file="progress.log", append=FALSE )

# Create the location string
bfro_data %<>%
mutate( location = form_location_string( country, province, state, county, nearest_town ) )

# Geolocate each location.
pb <- progress_estimated(nrow(bfro_data))
bfro_data$geolocation <-
map( bfro_data$location, progressive_geocode, progress_bar = pb )

cat("\nComplete.\n")

## With all values scraped, save geolocated data.
saveRDS( bfro_data, file="work/bfro_data_geolocated.rds")

[/code]

With geolocated data in hand, we can now venture into the wilds. In which areas of North America are Sasquatch most commonly seen to roam? The plot below shows the overall density of Bigfoot sightings, with individual reports marked.

Density of Bigfoot sightings in North America.

Density of Bigfoot sightings in North America. (PDF Version)

There are particular clusters on the Great Lakes, particularly in Southern Ontario; as well as in the Pacific Northwest. Smaller notable clusters exist in Florida, centered around Orlando. As with most report-based datasets, sightings are skewed towards areas of high population density.

The obvious first question to ask of such data is which, if any, environmental features correlate with these sightings. Other analyses of Bigfoot sightings, such as the seminal work of Lozier et al.¹, have suggested that forested regions are natural habitats for Sasquatch.

To answer this, we combine the underlying mapping data and Bigfoot sightings, with bioclimatic data taken from the Global Land Cover Facility. Amongst other datasets, this provides us with an accurate, high-resolution land cover raster map, detailing vegetation for each 5-arcminute cell in the country — approximately one cell per 10km² .

There are a range of bioclimatic variables in this dataset. The diagram below overlays all areas that are some form of forest onto the previous density plot.

Density of Bigfoot sightings in North America (Yellow) with forested areas overlaid (green).

Density of Bigfoot sightings in North America (yellow) with forested areas overlaid (green). (PDF Version)

The code for producing both of the above plots is given here:

Show density plotting code.

[code language=”r”]

library(spatstat)

library(rgdal)
library(maptools)

library(tidyverse)
library(magrittr)
library(ggplot2)
library(ggthemes)
library(raster)
library(viridis)
library(scales)

library(sf)

library(showtext)

library(grid)

library(cowplot)
library(magick)

# Load font
font_add( "mapfont", "/usr/share/fonts/TTF/weird/alchemy/1689 GLC Garamond Pro/1689GLCGaramondProNormal.otf" )
showtext_auto()

# Read world shapefile data and tranform to an appropriate projection.
world <- readOGR( dsn=’data/ne/10m_cultural’, layer=’ne_10m_admin_0_countries’ )
world_subset <- world[ world$iso_a2 %in% c("US","CA"), ] world_subset <- spTransform(world_subset,CRS("+init=epsg:4326 +lon_wrap=170"))
world_df <- fortify( world_subset )

# Read bfro database, filtering out locations with "NA" latitude or longitude.
# Also filter results that have been geolocated to "56.13037, -106.3468", which is the centroid of Canada, and results from locations having no more specific result.
bfro_tbl <-
readRDS( "data/bfro_locations.rds" ) %>%
filter( !is.na( lat ) & !is.na( lng ) ) %>%
filter( not( lat == modal( lat ) & lng == modal( lng ) ) )

# Convert the bfro dataframe to a spatial dataframe that contains
# explicit longitude and latitude projected appropriately for plotting.
coordinates( bfro_tbl ) <- ~lng+lat
proj4string( bfro_tbl ) <- CRS("+init=epsg:4326 +lon_wrap=170")
bfro_tbl_spatial <- spTransform(bfro_tbl,CRS(proj4string(bfro_tbl)))

# Restrict bfro_tbl to those points in the polygons defined by world_subset
bfro_tbl_rows <- bfro_tbl_spatial %>%
over( world_subset ) %>%
is.na() %>%
not() %>%
rowSums() %>%
`!=`(0) %>%
which

bfro_tbl <- as.tibble( bfro_tbl_spatial[ bfro_tbl_rows, ] )

# Create window for spatial analysis
bfro_owin <- as.owin.SpatialPolygons(world_subset)

# Function to plot density of a specific manifestation type.
# plot_resolution is for the density raster, and is mainly used for quick prototyping of the output.
density_plot <- function( density_res ) {

cat( paste0( "Plotting density: … " ) )

bfro_ppp <-
ppp(
x=coordinates(bfro_tbl_spatial)[,1],
y=coordinates(bfro_tbl_spatial)[,2],
window = bfro_owin
)

# This discards ‘illegal’ points outside of the window
bfro_ppp <- as.ppp(bfro_ppp)

bfro_density <- density( bfro_ppp, diggle=T, sigma=2, dimyx = c( density_res, density_res ) )

# Make density image object usable by ggplot as a raster
bfro_density_raster <- raster( bfro_density )
bfro_raster_tbl <- as.tibble( rasterToPoints( bfro_density_raster ) )

# Show the map
gp <- ggplot()

# Add density of sightings as raster.
gp <- gp +
geom_raster( data = bfro_raster_tbl, aes( x=x, y=y, fill = layer ), alpha=0.8, show.legend=FALSE ) +
scale_fill_viridis( option = "cividis", direction=1 )

# Add sightings as points.
gp <- gp +
geom_point( data = as.tibble( bfro_ppp ), aes( x=x, y=y ), colour="yellow", size=0.1, alpha=0.5, show.legend=FALSE )

gp <- gp +
geom_map( data = world_df, aes( map_id=id ), colour="#3c3f4a", fill = "transparent", size = 0.4, map = world_df )

# Theming
gp <- gp +
theme_map()

gp <- gp +
theme(
plot.background = element_rect(fill = "transparent", colour = "transparent"),
panel.border = element_blank(),
)

gp <- gp +
guides( fill = guide_colourbar( title.position="top", direction="horizontal", barwidth=6, barheight=0.4 ) )

cat("done.\n" )
return(gp)

}

# Add bioclimatic points to an existing plot
add_bioclimatic_variables <- function( gp, bioclim = seq( 1, 16 ) ) {

# This gets climatic variables for global range.
# (res=0.5 requires latitude and longitude to define a tile to download,
# but 2.5 minutes of a degree is ~5 miles, so probably good enough.)
#wc <- getData( ‘worldclim’, res=2.5, var=’bio’ )

# Value Label
# 0 Water
# 1 Evergreen Needleleaf forest
# 2 Evergreen Broadleaf forest
# 3 Deciduous Needleleaf forest
# 4 Deciduous Broadleaf forest
# 5 Mixed forest
# 6 Closed shrublands
# 7 Open shrublands
# 8 Woody savannas
# 9 Savannas
# 10 Grasslands
# 11 Permanent wetlands
# 12 Croplands
# 13 Urban and built-up
# 14 Cropland/Natural vegetation mosaic
# 15 Snow and ice
# 16 Barren or sparsely vegetated
# 254 Unclassified
# 255 Fill Value

glcf <- raster( "~/opt/datasets/gis/landcover/glcf/LC_5min_global_2012.tif" )

# We can’t just reproject a raster to wrap differently.
# This splits and merges the two edges.
# (This is fragile, unfortunately, but works here.)
# (Reprojecting is best done as the last step, apparently.)
glcf_west <- crop(glcf, extent(-180, 0, 18, 84))
glcf_east <- crop(glcf, extent(0, 180, 18, 84))
extent(glcf_west) <- c(180, 360, 18, 84)
glcf <- merge(glcf_west, glcf_east )

glcf <- crop( glcf, extent( world_subset ) )
glcf <- projectRaster( glcf, crs = CRS("+init=epsg:4326") )

# Make density image object usable by ggplot as a raster
glcf_raster_tbl <- as.tibble( rasterToPoints( glcf ) )
colnames( glcf_raster_tbl ) <- c ("x", "y", "layer" )

# Add bioclimatic variables
gp <- gp +
geom_raster( data = glcf_raster_tbl[ which( glcf_raster_tbl$layer %in% bioclim ), ], alpha=0.8, aes( x=x, y=y ), fill="#7cfc00", show.legend=FALSE )

}

# Cowplot for full-panel plotting. (Parchment background).
theme_set(theme_cowplot(font_size=4, font_family = "mapfont" ) )

# Only calculate the density plot if it isn’t already stored on disk.
if( not( file.exists( "work/density_plot.rds" ) ) ) {
gp <- density_plot( 1024 )
saveRDS( gp, "work/density_plot.rds" )
} else {
gp <- readRDS( "work/density_plot.rds" )
}

# Create a plot including the bioclimatic variables.
bioclim_gp <-
add_bioclimatic_variables( gp, seq( 1, 5 ) )

# Construct full plot, with title and backdrop.
title <- ggdraw() +
draw_label("Bigfoot Sightings in North America", fontfamily="mapfont", colour = "#3c3f4a", size=20, hjust=0, vjust=1, x=0.02, y=0.88) +
draw_label("http://www.weirddatascience.net | @WeirdDataSci", fontfamily="mapfont", colour = "#3c3f4a", size=12, hjust=0, vjust=1, x=0.02, y=0.40)

data_label <- ggdraw() +
draw_label("Data: http://www.bfro.net", fontfamily="mapfont", colour = "#3c3f4a", size=12, hjust=1, x=0.98 )

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

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

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

# Add bioclimatic variables to plot.
title <- ggdraw() +
draw_label("Bigfoot Sightings in North America Showing Forest Cover", fontfamily="mapfont", colour = "#3c3f4a", size=20, hjust=0, vjust=1, x=0.02, y=0.88) +
draw_label("http://www.weirddatascience.net | @WeirdDataSci", fontfamily="mapfont", colour = "#3c3f4a", size=12, hjust=0, vjust=1, x=0.02, y=0.40)

data_label <- ggdraw() +
draw_label("Data: http://www.bfro.net", fontfamily="mapfont", colour = "#3c3f4a", size=12, hjust=1, x=0.98 )

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

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

save_plot("output/bigfoot-density-forest.pdf",
parchment_plot,
base_width = 16,
base_height = 9,
base_aspect_ratio = 1.78 )

[/code]

From this initial plot we can see that, whilst tree cover is certainly not a bad predictor of Bigfoot sightings, it is far from a definitive correlation. The largest cluster, around the US-Canada border near Toronto, is principally lakes; whilst the secondary cluster in Florida is neither significantly forested or even close to the Everglades, which might have been expected. From the other perspective, there are significant forested areas for which sightings are reasonably rare.

The mystery of Bigfoot’s natural habitat and preferences is, therefore, very much unanswered from our initial analysis. With a broad range of variables still to explore — climate, altitude, food sources — future posts will attempt to determine what conditions lend themselves to strange survivals of pre-human primate activity. Perhaps changing conditions have pushed our far-distant cousins to previously unsuspected regions.

Until then, we keep following these trails into data unknown.

References

The Shape of the Other: The Evolution of UFO Sightings by Shape

moth — Wed, 20 Jun 2018 16:09:02 +0000

In earlier analyses of the UFO phenomenon, based on the NUFORC dataset, we have examined the global density of sightings, and the relative distribution of sightings against the location of military bases in the United States. All of these analyses have, however, considered individual sightings to be more or less equivalent.

The NUFORC dataset, however, provides much more detailed information on individual sightings. The most significant immediate feature of each report, beyond its time and location, is the recorded shape of each object. Was the reported UFO saucer-shaped? Triangular? A flash of light? Or did the individual see more more than one object moving in formation? By considering this aspect of the data we can interrogate more closely the nature of UFO sightings over the years.

The NUFORC dataset classifies each sighting as one of 46 possible shapes, with approximately three percent of entries not being classified directly. Of those 46, several categories overlap each other; “Triangle”, “triangle”, and “Triangular” are all, for example, possibilities. Additionally, the dataset contains both “other” and “unknown” categories.

With a minimal level of cleaning we are left with 26 categories, including the familiar circular objects, but also “crescent” (2 entries), “hexagon” (1 entry), and “cross” (356 entries). For easier representation and analysis, we have collapsed several infrequent and similar categories together, resulting in eight top-level categories distributed in the following way:

Frequency of UFO sightings by shape.

Frequency of UFO sightings by shape. (PDF Version.) | Frequency of UFO sightings by shape (all categories). (PDF Version.)

We can clearly see from this that lights are the most commonly-reported extraterrestrial manifestation, closely followed by the category of “round” objects that most closely matches, perhaps, the traditional concept of a UFO sighting. This category does, however, extend to spheres, disks, ovals, domes, eggs, and cones.

This breakdown of frequency is somewhat deceptive: the sightings reported in the NUFORC database span from a reported 1400CE (a roughly-dated cave painting in Texas depicting a saucer-shaped object) to the present day. For reliability, we have discounted reports prior to 1900CE from our analysis. In our data, then, are these sightings consistent over time? Has the form and nature of our extraterrestrial visitors shifted in recent history? Are we naively assuming that all objects are from the same source, and with similar intentions?

At the most mundane level, the total volume of sightings has sharply increased since the early reports in the dataset. The total number of reported sightings in the 1940s was 144 in total, compared with 4934 sightings in 2017 alone, and a peak of 8651 sightings in 2014.

Broken down by category, the total number of sightings since 1945 is shown below. We have removed sightings prior to 1945 from this diagram, as they were sufficiently low in volume that they were not visible. The most marked rise in sightings begins in the mid-1990s, with 502 sightings in 1994 rising to 1467 in 1995, with the overall rising trend following until its peak in 2014.

Count of sightings by shape over time.

Count of sightings by shape over time. (PDF Version.)

To understand the specific nature of visitations, however, it is useful to view sightings as a proportion of the total, rather than their absolute numbers.

Proportion of UFO sightings by shape over time.

Proportion of UFO sightings by shape over time. (PDF Version.)

It is clear that, allowing for the overall increase in numbers, the proportion of generically round UFOs has reduced since the 1950s, when they clearly dominated. The most significant increase has been the rise in triangular sightings, including “delta” and “chevron” shaped craft. This conceivably tracks the development of terrestrial military aircraft towards “delta wing” and similar profiles.

Since the mid-90s there have been a marked increase in sightings reported simply as “lights” — flashes, fireballs, flares, and similar. From 2000 onwards, the relative proportions appear to be mainly steady.

For specific cases, 1995 shows an oddly large proportion of unclassified “other” sightings, although these do not seem to be the result of any particular event. The highest proportion of these are in Seattle, with 38 sightings, but are spread fairly evenly throughout the year.

Breaking down sightings according to specific times, rather than year-by-year reveals some other points of interest. Firstly, sightings by month:

Per-month UFO sightings by shape.

Per-month UFO sightings by shape. (PDF Version.)

Sightings are much more common in the Northern hemisphere’s summer months, presumably due to higher numbers of people spending time outside and being in a position to spot anomalous phenomena.

Breaking down sightings by hour, we can see that sightings are far more common at night than during the day, with the lowest volumes of sightings around 08:00, and the highest at 21:00. For both monthly and hourly sightings, the relative proportions of sightings by shape remain relatively constant. We can conclude that UFOs’ activity is unrelated to their shape. This consistency of behaviour suggests that, regardless of their shape, the various forms of UFO, however they disguise themselves, may be drawn from a single source.

Hourly UFO sightings by shape.

Hourly UFO sightings by shape. (PDF Version.)

This is far from a definitive breakdown of UFO behaviour by their shape. In future posts we will explore whether differing shapes of UFO cluster geographically, and the extent to which cotemporaneous sightings can be correlated by their shape and description.

You can keep up to date with our latest statistical esoterica on Twitter at @WeirdDataSci.

As always, keep delving.

Code Note:
In developing this entry we have moved from using the excellent work of Tim Renner in gathering and cleaning the NUFORC UFO dataset, and developed our own scraping code. Most posts here have included source code at the bottom of each entry. As this post relied on more than the usual code, however, and included multiple outputs, we are including only representative code. The full scraping and analysis code will be the focus of a future post.

Show analysis code

Data:

National UFO Reporting Centre: http://www.nuforc.org.

Other:

Tox Typewriter font: https://www.dafont.com/tox-typewriter.font

Proportional Time Series Plot Code:

[code language=”r”]

# Structure of ufo_tbl object output from NUFORC scraping code
Classes ‘tbl_df’, ‘tbl’ and ‘data.frame’: 114949 obs. of 8 variables:
$ occurred: POSIXct, format: "1995-02-02 23:00:00" "1995-02-02 19:15:00" "1995-02-02 20:10:00" "1994-12-13 18:55:00" …
$ reported: POSIXct, format: "1995-02-02 10:47:00" "1995-02-03 06:06:00" "1995-02-03 10:32:00" "1995-02-03 17:45:00" …
$ posted : POSIXct, format: "2003-02-05" "2003-03-04" "2003-03-21" "2003-03-21" …
$ location: chr "Shady Grove, OR" "Denmark, WI" "Traverse City, MI" "Murphy, NC" …
$ shape : chr "Other" "Round" "Other" "Other" …
$ duration: chr "15 min" "75 min" "2 min (?)" "" …
$ details : chr "Man and wife witness very bright, moving light over ridge to southwest. Flashing green & red lights. Good rept." "Caller, and apparently several other people, witnessed multiple strange craft streaking through the night sky i"| __truncated__ "Four children left home to go sledding on a hill located approximately 500 yards away. At approximately 2010 h"| __truncated__ "Woman reports seeing strange, lighted obj. with \"arms.\" Many witnesses and written reports." …
$ date : Date, format: "1995-02-02" "1995-02-02" "1995-02-02" "1994-12-13" …
[/code] [code language=”r”]

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

library(ggplot2)
library(ggridges)
library(ggthemes)
library(showtext)

library(viridis)

# Create a summary barplot for UFO activity by shape over time

# Load the data from scraping http://www.nuforc.org
ufo_tbl <- readRDS( "data/ufo_processed.rds" )

# Load font
font_add( "mapfont", "font/Tox Typewriter.ttf")
showtext_auto()

# Shape entries are inconsistent. Manual fixing required.
# Most inconsistency is lowercase and uppercase, so use str_to_title to fix
# that.
ufo_tbl$shape <- ufo_tbl$shape %>%
str_to_title %>%
str_replace( "(^$|Unknown)", "Other" ) %>%
str_replace( "(Changed|Changing)", "Changing" ) %>%
str_replace( "(Delta|Triangle|Triangular)", "Triangle" ) %>%
str_replace( "(Circle|Round|Dome)", "Circle" ) %>%
# Categories too small to be represented individually
str_replace( "(Crescent|Pyramid|Hexagon|Dome)", "Other" ) %>%
str_replace( "Flare", "Light" )

# Cut off at 1900, as earlier sightings are infrequent and unreliable.
# (Unlike those post 1900…)
ufo_tbl <- ufo_tbl %>%
filter( occurred >= "1900-01-01" ) %>%
filter( occurred <= "2019-01-01" )

# Proportional frequency of each sighting
ufo_tbl$date <- lubridate::date( ufo_tbl$occurred )
frequency_tbl <- ufo_tbl %>%
count( aggr_date = year(occurred), shape ) %>%
group_by( aggr_date ) %>%
mutate(freq = n / sum(n))

colnames( frequency_tbl ) <- c( "aggr_date", "shape", "n" , "freq")

gp <- ggplot( frequency_tbl, aes( x=aggr_date, fill=shape, y=freq ) ) +
labs( x="Date", y="Sightings\n(Proportion)" ) +
geom_col( alpha=0.4 ) +
scale_fill_viridis( name = "Shape", option="D", discrete=TRUE ) +
theme_dark() +
theme(
panel.background = element_rect(fill = "#222222", colour = "#222222"),
plot.background = element_rect(fill = "#222222", colour = "#222222"),
legend.key = element_rect(fill = "#222222"),
legend.background = element_rect(fill = "#222222"),
legend.title = element_text( size=18, color="#eeeeee", family="mapfont", margin = margin( t = 20 ) ),
legend.text = element_text( size=14, color="#eeeeee", family="mapfont", margin = margin( t = 20 ) ),
text = element_text( color="#eeeeee", family="mapfont" ),
axis.title.x = element_text( size=18, color="#eeeeee", family="mapfont", margin = margin( t = 20 ) ),
axis.title.y = element_text( size=18, color="#eeeeee", family="mapfont", margin = margin( r = 20 ) ),
axis.text = element_text( size=14, color="#eeeeee", family="mapfont" ),
panel.grid.major = element_line(colour = "#444444"),
panel.grid.minor = element_line(colour = "#444444"),
)

# Cowplot trick for ggtitle
title <- ggdraw() +
draw_label("Propotion of UFO Sightings by Shape, 1900-2017", fontfamily="mapfont", colour = "#eeeeee", size=18, hjust=0, vjust=1, x=0.02, y=0.88) +
draw_label("http://www.weirddatascience.net | @WeirdDataSci", fontfamily="mapfont", colour = "#eeeeee", size=14, hjust=0, vjust=1, x=0.02, y=0.40)

data_label <- ggdraw() +
draw_label("Data: http://www.nuforc.org", fontfamily="mapfont", colour = "#eeeeee", size=14, hjust=1, x=0.98 )

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

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

tgp <- tgp +
theme(
panel.background = element_rect(fill = "#222222", colour = "#222222"),
plot.background = element_rect(fill = "#222222", colour = "#222222"),
)

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

[/code]

Paranormal Manifestations in the British Isles

moth — Sat, 17 Mar 2018 09:20:09 +0000

The British Isles are ancient, haunted places. Pre-Roman legends and folk songs are filled with dragons, magic, and strange, wild creatures. Spirits, fairies, and all kinds of imps and goblins roam the countryside with intent ranging from the mischievous to the malevolent. Will-o’-the-wisps lead unwary travellers deep into marshes in the night, before vanishing. The sad ghosts of past tragedies reside in ancient castles and stately homes.

In more recent history, strange beasts have been rumoured to live wild in the open spaces, whether large predators escaped from zoos, the last survivals of prehistory, or spirits. Every village, town, and county has its own stories and traditions.

The Paranormal Database is a collection of both traditional and recent paranormal events in Britain and Ireland. It contains details of almost 20,000 hauntings, cryptozoological sightings, legends, monsters, UFO’s, and other strange phenomena, with details of the date and time of sightings, the location, and brief descriptions.

The data is not easily accessible beyond directly reading pages, and required some effort and time to scrape and make usable. Paranormal Database entries contain names, dates, locations, and comments as unstructured text and so will require further effort to perform a more thorough analysis. The R code used to scrape the website is included at the end of this post.

To understand the range and breadth of the paranormal life of the British Isles, we will focus on the data stored in the Paranormal Database. For this initial entry, we will take a first look at the data and get an overview of what mind-numbing horrors are most commonly encountered by the unsuspecting traveller in the United Kingdom and beyond.

Frequency of paranormal sightings in the British Isles.

Frequency of paranormal sightings in the British Isles. (PDF version)

Show frequency table of manifestations

Paranormal Manifestations in the British Isles

Manifestation Type	Occurrences
Haunting Manifestation	12376
Legend	1662
Cryptozoology	835
Shuck	688
Poltergeist	625
Unknown Ghost Type	614
Fairy	550
Other	427
Alien Big Cat	382
UFO	336
Crisis Manifestation	277
Dragon	190
Curse	183
Post-Mortem Manifestation	179
Environmental Manifestation	152
Manifestation of the Living	44
Werewolf	36
Vampire	34
Spontaneous Human Combustion	28
Experimental Manifestation	2

As we can see from the diagram and the frequency table, hauntings are by far the most common manifestation in paranormal Britain, being an order of magnitude greater than the number of legend recorded. Examining the list, beyond “Haunting Manifestation” we see that several of the most common types are variants: both poltergeist activity and unknown types of ghost represent a significant amount of the total events recorded.

Cryptozoology, in its various forms, is also well-represented. The phenomenon of the Black Shuck, a ghostly black dog, is one of the highest categories next to the main cryptozoology category, and alien big cats are close behind. Dragons, werewolves, and vampires, perhaps, deserve to be classed more as monstrous entities than cryptozoological oddities and are, in any case, far less common.

In brief conclusion, then, the unquiet dead are by far the most numerous beings to trouble the unhappy folk of the British Isles; twisted mockeries of natural fauna are far from rare.

Do particular phenomena cluster in regions and, if so, where? Are werewolves truly more commonly seen when the moon is full? Have certain manifestations become more common as time passes? Are certain sightings clustered temporally as well as geographically? Are the most haunted areas also the most cryptozoologically active? With access to the full horror of the data we can begin to answer these question about the darkest corners of the United Kingdom.

Full code for scraping the data and producing the plot are given below.

You can keep up to date with our latest visions of the statistical unknown on Twitter at @WeirdDataSci.

Show analysis code

Data:

The Paranormal Database: http://www.paranormaldatabase.com

Other:

JSL Ancient font: http://www.1001fonts.com/jsl-ancient-font.html
Rvest web scraping library: http://blog.rstudio.com/2014/11/24/rvest-easy-web-scraping-with-r/ | https://cran.r-project.org/web/packages/rvest/index.html
xkcd styling for ggplot2: http://xkcd.r-forge.r-project.org/

Paranormal Database Scraping Code:

[code language=”r”] library(rvest)
library(magrittr)
library(tidyr)
library(stringr)
library(dplyr)

# Base URL for scraping
paranormal.base <- "http://www.paranormaldatabase.com"

# Extract links from a given page. Return a list with full URLs.
extract.links <- function( in.html, base.url ) {

# Read the page and extract any links from the ‘hero-unit’ div.
# Extract all links, making relatives absolute.
in.html %>%
html_nodes( ‘.hero-unit’ ) %>%
html_nodes( ‘a’ ) %>%
html_attr( ‘href’ ) %>%
url_absolute( base.url )

}

# Function to extract a paranormal database entries page into a dataframe.
# Returns a dataframe of the entries from the given HTML.
extract.entries <- function( in.html ) {

# Select all table cells with a width of 100% — ugly, but identifies the
# entries themselves.
page.entries <- in.html %>%
html_nodes( xpath=’//td[ contains( @width, "100" ) ]’ ) %>%
html_text() %>%
str_replace_all( "[\r\n]" , "" )

# If any entries were found, process them.
if( ( length( page.entries ) > 0 ) &&
(str_detect(page.entries, "(.*[[:graph:]])\\s*Location: (.*[[:graph:]])\\s*Type: (.*[[:graph:]])\\s*Date / Time: (.*[[:graph:]])\\s*Further Comments: (.*[[:graph:]])\\s*")) ) {
# Each entry is a string containing:
# – Location:
# – Type:
# – Date / Time:
# – Further Comments:
# So split the string on these and put the entries into a dataframe.
page.entries.df <- data.frame( entry=page.entries) %>%
tidyr::extract(entry, into=c(‘title’, ‘location’, ‘type’, ‘date’, ‘comments’), "(.*[[:graph:]])\\s*Location: (.*[[:graph:]])\\s*Type: (.*[[:graph:]])\\s*Date / Time: (.*[[:graph:]])\\s*Further Comments: (.*[[:graph:]])\\s*" )

# Further split these into subtypes where appropriate. Both ‘location’ and ‘type’ are often split into a main and a subtype by a space-surrounded hyphen.
# As we’ll do this twice, make it a function. This takes a base column name, a new name for the sub-column, and the separator string.
coalesce.join <- function( base.data, base.column, sub.column, separator ) {

base.data <- base.data %>%
tidyr::extract( base.column, into=c("tmp.main", sub.column), separator, remove=FALSE)

# Combine the old base column with the new tmp.main column, using base.column to fill in the NAs in tmp.main
# where the separator was not matched.
base.data[ base.column ] <- coalesce( base.data[[ "tmp.main" ]], base.data[[ base.column ]] )
base.data <- base.data %>%
select(-one_of("tmp.main"))

}

# Split ‘type’
page.entries.df <- coalesce.join( page.entries.df, "type", "subtype", "(.*) – (.*)" )
page.entries.df <- coalesce.join( page.entries.df, "location", "sublocation", "(.*) – (.*)" )

page.entries.df

}

# Read each page’s links to populate a list to process.
# Each page contains a "Return to Regional Listing" link, and a link to enter the listings.
# That listing can be either a straight entries page, or a link to subpages.

# Starting with the base page, pull every link in the main ‘hero-unit’ div and
# add it to a ‘to.process’ vector, checking that that URL is not already
# listed. Also pass along a ‘processed’ vector in the recursive calls so that
# we don’t overly duplicate results.

# WARNING: As written, this will cause a lot of duplication due to the lack of
# global list of processed links. As this was a one-off script, I haven’t fixed this.

# Base URL to being processing
paranormal.regions <- "http://www.paranormaldatabase.com/regions/regions.htm"

# Recursively process the top-level URL
scrape.recurse <- function( in.url, processed ) {

message( paste("Processing", in.url ) )

# Try to fetch this URL and any subpages.
# Warn on failure
page <- tryCatch(
{
# Fetch and parse HTML of current page.
read_html( in.url )
},
error=function( cond ) {
message( paste( "URL caused an error:", in.url ))
message( "Error message:")
message( cond )
return( NULL )
},
warning=function( cond ) {
message( paste( "URL caused a warning:", in.url ))
message( "Warning message:")
message( cond )
return( NULL )
},
finally={
}
)

if( is.null( page ) ) {
return( NULL )
}
else {
# Get the current page’s entries
links <- extract.links( page, in.url )
entries <- extract.entries( page )

lapply( entries$title, function(x) cat( x, "… ", sep="" ) )
cat( "\n")

# Recurse, but don’t follow any known links
new.entries <-
lapply( setdiff( links, processed ), function(x) scrape.recurse( x, union( links, processed ) ) ) %>%
bind_rows()

# Bind entries from sub-pages to this page’s entries.
all.entries <- bind_rows( entries, new.entries )

# Report success and return results
message( paste( "Successfully processed:", in.url ) )
return( all.entries )
}

}

# Run the scraping and parsing, then remove duplicates.
all.entries <- scrape.recurse( paranormal.regions, paranormal.regions )
paranormal.df <- unique( all.entries )

# Manually fix some type entries.
paranormal.df$type[ which( paranormal.df$type == "legend" ) ] <- "Legend"
paranormal.df$type[ which( paranormal.df$type == "Haunting Manifestation?" ) ] <- "Haunting Manifestation"
paranormal.df$type[ which( paranormal.df$type == "SHC" ) ] <- "Spontaneous Human Combustion"
paranormal.df$type[ which( paranormal.df$type == "ABC" ) ] <- "Alien Big Cat"

# With all values scraped, save data.
save( paranormal.df, file="paranormal.Rdata")

[/code]

Paranormal Manifestations in the British Isles Plotting Code:
[code language=”r”] library(ggplot2)
library(jpeg)
library(xkcd)
library(showtext)
library(grid)
library(gridExtra)

# Create a summary barplot for paranormal activity in the UK.

# Load the data from scraping http://www.paranormaldatabase.com/
load( "../data/paranormal.Rdata" )

# Process the data to frequency counts of each type of event.
counts <- table( paranormal.df$type )
df <- as.data.frame.table( sort(counts, decreasing=FALSE) )
colnames( df ) <- c("type", "frequency" )

# Create the plot.
# Use the xkcd package to create irregular bars for a hand-drawn look.
df$xmin <- 1
df$xmax <- df$frequency
df$ymin <- as.numeric(df$type) – 0.1
df$ymax <- as.numeric(df$type) + 0.1

xrange <- range( min( df$xmin ), max( df$xmax ) )
yrange <- range( min( df$ymin ), max( df$ymax ) + 1 )
mapping <- aes( xmin=xmin, ymin=ymin, xmax=xmax, ymax=ymax )

# Load font
font_add( "handwriting", "/usr/share/fonts/TTF/weird/JANCIENT.TTF" )
showtext_auto()

# Load background image.
bg.image <- jpeg::readJPEG("img/vellum.jpg")
bg.grob <- rasterGrob( bg.image, interpolate=TRUE,
width = 1.8,
height = 1.4 )

gp <- ggplot( data=paranormal.df, aes( x=frequency, y=type ) ) +
annotation_custom( bg.grob, xmin=-Inf, xmax=Inf, ymin=-Inf, ymax=Inf ) +
xkcdrect( mapping, df, alpha=0.6, fill="#8a0707", size=1 ) +
xkcdaxis( xrange, yrange ) +
theme(
text = element_text( size=12, color="#232732", family="handwriting" ),
plot.background = element_rect(fill = "transparent", color="transparent"),
panel.background = element_rect(fill = "transparent", color="transparent"),
plot.title = element_text( size=24, colour="#232732", family="handwriting" ),
axis.title = element_text( size=18, colour="#232732", family="handwriting" ),
axis.text.x=element_text( size=12, color="#232732", family="handwriting" ),
axis.text.y=element_text( size=12, color="#232732", family="handwriting", hjust=1) ) +
scale_y_discrete( labels=c( as.character( df$type ) ) ) +
scale_x_continuous( expand = c( 0, 0 ) ) +
ylab( "Phenomenon" ) +
xlab( "Occurrence" ) +
labs( caption = "Data from: http://www.paranormaldatabase.com" ) +
ggtitle("Paranormal Manifestations in the British Isles", subtitle="http://www.weirddatascience.net | @WeirdDataSci")

# To allow the background image to extend to the edge of the panel, we have to generate
# a gtable directly from gp, then turn off clipping.
p2 <- ggplot_gtable(ggplot_build(gp))
p2$layout$clip[p2$layout$name=="panel"] <- "off"

# To create the output, we need to call grid.draw on the gtable.
# Use the pdf device to draw directly to preserve clipping and fonts.
# showtext has to be called explicitly in here, for some reason.
pdf( file="output/haunting.pdf", width=16, height=9 )
showtext_begin()
grid.draw(p2)
showtext_end()
dev.off()

[/code]