get.inducedSubgraph() method for networkLite

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)
@@ -32,6 +33,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)

R/add_vertices.R

@@ -70,3 +70,31 @@
 
   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)
+}

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
+}

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)))
       }
     }
   }
@@ -883,7 +909,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 +1002,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)))
       }
     }
   }