Los modelos de grafos aleatorios exponenciales (exponential random graph models, ERGMs) o modelos \(p^*\) se especifican de manera análoga a los modelos lineales generalizados (generalized linear models, GLMs).
Frank, O. & Strauss, D. (1986), ‘Markov graphs’, Journal of the American Statistical Association 81(395), 832–842.
https://cran.r-project.org/web/packages/ergm/vignettes/ergm.pdf
Wasserman, S. & Pattison, P. (1996), ‘Logit models and logistic regressions for social networks:I. an introduction to markov graphs and p’, Psychometrika 61(3), 401–425.*
Un ERGM es un modelo de la forma \[ p(\mathbf{y}\mid\boldsymbol{\theta}) = \frac{1}{\kappa}\,\exp{\left\{ \boldsymbol{\theta}^{\textsf{T}}\,\boldsymbol{\mathsf{g}}(\mathbf{y}) \right\}} \] donde:
Los coeficientes \(\boldsymbol{\theta}\) representan el tamaño y la dirección de los efectos de \(\boldsymbol{\mathsf{g}}(\mathbf{y})\) sobre la probabilidad general de la red.
La probabilidad del grafo completo se puede volver a expresar en escala logit en términos de las probabilidades condicionales de observar una arista arista manteniendo el resto de la red fija entre dos actores: \[ \text{logit}\,\textsf{Pr}(y_{i,j}=1\mid\mathbf{y}_{-(i,j)}) = \boldsymbol{\theta}^{\textsf{T}}\,\boldsymbol{\delta}_{i,j}(\mathbf{y}) \] donde:
Para cada par de vértices la presencia o ausencia de una arista es independiente del estado de otras posibles aristas: \[ p(\mathbf{y}\mid\boldsymbol{\theta}) = \frac{1}{\kappa}\,\exp{\left\{ \sum_{i<j} \theta_{i,j}\, y_{i,j} \right\}}\,. \] Además, asumiendo \(\theta_{i,j}\equiv\theta\), i.e., homogeneidad a través de toda la red: \[ p(\mathbf{y}\mid\boldsymbol{\theta}) = \frac{1}{\kappa}\,\exp{\left\{ \theta\, S(\mathbf{y}) \right\}} \] donde \(S(\mathbf{y}) = \sum_{i<j}\, y_{i,j}\) es el número de aristas en el grafo. Esto es, el log odds de de observar \(\mathbf{y}\) es proporcional al número de aristas en el grafo.
Simplificando, se tiene que el modelo resultante es equivalente a: \[ y_{i,j}\mid\theta\stackrel{\text{iid}}{\sim}\textsf{Bernoulli}(\textsf{expit}(\theta)) \] para \(i<j\), donde \(\textsf{expit}(x) = 1/(1+\exp(-x))\) es la función inversa de la función \(\textsf{logit}(x) = \log(x/(1-x))\).
edges en ergm.
Es de interés incorporar estadísticos de orden superior asociados con la estructura global del grafo, como el número de \(k\)-estrellas (\(k\)-stars, \(k+1\) vértices y \(k\) aristas) \(S_k(\mathbf{y})\) y el número de triángulos (3-clique) \(T(\mathbf{y})\).
\(S_1(\mathbf{y})\) es el número de aristas.
Se especifica el modelo: \[ p(\mathbf{y}\mid\boldsymbol{\theta}) = \frac{1}{\kappa}\,\exp{\left\{ \sum_{k=1}^{n-1}\theta_k\,S_k(\mathbf{y}) + \theta_T\,T(\mathbf{y}) \right\}} \] donde \(n\) es el orden del grafo.
kstar y triangle en ergm.
Con el fin de mejorar el ajuste del modelo se proponen restricciones sobre los parámetros de las estrellas e la forma \(\theta_k \propto (-1)^k/\lambda^{k-2}\), para \(k\geq 2\) y algún \(\lambda\geq 1\). Esto combina las \(k\)-estrellas en un solo estadístico alternante (alternating \(k\)-star statistic) de la forma: \[ \textsf{AKS}(\mathbf{y}) = \sum_{k=2}^{n-1} \frac{(-1)^{k}}{\lambda^{k-2}}\,S_k(\mathbf{y}) \] el cual está asociado con un solo parámetro \(\theta_{\text{AKS}}\) que tiene en cuenta los efectos de todas las \(k\)-estrellas simultáneamente.
altkstar en ergm.
También se puede utilizar el conteo de grado ponderado geométricamente (geometrically weighted degree count), si se quiere incorporar el grado en el modelo: \[ \textsf{GWD}(\mathbf{y}) = \sum_{d=0}^{n-1} e^{-\gamma\,d} N_d(\mathbf{y}) \] donde \(N_d(\mathbf{y})\) es el número de vértices de grado \(d\) y \(\gamma>0\).
gwdegree o gwesp en ergm.
La plausibilidad de que una arista una a dos vértices depende no solo del estado (0 o 1) de las aristas entre otros pares de vértices, sino también de los atributos de los vértices (variables exógenas).
Los atributos de los vértices se pueden incluir en la formulación de un ERGM mediante \[ \boldsymbol{\mathsf{g}}(\mathbf{y},\mathbf{x}) = \sum_{i<j} y_{i,j}\,h(\mathbf{x}_i,\mathbf{x}_j) \] donde \(h(\mathbf{x}_i,\mathbf{x}_j)\) es una función simétrica de \(\mathbf{x}_i\) y \(\mathbf{x}_j\), y \(\mathbf{x}_i\) es el vector de atributos observados del vértice \(i\).
nodecov o nodemain en ergm.nodematch o absdif en ergm.match en ergm.El estimador de máxima verosimilitud (maximum likelihood estimator, MLE) de \(\boldsymbol{\theta}\) es \[ \hat{\boldsymbol{\theta}}_{\text{MLE}} = \text{arg max}_{\boldsymbol{\theta}}\, \ell(\boldsymbol{\theta}) = \text{arg max}_{\boldsymbol{\theta}}\, \left(\boldsymbol{\theta}^{\textsf{T}}\,\boldsymbol{\mathsf{g}}(\mathbf{y}) - \psi(\boldsymbol{\theta})\right) \] donde \(\psi(\boldsymbol{\theta}) = \log \kappa(\boldsymbol{\theta})\).
La función \(\psi(\boldsymbol{\theta})\) no se puede evaluar explícitamente, dado que involucra una suma sobre \(2^{\binom{n}{2}}\) términos (uno para cada posible valor de \(\mathbf{y}\)), para cada \(\boldsymbol{\theta}\).
El paquete ergm utiliza una versión estimación de máxima verosimilitud por medio de cadenas de Markov de Monte Carlo (Markoc chain Monte Carlo, MCMC).
Conjunto de datos de lazos matrimoniales y comerciales entre familias florentinas del Renacimiento.
Padgett, John F. 1994. Marriage and Elite Structure in Renaissance Florence, 1282-1500. Paper delivered to the Social Science History Association.
# paquetes
suppressMessages(suppressWarnings(library(ergm)))
# datos
data(florentine)
flomarriage
## Network attributes:
## vertices = 16
## directed = FALSE
## hyper = FALSE
## loops = FALSE
## multiple = FALSE
## bipartite = FALSE
## total edges= 20
## missing edges= 0
## non-missing edges= 20
##
## Vertex attribute names:
## priorates totalties vertex.names wealth
##
## No edge attributes
# clase
class(flomarriage)
## [1] "network"
# atributos
wealth <- flomarriage %v% 'wealth'
wealth
## [1] 10 36 55 44 20 32 8 42 103 48 49 3 27 10 146 48
Parace haber una relación entre la riqueza y la sociabilidad.
# grafico
par(mfrow=c(1,2)) # Setup a 2 panel plot
plot(flomarriage, main = "Matrimonios", label = network.vertex.names(flomarriage))
plot(flomarriage, vertex.cex = wealth/25, main = "Matrimoios por riqueza")
# formulacion del modelo
ergm.01 <- formula(flomarriage ~ edges)
summary(ergm.01)
## edges
## 20
# ajuste del modelo
set.seed(42)
ergm.fit.01 <- ergm(formula = ergm.01)
## Starting maximum pseudolikelihood estimation (MPLE):
## Evaluating the predictor and response matrix.
## Maximizing the pseudolikelihood.
## Finished MPLE.
## Stopping at the initial estimate.
## Evaluating log-likelihood at the estimate.
anova(ergm.fit.01)
## Analysis of Variance Table
##
## Model 1: flomarriage ~ edges
## Df Deviance Resid. Df Resid. Dev Pr(>|Chisq|)
## NULL 120 166.35
## Model 1: 1 58.221 119 108.14 2.343e-14 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
summary(ergm.fit.01)
## Call:
## ergm(formula = ergm.01)
##
## Maximum Likelihood Results:
##
## Estimate Std. Error MCMC % z value Pr(>|z|)
## edges -1.6094 0.2449 0 -6.571 <1e-04 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Null Deviance: 166.4 on 120 degrees of freedom
## Residual Deviance: 108.1 on 119 degrees of freedom
##
## AIC: 110.1 BIC: 112.9 (Smaller is better. MC Std. Err. = 0)
# extraer coeficientes
coef(ergm.fit.01)
## edges
## -1.609438
La probabilidad condicional en escala logit (log-odds) de que una arista esté presente entre dos actores, manteniendo fija el resto de la red, es \[ \text{logit}\,\textsf{Pr}(y_{i,j}=1\mid\mathbf{y}_{-(i,j)}) = -1.609438 \cdot\text{cambio en el n. de aristas} = -1.609438 \cdot 1 \] En escala natural, la probabilidad es \(\text{expit}(-1.609438 ) = -1.609438\) dado que
# de network a igraph
A <- as.matrix.network.adjacency(x = flomarriage)
g <- igraph::graph_from_adjacency_matrix(adjmatrix = A, mode = "undirected")
# expit de -1.4992
1/(1+exp(-(-1.609438)))
## [1] 0.1666667
exp(-1.609438)/(1+exp(-1.609438))
## [1] 0.1666667
# densidad
igraph::edge_density(graph = g)
## [1] 0.1666667
# mas componentes
names(ergm.fit.01)
## [1] "coefficients" "iterations" "MCMCtheta" "gradient"
## [5] "hessian" "covar" "failure" "glm"
## [9] "glm.null" "xmat.full" "call" "ergm_version"
## [13] "offset" "MPLE_is_MLE" "drop" "estimable"
## [17] "network" "reference" "newnetwork" "formula"
## [21] "constrained" "constraints" "obs.constraints" "nw.stats"
## [25] "etamap" "estimate" "estimate.desc" "control"
## [29] "null.lik" "mle.lik"
# formulacion del modelo
ergm.02 <- formula(flomarriage ~ edges + triangles)
summary(ergm.02)
## edges triangle
## 20 3
# ajuste del modelo
set.seed(42)
ergm.fit.02 <- ergm(formula = ergm.02)
## Starting maximum pseudolikelihood estimation (MPLE):
## Evaluating the predictor and response matrix.
## Maximizing the pseudolikelihood.
## Finished MPLE.
## Starting Monte Carlo maximum likelihood estimation (MCMLE):
## Iteration 1 of at most 60:
## Optimizing with step length 1.0000.
## The log-likelihood improved by 0.0062.
## Convergence test p-value: < 0.0001. Converged with 99% confidence.
## Finished MCMLE.
## Evaluating log-likelihood at the estimate. Fitting the dyad-independent submodel...
## Bridging between the dyad-independent submodel and the full model...
## Setting up bridge sampling...
## Using 16 bridges: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 .
## Bridging finished.
## This model was fit using MCMC. To examine model diagnostics and check
## for degeneracy, use the mcmc.diagnostics() function.
anova(ergm.fit.02)
## Analysis of Variance Table
##
## Model 1: flomarriage ~ edges + triangles
## Df Deviance Resid. Df Resid. Dev Pr(>|Chisq|)
## NULL 120 166.35
## Model 1: 2 58.285 118 108.07 2.206e-13 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
summary(ergm.fit.02)
## Call:
## ergm(formula = ergm.02)
##
## Monte Carlo Maximum Likelihood Results:
##
## Estimate Std. Error MCMC % z value Pr(>|z|)
## edges -1.6898 0.3595 0 -4.700 <1e-04 ***
## triangle 0.1622 0.6342 0 0.256 0.798
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Null Deviance: 166.4 on 120 degrees of freedom
## Residual Deviance: 108.1 on 118 degrees of freedom
##
## AIC: 112.1 BIC: 117.6 (Smaller is better. MC Std. Err. = 0.009767)
La probabilidad condicional en escala logit (log-odds) de que una arista esté presente entre dos actores, manteniendo fija el resto de la red, es \[ \text{logit}\,\textsf{Pr}(y_{i,j}=1\mid\mathbf{y}_{-(i,j)}) = -1.6898\cdot\text{cambio en el n. de aristas} + 0.1622\cdot\text{cambio en el n. de triángulos} \]
# probabilidades
expit <- function(x) 1/(1+exp(-x))
expit(-1.6898)
## [1] 0.1558021
expit(-1.5276)
## [1] 0.1783451
La riqueza parecía estar asociada con un mayor grado en esta red. En efecto, hay un efecto positivo de la riqueza sobre la probabilidad de un observar una arista:
# covariable
summary(wealth)
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 3.00 17.50 39.00 42.56 48.25 146.00
# formulacion del modelo
ergm.03 <- formula(flomarriage ~ edges + nodemain('wealth'))
summary(ergm.03)
## edges nodecov.wealth
## 20 2168
# ajuste del modelo
set.seed(42)
ergm.fit.03 <- ergm(formula = ergm.03)
## Starting maximum pseudolikelihood estimation (MPLE):
## Evaluating the predictor and response matrix.
## Maximizing the pseudolikelihood.
## Finished MPLE.
## Stopping at the initial estimate.
## Evaluating log-likelihood at the estimate.
anova(ergm.fit.03)
## Analysis of Variance Table
##
## Model 1: flomarriage ~ edges + nodemain("wealth")
## Df Deviance Resid. Df Resid. Dev Pr(>|Chisq|)
## NULL 120 166.35
## Model 1: 2 63.247 118 103.11 1.846e-14 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
summary(ergm.fit.03)
## Call:
## ergm(formula = ergm.03)
##
## Maximum Likelihood Results:
##
## Estimate Std. Error MCMC % z value Pr(>|z|)
## edges -2.594929 0.536056 0 -4.841 <1e-04 ***
## nodecov.wealth 0.010546 0.004674 0 2.256 0.0241 *
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Null Deviance: 166.4 on 120 degrees of freedom
## Residual Deviance: 103.1 on 118 degrees of freedom
##
## AIC: 107.1 BIC: 112.7 (Smaller is better. MC Std. Err. = 0)
La probabilidad condicional en escala logit (log-odds) de que una arista esté presente entre dos actores, manteniendo fija el resto de la red, es \[ \text{logit}\,\textsf{Pr}(y_{i,j}=1\mid\mathbf{y}_{-(i,j)}) = -2.594929\cdot\text{cambio en el n. de aristas} + 0.010546\cdot\text{suma de la riqueza de los dos nodos} \] - Para una arista entre dos nodos con la mínima riqueza, el log-odds condicional es \(-2.594929 + 0.010546*(3+3)=-2.531653\). - Para una arista entre dos nodos con la máxima riqueza, el log-odds condicional es \(-2.594929 + 0.010546*(146+146)=0.484503\). - Las probabilidades correspondientes son \(0.07366876\) y \(0.6188106\).
# probabilidades
expit(-2.531653)
## [1] 0.07366876
expit(0.484503)
## [1] 0.6188106
Red de amistad mutua basada en una de las escuelas del estudio AddHealth, Wave I. La comunidad escolar en la que se basa se encuentra en la zona rural del oeste de los EE. UU., con un alumnado mayoritariamente hispano y nativo americano.
Resnick M.D., Bearman, P.S., Blum R.W. et al. (1997). Protecting adolescents from harm. Findings from the National Longitudinal Study on Adolescent Health, Journal of the American Medical Association, 278: 823-32.
Se examina la homofilia en las amistades por grado y raza. Ambos son atributos discretos.
# datos (version simulada)
data(faux.mesa.high)
mesa <- faux.mesa.high
mesa
## Network attributes:
## vertices = 205
## directed = FALSE
## hyper = FALSE
## loops = FALSE
## multiple = FALSE
## bipartite = FALSE
## total edges= 203
## missing edges= 0
## non-missing edges= 203
##
## Vertex attribute names:
## Grade Race Sex
##
## No edge attributes
table(mesa %v% 'Grade')
##
## 7 8 9 10 11 12
## 62 40 42 25 24 12
table(mesa %v% 'Race')
##
## Black Hisp NatAm Other White
## 6 109 68 4 18
table(mesa %v% 'Sex')
##
## F M
## 99 106
# grafico
par(mfrow = c(1,1))
plot(mesa, vertex.col = 'Grade')
legend('bottomleft', fill = 7:12, legend = paste('Grade',7:12), cex = 0.75)
# formulacion del modelo
ergm.04 <- formula(mesa ~ edges + nodefactor('Grade') + nodematch('Grade', diff=T) + nodefactor('Race') + nodematch('Race', diff=T))
summary(ergm.04)
## edges nodefactor.Grade.8 nodefactor.Grade.9
## 203 75 65
## nodefactor.Grade.10 nodefactor.Grade.11 nodefactor.Grade.12
## 36 49 28
## nodematch.Grade.7 nodematch.Grade.8 nodematch.Grade.9
## 75 33 23
## nodematch.Grade.10 nodematch.Grade.11 nodematch.Grade.12
## 9 17 6
## nodefactor.Race.Hisp nodefactor.Race.NatAm nodefactor.Race.Other
## 178 156 1
## nodefactor.Race.White nodematch.Race.Black nodematch.Race.Hisp
## 45 0 53
## nodematch.Race.NatAm nodematch.Race.Other nodematch.Race.White
## 46 0 4
¡Cuidado! Hay varios 0s.
# ajuste del modelo
set.seed(42)
ergm.fit.04 <- ergm(formula = ergm.04)
## Observed statistic(s) nodematch.Race.Black and nodematch.Race.Other are at their smallest attainable values. Their coefficients will be fixed at -Inf.
## Starting maximum pseudolikelihood estimation (MPLE):
## Evaluating the predictor and response matrix.
## Maximizing the pseudolikelihood.
## Finished MPLE.
## Stopping at the initial estimate.
## Evaluating log-likelihood at the estimate.
anova(ergm.fit.04)
## Analysis of Variance Table
##
## Model 1: mesa ~ edges + nodefactor("Grade") + nodematch("Grade", diff = T) +
## nodefactor("Race") + nodematch("Race", diff = T)
## Df Deviance Resid. Df Resid. Dev Pr(>|Chisq|)
## NULL 20910 28987.4
## Model 1: 19 27161 20891 1826.8 < 2.2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
summary(ergm.fit.04)
## Call:
## ergm(formula = ergm.04)
##
## Maximum Likelihood Results:
##
## Estimate Std. Error MCMC % z value Pr(>|z|)
## edges -8.0538 1.2561 0 -6.412 < 1e-04 ***
## nodefactor.Grade.8 1.5201 0.6858 0 2.216 0.026663 *
## nodefactor.Grade.9 2.5284 0.6493 0 3.894 < 1e-04 ***
## nodefactor.Grade.10 2.8652 0.6512 0 4.400 < 1e-04 ***
## nodefactor.Grade.11 2.6291 0.6563 0 4.006 < 1e-04 ***
## nodefactor.Grade.12 3.4629 0.6566 0 5.274 < 1e-04 ***
## nodematch.Grade.7 7.4662 1.1730 0 6.365 < 1e-04 ***
## nodematch.Grade.8 4.2882 0.7150 0 5.997 < 1e-04 ***
## nodematch.Grade.9 2.0371 0.5538 0 3.678 0.000235 ***
## nodematch.Grade.10 1.2489 0.6233 0 2.004 0.045111 *
## nodematch.Grade.11 2.4521 0.6124 0 4.004 < 1e-04 ***
## nodematch.Grade.12 1.2987 0.6981 0 1.860 0.062824 .
## nodefactor.Race.Hisp -1.6659 0.2963 0 -5.622 < 1e-04 ***
## nodefactor.Race.NatAm -1.4725 0.2869 0 -5.132 < 1e-04 ***
## nodefactor.Race.Other -2.9618 1.0372 0 -2.856 0.004296 **
## nodefactor.Race.White -0.8488 0.2958 0 -2.869 0.004112 **
## nodematch.Race.Black -Inf 0.0000 0 -Inf < 1e-04 ***
## nodematch.Race.Hisp 0.6912 0.3451 0 2.003 0.045153 *
## nodematch.Race.NatAm 1.2482 0.3550 0 3.517 0.000437 ***
## nodematch.Race.Other -Inf 0.0000 0 -Inf < 1e-04 ***
## nodematch.Race.White 0.3140 0.6405 0 0.490 0.623947
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Null Deviance: 28987 on 20910 degrees of freedom
## Residual Deviance: 1827 on 20889 degrees of freedom
##
## AIC: 1865 BIC: 2016 (Smaller is better. MC Std. Err. = 0)
##
## Warning: The following terms have infinite coefficient estimates:
## nodematch.Race.Black nodematch.Race.Other
Algunos coeficientes dan como resultado -Inf:
mixingmatrix(object = mesa, attrname = "Race")
## Black Hisp NatAm Other White
## Black 0 8 13 0 5
## Hisp 8 53 41 1 22
## NatAm 13 41 46 0 10
## Other 0 1 0 0 0
## White 5 22 10 0 4
## Note: Marginal totals can be misleading for undirected mixing matrices.
Sampson (1969) registró las interacciones sociales entre un grupo de monjes mientras él era un residente como experimentador en el claustro. De particular interés son los datos sobre relaciones de afecto positivo (“agrado”), en los que se preguntó a cada monje si tenía relaciones positivas con cada uno de los demás monjes. Cada monje clasificó solo sus tres opciones principales (o cuatro, en el caso de empates) en “agrado”. Aquí, consideramos que existe auna arista dirigida del monje A al monje B si A nombró a B entre estas opciones principales.
Sampson, S.~F. (1968), A novitiate in a period of change: An experimental and case study of relationships, Unpublished Ph.D. dissertation, Department of Sociology, Cornell University.
# datos
data(samplk)
samplk3
## Network attributes:
## vertices = 18
## directed = TRUE
## hyper = FALSE
## loops = FALSE
## multiple = FALSE
## bipartite = FALSE
## total edges= 56
## missing edges= 0
## non-missing edges= 56
##
## Vertex attribute names:
## cloisterville group vertex.names
##
## No edge attributes
# grafico
plot(samplk3, vertex.cex = 2)
# formulacion del modelo
ergm.05 <- formula(samplk3 ~ edges + mutual)
summary(ergm.05)
## edges mutual
## 56 15
15 de las 56 aristas dirigidas son mutuas.
# ajuste del modelo
set.seed(42)
ergm.fit.05 <- ergm(formula = ergm.05)
## Starting maximum pseudolikelihood estimation (MPLE):
## Evaluating the predictor and response matrix.
## Maximizing the pseudolikelihood.
## Finished MPLE.
## Starting Monte Carlo maximum likelihood estimation (MCMLE):
## Iteration 1 of at most 60:
## Optimizing with step length 1.0000.
## The log-likelihood improved by 0.0031.
## Convergence test p-value: < 0.0001. Converged with 99% confidence.
## Finished MCMLE.
## Evaluating log-likelihood at the estimate. Fitting the dyad-independent submodel...
## Bridging between the dyad-independent submodel and the full model...
## Setting up bridge sampling...
## Using 16 bridges: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 .
## Bridging finished.
## This model was fit using MCMC. To examine model diagnostics and check
## for degeneracy, use the mcmc.diagnostics() function.
anova(ergm.fit.05)
## Analysis of Variance Table
##
## Model 1: samplk3 ~ edges + mutual
## Df Deviance Resid. Df Resid. Dev Pr(>|Chisq|)
## NULL 306 424.21
## Model 1: 2 156.28 304 267.92 < 2.2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
summary(ergm.fit.05)
## Call:
## ergm(formula = ergm.05)
##
## Monte Carlo Maximum Likelihood Results:
##
## Estimate Std. Error MCMC % z value Pr(>|z|)
## edges -2.1685 0.2199 0 -9.860 <1e-04 ***
## mutual 2.3127 0.4745 0 4.874 <1e-04 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Null Deviance: 424.2 on 306 degrees of freedom
## Residual Deviance: 267.9 on 304 degrees of freedom
##
## AIC: 271.9 BIC: 279.4 (Smaller is better. MC Std. Err. = 0.3185)
Red de relaciones de trabajo colaborativo entre miembros de una firma de abogados. Disponible en la librería sand de R.
Lazega, E. (2001). The collegial phenomenon: The social mechanisms of cooperation among peers in a corporate law partnership. Oxford University Press on Demand.
# paquetes
suppressMessages(suppressWarnings(library(ergm)))
suppressMessages(suppressWarnings(library(sand)))
# datos
data(lazega)
# matriz de adyacencia
A <- igraph::as_adjacency_matrix(graph = lazega)
# simetrica?
isSymmetric(as.matrix(A))
## [1] TRUE
# atributos (variables exogenas)
v.attrs <- igraph::as_data_frame(x = lazega, what = "vertices")
head(v.attrs)
## name Seniority Status Gender Office Years Age Practice School
## V1 V1 1 1 1 1 31 64 1 1
## V2 V2 2 1 1 1 32 62 2 1
## V3 V3 3 1 1 2 13 67 1 1
## V4 V4 4 1 1 1 31 59 2 3
## V5 V5 5 1 1 2 31 59 1 2
## V6 V6 6 1 1 2 29 55 1 1
# formato network
lazega.s <- network::as.network(x = as.matrix(A), directed = F)
# establecer atributos
network::set.vertex.attribute(x = lazega.s, attrname = "Office", value = v.attrs$Office)
network::set.vertex.attribute(x = lazega.s, attrname = "Practice", value = v.attrs$Practice)
network::set.vertex.attribute(x = lazega.s, attrname = "Gender", value = v.attrs$Gender)
network::set.vertex.attribute(x = lazega.s, attrname = "Seniority", value = v.attrs$Seniority)
# formulacion del modelo
my.ergm <- formula(lazega.s ~ edges + kstar(2) + kstar(3) + triangle)
summary(my.ergm)
## edges kstar2 kstar3 triangle
## 115 926 2681 120
\(\textsf{GWD}(\mathbf{y})\) con \(\gamma = 1\).
# formulacion del modelo
my.ergm <- formula(lazega.s ~ edges + gwesp(decay = 1, fixed = T))
summary(my.ergm)
## edges gwesp.fixed.1
## 115.0000 213.1753
\[ p(\mathbf{y}\mid\theta_1,\theta_2,\boldsymbol{\beta}) = \frac{1}{\kappa(\theta_1,\theta_2,\boldsymbol{\beta})}\,\exp{\left\{ \theta_1 S_1(\mathbf{y}) + \theta_2\textsf{GWD}(\mathbf{y}) + \boldsymbol{\beta}^{\textsf{T}}\boldsymbol{\mathsf{g}}(\mathbf{y},\mathbf{x}) \right\}} \]
lazega.ergm <- formula(lazega.s ~ edges + gwesp(decay = 1, fixed = T)
+ nodemain("Seniority")
+ nodemain("Practice")
+ match("Practice")
+ match("Gender")
+ match("Office"))
summary(lazega.ergm)
## edges gwesp.fixed.1 nodecov.Seniority nodecov.Practice
## 115.0000 213.1753 4687.0000 359.0000
## nodematch.Practice nodematch.Gender nodematch.Office
## 72.0000 99.0000 85.0000
set.seed(42)
lazega.ergm.fit <- ergm(formula = lazega.ergm)
## Starting maximum pseudolikelihood estimation (MPLE):
## Evaluating the predictor and response matrix.
## Maximizing the pseudolikelihood.
## Finished MPLE.
## Starting Monte Carlo maximum likelihood estimation (MCMLE):
## Iteration 1 of at most 60:
## Optimizing with step length 1.0000.
## The log-likelihood improved by 0.3105.
## Estimating equations are not within tolerance region.
## Iteration 2 of at most 60:
## Optimizing with step length 1.0000.
## The log-likelihood improved by 0.0645.
## Convergence test p-value: 0.3379. Not converged with 99% confidence; increasing sample size.
## Iteration 3 of at most 60:
## Optimizing with step length 1.0000.
## The log-likelihood improved by 0.0488.
## Convergence test p-value: 0.7349. Not converged with 99% confidence; increasing sample size.
## Iteration 4 of at most 60:
## Optimizing with step length 1.0000.
## The log-likelihood improved by 0.0206.
## Convergence test p-value: 0.1764. Not converged with 99% confidence; increasing sample size.
## Iteration 5 of at most 60:
## Optimizing with step length 1.0000.
## The log-likelihood improved by 0.0066.
## Convergence test p-value: < 0.0001. Converged with 99% confidence.
## Finished MCMLE.
## Evaluating log-likelihood at the estimate. Fitting the dyad-independent submodel...
## Bridging between the dyad-independent submodel and the full model...
## Setting up bridge sampling...
## Using 16 bridges: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 .
## Bridging finished.
## This model was fit using MCMC. To examine model diagnostics and check
## for degeneracy, use the mcmc.diagnostics() function.
anova(lazega.ergm.fit)
## Analysis of Variance Table
##
## Model 1: lazega.s ~ edges + gwesp(decay = 1, fixed = T) + nodemain("Seniority") +
## nodemain("Practice") + match("Practice") + match("Gender") +
## match("Office")
## Df Deviance Resid. Df Resid. Dev Pr(>|Chisq|)
## NULL 630 873.37
## Model 1: 7 415.71 623 457.66 < 2.2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
summary(lazega.ergm.fit)
## Call:
## ergm(formula = lazega.ergm)
##
## Monte Carlo Maximum Likelihood Results:
##
## Estimate Std. Error MCMC % z value Pr(>|z|)
## edges -7.095481 0.683921 0 -10.375 < 1e-04 ***
## gwesp.fixed.1 0.666311 0.099177 0 6.718 < 1e-04 ***
## nodecov.Seniority 0.024377 0.006338 0 3.846 0.000120 ***
## nodecov.Practice 0.398218 0.107373 0 3.709 0.000208 ***
## nodematch.Practice 0.770408 0.187214 0 4.115 < 1e-04 ***
## nodematch.Gender 0.724602 0.248256 0 2.919 0.003514 **
## nodematch.Office 1.167166 0.194039 0 6.015 < 1e-04 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Null Deviance: 873.4 on 630 degrees of freedom
## Residual Deviance: 457.7 on 623 degrees of freedom
##
## AIC: 471.7 BIC: 502.8 (Smaller is better. MC Std. Err. = 0.2505)
Hay evidencia de un efecto de transitividad no trivial.
Manteniendo constantes los valores de las otras estadísticas, condicionalmente se tiene que:
Se considera el término degree(1) para determinar si hay más (o menos) nodos de grado 1 de los que se esperarían, dada la densidad.
# formulacion del modelo
summary(flobusiness ~ edges + degree(1))
## edges degree1
## 15 3
# ajuste el modelo
fit <- ergm(flobusiness ~ edges + degree(1))
## Starting maximum pseudolikelihood estimation (MPLE):
## Evaluating the predictor and response matrix.
## Maximizing the pseudolikelihood.
## Finished MPLE.
## Starting Monte Carlo maximum likelihood estimation (MCMLE):
## Iteration 1 of at most 60:
## Optimizing with step length 1.0000.
## The log-likelihood improved by 0.3101.
## Estimating equations are not within tolerance region.
## Iteration 2 of at most 60:
## Optimizing with step length 1.0000.
## The log-likelihood improved by 0.0351.
## Convergence test p-value: 0.0003. Converged with 99% confidence.
## Finished MCMLE.
## Evaluating log-likelihood at the estimate. Fitting the dyad-independent submodel...
## Bridging between the dyad-independent submodel and the full model...
## Setting up bridge sampling...
## Using 16 bridges: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 .
## Bridging finished.
## This model was fit using MCMC. To examine model diagnostics and check
## for degeneracy, use the mcmc.diagnostics() function.
summary(fit)
## Call:
## ergm(formula = flobusiness ~ edges + degree(1))
##
## Monte Carlo Maximum Likelihood Results:
##
## Estimate Std. Error MCMC % z value Pr(>|z|)
## edges -2.1179 0.2965 0 -7.144 <1e-04 ***
## degree1 -0.6034 0.6906 0 -0.874 0.382
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Null Deviance: 166.36 on 120 degrees of freedom
## Residual Deviance: 89.37 on 118 degrees of freedom
##
## AIC: 93.37 BIC: 98.95 (Smaller is better. MC Std. Err. = 0.0338)
Cuando los términos dependientes de la díada están en el modelo, los algoritmos computacionales en ergm usan MCMC (con un muestreador de Metropolis-Hastings) para estimar los parámetros.
mcmc.diagnostics(fit)
## Sample statistics summary:
##
## Iterations = 20992:131072
## Thinning interval = 512
## Number of chains = 1
## Sample size per chain = 216
##
## 1. Empirical mean and standard deviation for each variable,
## plus standard error of the mean:
##
## Mean SD Naive SE Time-series SE
## edges 0.06944 3.593 0.2445 0.2708
## degree1 -0.39352 1.543 0.1050 0.1050
##
## 2. Quantiles for each variable:
##
## 2.5% 25% 50% 75% 97.5%
## edges -6 -2.25 0 2.00 6.625
## degree1 -3 -1.00 -1 0.25 3.000
##
##
## Are sample statistics significantly different from observed?
## edges degree1 Overall (Chi^2)
## diff. 0.06944444 -0.3935185185 NA
## test stat. 0.25647099 -3.7494437496 15.029026139
## P-val. 0.79758717 0.0001772272 0.000725652
##
## Sample statistics cross-correlations:
## edges degree1
## edges 1.0000000 -0.3323922
## degree1 -0.3323922 1.0000000
##
## Sample statistics auto-correlation:
## Chain 1
## edges degree1
## Lag 0 1.00000000 1.000000000
## Lag 512 0.09943339 0.038685469
## Lag 1024 0.09820085 0.009829421
## Lag 1536 -0.05466601 0.115088038
## Lag 2048 -0.03678104 0.052230451
## Lag 2560 0.03714065 0.047601743
##
## Sample statistics burn-in diagnostic (Geweke):
## Chain 1
##
## Fraction in 1st window = 0.1
## Fraction in 2nd window = 0.5
##
## edges degree1
## -1.0000 -0.3513
##
## Individual P-values (lower = worse):
## edges degree1
## 0.3173269 0.7253321
## Joint P-value (lower = worse): 0.3485651 .
##
## MCMC diagnostics shown here are from the last round of simulation, prior to computation of final parameter estimates. Because the final estimates are refinements of those used for this simulation run, these diagnostics may understate model performance. To directly assess the performance of the final model on in-model statistics, please use the GOF command: gof(ergmFitObject, GOF=~model).
Una vez que hemos estimado los coeficientes de un ERGM, el modelo está completamente especificado. Define una distribución de probabilidad en todas las redes de este tamaño. Si el modelo se ajusta bien a los datos observados, es más probable que las redes simuladas de esta distribución se “parezcan” a los datos observados.
# ajuste del modelo
set.seed(42)
ergm.03 <- formula(flomarriage ~ edges + nodemain('wealth'))
ergm.fit.03 <- ergm(formula = ergm.03)
## Starting maximum pseudolikelihood estimation (MPLE):
## Evaluating the predictor and response matrix.
## Maximizing the pseudolikelihood.
## Finished MPLE.
## Stopping at the initial estimate.
## Evaluating log-likelihood at the estimate.
# simulacion
sim.03 <- simulate(object = ergm.fit.03, nsim = 10, seed = 42)
# clase
class(sim.03)
## [1] "network.list"
# resumen de la simulacion
summary(sim.03)
## Number of Networks: 10
## Model: flomarriage ~ edges + nodemain("wealth")
## Reference: ~Bernoulli
## Constraints: ~.
## Stored network statistics:
## edges nodecov.wealth
## [1,] 21 2351
## [2,] 19 2266
## [3,] 18 2026
## [4,] 23 2451
## [5,] 18 2204
## [6,] 17 1841
## [7,] 18 2188
## [8,] 20 2385
## [9,] 15 1628
## [10,] 21 2315
## attr(,"monitored")
## [1] FALSE FALSE
## Number of Networks: 10
## Model: flomarriage ~ edges + nodemain("wealth")
## Reference: ~Bernoulli
## Constraints: ~.
# atributos de la simulacion
attributes(sim.03)
## $coefficients
## edges nodecov.wealth
## -2.59492903 0.01054591
##
## $control
## Control parameter list generated by 'control.simulate.formula' or equivalent. Non-empty parameters:
## MCMC.burnin: 16384
## MCMC.interval: 1024
## MCMC.scale: 1
## MCMC.prop: ~sparse
## MCMC.prop.weights: "default"
## MCMC.batch: 0
## MCMC.effectiveSize.damp: 10
## MCMC.effectiveSize.maxruns: 1000
## MCMC.effectiveSize.burnin.pval: 0.2
## MCMC.maxedges: Inf
## MCMC.runtime.traceplot: FALSE
## network.output: "network"
## parallel: 0
## parallel.version.check: TRUE
## parallel.inherit.MT: FALSE
## MCMC.samplesize: 10
## obs.MCMC.mul: 0.25
## obs.MCMC.samplesize.mul: 0.5
## obs.MCMC.interval.mul: 0.5
## obs.MCMC.burnin.mul: 0.5
## obs.MCMC.prop: ~sparse
## obs.MCMC.prop.weights: "default"
## MCMC.save_networks: TRUE
##
## $response
## [1] NA
##
## $class
## [1] "network.list"
##
## $stats
## edges nodecov.wealth
## [1,] 21 2351
## [2,] 19 2266
## [3,] 18 2026
## [4,] 23 2451
## [5,] 18 2204
## [6,] 17 1841
## [7,] 18 2188
## [8,] 20 2385
## [9,] 15 1628
## [10,] 21 2315
## attr(,"monitored")
## [1] FALSE FALSE
##
## $formula
## flomarriage ~ edges + nodemain("wealth")
## attr(,".Basis")
## Network attributes:
## vertices = 16
## directed = FALSE
## hyper = FALSE
## loops = FALSE
## multiple = FALSE
## bipartite = FALSE
## total edges= 20
## missing edges= 0
## non-missing edges= 20
##
## Vertex attribute names:
## priorates totalties vertex.names wealth
##
## No edge attributes
##
## $constraints
## ~.
## <environment: 0x0000000021bd4388>
##
## $reference
## ~Bernoulli
## <environment: 0x0000000021cd65b0>
# valores simulados vs valores observados
rbind("Valoes obs." = summary(ergm.03),
"Media sim." = colMeans(attr(sim.03, "stats")))
## edges nodecov.wealth
## Valoes obs. 20 2168.0
## Media sim. 19 2165.5
# grafico de una red simulada
plot(sim.03[[1]], label = sim.03[[1]] %v% "vertex.names", vertex.cex = (sim.03[[1]] %v% "wealth")/25)
Una prueba de si un modelo “se ajusta a los datos” es qué tan bien reproduce las propiedades de la red observada que no están en el modelo. Hacemos esto eligiendo un estadístico de prueba que no esté en el modelo y comparando el valor del estadístico observado en la red original con la distribución de valores que obtenemos en redes simuladas del modelo.
# bondad de ajuste del modelo
# solo tres estadistico de prueba
gof.03 <- gof(object = ergm.fit.03)
gof.03
##
## Goodness-of-fit for degree
##
## obs min mean max MC p-value
## degree0 1 0 1.24 4 1.00
## degree1 4 0 3.55 9 0.94
## degree2 2 1 4.35 10 0.34
## degree3 6 0 3.12 6 0.08
## degree4 2 0 1.93 5 1.00
## degree5 0 0 1.09 5 0.70
## degree6 1 0 0.42 3 0.62
## degree7 0 0 0.20 1 1.00
## degree8 0 0 0.02 1 1.00
## degree9 0 0 0.06 1 1.00
## degree10 0 0 0.01 1 1.00
## degree12 0 0 0.01 1 1.00
##
## Goodness-of-fit for edgewise shared partner
##
## obs min mean max MC p-value
## esp0 12 2 12.09 22 1.0
## esp1 7 0 6.05 13 0.9
## esp2 1 0 1.35 8 1.0
## esp3 0 0 0.26 3 1.0
## esp4 0 0 0.05 2 1.0
## esp5 0 0 0.01 1 1.0
##
## Goodness-of-fit for minimum geodesic distance
##
## obs min mean max MC p-value
## 1 20 12 19.81 30 1.00
## 2 35 10 34.41 70 1.00
## 3 32 0 26.67 41 0.64
## 4 15 0 11.66 24 0.64
## 5 3 0 4.01 16 0.98
## 6 0 0 0.90 8 1.00
## 7 0 0 0.18 5 1.00
## 8 0 0 0.03 2 1.00
## Inf 15 0 22.33 87 1.00
##
## Goodness-of-fit for model statistics
##
## obs min mean max MC p-value
## edges 20 12 19.81 30 1
## nodecov.wealth 2168 1233 2151.59 3792 1
# graficos
plot(gof.03)