tests/testthat/test-launchers.R

In r5rgui: Graphical User Interface for 'r5r' Router

skip_on_cran()
skip_if_not_installed("r5r")
skip_if_not_installed("shiny")
skip_if_not_installed("rlang")

# --- Test for r5r_gui_demo() ---
test_that("r5r_gui_demo() and r5r_gui() fail gracefully if r5r is not installed", {
  local_mocked_bindings(
    check_r5r_available = function() FALSE,
    .package = "r5rgui"
  )

  expect_error(
    r5r_gui_demo(),
    "The 'r5r' package is required to run this demo. Please install it first."
  )

  expect_error(
    r5r_gui(r5r_network = "dummy_network"),
    "The 'r5r' package is required to run this demo. Please install it first."
  )
})

test_that("r5r_gui_demo() prepares correct arguments for r5r_gui", {
  r5r_gui_args_captured <- NULL

  local_mocked_bindings(
    r5r_gui = function(...) {
      r5r_gui_args_captured <<- list(...)
    },
    .package = "r5rgui"
  )

  if (utils::packageVersion("r5r") >= "2.3.0") {
    local_mocked_bindings(
      build_network = function(...) "dummy_network",
      .package = "r5r"
    )
  }
  local_mocked_bindings(
    setup_r5 = function(...) "dummy_network",
    .package = "r5r"
  )

  r5r_gui_demo()

  expect_false(is.null(r5r_gui_args_captured))
  expect_equal(r5r_gui_args_captured$center, c(-51.22, -30.05))
  expect_equal(r5r_gui_args_captured$zoom, 11)
})


# --- Test for r5r_gui() ---

test_that("r5r_gui() prepares arguments correctly for the shiny app", {
  dummy_net <- list(name = "dummy_network_object")
  dummy_center <- c(-51.22, -30.05)
  dummy_zoom <- 11
  dummy_date <- as.Date("2025-09-01")

  captured_server_function <- NULL

  local_mocked_bindings(
    shinyApp = function(ui, server) {
      captured_server_function <<- server
    },
    .package = "shiny"
  )

  r5r_gui(
    r5r_network = dummy_net,
    center = dummy_center,
    zoom = dummy_zoom,
    departure_date = dummy_date
  )

  expect_false(
    is.null(captured_server_function),
    label = "The mock should have captured the server function."
  )
  expect_true(is.function(captured_server_function))

  server_env <- rlang::fn_env(captured_server_function)
  captured_args <- server_env$app_args

  expect_identical(captured_args$r5r_network, dummy_net)
  expect_identical(captured_args$center, dummy_center)
  expect_identical(captured_args$zoom, dummy_zoom)
  expect_identical(captured_args$departure_date, dummy_date)
  expect_identical(captured_args$r5r_network_name, "dummy_net")
})

# --- Tests for automatic centering and zooming ---

test_that("r5r_gui() sets automatic center and zoom when not provided", {
  skip_if_not(exists("r5r_net"))

  captured_server_function <- NULL
  local_mocked_bindings(
    shinyApp = function(ui, server) {
      captured_server_function <<- server
    },
    .package = "shiny"
  )

  r5r_gui(r5r_network = r5r_net)

  server_env <- rlang::fn_env(captured_server_function)
  captured_args <- server_env$app_args

  expect_false(
    is.null(captured_args$center),
    label = "Center should be calculated"
  )
  expect_false(is.null(captured_args$zoom), label = "Zoom should be calculated")
  expect_true(is.numeric(captured_args$center))
  expect_true(is.numeric(captured_args$zoom))
  expect_equal(length(captured_args$center), 2)
})

test_that("r5r_gui() uses fallback and shows message for older r5r versions", {
  skip_if_not(exists("r5r_net"))

  captured_server_function <- NULL

  local_mocked_bindings(
    shinyApp = function(ui, server) {
      captured_server_function <<- server
    },
    .package = "shiny"
  )

  local_mocked_bindings(
    packageVersion = function(pkg) {
      if (pkg == "r5r") {
        return("2.3.0")
      }
      return(base::packageVersion(pkg))
    },
    .package = "utils"
  )

  expect_message(
    r5r_gui(r5r_network = r5r_net),
    "Calculating network bounding box with a legacy method. This is slow."
  )

  server_env <- rlang::fn_env(captured_server_function)
  captured_args <- server_env$app_args

  expect_false(
    is.null(captured_args$center),
    label = "Center should be calculated with fallback"
  )
  expect_false(
    is.null(captured_args$zoom),
    label = "Zoom should be calculated with fallback"
  )
})