Comparación de Listas de Fauna Amenazada del Perú (2014 vs. 2018)

if (requireNamespace("perufaunads004", quietly = TRUE)) {
  library(perufaunads004)
}
library(dplyr)
library(tidyr)
library(purrr)
library(stringr)
library(ggplot2)
library(knitr)

# Paquetes opcionales para lectura y exportación
# library(readxl)
# library(writexl)

# 1. Normaliza un nombre científico:
#    - Elimina comillas, paréntesis y nombres comunes incrustados
#    - Remueve autorías y epítetos informales ("sp.", "ssp.", "cf.", "aff.")
#    - Convierte a minúsculas, elimina diacríticos/tildes y extrae solo Género + epíteto (binomio)
normalizar_nombre <- function(x) {
  x |>
    as.character() |>
    str_replace_all('["“”\']', " ") |>
    str_replace_all("\\(.*?\\)", " ") |>
    str_replace_all("\\b(sp|spp|ssp|subsp|cf|aff|var)\\.?\\b", " ") |>
    str_replace_all("[^A-Za-zÁÉÍÓÚÜÑáéíóúüñ ]", " ") |>
    str_squish() |>
    str_to_lower() |>
    stringi::stri_trans_general("Latin-ASCII") |>
    word(1, 2)
}

# 2. Descompone y normaliza múltiples sinónimos (separados por ';', '/' o ',')
separar_sinonimos <- function(x) {
  x |>
    as.character() |>
    str_replace_all("[()]", " ") |>
    str_split("[;,/]") |>
    map(~ .x |> normalizar_nombre() |> discard(~ is.na(.x) | .x == ""))
}

# 3. Escala ordinal de severidad de amenaza (de menor a mayor gravedad)
niveles_cat <- c("DD", "NT", "VU", "EN", "CR")
severidad   <- function(x) match(x, niveles_cat)

# Carga de datos integrados (con fallback para entorno de desarrollo local)
if (exists("ds004_fauna") && exists("libro_rojo_especies")) {
  # ya en memoria
} else if (requireNamespace("perufaunads004", quietly = TRUE)) {
  data("ds004_fauna", package = "perufaunads004")
  data("libro_rojo_especies", package = "perufaunads004")
} else if (file.exists("../data/ds004_fauna.rda")) {
  load("../data/ds004_fauna.rda")
  load("../data/libro_rojo_especies.rda")
} else if (file.exists("data/ds004_fauna.rda")) {
  load("data/ds004_fauna.rda")
  load("data/libro_rojo_especies.rda")
}
#> NULL

# Estandarización de la Lista 2014 (DS 004-2014-MINAGRI)
lista_2014 <- ds004_fauna |>
  transmute(
    id_2014        = ds004_id,
    cat_2014       = as.character(ds004_categoria_codigo),
    categoria_2014 = str_to_sentence(str_remove(ds004_categoria, "\\s*\\(.*\\)")),
    grupo_2014     = str_to_sentence(clase),
    nombre_2014    = str_squish(scientific_name),
    comun_2014     = common_name,
    sinonimo_2014  = synonym_scientific_name,
    observacion    = observacion,
    key            = normalizar_nombre(scientific_name),
    key_sin        = separar_sinonimos(synonym_scientific_name)
  )

# Estandarización de la Lista 2018 (Libro Rojo de SERFOR)
lista_2018 <- libro_rojo_especies |>
  transmute(
    id_2018        = libro_rojo_id,
    cat_2018       = as.character(libro_rojo_codigo),
    categoria_2018 = str_squish(libro_rojo_categoria),
    grupo_2018     = str_squish(grupo_taxonomico),
    nombre_2018    = str_squish(scientific_name),
    sinonimo_2018  = sinonimo,
    key            = normalizar_nombre(scientific_name),
    key_sin        = separar_sinonimos(sinonimo)
  )

# Verificación de calidad: claves duplicadas dentro de cada lista
dup_2014 <- lista_2014 |> count(key) |> filter(n > 1)
dup_2018 <- lista_2018 |> count(key) |> filter(n > 1)

tibble(
  Lista = c("2014 (DS 004)", "2018 (Libro Rojo)"),
  `Total Registros` = c(nrow(lista_2014), nrow(lista_2018)),
  `Claves Duplicadas` = c(nrow(dup_2014), nrow(dup_2018))
) |> kable(caption = "Control de integridad de registros y claves.")

# Paso A: Emparejamiento directo por binomio aceptado
directo <- inner_join(
  lista_2014 |> select(-key_sin),
  lista_2018 |> select(-key_sin),
  by = "key"
) |>
  mutate(tipo_match = "nombre aceptado")

# Registros pendientes de emparejamiento
pend_2014 <- lista_2014 |> filter(!key %in% directo$key)
pend_2018 <- lista_2018 |> filter(!key %in% directo$key)

# Tablas largas de sinónimos de especies pendientes
sin_2014 <- pend_2014 |>
  select(key, key_sin) |>
  unnest_longer(key_sin, values_to = "key_alt") |>
  filter(!is.na(key_alt))

sin_2018 <- pend_2018 |>
  select(key, key_sin) |>
  unnest_longer(key_sin, values_to = "key_alt") |>
  filter(!is.na(key_alt))

# Construcción de puente relacional:
# sinónimo 2018 -> nombre 2014  |  sinónimo 2014 -> nombre 2018
puente <- bind_rows(
  sin_2018 |> transmute(key_2014 = key_alt, key_2018 = key),
  sin_2014 |> transmute(key_2014 = key,     key_2018 = key_alt)
) |>
  filter(key_2014 %in% pend_2014$key, key_2018 %in% pend_2018$key) |>
  distinct()

por_sinonimo <- puente |>
  left_join(pend_2014 |> select(-key_sin), by = c("key_2014" = "key")) |>
  left_join(pend_2018 |> select(-key_sin), by = c("key_2018" = "key")) |>
  mutate(key = key_2014, tipo_match = "sinónimo / cambio taxonómico") |>
  select(-key_2014, -key_2018)

# Consolidación final de coincidencias
coincidencias <- bind_rows(directo, por_sinonimo) |>
  mutate(
    cambio = case_when(
      cat_2014 == cat_2018                       ~ "sin cambio",
      severidad(cat_2018) > severidad(cat_2014)  ~ "asciende (mayor amenaza)",
      severidad(cat_2018) < severidad(cat_2014)  ~ "desciende (menor amenaza)",
      TRUE                                       ~ "no comparable"
    ),
    transicion = paste(cat_2014, "->", cat_2018)
  ) |>
  arrange(grupo_2014, nombre_2014)

emparejadas_2014 <- coincidencias$id_2014
emparejadas_2018 <- coincidencias$id_2018

# Especies de 2014 que no figuran en 2018 (7 especies)
especies_retiradas <- lista_2014 |>
  filter(!id_2014 %in% emparejadas_2014) |>
  select(id_2014, nombre_2014, comun_2014, grupo_2014, cat_2014,
         categoria_2014, sinonimo_2014, observacion)

# Especies incorporadas exclusivamente en 2018
especies_nuevas <- lista_2018 |>
  filter(!id_2018 %in% emparejadas_2018) |>
  select(id_2018, nombre_2018, grupo_2018, cat_2018, categoria_2018, sinonimo_2018)

# Exportación de hojas de cálculo con writexl:
writexl::write_xlsx(
  list(
    resumen_general    = resumen_general,
    coincidencias      = coincidencias |> select(-starts_with("key")),
    especies_retiradas = especies_retiradas,
    especies_nuevas    = especies_nuevas,
    matriz_transicion  = matriz_transicion,
    balance_por_grupo  = balance_grupo
  ),
  path = "comparacion_fauna_2014_2018.xlsx"
)

# Guardar figura en alta resolución (300 DPI):
ggsave(
  filename = "matriz_transicion_2014_2018.png",
  plot = p_transicion,
  width = 7,
  height = 5.5,
  dpi = 300
)