tests/testthat/test-compute_lumi.R

In cnefetools: Access and Analysis of Brazilian CNEFE Address Data

testthat::test_that("compute_lumi computes expected p_res on offline fixture (backend r)", {
  testthat::skip_if_not_installed("arrow")
  testthat::skip_if_not_installed("dplyr")
  testthat::skip_if_not_installed("h3jsr")
  testthat::skip_if_not_installed("sf")

  code_muni <- 2927408L
  h3_res <- 9L

  tab <- testthat::with_mocked_bindings(
    cnefetools::read_cnefe(
      code_muni,
      verbose = FALSE,
      cache = TRUE,
      output = "arrow"
    ),
    .cnefe_ensure_zip = mock_ensure_zip_fixture,
    .package = "cnefetools"
  )

  df <- as.data.frame(tab) |>
    dplyr::transmute(
      LONGITUDE = suppressWarnings(as.numeric(.data$LONGITUDE)),
      LATITUDE = suppressWarnings(as.numeric(.data$LATITUDE)),
      COD_ESPECIE = suppressWarnings(as.integer(.data$COD_ESPECIE))
    ) |>
    dplyr::filter(
      !is.na(.data$LONGITUDE),
      !is.na(.data$LATITUDE),
      !is.na(.data$COD_ESPECIE),
      .data$COD_ESPECIE %in% 1L:8L,
      .data$COD_ESPECIE != 7L
    )

  ids <- h3jsr::point_to_cell(
    df |>
      dplyr::transmute(
        lon = .data$LONGITUDE,
        lat = .data$LATITUDE
      ),
    res = h3_res,
    simple = TRUE
  )

  expected <- df |>
    dplyr::mutate(id_hex = as.character(ids)) |>
    dplyr::group_by(.data$id_hex) |>
    dplyr::summarise(
      p_res = sum(.data$COD_ESPECIE == 1L) / dplyr::n(),
      .groups = "drop"
    )

  # Mock the municipality boundary so the test does not require geobr network
  # access and so that the fixture coordinates (near -38.5 lon, -3.7 lat) fall
  # inside the polygon used to build the full H3 grid.
  mock_boundary <- function(code_muni, year = 2022L) {
    sf::st_sf(geometry = sf::st_sfc(
      sf::st_polygon(list(matrix(
        c(-38.60, -3.80, -38.50, -3.80, -38.50, -3.70, -38.60, -3.70, -38.60, -3.80),
        ncol = 2, byrow = TRUE
      ))),
      crs = 4326
    ))
  }

  out <- testthat::with_mocked_bindings(
    cnefetools::compute_lumi(
      code_muni,
      h3_resolution = h3_res,
      backend = "r",
      verbose = FALSE
    ),
    .cnefe_ensure_zip = mock_ensure_zip_fixture,
    .read_muni_boundary = mock_boundary,
    .package = "cnefetools"
  )

  testthat::expect_s3_class(out, "sf")
  testthat::expect_true(all(
    c("id_hex", "p_res", "ei", "hhi", "hhi_adp", "bgbi") %in% names(out)
  ))

  out_df <- sf::st_drop_geometry(out) |>
    dplyr::select("id_hex", "p_res") |>
    dplyr::inner_join(expected, by = "id_hex", suffix = c("", "_exp"))

  testthat::expect_true(nrow(out_df) > 0L)
  testthat::expect_equal(out_df$p_res, out_df$p_res_exp, tolerance = 1e-12)
})


testthat::test_that("compute_lumi works with user polygon (backend r)", {
  testthat::skip_if_not_installed("arrow")
  testthat::skip_if_not_installed("dplyr")
  testthat::skip_if_not_installed("sf")

  code_muni <- 2927408L

  # Read CNEFE data to create a test polygon
  tab <- testthat::with_mocked_bindings(
    cnefetools::read_cnefe(
      code_muni,
      verbose = FALSE,
      cache = TRUE,
      output = "arrow"
    ),
    .cnefe_ensure_zip = mock_ensure_zip_fixture,
    .package = "cnefetools"
  )

  df <- as.data.frame(tab) |>
    dplyr::transmute(
      LONGITUDE = suppressWarnings(as.numeric(.data$LONGITUDE)),
      LATITUDE = suppressWarnings(as.numeric(.data$LATITUDE)),
      COD_ESPECIE = suppressWarnings(as.integer(.data$COD_ESPECIE))
    ) |>
    dplyr::filter(
      !is.na(.data$LONGITUDE),
      !is.na(.data$LATITUDE),
      !is.na(.data$COD_ESPECIE),
      .data$COD_ESPECIE %in% 1L:8L,
      .data$COD_ESPECIE != 7L
    )

  # Create a bounding box polygon that covers all points
  bbox <- sf::st_bbox(
    sf::st_as_sf(df, coords = c("LONGITUDE", "LATITUDE"), crs = 4326)
  )
  test_polygon <- sf::st_as_sfc(bbox) |>
    sf::st_sf(id = 1L, geometry = _)

  # Run compute_lumi with user polygon
  out <- testthat::with_mocked_bindings(
    suppressWarnings(
      cnefetools::compute_lumi(
        code_muni,
        polygon = test_polygon,
        backend = "r",
        verbose = FALSE
      )
    ),
    .cnefe_ensure_zip = mock_ensure_zip_fixture,
    .package = "cnefetools"
  )

  testthat::expect_s3_class(out, "sf")
  testthat::expect_equal(nrow(out), 1L)

  # Check that LUMI columns exist
  lumi_cols <- c("p_res", "ei", "hhi", "bal", "ice", "hhi_adp", "bgbi")
  for (cc in lumi_cols) {
    testthat::expect_true(cc %in% names(out), info = paste("Missing column:", cc))
  }

  # Check that original polygon columns are preserved
  testthat::expect_true("id" %in% names(out))

  # Check that LUMI indices are within valid ranges
  testthat::expect_true(out$p_res >= 0 && out$p_res <= 1)
  testthat::expect_true(out$ei >= 0 && out$ei <= 1)
  testthat::expect_true(out$hhi >= 0 && out$hhi <= 1)

  # Check CRS matches original polygon (EPSG:4326)
  testthat::expect_equal(sf::st_crs(out)$epsg, 4326L)

  # Verify p_res matches manual computation
  n_res <- sum(df$COD_ESPECIE == 1L)
  n_tot <- nrow(df)
  expected_p_res <- n_res / n_tot
  testthat::expect_equal(out$p_res, expected_p_res, tolerance = 1e-12)
})


testthat::test_that("LUMI helper functions return expected values", {
  # Access internal functions
  bal_fun <- cnefetools:::.bal_fun
  bgbi_fun <- cnefetools:::.bgbi_fun
  safe_plogp <- cnefetools:::.safe_plogp

  # --- .safe_plogp ---
  # 0 * log(0) should be treated as 0

  testthat::expect_equal(safe_plogp(0), 0)
  # NA input returns 0
  testthat::expect_equal(safe_plogp(NA), 0)
  # Negative input returns 0
  testthat::expect_equal(safe_plogp(-0.5), 0)
  # 1 * log(1) = 0
  testthat::expect_equal(safe_plogp(1), 0)
  # 0.5 * log(0.5)
  testthat::expect_equal(safe_plogp(0.5), 0.5 * log(0.5))

  # --- .bal_fun ---
  # When p == P, BAL should be 1 (perfect balance)
  testthat::expect_equal(bal_fun(0.6, 0.6), 1)
  # When p == 0 and P > 0, BAL should be 0
  testthat::expect_equal(bal_fun(0, 0.5), 0)
  # When p == 1 and P < 1, BAL should be 0
  testthat::expect_equal(bal_fun(1, 0.5), 0)
  # Symmetric: bal_fun(0.3, 0.5) should equal bal_fun(0.7, 0.5)
  testthat::expect_equal(bal_fun(0.3, 0.5), bal_fun(0.7, 0.5))

  # --- .bgbi_fun ---
  # When p == P, BGBI should be 0
  testthat::expect_equal(bgbi_fun(0.6, 0.6), 0)
  # When p > P, BGBI should be positive
  testthat::expect_true(bgbi_fun(0.8, 0.5) > 0)
  # When p < P, BGBI should be negative
  testthat::expect_true(bgbi_fun(0.2, 0.5) < 0)

  # --- .compute_lumi_indices ---
  # Test with known values: 3 residential out of 4 total, P = 0.6
  compute_lumi_indices <- cnefetools:::.compute_lumi_indices
  test_df <- dplyr::tibble(n_res = 3L, n_tot = 4L)
  result <- compute_lumi_indices(test_df, P = 0.6)

  # p_res = 3/4 = 0.75
  testthat::expect_equal(result$p_res, 0.75)
  # EI: -(0.75*log(0.75) + 0.25*log(0.25)) / log(2)
  expected_ei <- -(0.75 * log(0.75) + 0.25 * log(0.25)) / log(2)
  testthat::expect_equal(result$ei, expected_ei, tolerance = 1e-12)
  # HHI: 0.75^2 + 0.25^2 = 0.625
  testthat::expect_equal(result$hhi, 0.625)
  # ICE: 0.75 - 0.25 = 0.5
  testthat::expect_equal(result$ice, 0.5)
  # BAL at p=0.75, P=0.6
  testthat::expect_equal(result$bal, bal_fun(0.75, 0.6))
  # BGBI at p=0.75, P=0.6
  testthat::expect_equal(result$bgbi, bgbi_fun(0.75, 0.6))

  # Test with n_tot = 0 (should produce NA for all indices)
  test_df_zero <- dplyr::tibble(n_res = 0L, n_tot = 0L)
  result_zero <- compute_lumi_indices(test_df_zero, P = 0.5)
  testthat::expect_true(is.na(result_zero$p_res))
  testthat::expect_true(is.na(result_zero$ei))
  testthat::expect_true(is.na(result_zero$hhi))
})


testthat::test_that("compute_lumi validates polygon argument", {
  testthat::skip_if_not_installed("sf")

  code_muni <- 2927408L

  # polygon_type = "user" with no polygon is still an error, even though the
  # argument is deprecated (#90). Without polygon_type, polygon = NULL is now
  # simply H3 mode and correctly raises nothing.
  withr::local_options(lifecycle_verbosity = "quiet")
  testthat::expect_error(
    cnefetools::compute_lumi(
      code_muni,
      polygon_type = "user",
      polygon = NULL,
      verbose = FALSE
    ),
    "polygon.*required"
  )

  # Error when polygon is not an sf object
  testthat::expect_error(
    cnefetools::compute_lumi(
      code_muni,
      polygon = data.frame(x = 1),
      verbose = FALSE
    ),
    "polygon.*sf"
  )

  # Error when polygon contains non-polygon geometries
  pt_sf <- sf::st_sf(
    id = 1L,
    geometry = sf::st_sfc(sf::st_point(c(0, 0)), crs = 4326)
  )
  testthat::expect_error(
    cnefetools::compute_lumi(
      code_muni,
      polygon = pt_sf,
      verbose = FALSE
    ),
    "POLYGON|MULTIPOLYGON"
  )
})