tests/testthat/test-rasterize_terrain.R

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

las <- lidR:::generate_las(5000)
st_crs(las) <- 2949
las@data[, Z := round(Z + 0.1*X + 0.1*Y + sin(0.01*X) - sin(0.1*Y) + sin(0.003*X*Y),3)]

tdtm <- lidR:::raster_layout(las, 1, format = getOption("lidR.raster.default"))
xy   <- lidR:::raster_as_dataframe(tdtm, na.rm = FALSE, xy = TRUE)
X    <- xy$X
Y    <- xy$Y
cell <- lidR:::raster_cell_from_xy(tdtm, X, Y)
gnd  <- round(0.1*X + 0.1*Y + sin(0.01*X) - sin(0.1*Y) + sin(0.003*X*Y),3)
tdtm <- lidR:::raster_set_values(tdtm, gnd, cell)

slr = lidR:::raster_class()

test_that("rasterize_terrain works with knnidw", {

  dtm <- rasterize_terrain(las, 1, knnidw(k = 10L))

  expect_true(is(dtm, slr))
  expect_equal(lidR:::raster_res(dtm), c(1,1))
  expect_equal(dim(dtm), dim(tdtm))
  expect_equivalent(sf::st_bbox(dtm), sf::st_bbox(tdtm))
  expect_equal(lidR:::raster_names(dtm), "Z")
  expect_equal(sum(is.na(lidR:::raster_values(dtm))), 1L)

  error <- abs(dtm - tdtm)
  expect_equal(mean(lidR:::raster_values(error), na.rm = TRUE), 0.1558, tolerance = 0.0001)

  z <- lidR:::raster_value_from_xy(dtm, las$X, las$Y)
  expect_true(!anyNA(z))
})

test_that("grid_terrain is backward compatible", {
  skip_if_not_installed("raster")
  dtm <- grid_terrain(las, 1, knnidw(k = 10L))

  expect_true(is(dtm, "RasterLayer"))
  expect_equal(lidR:::raster_res(dtm), c(1,1))
  expect_equivalent(lidR:::raster_size(dtm), c(100, 100, 1))
  expect_equivalent(sf::st_bbox(dtm), sf::st_bbox(tdtm))
  expect_equal(lidR:::raster_names(dtm), "Z")
  expect_equal(sum(is.na(lidR:::raster_values(dtm))), 1L)
})

test_that("rasterize_terrain works with delaunay", {

  dtm <- suppressWarnings(rasterize_terrain(las, 1, tin()))

  expect_true(is(dtm, slr))
  expect_equal(lidR:::raster_res(dtm), c(1,1))
  expect_equal(dim(dtm), dim(tdtm))
  expect_equivalent(sf::st_bbox(dtm), sf::st_bbox(tdtm))
  expect_equal(lidR:::raster_names(dtm), "Z")
  expect_equal(sum(is.na(lidR:::raster_values(dtm))), 1L)

  error <- abs(dtm - tdtm)
  expect_equal(mean(lidR:::raster_values(error), na.rm = TRUE), 0.074, tolerance = 0.0001)

  z <- lidR:::raster_value_from_xy(dtm, las$X, las$Y)
  expect_true(!anyNA(z))
})

test_that("rasterize_terrain works with kriging", {

  skip_if_not_installed("gstat")

  dtm <- rasterize_terrain(las, 1, kriging(k = 10L))

  expect_true(is(dtm, slr))
  expect_equal(lidR:::raster_res(dtm), c(1,1))
  expect_equal(dim(dtm), dim(tdtm))
  expect_equivalent(sf::st_bbox(dtm), sf::st_bbox(tdtm))
  expect_equal(lidR:::raster_names(dtm), "Z")
  expect_equal(sum(is.na(lidR:::raster_values(dtm))), 1L)

  error <- abs(dtm - tdtm)
  expect_equal(mean(lidR:::raster_values(error), na.rm = TRUE), 0.0604, tolerance = 0.0001)

  z <- lidR:::raster_value_from_xy(dtm, las$X, las$Y)
  expect_true(!anyNA(z))
})

test_that("rasterize_terrain option keep_lowest works", {

  dtm <- rasterize_terrain(las, 1, tin(), keep_lowest = TRUE)

  expect_true(is(dtm, slr))
  expect_equal(lidR:::raster_res(dtm), c(1,1))
  expect_equal(dim(dtm), dim(tdtm))
  expect_equivalent(sf::st_bbox(dtm), sf::st_bbox(tdtm))
  expect_equal(lidR:::raster_names(dtm), "Z")
  expect_equal(sum(is.na(lidR:::raster_values(dtm))), 1L)

  error <- abs(dtm - tdtm)
  expect_equal(mean(lidR:::raster_values(error), na.rm = TRUE), 0.0754, tolerance = 0.0001)

  z <- lidR:::raster_value_from_xy(dtm, las$X, las$Y)
  expect_true(!anyNA(z))
})

las2 <- clip_circle(las, 50, 50, 40)

test_that("rasterize_terrain returns a circular dtm ", {

  dtm <- rasterize_terrain(las2, 1, tin())

  expected_bbox = sf::st_bbox(c(xmin = 10, xmax = 90, ymin = 10, ymax = 90), crs = st_crs(las2))

  expect_true(is(dtm,slr))
  expect_equal(lidR:::raster_res(dtm), c(1,1))
  expect_equal(lidR:::raster_names(dtm), "Z")
  expect_equivalent(sf::st_bbox(dtm), expected_bbox)

  z <- lidR:::raster_value_from_xy(dtm, las2$X, las2$Y)
  expect_true(!anyNA(z))
})

ctg  <- topography_ctg
las  <- topography

opt_chunk_size(ctg)      <- 300
opt_chunk_buffer(ctg)    <- 30
opt_chunk_alignment(ctg) <- c(50, 200)
opt_progress(ctg)        <- FALSE

test_that("rasterize_terrain returns the same both with LAScatalog and LAS", {

  dtm1 <- rasterize_terrain(las, 1, tin())
  dtm2 <- rasterize_terrain(ctg, 1, tin())
  bbox <- sf::st_bbox(sf::st_buffer(sf::st_as_sfc(st_bbox(las), crs = st_crs(las)), -4))

  cdtm1 <- lidR:::raster_crop(dtm1, bbox)
  cdtm2 <- lidR:::raster_crop(dtm2, bbox)

  error <- abs(cdtm1 - cdtm2)

  expect_equal(mean(lidR:::raster_values(error)), 0, tolerance = 2e-5)

  z <- lidR:::raster_value_from_xy(dtm1, las$X, las$Y)
  expect_true(!anyNA(z))
})

test_that("rasterize_terrain with LAScatalog and file", {

  skip_on_cran()

  opt_output_files(ctg) <- "{tempdir()}/{ID}"
  dtm <- rasterize_terrain(ctg, 1, tin())

  expect_is(dtm, "SpatRaster")
})

test_that("rasterize_terrain fails in some specific case", {

  skip_if_not_installed("geometry")

  las@header@PHB$`X scale factor` <- 0.002
  las@header@PHB$`Y scale factor` <- 0.002

  expect_message(rasterize_terrain(las, 1, tin()), "reverted to the old slow method")

  las = data.frame(
    X = runif(10, 0,10),
    Y = runif(10, 0,10),
    Z = 1,
    Classification = 2L)

  las = LAS(las)

  expect_error(rasterize_terrain(las, 1, tin()), NA)

  las@data$Classification <- 1L
  expect_error(rasterize_terrain(las, 1, tin()), "No ground points found")

  expect_error(rasterize_terrain(las, 1, tin(), use_class = 1), NA)

  las@data$Classification <- NULL
  expect_error(rasterize_terrain(las, 1, tin()), "LAS object does not contain 'Classification' attribute")
})