tests/testthat/test-portfolio.R

In mapme-initiative/mapme.biodiversity: Efficient Monitoring of Global Biodiversity Portfolios

test_that("portoflio I/O works as expected", {
  mapme_options(verbose = F)
  x <- read_sf(
    system.file("extdata", "sierra_de_neiba_478140.gpkg",
      package = "mapme.biodiversity"
    )
  )
  x <- suppressWarnings(st_cast(x, to = "POLYGON")[1, ])

  x[["assetid"]] <- 1
  dsn <- tempfile(fileext = ".gpkg")

  expect_error(
    write_portfolio(x, dsn),
    "No calculated indicators have been found"
  )

  indicator <- list(tibble(
    datetime = "2000-01-01",
    variable = "biome",
    unit = "ha",
    value = 1
  ))

  x[["biome"]] <- indicator

  expect_invisible(out <- write_portfolio(x, dsn, quiet = TRUE))
  expect_equal(out, dsn)
  expect_silent(write_portfolio(x, dsn))
  expect_equal(st_layers(dsn)[["name"]], c("metadata", "indicators"))

  meta <- st_read(dsn, layer = "metadata", quiet = TRUE)
  inds <- st_read(dsn, layer = "indicators", quiet = TRUE)

  expect_true(inherits(meta, "sf"))
  expect_true(inherits(inds, "data.frame"))

  vars <- c("assetid", "indicator", "datetime", "variable", "unit", "value")
  expect_true(all(vars %in% names(inds)))

  data <- read_portfolio(dsn, quiet = TRUE)
  vars <- c("WDPAID", "ISO3", "assetid", "biome", "geom")
  expect_true(all(vars %in% names(data)))
  expect_true(inherits(data[["biome"]], "list"))

  file.remove(dsn)

  x[["biome2"]] <- indicator
  write_portfolio(x, dsn, quiet = TRUE)
  data <- read_portfolio(dsn, quiet = TRUE)
  vars <- c("biome", "biome2")
  expect_true(all(vars %in% names(data)))

  file.remove(dsn)

  x2 <- x
  x2[["biome"]] <- list(NULL)
  x2[["biome2"]] <- list(NULL)
  x <- do.call(rbind, list(x, x2))
  x$assetid <- 1:2

  write_portfolio(x, dsn)
  data <- read_portfolio(dsn)
  expect_true(!is.null(data[["biome"]][[1]]))
  expect_true(!is.null(data[["biome2"]][[1]]))
  expect_true(is.null(data[["biome"]][[2]]))
  expect_true(is.null(data[["biome2"]][[2]]))

  file.remove(dsn)

  x$biome2 <- list(c(NULL, NULL))
  expect_warning(write_portfolio(x, dsn), "Dropping")
  data <- read_portfolio(dsn)
  expect_true(!"biome2" %in% names(data))
  suppressWarnings(inds <- read_sf(dsn, "indicators"))
  # check NULL was not writte
  expect_equal(nrow(inds), 1)
})

test_that(".check_portfolio works as expected", {
  x <- read_sf(
    system.file("extdata", "sierra_de_neiba_478140.gpkg",
      package = "mapme.biodiversity"
    )
  )
  p <- suppressWarnings(st_centroid(x))
  expect_error(.check_portfolio(p), "Only assets of type 'POLYGON' and 'MULTIPOLYGON' are supported.")
  expect_silent(.check_portfolio(x))

  center <- as.numeric(suppressWarnings(st_coordinates(st_centroid(x))))
  srs <- sprintf(
    "+proj=laea +x_0=0 +y_0=0 +lon_0=%s +lat_0=%s",
    center[1], center[2]
  )
  x <- st_transform(x, srs)

  expect_message(
    x <- .check_portfolio(x),
    "CRS of x is not EPSG:4326. Attempting to transform."
  )
  mapme_options(verbose = TRUE)
  expect_silent(.check_portfolio(x))
  x$assetid <- NULL
  expect_silent(x <- .check_portfolio(x))
  expect_true("assetid" %in% names(x))
  x <- do.call(rbind, lapply(1:2, function(y) x))
  expect_message(.check_portfolio(x), "Found a column named 'assetid' with non-unique identifiers")
})

test_that("portfolio helpers work as expected", {
  mapme_options(verbose = FALSE)
  x <- read_sf(
    system.file("extdata", "sierra_de_neiba_478140.gpkg",
      package = "mapme.biodiversity"
    )
  )
  x <- suppressWarnings(st_cast(x, to = "POLYGON")[1, ])
  x[["assetid"]] <- 1

  expect_error(.indicators_col(x))

  indicator <- list(tibble(
    datetime = "2000-01-01",
    variable = "biome",
    unit = "ha",
    value = 1
  ))

  x[["biome"]] <- indicator
  x[["biome2"]] <- indicator

  cols <- .indicators_col(x)
  expected <- 5:6
  names(expected) <- c("biome", "biome2")
  expect_equal(cols, expected)

  vars <- c("indicator", "datetime", "variable", "unit", "value")
  out <- portfolio_long(x, names(cols))
  expect_equal(nrow(out), 2)
  expect_true(inherits(out, "sf"))
  expect_true(all(vars %in% names(out)))
  out <- portfolio_long(x, names(cols)[1], drop_geoms = TRUE)
  expect_equal(nrow(out), 1)
  expect_false(inherits(out, "sf"))
  expect_true(all(vars %in% names(out)))

  out <- portfolio_wide(x, names(cols))
  expect_equal(nrow(out), 1)
  vars <- c("assetid", "biome_2000-01-01_biome_ha", "biome2_2000-01-01_biome_ha")
  expect_true(all(vars %in% names(out)))
  expect_true(inherits(out, "sf"))
  out <- portfolio_wide(x, names(cols), drop_geoms = TRUE)
  expect_equal(nrow(out), 1)
  expect_true(all(vars %in% names(out)))
  expect_false(inherits(out, "sf"))
  out <- portfolio_wide(x, names(cols)[1])
  expect_equal(nrow(out), 1)
  expect_true(inherits(out, "sf"))
  expect_true(all(c(vars[1:2], "biome2") %in% names(out)))

  x <- rbind(x, x)
  x$assetid <- 1:2
  x$biome2 <- list(x$biome2[[1]], NULL)
  expect_silent(out <- portfolio_wide(x))
  expect_equal(nrow(out), 2)
  expect_equal(out$`biome_2000-01-01_biome_ha`[2], 1)
  expect_true(is.na(out$`biome2_2000-01-01_biome_ha`[2]))
  expect_silent(out <- portfolio_long(x))
  expect_equal(nrow(out), 3)
  expect_equal(out$value, c(1, 1, 1))

  x$biome <- list(NULL)
  expect_silent(portfolio_long(x))
  expect_silent(portfolio_wide(x))
  x$biome2 <- list(NULL)
  expect_warning(portfolio_long(x), "All indicator columns contained 'NULL'.")
  expect_warning(portfolio_wide(x), "All indicator columns contained 'NULL'.")
})