Skip to content

GitLab

Commit 1bffcd63 authored by Florian de Boissieu's avatar Florian de Boissieu
Browse files

change dependency to lidR 1.6.1 only

parent e6f89b69
Hide whitespace changes
Inline Side-by-side
Showing with 95 additions and 207 deletions
DESCRIPTION
View file @ 1bffcd63
......@@ -11,7 +11,7 @@ License: GPL3
LazyData: true
Imports: shiny (>= 1.0.3),
shinydashboard (>= 0.6.1),
lidR (>= 1.2.1),
lidR (== 1.6.1),
rlas (>= 1.1.3),
DT (>= 0.2),
R6 (>= 2.2.2),
......
NEWS.md
View file @ 1bffcd63
......@@ -11,14 +11,16 @@
* Add voxelisation
* Add field id or a method getID in every models, to track/check id every time needed.
## lidRGUI v0.0.0.9012 (in development)
## lidRGUI v0.0.0.9012
### Bug fix
- global variables update on chosse directory/file cancelling
- global variables update on choose directory/file cancelling
- custom data table with opion paging instead of scroller
- fix bugs in caret for cohexistence of preProcess options "zv" and "corr"
### Change
- *lidR must be 1.6.1*, next releases will follow lidR evolution
- demo gif
- file and directory browsers on server with shinyFiles
### Add
- projection persitence at loading between LAScatalog and Plots
......
R/button_LasGridButton.R
View file @ 1bffcd63
......@@ -89,9 +89,8 @@ LasGridButton <- function(input, output, session, default_param) {
if (!is.na(path()) && nchar(path()) > 0){
withBusyIndicatorServer(session$ns("load"), {
new_catalog <- catalog(path())
if (!(nrow(new_catalog@data > 0)) ||
(packageVersion("lidR")<'1.3.0' && !(nrow(new_catalog) > 0))) {
stop("invalid choice")
if (!(nrow(new_catalog@data > 0))) {
stop("Directory has no las/laz file.")
} else {
newData(new_catalog)
showModal(lasGridModal())
......
R/transform_TreeSegementation_methods.R
View file @ 1bffcd63
......@@ -44,67 +44,38 @@ watershedMethod = function() {
}
watershedRenderUI <- function(session) {
if(packageVersion("lidR")<'1.4.0')
fluidRow(
column(3, tooltip("Image of the canopy for each plot. You can compute it in Canopy Height Model section.",
selectInput(session$ns("chm_input_data"), "CHM", dataModel$getKeys(CHMData$classname)))),
column(3, tooltip("Number value below which a pixel cannot be a crown.",
numericInput(session$ns("th_input_param"), "th", 2, min = 3, step = 2))),
column(3, tooltip("see ?EBImage::watershed.",
numericInput(session$ns("tolerance_input_param"), "tolerance", 1, min = 3, step = 2))),
column(3, tooltip("see ?EBImage::watershed",
numericInput(session$ns("ext_input_param"), "ext", 1, min = 3, step = 2)))
)
else
fluidRow(
column(3, tooltip("Image of the canopy for each plot. You can compute it in Canopy Height Model section.",
selectInput(session$ns("chm_input_data"), "CHM", dataModel$getKeys(CHMData$classname)))),
column(3, tooltip("Threshold below which a pixel cannot be a tree.",
numericInput(session$ns("th_tree_input_param"), "th_tree", 2, min = 0))),
column(3, tooltip("Tolerance see ?EBImage::watershed.",
numericInput(session$ns("tol_input_param"), "tol", 1, min = 0))),
column(3, tooltip("see ?EBImage::watershed.",
numericInput(session$ns("ext_input_param"), "ext", 1, min = 0)))
)
fluidRow(
column(3, tooltip("Image of the canopy for each plot. You can compute it in Canopy Height Model section.",
selectInput(session$ns("chm_input_data"), "CHM", dataModel$getKeys(CHMData$classname)))),
column(3, tooltip("Threshold below which a pixel cannot be a tree.",
numericInput(session$ns("th_tree_input_param"), "th_tree", 2, min = 0))),
column(3, tooltip("Tolerance see ?EBImage::watershed.",
numericInput(session$ns("tol_input_param"), "tol", 1, min = 0))),
column(3, tooltip("see ?EBImage::watershed.",
numericInput(session$ns("ext_input_param"), "ext", 1, min = 0)))
)
}
watershedProcess <- function(input) {
if(packageVersion("lidR")<'1.4.0')
req(input$chm_input_data, input$th_input_param, input$tolerance_input_param, input$ext_input_param)
else
req(input$chm_input_data, input$th_tree_input_param, input$tol_input_param, input$ext_input_param)
req(input$chm_input_data, input$th_tree_input_param, input$tol_input_param, input$ext_input_param)
selectedCHM <- dataModel$getData(input$chm_input_data)$data
selectedLas <- dataModel$getData(input$laslist_input_data)$data
cl = parallel::makeCluster(parameters$cores, outfile = "")
if(packageVersion("lidR")<'1.4.0'){
plots.lastrees <- parallel::clusterMap(cl, watershedGUI, selectedLas, selectedCHM,
MoreArgs = list(th = input$th_input_param,
tolerance = input$tolerance_input_param,
ext = input$ext_input_param))
}else{
selectedTreeTops <- dataModel$getData(input$treetops_input_data)$data
plots.lastrees <- parallel::clusterMap(cl, watershedGUI, las=selectedLas, chm=selectedCHM, treetops=selectedTreeTops,
MoreArgs = list( th = input$th_tree_input_param,
tol = input$tol_input_param,
ext = input$ext_input_param))
}
selectedTreeTops <- dataModel$getData(input$treetops_input_data)$data
plots.lastrees <- parallel::clusterMap(cl, watershedGUI, las=selectedLas, chm=selectedCHM, treetops=selectedTreeTops,
MoreArgs = list( th = input$th_tree_input_param,
tol = input$tol_input_param,
ext = input$ext_input_param))
parallel::stopCluster(cl)
return(plots.lastrees)
}
watershedGUI <- function(las, ...){
# processing by reference --> needs to be copied for parallel proc
if(packageVersion("lidR")<'1.3.0')
las=LAS(las@data, las@header)
else if(packageVersion("lidR")<'1.5.0'){
lascrs = las@crs
las=LAS(las@data, las@header)
las@crs = lascrs
}else
las=LAS(las@data, las@header, las@crs)
las=LAS(las@data, las@header, las@crs)
lastrees(las, "watershed", ...)
# th_tree = 2, th_seed = 0.45,
......@@ -126,27 +97,20 @@ dalponte2016Method = function() {
dalponte2016RenderUI <- function(session) {
# dalponte2016 parameters: searchWinSize = 9, TRESHSeed = .45, TRESHCrown = .55, DIST = 2, th = 3
if(packageVersion("lidR")<'1.4.0')
fluidRow(
column(4, tooltip("Image of the canopy for each plot. You can compute it in Canopy Height Model section.",
selectInput(session$ns("chm_input_data"), "CHM RASTER", dataModel$getKeys(CHMData$classname)))),
column(3, numericInput(session$ns("winsize_input_param"), "Window Size", 9L, min = 3, step = 2))
)
else
fluidRow(
column(6, tooltip("Image of the canopy for each plot. You can compute it in Canopy Height Model section.",
selectInput(session$ns("chm_input_data"), "CHM", dataModel$getKeys(CHMData$classname)))),
column(6, tooltip("Object of class TreeTops containing the position of the trees. Can be computed in Tree Top Detection section.",
selectInput(session$ns("treetops_input_data"), "Tree Tops", dataModel$getKeys(TreeTopsData$classname)))),
column(3, tooltip("Threshold below which a pixel cannot be a tree.",
numericInput(session$ns("th_tree_input_param"), "th_tree", 2, min = 0))),
column(3, tooltip("Growing threshold 1. See reference in Dalponte et al. 2016. A pixel is added to a region if its height is greater than the tree height multiplied by this value. It should be between 0 and 1.",
numericInput(session$ns("th_seed_input_param"), "th_seed", 0.45, min = 0))),
column(3, tooltip("Growing threshold 2. See reference in Dalponte et al. 2016. A pixel is added to a region if its height is greater than the current mean height of the region multiplied by this value. It should be between 0 and 1. Default 0.55.",
numericInput(session$ns("th_cr_input_param"), "th_cr", .55, min = 0))),
column(3, tooltip("Maximum value of the crown diameter of a detected tree (in pixels).",
numericInput(session$ns("max_cr_input_param"), "max_cr", 10, min = 0)))
)
fluidRow(
column(6, tooltip("Image of the canopy for each plot. You can compute it in Canopy Height Model section.",
selectInput(session$ns("chm_input_data"), "CHM", dataModel$getKeys(CHMData$classname)))),
column(6, tooltip("Object of class TreeTops containing the position of the trees. Can be computed in Tree Top Detection section.",
selectInput(session$ns("treetops_input_data"), "Tree Tops", dataModel$getKeys(TreeTopsData$classname)))),
column(3, tooltip("Threshold below which a pixel cannot be a tree.",
numericInput(session$ns("th_tree_input_param"), "th_tree", 2, min = 0))),
column(3, tooltip("Growing threshold 1. See reference in Dalponte et al. 2016. A pixel is added to a region if its height is greater than the tree height multiplied by this value. It should be between 0 and 1.",
numericInput(session$ns("th_seed_input_param"), "th_seed", 0.45, min = 0))),
column(3, tooltip("Growing threshold 2. See reference in Dalponte et al. 2016. A pixel is added to a region if its height is greater than the current mean height of the region multiplied by this value. It should be between 0 and 1. Default 0.55.",
numericInput(session$ns("th_cr_input_param"), "th_cr", .55, min = 0))),
column(3, tooltip("Maximum value of the crown diameter of a detected tree (in pixels).",
numericInput(session$ns("max_cr_input_param"), "max_cr", 10, min = 0)))
)
}
dalponte2016Process <- function(input) {
......@@ -159,39 +123,30 @@ dalponte2016Process <- function(input) {
# sapply(paste0(reqinput, "_input"), function(x){any(grepl(x, c(input_data_ID, input_param_ID)))})
#
if(packageVersion("lidR")<'1.4.0')
req(input$chm_input_data, input$winsize_input_param)
else
req(input$chm_input_data, input$treetops_input_data, input$th_tree_input_param, input$th_seed_input_param,
input$th_cr_input_param, input$max_cr_input_param)
req(input$chm_input_data, input$treetops_input_data, input$th_tree_input_param, input$th_seed_input_param,
input$th_cr_input_param, input$max_cr_input_param)
selectedCHM <- dataModel$getData(input$chm_input_data)$data
selectedLas <- dataModel$getData(input$laslist_input_data)$data
cl = parallel::makeCluster(parameters$cores, outfile = "")
if(packageVersion("lidR")<'1.4.0'){
plots.lastrees <- parallel::clusterMap(cl, lasdalponte2016, selectedLas, selectedCHM,
MoreArgs = list(algorithm = "dalponte2012",
searchWinSize = input$searchWinSize_input_parm ))
}else{
selectedTreeTops <- dataModel$getData(input$treetops_input_data)$data
if(any(sapply(selectedTreeTops,nrow)==0)){
selectedCHM = selectedCHM[sapply(selectedTreeTops,nrow)!=0]
selectedLas = selectedLas[sapply(selectedTreeTops,nrow)!=0]
selectedTreeTops = selectedTreeTops[sapply(selectedTreeTops,nrow)!=0]
}
selectedTreeTops <- dataModel$getData(input$treetops_input_data)$data
if(any(sapply(selectedTreeTops,nrow)==0)){
selectedCHM = selectedCHM[sapply(selectedTreeTops,nrow)!=0]
selectedLas = selectedLas[sapply(selectedTreeTops,nrow)!=0]
selectedTreeTops = selectedTreeTops[sapply(selectedTreeTops,nrow)!=0]
}
# seed ID is necessary for lastrees_dalponte in lidR version 1.6.*
selectedTreeTops = lapply(selectedTreeTops, function(x){x[, .(X, Y)][, seed_id:=sample.int(nrow(x))]})
# seed ID is necessary for lastrees_dalponte in lidR version 1.6.*
selectedTreeTops = lapply(selectedTreeTops, function(x){x[, .(X, Y)][, seed_id:=sample.int(nrow(x))]})
plots.lastrees <- parallel::clusterMap(cl, lasdalponte2016, las=selectedLas, chm=selectedCHM, treetops=selectedTreeTops,
MoreArgs = list( algorithm = "dalponte2016",
th_tree = input$th_tree_input_param,
th_seed = input$th_seed_input_param,
th_cr = input$th_cr_input_param,
max_cr = input$max_cr_input_param))
plots.lastrees <- parallel::clusterMap(cl, lasdalponte2016, las=selectedLas, chm=selectedCHM, treetops=selectedTreeTops,
MoreArgs = list( algorithm = "dalponte2016",
th_tree = input$th_tree_input_param,
th_seed = input$th_seed_input_param,
th_cr = input$th_cr_input_param,
max_cr = input$max_cr_input_param))
}
parallel::stopCluster(cl)
return(plots.lastrees)
}
......@@ -199,15 +154,7 @@ dalponte2016Process <- function(input) {
lasdalponte2016 <- function(las, ...){
# processing by reference --> needs to be copied for parallel proc
if(packageVersion("lidR")<'1.3.0')
las=lidR::LAS(las@data, las@header)
else if(packageVersion("lidR")<'1.5.0'){
lascrs = las@crs
las=lidR::LAS(las@data, las@header)
las@crs = lascrs
}else
las=lidR::LAS(las@data, las@header, las@crs)
las=lidR::LAS(las@data, las@header, las@crs)
lidR::lastrees(las, ...)
# th_tree = 2, th_seed = 0.45,
# th_cr = 0.55, max_cr = 10, extra = FALSE)
......@@ -228,33 +175,20 @@ li2012Method = function() {
li2012RenderUI <- function(session) {
if(packageVersion("lidR")<'1.4.0')
fluidRow(
column(3, tooltip("Threshold number 1. See reference page 79 in Li et al. (2012).",
numericInput(session$ns("dt1_input_param"), "dt1", 2, min = 0))),
column(3, tooltip("Threshold number 2. See reference page 79 in Li et al. (2012).",
numericInput(session$ns("dt2_input_param"), "dt2", 2.5, min = 0))),
column(3, tooltip("Maximum radius of a crown. Any value greater than a crown is good because this parameter does not affect the result. However, it greatly affects the computation speed. The lower the value, the faster the method.",
numericInput(session$ns("R_input_param"), "R", 2.5, min = 0)))
)
else
fluidRow(
column(3, tooltip("Threshold number 1. See reference page 79 in Li et al. (2012).",
numericInput(session$ns("dt1_input_param"), "dt1", 2, min = 0))),
column(3, tooltip("Threshold number 2. See reference page 79 in Li et al. (2012).",
numericInput(session$ns("dt2_input_param"), "dt2", 2.5, min = 0))),
column(3, tooltip("Minimum height of a detected tree.",
numericInput(session$ns("hmin_input_param"), "hmin", 2, min = 0))),
column(3, tooltip("Maximum radius of a crown. Any value greater than a crown is good because this parameter does not affect the result. However, it greatly affects the computation speed. The lower the value, the faster the method.",
numericInput(session$ns("R_input_param"), "R", 10, min = 0)))
)
fluidRow(
column(3, tooltip("Threshold number 1. See reference page 79 in Li et al. (2012).",
numericInput(session$ns("dt1_input_param"), "dt1", 2, min = 0))),
column(3, tooltip("Threshold number 2. See reference page 79 in Li et al. (2012).",
numericInput(session$ns("dt2_input_param"), "dt2", 2.5, min = 0))),
column(3, tooltip("Minimum height of a detected tree.",
numericInput(session$ns("hmin_input_param"), "hmin", 2, min = 0))),
column(3, tooltip("Maximum radius of a crown. Any value greater than a crown is good because this parameter does not affect the result. However, it greatly affects the computation speed. The lower the value, the faster the method.",
numericInput(session$ns("R_input_param"), "R", 10, min = 0)))
)
}
li2012Process <- function(input) {
if(packageVersion("lidR")<'1.4.0')
req(input$dt1_input_param, input$dt2_input_param, input$R_input_param)
else
req(input$dt1_input_param, input$dt2_input_param,
req(input$dt1_input_param, input$dt2_input_param,
input$hmin_input_param, input$R_input_param)
selectedLas <- dataModel$getData(input$laslist_input_data)$data
......@@ -273,14 +207,7 @@ li2012Process <- function(input) {
lasli2012 <- function(las, ...){
# processing by reference --> needs to be copied for parallel proc
if(packageVersion("lidR")<'1.3.0')
las=LAS(las@data, las@header)
else if(packageVersion("lidR")<'1.5.0'){
lascrs = las@crs
las=LAS(las@data, las@header)
las@crs = lascrs
}else
las=LAS(las@data, las@header, las@crs)
las=LAS(las@data, las@header, las@crs)
# check if any above hmin
if("hmin" %in% names(list(...)) &&
......
R/transform_dtm_methods.R
View file @ 1bffcd63
......@@ -54,10 +54,7 @@ rasterProcess <- function(input) {
selectedDTM <- dataModel$getData(input$dtm_input_data)$data
selectedLas <- dataModel$getData(input$laslist_input_data)$data
cl = parallel::makeCluster(parameters$cores, outfile = "")
if(packageVersion("lidR") >= '1.3.0')
plots.lasn <- parallel::parLapply(cl, selectedLas, lidR::lasnormalize, dtm = selectedDTM, copy = TRUE)
else
plots.lasn <- parallel::parLapply(cl, selectedLas, lidR::lasnormalize, dtm = selectedDTM)
plots.lasn <- parallel::parLapply(cl, selectedLas, lidR::lasnormalize, dtm = selectedDTM, copy = TRUE)
parallel::stopCluster(cl)
return(plots.lasn)
}
......@@ -81,18 +78,14 @@ knnidwProcess <- function(input) {
req(input$k_input_param)
cl = parallel::makeCluster(parameters$cores, outfile = "")
selectedLas <- dataModel$getData(input$laslist_input_data)$data
if(packageVersion("lidR") >= '1.3.0'){
plots.lasn <- parallel::parLapply(cl,
selectedLas, lidR::lasnormalize, method = "knnidw",
k = input$k_input_param,
copy = TRUE)
for(i in 1:length(plots.lasn))
plots.lasn[[i]]@crs <- selectedLas[[i]]@crs
}
else
plots.lasn <- parallel::parLapply(cl,
selectedLas, lidR::lasnormalize, method = "knnidw",
k = input$k_input_param)
plots.lasn <- parallel::parLapply(cl,
selectedLas, lidR::lasnormalize, method = "knnidw",
k = input$k_input_param,
copy = TRUE)
#TODO: check if CRS heritage is now good for lasnormalize
for(i in 1:length(plots.lasn))
plots.lasn[[i]]@crs <- selectedLas[[i]]@crs
parallel::stopCluster(cl)
return(plots.lasn)
}
......@@ -115,18 +108,13 @@ krigingProcess <- function(input) {
req(input$k_input_param)
cl = parallel::makeCluster(parameters$cores, outfile = "")
selectedLas <- dataModel$getData(input$laslist_input_data)$data
if(packageVersion("lidR") >= '1.3.0'){
plots.lasn <- parallel::parLapply(cl, selectedLas, lidR::lasnormalize,
plots.lasn <- parallel::parLapply(cl, selectedLas, lidR::lasnormalize,
method = "kriging",
k = input$k_input_param,
copy = TRUE)
for(i in 1:length(plots.lasn))
plots.lasn[[i]]@crs <- selectedLas[[i]]@crs
}
else
plots.lasn <- parallel::parLapply(cl, selectedLas, lidR::lasnormalize,
method = "kriging",
k = input$k_input_param)
#TODO: check if CRS heritage is now good for lasnormalize
for(i in 1:length(plots.lasn))
plots.lasn[[i]]@crs <- selectedLas[[i]]@crs
parallel::stopCluster(cl)
return(plots.lasn)
......@@ -149,15 +137,12 @@ delaunayRenderUI <- function(session) {
delaunayProcess <- function(input) {
cl = parallel::makeCluster(parameters$cores, outfile = "")
selectedLas <- dataModel$getData(input$laslist_input_data)$data
if(packageVersion("lidR") >= '1.3.0'){
plots.lasn <- parallel::parLapply(cl, selectedLas, lidR::lasnormalize,
method = "delaunay", copy = TRUE)
for(i in 1:length(plots.lasn))
plots.lasn[[i]]@crs <- selectedLas[[i]]@crs
}
else
plots.lasn <- parallel::parLapply(cl, selectedLas, lidR::lasnormalize,
plots.lasn <- parallel::parLapply(cl, selectedLas, lidR::lasnormalize,
method = "delaunay", copy = TRUE)
#TODO: check if CRS heritage is now good for lasnormalize
for(i in 1:length(plots.lasn))
plots.lasn[[i]]@crs <- selectedLas[[i]]@crs
parallel::stopCluster(cl)
return(plots.lasn)
}
......
R/transform_extractPlots.R
View file @ 1bffcd63
......@@ -161,41 +161,16 @@ extract_plots <- function(input, output, session) {
buffer <- input$buffer_input_param
# extract plots
if(packageVersion("lidR") < '1.3.0'){
extracted_plots <- lidR::catalog_queries(
catalog_las,
x = plots@coords[,1],
y = plots@coords[,2],
r = r,
r2 = r2,
roinames = plots[[id_name]],
mc.cores = parameters$cores
)
}else{
extracted_plots <- lidR::catalog_queries(
catalog_las,
x = plots@coords[,1],
y = plots@coords[,2],
r = r,
r2 = r2,
buffer = buffer,
roinames = plots[[id_name]],
select = "*+"
)
### when add buffer to extrabytes, error: "Error: Type uchar not supported."
### tested with short, int, double with no success... The problem seem to come from rlas
# if(packageVersion("lidR") >= '1.5.0'){
# for(i in 1:length(extracted_plots))
# lidR::lasaddextrabytes_manual(extracted_plots[[i]], name = "buffer", desc = "buffer", type="uchar")
# }
# CRS inheritage only starting at lidR 1.6.0
if(packageVersion("lidR") < '1.6.0'){
for(i in 1:length(extracted_plots))
extracted_plots[[i]]@crs <- catalog_las@crs
}
}
extracted_plots <- lidR::catalog_queries(
catalog_las,
x = plots@coords[,1],
y = plots@coords[,2],
r = r,
r2 = r2,
buffer = buffer,
roinames = plots[[id_name]],
select = "*+"
)
null_lasplots = sapply(extracted_plots,is.null)
if(any(null_lasplots)){
......
Markdown is supported
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