From 8549cee0367d5705cc8b3fe6a74e22104b652b48 Mon Sep 17 00:00:00 2001 From: "Pavel N. Krivitsky" Date: Tue, 19 Nov 2024 12:02:09 +1100 Subject: [PATCH 1/2] Implemented a permute.vertexIDs() method for networkLite and added tests. references EpiModel/networkLite#5 --- NAMESPACE | 1 + R/add_vertices.R | 28 ++++++++++++++++++++++++++++ man/permute.vertexIDs.networkLite.Rd | 14 ++++++++++++++ tests/testthat/test-networkLite.R | 11 ++++++++++- 4 files changed, 53 insertions(+), 1 deletion(-) create mode 100644 man/permute.vertexIDs.networkLite.Rd diff --git a/NAMESPACE b/NAMESPACE index 575ac0c..ac94429 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -32,6 +32,7 @@ S3method(network.naedgecount,networkLite) S3method(networkLite,edgelist) S3method(networkLite,matrix) S3method(networkLite,numeric) +S3method(permute.vertexIDs,networkLite) S3method(print,networkLite) S3method(set.edge.attribute,networkLite) S3method(set.edge.value,networkLite) diff --git a/R/add_vertices.R b/R/add_vertices.R index afd9aab..04622d9 100644 --- a/R/add_vertices.R +++ b/R/add_vertices.R @@ -70,3 +70,31 @@ add.vertices.networkLite <- function(x, nv, vattr = NULL, modify_in_place(x) } + +#' Permute vertices +#' +#' @param x,vids see [network::permute.vertexIDs()] +#' @export +permute.vertexIDs.networkLite <- function(x, vids, ...) { + #Sanity check: is this a permutation vector? + n<-network.size(x) + if((length(unique(vids))!=n)||any(range(vids)!=c(1,n))) + stop("Invalid permutation vector in permute.vertexIDs.") + if(is.bipartite(x)){ #If bipartite, enforce partitioning + bpc<-get.network.attribute(x,"bipartite") + if(any(vids[0:bpc]>bpc)||any(vids[(bpc+1):n]<=bpc)) + warning("Performing a cross-mode permutation in permute.vertexIDs. I hope you know what you're doing....") + } + + # Remap the edge list and sort by new indices. + o <- order(vids) + x$el$.tail <- o[x$el$.tail] + x$el$.head <- o[x$el$.head] + if(!is.directed(x)) x$el[, c(".tail", ".head")] <- cbind(pmin(x$el$.tail, x$el$.head), pmax(x$el$.tail, x$el$.head)) + x$el <- x$el[order(x$el$.tail, x$el$.head), , drop = FALSE] + + # Permute the vertex attributes. + x$attr <- x$attr[vids, , drop = FALSE] + + modify_in_place(x) +} diff --git a/man/permute.vertexIDs.networkLite.Rd b/man/permute.vertexIDs.networkLite.Rd new file mode 100644 index 0000000..88c134a --- /dev/null +++ b/man/permute.vertexIDs.networkLite.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/add_vertices.R +\name{permute.vertexIDs.networkLite} +\alias{permute.vertexIDs.networkLite} +\title{Permute vertices} +\usage{ +\method{permute.vertexIDs}{networkLite}(x, vids, ...) +} +\arguments{ +\item{x, vids}{see \code{\link[network:permute.vertexIDs]{network::permute.vertexIDs()}}} +} +\description{ +Permute vertices +} diff --git a/tests/testthat/test-networkLite.R b/tests/testthat/test-networkLite.R index a236dec..88f4564 100644 --- a/tests/testthat/test-networkLite.R +++ b/tests/testthat/test-networkLite.R @@ -883,7 +883,7 @@ test_that("network and networkLite behave equivalently for basic access and muta } }) -test_that("add.vertices and add.edges with irregular attribute arguments behave equivalently for network and networkLite", { +test_that("add.vertices and add.edges with irregular attribute arguments and vertex permutation behave equivalently for network and networkLite", { net_size <- 100 bip_size <- 40 edges_target <- net_size @@ -976,6 +976,15 @@ test_that("add.vertices and add.edges with irregular attribute arguments behave expect_equiv_nets(as.networkLite(nw), nwL) expect_equiv_nets(as.networkLite(nw), as.networkLite(to_network_networkLite(nwL))) + + P <- if(is.bipartite(nw)){ + b <- nw %n% "bipartite" + c(sample.int(b), b + sample.int(network.size(nw) - b)) + }else sample.int(network.size(nw)) + nwP <- permute.vertexIDs((nw), P) + nwLP <- permute.vertexIDs((nwL), P) + expect_equiv_nets(as.networkLite(nwP), nwLP) + expect_equiv_nets(as.networkLite(nwP), as.networkLite(to_network_networkLite(nwLP))) } } } From 72ff1ac1c13d1fd030cee18b7253ef423d89dec0 Mon Sep 17 00:00:00 2001 From: "Pavel N. Krivitsky" Date: Tue, 19 Nov 2024 20:22:52 +1100 Subject: [PATCH 2/2] Implemented a get.inducedSubgraph() method for networkLite and added tests. fixes EpiModel/networkLite#5 --- NAMESPACE | 1 + R/add_vertices.R | 2 +- R/delete_vertices.R | 39 ++++++++++++++++++++++++++ man/get.inducedSubgraph.networkLite.Rd | 14 +++++++++ man/permute.vertexIDs.networkLite.Rd | 2 +- tests/testthat/test-networkLite.R | 26 +++++++++++++++++ 6 files changed, 82 insertions(+), 2 deletions(-) create mode 100644 man/get.inducedSubgraph.networkLite.Rd diff --git a/NAMESPACE b/NAMESPACE index ac94429..89a03c8 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -20,6 +20,7 @@ S3method(delete.vertex.attribute,networkLite) S3method(delete.vertices,networkLite) S3method(get.edge.attribute,networkLite) S3method(get.edge.value,networkLite) +S3method(get.inducedSubgraph,networkLite) S3method(get.network.attribute,networkLite) S3method(get.vertex.attribute,networkLite) S3method(is.na,networkLite) diff --git a/R/add_vertices.R b/R/add_vertices.R index 04622d9..7887a0c 100644 --- a/R/add_vertices.R +++ b/R/add_vertices.R @@ -73,7 +73,7 @@ add.vertices.networkLite <- function(x, nv, vattr = NULL, #' Permute vertices #' -#' @param x,vids see [network::permute.vertexIDs()] +#' @param x,vids,... see [network::permute.vertexIDs()] #' @export permute.vertexIDs.networkLite <- function(x, vids, ...) { #Sanity check: is this a permutation vector? diff --git a/R/delete_vertices.R b/R/delete_vertices.R index 3db1ff2..2d22430 100644 --- a/R/delete_vertices.R +++ b/R/delete_vertices.R @@ -41,3 +41,42 @@ delete.vertices.networkLite <- function(x, vid, ...) { modify_in_place(x) } + + +#' Return an induced subgraph +#' +#' @param x,v,alters,... see [network::get.inducedSubgraph()] +#' @export +get.inducedSubgraph.networkLite <- function(x, v, alters=NULL, ...){ + #Do some reality checking + n<-network.size(x) + + # do checks for v and alters + if((length(v)<1)||any(is.na(v))||any(v<1)||any(v>n)) + stop("Illegal vertex selection in get.inducedSubgraph") + if(!is.null(alters)){ + if((length(alters)<1)||any(is.na(alters))||any(alters<1)||any(alters>n)|| any(alters%in%v)) + stop("Illegal vertex selection (alters) in get.inducedSubgraph") + } + + #Start by making a copy of our target network (yes, this can be wasteful) + #TODO: in most cases, probably faster to create a new network and only copy over what is needed + + #Now, strip out what is needed, and/or permute in the two-mode case + if(is.null(alters)){ #Simple case + delete.vertices(x,(1:n)[-v]) #Get rid of everyone else + }else{ #Really an edge cut, but w/vertices + nv<-length(v) + na<-length(alters) + newids<-sort(c(v,alters)) + newv<-match(v,newids) + newalt<-match(alters,newids) + delete.vertices(x,(1:n)[-c(v,alters)]) #Get rid of everyone else + permute.vertexIDs(x,c(newv,newalt)) #Put the new vertices first + #Remove within-group edges + x$el <- x$el[(x$el$.tail <= nv) != (x$el$.head <= nv), , drop=FALSE] + x%n%"bipartite"<-nv #Set bipartite attribute + } + + x +} diff --git a/man/get.inducedSubgraph.networkLite.Rd b/man/get.inducedSubgraph.networkLite.Rd new file mode 100644 index 0000000..ebedaa4 --- /dev/null +++ b/man/get.inducedSubgraph.networkLite.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/delete_vertices.R +\name{get.inducedSubgraph.networkLite} +\alias{get.inducedSubgraph.networkLite} +\title{Return an induced subgraph} +\usage{ +\method{get.inducedSubgraph}{networkLite}(x, v, alters = NULL, ...) +} +\arguments{ +\item{x, v, alters, ...}{see \code{\link[network:get.inducedSubgraph]{network::get.inducedSubgraph()}}} +} +\description{ +Return an induced subgraph +} diff --git a/man/permute.vertexIDs.networkLite.Rd b/man/permute.vertexIDs.networkLite.Rd index 88c134a..68ded60 100644 --- a/man/permute.vertexIDs.networkLite.Rd +++ b/man/permute.vertexIDs.networkLite.Rd @@ -7,7 +7,7 @@ \method{permute.vertexIDs}{networkLite}(x, vids, ...) } \arguments{ -\item{x, vids}{see \code{\link[network:permute.vertexIDs]{network::permute.vertexIDs()}}} +\item{x, vids, ...}{see \code{\link[network:permute.vertexIDs]{network::permute.vertexIDs()}}} } \description{ Permute vertices diff --git a/tests/testthat/test-networkLite.R b/tests/testthat/test-networkLite.R index 88f4564..05468a6 100644 --- a/tests/testthat/test-networkLite.R +++ b/tests/testthat/test-networkLite.R @@ -677,6 +677,32 @@ test_that("network and networkLite produce identical matrices, edgelists, and ti expect_identical(tbl, tibble::as_tibble(nwL, attrname = attrname, na.rm = na.rm)) } + } + + n <- network.size(nw) + for(into_bipartite in c(FALSE, TRUE)){ + if(is.bipartite(nw)){ + if(into_bipartite){ + b <- nw %n% "bipartite" + v <- sample.int(b, round(b/2)) + a <- b + round((n-b)/2) + }else{ + v <- sort(sample.int(n, round(n/2))) + a <- NULL + } + }else{ + v <- sample.int(n, round(n/2)) + if(into_bipartite){ + a <- sample(v, round(n/4)) + v <- setdiff(v, a) + }else a <- NULL + } + + nwS <- get.inducedSubgraph(nw, v, a) + nwLS <- get.inducedSubgraph(nwL, v, a) + + expect_equiv_nets(as.networkLite(nwS), nwLS) + expect_equiv_nets(as.networkLite(nwS), as.networkLite(to_network_networkLite(nwLS))) } } }