-
Notifications
You must be signed in to change notification settings - Fork 1
/
statistics.R
233 lines (214 loc) · 5.82 KB
/
statistics.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
#' @title Network Statistics
#'
#' @description These functions calculate the respective network statistic for
#' ego. When multiplied with the importance of each statistic (the
#' 'parameters') this constitutes the network evaluation of ego. See:
#' [`ts_eval()`].
#'
#' @details For examples on how to use these statistics see:
#' `vignette("1.Introduction_RsienaTwoStep", package="RsienaTwoStep")`.
#'
#' For the mathematical definition of these network statistics see chapter 12
#' of the RSiena manual \insertCite{ripley2022manual}{RsienaTwoStep}.
#' @family networkstatistics
#' @param net matrix, the adjacency matrix representing the relations between
#' actors. Valid values are 0 and 1.
#' @param cov numeric, covariate scores
#' @param ego numeric, the ego for which we want to calculate the network
#' statistic.
#'
#' @references \insertRef{ripley2022manual}{RsienaTwoStep}
#' @return numeric value
#' @seealso [`ts_eval()`]
#' @examples
#' ts_degree(net=ts_net1, ego=3)
#'
#' @importFrom Rdpack reprompt
#' @export
ts_degree <- function(net, ego) {
statistic <- sum(net[ego,])
return(statistic)
}
attr(ts_degree, "name") <- "degree"
ts_degree <- compiler::cmpfun(ts_degree)
#' @rdname ts_degree
#' @export
ts_recip <- function(net, ego) {
statistic <- sum(net[ego,]==1 & t(net)[ego,]==1)
return(statistic)
}
attr(ts_recip, "name") <- "recip"
#' @rdname ts_degree
#' @export
ts_outAct <- function(net, ego) {
statistic <- sum(net[ego,])^2
return(statistic)
}
attr(ts_outAct, "name") <- "outAct"
#' @rdname ts_degree
#' @export
ts_inAct <- function(net, ego) {
statistic <- sum(t(net)[ego,])*sum(net[ego,])
return(statistic)
}
attr(ts_inAct, "name") <- "inAct"
#' @rdname ts_degree
#' @export
ts_outPop <- function(net, ego) {
outdegrees <- rowSums(net) #outdegrees of alters
statistic <- sum(net[ego,] * outdegrees)
return(statistic)
}
attr(ts_outPop, "name") <- "outPop"
#' @rdname ts_degree
#' @export
ts_inPop <- function(net, ego) {
indegrees <- colSums(net) #indegrees of alters
statistic <- sum(net[ego,] * indegrees)
return(statistic)
}
attr(ts_inPop, "name") <- "inPop"
#' @rdname ts_degree
#' @export
ts_transTrip <- function(net, ego) {
statistic <- 0
alters <- which(net[ego,]==1)
if (length(alters)>1) {
#check if alters are connected
for (alter1 in alters) {
for (alter2 in alters) {
statistic <- statistic + net[alter1, alter2]
}
}
}
return(statistic)
}
attr(ts_transTrip, "name") <- "transTrip"
#' @rdname ts_degree
#' @export
ts_transMedTrip <- function(net, ego) {
statistic <- 0
alters1 <- which(net[ego,]==1) #ego connected to by outdegree
alters2 <- which(t(net)[ego,]==1) #ego connected to by indegree
if (length(alters1)>0 & length(alters2)>0) {
#check if alters are connected
for (alter1 in alters1) {
for (alter2 in alters2) {
statistic <- statistic + net[alter1, alter2]
}
}
}
return(statistic)
}
attr(ts_transMedTrip, "name") <- "transMedTrip"
#' @rdname ts_degree
#' @export
ts_transRecTrip <- function(net, ego) {
# i<->j, i->h, h->j
statistic <- 0
alters <- which(net[ego,]==1)
if (length(alters)>1) {
#check if alters are connected
for (alter1 in alters) {
for (alter2 in alters) {
#check first if alter is connected to ego (check for reciprocal tie i <-> j.
if (net[alter1, ego]==1) {
statistic <- statistic + net[alter2, alter1]
}
}
}
}
return(statistic)
}
attr(ts_transRecTrip, "name") <- "transRecTrip"
#' @rdname ts_degree
#' @export
ts_cycle3 <- function(net, ego) {
# i->j, j->h, h->i
statistic <- 0
altersi <- which(net[ego,]==1) #identify alters of ego
if (length(altersi)>0) {
for (alter1 in altersi) {
net_temp <- net
net_temp[alter1, ego] <- 0
altersj <- which(net_temp[alter1,]==1) #identify alters of alter but not including ego
if (length(altersj)>0) {
for (alter2 in altersj) {
statistic <- statistic + net[alter2, ego]
# for some reason in RSiena the 3cycles are counted and not the number
# of three cycles for each ego summed
}
}
}
}
return(statistic)
}
attr(ts_cycle3, "name") <- "cycle3"
#' @rdname ts_degree
#' @export
ts_egoX <- function(net, ego, cov) {
statistic <- cov[ego]*sum(net[ego,])
return(statistic)
}
attr(ts_egoX, "name") <- "egoX"
#' @rdname ts_degree
#' @export
ts_altX <- function(net, ego, cov) {
statistic <- 0
alters <- which(net[ego,]==1)
statistic <- sum(cov[alters])
return(statistic)
}
attr(ts_altX, "name") <- "altX"
#' @rdname ts_degree
#' @export
ts_diffX <- function(net, ego, cov) {
statistic <- 0
alters <- which(net[ego,]==1)
statistic <- sum(cov[alters] - cov[ego])
return(statistic)
}
attr(ts_diffX, "name") <- "diffX"
#' @rdname ts_degree
#' @export
ts_simX <- function(net, ego, cov) {
statistic <- 0
alters <- which(net[ego,]==1)
statistic <- sum(((attributes(cov)$range - abs(cov[alters] - cov[ego])) / attributes(cov)$range) - attributes(cov)$simMean)
return(statistic)
}
attr(ts_simX, "name") <- "simX"
#' @rdname ts_degree
#' @export
ts_absDiffX <- function(net, ego, cov) {
statistic <- 0
alters <- which(net[ego,]==1)
statistic <- sum(abs(cov[alters] - cov[ego]))
return(statistic)
}
attr(ts_absDiffX, "name") <- "absDiffX"
#' @rdname ts_degree
#' @export
ts_sameX <- function(net, ego, cov) {
statistic <- 0
alters <- which(net[ego,]==1)
statistic <- sum(cov[alters] == cov[ego])
return(statistic)
}
attr(ts_sameX, "name") <- "sameX"
#' @rdname ts_degree
#' @export
ts_egoXaltX <- function(net, ego, cov) {
statistic <- 0
alters <- which(net[ego,]==1)
statistic <- cov[ego]*sum(cov[alters])
return(statistic)
}
attr(ts_egoXaltX, "name") <- "egoXaltX"
ts_names <- function(x) {
if (length(x) == 1) {
attributes(x)$name
} else {
paste(attributes(x[[1]])$name, x[[2]])
}
}