#' @import tidyverse
#'
#'
#' @param data A one-plot, one-census dataset you want to process
#' @param X Character. The name of the column containing plot-scale \code{X} coordinates.
#' Coordinates must be in the plot's referential, not UTM or others.
#' @param Y Character. The name of the column containing plot-scale Y coordinates.
#' Coordinates must be in the plot's referential, not UTM or others.
#' @param dbh Character. The name of the column containing dbh measurements
#' @param ID Character. The name of the column containing unique individual IDs
#' @param dmax Maximum distance you wannt to move a tree from its conflicting
#' position. If tree cannot be replace within that range, the biggest dbh are kept
#' and the smallest, removed.
#'
#' @return Function returns a new inventory with modified coordinates,
#' where there is one individual per cell.
#' @export
#'
#' @examples
# replacement <- function(data, X = "X", Y = "Y", dbh ="dbh", ID = "i_arbre", dmax = 3)
replacement <- function(data, X, Y, dbh, ID, dmax = 5)
{
library(tidyverse)
# Variable preparation for plyr syntaxis ----------------------------------
X <- enquo(X)
Y <- enquo(Y)
dbh <- enquo(dbh)
ID <- enquo(ID)
# Definition of conflicts matrix ------------------------------------------
count_conflicts <- data %>%
dplyr::select(!!X, !!Y) %>%
group_by(!!X, !!Y) %>%
summarise(n = n()) %>%
#as.numeric %>%
#Is this line to be removed ? it can avoid to do useless tests.
filter(n > 1)
names(count_conflicts) <- c("X","Y","n")
# Core loop for each conflicting cell ---------------------------
for (i in 1:nrow(count_conflicts))
{
cat("iteration ", i, "sur ", nrow(count_conflicts), "\n")
# Declaring new coordinates matrix ----------------------------------------
# First line will be NA and is removed after the loop.
newcoord <- matrix(ncol = 3) %>% as.data.frame
names(newcoord) <- c("X","Y","d")
# Scope loop for one conflicting cell -------------------------------------
# Scoping until there are enough free cells for the number of trees we want to replace
d = 1
while((newcoord %>% filter(!is.na(X)) %>% filter(!is.na(Y)) %>% filter(!is.na(d)) %>% nrow()) < (count_conflicts$n[i]-1) && d < dmax)
{
# Creating the scope matrix : coordinates, availability, distance ---------
x <- count_conflicts$X[i]
y <- count_conflicts$Y[i]
Scope <- matrix(NA, ncol = 4, nrow = 8*d)
Scope <- as.data.frame(Scope)
colnames(Scope) <- c("X","Y","Available","d")
### Scope coordinates (a square crown of distance d to the focus conflict cell.)
Scope$X <- c(rep(x-d, 2*d+1), ((x-d+1):(x+d-1)), rep(x+d,2*d+1), sort((x-d+1):(x+d-1), decreasing = T))
Scope$Y <- c(sort((y-d):(y+d), decreasing = T), rep(y-d,2*d-1),(y-d):(y+d), rep(y+d,2*d-1))
### Scope distance is stored to move less bigger dbhs when several trees have to be replaced
Scope$d <- rep(d, 8*d)
# Filling the Scope matrix -------------------------------------------------
for(j in 1:nrow(Scope))
{
# Safety check : avoiding edge effects by declaring coordinates un --------
if(!(Scope$X[j] > min(data %>% dplyr::select(!!X)) & Scope$X[j] < max(data %>% dplyr::select(!!X))))
{
Scope$Available[j] <- FALSE
}
else if(!(Scope$Y[j] > min(data %>% dplyr::select(!!Y)) & Scope$Y[j] < max(data %>% dplyr::select(!!Y))))
{
Scope$Available[j] <- FALSE
}
else
{
row_x <- which(data[,as.character(X)[2]] == Scope$X[j])
row_xy <- which(data[row_x,as.character(Y)[2]]== Scope$Y[j])
if(length(row_xy) > 0) {Scope$Available[j] <- FALSE}
else{Scope$Available[j] <- TRUE}
}
# Availability of the cells -----------------------------------------------
## TO DEBUG
}
# Test for sufficiency of the number of available cells in the scope ------
# print(newcoord)
#If enough, end while-loop
newcoord <- rbind(newcoord, Scope %>% filter(Available == T) %>% dplyr::select(X,Y,d))
# count_conflicts$n[i] <- count_conflicts$n[i] - nrow(newcoord %>% filter(!is.na(newcoord$X) & !is.na(newcoord$Y)))
d <- d+1
}
# print(newcoord)
newcoord <- newcoord %>%
filter(!is.na(X)) %>%
filter(!is.na(Y)) %>%
filter(!is.na(d))
# filter(!is.na(X)) %>% filter(!is.na(Y)) %>% filter(!is.na(d)) %>%
# sample_n(size = (count_conflicts$n[i])-1, replace = FALSE)
# print("conflict number");print((count_conflicts$n[i])-1)
# debugueuh
# print("Nombre de lignes de newcoord")
# print(newcoord)
focus <- data %>%
dplyr::select(!!X,!!Y,!!dbh,!!ID) %>%
filter(!!X == count_conflicts$X[i]) %>%
filter(!!Y == count_conflicts$Y[i]) %>%
rename(X = !!X) %>%
rename(Y = !!Y) %>%
rename(ID = !!ID)
# temp <-temp %>% filter(!is.na(!!dbh) & !is.na(!!X) & !is.na(!!Y) & !is.na(!!ID))
# Error in `$<-.data.frame`(`*tmp*`, "X", value = 66.5) :
# le tableau de remplacement a 1 lignes, le tableau remplacé en a 0
#The one with the biggest dbh will stay there for being to heavy lol
ngros <- focus %>% filter(!!dbh == max(focus %>% dplyr::select(!!dbh))) %>% nrow()
if(ngros == 1) {focus <- focus %>% filter(!!dbh != max(focus %>% dplyr::select(!!dbh))) %>%
arrange(desc(!!dbh))}
else
{
spl <- focus %>% filter(!!dbh == max(focus %>% dplyr::select(!!dbh))) %>% sample_n(size = ngros-1, replace = FALSE)
focus <- focus %>% filter(!!dbh != max(focus %>% dplyr::select(!!dbh))) %>% rbind(spl) %>%
arrange(desc(!!dbh))
}
# Replacement -------------------------------------------------------------
# print(data[,which(names(data)== ID)])
## If the new coordinates are sufficiently numerous, then replace all trees..
IDcol_data <- which(names(data) == as.character(ID)[2])
if(nrow(newcoord) >= (count_conflicts$n[i]-1))
{
newcoord <- newcoord %>%
sample_n(size = (count_conflicts$n[i])-1, replace = FALSE)
focus$X <- newcoord$X
focus$Y <- newcoord$Y
for(k in 1:nrow(focus))
{
# to fix#
row_k <- which(data[,IDcol_data] == focus$ID[k])
data[row_k, as.character(X)[2]] <- focus$X[k]
data[row_k, as.character(Y)[2]] <- focus$Y[k]
# data[which(data[,which(names(data) == quo(ID))] == focus$ID[k]), quo(X)] <- focus$X[k]
# data[which(data[,which(names(data) == quo(ID))] == focus$ID[k]), quo(Y)] <- focus$Y[k]
}
}
else
{
if(nrow(newcoord)>0)
{
newcoord <- newcoord %>%
sample_n(size = nrow(newcoord), replace = FALSE)
tosuppr <- focus[(nrow(newcoord)+1):nrow(focus),]
focus <- focus[1:nrow(newcoord),]
focus$X <- newcoord$X
focus$Y <- newcoord$Y
for(k in 1:nrow(focus))
{
row_k <- which(data[,IDcol_data] == focus$ID[k])
data[row_k, as.character(X)[2]] <- focus$X[k]
data[row_k, as.character(Y)[2]] <- focus$Y[k]
}
for(s in 1:nrow(tosuppr))
{
row_s <- which(data[,IDcol_data] == tosuppr$ID[s])
data <- data[-row_s,]
}
}
else
{
for(s in 1:nrow(focus))
{
row_t <- which(data[,IDcol_data] == focus$ID[s])
data <- data[-row_t,]
}
}
}
# would we have to movethe bigger dbhs lesser than small dbhs in case the new coordinates differ in terms of distance to the old ones ?
}
# Return ! ----------------------------------------------------------------
return(data)
}
# # Test
# dat %>%
# dplyr::select(X, Y, dbh, i_arbre) %>%
# rename(Xcol = X, Ycol = Y, dbhcol = dbh) %>%
# replacement(Xcol, Ycol, dbhcol, i_arbre)
# # Dirty "Biggest dbh" keeping
#
# if(duplicated_method == "Dirty")
# {
# for (i in 1:nrow(forest))
# {
# if(forest$suppr[i] != T)
# {
# for (j in 1:nrow(forest))
# {
# if(forest[,which(names(forest)== X)][i] == forest[,which(names(forest)== X)][j] &&
# forest[,which(names(forest)== Y)][i] == forest[,which(names(forest)== Y)][j])
# {
# if(forest$suppr[j] != T && j!= i)
# {
# if(forest[,which(names(forest)== dbh)][i] > forest[,which(names(forest)== dbh)][j])
# {
# forest$suppr[j] <- T
# }
# else if(forest[,which(names(forest)== dbh)][j] > forest[,which(names(forest)== dbh)][i])
# {
# forest$suppr[i] <- T
# }
# else
# {
# forest$suppr[sample(x = c(i,j), 1)] <- T
# }
# }
# }
# }
# }
# }
# }
#
# else if(duplicated_method == "Strange")
# {
# forest <- replacement(forest)
# }
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.