remove dependency on networkDynamic, ergm, tergm, and EpiModel

DESCRIPTION

@@ -5,10 +5,10 @@ Title: An Alternative Implementation of some of the `network` Package
     Functionality
 Description: An implementation of *some* of the `network` package functionality
     based on a simplified data structure that is faster in some applications.
-    Primarily intended for back-end use in `statnet` and `EpiModel` packages.
-    Supports binary and weighted, directed and undirected, bipartite and
-    unipartite networks; does not support multigraphs, hypergraphs, or loops.
-    Vertex and edge attributes should be atomic.
+    Primarily intended for back-end use in `statnet` and `EpiModel` packages;
+    the implementation is subject to change without notice. Supports binary and
+    weighted, directed and undirected, bipartite and unipartite networks;
+    does not support multigraphs, hypergraphs, or loops.
 Maintainer: Samuel Jenness <samuel.m.jenness@emory.edu>
 Authors@R: c(person("Samuel", "Jenness",
     role=c("cre","aut"), email="samuel.m.jenness@emory.edu"),
@@ -26,26 +26,13 @@ License: GPL-3
 URL: http://www.epimodel.org/
 BugReports: https://github.com/EpiModel/networkLite/issues
 Depends:
-    R (>= 3.5)
+    R (>= 3.5),
+    network (>= 1.17.2)
 Imports:
-    statnet.common,
-    network,
-    networkDynamic,
+    statnet.common (>= 4.6.0),
     tibble,
     dplyr
 Suggests:
-    testthat,
-    ergm,
-    tergm,
-    EpiModel
-RoxygenNote: 7.2.1
+    testthat
+RoxygenNote: 7.2.2
 Encoding: UTF-8
-Remotes:
-    github::statnet/rle@master,
-    github::statnet/statnet.common@master,
-    github::statnet/network@master,
-    github::statnet/networkDynamic@master,
-    github::EpiModel/networkLite@main,    
-    github::statnet/ergm@master,
-    github::statnet/tergm@master,
-    github::EpiModel/EpiModel@main

NAMESPACE

@@ -8,13 +8,16 @@ S3method(add.vertices,networkLite)
 S3method(as.edgelist,networkLite)
 S3method(as.matrix,networkLite)
 S3method(as.network,networkLite)
-S3method(as.networkDynamic,networkLite)
 S3method(as.networkLite,network)
 S3method(as.networkLite,networkLite)
 S3method(as_tibble,networkLite)
+S3method(atomize,networkLite)
+S3method(atomize,tbl_df)
 S3method(delete.edge.attribute,networkLite)
+S3method(delete.edges,networkLite)
 S3method(delete.network.attribute,networkLite)
 S3method(delete.vertex.attribute,networkLite)
+S3method(delete.vertices,networkLite)
 S3method(get.edge.attribute,networkLite)
 S3method(get.edge.value,networkLite)
 S3method(get.network.attribute,networkLite)
@@ -34,14 +37,15 @@ S3method(set.edge.attribute,networkLite)
 S3method(set.edge.value,networkLite)
 S3method(set.network.attribute,networkLite)
 S3method(set.vertex.attribute,networkLite)
+S3method(valid.eids,networkLite)
 export(as.networkLite)
+export(atomize)
 export(networkLite)
 export(networkLite_initialize)
 export(to_network_networkLite)
 import(network)
 importFrom(dplyr,bind_cols)
 importFrom(dplyr,bind_rows)
-importFrom(networkDynamic,as.networkDynamic)
 importFrom(statnet.common,NVL)
 importFrom(statnet.common,NVL2)
 importFrom(stats,na.omit)

R/add_edges.R

@@ -0,0 +1,168 @@
+
+#' @rdname add_edges
+#' @title Methods to Add or Modify Edges in a \code{networkLite}
+#' @param x A \code{networkLite}.
+#' @param tail Vector of tails of edges to add to the \code{networkLite}.
+#' @param head Vector of heads of edges to add to the \code{networkLite}.
+#' @param names.eval Names of edge attributes, or \code{NULL} to indicate that
+#'        attributes are not being specified. For \code{add.edges}, this
+#'        argument should be structured as a list of length equal to
+#'        \code{length(tail)}, each element of which is a character vector
+#'        of attribute names for the corresponding edge. For the replacement
+#'        method \code{[<-.networkLite}, this should argument should be a
+#'        single attribute name, which is applied to all edges.
+#' @param vals.eval Value(s) of edge attributes, or \code{NULL} to indicate
+#'        that attributes are not being specified. This argument should be
+#'        structured as a list of length equal to \code{length(tail)}, each
+#'        element of which is a list of attribute values, in the same order
+#'        as the corresponding attribute names in \code{names.eval}.
+#' @param i,j Nodal indices (must be missing for \code{networkLite} method).
+#' @param add.edges logical; should edges being assigned to be added if they
+#'        are not already present?
+#' @param value Edge values to assign (coerced to a matrix).
+#' @param ... additional arguments
+#' @export
+add.edges.networkLite <- function(x, tail, head, names.eval = NULL,
+                                  vals.eval = NULL, ...) {
+  ## convert to atomic...
+  tail <- NVL(as.integer(unlist(tail)), integer(0))
+  head <- NVL(as.integer(unlist(head)), integer(0))
+
+  ## if we were passed any attribute information...
+  if (length(unlist(names.eval))  > 0) {
+    if (!is.list(names.eval)) names.eval <-
+        as.list(rep(names.eval, length.out = length(tail)))
+    if (!is.list(vals.eval)) vals.eval <-
+        as.list(rep(vals.eval, length.out = length(names.eval)))
+
+    for (i in seq_along(vals.eval)) {
+      vals.eval[[i]] <- as.list(vals.eval[[i]])
+      names(vals.eval[[i]]) <- names.eval[[i]]
+    }
+
+    new_names <- unique(unlist(names.eval))
+    update_list <- lapply(new_names, function(name) lapply(vals.eval, `[[`, name))
+    names(update_list) <- new_names
+  } else {
+    update_list <- list()
+  }
+
+  if ("na" %in% names(update_list)) {
+    update_list[["na"]] <- lapply(update_list[["na"]], isTRUE)
+  } else {
+    update_list <- c(update_list, list(na = logical(length(tail))))
+  }
+  update_tibble <- as_tibble(c(list(.tail = tail, .head = head), update_list))
+
+  new_names <- names(update_tibble) # including ".tail", ".head", and "na"
+  old_names <- names(x$el)
+
+  for (name in setdiff(old_names, new_names)) {
+    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))
+  }
+
+  x$el <- dplyr::bind_rows(ensure_list(list(x$el, update_tibble)))
+  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)
+}
+
+#' @rdname add_edges
+#' @export
+"[<-.networkLite" <- function(x, i, j, names.eval = NULL,
+                              add.edges = FALSE, value) {
+  if (!missing(i) || !missing(j)) {
+    stop("`[<-.networkLite` does not support `i` and `j` arguments at this",
+         " time")
+  }
+
+  if (any(is.na(value))) {
+    stop("`[<-.networkLite` does not support NA `value` arguments at this",
+         " time")
+  }
+
+  if (is.null(names.eval) && isTRUE(all(value == FALSE))) {
+    x$el <- as_tibble(list(.tail = integer(0),
+                           .head = integer(0),
+                           na = logical(0)))
+    return(x)
+  }
+
+  b1 <- if (is.bipartite(x)) x %n% "bipartite" else
+    network.size(x)
+  b2 <- if (is.bipartite(x)) network.size(x) - x %n% "bipartite" else
+    network.size(x)
+
+  if (!is.matrix(value)) {
+    value <- matrix(value, nrow = b1, ncol = b2)
+  } else {
+    if (nrow(value) < b1 || ncol(value) < b2) {
+      stop("too small a matrix `value` passed to `[<-.networkLite`")
+    }
+    value <- value[seq_len(b1), seq_len(b2), drop = FALSE]
+  }
+
+  if (is.null(names.eval)) {
+    # add edges whether or not add.edges is TRUE,
+    #   for consistency with `network` behavior
+    w <- which(value != 0, arr.ind = TRUE)
+    if (is.bipartite(x)) {
+      w[, 2] <- w[, 2] + b1
+    }
+    if (!is.directed(x)) {
+      w <- w[w[, 1] < w[, 2], , drop = FALSE]
+    } else {
+      w <- w[w[, 1] != w[, 2], , drop = FALSE]
+    }
+    w <- w[order(w[, 1], w[, 2]), , drop = FALSE]
+    x$el <- as_tibble(list(.tail = as.integer(w[, 1]),
+                           .head = as.integer(w[, 2]),
+                           na = logical(NROW(w))))
+  } else {
+    if (!add.edges) {
+      el <- as.edgelist(x, na.rm = FALSE)
+      if (is.bipartite(x)) {
+        el[, 2] <- el[, 2] - b1
+      }
+      if (names.eval == "na") {
+        value[is.na(value)] <- FALSE
+      }
+      set.edge.attribute(x, names.eval, value[el])
+    } else {
+      w <- which(value != 0, arr.ind = TRUE)
+      vals <- value[w]
+      if (is.bipartite(x)) {
+        w[, 2] <- w[, 2] + b1
+      }
+      if (!is.directed(x)) {
+        vals <- vals[w[, 1] < w[, 2]]
+        w <- w[w[, 1] < w[, 2], , drop = FALSE]
+      } else {
+        vals <- vals[w[, 1] != w[, 2]]
+        w <- w[w[, 1] != w[, 2], , drop = FALSE]
+      }
+      vals <- vals[order(w[, 1], w[, 2])]
+      w <- w[order(w[, 1], w[, 2]), , drop = FALSE]
+      if (names.eval == "na") {
+        vals[is.na(vals)] <- FALSE
+        tbl_list <- list(as.integer(w[, 1]), as.integer(w[, 2]), vals)
+        names(tbl_list) <- c(".tail",
+                             ".head",
+                             names.eval)
+      } else {
+        tbl_list <- list(as.integer(w[, 1]), as.integer(w[, 2]), vals, logical(NROW(w)))
+        names(tbl_list) <- c(".tail", ".head", names.eval, "na")
+      }
+      x$el <- as_tibble(tbl_list)
+    }
+  }
+  return(x)
+}

R/add_vertices.R

@@ -0,0 +1,68 @@
+#' @rdname add_vertices
+#' @title Add Vertices to a \code{networkLite}
+#' @param x A \code{networkLite} object.
+#' @param nv Number of vertices to add to the \code{networkLite}.
+#' @param vattr A list (of length \code{nv}) of named lists of vertex
+#'        attribute values for added vertices, or \code{NULL} to indicate vertex
+#'        attribute values are not being passed.
+#' @param last.mode logical; if \code{x} is bipartite, should the new vertices
+#'        be added to the second mode?
+#' @param ... additional arguments
+#' @export
+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)
+    x %n% "n" <- oldsize + nv
+
+    if (is.bipartite(x) && !last.mode) {
+      offset <- x %n% "bipartite"
+      x %n% "bipartite" <- x %n% "bipartite" + nv
+      x$el$.head <- x$el$.head + nv
+    } else {
+      offset <- oldsize
+    }
+
+    ## if we were passed any attribute information...
+    if (length(unlist(vattr)) > 0) {
+      if (is.list(vattr)) {
+        vattr <- rep(vattr, length.out = nv)
+      } else {
+        vattr <- as.list(rep(vattr, length.out = nv))
+      }
+
+      new_names <- unique(unlist(lapply(vattr, names)))
+      update_list <- lapply(new_names, function(name) lapply(vattr, `[[`, name))
+      names(update_list) <- new_names
+    } else {
+      update_list <- list()
+    }
+
+    if ("na" %in% names(update_list)) {
+      update_list[["na"]] <- lapply(update_list[["na"]], isTRUE)
+    } else {
+      update_list <- c(update_list, list(na = logical(nv)))
+    }
+    update_tibble <- as_tibble(update_list)
+
+    new_names <- names(update_tibble) # including "na"
+    old_names <- names(x$attr)
+
+    for (name in setdiff(old_names, new_names)) {
+      update_tibble[[name]] <- vector(mode = "list", length = NROW(update_tibble))
+    }
+    for (name in setdiff(new_names, old_names)) {
+      x$attr[[name]] <- vector(mode = "list", length = NROW(x$attr))
+    }
+
+    x$attr <- dplyr::bind_rows(ensure_list(list(x$attr[seq_len(offset), ],
+                                                update_tibble,
+                                                x$attr[offset + seq_len(oldsize - offset), ])))
+  }
+
+  on.exit(eval.parent(call("<-", xn, x)))
+  invisible(x)
+}

R/as_networkLite.R

@@ -0,0 +1,73 @@
+#' @rdname as_networkLite
+#' @title Convert to \code{networkLite} Representation
+#' @details \code{as.networkLite.network} converts a \code{network} object
+#'          to a \code{networkLite} object.  \code{as.networkLite.networkLite}
+#'          returns the \code{networkLite} object unchanged.
+#'
+#'          Currently the network attributes \code{hyper}, \code{multiple}, and
+#'          \code{loops} must be \code{FALSE} for \code{networkLite}s;
+#'          attempting to convert a \code{network} to a \code{networkLite} when
+#'          this is not the case will result in an error.
+#'
+#'          The \code{...} are passed to \code{\link{atomize}} and can be used
+#'          to set the \code{upcast} argument controlling attribute conversion.
+#' @param x A \code{network} or \code{networkLite} object.
+#' @param atomize Logical; should we call \code{\link{atomize}} on the
+#'        \code{networkLite} before returning it?
+#' @param ... additional arguments
+#' @return A corresponding \code{networkLite} object.
+#' @seealso \code{\link{to_network_networkLite}}
+#' @export
+as.networkLite <- function(x, ...) {
+  UseMethod("as.networkLite")
+}
+
+#' @rdname as_networkLite
+#' @export
+as.networkLite.network <- function(x, ..., atomize = TRUE) {
+  if (is.hyper(x) || is.multiplex(x) || has.loops(x)) {
+    stop("cannot coerce `network` to `networkLite` unless `hyper`,",
+         " `multiple`, and `loops` are all `FALSE`")
+  }
+
+  el <- as.edgelist(x, na.rm = FALSE)
+
+  rv <- networkLite(el)
+
+  for (name in list.vertex.attributes(x)) {
+    value <- get.vertex.attribute(x, name, null.na = FALSE, na.omit = FALSE,
+                                  unlist = FALSE)
+    set.vertex.attribute(rv, name, value)
+  }
+
+  for (name in setdiff(list.network.attributes(x), c("mnext"))) {
+    value <- get.network.attribute(x, name)
+    set.network.attribute(rv, name, value)
+  }
+
+  eids <- unlist(lapply(seq_len(NROW(el)),
+                 function(index) {
+                   get.edgeIDs(x, el[index, 1], el[index, 2], na.omit = FALSE)
+                 }))
+  for (name in list.edge.attributes(x)) {
+    value <- get.edge.attribute(x, name, unlist = FALSE, null.na = FALSE,
+                                na.omit = FALSE, deleted.edges.omit = FALSE)[eids]
+    set.edge.attribute(rv, name, value)
+  }
+
+  for (name in setdiff(names(attributes(x)), c("class", "names"))) {
+    attr(rv, name) <- attr(x, name)
+  }
+
+  if (atomize == TRUE) {
+    rv <- atomize(rv, ...)
+  }
+
+  rv
+}
+
+#' @rdname as_networkLite
+#' @export
+as.networkLite.networkLite <- function(x, ...) {
+  x
+}