Use statnet.common::modify_in_place(), which handles unassignable arg…

…uments, for in-place modification and add some checks. fixes #6
EpiModel · Nov 18, 2024 · 08c0be5 · 08c0be5
1 parent 282ee5d
commit 08c0be5
Show file tree

Hide file tree

Showing 11 changed files with 37 additions and 50 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -27,11 +27,12 @@ Depends:
     R (>= 3.5),
     network (>= 1.18.1)
 Imports:
-    statnet.common (>= 4.8.0),
+    statnet.common (>= 4.11.0),
     tibble,
     dplyr
 Suggests:
     testthat
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.2.9000
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
+Remotes: github::statnet/statnet.common@master
diff --git a/NAMESPACE b/NAMESPACE
@@ -48,6 +48,8 @@ importFrom(dplyr,bind_cols)
 importFrom(dplyr,bind_rows)
 importFrom(statnet.common,NVL)
 importFrom(statnet.common,NVL2)
+importFrom(statnet.common,attr)
+importFrom(statnet.common,modify_in_place)
 importFrom(stats,na.omit)
 importFrom(tibble,as_tibble)
 importFrom(tibble,is_tibble)

diff --git a/R/add_edges.R b/R/add_edges.R
@@ -70,8 +70,6 @@ add.edges.networkLite <- function(x, tail, head, names.eval = NULL,
     update_tibble[[name]] <- vector(mode = "list", length = NROW(update_tibble))
   }
 
-  xn <- substitute(x)
-
   for (name in setdiff(new_names, old_names)) {
     x$el[[name]] <- vector(mode = "list", length = NROW(x$el))
   }
@@ -80,8 +78,7 @@ add.edges.networkLite <- function(x, tail, head, names.eval = NULL,
   x$el <- x$el[order(x$el$.tail, x$el$.head), ]
   x$el <- x$el[!duplicated(x$el[, c(".tail", ".head")]), ]
 
-  on.exit(eval.parent(call("<-", xn, x)))
-  invisible(x)
+  modify_in_place(x)
 }
 
 #' @rdname add_edges

diff --git a/R/add_vertices.R b/R/add_vertices.R
@@ -18,8 +18,6 @@
 #'
 add.vertices.networkLite <- function(x, nv, vattr = NULL,
                                      last.mode = TRUE, ...) {
-  xn <- substitute(x)
-
   nv <- as.integer(nv)
   if (nv > 0) {
     oldsize <- network.size(x)
@@ -70,6 +68,5 @@ add.vertices.networkLite <- function(x, nv, vattr = NULL,
                                                 x$attr[offset + seq_len(oldsize - offset), ])))
   }
 
-  on.exit(eval.parent(call("<-", xn, x)))
-  invisible(x)
+  modify_in_place(x)
 }
diff --git a/R/attribute_methods.R b/R/attribute_methods.R
@@ -86,8 +86,6 @@ set.vertex.attribute.networkLite <- function(x,
                                              v = seq_len(network.size(x)),
                                              ...,
                                              upcast = FALSE) {
-  xn <- substitute(x)
-
   if (missing(v)) {
     ## just set everything
     x$attr[[attrname]] <- rep(value, length.out = network.size(x))
@@ -102,8 +100,7 @@ set.vertex.attribute.networkLite <- function(x,
     x$attr[[attrname]][v] <- value
   }
 
-  on.exit(eval.parent(call("<-", xn, x)))
-  invisible(x)
+  modify_in_place(x)
 }
 
 #' @rdname attribute_methods
@@ -135,12 +132,9 @@ get.network.attribute.networkLite <- function(x, attrname, ..., unlist = FALSE)
 #' @export
 #'
 set.network.attribute.networkLite <- function(x, attrname, value, ...) {
-  xn <- substitute(x)
-
   x$gal[[attrname]] <- value
 
-  on.exit(eval.parent(call("<-", xn, x)))
-  invisible(x)
+  modify_in_place(x)
 }
 
 #' @rdname attribute_methods
@@ -194,8 +188,6 @@ set.edge.attribute.networkLite <- function(
     x, attrname, value,
     e = seq_len(network.edgecount(x, na.omit = FALSE)), ..., upcast = FALSE) {
 
-  xn <- substitute(x)
-
   if (missing(e)) {
     ## just set everything
     x$el[[attrname]] <- rep(value, length.out = network.edgecount(x, na.omit = FALSE))
@@ -210,8 +202,7 @@ set.edge.attribute.networkLite <- function(
     x$el[[attrname]][e] <- value
   }
 
-  on.exit(eval.parent(call("<-", xn, x)))
-  invisible(x)
+  modify_in_place(x)
 }
 
 #' @rdname attribute_methods
@@ -221,8 +212,6 @@ set.edge.value.networkLite <- function(
     x, attrname, value,
     e = seq_len(network.edgecount(x, na.omit = FALSE)), ..., upcast = FALSE) {
 
-  xn <- substitute(x)
-
   value <- value[cbind(x$el$.tail[e], x$el$.head[e])]
 
   if (missing(e)) {
@@ -239,8 +228,7 @@ set.edge.value.networkLite <- function(
     x$el[[attrname]][e] <- value
   }
 
-  on.exit(eval.parent(call("<-", xn, x)))
-  invisible(x)
+  modify_in_place(x)
 }
 
 #' @rdname attribute_methods
@@ -258,32 +246,23 @@ list.edge.attributes.networkLite <- function(x, ...) {
 #' @rdname attribute_methods
 #' @export
 delete.vertex.attribute.networkLite <- function(x, attrname, ...) {
-  xn <- substitute(x)
-
   x$attr[[attrname]] <- NULL
 
-  on.exit(eval.parent(call("<-", xn, x)))
-  invisible(x)
+  modify_in_place(x)
 }
 
 #' @rdname attribute_methods
 #' @export
 delete.edge.attribute.networkLite <- function(x, attrname, ...) {
-  xn <- substitute(x)
-
   x$el[[attrname]] <- NULL
 
-  on.exit(eval.parent(call("<-", xn, x)))
-  invisible(x)
+  modify_in_place(x)
 }
 
 #' @rdname attribute_methods
 #' @export
 delete.network.attribute.networkLite <- function(x, attrname, ...) {
-  xn <- substitute(x)
-
   x$gal[[attrname]] <- NULL
 
-  on.exit(eval.parent(call("<-", xn, x)))
-  invisible(x)
+  modify_in_place(x)
 }
diff --git a/R/delete_edges.R b/R/delete_edges.R
@@ -15,14 +15,11 @@
 #' @export
 #'
 delete.edges.networkLite <- function(x, eid, ...) {
-  xn <- substitute(x)
-
   eid <- as.integer(eid)
   eid <- eid[eid >= 1 & eid <= network.edgecount(x, na.omit = FALSE)]
   if (length(eid) > 0) {
     x$el <- x$el[-eid, ]
   }
 
-  on.exit(eval.parent(call("<-", xn, x)))
-  invisible(x)
+  modify_in_place(x)
 }
diff --git a/R/delete_vertices.R b/R/delete_vertices.R
@@ -14,8 +14,6 @@
 #' @export
 #'
 delete.vertices.networkLite <- function(x, vid, ...) {
-  xn <- substitute(x)
-
   vid <- as.integer(vid)
   vid <- vid[vid >= 1 & vid <= network.size(x)]
   if (length(vid) > 0) {
@@ -41,6 +39,5 @@ delete.vertices.networkLite <- function(x, vid, ...) {
     }
   }
 
-  on.exit(eval.parent(call("<-", xn, x)))
-  invisible(x)
+  modify_in_place(x)
 }
diff --git a/R/misc.R b/R/misc.R
@@ -116,7 +116,7 @@ is.na.networkLite <- function(x) {
     edgelist <- tibble(.tail = e1$el$.tail, .head = e1$el$.head)
   }
   out <- networkLite(e1 %n% "n", e1 %n% "directed", e1 %n% "bipartite")
-  out <- add.edges(out, edgelist$.tail, edgelist$.head)
+  add.edges(out, edgelist$.tail, edgelist$.head)
   out
 }
 
@@ -145,7 +145,7 @@ is.na.networkLite <- function(x) {
     edgelist <- tibble(.tail = e1$el$.tail, .head = e1$el$.head)
   }
   out <- networkLite(e1 %n% "n", e1 %n% "directed", e1 %n% "bipartite")
-  out <- add.edges(out, edgelist$.tail, edgelist$.head)
+  add.edges(out, edgelist$.tail, edgelist$.head)
   out
 }
 

diff --git a/R/networkLite-package.R b/R/networkLite-package.R
@@ -54,7 +54,7 @@
 #' @name networkLite-package
 #'
 #' @import network
-#' @importFrom statnet.common NVL NVL2
+#' @importFrom statnet.common NVL NVL2 attr modify_in_place
 #' @importFrom tibble tibble as_tibble is_tibble
 #' @importFrom dplyr bind_rows bind_cols
 #' @importFrom stats na.omit

diff --git a/R/to_network_networkLite.R b/R/to_network_networkLite.R
@@ -28,7 +28,7 @@ to_network_networkLite <- function(x, ...) {
 
   el <- as.edgelist(x, na.rm = FALSE)
 
-  nw <- add.edges(nw, el[, 1], el[, 2])
+  add.edges(nw, el[, 1], el[, 2])
 
   for (name in list.vertex.attributes(x)) {
     value <- get.vertex.attribute(x, name, null.na = FALSE, unlist = FALSE)

diff --git a/tests/testthat/test-networkLite.R b/tests/testthat/test-networkLite.R
@@ -1132,3 +1132,20 @@ test_that("as.edgelist with attrname", {
   expect_equal(nwL$el[["eattr"]], list(1, 2, NULL, NA, 3))
   expect_equal(el[,3], c(1, 2, NA, NA, 3))
 })
+
+test_that("in-place modification fails gracefully", {
+  nw <- network.initialize(10, directed = FALSE)
+  nwL0 <- nwL <- as.networkLite(nw)
+  expect_silent(set.vertex.attribute(identity(nwL), "a", 1))
+  expect_equal(nwL, nwL0) 
+})
+
+test_that("in-place modification with a complex LHS", {
+  nw <- network.initialize(10, directed = FALSE)
+  nwL <- as.networkLite(nw)
+  nwLl <- list(nwL, list(a = nwL, b = nwL))
+  set.vertex.attribute(nwLl[[2]]$a, "a", 1)
+  expect_equal(nwLl[[1]], nwL) 
+  expect_equal(nwLl[[2]]$b, nwL) 
+  expect_failure(expect_equal(nwLl[[2]]$a, nwL))
+})