tests/testthat/test-apply_automerge.R

In lidR: Airborne LiDAR Data Manipulation and Visualization for Forestry Applications

ctg <- random_2files_250points
ctg@output_options$drivers$Raster$param$overwrite = TRUE
ctg@output_options$drivers$Spatial$param$overwrite = TRUE
ctg@output_options$drivers$SimpleFeature$param$delete_dsn = TRUE

rtest <- function(cluster, layers = 1L) {
  las <- readLAS(cluster)
  if (is.empty(las)) return(NULL)
  r = lidR:::raster_layout(las, 4, format = "raster")
  r[] <- 1
  r[55:56] <- NA
  if (layers > 1) {
    r <- raster::brick(r,r)
    raster::crs(r) <- as(st_crs(las), "CRS")
    layers <- 2L
  }
  lidR:::raster_names(r) <- paste0("layername", 1:layers)
  return(r)
}

starstest <- function(cluster, layers = 1L) {
  las <- readLAS(cluster)
  if (is.empty(las)) return(NULL)
  r = lidR:::raster_layout(las, 4, format = "stars")
  r[[1]][] <- 1
  r[[1]][55:56] <- NA
  if (layers > 1) {
    r <- c(r,r, along = 3)
    sf::st_crs(r) <- st_crs(las)
    layers <- 2L
  }

  lidR:::raster_names(r) <- paste0("layername", 1:layers)
  return(r)
}

sftest <- function(cluster, DataFrame = TRUE) {
  las <- readLAS(cluster)
  if (is.empty(las)) return(NULL)
  D <- head(lidR:::coordinates(las))
  D <- sf::st_as_sf(D, coords = c("X", "Y"), crs = cluster@crs)
  D$u <- 1:6

  if (!DataFrame )
    return(sf::st_geometry(D))
  else
    return(D)
}

sptest <- function(cluster, DataFrame = FALSE) {
  x = sftest(cluster, DataFrame)
  if (is.null(x)) return(NULL)
  return(sf::as_Spatial(x))
}

lastest <- function(cluster) {
  las <- readLAS(cluster)
  if (is.empty(las)) return(NULL)
  las[1:6]
}

dftest <- function(cluster) {
  las <- readLAS(cluster)
  if (is.empty(las)) return(NULL)
  head(lidR:::coordinates3D(las))
}

terratest <- function(cluster, DataFrame = FALSE) {
  x <- sftest(cluster, DataFrame)
  if (is.null(x)) return(NULL)
  v <- terra::vect(x)
  terra::crs(v) <- sf::st_crs(x)$wkt
  return(v)
}

expected_bbox <- sf::st_bbox(c(xmin = 0,xmax = 100, ymin =  0, ymax = 200))

test_that("catalog_apply automerge works with in memory RasterLayer", {
  skip_if_not_installed("raster")

  # No automerge option
  req1 <- catalog_apply(ctg, rtest)

  # automerge option
  option <- list(automerge = TRUE)
  req2 <- catalog_apply(ctg, rtest, .options = option)

  expect_is(req1, "list")
  expect_is(req2, "RasterLayer")
  expect_true(raster::inMemory(req2))
  expect_equal(lidR:::raster_names(req2), "layername1")
  #expect_equivalent(crs(req2), crs(ctg))
  expect_equivalent(sf::st_bbox(req2), expected_bbox)
  expect_equal(sum(is.na(req2[])), 4L)
})

test_that("catalog_apply automerge works with in memory RastersBrick", {
  skip_if_not_installed("raster")
  skip_on_cran()

  # No automerge option
  req1 <- catalog_apply(ctg, rtest, layers = 2L)

  # automerge option
  option <- list(automerge = TRUE)
  req2 <- catalog_apply(ctg, rtest, layers = 2, .options = option)

  expect_is(req1, "list")
  expect_is(req2, "RasterBrick")
  expect_true(raster::inMemory(req2))
  expect_equal(lidR:::raster_names(req2), c("layername1", "layername2"))
  expect_equivalent(sf::st_bbox(req2), expected_bbox)
  expect_equal(sum(is.na(req2[])), 8L)
})

test_that("catalog_apply automerge works with on disk rasters as Raster* (VRT)", {
    skip_if_not_installed("raster")

    opt_output_files(ctg) <- paste0(tempdir(), "/{ORIGINALFILENAME}_{lidR:::uuid()}")
    option <- list(automerge = T)

    req1 <- catalog_apply(ctg, rtest, .options = option)

    expect_is(req1, "RasterLayer")
    expect_true(!raster::inMemory(req1))
    expect_equivalent(sf::st_bbox(req1), expected_bbox)
    expect_equal(sum(is.na(req1[])), 4L)
    expect_equal(lidR:::raster_names(req1), "layername1")

    req1 <- catalog_apply(ctg, rtest, layers = 2, .options = option)

    expect_is(req1, "RasterBrick")
    expect_true(!raster::inMemory(req1))
    expect_equivalent(sf::st_bbox(req1), expected_bbox)
    expect_equal(sum(is.na(req1[])), 8L)
    expect_equal(lidR:::raster_names(req1), c("layername1", "layername2"))
})

test_that("catalog_apply automerge works with on disk rasters as stars (VRT)", {

  opt_output_files(ctg) <- paste0(tempdir(), "/{ORIGINALFILENAME}_{lidR:::uuid()}")
  option <- list(automerge = TRUE)

  req1 <- catalog_apply(ctg, starstest, .options = option)
  res <- stars::read_stars(req1[[1]])

  expect_is(req1, "stars_proxy")
  expect_equivalent(sf::st_bbox(req1), expected_bbox)
  expect_equal(sum(is.na(res[[1]])), 4L)
  expect_equal(lidR:::raster_names(req1), "layername1")

  req1 <- catalog_apply(ctg, starstest, layers = 2, .options = option)
  res  <- stars::read_stars(req1[[1]])

  expect_is(req1, "stars_proxy")
  expect_equivalent(sf::st_bbox(req1), expected_bbox)
  expect_equal(sum(is.na(res[[1]])), 8L)
  expect_equal(lidR:::raster_names(req1), c("layername1", "layername2"))
})

test_that("catalog_apply automerge works with in memory SpatialPoints*", {
  skip_if_not_installed("sp")
  skip_on_cran()

  option <- list(automerge = TRUE)
  req2 <- catalog_apply(ctg, sptest, .options = option)

  expect_is(req2, "SpatialPoints")
  #expect_equal(req2@proj4string, crs(ctg))
  expect_equal(length(req2), 12L)

  option <- list(automerge = TRUE)
  req2 <- catalog_apply(ctg, sptest, DataFrame = TRUE, .options = option)

  expect_is(req2, "SpatialPointsDataFrame")
  #expect_equal(req2@proj4string, crs(ctg))
  expect_equal(dim(req2), c(12L,1L))
})

test_that("catalog_apply automerge works with on disk SpatialPoints*", {

  skip_if_not_installed("sp")
  skip_on_cran()

  opt_output_files(ctg) <- paste0(tempdir(), "/{ORIGINALFILENAME}_{lidR:::uuid()}")

  option <- list(automerge = TRUE)
  req3 <- catalog_apply(ctg, sptest, .options = option)

  expect_true(is.character(req3))
  expect_true(all(tools::file_ext(req3) == "shp"))
})

test_that("catalog_apply automerge works with on disk SpatVector", {

  skip_on_cran()

  opt_output_files(ctg) <- ""

  option <- list(automerge = T)
  req3 <- catalog_apply(ctg, terratest, .options = option)

  expect_is(req3, "SpatVector")
  expect_false(terra::crs(req3) == "")

  opt_output_files(ctg) <- paste0(tempdir(), "/{ORIGINALFILENAME}_{lidR:::uuid()}")

  option <- list(automerge = TRUE)
  req3 <- catalog_apply(ctg, terratest, .options = option)

  expect_true(is.character(req3))
  expect_true(all(tools::file_ext(req3) == "shp"))
})

test_that("catalog_apply automerge works with in memory POINTS", {

  skip_on_cran()

  option <- list(automerge = TRUE)
  req2 <- catalog_apply(ctg, sftest, .options = option)

  expect_is(req2, "sf")
  #expect_equal(projection(req2), "+proj=tmerc +lat_0=0 +lon_0=-55.5 +k=0.9999 +x_0=304800 +y_0=0 +ellps=clrk66 +units=m +no_defs")
  expect_equal(nrow(req2), 12L)
})

test_that("catalog_apply automerge works with on disk POINTS*", {

  skip_on_cran()

  opt_output_files(ctg) <- paste0(tempdir(), "/{ORIGINALFILENAME}_{lidR:::uuid()}")

  option <- list(automerge = TRUE)
  req3 <- catalog_apply(ctg, sftest, .options = option)

  expect_true(is.character(unlist(req3)))
  expect_true(all(tools::file_ext(req3) == "shp"))
})

test_that("catalog_apply automerge works with in memory LAS", {

  option <- list(automerge = TRUE)
  req2 <- catalog_apply(ctg, lastest, .options = option)

  expect_is(req2, "LAS")
  expect_equal(st_crs(req2), st_crs(ctg))
  expect_equal(npoints(req2), 12L)
})

test_that("catalog_apply automerge works with on disk LAS (LAScatalog)", {

  opt_output_files(ctg) <- paste0(tempdir(), "/{ORIGINALFILENAME}_{lidR:::uuid()}")

  option <- list(automerge = TRUE)
  req3 <- catalog_apply(ctg, lastest, .options = option)

  expect_is(req3, "LAScatalog")
  expect_equal(st_crs(req3), st_crs(ctg))
})

test_that("catalog_apply automerge works with in memory data.frame", {

  skip_on_cran()

  option <- list(automerge = TRUE)
  req2 <- catalog_apply(ctg, dftest, .options = option)

  expect_is(req2, "data.frame")
  expect_equal(nrow(req2), 12L)
})

test_that("catalog_apply automerge works with on disk data.frame", {

  skip_on_cran()

  opt_output_files(ctg) <- paste0(tempdir(), "/{ORIGINALFILENAME}_{lidR:::uuid()}")

  option <- list(automerge = TRUE)
  req3 <- catalog_apply(ctg, dftest, .options = option)

  expect_true(is.character(req3))
  expect_true(all(tools::file_ext(req3) == "txt"))
})

test_that("catalog_apply automerge does not fail with heterogeneous outputs", {

  test <- function(cluster) {
    if (st_bbox(cluster)[2] > 80) return(list(0))
    return(data.frame(X = 1:3))
  }

  opt_wall_to_wall(ctg) <- FALSE
  option <- list(automerge = FALSE)

  expect_warning(req <- catalog_sapply(ctg, test, .options = option), "heterogeneous objects")
  expect_is(req, "list")
  expect_is(req[[1]], "data.frame")
  expect_is(req[[2]], "list")
})

test_that("catalog_apply automerge does not fail with unsupported objects outputs", {

  test <- function(cluster) {
    x = runif(5)
    y = runif(5)
    stats::lm(y~x)
  }

  opt_wall_to_wall(ctg) <- FALSE
  option <- list(automerge = FALSE)

  expect_warning(req <- catalog_sapply(ctg, test, .options = option), "unsupported objects")
  expect_is(req, "list")
  expect_is(req[[1]], "lm")
})

test_that("catalog_sapply is the same than apply with automerge", {

  skip_if_not_installed("raster")
  skip_on_cran()

  option <- list(automerge = FALSE)
  req1 <- catalog_sapply(ctg, rtest)
  req2 <- catalog_sapply(ctg, rtest, .options = option)

  expect_is(req1, "RasterLayer")
  expect_true(raster::inMemory(req1))
  expect_equal(lidR:::raster_names(req1), "layername1")
  expect_equal(req1, req2)
})

test_that("catalog_apply automerge disabled with opt_merge = FALSE", {

  skip_if_not_installed("raster")
  skip_on_cran()

  opt_merge(ctg) <- FALSE
  option <- list(automerge = TRUE)
  req1 <- catalog_apply(ctg, rtest, .options = option)

  expect_true(is.list(req1))
  expect_true(is(req1[[1]], "RasterLayer"))

  opt_output_files(ctg) <- paste0(tempdir(), "/{ORIGINALFILENAME}_{lidR:::uuid()}")
  req2 <- catalog_apply(ctg, rtest, .options = option)

  expect_true(is.list(req2))
  expect_true(is.character(req2[[1]]))
})