From 3cc3563c2072b237f45c15900bc08aca4ca2e4f4 Mon Sep 17 00:00:00 2001 From: "Pavel N. Krivitsky" Date: Mon, 16 Dec 2024 12:15:15 +1100 Subject: [PATCH] Implemented term *degm1factorial. --- DESCRIPTION | 1 + R/InitErgmTerm.degfactorial.R | 85 ++++++++++++++++++++++ man/b1degm1lfactorial-ergmTerm-268d1fe0.Rd | 20 +++++ man/b2degm1lfactorial-ergmTerm-134e4482.Rd | 20 +++++ man/degm1lfactorial-ergmTerm-0f187aa0.Rd | 19 +++++ man/idegm1lfactorial-ergmTerm-4be755fd.Rd | 19 +++++ man/odegm1lfactorial-ergmTerm-b8eb44b3.Rd | 19 +++++ src/changestats_degfactorial.c | 20 +++++ tests/testthat/test-ergm-term-doc.R | 6 +- tests/testthat/test-term-degfactorial.R | 43 +++++++++++ 10 files changed, 249 insertions(+), 3 deletions(-) create mode 100644 R/InitErgmTerm.degfactorial.R create mode 100644 man/b1degm1lfactorial-ergmTerm-268d1fe0.Rd create mode 100644 man/b2degm1lfactorial-ergmTerm-134e4482.Rd create mode 100644 man/degm1lfactorial-ergmTerm-0f187aa0.Rd create mode 100644 man/idegm1lfactorial-ergmTerm-4be755fd.Rd create mode 100644 man/odegm1lfactorial-ergmTerm-b8eb44b3.Rd create mode 100644 src/changestats_degfactorial.c create mode 100644 tests/testthat/test-term-degfactorial.R diff --git a/DESCRIPTION b/DESCRIPTION index 727d7faa..136bf67d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -79,6 +79,7 @@ Collate: 'InitErgmTerm.bipartite.degree.R' 'InitErgmTerm.blockop.R' 'InitErgmTerm.coincidence.R' + 'InitErgmTerm.degfactorial.R' 'InitErgmTerm.dgw_sp.R' 'InitErgmTerm.diversity.R' 'InitErgmTerm.extra.R' diff --git a/R/InitErgmTerm.degfactorial.R b/R/InitErgmTerm.degfactorial.R new file mode 100644 index 00000000..0ea024e3 --- /dev/null +++ b/R/InitErgmTerm.degfactorial.R @@ -0,0 +1,85 @@ +#' @templateVar name degm1lfactorial +#' @title Sum of log-factorials of degrees of non-isolates minus 1 +#' @description This term adds one network statistic to the model, +#' equalling \eqn{\sum_{i=1}^n \mathbb{I}(d_i>0) \log(d_i - 1)!}. +#' +#' @usage +#' # binary: degm1lfactorial +#' +#' @template ergmTerm-general +#' +#' @concept undirected +InitErgmTerm.degm1lfactorial <- function(nw, arglist, ..., version=packageVersion("ergm")) { + a <- check.ErgmTerm(nw, arglist) + list(name="sum_lfactorial_degreem1", coef.names="ldegm1lfactorial", minval = 0) +} + + +#' @templateVar name b2degm1lfactorial +#' @title Sum of log-factorials of degrees of Mode-2 non-isolates minus 1 +#' @description This term adds one network statistic to the model, +#' equalling \eqn{\sum_{i=b+1}^n \mathbb{I}(d_i>0) \log(d_i - 1)!}. +#' +#' @usage +#' # binary: b2degm1lfactorial +#' +#' @template ergmTerm-general +#' +#' @concept undirected +#' @concept bipartite +InitErgmTerm.b2degm1lfactorial <- function(nw, arglist, ...) { + a <- check.ErgmTerm(nw, arglist, bipartite = TRUE) + list(name="sum_lfactorial_idegreem1", coef.names="b2degm1lfactorial", minval = 0) +} + + +#' @templateVar name b1degm1lfactorial +#' @title Sum of log-factorials of degrees of Mode-1 non-isolates minus 1 +#' @description This term adds one network statistic to the model, +#' equalling \eqn{\sum_{i=1}^b \mathbb{I}(d_i>0) \log(d_i - 1)!}. +#' +#' @usage +#' # binary: b1degm1lfactorial +#' +#' @template ergmTerm-general +#' +#' @concept undirected +#' @concept bipartite +InitErgmTerm.b1degm1lfactorial <- function(nw, arglist, ...) { + a <- check.ErgmTerm(nw, arglist, bipartite = TRUE) + list(name="sum_lfactorial_odegreem1", coef.names="b1degm1lfactorial", minval = 0) +} + + +#' @templateVar name idegm1lfactorial +#' @title Sum of log-factorials of indegrees of non-in-isolates minus 1 +#' @description This term adds one network statistic to the model, +#' equalling \eqn{\sum_{i=1}^n \mathbb{I}(id_i>0) \log(id_i - 1)!}. +#' +#' @usage +#' # binary: idegm1lfactorial +#' +#' @template ergmTerm-general +#' +#' @concept directed +InitErgmTerm.idegm1lfactorial <- function(nw, arglist, ...) { + a <- check.ErgmTerm(nw, arglist, directed = TRUE) + list(name="sum_lfactorial_idegreem1", coef.names="idegm1lfactorial", minval = 0) +} + + +#' @templateVar name odegm1lfactorial +#' @title Sum of log-factorials of outdegrees of non-out-isolates minus 1 +#' @description This term adds one network statistic to the model, +#' equalling \eqn{\sum_{i=1}^n \mathbb{I}(od_i>0) \log(od_i - 1)!}. +#' +#' @usage +#' # binary: odegm1lfactorial +#' +#' @template ergmTerm-general +#' +#' @concept directed +InitErgmTerm.odegm1lfactorial <- function(nw, arglist, ...) { + a <- check.ErgmTerm(nw, arglist, directed = TRUE) + list(name="sum_lfactorial_odegreem1", coef.names="odegm1lfactorial", minval = 0) +} diff --git a/man/b1degm1lfactorial-ergmTerm-268d1fe0.Rd b/man/b1degm1lfactorial-ergmTerm-268d1fe0.Rd new file mode 100644 index 00000000..351352c9 --- /dev/null +++ b/man/b1degm1lfactorial-ergmTerm-268d1fe0.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/InitErgmTerm.degfactorial.R +\name{b1degm1lfactorial-ergmTerm} +\alias{b1degm1lfactorial-ergmTerm} +\alias{InitErgmTerm.b1degm1lfactorial} +\title{Sum of log-factorials of degrees of Mode-1 non-isolates minus 1} +\usage{ +# binary: b1degm1lfactorial +} +\description{ +This term adds one network statistic to the model, +equalling \eqn{\sum_{i=1}^b \mathbb{I}(d_i>0) \log(d_i - 1)!}. +} +\seealso{ +\code{\link{ergmTerm}} for index of model terms currently visible to the package. + +\Sexpr[results=rd,stage=render]{ergm:::.formatTermKeywords("ergmTerm", "b1degm1lfactorial", "subsection")} +} +\concept{bipartite} +\concept{undirected} diff --git a/man/b2degm1lfactorial-ergmTerm-134e4482.Rd b/man/b2degm1lfactorial-ergmTerm-134e4482.Rd new file mode 100644 index 00000000..26dffe27 --- /dev/null +++ b/man/b2degm1lfactorial-ergmTerm-134e4482.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/InitErgmTerm.degfactorial.R +\name{b2degm1lfactorial-ergmTerm} +\alias{b2degm1lfactorial-ergmTerm} +\alias{InitErgmTerm.b2degm1lfactorial} +\title{Sum of log-factorials of degrees of Mode-2 non-isolates minus 1} +\usage{ +# binary: b2degm1lfactorial +} +\description{ +This term adds one network statistic to the model, +equalling \eqn{\sum_{i=b+1}^n \mathbb{I}(d_i>0) \log(d_i - 1)!}. +} +\seealso{ +\code{\link{ergmTerm}} for index of model terms currently visible to the package. + +\Sexpr[results=rd,stage=render]{ergm:::.formatTermKeywords("ergmTerm", "b2degm1lfactorial", "subsection")} +} +\concept{bipartite} +\concept{undirected} diff --git a/man/degm1lfactorial-ergmTerm-0f187aa0.Rd b/man/degm1lfactorial-ergmTerm-0f187aa0.Rd new file mode 100644 index 00000000..0cfe96b7 --- /dev/null +++ b/man/degm1lfactorial-ergmTerm-0f187aa0.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/InitErgmTerm.degfactorial.R +\name{degm1lfactorial-ergmTerm} +\alias{degm1lfactorial-ergmTerm} +\alias{InitErgmTerm.degm1lfactorial} +\title{Sum of log-factorials of degrees of non-isolates minus 1} +\usage{ +# binary: degm1lfactorial +} +\description{ +This term adds one network statistic to the model, +equalling \eqn{\sum_{i=1}^n \mathbb{I}(d_i>0) \log(d_i - 1)!}. +} +\seealso{ +\code{\link{ergmTerm}} for index of model terms currently visible to the package. + +\Sexpr[results=rd,stage=render]{ergm:::.formatTermKeywords("ergmTerm", "degm1lfactorial", "subsection")} +} +\concept{undirected} diff --git a/man/idegm1lfactorial-ergmTerm-4be755fd.Rd b/man/idegm1lfactorial-ergmTerm-4be755fd.Rd new file mode 100644 index 00000000..0496be66 --- /dev/null +++ b/man/idegm1lfactorial-ergmTerm-4be755fd.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/InitErgmTerm.degfactorial.R +\name{idegm1lfactorial-ergmTerm} +\alias{idegm1lfactorial-ergmTerm} +\alias{InitErgmTerm.idegm1lfactorial} +\title{Sum of log-factorials of indegrees of non-in-isolates minus 1} +\usage{ +# binary: idegm1lfactorial +} +\description{ +This term adds one network statistic to the model, +equalling \eqn{\sum_{i=1}^n \mathbb{I}(id_i>0) \log(id_i - 1)!}. +} +\seealso{ +\code{\link{ergmTerm}} for index of model terms currently visible to the package. + +\Sexpr[results=rd,stage=render]{ergm:::.formatTermKeywords("ergmTerm", "idegm1lfactorial", "subsection")} +} +\concept{directed} diff --git a/man/odegm1lfactorial-ergmTerm-b8eb44b3.Rd b/man/odegm1lfactorial-ergmTerm-b8eb44b3.Rd new file mode 100644 index 00000000..7b40600d --- /dev/null +++ b/man/odegm1lfactorial-ergmTerm-b8eb44b3.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/InitErgmTerm.degfactorial.R +\name{odegm1lfactorial-ergmTerm} +\alias{odegm1lfactorial-ergmTerm} +\alias{InitErgmTerm.odegm1lfactorial} +\title{Sum of log-factorials of outdegrees of non-out-isolates minus 1} +\usage{ +# binary: odegm1lfactorial +} +\description{ +This term adds one network statistic to the model, +equalling \eqn{\sum_{i=1}^n \mathbb{I}(od_i>0) \log(od_i - 1)!}. +} +\seealso{ +\code{\link{ergmTerm}} for index of model terms currently visible to the package. + +\Sexpr[results=rd,stage=render]{ergm:::.formatTermKeywords("ergmTerm", "odegm1lfactorial", "subsection")} +} +\concept{directed} diff --git a/src/changestats_degfactorial.c b/src/changestats_degfactorial.c new file mode 100644 index 00000000..565322ad --- /dev/null +++ b/src/changestats_degfactorial.c @@ -0,0 +1,20 @@ +#include "ergm_changestat.h" +#include "ergm_storage.h" + +#define mk_c_sum_lfactorial_degreem1(_LABEL_, _OUT_, _IN_) \ + \ + C_CHANGESTAT_FN(c_sum_lfactorial_ ## _LABEL_ ## degreem1){ \ + int echange=edgestate ? -1:+1; \ + \ + Vertex otd = 0, ntd = 0, ohd = 0, nhd = 0; \ + \ + if(_OUT_){otd = OUT_DEG[tail] + ( _IN_ ? IN_DEG[tail] : 0); ntd = otd + echange;} \ + if(_IN_){ohd = ( _OUT_ ? OUT_DEG[head] : 0) + IN_DEG[head]; nhd = ohd + echange;} \ + \ + CHANGE_STAT[0] += (ntd?lgammafn(ntd):0) - (otd?lgammafn(otd):0) \ + + (nhd?lgammafn(nhd):0) - (ohd?lgammafn(ohd):0); \ + } + +mk_c_sum_lfactorial_degreem1(, TRUE, TRUE) +mk_c_sum_lfactorial_degreem1(o, TRUE, FALSE) +mk_c_sum_lfactorial_degreem1(i, FALSE, TRUE) diff --git a/tests/testthat/test-ergm-term-doc.R b/tests/testthat/test-ergm-term-doc.R index 7264c60d..70c07f87 100644 --- a/tests/testthat/test-ergm-term-doc.R +++ b/tests/testthat/test-ergm-term-doc.R @@ -32,14 +32,14 @@ test_that("test search ergm term", { # search using a bipartite net as a template myNet<-network.initialize(5,bipartite=3,directed=FALSE) - expect_equal(length(search.ergmTerms(net=myNet)), 31) + expect_equal(length(search.ergmTerms(net=myNet)), 33) - expect_equal(length(search.ergmTerms(keywords = 'bipartite', packages='ergm')), 36) + expect_equal(length(search.ergmTerms(keywords = 'bipartite', packages='ergm')), 38) expect_gt(length(search.ergmTerms(name = 'b2factor', packages='ergm')), 0) expect_equal(length(search.ergmTerms(name = 'b3factor', packages='ergm')), 0) - expect_equal(length(search.ergmTerms(keywords = 'bipartite', packages='ergm')), 36) + expect_equal(length(search.ergmTerms(keywords = 'bipartite', packages='ergm')), 38) ## expect_gt(length(search.ergmTerms(keywords = 'valued')), 44) expect_equal(length(search.ergmTerms(keywords = 'valued', packages='ergm')), 44) diff --git a/tests/testthat/test-term-degfactorial.R b/tests/testthat/test-term-degfactorial.R new file mode 100644 index 00000000..81897bed --- /dev/null +++ b/tests/testthat/test-term-degfactorial.R @@ -0,0 +1,43 @@ +degm1lfactorial <- function(d){ + d <- d-1 + sum(lfactorial(d[d>=0])) +} + +data(florentine) + +test_that("degm1lfactorial summary", { + expect_equal(summary(flomarriage~degm1lfactorial), + degm1lfactorial(summary(flomarriage~sociality(nodes=TRUE))), + ignore_attr = TRUE) +}) + +n <- 20 +b <- 5 +nw0 <- network.initialize(n, bipartite = b, directed = FALSE) +nw1 <- simulate(nw0 ~ edges, coef = 0) + +test_that("b1degm1lfactorial summary", { + expect_equal(summary(nw1~b1degm1lfactorial), + degm1lfactorial(summary(nw1~b1sociality(nodes=TRUE))), + ignore_attr = TRUE) +}) + +test_that("b2degm1lfactorial summary", { + expect_equal(summary(nw1~b2degm1lfactorial), + degm1lfactorial(summary(nw1~b2sociality(nodes=TRUE))), + ignore_attr = TRUE) +}) + +data(sampson) + +test_that("odegm1lfactorial summary", { + expect_equal(summary(samplike~odegm1lfactorial), + degm1lfactorial(summary(samplike~sender(nodes=TRUE))), + ignore_attr = TRUE) +}) + +test_that("idegm1lfactorial summary", { + expect_equal(summary(samplike~idegm1lfactorial), + degm1lfactorial(summary(samplike~receiver(nodes=TRUE))), + ignore_attr = TRUE) +})