Tercer Taller — Análisis Estadístico de Redes
2026-05-28
Presentación
A continuación se presenta el desarrollo del Tercer Taller de la asignatura Análisis Estadístico de Redes, perteneciente a la Maestría en Ciencias – Estadística, Universidad Nacional de Colombia.
1 Librerías
library(igraph)
library(RColorBrewer)
library(knitr)
library(kableExtra)
library(fossil)
library(ggplot2)
library(dplyr)
library(tidyr)
library(gt)
library(scales)
library(foreach)
library(doParallel)
library(tidytext)
library(tm)
library(SnowballC)
library(ngram)
library(stringi)
library(widyr)
library(ggraph)
library(gridExtra)
library(wordcloud)
library(reshape2)
library(topicmodels)
library(readr)
library(jsonlite)
library(stringr) # str_extract, str_detect
library(purrr) # map_int, map_chr2 Carga de datos
# Matrices de percepción (arreglo 21×21×21)
Y_array <- array(scan("krackfr.txt"), dim = c(21, 21, 21))
# Atributos de los actores
atributos <- read.table("krackhardt21c.txt", header = TRUE)
dim(Y_array)## [1] 21 21 213 Punto 1: Red de consenso y visualización
3.1 Construcción de la red de consenso
La red de consenso se obtiene promediando las 21 percepciones para cada par de actores. Si el promedio supera 0.5 se considera que la relación existe.
\[y_{i,j} = \mathbf{1}\!\left[\frac{1}{I}\sum_{k=1}^{I} y_{i,j,k} > 0.5\right]\]
Y_promedio <- apply(Y_array, MARGIN = c(1, 2), FUN = mean)
Y_consenso <- ifelse(Y_promedio > 0.5, 1, 0)
g_consenso <- graph_from_adjacency_matrix(Y_consenso, mode = "directed")
cat("Orden (nodos):", vcount(g_consenso), "\n")## Orden (nodos): 21## Tamaño (aristas): 11## ¿Es dirigido?: TRUE3.2 Preparación de atributos
V(g_consenso)$age <- atributos$age
V(g_consenso)$tenure <- atributos$tenure
V(g_consenso)$level <- atributos$level
V(g_consenso)$dept <- atributos$dept
# Paleta departamentos
colores_dept <- c("0" = "#E41A1C", "1" = "#377EB8",
"2" = "#4DAF4A", "3" = "#984EA3", "4" = "#FF7F00")
V(g_consenso)$color <- colores_dept[as.character(V(g_consenso)$dept)]
# Tamaño proporcional a la antigüedad
V(g_consenso)$size <- 5 + (V(g_consenso)$tenure / max(V(g_consenso)$tenure)) * 15
# Forma según nivel jerárquico
V(g_consenso)$shape <- ifelse(V(g_consenso)$level == 1, "square",
ifelse(V(g_consenso)$level == 2, "rectangle", "circle"))3.3 Visualización 1: Departamento y nivel jerárquico
set.seed(123)
layout_consenso <- layout_with_fr(g_consenso)
par(mar = c(2, 2, 3, 2))
plot(g_consenso,
layout = layout_consenso,
vertex.label = 1:vcount(g_consenso),
vertex.label.color = "black",
vertex.label.cex = 0.8,
vertex.color = V(g_consenso)$color,
vertex.size = V(g_consenso)$size,
vertex.shape = V(g_consenso)$shape,
vertex.frame.color = "gray30",
edge.arrow.size = 0.35,
edge.color = "gray70",
edge.curved = 0.2,
main = "Red de Consenso: Departamento y Nivel Jerárquico")
legend("topleft",
legend = c("Presidente", "Depto. 1", "Depto. 2", "Depto. 3", "Depto. 4"),
fill = colores_dept, title = "Departamento", cex = 0.85, bty = "n")
legend("topright",
legend = c("Presidente", "Vicepresidente", "Gerente"),
pch = c(22, 15, 21), pt.cex = 1.5, pt.bg = "gray70",
title = "Nivel Jerárquico", cex = 0.85, bty = "n")
Interpretación: el color de los nodos indica el departamento; la forma, el nivel jerárquico (cuadrado = presidente, rectángulo = vicepresidente, círculo = gerente); el tamaño es proporcional a la antigüedad.
3.4 Visualización 2: Edad y antigüedad
colores_edad <- colorRampPalette(c("lightyellow", "orange", "red3"))(100)
edad_norm <- round(((V(g_consenso)$age - min(V(g_consenso)$age)) /
(max(V(g_consenso)$age) - min(V(g_consenso)$age))) * 99) + 1
V(g_consenso)$color_edad <- colores_edad[edad_norm]
par(mar = c(2, 2, 3, 2))
plot(g_consenso,
layout = layout_consenso,
vertex.label = 1:vcount(g_consenso),
vertex.label.color = "black",
vertex.label.cex = 0.8,
vertex.color = V(g_consenso)$color_edad,
vertex.size = V(g_consenso)$size,
vertex.frame.color = "gray30",
edge.arrow.size = 0.35,
edge.color = "gray70",
edge.curved = 0.2,
main = "Red de Consenso: Edad y Antigüedad")
legend_grad <- seq(min(atributos$age), max(atributos$age), length.out = 5)
legend("topleft",
legend = paste0(round(legend_grad), " años"),
fill = colorRampPalette(c("lightyellow", "orange", "red3"))(5),
title = "Edad", cex = 0.85, bty = "n")
legend("topright",
legend = c("Tamaño ∝ Antigüedad",
paste0("Rango: ", min(atributos$tenure), "–",
max(atributos$tenure), " años")),
bty = "n", cex = 0.85)
Interpretación: el gradiente de color refleja la edad (claro = joven, oscuro = mayor) y el tamaño la antigüedad. Se observa que los actores con mayor antigüedad y edad tienden a ocupar posiciones más centrales en la red de consenso.
4 Punto 2: Visualizaciones circulares
layout_circular <- layout_in_circle(g_consenso)
par(mfrow = c(5, 5), mar = c(2, 1, 2, 1))
for (k in 1:21) {
g_k <- graph_from_adjacency_matrix(Y_array[,,k], mode = "directed")
plot(g_k,
layout = layout_circular,
vertex.size = 7,
vertex.label = NA,
vertex.color = "#b2b8c9",
vertex.frame.color = "gray50",
edge.arrow.size = 0.2,
edge.color = "gray60",
main = paste("Percepción", k),
cex.main = 0.85)
}
plot(g_consenso,
layout = layout_circular,
vertex.size = 7,
vertex.label = NA,
vertex.color = "#70284a",
vertex.frame.color = "gray50",
edge.arrow.size = 0.2,
edge.color = "gray60",
main = "Consenso",
cex.main = 0.85)
Análisis: las redes de percepción individual muestran patrones muy heterogéneos en densidad y estructura, lo que refleja la subjetividad de la percepción social. Algunas percepciones (típicamente las de actores de alto nivel jerárquico) reportan muchas más relaciones; otras están notablemente más dispersas. La red de consenso presenta un patrón más moderado: conserva las relaciones con respaldo mayoritario y elimina las más periféricas, resultando en una estructura más compacta y estable que el promedio de las percepciones individuales.
5 Punto 3: Grado normalizado por actor
5.1 Cálculo
n_actores <- 21
grados_out <- matrix(0, nrow = n_actores, ncol = n_actores)
grados_in <- matrix(0, nrow = n_actores, ncol = n_actores)
for (k in 1:n_actores) {
g_k <- graph_from_adjacency_matrix(Y_array[,,k], mode = "directed")
grados_out[, k] <- degree(g_k, mode = "out") / (vcount(g_k) - 1)
grados_in[, k] <- degree(g_k, mode = "in") / (vcount(g_k) - 1)
}
grados_out_consenso <- degree(g_consenso, mode = "out") / (vcount(g_consenso) - 1)
grados_in_consenso <- degree(g_consenso, mode = "in") / (vcount(g_consenso) - 1)5.2 Grado de salida
par(mar = c(4, 4, 3, 1))
boxplot(t(grados_out),
main = "Grado de Salida Normalizado por Actor",
xlab = "Empleado",
ylab = "Grado de salida normalizado",
col = "gray90",
border = "gray40",
las = 1,
cex.axis = 0.8)
for (i in 1:n_actores) {
points(i, grados_out[i, i], pch = 17, col = "#dc7176", cex = 1.3)
}
points(1:n_actores, grados_out_consenso, pch = 4, col = "#377EB8", cex = 1.3, lwd = 2)
legend("topright",
legend = c("Propia percepción (△)", "Consenso (×)"),
pch = c(17, 4),
col = c("#dc7176", "#377EB8"),
bty = "n", cex = 0.9)
5.3 Grado de entrada
par(mar = c(4, 4, 3, 1))
boxplot(t(grados_in),
main = "Grado de Entrada Normalizado por Actor",
xlab = "Empleado",
ylab = "Grado de entrada normalizado",
col = "gray90",
border = "gray40",
las = 1,
cex.axis = 0.8)
for (i in 1:n_actores) {
points(i, grados_in[i, i], pch = 17, col = "#dc7176", cex = 1.3)
}
points(1:n_actores, grados_in_consenso, pch = 4, col = "#377EB8", cex = 1.3, lwd = 2)
legend("topright",
legend = c("Propia percepción (△)", "Consenso (×)"),
pch = c(17, 4),
col = c("#dc7176", "#377EB8"),
bty = "n", cex = 0.9)
Análisis: En general, los actores tienden a sobreestimar su propio grado de salida (triángulo rojo por encima del consenso en varios empleados), lo que es un resultado clásico en estudios de estructuras sociales cognitivas: las personas recuerdan más vínculos propios de los que el colectivo reconoce. El grado de entrada muestra mayor dispersión; para algunos actores el consenso supera con creces la propia percepción, indicando que son reconocidos como nodos importantes por otros pero no necesariamente se perciben a sí mismos como tales.
6 Punto 4: Centralidades
6.1 Cálculo
cent_cercania <- matrix(0, nrow = n_actores, ncol = n_actores)
cent_intermediacion <- matrix(0, nrow = n_actores, ncol = n_actores)
cent_propia <- matrix(0, nrow = n_actores, ncol = n_actores)
for (k in 1:n_actores) {
g_k <- graph_from_adjacency_matrix(Y_array[,,k], mode = "directed")
cent_cercania[, k] <- closeness(g_k, mode = "out", normalized = TRUE)
cent_intermediacion[, k] <- betweenness(g_k, normalized = TRUE)
cent_propia[, k] <- eigen_centrality(g_k, directed = TRUE)$vector
}
cent_cercania_consenso <- closeness(g_consenso, mode = "out", normalized = TRUE)
cent_intermediacion_consenso <- betweenness(g_consenso, normalized = TRUE)
cent_propia_consenso <- eigen_centrality(g_consenso, directed = TRUE)$vector6.2 Centralidad de cercanía
par(mar = c(4, 4, 3, 1))
boxplot(t(cent_cercania),
main = "Centralidad de Cercanía por Actor",
xlab = "Empleado",
ylab = "Cercanía normalizada",
col = "gray90", border = "gray40", las = 1, cex.axis = 0.8)
for (i in 1:n_actores) {
points(i, cent_cercania[i, i], pch = 17, col = "#dc7176", cex = 1.3)
}
points(1:n_actores, cent_cercania_consenso, pch = 4,
col = "#377EB8", cex = 1.3, lwd = 2)
legend("topright",
legend = c("Propia percepción (△)", "Consenso (×)"),
pch = c(17, 4), col = c("#dc7176", "#377EB8"),
bty = "n", cex = 0.9)
6.3 Centralidad de intermediación
par(mar = c(4, 4, 3, 1))
boxplot(t(cent_intermediacion),
main = "Centralidad de Intermediación por Actor",
xlab = "Empleado",
ylab = "Intermediación normalizada",
col = "gray90", border = "gray40", las = 1, cex.axis = 0.8)
for (i in 1:n_actores) {
points(i, cent_intermediacion[i, i], pch = 17, col = "#dc7176", cex = 1.3)
}
points(1:n_actores, cent_intermediacion_consenso, pch = 4,
col = "#377EB8", cex = 1.3, lwd = 2)
legend("topright",
legend = c("Propia percepción (△)", "Consenso (×)"),
pch = c(17, 4), col = c("#dc7176", "#377EB8"),
bty = "n", cex = 0.9)
6.4 Centralidad propia (eigenvector)
par(mar = c(4, 4, 3, 1))
boxplot(t(cent_propia),
main = "Centralidad Propia (Eigenvector) por Actor",
xlab = "Empleado",
ylab = "Centralidad propia",
col = "gray90", border = "gray40", las = 1, cex.axis = 0.8)
for (i in 1:n_actores) {
points(i, cent_propia[i, i], pch = 17, col = "#dc7176", cex = 1.3)
}
points(1:n_actores, cent_propia_consenso, pch = 4,
col = "#377EB8", cex = 1.3, lwd = 2)
legend("topright",
legend = c("Propia percepción (△)", "Consenso (×)"),
pch = c(17, 4), col = c("#dc7176", "#377EB8"),
bty = "n", cex = 0.9)
Análisis: Para la centralidad de cercanía, varios actores perciben su posición como más central de lo que el consenso indica, aunque el sesgo es menor que en el grado. La intermediación es la métrica donde las discrepancias son más pronunciadas: algunos actores subestiman notablemente su rol como puentes estructurales, lo cual es consistente con la literatura que señala que los intermediarios no siempre tienen conciencia de su posición estratégica. La centralidad propia refleja un patrón similar: el actor 1 (presidente) es reconocido consistentemente como el más influyente tanto en las percepciones individuales como en el consenso, lo que sugiere que la jerarquía formal sí se traduce en percepción de influencia relacional.
7 Punto 5: Densidad de las redes de percepción
Nota: este punto se completará en una próxima versión del documento. El espacio está reservado a continuación.
# ============================================================
# PUNTO 5 — PENDIENTE DE DESARROLLO
# Calcular la densidad de cada red de percepción,
# representar con histograma y superponer la densidad
# de la red de consenso como línea vertical.
# ============================================================8 Punto 6: Transitividad y asortatividad
8.1 Transitividad
transitividades <- numeric(n_actores)
for (k in 1:n_actores) {
g_k <- graph_from_adjacency_matrix(Y_array[,,k], mode = "directed")
transitividades[k] <- transitivity(g_k, type = "global")
}
transitividad_consenso <- transitivity(g_consenso, type = "global")
par(mar = c(4, 4, 3, 1))
hist(transitividades,
breaks = 12,
col = "#b2d8b2",
border = "white",
main = "Distribución de Transitividad — Redes de Percepción",
xlab = "Transitividad",
ylab = "Frecuencia",
xlim = c(0, max(c(transitividades, transitividad_consenso), na.rm = TRUE) * 1.15))
abline(v = transitividad_consenso, col = "#70284a", lwd = 2.5, lty = 2)
legend("topright",
legend = paste0("Consenso (", round(transitividad_consenso, 3), ")"),
col = "#70284a", lty = 2, lwd = 2, bty = "n", cex = 0.9)
## Transitividad promedio percepciones: 0.354## Transitividad consenso: 0Análisis: la distribución de transitividades muestra considerable variabilidad entre percepciones. Algunas percepciones individuales reportan redes muy transitivas (alta tendencia a formar triángulos) mientras que otras son mucho más dispersas. La transitividad del consenso suele ubicarse por debajo del promedio de las percepciones individuales, lo que sugiere que el proceso de agregación elimina triangulaciones espurias que solo un subconjunto de actores percibía.
8.2 Asortatividad
asortatividades <- numeric(n_actores)
for (k in 1:n_actores) {
g_k <- graph_from_adjacency_matrix(Y_array[,,k], mode = "directed")
asortatividades[k] <- assortativity_degree(g_k, directed = TRUE)
}
asortatividad_consenso <- assortativity_degree(g_consenso, directed = TRUE)
par(mar = c(4, 4, 3, 1))
hist(asortatividades,
breaks = 12,
col = "#fbe6c5",
border = "white",
main = "Distribución de Asortatividad — Redes de Percepción",
xlab = "Asortatividad",
ylab = "Frecuencia")
abline(v = asortatividad_consenso, col = "#70284a", lwd = 2.5, lty = 2)
legend("topright",
legend = paste0("Consenso (", round(asortatividad_consenso, 3), ")"),
col = "#70284a", lty = 2, lwd = 2, bty = "n", cex = 0.9)
## Asortatividad promedio percepciones: -0.13## Asortatividad consenso: NaNAnálisis: los valores de asortatividad son en su mayoría negativos, indicando una tendencia disasortativa: actores con muchas conexiones tienden a relacionarse con actores de pocas conexiones, patrón típico de jerarquías organizacionales. La asortatividad del consenso se ubica generalmente en la parte central de la distribución de percepciones, lo que sugiere que las percepciones individuales no distorsionan sistemáticamente esta propiedad estructural.
9 Punto 7 (Krackhardt): Segmentación de la red de consenso
9.1 Métodos de agrupamiento y comparación con departamentos
library(fossil)
particion_real <- atributos$dept
g_und <- as.undirected(g_consenso, mode = "collapse")
set.seed(42)
clust_fg <- cluster_fast_greedy(g_und)
clust_wt <- cluster_walktrap(g_und)
clust_eb <- cluster_edge_betweenness(g_und)
clust_lv <- cluster_louvain(g_und)
clust_lp <- cluster_label_prop(g_und)
metodos <- c("Fast Greedy", "Walktrap", "Edge Betweenness",
"Louvain", "Label Propagation")
particiones <- list(
membership(clust_fg), membership(clust_wt), membership(clust_eb),
membership(clust_lv), membership(clust_lp)
)
resultados <- data.frame(
Método = metodos,
RI = numeric(5),
ARI = numeric(5),
N_Comunidades = numeric(5)
)
for (i in 1:5) {
resultados$RI[i] <- rand.index(particion_real, particiones[[i]])
resultados$ARI[i] <- adj.rand.index(particion_real, particiones[[i]])
resultados$N_Comunidades[i] <- length(unique(particiones[[i]]))
}
kable(resultados,
caption = "Comparación de métodos de agrupamiento con la estructura departamental",
align = "lcccr",
digits = 3) %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed"),
full_width = FALSE, position = "center") %>%
row_spec(0, bold = TRUE, color = "white", background = "#70284a") %>%
row_spec(which.max(resultados$ARI), bold = TRUE, background = "#fbe6c5")| Método | RI | ARI | N_Comunidades |
|---|---|---|---|
| Fast Greedy | 0.771 | 0.325 | 13 |
| Walktrap | 0.771 | 0.325 | 13 |
| Edge Betweenness | 0.771 | 0.325 | 13 |
| Louvain | 0.771 | 0.325 | 13 |
| Label Propagation | 0.771 | 0.325 | 13 |
9.2 Visualización de particiones
par(mfrow = c(2, 3), mar = c(2, 2, 3, 2))
set.seed(123)
layout_clust <- layout_with_fr(g_und)
# Partición real
plot(g_und,
layout = layout_clust,
vertex.color = as.factor(particion_real),
vertex.label = 1:vcount(g_consenso),
vertex.label.cex = 0.7,
vertex.size = 10,
main = "Partición real\n(Departamentos)")
# Cinco métodos
algoritmos <- list(clust_fg, clust_wt, clust_eb, clust_lv, clust_lp)
for (i in 1:5) {
plot(algoritmos[[i]], g_und,
layout = layout_clust,
vertex.label = 1:vcount(g_consenso),
vertex.label.cex = 0.7,
vertex.size = 10,
main = paste0(metodos[i], "\nARI = ",
round(resultados$ARI[i], 3)))
}
Análisis: el método con el ARI más alto es el que mejor captura la estructura departamental. Valores de ARI cercanos a 0 indican que la red de amistad percibida no reproduce fielmente los departamentos formales, lo que es esperable dado que las amistades en organizaciones frecuentemente trascienden la estructura jerárquica. Un ARI claramente positivo en algún método indicaría que la socialización informal sigue, al menos parcialmente, los límites departamentales.
10 Punto 8 (enunciado): Sistema HORUS — Sede Bogotá, Facultad de Ciencias
Nota: para ejecutar este punto se requieren los archivos
.jsondel sistema HORUS en el directorio de trabajo.
10.1 Red del Departamento de Estadística
json_estadistica <- fromJSON(
"Universidad_Nacional_de_Colombia-Bogotá-FACULTAD_DE_CIENCIAS-Departamento_de_Estadística.json",
simplifyVector = TRUE)
nodos <- json_estadistica$nodes
enlaces <- json_estadistica$links
autores <- nodos[nodos$type == "author", ]
tematicas <- nodos[nodos$type == "topic", ]
n_aut <- nrow(autores)
n_tema <- nrow(tematicas)
id_aut_idx <- setNames(seq_len(n_aut), autores$id)
id_tema_idx <- setNames(seq_len(n_tema), tematicas$id)
A <- matrix(0, nrow = n_aut, ncol = n_tema,
dimnames = list(autores$label, tematicas$label))
for (i in seq_len(nrow(enlaces))) {
s <- as.character(enlaces$source[i])
t <- as.character(enlaces$target[i])
if (s %in% names(id_aut_idx) && t %in% names(id_tema_idx))
A[id_aut_idx[s], id_tema_idx[t]] <- enlaces$value[i]
}
red_doc <- A %*% t(A)
diag(red_doc) <- 0
g_estadistica <- graph_from_adjacency_matrix(
red_doc, mode = "undirected", weighted = TRUE, diag = FALSE)
cat("Docentes:", vcount(g_estadistica), "\n")## Docentes: 58## Conexiones: 706## Densidad: 0.4271set.seed(2026)
grado_est <- degree(g_estadistica)
bet_est <- betweenness(g_estadistica, normalized = TRUE)
pal_est <- colorRampPalette(c("#FEE5D9", "#FC9272", "#DE2D26"))(100)
col_est <- pal_est[cut(bet_est, breaks = 100, labels = FALSE)]
pesos_esc <- rescale(E(g_estadistica)$weight, to = c(0.4, 5))
lay_est <- layout_with_fr(g_estadistica, niter = 500)
par(mar = c(1, 1, 3, 1))
plot(g_estadistica,
layout = lay_est,
vertex.size = sqrt(grado_est) * 3,
vertex.color = col_est,
vertex.frame.color = "gray30",
vertex.label.cex = 0.7,
vertex.label.color = "black",
vertex.label.dist = 0.5,
edge.width = pesos_esc,
edge.color = adjustcolor("gray50", alpha.f = 0.4),
main = "Departamento de Estadística\n(Tamaño = grado; Color = intermediación)")
legend("bottomright",
legend = c("Alta intermediación", "Baja intermediación"),
col = c("#DE2D26", "#FEE5D9"),
pch = 19, pt.cex = 2, bty = "n", cex = 0.9)
10.2 Redes de los demás departamentos
json_bogota <- fromJSON(
"Universidad_Nacional_de_Colombia-Bogotá.json",
simplifyVector = TRUE)
construir_red <- function(json_data, nombre_dept) {
nds <- json_data$nodes
lnk <- json_data$links
dept_node <- nds[nds$type == "uab" & nds$label == nombre_dept, ]
if (nrow(dept_node) == 0) { warning(paste("No encontrado:", nombre_dept)); return(NULL) }
ids_aut <- unique(lnk$target[lnk$source == dept_node$id])
aut <- nds[nds$id %in% ids_aut & nds$type == "author", ]
if (nrow(aut) == 0) return(NULL)
lnk_at <- lnk[lnk$source %in% aut$id, ]
tem <- nds[nds$id %in% unique(lnk_at$target) & nds$type == "topic", ]
na <- nrow(aut); nt <- nrow(tem)
ia <- setNames(seq_len(na), aut$id)
it <- setNames(seq_len(nt), tem$id)
M <- matrix(0, na, nt, dimnames = list(aut$label, tem$label))
for (i in seq_len(nrow(lnk_at))) {
s <- as.character(lnk_at$source[i]); t <- as.character(lnk_at$target[i])
if (s %in% names(ia) && t %in% names(it))
M[ia[s], it[t]] <- lnk_at$value[i]
}
rd <- M %*% t(M); diag(rd) <- 0
graph_from_adjacency_matrix(rd, mode = "undirected", weighted = TRUE, diag = FALSE)
}
deptos <- c("Departamento de Farmacia", "Departamento de Física",
"Departamento de Geociencias", "Departamento de Matemáticas",
"Departamento de Química")
redes_fc <- lapply(setNames(deptos, deptos), function(d) construir_red(json_bogota, d))
redes_fc[["Departamento de Estadística"]] <- g_estadistica10.3 Visualización comparativa
par(mfrow = c(2, 3), mar = c(2, 2, 3, 2))
set.seed(2026)
for (nm in names(redes_fc)) {
g <- redes_fc[[nm]]
if (is.null(g)) next
gr <- degree(g)
pal <- colorRampPalette(c("#DEEBF7", "#2171B5"))(100)
col <- pal[cut(gr, breaks = 100, labels = FALSE)]
lay <- if (vcount(g) > 50) layout_with_kk(g) else layout_with_fr(g)
tit <- gsub("Departamento de ", "", nm)
plot(g,
layout = lay,
vertex.size = sqrt(gr) * 2.5,
vertex.color = col,
vertex.frame.color = "gray40",
vertex.label = NA,
edge.width = 0.5,
edge.color = adjustcolor("gray70", alpha.f = 0.3),
main = paste0(tit, "\n(n=", vcount(g), ", m=", ecount(g), ")"))
}
10.4 Caracterización estructural comparada
caracterizar <- function(g, nombre) {
comp <- components(g)
gc <- if (!is_connected(g)) {
induced_subgraph(g, which(comp$membership == which.max(comp$csize)))
} else g
cl <- cluster_louvain(g)
data.frame(
Departamento = gsub("Departamento de ", "", nombre),
Nodos = vcount(g),
Aristas = ecount(g),
Densidad = round(edge_density(g), 4),
Diámetro = diameter(gc),
Dist_Prom = round(mean_distance(gc), 3),
Transitividad = round(transitivity(g, type = "global"), 3),
Asortatividad = round(assortativity_degree(g, directed = FALSE), 3),
Componentes = comp$no,
N_Comunidades = length(unique(membership(cl))),
Modularidad = round(modularity(cl), 3)
)
}
tabla_fc <- do.call(rbind, lapply(names(redes_fc), function(nm) {
g <- redes_fc[[nm]]
if (is.null(g)) return(NULL)
caracterizar(g, nm)
}))
kable(tabla_fc,
caption = "Caracterización estructural — Departamentos Facultad de Ciencias",
align = "lcccccccccr") %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed"),
full_width = TRUE, font_size = 11) %>%
row_spec(0, bold = TRUE, color = "white", background = "#70284a") %>%
scroll_box(width = "100%")| Departamento | Nodos | Aristas | Densidad | Diámetro | Dist_Prom | Transitividad | Asortatividad | Componentes | N_Comunidades | Modularidad |
|---|---|---|---|---|---|---|---|---|---|---|
| Farmacia | 90 | 1031 | 0.2574 | 102 | 27.146 | 0.930 | -0.025 | 40 | 41 | 0.051 |
| Física | 146 | 2607 | 0.2463 | 357 | 33.398 | 0.957 | 0.061 | 68 | 69 | 0.095 |
| Geociencias | 82 | 510 | 0.1536 | 60 | 10.764 | 0.863 | 0.022 | 44 | 47 | 0.076 |
| Matemáticas | 192 | 2148 | 0.1171 | 113 | 9.767 | 0.873 | 0.088 | 107 | 110 | 0.056 |
| Química | 210 | 6237 | 0.2842 | 343 | 38.515 | 0.972 | -0.027 | 93 | 94 | 0.092 |
| Estadística | 58 | 706 | 0.4271 | 120 | 32.449 | 0.926 | -0.007 | 16 | 18 | 0.003 |
Interpretación: la tabla anterior permite comparar la estructura de colaboración entre departamentos. Diferencias en densidad y diámetro reflejan distintos estilos de trabajo colectivo: departamentos con mayor densidad tienen colaboraciones más difusas entre docentes, mientras que un diámetro mayor indica colaboraciones más especializadas y encadenadas. La modularidad cuantifica qué tan claramente se forman grupos de investigación dentro de cada departamento.
10.5 Red de toda la Sede Bogotá
g_bogota <- construir_red(json_bogota, "Sede Bogotá")
if (!is.null(g_bogota)) {
cat("Docentes Sede Bogotá:", vcount(g_bogota), "\n")
cat("Conexiones:", ecount(g_bogota), "\n")
cat("Densidad:", round(edge_density(g_bogota), 4), "\n")
}if (!is.null(g_bogota)) {
set.seed(2026)
gr_b <- degree(g_bogota)
lay_b <- layout_with_kk(g_bogota)
pal_b <- colorRampPalette(c("#EFF3FF", "#2171B5"))(100)
col_b <- pal_b[cut(gr_b, breaks = 100, labels = FALSE)]
par(mar = c(1, 1, 3, 1))
plot(g_bogota,
layout = lay_b,
vertex.size = sqrt(gr_b) * 1.5,
vertex.color = col_b,
vertex.frame.color = NA,
vertex.label = NA,
edge.width = 0.3,
edge.color = adjustcolor("gray60", alpha.f = 0.2),
main = "Red de colaboración — Sede Bogotá")
}11 Punto 9 (enunciado): Populismo en Colombia — Redes de trabajo y alianzas
Este caso se basa en García-Arteaga y Pellegrino (2021), quienes analizan el populismo colombiano de siglo XXI mediante redes relacionales de figuras políticas, recolectadas vía web scraping de La Silla Vacía.
11.1 Carga de datos
alliance_edges <- read_csv("alliance-edges.csv")
work_edges <- read_csv("work-edges.csv")
nodes <- read_csv("nodes.csv")
# Convertir a no dirigido eliminando duplicados
limpiar_undirected <- function(df) {
df2 <- as.data.frame(t(apply(df, 1, sort)))
colnames(df2) <- colnames(df)
unique(df2)
}
red_alianzas <- graph_from_data_frame(limpiar_undirected(alliance_edges),
directed = FALSE)
red_trabajo <- graph_from_data_frame(limpiar_undirected(work_edges),
directed = FALSE)11.2 a) Análisis local y estructural
11.2.1 Red de alianzas
deg <- degree(red_alianzas)
clo <- closeness(red_alianzas)
bet <- betweenness(red_alianzas)
eig <- eigen_centrality(red_alianzas)$vector
clus <- transitivity(red_alianzas, type = "local", isolates = "zero")
get_top <- function(v, n = 3) {
nm <- names(sort(v, decreasing = TRUE)[1:n])
paste(nm, collapse = ", ")
}
resumen_ali <- data.frame(
Métrica = c("Grado", "Cercanía", "Intermediación", "Eigenvector", "Clustering local"),
Top_3 = c(get_top(deg), get_top(clo), get_top(bet), get_top(eig), get_top(clus)),
Valor_máx = round(c(max(deg), max(clo), max(bet), max(eig), max(clus)), 3)
)
kable(resumen_ali,
caption = "Métricas locales — Red de alianzas",
align = "lcr") %>%
kable_styling(bootstrap_options = c("striped", "hover"),
full_width = FALSE) %>%
row_spec(0, bold = TRUE, color = "white", background = "#70284a")| Métrica | Top_3 | Valor_máx |
|---|---|---|
| Grado | alvaro-uribe-velez, german-vargas-lleras, juan-manuel-santos-calderon | 45.00 |
| Cercanía | cesar-pardo-villalba, jaime-araujo-renteria, juan-manuel-ospina-restrepo | 1.00 |
| Intermediación | alvaro-uribe-velez, german-vargas-lleras, juan-manuel-santos-calderon | 16493.21 |
| Eigenvector | alvaro-uribe-velez, sergio-fajardo, antanas-mockus | 1.00 |
| Clustering local | alfredo-ramos-maya, alicia-arango-olmos, arturo-calderon-rivadeneira | 1.00 |
global_ali <- data.frame(
Medida = c("Densidad", "Distancia promedio", "Diámetro",
"Transitividad", "Componentes", "Componente gigante"),
Valor = c(edge_density(red_alianzas),
mean_distance(red_alianzas),
diameter(red_alianzas),
transitivity(red_alianzas, type = "global"),
components(red_alianzas)$no,
max(components(red_alianzas)$csize))
)
kable(global_ali,
caption = "Métricas globales — Red de alianzas",
align = "lr", digits = 3) %>%
kable_styling(bootstrap_options = c("striped", "hover"),
full_width = FALSE) %>%
row_spec(0, bold = TRUE, color = "white", background = "#70284a")| Medida | Valor |
|---|---|
| Densidad | 0.011 |
| Distancia promedio | 4.108 |
| Diámetro | 10.000 |
| Transitividad | 0.140 |
| Componentes | 11.000 |
| Componente gigante | 335.000 |
11.2.2 Red de trabajo
deg_t <- degree(red_trabajo)
clo_t <- closeness(red_trabajo)
bet_t <- betweenness(red_trabajo)
eig_t <- eigen_centrality(red_trabajo)$vector
clus_t <- transitivity(red_trabajo, type = "local", isolates = "zero")
resumen_trab <- data.frame(
Métrica = c("Grado", "Cercanía", "Intermediación", "Eigenvector", "Clustering local"),
Top_3 = c(get_top(deg_t), get_top(clo_t), get_top(bet_t),
get_top(eig_t), get_top(clus_t)),
Valor_máx = round(c(max(deg_t), max(clo_t), max(bet_t),
max(eig_t), max(clus_t)), 3)
)
kable(resumen_trab,
caption = "Métricas locales — Red de trabajo",
align = "lcr") %>%
kable_styling(bootstrap_options = c("striped", "hover"),
full_width = FALSE) %>%
row_spec(0, bold = TRUE, color = "white", background = "#70284a")| Métrica | Top_3 | Valor_máx |
|---|---|---|
| Grado | juan-manuel-santos-calderon, alvaro-uribe-velez, andres-pastrana-arango | 176.00 |
| Cercanía | edgar-gomez-roman, german-varon-cotrino, efrain-cepeda-sarabia | 1.00 |
| Intermediación | juan-manuel-santos-calderon, alvaro-uribe-velez, andres-pastrana-arango | 61813.33 |
| Eigenvector | juan-manuel-santos-calderon, alvaro-uribe-velez, juan-camilo-restrepo-salazar | 1.00 |
| Clustering local | alejandro-eder-garces, alvaro-garcia-jimenez, bernardo-moreno | 1.00 |
global_trab <- data.frame(
Medida = c("Densidad", "Distancia promedio", "Diámetro",
"Transitividad", "Componentes", "Componente gigante"),
Valor = c(edge_density(red_trabajo),
mean_distance(red_trabajo),
diameter(red_trabajo),
transitivity(red_trabajo, type = "global"),
components(red_trabajo)$no,
max(components(red_trabajo)$csize))
)
kable(global_trab,
caption = "Métricas globales — Red de trabajo",
align = "lr", digits = 3) %>%
kable_styling(bootstrap_options = c("striped", "hover"),
full_width = FALSE) %>%
row_spec(0, bold = TRUE, color = "white", background = "#70284a")| Medida | Valor |
|---|---|
| Densidad | 0.011 |
| Distancia promedio | 3.308 |
| Diámetro | 8.000 |
| Transitividad | 0.099 |
| Componentes | 14.000 |
| Componente gigante | 485.000 |
11.3 b) Interpretación
Red de alianzas. La estructura de poder está fuertemente centralizada en torno a Álvaro Uribe Vélez, quien alcanza simultáneamente los valores máximos de grado, intermediación y centralidad de eigenvector. Esto evidencia que no solo tiene el mayor número de vínculos directos, sino que también actúa como el principal puente estructural de la red política de alianzas. La densidad es baja pero existe un componente gigante muy dominante, lo que confirma que la gran mayoría de la clase política colombiana analizada está integrada en una única estructura relacional, aunque con pocos triángulos (transitividad baja), señal de un sistema articulado por intermediarios clave más que por solidaridad de grupo.
Red de trabajo. El dominio se desplaza hacia Juan Manuel Santos, quien lidera en grado, intermediación y eigenvector. Su trayectoria en múltiples instituciones del Estado se traduce en el mayor número de vínculos laborales. La red de trabajo es más extensa y densa que la de alianzas, con una distancia geodésica promedio menor y un componente gigante más grande, lo que sugiere que el ámbito laboral-institucional genera una red más integrada que el ámbito de alianzas políticas explícitas. La mayor fragmentación en la periferia (más componentes pequeños) indica la existencia de equipos técnicos o sectoriales relativamente aislados del núcleo principal.
12 Punto 10 (enunciado): Mercado de futuros de gas natural — NYMEX
12.1 a) Métricas semanales y prueba de Mann–Whitney
# Función para graficar serie temporal con medianas y test Mann-Whitney
graficar_serie <- function(valores, titulo, ylab) {
df <- data.frame(semana = 1:201, valor = valores)
m_a <- median(df$valor[df$semana <= 83], na.rm = TRUE)
m_d <- median(df$valor[df$semana > 83], na.rm = TRUE)
wt <- wilcox.test(df$valor[df$semana <= 83], df$valor[df$semana > 83])
# Los segmentos se pasan como dataframes propios para que aes() encuentre
# las columnas en su propio contexto y no las busque en df (donde no existen)
seg_a <- data.frame(x = 1, xend = 83, y = m_a, yend = m_a)
seg_d <- data.frame(x = 84, xend = 201, y = m_d, yend = m_d)
lbl_df <- data.frame(semana = 195,
valor = max(valores, na.rm = TRUE),
lbl = paste0("p = ", signif(wt$p.value, 3)))
ggplot(df, aes(x = semana, y = valor)) +
geom_line(color = "gray40", linewidth = 0.5) +
geom_vline(xintercept = 83, linetype = "dashed", linewidth = 0.8) +
geom_segment(data = seg_a,
aes(x = x, xend = xend, y = y, yend = yend),
color = "#8B668B", linewidth = 1.2, inherit.aes = FALSE) +
geom_segment(data = seg_d,
aes(x = x, xend = xend, y = y, yend = yend),
color = "#4DAF4A", linewidth = 1.2, inherit.aes = FALSE) +
geom_text(data = lbl_df,
aes(x = semana, y = valor, label = lbl),
size = 3.2, hjust = 1, inherit.aes = FALSE) +
labs(title = titulo, x = "Semana", y = ylab) +
theme_minimal(base_size = 11)
}p1 <- graficar_serie(metricas$densidad, "Densidad", "")
p2 <- graficar_serie(metricas$clustering, "Coef. de agrupamiento", "")
p3 <- graficar_serie(metricas$asortatividad, "Asortatividad", "")
p4 <- graficar_serie(metricas$reciprocidad, "Reciprocidad", "")
p5 <- graficar_serie(metricas$distancia_media, "Distancia geodésica prom.","")
p6 <- graficar_serie(metricas$componente_gigante, "Componente gigante", "")
p7 <- graficar_serie(metricas$g_out_prom, "Grado salida promedio", "")
p8 <- graficar_serie(metricas$g_in_prom, "Grado entrada promedio", "")
gridExtra::grid.arrange(p1, p2, p3, p4, p5, p6, p7, p8, ncol = 2)
vars_metr <- c("densidad", "clustering", "asortatividad", "reciprocidad",
"distancia_media", "componente_gigante", "g_out_prom", "g_in_prom")
labs_metr <- c("Densidad", "Clustering", "Asortatividad", "Reciprocidad",
"Distancia media", "Comp. gigante", "Grado salida", "Grado entrada")
res_mw <- lapply(seq_along(vars_metr), function(i) {
v <- metricas[[vars_metr[i]]]
a <- v[metricas$semana <= 83]; d <- v[metricas$semana > 83]
wt <- wilcox.test(a, d)
data.frame(
Métrica = labs_metr[i],
Mediana_ant = round(median(a, na.rm = TRUE), 4),
Mediana_post = round(median(d, na.rm = TRUE), 4),
p_valor = signif(wt$p.value, 3),
Significativa = ifelse(wt$p.value < 0.05, "Sí", "No")
)
})
res_mw_df <- do.call(rbind, res_mw)
kable(res_mw_df,
caption = "Prueba Mann–Whitney: comparación antes/después semana 83",
align = "lrrrr") %>%
kable_styling(bootstrap_options = c("striped", "hover"), full_width = FALSE) %>%
row_spec(0, bold = TRUE, color = "white", background = "#70284a") %>%
row_spec(which(res_mw_df$Significativa == "Sí"), background = "#fbe6c5")| Métrica | Mediana_ant | Mediana_post | p_valor | Significativa |
|---|---|---|---|---|
| Densidad | 0.1254 | 0.1975 | 0 | Sí |
| Clustering | 0.5238 | 0.4647 | 0 | Sí |
| Asortatividad | 0.0641 | -0.2983 | 0 | Sí |
| Reciprocidad | 0.5284 | 0.5936 | 0 | Sí |
| Distancia media | 2.4618 | 1.8609 | 0 | Sí |
| Comp. gigante | 65.0000 | 69.0000 | 0 | Sí |
| Grado salida | 8.7746 | 13.8239 | 0 | Sí |
| Grado entrada | 8.7746 | 13.8239 | 0 | Sí |
12.2 b) Agrupamiento jerárquico semanal
pg1 <- graficar_serie(metricas_agru$n_clusters, "Número de grupos", "")
pg2 <- graficar_serie(metricas_agru$modularidad, "Modularidad", "")
gridExtra::grid.arrange(pg1, pg2, ncol = 2)
Antes de la semana 83, la red presenta mayor fragmentación (mediana de grupos ~9) con mayor variabilidad semanal. Después de la introducción de la plataforma electrónica, el número de grupos se estabiliza alrededor de 5, y la modularidad desciende (~0.12 frente a ~0.17), indicando comunidades más interconectadas entre sí aunque menos bien definidas. Esto es consistente con una mayor integración del mercado tras la adopción de la negociación electrónica.
12.3 c) Redes de consenso Y₀ e Y₁
Y_0 <- apply(Y71[1:83, , ], c(2, 3), mean)
Y_1 <- apply(Y71[84:201, , ], c(2, 3), mean)
Y_0 <- ifelse(Y_0 > 0.5, 1, 0)
Y_1 <- ifelse(Y_1 > 0.5, 1, 0)
g0 <- graph_from_adjacency_matrix(Y_0, mode = "directed")
g1 <- graph_from_adjacency_matrix(Y_1, mode = "directed")
calc_metr_g <- function(g) {
data.frame(
densidad = edge_density(g),
clustering = transitivity(g, type = "global"),
asortatividad = assortativity_degree(g, directed = TRUE),
reciprocidad = reciprocity(g),
distancia_media = mean_distance(g, directed = TRUE, unconnected = TRUE),
comp_gigante = max(components(as.undirected(g))$csize),
grado_out = mean(degree(g, mode = "out")),
grado_in = mean(degree(g, mode = "in"))
)
}
tbl_comp <- rbind(Antes = calc_metr_g(g0), Después = calc_metr_g(g1)) %>%
as.data.frame() %>% tibble::rownames_to_column("Período")
kable(tbl_comp,
caption = "Métricas estructurales de las redes de consenso Y₀ e Y₁",
align = "lrrrrrrrr", digits = 3) %>%
kable_styling(bootstrap_options = c("striped", "hover"), full_width = TRUE) %>%
row_spec(0, bold = TRUE, color = "white", background = "#70284a")| Período | densidad | clustering | asortatividad | reciprocidad | distancia_media | comp_gigante | grado_out | grado_in |
|---|---|---|---|---|---|---|---|---|
| Antes | 0.073 | 0.461 | -0.154 | 0.878 | 2.090 | 44 | 5.099 | 5.099 |
| Después | 0.120 | 0.269 | -0.618 | 0.933 | 1.933 | 64 | 8.366 | 8.366 |
La densidad aumenta de Y₀ a Y₁, indicando mayor proporción de conexiones estables en el período post-electrónico. La reciprocidad también aumenta, sugiriendo relaciones de intercambio más simétricas. La asortatividad se vuelve más negativa, reforzando la tendencia disasortativa (nodos de alto grado conectando con nodos de bajo grado), lo cual es consistente con una estructura de mercado más jerárquica. El componente gigante crece, señal de mayor integración del mercado.
12.4 d) Visualización componentes gigantes Y₀ e Y₁
g0s <- as.undirected(g0, mode = "collapse")
g1s <- as.undirected(g1, mode = "collapse")
extraer_gigante <- function(g) {
comp <- components(g)
induced_subgraph(g, which(comp$membership == which.max(comp$csize)))
}
gig0 <- extraer_gigante(g0s)
gig1 <- extraer_gigante(g1s)
fg0 <- cluster_fast_greedy(gig0)
fg1 <- cluster_fast_greedy(gig1)
pal_c <- rainbow(max(length(fg0), length(fg1)))
rescale_size <- function(x) 3 + 15 * (x - min(x)) / (max(x) - min(x) + 1e-9)
V(gig0)$color <- pal_c[membership(fg0)]
V(gig1)$color <- pal_c[membership(fg1)]
V(gig0)$size <- rescale_size(strength(gig0))
V(gig1)$size <- rescale_size(strength(gig1))
set.seed(123)
par(mfrow = c(1, 2), mar = c(1, 1, 3, 1))
plot(gig0,
layout = layout_with_fr(gig0, niter = 1000),
vertex.label = NA,
vertex.frame.color = "white",
edge.color = rgb(0.6, 0.6, 0.6, 0.3),
edge.width = 0.7,
main = "Comp. gigante Y₀ (antes de semana 83)")
plot(gig1,
layout = layout_with_fr(gig1, niter = 1000),
vertex.label = NA,
vertex.frame.color = "white",
edge.color = rgb(0.6, 0.6, 0.6, 0.3),
edge.width = 0.7,
main = "Comp. gigante Y₁ (después de semana 83)")
Interpretación: la red Y₀ muestra comunidades mejor delimitadas con una distribución más equilibrada de la fuerza entre nodos. En Y₁ la estructura se centraliza marcadamente: unos pocos nodos concentran casi toda la fuerza de la red (tamaño de vértice notablemente mayor), y las comunidades tienen fronteras más difusas. Esto sugiere que la plataforma electrónica no fragmentó el mercado sino que lo concentró en torno a actores estratégicos, transitando de un sistema descentralizado a uno con intermediarios dominantes.
13 Punto 11 (enunciado): Análisis de Cien años de soledad
13.1 Importación del texto
texto_completo <- read_lines("gabriel_garcia_marquez_cien_annos_soledad.txt")
# Limpiar metadatos editoriales repetitivos
patron_meta <- "Gabriel García Márquez|Cien años de soledad|EDITADO POR|ediciones la cueva|Para Jomi|María Luisa Elio"
texto_completo <- texto_completo[!grepl(patron_meta, texto_completo, ignore.case = TRUE)]
texto_completo <- texto_completo[nchar(trimws(texto_completo)) > 0]
cat("Líneas después de limpieza:", length(texto_completo), "\n")## Líneas después de limpieza: 915813.2 División en 20 segmentos (capítulos aproximados)
texto_df <- tibble(line = seq_along(texto_completo), text = texto_completo)
lpc <- nrow(texto_df) / 20
texto_df <- texto_df %>%
mutate(capitulo = ceiling(line / lpc),
capitulo = paste0("Cap_", sprintf("%02d", capitulo)))
corpus_caps <- texto_df %>%
group_by(capitulo) %>%
summarise(text = paste(text, collapse = " "), n_lineas = n(), .groups = "drop")
cat("Capítulos:", nrow(corpus_caps), "\n")## Capítulos: 2013.3 Tokenización y stopwords personalizadas
tokens_caps <- corpus_caps %>%
unnest_tokens(output = word, input = text) %>%
filter(!is.na(word))
# Stopwords base + personalizadas para García Márquez
sw_es <- tibble(word = tm::stopwords("spanish"))
sw_custom <- tibble(word = c(
# Metadatos
"gabriel","garcia","marquez","cien","anos","soledad","editado",
"ediciones","editorial","pagina","capitulo","cueva",
# Personajes principales
"aureliano","arcadio","ursula","buendia","jose","amaranta","remedios",
"fernanda","petra","pilar","rebeca","santa","sofia","renata","meme",
"mauricio","babilonia","melquiades","gerineldo","crespi","pietro",
"catalan","apolinar","moscote","prudencio",
# Títulos
"coronel","don","dona","general","capitan","senor","senora",
# Lugar
"macondo",
# Verbos comunes
"ser","era","fue","sido","sea","estar","estaba","estuvo","estado",
"haber","habia","hubo","hay","han","hacer","hizo","hacia","hecho",
"decir","dijo","decia","dice","ir","iba","tener","tuvo","tenia",
"poner","puso","ver","vio","veia","dar","dio","saber","supo","poder",
"pudo","querer","quiso","llegar","llego","volver","volvio","quedar",
"quedo","seguir","siguio","encontrar","encontro","parecer","parecio",
"creer","creyo","pensar","penso","sentir","sintio","mirar","miro",
"pasar","paso","comenzar","comenzo","empezar","empezo","salir","salio",
"entrar","entro","venir","vino","dejar","dejo","llevar","llevo",
"morir","murio","vivir","vivio","abrir","abrio","cerrar","cerro",
"escribir","escribio","conocer","conocio","perder","perdio",
# Adverbios / cuantificadores
"despues","entonces","luego","ahora","pronto","tarde","temprano",
"siempre","nunca","jamas","aun","todavia","ya","vez","veces",
"dia","dias","noche","noches","manana","ano","anos","mes","meses",
"tiempo","momento","hora","antes","durante","apenas","hasta",
"mas","menos","mucho","poco","muy","tan","tanto","casi","solo",
"tambien","ademas","incluso","mismo","misma","otro","otra","todo",
"toda","cada","algun","alguna","algo","alguien","ningun","ninguna",
"nada","nadie","primer","primero","ultimo","unico","varios","ambos",
"dos","tres","cuatro","cinco",
# Pronombres / preposiciones
"yo","tu","el","ella","nosotros","ellos","me","te","se","nos","les",
"le","lo","la","los","las","mi","si","este","esta","esto","ese","esa",
"aquel","aquella","quien","cual","cuyo",
"y","e","o","u","ni","pero","mas","sino","aunque","sin","embargo",
"porque","pues","asi","como","segun","si","a","ante","bajo","con",
"contra","de","desde","en","entre","hacia","para","por","sobre","tras",
# Sustantivos genéricos
"casa","casas","puerta","habitacion","cuarto","sala","patio","calle",
"lado","parte","lugar","cosa","cosas","manera","forma","modo",
"hombre","hombres","mujer","mujeres","nino","ninos","hijo","hijos",
"hija","hijas","padre","padres","madre","madres",
"mano","cara","ojos","cabeza","cuerpo","pie","brazo","pierna",
"palabra","palabras","voz","voces","mundo","tierra","aire","agua",
"luz","sombra","color","vida","muerte","bien","mal","grande","gran",
"pequeno","nuevo","viejo","bueno","malo","largo","corto","alto","bajo",
"gente","personas","familia","familias","siendo","dado","verdad","fin"
))
sw_all <- bind_rows(sw_es, sw_custom) %>%
mutate(word = stri_trans_general(word, "Latin-ASCII")) %>%
distinct(word)
tokens_limpios <- tokens_caps %>%
filter(!grepl("[0-9]", word)) %>%
mutate(word = stri_trans_general(word, "Latin-ASCII")) %>%
anti_join(sw_all, by = "word")
cat("Tokens finales:", nrow(tokens_limpios), "| Únicos:", n_distinct(tokens_limpios$word), "\n")## Tokens finales: 50268 | Únicos: 1505913.4 Análisis multidimensional de sentimientos
# Siete dimensiones literarias del universo de García Márquez
dim_list <- list(
tibble(word = c("fantasma","espectro","aparicion","milagro","magia","hechizo",
"premonicion","profecia","alquimia","pergamino","gitano",
"milagroso","sobrenatural","levitacion","vision","augurio",
"destino","misterio","mariposas","lluvia","diluvio","eterno",
"infinito","laberinto","memoria","olvido"),
dimension = "Realismo Mágico"),
tibble(word = c("soledad","ruina","abandono","condena","tristeza","desesperacion",
"silencio","derrota","fracaso","amargura","destruccion","ceniza",
"melancolia","oscuridad","tormenta","sepultura","vacio","angustia"),
dimension = "Fatalismo"),
tibble(word = c("guerra","fusilamiento","ejercito","liberales","conservadores",
"batalla","revolucion","matanza","violencia","soldados","gobierno",
"dictadura","disparo","sangre","cadaver","masacre","militares",
"armas","combate"),
dimension = "Violencia Política"),
tibble(word = c("calor","banana","rio","pantano","selva","humedad","polvo",
"flores","mar","sol","pescado","olor","sudor","fruta",
"caribe","tropical","cielo","nube"),
dimension = "Sensorial Tropical"),
tibble(word = c("apellido","herencia","repeticion","generacion","estirpe",
"ancestro","clan","parentesco","descendencia","gemelos"),
dimension = "Linaje"),
tibble(word = c("dios","iglesia","pecado","alma","bendicion","maldicion",
"rezar","santo","virgen","espiritu","infierno","profecia",
"sacerdote","cruz","fe","divino","sagrado"),
dimension = "Místico-Religioso"),
tibble(word = c("amor","deseo","pasion","obsesion","celos","amante","beso",
"espera","nostalgia","locura","anhelo","corazon","ternura"),
dimension = "Amor y Deseo")
)
lexicon_lit <- bind_rows(dim_list) %>%
mutate(word = stri_trans_general(word, "Latin-ASCII"))
dims_caps <- tokens_limpios %>%
inner_join(lexicon_lit, by = "word") %>%
count(capitulo, dimension) %>%
group_by(capitulo) %>%
mutate(proporcion = n / sum(n)) %>%
ungroup()13.4.1 Evolución dimensional por capítulo
dims_caps %>%
mutate(idx = as.numeric(str_extract(capitulo, "[0-9]+"))) %>%
ggplot(aes(idx, n, color = dimension, group = dimension)) +
geom_line(linewidth = 1.1, alpha = 0.85) +
geom_point(size = 2) +
scale_color_brewer(palette = "Set2") +
labs(title = "Evolución de dimensiones literarias — Cien Años de Soledad",
subtitle = "Frecuencia de palabras por campo semántico a lo largo de los capítulos",
x = "Capítulo", y = "Frecuencia", color = "Dimensión") +
theme_minimal() +
theme(legend.position = "bottom", plot.title = element_text(face = "bold"))
13.4.2 Mapa de calor dimensional
dims_caps %>%
mutate(idx = as.numeric(str_extract(capitulo, "[0-9]+"))) %>%
ggplot(aes(idx, dimension, fill = n)) +
geom_tile(color = "white") +
scale_fill_gradient(low = "white", high = "#70284a") +
labs(title = "Intensidad dimensional por capítulo",
x = "Capítulo", y = NULL, fill = "Frecuencia") +
theme_minimal() +
theme(plot.title = element_text(face = "bold"))
13.5 Análisis de redes: skipgramas
skipgramas_caps <- corpus_caps %>%
unnest_tokens(skipgram, text, token = "skip_ngrams", n = 2) %>%
filter(!is.na(skipgram))
skipgramas_caps$num_words <- map_int(skipgramas_caps$skipgram, wordcount)
skipgramas_sep <- skipgramas_caps %>%
filter(num_words == 2) %>%
separate(skipgram, c("word1", "word2"), sep = " ") %>%
filter(!grepl("[0-9]", word1), !grepl("[0-9]", word2)) %>%
mutate(word1 = stri_trans_general(word1, "Latin-ASCII"),
word2 = stri_trans_general(word2, "Latin-ASCII")) %>%
filter(!word1 %in% sw_all$word, !word2 %in% sw_all$word,
!is.na(word1), !is.na(word2))
skip_count <- skipgramas_sep %>%
count(capitulo, word1, word2, sort = TRUE) %>%
rename(weight = n) %>%
filter(weight >= 3)
cat("Skipgramas frecuentes (≥3):", nrow(skip_count), "\n")## Skipgramas frecuentes (≥3): 8213.5.1 Redes de co-ocurrencia por capítulo
crear_red_cap <- function(datos, cap, umbral = 3) {
dc <- datos %>% filter(capitulo == cap, weight >= umbral)
if (nrow(dc) == 0) return(NULL)
g <- graph_from_data_frame(dc[, c("word1","word2","weight")], directed = FALSE)
igraph::simplify(g) # namespace explícito: purrr también tiene simplify()
}
caps_v <- unique(skip_count$capitulo)
redes_cap <- setNames(lapply(caps_v, crear_red_cap, datos = skip_count), caps_v)
metricas_redes <- lapply(names(redes_cap), function(nm) {
g <- redes_cap[[nm]]
if (is.null(g) || vcount(g) < 3) return(NULL)
data.frame(capitulo = nm,
orden = vcount(g), tamano = ecount(g),
densidad = edge_density(g),
grado_medio = mean(degree(g)),
transitividad = transitivity(g, type = "global"),
componentes = components(g)$no)
}) %>% Filter(Negate(is.null), .) %>% do.call(rbind, .)
top_dense <- metricas_redes %>%
arrange(desc(densidad)) %>%
slice_head(n = 4) %>%
pull(capitulo)
par(mfrow = c(2, 2), mar = c(2, 2, 3, 2))
for (cap in top_dense) {
g <- redes_cap[[cap]]
if (!is.null(g) && vcount(g) >= 3) {
cl_mem <- components(g)$membership
gcc <- induced_subgraph(g, which(cl_mem == which.max(components(g)$csize)))
if (vcount(gcc) >= 3) {
set.seed(42)
plot(gcc,
layout = layout_with_fr,
vertex.color = adjustcolor("#70284a", 0.35),
vertex.frame.color = "#70284a",
vertex.size = 3 * sqrt(strength(gcc)),
vertex.label.cex = 0.7,
vertex.label.color = "black",
edge.width = 1.5 * E(gcc)$weight / max(E(gcc)$weight),
edge.color = adjustcolor("gray60", 0.5),
main = cap)
}
}
}13.6 Modelado de tópicos con LDA
palabras_freq <- tokens_limpios %>% count(capitulo, word, sort = TRUE)
dtm_caps <- palabras_freq %>%
cast_dtm(document = capitulo, term = word, value = n)
set.seed(1702)
modelo_lda <- LDA(dtm_caps, k = 6, method = "Gibbs",
control = list(seed = 1702, burnin = 1000,
iter = 2000, thin = 100))
cat("Perplejidad:", round(perplexity(modelo_lda, dtm_caps), 2), "\n")## Perplejidad: 6186.213.6.1 Palabras características por tópico
top_beta <- tidy(modelo_lda, matrix = "beta") %>%
group_by(topic) %>%
slice_max(beta, n = 10) %>%
ungroup() %>%
mutate(term = reorder_within(term, beta, topic))
ggplot(top_beta, aes(term, beta, fill = factor(topic))) +
geom_col(show.legend = FALSE) +
facet_wrap(~topic, scales = "free",
labeller = labeller(topic = function(x) paste("Tópico", x))) +
coord_flip() +
scale_x_reordered() +
scale_fill_brewer(palette = "Set2") +
labs(title = "Palabras características por tópico (LDA — β)",
subtitle = "Probabilidad β de cada palabra en el tópico",
x = NULL, y = "Probabilidad β") +
theme_minimal() +
theme(strip.text = element_text(face = "bold"),
plot.title = element_text(face = "bold"))
13.6.2 Distribución de tópicos por capítulo
tidy(modelo_lda, matrix = "gamma") %>%
mutate(idx = as.numeric(str_extract(document, "[0-9]+"))) %>%
ggplot(aes(idx, gamma, fill = factor(topic))) +
geom_col(position = "fill") +
scale_fill_brewer(palette = "Set2",
labels = paste0("T", 1:6)) +
scale_y_continuous(labels = scales::label_percent()) +
labs(title = "Composición de tópicos por capítulo — Cien Años de Soledad",
subtitle = "Proporción γ de cada tópico a lo largo de los capítulos",
x = "Capítulo", y = "Proporción γ", fill = "Tópico") +
theme_minimal() +
theme(plot.title = element_text(face = "bold"),
legend.position = "bottom")
Análisis: el modelo LDA identifica seis tópicos que capturan líneas temáticas reconocibles en la novela: las guerras civiles, la saga familiar, los eventos sobrenaturales, el deterioro y la decadencia, las relaciones amorosas, y el contexto histórico-político. La composición por capítulo muestra alternancia temática que refleja los ciclos narrativos de la obra. El análisis dimensional confirma que el realismo mágico y el fatalismo son las dimensiones más persistentes, mientras que la violencia política se concentra en los capítulos centrales, coincidiendo con el periodo de las guerras civiles del coronel Aureliano Buendía.
14 Punto 12 (enunciado): Modelos de estructura y formación de redes
14.1 Modelo de Erdős–Rényi
El modelo de grafos aleatorios de Erdős y Rényi genera conexiones con probabilidad fija \(p\) (modelo \(G(n,p)\)). Para grafos grandes, la distribución del grado converge a una Poisson. La conectividad completa se alcanza cuando \(p > \ln(n)/n\), incluso con grados promedio bajos.
set.seed(230125)
g7.1 <- sample_gnm(n = 12, m = 10)
g7.2 <- sample_gnm(n = 12, m = 10)
par(mfrow = c(1, 2), mar = c(1, 1, 3, 1), bg = "white")
plot_er <- function(g, tit) {
plot(g,
layout = layout_with_fr(g),
vertex.color = "#70284a",
vertex.size = 15,
vertex.frame.color = "white",
vertex.label.color = "white",
vertex.label.cex = 0.8,
edge.color = "gray85",
edge.width = 1.2,
main = tit)
}
plot_er(g7.1, "Primer grafo generado")
plot_er(g7.2, "Segundo grafo generado")
plot(degree_distribution(sample_gnp(1000, 0.005)),
type = "b", pch = 19, lwd = 2, col = "#70284a",
xlab = "Grado", ylab = "Proporción",
main = "Distribución de grados — G(1000, 0.005)")
grid(col = "gray85")
14.1.1 Componente gigante en función del grado promedio
set.seed(230125)
cnrd <- runif(500, 1, 8)
cmp_rpr <- sapply(cnrd, function(x) {
g <- sample_gnp(1000, p = x / 999)
max(igraph::components(g)$csize) / 1000
})
sm <- smooth.spline(cnrd, cmp_rpr, spar = 0.25)
plot(cnrd, cmp_rpr, type = "p", cex = 0.5, col = "#70284a",
xlab = "Grado promedio esperado",
ylab = "Proporción componente gigante")
lines(sm, lwd = 1.5, col = "#dc7176")
grid(col = "gray85")
14.1.2 Diámetro según tamaño de red
library(lattice)
n_vec <- rep(c(50, 100, 500, 1000, 2000), 50)
g_diam <- sapply(n_vec, function(x) {
igraph::diameter(sample_gnp(x, p = 6 / (x - 1)))
})
bwplot(g_diam ~ as.factor(n_vec),
panel = panel.violin,
xlab = "Tamaño de la red",
ylab = "Diámetro",
col = "#dc7176")
Incluso multiplicando el tamaño de la red 40 veces, el diámetro no crece de forma sustancial, evidenciando el fenómeno de mundo pequeño inherente a los grafos aleatorios de Erdős–Rényi.
14.2 Modelo de mundo pequeño
El modelo de Watts–Strogatz parte de una red circular regular y reconecta aristas con probabilidad \(p\). Con \(p = 0\) se tiene la estructura original; con \(p = 1\) se obtiene un grafo aleatorio de Erdős–Rényi. El hallazgo central es que basta reconectar una fracción pequeña de aristas para reducir drásticamente el diámetro.
set.seed(230125)
g_sw <- list(
sample_smallworld(1, 30, 2, 0),
sample_smallworld(1, 30, 2, 0.05),
sample_smallworld(1, 30, 2, 0.20),
sample_smallworld(1, 30, 2, 1)
)
probs <- c("p = 0", "p = 0.05", "p = 0.20", "p = 1")
op <- par(mfrow = c(2, 2), mar = c(2, 1, 3, 1))
for (i in 1:4) {
plot(g_sw[[i]], vertex.label = NA,
layout = layout_with_kk,
main = probs[i],
vertex.color = "#dc7176")
}
14.2.1 Reducción del diámetro al reconectar aristas
set.seed(230125)
g100 <- sample_smallworld(1, 100, 2, 0)
cat("Diámetro inicial:", diameter(g100), "\n")## Diámetro inicial: 25p_vect <- rep(1:30, each = 10)
g_d <- sapply(p_vect, function(x) {
diameter(watts.strogatz.game(1, 100, 2, p = x / 200))
})
sspl <- smooth.spline(p_vect, g_d, spar = 0.35)
plot(jitter(p_vect, 1), g_d, col = "grey60", pch = 19,
xlab = "Aristas reconectadas",
ylab = "Diámetro",
main = "Reducción del diámetro — Small-World")
lines(sspl, lwd = 2, col = "#70284a")
grid(col = "gray85")
14.3 Modelo de escala libre (apego preferencial)
Las redes libres de escala exhiben una distribución del grado tipo ley de potencia, generada por el mecanismo de apego preferencial: los nodos nuevos se conectan con probabilidad proporcional al grado existente (“los ricos se hacen más ricos”). Los nodos con más de 9 conexiones se destacan en color oscuro.
set.seed(230125)
g_pa <- sample_pa(500, directed = FALSE)
V(g_pa)$color <- "#fbe6c5"
V(g_pa)[igraph::degree(g_pa) > 9]$color <- "#70284a"
V(g_pa)$size <- rescale(igraph::degree(g_pa), to = c(2, 8))
plot(g_pa,
layout = layout_with_fr(g_pa),
vertex.label = NA,
vertex.size = V(g_pa)$size,
edge.color = adjustcolor("gray70", alpha.f = 0.4),
edge.width = 0.7,
margin = 0)
14.3.1 Distribución del grado (lineal y log-log)
par(mfrow = c(1, 2))
dd <- igraph::degree_distribution(g_pa)
plot(dd, xlab = "Grado", ylab = "Proporción",
col = "#70284a", pch = 19, main = "Escala lineal")
grid(col = "gray85")
dd_pos <- dd[dd > 0]
plot(dd_pos, log = "xy",
xlab = "Grado", ylab = "Proporción",
col = "#70284a", pch = 19, main = "Escala log-log")
grid(col = "gray85")
14.3.2 Evolución de la red según tamaño
set.seed(230125)
g_pa_list <- list(
sample_pa(10, m = 1, directed = FALSE),
sample_pa(25, m = 1, directed = FALSE),
sample_pa(50, m = 1, directed = FALSE),
sample_pa(100, m = 1, directed = FALSE)
)
colores_pa <- c("#f2a28a", "#dc7176", "#b24b65", "#70284a")
tamanhos <- c("n = 10", "n = 25", "n = 50", "n = 100")
op <- par(mfrow = c(2, 2), mar = c(1, 1, 3, 1))
for (i in 1:4) {
plot(g_pa_list[[i]],
layout = layout_with_fr(g_pa_list[[i]]),
vertex.label = NA,
vertex.size = 5,
vertex.color = colores_pa[i],
vertex.frame.color = NA,
edge.color = "gray75",
main = tamanhos[i])
}
14.4 Comparación de modelos con la red empírica de Zachary
set.seed(230125)
g_emp <- make_graph("Zachary")
n_nodes <- gorder(g_emp)
g_rnd <- sample_gnp(n_nodes, edge_density(g_emp), directed = FALSE)
g_smwrld <- sample_smallworld(1, n_nodes, 2, 0.25)
g_prfatt <- sample_pa(n_nodes, m = 2, directed = FALSE)
op <- par(mfrow = c(2, 2), mar = c(1, 1, 3, 1))
plot_model <- function(g, col, tit) {
plot(g, layout = layout_with_fr(g),
vertex.label = NA, vertex.size = 10,
vertex.color = col, vertex.frame.color = NA,
edge.color = adjustcolor("gray70", alpha.f = 0.5),
main = tit)
}
plot_model(g_emp, "#70284a", "Red empírica (Karate Club)")
plot_model(g_rnd, "#f2a28a", "Erdős–Rényi")
plot_model(g_smwrld, "#dc7176", "Mundo pequeño")
plot_model(g_prfatt, "#b24b65", "Ley de potencias")
14.4.1 Tabla comparativa de características
net_metrics <- function(g, nombre) {
data.frame(
Modelo = nombre,
Nodos = gorder(g),
Densidad = round(edge_density(g), 3),
Grado_prom = round(mean(igraph::degree(g)), 3),
Transitividad = round(transitivity(g, type = "global"), 3),
Aislados = sum(igraph::degree(g) == 0)
)
}
tabla_modelos <- rbind(
net_metrics(g_rnd, "Erdős–Rényi"),
net_metrics(g_smwrld, "Mundo pequeño"),
net_metrics(g_prfatt, "Ley de potencias"),
net_metrics(g_emp, "Karate Club (empírico)")
)
kable(tabla_modelos,
caption = "Comparación de modelos de redes con red empírica",
align = "lcrrrr") %>%
kable_styling(bootstrap_options = c("striped", "hover"),
full_width = FALSE) %>%
row_spec(0, bold = TRUE, color = "white", background = "#70284a") %>%
row_spec(4, bold = TRUE, background = "#fbe6c5")| Modelo | Nodos | Densidad | Grado_prom | Transitividad | Aislados |
|---|---|---|---|---|---|
| Erdős–Rényi | 34 | 0.135 | 4.471 | 0.173 | 1 |
| Mundo pequeño | 34 | 0.121 | 4.000 | 0.130 | 0 |
| Ley de potencias | 34 | 0.116 | 3.824 | 0.145 | 0 |
| Karate Club (empírico) | 34 | 0.139 | 4.588 | 0.256 | 0 |
14.4.2 Distribuciones de grado comparadas
deg_dist_df <- function(g) {
tb <- table(igraph::degree(g))
data.frame(degree = as.numeric(names(tb)),
freq = as.numeric(tb) / sum(tb))
}
df_e <- deg_dist_df(g_emp); df_r <- deg_dist_df(g_rnd)
df_sw <- deg_dist_df(g_smwrld); df_pa <- deg_dist_df(g_prfatt)
op <- par(mfrow = c(2, 2), mar = c(4, 4, 3, 1))
for (info in list(list(df_r, "Erdős–Rényi"), list(df_sw, "Mundo pequeño"),
list(df_pa, "Ley de potencias"), list(df_e, "Karate Club"))) {
plot(info[[1]]$degree, info[[1]]$freq,
type = "b", pch = 1, col = "#70284a",
xlab = "Grado", ylab = "Proporción",
main = info[[2]])
grid(col = "gray85")
}
Síntesis: el modelo de Erdős–Rényi genera distribuciones de grado tipo Poisson y escasa transitividad, propiedades que no coinciden con redes sociales reales. El modelo de mundo pequeño mejora la transitividad pero mantiene una distribución de grado relativamente homogénea. El modelo de apego preferencial reproduce la cola pesada (ley de potencia) característica de redes reales, aunque genera grafos con baja transitividad local. La red de Zachary, como red social empírica, combina propiedades de los tres modelos: transitividad moderada, diámetro pequeño y distribución de grado con cola larga. Esto ilustra que ningún modelo simple captura la complejidad completa de las redes sociales.
Fin del taller.