Extraccion de tablas de PDF con R tabulizer

No son extrañas las situaciones en las que los datos, que se desea analizar, se encuentran contenidos en tablas de archivos PDF. En general, desde hace tiempo, situaciones como esa no representan un obstaculo insalvable; existen herramientas eficaces para extraer la data y ponerla en disposición de ser procesada, en alguna forma que sea de interés. En R, existen varios paquetes, que ofrecen medios para extraer datos de documentos PDF: pdftools y tabulizer, son dos bastante conocidos y descargados muchas veces.
Este ejercicio, involucra la extracción de los datos de una tabla, contenida en un PDF, además de el procesamiento correspondiente para disponer los datos, en una forma que resulte adecuada para efectuar operaciones en ellos: producir gráficos o agregados.
Descargué un archivo contenido en la página:

https://www.worldwater.org/water-data/

Concretamente la tabla 10, llamada:Bottled Water Consumption by Country, 1997 to 2004

library(tabulizer)
library(magrittr)

El comando tabulizer::extract_tables(), permite leer los datos, bien sea desde una URL o una dirección en el computador.

p <- "~/BottledWater_pdf_Table10.pdf"
t <- tabulizer::extract_tables(p, pages = 2:4)

El objeto guardado en 't' es una lista de tres componentes, que se corresponden, aproximadamente, con las hojas especificadas para extracción, en el argumento 'pages'.

class(t) # [1] "list"

Para averiguar la clase, de cada uno de los componentes de la lista 't'

lapply(t, class)
# [[1]]
# [1] "matrix"

# [[2]]
# [1] "matrix"

# [[3]]
# [1] "matrix"

La lista contiene, tres matrices, correspondientes a las tres hojas extraídas del PDF. Para indagar, sobre la forma en que están contenidos los datos en esas 3 matrices:

lapply(t, head, 3)

De esa manera vemos que las dos primeras matrices, presentan los nombres en las variables, en la primera fila de la matriz, pero sus encabezados son los numeros de columna, para no sobrepoblar el espacio con todo el resultado muestro, unicamente las dos filas iniciales, de la primera matriz:

# [[1]]
#     [,1]         [,2]            [,3]     [,4]     [,5]     [,6]     [,7]     [,8]     [,9]     [,10]     
#[1,] "Region"     "Countries"     "1997"   "1998"   "1999"   "2000"   "2001"   "2002"   "2003"   "2004 (P)"
#[2,] "N. America" "United States" "14,362" "15,635" "17,348" "18,563" "20,535" "22,893" "24,199" "25,893"

La idea es hacer una unión vertical de esas tres matrices, y convertirlas en una data frame. Para eso, será conveniente de deshacernos de los elementos que puedan estorbar operaciones ulteriores. Por ejemplo, la (p) y el espacio extra en la columna correspondiente al año 2004.

coln <- t[[1]][1, ] # para guardar los nombres de variables
# para el data.frame
lapply(t, dim)

# [[1]]
# [1] 29 10

# [[2]]
# [1] 29 10

# [[3]]
# [1] 18 10

El funcional 'lapply' y 'dim', sirven para cerciorarnos de que todas las matrices tengan el mismo número de columnas, lo que posibilita la unión vertical. Ahora, los encabezados, que aparecen como primeras filas:

t[[1]] <- t[[1]][2:nrow(t[[1]]), ] # eliminar encabezados
t[[2]] <- t[[2]][2:nrow(t[[2]]), ] # eliminar encabezados

Ahora se pueden unir las matrices verticalmente:

wt <- data.frame(do.call(rbind, t),
                    stringsAsFactors = FALSE)
colnames(wt) <- gsub("\\s+", "", gsub("\\(.\\)", "", coln))
## "\\(.\\)" elimina el parentesis y lo que este contenga y
## "\\s+" elimina el espacio.

Con gsub() y una expresión regular se eliminan los nombres de columnas:(p) y el espacio extra, comentados arriba.

wt %>% head(3) %>% knitr::kable()
|Region     |Countries |1997   |1998   |1999   |2000   |2001   |2002   |2003   |2004   |
|:----------|:---------|:------|:------|:------|:------|:------|:------|:------|:------|
|N. America |Mexico    |10,484 |10,883 |11,579 |12,424 |13,244 |14,767 |16,495 |17,683 |
|Asia       |China*    |2,750  |3,540  |4,610  |5,993  |7,605  |9,887  |10,628 |11,894 |
|S. America |Brazil    |3,932  |4,742  |5,658  |6,817  |8,166  |9,628  |10,758 |11,598 |

Para obsevar qué tipo de variables estan contenidas en, el recien creado, data frame:

vapply(wt, class, character(1)) %>% knitr::kable()
|          |x         |
|:---------|:---------|
|Region    |character |
|Countries |character |
|1997      |character |
|1998      |character |
|1999      |character |
|2000      |character |
|2001      |character |
|2002      |character |
|2003      |character |
|2004      |character |

El resultado muestra variables, que deberían ser numéricas, contenidas como character, en el proceso de extracción y conversión de las listas a matrices con una fila de encabezados, produjo una coercion de todos los valores a tipo character, el siguiente código puede corregir eso:

# conversion a numericas: variables 1997 a 2004 
wt[3:length(wt)] <- lapply(wt[3:length(wt)], 
                           function(x) as.numeric(gsub(",", "", x))) 

Para cerciorarnos de que el cambio se efectuó:

vapply(wt, class, character(1))%>% knitr::kable()
|:---------|:---------|
|Region    |character |
|Countries |character |
|1997      |numeric   |
|1998      |numeric   |
|1999      |numeric   |
|2000      |numeric   |
|2001      |numeric   |
|2002      |numeric   |
|2003      |numeric   |
|2004      |numeric   |

Las líneas finales contienen algunos totales y subtotales, que podrían estorbar:

tail(wt)
 Region         Countries  1997  1998  1999   2000   2001   2002   2003   2004
67 N. America              Cuba    11    12    13     15     17     19     21     23
68       Asia Brunei Darussalam    10    11    12     14     15     16     18     19
69    Oceania Pacific Islands**    10    11    12     13     14     15     16     18
70                     Subtotal 80141 87244 97722 107280 117831 131265 143517 152784
71                   All Others   508   595   737    891   1033   1234   1407   1597
72                        TOTAL 80649 87839 98459 108171 118864 132499 144925 154381

wt <- wt[1:(nrow(wt) - 3), ] # eliminar las 3 últimas filas

Para observar ausencias en los datos:

do.call(rbind, lapply(wt, function(x) sum(is.na(x))))
Region       0
Countries    0
1997         1
1998         1
1999         0
2000         0
2001         0
2002         0
2003         0
2004         0

Después de esto, tenemos un dataset sobre el cual se pueden efectuar operaciones , que resulten convenientes, para el interesado. A continuación, algunos gráficos:

suppressPackageStartupMessages(library(tidyverse))
wt %<>% rename(paises = Countries, region = Region) %>% # cambiar nombres de variables
  gather(key = annio, value = cons, -region, -paises) %>% # cambiar de wide a long
  mutate(paises = fct_recode(paises, `China` = "China*",# eliminar asteriscos en nombres de paises
                             `Pacific Islan` = "Pacific Islands**")) %>%
  mutate_if(is.factor, as.character) %>% 
  as_tibble()

wt %<>% filter(!is.na(cons)) # eliminar NAs

El comando %<>%, de magritr, actualiza en wt, los cambios efectuados al lado izquierdo de la expresión. La columna correspondiente a 'region' tiene algunos espacios de más en los nombres de las regiones de América:

unique(wt$region)

# [1] "N. America" "Asia"       "S. America" "Europe"     "Mideast"    "Oceania"    "Africa"

Nuevamente, con la ayuda de una expresión regular, prescindiremos de ese espacio, que puede ser un estorbo para algún cotejo, a la hora de efectuar alguna union (merge) conveniente con otros datos.

wt["region"] <- gsub("^S\\.\\s+|^N\\.\\s+", "", wt$region)

unique(wt$region)
# [1] "America" "Asia"    "Europe"  "Mideast" "Oceania" "Africa"

Observemos, por ejemplo, el consumo por continente, a través de los años 1997-2004:

# -------------------
# Creamos un tema
# -------------------
theme.graf <- theme(legend.position ="none",
        panel.border = element_blank(),
        axis.title.y = element_blank(),
        axis.text.y = element_blank(),
        panel.grid.major.y = element_blank(),
        panel.grid.minor.y = element_blank(),
        axis.title.x.top = element_text(size = 12),
        axis.ticks = element_blank(),
        plot.title = element_text(size = 14, face = "bold", hjust = 0.5),
        plot.subtitle = element_text(hjust = 0.5))

Por lo general, el tema se va ajustando, de manera interactiva, aquí quise escribirlo aparte, para hacer el código menos recargado. El paqute ggrepel evita que las etiquetas en un gráfico se solapen demasiado

library(ggrepel)
## data para las etiquetas:
d.iz <- wt %>% group_by(region, annio) %>% 
                    summarise(sums = sum(cons)) %>% 
                    top_n(-1, annio)
d.der <- wt %>% group_by(region, annio) %>% 
                    summarise(sums = sum(cons)) %>% 
                    top_n(1, annio)

Con el siguiente código, creamos un gráfico, del consumo de agua embotellada por continentes:

## secuencia de colores

cols <- c("#FF8C00","#483D8B", 
           "#2E8B57", "#BDB76B", 
           "#8B1A1A", "#7FFF00", 
            "#545454")


wt %>% 
  group_by(region, annio) %>%
  summarise(sums = sum(cons)) %>% 
  ggplot(aes(x = annio, y = sums,
             col = region, group = region))  +
  geom_line(size = 1.5, show.legend = FALSE) +
  scale_x_discrete(position = "top") +
  geom_text_repel(data = d.iz,
                  aes(label = paste(region, sums, sep = "-")),
                  hjust = 0,
                  nudge_x = -2,
                  nudge_y = .8,
                  direction = "y", fontface = "bold") +
  geom_text_repel(data = d.der,
                  aes(label = paste0(" ", sums)),
                  hjust = 0,
                  nudge_x = .1,
                  nudge_y = 1.5,
                  direction = "y", fontface = "bold") +
  scale_color_manual(values = cols)+
  labs(x = "", y = "",
       title = "Consumo de Agua Embotellada\n(miles)") +
  theme_light() + theme.graf

Según estos datos, América y Europa representaron los mayores mercados para el consumo de agua en esos años. Se puede observar cómo ha sido la transición en sus cuotas de mercado en esos años.

library(gganimate)
library(directlabels)
library(transformr)
library(httr)

## Los continentes líderes en consumo:

dat02 <- wt %>% mutate(annio = as.integer(annio)) %>% 
  group_by(annio, region) %>% 
  summarise(sums = sum(cons)) %>% 
  mutate(pct = sums/sum(sums)) %>% 
  ungroup() %>%  
  group_by(annio) %>% 
  top_n(2, sums)


pict03 <- dat02 %>% 
  ggplot(aes(x = factor(annio), 
             y = pct, 
             group = region, 
             colour = region)) +
  geom_line(size = 2, show.legend = FALSE) +
  scale_color_manual(values = c("#FF8C00", "#483D8B")) +
  scale_x_discrete(position = "top") +
  scale_y_continuous(labels = scales::percent_format(accuracy = 1)) +
  labs(title = 'Consumo de Agua Embotellada:\nEuropa-America ',
       x = "", y = "") +
  geom_text(aes(label = scales::percent(pct, accuracy = 1),
                vjust = -2), show.legend = FALSE) +
  theme(plot.title = element_text(hjust = .5)) +
  geom_dl(aes(label = substr(region,1L , 2L)), 
          method = "last.points") +
  transition_reveal(annio) +
  coord_cartesian(clip = 'off') +
  ease_aes('cubic-in-out') 

animate(pict03, fps = 10, width = 800, height = 400)

Améria ha mantenido su cuota entre un 37-39%, el consumo en Europa, habría caído, según estos datos. Es posible, crear un choropleth con esta data, ubicandola en un mapa de consumo por países:

w_map <- map_data("world") # contenido en el paquete ggplot2, cargado con tidyverse.

str(w_map)

Se requerirá unir los datos extraidos del PDF, con los contenidos en w_map, lo cual hace necesarios algunos ajustes, para hacer la union:

wt %<>% mutate(paises = ifelse(paises == "Venezuela, Boliv Rep of", "Venezuela", 
                               ifelse(paises == "United States", "USA", 
                                      ifelse(paises == "United Kingdom",
                                             "UK",
                                             ifelse(paises == "Russian Federation",
                                             "Russia",
                                             ifelse(paises == "Belgium-Luxembourg",
                                                    "Belgium",
                                                    ifelse(paises == "Korea, Republic of",
                                                           "South Korea",
                                                           ifelse(paises == "Viet Nam",
                                                                  "Vietnam",
                                                                  ifelse(paises == "Brunei Darussalam",
                                                                         "Brunei", paises)))))))))

n_map <- w_map %>% left_join(wt, by = c("region" = "paises")) # unir wt con w_map

Con ayuda de gganimate es posible crear una animación con un mapa:

t <- tabulizer::extract_tables(p, pages = 2:4)

t0 <- lapply(t, function(x) x[2:dim(x)[1], ])

t0 <- do.call(rbind, t0)

colnames(t0) <- c("region", "countries",
                 paste0("_", 1997:2004))


t0 <-  data.frame(t0)

t0[] <- lapply(t0, function(x) gsub("\\*|\\,", "", x))



lapply(t0[3:10], 
       function(x) grep("[^0-9]", x, value = TRUE))

t0[3:10] <- lapply(t0[3:10], 
                   function(x) gsub("—-", 0, x))

t0[3:10] <- lapply(t0[3:10],
                   as.numeric)

t1 <- t0 %>% reshape2::melt(., id = c("region", "countries"))

t1[["year"]] <-  as.numeric(gsub("X_", "", t1$variable))



URL <- "http://www.naturalearthdata.com/http//www.naturalearthdata.com/download/110m/cultural/ne_110m_admin_0_map_units.zip"

temp <- tempfile()

download.file(URL, temp)

unzip(temp)
unlink(temp)

world <- st_read("ne_110m_admin_0_map_units.shp") %>% 
  st_transform(crs = "+proj=longlat +datum=WGS84")


t3 <- merge(world, t1, by.x = "NAME", by.y = "countries")

t3$value <- t3$value/1000

g0 <- ggplot() +
  geom_sf(data = world, 
               colour = "#ffffff20", 
               fill = "#2d2d2d60", size = .5) +
  geom_sf(data = t3, aes(fill = value)) +
  coord_sf(crs = st_crs(world), datum = NA) +
  cowplot::background_grid(major = "none", minor = "none") +
  xlab("") + ylab("") +
  labs(title ="Consumo de Agua\nEmbotellada (MM)", subtitle = "Año: {current_frame}") +
  theme_dark() +
  theme(axis.text.x = element_blank(), 
        axis.ticks.x = element_blank(),
        axis.text.y = element_blank(), 
        axis.ticks.y = element_blank(),
        axis.line = element_blank(),
        legend.background = element_blank(),
        legend.position = "bottom",
        plot.background = element_rect(fill = "#454545"),
        panel.background = element_rect(fill = "#454545"),
        legend.text = element_text(size = 7, colour =  "white"),
        legend.title = element_text(colour="white", size = 8, 
                                    face = "bold"),
        plot.title = element_text(size = 17, face="bold",hjust = 0.5,
                                colour = "white"),
        plot.subtitle = element_text(hjust = 0.5,size = 12, 
                                     face = "bold", 
                                     colour = "white"),
        plot.caption = element_text(size = 11,
                                    hjust = .5,
                                    color = "white",
                                    face = "bold")) +
  scale_fill_gradient(low = "#8B0000", high = "#FFA500") +
  transition_manual(year)


animate(g0, fps = 10, width = 800, height = 400)

anim_save("AguaEmb.gif", g0)