diff --git a/DESCRIPTION b/DESCRIPTION index d0bb2f9..3d510df 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: networkLite Version: 1.1.0 -Date: 2024-11-23 +Date: 2025-01-08 Title: An Simplified Implementation of the 'network' Package Functionality Description: An implementation of some of the core 'network' package functionality based on a simplified data structure that is faster in many research applications. This package is designed @@ -33,9 +33,6 @@ Imports: dplyr Suggests: testthat -RoxygenNote: 7.3.2.9000 +RoxygenNote: 7.3.2 Encoding: UTF-8 Roxygen: list(markdown = TRUE) -Remotes: - github::statnet/statnet.common@master, - github::statnet/network@master diff --git a/NAMESPACE b/NAMESPACE index 89a03c8..5a3f26d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -7,6 +7,9 @@ S3method(add.edges,networkLite) S3method(add.vertices,networkLite) S3method(as.edgelist,networkLite) S3method(as.matrix,networkLite) +S3method(as.matrix,networkLite.adjacency) +S3method(as.matrix,networkLite.edgelist) +S3method(as.matrix,networkLite.incidence) S3method(as.network,networkLite) S3method(as.networkLite,network) S3method(as.networkLite,networkLite) diff --git a/R/add_edges.R b/R/add_edges.R index 93197c6..07548e5 100644 --- a/R/add_edges.R +++ b/R/add_edges.R @@ -40,9 +40,9 @@ add.edges.networkLite <- function(x, tail, head, names.eval = NULL, ## 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))) + 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))) + 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]]) diff --git a/R/add_vertices.R b/R/add_vertices.R index 7887a0c..0c4ecff 100644 --- a/R/add_vertices.R +++ b/R/add_vertices.R @@ -77,12 +77,12 @@ add.vertices.networkLite <- function(x, nv, vattr = NULL, #' @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))) + 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)) + 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....") } @@ -90,7 +90,8 @@ permute.vertexIDs.networkLite <- function(x, vids, ...) { 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)) + 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. diff --git a/R/as_networkLite.R b/R/as_networkLite.R index ffedfad..b077136 100644 --- a/R/as_networkLite.R +++ b/R/as_networkLite.R @@ -55,9 +55,9 @@ as.networkLite.network <- function(x, ..., atomize = TRUE) { } eids <- unlist(lapply(seq_len(NROW(el)), - function(index) { - get.edgeIDs(x, el[index, 1], el[index, 2], na.omit = FALSE) - })) + 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] diff --git a/R/attribute_methods.R b/R/attribute_methods.R index 4871107..fec6c4d 100644 --- a/R/attribute_methods.R +++ b/R/attribute_methods.R @@ -243,7 +243,7 @@ list.edge.attributes.networkLite <- function(x, ...) { #' @export delete.vertex.attribute.networkLite <- function(x, attrname, ...) { ## TODO: See if this can be done in one operation faster. - for(a in attrname) x$attr[[a]] <- NULL + for (a in attrname) x$attr[[a]] <- NULL modify_in_place(x) } @@ -252,7 +252,7 @@ delete.vertex.attribute.networkLite <- function(x, attrname, ...) { #' @export delete.edge.attribute.networkLite <- function(x, attrname, ...) { ## TODO: See if this can be done in one operation faster. - for(a in attrname) x$el[[a]] <- NULL + for (a in attrname) x$el[[a]] <- NULL modify_in_place(x) } @@ -261,7 +261,7 @@ delete.edge.attribute.networkLite <- function(x, attrname, ...) { #' @export delete.network.attribute.networkLite <- function(x, attrname, ...) { ## TODO: See if this can be done in one operation faster. - for(a in attrname) x$gal[[a]] <- NULL + for (a in attrname) x$gal[[a]] <- NULL modify_in_place(x) } diff --git a/R/constructors.R b/R/constructors.R index d853d93..a716243 100644 --- a/R/constructors.R +++ b/R/constructors.R @@ -75,9 +75,9 @@ networkLite.edgelist <- function( attr = list(vertex.names = seq_len(net_attr[["n"]]), na = logical(net_attr[["n"]])), net_attr = attributes(x)[setdiff(names(attributes(x)), - c("class", "dim", "dimnames", - "vnames", "row.names", "names", - "mnext"))], + c("class", "dim", "dimnames", + "vnames", "row.names", "names", + "mnext"))], ..., atomize = FALSE) { @@ -130,7 +130,7 @@ networkLite.edgelist <- function( } if (!isFALSE(nw$gal[["loops"]]) || !isFALSE(nw$gal[["hyper"]]) || - !isFALSE(nw$gal[["multiple"]])) { + !isFALSE(nw$gal[["multiple"]])) { stop("networkLite requires network attributes `loops`, `hyper`, and", " `multiple` be `FALSE`.") } diff --git a/R/delete_vertices.R b/R/delete_vertices.R index 2d22430..0a948ad 100644 --- a/R/delete_vertices.R +++ b/R/delete_vertices.R @@ -47,15 +47,16 @@ delete.vertices.networkLite <- function(x, vid, ...) { #' #' @param x,v,alters,... see [network::get.inducedSubgraph()] #' @export -get.inducedSubgraph.networkLite <- function(x, v, alters=NULL, ...){ +get.inducedSubgraph.networkLite <- function(x, v, alters = NULL, ...) { #Do some reality checking - n<-network.size(x) + n <- network.size(x) # do checks for v and alters - if((length(v)<1)||any(is.na(v))||any(v<1)||any(v>n)) + 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)) + 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") } @@ -63,20 +64,19 @@ get.inducedSubgraph.networkLite <- function(x, v, alters=NULL, ...){ #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 + 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) + 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 + return(x) } diff --git a/R/matrix_conversions.R b/R/matrix_conversions.R index 3f18059..574951d 100644 --- a/R/matrix_conversions.R +++ b/R/matrix_conversions.R @@ -69,16 +69,17 @@ as.edgelist.networkLite <- function(x, attrname = NULL, #' @rdname matrix_conversions #' @export -as_tibble.networkLite <- function(x, attrnames=(match.arg(unit)=="vertices"), na.rm=TRUE, ..., unit=c("edges", "vertices")) { +as_tibble.networkLite <- function(x, attrnames = (match.arg(unit) == "vertices"), + na.rm = TRUE, ..., unit = c("edges", "vertices")) { unit <- match.arg(unit) df <- switch(unit, edges = x$el, vertices = x$attr) if (is.logical(attrnames) || is.numeric(attrnames)) attrnames <- na.omit(setdiff(names(df), c(".tail", ".head", ".eid"))[attrnames]) - # Keep only requested columns, but make sure all named columns are present. - if(na.rm) df <- df[!df$na,] + # Keep only requested columns, but make sure all named columns are present + if (na.rm) df <- df[!df$na, ] df <- df[intersect(c(".tail", ".head", ".eid", attrnames), names(df))] - for(a in setdiff(attrnames, names(df))) df[[a]] <- rep(list(), nrow(df)) + for (a in setdiff(attrnames, names(df))) df[[a]] <- rep(list(), nrow(df)) df <- atomize(df, ...) attr(df, "n") <- network.size(x) @@ -100,6 +101,7 @@ as.matrix.networkLite <- function(x, edgelist = as.matrix.networkLite.edgelist(x, attrname, ...)) } +#' @export as.matrix.networkLite.adjacency <- function(x, attrname = NULL, ...) { el <- as.edgelist(x, na.rm = FALSE) @@ -127,6 +129,7 @@ as.matrix.networkLite.adjacency <- function(x, attrname = NULL, ...) { } } +#' @export as.matrix.networkLite.incidence <- function(x, attrname = NULL, ...) { el <- as.edgelist(x, na.rm = FALSE) @@ -143,6 +146,7 @@ as.matrix.networkLite.incidence <- function(x, attrname = NULL, ...) { m } +#' @export as.matrix.networkLite.edgelist <- function(x, attrname = NULL, na.rm = TRUE, ...) { diff --git a/R/misc.R b/R/misc.R index 506f6b1..fc55ebf 100644 --- a/R/misc.R +++ b/R/misc.R @@ -97,8 +97,8 @@ is.na.networkLite <- function(x) { #' `+.networkLite` <- function(e1, e2) { if (!identical(e1 %n% "n", e2 %n% "n") || - !identical(e1 %n% "directed", e2 %n% "directed") || - !identical(e1 %n% "bipartite", e2 %n% "bipartite")) { + !identical(e1 %n% "directed", e2 %n% "directed") || + !identical(e1 %n% "bipartite", e2 %n% "bipartite")) { stop("cannot add networkLites of differing network size, directedness, or", " bipartiteness") } @@ -124,8 +124,8 @@ is.na.networkLite <- function(x) { #' @export `-.networkLite` <- function(e1, e2) { if (!identical(e1 %n% "n", e2 %n% "n") || - !identical(e1 %n% "directed", e2 %n% "directed") || - !identical(e1 %n% "bipartite", e2 %n% "bipartite")) { + !identical(e1 %n% "directed", e2 %n% "directed") || + !identical(e1 %n% "bipartite", e2 %n% "bipartite")) { stop("cannot subtract networkLites of differing network size,", " directedness, or bipartiteness") } diff --git a/R/networkLite-package.R b/R/networkLite-package.R index 56e998c..215cd29 100644 --- a/R/networkLite-package.R +++ b/R/networkLite-package.R @@ -4,8 +4,8 @@ #' \tabular{ll}{ #' Package: \tab networkLite\cr #' Type: \tab Package\cr -#' Version: \tab 1.0.5\cr -#' Date: \tab 2023-03-10\cr +#' Version: \tab 1.1.0\cr +#' Date: \tab 2025-01-08\cr #' License: \tab GPL-3\cr #' LazyLoad: \tab yes\cr #' } diff --git a/R/utils.R b/R/utils.R index bf72eb4..43bed46 100644 --- a/R/utils.R +++ b/R/utils.R @@ -47,10 +47,10 @@ atomize.tbl_df <- function(x, ..., upcast = FALSE) { for (name in names(x)) { value <- x[[name]] if (is.list(value) && - length(value) > 0 && - all(unlist(lapply(value, is.atomic))) && - all(unlist(lapply(value, length)) == 1) && - (upcast == TRUE || length(unique(unlist(lapply(value, class)))) == 1)) { + length(value) > 0 && + all(unlist(lapply(value, is.atomic))) && + all(unlist(lapply(value, length)) == 1) && + (upcast == TRUE || length(unique(unlist(lapply(value, class)))) == 1)) { x[[name]] <- unlist(value) } } @@ -66,11 +66,11 @@ ensure_list <- function(x) { any_list <- any(unlist(lapply(lapply(x, `[[`, name), is.list))) if (any_list == TRUE) { x <- lapply(x, function(y) { - if (name %in% names(y)) { - y[[name]] <- as.list(y[[name]]) - } - y - }) + if (name %in% names(y)) { + y[[name]] <- as.list(y[[name]]) + } + y + }) } } return(x) diff --git a/man/networkLite-package.Rd b/man/networkLite-package.Rd index dffa1c3..c4f4fe1 100644 --- a/man/networkLite-package.Rd +++ b/man/networkLite-package.Rd @@ -7,8 +7,8 @@ \tabular{ll}{ Package: \tab networkLite\cr Type: \tab Package\cr -Version: \tab 1.0.5\cr -Date: \tab 2023-03-10\cr +Version: \tab 1.1.0\cr +Date: \tab 2025-01-08\cr License: \tab GPL-3\cr LazyLoad: \tab yes\cr } diff --git a/networkLite.Rproj b/networkLite.Rproj index ce013e1..fab3b4f 100644 --- a/networkLite.Rproj +++ b/networkLite.Rproj @@ -1,4 +1,5 @@ Version: 1.0 +ProjectId: 4584846e-a1cd-4ea7-a3fe-12c82787826e RestoreWorkspace: Default SaveWorkspace: Default