geom_sf
geom_sf_pattern
Autor

Víctor Gauto

Fecha de publicación

17 de febrero de 2024

Animación del avance de las torres de telecomunicaciones en Argentina, entr 2009 y 2024, para redes GSM, UMTS y LTE.

Animación del avance de torres celulares.

Paquetes

Ocultar código 
library(glue)
library(showtext)
library(ggtext)
library(sf)
library(magick)
library(tidyverse)

Estilos

Colores.

Ocultar código 
c1 <- "#76BE72"
c2 <- "#F04C44"
c3 <- "#442224"
c4 <- "grey95"
c5 <- "grey92"

Fuentes: Ubuntu y JetBrains Mono.

Ocultar código 
font_add(
  family = "ubuntu",
  regular = "././fuente/Ubuntu-Regular.ttf",
  bold = "././fuente/Ubuntu-Bold.ttf",
  italic = "././fuente/Ubuntu-Italic.ttf"
)

font_add(
  family = "jet",
  regular = "././fuente/JetBrainsMonoNLNerdFontMono-Regular.ttf"
)

showtext_auto()
showtext_opts(dpi = 300)

Epígrafe

Ocultar código 
fuente <- glue(
  "Datos: <span style='color:{c2}; font-size: 8px'>**OpenCelliD Project** is
  licensed under a Creative<br>Commons Attribution-ShareAlike 4.0 International
  License</span>")
autor <- glue("<span style='color:{c2};'>**Víctor Gauto**</span>")
icon_twitter <- glue("<span style='font-family:jet;'>&#xf099;</span>")
icon_instagram <- glue("<span style='font-family:jet;'>&#xf16d;</span>")
icon_github <- glue("<span style='font-family:jet;'>&#xf09b;</span>")
icon_mastodon <- glue("<span style='font-family:jet;'>&#xf0ad1;</span>")
icon_bsky <- glue("<span style='font-family:jet;'>&#xe28e;</span>")
usuario <- glue("<span style='color:{c2};'>**vhgauto**</span>")
sep <- glue("**|**")

mi_caption <- glue(
  "{fuente}<br>{autor} {sep} {icon_github} {icon_twitter} {icon_instagram} ",
  "{icon_mastodon} {icon_bsky} {usuario}"
)

Funciones

Convierte la cantidad de torres por período a largo del segmento, para mostrar avance.

Ocultar código 
f_escala <- function(x) {
  eje_x_min + x*(eje_x_max - eje_x_min)/l_max
}

Generación y almacenamiento de cada mapa.

Ocultar código 
f_mapa <- function(año_mes) {

  # contador para seguimiento en consola
  l <- length(v_año_mes)
  n <- which(v_año_mes == año_mes)

  n <- case_when(
    n <= 9 ~ glue("00{n}"),
    n <= 99 ~ glue("0{n}"),
    .default = glue("{n}")
  )

  print(glue("-- {n} de {l} --"))

  # etiquetas de año y mes
  año_label <- year(año_mes)
  mes_label <- str_to_upper(format(año_mes, "%B"))

  mi_title <- glue(
    "<span style='font-size:20px;'>{año_label}</span><br>",
    "<span style='font-size:10px;'>{mes_label}</span>")

  # filtro los datos
  e <- d |>
    filter(primero <= año_mes)

  # color de la leyenda
  label_tbl <- count(e, radio) |>
    mutate(color = paleta_radio[radio]) |>
    mutate(label = glue("{radio}<br><span style='color:{color}'>{n}</span>")) |>
    arrange(radio)

  scale_color_names <- pull(label_tbl, radio)
  scale_color_labels <- pull(label_tbl, label)
  scale_color_values <- pull(label_tbl, color)

  # extensión
  d_l <- count(tibble(e), radio) |>
    arrange(radio) |>
    mutate(
      x = eje_x_min,
      xend = f_escala(n),
      y = eje_y_radio[radio]
    ) |>
    mutate(yend = y) |>
    mutate(color = paleta_radio[radio])

  # figura
  g <- ggplot() +
    # Argentina
    geom_sf(data = arg_sf, fill = c5, color = NA, linewidth = .1) +
    # torres de radio
    geom_sf(data = e, aes(color = radio, size = radio), alpha = .5) +
    # líneas horizontales
    geom_segment(
      data = d_l, aes(x, y, xend = xend, yend = yend),  color = d_l$color,
      linewidth = 1) +
    # año
    annotate(
      geom = "text", x = I(.85), y = I(.95), label = año_label, vjust = 0,
      family = "jet", size = 6, color = c3) +
    # mes
    annotate(
      geom = "text", x = I(.85), y = I(.944), label = mes_label, vjust = 1,
      family = "jet", size = 3, color = c3) +
    scale_color_manual(
      breaks = scale_color_names,
      labels = scale_color_labels,
      values = scale_color_values) +
    scale_size_manual(values = c(.1, .4, .7)) +
    labs(color = NULL, caption = mi_caption) +
    coord_sf(
      xlim = c(bb_sf$xmin, bb_sf$xmax),
      ylim = c(bb_sf$ymin, bb_sf$ymax),
      expand = FALSE) +
    guides(
      color = guide_legend(
        position = "inside",
        override.aes = list(size = 3, alpha = 1)),
      size = guide_none()
    ) +
    theme_void() +
    theme(
      plot.background = element_rect(fill = c4, color = c3, linewidth = 1),
      plot.margin = margin(r = 4, b = 3, l = 4),
      plot.caption = element_markdown(
        family = "ubuntu", color = c1, size = 7, lineheight = unit(1.1, "line"),
        margin = margin(t = -15, r = 5)),
      legend.position.inside = c(0.6, 0.4),
      legend.key.spacing.y = unit(.7, "line"),
      legend.justification.inside = c(0, 1),
      legend.text = element_markdown(family = "jet")
    )

  # guardo
  ggsave(
    plot = g,
    filename = glue("./argentina/animaciones/torres_celulares/{n}.png"),
    width = 1000,
    height = 2140,
    units = "px"
  )

}

Datos

Los datos de las torres de celulares se encuentran en OpenCellid. Es requisito tener una cuenta para poder solicitar un token de acceso y descargar los datos.

Ocultar código 
d <- read_csv(
  "./argentina/vectores/722X.csv",
  col_names = 1:14,
  col_select = c(1, 7, 8, 12, 13)) |>
  rename(radio = X1, lon = X7, lat = X8, primero = X12, ultimo = X13) |>
  mutate(primero = as_datetime(primero)) |>
  mutate(ultimo = as_datetime(ultimo)) |>
  mutate(primero = as.Date(primero)) |>
  mutate(ultimo = as.Date(ultimo)) |>
  mutate(año = year(primero), mes = month(primero)) |>
  mutate(radio = fct(radio, levels = c("GSM", "UMTS", "LTE"))) |>
  st_as_sf(coords = c("lon", "lat")) |>
  st_set_crs(value = 4326) |>
  st_transform(crs = 5346)

Vector de Argentina y contorno.

Ocultar código 
arg_sf <- st_read("./argentina/vectores/arg_continental.gpkg") |>
  st_transform(crs = 5346)

# extensión de Argentina, para ampliar el mapa
bb <- st_bbox(arg_sf)
ext <- terra::vect(arg_sf) |> terra::ext()
bb_sf <- terra::vect(ext*1.1, crs = "EPSG:5346") |>
  st_as_sf() |>
  st_bbox()

Extraigo los meses y años de la base de datos.

Ocultar código 
v_año_mes <- tibble(d) |>
  distinct(año, mes) |>
  mutate(dia = 1) |>
  mutate(fecha = make_date(year = año, month = mes, day = dia)) |>
  arrange(fecha) |>
  pull(fecha)

# máxima cantidad de torres de radio
l_max <- count(tibble(d), radio, sort = TRUE) |>
  arrange(radio) |>
  pull(n) |>
  max()

Figura

Paleta de colores por tipo de red.

Ocultar código 
paleta_radio <- c(c1, c2, c3)
names(paleta_radio) <- c("GSM", "UMTS", "LTE")

Posición de cada segmento según tipo de torre.

Ocultar código 
eje_x_min <- bb_sf$xmax*.895
eje_x_max <- bb_sf$xmax*.99

# posición vertical, de los segmentos según tipo de radio
eje_y_gsm <- bb_sf$ymin*1.402
eje_y_umts <- eje_y_gsm - 2.22e5
eje_y_lte <- eje_y_gsm - 2*2.22e5

eje_y_radio <- c(eje_y_gsm, eje_y_umts, eje_y_lte)
names(eje_y_radio) <- c("GSM", "UMTS", "LTE")

Genero todas las figuras.

Ocultar código 
walk(v_año_mes, f_mapa)
beepr::beep(2)
Sys.sleep(1.5)
beepr::beep(2)
Sys.sleep(1.5)
beepr::beep(2)
Sys.sleep(1.5)

Animación

A partir de las figuras genero la animación.

Ocultar código 
av::av_encode_video(
  input = list.files(
    path = "./argentina/animaciones/torres_celulares/",
    full.names = TRUE, pattern = ".png"
  )[-c(1, 2)],
  framerate = 7,
  output = "./argentina/animaciones/torres_celulares.mp4"
)

Elimino la carpeta con todas las imágenes.

Ocultar código 
unlink("./argentina/animaciones/torres_celulares/", recursive = TRUE)
Subir