Building a shiny app to explore historical newspapers: a step-by-step guide

# This functions will be used within the next functions to extract the relevant pieces

extractor <- function(string, regex, all = FALSE){
    if(all) {
        string %>%
            str_extract_all(regex) %>%
            flatten_chr() %>%
            str_remove_all("=|\\\"") %>%
            #str_extract_all("[:alnum:]+|.|,|\\?|!", simplify = FALSE) %>%
            map(paste, collapse = "") %>%
            flatten_chr()
    } else {
        string %>%
            str_extract(regex) %>%
            str_remove_all("=|\\\"") %>%
            #str_extract_all("[:alnum:]+|.|,|\\?|!", simplify = TRUE) %>%
            paste(collapse = " ") %>%
            tolower()
    }
}

# This function extracts the data from the METS files, and returns a tibble:

extract_mets <- function(article){
    id <- article %>%
        extractor("(?<=ID)(.*?)(?=LABEL)")

    label <- article %>%
        extractor("(?<=LABEL)(.*?)(?=TYPE)")

    type <- article %>%
        extractor("(?<=TYPE)(.*?)(?=>)")

    begins <- article %>%
        extractor("(?<=BEGIN)(.*?)(?=BETYPE)", all = TRUE)

    tibble::tribble(~label, ~type, ~begins, ~id,
                    label, type, begins, id) %>%
        unnest()
}

# This function extracts the data from the ALTO files, and also returns a tibble:

extract_alto <- function(article){
    begins <- article[1] %>%
        extractor("(?<=^ID)(.*?)(?=HPOS)", all = TRUE)

    content <- article %>%
        extractor("(?<=CONTENT)(.*?)(?=WC)", all = TRUE)

    tibble::tribble(~begins, ~content,
                    begins, content) %>%
        unnest()
}

# This function takes the path to a page as an argument, and extracts the data from 
# each article using the function defined above. It then writes a flat CSV to disk.

alto_csv <- function(page_path){

    page <- read_file(page_path)

    doc_name <- str_extract(page_path, "(?<=/text/).*")

    alto_articles <- page %>%
        str_split("TextBlock ") %>%
        flatten_chr()

    alto_df <- map_df(alto_articles, extract_alto)

    alto_df <- alto_df %>%
        mutate(document = doc_name)

    write_csv(alto_df, paste0(page_path, ".csv"))
}

# Same as above, but for the METS file:

mets_csv <- function(page_path){

    page <- read_file(page_path)

    doc_name <- str_extract(page_path, "(?<=/).*")

    mets_articles <- page %>%
        str_split("DMDID") %>%
        flatten_chr()

    mets_df <- map_df(mets_articles, extract_mets)

    mets_df <- mets_df %>%
        mutate(document = doc_name)

    write_csv(mets_df, paste0(page_path, ".csv"))
}

# Time to use the above defined functions. First, let's save the path of all the ALTO files
# into a list:

pages_alto <- str_match(list.files(path = "./", all.files = TRUE, recursive = TRUE), ".*/text/.*.xml") %>%
    discard(is.na)

# I use the {furrr} library to do the extraction in parallel, using 8 cores:

library(furrr)

plan(multiprocess, workers = 8)

tic <- Sys.time()
future_map(pages_alto, alto_csv)
toc <- Sys.time()

toc - tic

#Time difference of 18.64776 mins


# Same for the METS files:

pages_mets <- str_match(list.files(path = "./", all.files = TRUE, recursive = TRUE), ".*mets.xml") %>%
    discard(is.na)


library(furrr)

plan(multiprocess, workers = 8)

tic <- Sys.time()
future_map(pages_mets, mets_csv)
toc <- Sys.time()

toc - tic

#Time difference of 18.64776 mins

mets <- read_file("1533660_newspaper_lunion_1860-11-14/1533660_newspaper_lunion_1860-11-14-mets.xml")

mets_articles2 <- mets %>%
    str_split("DMDID") %>%
    flatten_chr()


alto <- read_file("1533660_newspaper_lunion_1860-11-14/text/1860-11-14_01-00001.xml")

alto_articles <- alto %>%
    str_split("TextBlock ") %>%
    flatten_chr()

mets_df2 <- mets_articles2 %>%
    map_df(extract_mets)

# Same exercice for ALTO

alto_df <- alto_articles %>%
    map_df(extract_alto)

library(tidyverse)
library(udpipe)
library(textrank)
library(tidytext)

# First, I need the path to each folder that contains the ALTO and METS files. Each newspaper
# data is inside its own folder, one folder per publication. Inside, there's `text` folder that
# contains the ALTO and METS files. This is also where I saved the .csv files from before.

pathdirs <- list.dirs(recursive = FALSE) %>%
    str_match(".*lunion.*") %>%
    discard(is.na)

# The following function imports the METS and the ALTO csv files, joins them, and does some 
# basic cleaning. I used a trick to detect German articles (even though L'Union is a French publication
# some articles are in German) and then remove them.

tidy_papers <- function(path){
    mets_path <- paste0(path, "/", list.files(path, ".*.xml.csv"))
    mets_csv <- data.table::fread(mets_path)

    alto_path <- paste0(path, "/text/", list.files(paste0(path, "/text/"), ".*.csv"))
    alto_csv <- map_dfr(alto_path, data.table::fread)

    final <- full_join(alto_csv, mets_csv, by = "begins") %>%
        mutate(content = tolower(content)) %>%
        mutate(content = if_else(str_detect(content, "hyppart1"), str_extract_all(content, "(?<=CONTENT_).*", simplify = TRUE), content)) %>%
        mutate(content = if_else(str_detect(content, "hyppart2"), NA_character_, content)) %>%
        # When words are separated by a hyphen and split over two lines, it looks like this in the data.
        # ex SUBS_TYPEHypPart1 SUBS_CONTENTexceptée
        # ceptée SUBS_TYPEHypPart2 SUBS_CONTENTexceptée
        # Here, the word `exceptée` is split over two lines, so using a regular expression, I keep
        # the string `exceptée`, which comes after the string `CONTENT`,  from the first line and 
        # replace the second line by an NA_character_
        mutate(content = if_else(str_detect(content, "superscript"), NA_character_, content)) %>%
        mutate(content = if_else(str_detect(content, "subscript"), NA_character_, content)) %>%
        filter(!is.na(content)) %>%
        filter(type == "article") %>%
        group_by(id) %>%
        nest %>%
        # Below I create a list column with all the content of the article in a single string.
        mutate(article_text = map(data, ~paste(.$content, collapse = " "))) %>%
        mutate(article_text = as.character(article_text)) %>%
        # Detecting and removing german articles
        mutate(german = str_detect(article_text, "wenn|wird|und")) %>%
        filter(german == FALSE) %>%
        select(-german) %>%
        # Finally, creating the label of the article (the title), and removing things that are 
        # not articles, such as the daily feuilleton.
        mutate(label = map(data, ~`[`(.$label, 1))) %>%
        filter(!str_detect(label, "embranchement|ligne|bourse|abonnés|feuilleton")) %>%
        filter(label != "na")

    # Save the data in the rds format, as it is not a flat file
    saveRDS(final, paste0(path, "/", str_sub(path, 11, -1), ".rds"))
}

# Here again, I do this in parallel

library(furrr)

plan(multiprocess, workers = 8)

future_map(pathdirs, tidy_papers)

# Only run this once. This downloads the model for French
udpipe_download_model(language = "french")

# Load the model
udmodel_french <- udpipe_load_model(file = 'french-gsd-ud-2.3-181115.udpipe')

# Save the path of the files to annotate in a list:
pathrds <- list.files(path = "./", all.files = TRUE, recursive = TRUE) %>% 
  str_match(".*.rds") %>%
  discard(is.na)

annotate_rds <- function(path, udmodel){

    newspaper <- readRDS(path)

    s <- udpipe_annotate(udmodel, newspaper$article_text, doc_id = newspaper$label)
    x <- data.frame(s)

    saveRDS(x, str_replace(path, ".rds", "_annotated.rds"))
}

library(furrr)
plan(multiprocess, workers = 8)
tic <- Sys.time()
future_map(pathrds, annotate_rds, udmodel = udmodel_french)
toc <- Sys.time()
toc - tic

path_annotatedrds <- list.files(path = "./", all.files = TRUE, recursive = TRUE) %>% str_match(".*_annotated.rds") %>%
    discard(is.na)

prepare_tf_idf <- function(path){

    annotated_newspaper <- readRDS(path)

    tf_idf_data <- annotated_newspaper %>%
        filter(upos %in% c("NOUN", "VERB", "ADJ", "PROPN")) %>%
        filter(nchar(lemma) > 3) %>%
        count(doc_id, lemma) %>%
        bind_tf_idf(lemma, doc_id, n) %>%
        arrange(desc(tf_idf)) %>%
        group_by(doc_id)

    name_tf_idf_data <- str_split(path, "/", simplify = 1)[1] %>%
        paste0("_tf_idf_data.rds")  %>%
        str_sub(start = 9, -1)

    saveRDS(tf_idf_data, paste0("tf_idf_data/", name_tf_idf_data))
}

library(furrr)
plan(multiprocess, workers = 8)

future_map(path_annotatedrds, prepare_tf_idf)

library(textrank)
library(brotools)

path_annotatedrds <- list.files(path = "./", all.files = TRUE, recursive = TRUE) %>% str_match(".*_annotated.rds") %>%
    discard(is.na)

prepare_textrank <- function(path){

    annotated_newspaper <- readRDS(path)

    # sentences summary
    x_text_rank <- annotated_newspaper %>%
        group_by(doc_id) %>%
        nest() %>%
        mutate(textrank_id = map(data, ~unique_identifier(., c("paragraph_id", "sentence_id")))) %>%
        mutate(cleaned = map2(.x = data, .y = textrank_id, ~cbind(.x, "textrank_id" = .y))) %>%
        select(doc_id, cleaned)

    x_text_rank2 <- x_text_rank %>%
        mutate(sentences = map(cleaned, ~select(., textrank_id, sentence))) %>%
        # one_row() is a function from my own package, which eliminates duplicates rows
        # from a data frame
        mutate(sentences = map(sentences, ~one_row(., c("textrank_id", "sentence"))))

    x_terminology <- x_text_rank %>%
        mutate(terminology = map(cleaned, ~filter(., upos %in% c("NOUN", "ADJ")))) %>%
        mutate(terminology = map(terminology, ~select(., textrank_id, "lemma"))) %>%
        select(terminology)

    x_final <- bind_cols(x_text_rank2, x_terminology)

    possibly_textrank_sentences <- possibly(textrank_sentences, otherwise = NULL)

    x_final <- x_final %>%
        mutate(summary = map2(sentences, terminology, possibly_textrank_sentences)) %>%
        select(doc_id, summary)

    name_textrank_data <- str_split(path, "/", simplify = 1)[1] %>%
        paste0("_textrank_data.rds") %>%
        str_sub(start = 9, -1)

    saveRDS(x_final, paste0("textrank_data/", name_textrank_data))
}

library(furrr)
plan(multiprocess, workers = 8)

future_map(path_annotatedrds, prepare_textrank)