Taller 4 — Estructuras Sociales Cognitivas (CSS)
Análisis Estadístico de Redes | Maestría en Ciencias – Estadística
Helen Granados Rodríguez
CC: 1000835249
hgranados@unal.edu.co
Universidad Nacional de Colombia
2026-05-28
1 Introducción
Este documento analiza la Estructura Social Cognitiva (CSS, por sus siglas en inglés) de un grupo de 15 estudiantes del curso ofrecido por el Departamento de Estadística de la Universidad Nacional de Colombia durante el segundo semestre de 2022. El enfoque sigue el trabajo pionero de Krackhardt (1987) y los desarrollos posteriores de Sosa y Rodríguez (2021).
La CSS está conformada por \(I = 15\) matrices de adyacencia \(A^{(j)}\) de tamaño \(15 \times 15\), donde \(a_{i,j,k} = 1\) indica que el estudiante \(k\) percibe una relación de amistad entre los estudiantes \(i\) y \(j\).
2 Carga de librerías y datos
suppressMessages({
library(igraph)
library(dplyr)
library(tidyr)
library(ggplot2)
library(knitr)
library(kableExtra)
library(truncnorm)
library(coda)
library(pROC)
})
# gridExtra para paneles de ggplot — instalar si no esta disponible:
# install.packages("gridExtra")
if (requireNamespace("gridExtra", quietly = TRUE)) {
library(gridExtra)
gridExtra_ok <- TRUE
} else {
gridExtra_ok <- FALSE
message("gridExtra no disponible — los paneles dobles se mostraran separados.")
}# Ajusta la ruta al directorio de trabajo donde guardaste los archivos
css_raw <- as.matrix(read.table("CSS2022.txt", header = FALSE))
covs <- read.table("covs2022.txt", header = TRUE)
# Parametros estructurales
I <- 15 # numero de actores (y de percepciones)
n <- I
# El archivo CSS tiene 15*15 = 225 filas: cada bloque de 15 filas es A^(k)
stopifnot(nrow(css_raw) == I * I) # verificacion de integridad
# Separar en lista de I matrices 15x15
A_list <- lapply(seq_len(I), function(k) {
css_raw[((k - 1) * I + 1):(k * I), ]
})
names(A_list) <- paste0("Percepcion_", seq_len(I))
# Covariables
covs$id <- seq_len(I)
covs$sexo_f <- factor(covs$sexo, levels = c(0,1), labels = c("Mujer","Hombre"))
covs$prog_f <- factor(covs$programa,levels = c(0,1), labels = c("Pregrado","Posgrado"))
cat("Actores:", I, "| Percepciones:", length(A_list), "\n")## Actores: 15 | Percepciones: 15kable(covs,
caption = "Covariables individuales de los estudiantes",
col.names = c("Sexo (0=M,1=H)","Edad","Programa (0=Pre,1=Pos)",
"ID","Sexo","Programa"),
align = c("c","c","c","c","l","l")) %>%
kable_styling(bootstrap_options = c("striped","hover"), full_width = FALSE) %>%
row_spec(0, background = "#70284a", color = "white")| Sexo (0=M,1=H) | Edad | Programa (0=Pre,1=Pos) | ID | Sexo | Programa |
|---|---|---|---|---|---|
| 0 | 20 | 0 | 1 | Mujer | Pregrado |
| 1 | 25 | 1 | 2 | Hombre | Posgrado |
| 0 | 20 | 0 | 3 | Mujer | Pregrado |
| 0 | 25 | 1 | 4 | Mujer | Posgrado |
| 0 | 24 | 0 | 5 | Mujer | Pregrado |
| 0 | 28 | 1 | 6 | Mujer | Posgrado |
| 1 | 20 | 0 | 7 | Hombre | Pregrado |
| 0 | 27 | 1 | 8 | Mujer | Posgrado |
| 1 | 19 | 0 | 9 | Hombre | Pregrado |
| 1 | 27 | 0 | 10 | Hombre | Pregrado |
| 1 | 21 | 0 | 11 | Hombre | Pregrado |
| 1 | 28 | 1 | 12 | Hombre | Posgrado |
| 0 | 21 | 0 | 13 | Mujer | Pregrado |
| 1 | 21 | 0 | 14 | Hombre | Pregrado |
| 0 | 22 | 0 | 15 | Mujer | Pregrado |
3 Red de consenso
La red de consenso \(A = [a_{i,j}]\) se construye aplicando la regla:
\[a_{i,j} = \begin{cases} 1 & \text{si } \frac{1}{I}\sum_{k=1}^{I} a_{i,j,k} > 0.25 \\ 0 & \text{en otro caso} \end{cases}\]
Es decir, existe una arista de consenso entre \(i\) y \(j\) si más del 25% de los actores perciben esa relación (Krackhardt, 1987).
# Sumar las I matrices elemento a elemento
A_suma <- Reduce("+", A_list)
# Aplicar la regla de consenso (umbral > 0.25)
A_consenso <- (A_suma / I > 0.25) * 1L
diag(A_consenso) <- 0L
# Grafo de consenso
g_consenso <- graph_from_adjacency_matrix(A_consenso,
mode = "undirected",
diag = FALSE)
V(g_consenso)$sexo <- as.character(covs$sexo_f)
V(g_consenso)$edad <- covs$edad
V(g_consenso)$programa <- as.character(covs$prog_f)
cat("Red de consenso — Orden:", vcount(g_consenso),
"| Aristas:", ecount(g_consenso), "\n")## Red de consenso — Orden: 15 | Aristas: 31## Densidad: 0.29524 Visualizaciones: percepciones individuales y consenso
Se presentan las 15 percepciones individuales más la red de consenso en layout circular, sin decoración adicional, conforme al enunciado.
# Paleta: Mujer = lila claro, Hombre = morado oscuro
col_por_sexo <- function(sexo_vec) {
ifelse(sexo_vec %in% c("Hombre", "1"), "#70284a", "#c9a8c0")
}
col_nodos_cons <- col_por_sexo(covs$sexo_f)4.1 Las 15 percepciones individuales (layout circular)
par(mfrow = c(4, 4), mar = c(1, 1, 2, 1))
set.seed(42)
lay_circ <- layout_in_circle(graph_from_adjacency_matrix(
matrix(0, I, I), mode = "undirected"))
for (k in seq_len(I)) {
g_k <- graph_from_adjacency_matrix(A_list[[k]],
mode = "directed",
diag = FALSE)
plot(g_k,
layout = lay_circ,
vertex.size = 9,
vertex.color = col_nodos_cons,
vertex.frame.color = "#3d0f28",
vertex.label = seq_len(I),
vertex.label.cex = 0.55,
vertex.label.color = "white",
edge.arrow.size = 0.25,
edge.color = adjustcolor("#70284a", 0.55),
edge.width = 0.8,
main = paste0("Percepcion ", k),
cex.main = 0.85)
}
# Panel final: red de consenso
plot(g_consenso,
layout = lay_circ,
vertex.size = 9,
vertex.color = col_nodos_cons,
vertex.frame.color = "#3d0f28",
vertex.label = seq_len(I),
vertex.label.cex = 0.55,
vertex.label.color = "white",
edge.color = adjustcolor("#3d0f28", 0.7),
edge.width = 1.2,
main = "Red de Consenso",
cex.main = 0.85)
legend("bottomright",
legend = c("Mujer","Hombre"),
fill = c("#c9a8c0","#70284a"),
bty = "n", cex = 0.75)
4.2 Densidad por percepcion vs. consenso
dens_ind <- sapply(seq_len(I), function(k) {
g_k <- graph_from_adjacency_matrix(A_list[[k]], mode = "directed", diag = FALSE)
edge_density(g_k)
})
df_dens <- data.frame(
Percepcion = c(paste0("P", seq_len(I)), "Consenso"),
Densidad = c(dens_ind, edge_density(g_consenso)),
Tipo = c(rep("Individual", I), "Consenso")
)
ggplot(df_dens, aes(x = reorder(Percepcion, Densidad),
y = Densidad, fill = Tipo)) +
geom_col(alpha = 0.85) +
geom_hline(yintercept = edge_density(g_consenso),
linetype = "dashed", color = "#3d0f28", linewidth = 0.8) +
scale_fill_manual(values = c("Individual" = "#9b6b8a",
"Consenso" = "#3d0f28")) +
labs(title = "Densidad por percepcion individual y red de consenso",
subtitle = "Linea discontinua: densidad del consenso",
x = NULL, y = "Densidad") +
theme_minimal(base_size = 11) +
theme(axis.text.x = element_text(angle = 45, hjust = 1),
legend.title = element_blank())
4.3 Matriz de superposicion entre percepciones
# Fraccion de aristas compartidas entre cada par de percepciones
overlap_mat <- matrix(0, I, I)
for (i in seq_len(I)) {
for (j in seq_len(I)) {
shared <- sum(A_list[[i]] & A_list[[j]])
total <- sum(A_list[[i]] | A_list[[j]])
overlap_mat[i, j] <- if (total > 0) shared / total else 0
}
}
rownames(overlap_mat) <- colnames(overlap_mat) <- paste0("P", seq_len(I))
# Heatmap
overlap_df <- as.data.frame(overlap_mat) %>%
tibble::rownames_to_column("P_fila") %>%
pivot_longer(-P_fila, names_to = "P_col", values_to = "Overlap")
ggplot(overlap_df, aes(x = P_col, y = P_fila, fill = Overlap)) +
geom_tile(color = "white") +
scale_fill_gradient(low = "#f0eaf5", high = "#70284a",
name = "Jaccard") +
labs(title = "Superposicion (similitud de Jaccard) entre percepciones",
subtitle = "Valores altos indican mayor acuerdo entre dos percepciones",
x = NULL, y = NULL) +
theme_minimal(base_size = 11) +
theme(axis.text.x = element_text(angle = 45, hjust = 1))
Comparacion entre percepciones. Las percepciones individuales son bastante heterogeneas en densidad: algunas captan una red relativamente densa mientras otras reportan muy pocas relaciones. La matriz de similitud de Jaccard revela que algunas percepciones comparten pocos patrones de enlaces, lo que refleja las limitaciones en la capacidad de los actores para percibir correctamente la estructura social (Krackhardt, 1987). La red de consenso sintetiza estas discrepancias aplicando el umbral del 25%, produciendo una red mas conservadora pero representativa del acuerdo colectivo.
5 Análisis descriptivo de la red de consenso
# Componente gigante
comp_c <- components(g_consenso)
gcc_c <- induced_subgraph(g_consenso,
which(comp_c$membership == which.max(comp_c$csize)))
metricas_cons <- data.frame(
Metrica = c("Orden (n)", "Tamano (m)", "N. componentes",
"Tamano comp. gigante", "Densidad",
"Transitividad global", "Trans. local (media)",
"Distancia geodesica media", "Diametro",
"Asortatividad de grado", "Grado promedio",
"Grado maximo", "Grado minimo"),
Valor = c(
vcount(g_consenso),
ecount(g_consenso),
comp_c$no,
vcount(gcc_c),
round(edge_density(g_consenso), 4),
round(transitivity(g_consenso, type = "global"), 4),
round(mean(transitivity(g_consenso, type = "local"), na.rm = TRUE), 4),
round(mean_distance(gcc_c, directed = FALSE), 4),
diameter(gcc_c, directed = FALSE),
round(assortativity_degree(g_consenso, directed = FALSE), 4),
round(mean(degree(g_consenso)), 3),
max(degree(g_consenso)),
min(degree(g_consenso))
)
)
kable(metricas_cons,
caption = "Metricas estructurales de la red de consenso",
align = c("l","r")) %>%
kable_styling(bootstrap_options = c("striped","hover"), full_width = FALSE) %>%
row_spec(0, background = "#70284a", color = "white") %>%
row_spec(seq(1, nrow(metricas_cons), 2), background = "#f9f5fb")| Metrica | Valor |
|---|---|
| Orden (n) | 15.0000 |
| Tamano (m) | 31.0000 |
| N. componentes | 2.0000 |
| Tamano comp. gigante | 8.0000 |
| Densidad | 0.2952 |
| Transitividad global | 0.8017 |
| Trans. local (media) | 0.8027 |
| Distancia geodesica media | 1.2857 |
| Diametro | 2.0000 |
| Asortatividad de grado | 0.2457 |
| Grado promedio | 4.1330 |
| Grado maximo | 7.0000 |
| Grado minimo | 1.0000 |
5.1 Distribucion de grado
d_cons <- degree(g_consenso)
df_grado <- data.frame(
Actor = paste0("Actor ", seq_len(I)),
Grado = d_cons,
Sexo = covs$sexo_f,
Prog = covs$prog_f
)
p1 <- ggplot(df_grado, aes(x = reorder(Actor, -Grado), y = Grado,
fill = Sexo)) +
geom_col(alpha = 0.85) +
scale_fill_manual(values = c("Mujer" = "#c9a8c0", "Hombre" = "#70284a")) +
labs(title = "Grado por actor — Red de consenso",
x = NULL, y = "Grado") +
theme_minimal(base_size = 11) +
theme(axis.text.x = element_text(angle = 45, hjust = 1),
legend.title = element_blank())
p2 <- ggplot(df_grado, aes(x = Grado)) +
geom_histogram(fill = "#9b6b8a", color = "white",
bins = max(d_cons) - min(d_cons) + 1, alpha = 0.85) +
labs(title = "Distribucion del grado — Red de consenso",
x = "Grado", y = "Frecuencia") +
theme_minimal(base_size = 11)
if (gridExtra_ok) {
gridExtra::grid.arrange(p1, p2, ncol = 2)
} else {
print(p1)
print(p2)
}
Nota: Si gridExtra no esta instalado,
ejecute en consola: install.packages("gridExtra").
5.2 Visualizacion de la red de consenso con atributos
set.seed(42)
lay_fr <- layout_with_fr(g_consenso)
# Forma segun programa
forma_prog <- ifelse(covs$prog_f == "Posgrado", "square", "circle")
plot(g_consenso,
layout = lay_fr,
vertex.size = 4 + 2.5 * d_cons,
vertex.color = col_nodos_cons,
vertex.frame.color = "#3d0f28",
vertex.shape = forma_prog,
vertex.label = seq_len(I),
vertex.label.cex = 0.7,
vertex.label.color = "white",
edge.color = adjustcolor("#9b6b8a", 0.5),
edge.width = 1.2,
main = "Red de consenso — CSS 2022")
legend("bottomleft",
legend = c("Mujer","Hombre","Pregrado","Posgrado"),
fill = c("#c9a8c0","#70284a","white","white"),
pch = c(NA,NA,21,22),
bty = "n", cex = 0.8)
5.3 Cliques y cohesion
# Cliques
cliques_cons <- cliques(g_consenso, min = 3)
max_cl <- max_cliques(g_consenso)
cat("Cliques de tamano >= 3:", length(cliques_cons), "\n")## Cliques de tamano >= 3: 56## Cliques maximales: 6## Tamano del clique maximo: 6# Tabla de frecuencias por tamano
tabla_cliques <- table(sapply(cliques(g_consenso, min = 1), length))
kable(as.data.frame(tabla_cliques),
caption = "Frecuencia de cliques por tamano",
col.names = c("Tamano del clique","Frecuencia"),
align = c("c","r")) %>%
kable_styling(bootstrap_options = c("striped","hover"),
full_width = FALSE) %>%
row_spec(0, background = "#70284a", color = "white")| Tamano del clique | Frecuencia |
|---|---|
| 1 | 15 |
| 2 | 31 |
| 3 | 31 |
| 4 | 18 |
| 5 | 6 |
| 6 | 1 |
Interpretacion estructural de la red de consenso. La red de consenso es relativamente dispersa, lo cual es tipico de redes de amistad en grupos academicos pequenos donde el conocimiento mutuo no implica necesariamente amistad declarada. La transitividad moderada indica que hay una tendencia a que los amigos de mis amigos tambien sean mis amigos, sugiriendo la existencia de grupos sociales dentro del curso. La distancia geodesica promedio corta en la componente gigante refleja que la informacion se propaga rapidamente entre los actores conectados. La distribucion del grado es heterogenea: hay actores muy conectados (hubs sociales) y actores con pocas conexiones, coherente con la diferenciacion por rol social en el contexto academico (Krackhardt, 1987).
6 Grado normalizado y diagramas de caja
Se calcula el grado normalizado \(d_i^* = d_i / (n-1)\) para cada actor en las 15 percepciones individuales y en la red de consenso. Se construye un diagrama de caja por actor mostrando la distribucion a traves de las percepciones.
Segun el enunciado: - Triangulo rojo (\(\triangle\)): grado basado en la percepcion propia del actor. - Cruz azul (\(\times\)): grado basado en la red de consenso.
# Grado normalizado en cada percepcion (red dirigida -> se suma fila+col / 2*(n-1))
# Para ser consistente con la red de consenso (no dirigida), se usa
# grado saliente + entrante dividido entre 2*(n-1)
grado_norm_ind <- matrix(0, nrow = I, ncol = I,
dimnames = list(paste0("Actor_", seq_len(I)),
paste0("Percepcion_", seq_len(I))))
for (k in seq_len(I)) {
A_k <- A_list[[k]]
# Grado no dirigido equivalente: (saliente + entrante) / 2
d_k <- (rowSums(A_k) + colSums(A_k)) / 2
grado_norm_ind[, k] <- d_k / (I - 1)
}
# Grado normalizado en la red de consenso
grado_norm_cons <- degree(g_consenso) / (I - 1)
# Grado propio: percepcion k sobre el actor k (diagonal de la tabla)
grado_norm_propio <- sapply(seq_len(I), function(k) {
grado_norm_ind[k, k]
})# Formato largo para ggplot
df_box <- as.data.frame(t(grado_norm_ind)) %>%
pivot_longer(everything(),
names_to = "Actor",
values_to = "Grado_norm") %>%
mutate(Actor = factor(Actor,
levels = paste0("Actor_", seq_len(I)),
labels = paste0("A", seq_len(I))))
# Puntos especiales
df_propio <- data.frame(
Actor = factor(paste0("A", seq_len(I))),
Grado_norm = grado_norm_propio,
Tipo = "Percepcion propia"
)
df_consenso_pts <- data.frame(
Actor = factor(paste0("A", seq_len(I))),
Grado_norm = as.numeric(grado_norm_cons),
Tipo = "Consenso"
)
ggplot(df_box, aes(x = Actor, y = Grado_norm)) +
geom_boxplot(fill = "#c9a8c0",
color = "#3d0f28",
outlier.shape = NA,
width = 0.55,
alpha = 0.7) +
# Cruz azul: grado en consenso
geom_point(data = df_consenso_pts,
aes(shape = Tipo),
color = "#1a4a8a",
size = 3.5,
stroke = 1.8) +
# Triangulo rojo: percepcion propia
geom_point(data = df_propio,
aes(shape = Tipo),
color = "#c0392b",
size = 3.5,
stroke = 1.8) +
scale_shape_manual(
values = c("Percepcion propia" = 2, # triangulo vacio
"Consenso" = 4), # cruz
name = ""
) +
labs(title = "Distribucion del grado normalizado por actor",
subtitle = "Cajas: variacion entre percepciones | Triangulo rojo: percepcion propia | Cruz azul: consenso",
x = "Actor", y = "Grado normalizado") +
theme_minimal(base_size = 11) +
theme(legend.position = "bottom",
panel.grid.minor = element_blank())
Autopercepcion del rol social. Cuando el triangulo rojo (percepcion propia) se ubica por encima de la mediana de las cajas, el actor sobreestima su centralidad; si queda por debajo, la subestima. La cruz azul (consenso) indica el rol que le reconoce el colectivo. Los actores cuyas cruces azules se alejan del cuerpo de la caja tienen un rol claramente diferenciado del que ellos mismos perciben, lo que puede indicar falta de conciencia de su posicion social en el grupo (Krackhardt, 1987). Actores con grado alto en consenso pero bajo en su propia percepcion son actores “populares discretos”, mientras que el caso contrario corresponde a actores que sobrevaloran su influencia social en el curso.
7 Modelo ERGM para la red de consenso
# Carga condicional de ergm/statnet
# Si no esta instalado: install.packages(c("statnet","ergm","network"))
ergm_disponible <- tryCatch({
suppressMessages({
library(statnet)
library(ergm)
library(network)
})
TRUE
}, error = function(e) {
message("ergm/statnet no disponible — seccion ERGM se omite.")
FALSE
})
cat("ergm disponible:", ergm_disponible, "\n")## ergm disponible: FALSEif (ergm_disponible) {
# Convertir a objeto network
Y_cons <- as.matrix(as_adjacency_matrix(g_consenso, sparse = FALSE))
net_cons <- as.network(Y_cons, directed = FALSE)
# Agregar covariables nodales
net_cons %v% "sexo" <- as.integer(covs$sexo)
net_cons %v% "edad" <- covs$edad
net_cons %v% "programa" <- as.integer(covs$programa)
# Ajuste del ERGM:
# - edges: densidad de la red
# - nodematch("sexo"): homofilia por sexo
# - nodematch("programa"): homofilia por programa
# - absdiff("edad"): heterofilia por diferencia de edad
set.seed(123)
ergm_cons <- tryCatch(
ergm(net_cons ~ edges +
nodematch("sexo") +
nodematch("programa") +
absdiff("edad"),
control = control.ergm(seed = 123,
MCMC.samplesize = 2000,
MCMLE.maxit = 25)),
error = function(e) {
cat("Error en ERGM:", conditionMessage(e), "\n")
NULL
}
)
if (!is.null(ergm_cons)) {
cat("\n=== Resumen del ERGM — Red de consenso ===\n")
print(summary(ergm_cons))
}
} else {
cat("ERGM omitido por falta de paquetes.\n")
ergm_cons <- NULL
}## ERGM omitido por falta de paquetes.if (ergm_disponible && !is.null(ergm_cons)) {
coefs <- summary(ergm_cons)$coefficients
df_ergm <- data.frame(
Termino = rownames(coefs),
Estimacion = round(coefs[, "Estimate"], 4),
Error_std = round(coefs[, "Std. Error"], 4),
z_valor = round(coefs[, "z-value"], 3),
p_valor = round(coefs[, "Pr(>|z|)"], 4),
Significativo = ifelse(coefs[, "Pr(>|z|)"] < 0.05, "*", "")
)
kable(df_ergm,
caption = "Coeficientes del ERGM — Red de consenso CSS 2022",
col.names = c("Termino","Estimacion","Err. std.","z","p-valor",""),
align = c("l","r","r","r","r","c")) %>%
kable_styling(bootstrap_options = c("striped","hover"),
full_width = FALSE) %>%
row_spec(0, background = "#70284a", color = "white") %>%
footnote(general = "* p < 0.05")
} else {
cat("Tabla ERGM no disponible.\n")
}Tabla ERGM no disponible.
Interpretacion del ERGM. El termino
edges (intercepto del modelo) captura la densidad basal de
la red; un valor negativo indica una red dispersa, como es de esperarse
en un grupo academico. El termino nodematch("sexo") mide
homofilia de genero: un coeficiente positivo y significativo indicaria
que los estudiantes tienden a reportar amistades con personas del mismo
sexo. De manera analoga, nodematch("programa") captura
homofilia por nivel academico (pregrado vs. posgrado). El termino
absdiff("edad") captura heterofilia por edad: un
coeficiente negativo indicaria que los pares con edades similares tienen
mayor probabilidad de estar conectados. Estos efectos son interpretados
en escala logit (enlace probit no disponible directamente en ergm): cada
coeficiente representa el cambio en el log-odds de observar una arista
cuando la covariable cambia en una unidad, manteniendo el resto
constante.
8 Modelos estadísticos adicionales (sin covariables)
Se ajustan seis modelos a la red de consenso siguiendo el enunciado:
- M1: Modelo de grafos aleatorios (Erdos-Renyi).
- M2: Modelo de grafos aleatorios generalizado (MCMC
via
ergmcon soloedges). - M3: ERGM con aristas y triangulos
(
edges + triangle). - M4: Modelo de bloques estocasticos (SBM via Louvain).
- M5: Modelo latente de distancia clasico con dos dimensiones latentes.
- M6: Modelo de sociabilidad (Sosa & Martinez, 2026).
# M1: Modelo de Erdos-Renyi
# p_hat = densidad observada
Y_cons_mat <- as.matrix(as_adjacency_matrix(g_consenso, sparse = FALSE))
n_c <- vcount(g_consenso)
m_obs <- ecount(g_consenso)
p_hat <- edge_density(g_consenso)
cat("M1 — Erdos-Renyi\n")## M1 — Erdos-Renyi## p estimado: 0.2952## Aristas esperadas: 31## Aristas observadas: 31# M2: ERGM con solo edges (equivalente a Erdos-Renyi en marco ERGM)
if (ergm_disponible) {
set.seed(123)
M2_fit <- tryCatch(
ergm(net_cons ~ edges,
control = control.ergm(seed = 123, MCMC.samplesize = 2000)),
error = function(e) { cat("M2 error:", conditionMessage(e), "\n"); NULL }
)
if (!is.null(M2_fit)) {
cat("M2 — ERGM (edges):\n")
print(summary(M2_fit)$coefficients)
}
} else {
M2_fit <- NULL
cat("M2 omitido (ergm no disponible).\n")
}## M2 omitido (ergm no disponible).# M3: ERGM con edges + triangulos
if (ergm_disponible) {
set.seed(123)
M3_fit <- tryCatch(
ergm(net_cons ~ edges + triangle,
control = control.ergm(seed = 123,
MCMC.samplesize = 2000,
MCMLE.maxit = 20)),
error = function(e) { cat("M3 error:", conditionMessage(e), "\n"); NULL }
)
if (!is.null(M3_fit)) {
cat("M3 — ERGM (edges + triangle):\n")
print(summary(M3_fit)$coefficients)
}
} else {
M3_fit <- NULL
cat("M3 omitido (ergm no disponible).\n")
}## M3 omitido (ergm no disponible).# M4: Modelo de bloques estocasticos (SBM) via Louvain
set.seed(123)
M4_louvain <- cluster_louvain(g_consenso)
M4_membresia <- M4_louvain$membership
M4_modularidad <- modularity(M4_louvain)
M4_K <- max(M4_membresia)
cat("M4 — SBM (Louvain)\n")## M4 — SBM (Louvain)## Bloques detectados: 2## Modularidad: 0.4579# Visualizacion del SBM
pal_sbm <- colorRampPalette(c("#3d0f28","#70284a","#9b6b8a","#c9a8c0","#5c1a35"))(M4_K)set.seed(42)
plot(g_consenso,
layout = layout_with_fr(g_consenso),
vertex.size = 4 + 2 * degree(g_consenso),
vertex.color = pal_sbm[M4_membresia],
vertex.frame.color = "#3d0f28",
vertex.label = seq_len(n_c),
vertex.label.cex = 0.65,
vertex.label.color = "white",
edge.color = adjustcolor("#9b6b8a", 0.4),
edge.width = 1,
main = paste0("M4 — SBM Louvain (K=", M4_K,
", Mod=", round(M4_modularidad, 3), ")"))
# M5: Modelo latente de distancia clasico con 2 dimensiones latentes
# Se implementa directamente via optimizacion del log-posterior
# siguiendo Hoff, Raftery & Handcock (2002)
# P(y_ij = 1) = Phi(mu - ||u_i - u_j||)
Y_c <- Y_cons_mat
# Funcion de log-verosimilitud del modelo latente de distancia
log_lik_latente <- function(params, Y, n, d = 2) {
mu <- params[1]
U <- matrix(params[-1], nrow = n, ncol = d)
ll <- 0
for (i in 1:(n - 1)) {
for (j in (i + 1):n) {
dist_ij <- sqrt(sum((U[i,] - U[j,])^2))
eta_ij <- mu - dist_ij
p_ij <- pnorm(eta_ij)
p_ij <- max(min(p_ij, 1 - 1e-8), 1e-8)
ll <- ll + Y[i,j] * log(p_ij) + (1 - Y[i,j]) * log(1 - p_ij)
}
}
return(ll)
}
# Inicializacion con MDS en 2D
set.seed(123)
D_init <- 1 - as.matrix(as_adjacency_matrix(g_consenso, sparse = FALSE))
mds_init <- cmdscale(D_init, k = 2)
params0 <- c(0, as.vector(mds_init))
# Optimizacion
M5_opt <- optim(params0,
fn = function(p) -log_lik_latente(p, Y_c, n_c),
method = "BFGS",
control = list(maxit = 500, reltol = 1e-6))
M5_mu <- M5_opt$par[1]
M5_U <- matrix(M5_opt$par[-1], nrow = n_c, ncol = 2)
M5_loglik <- -M5_opt$value
cat("M5 — Modelo latente de distancia (2D)\n")## M5 — Modelo latente de distancia (2D)## mu estimado: 30.5229## Log-verosimilitud: 0df_latente <- data.frame(
x = M5_U[, 1],
y = M5_U[, 2],
id = seq_len(n_c),
sexo = covs$sexo_f,
prog = covs$prog_f
)
ggplot(df_latente, aes(x = x, y = y, color = sexo, shape = prog,
label = id)) +
geom_point(size = 4, alpha = 0.85) +
geom_text(nudge_y = 0.03, size = 3, color = "black") +
scale_color_manual(values = c("Mujer" = "#c9a8c0", "Hombre" = "#70284a")) +
scale_shape_manual(values = c("Pregrado" = 16, "Posgrado" = 17)) +
labs(title = "M5 — Espacio latente de distancia (2D)",
subtitle = "Actores proximos tienen mayor probabilidad de conexion",
x = "Dimension 1", y = "Dimension 2",
color = "Sexo", shape = "Programa") +
theme_minimal(base_size = 11)
# M6: Modelo de sociabilidad (Sosa & Martinez, 2026)
# Funciones vectorizadas (identicas al Punto 1)
sample_z_css <- function(y, mu, delta, z) {
n <- nrow(y)
idx <- which(upper.tri(y))
ri <- row(y)[idx]
ci <- col(y)[idx]
mz <- mu + delta[ri] + delta[ci]
yij <- y[idx]
zpos <- truncnorm::rtruncnorm(length(idx), a = 0, b = Inf, mean = mz, sd = 1)
zneg <- truncnorm::rtruncnorm(length(idx), a = -Inf, b = 0, mean = mz, sd = 1)
znew <- ifelse(yij == 1, zpos, zneg)
z[idx] <- znew
z[cbind(ci, ri)] <- znew
z
}
sample_mu_css <- function(z, delta, sigma2) {
idx <- upper.tri(z)
v2_mu <- 1 / (1/sigma2 + sum(idx))
m_mu <- v2_mu * sum(z[idx] - delta[row(z)[idx]] - delta[col(z)[idx]])
rnorm(1, mean = m_mu, sd = sqrt(v2_mu))
}
sample_delta_css <- function(z, mu, tau2, delta) {
n <- length(delta)
for (i in 1:n) {
vecinos <- setdiff(1:n, i)
v2_delta <- 1 / (1/tau2 + length(vecinos))
m_delta <- v2_delta * sum(z[i, vecinos] - mu - delta[vecinos])
delta[i] <- rnorm(1, mean = m_delta, sd = sqrt(v2_delta))
}
delta
}
gibbs_css <- function(Y, n_iter = 5000, n_burn = 1000, n_thin = 5,
a_sigma = 2, b_sigma = 1, a_tau = 2, b_tau = 1) {
n <- nrow(Y)
mu <- 0
delta <- rnorm(n, 0, 1)
sigma2 <- 1
tau2 <- 1
z <- matrix(0, n, n)
n_samples <- floor((n_iter - n_burn) / n_thin)
out <- list(mu = numeric(n_samples),
delta = matrix(0, n_samples, n),
sigma2 = numeric(n_samples),
tau2 = numeric(n_samples))
for (t in 1:n_iter) {
z <- sample_z_css(Y, mu, delta, z)
mu <- sample_mu_css(z, delta, sigma2)
delta <- sample_delta_css(z, mu, tau2, delta)
sigma2 <- 1 / rgamma(1, shape = a_sigma + 0.5,
rate = b_sigma + 0.5 * mu^2)
tau2 <- 1 / rgamma(1, shape = a_tau + n/2,
rate = b_tau + 0.5 * sum(delta^2))
if (t > n_burn && (t - n_burn) %% n_thin == 0) {
idx <- (t - n_burn) %/% n_thin
out$mu[idx] <- mu
out$delta[idx,] <- delta
out$sigma2[idx] <- sigma2
out$tau2[idx] <- tau2
}
}
out
}
set.seed(123)
M6_samples <- gibbs_css(Y_cons_mat, n_iter = 5000, n_burn = 1000, n_thin = 5)
cat("M6 — Sociabilidad: muestras obtenidas:", length(M6_samples$mu), "\n")## M6 — Sociabilidad: muestras obtenidas: 800# Estadisticos posteriores de M6
M6_resumen <- data.frame(
Parametro = c("mu", "sigma2", "tau2"),
Media = round(c(mean(M6_samples$mu),
mean(M6_samples$sigma2),
mean(M6_samples$tau2)), 4),
Mediana = round(c(median(M6_samples$mu),
median(M6_samples$sigma2),
median(M6_samples$tau2)), 4),
IC95_inf = round(c(quantile(M6_samples$mu, 0.025),
quantile(M6_samples$sigma2, 0.025),
quantile(M6_samples$tau2, 0.025)), 4),
IC95_sup = round(c(quantile(M6_samples$mu, 0.975),
quantile(M6_samples$sigma2, 0.975),
quantile(M6_samples$tau2, 0.975)), 4)
)
kable(M6_resumen,
caption = "Inferencia posterior — M6 Modelo de sociabilidad",
col.names = c("Parametro","Media","Mediana","IC95 inf.","IC95 sup."),
align = c("l","r","r","r","r")) %>%
kable_styling(bootstrap_options = c("striped","hover"),
full_width = FALSE) %>%
row_spec(0, background = "#70284a", color = "white")| Parametro | Media | Mediana | IC95 inf. | IC95 sup. |
|---|---|---|---|---|
| mu | -0.4961 | -0.4912 | -1.0463 | 0.0364 |
| sigma2 | 0.7236 | 0.5370 | 0.1756 | 2.4312 |
| tau2 | 0.2588 | 0.2318 | 0.1111 | 0.5201 |
delta_media <- colMeans(M6_samples$delta)
delta_ci <- apply(M6_samples$delta, 2, quantile, probs = c(0.025, 0.975))
df_delta <- data.frame(
Actor = factor(paste0("A", seq_len(n_c))),
Media = delta_media,
lwr = delta_ci[1,],
upr = delta_ci[2,],
Sexo = covs$sexo_f,
Prog = covs$prog_f
)
ggplot(df_delta, aes(x = reorder(Actor, Media), y = Media, color = Sexo)) +
geom_linerange(aes(ymin = lwr, ymax = upr), linewidth = 1.2, alpha = 0.7) +
geom_point(aes(shape = Prog), size = 3) +
geom_hline(yintercept = 0, linetype = "dashed", color = "gray50") +
coord_flip() +
scale_color_manual(values = c("Mujer" = "#c9a8c0", "Hombre" = "#70284a")) +
scale_shape_manual(values = c("Pregrado" = 16, "Posgrado" = 17)) +
labs(title = "M6 — Efectos de sociabilidad (delta_i) — Red de consenso",
subtitle = "Media posterior con IC al 95%",
x = NULL, y = expression(delta[i]),
color = "Sexo", shape = "Programa") +
theme_minimal(base_size = 11)
9 Bondad de ajuste
Se evalua la bondad de ajuste de los modelos usando densidad, transitividad, asortatividad y distancia geodesica promedio como estadisticos de prueba (Hunter et al., 2008; Sosa, 2024).
stats_obs <- c(
densidad = edge_density(g_consenso),
transitividad = transitivity(g_consenso, type = "global"),
asortatividad = assortativity_degree(g_consenso, directed = FALSE),
dist_geo = mean_distance(gcc_c, directed = FALSE)
)
cat("Estadisticos observados:\n")## Estadisticos observados:## densidad transitividad asortatividad dist_geo
## 0.2952 0.8017 0.2457 1.2857# Funcion generica para simular redes y calcular estadisticos
stats_red <- function(g) {
comp <- components(g)
gcc <- induced_subgraph(g, which(comp$membership == which.max(comp$csize)))
c(
densidad = tryCatch(edge_density(g), error = function(e) NA),
transitividad = tryCatch(transitivity(g, type = "global"), error = function(e) NA),
asortatividad = tryCatch(assortativity_degree(g, directed = FALSE), error = function(e) NA),
dist_geo = tryCatch(mean_distance(gcc, directed = FALSE), error = function(e) NA)
)
}
N_SIM <- 500
set.seed(42)# GOF M1: Erdos-Renyi
sim_M1 <- t(replicate(N_SIM, {
g_sim <- erdos.renyi.game(n_c, p = p_hat, type = "gnp")
stats_red(g_sim)
}))# GOF M4: SBM (Louvain) — simular con densidades intra/inter bloque
# Estimar matriz de probabilidades por bloque
bloques <- M4_membresia
K_sbm <- max(bloques)
P_sbm <- matrix(0, K_sbm, K_sbm)
for (ki in 1:K_sbm) {
for (kj in ki:K_sbm) {
nodos_i <- which(bloques == ki)
nodos_j <- which(bloques == kj)
if (ki == kj) {
pares <- choose(length(nodos_i), 2)
aristas <- sum(Y_cons_mat[nodos_i, nodos_i]) / 2
} else {
pares <- length(nodos_i) * length(nodos_j)
aristas <- sum(Y_cons_mat[nodos_i, nodos_j])
}
P_sbm[ki, kj] <- P_sbm[kj, ki] <- if (pares > 0) aristas / pares else 0
}
}
sim_M4 <- t(replicate(N_SIM, {
Y_sim <- matrix(0, n_c, n_c)
for (i in 1:(n_c-1)) {
for (j in (i+1):n_c) {
p_ij <- P_sbm[bloques[i], bloques[j]]
Y_sim[i,j] <- Y_sim[j,i] <- rbinom(1, 1, p_ij)
}
}
g_sim <- graph_from_adjacency_matrix(Y_sim, mode = "undirected", diag = FALSE)
stats_red(g_sim)
}))# GOF M5: Modelo latente de distancia
P_latente <- matrix(0, n_c, n_c)
for (i in 1:(n_c-1)) {
for (j in (i+1):n_c) {
dist_ij <- sqrt(sum((M5_U[i,] - M5_U[j,])^2))
P_latente[i,j] <- P_latente[j,i] <- pnorm(M5_mu - dist_ij)
}
}
sim_M5 <- t(replicate(N_SIM, {
Y_sim <- matrix(0, n_c, n_c)
idx <- which(upper.tri(Y_sim))
Y_sim[idx] <- rbinom(length(idx), 1, P_latente[idx])
Y_sim <- Y_sim + t(Y_sim)
g_sim <- graph_from_adjacency_matrix(Y_sim, mode = "undirected", diag = FALSE)
stats_red(g_sim)
}))# GOF M6: Modelo de sociabilidad
n_muestras <- length(M6_samples$mu)
idx_sim <- sample(seq_len(n_muestras), min(N_SIM, n_muestras))
sim_M6 <- t(sapply(idx_sim, function(s) {
mu_s <- M6_samples$mu[s]
delta_s <- M6_samples$delta[s,]
P_s <- pnorm(mu_s + outer(delta_s, delta_s, "+"))
Y_sim <- matrix(0, n_c, n_c)
idx <- which(upper.tri(Y_sim))
Y_sim[idx] <- rbinom(length(idx), 1, P_s[idx])
Y_sim <- Y_sim + t(Y_sim)
diag(Y_sim) <- 0
g_sim <- graph_from_adjacency_matrix(Y_sim, mode = "undirected", diag = FALSE)
stats_red(g_sim)
}))# Tabla comparativa de GOF
resumen_gof <- function(sim_mat, nombre) {
data.frame(
Modelo = nombre,
Estadistico = names(stats_obs),
Observado = round(stats_obs, 4),
Media_sim = round(colMeans(sim_mat, na.rm = TRUE), 4),
IC95_inf = round(apply(sim_mat, 2, quantile, 0.025, na.rm = TRUE), 4),
IC95_sup = round(apply(sim_mat, 2, quantile, 0.975, na.rm = TRUE), 4),
Dentro_IC = ifelse(
stats_obs >= apply(sim_mat, 2, quantile, 0.025, na.rm = TRUE) &
stats_obs <= apply(sim_mat, 2, quantile, 0.975, na.rm = TRUE),
"Si", "No")
)
}
gof_df <- bind_rows(
resumen_gof(sim_M1, "M1: Erdos-Renyi"),
resumen_gof(sim_M4, "M4: SBM"),
resumen_gof(sim_M5, "M5: Latente dist."),
resumen_gof(sim_M6, "M6: Sociabilidad")
)
kable(gof_df,
caption = "Bondad de ajuste — Estadisticos de prueba por modelo",
col.names = c("Modelo","Estadistico","Obs.","Media sim.",
"IC95 inf.","IC95 sup.","Dentro IC"),
align = c("l","l","r","r","r","r","c")) %>%
kable_styling(bootstrap_options = c("striped","hover"),
full_width = FALSE) %>%
row_spec(0, background = "#70284a", color = "white")| Modelo | Estadistico | Obs. | Media sim. | IC95 inf. | IC95 sup. | Dentro IC | |
|---|---|---|---|---|---|---|---|
| densidad…1 | M1: Erdos-Renyi | densidad | 0.2952 | 0.2940 | 0.2095 | 0.3714 | Si |
| transitividad…2 | M1: Erdos-Renyi | transitividad | 0.8017 | 0.2793 | 0.1230 | 0.4179 | No |
| asortatividad…3 | M1: Erdos-Renyi | asortatividad | 0.2457 | -0.1469 | -0.4053 | 0.1216 | No |
| dist_geo…4 | M1: Erdos-Renyi | dist_geo | 1.2857 | 1.9343 | 1.6902 | 2.3333 | No |
| densidad…5 | M4: SBM | densidad | 0.2952 | 0.2935 | 0.2381 | 0.3524 | Si |
| transitividad…6 | M4: SBM | transitividad | 0.8017 | 0.6443 | 0.4563 | 0.8031 | Si |
| asortatividad…7 | M4: SBM | asortatividad | 0.2457 | 0.2221 | -0.3546 | 0.7213 | Si |
| dist_geo…8 | M4: SBM | dist_geo | 1.2857 | 1.2963 | 1.1429 | 1.5000 | Si |
| densidad…9 | M5: Latente dist. | densidad | 0.2952 | 0.2952 | 0.2952 | 0.2952 | Si |
| transitividad…10 | M5: Latente dist. | transitividad | 0.8017 | 0.8017 | 0.8017 | 0.8017 | Si |
| asortatividad…11 | M5: Latente dist. | asortatividad | 0.2457 | 0.2457 | 0.2457 | 0.2457 | Si |
| dist_geo…12 | M5: Latente dist. | dist_geo | 1.2857 | 1.2857 | 1.2857 | 1.2857 | Si |
| densidad…13 | M6: Sociabilidad | densidad | 0.2952 | 0.3055 | 0.1810 | 0.4190 | Si |
| transitividad…14 | M6: Sociabilidad | transitividad | 0.8017 | 0.3525 | 0.1454 | 0.5325 | No |
| asortatividad…15 | M6: Sociabilidad | asortatividad | 0.2457 | -0.2280 | -0.4900 | 0.0467 | No |
| dist_geo…16 | M6: Sociabilidad | dist_geo | 1.2857 | 1.8807 | 1.6154 | 2.3327 | No |
# Grafico de distribuciones predictivas por modelo y estadistico
modelos_sim <- list(
"M1: Erdos-Renyi" = sim_M1,
"M4: SBM" = sim_M4,
"M5: Latente dist." = sim_M5,
"M6: Sociabilidad" = sim_M6
)
df_gof_long <- bind_rows(lapply(names(modelos_sim), function(nm) {
as.data.frame(modelos_sim[[nm]]) %>%
pivot_longer(everything(),
names_to = "Estadistico",
values_to = "Valor") %>%
mutate(Modelo = nm)
}))
df_obs_long <- data.frame(
Estadistico = names(stats_obs),
Valor = as.numeric(stats_obs)
)
ggplot(df_gof_long, aes(x = Valor, fill = Modelo)) +
geom_histogram(bins = 30, alpha = 0.7, color = "white",
position = "identity") +
geom_vline(data = df_obs_long,
aes(xintercept = Valor),
color = "#3d0f28", linewidth = 1, linetype = "dashed") +
facet_grid(Modelo ~ Estadistico, scales = "free") +
scale_fill_manual(values = c(
"M1: Erdos-Renyi" = "#c9a8c0",
"M4: SBM" = "#9b6b8a",
"M5: Latente dist." = "#70284a",
"M6: Sociabilidad" = "#3d0f28"
)) +
labs(title = "Distribucion predictiva posterior — Bondad de ajuste",
subtitle = "Linea discontinua: valor observado en la red de consenso",
x = "Valor simulado", y = "Frecuencia") +
theme_minimal(base_size = 10) +
theme(legend.position = "none",
strip.background = element_rect(fill = "#70284a"),
strip.text = element_text(color = "white", size = 8,
face = "bold"))
Bondad de ajuste. El modelo de Erdos-Renyi (M1) reproduce la densidad observada por construccion pero falla en transitividad y asortatividad, dado que no incorpora ninguna estructura local. El SBM (M4) mejora la reproduccion de la densidad intra e inter bloque pero puede subestimar la transitividad global si los bloques no reflejan completamente los triangulos de la red. El modelo latente de distancia (M5) tiende a reproducir mejor la estructura de comunidades al proyectar actores en un espacio donde la proximidad implica conexion. El modelo de sociabilidad (M6) es el mas flexible en cuanto a heterogeneidad individual, pero al igual que M1 no incluye efectos de triangulos, por lo que puede subestimar la transitividad. En general, ningun modelo simple captura simultaneamente todos los estadisticos de prueba, lo cual es una limitacion esperada en redes pequenas con estructura rica.
10 Validacion cruzada con 5 folds
Se evalua la capacidad predictiva de los modelos mediante validacion cruzada con 5 particiones de los pares de nodos del triangulo superior.
# Pares del triangulo superior
pares_idx <- which(upper.tri(Y_cons_mat), arr.ind = TRUE)
N_pares <- nrow(pares_idx)
y_pares <- Y_cons_mat[pares_idx]
# Crear folds
set.seed(42)
K_folds <- 5
folds <- sample(rep(seq_len(K_folds), length.out = N_pares))
cat("Total de pares:", N_pares,
"| Pares por fold (aprox.):", round(N_pares / K_folds), "\n")## Total de pares: 105 | Pares por fold (aprox.): 21# CV para M1: Erdos-Renyi
# Prediccion = p_hat estimado en el training set
auc_M1 <- numeric(K_folds)
for (k in seq_len(K_folds)) {
test_idx <- which(folds == k)
train_idx <- which(folds != k)
y_train <- y_pares[train_idx]
p_train <- mean(y_train) # estimador de maxima verosimilitud
y_test <- y_pares[test_idx]
pred <- rep(p_train, length(test_idx))
auc_M1[k] <- tryCatch(
as.numeric(pROC::auc(pROC::roc(y_test, pred, quiet = TRUE))),
error = function(e) NA
)
}
cat("M1 AUC por fold:", round(auc_M1, 4), "\n")## M1 AUC por fold: 0.5 0.5 0.5 0.5 0.5# CV para M5: Modelo latente de distancia
auc_M5 <- numeric(K_folds)
for (k in seq_len(K_folds)) {
test_idx <- which(folds == k)
train_idx <- which(folds != k)
# Construir Y de entrenamiento
Y_train <- Y_cons_mat
Y_train[pares_idx[test_idx, ]] <- NA
# Simetrizar entrenamiento
for (idx in test_idx) {
i <- pares_idx[idx, 1]; j <- pares_idx[idx, 2]
Y_train[j, i] <- NA
}
# Reemplazar NAs por 0 para ajuste
Y_train_0 <- Y_train; Y_train_0[is.na(Y_train_0)] <- 0
# Re-ajustar M5 en training
params_k <- tryCatch({
opt_k <- optim(params0,
fn = function(p) -log_lik_latente(p, Y_train_0, n_c),
method = "BFGS",
control = list(maxit = 200, reltol = 1e-4))
opt_k$par
}, error = function(e) params0)
mu_k <- params_k[1]
U_k <- matrix(params_k[-1], nrow = n_c, ncol = 2)
# Predicciones en test
pred <- sapply(test_idx, function(idx) {
i <- pares_idx[idx, 1]; j <- pares_idx[idx, 2]
pnorm(mu_k - sqrt(sum((U_k[i,] - U_k[j,])^2)))
})
y_test <- y_pares[test_idx]
auc_M5[k] <- tryCatch(
as.numeric(pROC::auc(pROC::roc(y_test, pred, quiet = TRUE))),
error = function(e) NA
)
}
cat("M5 AUC por fold:", round(auc_M5, 4), "\n")## M5 AUC por fold: 0.8077 0.8824 0.8676 0.6389 0.9778# CV para M6: Modelo de sociabilidad
# Usa las probabilidades posteriores promediadas sobre las muestras MCMC
# del modelo ajustado en el conjunto completo (aproximacion por eficiencia)
P_M6_media <- matrix(0, n_c, n_c)
for (s in seq_along(M6_samples$mu)) {
mu_s <- M6_samples$mu[s]
delta_s <- M6_samples$delta[s,]
P_M6_media <- P_M6_media + pnorm(mu_s + outer(delta_s, delta_s, "+"))
}
P_M6_media <- P_M6_media / length(M6_samples$mu)
auc_M6 <- numeric(K_folds)
for (k in seq_len(K_folds)) {
test_idx <- which(folds == k)
pred <- P_M6_media[pares_idx[test_idx, , drop = FALSE]]
y_test <- y_pares[test_idx]
auc_M6[k] <- tryCatch(
as.numeric(pROC::auc(pROC::roc(y_test, pred, quiet = TRUE))),
error = function(e) NA
)
}
cat("M6 AUC por fold:", round(auc_M6, 4), "\n")## M6 AUC por fold: 0.7596 0.9118 0.8971 0.6111 0.6556# CV para M4: SBM (basado en probabilidades intra/inter bloque)
auc_M4 <- numeric(K_folds)
for (k in seq_len(K_folds)) {
test_idx <- which(folds == k)
train_idx <- which(folds != k)
# Re-estimar probabilidades por bloque en training
Y_train <- Y_cons_mat
P_sbm_k <- matrix(0, K_sbm, K_sbm)
for (ki in 1:K_sbm) {
for (kj in ki:K_sbm) {
nodos_i <- which(bloques == ki)
nodos_j <- which(bloques == kj)
pares_ij <- expand.grid(nodos_i, nodos_j)
pares_ij <- pares_ij[pares_ij[,1] != pares_ij[,2], ]
in_train <- sapply(seq_len(nrow(pares_ij)), function(r) {
i <- pares_ij[r,1]; j <- pares_ij[r,2]
pair_r <- which(pares_idx[,1] == min(i,j) & pares_idx[,2] == max(i,j))
length(pair_r) > 0 && !(pair_r %in% test_idx)
})
if (sum(in_train) > 0) {
idxs_ij <- sapply(which(in_train), function(r) {
i <- pares_ij[r,1]; j <- pares_ij[r,2]
which(pares_idx[,1] == min(i,j) & pares_idx[,2] == max(i,j))
})
P_sbm_k[ki, kj] <- P_sbm_k[kj, ki] <- mean(y_pares[unlist(idxs_ij)])
}
}
}
pred <- sapply(test_idx, function(idx) {
i <- pares_idx[idx,1]; j <- pares_idx[idx,2]
P_sbm_k[bloques[i], bloques[j]]
})
y_test <- y_pares[test_idx]
auc_M4[k] <- tryCatch(
as.numeric(pROC::auc(pROC::roc(y_test, pred, quiet = TRUE))),
error = function(e) NA
)
}
cat("M4 AUC por fold:", round(auc_M4, 4), "\n")## M4 AUC por fold: 0.9712 0.9118 0.8824 0.8611 0.95# Tabla y grafico resumen de CV
cv_resumen <- data.frame(
Modelo = c("M1: Erdos-Renyi", "M4: SBM",
"M5: Latente dist.", "M6: Sociabilidad"),
AUC_media = round(c(mean(auc_M1, na.rm=TRUE), mean(auc_M4, na.rm=TRUE),
mean(auc_M5, na.rm=TRUE), mean(auc_M6, na.rm=TRUE)), 4),
AUC_sd = round(c(sd(auc_M1, na.rm=TRUE), sd(auc_M4, na.rm=TRUE),
sd(auc_M5, na.rm=TRUE), sd(auc_M6, na.rm=TRUE)), 4)
)
kable(cv_resumen,
caption = "Capacidad predictiva — AUC promedio (5-fold CV)",
col.names = c("Modelo","AUC media","AUC desv. std."),
align = c("l","r","r")) %>%
kable_styling(bootstrap_options = c("striped","hover"),
full_width = FALSE) %>%
row_spec(0, background = "#70284a", color = "white") %>%
row_spec(which.max(cv_resumen$AUC_media),
background = "#f0eaf5", bold = TRUE)| Modelo | AUC media | AUC desv. std. |
|---|---|---|
| M1: Erdos-Renyi | 0.5000 | 0.0000 |
| M4: SBM | 0.9153 | 0.0457 |
| M5: Latente dist. | 0.8349 | 0.1254 |
| M6: Sociabilidad | 0.7670 | 0.1366 |
# Grafico de puntos con barras de error
ggplot(cv_resumen,
aes(x = reorder(Modelo, AUC_media), y = AUC_media)) +
geom_col(fill = "#9b6b8a", alpha = 0.8, width = 0.6) +
geom_errorbar(aes(ymin = AUC_media - AUC_sd,
ymax = AUC_media + AUC_sd),
width = 0.2, color = "#3d0f28", linewidth = 0.9) +
geom_hline(yintercept = 0.5, linetype = "dashed",
color = "gray50", linewidth = 0.8) +
coord_flip() +
labs(title = "Capacidad predictiva — AUC por modelo (5-fold CV)",
subtitle = "Barras de error: +/- 1 desviacion estandar | Linea: AUC = 0.5 (azar)",
x = NULL, y = "AUC") +
ylim(0, 1) +
theme_minimal(base_size = 11)
Capacidad predictiva. Un AUC superior a 0.5 indica poder predictivo sobre el azar. El modelo de sociabilidad (M6) suele superar al modelo de Erdos-Renyi (M1) porque incorpora heterogeneidad individual en la propension a conectarse, lo cual es relevante en contextos academicos donde algunos estudiantes son sistematicamente mas sociables. El modelo latente de distancia (M5) puede tener ventaja cuando la estructura de la red refleja grupos bien separados en el espacio latente. El SBM (M4) es competitivo cuando la red tiene bloques claros con densidades diferenciadas. En redes pequenas (\(n=15\)), las diferencias entre modelos suelen ser modestas y la varianza del AUC entre folds puede ser alta, lo que hace necesario interpretar con cautela las comparaciones.
11 Referencias
- Hunter, D. R., Goodreau, S. M., & Handcock, M. S. (2008). Goodness of fit of social network models. Journal of the American Statistical Association, 103(481), 248–258.
- Hoff, P. D., Raftery, A. E., & Handcock, M. S. (2002). Latent space approaches to social network analysis. Journal of the American Statistical Association, 97(460), 1090–1098.
- Krackhardt, D. (1987). Cognitive social structures. Social Networks, 9(2), 109–134.
- Luke, D. A. (2015). A User’s Guide to Network Analysis in R. Springer.
- Sosa, J. (2024). Notas de clase: Analisis Estadistico de Redes. Departamento de Estadistica, Universidad Nacional de Colombia.
- Sosa, J., & Martinez, A. (2026). A sociability model for networks. Journal of Computational and Graphical Statistics. https://doi.org/10.1080/10618600.2026.2627454
- Sosa, J., & Rodriguez, L. (2021). A latent space model for cognitive social structures data. Social Networks, 65, 85–97.