Skip to content

Commit dae818c

Browse files
krivitkrivit
committed
Fixes to *b*sp() terms, particularly that they do not work on networks with heterogeneous bipartitedness at this time; tests.
1 parent e626b41 commit dae818c

8 files changed

Lines changed: 143 additions & 22 deletions

‎R/InitErgmTerm.dgw_sp.R‎

Lines changed: 17 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -51,7 +51,7 @@
5151
out$auxiliaries[[2]] <- call("+", out$auxiliaries[[2]], aux3[[2]])
5252
}
5353
if(cache.sp){
54-
aux4 <- .spcache.auxL(type, c(L.path1, L.path2), a$L.in_order)
54+
aux4 <- .spcache.auxL(type, c(L.path1, L.path2), a$L.in_order %||% FALSE)
5555
out$auxiliaries[[2]] <- call("+", out$auxiliaries[[2]], aux4[[2]])
5656
}
5757

@@ -429,11 +429,13 @@ InitErgmTerm.gwnspL <- InitErgmTerm.dgwnspL
429429
#' of the second bipartition.) This term can only be used with bipartite networks.
430430
#'
431431
#' @usage
432-
#' # binary: b1dsp(d, Ls.path=NULL)
432+
#' # binary: b1dspL(d, Ls.path=NULL)
433433
#'
434434
#' @param d a vector of distinct integers.
435435
#' @template ergmTerm-Ls-path
436436
#'
437+
#' @template ergmTerm-bipartite-note
438+
#'
437439
#' @template ergmTerm-cache-sp
438440
#' @template ergmTerm-general
439441
#'
@@ -452,21 +454,23 @@ InitErgmTerm.b1dspL <- function(nw, arglist, cache.sp=TRUE, ...){
452454

453455
################################################################################
454456

455-
#' @templateVar name gwb1dsp
457+
#' @templateVar name gwb1dspL
456458
#' @title Geometrically weighted dyadwise shared partner distribution for dyads in the first bipartition on layers
457459
#' @description This term adds one network statistic to the model equal to the geometrically
458460
#' weighted dyadwise shared partner distribution for dyads in the first bipartition with decay parameter
459461
#' `decay` parameter, which should be non-negative. This term can only be used with bipartite networks.
460462
#'
461463
#' @usage
462-
#' # binary: gwb1dsp(decay=0, fixed=FALSE, cutoff=30, Ls.path=NULL)
464+
#' # binary: gwb1dspL(decay=0, fixed=FALSE, cutoff=30, Ls.path=NULL)
463465
#'
464466
#' @templateVar multiplicand shared partner counts
465467
#' @template ergmTerm-gw-decay-fixed
466468
#' @templateVar underlying b1dsp
467469
#' @template ergmTerm-gw-cutoff
468470
#' @template ergmTerm-Ls-path
469471
#'
472+
#' @template ergmTerm-bipartite-note
473+
#'
470474
#' @template ergmTerm-cache-sp
471475
#' @template ergmTerm-general
472476
#'
@@ -479,7 +483,7 @@ InitErgmTerm.gwb1dspL<-function(nw, arglist, cache.sp=TRUE, gw.cutoff=30, ...) {
479483
varnames = c("decay", "fixed", "cutoff", "alpha", "Ls.path"),
480484
vartypes = c("numeric", "logical", "numeric", "numeric", "formula,list"),
481485
defaultvalues = list(NULL, FALSE, gw.cutoff, NULL, NULL),
482-
required = c(FALSE, FALSE, FALSE, FALSE, FALSE, FALSE))
486+
required = c(FALSE, FALSE, FALSE, FALSE, FALSE))
483487

484488
wrap_ergm_sp_call("gwb1dsp", nw, a, FALSE, ...)
485489
}
@@ -494,11 +498,13 @@ InitErgmTerm.gwb1dspL<-function(nw, arglist, cache.sp=TRUE, gw.cutoff=30, ...) {
494498
#' of the first bipartition.) This term can only be used with bipartite networks.
495499
#'
496500
#' @usage
497-
#' # binary: b2dsp(d, Ls.path=NULL)
501+
#' # binary: b2dspL(d, Ls.path=NULL)
498502
#'
499503
#' @param d a vector of distinct integers
500504
#' @template ergmTerm-Ls-path
501505
#'
506+
#' @template ergmTerm-bipartite-note
507+
#'
502508
#' @template ergmTerm-cache-sp
503509
#' @template ergmTerm-general
504510
#'
@@ -524,27 +530,29 @@ InitErgmTerm.b2dspL <- function(nw, arglist, cache.sp=TRUE, ...){
524530
#' `decay` parameter, which should be non-negative. This term can only be used with bipartite networks.
525531
#'
526532
#' @usage
527-
#' # binary: gwb2dsp(decay=0, fixed=FALSE, cutoff=30, Ls.path=NULL)
533+
#' # binary: gwb2dspL(decay=0, fixed=FALSE, cutoff=30, Ls.path=NULL)
528534
#'
529535
#' @templateVar multiplicand shared partner counts
530536
#' @template ergmTerm-gw-decay-fixed
531537
#' @templateVar underlying b2dsp
532538
#' @template ergmTerm-gw-cutoff
533539
#' @template ergmTerm-Ls-path
534540
#'
541+
#' @template ergmTerm-bipartite-note
542+
#'
535543
#' @template ergmTerm-cache-sp
536544
#' @template ergmTerm-general
537545
#'
538546
#' @concept bipartite
539547
#' @concept undirected
540548
#' @concept curved
541549
#' @concept layer-aware
542-
InitErgmTerm.gwb2dsp<-function(nw, arglist, cache.sp=TRUE, gw.cutoff=30, ...) {
550+
InitErgmTerm.gwb2dspL<-function(nw, arglist, cache.sp=TRUE, gw.cutoff=30, ...) {
543551
a <- check.ErgmTerm(nw, arglist, bipartite = TRUE,
544552
varnames = c("decay", "fixed", "cutoff", "alpha", "Ls.path"),
545553
vartypes = c("numeric", "logical", "numeric", "numeric", "formula,list"),
546554
defaultvalues = list(NULL, FALSE, gw.cutoff, NULL, NULL),
547-
required = c(FALSE, FALSE, FALSE, FALSE, FALSE, FALSE))
555+
required = c(FALSE, FALSE, FALSE, FALSE, FALSE))
548556

549557
wrap_ergm_sp_call("gwb2dsp", nw, a, FALSE, ...)
550558
}

‎R/InitErgmTerm.spcache.multilayer.R‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -19,10 +19,11 @@ InitErgmTerm..spcache.netL<-function(nw, arglist, ...){
1919

2020
type <- match.arg(tolower(a$type), c("otp","osp","isp","utp")) # ITP not included, because it's just OTP with direction reversed.
2121

22-
if(is.directed(nw)==(type=="utp")) stop("Type UTP may only be used with undirected networks, the others only with directed.")
22+
if (is.directed(nw) == (type == "utp")
23+
&& !(is.bipartite(nw) && type %in% c("osp", "isp")))
24+
stop("Type UTP may only be used with undirected networks, OSP and ISP with bipartite or directed, and the rest only with directed.")
2325

2426
dname <- paste0("_",type,"_wtnet")
25-
2627
linfo <- .sp.handle_layers(nw, a, type, FALSE)
2728

2829

‎man-roxygen/ergmTerm-bipartite-note.R‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,2 @@
1+
#' @note This term does not support multilayer networks with
2+
#' heterogeneous bipartedness. This may change in the future.

‎man/b1dspL-ergmTerm-50daeb76.Rd‎

Lines changed: 4 additions & 1 deletion
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

‎man/b2dspL-ergmTerm-fe3c0be7.Rd‎

Lines changed: 4 additions & 1 deletion
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

man/gwb1dsp-ergmTerm-0bf628f4.Rd renamed to man/gwb1dspL-ergmTerm-e11e8513.Rd

Lines changed: 7 additions & 4 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

‎man/gwb2dspL-ergmTerm-a90bec3f.Rd‎

Lines changed: 5 additions & 2 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

‎tests/testthat/test-term-dgwesp-ml.R‎

Lines changed: 101 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -46,6 +46,18 @@ dspL <- function(x, Ls.path1, Ls.path2=Ls.path1, ...){
4646
tabulate(match(dspL, x),length(x))
4747
}
4848

49+
b1dspL <- function(x, Ls.path1, Ls.path2=Ls.path1, ...){
50+
TP <- OSP(Ls.path1, Ls.path2, ...)
51+
dspL <- dediag(TP, NA)[upper.tri(TP)]
52+
tabulate(match(dspL, x),length(x))
53+
}
54+
55+
b2dspL <- function(x, Ls.path1, Ls.path2=Ls.path1, ...){
56+
TP <- ISP(Ls.path1, Ls.path2, ...)
57+
dspL <- dediag(TP, NA)[upper.tri(TP)]
58+
tabulate(match(dspL, x),length(x))
59+
}
60+
4961
nspL <- function(x, L.base, Ls.path1, Ls.path2=Ls.path1, ...){
5062
TP <- UTP(Ls.path1, Ls.path2, ...)
5163
L.base[L.base==1] <- NA # I.e., those with base=1 don't count at all.
@@ -115,6 +127,18 @@ gwnspL <- function(decay, n, L.base, Ls.path1, Ls.path2=Ls.path1, ...){
115127
sum(w*sp)
116128
}
117129

130+
gwb1dspL <- function(decay, n, Ls.path1, Ls.path2=Ls.path1, ...){
131+
w <- GW(decay,n)
132+
sp <- b1dspL(1:n, Ls.path1, Ls.path2, ...)
133+
sum(w*sp)
134+
}
135+
136+
gwb2dspL <- function(decay, n, Ls.path1, Ls.path2=Ls.path1, ...){
137+
w <- GW(decay,n)
138+
sp <- b2dspL(1:n, Ls.path1, Ls.path2, ...)
139+
sum(w*sp)
140+
}
141+
118142
library(purrr)
119143
n <- 5
120144

@@ -342,7 +366,7 @@ test_that(paste("Multilayer dgw*sp statistics for homogeneously directed network
342366
## dgwnspL(decay,fixed=TRUE,type="ITP",L.base=~`2`,Ls.path=c(~`2`,~`3`),L.in_order=FALSE)+
343367
## dgwnspL(decay,fixed=TRUE,type="OSP",L.base=~`2`,Ls.path=c(~`2`,~`3`))+
344368
## dgwnspL(decay,fixed=TRUE,type="ISP",L.base=~`2`,Ls.path=c(~`2`,~`3`))
345-
, coef = numeric(450),
369+
, coef = setNames(0, ""),
346370
control=ctrl,
347371
nsim=200)
348372

@@ -706,7 +730,7 @@ test_that(paste("Multilayer dgw*sp statistics for heterogeneously directed netwo
706730
## dgwnspL(decay,fixed=TRUE,type="ITP",L.base=~`2`,Ls.path=c(~`2`,~`3`),L.in_order=FALSE)+
707731
## dgwnspL(decay,fixed=TRUE,type="OSP",L.base=~`2`,Ls.path=c(~`2`,~`3`))+
708732
## dgwnspL(decay,fixed=TRUE,type="ISP",L.base=~`2`,Ls.path=c(~`2`,~`3`))
709-
, coef = numeric(450),
733+
, coef = setNames(0, ""),
710734
control=ctrl,
711735
nsim=200)
712736

@@ -951,7 +975,7 @@ test_that(paste("Multilayer dgw*sp statistics for undirected networks",sptxt), {
951975
## dgwdspL(decay,fixed=TRUE,Ls.path=c(~`2`,~`3`))+
952976
## # dnspL distinct base and one layer
953977
## dgwnspL(decay,fixed=TRUE,L.base=~`2`,Ls.path=c(~`2`,~`3`))
954-
, coef = numeric(75),
978+
, coef = setNames(0, ""),
955979
control=ctrl,
956980
nsim=200)
957981

@@ -1018,4 +1042,78 @@ test_that(paste("Multilayer dgw*sp statistics for undirected networks",sptxt), {
10181042

10191043
expect_equal(attr(sim,"stats"), stats, ignore_attr=TRUE)
10201044
})
1045+
1046+
### Bipartite.
1047+
n <- 10
1048+
b1 <- 4
1049+
b2 <- n - b1
1050+
nw1 <- nw2 <- nw3 <- network.initialize(n, dir = FALSE, bipartite = b1)
1051+
lnw <- Layer(nw1,nw2,nw3)
1052+
1053+
test_that(paste("Multilayer dgw*sp statistics for bipartite networks",sptxt), {
1054+
sim <- simulate(lnw~
1055+
## b1
1056+
b1dspL(0:n,Ls.path=c(~`2`,~`3`))+
1057+
# dspL base and path distinct
1058+
b1dspL(0:n,Ls.path=c(~`2`,~`2`))+
1059+
# dspL base and path same
1060+
b1dspL(0:n,Ls.path=c(~`2`,~`2`))+
1061+
# dspL distinct base and one layer
1062+
b1dspL(0:n,Ls.path=c(~`2`,~`3`))+
1063+
# Geometrically weighted
1064+
# dspL distinct layers
1065+
gwb1dspL(decay,fixed=TRUE,Ls.path=c(~`2`,~`3`))+
1066+
## b2
1067+
b2dspL(0:n,Ls.path=c(~`2`,~`3`))+
1068+
# dspL base and path distinct
1069+
b2dspL(0:n,Ls.path=c(~`2`,~`2`))+
1070+
# dspL base and path same
1071+
b2dspL(0:n,Ls.path=c(~`2`,~`2`))+
1072+
# dspL distinct base and one layer
1073+
b2dspL(0:n,Ls.path=c(~`2`,~`3`))+
1074+
# Geometrically weighted
1075+
# dspL distinct layers
1076+
gwb2dspL(decay,fixed=TRUE,Ls.path=c(~`2`,~`3`))
1077+
, coef = setNames(0, ""),
1078+
control=ctrl,
1079+
nsim=200)
1080+
1081+
stats <- sapply(sim,
1082+
function(nw){
1083+
n <- network.size(nw)/3
1084+
m <- as.matrix(nw)
1085+
m1 <- m[seq_len(b1),seq_len(b2)]
1086+
m2 <- m[seq_len(b1)+b1,seq_len(b2)+b2]
1087+
m3 <- m[seq_len(b1)+b1*2,seq_len(b2)+b2*2]
1088+
1089+
c(
1090+
## b1
1091+
# dspL distinct layers
1092+
b1dspL(0:n,Ls.path1=m2,Ls.path2=m3),
1093+
# dspL base and path distinct
1094+
b1dspL(0:n,Ls.path1=m2,Ls.path2=m2),
1095+
# dspL base and path same
1096+
b1dspL(0:n,Ls.path1=m2,Ls.path2=m2),
1097+
# dspL distinct base and one layer
1098+
b1dspL(0:n,Ls.path1=m2,Ls.path2=m3),
1099+
# Geometrically weighted
1100+
# dspL distinct layers
1101+
gwb1dspL(decay,n,Ls.path1=m2,Ls.path2=m3),
1102+
## b2
1103+
# dspL distinct layers
1104+
b2dspL(0:n,Ls.path1=m2,Ls.path2=m3),
1105+
# dspL base and path distinct
1106+
b2dspL(0:n,Ls.path1=m2,Ls.path2=m2),
1107+
# dspL base and path same
1108+
b2dspL(0:n,Ls.path1=m2,Ls.path2=m2),
1109+
# dspL distinct base and one layer
1110+
b2dspL(0:n,Ls.path1=m2,Ls.path2=m3),
1111+
# Geometrically weighted
1112+
# dspL distinct layers
1113+
gwb2dspL(decay,n,Ls.path1=m2,Ls.path2=m3)
1114+
)
1115+
}) %>% t()
1116+
1117+
expect_equal(attr(sim, "stats"), stats, ignore_attr=TRUE)
1118+
})
10211119
}

0 commit comments

Comments
 (0)