R/build_forest_profile.R

In fractalforest: Simulate Fractal Trees and Forests

#' Construct a 2D Forest Profile Using L-System Trees from Inventory Data.
#'
#' @param data A data frame containing forest inventory data (field-measured or simulated). Each row represents an individual tree.
#' @param height Name of the column (character) containing tree heights, measured in meters.
#' @param diameter Name of the column (character) containing tree diameters, measured in centimeters.
#' @param label Name of the column (character) containing tree labels or unique IDs.
#' @param string The column (character) or string containing turtle graphics instructions generated by the `iterate_lsystem` function. If NULL (default), the `tree_model` argument is used to create instructions.
#' @param tree_model The predefined tree model to use when `string` is NULL. Accepts either an integer or a character string corresponding to a model name (e.g., 'binary_tree'). See `fractal_tree_model()` for details.
#' @param n_iter An integer specifying the number of iterations to generate the `tree_model` when `string` is NULL. Defaults to model-specific settings.
#' @param angle A numeric value specifying the branching angle (in degrees). Default is 15.
#' @param crown_diameter Column name (unquoted) or numeric value for the crown diameter of the trees. Default is NULL.
#' @param h_reduction A numeric value representing the reduction factor applied to branch lengths. Default is the golden ratio (\eqn{(1+\sqrt{5})/2 - 1}).
#' @param d_reduction A numeric value representing the reduction factor applied to branch diameters. Default is the golden ratio (\eqn{(1+\sqrt{5})/2 - 1}).
#' @param randomness A logical value. If set to TRUE, randomness is introduced to the branch angles. Default is FALSE.
#' @param angle_cv A numeric value specifying the coefficient of variation for branch angles, applied when `randomness` is set to TRUE. Default is 0.1.
#' @param length_cv A numeric value specifying the coefficient of variation for branch lengths, applied when `randomness` is set to TRUE. Default is 0.1.
#' @param leaf_size An unquoted column name or a numeric value specifying the size of the leaves. Defaults to NULL, in which case the `d_reduction` value is used.
#' @param sample A logical value. If TRUE, rows are sampled from data to construct the forest. The default is TRUE.
#' @param n_trees An integer specifying the number of trees to sample when `sample` is set to TRUE..
#' @param dist A numeric value representing the average linear distance between trees. The default is 3.
#' @param dist_cv A numeric value representing the coefficient of variation for tree distances. The default is 0.3.
#'
#' @details
#' - When `string` is specified, it must be a column in `data` containing turtle graphics strings for each tree.
#' - If `sample` is TRUE, `n_trees` must be provided.
#'
#' @return A data frame containing the 2D forest profile data, with individual tree id, component coordinates, component types, labels and diameters.
#'
#' @importFrom magrittr %>%
#' @importFrom stats rnorm
#' @importFrom purrr detect_index
#' @importFrom rlang :=
#' @export
#'
#' @examples
#' # Example data
#' data <- data.frame(
#'   height = c(10, 12, 14, 12, 18, 15, 13, 16, 10, 8, 10, 7),
#'   diameter = c(12, 15, 11, 17, 25, 18, 10, 21, 12, 10, 10, 11),
#'   label = c("Tree1", "Tree2", "Tree3","Tree4", "Tree5", "Tree6",
#'             "Tree7", "Tree8", "Tree9", "Tree10", "Tree11", "Tree12")
#' )
#'
#' # Build forest profile
#' build_forest_profile(
#'   data = data,
#'   height = height,
#'   diameter = diameter,
#'   label = label,
#'   tree_model = "binary_tree",
#'   n_trees = 3
#' )
#' @export
build_forest_profile <- function(data,
                                 height, diameter, label,
                                 string = NULL, tree_model = "binary_tree", n_iter = NULL,
                                 angle = 15, crown_diameter = NULL,
                                 h_reduction = (1 + sqrt(5)) / 2 - 1, d_reduction = (1 + sqrt(5)) / 2 - 1,
                                 randomness = FALSE, angle_cv = 0.1, length_cv = 0.1, leaf_size = NULL,
                                 sample = TRUE, n_trees,
                                 dist = 3, dist_cv = 0) {

  if(sample){
    smp <- sample(1:nrow(data), n_trees, replace = TRUE)

    full_df <- data[smp, ]
  }
  else{
    full_df <- data

    n_trees <- nrow(full_df)
  }

  # required columns
  diameter <- rlang::ensym(diameter)
  height <- rlang::ensym(height)
  label <- rlang::ensym(label)

  # null, char or column
  string <- rlang::enquo(string)

  if(rlang::quo_is_null(string)){

    if(is.null(n_iter)){
      strings <- replicate(fractalforest::fractal_tree_model(tree_model), n = n_trees)
    }
    else{
      strings <- replicate(fractalforest::fractal_tree_model(tree_model, n_iter = n_iter), n = n_trees)
    }

    full_df <- full_df %>%
      dplyr::mutate(..string.. = strings)

  }
  else if(rlang::quo_is_symbol(string)){
    string <- rlang::ensym(string)
    full_df <- full_df %>%
      dplyr::mutate(..string.. = !!string)
  }
  else{
    string <- rlang::as_name(string)
    full_df <- full_df %>%
      dplyr::mutate(..string.. = string)
  }

  # null, integer or column
  leaf_size <- rlang::enquo(leaf_size)
  if(rlang::quo_is_null(leaf_size)){
    full_df <- full_df %>%
      dplyr::mutate(..leaf_size.. = NA)
  }
  else if(rlang::quo_is_symbol(leaf_size)){
    leaf_size <- rlang::ensym(leaf_size)
    full_df <- full_df %>%
      dplyr::mutate(..leaf_size.. = !!leaf_size)
  }
  else{
    leaf_size <- rlang::quo_squash(leaf_size)
    if(!is.numeric(leaf_size)){stop('`leaf_size` must be numeric.')}
    full_df <- full_df %>%
      dplyr::mutate(..leaf_size.. = leaf_size)
  }

  # null or column
  crown_diameter <- rlang::enquo(crown_diameter)
  if(rlang::quo_is_null(crown_diameter)){
    full_df <- full_df %>%
      dplyr::mutate(..crown_diameter.. = NA)
  }
  else{
    crown_diameter <- rlang::ensym(crown_diameter)
    full_df <- full_df %>%
      dplyr::mutate(..crown_diameter.. = !!crown_diameter)
  }

  # logical or column
  randomness <- rlang::enquo(randomness)
  if(rlang::quo_is_symbol(randomness)){
    randomness <- rlang::ensym(randomness)
    full_df <- full_df %>%
      dplyr::mutate(..randomness.. = !!randomness)

    if(!is.logical(full_df$..randomness..)){stop('`randomness` must be logical.')}

  }
  else{

    randomness <- rlang::quo_squash(randomness)

    if(!is.logical(randomness)){stop('`randomness` must be logical.')}

    full_df <- full_df %>%
      dplyr::mutate(..randomness.. = randomness)
  }

  # numeric or column
  angle <- rlang::enquo(angle)
  if(rlang::quo_is_symbol(angle)){
    angle <- rlang::ensym(angle)
    full_df <- full_df %>%
      dplyr::mutate(..angle.. = !!angle)

    if(!is.numeric(full_df$..angle..)){stop('`angle` must be numeric.')}

  }
  else{
    angle <- rlang::quo_squash(angle)

    if(!is.numeric(angle)){stop('`angle` must be numeric.')}

    full_df <- full_df %>%
      dplyr::mutate(..angle.. = angle)
  }

  h_reduction <- h_reduction
  h_reduction <- rlang::enquo(h_reduction)
  if(rlang::quo_is_symbol(h_reduction)){
    h_reduction <- rlang::ensym(h_reduction)
    full_df <- full_df %>%
      dplyr::mutate(..h_reduction.. = !!h_reduction)

    if(!is.numeric(full_df$..h_reduction..)){stop('`h_reduction` must be numeric.')}

  }
  else{
    h_reduction <- rlang::quo_squash(h_reduction)

    if(!is.numeric(h_reduction)){stop('`h_reduction` must be numeric.')}

    full_df <- full_df %>%
      dplyr::mutate(..h_reduction.. = h_reduction)
  }

  d_reduction <- d_reduction
  d_reduction <- rlang::enquo(d_reduction)
  if(rlang::quo_is_symbol(d_reduction)){
    d_reduction <- rlang::ensym(d_reduction)
    full_df <- full_df %>%
      dplyr::mutate(..d_reduction.. = !!d_reduction)

    if(!is.numeric(full_df$..d_reduction..)){stop('`d_reduction` must be numeric.')}

  }
  else{
    d_reduction <- rlang::quo_squash(d_reduction)

    if(!is.numeric(d_reduction)){stop('`d_reduction` must be numeric.')}

    full_df <- full_df %>%
      dplyr::mutate(..d_reduction.. = d_reduction)
  }

  angle_cv <- rlang::enquo(angle_cv)
  if(rlang::quo_is_symbol(angle_cv)){
    angle_cv <- rlang::ensym(angle_cv)
    full_df <- full_df %>%
      dplyr::mutate(..angle_cv.. = !!angle_cv)

    if(!is.numeric(full_df$..angle_cv..)){stop('`angle_cv` must be numeric.')}

  }
  else{
    angle_cv <- rlang::quo_squash(angle_cv)

    if(!is.numeric(angle_cv)){stop('`angle_cv` must be numeric.')}

    full_df <- full_df %>%
      dplyr::mutate(..angle_cv.. = angle_cv)
  }

  length_cv <- rlang::enquo(length_cv)
  if(rlang::quo_is_symbol(length_cv)){
    length_cv <- rlang::ensym(length_cv)
    full_df <- full_df %>%
      dplyr::mutate(..length_cv.. = !!length_cv)

    if(!is.numeric(full_df$..length_cv..)){stop('`length_cv` must be numeric.')}

  }
  else{
    length_cv <- rlang::quo_squash(length_cv)

    if(!is.numeric(length_cv)){stop('`length_cv` must be numeric.')}

    full_df <- full_df %>%
      dplyr::mutate(..length_cv.. = length_cv)
  }

    df <- full_df %>%
      dplyr::select(
        !!diameter,
        !!height,
        !!label,
        ..string..,
        ..angle..,
        ..crown_diameter..,
        ..h_reduction..,
        ..d_reduction..,
        ..randomness..,
        ..angle_cv..,
        ..length_cv..,
        ..leaf_size..
      )

  ac_dist <- 0
  nx <- 0
  forest_df <- df %>%
    dplyr::rowwise() %>%
    dplyr::group_split() %>%
    lapply(function(x){
      nx <<- nx + 1

      xd <- x %>% dplyr::pull(!!diameter)
      xh <- x %>% dplyr::pull(!!height)
      xl <- x %>% dplyr::pull(!!label)

      lsp <- x %>% dplyr::pull(..string..)

      xang <- x %>% dplyr::pull(..angle..)
      xcrdiam <- x %>% dplyr::pull(..crown_diameter..)
      xhred <- x %>% dplyr::pull(..h_reduction..)
      xdred <- x %>% dplyr::pull(..d_reduction..)
      xrand <- x %>% dplyr::pull(..randomness..)
      xangcv <- x %>% dplyr::pull(..angle_cv..)
      xlencv <- x %>% dplyr::pull(..length_cv..)
      xlfsz <-  x %>% dplyr::pull(..leaf_size..)

      if(is.na(xlfsz)){xlfsz <- NULL}
      if(is.na(xcrdiam)){xcrdiam <- NULL}

      tree_df <- fractalforest::build_tree(string = lsp, height = xh, diameter = xd, angle = xang,
                            randomness = xrand, crown_diameter = xcrdiam, h_reduction = xhred,
                            d_reduction = xdred, angle_cv = xangcv, length_cv = xlencv,leaf_size = xlfsz)

      tree_df <- tree_df %>%
        dplyr::mutate(!!label := xl,
               from_x = from_x + ac_dist,
               to_x = to_x + ac_dist,
               tree_id = nx)

      ac_dist <<- ac_dist + rnorm(1, dist, dist*dist_cv)

      message("Building tree ", nx, " of ", n_trees, '\r',appendLF=FALSE)
      flush.console()
      return(tree_df)

    }) %>%
    dplyr::bind_rows()

  return(forest_df)

}