From b0c46a41cdfa6ebca1b491c23b9f3e6dd54c152e Mon Sep 17 00:00:00 2001 From: Alex Hayes Date: Thu, 22 Aug 2024 16:31:14 -0500 Subject: [PATCH] Style package --- DESCRIPTION | 2 +- R/directed_dcsbm.R | 53 ++++++++----------- R/directed_erdos_renyi.R | 20 ++++--- R/directed_factor_model.R | 39 ++++++-------- R/expected-degrees.R | 8 +-- R/expected-spectra.R | 3 -- R/plotting.R | 2 - R/sample_edgelist.R | 33 ++++-------- R/sample_igraph.R | 15 +++--- R/sample_sparse.R | 23 ++++---- R/sample_tidygraph.R | 13 +++-- R/undirected_chung_lu.R | 15 +++--- R/undirected_dcsbm.R | 43 +++++++-------- R/undirected_erdos_renyi.R | 18 +++---- R/undirected_factor_model.R | 43 +++++++-------- R/undirected_mmsbm.R | 8 --- R/undirected_overlapping_sbm.R | 8 +-- R/undirected_planted_partition.R | 25 ++++----- R/undirected_sbm.R | 18 +++---- R/utils.R | 2 +- README.Rmd | 2 +- README.md | 6 +-- man/sample_igraph.Rd | 2 +- man/sample_sparse.Rd | 2 +- man/sample_tidygraph.Rd | 2 +- tests/testthat/test-allow_self_loops.R | 4 +- tests/testthat/test-degree-scaling.R | 28 ++++------ tests/testthat/test-directedness.R | 2 - tests/testthat/test-poisson_edges.R | 2 - tests/testthat/test-retain-isolated-nodes.R | 13 ++--- .../test-undirected-overlapping-sbms.R | 3 -- tests/testthat/test-undirected-sbms.R | 4 -- 32 files changed, 176 insertions(+), 285 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 20f186a..2863822 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -45,4 +45,4 @@ Suggests: Config/testthat/edition: 3 Encoding: UTF-8 Roxygen: list(markdown = TRUE) -RoxygenNote: 7.2.3 +RoxygenNote: 7.3.2 diff --git a/R/directed_dcsbm.R b/R/directed_dcsbm.R index aeddbbc..8232075 100644 --- a/R/directed_dcsbm.R +++ b/R/directed_dcsbm.R @@ -1,14 +1,14 @@ new_directed_dcsbm <- function( - X, S, Y, - theta_out, - theta_in, - z_out, - z_in, - pi_out, - pi_in, - sorted, - ..., - subclass = character()) { + X, S, Y, + theta_out, + theta_in, + z_out, + z_in, + pi_out, + pi_in, + sorted, + ..., + subclass = character()) { subclass <- c(subclass, "directed_dcsbm") dcsbm <- directed_factor_model(X, S, Y, ..., subclass = subclass) dcsbm$theta_out <- theta_out @@ -22,7 +22,6 @@ new_directed_dcsbm <- function( } validate_directed_dcsbm <- function(x) { - values <- unclass(x) if (!is.factor(values$z_out)) { @@ -335,17 +334,16 @@ validate_directed_dcsbm <- function(x) { #' population_svd <- svds(ddcsbm) #' directed_dcsbm <- function( - n = NULL, - theta_out = NULL, theta_in = NULL, - k_out = NULL, k_in = NULL, B = NULL, - ..., - pi_out = rep(1 / k_out, k_out), - pi_in = rep(1 / k_in, k_in), - sort_nodes = TRUE, - force_identifiability = TRUE, - poisson_edges = TRUE, - allow_self_loops = TRUE) { - + n = NULL, + theta_out = NULL, theta_in = NULL, + k_out = NULL, k_in = NULL, B = NULL, + ..., + pi_out = rep(1 / k_out, k_out), + pi_in = rep(1 / k_in, k_in), + sort_nodes = TRUE, + force_identifiability = TRUE, + poisson_edges = TRUE, + allow_self_loops = TRUE) { # NOTE: # - X corresponds to outgoing communities, outgoing edges and rows of A # - Y corresponds to incoming communities, incoming edges and columns of A @@ -364,7 +362,6 @@ directed_dcsbm <- function( call. = FALSE ) } else if (is.null(theta_out) && is.null(theta_in)) { - if (n < 1) { stop("`n` must be a positive integer.", call. = FALSE) } @@ -377,9 +374,7 @@ directed_dcsbm <- function( theta_out <- stats::rlnorm(n, meanlog = 2, sdlog = 1) theta_in <- stats::rlnorm(n, meanlog = 2, sdlog = 1) - } else if (is.null(n)) { - if (length(theta_out) != length(theta_in)) { stop( "Length of `theta_out` must match length of `theta_in`.", @@ -398,7 +393,6 @@ directed_dcsbm <- function( call. = FALSE ) } else if (is.null(B)) { - if (k_out < 1) { stop("`k_out` must be a positive integer.", call. = FALSE) } @@ -414,9 +408,7 @@ directed_dcsbm <- function( ) B <- Matrix(data = stats::runif(k_out * k_in), nrow = k_out, ncol = k_in) - } else if (!is.null(B)) { - k_out <- nrow(B) k_in <- ncol(B) } @@ -473,13 +465,13 @@ directed_dcsbm <- function( if (k_out > 1) { - X <- sparse.model.matrix(~z_out + 0) + X <- sparse.model.matrix(~ z_out + 0) } else { X <- Matrix(1, nrow = n, ncol = 1) } if (k_in > 1) { - Y <- sparse.model.matrix(~z_in + 0) + Y <- sparse.model.matrix(~ z_in + 0) } else { Y <- Matrix(1, nrow = n, ncol = 1) } @@ -532,7 +524,6 @@ directed_dcsbm <- function( #' @method print directed_dcsbm #' @export print.directed_dcsbm <- function(x, ...) { - cat(glue("Directed Degree-Corrected Stochastic Blockmodel\n", .trim = FALSE)) cat(glue("-----------------------------------------------\n\n", .trim = FALSE)) diff --git a/R/directed_erdos_renyi.R b/R/directed_erdos_renyi.R index 62bd59a..7f2a171 100644 --- a/R/directed_erdos_renyi.R +++ b/R/directed_erdos_renyi.R @@ -1,5 +1,4 @@ -new_directed_erdos_renyi <- function(X, S, Y, p, poisson_edges, allow_self_loops,...) { - +new_directed_erdos_renyi <- function(X, S, Y, p, poisson_edges, allow_self_loops, ...) { er <- directed_factor_model( X, S, Y, ..., subclass = "directed_erdos_renyi", @@ -12,7 +11,6 @@ new_directed_erdos_renyi <- function(X, S, Y, p, poisson_edges, allow_self_loops } validate_directed_erdos_renyi <- function(x) { - values <- unclass(x) if (ncol(values$X) != 1) { @@ -59,15 +57,14 @@ validate_directed_erdos_renyi <- function(x) { #' A #' directed_erdos_renyi <- function( - n, ..., p = NULL, - poisson_edges = TRUE, - allow_self_loops = TRUE) { - + n, ..., p = NULL, + poisson_edges = TRUE, + allow_self_loops = TRUE) { X <- Matrix(1, nrow = n, ncol = 1) Y <- Matrix(1, nrow = n, ncol = 1) - if (is.null(p) && is.null(expected_in_degree) - && is.null(expected_out_degree)) { + if (is.null(p) && is.null(expected_in_degree) && + is.null(expected_out_degree)) { stop( "Must specify either `p`, `expected_in_degree` or ", " `expected_out_degree`.", @@ -76,13 +73,14 @@ directed_erdos_renyi <- function( } if (is.null(p)) { - p <- 0.5 # doesn't matter, will get rescaled anyway + p <- 0.5 # doesn't matter, will get rescaled anyway } S <- matrix(p, nrow = 1, ncol = 1) er <- new_directed_erdos_renyi( - X, S, Y, p = p, + X, S, Y, + p = p, poisson_edges = poisson_edges, allow_self_loops = allow_self_loops, ... diff --git a/R/directed_factor_model.R b/R/directed_factor_model.R index 8c35b86..d8af5cf 100644 --- a/R/directed_factor_model.R +++ b/R/directed_factor_model.R @@ -1,10 +1,9 @@ new_directed_factor_model <- function( - X, S, Y, - poisson_edges, - allow_self_loops, - ..., - subclass = character()) { - + X, S, Y, + poisson_edges, + allow_self_loops, + ..., + subclass = character()) { ellipsis::check_dots_unnamed() n <- nrow(X) @@ -29,7 +28,6 @@ new_directed_factor_model <- function( } validate_directed_factor_model <- function(x) { - values <- unclass(x) if (any(values$X < 0) || any(values$S < 0) || any(values$Y < 0)) { @@ -162,14 +160,13 @@ validate_directed_factor_model <- function(x) { #' fm2 #' directed_factor_model <- function( - X, S, Y, - ..., - expected_in_degree = NULL, - expected_out_degree = NULL, - expected_density = NULL, - poisson_edges = TRUE, - allow_self_loops = TRUE) { - + X, S, Y, + ..., + expected_in_degree = NULL, + expected_out_degree = NULL, + expected_density = NULL, + poisson_edges = TRUE, + allow_self_loops = TRUE) { X <- Matrix(X) S <- Matrix(S) Y <- Matrix(Y) @@ -196,7 +193,6 @@ directed_factor_model <- function( ) if (!is.null(expected_in_degree)) { - if (expected_in_degree <= 0) { stop( "`expected_in_degree` must be strictly greater than zero.", @@ -208,7 +204,6 @@ directed_factor_model <- function( } if (!is.null(expected_out_degree)) { - if (expected_out_degree <= 0) { stop( "`expected_out_degree` must be strictly greater than zero.", @@ -220,7 +215,6 @@ directed_factor_model <- function( } if (!is.null(expected_density)) { - if (expected_density <= 0 || 1 <= expected_density) { stop( "`expected_density` must be strictly between zero and one.", @@ -234,7 +228,6 @@ directed_factor_model <- function( fm$S <- S if (!poisson_edges) { - # when poisson_edges = FALSE, S is the desired Bernoulli edge probability. # we must # back-transform it to a Poisson parameterization of S. see section 2.3 @@ -255,17 +248,16 @@ directed_factor_model <- function( } dim_and_class <- function(x, ...) { - - if (is.matrix(x) || inherits(x, "Matrix")) + if (is.matrix(x) || inherits(x, "Matrix")) { paste0(nrow(x), " x ", ncol(x), " [", class(x)[1], "]") - else + } else { paste0(length(x), " [", class(x)[1], "]") + } } #' @method print directed_factor_model #' @export print.directed_factor_model <- function(x, ...) { - cat(glue("Directed Factor Model\n", .trim = FALSE)) cat(glue("---------------------\n\n", .trim = FALSE)) @@ -289,4 +281,3 @@ print.directed_factor_model <- function(x, ...) { sep = "\n" ) } - diff --git a/R/expected-degrees.R b/R/expected-degrees.R index e85722d..98c8309 100644 --- a/R/expected-degrees.R +++ b/R/expected-degrees.R @@ -23,7 +23,7 @@ #' a <- .1 #' b <- .05 #' -#' B <- matrix(c(a,b,b,a), nrow = 2) +#' B <- matrix(c(a, b, b, a), nrow = 2) #' #' b_model <- fastRG::sbm(n = n, k = 2, B = B, poisson_edges = FALSE) #' @@ -34,7 +34,7 @@ #' # compare #' mean(rowSums(triu(A))) #' -#' pop * a + pop * b # analytical average degree +#' pop * a + pop * b # analytical average degree #' #' ##### more generic examples #' @@ -75,7 +75,6 @@ expected_edges <- function(factor_model, ...) { #' @export expected_edges.directed_factor_model <- function(factor_model, ...) { - X <- factor_model$X S <- factor_model$S Y <- factor_model$Y @@ -87,7 +86,6 @@ expected_edges.directed_factor_model <- function(factor_model, ...) { #' @export expected_edges.undirected_factor_model <- function(factor_model, ...) { - X <- factor_model$X S <- factor_model$S @@ -134,7 +132,6 @@ expected_degrees <- function(factor_model, ...) { #' @export expected_degrees.undirected_factor_model <- function(factor_model, ...) { - # rowSums of E[A|X, S] = XSX' are XSX'1 for 1 a column vector of ones # want to avoid memory cost of instantiating all of E[A|X, S], which is # typically large and dense @@ -161,7 +158,6 @@ expected_out_degree.directed_factor_model <- function(factor_model, ...) { #' @export expected_density.directed_factor_model <- function(factor_model, ...) { - n <- factor_model$n d <- factor_model$d diff --git a/R/expected-spectra.R b/R/expected-spectra.R index 89ed765..456aeeb 100644 --- a/R/expected-spectra.R +++ b/R/expected-spectra.R @@ -20,7 +20,6 @@ eigs_sym.undirected_factor_model <- function( which = "LM", sigma = NULL, opts = list(), ...) { - if (!requireNamespace("RSpectra", quietly = TRUE)) { stop( "Must install `RSpectra` for this functionality.", @@ -49,7 +48,6 @@ svds.undirected_factor_model <- function( nv = k, opts = list(), ...) { - if (!requireNamespace("RSpectra", quietly = TRUE)) { stop( "Must install `RSpectra` for this functionality.", @@ -94,7 +92,6 @@ svds.directed_factor_model <- function( nv = k, opts = list(), ...) { - if (!requireNamespace("RSpectra", quietly = TRUE)) { stop( "Must install `RSpectra` for this functionality.", diff --git a/R/plotting.R b/R/plotting.R index 21df25a..628e07a 100644 --- a/R/plotting.R +++ b/R/plotting.R @@ -53,7 +53,6 @@ plot_expectation <- function(model) { #' @import ggplot2 #' @export plot_dense_matrix <- function(A, ...) { - # don't preserve rownames because rownames and colnames get coerced to # indices and this can lead to type errors rownames(A) <- 1:nrow(A) @@ -76,7 +75,6 @@ plot_dense_matrix <- function(A, ...) { #' @rdname plot_expectation #' @export plot_sparse_matrix <- function(A) { - stopifnot(inherits(A, "sparseMatrix")) A <- methods::as(A, "CsparseMatrix") diff --git a/R/sample_edgelist.R b/R/sample_edgelist.R index 2e11554..cccac92 100644 --- a/R/sample_edgelist.R +++ b/R/sample_edgelist.R @@ -144,8 +144,8 @@ #' sample_tidygraph(fm) #' sample_edgelist <- function( - factor_model, - ...) { + factor_model, + ...) { ellipsis::check_dots_unnamed() UseMethod("sample_edgelist") } @@ -153,9 +153,8 @@ sample_edgelist <- function( #' @rdname sample_edgelist #' @export sample_edgelist.undirected_factor_model <- function( - factor_model, - ...) { - + factor_model, + ...) { X <- factor_model$X S <- factor_model$S @@ -170,9 +169,8 @@ sample_edgelist.undirected_factor_model <- function( #' @rdname sample_edgelist #' @export sample_edgelist.directed_factor_model <- function( - factor_model, - ...) { - + factor_model, + ...) { X <- factor_model$X S <- factor_model$S Y <- factor_model$Y @@ -250,12 +248,11 @@ sample_edgelist.directed_factor_model <- function( #' sample_edgelist(X, S, Y, TRUE, TRUE, TRUE) #' sample_edgelist.matrix <- function( - factor_model, S, Y, - directed, - poisson_edges, - allow_self_loops, - ...) { - + factor_model, S, Y, + directed, + poisson_edges, + allow_self_loops, + ...) { X <- factor_model stopifnot(is.logical(directed)) @@ -306,7 +303,6 @@ sample_edgelist.matrix <- function( for (u in 1:k1) { if (u_block_sizes[u] > 0) { - indices <- u_block_start:(u_block_start + u_block_sizes[u] - 1) # the prob argument should be \tilde X from the paper, but \tilde X @@ -329,7 +325,6 @@ sample_edgelist.matrix <- function( for (v in 1:k2) { if (v_block_sizes[v] > 0) { - indices <- v_block_start:(v_block_start + v_block_sizes[v] - 1) # note same lack of \tilde Y as in the X/U case @@ -360,9 +355,7 @@ sample_edgelist.matrix <- function( for (u in 1:k1) { for (v in 1:k2) { - if (block_sizes[u, v] > 0) { - to_index <- u_block_start:(u_block_start + block_sizes[u, v] - 1) tmp_index <- v_block_start[v]:(v_block_start[v] + block_sizes[u, v] - 1) @@ -377,7 +370,6 @@ sample_edgelist.matrix <- function( if (directed) { edgelist <- tibble(from = from, to = to) } else { - # in the undirected case, sort the indices so that the *directed* # representations lives all in the same triangle (upper or lower i # didn't work it out) @@ -394,7 +386,6 @@ sample_edgelist.matrix <- function( } if (!poisson_edges) { - # need to deduplicate edgelist. the number of times a given # (to, from) pair appears in the edgelist is the weight of # that edge (i.e. we're really working with a multigraph) @@ -412,5 +403,3 @@ sample_edgelist.matrix <- function( #' @rdname sample_edgelist.matrix #' @export sample_edgelist.Matrix <- sample_edgelist.matrix - - diff --git a/R/sample_igraph.R b/R/sample_igraph.R index c0f85b6..11a2104 100644 --- a/R/sample_igraph.R +++ b/R/sample_igraph.R @@ -25,9 +25,8 @@ #' @family samplers #' sample_igraph <- function( - factor_model, - ...) { - + factor_model, + ...) { ellipsis::check_dots_unnamed() if (!(requireNamespace("igraph", quietly = TRUE))) { @@ -44,9 +43,8 @@ sample_igraph <- function( #' @rdname sample_igraph #' @export sample_igraph.undirected_factor_model <- function( - factor_model, - ...) { - + factor_model, + ...) { edgelist <- sample_edgelist(factor_model, ...) nodes <- tibble(name = 1:nrow(factor_model$X)) igraph::graph_from_data_frame(edgelist, directed = FALSE, vertices = nodes) @@ -55,9 +53,8 @@ sample_igraph.undirected_factor_model <- function( #' @rdname sample_igraph #' @export sample_igraph.directed_factor_model <- function( - factor_model, - ...) { - + factor_model, + ...) { if (factor_model$n == factor_model$d) { edgelist <- sample_edgelist(factor_model, ...) nodes <- tibble(name = 1:nrow(factor_model$X)) diff --git a/R/sample_sparse.R b/R/sample_sparse.R index ae575a6..a63c885 100644 --- a/R/sample_sparse.R +++ b/R/sample_sparse.R @@ -22,8 +22,8 @@ #' @family samplers #' sample_sparse <- function( - factor_model, - ...) { + factor_model, + ...) { ellipsis::check_dots_unnamed() UseMethod("sample_sparse") } @@ -31,9 +31,8 @@ sample_sparse <- function( #' @rdname sample_sparse #' @export sample_sparse.undirected_factor_model <- function( - factor_model, - ...) { - + factor_model, + ...) { # to construct a symmetric sparseMatrix, we only pass in elements # of either the upper or lower diagonal (otherwise we'll get an error) # so we're going to sample as we want a directed graph, and then @@ -45,11 +44,11 @@ sample_sparse.undirected_factor_model <- function( el <- sample_edgelist(factor_model, ...) n <- factor_model$n - if (nrow(el) == 0) + if (nrow(el) == 0) { return(sparseMatrix(1:n, 1:n, x = 0, dims = c(n, n))) + } if (factor_model$poisson_edges) { - # NOTE: x = 1 is correct to create a multigraph adjacency matrix # here. see ?Matrix::sparseMatrix for details, in particular the # documentation for arguments `i, j` and `x` @@ -91,19 +90,18 @@ sample_sparse.undirected_factor_model <- function( #' @rdname sample_sparse #' @export sample_sparse.directed_factor_model <- function( - factor_model, - ...) { - + factor_model, + ...) { edgelist <- sample_edgelist(factor_model, ...) n <- factor_model$n d <- factor_model$d - if (nrow(edgelist) == 0) + if (nrow(edgelist) == 0) { return(sparseMatrix(1:n, 1:d, x = 0, dims = c(n, d))) + } if (factor_model$poisson_edges) { - # NOTE: x = 1 is correct to create a multigraph adjacency matrix # here. see ?Matrix::sparseMatrix for details, in particular the # documentation for arguments `i, j` and `x` @@ -115,7 +113,6 @@ sample_sparse.directed_factor_model <- function( dims = c(n, d), symmetric = FALSE ) - } else { A <- sparseMatrix( edgelist$from, diff --git a/R/sample_tidygraph.R b/R/sample_tidygraph.R index b966b6b..c041b35 100644 --- a/R/sample_tidygraph.R +++ b/R/sample_tidygraph.R @@ -25,9 +25,8 @@ #' @family samplers #' sample_tidygraph <- function( - factor_model, - ...) { - + factor_model, + ...) { ellipsis::check_dots_unnamed() if (!(requireNamespace("tidygraph", quietly = TRUE))) { @@ -44,8 +43,8 @@ sample_tidygraph <- function( #' @rdname sample_tidygraph #' @export sample_tidygraph.undirected_factor_model <- function( - factor_model, - ...) { + factor_model, + ...) { ig <- sample_igraph(factor_model, ...) tidygraph::as_tbl_graph(ig, directed = FALSE) } @@ -53,8 +52,8 @@ sample_tidygraph.undirected_factor_model <- function( #' @rdname sample_tidygraph #' @export sample_tidygraph.directed_factor_model <- function( - factor_model, - ...) { + factor_model, + ...) { ig <- sample_igraph(factor_model, ...) tidygraph::as_tbl_graph(ig, directed = TRUE) } diff --git a/R/undirected_chung_lu.R b/R/undirected_chung_lu.R index a2aa334..b9dc33c 100644 --- a/R/undirected_chung_lu.R +++ b/R/undirected_chung_lu.R @@ -59,19 +59,17 @@ #' edgelist #' chung_lu <- function( - n = NULL, theta = NULL, - ..., - sort_nodes = TRUE, - poisson_edges = TRUE, - allow_self_loops = TRUE, - force_identifiability = FALSE) { - + n = NULL, theta = NULL, + ..., + sort_nodes = TRUE, + poisson_edges = TRUE, + allow_self_loops = TRUE, + force_identifiability = FALSE) { ### degree heterogeneity parameters if (is.null(n) && is.null(theta)) { stop("Must specify either `n` or `theta`.", call. = FALSE) } else if (is.null(theta)) { - if (n < 1) { stop("`n` must be a positive integer.", call. = FALSE) } @@ -106,7 +104,6 @@ chung_lu <- function( #' @method print undirected_chung_lu #' @export print.undirected_chung_lu <- function(x, ...) { - cat(glue("Undirected Chung-Lu Graph\n", .trim = FALSE)) cat(glue("-------------------------------------------------\n\n", .trim = FALSE)) diff --git a/R/undirected_dcsbm.R b/R/undirected_dcsbm.R index 55ddfaa..cc5f334 100644 --- a/R/undirected_dcsbm.R +++ b/R/undirected_dcsbm.R @@ -1,11 +1,11 @@ new_undirected_dcsbm <- function( - X, S, - theta, - z, - pi, - sorted, - ..., - subclass = character()) { + X, S, + theta, + z, + pi, + sorted, + ..., + subclass = character()) { subclass <- c(subclass, "undirected_dcsbm") dcsbm <- undirected_factor_model(X, S, ..., subclass = subclass) dcsbm$theta <- theta @@ -16,7 +16,6 @@ new_undirected_dcsbm <- function( } validate_undirected_dcsbm <- function(x) { - values <- unclass(x) if (!is.factor(values$z)) { @@ -51,8 +50,8 @@ validate_undirected_dcsbm <- function(x) { if (length(levels(values$z)) != values$k) { stop( - "The number of levels of `z` must match the rank of the model.", - call. = FALSE + "The number of levels of `z` must match the rank of the model.", + call. = FALSE ) } @@ -248,21 +247,19 @@ validate_undirected_dcsbm <- function(x) { #' population_eigs <- eigs_sym(custom_dcsbm) #' dcsbm <- function( - n = NULL, theta = NULL, - k = NULL, B = NULL, - ..., - pi = rep(1 / k, k), - sort_nodes = TRUE, - force_identifiability = FALSE, - poisson_edges = TRUE, - allow_self_loops = TRUE) { - + n = NULL, theta = NULL, + k = NULL, B = NULL, + ..., + pi = rep(1 / k, k), + sort_nodes = TRUE, + force_identifiability = FALSE, + poisson_edges = TRUE, + allow_self_loops = TRUE) { ### degree heterogeneity parameters if (is.null(n) && is.null(theta)) { stop("Must specify either `n` or `theta`.", call. = FALSE) } else if (is.null(theta)) { - if (n < 1) { stop("`n` must be a positive integer.", call. = FALSE) } @@ -283,7 +280,6 @@ dcsbm <- function( if (is.null(k) && is.null(B)) { stop("Must specify either `k` or `B`.", call. = FALSE) } else if (is.null(B)) { - if (k < 1) { stop("`k` must be a positive integer.", call. = FALSE) } @@ -295,9 +291,7 @@ dcsbm <- function( ) B <- matrix(data = stats::runif(k * k), nrow = k, ncol = k) - } else if (is.null(k)) { - if (nrow(B) != ncol(B)) { stop("`B` must be a square matrix.", call. = FALSE) } @@ -335,7 +329,7 @@ dcsbm <- function( } if (k > 1) { - X <- sparse.model.matrix(~z + 0) + X <- sparse.model.matrix(~ z + 0) } else { X <- Matrix(1, nrow = n, ncol = 1) } @@ -375,7 +369,6 @@ dcsbm <- function( #' @method print undirected_dcsbm #' @export print.undirected_dcsbm <- function(x, ...) { - cat(glue("Undirected Degree-Corrected Stochastic Blockmodel\n", .trim = FALSE)) cat(glue("-------------------------------------------------\n\n", .trim = FALSE)) diff --git a/R/undirected_erdos_renyi.R b/R/undirected_erdos_renyi.R index 7dfa5fb..329d589 100644 --- a/R/undirected_erdos_renyi.R +++ b/R/undirected_erdos_renyi.R @@ -8,7 +8,6 @@ new_undirected_erdos_renyi <- function(X, S, p, ...) { } validate_undirected_erdos_renyi <- function(x) { - values <- unclass(x) if (ncol(values$X) != 1) { @@ -55,10 +54,9 @@ validate_undirected_erdos_renyi <- function(x) { #' A #' erdos_renyi <- function( - n, ..., p = NULL, - poisson_edges = TRUE, - allow_self_loops = TRUE) { - + n, ..., p = NULL, + poisson_edges = TRUE, + allow_self_loops = TRUE) { X <- Matrix(1, nrow = n, ncol = 1) if (is.null(p) && is.null(expected_degree)) { @@ -66,13 +64,15 @@ erdos_renyi <- function( } if (is.null(p)) { - p <- 0.5 # doesn't matter, will get rescaled anyway + p <- 0.5 # doesn't matter, will get rescaled anyway } B <- matrix(p) - er <- new_undirected_erdos_renyi(X, B, p = p, ..., - poisson_edges = poisson_edges, - allow_self_loops = allow_self_loops) + er <- new_undirected_erdos_renyi(X, B, + p = p, ..., + poisson_edges = poisson_edges, + allow_self_loops = allow_self_loops + ) validate_undirected_erdos_renyi(er) } diff --git a/R/undirected_factor_model.R b/R/undirected_factor_model.R index 6f43791..52c09a6 100644 --- a/R/undirected_factor_model.R +++ b/R/undirected_factor_model.R @@ -1,10 +1,9 @@ new_undirected_factor_model <- function( - X, S, - ..., - poisson_edges = TRUE, - allow_self_loops = TRUE, - subclass = character()) { - + X, S, + ..., + poisson_edges = TRUE, + allow_self_loops = TRUE, + subclass = character()) { ellipsis::check_dots_unnamed() n <- nrow(X) @@ -24,7 +23,6 @@ new_undirected_factor_model <- function( } validate_undirected_factor_model <- function(x) { - values <- unclass(x) if (any(values$X < 0) || any(values$S < 0)) { @@ -145,13 +143,12 @@ validate_undirected_factor_model <- function(x) { #' svds(ufm2) #' undirected_factor_model <- function( - X, S, - ..., - expected_degree = NULL, - expected_density = NULL, - poisson_edges = TRUE, - allow_self_loops = TRUE) { - + X, S, + ..., + expected_degree = NULL, + expected_density = NULL, + poisson_edges = TRUE, + allow_self_loops = TRUE) { X <- Matrix(X) S <- Matrix(S) @@ -163,13 +160,13 @@ undirected_factor_model <- function( } ufm <- new_undirected_factor_model(X, S, ..., - poisson_edges = poisson_edges, - allow_self_loops = allow_self_loops) + poisson_edges = poisson_edges, + allow_self_loops = allow_self_loops + ) - ufm$S <- (S + t(S)) / 2 # symmetrize S. idempotent if S already symmetric + ufm$S <- (S + t(S)) / 2 # symmetrize S. idempotent if S already symmetric if (!is.null(expected_degree)) { - if (expected_degree <= 0) { stop( "`expected_degree` must be strictly greater than zero.", @@ -181,7 +178,6 @@ undirected_factor_model <- function( } if (!is.null(expected_density)) { - if (expected_density <= 0 || 1 <= expected_density) { stop( "`expected_density` must be strictly between zero and one.", @@ -193,7 +189,6 @@ undirected_factor_model <- function( } if (!poisson_edges) { - # when poisson_edges = FALSE, S is the desired Bernoulli edge probability. # we must # back-transform it to a Poisson parameterization of S. see section 2.3 @@ -214,17 +209,16 @@ undirected_factor_model <- function( } dim_and_class <- function(x, ...) { - - if (is.matrix(x) || inherits(x, "Matrix")) + if (is.matrix(x) || inherits(x, "Matrix")) { paste0(nrow(x), " x ", ncol(x), " [", class(x)[1], "]") - else + } else { paste0(length(x), " [", class(x)[1], "]") + } } #' @method print undirected_factor_model #' @export print.undirected_factor_model <- function(x, ...) { - cat(glue("Undirected Factor Model\n", .trim = FALSE)) cat(glue("-----------------------\n\n", .trim = FALSE)) @@ -241,4 +235,3 @@ print.undirected_factor_model <- function(x, ...) { cat(glue("Expected degree: {round(expected_degree(x), 1)}\n", .trim = FALSE)) cat(glue("Expected density: {round(expected_density(x), 5)}", .trim = FALSE)) } - diff --git a/R/undirected_mmsbm.R b/R/undirected_mmsbm.R index baa83cd..7cea439 100644 --- a/R/undirected_mmsbm.R +++ b/R/undirected_mmsbm.R @@ -1,5 +1,4 @@ validate_undirected_mmsbm <- function(x) { - values <- unclass(x) if (!is.numeric(values$theta)) { @@ -43,7 +42,6 @@ new_undirected_mmsbm <- function( sorted, ..., subclass = character()) { - subclass <- c(subclass, "undirected_mmsbm") mmsbm <- undirected_factor_model(X, S, ..., subclass = subclass) mmsbm$theta <- theta @@ -191,13 +189,11 @@ mmsbm <- function( force_pure = TRUE, poisson_edges = TRUE, allow_self_loops = TRUE) { - ### degree heterogeneity parameters if (is.null(n) && is.null(theta)) { stop("Must specify either `n` or `theta`.", call. = FALSE) } else if (is.null(theta)) { - if (n < 1) { stop("`n` must be a positive integer.", call. = FALSE) } @@ -218,7 +214,6 @@ mmsbm <- function( if (is.null(k) && is.null(B)) { stop("Must specify either `k` or `B`.", call. = FALSE) } else if (is.null(B)) { - if (k < 1) { stop("`k` must be a positive integer.", call. = FALSE) } @@ -230,9 +225,7 @@ mmsbm <- function( ) B <- matrix(data = stats::runif(k * k), nrow = k, ncol = k) - } else if (is.null(k)) { - if (nrow(B) != ncol(B)) { stop("`B` must be a square matrix.", call. = FALSE) } @@ -293,7 +286,6 @@ mmsbm <- function( #' @method print undirected_mmsbm #' @export print.undirected_mmsbm <- function(x, ...) { - cat(glue("Undirected Degree-Corrected Mixed Membership Stochastic Blockmodel\n", .trim = FALSE)) cat(glue("------------------------------------------------------------------\n\n", .trim = FALSE)) diff --git a/R/undirected_overlapping_sbm.R b/R/undirected_overlapping_sbm.R index d7293af..c8a4b62 100644 --- a/R/undirected_overlapping_sbm.R +++ b/R/undirected_overlapping_sbm.R @@ -18,7 +18,6 @@ new_undirected_overlapping_sbm <- function( } validate_undirected_overlapping_sbm <- function(x) { - values <- unclass(x) if (any(values$pi < 0) || any(values$pi > 1)) { @@ -207,13 +206,11 @@ overlapping_sbm <- function( force_pure = TRUE, poisson_edges = TRUE, allow_self_loops = TRUE) { - ### mixing matrix if (is.null(k) && is.null(B)) { stop("Must specify either `k` or `B`.", call. = FALSE) } else if (is.null(B)) { - if (k < 1) { stop("`k` must be a positive integer.", call. = FALSE) } @@ -226,9 +223,7 @@ overlapping_sbm <- function( B <- matrix(0.1 / (k - 1), nrow = k, ncol = k) diag(B) <- 0.8 - } else if (is.null(k)) { - if (nrow(B) != ncol(B)) { stop("`B` must be a square matrix.", call. = FALSE) } @@ -280,7 +275,7 @@ overlapping_sbm <- function( overlapping_sbm <- new_undirected_overlapping_sbm( X = X, - S = B, # accepts B but transforms by symmetrizing and scaling internally + S = B, # accepts B but transforms by symmetrizing and scaling internally B = B, Z = X, pi = pi, @@ -296,7 +291,6 @@ overlapping_sbm <- function( #' @method print undirected_overlapping_sbm #' @export print.undirected_overlapping_sbm <- function(x, ...) { - cat(glue("Undirected Degree-Corrected Overlapping Blockmodel\n", .trim = FALSE)) cat(glue("-------------------------------------------------\n\n", .trim = FALSE)) diff --git a/R/undirected_planted_partition.R b/R/undirected_planted_partition.R index 2487fdb..1b3bfe0 100644 --- a/R/undirected_planted_partition.R +++ b/R/undirected_planted_partition.R @@ -1,5 +1,4 @@ validate_undirected_planted_partition <- function(x) { - values <- unclass(x) if (!inherits(x, "undirected_planted_partition")) { @@ -121,18 +120,17 @@ validate_undirected_planted_partition <- function(x) { #' lazy_pp #' planted_partition <- function( - n, - k, - ..., - within_block = NULL, - between_block = NULL, - a = NULL, - b = NULL, - pi = rep(1 / k, k), - sort_nodes = TRUE, - poisson_edges = TRUE, - allow_self_loops = TRUE) { - + n, + k, + ..., + within_block = NULL, + between_block = NULL, + a = NULL, + b = NULL, + pi = rep(1 / k, k), + sort_nodes = TRUE, + poisson_edges = TRUE, + allow_self_loops = TRUE) { if (is.null(within_block)) { within_block <- a / n } @@ -165,7 +163,6 @@ planted_partition <- function( #' @method print undirected_planted_partition #' @export print.undirected_planted_partition <- function(x, ...) { - cat(glue("Undirected Planted Partition Model\n", .trim = FALSE)) cat(glue("----------------------------------\n\n", .trim = FALSE)) diff --git a/R/undirected_sbm.R b/R/undirected_sbm.R index e66fd4b..c5d4f12 100644 --- a/R/undirected_sbm.R +++ b/R/undirected_sbm.R @@ -1,6 +1,4 @@ - validate_undirected_sbm <- function(x) { - values <- unclass(x) if (!inherits(x, "undirected_sbm")) { @@ -85,14 +83,13 @@ validate_undirected_sbm <- function(x) { #' sign(A) #' sbm <- function( - n, - k = NULL, B = NULL, - ..., - pi = rep(1 / k, k), - sort_nodes = TRUE, - poisson_edges = TRUE, - allow_self_loops = TRUE) { - + n, + k = NULL, B = NULL, + ..., + pi = rep(1 / k, k), + sort_nodes = TRUE, + poisson_edges = TRUE, + allow_self_loops = TRUE) { sbm <- dcsbm( n = n, theta = rep(1, n), @@ -113,7 +110,6 @@ sbm <- function( #' @method print undirected_sbm #' @export print.undirected_sbm <- function(x, ...) { - cat(glue("Undirected Stochastic Blockmodel\n", .trim = FALSE)) cat(glue("--------------------------------\n\n", .trim = FALSE)) diff --git a/R/utils.R b/R/utils.R index 247094b..ecfe976 100644 --- a/R/utils.R +++ b/R/utils.R @@ -7,7 +7,7 @@ sort_by_all_columns <- function(X) { args <- as.list(as.data.frame(as.matrix(X))) args$decreasing <- TRUE - X <- X[do.call(order, args),] + X <- X[do.call(order, args), ] X } diff --git a/README.Rmd b/README.Rmd index 659c064..019df69 100644 --- a/README.Rmd +++ b/README.Rmd @@ -87,7 +87,7 @@ Note that every time we call `sample_*()` we draw a new sample. A <- sample_sparse(sbm) B <- sample_sparse(sbm) -all(A == B) # random realizations from the SBM don't match! +all(A == B) # random realizations from the SBM don't match! ``` ## Efficient spectral decompositions diff --git a/README.md b/README.md index 85394f0..c460550 100644 --- a/README.md +++ b/README.md @@ -145,9 +145,9 @@ or an igraph object ``` r sample_igraph(sbm) -#> IGRAPH 49b52e2 UN-- 1000 5033 -- +#> IGRAPH be5b840 UN-- 1000 5033 -- #> + attr: name (v/c) -#> + edges from 49b52e2 (vertex names): +#> + edges from be5b840 (vertex names): #> [1] 63 --76 135--215 59 --182 21 --134 180--218 53 --189 138--139 21 --78 #> [9] 49 --70 76 --127 6 --139 64 --214 31 --132 56 --93 75 --144 9 --185 #> [17] 33 --150 115--165 163--213 6 --53 47 --179 25 --26 7 --51 10 --55 @@ -165,7 +165,7 @@ Note that every time we call `sample_*()` we draw a new sample. A <- sample_sparse(sbm) B <- sample_sparse(sbm) -all(A == B) # random realizations from the SBM don't match! +all(A == B) # random realizations from the SBM don't match! #> [1] FALSE ``` diff --git a/man/sample_igraph.Rd b/man/sample_igraph.Rd index c2615d2..99b7234 100644 --- a/man/sample_igraph.Rd +++ b/man/sample_igraph.Rd @@ -166,8 +166,8 @@ Journal of Machine Learning Research; 19(77):1-13, 2018. } \seealso{ Other samplers: -\code{\link{sample_edgelist.matrix}()}, \code{\link{sample_edgelist}()}, +\code{\link{sample_edgelist.matrix}()}, \code{\link{sample_sparse}()}, \code{\link{sample_tidygraph}()} } diff --git a/man/sample_sparse.Rd b/man/sample_sparse.Rd index 3d30116..02a4eae 100644 --- a/man/sample_sparse.Rd +++ b/man/sample_sparse.Rd @@ -160,8 +160,8 @@ Journal of Machine Learning Research; 19(77):1-13, 2018. } \seealso{ Other samplers: -\code{\link{sample_edgelist.matrix}()}, \code{\link{sample_edgelist}()}, +\code{\link{sample_edgelist.matrix}()}, \code{\link{sample_igraph}()}, \code{\link{sample_tidygraph}()} } diff --git a/man/sample_tidygraph.Rd b/man/sample_tidygraph.Rd index ff2537b..9ae36dc 100644 --- a/man/sample_tidygraph.Rd +++ b/man/sample_tidygraph.Rd @@ -166,8 +166,8 @@ Journal of Machine Learning Research; 19(77):1-13, 2018. } \seealso{ Other samplers: -\code{\link{sample_edgelist.matrix}()}, \code{\link{sample_edgelist}()}, +\code{\link{sample_edgelist.matrix}()}, \code{\link{sample_igraph}()}, \code{\link{sample_sparse}()} } diff --git a/tests/testthat/test-allow_self_loops.R b/tests/testthat/test-allow_self_loops.R index d48a519..5367283 100644 --- a/tests/testthat/test-allow_self_loops.R +++ b/tests/testthat/test-allow_self_loops.R @@ -1,7 +1,6 @@ library(igraph) test_that("undirected graphs allow_self_loops = FALSE", { - set.seed(1) n <- 1000 @@ -16,7 +15,7 @@ test_that("undirected graphs allow_self_loops = FALSE", { allow_self_loops = FALSE ) - edgelist <- sample_edgelist(ufm,) + edgelist <- sample_edgelist(ufm, ) expect_false(any(edgelist$from == edgelist$to)) A <- sample_sparse(ufm) @@ -32,7 +31,6 @@ test_that("undirected graphs allow_self_loops = FALSE", { }) test_that("directed graphs allow_self_loops = FALSE", { - set.seed(2) n2 <- 1000 diff --git a/tests/testthat/test-degree-scaling.R b/tests/testthat/test-degree-scaling.R index c9da969..5dbaf1f 100644 --- a/tests/testthat/test-degree-scaling.R +++ b/tests/testthat/test-degree-scaling.R @@ -26,7 +26,6 @@ test_that("expected_degrees() has dimension and correctness", { test_that("undirected expected degree computed consistently", { - # see issue 19 set.seed(27) @@ -45,7 +44,7 @@ test_that("undirected expected degree computed consistently", { expect_equal( expected_degree(b_model), # computed - pop * a + pop * b, # expected "undirected edge degree", + pop * a + pop * b, # expected "undirected edge degree", tolerance = 5 ) @@ -53,14 +52,14 @@ test_that("undirected expected degree computed consistently", { ### degree computation gotchas - mean(rowSums(A)) # double counts undirected edges + mean(rowSums(A)) # double counts undirected edges #> [1] 156.711 - mean(rowSums(triu(A))) # right way to count undirected edges in A + mean(rowSums(triu(A))) # right way to count undirected edges in A #> [1] 78.413 expect_equal( mean(rowSums(triu(A))), # computed - pop * a + pop * b, # expected "undirected edge degree" + pop * a + pop * b, # expected "undirected edge degree" tolerance = 5 ) @@ -68,7 +67,7 @@ test_that("undirected expected degree computed consistently", { expect_equal( expected_degree(model2), # computed - pop * a + pop * b, # expected "undirected edge degree", + pop * a + pop * b, # expected "undirected edge degree", tolerance = 5 ) @@ -76,14 +75,12 @@ test_that("undirected expected degree computed consistently", { expect_equal( mean(rowSums(triu(A2))), # computed - pop * a + pop * b, # expected "undirected edge degree", + pop * a + pop * b, # expected "undirected edge degree", tolerance = 5 ) - }) test_that("undirected density computed consistently", { - # see issue 19 set.seed(27) @@ -101,7 +98,7 @@ test_that("undirected density computed consistently", { ) expect_equal( - expected_density(b_model), # computed + expected_density(b_model), # computed n * (pop * a + pop * b) / choose(n, 2), # expected undirected degree density, possibly being a little sloppy about the diagonal tolerance = 0.05 ) @@ -114,10 +111,10 @@ test_that("undirected density computed consistently", { # but diagonal gets too much weight. slight over-estimate of density sum(A) / n^2 - sum(triu(A)) / choose(n, 2) # correct density estimate + sum(triu(A)) / choose(n, 2) # correct density estimate expect_equal( - sum(triu(A)) / choose(n, 2), # computed + sum(triu(A)) / choose(n, 2), # computed n * (pop * a + pop * b) / choose(n, 2), # expected "undirected edge degree", tolerance = 0.05 ) @@ -125,7 +122,7 @@ test_that("undirected density computed consistently", { model2 <- sbm(n = n, k = 2, B = B, expected_density = 0.15) expect_equal( - expected_density(model2), # computed + expected_density(model2), # computed n * (pop * a + pop * b) / choose(n, 2), # expected undirected degree density, possibly being a little sloppy about the diagonal tolerance = 0.02 ) @@ -133,15 +130,13 @@ test_that("undirected density computed consistently", { A2 <- sample_sparse(model2) expect_equal( - sum(triu(A2)) / choose(n, 2), # computed + sum(triu(A2)) / choose(n, 2), # computed 0.15, # expected "undirected edge degree", tolerance = 0.05 ) - }) test_that("undirected factor model", { - library(tidygraph) set.seed(7) @@ -204,7 +199,6 @@ test_that("undirected factor model", { }) test_that("directed factor model", { - set.seed(8) library(dplyr) diff --git a/tests/testthat/test-directedness.R b/tests/testthat/test-directedness.R index 0593751..81c37a2 100644 --- a/tests/testthat/test-directedness.R +++ b/tests/testthat/test-directedness.R @@ -1,7 +1,6 @@ library(igraph) test_that("undirected graphs are undirected", { - set.seed(3) n <- 1000 @@ -31,7 +30,6 @@ test_that("undirected graphs are undirected", { }) test_that("directed graphs are directed", { - set.seed(4) n2 <- 1000 diff --git a/tests/testthat/test-poisson_edges.R b/tests/testthat/test-poisson_edges.R index 48f5e80..6b1d4e4 100644 --- a/tests/testthat/test-poisson_edges.R +++ b/tests/testthat/test-poisson_edges.R @@ -2,7 +2,6 @@ library(igraph) library(magrittr) test_that("undirected graphs poisson_edges = FALSE", { - set.seed(6) library(dplyr) @@ -40,7 +39,6 @@ test_that("undirected graphs poisson_edges = FALSE", { }) test_that("directed graphs poisson_edges = FALSE", { - set.seed(7) library(dplyr) diff --git a/tests/testthat/test-retain-isolated-nodes.R b/tests/testthat/test-retain-isolated-nodes.R index 8c8d465..e39af49 100644 --- a/tests/testthat/test-retain-isolated-nodes.R +++ b/tests/testthat/test-retain-isolated-nodes.R @@ -1,5 +1,4 @@ test_that("sampling from undirected factor models doesn't drop isolated nodes", { - set.seed(27) latent <- sbm( @@ -18,7 +17,7 @@ test_that("sampling from undirected factor models doesn't drop isolated nodes", el <- sample_edgelist(latent) expect_lte( - length(unique(el$from)), # not n! and that's okay!, + length(unique(el$from)), # not n! and that's okay!, 10000 ) @@ -48,11 +47,9 @@ test_that("sampling from undirected factor models doesn't drop isolated nodes", igraph::vcount(tbl_graph), 10000 ) - }) test_that("sampling from square directed factor models doesn't drop isolated nodes", { - set.seed(32) bm <- as.matrix(cbind( @@ -79,7 +76,7 @@ test_that("sampling from square directed factor models doesn't drop isolated nod el <- sample_edgelist(latent) expect_lte( - length(unique(c(el$from, el$to))), # not n! and that's okay!, + length(unique(c(el$from, el$to))), # not n! and that's okay!, 200 ) @@ -113,7 +110,6 @@ test_that("sampling from square directed factor models doesn't drop isolated nod test_that("sampling from rectangular directed factor models doesn't drop isolated nodes", { - n <- 10000 k1 <- 5 @@ -134,13 +130,13 @@ test_that("sampling from rectangular directed factor models doesn't drop isolate # nodes with out-degree > 0 expect_lte( - length(unique(el$from)), # not n! and that's okay!, + length(unique(el$from)), # not n! and that's okay!, n ) # nodes with in-degree > 0 expect_lte( - length(unique(el$to)), # not d! and that's okay!, + length(unique(el$to)), # not d! and that's okay!, d ) @@ -196,5 +192,4 @@ test_that("sampling from rectangular directed factor models doesn't drop isolate sum(igraph::V(tbl_graph)$type), d ) - }) diff --git a/tests/testthat/test-undirected-overlapping-sbms.R b/tests/testthat/test-undirected-overlapping-sbms.R index 38e0d17..080145e 100644 --- a/tests/testthat/test-undirected-overlapping-sbms.R +++ b/tests/testthat/test-undirected-overlapping-sbms.R @@ -1,5 +1,4 @@ test_that("rank 1 overlapping sbms sample", { - set.seed(27) n <- 10 @@ -12,5 +11,3 @@ test_that("rank 1 overlapping sbms sample", { expect_silent(A <- sample_sparse(sbm)) }) - - diff --git a/tests/testthat/test-undirected-sbms.R b/tests/testthat/test-undirected-sbms.R index 7a8d473..21328ae 100644 --- a/tests/testthat/test-undirected-sbms.R +++ b/tests/testthat/test-undirected-sbms.R @@ -1,5 +1,4 @@ test_that("SBMs don't drop isolated nodes", { - set.seed(27) n <- 10 @@ -17,7 +16,6 @@ test_that("SBMs don't drop isolated nodes", { }) test_that("rank 1 sbms sample", { - set.seed(27) n <- 10 @@ -30,5 +28,3 @@ test_that("rank 1 sbms sample", { expect_silent(A <- sample_sparse(sbm)) }) - -