Commit eef15d73 authored by Monnet Jean-Matthieu's avatar Monnet Jean-Matthieu
Browse files

future_lapply used in aba3

No related merge requests found
Showing with 222 additions and 205 deletions
+222 -205
...@@ -21,7 +21,7 @@ knitr::opts_chunk$set(fig.align = "center") ...@@ -21,7 +21,7 @@ knitr::opts_chunk$set(fig.align = "center")
``` ```
--- ---
The code below presents a workflow to map forest parameters using calibrated prediction models (see [previous tutorial](https://gitlab.irstea.fr/jean-matthieu.monnet/lidartree_tutorials/-/blob/master/area-based.2.model.calibration.Rmd)) and wall-to-wall coverage of the region of interest with airborne laser scanning. This tutorial is the last step of the so-called area-based approach. It is based on functions from `R` packages `lidaRtRee` and `lidR`. The code below presents a workflow to map forest parameters using calibrated prediction models (see [previous tutorial](https://gitlab.irstea.fr/jean-matthieu.monnet/lidartree_tutorials/-/blob/master/area-based.2.model.calibration.Rmd)) and wall-to-wall coverage of the region of interest with airborne laser scanning. This tutorial is the last step of the so-called area-based approach. It is based on functions from `R` packages [lidaRtRee](https://cran.r-project.org/package=lidaRtRee) (`r packageVersion("lidaRtRee")`) and [lidR](https://cran.r-project.org/package=lidR) (`r packageVersion("lidR")`).
Licence: GNU GPLv3 / [Source page](https://gitlab.irstea.fr/jean-matthieu.monnet/lidartree_tutorials/-/blob/master/R/area-based.3.mapping.and.inference.Rmd) Licence: GNU GPLv3 / [Source page](https://gitlab.irstea.fr/jean-matthieu.monnet/lidartree_tutorials/-/blob/master/R/area-based.3.mapping.and.inference.Rmd)
...@@ -212,13 +212,13 @@ raster::plot(metrics_terrain$slope_gr, main = "Slope (gr)") ...@@ -212,13 +212,13 @@ raster::plot(metrics_terrain$slope_gr, main = "Slope (gr)")
### Batch processing of tiles ### Batch processing of tiles
For the batch processing of tiles, parallel processing with packages `foreach` and `doFuture` is used. The processing capabilities of `lidR` are not yet used. For the batch processing of tiles, parallel processing with packages `future` and `future.apply` is used. The processing capabilities of `lidR` are not yet used.
```{r setupCluster, include=TRUE, message=FALSE, warning=FALSE, fig.width = 12, fig.height = 4} ```{r setupCluster, include=TRUE, message=FALSE, warning=FALSE, fig.width = 12, fig.height = 4}
library(foreach) # specify to use two parallel sessions
# create parallel frontend, specify to use two parallel sessions
doFuture::registerDoFuture()
future::plan("multisession", workers = 2L) future::plan("multisession", workers = 2L)
# remove warning when using random numbers in parallel sessions
options(future.rng.onMisue = "ignore")
``` ```
A buffering procedure is designed to handle the border effects when detecting trees at tile edges. A 10 m buffer is enough for tree metrics. One can also specify points classes to use, or apply a threshold to high points. Some parameters specified in the previous paragraphs are also required for the batch processing (output map resolution, chm resolution for tree segmentation, functions for metrics computation). A buffering procedure is designed to handle the border effects when detecting trees at tile edges. A 10 m buffer is enough for tree metrics. One can also specify points classes to use, or apply a threshold to high points. Some parameters specified in the previous paragraphs are also required for the batch processing (output map resolution, chm resolution for tree segmentation, functions for metrics computation).
...@@ -237,95 +237,115 @@ class_points <- c(0, 1, 2, 3, 4, 5) ...@@ -237,95 +237,115 @@ class_points <- c(0, 1, 2, 3, 4, 5)
This first chunk of code computes tree and point metrics from the normalized ALS tiles. This first chunk of code computes tree and point metrics from the normalized ALS tiles.
```{r batchProcessing, include=TRUE, message=FALSE, warning=FALSE, fig.width = 12, fig.height = 4} ```{r batchProcessing, include=TRUE, message=FALSE, warning=FALSE, fig.width = 12, fig.height = 4}
# processing by tile # processing by tile: apply to all tiles a function that loads a tile plus buffer and then processes the data)
metrics <- foreach::foreach(i = 1:nrow(cata_height), .errorhandling = "remove") %dopar% { metrics <- future.apply::future_lapply(
# tile extent as.list(1:nrow(cata_height)),
b_box <- as.numeric(cata_height@data[i, c("Min.X", "Min.Y", "Max.X", "Max.Y")]) FUN = function(i) {
# load tile extent plus buffer # tile extent
a <- try(lidR::clip_rectangle( b_box <-
cata_height, b_box[1] - b_size, b_box[2] - b_size, b_box[3] + b_size, as.numeric(cata_height@data[i, c("Min.X", "Min.Y", "Max.X", "Max.Y")])
b_box[4] + b_size # load tile extent plus buffer
)) a <- try(lidR::clip_rectangle(cata_height,
# b_box[1] - b_size,
# check if points are successfully loaded b_box[2] - b_size,
if (class(a) == "try-error") { b_box[3] + b_size,
return(NULL) b_box[4] + b_size))
} #
# add 'buffer' flag to points in buffer with TRUE value in this new attribute # check if points are successfully loaded
a <- lidR::add_attribute( if (class(a) == "try-error") {
a, return(NULL)
a$X < b_box[1] | a$Y < b_box[2] | a$X >= b_box[3] | a$Y >= b_box[4], }
"buffer" # add 'buffer' flag to points in buffer with TRUE value in this new attribute
) a <- lidR::add_attribute(a,
# remove unwanted point classes, and points higher than height threshold a$X < b_box[1] |
a <- lidR::filter_poi(a, is.element(Classification, class_points) & Z <= h_points) a$Y < b_box[2] |
# check number of remaining points a$X >= b_box[3] | a$Y >= b_box[4],
if (length(a) == 0) { "buffer")
return(NULL) # remove unwanted point classes, and points higher than height threshold
} a <-
# set negative heights to 0 lidR::filter_poi(a, is.element(Classification, class_points) &
a@data$Z[a@data$Z < 0] <- 0 Z <= h_points)
# # check number of remaining points
# compute chm if (length(a) == 0) {
chm <- lidaRtRee::points2DSM(a, res = aba_res_chm) return(NULL)
# replace NA, low and high values by 0 }
chm[is.na(chm) | chm < 0 | chm > h_points] <- 0 # set negative heights to 0
# a@data$Z[a@data$Z < 0] <- 0
# compute tree metrics #
# tree top detection (default parameters) # compute chm
segms <- lidaRtRee::tree_segmentation(chm) chm <-
# extraction to data.frame lidaRtRee::points2DSM(a, res = aba_res_chm)
trees <- lidaRtRee::tree_extraction(segms$filled_dem, segms$local_maxima, segms$segments_id) # replace NA, low and high values by 0
# remove trees outside of tile chm[is.na(chm) |
trees <- trees[trees$x >= b_box[1] & trees$x < b_box[3] & trees$y >= b_box[2] & trees$y < b_box[4], ] chm < 0 | chm > h_points] <- 0
# compute raster metrics #
metrics_trees <- lidaRtRee::raster_metrics(trees[, -1], # compute tree metrics
res = resolution, # tree top detection (default parameters)
fun = function(x) { segms <- lidaRtRee::tree_segmentation(chm)
lidaRtRee::std_tree_metrics(x, resolution^2 / 10000) # extraction to data.frame
}, trees <-
output = "raster" lidaRtRee::tree_extraction(segms$filled_dem, segms$local_maxima, segms$segments_id)
) # remove trees outside of tile
# compute canopy cover in trees and canopy mean height in trees trees <-
# in region of interest, because it is not in previous step. trees[trees$x >= b_box[1] &
r_treechm <- segms$filled_dem trees$x < b_box[3] &
# set chm to NA in non segment area trees$y >= b_box[2] & trees$y < b_box[4],]
r_treechm[segms$segments_id == 0] <- NA # compute raster metrics
# compute raster metrics metrics_trees <- lidaRtRee::raster_metrics(
metrics_trees2 <- lidaRtRee::raster_metrics( trees[,-1],
raster::crop(r_treechm, raster::extent(b_box[1], b_box[3], b_box[2], b_box[4])), res = resolution,
res = resolution, fun = function(x) {
fun = function(x) { lidaRtRee::std_tree_metrics(x, resolution ^ 2 / 10000)
c( },
sum(!is.na(x$filled_dem)) / (resolution / aba_res_chm)^2, output = "raster"
mean(x$filled_dem, na.rm = T) )
) # compute canopy cover in trees and canopy mean height in trees
}, # in region of interest, because it is not in previous step.
output = "raster" r_treechm <- segms$filled_dem
) # set chm to NA in non segment area
names(metrics_trees2) <- c("TreeCanopy_cover_in_plot", "TreeCanopy_meanH_in_plot") r_treechm[segms$segments_id == 0] <- NA
# # compute raster metrics
# compute 1D height metrics metrics_trees2 <- lidaRtRee::raster_metrics(
# remove buffer points raster::crop(r_treechm, raster::extent(b_box[1], b_box[3], b_box[2], b_box[4])),
a <- lidR::filter_poi(a, buffer == 0) res = resolution,
# fun = function(x) {
if (length(a) == 0) { c(sum(!is.na(x$filled_dem)) / (resolution / aba_res_chm) ^ 2,
return(NULL) mean(x$filled_dem, na.rm = T))
},
output = "raster"
)
names(metrics_trees2) <-
c("TreeCanopy_cover_in_plot", "TreeCanopy_meanH_in_plot")
#
# compute 1D height metrics
# remove buffer points
a <- lidR::filter_poi(a, buffer == 0)
#
if (length(a) == 0) {
return(NULL)
}
# all points metrics
metrics_points <-
lidR::grid_metrics(a, aba_point_metrics_fun, res = resolution)
#
# extend / crop to match metrics_points
metrics_trees <-
raster::extend(metrics_trees, metrics_points, values = NA)
metrics_trees2 <-
raster::extend(metrics_trees2, metrics_points, values = NA)
metrics_trees <-
raster::crop(metrics_trees, metrics_points)
metrics_trees2 <-
raster::crop(metrics_trees2, metrics_points)
# merge rasterstacks
metrics <- metrics_points
metrics <-
raster::addLayer(metrics, metrics_trees)
metrics <-
raster::addLayer(metrics, metrics_trees2)
return(metrics)
} }
# all points metrics )
metrics_points <- lidR::grid_metrics(a, aba_point_metrics_fun, res = resolution)
#
# extend / crop to match metrics_points
metrics_trees <- raster::extend(metrics_trees, metrics_points, values = NA)
metrics_trees2 <- raster::extend(metrics_trees2, metrics_points, values = NA)
metrics_trees <- raster::crop(metrics_trees, metrics_points)
metrics_trees2 <- raster::crop(metrics_trees2, metrics_points)
# merge rasterstacks
metrics <- metrics_points
metrics <- raster::addLayer(metrics, metrics_trees)
metrics <- raster::addLayer(metrics, metrics_trees2)
return(metrics)
}
# mosaic rasters # mosaic rasters
names_metrics <- names(metrics[[1]]) names_metrics <- names(metrics[[1]])
metrics_map <- do.call(raster::merge, metrics) metrics_map <- do.call(raster::merge, metrics)
...@@ -340,23 +360,26 @@ The second chunk of code computes terrain metrics from the ALS tiles with altitu ...@@ -340,23 +360,26 @@ The second chunk of code computes terrain metrics from the ALS tiles with altitu
f <- function(x, y, z) { f <- function(x, y, z) {
as.list(lidaRtRee::terrain_points_metrics(data.frame(x, y, z))) as.list(lidaRtRee::terrain_points_metrics(data.frame(x, y, z)))
} }
# # apply function to all tiles specified by indices
metrics_terrain <- foreach::foreach(i = 1:nrow(cata_altitude), .errorhandling = "remove") %dopar% { metrics_terrain <- future.apply::future_lapply(
# tile extent as.list(1:nrow(cata_height)),
b_box <- as.numeric(cata_altitude@data[i, c("Min.X", "Min.Y", "Max.X", "Max.Y")]) FUN = function(i) {
# load tile extent plus buffer # tile extent
a <- try(lidR::clip_rectangle( b_box <- as.numeric(cata_altitude@data[i, c("Min.X", "Min.Y", "Max.X", "Max.Y")])
cata_altitude, b_box[1], b_box[2], b_box[3], # load tile extent plus buffer
b_box[4] a <- try(lidR::clip_rectangle(
)) cata_altitude, b_box[1], b_box[2], b_box[3],
# check if points are successfully loaded b_box[4]
if (class(a) == "try-error") { ))
return(NULL) # check if points are successfully loaded
if (class(a) == "try-error") {
return(NULL)
}
# keep only ground points
a <- lidR::filter_ground(a)
lidR::grid_metrics(a, ~ f(X, Y, Z), res = resolution)
} }
# keep only ground points )
a <- lidR::filter_ground(a)
lidR::grid_metrics(a, ~ f(X, Y, Z), res = resolution)
}
# mosaic rasters # mosaic rasters
names_metrics <- names(metrics_terrain[[1]]) names_metrics <- names(metrics_terrain[[1]])
metrics_terrain <- do.call(raster::merge, metrics_terrain) metrics_terrain <- do.call(raster::merge, metrics_terrain)
......
This source diff could not be displayed because it is too large. You can view the blob instead.
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment