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

Merge branch 'master' of https://gitlab.irstea.fr/jean-matthieu.monnet/lidaRtRee into devel

Add master updates to devel branch
No related merge requests found
Showing with 62 additions and 1891 deletions
+62 -1891
^.*\.Rproj$
^\.Rproj\.user$
.Rproj.user .Rproj.user
.Rhistory .Rhistory
.RData .RData
.Rbuildignore
.Ruserdata .Ruserdata
lidaRtRee.Rproj
lidaRtRee.Rcheck/
lidaRtRee_*
*~
..Rcheck/
\ No newline at end of file
...@@ -233,7 +233,7 @@ speciesColor <- function() ...@@ -233,7 +233,7 @@ speciesColor <- function()
c("Pinus mugo","salmon2", "C"), c("Pinus mugo","salmon2", "C"),
c("Pinus nigra","salmon1", "C"), c("Pinus nigra","salmon1", "C"),
c("Pinus sp.","salmon1", "C"), c("Pinus sp.","salmon1", "C"),
c("Pinus uncinata","salmon1", "C"), c("Pinus uncinata","salmon4", "C"),
c("Pinus sylvestris","salmon", "C"), c("Pinus sylvestris","salmon", "C"),
c("Populus alba","slateblue", "B"), c("Populus alba","slateblue", "B"),
c("Populus nigra","slateblue", "B"), c("Populus nigra","slateblue", "B"),
......
...@@ -375,7 +375,7 @@ coregistration <- function(chm, trees, mask= NULL, buffer=19, step=0.5, dm=2, pl ...@@ -375,7 +375,7 @@ coregistration <- function(chm, trees, mask= NULL, buffer=19, step=0.5, dm=2, pl
# display initial tree positions # display initial tree positions
graphics::points(trees[,1], trees[,2], cex=trees[,3]/40) graphics::points(trees[,1], trees[,2], cex=trees[,3]/40)
# display coregistered tree positions # display coregistered tree positions
graphics::points(trees[,1]+resul$dx1, trees[,2]+resul$dy1, cex=trees[,3]/20, col="red") graphics::points(trees[,1]+resul$dx1, trees[,2]+resul$dy1, cex=trees[,3]/40, col="red")
graphics::legend("topleft", c("Initial", "Coregistered"), pch=1, col=c("black", "red")) graphics::legend("topleft", c("Initial", "Coregistered"), pch=1, col=c("black", "red"))
} }
list(correlation.raster=r.correlation, local.max=resul) list(correlation.raster=r.correlation, local.max=resul)
......
#' # package lidaRtRee
#' # Copyright Irstea
#' # Author(s): Jean-Matthieu Monnet
#' # Licence: LGPL-3
#' ###################### FUNCTIONS FOR TREE-LEVEL METRICS COMPUTATION #################
#' #
#' ##############################
#' #' segment-wise computation of point metrics
#' #'
#' #' @param p A dataframe with point attributes, including the segment ID field
#' #' @param columnId A string: name of the field containing the segment ID
#' #' @param FUN Function to compute for each segment ID. Default: number of points
#' #' @return A vector of values obtainted by applying the function to the point cloud in each segment
#' #' @export
#' computeMetric <- function(p,columnId,FUN=nrow)
#' {
#' by(p,as.factor(p[,columnId]),FUN)
#' }
#' ##############################
#' #' replace values in a raster based on segment ID and tree attributes
#' #'
#' #' @param r.dem.w a raster with segment ID, integers starting from 0 to max(r.dem.w)
#' #' @param segms A dataframe with tree attributes
#' #' @param attr the attribute to use for rast
#' #' @return a raster
#' #' @export
#' rasterValueFromSegment <- function(r.dem.w, segms, attr)
#' {
#' dummy <- r.dem.w
#' # creer le tableau de correspondance id / attribut
#' # tableau avec autant de lignes que de segments 'max + 1' en comptant le 0
#' fh <- matrix(nrow=max(raster::values(r.dem.w))+1,ncol=1)
#' # mettre la hauteur correspondant aux id
#' fh[segms$id+1] <- segms[,attr]
#' # convertir id en h dans segmentation
#' raster::values(dummy) <- as.vector(fh[raster::values(dummy)+1])
#' dummy
#' }
#' ###############################
#' #' add trunk altitude information
#' #'
#' #' @param segms a data.frame of segment id
#' #' @param dtm a raster with terrain altitude
#' #' @param p a point cloud data.frame
#' #' @return a list with two elements: the segments with additional attribute (terrain altitude in the cell below the maximum) and the point cloud with additional attribute (point height relatively to terrain altitude below maximum)
#' #' @export
#' pointHeightAboveTrunk <- function(segms, dtm, p)
#' {
#' # extract terrain altitude
#' segms$alt.dtm <- pointsInSegments(segms[,c("x","y")],dtm)
#' dummy <- merge(p,segms[,c("id","alt.dtm")],by.x="seg.id",by.y="id",all.x=T)
#' dummy$h.trunk <- dummy$z-dummy$alt.dtm
#' list(segms,dummy)
#' }
\ No newline at end of file
Package: lidaRtRee
Version: 1.0
Title: Forest Analysis with Airborne Laser Scanning (Lidar) Data
Date: 2018-04-27
Author: Jean-Matthieu Monnet [aut, cre]
Maintainer: Jean-Matthieu Monnet <jean-matthieu.monnet@irstea.fr>
Description: Provides functions for forest analysis using airborne laser scanning data. It includes complementary steps for foret mapping: extraction of both physical and statistical features from lidar data, model calibration with ground reference, and maps export.
URL: https://gitlab.irstea.fr/jean-matthieu.monnet/lidaRtRee
Imports: graphics, stats, grDevices, sp, raster, imager, akima, leaps,
gvlma, car, foreach, doParallel, reldist, lidR (>= 1.4-2)
License: LGPL-3
LazyData: TRUE
RoxygenNote: 6.0.1
NeedsCompilation: no
Packaged: 2018-04-27 11:56:04 UTC; jean-matthieu
Depends: R (>= 2.10)
# Generated by roxygen2: do not edit by hand
export(circle2Raster)
export(coregistration)
export(createDisk)
export(demFiltering)
export(heightRegression)
export(histDetection)
export(histStack)
export(maximaDetection)
export(maximaSelection)
export(plot2Dmatched)
export(plotTreeInventory)
export(points2DSM)
export(points2DTM)
export(polar2Projected)
export(rasterChullMask)
export(rasterLocalmax)
export(rasterXYMask)
export(rasters2Cor)
export(rastersMovingCor)
export(segAdjust)
export(segmentation)
export(speciesColor)
export(treeExtraction)
export(treeMatching)
export(treeSegmentation)
#' @name chmchablais3
#'
#' @title Canopy height model (Chablais 3 plot)
#'
#' @description Canopy height model computed from airborne laser scanning data acquired in July 2010.
#'
#' @docType data
#'
#' @usage data(chmchablais3)
#'
#' @format A raster object
#'
#' @keywords datasets
#'
#' @references Monnet, J.-M. 2011. Using airborne laser scanning for mountain forests mapping: Support vector regression for stand parameters estimation and unsupervised training for treetop detection. Ph.D. thesis. University of Grenoble, France. pp. 21-22 & 34 \url{https://tel.archives-ouvertes.fr/tel-00652698/document}
#'
#' @examples
#' data(chmchablais3)
#' chmchablais3
#' \dontrun{
#' raster::plot(chmchablais3)}
NULL
"chmchablais3"
# package lidaRtRee
# Copyright Irstea
# Author(s): Jean-Matthieu Monnet
# Licence: LGPL-3
################################
#' Digital Surface Model
#'
#' Creates a Digital Surface Model from LAS object. Raster extent is specified by the coordinates of lower left and upper right corners. Default extent covers the full range of points, and aligns on multiple values of the resolution. Cell value is the maximum height of points contained in the cell.
#'
#' @param .las LAS object (e.g. from \code{\link[lidR]{LAS}} function)
#' @param res numeric. raster resolution
#' @param xmin numeric. lower left corner easting coordinate for output raster.
#' @param xmax numeric. upper right corner easting coordinate for output raster.
#' @param ymin numeric. lower left corner northing coordinate for output raster.
#' @param ymax numeric. upper right corner northing coordinate for output raster.
#' @return A raster object.
#' @seealso \code{\link{points2DTM}} for Digital Terrain Model computation.
#' @examples
#' data(laschablais3)
#'
#' # create digital surface model with first-return points, resolution 0.5 m
#' dsm <- points2DSM(lidR::lasfilterfirst(laschablais3), res=0.5)
#'
#' \dontrun{
#' # display raster
#' raster::plot(dsm,asp=1)}
#' @export
points2DSM <- function(.las, res=1, xmin, xmax, ymin, ymax)
{
#
if (missing(xmin) | missing(xmax) | missing(ymin) | missing(ymax)) # if no extent info
{
xmin <- floor(min(.las@data$X)/res)*res
xmax <- ceiling(max(.las@data$X)/res)*res
ymin <- floor(min(.las@data$Y)/res)*res
ymax <- ceiling(max(.las@data$Y)/res)*res
}
# create empty raster
r <- raster::raster()
raster::extent(r) <- c(xmin,xmax,ymin,ymax)
raster::res(r) <- res
raster::crs(r) <- NA
# convert LAS coordinates to spatial data
points <- as.data.frame(.las@data[,1:2])
val <- .las@data[,3]
sp::coordinates(points)=c(1,2)
# rasterize with max function
raster::rasterize(points,r,val,fun=max)
}
###################################
#' Digital Terrain Model
#'
#' Creates a Digital Terrain Model from LAS object. Raster extent is specified by the coordinates of lower left and upper right corners. Default extent covers the full range of points, and aligns on multiple values of the resolution. Cell value is compute as the Delaunay interpolation at the cell center. Relies on the \code{\link[akima]{interp}} function, which is slow, while waiting for new release of \code{\link[lidR]{grid_terrain}} which will integrate an additional argument to specify the output extent.
#'
#' @param .las LAS object (e.g. from \code{\link[lidR]{LAS}} function) containing only ground points
#' @param res numeric. raster resolution
#' @param xmin numeric. lower left corner easting coordinate for output raster.
#' @param xmax numeric. upper right corner easting coordinate for output raster.
#' @param ymin numeric. lower left corner northing coordinate for output raster.
#' @param ymax numeric. upper right corner northing coordinate for output raster.
#' @seealso \code{\link{points2DSM}} for Digital Surface Model computation.
#' @return A raster object
#' @examples
#' data(laschablais3)
#'
#' # create digital terrain model with points classified as ground
#' dtm <- points2DTM(lidR::lasfilter(laschablais3, Classification==2))
#'
#' \dontrun{
#' # display raster
#' raster::plot(dtm,asp=1)}
#' @export
points2DTM = function(.las, res = 1, xmin, xmax, ymin, ymax)
{
if (missing(xmin) | missing(xmax) | missing(ymin) | missing(ymax)) # if no extent info
{
xmin <- floor(min(.las@data$X)/res)*res
xmax <- ceiling(max(.las@data$X)/res)*res
ymin <- floor(min(.las@data$Y)/res)*res
ymax <- ceiling(max(.las@data$Y)/res)*res
}
points <- as.matrix(.las@data[,c("X","Y","Z")])
# interpolation: value estimated at pixel center by bilinear interpolation
mnt <- akima::interp(points[,1],points[,2],points[,3], xo=seq(xmin+res/2, xmax-res/2,by=res), yo=seq(ymax-res/2,ymin+res/2,by=-res),linear=TRUE,extrap=FALSE, duplicate="user", dupfun=function(x){min(x)})
#
dtm = raster::raster(t(mnt[[3]]), xmn = xmin, xmx = xmax, ymn = ymin, ymx = ymax)
return(dtm)
}
# ################################
# #' creates Digital Elevation Model from LAS object and extent info (parallelised version)
# #' tiles extent and calls points2DTM or points2DSM
# #'
# #' @param .las LAS object (from \code{lidR} package)
# #' @param type model to return ("dsm" or "dtm")
# #' @param res the raster resolution
# #' @param xmin the raster lower left corner easting coordinate
# #' @param xmax the raster upper right corner easting coordinate
# #' @param ymin the raster lower left corner northing coordinate
# #' @param ymax the raster upper right corner northing coordinate
# #' @param method a string specifying the interpolation method
# #' @param buffer the size of buffer area for tiling
# #' @param tile.size the size of tiles for parallelisation
# #' @param n.cores the number of cores to use
# #' @return a raster object
# #' @export
# points2DEM = function(.las, type="dtm", res = 1, xmin, xmax, ymin, ymax, method="delaunay", buffer=5, tile.size=250, n.cores=4)
# {
# doParallel::registerDoParallel(cores=n.cores)
# if (missing(xmin) | missing(xmax) | missing(ymin) | missing(ymax)) # if no extent info
# {
# xmin <- floor(min(.las@data$X)/res)*res
# xmax <- ceiling(max(.las@data$X)/res)*res
# ymin <- floor(min(.las@data$Y)/res)*res
# ymax <- ceiling(max(.las@data$Y)/res)*res
# }
# # low left corner
# xlow <- floor(xmin/tile.size)*tile.size
# ylow <- floor(ymin/tile.size)*tile.size
# # tiles indices which intersect the extent
# i <- 0
# j <- 0
# n <- 1
# l <- list()
# while(xlow+i*tile.size<xmax)
# {
# while(ylow + j * tile.size < ymax)
# {
# l[[n]] <- c(i,j)
# n <- n+1
# j <- j+1
# }
# i <- i+1
# j <- 0
# }
# l <- foreach::foreach(i=1:length(l), .errorhandling="remove") %dopar%
# {
# coord <- c(max(xmin, xlow+l[[i]][1]*tile.size), min(xmax, xlow+(l[[i]][1]+1)*tile.size), max(ymin, ylow+l[[i]][2]*tile.size), min(ymax, ylow+(l[[i]][2]+1)*tile.size))
# dummy <- .las %>% lidR::lasfilter(X >= coord[1]-buffer & X <= coord[2]+buffer & Y >= coord[3]-buffer & Y <= coord[4]+buffer)
# if (type=="dtm") {return(points2DTM(dummy, res = res, coord[1], coord[2], coord[3], coord[4], method=method))}
# else {return(points2DSM(dummy, res = res, coord[1], coord[2], coord[3], coord[4]))}
# }
# l$fun <- mean
# l$na.rm <- TRUE
# do.call(raster::mosaic, l)
# }
################################
#' Polar to cartesian coordinates conversion
#'
#' Computes projected coordinates (Easting, Northing, Altitude) from polar coordinates (Azimuth, Slope, Distance) and center position (Easting, Northing, Altitude). Magnetic declination and meridian convergence are optional parameters. In case distance is measured to the border of objects (e.g. trees), the diameter can be added to compute the coordinates of object center.
#'
#' @param x vector. easting coordinates of centers in meter
#' @param y vector. northing coordinates of centers in meter
#' @param z vector. altitudes of centers in meters
#' @param declination vector. magnetic declination values in radian
#' @param convergence vector. meridian convergence values in radian
#' @param azimuth vector. azimuth values from centers in radian
#' @param slope vector. slope values from centers in radian
#' @param dist vector. distances between centers and objects in meter
#' @param diameter vector. diameters in meter (e.g. in case a radius should be added to the distance)
#' @seealso \code{\link{plotTreeInventory}} for tree inventory display
#' @return A data.frame with easting, northing and altitude coordinates, and horizontal distance from centers to objects centers
#' @examples
#' # create data.frame of trees with polar coordinates and diameters
#' trees <- data.frame (x=rep(c(0,10), each=2),
#' y = rep(c(0,10),each=2),
#' z=rep(c(0,2),each=2),
#' azimuth=rep(c(0,pi/3)),
#' dist=rep(c(2,4)),
#' slope=rep(c(0,pi/6)),
#' diameter.cm=c(15,20,25,30))
#' trees
#'
#' # compute projected coordinates
#' polar2Projected(trees$x, trees$y, trees$z, trees$azimuth, trees$dist,
#' trees$slope, declination=0.03, convergence=0.02, trees$diameter.cm/200)
#' @export
polar2Projected <- function(x, y, z=0, azimuth, dist, slope=0, declination=0, convergence=0, diameter=0)
{
d <- dist*cos(slope)+diameter/2
data.frame(x = x + d*sin(azimuth+convergence+declination),
y = y + d*cos(azimuth+convergence+declination),
z = z + (dist*sin(slope)+diameter/2),
d)
}
###############################
#' Table of species names, abreviations and display colors
#'
#' table for species names, abreviations and type (coniferous/broadleaf), and display color
#' @return A data frame with species name, color, coniferous (C) / broadleaf (B) type, and name abreviation GESP of GEnus and SPecies
#' @seealso \code{\link{plotTreeInventory}} for tree inventory display
#' @examples
#' # load table
#' tab.species <- speciesColor()
#' head(tab.species)
#' summary(tab.species)
#' @export
speciesColor <- function()
{
d <- rbind(c("Abies alba","purple", "C"),
c("Acer","orange", "B"),
c("Acer campestre","orange1", "B"),
c("Acer opalus","orange2", "B"),
c("Acer platanoides","orange3", "B"),
c("Acer pseudoplatanus","orange4", "B"),
c("Acer sp.","orange", "B"),
c("Alnus incana","violet", "B"),
c("Alnus viridis","violet", "B"),
c("Betula pendula","darkgreen", "B"),
c("Betula pubescens","darkgreen", "B"),
c("Betula sp.","darkgreen", "B"),
c("Buxus sempervirens","black", "B"),
c("Carpinus betulus","seagreen", "B"),
c("Castanea sativa","pink", "B"),
c("Corylus avellana","cadetblue2", "B"),
c("Cornus mas","black", "B"),
c("Cotinus sp.","black", "B"),
c("Crataegus sp.","black", "B"),
c("Crataegus monogyna","black", "B"),
c("Euonymus latifolius","black", "B"),
c("Fagus sylvatica","green", "B"),
c("feuillus","black", "B"),
c("Fraxinus excelsior","yellow", "B"),
c("Ilex aquifolium","cyan", "B"),
c("inconnu","black", NA),
c("Juniperus communis","black", "C"),
c("Juniperus sp.","black", "C"),
c("Laburnum anagyroides","black", "B"),
c("Larix decidua","pink", "C"),
c("Larix kaempferi","pink", "C"),
c("Malus sylvestris","plum", "B"),
c("Picea abies","blue", "C"),
c("Pinus cembro","salmon3", "C"),
c("Pinus mugo","salmon2", "C"),
c("Pinus nigra","salmon1", "C"),
c("Pinus sp.","salmon1", "C"),
c("Pinus sylvestris","salmon", "C"),
c("Populus alba","slateblue", "B"),
c("Populus nigra","slateblue", "B"),
c("Populus tremula","slateblue", "B"),
c("Pseudotsuga menziesii","darkblue", "C"),
c("Prunus avium","grey", "B"),
c("Prunus sp.","grey", "B"),
c("Pyrus communis","grey", "B"),
c("Quercus petraea","turquoise", "B"),
c("Quercus pubescens","turquoise", "B"),
c("Quercus robur","turquoise", "B"),
c("Salix caprea","darkgoldenrod2", "B"),
c("Salix sp.","darkgoldenrod2", "B"),
c("Salix nigra","darkgoldenrod2", "B"),
c("Sorbus aria","red3", "B"),
c("Sorbus aucuparia","red", "B"),
c("Taxus baccata","burlywood3", "C"),
c("Tilia cordata","chocolate4", "B"),
c("Tilia platyphyllos","chocolate4", "B"),
c("Tilia sp.","chocolate4", "B"),
c("Ulmus glabra","brown", "B"),
c("Ulmus sp.","brown", "B"),
c("Viburnum lantana","black", "B"))
d <- as.data.frame(d,stringsAsFactors = F)
names(d) <- c("name","col","broad.conif")
d$broad.conif <- factor(d$broad.conif)
# abreviation GEsp (GEnus species)
dummy <- strsplit(d$name," ")
dummy2 <- lapply(dummy, function(x){
ifelse(length(x)==2 && x[2]=="sp.",
paste(toupper(substr(x[1],1,2)),"sp",sep=""),
paste(toupper(substr(x,1,2)),collapse=""))})
d$abvr <- row.names(d) <- unlist(dummy2)
d
}
#######################################
#' Displays a map of tree inventory data
#'
#' displays tree inventory data
#'
#' @param xy data.frame. contains two columns with the X, Y coordinates of tree centers
#' @param height vector. tree heights in meters
#' @param diam vector. tree diameters in centimeters
#' @param species vector. species abreviation as in \code{\link{speciesColor}} for display with corresponding color.
#' @param add boolean. indicates whether points should be added to an existing plot
#' @seealso \code{\link{speciesColor}} for a table of species and associated colors
#' @examples
#' # load tree inventory data from plot Chablais 3
#' data("treeinventorychablais3")
#'
#' \dontrun{
#' # display tree inventory
#' plotTreeInventory(treeinventorychablais3[,c("x","y")],
#' treeinventorychablais3$h,
#' species=as.character(treeinventorychablais3$s))}
#' @return no return
#' @export
#'
plotTreeInventory <-function(xy, height=NULL, diam=NULL, species=NULL, add=FALSE)
{
# set size of symbol
# proportionnal to height if present
if(!is.null(height))
{
size <- height/20
# otherwise proportionnal to diameter
} else {
if (!is.null(diam/40))
{
size <- diam/20
} else { size <- 1}
}
# apply species-specific colors
if (!is.null(species))
{
# load palette
color <- speciesColor()
# extract corresponding colors
col1 <- color[as.character(species), c("col","abvr")]
} else { col1 <- data.frame(col="black")}
if (add==FALSE)
{
#grDevices::dev.new(height=2.5,width=2.5)
graphics::par(mar=c(2.5,2.5,0.5,0.5))
graphics::plot(xy[,1],xy[,2],cex=size,col=col1$col,xlab="NA",ylab="NA",yaxt="n",xaxt="n",asp=1)
graphics::axis(2,mgp=c(0.5,0.5,0))
graphics::axis(1,mgp=c(0.5,0.5,0))
graphics::mtext(side=2,text="Easting (m)",line=1.3)
graphics:: mtext(side=1,text="Northing (m)",line=1.3)
} else {
graphics::points(xy[,1],xy[,2],cex=size,col=col1$col)
}
# add color legend
if (!is.null(species))
{
texte <- sort(unique(col1$abvr))
graphics::legend("topleft", texte, col=color[texte,"col"],pch=15,cex=1,y.intersp = 1)
}
}
##################################
#' Raster mask by union of buffers around xy positions
#'
#' creates a raster mask by union of circular buffers around xy positions
#'
#' @param xy 2 columns matrix or data.frame. xy positions
#' @param buff vector. buffers to apply to the xy positions
#' @param r raster object. target raster
#' @param binary boolean. should the output mask be boolean (TRUE) or greyscale (FALSE)
#' @return a raster object
#' @seealso \code{\link{rasterChullMask}}
#' @examples
#' # create raster
#' r <- raster::raster()
#' raster::extent(r) <- c(0,40,0,40)
#' raster::res(r) <- 1
#'
#' # xy positions
#' xy <- data.frame(c(10,20,31.25,15),
#' c(10,20,31.25,25))
#' # compute mask
#' mask1 <- rasterXYMask(xy, c(5, 8, 5, 5), r)
#' mask2 <- rasterXYMask(xy, c(5, 8, 5, 5), r, binary=FALSE)
#'
#' \dontrun{
#' # display binary raster
#' raster::plot(mask1)
#' graphics::points(xy)
#'
#' # display distance raster
#' raster::plot(mask2)
#' graphics::points(xy)}
#' @export
rasterXYMask <- function(xy, buff, r, binary=TRUE)
{
# compute squared buffers
buff2 <- buff^2
# compute XY coordinates of cell centers
dummyXY <- raster::xyFromCell(r,1:length(r))
# create matrix of cell values
val <- matrix(NA,nrow=length(r), ncol=nrow(xy))
# compute cell value for each position
for (i in 1:nrow(xy))
{
val[,i] <- sqrt(pmax(0,buff2[i] - ((dummyXY[,1]-xy[i,1])^2 + (dummyXY[,2]-xy[i,2])^2)))
}
# take maximum for each cell
val <- apply(val,1,max)
# convert to binary if required
if (binary) {val <- val >0}
raster::values(r) <- val
r
}
####################################
#' Raster mask of convex hull
#'
#' creates raster mask corresponding to the convex hull of xy positions
#'
#' @param xy 2 columns matrix or data.frame. xy positions
#' @param r raster object. target raster
#' @return a raster with 0 or 1
#' @examples
#' # create raster
#' r <- raster::raster()
#' raster::extent(r) <- c(0,40,0,40)
#' raster::res(r) <- 1
#'
#' # xy positions
#' xy <- data.frame(c(10,20,31.25,15),
#' c(10,20,31.25,25))
#' # compute mask
#' mask1 <- rasterChullMask(xy, r)
#'
#' \dontrun{
#' # display binary raster
#' raster::plot(mask1)
#' graphics::points(xy)}
#' @seealso \code{\link{rasterXYMask}}
#' @export
rasterChullMask <- function(xy, r)
{
# points on convexHull
idchull <- grDevices::chull(xy)
#
# create chull polygon
Po <- sp::Polygons(list(sp::Polygon(xy[c(idchull,idchull[1]),])),1)
sPo <- sp::SpatialPolygons(list(Po),proj4string=r@crs)
# rasterize polygon
dummy <- raster::rasterize(sPo,r)
dummy[is.na(dummy)] <- 0
dummy
}
# package lidaRtRee
# Copyright Irstea
# Author(s): Jean-Matthieu Monnet
# Licence: LGPL-3
########################### FUNCTIONS FOR COREGISTRATION #############################
#
######################################
#' Raster corresponding to circle extent
#'
#' Creates an empty raster which extents corresponds to the circle specified by center coordinates, radius and optional buffer size.
#'
#' @param X numeric. easting coordinate of plot center in meters
#' @param Y numeric. northing coordinate of plot center in meters
#' @param radius numeric. plot radius in meters
#' @param resolution numeric. raster resolution in meters
#' @param buffer numeric. buffer to be added to plot radius in meters
#' @return A raster object
#' @examples
#' circle2Raster(100, 100, 20, 1, 5)
#' @export
circle2Raster <- function(X, Y, radius, resolution=0.5, buffer=0.5)
{
r <- raster::raster()
r@extent@xmin <- floor((X-radius-buffer)/resolution)*resolution
r@extent@ymin <- floor((Y-radius-buffer)/resolution)*resolution
r@extent@xmax <- ceiling((X+radius+buffer)/resolution)*resolution
r@extent@ymax <- ceiling((Y+radius+buffer)/resolution)*resolution
raster::res(r) <- resolution
raster::crs(r) <- NA
r
}
######################################
#' Correlation between two rasters
#'
#' computes correlation between two rasters, based on the extent of the smallest one.
#'
#' @param raster.b raster. raster to correlate with largest extent
#' @param raster.s raster. raster to correlate with smallest extent
#' @param mask raster. mask of area to correlate
#' @param small.SC boolean. is the small raster already standardized and centered ?
#' @seealso \code{\link{rastersMovingCor}} to compute correlation between rasters for different translations
#' @return A numeric
#' @examples
#' # create raster
#' r.b <- raster::raster()
#' raster::extent(r.b) <- c(0,40,0,40)
#' raster::res(r.b) <- 1
#' xy <- raster::xyFromCell(r.b,1:length(r.b))
#'
#' # add Gaussian surface and noise
#' z <- 3*exp(-((xy[,1]-20)^2+(xy[,2]-20)^2/2)/6)
#' r.b <- raster::rasterFromXYZ(cbind(xy,z))
#'
#' # create circular mask of radius 5
#' z.mask <- (xy[,1]-20)^2 + (xy[,2]-20)^2 < 5^2
#' r.mask <- raster::rasterFromXYZ(cbind(xy, z.mask))
#'
#' # create small raster of size 20
#' r.s <- raster::crop(r.b, raster::extent(c(10,30,10,30)))
#'
#' # add noise to small raster
#' raster::values(r.s) <- raster::values(r.s) + rnorm(length(r.s),0,0.5)
#' r.mask <- raster::crop(r.mask, raster::extent(c(10,30,10,30)))
#'
#' # compute correlation on masked area where signal to noise ratio is lower
#' rasters2Cor(r.b, r.s, r.mask, small.SC=FALSE)
#'
#' # compute correlation for whole small raster
#' rasters2Cor(r.b, r.s, small.SC=FALSE)
#'
#' \dontrun{
#' # display large raster
#' raster::plot(r.b, main="Large raster")
#' # display small raster
#' raster::plot(r.s, main="Small raster")
#' # display mask
#' raster::plot(r.mask, main="Computation mask")}
#' @export
rasters2Cor <- function(raster.b, raster.s, mask=NULL, small.SC=TRUE)
{
# crop large raster to smaller size
raster.b <- raster::crop(raster.b,raster.s)
# apply raster mask if existing
if (!is.null(mask))
{
# apply raster mask to small raster if not already centered / standardized
if (small.SC==F) {raster.s <- raster.s*mask}
raster.b <- raster.b*mask
}
# center small raster if not already done
if (small.SC==F)
{
# compute standard deviation
sd.raster.s <- stats::sd(raster::values(raster.s),na.rm=TRUE)
# compute mean
m.raster.s <- mean(raster::values(raster.s),na.rm=TRUE)
# center values of small raster
raster.s <- raster.s - m.raster.s
} else {sd.raster.s <- 1}
# compute standard deviation of large raster
sd.raster.b <- stats::sd(raster::values(raster.b),na.rm=TRUE)
# compute mean of large raster
m.raster.b <- mean(raster::values(raster.b),na.rm=TRUE)
# center large raster
raster.b <- raster.b-m.raster.b
#
# compute correlation value
mean(raster::values(raster.b*raster.s),na.rm=TRUE)/(sd.raster.s*sd.raster.b)
}
#
######################################
#' Correlation between rasters for different XY translations
#'
#' computes correlation between two rasters for different XY translations. The correlation values are computed on the extent of the smallest raster using \code{\link{rasters2Cor}}, after applying an optional mask, and for each translation within a buffer area.
#'
#' @param raster.b raster. raster to correlate with largest extent
#' @param raster.s raster. raster to correlate with smallest extent
#' @param mask raster. mask of area to correlate, applied to small raster
#' @param buffer numeric. radius of the circular buffer area for possible translations
#' @param pas numeric. increment step of translations within buffer area to compute correlation values, should be a multiple of raster resolution
#' @seealso \code{\link{rasterLocalmax}} to extract local maximum of resulting correlation raster, \code{\link{rasters2Cor}}
#' @return A raster. Raster value at coordinates x,y correspond to the correlation between the large raster and the small raster when small raster center has been translated of (x,y)
#' @examples
#' # create raster
#' r.b <- raster::raster()
#' raster::extent(r.b) <- c(0,40,0,40)
#' raster::res(r.b) <- 1
#' xy <- raster::xyFromCell(r.b,1:length(r.b))
#'
#' # add Gaussian surfaces
#' z1 <- 1.5*exp(-((xy[,1]-22)^2+(xy[,2]-22)^2/2)/5)
#' z2 <- exp(-((xy[,1]-20)^2+(xy[,2]-22)^2/2)/3)
#' z3 <- 1.5*exp(-((xy[,1]-17)^2+(xy[,2]-17)^2/2)/5)
#' r.b <- raster::rasterFromXYZ(cbind(xy,z1+z2+z3))
#'
#' # create small raster
#' r.s <- raster::crop(r.b, raster::extent(c(15,25,15,25)))
#' # offset raster by (-3, -3)
#' raster::extent(r.s) <- c(12,22,12,22)
#'
#' # compute correlations for translations inside buffer
#' rr <- rastersMovingCor(r.b, r.s, buffer=9, pas=1)
#' rr
#'
#' \dontrun{
#' # display large raster
#' raster::plot(r.b)
#' # display small raster
#' raster::plot(r.s)
#' # display correlation
#' raster::plot(rr, xlab="X translation", ylab="Y translation",
#' main="Correlation between rasters")}
#' @export
rastersMovingCor <- function(raster.b, raster.s, mask=NULL, buffer=19, pas=0.5)
{
# create data.frame for results
resultat <- data.frame(xoffset=numeric(),yoffset=numeric(),correlation=numeric())
# initialize output line
n <- 0
# perform computation on small raster
# apply mask
if (!is.null(mask))
{
raster.s <- raster.s*mask
}
# center and standardize small raster
raster.s <- raster.s-mean(raster::values(raster.s),na.rm=T)
raster.s <- raster.s/stats::sd(raster::values(raster.s),na.rm=T)
#
# compute squared radius
buff2 <- buffer^2
# copy small raster before offsetting
matrice2 <- raster.s
# copy mask before offsetting
if (!is.null(mask)) {mask2 <- mask} else {mask2 <- NULL}
# loop on X offset
for (xoffset in seq(from=-buffer,to=buffer,by=pas))
{
# modify small raster X extent
matrice2@extent@xmin <- raster.s@extent@xmin+xoffset
matrice2@extent@xmax <- raster.s@extent@xmax+xoffset
# modify mask X extent
if (!is.null(mask))
{
mask2@extent@xmin <- mask@extent@xmin+xoffset
mask2@extent@xmax <- mask@extent@xmax+xoffset
}
# loop on Y offset
for (yoffset in seq(from=-buffer,to=buffer,by=pas))
{
# check if new position is inside the search buffer
if (yoffset^2+xoffset^2<=buff2)
{
# modify small raster Y extent
matrice2@extent@ymin <- raster.s@extent@ymin+yoffset
matrice2@extent@ymax <- raster.s@extent@ymax+yoffset
# modify mask Y extent
if (!is.null(mask))
{
mask2@extent@ymin <- mask@extent@ymin+yoffset
mask2@extent@ymax <- mask@extent@ymax+yoffset
}
# increment line
n <- n+1
# compute correlation and record results
resultat[n,] <- c(xoffset, yoffset, rasters2Cor(raster.b,matrice2,mask2,T))
}
}
}
# convert results to raster
taille <- length(seq(from=-buffer,to=buffer,by=pas))
rr <- raster::raster(nrows=taille,ncols=taille,xmx=buffer+pas/2,xmn=-buffer-pas/2,ymx=buffer+pas/2,ymn=-buffer-pas/2)
rr <- raster::rasterize(resultat[,1:2],rr,resultat[,3],fun=max)
rr
}
########################################################
#' Statistics of raster local maximum
#'
#' identifies local maximum from raster (e.g. output from \code{\link{rastersMovingCor}}), and computes related statistics. The second local maximum is the pixel which is local maximum on the largest neighborhood except for the global maximum.
#'
#' @param r raster. typically output of \code{\link{rastersMovingCor}}
#' @param dm numeric. minimum distance between two local maxima in meters
#' @param med1 numeric. window radius to compute median value around the maximum position (default: 1m)
#' @param med2 numeric. window radius #2 to compute median value around the maximum position (default: 2m)
#' @param quanta numeric. quantile value to compute for raster values (default: 3rd quartile)
#' @param quantb numeric. quantile #2 value to compute for raster values (default: median)
#' @seealso \code{\link{rastersMovingCor}}, \code{\link{coregistration}} for application to the coregistration of tree inventory data with canopy height models
#' @return A data.frame with value of maximum, position of maximum, position of second maximum, ratio of max value to 2nd max, ratio of max value to median of neighborhood (size1 and size 2), ratio of max value to raster quantiles 1 and 2
#' @examples
#' # create raster
#' r.b <- raster::raster()
#' raster::extent(r.b) <- c(0,40,0,40)
#' raster::res(r.b) <- 1
#' xy <- raster::xyFromCell(r.b,1:length(r.b))
#'
#' # add Gaussian surfaces
#' z1 <- 1.5*exp(-((xy[,1]-22)^2+(xy[,2]-22)^2/2)/5)
#' z2 <- exp(-((xy[,1]-20)^2+(xy[,2]-22)^2/2)/3)
#' z3 <- 1.5*exp(-((xy[,1]-17)^2+(xy[,2]-17)^2/2)/5)
#' r.b <- raster::rasterFromXYZ(cbind(xy,z1+z2+z3))
#'
#' # create small raster
#' r.s <- raster::crop(r.b, raster::extent(c(15,25,15,25)))
#' # offset raster by (-3, -3)
#' raster::extent(r.s) <- c(12,22,12,22)
#'
#' rr <- rastersMovingCor(r.b, r.s, buffer=9, pas=1)
#' loc.max <- rasterLocalmax(rr)
#' loc.max
#'
#' \dontrun{
#' # plot raster
#' raster::plot(rr)
#' # add location of two local maxima
#' points(loc.max[1,c("dx1","dx2")], loc.max[1,c("dy1","dy2")], cex=c(1,0.5), pch=3)}
#' @export
rasterLocalmax <- function(r, dm=2, med1=1, med2=2, quanta=0.75, quantb=0.5)
{
# check if raster is valid
if (length(r)>1 && max(raster::values(r),na.rm=T)>-Inf)
{
# convert raster to cimg object
dummy<- imager::as.cimg(raster::as.matrix(r))
# replace NA values with -Inf
dummy[is.na(dummy)] <- -Inf
# maxima detection
maxi <- maximaDetection(dummy,raster::res(r)[1])
dummy[] <- 1
# maxima selection, without value criteria
maxi <- maximaSelection(maxi, dummy, hmin=0, dmin=dm, dprop=0)
# conversion to raster
maxi <- raster::raster(as.matrix(maxi))
raster::extent(maxi) <- raster::extent(r)
# indice of global max
pixel1 <- raster::which.max(maxi)
# max value
max1 <- r[pixel1[1]]
# coordinates of global max
coord1 <- raster::xyFromCell(maxi,pixel1[1])
# erase first max
maxi[pixel1] <- NA
# second maximum
pixel2 <- raster::which.max(maxi)
max2 <- r[pixel2[1]]
coord2 <- raster::xyFromCell(maxi,pixel2[1])
# median around global max
# half resolution
hres <- raster::res(r)[1]/2
# median around maximum, neighborhood 1
medloc1 <- stats::median(raster::values(raster::crop(r,raster::extent(c(coord1[1]-med1-hres,
coord1[1]+med1+hres,
coord1[2]-med1-hres,
coord1[2]+med1+hres)))), na.rm=T)
# median around maximum, neighborhood 2
medloc2 <- stats::median(raster::values(raster::crop(r,raster::extent(c(coord1[1]-med2-hres,
coord1[1]+med2+hres,
coord1[2]-med2-hres,
coord1[2]+med2+hres)))), na.rm=T)
# stats of correlation raster
quant.a <- stats::quantile(r,quanta,na.rm=T)
quant.b <- stats::quantile(r,quantb,na.rm=T)
# store results into data.frame
data.frame(max1=max1,dx1=coord1[1],dy1=coord1[2],dx2=coord2[1],dy2=coord2[2],ratiomax1max2=max1/max2,rmedloc1=max1/medloc1,rmedloc2=max1/medloc2,rquanta=max1/quant.a,rquantb=max1/quant.b)
} else { NA }
}
########################################################
#' Tree inventory and canopy height model coregistration
#'
#' Computes the correlation between the canopy height model and a virtual canopy height model simulated from tree locations, for different translations of tree inventory positions, and outputs the translation corresponding to best estimated co-registration.
#'
#' @param chm raster. canopy height model
#' @param trees data.frame. the first two columns contain xy coordinates, and the third is the value to correlate to the chm (e.g. tree heights or diameters)
#' @param mask raster. raster mask of tree inventory area
#' @param buffer numeric. radius of the circular buffer area of possible translations
#' @param pas numeric. increment step of translations within buffer area to compute correlation values, should be a multiple of raster resolution
#' @param dm numeric. minimum distance between two local maxima in meters
#' @param plot boolean. whether to display the results or not
#' @seealso \code{\link{rastersMovingCor}}, \code{\link{rasterLocalmax}}
#' @return A list with two elements : first the correlation raster returned by \code{\link{rastersMovingCor}}, second a data.frame returned by \code{\link{rasterLocalmax}}
#' @references Monnet, J.-M. and Mermin, E. 2014. Cross-Correlation of Diameter Measures for the Co-Registration of Forest Inventory Plots with Airborne Laser Scanning Data. Forests 2014, 5(9), 2307-2326, \url{https://doi.org/10.3390/f5092307}
#' @examples
#' # tree inventory
#' trees <- data.frame(x=c(22.2, 18.3, 18.1), y =c(22.1, 22.7, 18.4), z=c(15,10,15))
#'
#' # mask of inventory area
#' # empty raster with extent
#' tree.mask <- circle2Raster(20, 20, 9, resolution=1)
#' # fill binary mask
#' tree.mask <- rasterXYMask(rbind(c(20, 20), c(20, 20)), c(9,9), tree.mask, binary=TRUE)
#'
#' # simulate chm raster
#' chm <- raster::raster()
#' raster::extent(chm) <- c(0,40,0,40)
#' raster::res(chm) <- 1
#' xy <- raster::xyFromCell(chm,1:length(chm))
#'
#' # add Gaussian surfaces to simulate tree crowns
#' z1 <- trees$z[1]*exp(-((xy[,1]-trees$x[1])^2+(xy[,2]-trees$y[1])^2/2)*trees$z[1]/50)
#' z2 <- trees$z[2]*exp(-((xy[,1]-trees$x[2])^2+(xy[,2]-trees$y[2])^2/2)*trees$z[2]/50)
#' z3 <- trees$z[3]*exp(-((xy[,1]-trees$x[3])^2+(xy[,2]-trees$y[3])^2/2)*trees$z[3]/50)
#' chm <- raster::rasterFromXYZ(cbind(xy,pmax(z1,z2,z3)))#+rnorm(length(z1),0,1)))
#'
#' # translate trees
#' trees$x <- trees$x-2
#' trees$y <- trees$y+4
#'
#' coregistration <- coregistration(chm, trees, mask=tree.mask, buffer=8, pas=1, dm=1, plot=TRUE)
#' coregistration$local.max[,c("dx1", "dy1")]
#'
#' \dontrun{
#' # plot raster
#' raster::plot(coregistration$correlation.raster)
#' abline(h=0, lty=2)
#' abline(v=0, lty=2)
#' # add location of two local maxima
#' points(coregistration$local.max[1,c("dx1","dx2")],
#' coregistration$local.max[1,c("dy1","dy2")], cex=c(1,0.5), pch=3, col="red")}
#' @export
coregistration <- function(chm, trees, mask= NULL, buffer=19, pas=0.5, dm=2, plot=TRUE)
{
# compute virtual chm from tree inventory
virtualchm <- raster::rasterize(trees[,1:2], mask, trees[,3],fun=max)
# fill NA values with 0
virtualchm[is.na(virtualchm)] <- 0
#
# compute correlation raster
r.correlation <- rastersMovingCor(chm, virtualchm, mask=mask, buffer=buffer, pas=pas)
# analyse correlation image
resul <- rasterLocalmax(r.correlation)
# display results
if (plot)
{
# CHM
raster::plot(chm, asp=1)
# display initial tree positions
graphics::points(trees[,1], trees[,2], cex=trees[,3]/40)
# display coregistered tree positions
graphics::points(trees[,1]+resul$dx1, trees[,2]+resul$dy1, cex=trees[,3]/20, col="red")
graphics::legend("topleft", c("Initial", "Coregistered"), pch=1, col=c("black", "red"))
}
list(correlation.raster=r.correlation, local.max=resul)
}
#
\ No newline at end of file
#' las data in France (Chablais 3 plot)
#'
#' Airborne laser scanning data over the Chablais 3 plot, acquired in 2009 by Sintegra, copyright Irstea
#'
#' @docType data
#'
#' @usage data(laschablais3)
#'
#' @format An object of class \code{"LAS"} (e.g. returned by \code{\link[lidR]{LAS}})
#'
#' @keywords datasets
#'
#' @references Monnet, J.-M. 2011. Using airborne laser scanning for mountain forests mapping: Support vector regression for stand parameters estimation and unsupervised training for treetop detection. Ph.D. thesis. University of Grenoble, France. pp. 21-22. \url{https://tel.archives-ouvertes.fr/tel-00652698/document}
#'
#' @source Monnet J.-M. Irstea
#'
#' @examples
#' data(laschablais3)
#' laschablais3
#' @name laschablais3
NULL
"laschablais3"
This diff is collapsed.
# package lidaRtRee
# Copyright Irstea
# Author(s): Jean-Matthieu Monnet
# Licence: LGPL-3
########################### FUNCTIONS FOR TREE MATCHING #############################
#
######################################
#' 3D matching of detected tree top positions with reference positions
#'
#' First computes a matching index for each potential pair associating a detected with a reference tree. This index is the 3D distance between detected and reference points, divided by a maximum matching distance set by user-defined parameters. Pairs with the lowest index are then iteratively associated.
#'
#' @param lr data.frame or matrix. 3D coordinates (X Y Height) of reference positions
#' @param ld data.frame or matrix. 3D coordinates (X Y Height) of detected positions
#' @param deltaGround numeric. buffer around trunk position
#' @param hPrec numeric. buffer around apex position (reference Height)
#' @param computeStat boolean. should matching stats be computed
#' @return A dataframe with matched pairs (row of reference positions in first column, and row of detected positions in second column) and corresponding 3D distances
#' @references Monnet, J.-M. 2011. Using airborne laser scanning for mountain forests mapping: Support vector regression for stand parameters estimation and unsupervised training for treetop detection. Ph.D. thesis. University of Grenoble, France. pp. 53-55 \url{https://tel.archives-ouvertes.fr/tel-00652698/document}
#'
#' Monnet, J.-M., Mermin, E., Chanussot, J., Berger, F. 2010. Tree top detection using local maxima filtering: a parameter sensitivity analysis. Silvilaser 2010, the 10th International Conference on LiDAR Applications for Assessing Forest Ecosystems, September 14-17, Freiburg, Germany, 9 p. \url{https://hal.archives-ouvertes.fr/hal-00523245/document}
#' @seealso \code{\link{plot2Dmatched}}, \code{\link{histDetection}}
#' @examples
#' # create reference and detected trees
#' ref.trees <- cbind(c(1,4,3,4,2), c(1,1,2,3,4), c(15,18,20,10,11))
#' def.trees <- cbind(c(2,2,4,4), c(1,3,4,1), c(16,19,9,15))
#' #
#' # match trees
#' match1 <- treeMatching(ref.trees, def.trees)
#' match2 <- treeMatching(ref.trees, def.trees, deltaGround=2, hPrec=0)
#' match1
#' match2
#'
#' \dontrun{
#' # 2D display of matching result
#' plot2Dmatched(ref.trees, def.trees, match1)
#' plot2Dmatched(ref.trees, def.trees, match2)}
#' @export
treeMatching <- function(lr, ld, deltaGround=2.1, hPrec=0.14, computeStat=TRUE)
{
# coefficients for max matching squared radius ( rmax = deltaGround + hPrec * HEIGHT -> rmax^2 = deltaGround^2 + 2* hPrec * deltaGround * HEIGHT + hPrec^2 * HEIGHT^2)
d2max0 <- deltaGround^2
d2max1 <- 2* hPrec * deltaGround
d2max2 <- hPrec^2
# number of positions
nr <- nrow(lr)
nd <- nrow(ld)
#
# max distance for matching (depends on reference tree height)
norm.f <- d2max0 + d2max1 * lr[,3] + d2max2 * lr[,3] * lr[,3]
#
# create matrix of of matching indices (row : detected position, column : reference position)
d <- dn <- matrix(NA,nd,nr,dimnames=list(paste("d",1:nd,sep=""),paste("r",1:nr,sep="")))
# for each reference tree
for (i in 1:nr)
{
# compute matching index to detected trees
# compute distances in each axis
dummy <- cbind(ld[,1] - lr[i,1], ld[,2] - lr[i,2], ld[,3] - lr[i,3])
# compute 3D distance
d[,i] <- dn[,i] <- apply(dummy^2,1,sum)
# divided by max matching squared radius to obtain matching index
dn[,i] <- dn[,i]/norm.f[i]
}
#
# tree matching
# replace values over the matching limit (pairs where the 3D distance is over the max matching radius of the reference tree) by the limit
dn[dn>=1] <- 1
#
# trees that have no matching possibilities
# reference trees (sum of column == number of detected trees)
i.r <- which(apply(dn,2,sum)==nrow(dn))
if (length(i.r)>0)
{
# remove from distance matrix
dn <- dn[,-i.r]
}
# detected trees (sum of row == number of reference trees)
i.d<- which(apply(dn,1,sum)==ncol(dn))
if (length(i.d)>0)
{
# remove from distance matrix
dn <- dn[-i.d,]
}
#
# iterative matching of pairs with the lowest matching index
matched <- data.frame()
# add one row of "1" and one column to prevent dn from becoming a vector
dn <- rbind(dn,rep(1,ncol(dn)))
dn <- cbind(dn,rep(1,nrow(dn)))
while (min(dn)<1) # while there are values below the matching limit
{
# find first pair with minimum index
coord <- t(which(dn==min(dn),arr.ind=T))[1:2]
# store pair
matched <- rbind(matched,as.numeric(gsub("d","",gsub("r","",c(colnames(dn)[coord[2]],rownames(dn)[coord[1]])))))
# remove pair from matrix
dn <- dn[-coord[1],-coord[2]]
}
if (length(matched)==0)
{
return(NULL)
} else {
names(matched)=c("r","d")
#
# computes stats if required
if (computeStat)
{
matched$h.diff <- ld[matched[,2],3] - lr[matched[,1],3]
matched$plan.diff <- sqrt((ld[matched[,2],1] - lr[matched[,1],1])^2 + (ld[matched[,2],2] - lr[matched[,1],2])^2)
}
return(matched)
}
}
#
######################################
#' Plot of matched pairs of detected and reference trees
#'
#' @param lr data.frame or matrix. 3D coordinates (X Y Height) of reference positions
#' @param ld data.frame or matrix. 3D coordinates (X Y Height) of detected positions
#' @param matched data.frame. contains pair indices, typically returned by \code{\link{treeMatching}}
#' @param chm raster object. raster for background display
#' @param plotBoundary Spatialpolygon. plot boundaries for display
#' @return no return
#' @seealso \code{\link{treeMatching}}, \code{\link{histDetection}}
#' @examples
#' # create reference and detected trees
#' ref.trees <- cbind(c(1,4,3,4,2), c(1,1,2,3,4), c(15,18,20,10,11))
#' def.trees <- cbind(c(2,2,4,4), c(1,3,4,1), c(16,19,9,15))
#' #
#' # compute matching
#' match1 <- treeMatching(ref.trees, def.trees)
#' match2 <- treeMatching(ref.trees, def.trees, deltaGround=2, hPrec=0)
#'
#' \dontrun{
#' # 2D display of matching results
#' plot2Dmatched(ref.trees, def.trees, match1)
#' plot2Dmatched(ref.trees, def.trees, match2)}
#' @export
plot2Dmatched <- function(lr, ld, matched, chm=NULL, plotBoundary=NULL)
{
# colors
couleur.lr <- rep("red",nrow(lr))
couleur.ld <- rep("red",nrow(ld))
couleur.lr[matched[,"r"]] <- "blue"
couleur.ld[matched[,"d"]] <- "blue"
#
# display raster background or not
if (!is.null(chm))
{
raster::plot(chm, asp=1)
# add points of detected and reference trees
graphics::points(rbind(lr[,1:2],ld[,1:2]),pch=c(rep(1,nrow(lr)),rep(2,nrow(ld))),asp=1,cex=c(lr[,3],ld[,3])/20,col=c(couleur.lr,couleur.ld))
} else {
# add points of detected and reference trees
graphics::plot(rbind(lr[,1:2],ld[,1:2]),pch=c(rep(1,nrow(lr)),rep(2,nrow(ld))),asp=1,cex=c(lr[,3],ld[,3])/20,col=c(couleur.lr,couleur.ld))
}
#
# draw lines between pairs
for (i in 1:nrow(matched))
{
graphics::lines(rbind(lr[matched[i,1],1:2],ld[matched[i,2],1:2]),col="blue")
}
# add plot boundary
if (!is.null(plotBoundary))
{sp::plot(plotBoundary,add=T)}
#
# legend
graphics::legend("topleft", c("reference", "detected", "matched", "not matched"), col=c("black", "black", "blue", "red"), pch=c(1,2,15,15))
}
#
#####################################
#' Histogram of detection
#'
#' Displays the histogram of tree heights of three categories: true detections, omissions, and false detections.
#'
#' @param lr data.frame or matrix. 3D coordinates (X Y Height) of reference positions
#' @param ld data.frame or matrix. 3D coordinates (X Y Height) of detected positions
#' @param matched data.frame. contains pair indices, typically returned by \code{\link{treeMatching}}
#' @param plot boolean. should the histogram be displayed or not
#' @return A list with three numerics: numbers of true detections, omissions and false detections
#' @seealso \code{\link{treeMatching}}
#' @examples
#' # create reference and detected trees
#' ref.trees <- cbind(c(1,4,3,4,2), c(1,1,2,3,4), c(15,18,20,10,11))
#' def.trees <- cbind(c(2,2,4,4), c(1,3,4,1), c(16,19,9,15))
#' #
#' # tree matching with different buffer size
#' match1 <- treeMatching(ref.trees, def.trees)
#' match2 <- treeMatching(ref.trees, def.trees, deltaGround=2, hPrec=0)
#' #
#' # corresponding number of detections
#' histDetection(ref.trees, def.trees, match1, plot=FALSE)
#' histDetection(ref.trees, def.trees, match2, plot=FALSE)
#'
#' \dontrun{
#' # 2D display of matching result
#' histDetection(ref.trees, def.trees, match1)
#' histDetection(ref.trees, def.trees, match2)}
#' @export
histDetection <- function(lr, ld, matched, plot=TRUE)
{
dummy <- list()
# true detections
dummy[[1]] <- lr[matched[,1],3]
# true omissions
dummy[[2]] <- lr[-matched[,1],3]
# false detections
dummy[[3]] <- ld[-matched[,2],3]
if (plot)
{
# draw histogram
histStack(dummy,breaks=seq(from=0,to=ceiling(max(lr[,3],ld[,3])/5)*5,by=5),col=c("green","red","blue"))
graphics::axis(2,mgp=c(0.5,0.5,0))
graphics::mtext(side=2,text="Number of trees",line=1.3)
graphics::mtext(side=1,text="Height classes (m)",line=1.3)
graphics::legend("topright",c("True positive","False negative","False positive"),pch=15,col=c("green","red","blue"))
}
#
list(true.detections=length(dummy[[1]]), false.detections=length(dummy[[3]]), omissions=length(dummy[[2]]))
}
######################################
#' Stacked histogramm
#'
#' @param x list of vectors. values for each category
#' @param breaks vector. breaks for histogram bins
#' @param col vector. colors for each category
#' @param breaksFun function for breaks display
#' @return no return
#' @export
#'
histStack <- function(x, breaks, col=NULL, breaksFun=paste)
{
if(!is.list(x))
stop("'x' must be a list.")
if (is.null(col)) { col <- 1:length(x)}
bars <- NULL
for (i in 1:length(x)) {
if(!is.numeric(x[[i]]))
paste("Element", i, "of 'x' is not numeric.")
h <- graphics::hist(x[[i]], breaks=breaks, plot=FALSE)
bars <- rbind(bars, h$counts)
}
# grDevices::dev.new(width=3.5, height=3.5)
graphics::par(mar=c(2.5,2.5,0.5,0.5))
graphics::barplot(bars, names.arg=NULL, col=col, space=0,yaxt="n")
at = seq(along=h$breaks)-1
modulo = ceiling(length(at)/10)
sel = (at %% modulo == 0)
graphics::axis(side=1,at=at[sel],labels=breaksFun(h$breaks)[sel],mgp=c(0.5,0.5,0))
}
#######################################
#' Regression of detected heights VS reference heights
#'
#' Computes a linear regression model between the reference heights and the detected heights of matched pairs.
#'
#' @param lr data.frame or matrix. 3D coordinates (X Y Height) of reference positions
#' @param ld data.frame or matrix. 3D coordinates (X Y Height) of detected positions
#' @param matched data.frame. contains pair indices, typically returned by \code{\link{treeMatching}}
#' @param plot boolean. indicates whether results should be plotted
#' @param species vector of strings. species for standardized color use by call to \code{\link{speciesColor}}
#' @param limits vector of two numerics. range to be plotted
#' @return A list with two elements. First one is the linear regression model, second one is a list with stats (root mean square error, bias and standard deviation of detected heights compared to reference heights).
#' @seealso \code{\link{treeMatching}}
#' @examples
#' # create tree locations and heights
#' ref.trees <- cbind(c(1,4,3,4,2), c(1,1,2,3,4), c(15,18,20,10,11))
#' def.trees <- cbind(c(2,2,4,4), c(1,3,4,1), c(16,19,9,15))
#'
#' # tree matching
#' match1 <- treeMatching(ref.trees, def.trees)
#'
#' # height regression
#' reg <- heightRegression(ref.trees, def.trees, match1, plot=FALSE,
#' species=c("ABAL", "ABAL", "FASY", "FASY", "ABAL"), limits=c(0,30))
#' summary(reg$lm)
#' reg$stats
#'
#' \dontrun{
#' # display plot
#' reg <- heightRegression(ref.trees, def.trees, match1,
#' species=c("ABAL", "ABAL", "FASY", "FASY", "ABAL"), limits=c(0,30), plot=TRUE)}
#' @export
#'
heightRegression <-function(lr, ld, matched, plot=T, species=NULL, limits=NULL)
{
app <- data.frame(Hm=lr[matched[,1],3], Hl=ld[matched[,2],3])
reg<-stats::lm(Hm~Hl,data=app)
if (plot)
{
# apply species-specific colors
if (!is.null(species))
{
# load palette
color <- speciesColor()
# extract corresponding colors
col1 <- color[as.character(species[matched[,1]]),c("col","abvr")]
} else { col1 <- data.frame(col="black")}
# grDevices::dev.new(height=2.5,width=2.5)
graphics::par(mar=c(2.5,2.5,0.5,0.5))
if (is.null(limits)) {limits <- c(0,40)}#range(c(app$Hm,app$Hl)).*c(0.9,1.1)
graphics::plot(app$Hl,app$Hm,xlim=limits,ylim=limits,pch=4,cex=0.6,col=col1$col,xlab="NA",ylab="NA",yaxt="n",xaxt="n")
graphics::axis(2,mgp=c(0.5,0.5,0))
graphics::axis(1,mgp=c(0.5,0.5,0))
graphics::mtext(side=2,text="Reference height (m)",line=1.3)
graphics::mtext(side=1,text="Detected height (m)",line=1.3)
graphics::abline(c(0,1),lty=1)
graphics::abline(c(reg$coefficients[1],reg$coefficients[2]),lty=2)
graphics::text(27,9,paste("n = ",nrow(app),sep=""))
graphics::text(27,6,paste("h = ",round(reg$coefficients[2],digits=2)," x hl + ",round(reg$coefficients[1],digits=2),sep=""))
graphics::text(27,2.75,paste("adj-R2 = ",round(summary(reg)$adj.r.squared,digits=2),sep=""))
if (!is.null(species))
{
texte <- sort(unique(col1$abvr))
graphics::legend("topleft", texte, col=color[texte,"col"],pch=15,cex=1,y.intersp = 1)
}
}
list(lm=reg, stats=list(rmse=sqrt(sum(app$Hm-app$Hl)^2/nrow(app)), bias=mean(app$Hl-app$Hm), sd=stats::sd(app$Hl-app$Hm)))
}
#' @name treeinventorychablais3
#'
#' @title Tree inventory data in France (Chablais 3 plot, July 2010)
#'
#' @description All trees with diameter at breast height >= 7.5 cm are inventoried on a 50m x 50m plot.
#'
#' @docType data
#'
#' @usage data(treeinventorychablais3)
#'
#' @format A dataframe with columns:
#' \enumerate{
#' \item x easting coordinate in Lambert 93
#' \item y northing coordinate in Lambert 93
#' \item d dbh (cm)
#' \item h tree height (m)
#' \item n tree number
#' \item s species abreviated as GESP (GEnus SPecies)
#' \item e appearance (0: missing or lying, 1: normal, 2: broken treetop, 3: dead with branches, 4: snag)
#' \item t tilted (0: no, 1: yes)
#' }
#'
#' @keywords datasets
#'
#' @references Monnet, J.-M. 2011. Using airborne laser scanning for mountain forests mapping: Support vector regression for stand parameters estimation and unsupervised training for treetop detection. Ph.D. thesis. University of Grenoble, France. pp. 21-22 & 34 \url{https://tel.archives-ouvertes.fr/tel-00652698/document}
#'
#' @examples
#' data(treeinventorychablais3)
#' summary(treeinventorychablais3)
NULL
"treeinventorychablais3"
File deleted
File deleted
File deleted
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/chmchablais3-data.R
\docType{data}
\name{chmchablais3}
\alias{chmchablais3}
\title{Canopy height model (Chablais 3 plot)}
\format{A raster object}
\usage{
data(chmchablais3)
}
\description{
Canopy height model computed from airborne laser scanning data acquired in July 2010.
}
\examples{
data(chmchablais3)
chmchablais3
\dontrun{
raster::plot(chmchablais3)}
}
\references{
Monnet, J.-M. 2011. Using airborne laser scanning for mountain forests mapping: Support vector regression for stand parameters estimation and unsupervised training for treetop detection. Ph.D. thesis. University of Grenoble, France. pp. 21-22 & 34 \url{https://tel.archives-ouvertes.fr/tel-00652698/document}
}
\keyword{datasets}
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/coregistration.R
\name{circle2Raster}
\alias{circle2Raster}
\title{Raster corresponding to circle extent}
\usage{
circle2Raster(X, Y, radius, resolution = 0.5, buffer = 0.5)
}
\arguments{
\item{X}{numeric. easting coordinate of plot center in meters}
\item{Y}{numeric. northing coordinate of plot center in meters}
\item{radius}{numeric. plot radius in meters}
\item{resolution}{numeric. raster resolution in meters}
\item{buffer}{numeric. buffer to be added to plot radius in meters}
}
\value{
A raster object
}
\description{
Creates an empty raster which extents corresponds to the circle specified by center coordinates, radius and optional buffer size.
}
\examples{
circle2Raster(100, 100, 20, 1, 5)
}
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/coregistration.R
\name{coregistration}
\alias{coregistration}
\title{Tree inventory and canopy height model coregistration}
\usage{
coregistration(chm, trees, mask = NULL, buffer = 19, pas = 0.5, dm = 2,
plot = TRUE)
}
\arguments{
\item{chm}{raster. canopy height model}
\item{trees}{data.frame. the first two columns contain xy coordinates, and the third is the value to correlate to the chm (e.g. tree heights or diameters)}
\item{mask}{raster. raster mask of tree inventory area}
\item{buffer}{numeric. radius of the circular buffer area of possible translations}
\item{pas}{numeric. increment step of translations within buffer area to compute correlation values, should be a multiple of raster resolution}
\item{dm}{numeric. minimum distance between two local maxima in meters}
\item{plot}{boolean. whether to display the results or not}
}
\value{
A list with two elements : first the correlation raster returned by \code{\link{rastersMovingCor}}, second a data.frame returned by \code{\link{rasterLocalmax}}
}
\description{
Computes the correlation between the canopy height model and a virtual canopy height model simulated from tree locations, for different translations of tree inventory positions, and outputs the translation corresponding to best estimated co-registration.
}
\examples{
# tree inventory
trees <- data.frame(x=c(22.2, 18.3, 18.1), y =c(22.1, 22.7, 18.4), z=c(15,10,15))
# mask of inventory area
# empty raster with extent
tree.mask <- circle2Raster(20, 20, 9, resolution=1)
# fill binary mask
tree.mask <- rasterXYMask(rbind(c(20, 20), c(20, 20)), c(9,9), tree.mask, binary=TRUE)
# simulate chm raster
chm <- raster::raster()
raster::extent(chm) <- c(0,40,0,40)
raster::res(chm) <- 1
xy <- raster::xyFromCell(chm,1:length(chm))
# add Gaussian surfaces to simulate tree crowns
z1 <- trees$z[1]*exp(-((xy[,1]-trees$x[1])^2+(xy[,2]-trees$y[1])^2/2)*trees$z[1]/50)
z2 <- trees$z[2]*exp(-((xy[,1]-trees$x[2])^2+(xy[,2]-trees$y[2])^2/2)*trees$z[2]/50)
z3 <- trees$z[3]*exp(-((xy[,1]-trees$x[3])^2+(xy[,2]-trees$y[3])^2/2)*trees$z[3]/50)
chm <- raster::rasterFromXYZ(cbind(xy,pmax(z1,z2,z3)))#+rnorm(length(z1),0,1)))
# translate trees
trees$x <- trees$x-2
trees$y <- trees$y+4
coregistration <- coregistration(chm, trees, mask=tree.mask, buffer=8, pas=1, dm=1, plot=TRUE)
coregistration$local.max[,c("dx1", "dy1")]
\dontrun{
# plot raster
raster::plot(coregistration$correlation.raster)
abline(h=0, lty=2)
abline(v=0, lty=2)
# add location of two local maxima
points(coregistration$local.max[1,c("dx1","dx2")],
coregistration$local.max[1,c("dy1","dy2")], cex=c(1,0.5), pch=3, col="red")}
}
\references{
Monnet, J.-M. and Mermin, E. 2014. Cross-Correlation of Diameter Measures for the Co-Registration of Forest Inventory Plots with Airborne Laser Scanning Data. Forests 2014, 5(9), 2307-2326, \url{https://doi.org/10.3390/f5092307}
}
\seealso{
\code{\link{rastersMovingCor}}, \code{\link{rasterLocalmax}}
}
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