R/build_tree.R

In fractalforest: Simulate Fractal Trees and Forests

#' Build a 2D L-System Tree Using Turtle Graphics
#'
#' This function generates a 2D representation of a tree using L-system string instructions and turtle graphics.
#' The tree structure is determined by the L-system string, and various parameters control the shape, size, and randomness of the tree's growth.
#'
#' @param string A character vector containing the turtle graphics instructions, typically generated by the `iterate_lsystem` function.
#' @param height A numeric value specifying the total height of the plant, in meters.
#' @param diameter A numeric value specifying the base diameter of the plant, in centimeters.
#' @param crown_diameter A numeric value specifying the diameter of the plant crown, in meters.
#' @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 angle A numeric value specifying the branching angle (in degrees). Default is 15.
#' @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.
#'
#' @importFrom magrittr %>%
#' @importFrom stats rnorm
#' @importFrom purrr detect_index
#'
#' @return A data frame containing the 2D tree profile data (component coordinates and types).
#'
#' @export
build_tree <- function (string = NULL, angle = 15,
                        height = NULL, diameter = NULL, crown_diameter = NULL,
                        h_reduction = (1+sqrt(5))/2-1, d_reduction = (1+sqrt(5))/2-1,
                        randomness = FALSE, angle_cv = .1, length_cv = .1, leaf_size = NULL) {

  uniques <- strsplit(string, "") %>% unlist() %>% unique()

  Fs <- uniques[which(!uniques %in% c("+", "-", "[", "]", "(", ")"))]

  drules <- data.frame(sym = uniques) %>%
    dplyr::mutate(action = dplyr::if_else(sym %in% Fs, "F", sym))

  sring <- unlist(strsplit(string, ""))
  for (i in 1:nrow(drules)) {
    for (j in 1:length(sring)) {
      if (sring[[j]] == drules$sym[i])
        sring[[j]] <- drules$action[i]
    }
  }
  st <- c(0, 0, 90)
  cp <- st
  ch <- st[3]

  fifo <- vector("list")
  prop_red <- vector("list")
  ns <- 0L
  pr <- c(1, 1)

  angle_sd <- angle * angle_cv

  n <- 0

  sring <- sring %>% paste0(collapse='') %>%
    stringi::stri_replace_all_fixed('[',';[;') %>%
    stringi::stri_replace_all_fixed(']',';];') %>%
    stringi::stri_replace_all_fixed('+',';+;') %>%
    stringi::stri_replace_all_fixed('-',';-;') %>%
    stringi::stri_replace_all_fixed('(',';(;') %>%
    stringi::stri_replace_all_fixed(')',';);') %>%
    stringr::str_split(pattern = ';') %>%
    unlist() %>%
    lapply(.,
           function(x){
             if(!x %in% c('[',']','+','-','(',')','')){
               return(nchar(x))
             }
             else{x}
           }
    ) %>%
    paste0(collapse = '') %>%
    stringi::stri_replace_all_fixed('[',';[;') %>%
    stringi::stri_replace_all_fixed(']',';];') %>%
    stringi::stri_replace_all_fixed('+',';+;') %>%
    stringi::stri_replace_all_fixed('-',';-;') %>%
    stringi::stri_replace_all_fixed('(',';(;') %>%
    stringi::stri_replace_all_fixed(')',';);') %>%
    stringr::str_split(pattern = ';') %>%
    unlist()

  suppressWarnings({
  sring <- sring[-which(sring == '')] %>% as.list()
  output <- vector("list", length(which(!is.na(as.numeric(sring)))))

  if(is.null(height)){
    height <- 1
  }
  if(is.null(diameter)){
    size <- 1
  }
  else(size <- diameter)

  for (j in 1:length(sring)) {

    if (!is.na(as.numeric(sring[[j]]))) {
      n <- n+1

      step <- as.numeric(sring[[j]]) * pr[1]

      if(randomness){ step <- stats::rnorm(1, step, step * length_cv)}

      x <- cp[1] + step * cos(ch * pi/180)
      y <- cp[2] + step * sin(ch * pi/180)

      d <- size * pr[2]


      if(
        j == length(sring) # if is the last element, is a leaf
      ){
        tp <- 'leaf'
        if(!is.null(leaf_size)){
          d <- leaf_size
        }
      }
      else if(
        purrr::detect_index(sring[(j+1):length(sring)], fractalforest::is_pop_symbol) == 0 | #if there is no bracket forward, is a leaf
        sring[(j+1):length(sring)] %>% purrr::detect_index(fractalforest::is_branch_symbol) == 0 | # if there is no segment forward, is a leaf
        (sring[(j+1):length(sring)] %>% purrr::detect_index(is_pop_symbol) < sring[(j+1):length(sring)] %>% purrr::detect_index(fractalforest::is_branch_symbol)) # if the next bracket is comes before the next segment, is a leaf
      ){
        tp <- 'leaf'
        if(!is.null(leaf_size)){
          d <- leaf_size
        }
      }
      else{
        tp <- 'branch'
      }

      output[[n]] <- list(from_x = cp[1], to_x = x, from_y = cp[2], to_y = y, diameter = d, type = tp)
      cp <- c(x, y)
    }

    else if (sring[[j]] == "[") {

      ns <- ns + 1
      fifo[[ns]] <- c(cp, ch)

    }

    else if (sring[[j]] == "]") {
      cp <- fifo[[ns]][1:2]
      ch <- fifo[[ns]][3]

      ns <- ns - 1

    }

    else if (sring[[j]] == "-"){
      if(randomness){ang_j <- stats::rnorm(1, angle, angle_sd)}
      else{ang_j <- angle}
      ch = ch - ang_j}

    else if (sring[[j]] == "+") {
      if(randomness){ang_j <- rnorm(1, angle, angle_sd)}
      else{ang_j <- angle}
      ch = ch + angle
    }

    else if (sring[[j]] == "(") {

      pr[1] <- pr[1] * h_reduction
      pr[2] <- pr[2] * d_reduction

    }

    else if (sring[[j]] == ")") {

      pr[1] <- pr[1] / h_reduction
      pr[2] <- pr[2] / d_reduction

    }

  }
  })

  df <- output %>% dplyr::bind_rows()

  hfac <- (max(df$to_y)-min(df$from_y))/height
  if(is.null(crown_diameter)){
    df[,1:4] <- df[,1:4]/hfac
  }
  else{
    dfac <- (max(df$to_x)-min(df$from_x))/crown_diameter
    df[,1:2] <- df[,1:2]/dfac
    df[,3:4] <- df[,3:4]/hfac
  }

  if(is.null(diameter)){
    df <- df[,-5]
  }

  return(df)

}