tests/testthat/test_quadtree.R

In quadtree: Region Quadtrees for Spatial Data

test_that("we can create a quadtree from a matrix", {
  mat <- matrix(runif(16), 4)
  qt <- expect_error(quadtree(mat, .2), NA)
  expect_s4_class(qt, "Quadtree")
})

test_that("we can create a quadtree from a raster", {
  mat <- matrix(runif(16), 4)
  rast <- terra::rast(mat)
  qt <- expect_error(quadtree(rast, .2), NA)
  expect_s4_class(qt, "Quadtree")
})

test_that("quadtree creation with templates works", {
  habitat <- terra::rast(system.file("extdata", "habitat.tif", package="quadtree"))
  habitat_roads <- terra::rast(system.file("extdata", "habitat_roads.tif", package="quadtree"))

  qt1 <- expect_error(quadtree(habitat_roads, .1), NA)
  qt2 <- expect_error(quadtree(habitat, template_quadtree = qt1), NA)

  qt1_df <- as_data_frame(qt1, FALSE)
  qt2_df <- as_data_frame(qt2, FALSE)
  expect_equal(dim(qt1_df), dim(qt2_df))

  # everything except for the cell values should be the same
  qt1_df2 <- qt1_df[, -1 * which(names(qt1_df) == "value")]
  qt2_df2 <- qt2_df[, -1 * which(names(qt2_df) == "value")]
  expect_equal(qt1_df2, qt2_df2)
})

test_that("summary(<Quadtree>) runs without errors", {
  habitat <- terra::rast(system.file("extdata", "habitat.tif", package="quadtree"))
  qt <- quadtree(habitat, .1, split_method = "sd")
  expect_output(summary(qt))
})

test_that("'quadtree()' runs without errors for all parameter settings", {
  # library(terra)

  # retrieve the sample data
  habitat <- terra::rast(system.file("extdata", "habitat.tif", package="quadtree"))
  
  # make the raster smaller so the output files are smaller
  rast <- terra::aggregate(habitat, 6, na.rm = TRUE)

  qts <- list()
  qts[[1]] <- expect_error(quadtree(rast, .3), NA)
  qts[[2]] <- expect_error(quadtree(rast, .3, adj_type = "resample", resample_n_side = 32), NA)
  qts[[3]] <- expect_error(quadtree(rast, .3, adj_type = "resample", resample_n_side = 32, resample_pad_nas = FALSE), NA)
  qts[[4]] <- expect_error(quadtree(rast, .3, adj_type = "none"), NA)
  qts[[5]] <- expect_error(quadtree(rast, .3, max_cell_length = 3000), NA)
  qts[[6]] <- expect_error(quadtree(rast, .3, min_cell_length = 3000), NA)
  expect_equal(qts[[6]]@ptr$root()$smallestChildSideLength(), 3000) #make sure the minimum length restriction works

  qts[[7]] <- expect_error(quadtree(rast, .3, split_if_all_na = TRUE), NA)
  qts[[8]] <- expect_error(quadtree(rast, .3, split_if_any_na = FALSE), NA)
  qts[[9]] <- expect_error(quadtree(rast, .3, split_if_any_na = FALSE, max_cell_length = 3000), NA)
  qts[[10]] <- expect_error(quadtree(rast, .3, split_method = "range"), NA)
  qts[[11]] <- expect_error(quadtree(rast, .1, split_method = "sd"), NA)
  qts[[12]] <- expect_error(quadtree(rast, .1, split_method = "cv"), NA)
  qts[[13]] <- expect_error(quadtree(rast, .3, combine_method = "mean"), NA)
  qts[[14]] <- expect_error(quadtree(rast, .3, combine_method = "median"), NA)
  qts[[15]] <- expect_error(quadtree(rast, .3, combine_method = "min"), NA)
  qts[[16]] <- expect_error(quadtree(rast, .3, combine_method = "max"), NA)
  qts[[17]] <- expect_error(quadtree(rast, .1, split_method = "sd", combine_method = "min"), NA)
  #----
  split_fun <- function(vals, args) {
    if (any(is.na(vals))) { #check for NAs first
      return(TRUE) #if there are any NAs we'll split automatically
    } else {
      return(any(vals < args$threshold))
    }
  }
  qts[[18]] <- expect_error(quadtree(rast, split_method = "custom", split_fun = split_fun, split_args = list(threshold = .8)), NA)
  #----
  cmb_fun <- function(vals, args) {
    if (any(is.na(vals))) {
      return(NA)
    }
    if (mean(vals) < args$threshold) {
      return(args$low_val)
    } else {
      return(args$high_val)
    }
  }
  qts[[19]] <- expect_error(quadtree(rast, .1, combine_method = "custom", combine_fun = cmb_fun, combine_args = list(threshold = .5, low_val = 0, high_val = 1)), NA)
  #----
  cmb_fun2 <- function(vals, args) {
    return(max(vals) - min(vals))
  }
  qts[[20]] <- expect_error(quadtree(rast, .1, combine_method = "custom", combine_fun = cmb_fun2), NA)
  #----
  
  habitat_roads <- terra::rast(system.file("extdata", "habitat_roads.tif", package="quadtree"))
  template <- terra::aggregate(habitat_roads, 6, na.rm = TRUE)
  split_if_road <- function(vals, args) {
    if (any(vals > 0, na.rm = TRUE)) return(TRUE)
    return(FALSE)
  }
  qt_template <- quadtree(template, split_method = "custom", split_fun = split_if_road)
  qts[[21]] <- expect_error(quadtree(rast, template_quadtree = qt_template), NA)

  #------------------------
  # now I'll check to see if the structure of the quadtrees is the same as in
  # previous runs. Note that this doesn't guarantee correctness but is still
  # useful for alerting me if the result of 'quadtree()' changes

  # # need to use 'setwd()' first
  # for (i in seq_len(length(qts))) {
  #   write_quadtree(paste0("tests/testthat/qtrees/qt", sprintf("%03d", i), ".qtree"), qts[[i]])
  # }

  paths <- list.files("qtrees/", pattern = "*.qtree", full.names = TRUE)
  qtsp <- lapply(paths, read_quadtree) #'p' in 'qtsp' stands for 'previous'
  expect_equal(length(qts), length(qtsp))
  for (i in seq_len(length(qtsp))) {
    qts_df <- as_data_frame(qts[[i]], FALSE)
    qtsp_df <- as_data_frame(qtsp[[i]], FALSE)
    expect_equal(qts_df, qtsp_df)
  }
})