diff --git a/DESCRIPTION b/DESCRIPTION index a4aef212..1303ba86 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: migraph Title: Inferential Methods for Multimodal and Other Networks -Version: 1.6.7 +Version: 1.6.8 Description: A set of tools for testing networks. It includes functions for univariate and multivariate conditional uniform graph and quadratic assignment procedure testing, and network regression. diff --git a/NAMESPACE b/NAMESPACE index 2026f1cd..ff838e49 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -34,9 +34,7 @@ export(test_permutation) export(test_random) export(tidy) importFrom(autograph,ag_base) -importFrom(dplyr,"%>%") importFrom(dplyr,as_tibble) -importFrom(dplyr,bind_cols) importFrom(dplyr,left_join) importFrom(dplyr,select) importFrom(dplyr,tibble) diff --git a/NEWS.md b/NEWS.md index 6c33a199..653d3b8c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,21 @@ +# migraph 1.6.8 + +2026-07-31 + +## Package + +- Replaced all remaining uses of the magrittr pipe `%>%` with the native pipe `|>`, in package code, tests, examples, and tutorials + - This fixes the `predict()`, `net_regression()`, and `test_*()` examples, which still called `%>%` after the re-export was removed in 1.6.3 and so were relying on `{dplyr}` being attached + - `%>%` is no longer imported from `{dplyr}` + - The pipes section of tutorial0 now teaches `|>` only, noting `%>%` as something readers may encounter in older code + +## Models + +- Substantially accelerated `net_regression()` (by about 35x), resolving the CRAN NOTE about the running time of the `predict()` examples + - Permutations now operate directly on the matrices rather than coercing to and from a network object each time, deferring to `manynet::to_permuted()` again once manynet gains a method for matrix input + - Vectorising the matrix list for each fit now uses base operations rather than constructing a data frame + - Results are unchanged: for a given seed, the same permutations are drawn and the same coefficients, test statistics, and p-values are returned + # migraph 1.6.7 2026-07-31 diff --git a/R/class_makes.R b/R/class_makes.R index 95478c59..b16aa076 100644 --- a/R/class_makes.R +++ b/R/class_makes.R @@ -1,6 +1,6 @@ make_network_measures <- function(out, .data) { - out <- dplyr::as_tibble(out) %>% - dplyr::mutate(time = as.numeric(names(out))) %>% + out <- dplyr::as_tibble(out) |> + dplyr::mutate(time = as.numeric(names(out))) |> dplyr::select(time, value) class(out) <- c("network_measures", class(out)) attr(out, "mode") <- manynet::net_dims(.data) @@ -15,8 +15,8 @@ make_diffs_model <- function(report, .data) { #' @export summary.diffs_model <- function(object, ...) { - object %>% dplyr::mutate(fin = (I!=n)*1) %>% - dplyr::group_by(sim) %>% dplyr::summarise(toa = sum(fin)+1) + object |> dplyr::mutate(fin = (I!=n)*1) |> + dplyr::group_by(sim) |> dplyr::summarise(toa = sum(fin)+1) } #' @export diff --git a/R/class_models.R b/R/class_models.R index 13a82ddb..00c31507 100644 --- a/R/class_models.R +++ b/R/class_models.R @@ -63,8 +63,8 @@ tidy.ergm <- function( # in ergm 3.10 summary(x, ...)$coefs has columns: # Estimate, Std. Error, MCMC %, z value, Pr(>|Z|) - ret <- summary(x, ...)$coefficients %>% - dplyr::as_tibble(rownames = "term") %>% + ret <- summary(x, ...)$coefficients |> + dplyr::as_tibble(rownames = "term") |> rename2( term = "term", estimate = "Estimate", @@ -305,10 +305,10 @@ rename2 <- function(.data, ...) { } exponentiate <- function(data, col = "estimate") { - data <- data %>% dplyr::mutate(dplyr::across(dplyr::all_of(col), exp)) + data <- data |> dplyr::mutate(dplyr::across(dplyr::all_of(col), exp)) if ("conf.low" %in% colnames(data)) { - data <- data %>% dplyr::mutate(dplyr::across(c(conf.low, conf.high), exp)) + data <- data |> dplyr::mutate(dplyr::across(c(conf.low, conf.high), exp)) } data diff --git a/R/model_distrib.R b/R/model_distrib.R index a79365f8..4b47fabc 100644 --- a/R/model_distrib.R +++ b/R/model_distrib.R @@ -59,7 +59,7 @@ test_fit <- function(diff_model, diff_models){ # make into method? x <- diff_model if(manynet::is_graph(x)) x <- manynet::as_diffusion(x) y <- diff_models - sims <- y %>% dplyr::select(sim, t, I) + sims <- y |> dplyr::select(sim, t, I) if(max(x$t) < max(sims$t)){ x <- dplyr::mutate(x, t = as.integer(t), S = as.integer(S), I = as.integer(I)) |> dplyr::select(t, S, I) diff --git a/R/model_predict.R b/R/model_predict.R index 956e6c49..e1324335 100644 --- a/R/model_predict.R +++ b/R/model_predict.R @@ -10,9 +10,10 @@ NULL #' @rdname predict #' @method predict netlm #' @examples -#' networkers <- ison_networkers %>% to_subgraph(Discipline == "Sociology") -#' model1 <- net_regression(weight ~ ego(Citations) + alter(Citations) + sim(Citations), +#' networkers <- ison_networkers |> to_subgraph(Discipline == "Sociology") +#' model1 <- net_regression(weight ~ ego(Citations) + alter(Citations) + sim(Citations), #' networkers, times = 20) +#' # Should be run many more `times` for publication-ready results #' predict(model1, matrix(c(1,10,5,2),1,4)) #' @export predict.netlm <- function(object, newdata = NULL, ...) { @@ -43,10 +44,11 @@ predict.netlm <- function(object, newdata = NULL, ...) { #' (default, whether the returned predictions are on the probability scale) #' or "link" (returned predictions are on the scale of the linear predictor). #' @examples -#' networkers <- ison_networkers %>% to_subgraph(Discipline == "Sociology") %>% +#' networkers <- ison_networkers |> to_subgraph(Discipline == "Sociology") |> #' to_unweighted() -#' model1 <- net_regression(. ~ ego(Citations) + alter(Citations) + sim(Citations), +#' model1 <- net_regression(. ~ ego(Citations) + alter(Citations) + sim(Citations), #' networkers, times = 20) +#' # Should be run many more `times` for publication-ready results #' predict(model1, matrix(c(1,10,5,2),1,4)) #' @export predict.netlogit <- function(object, newdata = NULL, type = c("link", "response"), ...) { diff --git a/R/model_regression.R b/R/model_regression.R index 0af2110f..aaf77e81 100644 --- a/R/model_regression.R +++ b/R/model_regression.R @@ -68,7 +68,7 @@ #' @param verbose Whether the function should report on its progress. #' By default FALSE. #' See [`{progressr}`](https://progressr.futureverse.org) for more. -#' @importFrom dplyr bind_cols left_join +#' @importFrom dplyr left_join #' @importFrom purrr flatten #' @importFrom future plan #' @importFrom furrr future_map_dfr furrr_options @@ -85,7 +85,7 @@ #' \doi{10.1007/s11336-007-9016-1}. #' #' @examples -#' networkers <- ison_networkers %>% to_subgraph(Discipline == "Sociology") +#' networkers <- ison_networkers |> to_subgraph(Discipline == "Sociology") #' model1 <- net_regression(weight ~ ego(Citations) + alter(Citations) + sim(Citations), #' networkers, times = 20) #' # Should be run many more `times` for publication-ready results @@ -171,14 +171,14 @@ net_regression <- function(formula, .data, on.exit(future::plan(oplan), add = TRUE) if(valued){ repdist <- furrr::future_map_dfr(1:times, function(j){ - nlmfit(c(list(manynet::to_permuted(g[[1]], with_attr = FALSE)), + nlmfit(c(list(permute_matrix(g[[1]])), g[2:(nx+1)]), directed = directed, diag = diag, rety = FALSE) }, .progress = verbose, .options = furrr::furrr_options(seed = T)) } else { repdist <- furrr::future_map_dfr(1:times, function(j){ - repfit <- nlgfit(c(list(manynet::to_permuted(g[[1]], with_attr = FALSE)), + repfit <- nlgfit(c(list(permute_matrix(g[[1]])), g[2:(nx+1)]), directed = directed, diag = diag) repfit$coef/sqrt(diag(chol2inv(repfit$qr$qr))) @@ -207,14 +207,14 @@ net_regression <- function(formula, .data, if(valued){ repdist[,i] <- furrr::future_map_dbl(1:times, function(j){ nlmfit(c(g[-(1 + i)], - list(manynet::to_permuted(xres, with_attr = FALSE))), + list(permute_matrix(xres))), directed = directed, diag = diag, rety = FALSE)[nx] }, .progress = verbose, .options = furrr::furrr_options(seed = T)) } else { repdist[,i] <- furrr::future_map_dbl(1:times, function(j){ repfit <- nlgfit(c(g[-(1 + i)], - list(manynet::to_permuted(xres, with_attr = FALSE))), + list(permute_matrix(xres))), directed = directed, diag = diag) repfit$coef[nx]/sqrt(diag(chol2inv(repfit$qr$qr)))[nx] }, .progress = verbose, .options = furrr::furrr_options(seed = T)) @@ -283,10 +283,48 @@ vectorise_list <- function(glist, simplex, directed){ diag(glist[[1]]) <- NA if(!directed) glist[[1]][upper.tri(glist[[1]])] <- NA - suppressMessages(stats::na.omit(dplyr::bind_cols(furrr::future_map(glist, - function(x) c(x))))) + # Assembled with base operations rather than a data frame because this is + # called once per permutation, so per-call overhead dominates the QR itself + out <- matrix(unlist(lapply(glist, as.vector), use.names = FALSE), + ncol = length(glist), + dimnames = list(NULL, names(glist))) + out[stats::complete.cases(out), , drop = FALSE] } +# Permutes a matrix as `manynet::to_permuted()` would, but without the +# round-trip coercion to a network object, which dominates the permutation +# loops below. Rows and columns are permuted together for one-mode networks +# and independently for two-mode ones; labels stay put while values move. +# Once manynet gains a `to_permuted()` method for matrix input this shortcut +# is redundant, and we defer to it again. +permute_matrix <- function(m){ + if(manynet_permutes_matrices()) + manynet::to_permuted(m, with_attr = FALSE) + else permute_matrix_directly(m) +} + +permute_matrix_directly <- function(m){ + rows <- sample(seq_len(dim(m)[1])) + cols <- if(manynet::is_twomode(m)) sample(seq_len(dim(m)[2])) else rows + matrix(m[rows, cols], nrow = dim(m)[1], ncol = dim(m)[2], + dimnames = if(manynet::is_labelled(m)) dimnames(m) else NULL) +} + +# Detects the matrix method rather than a manynet version, so that a release +# without it keeps the shortcut instead of silently reverting to the slow +# coercion path. Cached because `permute_matrix()` is called once per +# permutation, and looking the method up each time would reintroduce the +# per-call overhead the shortcut exists to avoid. +manynet_permutes_matrices <- local({ + delegate <- NA + function(){ + if(is.na(delegate)) + delegate <<- !is.null(utils::getS3method("to_permuted", "matrix", + optional = TRUE)) + delegate + } +}) + convertToMatrixList <- function(formula, .data){ data <- manynet::as_tidygraph(.data) if(manynet::is_weighted(data) & getDependentName(formula)=="weight"){ diff --git a/R/model_tests.R b/R/model_tests.R index 0258164c..5b5fda01 100644 --- a/R/model_tests.R +++ b/R/model_tests.R @@ -23,8 +23,8 @@ NULL #' @rdname tests #' @importFrom manynet generate_random bind_node_attributes is_directed is_complex #' @examples -#' marvel_friends <- fict_marvel %>% to_uniplex("relationship") %>% -#' to_unsigned() %>% to_giant() %>% +#' marvel_friends <- fict_marvel |> to_uniplex("relationship") |> +#' to_unsigned() |> to_giant() |> #' to_subgraph(PowerOrigin == "Human") #' (cugtest <- test_random(marvel_friends, net_by_heterophily, attribute = "Attractive", #' times = 200)) diff --git a/R/tutorial_run.R b/R/tutorial_run.R index efad953c..18381806 100644 --- a/R/tutorial_run.R +++ b/R/tutorial_run.R @@ -14,7 +14,7 @@ #' saving the .R script to the current working directory. #' #' @param tute String, name of the tutorial (e.g. "tutorial2"). -#' @importFrom dplyr %>% as_tibble select tibble +#' @importFrom dplyr as_tibble select tibble #' @name tutorials NULL @@ -31,10 +31,10 @@ run_tute <- function(tute) { name = "Checking tutorials in stocnet packages"), function(p){ dplyr::as_tibble(learnr::available_tutorials(package = avail_pkgs[p]), - silent = TRUE) %>% dplyr::select(1:3) + silent = TRUE) |> dplyr::select(1:3) }) - dplyr::bind_rows(tutelist) %>% - dplyr::arrange(dplyr::across(dplyr::any_of("name"))) %>% + dplyr::bind_rows(tutelist) |> + dplyr::arrange(dplyr::across(dplyr::any_of("name"))) |> print() manynet::snet_info("You can run a tutorial by typing e.g `run_tute('tutorial1')` or `run_tute('Data')` into the console.") } else { @@ -46,7 +46,7 @@ run_tute <- function(tute) { tutelist <- lapply(manynet::snet_progress_along(avail_pkgs, name = "Checking tutorials in stocnet packages"), function(p){ dplyr::as_tibble(learnr::available_tutorials(package = avail_pkgs[p]), - silent = TRUE) %>% dplyr::select(1:3) + silent = TRUE) |> dplyr::select(1:3) }) avails <- dplyr::bind_rows(tutelist) inftit <- grepl(tute, avails$title, ignore.case = TRUE) @@ -72,10 +72,10 @@ extract_tute <- function(tute) { tutelist <- lapply(manynet::snet_progress_along(avail_pkgs, name = "Checking tutorials in stocnet packages"), function(p){ dplyr::as_tibble(learnr::available_tutorials(package = avail_pkgs[p]), - silent = TRUE) %>% dplyr::select(1:3) + silent = TRUE) |> dplyr::select(1:3) }) - dplyr::bind_rows(tutelist) %>% - dplyr::arrange(dplyr::across(dplyr::any_of("name"))) %>% + dplyr::bind_rows(tutelist) |> + dplyr::arrange(dplyr::across(dplyr::any_of("name"))) |> print() manynet::snet_info("You can extract the code from one of these tutorials by typing e.g `extract_tute('tutorial1')` into the console.") } else { diff --git a/inst/tutorials/tutorial0/tutorial0.Rmd b/inst/tutorials/tutorial0/tutorial0.Rmd index 8fc173a8..e66572a5 100644 --- a/inst/tutorials/tutorial0/tutorial0.Rmd +++ b/inst/tutorials/tutorial0/tutorial0.Rmd @@ -384,7 +384,7 @@ It is good practice to be explicit whereever possible though to avoid unexpected ### Pipes When working with multiple functions on the same object, -we can use pipe operators `%>%` or `|>` to chain consecutive functions +we can use the pipe operator `|>` to chain consecutive functions and avoid nesting multiple functions in the code. Pipes take the result of the code on the left of the pipe operator and uses it in whatever function is on the right or next line of the pipe operator. @@ -396,19 +396,13 @@ example.vector <- c(1, 5, 8, 7, 6, 4, 22, 1, 0.9) pipe.result.1 <- example.vector |> mean() pipe.result.1 - -# library(dplyr) -# pipe.result.2 <- example.vector %>% - # mean() -# both pipe operators give the same result -# pipe.result.1 == pipe.result.2 ``` -While `|>`is the native pipe operator since R v4.0.0, -those using earlier versions of R may wish to use `%>%` -from either the `{magrittr}` or `{dplyr}` packages. -Note that in that case, the package would need to be loaded first -before you can use the operator. +`|>` is R's native pipe operator, available since R v4.1.0. +You may still come across `%>%` in older code and tutorials, +which does much the same thing but comes +from either the `{magrittr}` or `{dplyr}` packages, +and so requires that package to be loaded first. ## Tasks diff --git a/inst/tutorials/tutorial7/diffusion.Rmd b/inst/tutorials/tutorial7/diffusion.Rmd index 68cb6907..80f18d25 100644 --- a/inst/tutorials/tutorial7/diffusion.Rmd +++ b/inst/tutorials/tutorial7/diffusion.Rmd @@ -331,7 +331,7 @@ but different races have different resistances (i.e. thresholds). Let us say that there is a clear ordering to this. ```{r lotr-resist, exercise=TRUE, fig.width=9} -lotr_resist <- fict_lotr %>% mutate(resistance = dplyr::case_when(Race == "Dwarf" ~ 2, +lotr_resist <- fict_lotr |> mutate(resistance = dplyr::case_when(Race == "Dwarf" ~ 2, Race == "Elf" ~ 4, Race == "Ent" ~ 5, Race == "Hobbit" ~ 3, @@ -452,8 +452,8 @@ one with the first node as seed and again one on the middle. ```{r lattice-solution} plot(play_diffusion(lat, seeds = 1)) plot(play_diffusion(lat, seeds = 16)) -lat %>% - add_node_attribute("color", c(1, rep(0, 14), 2, rep(0, 16))) %>% +lat |> + add_node_attribute("color", c(1, rep(0, 14), 2, rep(0, 16))) |> graphr(node_color = "color") # visualise diffusion in lattice graph @@ -481,10 +481,10 @@ We could use these on degree centrality, or perhaps some other kind of centralit ```{r sf, exercise=TRUE, fig.width=9} sf <- generate_scalefree(32, 0.025) -sf %>% - as_tidygraph() %>% +sf |> + as_tidygraph() |> mutate(degree = ifelse(node_is_max(node_by_degree(sf)) == TRUE, "max", - ifelse(node_is_min(node_by_degree(sf)) == TRUE, "min", "others"))) %>% + ifelse(node_is_min(node_by_degree(sf)) == TRUE, "min", "others"))) |> graphr(node_color = "degree") + guides(color = "legend") ``` @@ -525,7 +525,7 @@ Many of them are implemented here and might be considered as strategies: - `node_is_mentor()` identifies high indegree nodes as mentors ```{r indepsets, exercise = TRUE, exercise.setup="sf", fig.width=9} -sf %>% mutate_nodes(ni = node_is_independent()) %>% graphr(node_color = "ni") +sf |> mutate_nodes(ni = node_is_independent()) |> graphr(node_color = "ni") plot(play_diffusion(sf, seeds = node_is_independent(sf), steps = 10)) ``` @@ -920,14 +920,14 @@ Then play the learning model with these beliefs, and plot the result. ```{r degroot-hint, purl = FALSE} beliefs <- rbinom(net_nodes(____), 1, prob = 0.25) -____ %>% mutate(____ = beliefs) %>% graphr(node_color = "____") +____ |> mutate(____ = beliefs) |> graphr(node_color = "____") netlearn <- play_learning(____, ____) plot(____) ``` ```{r degroot-solution} beliefs <- rbinom(net_nodes(ison_networkers), 1, prob = 0.25) -ison_networkers %>% mutate(beliefs = beliefs) %>% graphr(node_color = "beliefs") +ison_networkers |> mutate(beliefs = beliefs) |> graphr(node_color = "beliefs") (netlearn <- play_learning(ison_networkers, beliefs)) plot(netlearn) ``` @@ -969,12 +969,12 @@ Which are the highest eigenvector centrality nodes in this network? ```{r eigen-hint} node_by_eigenvector(ison_networkers) -ison_networkers %>% - mutate(who_to_convince = node_is_max(node_by_eigenvector(ison_networkers))) %>% +ison_networkers |> + mutate(who_to_convince = node_is_max(node_by_eigenvector(ison_networkers))) |> graphr(node_color = who_to_convince) beliefs2 <- rep(0, net_nodes(ison_networkers)) beliefs2[node_is_max(node_by_eigenvector(ison_networkers))] <- 1 -ison_networkers %>% mutate(beliefs = beliefs2) %>% graphr(node_color = "beliefs") +ison_networkers |> mutate(beliefs = beliefs2) |> graphr(node_color = "beliefs") (netlearn2 <- play_learning(ison_networkers, beliefs2)) plot(netlearn2) ``` diff --git a/inst/tutorials/tutorial8/diversity.Rmd b/inst/tutorials/tutorial8/diversity.Rmd index 380a7492..2748c234 100644 --- a/inst/tutorials/tutorial8/diversity.Rmd +++ b/inst/tutorials/tutorial8/diversity.Rmd @@ -52,7 +52,7 @@ learnr::random_phrases_add(language = "en", encouragement = "Bon effort") marvel_friends <- to_unsigned(to_uniplex(fict_marvel, "relationship"), keep = "positive") marvel_friends <- to_giant(marvel_friends) -marvel_friends <- marvel_friends %>% to_subgraph(Appearances >= mean(Appearances)) +marvel_friends <- marvel_friends |> to_subgraph(Appearances >= mean(Appearances)) ``` ## This tutorial @@ -113,7 +113,7 @@ to_subgraph(____, Appearances >= mean(Appearances)) ```{r friends-hint-5, purl = FALSE} marvel_friends <- to_unsigned(ison_marvel_relationships, keep = "positive") marvel_friends <- to_giant(marvel_friends) -marvel_friends <- marvel_friends %>% to_subgraph(Appearances >= mean(Appearances)) +marvel_friends <- marvel_friends |> to_subgraph(Appearances >= mean(Appearances)) marvel_friends ``` @@ -121,7 +121,7 @@ marvel_friends marvel_friends <- to_uniplex(fict_marvel, "relationship") marvel_friends <- to_unsigned(marvel_friends, keep = "positive") marvel_friends <- to_giant(marvel_friends) -marvel_friends <- marvel_friends %>% to_subgraph(Appearances >= mean(Appearances)) +marvel_friends <- marvel_friends |> to_subgraph(Appearances >= mean(Appearances)) marvel_friends ``` diff --git a/inst/tutorials/tutorial9/ergm.Rmd b/inst/tutorials/tutorial9/ergm.Rmd index cd35cd46..55e4c7f6 100644 --- a/inst/tutorials/tutorial9/ergm.Rmd +++ b/inst/tutorials/tutorial9/ergm.Rmd @@ -107,8 +107,8 @@ What do you observe? Describe the network in terms of configurations. ```{r vis-flomarriage, exercise=TRUE, exercise.setup = "ergm-data", fig.width=8} graphr(flomarriage, node_size = "wealth") -as_tidygraph(flomarriage) %>% mutate_nodes(Degree = node_by_deg()) %>% - mutate_ties(Triangles = tie_is_triangular()) %>% +as_tidygraph(flomarriage) |> mutate_nodes(Degree = node_by_deg()) |> + mutate_ties(Triangles = tie_is_triangular()) |> graphr(node_size = "Degree", edge_color = "Triangles") ``` @@ -392,8 +392,8 @@ We need additional modelling! ## Markov model ```{r visflo2, echo=FALSE, purl = FALSE, fig.width=9, setup = "flom-gof"} -p1 <- as_tidygraph(flomarriage) %>% mutate_nodes(Degree = node_by_deg()) %>% - mutate_ties(Triangles = tie_is_triangular()) %>% +p1 <- as_tidygraph(flomarriage) |> mutate_nodes(Degree = node_by_deg()) |> + mutate_ties(Triangles = tie_is_triangular()) |> graphr(node_size = "Degree", edge_color = "Triangles") + ggplot2::theme(legend.position = 'none') p2 <- (plot(flom.bern.gof, statistic = "deg") / plot(flom.bern.gof, statistic = "espart")) diff --git a/man/predict.Rd b/man/predict.Rd index 725e4c2b..15e1c07f 100644 --- a/man/predict.Rd +++ b/man/predict.Rd @@ -29,13 +29,15 @@ A numeric vector of predicted values. Predict methods for network regression } \examples{ -networkers <- ison_networkers \%>\% to_subgraph(Discipline == "Sociology") -model1 <- net_regression(weight ~ ego(Citations) + alter(Citations) + sim(Citations), +networkers <- ison_networkers |> to_subgraph(Discipline == "Sociology") +model1 <- net_regression(weight ~ ego(Citations) + alter(Citations) + sim(Citations), networkers, times = 20) +# Should be run many more `times` for publication-ready results predict(model1, matrix(c(1,10,5,2),1,4)) -networkers <- ison_networkers \%>\% to_subgraph(Discipline == "Sociology") \%>\% +networkers <- ison_networkers |> to_subgraph(Discipline == "Sociology") |> to_unweighted() -model1 <- net_regression(. ~ ego(Citations) + alter(Citations) + sim(Citations), +model1 <- net_regression(. ~ ego(Citations) + alter(Citations) + sim(Citations), networkers, times = 20) +# Should be run many more `times` for publication-ready results predict(model1, matrix(c(1,10,5,2),1,4)) } diff --git a/man/regression.Rd b/man/regression.Rd index ec3b6af1..a957d1bf 100644 --- a/man/regression.Rd +++ b/man/regression.Rd @@ -93,7 +93,7 @@ will always be respected in permutations and analysis. } } \examples{ -networkers <- ison_networkers \%>\% to_subgraph(Discipline == "Sociology") +networkers <- ison_networkers |> to_subgraph(Discipline == "Sociology") model1 <- net_regression(weight ~ ego(Citations) + alter(Citations) + sim(Citations), networkers, times = 20) # Should be run many more `times` for publication-ready results diff --git a/man/tests.Rd b/man/tests.Rd index c33b0cbd..3e6c297c 100644 --- a/man/tests.Rd +++ b/man/tests.Rd @@ -75,8 +75,8 @@ of the original network. } } \examples{ -marvel_friends <- fict_marvel \%>\% to_uniplex("relationship") \%>\% - to_unsigned() \%>\% to_giant() \%>\% +marvel_friends <- fict_marvel |> to_uniplex("relationship") |> + to_unsigned() |> to_giant() |> to_subgraph(PowerOrigin == "Human") (cugtest <- test_random(marvel_friends, net_by_heterophily, attribute = "Attractive", times = 200)) diff --git a/tests/testthat/test-model_predict.R b/tests/testthat/test-model_predict.R index 5c73ccba..10d42351 100644 --- a/tests/testthat/test-model_predict.R +++ b/tests/testthat/test-model_predict.R @@ -1,5 +1,5 @@ test_that("predict.netlm works", { - networkers <- ison_networkers %>% to_subgraph(Discipline == "Sociology") + networkers <- ison_networkers |> to_subgraph(Discipline == "Sociology") model1 <- net_regression(weight ~ ego(Citations) + alter(Citations) + sim(Citations), networkers, times = 5) pred <- predict(model1, matrix(c(1,10,5,2),1,4)) @@ -8,7 +8,7 @@ test_that("predict.netlm works", { }) test_that("predict.netlogit works", { - networkers <- ison_networkers %>% to_subgraph(Discipline == "Sociology") %>% + networkers <- ison_networkers |> to_subgraph(Discipline == "Sociology") |> to_unweighted() model1 <- net_regression(. ~ ego(Citations) + alter(Citations) + sim(Citations), networkers, times = 5) diff --git a/tests/testthat/test-model_regression.R b/tests/testthat/test-model_regression.R index dcc29d17..2c0ccac7 100644 --- a/tests/testthat/test-model_regression.R +++ b/tests/testthat/test-model_regression.R @@ -1,5 +1,5 @@ set.seed(123) -networkers <- manynet::ison_networkers %>% manynet::to_subgraph(Discipline == "Sociology") +networkers <- manynet::ison_networkers |> manynet::to_subgraph(Discipline == "Sociology") netsenders <- manynet::to_unweighted(networkers) test <- net_regression(weight ~ ego(Citations), @@ -40,11 +40,48 @@ test_that("glance works correctly for network_reg",{ }) test_that("multivariate QAP works",{ - expect_s3_class(net_regression(weight ~ ego(Citations) + alter(Citations) + sim(Citations), + expect_s3_class(net_regression(weight ~ ego(Citations) + alter(Citations) + sim(Citations), networkers, times = 10), "netlm") }) +test_that("permutation shortcut matches manynet::to_permuted()",{ + # Tests the shortcut directly rather than via `permute_matrix()`, so that it + # keeps guarding the equivalence once the version check defers to manynet + onemode <- matrix(rpois(36, 3), 6, 6) + labelled <- matrix(rbinom(36, 1, 0.4), 6, 6, + dimnames = list(LETTERS[1:6], LETTERS[1:6])) + twomode <- matrix(rbinom(24, 1, 0.4), 6, 4) + for(m in list(onemode, labelled, twomode)){ + set.seed(7) + expected <- manynet::to_permuted(m, with_attr = FALSE) + set.seed(7) + expect_equal(permute_matrix_directly(m), expected, ignore_attr = FALSE) + } +}) + +test_that("permutation defers to manynet once it has a matrix method",{ + expect_type(manynet_permutes_matrices(), "logical") + expect_equal(manynet_permutes_matrices(), + !is.null(utils::getS3method("to_permuted", "matrix", + optional = TRUE))) + # The cache is what `permute_matrix()` actually branches on, so check both + # branches rather than only the one the installed manynet happens to select + cached <- environment(manynet_permutes_matrices) + on.exit(assign("delegate", NA, envir = cached), add = TRUE) + m <- matrix(rpois(36, 3), 6, 6) + + assign("delegate", TRUE, envir = cached) + set.seed(7); delegated <- permute_matrix(m) + set.seed(7); expect_equal(delegated, + manynet::to_permuted(m, with_attr = FALSE), + ignore_attr = FALSE) + + assign("delegate", FALSE, envir = cached) + set.seed(7); shortcut <- permute_matrix(m) + set.seed(7); expect_equal(shortcut, permute_matrix_directly(m)) +}) + # test_that("specification advice appears",{ # expect_message(net_regression(weight ~ same(Discipline), networkers, times = 1), # "When testing for homophily") diff --git a/tests/testthat/test-model_tests.R b/tests/testthat/test-model_tests.R index 7ab79e6d..b42ccc55 100644 --- a/tests/testthat/test-model_tests.R +++ b/tests/testthat/test-model_tests.R @@ -1,6 +1,6 @@ # # Making sure the tests family of functions works as intended. -marvel_friends <- manynet::to_uniplex(manynet::fict_marvel, "relationship") %>% - manynet::to_giant() %>% manynet::to_unsigned() %>% +marvel_friends <- manynet::to_uniplex(manynet::fict_marvel, "relationship") |> + manynet::to_giant() |> manynet::to_unsigned() |> manynet::to_subgraph(PowerOrigin == "Human") cugtest <- test_random(marvel_friends, netrics::net_by_heterophily,