tests/testthat/test-subplot_summary.R

In BIOMASS: Estimating Aboveground Biomass and Its Uncertainty in Tropical Forests

context("subplot_summary")

data("NouraguesCoords")
data("NouraguesPlot201")
data("NouraguesTrees")
NouraguesTrees201 <- NouraguesTrees[NouraguesTrees$Plot==201,]
nouragues_raster <- terra::rast( system.file("extdata", "NouraguesRaster.tif", package = "BIOMASS", mustWork = TRUE))

corner_data <- suppressWarnings(check_plot_coord(NouraguesPlot201, proj_coord = c("Xutm","Yutm"), rel_coord = c("Xfield","Yfield"), trust_GPS_corners = F, draw_plot = F))$corner_coord

test_that("subplot_summary error", {
  subplots <- divide_plot(corner_data, rel_coord = c("x_rel","y_rel"), grid_size = 50)
  
  subplots <- suppressWarnings(divide_plot(corner_data, rel_coord = c("x_rel","y_rel"), grid_size = 50, tree_data = NouraguesTrees201, tree_coords = c("Xfield","Yfield")))
  
  expect_message(subplot_summary(subplots, value = "D", draw_plot = F), "Projected coordinates are not found in sub_corner_coord$subplots, metric(s) will be summarised in the relative coordinate system.", fixed=TRUE)
  
  expect_error(suppressMessages(subplot_summary(subplots = subplots, AGB_simu = matrix(1:4))), "The rows in 'subplots$tree_data' must match the rows in 'AGB_simu'", fixed = TRUE)
  
  subplots <- suppressWarnings(divide_plot(corner_data, rel_coord = c("x_rel","y_rel"), proj_coord = c("x_proj","y_proj"), grid_size = 50, tree_data = NouraguesTrees201, tree_coords = c("Xfield","Yfield")))
  
  expect_error(subplot_summary(subplots, value = "a", draw_plot = F) , "a is not a column name of subplots$tree_data", fixed=TRUE)
  
  expect_error(subplot_summary(subplots, value = "D", draw_plot = F, fun = "quantile") , "the function provided using `fun =` is not a function", fixed=TRUE)
  expect_error(subplot_summary(subplots, value = c("D","D"), draw_plot = F, fun = list(D="quantile",D=mean)) , "the function quantile provided in `fun =` is not a function", fixed=TRUE)
  expect_error(subplot_summary(subplots, value = "D", draw_plot = F, fun = quantile) , "the function provided using `fun` must return a single value", fixed=TRUE)
  
  expect_error(subplot_summary(subplots, value = c("D","D"), draw_plot = F, fun = list(D=mean)) , "the lengths of 'value' and 'fun' are not the same", fixed=TRUE)
  expect_error(subplot_summary(subplots, value = c("D","D","D"), draw_plot = F, fun = list(D=mean,sum,sd), per_ha = c(T,F)) , "the lengths of 'value' and 'per_ha' are not the same", fixed=TRUE)
  
})

test_that("subplot_summary_value", {
  corner_data <- suppressWarnings(check_plot_coord(NouraguesPlot201, proj_coord = c("Xutm","Yutm"), rel_coord = c("Xfield","Yfield"), trust_GPS_corners = FALSE, draw_plot = F))$corner_coord
  
  # Test with rel_coord
  subplots_rel_coord <- suppressWarnings(divide_plot(corner_data, rel_coord = c("x_rel","y_rel"), grid_size = 25,
                                                     tree_data = NouraguesTrees201, tree_coords = c("Xfield","Yfield")))
  res_rel_coord <- suppressMessages(subplot_summary(subplots_rel_coord, value = "D", draw_plot = F))
  expect_equivalent(res_rel_coord$tree_summary[1,2], as.data.table(subplots_rel_coord$tree_data)[subplot_ID=="subplot_0_0", sum(D)] * 16)
  
  
  # Test with proj_coord
  subplots_proj_coord <- suppressWarnings(divide_plot(corner_data, rel_coord = c("x_rel","y_rel"), proj_coord = c("x_proj","y_proj"), grid_size = 25, tree_data = NouraguesTrees201, tree_coords = c("Xfield","Yfield")))
  res_proj_coord <- suppressMessages(subplot_summary(subplots_proj_coord, value = "D", draw_plot = F))
  expect_equal(res_rel_coord$tree_summary, res_proj_coord$tree_summary) # equal as corner_dat has been evaluated with trust_GPS_corners=FALSE 
  
  # Test with longlat
  longlat_corner_data <- suppressWarnings(check_plot_coord(NouraguesPlot201, longlat = c("Long","Lat"), rel_coord = c("Xfield","Yfield"), trust_GPS_corners = F, draw_plot = F))
  corner_data[c("long","lat")] <- as.data.frame( proj4::project(corner_data[c("x_proj","y_proj")],
                                                                proj = longlat_corner_data$UTM_code$UTM_code, inverse = TRUE) )
  subplots_longlat <- suppressWarnings(divide_plot(corner_data, rel_coord = c("x_rel","y_rel"), longlat = c("long","lat"), grid_size = 25, tree_data = NouraguesTrees201, tree_coords = c("Xfield","Yfield")))
  res_longlat <- subplot_summary(subplots = subplots_longlat, value = "D", draw_plot = F)
  expect_equal(res_longlat$tree_summary, res_proj_coord$tree_summary)
  
  # Test when there isn't a tree in a subplot
  subplots_less_trees <- subplots_proj_coord
  subplots_less_trees$tree_data <- subplots_less_trees$tree_data[subplots_less_trees$tree_data$subplot_ID != "subplot_0_1",]
  res_less <- subplot_summary(subplots_less_trees, value = "D", draw_plot = F)
  expect_true(is.na(res_less$tree_summary[5,"D_sum_per_ha"]))
  
  # Test with quantile function
  res_quantile <- subplot_summary(subplots_longlat, value = "D", draw_plot = F, fun = quantile, probs=0.75, per_ha = FALSE)
  expect_equivalent(res_quantile$tree_summary$D_quantile[1], as.data.table(subplots_longlat$tree_data)[subplot_ID == "subplot_0_0",quantile(D,probs=0.75)])
  
  # Test multiple plots
  multiple_subplots <- suppressWarnings(divide_plot(corner_data = NouraguesCoords,
                                                    rel_coord = c("Xfield","Yfield"), proj_coord = c("Xutm","Yutm"), 
                                                    grid_size = 50, corner_plot_ID = "Plot",
                                                    tree_data = NouraguesTrees , tree_coords = c("Xfield","Yfield"), tree_plot_ID = "Plot"))
  
  res_multiple <- subplot_summary(subplots = multiple_subplots, value = "D", fun=mean, draw_plot = F, per_ha = FALSE)
  res_mean_D <- as.data.table(multiple_subplots$tree_data)[!is.na(subplot_ID), mean(D), by=subplot_ID]
  expect_equivalent(res_multiple$tree_summary[order(res_multiple$tree_summary$subplot_ID),"D_mean"], res_mean_D[order(res_mean_D$subplot_ID),V1])
  
  # Test with multiple metrics
  res_metrics <- subplot_summary(subplots = multiple_subplots, value = c("D","x_rel"), fun = list(D=sum,x_rel=mean), per_ha = c(T,F) , draw_plot = F)
  expect_equal(names(res_metrics$tree_summary), c("subplot_ID","x_rel_mean","D_sum_per_ha"))
  
  # Test with user function : 
  count_fun <- function(x) length(na.omit(x))
  res_metrics <- subplot_summary(subplots = subplots_longlat, value = c("D","x_rel"), fun = list(D=sum,x_rel=count_fun), per_ha = c(T,F) , draw_plot = F)
  expect_equal(names(res_metrics$tree_summary), c("subplot_ID","x_rel_count_fun","D_sum_per_ha"))
  
})

test_that("subplot_summary_raster", {
  multiple_subplots <- suppressWarnings(divide_plot(corner_data = NouraguesCoords,
                                                    rel_coord = c("Xfield","Yfield"), proj_coord = c("Xutm","Yutm"), 
                                                    grid_size = 25, corner_plot_ID = "Plot",
                                                    tree_data = NouraguesTrees , tree_coords = c("Xfield","Yfield"), tree_plot_ID = "Plot"))
  
  expect_error(subplot_summary(subplots = multiple_subplots, value = c("D","D"), draw_plot = FALSE, fun = list(mean,sd), ref_raster = "toto", raster_fun = list(mean,sd)) , "ref_raster is not recognised as a SpatRaster of terra package")
  
  expect_error(subplot_summary(multiple_subplots, value = "D", draw_plot = F, raster_fun = "quantile") , "the function provided using `raster_fun =` is not a function", fixed=TRUE)
  expect_error(subplot_summary(multiple_subplots, value = c("D","D"), draw_plot = F, raster_fun = list(D="quantile",D=mean)) , "not a function")
  expect_error(subplot_summary(multiple_subplots, value = "D", draw_plot = F, ref_raster = nouragues_raster, raster_fun = quantile) , "the function provided using `raster_fun` must return a single value", fixed=TRUE)
  
  
  res_multiple <- subplot_summary(multiple_subplots, value = c("D","D"), draw_plot = FALSE, fun = list(mean,sd), ref_raster = nouragues_raster, raster_fun = list(mean,sd))
  rownames(res_multiple$tree_summary) <- NULL
  
  expect_equal(as.data.frame(res_multiple$tree_summary[1,]) ,
               data.frame(subplot_ID="201_0_0",
                          D_mean_per_ha=409.8663, D_sd_per_ha=313.5045,
                          z2012_mean=24.26298,z2012_sd=11.45732), 
               tolerance = 1e-2)
  
  
  subplots <- suppressWarnings(divide_plot(NouraguesCoords[NouraguesCoords$Plot==201,], rel_coord = c("Xfield","Yfield"), proj_coord = c("Xutm","Yutm"), grid_size = 25, tree_data = NouraguesTrees201, tree_coords = c("Xfield","Yfield")))
  res_unique <- subplot_summary(subplots, value = "D", draw_plot = FALSE, fun = mean, ref_raster = nouragues_raster, raster_fun = mean)
  rownames(res_unique$tree_summary) <- NULL
  
  expect_equal(res_multiple$tree_summary[1:16, c(2,4)] , res_unique$tree_summary[,c(2,3)], tol=1e-2)
  
})


HDmodel <- modelHD(D = NouraguesHD$D, H = NouraguesHD$H, method = "log2")
NouraguesWD <- suppressMessages(getWoodDensity(NouraguesTrees$Genus, NouraguesTrees$Species))

error_prop <- AGBmonteCarlo(
  D = NouraguesTrees$D, WD = NouraguesWD$meanWD, # we do not provide H
  HDmodel = HDmodel, # but we provide HDmodel
  Dpropag = "chave2004",
  errWD = NouraguesWD$sdWD, n = 50)
error_prop_201 <- error_prop$AGB_simu[NouraguesTrees$Plot==201,]

subplots <- suppressWarnings(divide_plot(corner_data, rel_coord = c("x_rel","y_rel"), proj_coord = c("x_proj","y_proj"), grid_size = 25,
                                         tree_data = NouraguesTrees201, tree_coords = c("Xfield","Yfield")))
multiple_subplots <- suppressWarnings(divide_plot(corner_data = NouraguesCoords,
                                                  rel_coord = c("Xfield","Yfield"), proj_coord = c("Xutm","Yutm"), 
                                                  grid_size = 25, corner_plot_ID = "Plot",
                                                  tree_data = NouraguesTrees , tree_coords = c("Xfield","Yfield"), tree_plot_ID = "Plot"))


test_that("subplot_summary_AGB_uncertainties", {
  
  expect_error(subplot_summary(subplots = subplots, AGB_simu = error_prop), "'AGB_simu' must be a matrix containing individual AGB (one row per tree), typically, the output '$AGB_simu' of the AGBmonteCarlo() function.", fixed=TRUE)
  expect_error(subplot_summary(subplots = subplots, AGB_simu = error_prop$AGB_simu), "The rows in 'subplots$tree_data' must match the rows in 'AGB_simu'", fixed=TRUE)
  
  ### One plot:
  expect_message(res <- subplot_summary(subplots = subplots, AGB_simu = error_prop_201, draw_plot = FALSE), "AGB uncertainties will be propagated without propagation of corner GPS measurement uncertainties." )
  
  # check $tree_summary
  expect_equal(names(res$tree_summary), c("subplot_ID","AGBD_median","AGBD_cred_2.5","AGBD_cred_97.5"))
  # check $long_AGB_simu
  expect_equal(dim(res$long_AGB_simu), c(800, 6))
  expect_equal(length(unique(res$long_AGB_simu$x_center)), 16)
  expect_equal(names(res$long_AGB_simu), c("plot_ID","subplot_ID","N_simu","x_center","y_center","AGBD"))
  # Check by hand of the AGBD calculation
  AGB_simu_201 <- data.table(error_prop_201)
  AGB_simu_201$subplot_ID <- subplots$tree_data$subplot_ID
  AGB_simu_201_sum <- AGB_simu_201[!is.na(subplot_ID), lapply(.SD, sum), by=subplot_ID, .SDcols = !"subplot_ID"]
  AGB_simu_201_sum <- data.frame(AGB_simu_201_sum)
  rownames(AGB_simu_201_sum) <- AGB_simu_201_sum$subplot_ID
  AGB_simu_201_sum$subplot_ID <- NULL
  AGB_simu_201_sum <- AGB_simu_201_sum*16
  AGB_simu_201_sum <- apply(AGB_simu_201_sum , 1 , median)
  expect_equivalent(res$tree_summary$AGBD_median , AGB_simu_201_sum[res$tree_summary$subplot_ID])
  
  
  # With values : 
  res_w_values <- suppressMessages(subplot_summary(subplots = subplots, value = c("D","x_rel"), fun = list(D=sum,x_rel=mean), per_ha = c(T,F), AGB_simu = error_prop_201, draw_plot = F))
  # check $tree_summary
  expect_equal(names(res_w_values$tree_summary), c("subplot_ID","x_rel_mean","D_sum_per_ha","AGBD_median","AGBD_cred_2.5","AGBD_cred_97.5"))
  # check $plot_design
  expect_equal(length(res_w_values$plot_design), 3) # plot AGBD_median and the 2 metrics
  
  ### multiple plots:
  res_mult <- suppressMessages(subplot_summary(subplots = multiple_subplots, AGB_simu = error_prop$AGB_simu, draw_plot = FALSE))
  # check $tree_summary
  expect_equal(res_mult$tree_summary[grepl("201",subplot_ID),c(2,3,4)], res$tree_summary[,c(2,3,4)], tolerance = 0.1) #not exactly the same because of the number of digits of the area
  # check $plot_design
  expect_equal(length(res_mult$plot_design), 4) # the 4 plots
  expect_equal(length(res_mult$plot_design[[1]]), 1) # AGBD_median and that's it
  
  ### with raster
  res_mult_rast <- suppressMessages(subplot_summary(subplots = multiple_subplots, AGB_simu = error_prop$AGB_simu, draw_plot = FALSE, ref_raster = nouragues_raster, raster_fun = median))
  expect_equal(names(res_mult_rast$tree_summary), c("subplot_ID","z2012_median","AGBD_median","AGBD_cred_2.5","AGBD_cred_97.5") )
  expect_equal(length(res_mult_rast$plot_design[[1]]), 2 ) # z2012_median and AGBD median
  
  ### with raster and value
  res_mult_rast_value <- suppressMessages(subplot_summary(subplots = multiple_subplots, AGB_simu = error_prop$AGB_simu, value="D", fun = mean, draw_plot = FALSE, ref_raster = nouragues_raster))
  expect_equal(names(res_mult_rast_value$tree_summary), c("subplot_ID","D_mean_per_ha","z2012_mean","AGBD_median","AGBD_cred_2.5","AGBD_cred_97.5") )
  expect_equal(length(res_mult_rast_value$plot_design[[1]]), 3 ) # D_mean_per_ha, z2012_median and AGBD median 
  
})

test_that("subplot_summary_coord_uncertainties", {
  
  # One plot
  subplots <- suppressWarnings(divide_plot(corner_data, rel_coord = c("x_rel","y_rel"), proj_coord = c("x_proj","y_proj"), grid_size = 50,
                          tree_data = NouraguesTrees201, tree_coords = c("Xfield","Yfield"),
                          sd_coord = 5, n = 10))
  expect_warning(res_coord <- subplot_summary(subplots = subplots, value = "D", draw_plot = FALSE), "the following results will not take into account the uncertainty of corner coordinates.")
  
  res_coord <- subplot_summary(subplots = subplots, value = "D", ref_raster = nouragues_raster, draw_plot = FALSE)
  expect_equal(names(res_coord$tree_summary), c("subplot_ID","D_sum_per_ha","z2012_mean_median","z2012_mean_cred_2.5","z2012_mean_cred_97.5") )
  expect_equal(length(res_coord$plot_design), 2 ) # D_sum_per_ha and z2012_median
  
  # multiple plot
  multiple_subplots <- suppressWarnings(divide_plot(corner_data = NouraguesCoords,
                                                    rel_coord = c("Xfield","Yfield"), proj_coord = c("Xutm","Yutm"), 
                                                    grid_size = 50, corner_plot_ID = "Plot",
                                                    tree_data = NouraguesTrees , tree_coords = c("Xfield","Yfield"), tree_plot_ID = "Plot",
                                                    sd_coord = 3, n = 10))
  res_coord_mult <- subplot_summary(subplots = multiple_subplots, value = "D", ref_raster = nouragues_raster, draw_plot = FALSE)
  expect_equal(names(res_coord_mult$tree_summary), c("subplot_ID","D_sum_per_ha","z2012_mean_median","z2012_mean_cred_2.5","z2012_mean_cred_97.5") )
  expect_equal(length(res_coord_mult$plot_design), 4 ) # 4 plots
  expect_equal(length(res_coord_mult$plot_design[[1]]), 2 ) # D_mean_per_ha and z2012_median
  
  
  # With AGB uncertainties
  # one plot:
  expect_message(
    res_coord <- subplot_summary(subplots = subplots, AGB_simu = error_prop_201, ref_raster = nouragues_raster, draw_plot = FALSE),
    "40 simulations will be resampled in 'subplots'.")
  
  expect_equal(names(res_coord$tree_summary), c("subplot_ID","AGBD_median","AGBD_cred_2.5","AGBD_cred_97.5","z2012_mean_median","z2012_mean_cred_2.5","z2012_mean_cred_97.5") )
  expect_equal(dim(res_coord$long_AGB_simu), c(50*4,7))
  expect_equal(names(res_coord$long_AGB_simu), c("plot_ID","subplot_ID","N_simu","x_center","y_center","AGBD","z2012_mean"))
  expect_equal(length(unique(res_coord$long_AGB_simu$z2012_mean)) , 4 * 10)
  
  # multiple plots: 
  multiple_subplots <- suppressWarnings(divide_plot(NouraguesCoords, rel_coord = c("Xfield","Yfield"), proj_coord = c("Xutm","Yutm"), grid_size = 50,
                                           tree_data = NouraguesTrees, tree_coords = c("Xfield","Yfield"),
                                           corner_plot_ID = "Plot", tree_plot_ID = "Plot",
                                           sd_coord = 5, n = 60))
  expect_message(
    res_coord_mult <- subplot_summary(subplots = multiple_subplots, AGB_simu = error_prop$AGB_simu, ref_raster = nouragues_raster, draw_plot = FALSE),
    "the first 50 simulations contained in 'subplots$simu_coord' will be considered.", fixed=TRUE)
  
  expect_equal(names(res_coord_mult$tree_summary), c("subplot_ID","AGBD_median","AGBD_cred_2.5","AGBD_cred_97.5","z2012_mean_median","z2012_mean_cred_2.5","z2012_mean_cred_97.5") )
  expect_equal(dim(res_coord_mult$long_AGB_simu), c(50*4*4,7))
  expect_equal(names(res_coord_mult$long_AGB_simu), c("plot_ID","subplot_ID","N_simu","x_center","y_center","AGBD","z2012_mean"))
  expect_equal(length(unique(res_coord_mult$long_AGB_simu$z2012_mean)) , 4*50*4)
  
  
})