library(readr)
library(igraph)
library(ggraph)
library(tidygraph)
library(ggplot2)
library(gridExtra)
library(patchwork)
library(fossil)
library(tidyr)
library(kableExtra)
library(dplyr)
library(tibble) 
library(tidyverse)
library(tidytext)

Punto 1

  1. Una estructura social cognitiva es una representación mental que organiza cómo las personas perciben, interpretan y responden a interacciones sociales, roles y normas dentro de un grupo. Esta estructura, formada a partir de experiencias previas y procesos cognitivos como la percepción y la memoria, incluye esquemas, valores y mapas de relaciones que permiten anticipar comportamientos y adaptarse al entorno social. Su configuración varía según el contexto cultural y social, reflejando las particularidades de cada entorno colectivo.

    David Krackhardt recopiló datos relacionales para analizar la estructura social cognitiva de 21 miembros del personal administrativo de una empresa dedicada a la fabricación de maquinaria de alta tecnología, con el propósito de evaluar los efectos de una intervención administrativa. Una de las preguntas clave del estudio fue: “¿Quién es amigo de X?”, lo que permitió a cada persona identificar no solo sus propias relaciones de amistad, sino también las que percibía entre los demás empleados. Esto generó una matriz de adyacencia de \(21\times 21\), que representaba tanto las conexiones reales como las percibidas entre todos los miembros del grupo.

    El conjunto de datos, disponible en este enlace, incluye una red multicapa que describe la estructura social cognitiva completa de los 21 actores. Esta red está formada por 21 matrices de adyacencia de \(21\times 21\), donde cada matriz \(j\) refleja la percepción del actor \(j\) sobre las relaciones de amistad dentro del sistema social, con \(j=1,…,21\). Además, el archivo krackhardt21c.txt proporciona información adicional sobre cada actor, como la edad (age, en años), la antigüedad en la empresa (tenure, en años), el nivel jerárquico (level, donde 1 corresponde al presidente, 2 al vicepresidente y 3 al gerente) y el departamento al que pertenece (dept), destacando que el presidente no está asignado a ningún departamento.

    1. Obtener la red de consenso cuya matriz de adyacencia \(\mathbf{Y}=[y_{i,j}]\) se define de la siguiente manera: \(y_{i,j}=1\) si el promedio \(\frac{1}{I}\sum_{k=1}^I y_{i,j,k}\) es mayor a 0.5, y \(y_{i,j}=0\) en caso contrario. Aquí, \(I\) representa el número de actores en el sistema, y \(y_{i,j,k}\) corresponde a la percepción del actor \(k\) sobre la relación entre los actores \(i\) y \(j\). Crear un par de visualizaciones de la red de consenso que integren la mayor cantidad posible de información asociada a los nodos.

    2. Generar visualizaciones simples, sin elementos decorativos, en un diseño circular para todas las redes de percepción y la red de consenso. ¿Se identifican diferencias notables entre las redes de percepción o entre estas y la red de consenso?

    3. Calcular el grado normalizado de cada actor en todas las redes de percepción y en la red de consenso. Para cada actor, crear un diagrama de caja que muestre la distribución de su grado a través de las percepciones y el consenso. Resaltar en cada diagrama con un triángulo rojo (\(\Delta\)) el grado según su propia percepción y con una cruz azul (\(\times\)) el grado basado en el consenso. Todos los diagramas de caja deben estar organizados en un único gráfico. Un ejemplo de este tipo de representación se encuentra en este documento, página 9. Analizar si los actores parecen tener una percepción precisa de su participación en las relaciones del sistema.

    4. Repetir el procedimiento anterior para calcular la centralidad de cercanía, la centralidad de intermediación y la centralidad propia de cada actor en todas las redes de percepción y en la red de consenso. Analizar si los actores parecen tener una percepción precisa de su posición e influencia en las relaciones del sistema.

    5. Calcular la densidad de cada red de percepción y representar estos valores utilizando un histograma. Superponer una línea vertical que indique la densidad de la red de consenso. Analizar si las percepciones sobre la densidad de las relaciones están en concordancia con la densidad observada en el consenso.

    6. Repetir el numeral anterior tanto para la transitividad como para la asortatividad.

    7. Segmentar la red de consenso aplicando distintos métodos de agrupamiento y visualizar los resultados obtenidos para cada método. Evaluar la calidad de las particiones generadas comparándolas con la partición basada en los departamentos a los que pertenecen los empleados, utilizando el Índice de Rand (RI) y el Índice de Rand ajustado (ARI). Analizar los valores obtenidos para determinar qué método de agrupamiento logra una mayor concordancia con la estructura departamental.

Solución Punto 1

Empezamos cargando las matrices de adyacencia, que se encuentran apiladas una encima de la otra, y los atributos de los nodos

datos_p1 <- read_table("Datos/krackfr.txt", col_names = FALSE)
atributos_p1 <- read_table("Datos/krackhardt21c.txt", col_names = TRUE)
atributos_p1$level <- factor(atributos_p1$level, levels = c(1, 2, 3),
                             labels = c("Presidente",
                                        "Vicepresidente",
                                        "Gerente"))
dim(datos_p1)
## [1] 441  21
# Hay 21 actores
I <- 21
Y_p1 <- array(NA, dim = c(I, I, I))
# Debo obtener el arreglo tensorial 21x21x21
for (k in 1:I) {
  filas <- ((k - 1) * I + 1):(k * I)
  Y_p1[,,k] <- as.matrix(datos_p1[filas, ])
}
Y_consenso <- ifelse((apply(Y_p1, c(1,2), mean)) > 0.5, 1, 0)
dim(Y_consenso)
## [1] 21 21
# = = = = = = = = = = = = Creación de los grafos = = = = = = = = = = = = 
# 21 grafos de percepción
grafos_percepcion <- lapply(1:I, function(k) {
  graph_from_adjacency_matrix(Y_p1[,,k], mode = "directed",
                               weighted = FALSE, diag = FALSE)
})

# Grafo de consenso
grafo1 <- graph_from_adjacency_matrix(Y_consenso, mode = "directed", weighted = FALSE, diag = FALSE)
vertex_attr(grafo1) <- as.data.frame(atributos_p1)

V(grafo1)$in_degree  <- degree(grafo1, mode = "in")
V(grafo1)$out_degree <- degree(grafo1, mode = "out")
V(grafo1)$betweenness_val <- betweenness(grafo1, normalized = TRUE)

A continuación se muestran dos visualizaciones de la red de consenso. La diferencia entre estas es la variable que le da el tamaño a los nodos.

# = = = = = = = = = = = = Visualización de la red de consenso = = = = = = = = = = = = 
g1_tbl <- as_tbl_graph(grafo1)
paleta_nivel <- c("1" = "#E63946",
                  "2" = "#457B9D",
                  "3" = "#2A9D8F",
                  "4" = "#F4A261")

set.seed(9)
set_graph_style(plot_margin = margin(1,1,1,1))

# Layout
layout1 <- create_layout(g1_tbl, layout = 'igraph', algorithm = "fr")

plot1_1 <- ggraph(layout1) +
  geom_edge_link(#aes(width = weight, color = tipo_regimen),
                 color = "grey30", width = 1, alpha = 0.5, arrow = arrow(length = unit(2, "mm")),
                 end_cap = circle(2, "mm")
                 ) +
  geom_node_point(aes(size = age, color = as.factor(dept), shape = level )) +
  scale_size(range = c(3, 10), guide = "none") +
  scale_color_manual(name = "Departamento", values = paleta_nivel) +
  scale_shape_manual(name = "Nivel jerárquico",
    values = c("Presidente" = 17,
               "Vicepresidente" = 15,  # cuadrado
               "Gerente" = 16   # diamante
               ) ) +
  theme_void() +
  theme(legend.position = "right") +
  labs(title = "Red de consenso - Estructura social cognitiva",
       subtitle = "El tamano de los vertices representa la edad de los actores")

plot1_2 <- ggraph(layout1) +
  geom_edge_link(#aes(width = weight, color = tipo_regimen),
                 color = "grey30", width = 1, alpha = 0.5, arrow = arrow(length = unit(2, "mm")),
                 end_cap = circle(2, "mm")
                 ) +
  geom_node_point(aes(size = tenure, color = as.factor(dept), shape = level )) +
  scale_size(range = c(3, 10), guide = "none") +
  scale_color_manual(name = "Departamento", values = paleta_nivel) +
  scale_shape_manual(name = "Nivel jerárquico",
    values = c("Presidente" = 17,
               "Vicepresidente" = 15,  # cuadrado
               "Gerente" = 16   # diamante
               ) ) +
  theme_void() +
  theme(legend.position = "right") +
  labs(title = "Red de consenso - Estructura social cognitiva",
       subtitle = "El tamano de los vertices representa la antiguedad en la empresa")
wrap_plots(plot1_1, plot1_2, ncol = 2)

Observese que la red de consenso está bastante desconectada. Por ejemplo, en promedio, los empleados de la empresa dicen que el presidente de esta no es amigo de nadie.
Solamente se observan 4 grupos pequeños de actores, ninguno mayor de 3 nodos, que estarían dando cuenta de una percepción de amistad general. Además, estas pocas relaciones de amistad que se muestran, no son transitivas, algo inusual en redes sociales.

En cuanto a las características de los empleados, se observa que un ‘grupo de amigos’ se compone de personas con el mismo cargo que trabajn en el mismo departamento (gerentes del depto número 2). Adicionalmente, las personas tienden a agruparse con individuos que tienen antiguedad similar en la organización.

Ahora, se grafican las redes de los 21 empleados más la red de consenso de forma simple.

# = = = = = = = = = = = = Visualizaciones simples = = = = = = = = = = = = 
# Función para visualizaciones simples
plot_red_simple <- function(g, titulo = "") {
  tbl_g <- as_tbl_graph(g)
  ggraph(tbl_g, layout = "circle") +
    geom_edge_link(alpha = 0.25, color = "grey40",
                   arrow = arrow(length = unit(1.5, "mm"), type = "closed"),
                   end_cap = circle(2, "mm")) +
    geom_node_point(size = 2, color = "steelblue") +
    theme_void() +
    labs(title = titulo) +
    theme(plot.title = element_text(size = 7, hjust = 0.5))
}
plots_perc <- lapply(1:I, function(k) plot_red_simple(grafos_percepcion[[k]], paste0("Percepción: Actor ", k))
                     )
p_consenso_simple <- plot_red_simple(grafo1, "Consenso")
 
wrap_plots(c(plots_perc, list(p_consenso_simple)), ncol = 6)

Las visualizaciones simples de las redes de percepción nos dejan ver que estas son bastabte variadas. Hay redes muy densas como la de los empleados 7, 11 y 19; así como otras poco densas como la de los actores 3, 8 y 9. Norte una particularidad en la red del individuo 17: este cree que hay un empleado qye es amigo de bastanates personas, ya que vemos varias flechas salir conjuntamente de un mismo nodo.

Esta variabilidad notable en la percepción de amistad que tienen dentro de la empresa genera que la red de consenso sea dispersa, como vimos previamente.

Grados normalizados

Para una red dirigida, los grados normalizados de entrada y salida de un actor dado que él mismo es el reportero se calculan como \[d_{i,i}^{in}=\frac{1}{I-1}\sum_{i'\neq i}y_{i,i',i} \qquad d_{i,i}^{out}=\frac{1}{I-1}\sum_{i'\neq i}y_{i',i,i}.\]

Del mismo modo, cuando el reportero es cualquier otro actor \(j\), los grados normalizados se escriben como

\[d_{i,j}^{in}=\frac{1}{I-1}\sum_{i'\neq i}y_{i,i',j} \qquad d_{i,j}^{out}=\frac{1}{I-1}\sum_{i'\neq i}y_{i',i,j}.\]

Finalmente, estos mismos valores para la red de consenso se obtienen mediante \[\tilde{d}_{i}^{in}=\frac{1}{I-1}\sum_{i'\neq i}\tilde{y}_{i,i'} \qquad \tilde{d}_{i}^{out}=\frac{1}{I-1}\sum_{i'\neq i}\tilde{y}_{i',i}.\]

donde \(y_{i,i',j}=1\) si el actor \(j\) informa que el actor \(i\) es amigo del actor \(i'\), y \(y_{i,i',j}=0\) en caso contrario.

# = = = = = = = = = = = = Boxplot grados normalizados = = = = = = = = = = = = 

# Grados de i según reportero j
calc_out <- function(g) degree(g, mode = "out") / (I-1)
calc_in <- function(g) degree(g, mode = "in") / (I-1)
# --- Matrices IxI
out_matrix <- sapply(grafos_percepcion, calc_out)   # fila: actor i, columna: reportero j
in_matrix  <- sapply(grafos_percepcion, calc_in)    

out_matrix_offdiag <- out_matrix
in_matrix_offdiag <- in_matrix
diag(out_matrix_offdiag) <- NA # elimina el caso j=i
diag(in_matrix_offdiag) <- NA

# La percepción propia resulta de las diagonales de las matrices --> fila: i, reportero: i
out_propia <- diag(out_matrix)
in_propia  <- diag(in_matrix)

# Grados de consenso
out_consenso <- calc_out(grafo1)
in_consenso  <- calc_in(grafo1)

# --- Función para construir el boxplot 
make_boxplot_degree <- function(mat_offdiag, vec_propia, vec_consenso, label_y) {
  df_long <- as.data.frame(mat_offdiag) |>
    setNames(paste0("k", 1:I)) |>
    mutate(actor = factor(1:I)) |>
    pivot_longer(-actor, names_to = "reportero", values_to = "valor")

  df_esp <- data.frame(actor    = factor(1:I),
                       propia   = vec_propia,
                       consenso = vec_consenso)

  ggplot(df_long, aes(x = actor, y = valor)) +
    stat_boxplot(geom = "errorbar", width = 0.4, color = "grey30") +
    geom_boxplot(fill = "grey", outlier.size = 1,
                 color = "grey30", width = 0.6) +
    geom_point(data = df_esp, aes(x = actor, y = propia),
               shape = 24, color = "red", fill = "red", size = 2) +
    geom_point(data = df_esp, aes(x = actor, y = consenso),
               shape = 4, color = "blue", size = 3, stroke = 1.5) +
    labs(x = "Actor", y = label_y) +   # <-- título del panel va al eje y
    theme_bw(base_size = 11) +
    coord_cartesian(ylim = c(0,0.7))
}

p_out <- make_boxplot_degree(out_matrix_offdiag, out_propia, out_consenso, "Out-degree normalizado")
p_in  <- make_boxplot_degree(in_matrix_offdiag,  in_propia,  in_consenso,  "In-degree normalizado")

(p_out / p_in) +
  plot_annotation(
    title    = "Distribución del grado normalizado por actor",
    subtitle = expression("△ rojo = percepción propia · × azul = consenso"),
    theme    = theme(
      plot.title    = element_text(face = "bold", hjust = 0.5, size = 13),
      plot.subtitle = element_text(hjust = 0.5, size = 10)
    )
  )

El i-ésimo boxplot resume la distribución del grado para todos los reporteros excepto \(i\). Note que los empleados de la empresa tienden a sobreestimar sus relaciones de amistad (tanto la cantidad de amistades declaradas por ellos como la cantidad de personas que consideran amigo al actor), ya que vemos a la percepción propia por encima de los boxplot para muchos actores. Véase por ejemplo los nodos 10, 11, 15 y 17 que siguen esta tendencia.

Son pocos los casos en los que los grados de salida y entrada que los ejecutivos perciben para sí mismos son menores a la mediana de las distribuciones que los demás les atribuyen. Un ejempolo de este compartamiento son los actores 7, 8 y 9.

Finalmente, también se observa que la red de consenso genera grados normalizados muy pequeños (la mayoría igual a 0), consistente con lo poco conectada que está esta red; por lo que en general la persceptiva propia es mayor a esta. Se hace la claridad de unas excepciones: individuos 7, 8 y 18 cuyo numero de relaciones de amistad que salen de ellos coincide con el consenso.

Respondiendo a la pregunta: ¿La visión propia coincide con la colectiva?, se tiene a que en muchos casos no, las personas no suelen tener una percepción precisa de su participación social en el sistema. Las personas creen que tienen más amigos de lo que colectivamente se ve, así msimo creen que más personas las catalogarán como amigos.

Centralidades

# = = = = = = = = = = = = Boxplot centralidades = = = = = = = = = = = = 
 
cent_closeness   <- function(g) closeness(g, mode = "all", normalized = TRUE)
cent_betweenness <- function(g) betweenness(g, directed = TRUE, normalized = TRUE)
cent_eigen       <- function(g) eigen_centrality(g, directed = TRUE)$vector
 
make_boxplot_cent <- function(fn_cent, etiqueta, color_caja = "grey") {
  mat        <- sapply(grafos_percepcion, fn_cent)   # I×I
  vec_cons   <- fn_cent(grafo1)
  vec_propia <- diag(mat)
 
  df_long <- as.data.frame(mat) |>
    setNames(paste0("k", 1:I)) |>
    mutate(actor = factor(1:I)) |>
    pivot_longer(-actor, names_to = "percepcion", values_to = "valor")
 
  df_esp <- data.frame(actor    = factor(1:I),
                        propia   = vec_propia,
                        consenso = vec_cons)
 
  ggplot(df_long, aes(x = actor, y = valor)) +
    stat_boxplot(geom = "errorbar", width = 0.4, color = "grey30") +
    geom_boxplot(fill = color_caja, outlier.size = 1,
                 color = "grey30", width = 0.6) +
    geom_point(data = df_esp, aes(x = actor, y = propia),
               shape = 24, color = "red", fill = "red", size = 2) +
    geom_point(data = df_esp, aes(x = actor, y = consenso),
               shape = 4, color = "blue", size = 3, stroke = 1.5) +
    labs(title    = paste("Distribución de la centralidad de", etiqueta, "por actor"),
         subtitle = expression("△ rojo = percepción propia · × azul = consenso"),
         x = "Actor", y = etiqueta) +
    theme_bw(base_size = 11) +
    theme(plot.title    = element_text(face = "bold", hjust = 0.5),
          plot.subtitle = element_text(hjust = 0.5))
}
 
make_boxplot_cent(cent_closeness,   "Cercanía",       "lightcyan")

make_boxplot_cent(cent_betweenness, "Intermediación", "honeydew")

make_boxplot_cent(cent_eigen,       "Centralidad propia",           "lavender")

En primer lugar, las distribuciones de centralidad por cercanía se comportan de forma similar para todos los actores, ya que su mediana parece oscilar alrededor de 0.5. En cuanto al comportamiento individual, vemos que 6 de los 21 ejecutivos piensan que son menos centrales de lo que muestra la mediana de las perspectivas colectivas. Contrario a lo que se observa en el individuo 17, el cual sobreestima su importancia en términos de lo que cerca que está de otros individuos en la red. En cuanto a la red de consenso, los individuos 3, 4, 5 y 14 son catalogados como 100% importantes en esta.

En segundo lugar, las centralidades por intermediación, que recordemos dicen que un vértice es importante si este se encuentra entre otros pares de vértices, muestran una notable sobre estimación de la importancia que perciben los actores de si mismos respecto de las percepciones de los demás. Solo para los individuos 3, 8, 9, 16 y 18 las tres perspectivas (incluyendo la red de consenso) coinciden.

En último termino, las centralidades propias son las más dispersas de todas, las distribuciones menos dispersas parecen corresponder a las redes de percepción más desconectadas (actores 3, 8, 9 y 20). En estas, ningún ejecutivo está subestimando su importancia; es más, los que no son precisos al respecto, piensan que tienen una vecindad de amigos más centrales de lo que identifican los demás reporteros.

En conclusión, los actores no parecen tener una percepción precisa de su posición e influencia en las relaciones del sistema, exceptuando unos pocos casos.

Densidad

# = = = = = = = = = = = = Histograma de la densidad = = = = = = = = = = = = 
 
densidades_perc <- sapply(grafos_percepcion, edge_density)
densidad_cons   <- edge_density(grafo1)
 
ggplot(data.frame(densidad = densidades_perc), aes(x = densidad)) +
  geom_histogram(bins = 15, fill = "steelblue", color = "white", alpha = 0.8) +
  geom_vline(xintercept = densidad_cons, color = "red",
             linewidth = 1.2, linetype = "dashed") +
  annotate("text", x = densidad_cons + 0.005, y = Inf,
           label = paste0("Consenso: ", round(densidad_cons, 3)),
           color = "red", hjust = 0, vjust = 1.5, size = 3.5) +
  labs(title    = "Distribución de la densidad en las redes de percepción",
       #subtitle = "Línea roja punteada: densidad de la red de consenso",
       x = "Densidad", y = "Frecuencia") +
  theme_bw(base_size = 12) +
  theme(plot.title    = element_text(face = "bold", hjust = 0.5),
        plot.subtitle = element_text(hjust = 0.5))
## Warning in grid.Call.graphics(C_text, as.graphicsAnnot(x$label), x$x, x$y, :
## font family not found in Windows font database

Como se vio en las visualizaciones simples de las redes para cada actor, hay heterogeneidad en la conectividad de las redes. La red de consenso resultó ser una muy poco densa, al igual que ciertas redes de percepción que también cuentan con muy pocas aristas. Es por esto que en el gráfico observamos a la densidad de consenso hacia el lado izquierdo del histograma de densidades. Las percepciones sobre la densidad de las relaciones son acordes a la densidad observada en el consenso.

Transitividad

# = = = = = = = = = = = = Histograma de la transitividad = = = = = = = = = = = = 
 
transitividades_perc <- sapply(grafos_percepcion,
                                function(g) transitivity(g, type = "global"))
transitividad_cons   <- transitivity(grafo1, type = "global")
 
ggplot(data.frame(trans = transitividades_perc), aes(x = trans)) +
  geom_histogram(bins = 15, fill = "darkorange", color = "white", alpha = 0.8) +
  geom_vline(xintercept = transitividad_cons, color = "red",
             linewidth = 1.2, linetype = "dashed") +
  annotate("text", x = transitividad_cons + 0.005, y = Inf,
           label = paste0("Consenso: ", round(transitividad_cons, 3)),
           color = "red", hjust = 0, vjust = 1.5, size = 3.5) +
  labs(title    = "Distribución de la transitividad en las redes de percepción",
       subtitle = "Línea roja punteada: transitividad de la red de consenso",
       x = "Transitividad global", y = "Frecuencia") +
  theme_bw(base_size = 12) +
  theme(plot.title    = element_text(face = "bold", hjust = 0.5),
        plot.subtitle = element_text(hjust = 0.5))
## Warning in grid.Call.graphics(C_text, as.graphicsAnnot(x$label), x$x, x$y, :
## font family not found in Windows font database

El histograma de la transitividad global para las redes de percepción nos deja ver que hay 2 grupos de redes que tinen baja y nula transitividad, mientras hay otro grupo más grande cuyas redes si muestran una característica de transitividad en las relaciones de amistad. En este panorama, la red de consenso se ubica con los primeros, ya que esta no cuenta con relaciones transitivas.

Asortatividad

# = = = = = = = = = = = = Histogramas de la asortatividad = = = = = = = = = = = = 
 
age_v    <- atributos_p1$age
tenure_v <- atributos_p1$tenure
level_v  <- as.integer(atributos_p1$level)
dept_v   <- as.integer(factor(atributos_p1$dept, exclude = NULL))

calc_asort <- function(g, age, tenure, level, dept) {
  c(age_asor    = assortativity(g, age,    directed = is.directed(g)),
    tenure_asor = assortativity(g, tenure, directed = is.directed(g)),
    level_asor  = assortativity_nominal(g, level, directed = is.directed(g)),
    dept_asor   = assortativity_nominal(g, dept,  directed = is.directed(g))
  )}
# Matriz 4x21
asort_perc <- sapply(grafos_percepcion, calc_asort,
                     age = age_v,
                     tenure = tenure_v,
                     level = level_v,
                     dept = dept_v)
## Warning: `is.directed()` was deprecated in igraph 2.0.0.
## ℹ Please use `is_directed()` instead.
## This warning is displayed once per session.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.
asort_cons <- calc_asort(grafo1, age_v, tenure_v, level_v, dept_v)

df_asort <- as.data.frame(t(asort_perc)) |>
  pivot_longer(everything(), names_to = "variable", values_to = "asortatividad") |>
  mutate(variable = recode(variable,
                           age_asor = "Edad",
                           tenure_asor = "Antigüedad",
                           level_asor = "Nivel jerárquico",
                           dept_asor = "Departamento"))

df_cons <- data.frame(variable = c("Edad", "Antigüedad", "Nivel jerárquico", "Departamento"),
                      asortatividad = asort_cons)

ggplot(df_asort, aes(x = asortatividad)) +
  geom_histogram(bins = 10, fill = "mediumpurple", color = "white", alpha = 0.8) +
  geom_vline(data = df_cons, aes(xintercept = asortatividad),
             color = "red", linewidth = 1.2, linetype = "dashed") +
  facet_wrap(~ variable, scales = "free") +
  labs(
    title    = "Distribución de la asortatividad en las redes de percepción",
    subtitle = "Línea roja punteada: asortatividad de la red de consenso",
    x = "Coeficiente de asortatividad", y = "Frecuencia"
  ) +
  theme_bw(base_size = 12) +
  theme(plot.title    = element_text(face = "bold", hjust = 0.5),
        plot.subtitle = element_text(hjust = 0.5)) +
  coord_cartesian(ylim = c(0,9))

Ahora analizamos el coeficiente de asortatividad basado en las características nodales con las que se cuentan. Los resultados muestran que los empleados tienden a conectarse con otros que tienen antiguedad y nivel jerárquico similar, así como aquellos que pertenezcan a los mismos departamentos. En contraste, la edad es una variable que los empleados no tienen en cuenta a la hora de formar sus lazos de amistad, aunque hay aquelloscasos en los que los actores entablan amistad con otros de edad distinta.

En cuanto a la diferencia entre el comportamiento colectivo vs el de la red de consenso vemos que para las variables antiguedad, departamento y nivel jerárquico se obtuvo un coeficiente de asortatividad positivo, en corcondancia con el comportamiento de las distribuciones de percepción; mientras que para la variable edad este valor resultó ser negativo.

Clustering

Los algoritmos de agrupamiento se van a correr sobre la red no dirigida, ya que hay métodos que solo funcionan en este tipo de redes.

# = = = = = = = = = = = = Clustering de la red de consenso = = = = = = = = = = = = 
 
set.seed(123)
grafo1_ud <- as_undirected(grafo1, mode = "collapse")

# Etiquetas reales de departamento
dept_real <- as.integer(factor(atributos_p1$dept, exclude = NULL))
 
metodos <- list("Walktrap"      = cluster_walktrap(grafo1_ud),
                "Louvain"       = cluster_louvain(grafo1_ud),
                "Girvan-Newman" = cluster_edge_betweenness(grafo1_ud),
                "Leading eigen" = cluster_leading_eigen(grafo1_ud),
                "Label prop"    = cluster_label_prop(grafo1_ud),
                "Fast greedy"   = cluster_fast_greedy(grafo1_ud),
                "Infomap"       = cluster_infomap(grafo1_ud))
 
calcular_indices <- function(memb_pred, memb_real) {
  c(RI  = rand.index(memb_pred, memb_real),
    ARI = adj.rand.index(memb_pred, memb_real))
}
 
resultados_cluster <- do.call(rbind, lapply(names(metodos), function(nm) {
  memb <- membership(metodos[[nm]])
  idx  <- calcular_indices(as.integer(memb), dept_real)
  data.frame(Metodo      = nm,
             N_clusters  = max(memb),
             Modularidad = modularity(metodos[[nm]]),
             RI          = idx["RI"],
             ARI         = idx["ARI"],
             stringsAsFactors = FALSE)
}))
rownames(resultados_cluster) <- NULL
kable(resultados_cluster, align = "c") %>% 
  kable_styling(bootstrap_options = c("bordered"))
Metodo N_clusters Modularidad RI ARI
Walktrap 13 0.7187500 0.7714286 0.1140798
Louvain 13 0.7187500 0.7714286 0.1140798
Girvan-Newman 13 0.7187500 0.7714286 0.1140798
Leading eigen 13 0.7187500 0.7714286 0.1140798
Label prop 14 0.6640625 0.7904762 0.1533810
Fast greedy 13 0.7187500 0.7714286 0.1140798
Infomap 13 0.7187500 0.7714286 0.1140798

Habiendo corrido 7 algoritmos de agrupamiento se observa que todos coinciden en el número de clusters que generan, un total de 13, a excepción del algoritmo label prop que genera uno adicional. Igualmente, todos los algoritmos excepto el mencionado registran los mismos valores de modularidad, indice de rand e indice de rand ajustado, ya que generan las mismas particiones.

Vemos que el algoritmo que resulta en una agrupación más cercana a la original (generada por los departamentos) es el algoritmo label prop, con un índice de rand cercano a 0.8, el cual indica que la agrupación generada es bastante similar pese a la gran cantidad de grupos que se generan. Recuérdese que la partición de referencia consta solamente de 5 departamentos.

Se observan las particiones a continuación

set.seed(42)
layout1_clus <- layout_with_fr(grafo1_ud)

df_nodos <- data.frame(x = layout1_clus[, 1], y = layout1_clus[, 2], actor = 1:I)

edges_df <- igraph::as_data_frame(grafo1_ud, what = "edges") |>
  mutate(x0 = layout1_clus[from, 1], y0 = layout1_clus[from, 2],
         x1 = layout1_clus[to,   1], y1 = layout1_clus[to,   2])

# Función que dibuja un clustering dado su nombre
plot_clustering <- function(nm) {
  memb  <- membership(metodos[[nm]])
  df_n  <- df_nodos |> mutate(cluster = factor(memb))
  ri_v  <- round(resultados_cluster$RI[resultados_cluster$Metodo  == nm], 3)
  ari_v <- round(resultados_cluster$ARI[resultados_cluster$Metodo == nm], 3)
  mod_v <- round(resultados_cluster$Modularidad[resultados_cluster$Metodo == nm], 3)

  ggplot() +
    geom_segment(data = edges_df,
                 aes(x = x0, y = y0, xend = x1, yend = y1),
                 color = "grey70", alpha = 0.5, linewidth = 0.4) +
    geom_point(data = df_n, aes(x = x, y = y, color = cluster), size = 4) +
    geom_text(data  = df_n, aes(x = x, y = y, label = actor),
              size  = 2.5, vjust = -0.8, color = "black") +
    scale_color_manual(values = colorspace::qualitative_hcl(14, palette = "Dark 3"),
                       name = "Cluster",
                       guide = guide_legend(ncol = 2)) +
    theme_void() +
    labs(title    = nm,
         subtitle = paste0("k = ", max(memb), " Mod = ", mod_v,
                           "\nRI = ", ri_v, " ARI = ", ari_v)) +
    theme(plot.title    = element_text(face = "bold", hjust = 0.5, size = 10),
          plot.subtitle = element_text(hjust = 0.5, size = 7.5))
}

# Partición real (referencia)
p_real <- ggplot() +
  geom_segment(data = edges_df,
               aes(x = x0, y = y0, xend = x1, yend = y1),
               color = "grey70", alpha = 0.5, linewidth = 0.4) +
  geom_point(data = df_nodos |> mutate(dept_f = factor(atributos_p1$dept)),
             aes(x = x, y = y, color = dept_f), size = 4) +
  geom_text(data = df_nodos, aes(x = x, y = y, label = actor),
            size = 2.5, vjust = -0.8, color = "black") +
  scale_color_brewer(palette = "Set1", name = "Departamento", na.value = "grey50") +
  theme_void() +
  labs(title = "Partición real (Departamento)") +
  theme(plot.title    = element_text(face = "bold", hjust = 0.5, size = 10),
        plot.subtitle = element_text(hjust = 0.5, size = 7.5))

plots_cluster <- lapply(names(metodos), plot_clustering)

wrap_plots(c(list(p_real), plots_cluster), ncol = 2) +
  plot_annotation(
    title = "Segmentación de la red de consenso — Comparativa de métodos",
    theme = theme(plot.title = element_text(hjust = 0.5, size = 13))
  )

Se observa que lo que hace diferente al algoritmo label_prop de los demás es que divide al grupo de los actores 17-21-2-18 en dos grupos, lo cual resulta ser más consistente con la partición de referencia puesto que los empleados 17 y 21 pertenecen a un departamento distinto de 2 y 18.

Así mismo vemos que los algortimos generan un número grande de clusters ya que toman a cada nodo aislado como un grupo aparte.

Punto 2

  1. El Sistema HORUS de la Universidad Nacional de Colombia es una plataforma de inteligencia de negocios que integra y visualiza la productividad científica y tecnológica de la institución. Utiliza datos de fuentes internas y externas, como SCOPUS, Google Scholar y el Repositorio Institucional UN, aplicando algoritmos de inteligencia artificial para estandarizar información y generar métricas en tableros de control. Esto facilita la toma de decisiones estratégicas y mejora la visibilidad de la producción académica de la UNAL. Más información está disponible en HORUS UNAL. Considere la base de datos disponible en este enlace, que contiene un archivo comprimido con los grafos que representan las relaciones entre temáticas y docentes en todos los niveles de HORUS (Institución, Sede, Facultad y Departamento).

    1. Utilizar los datos correspondientes a la Universidad Nacional de Colombia, Sede Bogotá, Facultad de Ciencias, Departamento de Estadística. A partir de la red bipartita \(\mathbf{A}\), construir la red binaria no dirigida de docentes mediante el producto matricial \(\mathbf{A}^T\mathbf{A}\) o \(\mathbf{A}\mathbf{A}^T\), según corresponda.

    2. Repetir el procedimiento anterior para los departamentos de Farmacia, Física, Geociencias, Matemáticas, Química.

    3. Crear visualizaciones detalladas y decoradas de todas las redes, destacando sus características clave. Presentar los resultados en un formato comparativo para facilitar el análisis de similitudes y diferencias entre las redes.

    4. Caracterizar cada una de las redes a nivel local y estructural, considerando métricas como la distancia, la centralidad, la cohesión, la conectividad y el agrupamiento. Utilizar todas las métricas disponibles para proporcionar un análisis exhaustivo de las propiedades de cada red.

    5. Repetir el análisis para toda la sede Bogotá.

    6. Interpretar los hallazgos obtenidos.

Solución Punto 2

Puesto que el proceso de cargar los datos se ha de repetir para varias carreras, solo nos interesan las matrices de adyacencia bipartitas

library(rjson)

cargar_horus <- function(archivo){
  
  horus <- fromJSON(file = archivo)

  nodos   <- horus$nodes
  aristas <- horus$links

  nodes_df <- data.frame(
    id    = sapply(nodos, function(x) as.character(x$id)),
    label = sapply(nodos, function(x) x$label),
    type  = sapply(nodos, function(x) x$type),
    stringsAsFactors = FALSE
  )
  links_df <- data.frame(
    source = sapply(aristas, function(x) as.character(x$source)),
    target = sapply(aristas, function(x) as.character(x$target)),
    value  = sapply(aristas, function(x) x$value),
    stringsAsFactors = FALSE
  )

  authors <- nodes_df %>%
    filter(type == "author") %>%
    rename(author_id = id,
           author_name = label
           )

  topics <- nodes_df %>%
    filter(type == "topic")

  faculties <- nodes_df %>%
    filter(type == "faculty") %>%
    rename(faculty_id = id,
           faculty_name = label
           )

  uabs <- nodes_df %>%
    filter(type == "uab") %>%
    rename(uab_id = id,
           uab_name = label
           )

# Matris bipartita A
  
  links_author_topic <- links_df %>%
    filter(source %in% authors$author_id & target %in% topics$id)

  A <- table(links_author_topic$source, links_author_topic$target)
  A <- as.matrix(A)

# Relaciones autor-departamento
  
  autor_uab <- links_df %>%
    filter(source %in% uabs$uab_id & target %in% authors$author_id) %>%
    left_join(uabs, by = c("source" = "uab_id") ) %>%
    left_join(authors, by = c("target" = "author_id") ) %>%
    select(
      author_id = target,
      author_name,
      uab_name
    )

# Relaciones facultad-departamento
  
  faculty_uab <- links_df %>%
    filter(source %in% faculties$faculty_id & target %in% uabs$uab_i) %>%
    left_join(faculties, by = c("source" = "faculty_id") ) %>%
    left_join(uabs, by = c("target" = "uab_id") ) %>%
    select(
      uab_name,
      faculty_name
    )

# Tabla final docentes
  autores_info <- autor_uab %>%
    left_join(faculty_uab, by = "uab_name") %>%
    distinct()

  return(list(
    A = A,
    autores = autores_info,
    nodes = nodes_df,
    links = links_df
  ))
}

archivos_p2 <- c(
  "Datos/graph/Universidad Nacional de Colombia-Bogotá-FACULTAD DE CIENCIAS-Departamento de Estadística.json",
  "Datos/graph/Universidad Nacional de Colombia-Bogotá-FACULTAD DE CIENCIAS-Departamento de Farmacia.json",
  "Datos/graph/Universidad Nacional de Colombia-Bogotá-FACULTAD DE CIENCIAS-Departamento de Física.json",
  "Datos/graph/Universidad Nacional de Colombia-Bogotá-FACULTAD DE CIENCIAS-Departamento de Geociencias.json",
  "Datos/graph/Universidad Nacional de Colombia-Bogotá-FACULTAD DE CIENCIAS-Departamento de Matemáticas.json",
  "Datos/graph/Universidad Nacional de Colombia-Bogotá-FACULTAD DE CIENCIAS-Departamento de Química.json"
)

datos_horus <- lapply(archivos_p2, cargar_horus)
names(datos_horus) <- c("Estadistica", "Farmacia", "Fisica", "Geociencias", "Matematicas", "Quimica")
matrices_A <- lapply(datos_horus, function(x) x[[1]])
# Nombres de los profesores
autores_carreras <- lapply(datos_horus, function(x) x$autores)

Obtenidas las matrices \(\mathbf{A}\) de las redes bipartitas en el objeto matrices_A, se construyen las redes binarias no dirigidas de docentes mediante el producto matricial \(\mathbf{A}\mathbf{A}^T\)

Y_docentes <- lapply(matrices_A, function(A){
  M <- A %*% t(A)
  M[M > 0] <- 1 # es una red binaria
  diag(M) <- 0
  return(M)
})

g2_estadistica <- graph_from_adjacency_matrix(Y_docentes$Estadistica, mode = "undirected", weighted = NULL)
g2_farmacia   <- graph_from_adjacency_matrix(Y_docentes$Farmacia, mode = "undirected", weighted = NULL)
g2_fisica     <- graph_from_adjacency_matrix(Y_docentes$Fisica, mode = "undirected", weighted = NULL)
g2_geociencias <- graph_from_adjacency_matrix(Y_docentes$Geociencias, mode = "undirected", weighted = NULL)
g2_matematicas <- graph_from_adjacency_matrix(Y_docentes$Matematicas, mode = "undirected", weighted = NULL)
g2_quimica    <- graph_from_adjacency_matrix(Y_docentes$Quimica, mode = "undirected", weighted = NULL)

vcount(g2_estadistica); ecount(g2_estadistica)
## [1] 44
## [1] 706
vcount(g2_farmacia); ecount(g2_farmacia)
## [1] 51
## [1] 1031
vcount(g2_fisica); ecount(g2_fisica)
## [1] 84
## [1] 2607
vcount(g2_geociencias); ecount(g2_geociencias)
## [1] 42
## [1] 510
vcount(g2_matematicas); ecount(g2_matematicas)
## [1] 88
## [1] 2148
vcount(g2_quimica); ecount(g2_quimica)
## [1] 119
## [1] 6237

Se observa que Geociencias es el departamento con el que menos docentes cuenta en esta red, con 42. Mientras que Química cuenta con 119 docentes. Así mismo, la red que cuenta con una mayor cantidad de aristas es Química, por una diferencia gigantesca respecto de las redes de los demás departamentos.

Visualizaciones

Para hacer las visualizaciones comparativas, todas usan el mismo layout y para todas el tamaño de los nodos representa el grado.

grafos_ciencias <- list(
  Estadistica = g2_estadistica,
  Farmacia = g2_farmacia,
  Fisica = g2_fisica,
  Geociencias = g2_geociencias,
  Matematicas = g2_matematicas,
  Quimica = g2_quimica
)
# No mostrar los aislados en las visualizaciones
grafos_ciencias <- lapply(grafos_ciencias, function(g){
  g <- g #delete_vertices(g, which(degree(g) == 0))
  V(g)$grado <- degree(g)
  return(g)
})

grafos_ciencias <- Map(
  function(g, autores){
    V(g)$name <- autores$author_name[match(V(g)$name, autores$author_id)]
    return(g)
  },
  grafos_ciencias, autores_carreras)
# , fig.height=25, fig.width=5
set.seed(9)
set_graph_style(plot_margin = margin(1,1,1,1))

plots <- lapply(names(grafos_ciencias), function(nombre){

  g <- grafos_ciencias[[nombre]]
  g_tbl <- as_tbl_graph(g)

  layout <- create_layout( g_tbl, layout = "igraph", algorithm = "kk")

  p <- ggraph(layout) +
    geom_edge_link(color = "grey70",
                   alpha = 0.4) +
    geom_node_point(aes(size = sqrt(grado)),
      color = "dodgerblue4") +
    scale_size(range = c(1,4), 
               guide = "none") +
    theme_void() +
    labs(title = paste("Red proyectada de docentes -", nombre),
         subtitle = "Tamaño proporcional al grado")
  return(p)
})
wrap_plots(plots, ncol = 1)

Que se hayan usado los mismos diseños para graficar las distintas redes nos permite contar con comparabilidad en sus visualizaciones.

Observamos, que el departamento de estadística cuenta con una red casi conectada, ya que hay un solo docente aislado de la componente principal. Además, 36 de los 44 nodos están fuertemente conectados entre sí ya que se ubican en la esfera central de esta.

Farmacia tiene una sola componente en su red, lo cual dice mucho acerca de su conectividad. Destacan un único docente con grado igual a 1 y otros dos con bajas conexiones en la periferia del gráfico.

La red de Física tiene dos nodos aislados y una díada desconectada de la componente gigante. Podemos ver que el centro de la red parece estar altamente conectado mediante nodos de grados altos similares, a excepción de dos docentes con grados bajos ubicados en el centro de esta.

Por su parte, Geociencias al ser el departamento con menor cantidad de nodos, es el que genera una visulaización más ‘limpia’. Tiene mayormente actores con grados similares, exceptuando dos que se encuentran en el centro de la sección más conectada. También cuenta con un nodo aislado.

La red para el departamento de matemáticas es la que peor se ve. Su nodo y díada aisladas le quitan protagonismo a la gran componente conectada con la que cuenta. Esta, da la impresión de ser muy densa.

Finalmente, química tiene un comportamiento similar a la carrera de estadística, con la salvedad de que esta red es casi 10 veces más densa, lo cual genera que las aristas se vean como una gran mancha gris en el fondo.

Nota: En evidencia, el layout seleccionado no favorece a todos los departamentos, pero era importante el factor de comparabilidad.

Véase a continuación el top de docentes por carrera de acuerdo a sus grados

top_grados <- lapply(grafos_ciencias, function(g){

  ord_grados <- sort(degree(g), decreasing = TRUE)
  head(ord_grados, 3)
})
top_grados
## $Estadistica
## Vanegas Penagos Luis Hernando      Gonzalez Garcia Luz Mery 
##                            40                            39 
##       Trujillo Oyola Leonardo 
##                            39 
## 
## $Farmacia
## Ospina Giraldo Luis Fernando       Pinzon Serrano Roberto 
##                           47                           47 
##       Rincon Velandia Javier 
##                           47 
## 
## $Fisica
##            Dussan Cuenca Anderson Martinez Martinez Roberto Enrique 
##                                76                                75 
##            Barba Ortega José José 
##                                75 
## 
## $Geociencias
##  Sarmiento Perez Gustavo Adolfo         Hernandez Pardo Orlando 
##                              36                              34 
## Sanchez Quiñonez Carlos Alberto 
##                              34 
## 
## $Matematicas
##          Nuñez Alarcon Daniel   Rojas Santana Edixon Manuel 
##                            71                            71 
## Acosta Gempeler Lorenzo Maria 
##                            71 
## 
## $Quimica
##         Alí Torres Jorge Isaac Avila Murillo Monica Constanza 
##                            115                            114 
##     Rojas Araque Jose Leopoldo 
##                            114

Dentro de las carreras de la facultad de ciencias estudiadas en el presente estudio, los docentes que han trabajado más en temas de producción académica son: Luis Hernando Vanegas, Luis Fernando Ospina, Anderson Dussan, Gustavo Adolfo Sarmiento, Daniel Nuñez y Jorge Isaac Alí.

Caracterización local y estructural de las redes

Caracterización en términos de distancia: Se calculan el diámetro de la red y la distancia geodésica promedio, para cada una de las carreras. Adicionalmente se presenta la distribución de distancias geodésicas de las redes.

distancia_2 <- data.frame(
  Carrera = names(grafos_ciencias),
  Diametro = sapply(grafos_ciencias, diameter),
  Distancia_promedio = sapply(grafos_ciencias, function(g){mean_distance(g, directed = FALSE, unconnected = TRUE)})
)
rownames(distancia_2) <- NULL
distancia_2 <- distancia_2 %>%
  column_to_rownames("Carrera") %>%
  t() %>%
  as.data.frame()

distancia_2["Diametro", ] <- sprintf("%.0f", as.numeric(distancia_2["Diametro", ]))
distancia_2["Distancia_promedio", ] <- sprintf("%.3f",as.numeric(distancia_2["Distancia_promedio", ]))

kable(distancia_2, align = "c",
  caption = "Medidas de distancia geodésica por carrera") %>%
  kable_styling(bootstrap_options = c("bordered", "striped", "hover"), full_width = FALSE)
Medidas de distancia geodésica por carrera
Estadistica Farmacia Fisica Geociencias Matematicas Quimica
Diametro 3 3 3 2 5 3
Distancia_promedio 1.220 1.197 1.154 1.312 1.491 1.097 
distancias_df <- lapply(names(grafos_ciencias), function(nombre){
  g <- grafos_ciencias[[nombre]]
  caminos <- distance_table(g)$res # distancias geodesicas

  data.frame(Carrera = nombre, Distancia = seq_along(caminos), Frecuencia = prop.table(caminos) )
}) %>%
  bind_rows()

ggplot(distancias_df, aes(x = Distancia, y = Frecuencia)) +
  geom_col(fill = "grey60") +
  facet_wrap(~ Carrera) +
  coord_cartesian(ylim = c(0, 0.8)) +
  theme_minimal(base_size = 13) +
  labs(
    title = "Distribución de distancias geodésicas",
    x = "Distancia geodésica",
    y = "Frecuencia relativa"
  )

Todos las redes cuentan con un diámetro pequeño, teniendo en cuenta la grann cantidad de nodos que estás tienen. Particularmente, en geociencias los docentes más alejados necesitan solo de 2 aristas para conectarse. Matemáticas es la carrera en la que toma más aristas llevar a cabo esta conexión: un total de 5.

En promedio, los docentes se conectan mediante 1 o 2 intermediarios para todas las redes. Las distribuciones de las distancias nos muestran que en general el 80% de los nodos solo necesita 1 nodo intermedio para conectarse con otro.

Caracterización en términos de centralidad: Se calcula el top 3 de docentes más centrales según los criterios vistos en clase, para cada una de las redes.

# Función para obtener el Top de nodos más centrales según el criterio
obtener_top <- function(g, medida){
  valores <- switch(medida,
    "Closeness"   = closeness(g, normalized = TRUE),
    "Betweenness" = betweenness(g, normalized = TRUE),
    "Eigenvector" = eigen_centrality(g)$vector)
  top <- head(sort(valores, decreasing = TRUE), 3)
  paste(names(top), collapse = "<br>")
}

# Tabla vacía
centralidades_2 <- data.frame(Carrera = names(grafos_ciencias), 
                              Closeness = NA, Betweenness = NA, Eigenvector = NA)
# Llenar tabla
for(i in seq_along(grafos_ciencias)){
  g <- grafos_ciencias[[i]]
  centralidades_2$Closeness[i] <- obtener_top(g, "Closeness")
  centralidades_2$Betweenness[i] <- obtener_top(g, "Betweenness")
  centralidades_2$Eigenvector[i] <- obtener_top(g, "Eigenvector")
}

kable( centralidades_2, align = "c", escape = FALSE, format = "html",
  caption = "Top docentes según medidas de centralidad") %>%
  kable_styling(bootstrap_options = c("bordered", "striped", "hover"), full_width = TRUE) %>%
  column_spec(2, width = "25em") %>%
  column_spec(3, width = "25em") %>%
  column_spec(4, width = "25em")
Top docentes según medidas de centralidad
Carrera Closeness Betweenness Eigenvector
Estadistica Vanegas Penagos Luis Hernando
Gonzalez Garcia Luz Mery
Trujillo Oyola Leonardo 		Vanegas Penagos Luis Hernando
Arunachalam Viswanathan
Melo Martinez Oscar Orlando 		Vanegas Penagos Luis Hernando
Gonzalez Garcia Luz Mery
Trujillo Oyola Leonardo
Farmacia Ospina Giraldo Luis Fernando
Pinzon Serrano Roberto
Rincon Velandia Javier 		Vallejo Diaz Bibiana Margarita Rosa
Valencia Islas Norma Angelica
Garcia Castañeda Javier Eduardo 		Rincon Velandia Javier
Marin Loaiza Juan Camilo
Pinzon Serrano Roberto
Fisica Cediel Casas Gilberto
Ramírez Gómez Catalina De Las Mercedes
Dussan Cuenca Anderson 		Perilla Perilla Carlos Joel
Dussan Cuenca Anderson
Barba Ortega José José 		Dussan Cuenca Anderson
Martinez Martinez Roberto Enrique
Barba Ortega José José
Geociencias Sarmiento Perez Gustavo Adolfo
Hernandez Pardo Orlando
Sanchez Quiñonez Carlos Alberto 		Sarmiento Perez Gustavo Adolfo
Diaz Almanza Eliecer David
Sanchez Quiñonez Carlos Alberto 		Sarmiento Perez Gustavo Adolfo
Molano Mendoza Juan Carlos
Hernandez Pardo Orlando
Matematicas Guarin Lopez Alexander
Ramos Vargas Juan De La Rosa
Acosta Gempeler Lorenzo Maria 		Gomez Sierra Cesar Augusto
Montañez Puentes Jose Reinaldo
Velasco Muñoz Antonio 		Nuñez Alarcon Daniel
Becerra Rojas Edward Samuel
Sarria Zapata Humberto
Quimica Alí Torres Jorge Isaac
Avila Murillo Monica Constanza
Rojas Araque Jose Leopoldo 		Chegwin Angarita Carolina
Alí Torres Jorge Isaac
Suarez Mendieta Margoth 		Alí Torres Jorge Isaac
Carriazo Baños Jose Gregorio
Moreno Guaqueta Sonia

  • Estadística: Todos los criterios de centralidad posicionan al profesor Luis Hernando Vanegas como el más importante en la red. La centralidad por cercanía y la centralidad propia devuelven el mismo ranking de importancia, mientras que bajo el criterio de intermediación dos profesores distintos toman relevancia. Esto se puede deber a que estos últimos juegan el rol de intermediarios en muchas relaciones.

  • Farmacia: Los docentes Luis Ospina, Roberto Pinzón y Javier Rincon son al mismo tiempo los más centrales en la red y los que se rodean de otros individuos centrales ya que conforman el top bajo centralidades por cercanía y propia. Curiosamente, por intermediación sobresalen docentes distintos a los mencionados.

  • Física: El docente Anderson Dussan es el único que aparece en el top bajo los tres criterios, aunque en diferentes posiciones. Que este sea el que se rodea de más individuos centrales va en concordancia con que sea el que más conexiones tiene en la red.

  • Geociencias: Todos los criterios de centralidad posicionan al profesor Gustavo Sarmieto como el actor más importante de la red. Recordemos que este también es el que más conexiones tiene en el sistema.

  • Matemáticas: Particularmente, en este departamento todos los tops de individuos más importantes son totalmente distintos. Esto nos estaría indicando que la importancia de los actores en esta red es altamente sensible al criterio que se use para comparar.

  • Química: El docente Jorge Alí Torres es el único que mantiene su importancia bajo cualquiera de los criterios estudiados. Es el más central, el segundo más importante como intermediador y el que se rodea a su vez de otros docentes más centrales.

Caracterización en términos de cohesión: En este apartado, se encuentran los ‘cliques’ más grandes de las redes junto con su frecuencia, además se llevan a cabo los censos diádicos y triádicos. Del mismo modo, se calculan la densidad y transitividad.

tam_max_clique <- data.frame(
  Carrera = names(grafos_ciencias),
  Clique_maximo = sapply(grafos_ciencias, clique_num),
  Nodos = sapply(grafos_ciencias, vcount)
)
# proporción respecto al tamaño de la red
tam_max_clique$Proporcion <- round(tam_max_clique$Clique_maximo / tam_max_clique$Nodos, 2)
rownames(tam_max_clique) <- NULL

tabla_clique <- tam_max_clique %>%
  select(Carrera, Clique_maximo, Proporcion) %>%
  tibble::column_to_rownames("Carrera") %>%
  t() %>%
  as.data.frame()

rownames(tabla_clique) <- c("Tamaño clan máximo", "Proporción sobre total de nodos")

kable(tabla_clique, align = "c", caption = "Tamaño y proporción del clan máximo por carrera") %>%
  kable_styling(bootstrap_options = c("bordered", "striped", "hover"), full_width = FALSE
  )
Tamaño y proporción del clan máximo por carrera
Estadistica Farmacia Fisica Geociencias Matematicas Quimica
Tamaño clan máximo 36.00 42.00 69.00 25.0 56.00 106.00
Proporción sobre total de nodos 0.82 0.82 0.82 0.6 0.64 0.89

Que el tamaño del clan máximo represente una proporción elevada del total de nodos de la red sugiere que la producción académica no se encuentra fragmentada en pequeños grupos aislados, sino que existe un núcleo amplio de docentes conectados entre sí a través de intereses temáticos comunes.

Dado que la red corresponde a una proyección docente-docente, donde dos profesores se conectan si han trabajado en al menos un mismo tema, un clan máximo grande indica la existencia de numerosos de docentes que comparten agendas de investigación similares o complementarias. En términos estructurales, esto refleja altos niveles de cohesión temática y potenciales dinámicas de colaboración indirecta dentro de la carrera.

censos_diadas <- lapply(grafos_ciencias, dyad_census)
censos_diadas_df <- do.call(rbind, censos_diadas)

kable(censos_diadas_df, digits = 0, align = "c", caption = "Censo de díadas por carrera") %>%
  kable_styling( bootstrap_options = c("bordered", "striped", "hover"), full_width = FALSE)
Censo de díadas por carrera
mut asym null
Estadistica 706 0 240
Farmacia 1031 0 244
Fisica 2607 0 879
Geociencias 510 0 351
Matematicas 2148 0 1680
Quimica 6237 0 784

Típicamente, en el censo de díadas la carrera que más parejas se obtienen es Química.

triad_labels <- c(
  "003","012","102","021D","021U","021C",
  "111D","111U","030T","030C","201",
  "120D","120U","120C","210","300")

censos_triadas <- lapply(grafos_ciencias, function(g){
  x <- triad_census(g)
  names(x) <- triad_labels
  x
})
censos_triadas_df <- do.call(rbind, censos_triadas)

kable( censos_triadas_df, digits = 0, align = "c", caption = "Censo de triadas por carrera") %>%
  kable_styling( bootstrap_options = c("bordered", "striped", "hover"), full_width = TRUE)
Censo de triadas por carrera
003 012 102 021D 021U 021C 111D 111U 030T 030C 201 120D 120U 120C 210 300
Estadistica 510 0 3364 0 0 0 0 0 0 0 1822 0 0 0 0 7548
Farmacia 434 0 3808 0 0 0 0 0 0 0 3038 0 0 0 0 13545
Fisica 4114 0 26039 0 0 0 0 0 0 0 7658 0 0 0 0 57473
Geociencias 1269 0 4136 0 0 0 0 0 0 0 1961 0 0 0 0 4114
Matematicas 15166 0 41401 0 0 0 0 0 0 0 16180 0 0 0 0 36989
Quimica 2169 0 33132 0 0 0 0 0 0 0 18957 0 0 0 0 219561 
analisis_triadas <- function(g, B = 1000,
                             triadas_interes = c("003", "102", "201", "300")){
  triad_labels <- c(
    "003","012","102","021D","021U","021C",
    "111D","111U","030T","030C","201",
    "120D","120U","120C","210","300"
  )
  # índices de las triadas que se quieren
  idx <- match(triadas_interes, triad_labels)

  # censo observado
  censo_obs <- triad_census(g)[idx]
  deg <- degree(g)

  # matriz reducida
  null_counts <- matrix(
    NA_real_,
    nrow = B,
    ncol = length(idx),
    dimnames = list(NULL, triadas_interes)
  )

  set.seed(123)

  for(b in seq_len(B)){

    g_null <- sample_degseq(
      out.deg = deg,
      method = "edge.switching.simple"
    )

    null_counts[b, ] <- triad_census(g_null)[idx]
  }

  mu_null <- colMeans(null_counts)
  sd_null <- apply(null_counts, 2, sd)

  z_scores <- ifelse(
    sd_null > 0,
    (censo_obs - mu_null)/sd_null,
    NA_real_
  )

  data.frame(
    Triada = triadas_interes,
    Observado = censo_obs,
    Media_nula = mu_null,
    SD_nula = sd_null,
    Z = z_scores
  )
}
resultados_triadas <- lapply(grafos_ciencias, analisis_triadas, B = 100,
  triadas_interes = c("003", "102", "201", "300")
)
resultados_triadas$Estadistica  
##     Triada Observado Media_nula   SD_nula         Z
## 003    003       510     603.01  4.513716 -20.60608
## 102    102      3364    3084.97 13.541149  20.60608
## 201    201      1822    2101.03 13.541149 -20.60608
## 300    300      7548    7454.99  4.513716  20.60608
resultados_triadas$Farmacia 
##     Triada Observado Media_nula  SD_nula         Z
## 003    003       434     519.63  4.69613 -18.23416
## 102    102      3808    3551.11 14.08839  18.23416
## 201    201      3038    3294.89 14.08839 -18.23416
## 300    300     13545   13459.37  4.69613  18.23416
resultados_triadas$Fisica
##     Triada Observado Media_nula   SD_nula        Z
## 003    003      4114    4477.97  8.092215 -44.9778
## 102    102     26039   24947.09 24.276644  44.9778
## 201    201      7658    8749.91 24.276644 -44.9778
## 300    300     57473   57109.03  8.092215  44.9778
resultados_triadas$Geociencias 
##     Triada Observado Media_nula  SD_nula         Z
## 003    003      1269    1433.49  8.49301 -19.36769
## 102    102      4136    3642.53 25.47903  19.36769
## 201    201      1961    2454.47 25.47903 -19.36769
## 300    300      4114    3949.51  8.49301  19.36769
resultados_triadas$Matematicas 
##     Triada Observado Media_nula   SD_nula         Z
## 003    003     15166   16706.77  35.64382 -43.22685
## 102    102     41401   36778.69 106.93146  43.22685
## 201    201     16180   20802.31 106.93146 -43.22685
## 300    300     36989   35448.23  35.64382  43.22685
resultados_triadas$Quimica
##     Triada Observado Media_nula  SD_nula         Z
## 003    003      2169    2416.92 11.29108 -21.95716
## 102    102     33132   32388.24 33.87324  21.95716
## 201    201     18957   19700.76 33.87324 -21.95716
## 300    300    219561  219313.08 11.29108  21.95716

Evidenciamos que todas las redes estudiadas de la facultad presentaron una cantidad baja de tríadas nulas y tríadas tipo 201, respecto de lo esperado bajo un modelo nulo. Mientras que las tríadas tipo 102 y las completas se presenten en una cantidad significativamente alta.

cohesion_2 <- data.frame(Carrera = names(grafos_ciencias),
                         Densidad = round(sapply(grafos_ciencias, edge_density), 3),
                         Transitividad = round(sapply(grafos_ciencias, transitivity), 3) )
rownames(cohesion_2) <- NULL

cohesion_2 <- cohesion_2 %>%
  tibble::column_to_rownames("Carrera") %>%
  t() %>%
  as.data.frame()

kable(cohesion_2, align = "c") %>%
  kable_styling(bootstrap_options = c("bordered", "striped", "hover"), full_width = FALSE)
Estadistica Farmacia Fisica Geociencias Matematicas Quimica
Densidad 0.746 0.809 0.748 0.592 0.561 0.888
Transitividad 0.926 0.930 0.957 0.863 0.873 0.972 
# Transitividades locales
trans_df <- lapply(names(grafos_ciencias), function(nombre){
  g <- grafos_ciencias[[nombre]]
  data.frame(Carrera = nombre,
             Transitividad = transitivity( g, type = "local", isolates = "zero") ) }) %>%
  bind_rows()

# Gráfico
ggplot(trans_df, aes(x = Transitividad)) +
  geom_histogram(bins = 15, 
                 fill = "grey60",
                 color = "white") +
  facet_wrap(~ Carrera) +
  theme_minimal(base_size = 13) +
  labs(title = "Distribución de la transitividad local",
       x = "Transitividad local",y = "Frecuencia")

La red de proyección más densa resultó ser la del departamento de química (la cual está considerablemente cerca de ser un clan), seguida de farmacia, física y estadística. Sorprendentemente, la red menos densa es la de matemáticas, característica que se puede deber a sus nodos aislados.

En temas de transitividad, todas las carreras se están en una muy buena posición bajo este criterio. La red más transitiva es la de química, seguida por física y farmacia. Las distribcuiones de la transitividad local dejan ver que geociencias y matemáticas presentan más dispersión en sus valores, los cuales hacen que su transitividad global no tome los valores más altos.

Caracterización en términos de conectividad: Se estudia la conectividad por vértices y aristas, la componente gigante y sus características de conectividad.

sapply(grafos_ciencias, is_connected)
## Estadistica    Farmacia      Fisica Geociencias Matematicas     Quimica 
##       FALSE        TRUE       FALSE       FALSE       FALSE       FALSE
sapply(grafos_ciencias, vertex_connectivity)
## Estadistica    Farmacia      Fisica Geociencias Matematicas     Quimica 
##           0           1           0           0           0           0
sapply(grafos_ciencias, edge_connectivity)
## Estadistica    Farmacia      Fisica Geociencias Matematicas     Quimica 
##           0           1           0           0           0           0

Farmacia es la única carrera para la cual su red de docentes está conectada. Su conectividad nodal y de aristas toman un valor de 1, mostrando que esa conectividad es bastante sensible a la eliminación de algún actor de la red.

componentes_2 <- sapply(grafos_ciencias, decompose)
sapply(componentes_2, length)
## Estadistica    Farmacia      Fisica Geociencias Matematicas     Quimica 
##           2           1           6           4           3           2
tam_componentes <- lapply(componentes_2, function(comp){table(sapply(comp, vcount)) })
tam_componentes
## $Estadistica
## 
##  1 43 
##  1  1 
## 
## $Farmacia
## 
## 51 
##  1 
## 
## $Fisica
## 
##  1  2 78 
##  4  1  1 
## 
## $Geociencias
## 
##  1 39 
##  3  1 
## 
## $Matematicas
## 
##  1  2 85 
##  1  1  1 
## 
## $Quimica
## 
##   1 118 
##   1   1

La red de producción académica de los docentes del departamento de física es la que tiene una mayor cantidad de componentes, característcia ya detectadas en la visualziación de esta.

Las redes proyectadas de docentes de estadística, geociencias y química no están coenctadas por la presencia de un único profesor aislado quqe ha publicado sobre algún tema que nadie más comparte. Física y matemáticas adicionalmente cuentan con otra componente de tamaño 2 en sus descomposiciones.

grafos2_conectados <- lapply(grafos_ciencias, function(g){
  comps <- decompose(g)
  comps[[which.max(sapply(comps, vcount))]]
})

conectividad_df <- data.frame(
  Carrera = names(grafos2_conectados),
  Conectividad_nodal = sapply(grafos2_conectados, vertex_connectivity),

  Conectividad_aristas = sapply(grafos2_conectados, edge_connectivity),

  Puntos_articulacion = sapply(grafos2_conectados,
           function(g) length(articulation_points(g))),

  Proporcion_articulacion = sapply(grafos2_conectados, function(g){length(articulation_points(g)) / vcount(g)})
) 

kable(
  conectividad_df,
  digits = 3,
  align = "c",
  caption = "Medidas de conectividad sobre la componente gigante, por carrera"
) %>%
  kable_styling(
    bootstrap_options = c("bordered", "striped", "hover"),
    full_width = FALSE
  )
Medidas de conectividad sobre la componente gigante, por carrera
Carrera Conectividad_nodal Conectividad_aristas Puntos_articulacion Proporcion_articulacion
Estadistica Estadistica 5 5 0 0.000
Farmacia Farmacia 1 1 1 0.020
Fisica Fisica 1 1 1 0.013
Geociencias Geociencias 5 5 0 0.000
Matematicas Matematicas 1 1 2 0.024
Quimica Quimica 1 1 1 0.008

Ahora, con el fin de ir más allá en el análisis de la conectividad de las redes de proyección, se toman de base las componentes conexas de cadad carrera y sobre estas se analizan sus características. Las carreras de estadística y geociencias son las únicas que muestran una conectividad nodal y de aristas superior a 1, de echo toman el valor de 5; lo cual hace a sus componentes más robustas a posibles desconecciones de nodos. Por esta misma razón, no cuentan con puntos de articulación.

La red de docentes de matemáticas cuenta con 2 puntos de articulación, lo cual solo representa el 2.4% de los nodos totales, una cantidad baja.

Caracterización en términos del agrupamiento:

obtener_comunidades <- function(g){
  list(FastGreedy   = cluster_fast_greedy(g),
       LeadingEigen = cluster_leading_eigen(g),
       Walktrap     = cluster_walktrap(g),
       Louvain      = cluster_louvain(g),
       LabelProp    = cluster_label_prop(g),
      # Optimal      = cluster_optimal(g), este no se aplica debido a su gigantesco costo computacional (+4 horas)
       Infomap      = cluster_infomap(g)
  )
}
# aplicar a todas las carreras
comunidades_2 <- lapply(grafos_ciencias, obtener_comunidades)

modularidades_2 <- lapply(names(comunidades_2), function(nombre){
  algs <- comunidades_2[[nombre]]
  g <- grafos_ciencias[[nombre]]
  data.frame(Carrera = nombre, 
             Algoritmo = names(algs), 
             Modularidad = sapply(algs, modularity), 
             Clusters = sapply(algs, length) ) }) %>%
  bind_rows()

tabla_modularidad <- modularidades_2 %>%
  select(Carrera, Algoritmo, Modularidad) %>%
  pivot_wider(
    names_from = Algoritmo,
    values_from = Modularidad
  )
rownames(tabla_modularidad) <- NULL

tabla_clusters <- modularidades_2 %>%
  select(Carrera, Algoritmo, Clusters) %>%
  pivot_wider(
    names_from = Algoritmo,
    values_from = Clusters
  )
rownames(tabla_clusters) <- NULL

kable(tabla_modularidad, digits = 3, align = "c", caption = "Modularidad por algoritmo y carrera") %>%
  kable_styling(bootstrap_options = c("bordered", "striped", "hover"), full_width = FALSE
  )
Modularidad por algoritmo y carrera
Carrera FastGreedy LeadingEigen Walktrap Louvain LabelProp Infomap
Estadistica 0.031 0.030 0.008 0.034 0.000 0.000
Farmacia 0.025 0.026 0.006 0.027 0.000 0.000
Fisica 0.018 0.020 0.007 0.021 0.001 0.001
Geociencias 0.060 0.061 0.021 0.064 0.000 0.000
Matematicas 0.050 0.047 0.019 0.066 0.001 0.006
Quimica 0.010 0.011 0.001 0.012 0.000 0.000 
set.seed(1)
mejor_algoritmo <- modularidades_2 %>%
  group_by(Carrera) %>%
  slice_max(Modularidad, n = 1)
mejor_algoritmo
## # A tibble: 6 × 4
## # Groups:   Carrera [6]
##   Carrera     Algoritmo Modularidad Clusters
##   <chr>       <chr>           <dbl>    <int>
## 1 Estadistica Louvain        0.0337        5
## 2 Farmacia    Louvain        0.0268        3
## 3 Fisica      Louvain        0.0206        8
## 4 Geociencias Louvain        0.0640        6
## 5 Matematicas Louvain        0.0658        6
## 6 Quimica     Louvain        0.0120        4

En la búsqueda de comunidades para cada uno de los grafos de proyección docente-docente se implementaron seis algoritmos de agrupamiento para cada una de las carreras. En términos generales los que mejor se comportatron fueron el algoritmo jerárquico leading_eigen y el semi-jerarquico louvain (semi porque tiene una fase de optimización de la modularidad y otra fase jerarquica).

Concretamente, los agrupamientos de lasredes de proyección docente-deocente de las carreras de estadística, geociencias, matemáticas y química maximizan su modularidad bajo el algoritmo Louvain, mientras que farmacia y física lo hacen con leading_eigen.

graficar_comunidades <- function(g, clustering, nombre, algoritmo){
  g_tbl <- as_tbl_graph(g) %>%
    mutate(comunidad = factor(clustering$membership),
           grado = degree(g))

  set.seed(1)

  layout <- create_layout(g_tbl, layout = "igraph", algorithm = "kk")

  ggraph(layout) +
    geom_edge_link(alpha = 0.4, colour = "gray70"
                    ) +
    geom_node_point(aes(color = comunidad, size = grado)
                    ) +
    scale_size(range = c(1, 4),guide = "none") +
    theme_void() +
    labs(title = paste("Agrupamiento -", nombre),
      subtitle = paste("Algoritmo:", algoritmo, "| Modularidad =", round(modularity(clustering), 3) ),
      color = "Comunidad"
      )
}

plots_comunidades_2 <- lapply(names(grafos_ciencias), function(nombre){

  algoritmo <- mejor_algoritmo$Algoritmo[mejor_algoritmo$Carrera == nombre]
  clustering <- comunidades_2[[nombre]][[algoritmo]]

  graficar_comunidades(g = grafos_ciencias[[nombre]],
                       clustering = clustering,
                       nombre = nombre,
                       algoritmo = algoritmo)
})
wrap_plots(plots_comunidades_2, ncol = 2)

En todos los casos los docentes aislados comprenden un cluster en sí mismos. La red del departamento de farmacia se subdivide solo en 4 clusters, mientras que en la red de la carrera de física se obtienen un toal de 6.

Análisis Sede Bogotá

Ahora, se desea analizar nuevamente la red proyectada docente-docente en la que dos profesores están conectados si han llevado a cabo producciones académicas en temas en común, pero ahora a la escala de todos los docentes de la sede Bogotá.

datos_horus_bogota <- cargar_horus("Datos/graph/Universidad Nacional de Colombia-Bogotá.json")
matriz_A_bogota <- datos_horus_bogota$A
Y_docentes_bogota <- matriz_A_bogota %*% t(matriz_A_bogota)
Y_docentes_bogota[Y_docentes_bogota > 0] <- 1 # es una red binaria
diag(Y_docentes_bogota) <- 0
g2_bogota <- graph_from_adjacency_matrix(Y_docentes_bogota, mode = "undirected", weighted = NULL)

atributos_autores <- datos_horus_bogota$autores %>%
  filter(author_id %in% rownames(matriz_A_bogota))
vertex_attr(g2_bogota) <- atributos_autores

V(g2_bogota)$name <- V(g2_bogota)$author_name

vcount(g2_bogota); ecount(g2_bogota)
## [1] 1533
## [1] 315743

Esta red binaria no dirigida cuenta con 1533 nodos y 315.743 aristas, la red más grande que se ha trabajado hasta el momento.

ends_mat <- ends(g2_bogota, E(g2_bogota))

fac1 <- V(g2_bogota)$faculty_name[match(ends_mat[,1], V(g2_bogota)$name)]
fac2 <- V(g2_bogota)$faculty_name[match(ends_mat[,2], V(g2_bogota)$name)]

interfac <- fac1 != fac2

g2_inter <- subgraph_from_edges(g2_bogota, E(g2_bogota)[interfac], delete.vertices = FALSE)

deg <- degree(g2_inter)
umbral <- quantile(deg, 0.90)

g2_core <- induced_subgraph(g2_inter, vids = V(g2_inter)[deg >= umbral])

g2_tbl <- as_tbl_graph(g2_core)

# coreness opcional
g2_tbl <- g2_tbl %>%
  mutate(faculty = factor(faculty_name) )

# hive plot
ggraph(g2_bogota, layout = "hive", axis = faculty_name, sort.by = 'degree') +
  geom_edge_hive(alpha = 0.03, colour = "grey40", width = 0.5) +
  geom_axis_hive(aes(colour = faculty_name),
                 linewidth  = 2,
                 label = FALSE) +
  coord_fixed() +
  theme_gray() +
  theme(axis.text = element_blank(), axis.title = element_blank()
  ) +
  labs(
    title = "Hive plot de la red de docentes UNAL Bogotá",
    colour = "Facultad"
  )

Caracterización en términos de distancia

diameter(g2_bogota)
## [1] 5
mean_distance(g2_bogota)
## [1] 1.856395
# Visualización
caminos <- distance_table(g2_bogota)$res
names(caminos) <- 1:length(caminos)
barplot(
  prop.table(caminos), 
  xlab = "Distancia geodésica", 
  ylab = "F. Relativa", 
  border = "grey", 
  col = "grey", 
  main = "Distribución de distancias geodésicas para la\n red de docentes de la Sede Bogotá"
)

El diametro de la red toma el valor de 5, lo que quiere decir que los dos docentes más alejados necesitan 5 aristas para conectarse por el camino más corto. Que una red tan masiva como esta tenga un diametro tan pequeño ya nos está dando luces sobre lo conectada que está. La distribución de las distancias geodésicas sigue esta idea, ya que en su mayoria se agrupan en 1 y 2.

Caracterización en términos de centralidad

# top 3
cc <- igraph::closeness(graph = g2_bogota, normalized = T)
head(sort(cc, decreasing = T), n = 3)
##         García López Manuel   Galindo Cruz Johan Fabián 
##                   0.7026654                   0.6991312 
## Herrera Osorio Fredy Andrei 
##                   0.6956324
# top 3
bc <- igraph::betweenness(graph = g2_bogota, normalized = T)
head(sort(bc, decreasing = T), n = 3)
## Salazar Galán Sergio Andrés      Santana Santana Ismael 
##                  0.02109920                  0.01812228 
##       Mejía Gaviria Natalia 
##                  0.01762965
# top 3
ec <- igraph::eigen_centrality(graph = g2_bogota)$vector
head(sort(ec, decreasing = T), n = 3)
##   Galindo Cruz Johan Fabián         García López Manuel 
##                   1.0000000                   0.9980710 
## Herrera Osorio Fredy Andrei 
##                   0.9939592

En primer lugar, bajo el criterio de centralidad por cercanía los docentes más importantes son: Manuel García López, profesor en el departamento Ingeniería civil y agrícola; Johan Fabián Galindo, profesor en el departamento de Química; y Fredy Andrei Herrera, profesor en el departamento de Derecho. Sus valores de centralidad son bastante elevados, reiterando que su importancia tiene bastante peso.

En cuanto a la centralidad por intermediación, los actores más importantes son: Sergio Andrés Salazar, profesor en el departamento de Ingeniería civil y agrícola; Ismael Santana, profesor en el departamento de Ingeniería civil y agrícola; y Natalia Mejía, profesora en el departamento de Pediatría. Ya que dos docentes se coenctan si tienen temas en común, estos profesores estar´´ian actuando como puentes entre ejes temáticos para varios grupos de nodos.

Por último, los nodos más importantes en términos de los vecinos centrales con los que cuentan son unos ya mencionados en los tops anteriores: Johan Fabián Galindo, Manuel García López y Fredy Andrei Herrera.

Se resalta que 3 docentes del departamento de Ingeniería civil y agrícola hicieron parte de estos tops. Parece ser que en esa discilplina se trabajn muchos temas interdisciplinares que les otorgan importancia en la red.

Caracterización en términos de cohesión

La caracterización en términos de clanes y censos de diadas y triadas es computacionalmente muy pesada dado el tamañod e la red, así que se omiten.

# número clan
#clique_num(graph = g2_bogota)
#dyad_census(g8_conflict)

#triad_labels <- c("003",  "012",  "102",  "021D", "021U", "021C",
#                  "111D", "111U", "030T", "030C", "201",
#                  "120D", "120U", "120C", "210",  "300")
#censo3 <- triad_census(g2_bogota)
#names(g2_bogota) <- triad_labels
# Densidad
edge_density(graph = g2_bogota)
## [1] 0.2688827

Un valor de 0.27 en la densidad implica que aproximadamente el 27% de todas las conexiones posibles entre docentes efectivamente existen. Además, esta sugiere que las líneas de investigación en la universidad no están tan aisladas, porque muchos profesores están compartiendo áreas en sus producciones académicas dentro de la sede Bogotá.

# Transitividad
transitivity(graph = g2_bogota, type = "global")
## [1] 0.7271895
# intransitividad local
hist(transitivity(g2_bogota, type = "local"), xlab = "Transitividad local", ylab = "Frecuencia",
     main = "Distribución de la transitividad local")

La transitividad toma un valor de 0.727. Esta nos dice que si el docente A comparte temas con B, y B comparte temas con C, entonces con una alta probabilidad A también comparte temas con C. Esta medida soporta el hallazgo de que existen líneas de investigación colectivas entre los docentes de la institución.

Afirmamos entonces, que la red presenta una alta cohesión global

Caracterización en términos de conectividad

# componente gigante
is_connected(g2_bogota)
## [1] FALSE
vertex_connectivity(g2_bogota)
## [1] 0
edge_connectivity(g2_bogota)
## [1] 0

Como era de esperarse en una red con tantos actores, esta no es conectada. Procedemos ahora a encontrar las componentes de esta

# componentes
componentes <- decompose(g2_bogota)
length(componentes)
## [1] 4
table(sapply(X = componentes, FUN = vcount)) 
## 
##    1 1530 
##    3    1
g2_cg <- decompose(g2_bogota)[[1]]
# conectividad nodal
vertex_connectivity(g2_cg)
## [1] 1
edge_connectivity(g2_cg)
## [1] 1
articulation_points(g2_cg)
## + 1/1530 vertex, named, from 4638e54:
## [1] Valero Bernal José Francisco
length(articulation_points(g2_cg))/vcount(g2_cg)
## [1] 0.0006535948

La red de proyección docente-docente para la sede Bogotá tiene tres componentes de tamaño 1 y una componente de tamaño 1530. Esto nos dice que a pesar de la gran cantidad de nodos en al red, la componente gigante abarca el 99.8% de los nodos totales.

Acerca de esta gran componente conexa, tiene conectividad nodal y de aristas de 1, lo que quiere decir que removiendo solo uno de los 1530 docentes, el subgrafo ya no es conectado. Un vértice que al ser removido desconecta el grafo es el profesor Jose Franciso valero del departamento de Cirugía.

Caracterización en términos del agrupamiento

# algoritmos
set.seed(1)
clust2_fast_greedy <- cluster_fast_greedy(g2_bogota)
clust2_leading_eigen <- cluster_leading_eigen(g2_bogota)
clust2_walktrap <- cluster_walktrap(g2_bogota)
clust2_louvain <- cluster_louvain(g2_bogota)
clust2_label_prop <- cluster_label_prop(g2_bogota)
#clust2_optimal <- cluster_optimal(g2_bogota) no se icluye por costo computacional
clust2_infomap <- cluster_infomap(g2_bogota)
tabla_modularidad <- data.frame(
  Medida = c("Modularidad", "Número de clusters"),
  FastGreedy = c(sprintf("%.3f", modularity(clust2_fast_greedy)),
                 sprintf("%.0f", length(clust2_fast_greedy))  ),
  LeadingEigen = c(sprintf("%.3f", modularity(clust2_leading_eigen)),
                   sprintf("%.0f", length(clust2_leading_eigen))  ),
  Walktrap = c(sprintf("%.3f", modularity(clust2_walktrap)),
               sprintf("%.0f", length(clust2_walktrap))  ),
  Louvain = c(sprintf("%.3f", modularity(clust2_louvain)),
              sprintf("%.0f", length(clust2_louvain))  ),
  LabelProp = c(sprintf("%.3f", modularity(clust2_label_prop)),
                sprintf("%.0f", length(clust2_label_prop))  ),
  Infomap = c(sprintf("%.3f", modularity(clust2_infomap)),
              sprintf("%.0f", length(clust2_infomap))  ),
  check.names = FALSE
)

kable(tabla_modularidad, align = "c",
  caption = "Modularidad y número de clusters por algoritmo") %>%
  kable_styling(bootstrap_options = c("bordered", "striped", "hover"),
                full_width = FALSE)
Modularidad y número de clusters por algoritmo
Medida FastGreedy LeadingEigen Walktrap Louvain LabelProp Infomap
Modularidad 0.265 0.285 0.218 0.288 0.139 0.169
Número de clusters 7 7 35 7 7 10

El algoritmo que maximiza la modularidad es louvain (0.288), el cual genera una partición de los nodos en 7 clusters.

Ya que los nodos en la red ya cuentan con una segmentación natural dada por las facultades a las que pertenecen los docentes, se comparan ambos agrupamientos mediante el índice de rand y el indice de rand ajustado

set.seed(1)
clust_louvain <- cluster_louvain(g2_bogota)
facultades <- as.factor(V(g2_bogota)$faculty_name)

comm_facultad <- as.numeric(facultades)
comm_louvain  <- membership(clust_louvain)

# Indices
rand_index <- compare(comm1 = comm_facultad, comm2 = comm_louvain,method = "rand")
rand_ajustado <- compare(comm1 = comm_facultad, comm2 = comm_louvain, method = "adjusted.rand")

# tabla resumen
tabla_rand <- data.frame(Medida = c("Rand", "Rand ajustado"),
                         Valor = c(rand_index, rand_ajustado) )

kable(tabla_rand, digits = 3, align = "c",
  caption = "Comparación entre segmentación por facultad y Louvain"
) %>%
  kable_styling(bootstrap_options = c("bordered", "striped", "hover"),
                full_width = FALSE) %>% 
  column_spec(1, width = "25em") %>%
  column_spec(2, width = "25em")
Comparación entre segmentación por facultad y Louvain
Medida Valor
Rand 0.659
Rand ajustado 0.172

Un indice de rand cercano a 1 deja ver que ambas paticiones son muy similares. El índice de rand ajustado a su vez, toma valores cercanos 1 cuando hay una fuerte coincidencia, 0 cuando el acuerdo es comparable con el azar y -1 cuando hay desacuerdo total.

En nuestro caso, aunque el indice de rand es cercano a 0.66, el indice de rand ajustado es de 0.17, evidenciando que las comunidades surgen más por afinidad temática que por estructura administrativa (estructura de facultades).

Punto 3

  1. Este caso se basa en la preimpresión del artículo A Network-Based Approach to Characterize Twenty-First-Century Populism in Colombia (García-Arteaga y Pellegrino, 2021), disponible en este enlace. El artículo aborda el populismo como “un fenómeno político de antiliberalismo democrático centrado en la figura de un líder fuerte” y realiza, entre otros aspectos, una revisión del populismo y su contexto en Colombia, destacando la posición e influencia de Álvaro Uribe como líder populista. Para ello, se analizan las conexiones de figuras prominentes del panorama político colombiano reciente, considerando relaciones de trabajo, alianzas, rivalidades, amistades y vínculos familiares, contenidas en los archivos nodes.csv. Según la Sección 2 del artículo, los datos fueron recolectados mediante herramientas de web scraping de la sección “Quién es quién” del medio colombiano independiente La Silla Vacía. El análisis identifica que las redes de trabajo (work-edges.csv) y de alianzas (alliance-edges.csv) son las más relevantes, y sus componentes conexas constituyen la principal fuente de información para el estudio. Los datos están disponibles en la página web del curso.

  1. Analizar cada una de las redes tanto a nivel local como estructural, utilizando métricas como distancia, centralidad, cohesión, conectividad y agrupamiento. Emplear todas las métricas disponibles para realizar un análisis detallado y completo de las características y propiedades de cada red.

  2. Interpretar los hallazgos obtenidos.

Solución Punto 3

Empezamos cargando los datos de la red de trabajo y la red de alianzas.

library(readr)
nodes3 <- read_csv("Datos/nodes.csv")
work_edges3 <- read_csv("Datos/work-edges.csv")
alliance_edges3 <- read_csv("Datos/alliance-edges.csv")

g3_trabajo <- graph_from_edgelist(as.matrix(work_edges3), directed = FALSE)
g3_alianzas <- graph_from_edgelist(as.matrix(alliance_edges3), directed = FALSE)

g3_trabajo <- igraph::simplify(g3_trabajo, remove.multiple = TRUE, remove.loops = TRUE)
g3_alianzas <- igraph::simplify(g3_alianzas, remove.multiple = TRUE, remove.loops = TRUE)

vcount(g3_trabajo); ecount(g3_trabajo)
## [1] 511
## [1] 1392
vcount(g3_alianzas); ecount(g3_alianzas)  
## [1] 356
## [1] 689

Inicialmente, la red de relaciones de trabajo cuenta con 511 actores, conectados con 1392 aristas. Por otro lado, en la red de alianzas políticas se tienen 356 nodos unidos entre si a través de 689 aristas.

Como se menciona en el enunciado, las componentes conexas de las redes trabajadas constituyen la principal fuente de información. Es por esto que los análisis se harán sobre estas componentes exclusivamente.

g3_trabajo_cg <- decompose(g3_trabajo)[[1]]
g3_alianzas_cg <- decompose(g3_alianzas)[[1]]

V(g3_trabajo_cg)$grado <- degree(g3_trabajo_cg)
V(g3_alianzas_cg)$grado <- degree(g3_alianzas_cg)

vcount(g3_trabajo_cg); ecount(g3_trabajo_cg)
## [1] 485
## [1] 1379
vcount(g3_alianzas_cg); ecount(g3_alianzas_cg)
## [1] 335
## [1] 678

Al quedarnos solo con la componente conexa más grande de cada red resultamos con el 94.9% y el 94.1% de los nodos oruginales para las redes de trabajo y alianzas respectivamente, abarcando una gran cantidad de información

g3_trabajo_tbl <- as_tbl_graph(g3_trabajo_cg)
set_graph_style(plot_margin = margin(1,1,1,1))

nodos_especiales <- c("alvaro-uribe-velez",
                      "juan-manuel-santos-calderon")

g3_trabajo_tbl <- g3_trabajo_tbl %>%
  activate(edges) %>%
  mutate(edge_especial = .N()$name[from] %in% nodos_especiales |
           .N()$name[to] %in% nodos_especiales
  )

# Layout
set.seed(1)
layout3 <- create_layout(g3_trabajo_tbl, layout = 'igraph', algorithm = "nicely")

ggraph(layout3) +
  geom_edge_link(color = "grey70",
                 alpha = 0.5,
                 width = 1,
                 end_cap = circle(0, "mm")) +
  geom_node_point(aes(size = grado,
                      color = name %in% nodos_especiales,
                      alpha = name %in% nodos_especiales )
                  ) +
  geom_node_label(aes(label = case_when(name == "alvaro-uribe-velez" ~ "AU",
                                        name == "juan-manuel-santos-calderon" ~ "JS",
                                        TRUE ~ NA_character_)),
                  color = "white",
                  linewidth = 0,
                  size = 4,
                  show.legend = FALSE) +
  scale_color_manual(values = c("TRUE" = "darkblue", 
                                "FALSE" = "royalblue"),
                     guide = "none") +
  scale_alpha_manual(values = c("TRUE" = 1,
                                "FALSE" = 0.5),
                     guide = "none") +
  scale_size(range = c(2, 10), guide = "none") +
  theme_void() +
  theme(legend.position = "right") +
  labs(
    title = "Red de trabajo de las figuras prominentes en la política colombiana",
    subtitle = "El tamano de los vertices es proporcional el grado"
  )

g3_alianzas_tbl <- as_tbl_graph(g3_alianzas_cg)
set_graph_style(plot_margin = margin(1,1,1,1))

# Layout
set.seed(1)
layout3 <- create_layout(g3_alianzas_tbl, layout = 'igraph', algorithm = "kk") # fr

ggraph(layout3) +
  geom_edge_link(color = "grey70",
                 width = 1,
                 alpha = 0.5,
                 end_cap = circle(0, "mm")) +
  geom_node_point(aes(size = grado,
                      color = name %in% c( "alvaro-uribe-velez", "juan-manuel-santos-calderon",
                                           "german-vargas-lleras"),
                      alpha = name %in% c("alvaro-uribe-velez","juan-manuel-santos-calderon",
                                          "german-vargas-lleras") )
                  ) +
  geom_node_label(aes(label = case_when(name == "alvaro-uribe-velez" ~ "AU",
                                        name == "juan-manuel-santos-calderon" ~ "JS",
                                        name == "german-vargas-lleras" ~ "GV",
                                        TRUE ~ NA_character_)),
                  color = "white",
                  linewidth = 0,
                  size = 4,
                  show.legend = FALSE) +
  scale_color_manual(values = c("TRUE" = "darkblue",
                                "FALSE" = "royalblue"),
                     guide = "none") +
  scale_alpha_manual(values = c("TRUE" = 1,
                                "FALSE" = 0.5),
                     guide = "none") +
  scale_size(range = c(2, 10), guide = "none") +
  theme_void() +
  theme(legend.position = "right") +
  labs(
    title = "Red de alianzas de las figuras prominentes en la política colombiana",
    subtitle = "El tamano de los vertices es proporcional el grado"
  )

Los nodos resaltados son unas de las figuras más importantes en las redes (se verá más adelante por qué), y los acronimos corresponden a:

  • AU: Álvaro Uribe Vélez

  • JS: Juan Manuel Santos

  • GV: Gérman Vargas Lleras

grafos3 <- list(Trabajo = g3_trabajo_cg,
                Alianzas = g3_alianzas_cg)

Caracterización de los grados: Se identifican los individuos más importantes en términos de su número de conexiones, así como la distribución del grado

Empezamos obteniendo el top 5 de los personajes políticos con más conexiones para la red de trabajo

# Grado - Trabajo
d_trabajo <- degree(g3_trabajo_cg)
head(sort(d_trabajo, decreasing = T), n = 3)
## juan-manuel-santos-calderon          alvaro-uribe-velez 
##                         176                          88 
##      andres-pastrana-arango 
##                          48

Se observa que el ex presidente Juan Manuel Santos es la persona con más conexiones en la red, con un total de 176 políticos con los que ha trabajado. Particularmente, él ha tenido el doble de relaciones laborales que el segundo personaje de este top: el ex presidente Álvaro Uribe.

# Grado - Alianzas
d_alianzas <- degree(g3_alianzas_cg)
head(sort(d_alianzas, decreasing = T), n = 3)
##          alvaro-uribe-velez        german-vargas-lleras 
##                          45                          41 
## juan-manuel-santos-calderon 
##                          29

En cuanto a alianzas políticas, ahora es el ex presidente Álvaro Uribe el que encabeza la lista con 45 alianzas, seguido del ex vice presidente German Vargas Llleras (41 alianzas) y el ex presidente Juan Manuel Santos (29 alianzas). Ambas redes identifican a los dos ex presidentes como los más activos de acuerdo a las relaciones estudiadas.

par(mfrow=c(1, 2))
plot(x = NA, 
     y = NA, 
     type = "n", 
     xlim = c(0,100), 
     ylim = c(0,0.3), 
     xlab = "Grado", 
     ylab = "Densidad", 
     main = "Distribucion del grado\n para la red de trabajo")
hist(d_trabajo, freq = F, col = "lightskyblue", border = "royalblue", add = T, breaks = seq(0, 200, 2))

plot(x = NA, 
     y = NA, 
     type = "n", 
     xlim = c(0,50), 
     ylim = c(0,0.3), 
     xlab = "Grado", 
     ylab = "Densidad", 
     main = "Distribucion del grado\n para la red de alianzas")
hist(d_alianzas, freq = F, col = "lightskyblue", border = "royalblue", add = T, breaks = seq(0, 50, 2))

Se observa que las distribuciones de los grados tienen un marcado comportamiento asimétrico con cola a derecha, en las que priman los individuos poco conectados, con individuos pariculares con muchas relaciones. Como se vio en el análisis anterior, la red de trabajo tiene una cola más larga que llega hasta un grado de 176, mientras que la de alianzas toma su valor máximo en 45.

Caracterización en términos de distancia: Se calculan el diámetro de la red y la distancia geodésica promedio, para ambas redes. Adicionalmente se presenta las distribuciones de distancias geodésicas de estas.

library(tibble)
library(kableExtra)
distancia_3 <- data.frame(
  Relación = names(grafos3),
  Diametro = sapply(grafos3, diameter),
  Distancia_promedio = sapply(grafos3, function(g){mean_distance(g, directed = FALSE)})
)
rownames(distancia_3) <- NULL
distancia_3 <- distancia_3 %>%
  column_to_rownames("Relación") %>%
  t() %>%
  as.data.frame()

distancia_3["Diametro",] <- sprintf("%.0f", as.numeric(distancia_3["Diametro",]))
distancia_3["Distancia_promedio",] <- sprintf("%.3f",as.numeric(distancia_3["Distancia_promedio",]))

kable(distancia_3, align = "c",
  caption = "Medidas de distancia geodésica por tipo de relación") %>%
  kable_styling(bootstrap_options = c("bordered", "striped", "hover"), full_width = FALSE)
Medidas de distancia geodésica por tipo de relación
Trabajo Alianzas
Diametro 8 10
Distancia_promedio 3.308 4.109 
# Distribuciones de las distancias geodésicas

distancias_df <- lapply(names(grafos3), function(nombre){
  g <- grafos3[[nombre]]
  caminos <- distance_table(g)$res # distancias geodesicas

  data.frame(Relacion = nombre, Distancia = seq_along(caminos), Frecuencia = prop.table(caminos) )
}) %>%
  bind_rows()

ggplot(distancias_df, aes(x = Distancia, y = Frecuencia)) +
  geom_col(fill = "grey60") +
  facet_wrap(~ Relacion) +
  coord_cartesian(ylim = c(0, 0.4)) +
  theme_minimal(base_size = 13) +
  labs(
    title = "Distribución de distancias geodésicas",
    x = "Distancia geodésica",
    y = "Frecuencia relativa"
  )

Los diametros toman valores de 14 y 18, los cuales representando el valor máximo de las distancias geodésicas nos dicen que el actor político más alejado necesita 14 o 18 aristas para conectarse po el camino más corto. La distancia geodésica promedio toma un valor más alto para la red de alianzas, lo que indica que dos personas se conectan mediante 7 o 8 actores intermedios, en promedio. De forma complementaria, la distribución de las distancias geodésicas tiene una cola un poco más pronunciada para la red de alianzas, aunque ambas se compirtan de forma bastante similar.

Caracterización en términos de centralidad: Se calcula el top 3 de figuras prominentes en la política colombiana más centrales según los criterios vistos en clase, para cada una de las redes.

# Tabla vacía
centralidades <- data.frame(Relacion = names(grafos3), 
                              Closeness = NA, Betweenness = NA, Eigenvector = NA)
# Llenar tabla
for(i in seq_along(grafos3)){
  g <- grafos3[[i]]
  centralidades$Closeness[i] <- obtener_top(g, "Closeness")
  centralidades$Betweenness[i] <- obtener_top(g, "Betweenness")
  centralidades$Eigenvector[i] <- obtener_top(g, "Eigenvector")
}

kable(centralidades, align = "c", escape = FALSE, format = "html",
  caption = "Top figuras políticas según medidas de centralidad") %>%
  kable_styling(bootstrap_options = c("bordered", "striped", "hover"), full_width = TRUE) %>%
  column_spec(2, width = "25em") %>%
  column_spec(3, width = "25em") %>%
  column_spec(4, width = "25em")
Top figuras políticas según medidas de centralidad
Relacion Closeness Betweenness Eigenvector
Trabajo juan-manuel-santos-calderon
alvaro-uribe-velez
carlos-holmes-trujillo-qepd 		juan-manuel-santos-calderon
alvaro-uribe-velez
andres-pastrana-arango 		juan-manuel-santos-calderon
alvaro-uribe-velez
juan-camilo-restrepo-salazar
Alianzas enrique-penalosa-londono
alvaro-uribe-velez
german-vargas-lleras 		alvaro-uribe-velez
german-vargas-lleras
juan-manuel-santos-calderon 		alvaro-uribe-velez
sergio-fajardo
antanas-mockus

En cuanto a las relaciones de trabajo, vemos que Juan Manuel Santos se posiciona como el actor más importante en la red bajo todos los criterios de centralidad. Esto quiere decir que es la persona más cercana, la que está en medio de más relaciones y la que a su vez se rodea de más personajes centrales.

Es más, bajo los criterios de centralidad por cercanía y centralidad por intermediación, el top de actores más centrales es el mismo: Juan Manuel Santos, Álvaro Uribe y Carlos Holmes Trujillo. Este top csi presenta un cambio bajo el criterio de centralidad, propia: Juan Manuel Santos a la cabeza, seguido de el ex ministro Juan Camilo Restrepo y Álvaro Uribe. El ex ministro solo aparece en este top ya que se rodea de otros individuos importantes, pero no es central propiamente.

La red de alianzas políticas se comporta diferente. Enrique Peñalosa ex alcalode de Bogotá, Armando Antonio Zabarin miembro de la cámara de representantes y Álvaro Uribe son las figuras más importantes en el sistema en cuanto a su cercanía con los demás miembros. Álvaro Uribe, German Vargas y Juan Manuel Santos son los más importantes en cuanto a que se ubican en medio de otras relaciones entre políticos. Lo cual se interpreta como que estos están tomando un cierto rol de intermediarios en las alianzas políticas de los demás, lo cual tiene mucho sentido teniendo en cuenta la influencia y contactos con los que ellos contaban.

Finalmente, Álvaro Uribe, Sergio Fajado ex gobernador de Antioquia y Claudia López ex alcaldesa de Bogotá resultan ser los personajes que se rodean de otros políticos centrales.

Como comentario final, se observa que tipicamente las figuras políticas más importantes de los dos sistemas son aquellos que han ejercido cargos nacionales importantes (presidente, vice presidente) o cargos regionales en alguna de las ciudades/departamentos más importantes (alcalde bogotá, gobernador).

Caracterización en términos de cohesión: En este apartado, se encuentran los ‘cliques’ más grandes de las redes junto con su frecuencia, además se llevan a cabo los censos diádicos y triádicos. Del mismo modo, se calculan la densidad y transitividad.

tam_max_clique <- data.frame(Relacion = names(grafos3),
                             Clique_maximo = sapply(grafos3, clique_num))
rownames(tam_max_clique) <- NULL

tabla_clique <- tam_max_clique %>%
  tibble::column_to_rownames("Relacion") %>%
  t() %>%
  as.data.frame()

rownames(tabla_clique) <- "Tamaño clan máximo"

kable(tabla_clique, align = "c", caption = "Tamaño del clan máximo por relación") %>%
  kable_styling(bootstrap_options = c("bordered", "striped", "hover"), full_width = FALSE)
Tamaño del clan máximo por relación
Trabajo Alianzas
Tamaño clan máximo 6 5

El número clan o tamaño del clan maximal más grande nos dice que el subgrupo interconectado más grande para las redes de trabajo y alianzas se componenen de 6 y 5 actores, respectivamente. Hay un grupo de 6 personajes que mantienen reaciones de trabajo directas entre sí de maner totalmente reíproca; lo mismo aplica para el grupo de 5 personajes en la red de alianzas políticas.

censos_diadas <- lapply(grafos3, dyad_census)
censos_diadas_df <- do.call(rbind, censos_diadas)

kable(censos_diadas_df, digits = 0, align = "c", caption = "Censo de díadas por relación") %>%
  kable_styling( bootstrap_options = c("bordered", "striped", "hover"), full_width = FALSE)
Censo de díadas por relación
mut asym null
Trabajo 1379 0 115991
Alianzas 678 0 55267

Del censo de diadas se observa que la cantidad de parejas formadas en la red de trabajo dobla a esta cantidad en la red de alianzas.

triad_labels <- c(
  "003","012","102","021D","021U","021C",
  "111D","111U","030T","030C","201",
  "120D","120U","120C","210","300")

censos_triadas <- lapply(grafos3, function(g){
  x <- triad_census(g)
  names(x) <- triad_labels
  x
})
censos_triadas_df <- do.call(rbind, censos_triadas)

kable( censos_triadas_df, digits = 0, align = "c", caption = "Censo de triadas por relación") %>%
  kable_styling( bootstrap_options = c("bordered", "striped", "hover"), full_width = TRUE)
Censo de triadas por relación
003 012 102 021D 021U 021C 111D 111U 030T 030C 201 120D 120U 120C 210 300
Trabajo 18262751 0 602679 0 0 0 0 0 0 0 30042 0 0 0 0 1098
Alianzas 5989957 0 214387 0 0 0 0 0 0 0 5266 0 0 0 0 285 
analisis_triadas <- function(g, B = 1000, triadas_interes){
  triad_labels <- c(
    "003","012","102","021D","021U","021C",
    "111D","111U","030T","030C","201",
    "120D","120U","120C","210","300"
  )
  # índices de las triadas que se quieren
  idx <- match(triadas_interes, triad_labels)

  # censo observado
  censo_obs <- triad_census(g)[idx]
  deg <- degree(g)

  # matriz reducida
  null_counts <- matrix(
    NA_real_,
    nrow = B,
    ncol = length(idx),
    dimnames = list(NULL, triadas_interes)
  )

  set.seed(123)

  for(b in seq_len(B)){

    g_null <- sample_degseq(
      out.deg = deg,
      method = "edge.switching.simple"
    )

    null_counts[b, ] <- triad_census(g_null)[idx]
  }

  mu_null <- colMeans(null_counts)
  sd_null <- apply(null_counts, 2, sd)

  z_scores <- ifelse(
    sd_null > 0,
    (censo_obs - mu_null)/sd_null,
    NA_real_
  )

  data.frame(
    Triada = triadas_interes,
    Observado = censo_obs,
    Media_nula = mu_null,
    SD_nula = sd_null,
    Z = z_scores
  )
}
resultados_triadas <- lapply(grafos3, analisis_triadas, B = 100,
  triadas_interes = c("003", "102", "201", "300")
)
resultados_triadas$Trabajo  
##     Triada Observado  Media_nula  SD_nula         Z
## 003    003  18262751 18263193.71 32.40535 -13.66163
## 102    102    602679   601350.87 97.21606  13.66163
## 201    201     30042    31370.13 97.21606 -13.66163
## 300    300      1098      655.29 32.40535  13.66163
resultados_triadas$Alianzas 
##     Triada Observado Media_nula  SD_nula        Z
## 003    003   5989957 5990146.17 11.56628 -16.3553
## 102    102    214387  213819.49 34.69885  16.3553
## 201    201      5266    5833.51 34.69885 -16.3553
## 300    300       285      95.83 11.56628  16.3553

El censo de triadas nos muestra que las triadas nulas y las de tipo 201 aparecieron menos de lo esperado en un modelo nulo; mientras que las triadas tipo 102 y las completas se observaron más de lo esperado, afirmando que hay un número significativo de estas dos últimas coniguraciones.

cohesion <- data.frame(Relacion = names(grafos3),
                        Densidad = round(sapply(grafos3, edge_density), 3),
                        Transitividad = round(sapply(grafos3, transitivity), 3) )
rownames(cohesion) <- NULL

cohesion <- cohesion %>%
  tibble::column_to_rownames("Relacion") %>%
  t() %>%
  as.data.frame()

kable(cohesion, align = "c") %>%
  kable_styling(bootstrap_options = c("bordered", "striped", "hover"), full_width = FALSE)
Trabajo Alianzas
Densidad 0.012 0.012
Transitividad 0.099 0.140 
# Transitividades locales
trans_df <- lapply(names(grafos3), function(nombre){
  g <- grafos3[[nombre]]
  data.frame(Relacion = nombre,
             Transitividad = transitivity( g, type = "local", isolates = "zero") ) }) %>%
  bind_rows()

# Gráfico
ggplot(trans_df, aes(x = Transitividad)) +
  geom_histogram(bins = 15, 
                 fill = "grey60",
                 color = "white") +
  facet_wrap(~ Relacion) +
  theme_minimal(base_size = 13) +
  labs(title = "Distribución de la transitividad local",
       x = "Transitividad local",y = "Frecuencia")

La densidad total de las redes de trabajo y alianzas políticas es casi la misma, tomando un valor aproximado de 0.012, el cual nos deja ver que ambas redes sion desconectadas, comportamiento esperado en redes poíticas en las que debido a diferencias ideológicas, es casi imposible que todos los actores se relacionen entre sí. Ambas redes están lejos de convertirse en un clan.

En cuanto a la transitividad global, la red de alianzas es más transitiva que la red de trabajo, aunque ambos valores son pequeños. Podemos afirmar entonces que los políticos son más propensos a tener unas cuantas relaciones transitivas cuando se trata de aliarse con otros. Igualmente, la transitividad local alcanza su pico de frecuencia en 0 oor mucha diferencia en comparación con las demás transitividades.

Caracterización en términos de conectividad: Se estudia la conectividad por vértices y aristas, la componente gigante y sus características de conectividad.

# Análisis de la componente gigante
sapply(grafos3, is_connected)
##  Trabajo Alianzas 
##     TRUE     TRUE
sapply(grafos3, vertex_connectivity)
##  Trabajo Alianzas 
##        1        1
sapply(grafos3, edge_connectivity)
##  Trabajo Alianzas 
##        1        1

Como se mencionó al inicio del análisis, se está trabajando con las componentes gigantes de ambas redes, por eso vemos evidentemente que estas están conectadas. Ambas componentes son altamente sensibles a remover nodos de ellas puesto que ambas presentan una conectividad nodal y de aristas igual a 1.

grafos3_sinconectar <- list(g3_trabajo, g3_alianzas)
names(grafos3_sinconectar) <- c("Trabajo", "Alianzas")
componentes <- lapply(grafos3_sinconectar, decompose)
sapply(componentes, length)
##  Trabajo Alianzas 
##       14       11
tam_componentes <- lapply(componentes, function(comp){table(sapply(comp, vcount)) })
tam_componentes # 13 de tamaño 2 y 1 de tamaño 485
## $Trabajo
## 
##   2 485 
##  13   1 
## 
## $Alianzas
## 
##   2   3 335 
##   9   1   1
grafos_conectados <- lapply(grafos3, function(g){
  comps <- decompose(g)
  comps[[which.max(sapply(comps, vcount))]]
})

conectividad_df <- data.frame(
  Relacion = names(grafos_conectados),
  Conectividad_nodal = sapply(grafos_conectados, vertex_connectivity),
  Conectividad_aristas = sapply(grafos_conectados, edge_connectivity),
  Puntos_articulacion = sapply(grafos_conectados,
           function(g) length(articulation_points(g))),
  Proporcion_articulacion = sapply(grafos_conectados, function(g){length(articulation_points(g)) / vcount(g)})
) 

kable(
  conectividad_df,
  digits = 3,
  align = "c",
  caption = "Medidas de conectividad sobre la componente gigante, por carrera"
) %>%
  kable_styling(
    bootstrap_options = c("bordered", "striped", "hover"),
    full_width = FALSE
  )
Medidas de conectividad sobre la componente gigante, por carrera
Relacion Conectividad_nodal Conectividad_aristas Puntos_articulacion Proporcion_articulacion
Trabajo Trabajo 1 1 60 0.124
Alianzas Alianzas 1 1 68 0.203

Con el fin de analizar el comportamiento de las componentes de los grafos originales se obtienen los tamaños de estas. Vemos que la red de trabajo cuenta con 13 componentes de tamaño 2 y 1 de tamaño 485. En contraste, la red de alianzas se constituye de 9 componentes de tamaño 2, 1 de tamaño 3 y 1 de 335 nodos.

En lo que concierne a las medidas de las componentes gigantes observamos que el 12.4% y el 20.3% de los actores de cada una de las redes sin puntos de articulación.

Caracterización en términos del agrupamiento: Se finaliza la caracterización de las redes con la detección de comunidades en estas.

library(kableExtra)
set.seed(9)
obtener_comunidades <- function(g){
  list(FastGreedy   = cluster_fast_greedy(g),
       LeadingEigen = cluster_leading_eigen(g),
       Walktrap     = cluster_walktrap(g),
       Louvain      = cluster_louvain(g),
       LabelProp    = cluster_label_prop(g),
      # Optimal      = cluster_optimal(g), 
       Infomap      = cluster_infomap(g)
  )
}
# aplicar a todas las carreras
comunidades <- lapply(grafos3, obtener_comunidades)

modularidades <- lapply(names(comunidades), function(nombre){
  algs <- comunidades[[nombre]]
  data.frame(Relacion = nombre, Algoritmo = names(algs), Modularidad = sapply(algs, modularity),
             Clusters = sapply(algs, length)) }) %>%
  bind_rows()

tabla_modularidad <- modularidades %>%
  mutate(Resultado = paste0(round(Modularidad, 3), " (k=",Clusters, ")")
           ) %>% 
  select(Relacion, Algoritmo, Resultado) %>% 
  pivot_wider(
    names_from = Algoritmo,
    values_from = Resultado
  )
rownames(tabla_modularidad) <- NULL

tabla_clusters <- modularidades %>%
  select(Relacion, Algoritmo, Clusters) %>% 
  pivot_wider(
    names_from = Algoritmo,
    values_from = Clusters
  )
rownames(tabla_clusters) <- NULL

kable(tabla_modularidad, digits = 3, align = "c", caption = "Modularidad por algoritmo y relación") %>%
  kable_styling(bootstrap_options = c("bordered", "striped", "hover"), full_width = FALSE
  )
Modularidad por algoritmo y relación
Relacion FastGreedy LeadingEigen Walktrap Louvain LabelProp Infomap
Trabajo 0.489 (k=15) 0.406 (k=42) 0.391 (k=98) 0.51 (k=14) 0.147 (k=10) 0.476 (k=52)
Alianzas 0.643 (k=12) 0.61 (k=11) 0.61 (k=38) 0.641 (k=13) 0.609 (k=18) 0.601 (k=44) 
mejor_algoritmo <- modularidades %>%
  group_by(Relacion) %>%
  slice_max(Modularidad, n = 1)
mejor_algoritmo
## # A tibble: 2 × 4
## # Groups:   Relacion [2]
##   Relacion Algoritmo  Modularidad Clusters
##   <chr>    <chr>            <dbl>    <int>
## 1 Alianzas FastGreedy       0.643       12
## 2 Trabajo  Louvain          0.510       14

Se corrieron seis algoritmos de agrupoamiento para cada una de las redes, seleccionando el que maximiza la modularidad en cada caso. Se observa que para ambas redes, el mejor algoritmo resulta ser cluster_louvain, con modularidades de 0.64 para la red de trabajo y 0.51 para la red de alianzas.

graficar_comunidades <- function(g, clustering, nombre){
  g_tbl <- as_tbl_graph(g) %>%
    mutate(comunidad = factor(clustering$membership),
           grado = degree(g))

  set.seed(1)

  layout <- create_layout( g_tbl, layout = "igraph", algorithm = "fr")

  ggraph(layout) +
    geom_edge_link(alpha = 0.25, 
                   colour = "gray70"
                    ) +
    geom_node_point(aes( color = comunidad, size = grado)
                    ) +
    scale_size(range = c(1, 5),guide = "none") +
    guides(color = guide_legend(ncol = 2)
           ) +
    theme_void() +
    labs(title = paste("Agrupamiento -", nombre),
      subtitle = paste("Algoritmo: Louvain", "| Modularidad =", round(modularity(clustering), 3) ),
      color = "Comunidad"
      )
}

plots_comunidades <- list()

for(nombre in names(grafos3)){

  g <- grafos3[[nombre]]
  # algoritmo óptimo según modularidad
  mods <- sapply(comunidades[[nombre]], modularity)
  mejor_nombre <- names(which.max(mods))
  clustering <- comunidades[[nombre]][[mejor_nombre]]
  plots_comunidades[[nombre]] <-
    graficar_comunidades(g, clustering, nombre)
}

wrap_plots(plots_comunidades, ncol = 1)

La gráfica nos deja ver que para ambos redes se generaron más de 10 clusters, 14 y 12 especificamente.

Punto 4

  1. Considere el conjunto de datos disponible en el archivo traders.RData (139 KB), accesible en la página web del curso. Este archivo contiene un arreglo de dimensión \(T\times I \times I\), donde se registran datos relacionales de \(I\) comerciantes (traders) a lo largo de \(T\) semanas. Este conjunto consta de \(T=201\) redes binarias dirigidas de tamaño \(I=71\), representando las transacciones en el mercado de futuros de gas natural en la Bolsa Mercantil de Nueva York (NYMEX) durante el período de enero de 2005 a diciembre de 2008. Cada red semanal establece un vínculo dirigido entre un comerciante \(A\) y un comerciante \(B\) si hubo al menos una transacción en la que \(A\) actuó como vendedor y \(B\) como comprador (Betancourt et al., 2020). Hasta el 5 de septiembre de 2006 (semana 83), los futuros de gas natural se negociaron exclusivamente mediante operaciones tradicionales a gritos. A partir de esa fecha, se introdujo una plataforma de negociación electrónica como método alternativo. Este caso de estudio tiene como objetivo investigar si la implementación de esta plataforma provocó un cambio estructural significativo en el mercado de futuros de gas natural (Betancourt, B., Rodríguez, A., & Boyd, N. (2020). Modelling and prediction of financial trading networks: An application to the New York Mercantile Exchange natural gas futures market. Journal of the Royal Statistical Society Series C: Applied Statistics, 69(1)).

  1. Para cada red en cada semana, calcular métricas clave como la densidad, el coeficiente de agrupamiento, la asortatividad, la reciprocidad, la distancia geodésica promedio, el tamaño de la componente gigante, el grado de salida promedio y el grado de entrada promedio. Representar las series de tiempo generadas para cada métrica, incorporando una línea vertical en la semana 83, una línea horizontal en la mediana de los valores de la serie antes de la semana 83 (inclusive) y otra línea horizontal en la mediana de los valores posteriores a esta semana. Además, aplicar la prueba de Mann-Whitney para comparar los valores de cada serie antes y después de la semana 83. Presentar los resultados de estas comparaciones en una tabla, indicando las diferencias estadísticas identificadas.

  2. Para cada red en cada semana, realizar una segmentación de comerciantes utilizando un método de agrupamiento jerárquico. Determinar, para cada caso, el número de grupos formados y calcular la modularidad de las particiones obtenidas. Repetir el análisis anterior considerando estos dos nuevos estadísticos estructurales de agrupamiento como parte del conjunto de métricas a evaluar. Antes de realizar el proceso de agrupamiento, simetrizar las redes débilmente, de manera que \(i \leftrightarrow j\) si \(i\leftarrow j\) o \(i\rightarrow j\).

  3. Sea \(\mathbf{Y}_t=[y_{i,j,t}]\) la matriz de adyacencia de dimensión \(I\times I\) asociada con la red de transacciones en el instante \(t\), para \(t=1,…,T\). Además, sean \(\mathbf{Y}_0=[y^0_{i,j}]\) y \(\mathbf{Y}_1=[y^1_{i,j}]\) las matrices de adyacencia que representan las transacciones de consenso antes (incluyendo) y después de la semana 83, respectivamente, donde: \[y_{i, j}^k= \begin{cases}1, & \text { si } \frac{1}{T_k} \sum_{t=1}^{T_k} y_{i, j, t} \geq 0.5, \\ 0, & \text { en otro caso, }\end{cases}\] y \(T_k\) es el número de instantes de tiempo en el período \(k\), con \(k=0,1\). Calcular las medidas estructurales descritas en el numeral a. para las redes asociadas con \(\mathbf{Y}_0\) y \(\mathbf{Y}_1\), y presentar los resultados en una tabla comparativa.

  4. Para las redes asociadas con \(\mathbf{Y}_0=[y^0_{i,j}]\) y \(\mathbf{Y}_1=[y^1_{i,j}]\) , realizar una segmentación de comerciantes utilizando un método de agrupamiento jerárquico. Previo al proceso de agrupamiento, simetrizar las redes débilmente, estableciendo \(i \leftrightarrow j\) si \(i\leftarrow j\) o \(i\rightarrow j\). Visualizar la componente gigante de ambas redes empleando un diseño (layout) adecuado, donde el tamaño de los vértices sea proporcional a su fuerza (vertex strength) y los colores indiquen las comunidades detectadas.

  5. Interpretar los resultados obtenidos.

Solución Punto 4

# Cargar los datos
load("Datos/traders.RData")
dim(Y71)
## [1] 201  71  71

La base se compone de datos relacionales de 71 comerciantes a lo largo de \(T=201\) semanas que corresponden a transacciones en el mercado de gas natural.

Análisis de métricas

Se calculan las métricas deseadas para cada red a partir de la función

library(purrr)
calcular_metricas <- function(A){
  
  # Crear grafo
  g <- graph_from_adjacency_matrix(A, mode = "directed", diag = FALSE)
  g_und <- as.undirected(g, mode = "collapse")
  
  # Métricas
  densidad <- edge_density(g)
  transitividad <- transitivity(g_und, type = "global")
  asortatividad <- assortativity_degree(g, directed = TRUE)
  reciprocidad <- reciprocity(g)
  dist_geo <- mean_distance(g, directed = TRUE, unconnected = TRUE)
  # Grados
  out_deg <- mean(degree(g, mode = "out"))
  in_deg <- mean(degree(g, mode = "in"))
  # Tamaño componente gigante
  comp <- components(g_und)
  giant <- max(comp$csize)
  
  tibble(
    Densidad = densidad,
    Transitividad = transitividad,
    Asortatividad = asortatividad,
    Reciprocidad = reciprocidad,
    Distancia_geodesica = dist_geo,
    Grado_salida = out_deg,
    Grado_entrada = in_deg,
    Componente_gigante = giant
  )
}

# Calcular las métricas para cada semana
tiempo <- dim(Y71)[1]

metricas_p4 <- map_dfr(1:tiempo, function(t){
  A <- Y71[t,,]
  calcular_metricas(A) %>%
    mutate(semana = t)
})

head(metricas_p4)
## # A tibble: 6 × 9
##   Densidad Transitividad Asortatividad Reciprocidad Distancia_geodesica
##      <dbl>         <dbl>         <dbl>        <dbl>               <dbl>
## 1    0.115         0.476        0.0557        0.540                2.62
## 2    0.130         0.507        0.147         0.512                2.86
## 3    0.127         0.540        0.106         0.516                2.62
## 4    0.123         0.513        0.0677        0.529                2.63
## 5    0.129         0.531        0.0526        0.555                2.53
## 6    0.121         0.521        0.0581        0.547                2.68
## # ℹ 4 more variables: Grado_salida <dbl>, Grado_entrada <dbl>,
## #   Componente_gigante <dbl>, semana <int>
dim(metricas_p4)
## [1] 201   9

Ahora, se visualizan las series de tiempo para cada una de las métricas calculadas

plot_serie <- function(data, variable){
  
  y <- data[[variable]]
  
  med_pre <- median(y[1:83], na.rm = TRUE)
  med_post <- median(y[84:nrow(data)], na.rm = TRUE)
  
  ggplot(data, aes(x = semana, y = .data[[variable]])) +
    geom_line(color = "steelblue", linewidth = 0.8) +
    geom_vline(xintercept = 83,
               linetype = "dashed",
               color = "red",
               linewidth = 1) +
    geom_hline(aes(yintercept = med_pre,
                   color = "Mediana pre semana 83"),
               linetype = "dotted",
               linewidth = 1) +
    geom_hline(aes(yintercept = med_post,
                   color = "Mediana post semana 83"),
               linetype = "dotted",
               linewidth = 1) +
    scale_color_manual(name = "", values = c("Mediana pre semana 83" = "darkgreen",
                                             "Mediana post semana 83" = "purple") ) +
    labs(
      title = paste("Serie de tiempo:", variable),
      x = "Semana",
      y = variable
    ) +
    theme_minimal()
}
variables <- names(metricas_p4)[1:8]

plots <- map(variables, ~plot_serie(metricas_p4, .x))
wrap_plots(plots, ncol = 2) +
  plot_layout(guides = "collect") &
  theme(
    legend.position = "bottom"
  )

Visualmente si se evidencia un cambio de comportamiento marcado a partir de la semana 83 en todas las series correspondientes a las métricas. Las rectas horizontales de las medianas, morada para antes del punto de cambio y verde para después de este, así mismo toman valores bien diferentes.

Por ejemplo, la asortatividad, la distancia geodésica promedio y la transitividad tomaban valores más altos antes del cambio en la forma de negociar.

La prueba U de Mann-Whitney es una técnica estadística no paramétrica utilizada para comparar dos grupos independientes y determinar si sus medianas difieren significativamente. Actúa como la alternativa no paramétrica a la prueba t de Student cuando los datos no siguen una distribución normal o son de tipo ordinal.

La hipótesis para la prueba U de Mann-Whitney es

\[\begin{align*} H_0:& \text{ Las distribuciones de los dos grupos son idénticas}\\ H_1:& \text{ Las distribuciones de los dos grupos difieren} \end{align*}\]

El estadístico de prueba se calcula como \[U= n_1n_2+\frac{n_1(n_1+1)}{2}-R_1\] donde \(n_1\), \(n_2\) son los tamaños de los dos grupos y \(R_1\)es la suma de los rangos del primer grupo.

resultados_mw <- map_dfr(variables, function(v){
  
  pre <- metricas_p4[[v]][1:83]
  post <- metricas_p4[[v]][84:tiempo]
  
  test <- wilcox.test(pre, post)
  
  tibble(
    Variable = v,
    "Mediana Pre" = round(median(pre, na.rm = TRUE), 3),
    "Mediana Post" = round(median(post, na.rm = TRUE), 3),
    Estadistico_W = test$statistic,
    Valor_P = test$p.value,
    Diferentes = ifelse(test$p.value < 0.05, "Sí", "No")
  )
})

kable(resultados_mw, align = "c") %>%
  kable_styling(
    bootstrap_options = c("bordered")
  )
Variable Mediana Pre Mediana Post Estadistico_W Valor_P Diferentes
Densidad 0.125 0.197 189.0 0 Sí
Transitividad 0.524 0.465 9182.0 0 Sí
Asortatividad 0.064 -0.298 9794.0 0 Sí
Reciprocidad 0.528 0.594 779.5 0 Sí
Distancia_geodesica 2.462 1.861 9684.0 0 Sí
Grado_salida 8.775 13.824 189.0 0 Sí
Grado_entrada 8.775 13.824 189.0 0 Sí
Componente_gigante 65.000 69.000 1416.5 0 Sí

Se observa que para cada métrica se rechaza la hipótesis nula de que ambos conjuntos de datos tengan la misma distribución con una significancia del \(5%\) ya que los p-valores toman el vaor de cero. El resultado de esta prueba estadística soporta la diferencia que se notaba en los datos en sus visualizaiones.

Agrupamiento

Se utiliza el algoritmo cluster_louvain como método de agrupamiento jerárquico.

agrupamiento_red <- function(A){
  
  # Simetrización débil de la matriz
  A_sym <- (A + t(A)) > 0
  A_sym <- 1 * A_sym # convertir a matriz a 0 y 1
  diag(A_sym) <- 0
  
  g <- graph_from_adjacency_matrix(A_sym, mode = "undirected", diag = FALSE)
  clu <- cluster_louvain(g)
  
  num_grupos <- length(clu)
  mod <- modularity(clu)
  
  tibble(
    Numero_grupos = num_grupos,
    Modularidad = mod
  )
}
# Aplicar el agrupamiento a cada semana
cluster_stats <- map_dfr(1:tiempo, function(t){
  set.seed(9)
  A <- Y71[t,,]
  agrupamiento_red(A) %>% 
    mutate(semana = t)
})

head(cluster_stats)
## # A tibble: 6 × 3
##   Numero_grupos Modularidad semana
##           <int>       <dbl>  <int>
## 1             6       0.219      1
## 2             6       0.216      2
## 3             8       0.171      3
## 4             8       0.181      4
## 5             8       0.177      5
## 6             9       0.182      6
metricas_p4_2 <- metricas_p4 %>%
  left_join(cluster_stats, by = "semana") 
wrap_plots(c(plot_serie(metricas_p4_2, "Numero_grupos"), plot_serie(metricas_p4_2, "Modularidad")), ncol = 2) +
  plot_layout(guides = "collect") &
  theme(
    legend.position = "bottom"
  )

El número de grupos en los que el algoritmo clasifica a los nodos toma valores más altos y variables cuando aún se negociaba a gritos. En contraste, la modularidad toma valores más pequeños en el segundo periodo de interés, indicando que la estructura de comunidades es menos fuerte después del cambio.

Al igual que con las otras métricas, se observa una diferencia en sus comportamientos antes y despues de la semana 83.

variables2 <- c(variables, "Numero_grupos", "Modularidad")

resultados_mw2 <- map_dfr(variables2, function(v){
  
  pre <- metricas_p4_2[[v]][1:83]
  post <- metricas_p4_2[[v]][84:tiempo]
  
  test <- wilcox.test(pre, post)
  
  tibble(
    variable = v,
    mediana_pre = median(pre, na.rm = TRUE),
    mediana_post = median(post, na.rm = TRUE),
    estadistico_W = test$statistic,
    p_value = test$p.value,
    diferencia_significativa = ifelse(test$p.value < 0.05, "Sí", "No")
  )
})

kable(resultados_mw2, align = "c") %>%
  kable_styling(bootstrap_options = c("bordered") )
variable mediana_pre mediana_post estadistico_W p_value diferencia_significativa
Densidad 0.1253521 0.1974849 189.0 0 Sí
Transitividad 0.5237932 0.4647173 9182.0 0 Sí
Asortatividad 0.0640699 -0.2983378 9794.0 0 Sí
Reciprocidad 0.5283630 0.5935501 779.5 0 Sí
Distancia_geodesica 2.4617549 1.8609122 9684.0 0 Sí
Grado_salida 8.7746479 13.8239437 189.0 0 Sí
Grado_entrada 8.7746479 13.8239437 189.0 0 Sí
Componente_gigante 65.0000000 69.0000000 1416.5 0 Sí
Numero_grupos 10.0000000 6.0000000 8281.5 0 Sí
Modularidad 0.1770057 0.1207252 8780.0 0 Sí

De la misma forma, se rechaza la hipótesis nula de que el número de grupos y las modularidades para cada periodo provengan de la misma distribución a un nivel de significancia del \(5%\).

Con los análisis efectuados podemos afiarmar quela implementación de la plataforma de negociación electrónica si provocó un cambio estructural significativo en el mercado de futuros de gas natural.

Red de consenso

Se obtienen las redes de consenso para los dos periodos comparados. Rercordemos que estas son redes no dirigidas binarias.

# Consenso hasta la semana 83
Y0 <- ifelse(apply(Y71[1:83, , ], c(2,3), mean) >= 0.5, 
             1, 0)
diag(Y0) <- 0

# Consenso después de la semana 83
Y1 <- ifelse(apply(Y71[84:201, , ], c(2,3), mean) >= 0.5,
             1, 0)
diag(Y1) <- 0

dim(Y0)
## [1] 71 71
dim(Y1)
## [1] 71 71
metricas_Y0 <- calcular_metricas(Y0)
metricas_Y1 <- calcular_metricas(Y1)

tabla_consenso <- rbind(
  metricas_Y0,
  metricas_Y1
) %>%
  as.data.frame()

tabla_consenso$Red <- c("Y0", "Y1")

tabla_consenso <- tabla_consenso %>%
  select(Red, everything())

kable(
  tabla_consenso,
  digits = 3,
  align = "c",
  caption = "Medidas estructurales de las redes de consenso"
) %>%
  kable_styling(
    bootstrap_options = c("bordered", "striped", "hover"),
    full_width = FALSE
  )
Medidas estructurales de las redes de consenso
Red Densidad Transitividad Asortatividad Reciprocidad Distancia_geodesica Grado_salida Grado_entrada Componente_gigante
Y0 0.073 0.461 -0.154 0.878 2.090 5.099 5.099 44
Y1 0.122 0.265 -0.620 0.934 1.949 8.563 8.563 67

Las métricas de la red de consenso nos dan una visión del comportamiento típico/dominante de los periodos estudiados.

Observamos que la red de consenso asociada con la implementación de la plataforma electrónica es más densa que la del periodo previo. No obstante, en cuanto a la transitividad el comportamiento es opuesto, las transacciones en el mercado de gas natural son menos transitivas una vez establecido el cambio.

Tanto las relaciones predominantes antes de la semana 83 como las de después de esta presentan una asortatividad negativa, dejando ver que los comerciantes tienden a hacer transacciones con otros que tengan grados diferentes; aunque si es evidente que este comportamiento se potencia en el segundo periodo.

En cuanto a la caracterización de la distancia, la distancia geodésica promedio es levemente menor para la red de consenso construida a partir de \(\mathbf{Y}_1\). Ambos valores indican que dos comerciantes se conectan mediante aproximadamente 2 actores intermedios.

Por último, en cuanto a la reciprocidad se observa que ambas redes de consenso son altamente reciprocas aunque las relaciones dominantes del segundo periodo demuestran superar a las del primero en este criterio. En otras palabras, en general la implementación de la plataforma logró que las transacciones entre comerciantes fuesen más mutuas. Una de las diferencias más grandes está en los grados de los comerciantes en cada una de las redes de consenso. Los comerciantes están siendo en promedio más sociables y populares durante el segundo periodo de interés, dejando ver que la introducción de la plataforma de negociación electrónica puede estar haciendo que los comerciantes interactuen más y que por ende tengan más conexiones.

Ahora, se lleva a cabo el procedimiento de segmentación de comerciantes para las redes de consenso. El algoritmo jerárquico elegido es cluster_louvain.

# Agrupamiento de la red de consenso pre
  
# Simetrización débil de la matriz
Y0_sym <- (Y0 + t(Y0)) > 0
Y0_sym <- 1 * Y0_sym #
diag(Y0_sym) <- 0
  
g5_pre <- graph_from_adjacency_matrix(Y0_sym, mode = "undirected", diag = FALSE)
clu_pre <- cluster_louvain(g5_pre)

# Agrupamiento de la red de consenso post
  
# Simetrización débil de la matriz
Y1_sym <- (Y1 + t(Y1)) > 0
Y1_sym <- 1 * Y1_sym #
diag(Y1_sym) <- 0
  
g5_post <- graph_from_adjacency_matrix(Y1_sym, mode = "undirected", diag = FALSE)
clu_post <- cluster_louvain(g5_post)

length(clu_pre); round(modularity(clu_pre),4)
## [1] 30
## [1] 0.2631
length(clu_post); round(modularity(clu_post),4)
## [1] 8
## [1] 0.1664

La red derivada de \(\mathbf{Y}_0\) resultó segmentada en 30 clusters. Este número parece exagerado, pero es natural teniendo en cuenta que la red tiene 25 nodos aislados y estos algoritmos tipicamente asignan un cluster a cada nodo de estas características. Por otro lado, la red de consenso derivada de \(\mathbf{Y}_1\) se divide en 8 clusters, 4 de los cuales corresponden a nodos aislados.

# Visualización de la red de consenso 1:83

V(g5_pre)$grupo <- factor(clu_pre$membership)
V(g5_pre)$fuerza <- strength(g5_pre)

comp_pre <- components(g5_pre)
g5_pre_cg <- induced_subgraph(g5_pre, vids = V(g5_pre)[comp_pre$membership == which.max(comp_pre$csize)])

g5_pre_tbl <- as_tbl_graph(g5_pre_cg)

set_graph_style(plot_margin = margin(1,1,1,1))

set.seed(1)
layout5 <- create_layout(g5_pre_tbl, layout = "igraph", algorithm = "fr")

ggraph(layout5) +
  geom_edge_link(width = 1,
    alpha = 0.4,
    colour = "gray62",
    end_cap = circle(2, "mm")
  ) +
  geom_node_point(
    aes(color = grupo,
        size = fuerza )
  ) +
  scale_size(range = c(2, 8), guide = "none") +
  theme_void() +
  labs(
    title = "Agrupamiento de la red de consenso - Semana 1:83",
    subtitle = "El tamaño de los vertices es proporcional al grado\n Modularidad = 0.2631",
    color = "Comunidad"
  )

# Visualización de la red de consenso 84:T

V(g5_post)$grupo <- factor(clu_post$membership)
V(g5_post)$fuerza <- strength(g5_post)

comp_post <- components(g5_post)
g5_post_cg <- induced_subgraph(g5_post, vids = V(g5_post)[comp_post$membership == which.max(comp_post$csize)])

g5_post_tbl <- as_tbl_graph(g5_post_cg)

set_graph_style(plot_margin = margin(1,1,1,1))

set.seed(1)
layout5 <- create_layout(g5_post_tbl, layout = "igraph", algorithm = "fr")

ggraph(layout5) +
  geom_edge_link(width = 1,
    alpha = 0.4,
    colour = "gray62",
    end_cap = circle(2, "mm")
  ) +
  geom_node_point(
    aes(color = grupo,
        size = fuerza )
  ) +
  scale_size(range = c(2, 8), guide = "none") +
  theme_void() +
  labs(
    title = "Agrupamiento de la red de consenso - Semana 83:T",
    subtitle = "El tamaño de los vertices es proporcional al grado\n Modularidad = 0.1664",
    color = "Comunidad"
  )

La componente gigante de la red de consenso previa a la implementación de la plataforma digital cuenta con 4 clusters. Note que el cluster con identificador 4 parece abarcar a los comerciantes conectados que menos relaciones entablaron en promedio en el periodo estudiado.

Igualmente, la red de consenso posterior al cambio de plataforma se divide en 4 clusters. El grupo de color verde (2) abarca a cuatro de los comerciantes en promedio más activos en términos de cantidad de transacciones en el mercado de gas natural.
Con la visualización de esta red rectificamos que la implementación de la plataforma digital generó mayor movimiento en la red de comerciantes ya que vemos más enlaces y nodos con grados más altos.

Punto 5

  1. Considere las acciones de tutela disponibles en la página de la Relatoría de la Corte Constitucional de Colombia (Relatoría de la Corte Constitucional). Según la Corte, los derechos más protegidos mediante tutelas son, en primer lugar, el derecho de petición, seguido del derecho a la salud y, finalmente, el derecho al debido proceso.

  1. Una vez en la pagina, en el buscador principal escriba derecho a la salud y filtre la fecha para todas aquellas tutelas resueltas en el 2004 (fecha de providencia desde 01/01/2004) hasta el dia 13/12/24. Luego, inicie la búsqueda. En la parte izquierda de la pagina encontrara filtros adicionales. Así, en la sección Providencia filtre por Tutela y a continuación exporte los resultados en excel utilizando el botón verde que dice Exportar resultados en EXCEL. A la hora de hacer este proceso le deben resultar 158 providencias. Cuando exporte los resultados escoja la opción Seleccionar Todas respecto a la información a exportar. Este proceso descargara en su computador un archivo con raíz “relatoria_corte_Constitucional” seguido por la fecha del dia de la descarga. ahora consolidar un archivo de texto plano en el que consigne todo el texto dado en la columna denominada “sintesis”.

  2. Repetir el procedimiento descrito en el numeral a. para “derecho de petición” en 2024.

  3. Repetir el procedimiento descrito en el numeral a. para “debido proceso” en 2024.

  4. Realizar un análisis exhaustivo del texto relacionado con estos derechos empleando técnicas de redes sociales (no es necesario hacer un análsis de sentimiento). Comparar los resultados obtenidos y presentarlos de manera clara y estructurada, destacando las similitudes, diferencias y patrones relevantes.

  5. Repetir el análisis para los años 2019, 2020, 2021, 2022 y 2023. Importante: al aplicar el filtro de fechas, asegúrese de abarcar todo el año completo para cada caso.

  6. Interpretar los resultados obtenidos.

Solución Punto 5

Datos 2024

# Convertir los datos a texto plano
library(readxl)
library(stringr)
library(readr)

years <- 2019:2024
derechos <- c("salud", "peticion", "debidoproceso")

# Crear archivos txt automáticamente
walk(years, function(y){

  walk(derechos, function(d){
    
    archivo_excel <- paste0("Datos/CorteConstitucional/derecho_", d, "_", y, ".xlsx")
    datos <- read_excel(archivo_excel)["Resumen"]
    texto <- str_replace_all(datos$Resumen, "[\r\n]+", " ") # saltos de linea a espacios

    archivo_txt <- paste0("Datos/CorteConstitucional/derecho_", d, y, ".txt")
    writeLines(texto, archivo_txt)
  })
})

Una vez obtenidas las bases de de datos para ‘derecho a la salud’, ‘derecho de petición’ y ‘debido proceso’ para el año 2024 se construyen los archivos de texto plano. Las bases cuentan con 166, 151 y 269 tutelas, respectivamente.

# Cargar los archivos planos

text_salud2024 <- read_lines("Datos/CorteConstitucional/derecho_salud2024.txt")
text_peticion2024 <- read_lines("Datos/CorteConstitucional/derecho_peticion2024.txt")
text_proceso2024 <- read_lines("Datos/CorteConstitucional/derecho_debidoproceso2024.txt")


text_salud2024 <- unlist(c(text_salud2024))
text_peticion2024 <- unlist(c(text_peticion2024))
text_proceso2024 <- unlist(c(text_proceso2024))

names(text_salud2024) <- NULL
names(text_peticion2024) <- NULL
names(text_proceso2024) <- NULL

head(text_salud2024, n = 1)
## [1] "En tres acciones de tutela formuladas de manera independiente se tiene como hecho común que los actores son adultos mayores que alegaron que las EPS a las que se encuentran afiliados vulneraron sus derechos fundamentales, al no garantizarles el acceso oportuno y continuo a medicamentos y servicios médicos. Una de las peticionarias presenta cáncer de colon y alegó varios retrasos en la provisión de servicios. En los otros dos asuntos se argumentaron problemas porque los medicamentos prescritos no eran entregados en el lugar de residencia de los pacientes, por lo que debían desplazarse a otros municipios para reclamarlos. Se reiteró jurisprudencia sobre el derecho fundamental a la salud y los principios de accesibilidad, oportunidad, continuidad e integralidad. Así mismo, se expusieron las reglas sobre el carácter prevalente del derecho a la salud de los sujetos de especial protección constitucional, entre ellos, los adultos mayores y los pacientes con diagnóstico de cáncer. Igualmente, se analizó temática relacionada con la Ley 2360 de 2024 y las obligaciones de las entidades a cargo de la prestación del servicio de salud de no imponer barreras administrativas injustificadas; entregar pañales cuando los usuarios lo requieran, el derecho al diagnóstico y la concesión del tratamiento integral. En todos los asuntos se CONCEDIÓ el derecho a la salud y se impartieron unas órdenes específicas para hacer efectivo el goce de esta garantía constitucional."
head(text_peticion2024, n = 1)
## [1] "El accionante es un periodista que alegó en sede de tutela que la Universidad Nacional de Colombia vulneró sus derechos fundamentales, por cuanto sus facultades de Ingeniería y Ciencias se negaron a entregar la información que solicitó sobre los títulos y estatus académicos de un grupo de catorce personas, calificadas por él, como altos funcionarios del Estado, frente a los cuales pretendía hacer veeduría ciudadana y periodística.  Las referidas facultades exigieron la autorización de los titulares de los datos para entregarle la información. Se analizó la siguiente temática: 1º. Marco normativo y reiteración de jurisprudencia sobre el derecho de acceso a la información pública y su relación con el derecho de petición.  2º. El derecho al habeas data. Se CONCEDIÓ el amparo invocado y se ordenó a la accionada entregar al tutelante los datos requeridos."
head(text_proceso2024, n = 1)
## [1] "Los actores son dos ciudadanos venezolanos que ingresaron en el 2019 al territorio colombiano de forma irregular. Ellos son pareja y padres de dos hijos, uno de los cuales es menor de edad. Ninguno de los accionantes cuenta con un ingreso estable porque no ostentan permiso para trabajar, lo cual ha afectado su mínimo vital y la satisfacción de sus necesidades básicas. La vulneración de derechos fundamentales se atribuyó, por un lado, a la falta de respuesta a la solicitud de priorización del estudio y trámite de reconocimiento de la condición de refugiados y, de otro, a la condición de renunciar a la anterior pretensión, con el fin de poder continuar con el trámite de expedición de los Permisos por Protección Temporal (PPT). Migración Colombia alegó que los PPT se encontraban autorizados pero que iban a ser suspendidos porque los peticionarios tenían solicitudes de refugio activas y no era posible contar con más de una condición migratoria. Se analizó la siguiente temática: 1º. Los fundamentos legales y jurisprudenciales relacionados con el alcance del derecho al debido proceso en el procedimiento para la determinación de la condición de persona refugiada. 2º. La garantía de plazo razonable en la solicitud de refugio y, 3º. La prohibición de imponer barreras administrativas a los solicitantes de refugio y de PPT. En sede de revisión la Sala constató que los tutelantes desistieron de la solicitud de refugio y que en la actualidad cuentan con los Permisos de Protección vigentes. Con base en lo anterior se declaró la carencia actual de objeto por hecho superado y daño consumado. No obstante, se impartieron una serie de órdenes específicas a las entidades accionadas y se exhortó al Ministerio de Relaciones Exteriores y a la Unidad Administrativa Especial Migración Colombia para que adelanten los procedimientos de determinación de la condición de refugiado y de estudio y entrega del PPT, y gestionen las peticiones que presenten los solicitantes dentro de estos trámites, respetando la garantía de plazo razonable y los protocolos internos recientemente adoptados por ambas entidades, en cumplimiento de las Sentencias SU.543/23, T-078/24 y T-246/24, y los términos de respuesta fijados por la Ley 1755 de 2015 sobre el derecho fundamental de petición."
# Convertir a data frame
text_salud2024 <- tibble(
  line = seq_along(text_salud2024),   # Crear índice de línea
  text = text_salud2024               # Texto original, línea por línea
)
dim(text_salud2024)
## [1] 166   2
text_peticion2024 <- tibble(
  line = seq_along(text_peticion2024),   # Crear índice de línea
  text = text_peticion2024               # Texto original, línea por línea
)
dim(text_peticion2024)
## [1] 151   2
text_proceso2024 <- tibble(
  line = seq_along(text_proceso2024),   # Crear índice de línea
  text = text_proceso2024               # Texto original, línea por línea
)
dim(text_proceso2024)
## [1] 269   2

Acto seguido, se tokenizan las bases de datos de forma que cada palabra sea un token.

# Tokenización
suppressMessages(suppressWarnings(library(tidytext)))
suppressMessages(suppressWarnings(library(magrittr)))
library(tidyverse)

text_salud2024 %<>%
  unnest_tokens(input = text, output = word) %>%   # Convertir a un token por fila
  filter(!is.na(word))

text_peticion2024 %<>%
  unnest_tokens(input = text, output = word) %>%
  filter(!is.na(word))

text_proceso2024 %<>%
  unnest_tokens(input = text, output = word) %>%
  filter(!is.na(word))

dim(text_salud2024); head(text_salud2024, n = 5)
## [1] 40505     2
## # A tibble: 5 × 2
##    line word    
##   <int> <chr>   
## 1     1 en      
## 2     1 tres    
## 3     1 acciones
## 4     1 de      
## 5     1 tutela
dim(text_peticion2024); head(text_peticion2024, n = 5)
## [1] 34710     2
## # A tibble: 5 × 2
##    line word      
##   <int> <chr>     
## 1     1 el        
## 2     1 accionante
## 3     1 es        
## 4     1 un        
## 5     1 periodista
dim(text_proceso2024); head(text_proceso2024, n = 5)
## [1] 64417     2
## # A tibble: 5 × 2
##    line word      
##   <int> <chr>     
## 1     1 los       
## 2     1 actores   
## 3     1 son       
## 4     1 dos       
## 5     1 ciudadanos

Como es natural en todos los textos, hay palabras ‘vacías’ que no aportan al análisis dada su característica de conectores, artículos, etc. Estas se cargan a partir de un diccionario de stop_words en español, para su posterior eliminación.

# Diccionario de stop words en español
stop_words_es <- tibble(
  word    = unlist(c(read.table("stop_words_spanish.txt", quote = "\"", comment.char = ""))),
  lexicon = "custom"
)
# Acentos
replacement_list <- list(
  'á' = 'a',
  'é' = 'e',
  'í' = 'i',
  'ó' = 'o',
  'ú' = 'u'
)

La normalización de los tokens incluye eliminar palabras con caracteres numéricos, eliminar las palabras vacías, reemplazar los acentos y estandarizar las palabras ‘derecho y ’derechos’ en una sola.

# Normalización

text_salud2024 %<>%
  # Eliminar palabras que contienen dígitos
  filter(!grepl(pattern = "[0-9]", x = word)) %>% 
  # Eliminar stop words
  anti_join(x = ., y = stop_words_es) %>% 
  # Reemplazar acentos
  mutate(word = chartr(
    old = names(replacement_list) %>% str_c(collapse = ""), 
    new = replacement_list %>% str_c(collapse = ""), 
    x = word
  )) %>% 
  mutate(word = case_when(word %in% c("derecho", "derechos") ~ "derecho",
                            TRUE ~ word) )

text_peticion2024 %<>%
  # Eliminar palabras que contienen dígitos
  filter(!grepl(pattern = "[0-9]", x = word)) %>% 
  # Eliminar stop words
  anti_join(x = ., y = stop_words_es) %>% 
  # Reemplazar acentos
  mutate(word = chartr(
    old = names(replacement_list) %>% str_c(collapse = ""), 
    new = replacement_list %>% str_c(collapse = ""), 
    x = word
  )) %>% 
  mutate(word = case_when(word %in% c("derecho", "derechos") ~ "derecho",
                            TRUE ~ word) )

text_proceso2024 %<>%
  # Eliminar palabras que contienen dígitos
  filter(!grepl(pattern = "[0-9]", x = word)) %>% 
  # Eliminar stop words
  anti_join(x = ., y = stop_words_es) %>% 
  # Reemplazar acentos
  mutate(word = chartr(
    old = names(replacement_list) %>% str_c(collapse = ""), 
    new = replacement_list %>% str_c(collapse = ""), 
    x = word
  )) %>% 
  mutate(word = case_when(word %in% c("derecho", "derechos") ~ "derecho",
                            TRUE ~ word) )


dim(text_salud2024)
## [1] 18305     2
dim(text_peticion2024)
## [1] 15754     2
dim(text_proceso2024)
## [1] 29118     2

Una vez ejecutada la limpieza de los tokens se obtienen 18305 palabras para derecho a la salud, 15754 para derecho de petición y 29118 para debido proceso.

Véase ahora las palabras más frecuentes para cada tipo de tutela.

suppressMessages(suppressWarnings(library(gridExtra)))

# Tokens más frecuentes
text_salud2024 %>%
  count(word, sort = TRUE) %>%
  head(n = 10) 
## # A tibble: 10 × 2
##    word               n
##    <chr>          <int>
##  1 derecho          503
##  2 salud            297
##  3 amparo           149
##  4 fundamentales    136
##  5 tutela           123
##  6 proteccion       110
##  7 servicio         106
##  8 personas          99
##  9 constitucional    97
## 10 jurisprudencia    94
text_peticion2024 %>%
  count(word, sort = TRUE) %>%
  head(n = 10) 
## # A tibble: 10 × 2
##    word              n
##    <chr>         <int>
##  1 derecho         438
##  2 amparo          135
##  3 fundamentales   126
##  4 salud           106
##  5 tutela           95
##  6 proceso          91
##  7 accionante       84
##  8 entidad          84
##  9 invocado         84
## 10 tematica         84
text_proceso2024 %>%
  count(word, sort = TRUE) %>%
  head(n = 10) 
## # A tibble: 10 × 2
##    word              n
##    <chr>         <int>
##  1 derecho         736
##  2 proceso         256
##  3 amparo          237
##  4 fundamentales   214
##  5 tutela          206
##  6 accion          170
##  7 salud           155
##  8 proteccion      150
##  9 invocado        149
## 10 accionante      148
tema_texto <- theme_light(base_size = 10) +
  theme(
    plot.title = element_text(size = 12, face = "bold"),
    axis.text.y = element_text(size = 9),
    axis.text.x = element_text(size = 8),
    axis.title.x = element_text(size = 10)
  )

text_salud2024 %>%
  count(word, sort = TRUE) %>%
  filter(n > 80) %>%
  mutate(word = reorder(word, n)) %>%
  ggplot(aes(x = word, y = n)) +
    geom_col(fill = "darkolivegreen4", alpha = 0.8) +
    coord_flip() +
    labs(title = "Derecho a la salud",
         x = NULL,
         y = "Frecuencia") +
  tema_texto -> p1

text_peticion2024 %>%
  count(word, sort = TRUE) %>%
  filter(n > 80) %>%
  mutate(word = reorder(word, n)) %>%
  ggplot(aes(x = word, y = n)) +
    geom_col(fill = "blue4", alpha = 0.8) +
    coord_flip() +
    labs(title = "Derecho de petición",
         x = NULL,
         y = "Frecuencia") +
  tema_texto -> p2

text_proceso2024 %>%
  count(word, sort = TRUE) %>%
  filter(n > 100) %>%
  mutate(word = reorder(word, n)) %>%
  ggplot(aes(x = word, y = n)) +
    geom_col(fill = "blue4", alpha = 0.8) +
    coord_flip() +
    labs(title = "Debido proceso",
         x = NULL,
         y = "Frecuencia") +
  tema_texto -> p3

library(patchwork)
(p1 | p2 | p3)

Para todos los tipos de tutela, la palabra más frecuente es ‘derecho’, por una gran diferencia en derecho de petición y debido proceso. Las segundas palabras más frecuentes en los grupos son ‘salud’, ‘amparo’ y ‘proceso’, respectivamente. De este gráfico también podemos observar que los datos de Debido proceso cuentan con una mayor cantidad de palabras que superan el umbral de repetirse al menos 100 veces, tanto así que los demás tipo de derecho tienen el umbral en 80.

suppressMessages(suppressWarnings(library(wordcloud)))

# Configuración del área de gráficos
par(mfrow = c(1, 3), mar = c(1, 1, 2, 1), mgp = c(1, 1, 1))

set.seed(123)
text_salud2024 %>%
  count(word, sort = TRUE) %>%
  with(wordcloud(
    words = word,
    freq = n,
    max.words = 20,
    colors = "darkolivegreen4"
  ))
title(main = "Derecho a la salud")

set.seed(123)
text_peticion2024 %>%
  count(word, sort = TRUE) %>%
  with(wordcloud(
    words = word,
    freq = n,
    max.words = 20,
    colors = "blue4"
  ))
title(main = "Derecho de petición")

set.seed(123)
text_proceso2024 %>%
  count(word, sort = TRUE) %>%
  with(wordcloud(
    words = word,
    freq = n,
    max.words = 20,
    colors = "blue4"
  ))
title(main = "Debido proceso")

Ahora, veremos la frecuencia relativa de las palabras asociadas a cada derecho, específicamente aquellas comunes para los tres conjuntos de datos.

# Frecuencias relativas de palabras por derecho
bind_rows(
  mutate(.data = text_salud2024, author = "derecho_salud"),
  mutate(.data = text_peticion2024, author = "derecho_peticion"),
  mutate(.data = text_proceso2024, author = "debido_proceso")
) %>%
  count(author, word) %>%
  group_by(author) %>%
  mutate(proportion = n / sum(n)) %>%         # Calcular proporción relativa por autor
  select(-n) %>%
  spread(author, proportion, fill = 0) -> frec  # Convertir a formato ancho

frec %<>%
  select(word, derecho_salud, derecho_peticion, debido_proceso)

dim(frec)
## [1] 6110    4
# Top 10 palabras en comun
frec %>%
  filter(derecho_salud != 0, derecho_peticion != 0, debido_proceso != 0) %>%
  arrange(desc(derecho_salud), desc(derecho_peticion), desc(debido_proceso)) -> frec_comun

# Inspección de dimensiones y primeras palabras
dim(frec_comun)
## [1] 2473    4
head(frec_comun, n = 10)
## # A tibble: 10 × 4
##    word           derecho_salud derecho_peticion debido_proceso
##    <chr>                  <dbl>            <dbl>          <dbl>
##  1 derecho              0.0275           0.0278         0.0253 
##  2 salud                0.0162           0.00673        0.00532
##  3 amparo               0.00814          0.00857        0.00814
##  4 fundamentales        0.00743          0.00800        0.00735
##  5 tutela               0.00672          0.00603        0.00707
##  6 proteccion           0.00601          0.00495        0.00515
##  7 servicio             0.00579          0.00273        0.00192
##  8 personas             0.00541          0.00444        0.00326
##  9 constitucional       0.00530          0.00444        0.00508
## 10 jurisprudencia       0.00514          0.00482        0.00484
# proporción de palabras en comun
prop_palabras_comunes <- dim(frec_comun)[1] / dim(frec)[1]
prop_palabras_comunes
## [1] 0.4047463

Las palabras comunes en los tres tipos de tutela más frecuentes son: derecho, salud, amparo, fundamentales y tutela. Que la segunda palabra en común más frecuente sea ‘salud’ nos dice que este tema trasciende los tipos de tutelas presdentadas.

Bigramas

Con el fin de ir más allá en el análisis de texto, se construyen los bigramas: tokens de dos palabras consecutivas en el texto. Estos nuevos tokens se normalizan igualmente, para luego construir redes de palabras a partir de ellos.

limpiar_bigramas <- function(path_archivo,
                             stop_words_es,
                             replacement_list,
                             umbral = 2) {
  # Leer texto
  texto <- read_lines(path_archivo) %>%
    unlist(use.names = FALSE)
  
  # Construcción y limpieza de bigramas
  bigramas_counts <- tibble(
    line = seq_along(texto),
    text = texto
  ) %>%
    
    unnest_tokens(input = text, output = bigram, token = "ngrams", n = 2) %>%
    filter(!is.na(bigram)) %>%
    
    separate(bigram, into = c("word1", "word2"), sep = " ") %>%
    
    # Eliminar números
    filter(!grepl("[0-9]", word1), !grepl("[0-9]", word2)) %>%
    # Eliminar stopwords
    filter(!word1 %in% stop_words_es$word,
           !word2 %in% stop_words_es$word) %>%
    # Normalizar acentos
    mutate(across(c(word1, word2),
        ~ chartr(
          old = names(replacement_list) %>% str_c(collapse = ""),
          new = replacement_list %>% str_c(collapse = ""),
          x = .))
    ) %>%
    # Simplificación de palabras
    mutate(across(c(word1, word2),
        ~ case_when(
          . %in% c("derecho", "derechos") ~ "derecho",
          . %in% c("fundamental", "fundamentales") ~ "fundamental",
          . %in% c("reitero", "reitera", "reiterar") ~ "reiterar",
          . %in% c("vulneraron", "vulnerados", "vulnero") ~ "vulnerar",
          TRUE ~ .)) ) %>%
    # Eliminar NAs
    drop_na(word1, word2) %>%
    # Contar
    count(word1, word2, sort = TRUE) %>%
    rename(weight = n)
  
  # Crear grafo
  g <- bigramas_counts %>%
    filter(weight > umbral) %>%
    graph_from_data_frame(directed = FALSE) %>%
    igraph::simplify(remove.multiple = TRUE)
  
  # Componente gigante
  comp <- components(g)
  V(g)$cluster <- comp$membership
  gcc <- induced_subgraph(g, vids = V(g)[comp$membership == which.max(comp$csize)])
  
  list(counts = bigramas_counts,
       graph = g,
       gcc = gcc)
}
bigramas_salud24 <- limpiar_bigramas(
  path_archivo = "Datos/CorteConstitucional/derecho_salud2024.txt",
  stop_words_es = stop_words_es,
  replacement_list = replacement_list,
  umbral = 2)

bigramas_peticion24 <- limpiar_bigramas(
  path_archivo = "Datos/CorteConstitucional/derecho_peticion2024.txt",
  stop_words_es = stop_words_es,
  replacement_list = replacement_list,
  umbral = 2)

bigramas_proceso24 <- limpiar_bigramas(
  path_archivo = "Datos/CorteConstitucional/derecho_debidoproceso2024.txt",
  stop_words_es = stop_words_es,
  replacement_list = replacement_list,
  umbral = 3)

Note que el grafo para el debido proceso se construye con un umbral más alto que los otros dos (pesos mayores a 3), dada su gran cantidad de palabras.

head(bigramas_salud24$counts)
## # A tibble: 6 × 3
##   word1    word2          weight
##   <chr>    <chr>           <int>
## 1 derecho  fundamental       227
## 2 amparo   invocado           89
## 3 reiterar jurisprudencia     53
## 4 carencia actual             48
## 5 ordenes  conducentes        46
## 6 tematica relacionada        43
head(bigramas_peticion24$counts)
## # A tibble: 6 × 3
##   word1    word2          weight
##   <chr>    <chr>           <int>
## 1 derecho  fundamental       190
## 2 amparo   invocado           82
## 3 reiterar jurisprudencia     49
## 4 carencia actual             38
## 5 ordenes  conducentes        34
## 6 tematica relacionada        31
head(bigramas_proceso24$counts)
## # A tibble: 6 × 3
##   word1    word2          weight
##   <chr>    <chr>           <int>
## 1 derecho  fundamental       306
## 2 amparo   invocado          147
## 3 reiterar jurisprudencia     86
## 4 tematica relacionada        63
## 5 ordenes  conducentes        55
## 6 carencia actual             54

Los bigramas más frecuentes para los tres tipos de tutela son ‘derecho fundamental’, ‘amparo invocado’ y ‘reiterar jurisprudencia’. Es más, el top de bigramas más frecuentes para el derecho a la salud y el derecho de petición coinciden en los bigramas considerados y el orden de estos de forma descendente; mientras que para el debido proceso cambian dos bigramas de orden en su frecuencia.

En cuanto a las palabras más frecuentes no se observa diferencia entre los derechos considerados.

Ahora, se presentan las visualizaciones de las redes construidas según el tipo de tutela presentada.

set.seed(123)
plot(
  bigramas_salud24$graph,
  layout = layout_with_fr,
  vertex.color = 1,
  vertex.frame.color = 1,
  vertex.size = 3,
  vertex.label = NA,
  main = "Red de palabras para el Derecho a salud \nUmbral = 3"
)

set.seed(123)
ggraph(bigramas_salud24$gcc, layout = "fr") +
  geom_edge_link(aes(width = weight),
                 alpha = 0.3, 
                 color = "gray60") +
  geom_node_point(size = 2,
                  color = "royalblue") +
  geom_node_text(aes(label = name),
                 repel = TRUE,
                 size = 3) +
  scale_edge_width(range = c(1, 4), guide = "none") +
  theme_void() +
  labs(
    title = "Componente gigante Red de bigramas: Derecho a la salud (2024)"
  )

La red de la componente conexa de las tutelas del derecho a la salud muestra que este derecho está fuertemente conectado con temas de seguridad social, protección constitucional y estabilidad laboral. Relaciones como “regimen–subsidiado” y “regimen–especial” evidencian que muchas tutelas giran alrededor del acceso y la cobertura dentro del sistema de salud colombiano.

Asimismo, conexiones como “capacidad–laboral”, “laboral–reforzada” y “estabilidad–laboral” reflejan la importancia de la estabilidad laboral reforzada en casos de personas con enfermedades o condiciones de vulnerabilidad. Esto indica que el derecho a la salud no se limita al acceso a servicios médicos, sino que también involucra garantías laborales y protección frente a despidos.

La presencia de enlaces como “proteccion–especial”, “proteccion–constitucional” y “seguridad–social” resalta el enfoque garantista de la Corte Constitucional y su interés en proteger sujetos vulnerables mediante la acción de tutela. Finalmente, la centralidad de la palabra “reiterar” muestra que las sentencias se apoyan constantemente en precedentes previos, consolidando líneas jurisprudenciales sobre salud y protección de derechos fundamentales.

set.seed(123)

plot(
  bigramas_peticion24$graph,
  layout = layout_with_fr,
  vertex.color = 1,
  vertex.frame.color = 1,
  vertex.size = 3,
  vertex.label = NA,
  main = "Red de palabras para el Derecho de petición \nUmbral = 3"
)

set.seed(123)
ggraph(bigramas_peticion24$gcc, layout = "lgl") + # graphopt
  geom_edge_link(aes(width = weight),
                 alpha = 0.3, 
                 color = "gray60") +
  geom_node_point(size = 2,
                  color = "steelblue") +
  geom_node_text(aes(label = name),
                 repel = TRUE,
                 size = 3) +
  scale_edge_width(range = c(1, 4), guide = "none") +
  theme_void() +
  labs(
    title = "Componente gigante Red de bigramas: Derecho de petición (2024)"
  )

A diferencia de la red del derecho a la salud, en la componente gigante de la red del derecho de petición predominan términos asociados con procedimientos institucionales, decisiones administrativas y garantías constitucionales vinculadas al acceso y respuesta por parte de las autoridades públicas.

Note por ejemplo “autoridad–judicial”, “acto–administrativo” y “proceso–administrativo”, conexiones que evidencian que muchas tutelas surgen por actuaciones u omisiones de entidades estatales en trámites y procedimientos formales. También destacan enlaces como “agencia–oficiosa”, “ejercito–nacional” y “registraduria–nacional”, que muestran la presencia de entidades públicas específicas dentro de las tutelas. La aparición de estos nodos indica que buena parte de los conflictos jurídicos involucran solicitudes dirigidas a organismos estatales encargados de funciones administrativas, electorales o de seguridad.

La conexión entre “derecho” y “fundamental”, así como “garantias–constitucionales”, refleja que el derecho de petición es tratado por la Corte Constitucional como una garantía esencial para la protección de otros derechos fundamentales. En este sentido, la tutela funciona como un mecanismo para exigir respuestas efectivas de las instituciones y garantizar el acceso ciudadano a la información y a la administración pública.

Finalmente, términos como “decision”, “pretension” y “reconocer” hacen parte del lenguaje jurídico característico de las sentencias constitucionales, centrado en la resolución de solicitudes concretas y en la definición de obligaciones estatales frente a los accionantes.

En conjunto, la red revela que las tutelas sobre derecho de petición se enfocan principalmente en la exigencia de respuestas oportunas por parte de entidades públicas y en el control constitucional de actuaciones administrativas, consolidando este derecho como un mecanismo fundamental de interacción entre ciudadanía y Estado.

bigramas_proceso24_alt <- limpiar_bigramas(
  path_archivo = "Datos/CorteConstitucional/derecho_debidoproceso2024.txt",
  stop_words_es = stop_words_es,
  replacement_list = replacement_list,
  umbral = 2
)
set.seed(123)

par(mfrow = c(1, 2))
plot(
  bigramas_proceso24_alt$graph,
  layout = layout_with_fr,
  vertex.color = 1,
  vertex.frame.color = 1,
  vertex.size = 3,
  vertex.label = NA,
  main = "Red de palabras: Debido proceso \nUmbral = 3"
)
plot(
  bigramas_proceso24$graph,
  layout = layout_with_fr,
  vertex.color = 1,
  vertex.frame.color = 1,
  vertex.size = 3,
  vertex.label = NA,
  main = "Red de palabras: Debido proceso \nUmbral = 4"
)

par(mfrow = c(1, 1))
set.seed(123)
ggraph(bigramas_proceso24$gcc, layout = "nicely") + # graphopt
  geom_edge_link(aes(width = weight),
                 alpha = 0.3, 
                 color = "gray60") +
  geom_node_point(size = 2,
                  color = "steelblue") +
  geom_node_text(aes(label = name),
                 repel = TRUE,
                 size = 3) +
  scale_edge_width(range = c(1, 4), guide = "none") +
  theme_void() +
  labs(
    title = "Componente gigante Red de bigramas: Debido proceso (2024)"
  )

La red de bigramas sobre las tutelas relacionadas con el debido proceso muestra un discurso altamente jurídico y procedimental, centrado en decisiones judiciales, garantías constitucionales y análisis jurisprudenciales. Las conexiones entre “decision–judicial”, “providencia–judicial” y “corte–suprema” reflejan que gran parte de las tutelas se originan en controversias sobre actuaciones de jueces y tribunales.

Asimismo, relaciones como “jurisprudencia–reitera”, “precedente–garantia” y “conformidad–jurisprudencia” evidencian la importancia del precedente judicial dentro de este tipo de decisiones. La centralidad de términos como “reitera”, “analizo” y “concluyo” muestra que las sentencias recurren constantemente a líneas jurisprudenciales previas para fundamentar la protección del debido proceso.

La red también destaca conexiones asociadas con protección social y laboral, como “seguridad–social”, “regimen–especial”, “carrera–administrativa” y “unidad–familiar”. Esto indica que muchas controversias sobre debido proceso aparecen vinculadas a decisiones administrativas o laborales que afectan derechos fundamentales de los accionantes.

Finalmente, la presencia de términos como “accionante”, “pretension”, “tutela” y “garantias–constitucionales” refleja el carácter garantista de la Corte Constitucional, donde el debido proceso es entendido como un mecanismo esencial para asegurar actuaciones judiciales y administrativas transparentes, motivadas y respetuosas de los derechos fundamentales.

Skipgramas

Ahora se busca identificar relaciones semánticas entre palabras no contiguas, ya que estos pueden revelar patrones más complejos del texto.

limpiar_skipgramas <- function(path_archivo,
                               stop_words_es,
                               replacement_list,
                               n_skip = 2,
                               umbral = 2) {
  
  texto <- read_lines(path_archivo) %>%
    unlist(use.names = FALSE)
  
  skip_counts <- tibble(
    line = seq_along(texto),
    text = texto
  ) %>%
    # Limpiar los skipgramas
    unnest_tokens(input = text, output = skipgram, token = "skip_ngrams", n = 2, k = n_skip) %>%
    filter(!is.na(skipgram)) %>%
    
    separate(skipgram, into = c("word1", "word2"), sep = " ") %>%
    filter(!grepl("[0-9]", word1),
           !grepl("[0-9]", word2)) %>%
    filter(!word1 %in% stop_words_es$word,
           !word2 %in% stop_words_es$word) %>%
    mutate(across(c(word1, word2),
             ~ chartr(old = names(replacement_list) %>% str_c(collapse = ""),
                      new = replacement_list %>% str_c(collapse = ""),
                      x = .))
    ) %>%
    mutate(across(c(word1, word2),
             ~ case_when(
               . %in% c("derecho", "derechos") ~ "derecho",
               . %in% c("fundamental", "fundamentales") ~ "fundamental",
               . %in% c("reitero", "reitera", "reiterar", "reiteracion", "reiteraron") ~ "reiterar",
               . %in% c("vulneraron", "vulnerados", "vulnero", "vulneracion", "vulnerar") ~ "vulnerar",
               . %in% c("tutelado", "tutelados", "tutelaron", "tutela") ~ "tutela",
               TRUE ~ .)) ) %>%

    filter(word1 != word2) %>%
    drop_na(word1, word2) %>%
    
    count(word1, word2, sort = TRUE) %>%
    rename(weight = n)
  
  # Construir el grafo
  g <- skip_counts %>%
    filter(weight > umbral) %>%
    graph_from_data_frame(directed = FALSE) %>%
    igraph::simplify(remove.multiple = TRUE)
  
  # Componente gigante
  comp <- components(g)
  V(g)$cluster <- comp$membership
  gcc <- induced_subgraph(g, vids = V(g)[comp$membership == which.max(comp$csize)])
  
  list(counts = skip_counts,
       graph = g,
       gcc = gcc)
}
# Obtener los skipgramas para cada derecho
skip_salud24 <- limpiar_skipgramas("Datos/CorteConstitucional/derecho_salud2024.txt",
                                   stop_words_es, replacement_list,
                                   n_skip = 2,umbral = 3)
skip_peticion24 <- limpiar_skipgramas("Datos/CorteConstitucional/derecho_peticion2024.txt",
                                      stop_words_es,replacement_list,
                                      n_skip = 2,umbral = 3)
skip_proceso24 <- limpiar_skipgramas("Datos/CorteConstitucional/derecho_debidoproceso2024.txt",
                                     stop_words_es, replacement_list,
                                     n_skip = 2,umbral = 4)

Una vez organizados y limpiados los skipgramas, se presentan los más frecuentes

head(skip_salud24$counts)
## # A tibble: 6 × 3
##   word1    word2       weight
##   <chr>    <chr>        <int>
## 1 derecho  fundamental    227
## 2 vulnerar derecho        116
## 3 vulnerar fundamental     93
## 4 amparo   invocado        89
## 5 concedio amparo          83
## 6 concedio invocado        68
head(skip_peticion24$counts)
## # A tibble: 6 × 3
##   word1    word2       weight
##   <chr>    <chr>        <int>
## 1 derecho  fundamental    190
## 2 vulnerar derecho        105
## 3 vulnerar fundamental     85
## 4 amparo   invocado        82
## 5 concedio amparo          79
## 6 analizo  tematica        64
head(skip_proceso24$counts)
## # A tibble: 6 × 3
##   word1    word2       weight
##   <chr>    <chr>        <int>
## 1 derecho  fundamental    307
## 2 vulnerar derecho        185
## 3 amparo   invocado       147
## 4 vulnerar fundamental    144
## 5 concedio amparo         132
## 6 accion   tutela         126

Las parejas de palabras más frecuentes para todas las tutelas son ‘derecho fundamental’ y ‘vulnerar derecho’. Por su parte, las parejas ‘concedio amparo’, ‘concedio invocado’ y ‘vulnerar fundamental’ hacen presencia ahora como términos importantes, cuando en los bigramas estos no estaban construidos.

set.seed(123)

V(skip_salud24$gcc)$fuerza <- strength(skip_salud24$gcc)

ggraph(skip_salud24$gcc, layout = "nicely") + # nicely
  geom_edge_link(aes(width = weight),
                 alpha = 0.5,
                 color = "gray70",
                 start_cap = circle(2, "mm"),
                 end_cap   = circle(2, "mm")) +
  geom_node_point(aes(size = fuerza),
    color = "royalblue",
    alpha = 0.5
  ) +
  scale_edge_width(range = c(1, 4), guide = "none") +
  scale_size(range = c(2, 15), guide = "none") +
  theme_void() +
  labs(
    title = "Componente gigante de skipgramas: Derecho a la salud",
    subtitle = "El tamaño de los nodos es proporcional a su fuerza"
  )

set.seed(123)

V(skip_peticion24$gcc)$fuerza <- strength(skip_peticion24$gcc)

ggraph(skip_peticion24$gcc, layout = "lgl") + # lgl
  geom_edge_link(aes(width = weight),
                 alpha = 0.5,
                 color = "gray70",
                 start_cap = circle(2, "mm"),
                 end_cap   = circle(2, "mm")) +
  geom_node_point(aes(size = fuerza),
    color = "blueviolet",
    alpha = 0.5
  ) +
  scale_edge_width(range = c(1, 4), guide = "none") +
  scale_size(range = c(2, 15), guide = "none") +
  theme_void() +
  labs(
    title = "Componente gigante de skipgramas: Derecho de petición",
    subtitle = "El tamaño de los nodos es proporcional a su fuerza"
  )

set.seed(123)

V(skip_proceso24$gcc)$fuerza <- strength(skip_proceso24$gcc)

ggraph(skip_proceso24$gcc, layout = "lgl") + # lgl, nicely
  geom_edge_link(aes(width = weight),
                 alpha = 0.5,
                 color = "gray70",
                 start_cap = circle(2, "mm"),
                 end_cap   = circle(2, "mm")) +
  geom_node_point(aes(size = fuerza),
    color = "springgreen4",
    alpha = 0.5
  ) +
  scale_edge_width(range = c(1, 4), guide = "none") +
  scale_size(range = c(2, 15), guide = "none") +
  theme_void() +
  labs(
    title = "Componente gigante de skipgramas: Debido proceso",
    subtitle = "El tamaño de los nodos es proporcional a su fuerza"
  )

En líneas generales, las visualizaciones de las redes se organizan de forma que los nodos con mayor fuerza se agrupan en el centro del grafo, y las palabras meno comunes en las periferias. Las tres redes cuentan con al menos una rama de palabras que se conecta al grafo gracias a una o dos palabras únicamente. Las métricas siguientes nos ayudarán a profundizar en sus características.

metricas_red <- function(g) {
  tibble(Nodos = vcount(g),
         Aristas = ecount(g),
         Densidad = edge_density(g),
         "Grado medio" = mean(degree(g)),
         "Sd grado" = sd(degree(g)),
         "Distancia media" = mean_distance(g, directed = FALSE),
         Transitividad = transitivity(g, type = "global"),
         Asortatividad = assortativity_degree(g, directed = FALSE),
         "Número clan" = clique_num(g)
         )
}

tabla_metricas <- bind_rows(
  Salud = metricas_red(skip_salud24$gcc),
  Peticion = metricas_red(skip_peticion24$gcc),
  Debido_Proceso = metricas_red(skip_proceso24$gcc),
  .id = "Derecho"
)

tabla_metricas_t <- tabla_metricas %>%
  tibble::column_to_rownames("Derecho") %>%
  t() %>%
  as.data.frame()

tabla_metricas_t$Metrica <- rownames(tabla_metricas_t)
rownames(tabla_metricas_t) <- NULL

tabla_metricas_t <- tabla_metricas_t %>%
  select(Metrica, everything())

# columnas que NO llevan decimales
sin_decimales <- c("Nodos", "Aristas", "Número clan")

# formatear
tabla_metricas_t <- tabla_metricas_t %>%
  mutate(
    across(
      -Metrica,
      ~ ifelse(
        Metrica %in% sin_decimales,
        format(round(as.numeric(.), 0), nsmall = 0),
        format(round(as.numeric(.), 3), nsmall = 3)
      )
    )
  )

kable(
  tabla_metricas_t,
  align = "c",
  escape = FALSE,
  caption = "Métricas estructurales de las redes de skipgramas"
) %>%
  kable_styling(
    bootstrap_options = c("bordered", "striped", "hover"),
    full_width = FALSE
  )
Métricas estructurales de las redes de skipgramas
Metrica Salud Peticion Debido_Proceso
Nodos 270 218 339
Aristas 404 312 512
Densidad 0.011 0.013 0.009
Grado medio 2.993 2.862 3.021
Sd grado 3.534 3.188 3.483
Distancia media 40.025 71.528 53.038
Transitividad 0.141 0.159 0.141
Asortatividad -0.028 -0.034 -0.049
Número clan 5 4 5

La red de derecho de petición es la más pequeña de las tres, con tan solo 218 nodos y 312 aristas; mientras que la red de debido proceso es la más grande con 339 nodos y más de 500 aristas. Note que el echo de que una red sea grande no implica que sea densa, ya que la red de tutelas asociadas al debido proceso es la menos densa (0.009), seguida de derecho a la salud (0.011) y derecho de petición (0.013). Esto evidencia que la red de Derecho de petición tiene más conexiones en relación con el número total de posibles conexiones.

El grado medio es más alto en la red de debido proceso (3.02), indicando que, en promedio, las palabras en las tutelas de este derecho están más conectadas o tienen más co-ocurrencias que las de derecho a salud y derecho de petición. La red con menos conexiones en promedio es la del derecho de petición. Curiosamente, la desviación estándar del grado es más alta para la red de salud, dejando ver esta tiene una mayor variabilidad en su cantidad de conexiones entre palabras, mientras que en la red del derecho de petición las conexiones son más homogéneas.

Una diferencia considerable se observa en la distancia geodésica promedio de las redes comparadas. Las palabras del derecho de petición están mucho más distantes (71.52) que aquellas del debido proceso (53.04) y el derecho a la salud (40.02). Por otro lado, todas las redes presentan una transitividad global baja, aunque la que resalta del grupo es la red del derecho de petición, con un valor de 0.159, dando cuenta de una estructura levemente más cohesiva que las demás.

Las tres redes presentan valores de asortatividad similares y menores a cero, mostrando que las palabras con baja conectividad tienden a relacionarse con aquellos que si tienen alta conectividad. Esto es, hay palabras con muchas relaciones semánticas unidas a otras no tan recurrentes en las tutelas. Por último, las redes de derecho a la salud y debido proceso cuentan con cinco clanes máximos, mientras que la red de derecho de petición tiene uno menos.

redes_skip <- list(salud = skip_salud24,
                   peticion = skip_peticion24,
                   proceso = skip_proceso24)
# Nodos centrales
obtener_centralidades <- function(red) {
  tibble(
    palabra = V(red$gcc)$name,

    propia = eigen_centrality(red$gcc)$vector,
    cercania = closeness(red$gcc, normalized = TRUE),
    intermediacion = betweenness(red$gcc, normalized = TRUE),
    grado = degree(red$gcc) 
    ) %>%
    arrange(desc(propia))
}

centralidades <- map(
  redes_skip,
  obtener_centralidades
)
top_centralidad <- function(df, variable, n = 5) {
  
  df %>%
    arrange(desc(.data[[variable]])) %>%
    slice_head(n = n) %>%
    pull(palabra) %>%
    str_c(collapse = ", ")
}


# Tabla de palabras más centrales
tabla_centralidades <- tibble(
  
  Criterio = c("Centralidad propia", "Centralidad de cercanía", "Centralidad de intermediación", "Grado"),
  
  `Derecho a la salud` = c(top_centralidad(centralidades$salud, "propia"),
                           top_centralidad(centralidades$salud, "cercania"),
                           top_centralidad(centralidades$salud, "intermediacion"),
                           top_centralidad(centralidades$salud, "grado") 
                           ),
  `Derecho de petición` = c(top_centralidad(centralidades$peticion, "propia"),
                            top_centralidad(centralidades$peticion, "cercania"),
                            top_centralidad(centralidades$peticion, "intermediacion"),
                            top_centralidad(centralidades$peticion, "grado")
  ),
  `Debido proceso` = c(top_centralidad(centralidades$proceso, "propia"),
                       top_centralidad(centralidades$proceso, "cercania"),
                       top_centralidad(centralidades$proceso, "intermediacion"),
                       top_centralidad(centralidades$proceso, "grado")
  )
)

tabla_centralidades %>%
  kable(caption = "Top 3 palabras más centrales por criterio y tipo de tutela", align = "lccc") %>%
  kable_styling(full_width = FALSE, 
                bootstrap_options = c("striped", "hover", "condensed")
  )
Top 3 palabras más centrales por criterio y tipo de tutela
Criterio Derecho a la salud Derecho de petición Debido proceso
Centralidad propia derecho, fundamental, vulnerar, salud, accionada derecho, fundamental, vulnerar, peticion, tutela derecho, fundamental, vulnerar, accionada, proceso
Centralidad de cercanía personas, derecho, proteccion, salud, fundamental derecho, personas, atribuye, niños, discapacidad derecho, adujo, judicial, vulnerar, personas
Centralidad de intermediación salud, derecho, personas, tutela, reiterar derecho, personas, situacion, objeto, declaro derecho, proceso, salud, judicial, violencia
Grado derecho, salud, fundamental, especial, proteccion derecho, fundamental, vulnerar, salud, amparo derecho, fundamental, proceso, vulnerar, tutela

Se identifican las palabras más importantes de las redes de texto mediante varios criterios de centralidad.

Los resultados de centralidad muestran que, en las tres redes de skipgramas, la palabra “derecho” ocupa siempre una posición dominante. Así mismo, términos como “fundamental” y “vulnerar” aparecen de manera recurrente entre las palabras más centrales, lo cual es evidente ya que al interponer una tutela, las personas hablan directamente sobre los derechos fundamentales que se les han vulnerado.

En las tutelas relacionadas con el derecho a la salud, destacan palabras como “salud”, “proteccion” y “especial”. Esto sugiere que los textos se concentran en la protección de personas vulnerables y en la garantía del acceso efectivo a servicios de salud y seguridad social. Por otra parte, la relevancia de “tutela” y “reiterar” en términos de intermediación indica que estos conceptos funcionan como puentes entre distintos temas jurídicos y de repetición dentro de la red.

En el caso del derecho de petición, palabras como “peticion”, “atribuye”, “niños”, “discapacidad”, “situacion” y “amparo” reflejan un discurso más orientado hacia la relación entre ciudadanía y administración pública, especialmente en contextos de vulnerabilidad social. Esto es natural ya que este tipo de tutelas se suelen interponer hacia una institución específica. La aparición de “declaro” y “objeto” entre las palabras con mayor intermediación sugiere un lenguaje fuertemente procesal y argumentativo.

Por su parte, las tutelas sobre debido proceso muestran una estructura más judicial y procedimental. La centralidad de términos como “proceso”, “judicial”, “adujo” y “violencia” evidencia que estas tutelas se enfocan en actuaciones de autoridades judiciales y administrativas, así como en controversias relacionadas con garantías procesales. Además, la alta importancia de “judicial” en términos de cercanía e intermediación revela que este concepto conecta múltiples dimensiones del discursos. En conjunto, las centralidades muestran que cada tipo de tutela posee núcleos semánticos diferenciados: protección social en salud, interacción ciudadano-Estado en derecho de petición y control de actuaciones judiciales en debido proceso.

comunidades <- map(redes_skip,
                   ~ cluster_louvain(.x$gcc))

graficar_comunidades <- function(red,
                                 comunidades,
                                 titulo,
                                 layout_red = "fr") {
  
  ggraph(red$gcc, layout = layout_red) +
    geom_edge_link(aes(width = weight),
                   alpha = 0.5,
                   color = "gray70",
                   start_cap = circle(2, "mm"),
                   end_cap   = circle(2, "mm")) +
    geom_node_point(aes(color = as.factor(membership(comunidades)),
                        size = fuerza),
                    #size = 3,
                    alpha = 0.5) +
 #   geom_node_text(aes(label = name),
 #     repel = TRUE, size = 3) +
    theme_void() +
    guides(color = guide_legend(ncol = 2) ) +
    scale_edge_width(range = c(1, 4), guide = "none") +
    scale_size(range = c(2, 15), guide = "none") +
    labs(title = titulo,
         color = "Comunidad")
}
set.seed(123)
graficar_comunidades(skip_salud24, comunidades$salud,
                     layout_red = "nicely",
                     titulo = "Comunidades semánticas: Derecho a la salud"
)

set.seed(123)
graficar_comunidades(skip_peticion24, comunidades$peticion,
                     layout_red = "lgl",
                     titulo = "Comunidades semánticas: Derecho de petición"
)

set.seed(123)
graficar_comunidades(skip_proceso24, comunidades$proceso,
                     layout_red = "lgl",
                     titulo = "Comunidades semánticas: Debido proceso"
)

Derecho a la salud:

El agrupamiento de la red de skipgramas resultantes de las tutelas sobre derecho a la salud es bastante variado, ya que vemos que el algoritmo identifica 19 grupos de palabras homogéneas entre si. El cluster más grande, ubicado en el centro de la red, agrupa varios de los términos con mayor fuerza como “derecho”, “salud”, “fundamental”, “eps”, “entidad”, “judicial” y “vulnerar”, lo que refleja el núcleo central del discurso: la protección del derecho fundamental a la salud frente a actuaciones u omisiones de entidades prestadoras y autoridades administrativas. La presencia de palabras como “diagnostico”, “vih”, “mental” e “intimidad” muestra la existencia de controversias involucran condiciones médicas sensibles y protección de datos personales.

Otro grupo importante (cluster 3) corresponde al ámbito judicial y legal, donde aparecen palabras como “jurisprudencia”, “precedente”, “garantia”, “proteccion”, “reiterar” y “constitucional”. También se identifican clusters asociados a poblaciones vulnerables, como el que reúne términos como “personas”, “discapacidad”, “debilidad”, “vulnerabilidad”, “adultos”, “menores”, “privadas”, “libertad” y “situacion” reflejando la atención especial que reciben grupos en condición de vulnerabilidad física, económica o social. Relacionado con ello, otro cluster conecta “capacidad”, “laboral”, “estabilidad” y “reforzada”, hacieno alusión a la importancia de la estabilidad laboral para personas con afectaciones de salud.

Del mismo modo, existen comunidades enfocadas en el acceso material a servicios médicos. El grupo conformado por “acceso”, “servicios”, “medicamentos”, “tratamiento”, “atencion”, “integralidad”, “transporte” y “suministro” revela que gran parte de las tutelas giran alrededor de barreras concretas en la prestación de servicios de salud y la garantía de atención integral. Finalmente, algunos clusters más específicos agrupan temas sectoriales, como el sistema penitenciario (“carcelario”, “penitenciario”, “seguridad”, “social”), las fuerzas militares (“fuerzas”, “militares”) o la representación por agencia oficiosa (“agencia”, “oficiosa”, “menor”, “hijos”), mostrando cómo las tutelas acerca del derecho a la salud aveces van enfocadas a grupo0s específicos.

Derecho de petición:

El agrupamiento de la red del derecho de petición muestra un discurso centrado en el acceso a la información y en la relación entre ciudadanía y administración pública. El cluster principal reúne términos como “derecho”, “peticion”, “fundamental”, “acto”, “administrativo”, “informacion” y “acceso”, reflejando que las tutelas se enfocan en exigir respuestas oportunas y actuaciones adecuadas por parte de entidades estatales. La presencia de palabras como “minimo”, “vital”, “salud” y “igualdad” indica además que el derecho de petición suele utilizarse como mecanismo para proteger otros derechos fundamentales.

Un segundo conjunto de clusters está (igual que con el derecho a la salud) con la parte judicial y legal de las decisiones. Palabras como “jurisprudencia”, “reiterar”, “garantia”, “constitucional”, “juez”, “reglas” y “proteccion” evidencian que la Corte Constitucional fundamenta sus decisiones en precedentes previos y en el desarrollo procesal. Del mismo modo, el cluster conformado por “accion”, “tutela”, “procedencia”, “requisitos”, “caducidad” y “providencias” muestra el peso del análisis técnico y procedimental dentro de las sentencias.

El cluster integrado por “personas”, “privadas”, “libertad”, “discapacidad”, “vulnerabilidad”, “mayores” y “condicion” refleja que muchas tutelas involucran grupos en situación de debilidad manifiesta. En esta misma línea, otro grupo reúne “niños”, “niñas”, “adolescentes” e “interes superior”, resaltando la importancia de la protección de menores de edad.

Finalmente, varios clusters muestran temas sectoriales específicos. Uno de ellos agrupa “capacidad”, “estabilidad”, “laboral”, “pension”, “invalidez” y “reforzada”, evidenciando conflictos relacionados con seguridad social y estabilidad laboral. Otro conecta “registro”, “civil”, “registraduria”, “nacimiento” y “nacional”, lo que indica la relevancia de tutelas asociadas a identidad y registro civil. Asimismo, la presencia de comunidades como “habeas–data” o “consulta–previa” muestra que el derecho de petición funciona también como para reclamar información y garantías.

Debido proceso:

El agrupamiento de la red de debido proceso deja ver un discurso mucho más jurídico y procedimental que en las otras tutelas, centrado en el control de actuaciones judiciales y administrativas. El cluster más importante (el más grande y central) agrupa palabras como “decision”, “precedente”, “fallo”, “defecto”, “judicial”, “procedimental”, “factico” y “sentencia”, lo que evidencia que gran parte de estas tutelas se orientan a cuestionar providencias judiciales por irregularidades procesales.

Otro conjunto relevante está relacionado con garantías constitucionales y acceso efectivo a la justicia. Los clusters conformados por “garantias”, “constitucionales”, “legales”, así como “corte”, “revision”, “sala”, “suprema”, “administracion”, “justicia” y “acceso”, muestran que las decisiones enfatizan la protección del debido proceso como eje fundamental del Estado de derecho.

La red también evidencia una fuerte presencia de poblaciones vulnerables y contextos de violencia. El cluster integrado por “violencia”, “genero”, “intrafamiliar”, “psicologica”, “sexual”, “identidad”, “digna” y “diferencial” revela que el debido proceso analiza frecuentemente estoa aspectos. De manera similar, otro grupo conecta “conflicto”, “desplazamiento”, “victimas”, “ejercito”, “gobierno”, “registro” y “armado”, mostrando la relevancia de casos asociados al conflicto armado, desplazamiento forzado y reconocimiento de víctimas.

Finalmente, aparecen clusters relacionados con seguridad social, estabilidad laboral y protección pensional, donde se agrupan palabras como “pension”, “invalidez”, “sobrevivientes”, “calificacion”, “continuidad”, “prestacion” y “servicios”. Además, la presencia de términos como “consulta–previa”, “penitenciario”, “discapacidad” y “privadas–libertad” evidencia que el debido proceso funciona como una garantía transversal aplicable a múltiples contextos institucionales y sociales.

En general, todos los derechos tienen 3 ejes en común: uno en el que las palabras se agrupan por su significado judicial y legal, otro referente a poblaciones vulnerables y un último que involucra instituciones específicas.

Comparación longitudinal

Ahora, se lleva a cabo un análisis longitudinal de los tres tipos de derecho tutelado durante los años 2019 al 2024. Para esto, se empieza haciendo el análisis de los tokens simples (palabras) para las redes.

# Pre-procesamiento y notmalización de los datos
procesar_texto <- function(path){

  text <- read_lines(path) %>%
    unlist(use.names = FALSE)

  tibble(line = seq_along(text),
         text = text) %>%
    unnest_tokens(word, text) %>%
    filter(!is.na(word)) %>%
    # eliminar números
    filter(!grepl("[0-9]", word)) %>%
    # eliminar stopwords
    anti_join(stop_words_es, by = "word") %>%
    # reemplazar acentos
    mutate(word = chartr(
      old = names(replacement_list) %>% str_c(collapse = ""),
      new = replacement_list %>% str_c(collapse = ""),
      x = word) ) %>% 
     # Unir ambos terminos en uno solo
    mutate(word = case_when(word %in% c("derecho", "derechos") ~ "derecho",
                            word %in% c("fundamental", "fundamentales") ~ "fundamental",
                            word %in% c("reitero", "reitera", "reiterar", "reiteracion", "reiteraron") ~ "reiterar",
                            word %in% c("vulneraron", "vulnerados", "vulnero", "vulneracion", "vulnerar") ~ "vulnerar",
                            word %in% c("tutelado", "tutelados", "tutelaron", "tutela") ~ "tutela",
                            TRUE ~ word) ) %>%
    filter(word != "")
}
years <- 2019:2024
derechos <- c("salud", "peticion", "debidoproceso")
corpus <- map_dfr(years, function(y){
  map_dfr(derechos, function(d){

    archivo <- paste0("Datos/CorteConstitucional/derecho_", d, y, ".txt") 
    procesar_texto(archivo) %>% 
      mutate(year = y,
             derecho = d)
  })
})
dim(corpus)
## [1] 319597      4
#head(corpus)
tabla_tokens <- corpus %>%
  count(year, derecho) %>%
  pivot_wider(
    names_from = derecho,
    values_from = n,
    values_fill = 0
  ) %>%
  
  mutate(
    Total = salud + peticion + debidoproceso
  )


tabla_tokens %>%
  kable(caption = "Número de tokens por año y tipo de tutela", align = "c") %>%
  kable_styling(full_width = FALSE, bootstrap_options = c("bordered") ) %>%
  column_spec(1, bold = TRUE)
Número de tokens por año y tipo de tutela
year debidoproceso peticion salud Total
2019 26915 11552 11559 50026
2020 18573 10149 9399 38121
2021 22720 12246 10398 45364
2022 25326 12823 12371 50520
2023 29962 16555 25872 72389
2024 29118 15754 18305 63177

En conjunto, se tienen 319.597 tokens limpios y listos para analizar. El año 2023 es el que cuenta con más palabras en todas las tutelas. En general, se evidencia que las sentencias asociadas al debido proceso son las más abundantes en palabras también.

# Frecuencia de palabras
frecuencias <- corpus %>%
  count(derecho, year, word, sort = TRUE)

head(frecuencias , n = 15)
## # A tibble: 15 × 4
##    derecho        year word        n
##    <chr>         <int> <chr>   <int>
##  1 debidoproceso  2023 derecho   736
##  2 debidoproceso  2024 derecho   736
##  3 debidoproceso  2019 derecho   699
##  4 debidoproceso  2022 derecho   592
##  5 salud          2023 derecho   531
##  6 debidoproceso  2021 derecho   524
##  7 salud          2024 derecho   503
##  8 peticion       2023 derecho   456
##  9 debidoproceso  2020 derecho   446
## 10 peticion       2024 derecho   438
## 11 peticion       2022 derecho   358
## 12 peticion       2019 derecho   345
## 13 peticion       2021 derecho   339
## 14 salud          2023 salud     333
## 15 salud          2019 derecho   325

Note que de momento observamos que la palabra más frecuente a través de los años no cambia, y esta es ‘derecho’.

# Top palabras por año
top_palabras <- frecuencias %>%
  group_by(derecho, year) %>%
  slice_max(n, n = 3)

top_palabras
## # A tibble: 55 × 4
## # Groups:   derecho, year [18]
##    derecho        year word            n
##    <chr>         <int> <chr>       <int>
##  1 debidoproceso  2019 derecho       699
##  2 debidoproceso  2019 fundamental   298
##  3 debidoproceso  2019 tutela        253
##  4 debidoproceso  2020 derecho       446
##  5 debidoproceso  2020 fundamental   214
##  6 debidoproceso  2020 amparo        152
##  7 debidoproceso  2021 derecho       524
##  8 debidoproceso  2021 fundamental   241
##  9 debidoproceso  2021 tutela        211
## 10 debidoproceso  2022 derecho       592
## # ℹ 45 more rows

Las palabras más frecuentes a lo largo de los años para el derecho a la salud son “derecho”, “salud” y “fundamental”, siempre en este orden. Para el derecho de petición las dos palabras más frecuentes son “derecho” y “fundamental” y la tercera palabra más frecuente oscila entre “tutela”, “amparo” y “vulnerar” (esta última aparece en el top desde 2021). En cuanto al debido proceso, sucede algo similar al derecho de petición: ‘derecho’ y ‘fundamental’ son las palabras principales, seguidas de ‘tutela’, ‘amparo’ y ‘proceso’ en tercer puesto a lo largo de los años estudiados.

En el siguiente gráfico veremos una evolución del vocabulario en el tiempo.

top_global <- corpus %>%
  count(word, sort = TRUE) %>%
  slice_max(n, n = 20) %>%
  pull(word)

heatmap_palabras <- corpus %>%

  filter(word %in% top_global) %>%

  count(year, derecho, word) %>%

  ggplot(aes(
    x = year,
    y = reorder(word, n),
    fill = n
  )) +

  geom_tile(color = "white") +

  facet_wrap(~derecho) +
  scale_fill_gradient(
    low = "lightcyan",
    high = "navyblue"
  ) +
  theme_minimal() +

  labs(
    title = "Evolución longitudinal del vocabulario",
    x = "Año",
    y = NULL
  )

heatmap_palabras

Visualmente se observa la mayor frecuencia de palabras que tienen las tutelas del debido proceso. Por otro lado, las palabras en el derecho a la salud son más frecuentes a partir del año 2023, razón por la cual vemos colores más oscuros en general para las úlrimas dos columnas de este derecho.

Bigramas

Habiendo analizado los textos de forma simple (tokens = palabras),procedemos a armar los bigramas.

# BIGRAMAS
crear_bigramas <- function(path,
                           derecho,
                           year){
# Leer texto
  text <- read_lines(path) %>%
    unlist(use.names = FALSE)
  names(text) <- NULL

  text_df <- tibble(line = seq_along(text),
                    text = text)

# Construir bigramas
  text_bi <- text_df %>%
    unnest_tokens(input = text, output = bigram, token = "ngrams", n = 2) %>%
    filter(!is.na(bigram))

  text_bi_counts <- text_bi %>%
    separate(bigram, c("word1", "word2"), sep = " ") %>%

    # Eliminar bigramas con números
    filter(!grepl("[0-9]", word1)) %>%
    filter(!grepl("[0-9]", word2)) %>%

    # Eliminar stop words en ambas posiciones
    filter(!word1 %in% stop_words_es$word) %>%
    filter(!word2 %in% stop_words_es$word) %>%

    # Normalizar acentos
    mutate(
      word1 = chartr(
        old = names(replacement_list) %>% str_c(collapse = ""),
        new = replacement_list %>% str_c(collapse = ""),
        x = word1),
      word2 = chartr(
        old = names(replacement_list) %>% str_c(collapse = ""),
        new = replacement_list %>% str_c(collapse = ""),
        x = word2) ) %>%
    
    # Simplificar palabras
    mutate(
      word1 = case_when(word1 %in% c("derecho", "derechos") ~ "derecho",
                        word1 %in% c("fundamental", "fundamentales") ~ "fundamental",
                        word1 %in% c("reitero", "reitera", "reiterar", "reiteracion", "reiteraron") ~ "reiterar",
                        word1 %in% c("vulneraron", "vulnerados", "vulnero", "vulneracion", "vulnerar") ~ "vulnerar",
                        word1 %in% c("tutelado", "tutelados", "tutelaron", "tutela") ~ "tutela",
                        TRUE ~ word1),
      word2 = case_when(word2 %in% c("derecho", "derechos") ~ "derecho", 
                        word2 %in% c("fundamental", "fundamentales") ~ "fundamental",
                        word2 %in% c("reitero", "reitera", "reiterar", "reiteracion", "reiteraron") ~ "reiterar",
                        word2 %in% c("vulneraron", "vulnerados", "vulnero", "vulneracion", "vulnerar") ~ "vulnerar",
                        word2 %in% c("tutelado", "tutelados", "tutelaron", "tutela") ~ "tutela",
                        TRUE ~ word2) 
      ) %>%

    # Eliminar posibles NAs
    filter(!is.na(word1)) %>%
    filter(!is.na(word2)) %>%

    # Contar combinaciones más frecuentes
    count(word1, word2, sort = TRUE) %>%
    rename(weight = n) %>%
    mutate(derecho = derecho, year = year)

  return(text_bi_counts)
}
bigramas <- map_dfr(years, function(y){
  map_dfr(derechos, function(d){

    path <- paste0("Datos/CorteConstitucional/derecho_", d, y, ".txt")
    crear_bigramas(path = path, derecho = d, year = y)
  })
})

top_bigramas <- bigramas %>%
  mutate(bigrama = paste(word1, word2)) %>%
  group_by(derecho, year) %>%
  slice_max(weight, n = 3)

top_bigramas %>%  select(bigrama, weight, derecho, year)
## # A tibble: 56 × 4
## # Groups:   derecho, year [18]
##    bigrama              weight derecho        year
##    <chr>                 <int> <chr>         <int>
##  1 derecho fundamental     295 debidoproceso  2019
##  2 amparo invocado         112 debidoproceso  2019
##  3 tematica relacionada     59 debidoproceso  2019
##  4 derecho fundamental     209 debidoproceso  2020
##  5 amparo invocado          98 debidoproceso  2020
##  6 tematica relacionada     65 debidoproceso  2020
##  7 derecho fundamental     234 debidoproceso  2021
##  8 amparo invocado          88 debidoproceso  2021
##  9 tematica relacionada     76 debidoproceso  2021
## 10 derecho fundamental     268 debidoproceso  2022
## # ℹ 46 more rows

Los bigramas más frecuente para todas las tutelas a lo largo de todos los años son ‘derecho fundamental’ y ‘amparo invocado’. Los bigramas que se ubican en tercer lugar en este top son: ‘tematica relacionada’, ‘reiterar jurisprudencia’ y ‘carencia actual’, los cuales dan cuenta de la estructura juridica que suelen tener este tipo de textos. Se destaca que en el año 2021, el bigrama ‘seguridad social’ aparece en el top para el derecho a la salud, lo que nos puede indicar que durante el segundo año de la pandemia hubo un cambio de narrativa.

crear_red <- function(df, umbral = 2){

  g <- graph_from_data_frame(df %>% filter(weight > umbral) %>% 
                              select(word1, word2, weight), directed = FALSE)
  # Componente gigante
  comp <- components(g)
  gcc <- induced_subgraph(g, vids = which(comp$membership == which.max(comp$csize)) )
  return(gcc)
}
# Redes a partir de los bigramas
redes <- list()

for(d in unique(bigramas$derecho)){
  for(y in unique(bigramas$year)){

    df_temp <- bigramas %>%
      filter(derecho == d, year == y)

    redes[[paste(d, y, sep = "_")]] <- crear_red(df_temp)
  }
}
metricas_red <- function(g){
  tibble(
    Nodos = vcount(g),
    Enlaces = ecount(g),
    Densidad = edge_density(g),
    Transitividad = transitivity(g),
    Grado_medio = mean(degree(g)),
    Grado_desviacion = sd(degree(g)),
    Distancia_media = mean_distance(g),
    #Modularidad = modularity(cluster_louvain(g))
    Asortatividad = igraph::assortativity_degree(g, directed = F)
  )
}

metricas <- map_dfr(
  names(redes),
  function(nombre){
    g <- redes[[nombre]]
    metricas_red(g) %>%
      mutate(red = nombre)
  }
)
metricas
## # A tibble: 18 × 9
##    Nodos Enlaces Densidad Transitividad Grado_medio Grado_desviacion
##    <dbl>   <dbl>    <dbl>         <dbl>       <dbl>            <dbl>
##  1    23      22   0.0870        0             1.91             1.56
##  2    17      18   0.132         0             2.12             1.50
##  3    23      22   0.0870        0             1.91             1.16
##  4    31      33   0.0710        0             2.13             1.59
##  5   102     107   0.0208        0.0242        2.10             1.61
##  6    58      62   0.0375        0.0201        2.14             1.76
##  7    21      20   0.0952        0             1.90             1.26
##  8    23      22   0.0870        0             1.91             1.44
##  9    23      23   0.0909        0             2                1.57
## 10    30      32   0.0736        0.0366        2.13             1.78
## 11    75      76   0.0274        0             2.03             1.56
## 12    72      76   0.0297        0.0387        2.11             1.47
## 13   203     226   0.0110        0.0323        2.23             2.15
## 14   123     133   0.0177        0.0158        2.16             1.92
## 15   124     131   0.0172        0.0212        2.11             2.15
## 16   133     147   0.0167        0.0315        2.21             2.15
## 17   179     209   0.0131        0.0476        2.34             2.18
## 18   219     245   0.0103        0.0172        2.24             1.93
## # ℹ 3 more variables: Distancia_media <dbl>, Asortatividad <dbl>, red <chr>
metricas_plot <- metricas %>%
  separate(red, into = c("derecho", "year"), sep = "_") %>%
  mutate(year = as.numeric(year))

metricas_plot %>%
pivot_longer(
    cols = c(Nodos, Enlaces, Densidad, Transitividad, Grado_medio, Grado_desviacion, Distancia_media, Asortatividad),
    names_to = "metrica",
    values_to = "valor"
  ) %>%
  ggplot(aes(year, valor, color = derecho)) +
  geom_line(size = 1.1) +
  geom_point(size = 2) +
  facet_wrap(~metrica, scales = "free") +
  theme_light() +
  scale_color_discrete(
    labels = c("salud" = "Derecho a la salud",
               "peticion" = "Derecho de petición",
               "debidoproceso" = "Debido proceso")
    ) +
  labs(title = "Evolución temporal de métricas de red",
       x = "Año",
       y = NULL,
       color = "Derecho tutelado"
  )

La asortatividad calculada a partir del grado siempre toma valores negativos, dejando ver que las palabras poco conectadas tienden a estar unidas a otras que si tengan alta conectividad, es decir, no hay homofilia. Particularmente, las redes con menor asortatividad son las asociadas a los skipgramas del derecho de petición. La mayor asortatividad se observa en el 2021 para el derecho a la salud.

La densidad para las redes de debido proceso se mantiene en valores bajos casi constantes a través del tiempo. Esta red es particularmente poco densa ya que tiene muchas palabras pero pocas conexiones observadas respecto de todas las posibles que se podrían tener. A partir del 2021 la densidad disminuye para los derechos de petición y de salud de forma que sus valores son casi iguales hasta el año 2023. Así, la red más densa corresponde al derecho a la salud en el año 2020.

La distancia geodésica promedio para el derecho de petición tiene una fuerte subida a partir del año 2022, indicando que a partitr de este periodo las palabras están más distanciadas. Tanto las redes del debido proceso como las de derecho a la salud terminan con una longitud media similar en 2024 luego de haber tenido un ‘pico’ en 2023.

Las redes de mayor tamaño son claramente las asociadas al debido proceso. En 2022 el número de aristas tiene un aumento para todos los derechos, el cual se mantiene para 2023-2024 solamente para el debido proceso. Las redes de derecho a la salud y derecho de petición tienen tamaños muy similares desde 2019 hasta 2022. Note que el orden del grafo se comporta de forma análoga (casi ideéntica)

Los grados medio de los textos analizados se ubican dentro de 1.9 a 2.4 aproximadamente. En promedio, las palabras de los textos del debido proceso están más conectadas que las de los otros dos tipos. La mayor conectividad media la alcanzó la red del debido proceso en el año 2023. Complementariamente, la desviación estándar del grado también es mayor para el debido proceso, dejando ver que las conexiones de sus palabras son más variables respecto de los otros derechos tutelados.

Por último, la transitividad oscila entre el 0 y el 0.05. Curiosamente, las redes del derecho a la salud son cero transitivas durante 4 años (2019-2022), mientras que las redes de derecho de petición también tienen esta particularidad durante 3 años (2019-2021). La transitividad más alta es alcanzada por el debido proceso en 2023.

Skipgramas

Con el fin de capturar relaciones semánticas no contiguas se analizan loos skipgramas de las redes de forma longitudinal.

library(ngram)
crear_skipgramas <- function(path,
                             derecho,
                             year,
                             stop_words_es,
                             replacement_list,
                             n_skip = 2){

  texto <- read_lines(path) %>%
    unlist(use.names = FALSE)

  tibble(line = seq_along(texto),
         text = texto
         ) %>%
    
    unnest_tokens(input = text, output = skipgram, token = "skip_ngrams", n = 2, k = n_skip) %>%
    filter(!is.na(skipgram)) %>%
    # Quedarse con los skipgramas de 2 palabras
    mutate(num_words = stringr::str_count(skipgram, "\\S+")
           ) %>%
    filter(num_words == 2) %>%
    select(-num_words) %>%
    
    separate(skipgram, into = c("word1", "word2"), sep = " ") %>%
    
    filter(!grepl("[0-9]", word1),
           !grepl("[0-9]", word2) ) %>%
    filter( !word1 %in% stop_words_es$word,
            !word2 %in% stop_words_es$word) %>%
    mutate(
      across(c(word1, word2), ~ chartr(
        old = names(replacement_list) %>% str_c(collapse = ""),
        new = replacement_list %>% str_c(collapse = ""),
        x = .) )
    ) %>%
    mutate(across(
        c(word1, word2), ~ case_when(
          . %in% c("derecho", "derechos") ~ "derecho",
          . %in% c("fundamental", "fundamentales") ~ "fundamental",
          . %in% c("reitero", "reitera", "reiterar", "reiteracion", "reiteraron") ~ "reiterar",
          . %in% c("vulneraron", "vulnerados", "vulnero", "vulneracion", "vulnerar") ~ "vulnerar",
          . %in% c("tutelado", "tutelados", "tutelaron", "tutela") ~ "tutela",
          TRUE ~ .) )
        ) %>%
    filter(word1 != word2) %>%
    drop_na(word1, word2) %>%
    
    count(word1, word2, sort = TRUE) %>%
    rename(weight = n) %>%
    
    mutate(derecho = derecho,
           year = year)
}
skipgramas <- map_dfr(years, function(y){

  map_dfr(derechos, function(d){

    path <- paste0("Datos/CorteConstitucional/derecho_", d, y, ".txt")

    crear_skipgramas(path = path,
                     derecho = d,
                     year = y,
                     stop_words_es = stop_words_es,
                     replacement_list = replacement_list,
                     n_skip = 2)
  })
})
# Top de skipgramas
top_skipgramas <- skipgramas %>%
  mutate(skipgram = paste(word1, word2)) %>%
  group_by(derecho, year) %>%
  slice_max(weight, n = 3)

top_skipgramas %>% select(skipgram, weight, derecho, year)
## # A tibble: 54 × 4
## # Groups:   derecho, year [18]
##    skipgram             weight derecho        year
##    <chr>                 <int> <chr>         <int>
##  1 derecho fundamental     295 debidoproceso  2019
##  2 vulnerar derecho        175 debidoproceso  2019
##  3 accion tutela           154 debidoproceso  2019
##  4 derecho fundamental     209 debidoproceso  2020
##  5 vulnerar derecho        123 debidoproceso  2020
##  6 vulnerar fundamental    103 debidoproceso  2020
##  7 derecho fundamental     236 debidoproceso  2021
##  8 vulnerar derecho        130 debidoproceso  2021
##  9 accion tutela           116 debidoproceso  2021
## 10 derecho fundamental     269 debidoproceso  2022
## # ℹ 44 more rows

El skigrama más frecuente es, como ya lo veíamos venir, ‘derecho fundamental’. Respecto de los bigramas analizados en el apartado anterior, acá vemos un cambio porque el término ‘vulnerar derecho’ se situa como el segundo más frecuente para todos los textos y años; dando cuenta de una estrutura temática orientada a exponer las vulneraciones sufridas por los ciudadanos. Los términos que se posicionan históricamente en el tercer lugar son ‘accion tutela’, ‘vulnerar fundamental’ y ‘amparo invocado’.

skip_redes <- list()
for(d in unique(skipgramas$derecho)){
  for(y in unique(skipgramas$year)){

    df_temp <- skipgramas %>%
      filter(derecho == d,
             year == y)
    skip_redes[[paste(d, y, sep = "_")]] <- crear_red(df_temp)
  }
}
# Métricas de las redes
metricas_skip <- map_dfr(
  names(skip_redes),
  function(nombre){
    metricas_red(skip_redes[[nombre]]) %>%
      mutate(red = nombre)
  }
)
metricas_skip
## # A tibble: 18 × 9
##    Nodos Enlaces Densidad Transitividad Grado_medio Grado_desviacion
##    <dbl>   <dbl>    <dbl>         <dbl>       <dbl>            <dbl>
##  1   255     389  0.0120         0.111         3.05             4.15
##  2   230     342  0.0130         0.139         2.97             3.71
##  3   247     369  0.0121         0.110         2.99             3.94
##  4   273     418  0.0113         0.145         3.06             3.77
##  5   686    1165  0.00496        0.102         3.40             4.61
##  6   441     733  0.00756        0.120         3.32             4.48
##  7   256     379  0.0116         0.0998        2.96             3.72
##  8   171     269  0.0185         0.117         3.15             4.21
##  9   254     377  0.0117         0.121         2.97             3.85
## 10   291     448  0.0106         0.112         3.08             4.12
## 11   387     579  0.00775        0.108         2.99             4.01
## 12   383     595  0.00813        0.123         3.11             3.90
## 13   614    1123  0.00597        0.0913        3.66             5.58
## 14   421     692  0.00783        0.113         3.29             4.46
## 15   517     883  0.00662        0.107         3.42             4.89
## 16   585    1072  0.00628        0.1000        3.66             5.27
## 17   697    1304  0.00538        0.101         3.74             5.62
## 18   717    1333  0.00519        0.0978        3.72             5.31
## # ℹ 3 more variables: Distancia_media <dbl>, Asortatividad <dbl>, red <chr>
metricas_plot <- metricas_skip %>%
  separate(red, into = c("derecho", "year"), sep = "_") %>%
  mutate(year = as.numeric(year))

metricas_plot %>%
  pivot_longer(
    cols = c(Nodos, Enlaces, Densidad, Transitividad, Grado_medio, Grado_desviacion, Distancia_media, Asortatividad),
    names_to = "metrica",
    values_to = "valor"
  ) %>%
  ggplot(aes(year, valor, color = derecho)) +
  geom_line(size = 1.1) +
  geom_point(size = 2) +
  facet_wrap(~metrica, scales = "free") +
  scale_color_discrete(
    labels = c("salud" = "Derecho a la salud",
               "peticion" = "Derecho de petición",
               "debidoproceso" = "Debido proceso")
    ) +
  theme_light() +
  labs(title = "Evolución temporal de métricas para la red de skipgramas",
       x = "Año",
       y = NULL,
       color = "Derecho tutelado"
  )

Se evidencia una tendencia en las asortatividades. Entre el 2019 y el 2022, esta característica toma valores entre -0.05 y -0.1 dando cuenta de una no homofilia en los datos. A partir de 2022, los valores para todos los derechos van aumentando, de forma que el derecho a la salud obtiene una asortatividad positiva (0.01) en 2024.

En general, todas las redes de los derechos tutelados son más densas en el año 2020, punto a partir del cual esta característica disminuye. La red menos densa para casi todos los años es la de los skipgramas del debido proceso. Adicionalmente, note que las densidades oscilan entre valores de 0 a 0.02 aproximadamente, dando cuenta de redes poco conectadas.

En promedio, la distancia entre palabras es mayor para la red de skipgramas asociadas al debido proceso en 2020, en 201 este lugar lo ocupa el derecho de petición, el cual es superado por el derecho a la salud en el año 2022 (siendo este el pico global de todas las distancias medias). Podemos afirmar que el distanciamiento de las palabras que conforman los skipgramas es muy variable para los derechos tutelados en el periodo estudiado.

El derecho tutelado con un tamaño de grafo mayor durante todo el periodo estudiado es el debido proceso. Las redes con menor número de aristas son las asociadas al derecho de petición. Se resalta que la red del derecho a la salud en 2023 tuvo un tipo alto en su tamaño. Al igual que con los bigramas, el comportamiento del orden de la red (número de nodos) es casi idéntico al del número de aristas.

En cuanto al grado medio, este oscila entre los valores 3 y 3.7 aproximadamente. Este es más alto a lo largo de todos los años para las tutelas sobre debido proceso, alcanzando su pico en 2023, sugiriendo que en promedio las palabars de este derecho están más conectadas que las de los otros dos derechos.

Finalmente, las tutelas más transitivas son las asociadas al derecho a la salud en los años 2020 y 2022, lo que implica que en estas redes es más probable que las palabras conectadas a una misma palabra estén conectadas entre sí, muestra de una estrutura algo más cohesiva. Por el contrario, las tutelas asociadas al debido proceso son las menos transitivas en todos los años estudiados.

centralidades_skip <- map_dfr(
  names(skip_redes),
  function(nombre_red){
    g <- skip_redes[[nombre_red]]

    tibble(palabra = V(g)$name,
           cercania = closeness(g, normalized = TRUE),
           intermediacion = betweenness(g, normalized = TRUE),
           eigen = eigen_centrality(g)$vector,
           red = nombre_red)
  }
) %>%
  separate(red, into = c("derecho", "year"), sep = "_") %>%
  mutate(year = as.numeric(year))

# Palabra más central para cada red
top_centrales <- centralidades_skip %>%
  group_by(derecho, year) %>%
  slice_max(order_by = cercania,
            n = 2) %>%
  ungroup()
top_centrales
## # A tibble: 36 × 6
##    palabra     cercania intermediacion  eigen derecho        year
##    <chr>          <dbl>          <dbl>  <dbl> <chr>         <dbl>
##  1 derecho       0.0827          0.409 1      debidoproceso  2019
##  2 corte         0.0760          0.127 0.0145 debidoproceso  2019
##  3 derecho       0.0641          0.342 1      debidoproceso  2020
##  4 fundamental   0.0622          0.239 0.953  debidoproceso  2020
##  5 derecho       0.0702          0.410 1      debidoproceso  2021
##  6 concede       0.0645          0.119 0.0301 debidoproceso  2021
##  7 derecho       0.0765          0.353 1      debidoproceso  2022
##  8 proceso       0.0681          0.161 0.130  debidoproceso  2022
##  9 derecho       0.0782          0.409 1      debidoproceso  2023
## 10 judicial      0.0728          0.124 0.0229 debidoproceso  2023
## # ℹ 26 more rows
top2 <- centralidades_skip %>%
  group_by(derecho, year) %>%
  slice_max(cercania, n = 2, with_ties = FALSE)

ggplot(top2,
       aes(x = factor(year),
           y = reorder(palabra, cercania),
           fill = cercania)) +
  geom_tile(color = "white") +
  facet_wrap(~ derecho, scales = "free_y",
             labeller = labeller(
               derecho = c(salud = "Derecho a la salud",
                           peticion = "Derecho de petición",
                           debidoproceso = "Debido proceso")
               )
             ) +
  scale_fill_viridis_c(direction = -1) +
  theme_minimal() +
  labs(
    title = "Palabras más centrales por cercanía en el tiempo",
    x = "Año",
    y = NULL,
    fill = "Cercanía"
  )

Este gráfico nos deja ver el top 2 de palabras más importantes para cada periodo y derecho estudiado según el criterio de centralidad propia. Ests centralidad mide la importancia de las palabras con las que una se conecta. Este enfoque permite identificar términos clave que tienen un impacto significativo en el discurso o contexto analizado.

En las redes de debido proceso, la palabra “derecho” aparece como el nodo más central de manera sostenida durante todo el periodo, además con los valores más altos de cercanía observados en el gráfico. En segundo lugar aparecen otros términos como “proceso”, “judicial”, “concede”, “fundamental” y “corte”, lo que indica una mayor especialización del lenguaje y un desplazamiento hacia componentes más procesales y judiciales de la discusión.

Para el derecho de petición, también sobresale “derecho” como palabra estructural recurrente a lo largo de casi todos los años. Sin embargo, la red presenta mayor variabilidad que en debido proceso. Se observa que “fundamental” se hace presente en 2019 y 2021, “negar” adquiere alta centralidad en 2022, “amparo” en 2020, “social” en 2023 y “consulta” en 2024. Esto sugiere que el discurso alrededor del derecho de petición se mueve entre el lenguaje jurídico general y situaciones concretas asociadas a solicitudes, respuestas negativas y mecanismos de protección.

En derecho a la salud, la palabra “derecho” vuelve a ser el nodo central más estable durante todo el periodo. La persistencia de este término indica una estructura discursiva altamente concentrada alrededor del reconocimiento del derecho mismo. Junto a este aparecen: “salud” y “agua”, esta segunda que adquiere relevancia únicamente en 2022. La presencia de “agua” como término central en ese año es particularmente interesante porque sugiere una conexión temática entre salud y acceso a servicios básicos. Esto puede reflejar cambios coyunturales en los casos analizados o una ampliación del marco discursivo del derecho a la salud hacia determinantes sociales más amplios.

A nivel general, variaciones interanuales no eliminan el núcleo central de “derecho”, pero sí muestran cómo cada derecho incorpora vocabulario específico según el tema predominante en cada momento.

Punto 6

  1. Considere la novela Cien años de soledad de Gabriel García Márquez, en su versión en español disponible en este enlace. Realice un análisis exhaustivo de la obra por capítulos, empleando técnicas de análisis de sentimientos y análisis de redes sociales para realizar comparaciones entre capítulos. Además, lleve a cabo un análisis de tópicos utilizando el modelo LDA (Latent Dirichlet Allocation), estructurando el corpus a partir de los capítulos de la novela. Para el análisis de tópicos, puede tomar como referencia el enfoque descrito en el capítulo 6 del libro Text Mining with R: A Tidy Approach (2017) de Julia Silge y David Robinson.

Solución Punto 6

La emblemática novela de Gabriel García Márquez se compone de 20 capítulos

# Leer el texto
text_novela <- read_lines("Datos/gabriel_garcia_marquez_cien_annos_soledad.txt")
text_novela <- unlist(c(text_novela))
names(text_novela) <- NULL

text_novela <- tibble(
  linea = seq_along(text_novela), 
  texto = text_novela
) %>%
  mutate(texto_trim = str_trim(texto))

# Detectar donde empiezan los capítulos
text_novela <- text_novela %>%
  mutate(
    es_vacia = (texto_trim == ""),
    es_romano = str_detect(texto_trim, "^[IVXLCDM]+$"),
    es_vacia_lag = lag(es_vacia, default = FALSE),
    es_vacia_lead = lead(es_vacia, default = FALSE),
    es_inicio_cap = es_vacia_lag & es_romano & es_vacia_lead
  )

text_novela <- text_novela %>%
  mutate(capitulo_num = cumsum(es_inicio_cap)) %>%
  filter(capitulo_num > 0)

text_novela <- text_novela %>%
  filter(!es_inicio_cap) %>% 
  filter(texto_trim != "") %>% 
  filter(!texto_trim %in% c("Cien años de soledad", "Gabriel García Márquez"))
# Cada fila es un capitulo ahora
text_novela <- text_novela %>%
  group_by(capitulo_num) %>%
  summarise(texto = paste(texto_trim, collapse = " "), .groups = "drop") %>%
  mutate(
    capitulo = factor(paste0("Cap_", capitulo_num), levels = paste0("Cap_", sort(unique(capitulo_num))))
  ) %>%
  select(capitulo, texto)
head(text_novela)
## # A tibble: 6 × 2
##   capitulo texto                                                                
##   <fct>    <chr>                                                                
## 1 Cap_1    Muchos años después, frente al pelotón de fusilamiento, el coronel A…
## 2 Cap_2    Cuando el pirata Francis Drake asaltó a Riohacha, en el siglo XVI, l…
## 3 Cap_3    El hijo de Pilar Ternera fue llevado a casa de sus abuelos a las dos…
## 4 Cap_4    La casa nueva, blanca como una paloma, fue estrenada con un baile. Ú…
## 5 Cap_5    Aureliano Buendía y Remedios Moscote se casaron un domingo de marzo …
## 6 Cap_6    El coronel Aureliano Buendía promovió treinta y dos levantamientos a…
text_personajes <- text_novela

A continuación, debido al tinte literario del texto a analizar, es necesario llevar a cabo un proceso de lematización. Este permite que palabras diferenets que apuntan hacia un mismo significado léxico se agrupen para no generar ruido en los análisis. Por ejemplo, las palabras: ‘muere’, ‘murió’, ‘morir’ y ‘morirse’ se convierten todas a ‘morir’.

# Lematización
library(udpipe)
modelo <- udpipe_load_model("spanish-gsd-ud-2.5-191206.udpipe")

annot <- udpipe_annotate(modelo,
                         x = text_novela$texto,doc_id = text_novela$capitulo)
annot <- as.data.frame(annot)

tokens_novela_lema <- annot %>%
  transmute(capitulo = factor(doc_id, levels = levels(text_novela$capitulo)),
            word = lemma ,
            sentence_id = sentence_id # será importante más adelante
            )

Una vez lematizado el texto, se lleva a cabo la normalización de los tokens ya conocida.

# Normalización de los tokens
procesar_tokens <- function(df){
  df %>%
    mutate(word = str_to_lower(word)) %>%
    mutate(word = str_replace_all(word, "[[:punct:]]", "")) %>%
    filter(!str_detect(word, "[0-9]")) %>%
    filter(word != "") %>%
    anti_join(stop_words_es, by = "word") %>%
    mutate(word = chartr(
      old = paste(names(replacement_list), collapse = ""),
      new = paste(replacement_list, collapse = ""),
      x = word)) %>%
    #mutate(word = str_replace_all(word, "[^a-z]", "")) %>%
    mutate(
      word = case_when(
        word %in% c("xv","xvi","xvii", "xviii") ~ NA_character_,
        TRUE ~ word)
    ) %>%
    filter(word != "", !is.na(word))
}

tokens_novela <- procesar_tokens(tokens_novela_lema)
dim(tokens_novela) # 57.722
## [1] 57722     3
head(tokens_novela)
##   capitulo         word sentence_id
## 1    Cap_1          año           1
## 2    Cap_1       frente           1
## 3    Cap_1      peloton           1
## 4    Cap_1 fusilamiento           1
## 5    Cap_1      coronel           1
## 6    Cap_1    aureliano           1

Vemos que en total contamos con 57.722 tokens simples (palabras) luego del pre-procesamiento. Los cuales se distributyen en los 20 capítulos como se muestra a continuación:

library(scales)

tokens_novela %>% 
  group_by(capitulo) %>% 
  summarise(n_tokens = n(), .groups = "drop") %>% 
  mutate(
    porcentaje = n_tokens / sum(n_tokens)
  ) %>% 
  ggplot(aes(x = factor(capitulo), y = porcentaje)) +
  geom_col(fill = "deepskyblue4", width = 0.7) +
  geom_text(
    aes(label = percent(porcentaje, accuracy = 0.1)),
    vjust = -0.3,
    size = 3.5
  ) +
  scale_y_continuous(labels = percent_format()) +
  labs(
    title = "Distribución porcentual de tokens por capítulo",
    x = "Capítulo",
    y = "Porcentaje del total del libro"
  ) +
  theme_minimal()

Con el 5.9% de los tokens totales, el capítulo 5 se posiciona como el más largo del libro, seguido de los capítulos 3 y 14 con un 5.5% cada uno. Así mismo, los capítulos más cortos serían el sexto y el décimo sexto, con un 4.4% de tokens respecto del total.

frecuencias_absolutas <- tokens_novela %>%
  count(capitulo, word, sort = TRUE)

top_palabras_capitulo <- frecuencias_absolutas %>%
  group_by(capitulo) %>%
  slice_max(n, n = 5, with_ties = FALSE) %>%
  ungroup()

#top_palabras_capitulo

top_palabras_capitulo %>% 
  mutate(word = reorder_within(word, n, capitulo)) %>% 
  ggplot(aes(x = n, y = word)) +
  geom_col(fill = "#2E4057", width = 0.7) +
  scale_y_reordered() +
  facet_wrap(~ capitulo, scales = "free") +
  scale_x_continuous(
    breaks = seq(0, max(top_palabras_capitulo$n), by = 20)
  ) +
  labs(
    title = "Top 5 palabras más frecuentes por capítulo",
    x = "Frecuencia",
    y = NULL
  ) +
  theme_minimal() +
  theme(
    strip.text = element_text(face = "bold")
  )

Vemos que en general, las palabras más frecuentes de todos los capítulos son los nombres de los personajes principales de la novela. José Arcadio Buendía tiene el protagonismo en los primeros tres capítulos. A partir del cuarto capítulo vemos a otros personajes como Aureliano y Arcadio ocupar este lugar.

En cuanto a palabras que no corresponden a nombres, resalta ‘noche’ en el segundo capítulo; ‘casa’ en los capítulos 3-6, 9-14 y 16-18; ‘guerra’ en el noveno capítulo; y ‘amor’ en los últimos dos capítulos.

Análisis de sentimiento

El objetivo de este análisis es identificar flujos y transiciones narrativas entre los capítulos del texto. Para esto, se cargan los diccionarios positive_words_es.txt y negative_words_es.txt que contienen listas con palabras clasificadas como positivas y negativas.

positive_words <- read_csv("positive_words_es.txt", col_names = "word", show_col_types = FALSE) %>%
  mutate(Sentimiento = "Positivo")

negative_words <- read_csv("negative_words_es.txt", col_names = "word", show_col_types = FALSE) %>%
  mutate(Sentimiento = "Negativo")

# Unir ambos diccionarios
sentiment_words <- bind_rows(positive_words, negative_words)

Como primer acercamiento a la caracterización sentimental del texto, se muestra la nube de palabras positivas vs negativas presentes en todo el libro.

library(reshape2)

set.seed(123)

tokens_novela %>%
  inner_join(sentiment_words, by = "word") %>%
  filter(Sentimiento %in% c("Positivo", "Negativo")) %>%
  count(word, Sentimiento, sort = TRUE) %>%
  acast(word ~ Sentimiento, value.var = "n", fill = 0) %>%
  comparison.cloud(
    colors = brewer.pal(8, "Dark2")[c(2, 5)],
    max.words = 60,
    scale = c(3, 0.8),
    title.size = 1.2
  )

La visualización de la nube de palabras nos muestra un aparente equilibrio entre positividad y negatividad. Eso sugiere que emocionalmente la novela está construida sobre una tensión constante entre pérdida y deseo, entre destrucción y persistencia.

La palabra más dominante del lado negativo es claramente “muerte”, acompañada de morir, perder, abandonar, soledad, triste, llorar. Esto encaja con la estructura de la novela, ya que hay varios fallecimientos a lo largo de las generaciones, violencia política y conflictos bélicos. De este modo, se cuenta con evidencia cuantitativa de que la novela está atravesada por una sensibilidad trágica.

Por el otro lado, tenemos las palabras positivas: “pasar” aparece como la más grande ya que no se trata de “pasar” como acción cotidiana, sino del paso del tiempo y el transcurrir de generaciones, eje principal de la historia de la familia Buendía. En este mismo polo, una de las palabras más visibles es “amor”, casi como si esta estuviese enfrentándose con la muerte en la historia. ¿Pero, por qué el amor no aparece con tanta fuerza como la muerte? Porque en la novela de García Márquez el amor no siempre resuelve los conflictos, sino que los intensifica.

# Total de tokens por capítulo
totales_cap <- tokens_novela %>%
  count(capitulo, name = "n_total")

# Conteo emocional
sent_cap <- tokens_novela %>%
  inner_join(sentiment_words, by = "word") %>%
  count(capitulo, Sentimiento) %>%
  pivot_wider(names_from = Sentimiento,
              values_from = n,
              values_fill = 0) %>%
  left_join(totales_cap, by = "capitulo") %>%
  mutate(
    neto = Positivo - Negativo,
    score_neto = neto / n_total * 100,
    tasa_positivo = Positivo / n_total * 100,
    tasa_negativo = Negativo / n_total * 100,
    prop_positivo = Positivo / (Positivo + Negativo),
    prop_negativo = Negativo / (Positivo + Negativo)
  ) %>%
  arrange(capitulo)
p1 <- sent_cap %>%
  select(capitulo, prop_positivo, prop_negativo) %>%
  pivot_longer(cols = starts_with("prop_"),
               names_to = "tipo",
               values_to = "proporcion") %>%
  mutate(
    tipo = recode(tipo, "prop_positivo" = "Positivo", "prop_negativo" = "Negativo")
  ) %>%
  ggplot(aes(x = factor(capitulo),
             y = proporcion,
             fill = tipo)) +
  geom_col(position = "fill") +
  geom_hline(yintercept = 0.5,
             linetype = "dashed",
             color = "grey20",
             linewidth = 0.8) +
  scale_y_continuous(labels = percent_format()) +
  labs(title = "Distribución emocional por capítulo",
       x = "Capítulo",
       y = "Proporción",
       fill = NULL) +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))

p2 <- sent_cap %>%
  ggplot(aes(x = factor(capitulo),
             y = score_neto,
             fill = score_neto >= 0)) +
  geom_col(width = 0.75) +
  geom_hline(yintercept = 0,
             linetype = "dashed",
             color = "grey20") +
  scale_fill_manual(
    values = c("FALSE" = "#F8766D",
               "TRUE" = "#00BFC4"),
    guide = "none") +
  labs(title = "Sentimiento neto por capítulo",
       subtitle = "(positivas − negativas) / total de tokens × 100",
       x = "Capítulo",
       y = "Score neto (%)") +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))

p3 <- sent_cap %>%
  select(capitulo, tasa_positivo, tasa_negativo) %>%
  pivot_longer(cols = c(tasa_positivo, tasa_negativo),
               names_to = "tipo",
               values_to = "tasa") %>%
  mutate(tipo = recode(tipo, "tasa_positivo" = "Positividad", "tasa_negativo" = "Negatividad")) %>%
  ggplot(aes(x = factor(capitulo),
             y = tasa,
             color = tipo,
             group = tipo)) +
  geom_line(linewidth = 1.1) +
  geom_point(size = 2.5) +
  labs(title = "Tasas de positividad y negatividad por capítulo",
       x = "Capítulo",
       y = "% sobre total de tokens",
       color = NULL) +
  theme_minimal() +
  theme(
    legend.position = "top",
    axis.text.x = element_text(angle = 45, hjust = 1)
  )

(p2 | p3) /
 ((plot_spacer() | p1 | plot_spacer()) +
   plot_layout(widths = c(0.3, 1, 0.3)))

La distribución emocional por capítulo deja ver que todos los capítulos de la novela tienen una mayor carga emocional negativa que positiva, aunque las diferencias entre ambas partes no alcanzan valores extremos. El gráfico superior izquierdo correspondiente al Sentimiento neto por capítulo nos deja ver la proporción de (positivas - negativas)/total_tokens, gracias a este podemos ver cuál es el balance emocional global del capítulo considerando su longitud. En nuestro caso, son los capítulos 7 y 10 aquellos en los que se está más cerca de un equilibrio emocional. El hecho de que esta gráfica no muestre alguna tendencia sostenida creciente o decreciente a medida que avanza la novela nos dice que existen ciclos emocionales repetidos en esta, esto es: mucha violencia/tristeza seguida de momentos más conciliadores y amorosos.

Obsérvese como resalta el sentimiento neto del capítulo 6, dominado por las palabras negativas. Teniendo en cuenta que este es el capítulo en el que el coronel Aureliano Buendía se va a la guerra y deja a su sobrino Arcadio al mando de Macondo, quien instaura una cruel dictadura militar, entendemos por qué la distribución de sntimientos en este caso.

Complementariamente, el gráfico de tasas de positividad y negatividad nos muestra que tan cargado emocionalmente está cada capítulo. Hay una alta densidad de léxico negativo el cual, a pesar de superar al positivo, no supera el 15% del total de tokens por capítulo. Que ambas tasas sumadas no lleguen al 50% nos habla de una obra más descriptiva y narrativa.

Análisis de bigramas/skipgramas

Bigramas

crear_bigramas_robustos <- function(df, stop_words_df, replacement_list) {
  
  bigramas <- df %>%
    # Normalización estructural (minúsculas, acentos, símbolos)
    mutate(word = str_to_lower(word)) %>%
    mutate(word = str_replace_all(word, "[[:punct:]]", "")) %>%
    filter(!str_detect(word, "[0-9]")) %>%
    filter(word != "") %>%
    mutate(word = chartr(
        old = paste(names(replacement_list), collapse = ""),
        new = paste(replacement_list, collapse = ""),
        x = word)) %>%
    
    mutate(
      word = case_when(word %in% c("xv","xvi","xvii", "xviii") ~ NA_character_,
                       TRUE ~ word) ) %>%
    filter(!is.na(word), word != "") %>%
    
    # Construcción del bigrama
    group_by(capitulo) %>% # No queremos formar parejas entre palabras de capitulos distintos
    mutate(word2 = lead(word)) %>%
    ungroup() %>%
    rename(word1 = word) %>%
    filter(!is.na(word2)) %>%
    
    # Eliminar stop_words
    filter(!word1 %in% stop_words_df$word) %>%
    filter(!word2 %in% stop_words_df$word) %>%
    
    # 4. Agregación y conteo
    count(capitulo, word1, word2, sort = TRUE) %>%
    rename(weight = n)
  
  return(bigramas)
}

bigramas_novela <- crear_bigramas_robustos(tokens_novela_lema, 
                                           stop_words_df = stop_words_es, replacement_list = replacement_list)

dim(bigramas_novela)
## [1] 14001     4
head(bigramas_novela)
## # A tibble: 6 × 4
##   capitulo word1     word2     weight
##   <fct>    <chr>     <chr>      <int>
## 1 Cap_2    jose      arcadio       50
## 2 Cap_9    aureliano buendia       44
## 3 Cap_9    coronel   aureliano     44
## 4 Cap_3    jose      arcadio       42
## 5 Cap_3    arcadio   buendia       39
## 6 Cap_1    jose      arcadio       38

Los bigramas más frecuentes en el texto son ‘jose arcadio’, ‘aureliano buendia’ y ‘coronel aureliano’; los cuales claramente hacen referencia a nombres compuestos de los protagonistas de la novela.

Skipgramas

crear_skipgramas_robustos <- function(df, stop_words_df, replacement_list, k = 2){

  tokens <- df %>%
    mutate(word = str_to_lower(word)) %>%
    mutate(word = str_replace_all(word, "[[:punct:]]", "")) %>%
    filter(!str_detect(word, "[0-9]")) %>%
    filter(word != "") %>%
    mutate(
      word = chartr(
        old = paste(names(replacement_list), collapse = ""),
        new = paste(replacement_list, collapse = ""),
        x = word)
    ) %>%
    mutate(
      word = case_when(word %in% c("xv","xvi","xvii","xviii") ~ NA_character_,
                       TRUE ~ word)
    ) %>%
    filter(!is.na(word)) %>%
    group_by(capitulo) %>%
    mutate(pos = row_number()) %>%
    ungroup()

  purrr::map_dfr(1:(k + 1), function(i){

    tokens %>%
      group_by(capitulo) %>%
      mutate(word2 = lead(word, i)) %>%
      ungroup() %>%
      transmute(capitulo,
                word1 = word,
                word2) %>%
      filter(!is.na(word2)) %>%
      filter(!word1 %in% stop_words_df$word) %>%
      filter(!word2 %in% stop_words_df$word)

  }) %>%
    count(capitulo, word1, word2, sort = TRUE) %>%
    rename(weight = n)
}

skipgramas_novela <- crear_skipgramas_robustos(tokens_novela_lema, k = 1,
                                               stop_words_df = stop_words_es, 
                                               replacement_list = replacement_list)

# 35.873
dim(skipgramas_novela)
## [1] 35873     4
head(skipgramas_novela)
## # A tibble: 6 × 4
##   capitulo word1     word2     weight
##   <fct>    <chr>     <chr>      <int>
## 1 Cap_2    jose      arcadio       50
## 2 Cap_9    aureliano buendia       44
## 3 Cap_9    coronel   aureliano     44
## 4 Cap_9    coronel   buendia       44
## 5 Cap_3    jose      arcadio       42
## 6 Cap_3    arcadio   buendia       39

Por su parte, los skipgramas construidos a partir de palabras no consecutivas (que se saltan una palabra intermedia) resultan en 35.873 tokens después del pre-procesamiento. De estos, los más frecuentes son, nuevamente, nombres compuestos de los personajes: ‘jose arcadio’, ‘aureliano buendia’, ‘coronel aureliano’ y ‘coronel buendia’.

Redes léxicas

A continuación, se construyen las redes para cada capítulo a partir de los skipgramas construidos. En este paso es habitual establecer un umbral de peso mínimo para que la red no se sature de palabras que pueden generar ruido en el análisis. No obstante, las palabras que solo tienen weight=1 corresponden al 96.97% de las palabras totales. Es decir, que si establecemos un umbral de peso mayor a 1, resultamos solamente con el 3.02% de la información total, una cantidad sumamente pequeña.

Para no dejar nada por fuera, se harán análisis de los dos tipos de grafos: sin umbral y con umbral=1.

redes_gigantes <- skipgramas_novela %>%
  split(.$capitulo) %>%
  map(~ crear_red(.x, umbral = 0))

redes_gigantes_1 <- skipgramas_novela %>%
  split(.$capitulo) %>%
  map(~ crear_red(.x, umbral = 1))
par(mfrow = c(1, 2))
set.seed(123)
ggraph(redes_gigantes[[1]], layout = "fr") + # graphopt
  geom_edge_link(aes(width = weight),
                 alpha = 0.3, 
                 color = "gray60") +
  geom_node_point(size = 2,
                  color = "steelblue") +
  geom_node_text(aes(label = name),
                 repel = TRUE,
                 size = 3) +
  scale_edge_width(range = c(1, 4), guide = "none") +
  theme_void() +
  labs(
    title = "Componente gigante Red de skipgramas: 1er capítulo de la novela",
    subtitle = "Sin umbral"
  )

set.seed(123)
ggraph(redes_gigantes_1[[1]], layout = "fr") + # graphopt
  geom_edge_link(aes(width = weight),
                 alpha = 0.3, 
                 color = "gray60") +
  geom_node_point(size = 2,
                  color = "steelblue") +
  geom_node_text(aes(label = name),
                 repel = TRUE,
                 size = 3) +
  scale_edge_width(range = c(1, 4), guide = "none") +
  theme_void() +
  labs(
    title = "Componente gigante Red de skipgramas: 1er capítulo de la novela",
    subtitle = "Umbral = 1"
  )

tabla_metricas_gc <- imap_dfr(
  redes_gigantes,
  ~ metricas_red(.x) %>%
    mutate(capitulo = .y)
)

tabla_metricas_gc_1 <- imap_dfr(
  redes_gigantes_1,
  ~ metricas_red(.x) %>%
    mutate(capitulo = .y)
)

# Tablas bonitas u.u
tabla_metricas_gc %>% 
  kable(caption = "Metricas de la componente gigante por capitulo", digits = 3, align = "c") %>% 
  kable_styling(full_width = FALSE,
                bootstrap_options = c("striped", "hover", "condensed")
  )
Metricas de la componente gigante por capitulo
Nodos Enlaces Densidad Transitividad Grado_medio Grado_desviacion Distancia_media Asortatividad capitulo
1080 1533 0.003 0.059 2.839 3.693 6.343 -0.058 Cap_1
973 1429 0.003 0.062 2.937 4.265 5.795 -0.014 Cap_2
1246 1893 0.002 0.062 3.039 4.038 6.024 -0.022 Cap_3
1245 1879 0.002 0.058 3.018 4.141 5.860 -0.022 Cap_4
1374 2088 0.002 0.062 3.039 4.021 5.956 -0.008 Cap_5
1083 1530 0.003 0.055 2.825 4.028 6.273 -0.025 Cap_6
1097 1671 0.003 0.064 3.046 3.944 5.877 0.019 Cap_7
1068 1569 0.003 0.058 2.938 4.155 5.946 -0.042 Cap_8
1131 1582 0.002 0.056 2.798 3.718 6.262 -0.010 Cap_9
1160 1608 0.002 0.055 2.772 3.725 6.396 -0.047 Cap_10
1192 1685 0.002 0.062 2.827 3.667 6.293 -0.024 Cap_11
1170 1601 0.002 0.063 2.737 3.284 6.644 -0.003 Cap_12
1104 1569 0.003 0.054 2.842 3.813 5.911 -0.041 Cap_13
1158 1674 0.002 0.037 2.891 4.749 5.582 -0.070 Cap_14
1132 1589 0.002 0.063 2.807 3.217 6.396 -0.026 Cap_15
1025 1311 0.002 0.063 2.558 3.166 7.312 -0.029 Cap_16
1228 1679 0.002 0.054 2.735 3.627 6.358 -0.023 Cap_17
1113 1557 0.003 0.052 2.798 3.919 6.068 0.011 Cap_18
1297 1752 0.002 0.050 2.702 3.939 6.308 -0.033 Cap_19
1083 1429 0.002 0.048 2.639 3.557 6.639 -0.035 Cap_20 
tabla_metricas_gc_1 %>% 
  kable(caption = "Metricas de la componente gigante por capitulo (segunda red)", digits = 3, align = "c") %>% 
  kable_styling(full_width = FALSE,
                bootstrap_options = c("striped", "hover", "condensed")
  )
Metricas de la componente gigante por capitulo (segunda red)
Nodos Enlaces Densidad Transitividad Grado_medio Grado_desviacion Distancia_media Asortatividad capitulo
12 15 0.227 0.279 2.500 1.931 10.894 -0.394 Cap_1
25 26 0.087 0.118 2.080 1.382 18.587 -0.357 Cap_2
7 7 0.333 0.250 2.000 1.291 32.286 -0.485 Cap_3
11 12 0.218 0.158 2.182 1.537 14.945 -0.422 Cap_4
18 19 0.124 0.182 2.111 1.183 12.876 -0.246 Cap_5
15 17 0.162 0.161 2.267 2.219 10.000 -0.734 Cap_6
14 18 0.198 0.316 2.571 1.399 23.813 -0.139 Cap_7
23 29 0.115 0.333 2.522 1.592 34.561 -0.232 Cap_8
12 14 0.212 0.243 2.333 1.826 35.985 -0.509 Cap_9
12 15 0.227 0.300 2.500 1.784 8.258 -0.500 Cap_10
13 15 0.192 0.310 2.308 1.251 6.487 -0.379 Cap_11
15 17 0.162 0.191 2.267 1.907 14.248 -0.455 Cap_12
18 20 0.131 0.205 2.222 1.517 13.333 -0.291 Cap_13
29 31 0.076 0.136 2.138 1.481 10.771 -0.256 Cap_14
8 10 0.357 0.500 2.500 0.926 8.714 -0.364 Cap_15
13 15 0.192 0.265 2.308 1.548 8.397 -0.320 Cap_16
14 16 0.176 0.150 2.286 1.939 7.473 -0.566 Cap_17
19 22 0.129 0.138 2.316 2.540 5.415 -0.496 Cap_18
12 14 0.212 0.391 2.333 0.888 8.970 -0.085 Cap_19
13 13 0.167 0.086 2.000 1.915 18.974 -0.566 Cap_20 
tabla_metricas_gc %>% 
  mutate(
    capitulo_num = readr::parse_number(capitulo),
    capitulo = factor(capitulo,
                      levels = paste0("Cap_", sort(unique(capitulo_num))))
  ) %>% 
  pivot_longer(
    cols = -c(capitulo, capitulo_num),
    names_to = "metrica",
    values_to = "valor"
  ) %>% 
  ggplot(aes(x = capitulo, y = valor, group = 1)) +
  geom_line(color = "#2E4057", linewidth = 0.8) +
  geom_point(color = "#2E4057", size = 2) +
  facet_wrap(~ metrica, scales = "free_y", ncol = 2) +
  labs(
    title = "Evolucion de metricas de la componente gigante por capitulo (Sin umbral)",
    x = "Capitulo",
    y = NULL
  ) +
  theme_minimal() +
  theme(
    strip.text = element_text(face = "bold"),
    axis.text.x = element_text(angle = 45, hjust = 1)
  )

En 18 de 20 capítulos las palabras tienden a relacionarse con otras que tengan número de conexiones diferente de ellas. La excepción a esta afirmación son los capítulos 7 y 18.

A medida que avanza la novela, parece ser que las redes de palabras se van volviendo menos densas. Esto es que se van formando menos conexiones entre palabras respecto de todas las posibles que estas podrían generar.

La distancia geodésica promedio tiene un comportamiento oscilante a lo largo de la obra. Esta se mueve entre valores de 5.5 y 7.5 aproximadamente, notando que aunque las redes tienen una alta cantidad de nodos, no están tan distanciados entre sí.

Los grados medios de los capítulos se ubican entre 2.6 y 3.1 aproximadamente. En promedio, las palabras de los capítulos 3, 4, 5 y 7 están más conectadas que las provenientes de los últimos capítulos de la novela. En cuanto a la desviación estándar del grado, esta presenta un comportamiento opuesto. A medida que avanza la novela, el número de conexiones entre las palabras se va volviendo más homogéneo, a excepción del capítulo 14, en el que la desviación estándar alcanza su pico más alto.

El número de nodos y número de enlaces se comportan de firma similar. El segundo capítulo es el que cuenta con una red más pequeña, pasando a las redes de los capítulos 3, 4 y 5 que son las más grandes. En la parte ‘central’ de la novela, las redes no varían mucho su tamaño.

Finalmente, la transitividad de las redes de skipgramas de los capítulos toma valores pequeños (0.04-0.065). Resalta el capítulo 14, en el que la red presenta la menor transitividad del texto, por una amplia diferencia.

tabla_metricas_gc_1 %>% 
  mutate(
    capitulo_num = readr::parse_number(capitulo),
    capitulo = factor(capitulo,
                      levels = paste0("Cap_", sort(unique(capitulo_num))))
  ) %>% 
  pivot_longer(
    cols = -c(capitulo, capitulo_num),
    names_to = "metrica",
    values_to = "valor"
  ) %>% 
  ggplot(aes(x = capitulo, y = valor, group = 1)) +
  geom_line(color = "#2E4057", linewidth = 0.8) +
  geom_point(color = "#2E4057", size = 2) +
  facet_wrap(~ metrica, scales = "free_y", ncol = 2) +
  labs(
    title = "Evolucion de metricas de la componente gigante por capitulo (Umbral = 1)",
    x = "Capitulo",
    y = NULL
  ) +
  theme_minimal() +
  theme(
    strip.text = element_text(face = "bold"),
    axis.text.x = element_text(angle = 45, hjust = 1)
  )

Primero, note que el comportamiento de las métricas de las redes que si tienen un umbral difiere considerablemente de las redes que no contaron con un umbral para el peso de las palabras en su construcción. En estas redes, todos los capítulos tienen asortatividades menores a cero, es decir, no hay homofilia ya que las palabras se conectan con otras de grados distintos.

Naturalmente, observamos densidades mayores ya que tenemos redes mucho más pequeñas. Resaltan los capítulos 3 y 15 por ser los más densos. El distanciamiento medio que tienen las palabras alcanza valores altos para los capítulos 3, 8 y 9, a partir de los cuales se tienen distancias pequeñas que disminuyen a medida que la obra se acerca al capítulo 18. Los grados medios tienen un comportamiento oscilante a lo largo de la novela, parece ser que después de capítulos en los que sus palabras tenían varias conexiones, sigue otro en el que esta cantidad baja. Por su parte, los capítulos 2 y 14 son los que cuentan con redes léxicas más grandes en términos de orden y tamaño de grafo. Finalmente, estas redes son más transitivas que las presentadas en las visualizaciones anteriores; dejando ver que el texto de García Márquez parece volverse más transitivo a medida que avanzan los capítulos.

centralidades_gc <- imap_dfr(redes_gigantes, function(g, cap){

  tibble(palabra = V(g)$name,
         grado = degree(g),
         intermediacion = betweenness(g),
         cercania = closeness(g),
         eigen = eigen_centrality(g)$vector,
         capitulo = cap) 
})

top_palabras_gc <- centralidades_gc %>%
  mutate(
    cap_num = readr::parse_number(capitulo)
  ) %>%
  arrange(cap_num) %>%
  mutate(
    capitulo = factor(capitulo,
                      levels = unique(capitulo))
  ) %>%
  group_by(capitulo) %>%
  slice_max(eigen, n = 3) %>%
  ungroup() %>%
  select(-cap_num)
top_palabras_gc
## # A tibble: 60 × 6
##    palabra grado intermediacion cercania eigen capitulo
##    <chr>   <dbl>          <dbl>    <dbl> <dbl> <fct>   
##  1 arcadio    43         61445. 0.000219 1     Cap_1   
##  2 jose       41         51716. 0.000210 0.989 Cap_1   
##  3 buendia    35         58861. 0.000219 0.973 Cap_1   
##  4 arcadio    62         85767. 0.000294 1     Cap_2   
##  5 jose       55         81574. 0.000287 0.997 Cap_2   
##  6 buendia    25         30630. 0.000240 0.770 Cap_2   
##  7 arcadio    50         78399. 0.000207 1     Cap_3   
##  8 jose       46         65535. 0.000205 0.982 Cap_3   
##  9 buendia    25         42954. 0.000195 0.953 Cap_3   
## 10 arcadio    44         91017. 0.000220 1     Cap_4   
## # ℹ 50 more rows

Los resultados de centralidad propia muestran una evolución del núcleo narrativo a lo largo de la novela. Hasta el capítulo 6, las palabras más centrales son “José”, “Arcadio” y “Buendía”, indicando que la red semántica se organiza alrededor de este eprsonaje como eje del relato. Dado que la centralidad propia identifica nodos importantes por estar conectados con otros nodos también importantes, esto concuerda con que el inicio de la novela está estructurado en torno al origen de la familia Buendía y la fundación de Macondo.

Entre los capítulos 7 y 13 se observa un desplazamiento hacia “coronel”, “Aureliano” y “Buendía”, reflejando el cambio de protagonismo desde José Arcadio hacia el Coronel Aureliano. Esto sugiere que, aunque cambia el personaje dominante, el linaje continúa siendo el eje estructural de la narración.

Desde el capítulo 14 la centralidad se distribuye de forma más variable entre distintos nombres y términos como “Babilonia”, “Mauricio”, “hijo”, “Amaranta” y “Úrsula”. Esta diversificación puede interpretarse como el paso hacia nuevas generaciones y una narrativa menos concentrada en un único personaje. La aparición de palabras asociadas al parentesco y la continuidad familiar refuerza la importancia de la genealogía como principio organizador del relato.

En los últimos capítulos destacan especialmente “Amaranta”, Úrsula y “Aureliano”, lo que sugiere un cierre narrativo centrado en la memoria, la herencia familiar y la permanencia del linaje. En conjunto, los resultados muestran que la estructura de la red acompaña la evolución de la novela: pasa del fundador al coronel, luego se expande hacia nuevas generaciones y finalmente converge en los temas de repetición, memoria y destino familiar.

Redes de personajes

Para finalizar este apartado, se construye una red de co-ocurrencias de los personajes. Acá, \(y_{i,j}=0\) si dos personajes no aparecen en un mismo capítulo juntos. Por construcción esta red es ponderada y no dirigida.

Este grafo nos permitirá identificar cuales personajes principales son mencionados en más capítulos, así como las co-ocurrencias de estos a lo largo de la novela.

library(widyr)
library(stringi)

# Personajes a evaluar
diccionario <- c(
  "jose_arcadio_buendia" = "Jose Arcadio Buendia",
  "coronel_aureliano_buendia" = "Coronel Aureliano Buendia",
  "mauricio_babilonia" = "Mauricio Babilonia",
  "prudencio_aguilar" = "Prudencio Aguilar",
  "pilar_ternera" = "Pilar Ternera",
  "amaranta_ursula" = "Amaranta Ursula",
  "jose_arcadio" = "Jose Arcadio",
  "aureliano" = "Aureliano",
  "arcadio" = "Arcadio",
  "ursula" = "Ursula",
  "amaranta" = "Amaranta",
  "rebeca" = "Rebeca",
  "remedios" = "Remedios",
  "melquiades" = "Melquiades")
diccionario <- diccionario[
  order(nchar(diccionario), decreasing = TRUE)]

text_personajes <- text_personajes %>%
  mutate(
    texto_original = texto,
    texto = stri_trans_general(texto, "Latin-ASCII")
  )

# Obtener a los personajes dentro del texto original
text_personajes <- text_personajes %>%
  mutate(
    texto = map_chr(texto, function(x){

      for(i in seq_along(diccionario)){
        patron <- paste0("\\b", diccionario[i], "\\b")
        reemplazo <- names(diccionario)[i]
        x <- str_replace_all(x, regex(patron, ignore_case = TRUE), reemplazo)
      }
      x
    })
  )

# Tokens
tokens_personajes <- text_personajes %>%
  unnest_tokens(word, texto, token = "words"
  )
tokens_personajes <- tokens_personajes %>%
  filter(word %in% names(diccionario))
# Co-ocurrencias entre personajes
cooc_personajes <- tokens_personajes %>%
  pairwise_count(word, capitulo, sort = TRUE) %>% 
  mutate(weight = n) %>% 
  select(-n)

cooc_personajes <- cooc_personajes %>%
  mutate(item1 = pmin(item1, item2),
         item2 = pmax(item1, item2)) %>%
  distinct(item1, item2, .keep_all = TRUE) %>%
  filter(item1 != item2)

head(cooc_personajes)
## # A tibble: 6 × 3
##   item1                     item2                     weight
##   <chr>                     <chr>                      <dbl>
## 1 aureliano                 ursula                        20
## 2 aureliano                 coronel_aureliano_buendia     18
## 3 coronel_aureliano_buendia ursula                        18
## 4 jose_arcadio              ursula                        18
## 5 amaranta                  ursula                        18
## 6 amaranta                  aureliano                     18
# Res de personajes
g_personajes <- graph_from_data_frame(cooc_personajes, directed = FALSE)
V(g_personajes)$strength <- strength(g_personajes)

Observe que Aureliano y Úrsula son los únicos dos personajes que aparecen en todos los capítulos, esto es, que su participación a lo largo de la obra es constante. Amaranta, el coronel Aureliano Buendía y José Arcadio son los siguientes nombres en la lista, apareciendo durante 18 de los 20 capítulos de la novela.

set.seed(123)
ggraph(g_personajes, layout = "graphopt") + #graphopt

  geom_edge_link(aes(width = weight),
                 alpha = 0.5,
                 colour = "grey60") +
  geom_node_point(aes(size = strength),
                  colour = "purple",
                  alpha = 0.7) +
  geom_node_text(aes(label = name),
                 repel = TRUE,
                 point.padding = unit(1, "lines"),
                 box.padding = unit(0.5, "lines") ) +
  scale_edge_width(range = c(1, 4), guide = "none") +
  scale_size(range = c(2, 10), guide = "none") +
  theme_void() +

  labs(
    title = "Red de coocurrencia entre personajes de la novela"
  )

La visualización de la red nos muestra que los personajes de primera y segunda generación (Úrsula, Jose Arcadio Buendía y sus hijos), junto con personas fuera de la familia relevantes para la historia (Pilar y Melquiades) son los que más fuerza tienen.

Análisis de tópicos LDA

El Latent Dirichlet Allocation (LDA) es un modelo probabilístico generativo que asume que cada documento es una mezcla de tópicos y cada tópico es una mezcla de palabras. Este método para estima ambos al mismo tiempo: encuentra la mezcla de palabras que está asociada con cada tema, mientras que también determina la mezcla de temas que describe cada documento. Aplicado a una novela, cada capítulo es un documento y los tópicos corresponden a características temáticas latentes en el texto.

Nota: Antes de empezar con el análisis, se hace una claridad. En las primeras corridas del modelo, los nombres de los personajes principales estaban en todos los temas encontrados, esto es, el modelo no estaba realmente identificando una clasificación de temas por esas palabras casi totalmente constantes a lo largo de toda la novela. Es por esto que se toma la decisión (espero que haya sido la correcta :b) de NO tener en cuenta estos tokens junto con otros que también fueron considerados como ruidosos en el análisis.

library(topicmodels)

# Tokens a quitar antes de hacer el análisis
quitar <- c("aureliano", "arcadio", "ursula", "amaranta", "jose", "fernanda", "casa", "coronel", "rebeca", "petra", 
            "dia", "buendia", "marquez",
            # Verbos de movimiento y estado — aparecen en todos los tópicos
            "volver", "llegar", "encontrar", "pasar", "quedar",  
            # Otras palabras que no aportan
            "año", "hora",
            "hombre", "mujer", "tu"
            )


tokens_sin_personajes <- tokens_novela %>%
  filter(!word %in% quitar)

# Obtener la Document Term Matrix
dtm_novela <- tokens_sin_personajes %>%
  count(capitulo, word) %>%
  cast_dtm(capitulo, word, n) 
print(dtm_novela)
## <<DocumentTermMatrix (documents: 20, terms: 9855)>>
## Non-/sparse entries: 31127/165973
## Sparsity           : 84%
## Maximal term length: 18
## Weighting          : term frequency (tf)

Con los datos en el formato adecuado para ser trabajados con tidy, se procede aplicar el modelo. Como mencionan Silge & Robinson (2017) en su libro, LDA es un método de clasificación no supervisada, por lo que nos enfrentamos al dilema estrella de este tipo de modelos: cuál \(k\) escoger? Después de haber probado \(k = 4, 5, 6\), en el presente trabajo se opta por \(k=6\) ya que este genera una mejor diferenciación de los temas construidos, son más identificables.

set.seed(1234)
k <- 6
lda_novela <- LDA(dtm_novela, k = k, control = list(seed = 1234, alpha = 1))
lda_novela
## A LDA_VEM topic model with 6 topics.

Ahora, veamos las probabilidades palabra-tema denominadas \(\beta\) en el modelo.

temas_capitulos <- tidy(lda_novela, matrix = "beta")
temas_capitulos
## # A tibble: 59,130 × 3
##    topic term           beta
##    <int> <chr>         <dbl>
##  1     1 abandonado 4.30e- 4
##  2     2 abandonado 1.26e- 4
##  3     3 abandonado 7.08e- 5
##  4     4 abandonado 3.78e- 4
##  5     5 abandonado 6.06e-47
##  6     6 abandonado 2.67e- 4
##  7     1 abandonar  1.01e- 3
##  8     2 abandonar  1.77e- 3
##  9     3 abandonar  1.68e- 3
## 10     4 abandonar  6.30e- 4
## # ℹ 59,120 more rows
top_terms <- temas_capitulos %>%
  group_by(topic) %>%
  slice_max(beta, n = 15) %>% 
  ungroup() %>%
  arrange(topic, -beta)

top_terms
## # A tibble: 95 × 3
##    topic term          beta
##    <int> <chr>        <dbl>
##  1     1 noche      0.00546
##  2     1 macondo    0.00437
##  3     1 melquiades 0.00413
##  4     1 pueblo     0.00404
##  5     1 padre      0.00403
##  6     1 gitano     0.00401
##  7     1 cosa       0.00394
##  8     1 mundo      0.00353
##  9     1 vida       0.00314
## 10     1 contar     0.00306
## # ℹ 85 more rows

Vemos, por ejemplo, que la palabra ‘abandonado’ tiene una probabilidad de \(4.298\times 10^{-4}\) de pertenecer al tópico 1, pero una probabilidad de \(6.059\times 10^{-47}\) de pertenecer al tópico 5.

top_terms %>%
  mutate(term = reorder_within(term, beta, topic)) %>%
  ggplot(aes(beta, term, fill = factor(topic))) +
  geom_col(show.legend = FALSE) +
  facet_wrap(~ topic, scales = "free") +
  scale_y_reordered() +
  labs(
    title    = "Top 15 palabras por tópico — probabilidades β",
    subtitle = "β = P(palabra | tema). Modelo LDA con K = 6",
    x        = "β", y = NULL
  ) +
 theme_gray(base_size = 11)

  • Tópico 1: Fundación de macondo y los gitanos

    Este es uno de los tópicos más distinguibles. “aldea” es la palabra más específica de los primeros capítulos, ya que a Macondo se le dice aldea al principio de la obra. “gitano” y “melquiades” anclan este periodo a una etapa temprana también. Por último, “contar” evoca la dimensión profética y narrativa de los manuscritos. Podemos suponer que este tema abarca los capítulos I–IV con precisión.

  • Tópico 2: Segunda generación y problemas familiares

    La palabra “cotes” viene de Petra Cotes, amante de Aureliano Segundo, por lo cual anclamos este tema en la segunda generación de la familia Buendía. “morir”, “vida” y “familia” reflejan los conflictos que se estsban desarrollando en este periodo, llevando a la familia a un periodo de lento declive. Finalmente, “mandar” habla de lñas disputas por autoridad en la casa. Este tema captura aproximadamente los capítulos X–XIV.

  • Tópico 3: Guerras civiles y política

    “guerra” domina con el \(\beta\) más alto. Pietro Crespi, el italiano que corteja a Rebeca y Amaranta, también es clave en este tema ya que es un personaje que aparece en los capítulos bisagra donde empieza la guerra. “liberal” y “general” sitúan claramente en el contexto político-militar del conflicto entre liberales y conservadores en el que el Coronel Aureliano Buendía se involucra. Este tema se puede situar dentro de los capítulos VI-VIII.

  • Tópico 4: Historia de Meme y Mauricio Babilonia

    “meme”, “maurico” y “babilonia” hablan de los personajes Renata Remedios (Meme) y Mauricio Babilonia, personajes de la quinta generación de la familia Buendía quienes viven una trágica historia de amor. “guerra” y “muerte” son palabras protagonistas también por los echos que transcurren en este periodo y los ecos de la violencia pasada. Este tema captura los capítulos XIII-XV.

  • Tópico 5: Generación final y Gastón

    “gaston”, el marido belga de Amaranta Úrsula aparece por un corto periodo solo en los capítulos finales de la novela. “carta” puede hacer referencia a la correspondencia que Gastón espera de sus socios de Bruselas. Así mismo, sabemos que Melquiades reaparece en el texto en estas partes finales cuando Aureliano descrifa los manuscritos, por eso vemos “melquiades” en este tópico. Este tema captura los capítulos XVIII–XX.

  • Tópico 6: La lluvia y el encierro

    La palabra “lluvia” ancla este tema en torno al diluvio de cuatro años ocurrido en Macondo. El vocabulario del espacio físico cerrado (“dormitorio”, “cuarto”, “calle”, “comer”) refleja este encierro. Es el tópico más difuso de los seis, pero la lluvia le da suficiente identificaión. Se cree que abarca los capítulos XV-XVII.

Además de estimar cada tema como una mezcla de palabras, LDA también modela cada documento como una mezcla de temas. Podemos examinar las probabilidades por documento y tema, denominadas \(\gamma\).

capitulos_gamma <- tidy(lda_novela, matrix = "gamma")
capitulos_gamma
## # A tibble: 120 × 3
##    document topic      gamma
##    <chr>    <int>      <dbl>
##  1 Cap_1        1 1.000     
##  2 Cap_2        1 1.000     
##  3 Cap_3        1 1.000     
##  4 Cap_4        1 0.00000517
##  5 Cap_5        1 0.00000453
##  6 Cap_6        1 0.00000613
##  7 Cap_7        1 0.00000561
##  8 Cap_8        1 0.0214    
##  9 Cap_9        1 0.00000577
## 10 Cap_10       1 1.000     
## # ℹ 110 more rows
orden_capitulos <- paste0("Cap_", 1:20)

capitulos_gamma %>%
  mutate(
    topic_label = paste("Tópico", topic),
    document    = factor(document, levels = orden_capitulos)
  ) %>%
  ggplot(aes(x = document, y = gamma, fill = topic_label)) +
  geom_col(alpha = 0.9, width = 0.75) +
  scale_y_continuous(labels = scales::percent_format()) +
  labs(
    title    = "Distribución de tópicos por capítulo",
    subtitle = "Cada barra representa un capítulo y suma 100%",
    x        = "Capítulo",
    y        = "Proporción",
    color = "Tópico"
  ) +
  theme_minimal(base_size = 12) +
  theme(
    legend.position = "right",
    axis.text.x     = element_text(angle = 45, hjust = 1)
  )
## Ignoring unknown labels:
## • colour : "Tópico"

El gráfico nos deja ver algo muy particular. En este corpus (los tokens analizados) los capítulos se concentran en 1 o máximo 2 tópicos, lo que quiere decir que los capítulos estarían siendo temáticamente concentrados, bien delimitados. Cuando hay un cambio grande en la narrativa de la historia, como iniciar o acabar una guerra, este se genera entre capítulos, no dentro de ellos.

Adicionalmente, que casi todas las barras (que recordemos, reprsentan los \(\gamma\)) lleguen hasta arriba nos dice que con los tokens usados, el modelo está 100% de esa clasificación.

Punto 7

  1. Sintetizar y replicar el Capítulo 10 de Luke, D. A. (2015).

CAPÍTULO 10: Modelos aleatorios para redes

Modelos de estructura y formación de redes

El primer modelo para la estructura de redes fue el modelo de grafos aleatorios, aveces llamado modelo poisson de grafos aleatorios, por la distribución poisson del grado en estos casos. El modelo \(G(n, p)\) es bastante simple, en el que se tienen \(n\) nodos y \(p\) como probabilidad de observar una arista de forma aleatoria. Algunas de sus propiedades son:

  • Estar completamente conectados con un grado medio bajo

  • El diámetro que aumenta lentamente en relación al tamaño del grafo

Se verán más a profundidad a continuación.

# Aqeuí 10 hace referencia al número de aristas que se quieren
g <- sample_gnm(n = 12, 10)
g
## IGRAPH b19ae1c U--- 12 10 -- Erdos-Renyi (gnm) graph
## + attr: name (g/c), type (g/c), loops (g/l), m (g/n)
## + edges from b19ae1c:
##  [1] 2-- 3 1-- 5 1-- 6 3-- 6 2-- 7 1--11 7--11 9--11 3--12 9--12

La naturaleza aleatoria de estos grafos se puede observar en sus visualizaciones

op <- par(mar = c(0,1,3,1), mfrow = c(1,2))
plot(sample_gnm(n = 12, 10), vertex.color = 2, main="First random graph")
plot(sample_gnm(n = 12, 10), vertex.color = 4, main="Second random graph") 

par(op)

Una característica importante de este modelo es que produce redes cuya distribución del grado es de tipo Poisson, cuando \(n\) es grande

g <- sample_gnp(n = 1000, .005)
plot(degree_distribution(g), type = "b", xlab = "Degree", ylab = "Proportion")

Los grafos aleatorios se vuelven completamente conectados para valores bastante bajos de grado medio. Eso significa que incluso cuando las aristas se determinan aleatoriamente, cada vértice de la red no tiene que estar conectado a demasiados otros miembros para que la propia red esté conectada; lo que se traduce en que la red tenga una sola componente.

Así mismo, el grado promedio \(c\) de un grafo aleatorio está relacionado con el tamaño del grafo y la probabilidad de aristas \[c=(n-1)p\]

Esto significa que el grado promedio requerido para tener un grafo totalmente conectado será aproximadamente menor a 12 si se tienen entre 100 y 10.000 nodos.

Véase el siguiente ejemplo en el que simulan redes con $p=. Este nos deja ver que grafos aleatorios de 1000 nodos son casi o completamente conectados cuando el grado promedio es mayor a 4 o 5.

# grados promedios
crnd <- runif(500,1,8)
# Grafos creados con p = grado_medio/999
cmp_prp <- sapply(crnd,function(x) max(components(sample_gnp(n = 1000, p = x/999))$csize)/1000)

smoothingSpline <- smooth.spline(crnd,cmp_prp, spar=0.25)
plot(crnd,cmp_prp, col='grey60', xlab="Avg. Degree", ylab="Largest Component Proportion") 
lines(smoothingSpline,lwd=1.5)

Otra propiedad es que los grafos aleatorios conectados son bastante compactos. Es decir, el diámetro de los componentes más grandes en grafos aleatorios se mantiene relativamente pequeño incluso para redes grandes.

n_vect <- rep(c(50,100,500,1000,5000),each=50)
g_diam <- sapply(n_vect,function(x) diameter(sample_gnp(n=x, p=6/(x-1))))

library(lattice)
bwplot(g_diam ~ factor(n_vect), panel = panel.violin, xlab = "Network Size", ylab = "Diameter")

Como muestra el gráfico, aunque el tamaño de los gráficos aumenta en dos órdenes de magnitud, el diámetro del componente más grande en cada gráfico aumenta mucho más lentamente, de unos cinco a diez.

Finalmente, dadas las características mencionadas de este modelo, es evidente que no describe las propiedades de muchos conjuntos de redes de la vida real. Además, presentan valores bajos de transitividad.

Modelo Small-World

Este modelo produce redes aleatorias más realistas que las de Erdos-Rényi. Las redes small-world tienen niveles más realistas de transitividad junto con diámetros pequeños.

Este comienza con un círculo de nodos, donde cada nodo está conectado a sus vecinos inmediatos \(c\). Luego, un pequeño número de aristas existentes son re-conectadas, donde son eliminados y luego reemplazados con otro lazo que conecta dos nodos aleatorios. Si la probabilidad de recableado es 0, entonces se tiene la red original. Cuando \(p\) es 1, se tiene un grafo aleatorio de Erdos-Renyi. El principal descubrimiento de los autores es que solo una pequeña fracción de los lazos necesita ser re-conectada para reducir dramáticamente el diámetro de la red.

Se muestran varios modelos small-world con diferentes probabilidades de recableado \(p\)

g1 <- sample_smallworld(dim=1, size=30, nei=2, p=0)
g2 <- sample_smallworld(dim=1, size=30, nei=2, p=.05)
g3 <- sample_smallworld(dim=1, size=30, nei=2, p=.20)
g4 <- sample_smallworld(dim=1, size=30, nei=2, p=1)

set.seed(1)
op <- par(mar=c(2,1,3,1),mfrow=c(2,2))
plot(g1,vertex.label=NA,layout=layout_with_kk, main=expression(paste(italic(p)," = 0")))
plot(g2,vertex.label=NA, main=expression(paste(italic(p)," = .05")))
plot(g3,vertex.label=NA, main=expression(paste(italic(p)," = .20")))
plot(g4,vertex.label=NA, main=expression(paste(italic(p)," = 1")))

par(op)

En el siguiente ejemplo se muestra como el recableado reduce el diámetro de una red bajo el presente modelo.

g100 <- sample_smallworld(dim=1,size=100,nei=2,p=0)
g100
## IGRAPH e8e246d U--- 100 200 -- Watts-Strogatz random graph
## + attr: name (g/c), dim (g/n), size (g/n), nei (g/n), p (g/n), loops
## | (g/l), multiple (g/l)
## + edges from e8e246d:
##  [1]  1-- 2  2-- 3  3-- 4  4-- 5  5-- 6  6-- 7  7-- 8  8-- 9  9--10 10--11
## [11] 11--12 12--13 13--14 14--15 15--16 16--17 17--18 18--19 19--20 20--21
## [21] 21--22 22--23 23--24 24--25 25--26 26--27 27--28 28--29 29--30 30--31
## [31] 31--32 32--33 33--34 34--35 35--36 36--37 37--38 38--39 39--40 40--41
## [41] 41--42 42--43 43--44 44--45 45--46 46--47 47--48 48--49 49--50 50--51
## [51] 51--52 52--53 53--54 54--55 55--56 56--57 57--58 58--59 59--60 60--61
## [61] 61--62 62--63 63--64 64--65 65--66 66--67 67--68 68--69 69--70 70--71
## + ... omitted several edges
# La red inicial tiene un diámetro de 25
diameter(g100)
## [1] 25

A medida que aumenta \(p\) se observa la disminución del diametro.

p_vect <- rep(1:30,each=10)
g_diam <- sapply(p_vect,function(x) diameter(sample_smallworld(dim=1, size=100, nei=2, p=x/200)))
smoothingSpline = smooth.spline(p_vect, g_diam, spar=0.35)
plot(jitter(p_vect,1), g_diam, col='grey60', xlab="Number of Rewired Edges", ylab="Diameter")
lines(smoothingSpline,lwd=1.5)

Modelos libres de escala

Una limitación de los dos modelos anteriores es que producen grafos con distribuciones de grado no representativas en el mundo real. Una gran variedad de redes tienen una distribución del grado con cola pesada, la cual sigue una ley de potencias. Estas son las llamadas redes libres de escala.

Esta característica surge por un proceso de formación de ventaja acumulada o apego preferencial. Es decir, si la red crece, los nuevos nodos son más propensos a formar vínculos con otros nodos que ya tienen muchos vínculos, debido a su visibilidad en la red. Por defecto, el algoritmo añade cada nuevo nodo a la red de forma que este esté conectado a otro con probabilidad proporcional al grado de ese al que se conecta.

library(scales)
set.seed(123)
g <- sample_pa(500, directed = FALSE, algorithm = "bag")
V(g)$color <- "lightblue"
V(g)[degree(g) > 9]$color <- "red" # se resaltan los 'hubs' con grado>9
node_size <- rescale(degree(g), to = c(2, 8))
plot(g, vertex.label = NA, vertex.size = node_size)

median(degree(g))
## [1] 1
mean(degree(g))
## [1] 1.996
table(degree(g))
## 
##   1   2   3   4   5   6   7   8   9  10  11  13  14  16  17 
## 306  94  45  16   9  11   7   3   1   1   1   1   2   1   2

Se observa la cola pesada en la distribución del grado.

op <- par(mfrow=c(1,2))
plot(degree_distribution(g), xlab="Degree", ylab="Proportion (linear scale)")
plot(degree_distribution(g), log='xy', xlab="Degree",ylab="Proportion (log scale)")

par(op)

La función sample_pa produce una gran variedad de modelos de apego preferencial.

set.seed(123)
# 25% de los nodos estarán aislados, 50% conectados a 1 nodo y 25% conectados a 2 nodos
g <- sample_pa(500, out.dist = c(0.25, 0.5, 0.25), directed = FALSE, zero.appeal = 1, algorithm = "bag")
V(g)$color <- "lightblue"
V(g)[degree(g) > 9]$color <- "red"
node_size <- rescale(degree(g), to = c(2, 8))
plot(g, vertex.label = NA, vertex.size = node_size)

Para ilustrar el crecimiento de estos modelos se presentan los siguientes gráficos.

set.seed(123)
g1 <- sample_pa(10,m=1,directed=FALSE, algorithm = "bag")
g2 <- sample_pa(25,m=1,directed=FALSE, algorithm = "bag")
g3 <- sample_pa(50,m=1,directed=FALSE, algorithm = "bag")
g4 <- sample_pa(100,m=1,directed=FALSE, algorithm = "bag")
op <- par(mfrow=c(2,2),mar=c(4,0,1,0))
plot(g1, vertex.label= NA, vertex.size = 3, xlab = "n = 10")
plot(g2, vertex.label= NA, vertex.size = 3, xlab = "n = 25")
plot(g3, vertex.label= NA, vertex.size = 3, xlab = "n = 50")
plot(g4, vertex.label= NA, vertex.size = 3, xlab = "n = 100")

par(op)

Comparando los modelos aleatorios con redes empíricas

Los modelos presentados se van a comprar con los datos de la red lhds, la cual se compone de lazos de comunicación entre 1283 lideres de un departamento de salud pública. Esta tiene baja densidad y grado medio cercano a 4.

suppressMessages(suppressWarnings(library(UserNetR)))
suppressMessages(suppressWarnings(library(intergraph)))
data(lhds)
ilhds <- asIgraph(lhds)
ilhds
## IGRAPH eb7c7fa U--- 1283 2708 -- 
## + attr: title (g/c), hivscreen (v/c), na (v/l), nutrition (v/c), popmil
## | (v/n), state (v/c), vertex.names (v/c), years (v/n), na (e/l)
## + edges from eb7c7fa:
##  [1]  2--  10  2--  11  2--  19  2--  20  5--1003  5--   6  6--  11  6--  17
##  [9] 10--  11 11--  19 11--  26  2--  12  6--  12 10--  12 11--  12 12--  19
## [17] 12--  26  9--  14 14--  15 14--  18 14--  25 14--  27 14-- 226 14-- 414
## [25] 14-- 697 14-- 698  2--  17 10--  17 11--  17 16--  17 17--  19 17--  20
## [33] 17--  26 16--  21 10--  26 19--  26 28--  46 28--  53 29--  32 29--  35
## [41] 29--  52 28--  30 30--  34 30--  39 31--  38 31--  50 34--  39 36--  51
## [49] 35--  37 40--  41 40--  54 30--  41 34--  41 41--  54 42--  45 42--  43
## + ... omitted several edges
edge_density(ilhds)
## [1] 0.00329279
mean(degree(ilhds))
## [1] 4.221356

Se muestran algunas estadísticas descriptivas para los tres modelos y la red original. Note que ningún modelo logra replicar todas las características deseadas de los datos reales. En particular, la red es mucho más transitiva que cualquiera de los modelos.

set.seed(123)
g_rnd <- sample_gnp(1283, .0033)
g_smwrld <- sample_smallworld(dim=1, size=1283, nei=2, p=.25)
g_prfatt <- sample_pa(1283, out.dist=c(.15,.6,.25), directed=FALSE, zero.appeal=2)

grado_promedio <- function(grafo){
  mean(degree(grafo))
}

tabla <- data.frame(
  Nombre = c("Erdos-Renyi", "Small world", "Preferenial attachment", "Red ilhds"),
  Tamaño = c(vcount(g_rnd),vcount(g_smwrld),vcount(g_prfatt), vcount(ilhds)    ),
  Densidad = c(edge_density(g_rnd), edge_density(g_smwrld), edge_density(g_prfatt), edge_density(ilhds)   ),
  Grado_medio = c( grado_promedio(g_rnd),grado_promedio(g_smwrld), grado_promedio(g_prfatt), grado_promedio(ilhds)   ),
  Transitividad = c(transitivity(g_rnd), transitivity(g_smwrld), transitivity(g_prfatt), transitivity(ilhds)   ),
  Aislados = c(21, 1, 109, 58  )
)
tabla[,-1] <- round(tabla[,-1], 3)

kable(tabla, align = "c") %>%
  collapse_rows(columns = 1) %>%
  kable_styling(
    # full_width = FALSE,
    bootstrap_options = c("bordered")
  )
Nombre Tamaño Densidad Grado_medio Transitividad Aislados
Erdos-Renyi 1283 0.003 4.184 0.003 21
Small world 1283 0.003 4.000 0.074 1
Preferenial attachment 1283 0.002 2.214 0.005 109
Red ilhds 1283 0.003 4.221 0.306 58