diff --git a/.devcontainer/Dockerfile b/.devcontainer/Containerfile similarity index 64% rename from .devcontainer/Dockerfile rename to .devcontainer/Containerfile index 39a03aa7..f9b37466 100644 --- a/.devcontainer/Dockerfile +++ b/.devcontainer/Containerfile @@ -1,16 +1,16 @@ -FROM rocker/tidyverse:4.4.0 +FROM ghcr.io/rocker-org/devcontainer/tidyverse:4.5 # RUN \ # echo 'options(repos=c(CRAN="https://packagemanager.posit.co/cran/__linux__/bookworm/latest"))' >> ~/.Rprofile && \ # Rscript --vanilla -e 'getOption("repos")' -# Adding R packages -RUN install2.r Rcpp sna network networkDynamic Matrix MASS MatchIt SparseM igraph \ - viridisLite covr testthat knitr rmarkdown ape RSiena survival RcppArmadillo - -RUN install2.r languageserver httpgd +RUN install2.r --error languageserver && installGithub.r nx10/httpgd RUN apt-get update && apt-get install --no-install-recommends -y valgrind gdb \ libglpk-dev +# Adding R packages +RUN install2.r --error Rcpp sna network networkDynamic Matrix MASS MatchIt SparseM igraph \ + viridisLite covr testthat knitr rmarkdown ape RSiena survival RcppArmadillo + CMD ["bash"] diff --git a/.devcontainer/devcontainer.json b/.devcontainer/devcontainer.json index 8b589118..d07306e4 100644 --- a/.devcontainer/devcontainer.json +++ b/.devcontainer/devcontainer.json @@ -1,9 +1,9 @@ // For format details, see https://aka.ms/devcontainer.json. For config options, see the // README at: https://github.com/devcontainers/templates/tree/main/src/cpp { - "name": "epiworldR", + "name": "netdiffuseR", "build": { - "dockerfile": "Dockerfile" + "dockerfile": "Containerfile" }, "customizations": { "vscode": { @@ -11,14 +11,15 @@ "reditorsupport.r", "rdebugger.r-debugger", "quarto.quarto", - "tianyishi.rmarkdown" + "tianyishi.rmarkdown", + "github.vscode-github-actions" ] } }, "mounts": [ // Mount the .vscode configuration into the container "source=${localWorkspaceFolder}/.devcontainer/.vscode,target=/workspaces/${localWorkspaceFolderBasename}/.vscode,type=bind,consistency=cached" - ] + ], // Features to add to the dev container. More info: https://containers.dev/features. // "features": {}, @@ -32,5 +33,5 @@ // "customizations": {}, // Uncomment to connect as root instead. More info: https://aka.ms/dev-containers-non-root. - // "remoteUser": "root" + "remoteUser": "root" } diff --git a/.github/copilot-instructions.md b/.github/copilot-instructions.md new file mode 100644 index 00000000..cf33a1e1 --- /dev/null +++ b/.github/copilot-instructions.md @@ -0,0 +1,30 @@ +# Copilot Instructions for netdiffuseR + +## Documentation Style + +When writing roxygen2 documentation, prefer markdown syntax over LaTeX: + +- Use `` `code` `` instead of `\code{code}` +- Use `` `[function()]` `` instead of `\code{\link{function}}` +- Use markdown bullet lists instead of `\itemize{}` +- Use markdown formatting for emphasis and structure + +## Code Style + +- Follow existing code patterns and conventions in the package +- Use meaningful variable names and keep functions focused +- Add comments only when they match the existing style or explain complex logic +- Prefer using existing libraries over adding new dependencies + +## Testing + +- Add comprehensive tests for new functions +- Include edge cases and error conditions +- Test with the existing sample datasets when possible +- Validate input parameters and handle errors gracefully + +## Examples + +- Use `\dontrun{}` only when examples take a long time to run +- Prefer examples that can execute quickly for CRAN checks +- Use existing package datasets in examples when available \ No newline at end of file diff --git a/.github/workflows/pkgdown.yml b/.github/workflows/pkgdown.yml index a0d1eba6..53ba6a5b 100644 --- a/.github/workflows/pkgdown.yml +++ b/.github/workflows/pkgdown.yml @@ -24,7 +24,7 @@ jobs: id-token: write pages: write steps: - - uses: actions/checkout@v4 + - uses: actions/checkout@v5 - uses: r-lib/actions/setup-pandoc@v2 with: @@ -35,6 +35,8 @@ jobs: - uses: r-lib/actions/setup-r-dependencies@v2 with: extra-packages: any::pkgdown + install-quarto: true + install-pandoc: true - name: Install the package run: R CMD INSTALL . @@ -44,7 +46,7 @@ jobs: shell: Rscript {0} - name: Upload artifact for GH pages deployment - uses: actions/upload-pages-artifact@v3 + uses: actions/upload-pages-artifact@v5 with: path: "docs/" diff --git a/.github/workflows/r.yml b/.github/workflows/r.yml index 700c87fc..e6bd1623 100644 --- a/.github/workflows/r.yml +++ b/.github/workflows/r.yml @@ -15,14 +15,16 @@ jobs: R-CMD-check: runs-on: ${{ matrix.config.os }} - name: ${{ matrix.config.os }} (${{ matrix.config.r }}) + name: ${{ matrix.config.os }} (${{ matrix.config.r }}) (valgrind:${{ matrix.config.valgrind }}) strategy: fail-fast: false matrix: config: - {os: macOS-latest, r: 'release'} + - {os: macOS-latest, r: 'devel', http-user-agent: 'release'} - {os: windows-latest, r: 'release'} + # - {os: windows-latest, r: 'devel', http-user-agent: 'release'} - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} - {os: ubuntu-latest, r: 'release'} - {os: ubuntu-latest, r: 'devel', valgrind: true, http-user-agent: 'release'} @@ -32,9 +34,12 @@ jobs: R_KEEP_PKG_SOURCE: yes steps: - - uses: actions/checkout@v4 + # Fix suggested by + # https://msmith.de/2020/03/12/r-cmd-check-github-actions.html + - name: Configure git + run: git config --global core.autocrlf false - - uses: r-lib/actions/setup-pandoc@v2 + - uses: actions/checkout@v5 - uses: r-lib/actions/setup-r@v2 with: @@ -46,6 +51,8 @@ jobs: with: extra-packages: any::rcmdcheck needs: check + install-quarto: true + install-pandoc: true - uses: r-lib/actions/check-r-package@v2 if: ${{ matrix.config.valgrind != true }} @@ -56,36 +63,43 @@ jobs: check-dir: '"check"' error-on: '"error"' - - name: Setup valgrind - if: ${{ matrix.config.valgrind == true }} + - name: Install valgrind + if: ${{ matrix.config.valgrind }} run: | sudo apt-get update - sudo apt-get install -y valgrind --no-install-recommends - shell: bash + sudo apt-get install -y --no-install-recommends valgrind - - name: Check with Valgrind - if: ${{ matrix.config.valgrind == true }} - env: - _R_CHECK_CRAN_INCOMING_REMOTE_: false - run: | - options(crayon.enabled = TRUE) - rcmdcheck::rcmdcheck(args = c("--no-manual", "--as-cran", "--use-valgrind"), error_on = "error", check_dir = "check") - shell: Rscript {0} + - uses: r-lib/actions/check-r-package@v2 + if: ${{ matrix.config.valgrind }} + with: + args: 'c("--as-cran", "--use-valgrind", "--no-manual")' + upload-results: true + + build-pkg: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v5 - - name: Upload check results - if: failure() - uses: actions/upload-artifact@main + - uses: r-lib/actions/setup-r@v2 with: - name: ${{ runner.os }}-r${{ matrix.config.r }}-results - path: check + r-version: 'release' + use-public-rspm: true - - name: Build the package - if: ${{ matrix.config.os == 'ubuntu-latest' && (matrix.config.r == 'release' || matrix.config.r == 'devel') && (matrix.config.valgrind != true) }} + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::devtools + + - name: Build package run: R CMD build . - - uses: actions/upload-artifact@v4 - if: ${{ matrix.config.os == 'ubuntu-latest' && (matrix.config.r == 'release' || matrix.config.r == 'devel') && (matrix.config.valgrind != true) }} + - name: Upload package artifact + uses: actions/upload-artifact@v5 with: - name: netdiffuseR-built-package-${{ matrix.config.os }}-${{ matrix.config.r }} - path: netdiffuseR_*.tar.gz - retention-days: 7 + name: R-package + path: '*.tar.gz' + + + + + + diff --git a/.gitignore b/.gitignore index 8a137dac..2d2dbdb2 100755 --- a/.gitignore +++ b/.gitignore @@ -22,3 +22,8 @@ inst/doc *.tex playground/ doc/ + +# Other files +.vscode/ +config.status +src/Makevars diff --git a/DESCRIPTION b/DESCRIPTION index 0d960f0a..2c7e9575 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: netdiffuseR Title: Analysis of Diffusion and Contagion Processes on Networks -Version: 1.23.0 +Version: 1.24.0 Authors@R: c( person("George", "Vega Yon", email="g.vegayon@gmail.com", role=c("aut", "cre"), comment=c(ORCID = "0000-0002-3171-0844", what="Rewrite functions with Rcpp, plus new features") @@ -51,7 +51,7 @@ Suggests: survival VignetteBuilder: knitr LinkingTo: Rcpp, RcppArmadillo -RoxygenNote: 7.3.2 +RoxygenNote: 7.3.3 Encoding: UTF-8 URL: https://github.com/USCCANA/netdiffuseR, https://USCCANA.github.io/netdiffuseR/ @@ -66,6 +66,7 @@ Collate: 'bootnet.r' 'citer_environment.R' 'data.r' + 'degree_adoption_diagnostic.R' 'diffnet-c.R' 'diffnet-class.r' 'diffnet-indexing.r' diff --git a/Makefile b/Makefile index 832637c0..03fa9d2a 100644 --- a/Makefile +++ b/Makefile @@ -9,16 +9,16 @@ help: @echo " make docs - Generate documentation" install: - R CMD INSTALL . + Rscript --vanilla -e 'devtools::install()' build: R CMD build . -README.md: README.Rmd - Rscript -e 'rmarkdown::render("README.Rmd")' +README.md: README.qmd + quarto render README.qmd -check: netdiffuseR_$(VERSION).tar.gz - R CMD check --as-cran netdiffuseR_$(VERSION).tar.gz +check: + Rscript --vanilla -e 'devtools::check()' checkv: netdiffuseR_$(VERSION).tar.gz R CMD check --as-cran --use-valgrind netdiffuseR_$(VERSION).tar.gz diff --git a/NAMESPACE b/NAMESPACE index 0e4f522d..d3a9d6e9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -66,6 +66,7 @@ S3method(plot_diffnet2,diffnet) S3method(plot_threshold,array) S3method(plot_threshold,default) S3method(plot_threshold,diffnet) +S3method(print,degree_adoption_diagnostic) S3method(print,diffnet) S3method(print,diffnet_bootnet) S3method(print,diffnet_diffmap) @@ -99,6 +100,7 @@ export(classify_adopters) export(classify_graph) export(compare_matrix) export(cumulative_adopt_count) +export(degree_adoption_diagnostic) export(dgr) export(diag_expand) export(diffmap) diff --git a/NEWS.md b/NEWS.md index a8600759..38a56e7e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,11 @@ +# Changes in netdiffuseR version 1.24.0 (DEV) + +* New function `degree_adoption_diagnostic()` analyzes the correlation between network + centrality measures (in-degree and out-degree) and time of adoption to identify + whether opinion leaders were supporters or opposers in diffusion processes. + The function supports multi-diffusion objects, undirected networks, and includes + bootstrap confidence intervals. + # Changes in netdiffuseR version 1.23.0 (2025-06-10) * New methods for simulating multi-diffusion models. diff --git a/R/degree_adoption_diagnostic.R b/R/degree_adoption_diagnostic.R new file mode 100644 index 00000000..1fa9adae --- /dev/null +++ b/R/degree_adoption_diagnostic.R @@ -0,0 +1,744 @@ +#' Degree and Time of Adoption Diagnostic +#' +#' Analyzes the correlation between in-degree, out-degree, and time of adoption +#' to identify whether opinion leaders were early adopters (supporters) or late +#' adopters (opposers). +#' +#' @param graph A `[diffnet()]` object or a graph data structure (classes include +#' `array` (\eqn{n\times n \times T}{n*n*T}), `dgCMatrix` (sparse), +#' `igraph`, etc.; see [netdiffuseR-graphs]). +#' @param toa Integer vector of length \eqn{n} (single behavior) or an \eqn{n\times Q}{n*Q} +#' matrix (multi-behavior) with times of adoption. Required when `graph` is not a `diffnet`. +#' @param t0,t1 Optional integer scalars defining the first and last observed +#' periods. If missing and `toa` is provided, `t0` defaults to 1 +#' and `t1` to `max(toa, na.rm=TRUE)`. +#' @param name Optional character scalars used only when coercing +#' inputs into a `diffnet` object (passed to `new_diffnet`). +#' @param behavior Which behaviors to include when `toa` is a matrix (multi-diffusion). +#' Can be `NULL` (all), a numeric index vector, or a character vector matching `colnames(toa)`. +#' @param combine Character scalar. How to combine multiple behaviors when `toa` is a matrix: +#' - `"none"` (analyze each behavior separately) +#' - `"pooled"` (stack rows across behaviors) +#' - `"average"` (per-actor mean of TOA across selected behaviors) +#' - `"earliest"` (per-actor minimum TOA) +#' Ignored for single-behavior. +#' @param min_adopters Integer scalar. Minimum number of adopters required to compute correlations +#' for any analysis cell (default 3). +#' @param degree_strategy Character scalar. How to aggregate degree measures across +#' time periods: +#' - `"mean"` (default): Average degree across all time periods +#' - `"first"`: Degree in the first time period +#' - `"last"`: Degree in the last time period +#' @param bootstrap Logical scalar. Whether to compute bootstrap confidence intervals. +#' @param R Integer scalar. Number of bootstrap replicates (default 1000). +#' @param conf.level Numeric scalar. Confidence level for bootstrap intervals (default 0.95). +#' @param valued Logical scalar. Whether to use edge weights in degree calculations. +#' @param ... Additional arguments passed on when coercing to `diffnet`. +#' +#' @details +#' This diagnostic function computes correlations between degree centrality measures +#' (in-degree and out-degree) and time of adoption. Positive correlations suggest +#' that central actors (opinion leaders) adopted early, while negative correlations +#' suggest they adopted late. +#' +#' When `bootstrap = TRUE`, the function uses the `boot` package to +#' compute bootstrap confidence intervals for the correlations. +#' +#' When `toa` is a matrix (multi-diffusion), degree vectors are computed once and +#' reused; the time of adoption is combined according to `combine`: +#' - `"none"`: computes separate results per behavior (see Value). +#' - `"pooled"`: stacks (actor, behavior) rows for adopters and runs a single analysis. +#' - `"average"`: one row per actor using the mean TOA of adopted behaviors. +#' - `"earliest"`: one row per actor using the minimum TOA of adopted behaviors. +#' +#' @return When analyzing a single behavior (or when `combine!="none"`), a list with: +#' \item{correlations}{Named numeric vector with correlations between in-degree/out-degree and time of adoption} +#' \item{bootstrap}{List with bootstrap results when `bootstrap = TRUE`, otherwise `NULL`} +#' \item{call}{The matched call} +#' \item{degree_strategy}{The degree aggregation strategy used} +#' \item{sample_size}{Number of rows included in the analysis (adopter rows)} +#' \item{combine}{`NULL` for single-behavior; otherwise the combination rule used.} +#' +#' When `combine="none"` with multiple behaviors, returns the same structure, except: +#' - `correlations` is a \eqn{2\times Q^*}{2 x Q*} matrix with rows `c("indegree_toa","outdegree_toa")` +#' and one column per analyzed behavior. +#' - `bootstrap` is a named list with one entry per behavior (each like the single-behavior case), or `NULL` if `bootstrap=FALSE`. +#' - `sample_size` is an integer vector named by behavior. +#' - `combine` is `"none"`. +#' +#' @examples +#' # Basic usage with Korean Family Planning data +#' data(kfamilyDiffNet) +#' result_basics <- degree_adoption_diagnostic(kfamilyDiffNet, bootstrap = FALSE) +#' print(result_basics) +#' +#' # With bootstrap confidence intervals +#' result_boot <- degree_adoption_diagnostic(kfamilyDiffNet) +#' print(result_boot) +#' +#' # Different degree aggregation strategies +#' result_first <- degree_adoption_diagnostic(kfamilyDiffNet, degree_strategy = "first") +#' result_last <- degree_adoption_diagnostic(kfamilyDiffNet, degree_strategy = "last") +#' +#' # Multi-diffusion (toy) ---------------------------------------------------- +#' set.seed(999) +#' n <- 40; t <- 5; q <- 2 +#' garr <- rgraph_ws(n, t, p=.3) +#' diffnet_multi <- rdiffnet(seed.graph = garr, t = t, seed.p.adopt = rep(list(0.1), q)) +#' +#' # pooled (one combined analysis) +#' degree_adoption_diagnostic(diffnet_multi, combine = "pooled", bootstrap = FALSE) +#' +#' # per-behavior (matrix of correlations; one column per behavior) +#' degree_adoption_diagnostic(diffnet_multi, combine = "none", bootstrap = FALSE) +#' +#' @seealso `[dgr()]`, `[diffreg()]`, `[exposure()]` +#' @family statistics +#' @export +degree_adoption_diagnostic <- function( + graph, + degree_strategy = c("mean", "first", "last"), + bootstrap = TRUE, + R = 1000, + conf.level = 0.95, + toa = NULL, + t0 = NULL, t1 = NULL, + name = NULL, + behavior = NULL, + combine = c("none", "pooled", "average", "earliest"), + min_adopters = 3, + valued = getOption("diffnet.valued", FALSE), + ... +) { + # Check that bootstrap is a logical scalar + if (!is.logical(bootstrap) || length(bootstrap) != 1 || is.na(bootstrap)) { + stop("'bootstrap' must be a logical scalar") + } + + # Check that R is a positive integer + if (!is.numeric(R) || length(R) != 1 || is.na(R) || R < 1 || R != as.integer(R)) { + stop("'R' must be a positive integer") + } + + # Check that conf.level is a numeric scalar between 0 and 1 + if (!is.numeric(conf.level) || length(conf.level) != 1 || is.na(conf.level) || conf.level <= 0 || conf.level >= 1) { + stop("'conf.level' must be between 0 and 1") + } + + # Match and validate arguments + degree_strategy <- match.arg(degree_strategy) + combine <- match.arg(combine) + + # Store the original call + original_call <- match.call() + + # Handle input processing and validation + graph_and_toa <- process_graph_input(graph, toa, t0, t1, name, ...) + graph <- graph_and_toa$graph + toa <- graph_and_toa$toa + + # Get the number of behaviors + if (is.matrix(toa)) { + Q <- ncol(toa) + behavior_names <- if (length(colnames(toa))) colnames(toa) else paste0("B", seq_len(Q)) + } else { + Q <- 1 + behavior_names <- NULL + } + + # Filter behaviors if requested + if (Q > 1 && !is.null(behavior)) { + if (is.character(behavior)) { + if (is.null(colnames(toa))) { + stop("Cannot use character behavior selection without column names in toa") + } + behavior_indices <- match(behavior, colnames(toa)) + if (any(is.na(behavior_indices))) { + stop("Some behavior names not found in colnames(toa): ", + paste(behavior[is.na(behavior_indices)], collapse = ", ")) + } + } else if (is.numeric(behavior)) { + behavior_indices <- behavior + if (any(behavior_indices < 1 | behavior_indices > Q)) { + stop("behavior index out of range: must be between 1 and ", Q) + } + } else { + stop("behavior must be NULL, numeric indices, or character names") + } + + toa <- toa[, behavior_indices, drop = FALSE] + Q <- ncol(toa) + behavior_names <- if (length(colnames(toa))) colnames(toa) else paste0("B", seq_len(Q)) + } + + # Compute degree measures + degrees <- compute_degree_measures(graph, degree_strategy, valued) + + # Handle multi-diffusion analysis: for combine = "none", always analyze per behavior and do not error for too few adopters + if (combine == "none" && is.matrix(toa)) { + return(analyze_multi_behaviors_separately( + degrees, toa, min_adopters, bootstrap, R, conf.level, + behavior_names, degree_strategy, original_call, graph + )) + } + + # Single behavior or combined analysis + combined_data <- prepare_combined_data(degrees, toa, combine, min_adopters, Q) + + if (nrow(combined_data) < min_adopters) { + stop("Insufficient adopters for correlation analysis. (n=", nrow(combined_data), + ", minimum = ", min_adopters, ").") + } + + # Compute correlations + correlations <- compute_correlations(combined_data) + + # Bootstrap if requested + bootstrap_results <- if (bootstrap) { + compute_bootstrap_results(combined_data, R, conf.level) + } else { + NULL + } + + # Determine if undirected (graph is always a diffnet here) + undirected <- isTRUE(is_undirected(graph)) + + # Return results + structure(list( + correlations = correlations, + bootstrap = bootstrap_results, + call = original_call, + degree_strategy = degree_strategy, + sample_size = nrow(combined_data), + combine = if (Q > 1) combine else NULL, + undirected = undirected + ), class = "degree_adoption_diagnostic") +} + +# Helper functions -------------------------------------------------------- + +process_graph_input <- function(graph, toa, t0, t1, name, ...) { + if (inherits(graph, "diffnet")) { + if (!is.null(toa)) { + warning("toa argument ignored when graph is a diffnet object") + } + return(list(graph = graph, toa = graph$toa)) + } + + if (is.null(toa)) { + stop("toa argument is required when graph is not a diffnet object") + } + + # If graph is a list, ensure all elements are dgCMatrix + if (is.list(graph)) { + graph <- lapply(graph, function(g) { + if (inherits(g, "dgCMatrix")) return(g) + if (is.matrix(g)) return(as(Matrix::Matrix(g, sparse = TRUE), "dgCMatrix")) + stop("All elements of the graph list must be matrices or dgCMatrix.") + }) + } + + # If graph is a single static adjacency (matrix/dgCMatrix), expand it to T layers to avoid recycling warnings in new_diffnet + if (inherits(graph, "dgCMatrix") || is.matrix(graph)) { + if (is.null(t0)) t0 <- 1 + if (is.null(t1)) t1 <- max(toa, na.rm = TRUE) + Tlen <- as.integer(t1 - t0 + 1L) + if (is.finite(Tlen) && Tlen > 1L) { + gmat <- if (inherits(graph, "dgCMatrix")) graph else as(Matrix::Matrix(graph, sparse = TRUE), "dgCMatrix") + graph <- replicate(Tlen, gmat, simplify = FALSE) + } + } + + # Detect undirectedness on the raw input before building diffnet + undirected_flag <- check_undirected_graph(graph) + + # Convert to diffnet + if (is.null(t0)) t0 <- 1 + if (is.null(t1)) t1 <- max(toa, na.rm = TRUE) + + graph <- new_diffnet( + graph, toa, + t0 = t0, t1 = t1, + name = name, + undirected = undirected_flag, + ... + ) + return(list(graph = graph, toa = toa)) +} + +compute_degree_measures <- function(graph, degree_strategy, valued) { + if (degree_strategy == "mean") { + indegree <- rowMeans(dgr(graph, cmode = "indegree", valued = valued), na.rm = TRUE) + outdegree <- rowMeans(dgr(graph, cmode = "outdegree", valued = valued), na.rm = TRUE) + } else { + deg_matrix <- dgr(graph, valued = valued) + if (length(dim(deg_matrix)) == 3) { + # Dynamic case + if (degree_strategy == "first") { + indegree <- deg_matrix[, 1, "indegree"] + outdegree <- deg_matrix[, 1, "outdegree"] + } else if (degree_strategy == "last") { + last_time <- dim(deg_matrix)[2] + indegree <- deg_matrix[, last_time, "indegree"] + outdegree <- deg_matrix[, last_time, "outdegree"] + } + } else if (length(dim(deg_matrix)) == 2) { + # Static case: check for column names, else use position + cn <- colnames(deg_matrix) + if (!is.null(cn) && all(c("indegree", "outdegree") %in% cn)) { + indegree <- deg_matrix[, "indegree"] + outdegree <- deg_matrix[, "outdegree"] + } else if (ncol(deg_matrix) >= 2) { + indegree <- deg_matrix[, 1] + outdegree <- deg_matrix[, 2] + } else { + stop("Degree matrix does not have expected columns for static graph.") + } + } else { + stop("Unexpected degree matrix dimensions in compute_degree_measures.") + } + } + + list(indegree = indegree, outdegree = outdegree) +} + +analyze_multi_behaviors_separately <- function(degrees, toa, min_adopters, bootstrap, R, conf.level, behavior_names, degree_strategy, original_call, graph) { + Q <- ncol(toa) + + # Initialize results containers + correlations_matrix <- matrix(NA_real_, nrow = 2, ncol = Q) + rownames(correlations_matrix) <- c("indegree_toa", "outdegree_toa") + colnames(correlations_matrix) <- behavior_names + + sample_sizes <- integer(Q) + names(sample_sizes) <- behavior_names + + bootstrap_results <- if (bootstrap) vector("list", Q) else NULL + if (bootstrap) names(bootstrap_results) <- behavior_names + + # Analyze each behavior + for (q in seq_len(Q)) { + toa_q <- toa[, q] + adopters_q <- which(!is.na(toa_q)) + + if (length(adopters_q) >= min_adopters) { + data_q <- data.frame( + indegree = degrees$indegree[adopters_q], + outdegree = degrees$outdegree[adopters_q], + toa = toa_q[adopters_q] + ) + + correlations_matrix[1, q] <- cor_safe(data_q$indegree, data_q$toa ) + correlations_matrix[2, q] <- cor_safe(data_q$outdegree, data_q$toa ) + sample_sizes[q] <- nrow(data_q) + + if (bootstrap) { + bootstrap_results[[q]] <- compute_bootstrap_results(data_q, R, conf.level) + } + } else { + sample_sizes[q] <- length(adopters_q) + } + } + + # Determine if undirected + undirected <- if (inherits(graph, "diffnet")) { + is_undirected(graph) + } else { + check_undirected_graph(graph) + } + + structure(list( + correlations = correlations_matrix, + bootstrap = bootstrap_results, + call = original_call, + degree_strategy = degree_strategy, + sample_size = sample_sizes, + combine = "none", + undirected = undirected + ), class = "degree_adoption_diagnostic") +} + +prepare_combined_data <- function(degrees, toa, combine, min_adopters, Q) { + if (Q == 1 || combine == "pooled") { + if (Q == 1) { + adopters <- which(!is.na(toa)) + data.frame( + indegree = degrees$indegree[adopters], + outdegree = degrees$outdegree[adopters], + toa = toa[adopters] + ) + } else { + # Pooled: stack all (actor, behavior) rows + adopter_rows <- which(!is.na(as.vector(toa))) + actor_indices <- ((adopter_rows - 1) %% nrow(toa)) + 1 + + data.frame( + indegree = degrees$indegree[actor_indices], + outdegree = degrees$outdegree[actor_indices], + toa = as.vector(toa)[adopter_rows] + ) + } + } else if (combine == "average") { + # Average TOA across behaviors per actor + toa_avg <- rowMeans(toa, na.rm = TRUE) + adopters <- which(!is.na(toa_avg)) + + data.frame( + indegree = degrees$indegree[adopters], + outdegree = degrees$outdegree[adopters], + toa = toa_avg[adopters] + ) + } else if (combine == "earliest") { + # Earliest TOA across behaviors per actor + toa_min <- apply(toa, 1, function(row) { + if (all(is.na(row))) return(NA_real_) + min(row, na.rm = TRUE) + }) + toa_min[is.infinite(toa_min)] <- NA + adopters <- which(!is.na(toa_min)) + + data.frame( + indegree = degrees$indegree[adopters], + outdegree = degrees$outdegree[adopters], + toa = toa_min[adopters] + ) + } +} + +compute_correlations <- function(data) { + c( + indegree_toa = cor_safe(data$indegree, data$toa), + outdegree_toa = cor_safe(data$outdegree, data$toa) + ) +} + +compute_bootstrap_results <- function(combined_data, R, conf.level) { + # Compute baseline correlations + base_corr <- compute_correlations(combined_data) + indeg_corr <- base_corr[["indegree_toa"]] + outdeg_corr <- base_corr[["outdegree_toa"]] + + indeg_boot_list <- NULL + out_boot_list <- NULL + + # Out-degree + if (!is.na(outdeg_corr)) { + # Out-degree bootstrap + safe_bootstrap_out <- function(data, indices) { + d <- data[indices, , drop = FALSE] + suppressWarnings(stats::cor(d$outdegree, d$toa, use = "complete.obs")) + } + boot_obj_out <- boot::boot(combined_data, statistic = safe_bootstrap_out, R = R) + bias_out <- mean(boot_obj_out$t, na.rm = TRUE) - outdeg_corr + se_out <- stats::sd(boot_obj_out$t, na.rm = TRUE) + + ci_out <- tryCatch({ + bci <- boot::boot.ci(boot_obj_out, conf = conf.level, type = "perc") + # Percentile CI vector (low, high) + if (!is.null(bci$percent)) bci$percent[4:5] else NULL + }, error = function(e) NULL) + + out_boot_list <- list( + correlation = outdeg_corr, + bias = bias_out, + std_error = se_out, + conf_int = ci_out, + conf_level = conf.level + ) + } else { + # Degenerate case: correlation is NA (do not include CI/SE/CL) + out_boot_list <- list( + correlation = NA_real_ + ) + boot_obj_out <- NULL + } + + # In-degree + if (!is.na(indeg_corr)) { + # In-degree bootstrap + safe_bootstrap_in <- function(data, indices) { + d <- data[indices, , drop = FALSE] + suppressWarnings(stats::cor(d$indegree, d$toa, use = "complete.obs")) + } + boot_obj_in <- boot::boot(combined_data, statistic = safe_bootstrap_in, R = R) + bias_in <- mean(boot_obj_in$t, na.rm = TRUE) - indeg_corr + se_in <- stats::sd(boot_obj_in$t, na.rm = TRUE) + + ci_in <- tryCatch({ + bci <- boot::boot.ci(boot_obj_in, conf = conf.level, type = "perc") + if (!is.null(bci$percent)) bci$percent[4:5] else NULL + }, error = function(e) NULL) + + indeg_boot_list <- list( + correlation = indeg_corr, + bias = bias_in, + std_error = se_in, + conf_int = ci_in, + conf_level = conf.level + ) + } else { + indeg_boot_list <- list( + correlation = NA_real_ + ) + boot_obj_in <- NULL + } + + list( + indegree = indeg_boot_list, + outdegree = out_boot_list, + R = R, + boot_object = list(indegree = boot_obj_in, outdegree = boot_obj_out) + ) +} + +create_empty_result <- function(degree_strategy, original_call, combine, sample_size) { + structure(list( + correlations = c(indegree_toa = NA_real_, outdegree_toa = NA_real_), + bootstrap = NULL, + call = original_call, + degree_strategy = degree_strategy, + sample_size = sample_size, + combine = combine, + undirected = FALSE + ), class = "degree_adoption_diagnostic") +} + +check_undirected_graph <- function(graph) { + if (is.list(graph)) { + return(all(sapply(graph, function(g) isSymmetric(as.matrix(g))))) + } + if (is.array(graph) && length(dim(graph)) == 3) { + return(all(sapply(seq_len(dim(graph)[3]), function(t) isSymmetric(as.matrix(graph[,,t]))))) + } + if (is.matrix(graph)) { + return(isSymmetric(as.matrix(graph))) + } + FALSE +} + +# Print method ------------------------------------------------------------ + +#' @export +print.degree_adoption_diagnostic <- function(x, ...) { + cat("Degree and Time of Adoption Diagnostic\n") + cat("======================================\n\n") + + # Basic info + cat(sprintf("Degree aggregation strategy: %s \n", x$degree_strategy)) + # Combination mode info (only for multi-diffusion) + if (!is.null(x$combine)) { + mode_label <- switch(x$combine, + "none" = "none (per-behavior)", + "pooled" = "pooled (stacked rows)", + "average" = "average (mean TOA per actor)", + "earliest" = "earliest (min TOA per actor)", + x$combine + ) + cat(sprintf("Behavior combination: %s \n\n", mode_label)) + } + + # Sample size info + if (is.null(names(x$sample_size))) { + cat(sprintf("Sample size (adopters only): %d \n", x$sample_size)) + } else { + cat("Sample sizes (adopters only):\n") + beh_names <- names(x$sample_size) + for (j in seq_along(x$sample_size)) { + cat(sprintf(" - %s: %d\n", if (length(beh_names)) beh_names[j] else paste0("B", j), x$sample_size[j])) + } + } + + undirected <- isTRUE(x$undirected) + + # Single behavior or combined analysis + if (is.vector(x$correlations)) { + print_single_behavior_results(x, undirected) + } else { + print_multi_behavior_results(x, undirected) + } + + invisible(x) +} + +print_single_behavior_results <- function(x, undirected) { + # Extract correlation values + indeg_r <- x$correlations[["indegree_toa"]] + outdeg_r <- x$correlations[["outdegree_toa"]] + + # Print correlations + cat("Correlations:\n") + if (undirected) { + deg_r <- indeg_r # For undirected graphs, in-degree = out-degree = degree + cat(sprintf(" Degree - Time of Adoption: %.3f\n", deg_r)) + } else { + cat(sprintf(" In-degree - Time of Adoption: %.3f\n", indeg_r)) + cat(sprintf(" Out-degree - Time of Adoption: %.3f\n", outdeg_r)) + } + + # Interpretation + cat("\nInterpretation:\n") + + if (!is.null(x$bootstrap)) { + bootstrap_data <- x$bootstrap + deg_ci <- if (undirected && !is.null(bootstrap_data$indegree$conf_int)) { + bootstrap_data$indegree$conf_int + } else NULL + indeg_ci <- if (!is.null(bootstrap_data$indegree$conf_int)) { + bootstrap_data$indegree$conf_int + } else NULL + outdeg_ci <- if (!is.null(bootstrap_data$outdegree$conf_int)) { + bootstrap_data$outdegree$conf_int + } else NULL + lvl <- if (!is.null(bootstrap_data$indegree$conf_level)) { + bootstrap_data$indegree$conf_level * 100 + } else NA_real_ + + if (undirected) { + explain_degree_correlation("Degree", deg_r, deg_ci, lvl_arg = lvl) + } else { + explain_degree_correlation("In-degree", indeg_r, indeg_ci, lvl_arg = lvl) + explain_degree_correlation("Out-degree", outdeg_r, outdeg_ci, lvl_arg = lvl) + } + } else { + if (undirected) { + explain_degree_correlation("Degree", deg_r, NULL) + } else { + explain_degree_correlation("In-degree", indeg_r, NULL) + explain_degree_correlation("Out-degree", outdeg_r, NULL) + } + } +} + +print_multi_behavior_results <- function(x, undirected) { + correlations_matrix <- x$correlations + Q <- ncol(correlations_matrix) + beh_names <- colnames(correlations_matrix) + + # Print correlations matrix + cat("\nCorrelations:\n") + if (undirected) { + cat(" Degree - Time of Adoption:\n") + deg_row <- correlations_matrix["indegree_toa", ] + for (j in seq_len(Q)) { + bname <- if (length(beh_names)) beh_names[j] else paste0("B", j) + cat(sprintf(" [%s]: %.3f\n", bname, deg_row[j])) + } + } else { + cat(" In-degree - Time of Adoption:\n") + indeg_row <- correlations_matrix["indegree_toa", ] + for (j in seq_len(Q)) { + bname <- if (length(beh_names)) beh_names[j] else paste0("B", j) + cat(sprintf(" [%s]: %.3f\n", bname, indeg_row[j])) + } + cat(" Out-degree - Time of Adoption:\n") + outdeg_row <- correlations_matrix["outdegree_toa", ] + for (j in seq_len(Q)) { + bname <- if (length(beh_names)) beh_names[j] else paste0("B", j) + cat(sprintf(" [%s]: %.3f\n", bname, outdeg_row[j])) + } + } + + # Interpretation per behavior + cat("\nInterpretation:\n") + for (j in seq_len(Q)) { + bname <- if (length(beh_names)) beh_names[j] else paste0("B", j) + r_in <- correlations_matrix["indegree_toa", j] + r_out <- correlations_matrix["outdegree_toa", j] + + bootstrap_data <- if (!is.null(x$bootstrap)) x$bootstrap[[j]] else NULL + deg_ci <- if (undirected && !is.null(bootstrap_data) && !is.null(bootstrap_data$indegree$conf_int)) { + bootstrap_data$indegree$conf_int + } else NULL + indeg_ci <- if (!is.null(bootstrap_data) && !is.null(bootstrap_data$indegree$conf_int)) { + bootstrap_data$indegree$conf_int + } else NULL + outdeg_ci <- if (!is.null(bootstrap_data) && !is.null(bootstrap_data$outdegree$conf_int)) { + bootstrap_data$outdegree$conf_int + } else NULL + lvl <- if (!is.null(bootstrap_data) && !is.null(bootstrap_data$indegree$conf_level)) { + bootstrap_data$indegree$conf_level * 100 + } else NA_real_ + + cat(sprintf(" [%s]\n", bname)) + if (undirected) { + explain_degree_correlation("Degree", r_in, deg_ci, lvl_arg = lvl) + } else { + explain_degree_correlation("In-degree", r_in, indeg_ci, lvl_arg = lvl) + explain_degree_correlation("Out-degree", r_out, outdeg_ci, lvl_arg = lvl) + } + } +} + +# Helper function for explaining correlations +explain_degree_correlation <- function(label, r, ci, lvl_arg = NA_real_, thr = 0.10) { + # Handle NA correlations gracefully + if (is.na(r)) { + cat(sprintf( + " %s: Weak relationship between centrality and adoption timing:\n r is NA; no CI.\n", + label + )) + return(invisible()) + } + + abs_big <- abs(r) > thr + degree_term <- switch(label, + "In-degree" = "in-degree", + "Out-degree" = "out-degree", + "degree" + ) + + if (is.null(ci)) { + format_interpretation_no_ci(label, r, abs_big, degree_term, thr) + } else { + format_interpretation_with_ci(label, r, ci, abs_big, degree_term, thr, lvl_arg) + } +} + +format_interpretation_no_ci <- function(label, r, abs_big, degree_term, thr) { + if (!abs_big) { + cat(sprintf(" %s: Weak relationship between %s and adoption timing:\n |r| \u2264 %.1f; no CI.\n", + label, degree_term, thr)) + } else if (r > 0) { + cat(sprintf(" %s: Central actors (high %s) tended to adopt early (supporters):\n |r| > %.1f; no CI.\n", + label, degree_term, thr)) + } else { + cat(sprintf(" %s: Central actors (high %s) tended to adopt late (opposers):\n |r| > %.1f; no CI.\n", + label, degree_term, thr)) + } +} + +format_interpretation_with_ci <- function(label, r, ci, abs_big, degree_term, thr, lvl_arg) { + lvl_local <- if (!is.na(lvl_arg)) lvl_arg else 95 + ci_includes_zero <- (length(ci) >= 2) && is.finite(ci[1]) && is.finite(ci[2]) && (ci[1] <= 0 && ci[2] >= 0) + + if (!abs_big) { + cat(sprintf(" %s: Weak relationship between %s and adoption timing; %s statistically supported:\n |r| \u2264 %.1f; CI (%.1f%%) %s 0.\n", + label, degree_term, + if (ci_includes_zero) "NOT" else "", + thr, lvl_local, + if (ci_includes_zero) "includes" else "excludes")) + } else if (r > 0) { + cat(sprintf(" %s: Central actors (high %s) tended to adopt early (supporters); %s statistically supported:\n |r| > %.1f; CI (%.1f%%) %s 0.\n", + label, degree_term, + if (ci_includes_zero) "NOT" else "", + thr, lvl_local, + if (ci_includes_zero) "includes" else "excludes")) + } else { + cat(sprintf(" %s: Central actors (high %s) tended to adopt late (opposers); %s statistically supported:\n |r| > %.1f; CI (%.1f%%) %s 0.\n", + label, degree_term, + if (ci_includes_zero) "NOT" else "", + thr, lvl_local, + if (ci_includes_zero) "includes" else "excludes")) + } +} + +# Safe correlation: returns NA (no warnings) if zero-variance or too few pairs +cor_safe <- function(x, y) { + x <- as.numeric(x); y <- as.numeric(y) + ok <- is.finite(x) & is.finite(y) + if (!any(ok)) return(NA_real_) + x <- x[ok]; y <- y[ok] + if (length(x) < 2L) return(NA_real_) + if (sd(x) == 0 || sd(y) == 0) return(NA_real_) + stats::cor(x, y) +} diff --git a/README.md b/README.md index b92c0419..6db64b07 100644 --- a/README.md +++ b/README.md @@ -3,12 +3,11 @@ [![R-CMD-check](https://github.com/USCCANA/netdiffuseR/actions/workflows/r.yml/badge.svg)](https://github.com/USCCANA/netdiffuseR/actions/workflows/r.yml) [![codecov.io](https://codecov.io/github/USCCANA/netdiffuseR/coverage.svg?branch=master)](https://app.codecov.io/github/USCCANA/netdiffuseR?branch=master) [![](https://cranlogs.r-pkg.org/badges/netdiffuseR)](https://cran.r-project.org/package=netdiffuseR) -[![CRAN_Status_Badge](https://www.r-pkg.org/badges/version/netdiffuseR)](https://cran.r-project.org/package=netdiffuseR) +[![CRAN\_Status\_Badge](https://www.r-pkg.org/badges/version/netdiffuseR)](https://cran.r-project.org/package=netdiffuseR) [![](https://cranlogs.r-pkg.org/badges/grand-total/netdiffuseR)](https://cran.r-project.org/package=netdiffuseR) [![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.1039317.svg)](https://doi.org/10.5281/zenodo.1039317) [![Dependencies](https://tinyverse.netlify.app/badge/netdiffuseR)](https://cran.r-project.org/package=netdiffuseR) -[![USC’s Department of Preventive -Medicine](https://raw.githubusercontent.com/USCbiostats/badges/master/tommy-uscprevmed-badge.svg)](https://keck.usc.edu/cana/) +[![USC's Department of Preventive Medicine](https://raw.githubusercontent.com/USCbiostats/badges/master/tommy-uscprevmed-badge.svg)](https://keck.usc.edu/cana/)

@@ -42,24 +41,23 @@ Health. ``` r citation(package="netdiffuseR") -``` - - To cite netdiffuseR in publications use the following paper: +To cite netdiffuseR in publications use the following paper: - Valente TW, Vega Yon GG. Diffusion/Contagion Processes on Social - Networks. Health Education & Behavior. 2020;47(2):235-248. - doi:10.1177/1090198120901497 + Valente TW, Vega Yon GG. Diffusion/Contagion Processes on Social + Networks. Health Education & Behavior. 2020;47(2):235-248. + doi:10.1177/1090198120901497 - And the actual R package: +And the actual R package: - Vega Yon G, Olivera Morales A, Valente T (2025). _netdiffuseR: - Analysis of Diffusion and Contagion Processes on Networks_. - doi:10.5281/zenodo.1039317 , - R package version 1.23.0, . + Vega Yon G, Olivera Morales A, Valente T (2025). _netdiffuseR: + Analysis of Diffusion and Contagion Processes on Networks_. + doi:10.5281/zenodo.1039317 , + R package version 1.24.0, . - To see these entries in BibTeX format, use 'print(, - bibtex=TRUE)', 'toBibtex(.)', or set - 'options(citation.bibtex.max=999)'. +To see these entries in BibTeX format, use 'print(, +bibtex=TRUE)', 'toBibtex(.)', or set +'options(citation.bibtex.max=999)'. +``` ## News @@ -85,42 +83,19 @@ remotes::install_github('USCCANA/netdiffuseR', build_vignettes = TRUE) ``` You can skip building vignettes by setting `build_vignettes = FALSE` (so -it is not required). +it is not required). You can also get the package (pre-built binaries) +from our R-Universe repository (recommended): -For the case of OSX users, there seems to be a problem when installing -packages depending on `Rcpp`. This issue, developed -[here](https://github.com/USCCANA/netdiffuseR/issues/3), can be solved -by open the terminal and typing the following - -``` sh -curl -O http://r.research.att.com/libs/gfortran-4.8.2-darwin13.tar.bz2 -sudo tar fvxz gfortran-4.8.2-darwin13.tar.bz2 -C / +``` r +install.packages( + 'epiworldR', + repos = c( + 'https://uofuepibio.r-universe.dev', + 'https://cloud.r-project.org' + ) +) ``` -before installing the package through `devtools`. - -### Binary versions - -For the case of windows and mac users, they can find binary versions of -the package [here](https://github.com/USCCANA/netdiffuseR/releases), -netdiffuseR_1…zip, and netdiffuseR_1…tgz respectively. They can install -this directly as follows (using the 1.16.3.29 version): - -1. Install dependencies from CRAN - `r > install.packages(c("igraph", "Matrix", "SparseM", "RcppArmadillo", "sna"), dependencies=TRUE)` - -2. Download the binary version and install it as follows: - - ``` r - > install.packages("netdiffuseR_1.16.3.29.zip", repos=NULL) - ``` - - For windows users, and for Mac users: - - ``` r - > install.packages("netdiffuseR_1.16.3.29.tgz", repos=NULL) - ``` - ## Tutorials Since starting netdiffuseR, we have done a couple of workshops at @@ -141,15 +116,16 @@ This example has been taken from the package’s vignettes: ``` r library(netdiffuseR) +#> Thank you for using netdiffuseR! Please consider citing it in your work. +#> You can find the citation information by running +#> citation("netdiffuseR") +#> +#> Attaching package: 'netdiffuseR' +#> The following object is masked from 'package:base': +#> +#> %*% ``` - - Attaching package: 'netdiffuseR' - - The following object is masked from 'package:base': - - %*% - ### Infectiousness and Susceptibility ``` r @@ -160,81 +136,72 @@ nper <- 20 graph <- rgraph_er(n, nper, .5) toa <- sample(c(1:(1+nper-1), NA), n, TRUE) head(toa) -``` +#> [1] 16 3 14 3 13 5 - [1] 16 3 14 3 13 5 - -``` r # Creating a diffnet object diffnet <- as_diffnet(graph, toa) diffnet -``` - - Dynamic network of class -diffnet- - Name : Diffusion Network - Behavior : Unknown - # of nodes : 100 (1, 2, 3, 4, 5, 6, 7, 8, ...) - # of time periods : 20 (1 - 20) - Type : directed - Num of behaviors : 1 - Final prevalence : 0.95 - Static attributes : - - Dynamic attributes : - - -``` r +#> Dynamic network of class -diffnet- +#> Name : Diffusion Network +#> Behavior : Unknown +#> # of nodes : 100 (1, 2, 3, 4, 5, 6, 7, 8, ...) +#> # of time periods : 20 (1 - 20) +#> Type : directed +#> Num of behaviors : 1 +#> Final prevalence : 0.95 +#> Static attributes : - +#> Dynamic attributes : - summary(diffnet) -``` +#> Diffusion network summary statistics +#> Name : Diffusion Network +#> Behavior : Unknown +#> ----------------------------------------------------------------------------- +#> Period Adopters Cum Adopt. (%) Hazard Rate Density Moran's I (sd) +#> -------- ---------- ---------------- ------------- --------- ---------------- +#> 1 8 8 (0.08) - 0.50 -0.01 (0.00) +#> 2 3 11 (0.11) 0.03 0.50 -0.01 (0.00) +#> 3 6 17 (0.17) 0.07 0.51 -0.01 (0.00) +#> 4 3 20 (0.20) 0.04 0.49 -0.01 (0.00) +#> 5 9 29 (0.29) 0.11 0.50 -0.01 (0.00) +#> 6 5 34 (0.34) 0.07 0.50 -0.01 (0.00) +#> 7 2 36 (0.36) 0.03 0.51 -0.01 (0.00) +#> 8 3 39 (0.39) 0.05 0.50 -0.01 (0.00) +#> 9 5 44 (0.44) 0.08 0.50 -0.01 (0.00) +#> 10 1 45 (0.45) 0.02 0.49 -0.01 (0.00) +#> 11 3 48 (0.48) 0.05 0.50 -0.01 (0.00) +#> 12 6 54 (0.54) 0.12 0.50 -0.01 (0.00) +#> 13 8 62 (0.62) 0.17 0.50 -0.01 (0.00) +#> 14 9 71 (0.71) 0.24 0.50 -0.01 (0.00) +#> 15 5 76 (0.76) 0.17 0.50 -0.00 (0.00) ** +#> 16 7 83 (0.83) 0.29 0.50 -0.01 (0.00) +#> 17 5 88 (0.88) 0.29 0.49 -0.00 (0.00) *** +#> 18 4 92 (0.92) 0.33 0.50 -0.01 (0.00) +#> 19 1 93 (0.93) 0.12 0.50 -0.01 (0.00) +#> 20 2 95 (0.95) 0.29 0.50 -0.01 (0.00) +#> ----------------------------------------------------------------------------- +#> Left censoring : 0.08 (8) +#> Right centoring : 0.05 (5) +#> # of nodes : 100 +#> +#> Moran's I was computed on contemporaneous autocorrelation using 1/geodesic +#> values. Significane levels *** <= .01, ** <= .05, * <= .1. - Diffusion network summary statistics - Name : Diffusion Network - Behavior : Unknown - ----------------------------------------------------------------------------- - Period Adopters Cum Adopt. (%) Hazard Rate Density Moran's I (sd) - -------- ---------- ---------------- ------------- --------- ---------------- - 1 8 8 (0.08) - 0.50 -0.01 (0.00) - 2 3 11 (0.11) 0.03 0.50 -0.01 (0.00) - 3 6 17 (0.17) 0.07 0.51 -0.01 (0.00) - 4 3 20 (0.20) 0.04 0.49 -0.01 (0.00) - 5 9 29 (0.29) 0.11 0.50 -0.01 (0.00) - 6 5 34 (0.34) 0.07 0.50 -0.01 (0.00) - 7 2 36 (0.36) 0.03 0.51 -0.01 (0.00) - 8 3 39 (0.39) 0.05 0.50 -0.01 (0.00) - 9 5 44 (0.44) 0.08 0.50 -0.01 (0.00) - 10 1 45 (0.45) 0.02 0.49 -0.01 (0.00) - 11 3 48 (0.48) 0.05 0.50 -0.01 (0.00) - 12 6 54 (0.54) 0.12 0.50 -0.01 (0.00) - 13 8 62 (0.62) 0.17 0.50 -0.01 (0.00) - 14 9 71 (0.71) 0.24 0.50 -0.01 (0.00) - 15 5 76 (0.76) 0.17 0.50 -0.00 (0.00) ** - 16 7 83 (0.83) 0.29 0.50 -0.01 (0.00) - 17 5 88 (0.88) 0.29 0.49 -0.00 (0.00) *** - 18 4 92 (0.92) 0.33 0.50 -0.01 (0.00) - 19 1 93 (0.93) 0.12 0.50 -0.01 (0.00) - 20 2 95 (0.95) 0.29 0.50 -0.01 (0.00) - ----------------------------------------------------------------------------- - Left censoring : 0.08 (8) - Right centoring : 0.05 (5) - # of nodes : 100 - - Moran's I was computed on contemporaneous autocorrelation using 1/geodesic - values. Significane levels *** <= .01, ** <= .05, * <= .1. - -``` r # Visualizing distribution of suscep/infect out <- plot_infectsuscep(diffnet, bins = 20,K=5, logscale = FALSE, h=.01) ``` -![](README_files/figure-commonmark/plot_infectsuscept-1.png) + ``` r out <- plot_infectsuscep(diffnet, bins = 20,K=5, logscale = TRUE, exclude.zeros = TRUE, h=1) +#> Warning in plot_infectsuscep.list(graph$graph, graph$toa, t0, normalize, : When +#> applying logscale some observations are missing. ``` - Warning in plot_infectsuscep.list(graph$graph, graph$toa, t0, normalize, : When - applying logscale some observations are missing. - -![](README_files/figure-commonmark/plot_infectsuscept-2.png) + ### Threshold @@ -246,25 +213,23 @@ diffnet <- rdiffnet(500, 20, rgraph.args = list(m=3), threshold.dist = function(x) runif(1, .3, .7)) diffnet -``` - - Dynamic network of class -diffnet- - Name : A diffusion network - Behavior : Random contagion - # of nodes : 500 (1, 2, 3, 4, 5, 6, 7, 8, ...) - # of time periods : 20 (1 - 20) - Type : directed - Num of behaviors : 1 - Final prevalence : 1.00 - Static attributes : real_threshold (1) - Dynamic attributes : - +#> Dynamic network of class -diffnet- +#> Name : A diffusion network +#> Behavior : Random contagion +#> # of nodes : 500 (1, 2, 3, 4, 5, 6, 7, 8, ...) +#> # of time periods : 20 (1 - 20) +#> Type : directed +#> Num of behaviors : 1 +#> Final prevalence : 1.00 +#> Static attributes : real_threshold (1) +#> Dynamic attributes : - -``` r # Threshold with fixed vertex size plot_threshold(diffnet) ``` -![](README_files/figure-commonmark/BoringThreshold,%20plot_threshold-1.png) + Using more features @@ -278,12 +243,12 @@ plot_threshold( sub = "Note: Vertices' sizes and shapes given by degree and city respectively", jitter.factor = c(1,1), jitter.amount = c(.25,.025) ) +#> Warning in (function (graph, expo, toa, include_censored = FALSE, t0 = min(toa, +#> : -vertex.sides- will be coerced to integer. ``` - Warning in (function (graph, expo, toa, include_censored = FALSE, t0 = min(toa, - : -vertex.sides- will be coerced to integer. - -![](README_files/figure-commonmark/NiceThreshold-1.png) + ### Adoption rate @@ -291,7 +256,7 @@ plot_threshold( plot_adopters(diffnet) ``` -![](README_files/figure-commonmark/Adopters-1.png) + ### Hazard rate @@ -299,7 +264,7 @@ plot_adopters(diffnet) hazard_rate(diffnet) ``` -![](README_files/figure-commonmark/Hazard-1.png) + ### Diffusion process @@ -307,14 +272,15 @@ hazard_rate(diffnet) plot_diffnet(medInnovationsDiffNet, slices=c(1,9,8)) ``` -![](README_files/figure-commonmark/plot_diffnet-1.png) + ``` r diffnet.toa(brfarmersDiffNet)[brfarmersDiffNet$toa >= 1965] <- NA plot_diffnet2(brfarmersDiffNet, vertex.size = "indegree") ``` -![](README_files/figure-commonmark/plot_diffnet2-1.png) + ``` r set.seed(1231) @@ -344,7 +310,8 @@ mtext("Both networks have the same distribution on times of adoption", 1, outer = TRUE) ``` -![](README_files/figure-commonmark/plot_diffnet2%20with%20map-1.png) + ``` r par(oldpar) @@ -355,17 +322,14 @@ par(oldpar) ``` r out <- classify(kfamilyDiffNet, include_censored = TRUE) ftable(out) -``` - - thr Non-Adopters Very Low Thresh. Low Thresh. High Thresh. Very High Thresh. - toa - Non-Adopters 0.00 0.00 0.00 0.00 0.00 - Early Adopters 0.00 14.04 8.40 0.57 0.29 - Early Majority 0.00 5.64 11.65 5.54 2.58 - Late Majority 0.00 1.34 5.06 6.21 2.96 - Laggards 0.00 1.53 0.00 0.00 34.19 +#> thr Non-Adopters Very Low Thresh. Low Thresh. High Thresh. Very High Thresh. +#> toa +#> Non-Adopters 0.00 0.00 0.00 0.00 0.00 +#> Early Adopters 0.00 14.04 8.40 0.57 0.29 +#> Early Majority 0.00 5.64 11.65 5.54 2.58 +#> Late Majority 0.00 1.34 5.06 6.21 2.96 +#> Laggards 0.00 1.53 0.00 0.00 34.19 -``` r # Plotting oldpar <- par(no.readonly = TRUE) par(xpd=TRUE) @@ -377,7 +341,7 @@ legend("bottom", legend = levels(out$thr), fill=viridisLite::inferno(5), horiz = cex=.6, bty="n", inset=c(0,-.1)) ``` -![](README_files/figure-commonmark/mosaic-1.png) + ``` r par(oldpar) @@ -387,44 +351,48 @@ par(oldpar) ``` r sessionInfo() +#> R version 4.5.2 (2025-10-31) +#> Platform: x86_64-pc-linux-gnu +#> Running under: Ubuntu 24.04.3 LTS +#> +#> Matrix products: default +#> BLAS: /usr/lib/x86_64-linux-gnu/openblas-pthread/libblas.so.3 +#> LAPACK: /usr/lib/x86_64-linux-gnu/openblas-pthread/libopenblasp-r0.3.26.so; LAPACK version 3.12.0 +#> +#> locale: +#> [1] LC_CTYPE=en_US.UTF-8 LC_NUMERIC=C +#> [3] LC_TIME=en_US.UTF-8 LC_COLLATE=en_US.UTF-8 +#> [5] LC_MONETARY=en_US.UTF-8 LC_MESSAGES=en_US.UTF-8 +#> [7] LC_PAPER=en_US.UTF-8 LC_NAME=C +#> [9] LC_ADDRESS=C LC_TELEPHONE=C +#> [11] LC_MEASUREMENT=en_US.UTF-8 LC_IDENTIFICATION=C +#> +#> time zone: Etc/UTC +#> tzcode source: system (glibc) +#> +#> attached base packages: +#> [1] stats graphics grDevices utils datasets methods base +#> +#> other attached packages: +#> [1] netdiffuseR_1.24.0 +#> +#> loaded via a namespace (and not attached): +#> [1] Matrix_1.7-4 jsonlite_2.0.0 dplyr_1.1.4 +#> [4] compiler_4.5.2 tidyselect_1.2.1 Rcpp_1.1.0 +#> [7] networkLite_1.1.0 boot_1.3-32 yaml_2.3.10 +#> [10] fastmap_1.2.0 lattice_0.22-7 coda_0.19-4.1 +#> [13] R6_2.6.1 generics_0.1.4 MatchIt_4.7.2 +#> [16] igraph_2.2.1 knitr_1.50 MASS_7.3-65 +#> [19] backports_1.5.0 tibble_3.3.0 statnet.common_4.12.0 +#> [22] pillar_1.11.1 rlang_1.1.6 xfun_0.53 +#> [25] viridisLite_0.4.2 cli_3.6.5 magrittr_2.0.4 +#> [28] network_1.19.0 digest_0.6.37 grid_4.5.2 +#> [31] lifecycle_1.0.4 vctrs_0.6.5 sna_2.8 +#> [34] evaluate_1.0.5 SparseM_1.84-2 glue_1.8.0 +#> [37] rmarkdown_2.30 tools_4.5.2 pkgconfig_2.0.3 +#> [40] networkDynamic_0.11.5 htmltools_0.5.8.1 ``` - R version 4.5.0 (2025-04-11) - Platform: aarch64-apple-darwin24.2.0 - Running under: macOS Sequoia 15.0.1 - - Matrix products: default - BLAS: /opt/homebrew/Cellar/openblas/0.3.29/lib/libopenblasp-r0.3.29.dylib - LAPACK: /opt/homebrew/Cellar/r/4.5.0/lib/R/lib/libRlapack.dylib; LAPACK version 3.12.1 - - locale: - [1] en_US.UTF-8/en_US.UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8 - - time zone: America/Denver - tzcode source: internal - - attached base packages: - [1] stats graphics grDevices utils datasets methods base - - other attached packages: - [1] netdiffuseR_1.23.0 - - loaded via a namespace (and not attached): - [1] Matrix_1.7-3 jsonlite_2.0.0 dplyr_1.1.4 - [4] compiler_4.5.0 tidyselect_1.2.1 Rcpp_1.0.14 - [7] networkLite_1.1.0 boot_1.3-31 yaml_2.3.10 - [10] fastmap_1.2.0 lattice_0.22-6 coda_0.19-4.1 - [13] R6_2.6.1 generics_0.1.4 MatchIt_4.7.2 - [16] igraph_2.1.4.9046 knitr_1.50 MASS_7.3-65 - [19] backports_1.5.0 tibble_3.3.0 statnet.common_4.12.0 - [22] pillar_1.10.2 rlang_1.1.6 xfun_0.52 - [25] viridisLite_0.4.2 cli_3.6.5 magrittr_2.0.3 - [28] network_1.19.0 digest_0.6.37 grid_4.5.0 - [31] lifecycle_1.0.4 vctrs_0.6.5 sna_2.8 - [34] evaluate_1.0.3 SparseM_1.84-2 glue_1.8.0 - [37] rmarkdown_2.29 tools_4.5.0 pkgconfig_2.0.3 - [40] networkDynamic_0.11.5 htmltools_0.5.8.1 - ## To-do list - Import/Export functions for interfacing other package’s clases, in diff --git a/README.qmd b/README.qmd index f279f82b..efcb6bed 100644 --- a/README.qmd +++ b/README.qmd @@ -2,6 +2,18 @@ format: gfm --- +```{r} +#| label: setup +#| echo: false +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>", + fig.path = "man/figures/README-", + out.width = "100%" +) +``` + +```{=markdown} [![R-CMD-check](https://github.com/USCCANA/netdiffuseR/actions/workflows/r.yml/badge.svg)](https://github.com/USCCANA/netdiffuseR/actions/workflows/r.yml) [![codecov.io](https://codecov.io/github/USCCANA/netdiffuseR/coverage.svg?branch=master)](https://app.codecov.io/github/USCCANA/netdiffuseR?branch=master) [![](https://cranlogs.r-pkg.org/badges/netdiffuseR)](https://cran.r-project.org/package=netdiffuseR) @@ -10,6 +22,7 @@ format: gfm [![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.1039317.svg)](https://doi.org/10.5281/zenodo.1039317) [![Dependencies](https://tinyverse.netlify.app/badge/netdiffuseR)](https://cran.r-project.org/package=netdiffuseR) [![USC's Department of Preventive Medicine](https://raw.githubusercontent.com/USCbiostats/badges/master/tommy-uscprevmed-badge.svg)](https://keck.usc.edu/cana/) +```

netdiffuseR: Analysis of Diffusion and Contagion Processes on Networks

@@ -59,41 +72,18 @@ If you want the latest (unstable) version of __netdiffuseR__, using the `remotes remotes::install_github('USCCANA/netdiffuseR', build_vignettes = TRUE) ``` -You can skip building vignettes by setting `build_vignettes = FALSE` (so it is not required). +You can skip building vignettes by setting `build_vignettes = FALSE` (so it is not required). You can also get the package (pre-built binaries) from our R-Universe repository (recommended): -For the case of OSX users, there seems to be a problem when installing packages -depending on `Rcpp`. This issue, developed [here](https://github.com/USCCANA/netdiffuseR/issues/3), -can be solved by open the terminal and typing the following - -```sh -curl -O http://r.research.att.com/libs/gfortran-4.8.2-darwin13.tar.bz2 -sudo tar fvxz gfortran-4.8.2-darwin13.tar.bz2 -C / +```r +install.packages( + 'epiworldR', + repos = c( + 'https://uofuepibio.r-universe.dev', + 'https://cloud.r-project.org' + ) +) ``` -before installing the package through `devtools`. - -### Binary versions - -For the case of windows and mac users, they can find binary versions of the package [here](https://github.com/USCCANA/netdiffuseR/releases), netdiffuseR_1...zip, and netdiffuseR_1...tgz respectively. They can install this directly as follows (using the 1.16.3.29 version): - - -1. Install dependencies from CRAN - ``` r - > install.packages(c("igraph", "Matrix", "SparseM", "RcppArmadillo", "sna"), dependencies=TRUE) - ``` - -2. Download the binary version and install it as follows: - - ``` r - > install.packages("netdiffuseR_1.16.3.29.zip", repos=NULL) - ``` - - For windows users, and for Mac users: - - ``` r - > install.packages("netdiffuseR_1.16.3.29.tgz", repos=NULL) - ``` - ## Tutorials Since starting netdiffuseR, we have done a couple of workshops at Sunbelt and NASN. Past and current workshops can be found at @@ -137,7 +127,7 @@ out <- plot_infectsuscep(diffnet, bins = 20,K=5, logscale = TRUE, ### Threshold -```{r BoringThreshold, plot_threshold, fig.height=7} +```{r BoringThreshold, fig.height=7} # Generating a random graph set.seed(123) diffnet <- rdiffnet(500, 20, @@ -190,7 +180,7 @@ diffnet.toa(brfarmersDiffNet)[brfarmersDiffNet$toa >= 1965] <- NA plot_diffnet2(brfarmersDiffNet, vertex.size = "indegree") ``` -```{r plot_diffnet2 with map, } +```{r plot_diffnet2-withmap} set.seed(1231) # Random scale-free diffusion network diff --git a/README_files/figure-gfm/Adopters-1.png b/README_files/figure-gfm/Adopters-1.png deleted file mode 100644 index 09fd0205..00000000 Binary files a/README_files/figure-gfm/Adopters-1.png and /dev/null differ diff --git a/README_files/figure-gfm/BoringThreshold, plot_threshold-1.png b/README_files/figure-gfm/BoringThreshold, plot_threshold-1.png deleted file mode 100644 index 7309b7fd..00000000 Binary files a/README_files/figure-gfm/BoringThreshold, plot_threshold-1.png and /dev/null differ diff --git a/README_files/figure-gfm/Hazard-1.png b/README_files/figure-gfm/Hazard-1.png deleted file mode 100644 index 1ae2dd39..00000000 Binary files a/README_files/figure-gfm/Hazard-1.png and /dev/null differ diff --git a/README_files/figure-gfm/NiceThreshold-1.png b/README_files/figure-gfm/NiceThreshold-1.png deleted file mode 100644 index 62b9cc37..00000000 Binary files a/README_files/figure-gfm/NiceThreshold-1.png and /dev/null differ diff --git a/README_files/figure-gfm/mosaic-1.png b/README_files/figure-gfm/mosaic-1.png deleted file mode 100644 index 07ce77c8..00000000 Binary files a/README_files/figure-gfm/mosaic-1.png and /dev/null differ diff --git a/README_files/figure-gfm/plot_diffnet-1.png b/README_files/figure-gfm/plot_diffnet-1.png deleted file mode 100644 index 8451a4f3..00000000 Binary files a/README_files/figure-gfm/plot_diffnet-1.png and /dev/null differ diff --git a/README_files/figure-gfm/plot_diffnet2 with map-1.png b/README_files/figure-gfm/plot_diffnet2 with map-1.png deleted file mode 100644 index 802503bd..00000000 Binary files a/README_files/figure-gfm/plot_diffnet2 with map-1.png and /dev/null differ diff --git a/README_files/figure-gfm/plot_diffnet2-1.png b/README_files/figure-gfm/plot_diffnet2-1.png deleted file mode 100644 index 91bc1eeb..00000000 Binary files a/README_files/figure-gfm/plot_diffnet2-1.png and /dev/null differ diff --git a/README_files/figure-gfm/plot_infectsuscept-1.png b/README_files/figure-gfm/plot_infectsuscept-1.png deleted file mode 100644 index 3746c70c..00000000 Binary files a/README_files/figure-gfm/plot_infectsuscept-1.png and /dev/null differ diff --git a/README_files/figure-gfm/plot_infectsuscept-2.png b/README_files/figure-gfm/plot_infectsuscept-2.png deleted file mode 100644 index ff55eae7..00000000 Binary files a/README_files/figure-gfm/plot_infectsuscept-2.png and /dev/null differ diff --git a/README_files/figure-markdown_github/Adopters-1.png b/README_files/figure-markdown_github/Adopters-1.png deleted file mode 100644 index 9b117b7a..00000000 Binary files a/README_files/figure-markdown_github/Adopters-1.png and /dev/null differ diff --git a/README_files/figure-markdown_github/BoringThreshold, plot_threshold-1.png b/README_files/figure-markdown_github/BoringThreshold, plot_threshold-1.png deleted file mode 100644 index 59e1d085..00000000 Binary files a/README_files/figure-markdown_github/BoringThreshold, plot_threshold-1.png and /dev/null differ diff --git a/README_files/figure-markdown_github/Hazard-1.png b/README_files/figure-markdown_github/Hazard-1.png deleted file mode 100644 index 69201d6c..00000000 Binary files a/README_files/figure-markdown_github/Hazard-1.png and /dev/null differ diff --git a/README_files/figure-markdown_github/NiceThreshold-1.png b/README_files/figure-markdown_github/NiceThreshold-1.png deleted file mode 100644 index b13c9074..00000000 Binary files a/README_files/figure-markdown_github/NiceThreshold-1.png and /dev/null differ diff --git a/README_files/figure-markdown_github/mosaic-1.png b/README_files/figure-markdown_github/mosaic-1.png deleted file mode 100644 index ded4b1f9..00000000 Binary files a/README_files/figure-markdown_github/mosaic-1.png and /dev/null differ diff --git a/README_files/figure-markdown_github/plot_diffnet-1.png b/README_files/figure-markdown_github/plot_diffnet-1.png deleted file mode 100644 index 4eeab5ae..00000000 Binary files a/README_files/figure-markdown_github/plot_diffnet-1.png and /dev/null differ diff --git a/README_files/figure-markdown_github/plot_diffnet2 with map-1.png b/README_files/figure-markdown_github/plot_diffnet2 with map-1.png deleted file mode 100644 index 632938de..00000000 Binary files a/README_files/figure-markdown_github/plot_diffnet2 with map-1.png and /dev/null differ diff --git a/README_files/figure-markdown_github/plot_diffnet2-1.png b/README_files/figure-markdown_github/plot_diffnet2-1.png deleted file mode 100644 index 6e2c08e4..00000000 Binary files a/README_files/figure-markdown_github/plot_diffnet2-1.png and /dev/null differ diff --git a/README_files/figure-markdown_github/plot_infectsuscept-1.png b/README_files/figure-markdown_github/plot_infectsuscept-1.png deleted file mode 100644 index 999e3c01..00000000 Binary files a/README_files/figure-markdown_github/plot_infectsuscept-1.png and /dev/null differ diff --git a/README_files/figure-markdown_github/plot_infectsuscept-2.png b/README_files/figure-markdown_github/plot_infectsuscept-2.png deleted file mode 100644 index 5f19727f..00000000 Binary files a/README_files/figure-markdown_github/plot_infectsuscept-2.png and /dev/null differ diff --git a/man/bass.Rd b/man/bass.Rd index c6512d3b..af305b08 100644 --- a/man/bass.Rd +++ b/man/bass.Rd @@ -138,6 +138,7 @@ Available at: \url{https://web.archive.org/web/20220331222618/http://www.bassbas Other statistics: \code{\link{classify_adopters}()}, \code{\link{cumulative_adopt_count}()}, +\code{\link{degree_adoption_diagnostic}()}, \code{\link{dgr}()}, \code{\link{ego_variance}()}, \code{\link{exposure}()}, diff --git a/man/classify_adopters.Rd b/man/classify_adopters.Rd index 7d32e0ac..4d3d41d1 100644 --- a/man/classify_adopters.Rd +++ b/man/classify_adopters.Rd @@ -138,6 +138,7 @@ Valente, T. W. (1995). "Network models of the diffusion of innovations" Other statistics: \code{\link{bass}}, \code{\link{cumulative_adopt_count}()}, +\code{\link{degree_adoption_diagnostic}()}, \code{\link{dgr}()}, \code{\link{ego_variance}()}, \code{\link{exposure}()}, diff --git a/man/cumulative_adopt_count.Rd b/man/cumulative_adopt_count.Rd index c78f340a..61d443b9 100644 --- a/man/cumulative_adopt_count.Rd +++ b/man/cumulative_adopt_count.Rd @@ -31,6 +31,7 @@ it is only calculated fot \eqn{t>1}. Other statistics: \code{\link{bass}}, \code{\link{classify_adopters}()}, +\code{\link{degree_adoption_diagnostic}()}, \code{\link{dgr}()}, \code{\link{ego_variance}()}, \code{\link{exposure}()}, diff --git a/man/degree_adoption_diagnostic.Rd b/man/degree_adoption_diagnostic.Rd new file mode 100644 index 00000000..0ddeb9ff --- /dev/null +++ b/man/degree_adoption_diagnostic.Rd @@ -0,0 +1,149 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/degree_adoption_diagnostic.R +\name{degree_adoption_diagnostic} +\alias{degree_adoption_diagnostic} +\title{Degree and Time of Adoption Diagnostic} +\usage{ +degree_adoption_diagnostic( + graph, + degree_strategy = c("mean", "first", "last"), + bootstrap = TRUE, + R = 1000, + conf.level = 0.95, + toa = NULL, + t0 = NULL, + t1 = NULL, + name = NULL, + behavior = NULL, + combine = c("none", "pooled", "average", "earliest"), + min_adopters = 3, + valued = getOption("diffnet.valued", FALSE), + ... +) +} +\arguments{ +\item{graph}{A `[diffnet()]` object or a graph data structure (classes include +`array` (\eqn{n\times n \times T}{n*n*T}), `dgCMatrix` (sparse), +`igraph`, etc.; see [netdiffuseR-graphs]).} + +\item{degree_strategy}{Character scalar. How to aggregate degree measures across +time periods: +- `"mean"` (default): Average degree across all time periods +- `"first"`: Degree in the first time period +- `"last"`: Degree in the last time period} + +\item{bootstrap}{Logical scalar. Whether to compute bootstrap confidence intervals.} + +\item{R}{Integer scalar. Number of bootstrap replicates (default 1000).} + +\item{conf.level}{Numeric scalar. Confidence level for bootstrap intervals (default 0.95).} + +\item{toa}{Integer vector of length \eqn{n} (single behavior) or an \eqn{n\times Q}{n*Q} +matrix (multi-behavior) with times of adoption. Required when `graph` is not a `diffnet`.} + +\item{t0, t1}{Optional integer scalars defining the first and last observed +periods. If missing and `toa` is provided, `t0` defaults to 1 +and `t1` to `max(toa, na.rm=TRUE)`.} + +\item{name}{Optional character scalars used only when coercing +inputs into a `diffnet` object (passed to `new_diffnet`).} + +\item{behavior}{Which behaviors to include when `toa` is a matrix (multi-diffusion). +Can be `NULL` (all), a numeric index vector, or a character vector matching `colnames(toa)`.} + +\item{combine}{Character scalar. How to combine multiple behaviors when `toa` is a matrix: +- `"none"` (analyze each behavior separately) +- `"pooled"` (stack rows across behaviors) +- `"average"` (per-actor mean of TOA across selected behaviors) +- `"earliest"` (per-actor minimum TOA) +Ignored for single-behavior.} + +\item{min_adopters}{Integer scalar. Minimum number of adopters required to compute correlations +for any analysis cell (default 3).} + +\item{valued}{Logical scalar. Whether to use edge weights in degree calculations.} + +\item{...}{Additional arguments passed on when coercing to `diffnet`.} +} +\value{ +When analyzing a single behavior (or when `combine!="none"`), a list with: +\item{correlations}{Named numeric vector with correlations between in-degree/out-degree and time of adoption} +\item{bootstrap}{List with bootstrap results when `bootstrap = TRUE`, otherwise `NULL`} +\item{call}{The matched call} +\item{degree_strategy}{The degree aggregation strategy used} +\item{sample_size}{Number of rows included in the analysis (adopter rows)} +\item{combine}{`NULL` for single-behavior; otherwise the combination rule used.} + +When `combine="none"` with multiple behaviors, returns the same structure, except: +- `correlations` is a \eqn{2\times Q^*}{2 x Q*} matrix with rows `c("indegree_toa","outdegree_toa")` + and one column per analyzed behavior. +- `bootstrap` is a named list with one entry per behavior (each like the single-behavior case), or `NULL` if `bootstrap=FALSE`. +- `sample_size` is an integer vector named by behavior. +- `combine` is `"none"`. +} +\description{ +Analyzes the correlation between in-degree, out-degree, and time of adoption +to identify whether opinion leaders were early adopters (supporters) or late +adopters (opposers). +} +\details{ +This diagnostic function computes correlations between degree centrality measures +(in-degree and out-degree) and time of adoption. Positive correlations suggest +that central actors (opinion leaders) adopted early, while negative correlations +suggest they adopted late. + +When `bootstrap = TRUE`, the function uses the `boot` package to +compute bootstrap confidence intervals for the correlations. + +When `toa` is a matrix (multi-diffusion), degree vectors are computed once and +reused; the time of adoption is combined according to `combine`: +- `"none"`: computes separate results per behavior (see Value). +- `"pooled"`: stacks (actor, behavior) rows for adopters and runs a single analysis. +- `"average"`: one row per actor using the mean TOA of adopted behaviors. +- `"earliest"`: one row per actor using the minimum TOA of adopted behaviors. +} +\examples{ +# Basic usage with Korean Family Planning data +data(kfamilyDiffNet) +result_basics <- degree_adoption_diagnostic(kfamilyDiffNet, bootstrap = FALSE) +print(result_basics) + +# With bootstrap confidence intervals +result_boot <- degree_adoption_diagnostic(kfamilyDiffNet) +print(result_boot) + +# Different degree aggregation strategies +result_first <- degree_adoption_diagnostic(kfamilyDiffNet, degree_strategy = "first") +result_last <- degree_adoption_diagnostic(kfamilyDiffNet, degree_strategy = "last") + +# Multi-diffusion (toy) ---------------------------------------------------- +set.seed(999) +n <- 40; t <- 5; q <- 2 +garr <- rgraph_ws(n, t, p=.3) +diffnet_multi <- rdiffnet(seed.graph = garr, t = t, seed.p.adopt = rep(list(0.1), q)) + +# pooled (one combined analysis) +degree_adoption_diagnostic(diffnet_multi, combine = "pooled", bootstrap = FALSE) + +# per-behavior (matrix of correlations; one column per behavior) +degree_adoption_diagnostic(diffnet_multi, combine = "none", bootstrap = FALSE) + +} +\seealso{ +`[dgr()]`, `[diffreg()]`, `[exposure()]` + +Other statistics: +\code{\link{bass}}, +\code{\link{classify_adopters}()}, +\code{\link{cumulative_adopt_count}()}, +\code{\link{dgr}()}, +\code{\link{ego_variance}()}, +\code{\link{exposure}()}, +\code{\link{hazard_rate}()}, +\code{\link{infection}()}, +\code{\link{moran}()}, +\code{\link{struct_equiv}()}, +\code{\link{threshold}()}, +\code{\link{vertex_covariate_dist}()} +} +\concept{statistics} diff --git a/man/dgr.Rd b/man/dgr.Rd index cd9c08b9..74505909 100644 --- a/man/dgr.Rd +++ b/man/dgr.Rd @@ -104,6 +104,7 @@ Other statistics: \code{\link{bass}}, \code{\link{classify_adopters}()}, \code{\link{cumulative_adopt_count}()}, +\code{\link{degree_adoption_diagnostic}()}, \code{\link{ego_variance}()}, \code{\link{exposure}()}, \code{\link{hazard_rate}()}, diff --git a/man/ego_variance.Rd b/man/ego_variance.Rd index 5a7d6dc8..95608959 100644 --- a/man/ego_variance.Rd +++ b/man/ego_variance.Rd @@ -49,6 +49,7 @@ Other statistics: \code{\link{bass}}, \code{\link{classify_adopters}()}, \code{\link{cumulative_adopt_count}()}, +\code{\link{degree_adoption_diagnostic}()}, \code{\link{dgr}()}, \code{\link{exposure}()}, \code{\link{hazard_rate}()}, diff --git a/man/exposure.Rd b/man/exposure.Rd index 62ee4cbd..82f3531b 100644 --- a/man/exposure.Rd +++ b/man/exposure.Rd @@ -278,6 +278,7 @@ Other statistics: \code{\link{bass}}, \code{\link{classify_adopters}()}, \code{\link{cumulative_adopt_count}()}, +\code{\link{degree_adoption_diagnostic}()}, \code{\link{dgr}()}, \code{\link{ego_variance}()}, \code{\link{hazard_rate}()}, diff --git a/man/figures/README-Adopters-1.png b/man/figures/README-Adopters-1.png new file mode 100644 index 00000000..51a8c5a7 Binary files /dev/null and b/man/figures/README-Adopters-1.png differ diff --git a/man/figures/README-BoringThreshold-1.png b/man/figures/README-BoringThreshold-1.png new file mode 100644 index 00000000..2293166d Binary files /dev/null and b/man/figures/README-BoringThreshold-1.png differ diff --git a/man/figures/README-Hazard-1.png b/man/figures/README-Hazard-1.png new file mode 100644 index 00000000..dcf26199 Binary files /dev/null and b/man/figures/README-Hazard-1.png differ diff --git a/man/figures/README-NiceThreshold-1.png b/man/figures/README-NiceThreshold-1.png new file mode 100644 index 00000000..e9535ec4 Binary files /dev/null and b/man/figures/README-NiceThreshold-1.png differ diff --git a/man/figures/README-mosaic-1.png b/man/figures/README-mosaic-1.png new file mode 100644 index 00000000..da05c373 Binary files /dev/null and b/man/figures/README-mosaic-1.png differ diff --git a/man/figures/README-plot_diffnet-1.png b/man/figures/README-plot_diffnet-1.png new file mode 100644 index 00000000..6641c26c Binary files /dev/null and b/man/figures/README-plot_diffnet-1.png differ diff --git a/man/figures/README-plot_diffnet2-1.png b/man/figures/README-plot_diffnet2-1.png new file mode 100644 index 00000000..cbe91990 Binary files /dev/null and b/man/figures/README-plot_diffnet2-1.png differ diff --git a/man/figures/README-plot_diffnet2-withmap-1.png b/man/figures/README-plot_diffnet2-withmap-1.png new file mode 100644 index 00000000..92cd7a23 Binary files /dev/null and b/man/figures/README-plot_diffnet2-withmap-1.png differ diff --git a/man/figures/README-plot_infectsuscept-1.png b/man/figures/README-plot_infectsuscept-1.png new file mode 100644 index 00000000..15d19e43 Binary files /dev/null and b/man/figures/README-plot_infectsuscept-1.png differ diff --git a/man/figures/README-plot_infectsuscept-2.png b/man/figures/README-plot_infectsuscept-2.png new file mode 100644 index 00000000..60e2f869 Binary files /dev/null and b/man/figures/README-plot_infectsuscept-2.png differ diff --git a/man/hazard_rate.Rd b/man/hazard_rate.Rd index c2f8fccd..0fe42da5 100644 --- a/man/hazard_rate.Rd +++ b/man/hazard_rate.Rd @@ -131,6 +131,7 @@ Other statistics: \code{\link{bass}}, \code{\link{classify_adopters}()}, \code{\link{cumulative_adopt_count}()}, +\code{\link{degree_adoption_diagnostic}()}, \code{\link{dgr}()}, \code{\link{ego_variance}()}, \code{\link{exposure}()}, diff --git a/man/infection.Rd b/man/infection.Rd index 02f2bad9..40531e78 100644 --- a/man/infection.Rd +++ b/man/infection.Rd @@ -149,6 +149,7 @@ Other statistics: \code{\link{bass}}, \code{\link{classify_adopters}()}, \code{\link{cumulative_adopt_count}()}, +\code{\link{degree_adoption_diagnostic}()}, \code{\link{dgr}()}, \code{\link{ego_variance}()}, \code{\link{exposure}()}, diff --git a/man/moran.Rd b/man/moran.Rd index d8b285bf..756ab5da 100644 --- a/man/moran.Rd +++ b/man/moran.Rd @@ -65,6 +65,7 @@ Other statistics: \code{\link{bass}}, \code{\link{classify_adopters}()}, \code{\link{cumulative_adopt_count}()}, +\code{\link{degree_adoption_diagnostic}()}, \code{\link{dgr}()}, \code{\link{ego_variance}()}, \code{\link{exposure}()}, diff --git a/man/struct_equiv.Rd b/man/struct_equiv.Rd index d2495b89..07673efb 100644 --- a/man/struct_equiv.Rd +++ b/man/struct_equiv.Rd @@ -111,6 +111,7 @@ Other statistics: \code{\link{bass}}, \code{\link{classify_adopters}()}, \code{\link{cumulative_adopt_count}()}, +\code{\link{degree_adoption_diagnostic}()}, \code{\link{dgr}()}, \code{\link{ego_variance}()}, \code{\link{exposure}()}, diff --git a/man/threshold.Rd b/man/threshold.Rd index 8926c026..23032cb6 100644 --- a/man/threshold.Rd +++ b/man/threshold.Rd @@ -67,6 +67,7 @@ Other statistics: \code{\link{bass}}, \code{\link{classify_adopters}()}, \code{\link{cumulative_adopt_count}()}, +\code{\link{degree_adoption_diagnostic}()}, \code{\link{dgr}()}, \code{\link{ego_variance}()}, \code{\link{exposure}()}, diff --git a/man/vertex_covariate_dist.Rd b/man/vertex_covariate_dist.Rd index 6cac7bc3..9f094899 100644 --- a/man/vertex_covariate_dist.Rd +++ b/man/vertex_covariate_dist.Rd @@ -88,6 +88,7 @@ Other statistics: \code{\link{bass}}, \code{\link{classify_adopters}()}, \code{\link{cumulative_adopt_count}()}, +\code{\link{degree_adoption_diagnostic}()}, \code{\link{dgr}()}, \code{\link{ego_variance}()}, \code{\link{exposure}()}, diff --git a/tests/testthat/test-degree-adoption-diagnostic.R b/tests/testthat/test-degree-adoption-diagnostic.R new file mode 100644 index 00000000..90f71c51 --- /dev/null +++ b/tests/testthat/test-degree-adoption-diagnostic.R @@ -0,0 +1,391 @@ +context("Degree and Time of Adoption Diagnostic") + +test_that("degree_adoption_diagnostic works with basic inputs", { + # Create a simple test diffnet + set.seed(123) + dn <- rdiffnet(30, 4, seed.p.adopt = 0.2) + + # Basic test + result <- degree_adoption_diagnostic(dn, bootstrap = FALSE) + + expect_s3_class(result, "degree_adoption_diagnostic") + expect_setequal(names(result), c("correlations","bootstrap","call","degree_strategy","sample_size","combine","undirected")) + expect_named(result$correlations, c("indegree_toa", "outdegree_toa")) + expect_type(result$correlations, "double") + expect_length(result$correlations, 2) + expect_null(result$bootstrap) + expect_equal(result$degree_strategy, "mean") + expect_gt(result$sample_size, 0) +}) + +test_that("degree_adoption_diagnostic works with different degree strategies", { + set.seed(456) + dn <- rdiffnet(25, 3, seed.p.adopt = 0.3) + + result_mean <- degree_adoption_diagnostic(dn, degree_strategy = "mean", bootstrap = FALSE) + result_first <- degree_adoption_diagnostic(dn, degree_strategy = "first", bootstrap = FALSE) + result_last <- degree_adoption_diagnostic(dn, degree_strategy = "last", bootstrap = FALSE) + + expect_equal(result_mean$degree_strategy, "mean") + expect_equal(result_first$degree_strategy, "first") + expect_equal(result_last$degree_strategy, "last") + + # Different strategies should potentially give different results + expect_true( + !all(result_mean$correlations == result_first$correlations) || + !all(result_mean$correlations == result_last$correlations) + ) +}) + +test_that("degree_adoption_diagnostic bootstrap works", { + set.seed(789) + dn <- rdiffnet(20, 3, seed.p.adopt = 0.4) + + # Skip if boot package not available + skip_if_not_installed("boot") + + result <- degree_adoption_diagnostic(dn, bootstrap = TRUE, R = 50, conf.level = 0.9) + + expect_false(is.null(result$bootstrap)) + expect_setequal(names(result$bootstrap), c("indegree","outdegree","R","boot_object")) + expect_equal(result$bootstrap$R, 50) + + # Check bootstrap structure for indegree + expect_true(all(c("correlation") %in% names(result$bootstrap$indegree))) + if (!is.null(result$bootstrap$indegree$conf_int)) { + expect_true(all(c("bias","std_error","conf_int","conf_level") %in% names(result$bootstrap$indegree))) + expect_equal(result$bootstrap$indegree$conf_level, 0.9) + expect_length(result$bootstrap$indegree$conf_int, 2) + } + + # Check bootstrap structure for outdegree (can be degenerate/NA) + od <- result$bootstrap$outdegree + expect_true("correlation" %in% names(od)) + if (!is.na(result$correlations[["outdegree_toa"]])) { + # fully-formed bootstrap stats expected + expect_true(all(c("bias","std_error","conf_int","conf_level") %in% names(od))) + expect_equal(od$conf_level, 0.9) + expect_length(od$conf_int, 2) + } else { + # degenerate case: allow missing CI/SE/CL when correlation is NA + expect_true(is.null(od$conf_int) || length(od$conf_int) == 0) + } +}) + +test_that("degree_adoption_diagnostic handles edge cases", { + # Test with diffnet that has no adopters + set.seed(111) + dn <- rdiffnet(100, 3, seed.p.adopt = 0.1) + dn$toa[] <- NA # Force no adopters + + expect_error( + degree_adoption_diagnostic(dn, bootstrap = FALSE), + "Insufficient adopters for correlation analysis" + ) + + # Test with insufficient adopters + set.seed(222) + dn <- rdiffnet(100, 3, seed.p.adopt = 0.1) + # Force only 2 adopters + dn$toa[!is.na(dn$toa)][-(1:2)] <- NA + + expect_error( + degree_adoption_diagnostic(dn, bootstrap = FALSE), + "Insufficient adopters for correlation analysis" + ) +}) + +test_that("degree_adoption_diagnostic input validation", { + set.seed(333) + dn <- rdiffnet(n = 15, t = 3, seed.p.adopt = 0.3) + + # Test invalid toa for non-diffnet input + expect_error( + degree_adoption_diagnostic("not a diffnet"), + "toa argument is required when graph is not a diffnet object" + ) + + # Test valid sparse matrix input + A <- Matrix::rsparsematrix(10,10,0.1); A@x[] <- 1 + toa <- sample(1:3, 10, TRUE) + x <- degree_adoption_diagnostic(A, toa = toa, bootstrap = FALSE) + expect_s3_class(x, "degree_adoption_diagnostic") + + # Test invalid degree_strategy + expect_error( + degree_adoption_diagnostic(dn, degree_strategy = "invalid"), + "'arg' should be one of" + ) + + # Test invalid bootstrap + expect_error( + degree_adoption_diagnostic(dn, bootstrap = "yes"), + "'bootstrap' must be a logical scalar" + ) + + # Test invalid R + expect_error( + degree_adoption_diagnostic(dn, R = -1), + "'R' must be a positive integer" + ) + + # Test invalid conf.level + expect_error( + degree_adoption_diagnostic(dn, conf.level = 1.5), + "'conf.level' must be between 0 and 1" + ) +}) + +test_that("degree_adoption_diagnostic works with Korean Family Planning data", { + # Test with real data + data(kfamilyDiffNet) + + # Basic test with real data + result <- degree_adoption_diagnostic(kfamilyDiffNet, bootstrap = FALSE) + + expect_s3_class(result, "degree_adoption_diagnostic") + expect_gt(result$sample_size, 100) # Korean data should have many adopters + expect_true(all(is.finite(result$correlations))) + + # Test that correlations are within valid range + expect_true(all(result$correlations >= -1 & result$correlations <= 1)) +}) + +test_that("degree_adoption_diagnostic print method works", { + set.seed(444) + dn <- rdiffnet(20, 3, seed.p.adopt = 0.3) + + result <- degree_adoption_diagnostic(dn, bootstrap = FALSE) + + # Test that print doesn't error and returns invisibly + expect_output(print(result), "Degree and Time of Adoption Diagnostic") + expect_output(print(result), "Correlations:") + expect_output(print(result), "In-degree") + expect_output(print(result), "Out-degree") + expect_output(print(result), "Interpretation:") + + # Test that it returns the object invisibly + returned <- capture.output(printed_result <- print(result)) + expect_identical(result, printed_result) +}) + +test_that("degree_adoption_diagnostic reproduces manual calculation", { + # Create a simple case where we can manually verify + set.seed(555) + dn <- rdiffnet(15, 3, seed.p.adopt = 0.4) + + result <- degree_adoption_diagnostic(dn, degree_strategy = "mean", bootstrap = FALSE) + + # Manual calculation to verify + adopters <- !is.na(dn$toa) + toa_adopters <- dn$toa[adopters] + + # Compute degrees manually + indegree_full <- dgr(dn, cmode = "indegree", valued = FALSE) + outdegree_full <- dgr(dn, cmode = "outdegree", valued = FALSE) + + indegree_mean <- rowMeans(indegree_full, na.rm = TRUE) + outdegree_mean <- rowMeans(outdegree_full, na.rm = TRUE) + + indegree_adopters <- indegree_mean[adopters] + outdegree_adopters <- outdegree_mean[adopters] + + # Manual correlations + manual_cor_in <- cor(indegree_adopters, toa_adopters, use = "complete.obs") + manual_cor_out <- cor(outdegree_adopters, toa_adopters, use = "complete.obs") + + # Compare + expect_equal(result$correlations[["indegree_toa"]], manual_cor_in, tolerance = 1e-10) + expect_equal(result$correlations[["outdegree_toa"]], manual_cor_out, tolerance = 1e-10) + expect_equal(result$sample_size, sum(adopters)) +}) + +test_that("degree_adoption_diagnostic supports multi-diffusion with combine='none'", { + set.seed(1001) + n <- 80; t <- 5; q <- 3 + garr <- rgraph_ws(n, t, p = .15) + dn <- rdiffnet(seed.graph = garr, t = t, seed.p.adopt = rep(list(0.12), q)) + colnames(dn$toa) <- paste0("Beh", seq_len(q)) + + res <- degree_adoption_diagnostic(dn, combine = "none", bootstrap = FALSE) + + # Structure: correlations is 2 x Q matrix with named columns + expect_true(is.matrix(res$correlations)) + expect_identical(rownames(res$correlations), c("indegree_toa","outdegree_toa")) + expect_equal(ncol(res$correlations), q) + expect_identical(colnames(res$correlations), colnames(dn$toa)) + # sample_size is integer vector of length Q + expect_true(is.integer(res$sample_size) || is.numeric(res$sample_size)) + expect_equal(length(res$sample_size), q) + # combine flag + expect_identical(res$combine, "none") +}) + +test_that("degree_adoption_diagnostic supports multi-diffusion with combine!='none'", { + set.seed(1002) + n <- 90; t <- 4; q <- 3 + garr <- rgraph_ws(n, t, p = .12) + dn <- rdiffnet(seed.graph = garr, t = t, seed.p.adopt = rep(list(0.10), q)) + colnames(dn$toa) <- paste0("B", seq_len(q)) + + res_pooled <- degree_adoption_diagnostic(dn, combine = "pooled", bootstrap = FALSE) + res_average <- degree_adoption_diagnostic(dn, combine = "average", bootstrap = FALSE) + res_earliest <- degree_adoption_diagnostic(dn, combine = "earliest", bootstrap = FALSE) + + # Single behavior-like objects: correlations is a named numeric vector + for (res in list(res_pooled, res_average, res_earliest)) { + expect_true(is.numeric(res$correlations)) + expect_named(res$correlations, c("indegree_toa","outdegree_toa")) + expect_equal(length(res$correlations), 2) + expect_true(is.numeric(res$sample_size) && length(res$sample_size) == 1) + expect_true(res$combine %in% c("pooled","average","earliest")) + } + + # Sample sizes: pooled should be >= earliest/average + expect_gte(res_pooled$sample_size, res_average$sample_size) + expect_gte(res_pooled$sample_size, res_earliest$sample_size) + + # Behavior subsetting by names and by indices produce the same pooled result + set.seed(1003) + n <- 70; t <- 4; q <- 3 + garr <- rgraph_ws(n, t, p = .20) + dn <- rdiffnet(seed.graph = garr, t = t, seed.p.adopt = rep(list(0.15), q)) + colnames(dn$toa) <- c("Alpha","Beta","Gamma") + + res_by_names <- degree_adoption_diagnostic(dn, behavior = c("Beta","Gamma"), combine = "pooled", bootstrap = FALSE) + res_by_index <- degree_adoption_diagnostic(dn, behavior = c(2,3), combine = "pooled", bootstrap = FALSE) + + expect_equal(res_by_names$correlations[["indegree_toa"]], res_by_index$correlations[["indegree_toa"]], tolerance = 1e-12) + expect_equal(res_by_names$correlations[["outdegree_toa"]], res_by_index$correlations[["outdegree_toa"]], tolerance = 1e-12) + expect_equal(res_by_names$sample_size, res_by_index$sample_size) +}) + +test_that("Undirected graphs collapse to a single Degree correlation and printer reflects that", { + set.seed(1004) + n <- 60; t <- 3 + # Build symmetric (undirected) time-varying graph + glist <- replicate(t, { + A <- matrix(0L, n, n) + A[sample(n*n, size = round(0.08*n*n))] <- 1L + A <- A * (1 - diag(n)) # no self loops + A <- (A | t(A)) * 1L # symmetrize + A + }, simplify = FALSE) + + toa <- sample(1:t, n, replace = TRUE); toa[sample(n, 8)] <- NA + res <- degree_adoption_diagnostic(glist, toa = toa, bootstrap = FALSE) + + expect_true(isTRUE(res$undirected)) + # indegree_toa and outdegree_toa should be identical under undirected collapse + expect_equal(res$correlations[["indegree_toa"]], res$correlations[["outdegree_toa"]], tolerance = 0) + # Printer shows "Degree - Time of Adoption" and not the separate lines + expect_output(print(res), "Degree\\s+-\\s+Time of Adoption") +}) + +test_that("Coercion works for non-diffnet inputs: dgCMatrix, array, and list", { + set.seed(1005) + n <- 40; t <- 4 + + # dgCMatrix (single slice) + A <- Matrix::rsparsematrix(n, n, 0.05); A@x[] <- 1 + diag(A) <- 0 + toa1 <- sample(1:t, n, TRUE); toa1[sample(n, 5)] <- NA + x1 <- degree_adoption_diagnostic(A, toa = toa1, bootstrap = FALSE) + expect_s3_class(x1, "degree_adoption_diagnostic") + expect_true(is.numeric(x1$sample_size) && length(x1$sample_size) == 1) + + # 3D array + arr <- array(0L, dim = c(n, n, t)) + for (k in 1:t) { + M <- matrix(rbinom(n*n, 1, 0.05), n, n) + diag(M) <- 0 + arr[,,k] <- M + } + toa2 <- sample(1:t, n, TRUE); toa2[sample(n, 6)] <- NA + x2 <- degree_adoption_diagnostic(arr, toa = toa2, bootstrap = FALSE) + expect_s3_class(x2, "degree_adoption_diagnostic") + + # list of matrices + glist <- replicate(t, { + M <- matrix(rbinom(n*n, 1, 0.06), n, n); diag(M) <- 0; M + }, simplify = FALSE) + toa3 <- sample(1:t, n, TRUE); toa3[sample(n, 4)] <- NA + x3 <- degree_adoption_diagnostic(glist, toa = toa3, bootstrap = FALSE) + expect_s3_class(x3, "degree_adoption_diagnostic") +}) + +test_that("Zero-variance cases yield NA correlations without warnings and printer explains NA", { + set.seed(1006) + n <- 50; t <- 3 + # Construct a directed graph with constant out-degree across nodes at all times + glist <- replicate(t, { + # Each node nominates exactly k others (fixed out-degree) + k <- 3 + M <- matrix(0L, n, n) + for (i in 1:n) { + neigh <- sample(setdiff(1:n, i), k) + M[i, neigh] <- 1L + } + M + }, simplify = FALSE) + + toa <- sample(1:t, n, TRUE); toa[sample(n, 7)] <- NA + res <- degree_adoption_diagnostic(glist, toa = toa, bootstrap = TRUE, R = 50) + + # Out-degree correlation can be NA; in any case, print should mention "r is NA" for that metric + if (is.na(res$correlations[["outdegree_toa"]])) { + expect_output(print(res), "r is NA; no CI\\.") + } +}) + +test_that("Degree strategy changes results on time-varying graphs", { + set.seed(1007) + n <- 60; t <- 5 + glist <- replicate(t, { + M <- matrix(rbinom(n*n, 1, 0.06), n, n); diag(M) <- 0; M + }, simplify = FALSE) + toa <- sample(1:t, n, TRUE); toa[sample(n, 6)] <- NA + + r_mean <- degree_adoption_diagnostic(glist, toa = toa, degree_strategy = "mean", bootstrap = FALSE) + r_first <- degree_adoption_diagnostic(glist, toa = toa, degree_strategy = "first", bootstrap = FALSE) + r_last <- degree_adoption_diagnostic(glist, toa = toa, degree_strategy = "last", bootstrap = FALSE) + + expect_true( + !all(r_mean$correlations == r_first$correlations, na.rm = TRUE) || + !all(r_mean$correlations == r_last$correlations, na.rm = TRUE) + ) +}) + +test_that("Behavior selection validates indices/names and min_adopters is enforced", { + set.seed(1008) + n <- 60; t <- 4; q <- 2 + garr <- rgraph_ws(n, t, p = .18) + dn <- rdiffnet(seed.graph = garr, t = t, seed.p.adopt = rep(list(0.05), q)) + colnames(dn$toa) <- c("X","Y") + + # Out-of-range indices + expect_error(degree_adoption_diagnostic(dn, behavior = c(3), combine = "pooled"), + "out of range") + + # Unknown names + expect_error(degree_adoption_diagnostic(dn, behavior = c("Z"), combine = "pooled"), + "not found") + + # min_adopters threshold + # Force very few adopters in behavior X + dn2 <- dn + dn2$toa[, "X"] <- NA + few <- sample(which(!is.na(dn$toa[, "X"])), size = 2) + dn2$toa[few, "X"] <- dn$toa[few, "X"] + # For combine='none' the function should NOT error; it should return NA correlations for that behavior + res_few_none <- degree_adoption_diagnostic(dn2, behavior = "X", combine = "none", min_adopters = 3, bootstrap = FALSE) + expect_true(is.matrix(res_few_none$correlations)) + expect_true(all(is.na(res_few_none$correlations))) + expect_equal(unname(res_few_none$sample_size["X"]), 2) + + # For combined modes, too few rows should still error + expect_error( + degree_adoption_diagnostic(dn2, behavior = "X", combine = "pooled", min_adopters = 3), + "Insufficient adopters for correlation analysis" + ) +})