tests/testthat/test-degree-adoption-diagnostic.R

In netdiffuseR: Analysis of Diffusion and Contagion Processes on Networks

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"
  )
})