tests/testthat/helper-test-utils.R

In cograph: Analysis and Visualization of Complex Networks

# Test helper utilities for CRAN testing suite
# Provides common test setup functions and custom expectations

# ============================================
# Test Data Generators
# ============================================

#' Create a test adjacency matrix
#' @param n Number of nodes
#' @param density Edge density (0-1)
#' @param weighted Logical: include weights?
#' @param symmetric Logical: make symmetric (undirected)?
#' @param seed Random seed for reproducibility
#' @return n x n matrix
create_test_matrix <- function(n = 5, density = 0.5, weighted = FALSE,
                               symmetric = TRUE, seed = 42) {

  set.seed(seed)
  mat <- matrix(0, n, n)
  n_possible <- n * (n - 1)
  if (symmetric) n_possible <- n_possible / 2
  n_edges <- round(n_possible * density)

  if (symmetric) {
    # Fill upper triangle
    upper_idx <- which(upper.tri(mat))
    selected <- sample(upper_idx, min(n_edges, length(upper_idx)))
    if (weighted) {
      mat[selected] <- runif(length(selected), 0.1, 1)
    } else {
      mat[selected] <- 1
    }
    mat <- mat + t(mat)
  } else {
    # Fill anywhere except diagonal
    all_idx <- which(row(mat) != col(mat))
    selected <- sample(all_idx, min(n_edges, length(all_idx)))
    if (weighted) {
      mat[selected] <- runif(length(selected), -1, 1)
    } else {
      mat[selected] <- 1
    }
  }

  mat
}

#' Create a test edge list data frame
#' @param n_edges Number of edges
#' @param n_nodes Number of unique nodes
#' @param weighted Include weight column?
#' @param char_nodes Use character node names?
#' @param seed Random seed
#' @return data.frame with from, to, (weight) columns
create_test_edgelist <- function(n_edges = 10, n_nodes = 5, weighted = FALSE,
                                  char_nodes = FALSE, seed = 42) {
  set.seed(seed)

  from <- sample(1:n_nodes, n_edges, replace = TRUE)
  to <- sample(1:n_nodes, n_edges, replace = TRUE)

  # Remove self-loops
  self_loops <- from == to
  if (any(self_loops)) {
    to[self_loops] <- ((to[self_loops]) %% n_nodes) + 1
  }

  if (char_nodes) {
    node_names <- LETTERS[1:n_nodes]
    from <- node_names[from]
    to <- node_names[to]
  }

  df <- data.frame(from = from, to = to, stringsAsFactors = FALSE)

  if (weighted) {
    df$weight <- runif(n_edges, -1, 1)
  }

  df
}

#' Create test network with specific topology
#' @param type One of "complete", "star", "ring", "path", "disconnected"
#' @param n Number of nodes
#' @return Adjacency matrix
create_test_topology <- function(type = "complete", n = 5) {
  mat <- matrix(0, n, n)

  switch(type,
    complete = {
      mat <- matrix(1, n, n)
      diag(mat) <- 0
    },
    star = {
      # Node 1 connects to all others
      mat[1, 2:n] <- 1
      mat[2:n, 1] <- 1
    },
    ring = {
      for (i in 1:(n-1)) {
        mat[i, i+1] <- 1
        mat[i+1, i] <- 1
      }
      mat[n, 1] <- 1
      mat[1, n] <- 1
    },
    path = {
      for (i in 1:(n-1)) {
        mat[i, i+1] <- 1
        mat[i+1, i] <- 1
      }
    },
    disconnected = {
      # Two disconnected components
      half <- floor(n/2)
      if (half > 1) {
        mat[1:half, 1:half] <- 1
        diag(mat[1:half, 1:half]) <- 0
      }
      if (n - half > 1) {
        mat[(half+1):n, (half+1):n] <- 1
        diag(mat[(half+1):n, (half+1):n]) <- 0
      }
    }
  )

  mat
}

# ============================================
# Skip Helpers
# ============================================

#' Skip test if igraph is not available
skip_if_no_igraph <- function() {
  skip_if_not_installed("igraph")
}

#' Skip test if running without display (for graphical tests)
skip_if_no_display <- function() {
  # On CI/CRAN, skip tests that require interactive graphics
  skip_on_cran()
  if (identical(Sys.getenv("CI"), "true")) {
    skip("Skipping graphical test on CI")
  }
}

#' Skip tests that require qgraph
skip_if_no_qgraph <- function() {
  skip_if_not_installed("qgraph")
}

#' Skip tests that require tna
skip_if_no_tna <- function() {
  skip_if_not_installed("tna")
}

# ============================================
# Custom Expectations
# ============================================

#' Expect valid color values
#' @param x Character vector to check
expect_valid_colors <- function(x) {
  # Check that colors can be parsed by R
  for (col in x) {
    result <- tryCatch(
      grDevices::col2rgb(col),
      error = function(e) NULL
    )
    expect_false(is.null(result),
                 info = paste("Invalid color:", col))
  }
  invisible(TRUE)
}

#' Expect file was created
#' @param path File path to check
expect_file_created <- function(path) {
  expect_true(file.exists(path),
              info = paste("File not created:", path))
}

#' Expect file has minimum size
#' @param path File path
#' @param min_bytes Minimum file size in bytes
expect_file_size <- function(path, min_bytes = 100) {
  expect_true(file.exists(path), info = paste("File missing:", path))
  expect_true(file.size(path) >= min_bytes,
              info = paste("File too small:", path, "size:", file.size(path)))
}

#' Expect numeric vector within range
#' @param x Numeric vector
#' @param min Minimum value
#' @param max Maximum value
expect_in_range <- function(x, min, max) {
  expect_true(all(x >= min & x <= max, na.rm = TRUE),
              info = paste("Values outside range [", min, ",", max, "]: ",
                          paste(range(x, na.rm = TRUE), collapse = "-")))
}

#' Expect cograph_network object
#' @param x Object to check
expect_cograph_network <- function(x) {
  expect_s3_class(x, "cograph_network")
  expect_true(!is.null(x$nodes))
  expect_true(n_nodes(x) >= 0)
}

# ============================================
# Temp File Helpers
# ============================================

#' Run code with temporary PNG device
#' @param expr Expression to evaluate
#' @param ... Arguments passed to png()
#' @return Result of expression (invisibly)
with_temp_png <- function(expr, width = 200, height = 200, ...) {
  tmp <- tempfile(fileext = ".png")
  on.exit(unlink(tmp), add = TRUE)

  grDevices::png(tmp, width = width, height = height, ...)
  result <- tryCatch(
    force(expr),
    finally = grDevices::dev.off()
  )

  invisible(result)
}

#' Run code with temporary PDF device
#' @param expr Expression to evaluate
#' @param ... Arguments passed to pdf()
#' @return Result of expression (invisibly)
with_temp_pdf <- function(expr, width = 7, height = 7, ...) {
  tmp <- tempfile(fileext = ".pdf")
  on.exit(unlink(tmp), add = TRUE)

  grDevices::pdf(tmp, width = width, height = height, ...)
  result <- tryCatch(
    force(expr),
    finally = grDevices::dev.off()
  )

  invisible(result)
}

#' Create temporary directory for test outputs
#' @return Path to temporary directory
create_temp_dir <- function() {
  dir <- tempfile(pattern = "cograph_test_")
  dir.create(dir)
  dir
}

# ============================================
# Graphical Test Helpers
# ============================================

#' Safely run a plotting function (captures errors)
#' @param expr Expression that produces a plot
#' @return List with success flag and any error message
safe_plot <- function(expr) {
  result <- list(success = FALSE, error = NULL)

  tryCatch({
    with_temp_png({
      force(expr)
    })
    result$success <- TRUE
  }, error = function(e) {
    result$error <- conditionMessage(e)
  })

  result
}

#' Test that splot() runs without error
#' @param ... Arguments to pass to splot()
expect_splot_works <- function(...) {
  result <- safe_plot(splot(...))
  expect_true(result$success, info = paste("splot() failed:", result$error))
}

#' Test that soplot() runs without error
#' @param ... Arguments to pass to soplot()
expect_soplot_works <- function(...) {
  skip_if_not_installed("grid")
  result <- safe_plot(soplot(...))
  expect_true(result$success, info = paste("soplot() failed:", result$error))
}

# ============================================
# Network Validation Helpers
# ============================================

#' Validate network structure
#' @param net cograph_network object
#' @param expected_nodes Expected node count
#' @param expected_edges Expected edge count (approximate)
validate_network <- function(net, expected_nodes = NULL, expected_edges = NULL) {
  expect_cograph_network(net)

  if (!is.null(expected_nodes)) {
    expect_equal(n_nodes(net), expected_nodes)
  }

  if (!is.null(expected_edges)) {
    expect_equal(n_edges(net), expected_edges)
  }

  # Validate layout exists in nodes
  nodes <- get_nodes(net)
  expect_true(all(c("x", "y") %in% names(nodes)))
  expect_false(all(is.na(nodes$x)))
}