R/draw_lines.R

In ggsem: Interactive Structural Equation Modeling (SEM) and Multi-Group Path Diagrams

#' Draw Lines on a ggplot Object from Line Data
#' @description
#' This function overlays lines or arrows to a ggplot object based on line data. It supports straight lines, curved lines, gradient color transitions, and one-way or two-way arrows. The data can come from a CSV file generated by the ggsem Shiny app or custom input.
#' @param lines_data A data frame containing line information. The expected columns include:
#' \itemize{
#'   \item \code{x_start}, \code{y_start}: Starting coordinates of the line.
#'   \item \code{x_end}, \code{y_end}: Ending coordinates of the line.
#'   \item \code{ctrl_x}, \code{ctrl_y}: Control points for curved lines (optional).
#'   \item \code{type}: Type of line (\code{"Straight Line"}, \code{"Curved Line"}, \code{"Straight Arrow"}, or \code{"Curved Arrow"}).
#'   \item \code{color}: Start color of the line (hexadecimal color code).
#'   \item \code{end_color}: End color of the line for gradients (hexadecimal color code).
#'   \item \code{color_type}: \code{"Gradient"} for gradient lines, or \code{"Single"} for solid-colored lines.
#'   \item \code{gradient_position}: Position of the gradient transition along the line (numeric, 0 to 1).
#'   \item \code{width}: Width of the line (numeric).
#'   \item \code{alpha}: Transparency of the line (numeric, 0 to 1).
#'   \item \code{arrow}: Logical, whether an arrowhead is used.
#'   \item \code{arrow_type}: Type of arrow (\code{"open"}, \code{"closed"}, etc.).
#'   \item \code{arrow_size}: Size of the arrowhead.
#'   \item \code{two_way}: Logical, whether the line has two arrowheads (bidirectional).
#'   \item \code{line_style}: Line style (\code{"solid"}, \code{"dashed"}, or \code{"dotted"}).
#' }
#' @param zoom_level Numeric. Adjusts the size of line widths and arrowheads relative to the plot. Default is \code{1}.
#' @param n Integer. Number of points for interpolation in gradient or curved lines. Default is \code{100}.
#' @return
#' ggplot2 line layers
#' @export
#' @importFrom ggplot2 annotate arrow unit
#' @importFrom grDevices colorRampPalette
#' @examples
#' library(ggplot2)
#'
#' lines_df <- data.frame(
#' x_start = 11, y_start = -2.3, x_end = 21, y_end = 3.5,
#' ctrl_x = NA, ctrl_y = NA, ctrl_x2 = NA, ctrl_y2 = NA,
#' curvature_magnitude = NA, rotate_curvature = NA,
#' curvature_asymmetry = NA, type = 'Straight Line',
#' color = '#000000', end_color = NA, color_type = 'Single',
#' gradient_position = NA, width = 1, alpha = 1, arrow = TRUE,
#' arrow_type = 'closed', arrow_size = 0.1, two_way = FALSE,
#' lavaan = FALSE, network = FALSE, line_style = 'solid',
#' locked = FALSE, group = 1
#' )
#'
#' p <- ggplot()
#'
#' p + draw_lines(lines_data = lines_df, zoom_level = 1.2, n = 200)
#'

draw_lines <- function(lines_data, zoom_level = 1, n = 100) {
  if (nrow(lines_data) == 0) return(list())

  # Input validation
  lines_data$color <- sapply(lines_data$color, valid_hex)
  lines_data$end_color <- sapply(lines_data$end_color, valid_hex)
  lines_data$line_style <- sapply(lines_data$line_style, valid_line_style)
  lines_data$alpha <- sapply(lines_data$alpha, valid_alpha)
  lines_data$gradient_position <- sapply(lines_data$gradient_position, valid_gradient_position)
  lines_data$type <- sapply(lines_data$type, valid_type)
  lines_data$locked <- sapply(lines_data$locked, valid_logical)

  # Process each line and collect layers
  layers <- lapply(1:nrow(lines_data), function(i) {
    line_type <- lines_data$type[i]
    start_color <- lines_data$color[i]
    end_color <- if (length(lines_data$color_type[i]) > 0 && lines_data$color_type[i] == "Gradient") {
      lines_data$end_color[i]
    } else {
      start_color
    }

    gradient_position <- if (!is.null(lines_data$gradient_position[i]) &&
                             length(lines_data$gradient_position[i]) > 0) {
      lines_data$gradient_position[i]
    } else {
      1
    }

    if (is.null(line_type) || length(line_type) == 0) return(NULL)

    adjusted_line_width <- lines_data$width[i] / zoom_level
    adjusted_arrow_size <- if (!is.na(lines_data$arrow_size[i]) &&
                               lines_data$type[i] %in% c('Straight Arrow', 'Curved Arrow')) {
      lines_data$arrow_size[i] / zoom_level
    } else {
      NA
    }

    line_layers <- list()

    if (line_type == "Straight Line" || line_type == "Straight Arrow") {
      if (!is.null(lines_data$x_start[i]) && !is.null(lines_data$x_end[i])) {
        if (lines_data$color_type[i] == "Gradient") {
          straight_points <- interpolate_points(
            x_start = lines_data$x_start[i], y_start = lines_data$y_start[i],
            x_end = lines_data$x_end[i], y_end = lines_data$y_end[i]
          )

          n_points <- nrow(straight_points)
          split_index <- round(gradient_position * n_points)

          color_interpolator <- colorRampPalette(c(start_color, end_color))
          intermediate_color <- color_interpolator(3)[2]

          gradient_colors_start <- colorRampPalette(c(start_color, intermediate_color))(split_index)
          gradient_colors_end <- colorRampPalette(c(intermediate_color, end_color))(n_points - split_index + 1)

          # Add gradient segments
          for (j in 1:(split_index - 1)) {
            line_layers[[length(line_layers) + 1]] <- annotate(
              "segment",
              x = straight_points$x[j], y = straight_points$y[j],
              xend = straight_points$x[j + 1], yend = straight_points$y[j + 1],
              color = gradient_colors_start[j],
              linewidth = adjusted_line_width,
              alpha = lines_data$alpha[i]
            )
          }

          for (j in split_index:(n_points - 1)) {
            line_layers[[length(line_layers) + 1]] <- annotate(
              "segment",
              x = straight_points$x[j], y = straight_points$y[j],
              xend = straight_points$x[j + 1], yend = straight_points$y[j + 1],
              color = gradient_colors_end[j - split_index + 1],
              linewidth = adjusted_line_width,
              alpha = lines_data$alpha[i]
            )
          }
        } else {
          # Single color line
          line_layers[[length(line_layers) + 1]] <- annotate(
            "segment",
            x = lines_data$x_start[i], y = lines_data$y_start[i],
            xend = lines_data$x_end[i], yend = lines_data$y_end[i],
            color = start_color,
            linewidth = adjusted_line_width,
            alpha = lines_data$alpha[i],
            linetype = lines_data$line_style[i]
          )
        }

        # Add arrowhead if needed
        arrow_type <- lines_data$arrow_type[i]
        if (!is.null(arrow_type) && !is.na(adjusted_arrow_size)) {
          dx <- lines_data$x_end[i] - lines_data$x_start[i]
          dy <- lines_data$y_end[i] - lines_data$y_start[i]
          norm <- sqrt(dx^2 + dy^2)

          x_adjust_end <- lines_data$x_end[i] - 0.01 * dx / norm
          y_adjust_end <- lines_data$y_end[i] - 0.01 * dy / norm

          if (lines_data$two_way[i]) {
            x_adjust_start <- lines_data$x_start[i] + 0.01 * dx / norm
            y_adjust_start <- lines_data$y_start[i] + 0.01 * dy / norm

            line_layers[[length(line_layers) + 1]] <- annotate(
              "segment",
              x = x_adjust_start, y = y_adjust_start,
              xend = lines_data$x_start[i], yend = lines_data$y_start[i],
              linewidth = adjusted_line_width,
              alpha = lines_data$alpha[i],
              arrow = arrow(type = arrow_type, length = unit(adjusted_arrow_size, "inches")),
              color = if (lines_data$color_type[i] == "Gradient") gradient_colors_start[1] else start_color
            )
          }

          line_layers[[length(line_layers) + 1]] <- annotate(
            "segment",
            x = x_adjust_end, y = y_adjust_end,
            xend = lines_data$x_end[i], yend = lines_data$y_end[i],
            linewidth = adjusted_line_width,
            alpha = lines_data$alpha[i],
            arrow = arrow(type = arrow_type, length = unit(adjusted_arrow_size, "inches")),
            color = if (lines_data$color_type[i] == "Gradient") gradient_colors_end[length(gradient_colors_end)] else end_color
          )
        }
      }
    }

    if (line_type == "Curved Line" || line_type == "Curved Arrow") {
      if (!is.null(lines_data$ctrl_x[i]) && !is.null(lines_data$ctrl_y[i])) {
        bezier_points <- create_bezier_curve(
          x_start = lines_data$x_start[i], y_start = lines_data$y_start[i],
          x_end = lines_data$x_end[i], y_end = lines_data$y_end[i],
          ctrl_x = lines_data$ctrl_x[i], ctrl_y = lines_data$ctrl_y[i],
          ctrl_x2 = lines_data$ctrl_x2[i], ctrl_y2 = lines_data$ctrl_y2[i]
        )

        if (lines_data$color_type[i] == "Gradient") {
          n_points <- nrow(bezier_points)
          split_index <- round(gradient_position * n_points)
          color_interpolator <- colorRampPalette(c(start_color, end_color))
          intermediate_color <- color_interpolator(3)[2]

          gradient_colors_start <- colorRampPalette(c(start_color, intermediate_color))(split_index)
          gradient_colors_end <- colorRampPalette(c(intermediate_color, end_color))(n_points - split_index + 1)

          # Add gradient path segments
          for (j in 1:(split_index - 1)) {
            line_layers[[length(line_layers) + 1]] <- annotate(
              "path",
              x = bezier_points$x[j:(j + 1)],
              y = bezier_points$y[j:(j + 1)],
              color = gradient_colors_start[j],
              linewidth = adjusted_line_width,
              alpha = lines_data$alpha[i]
            )
          }

          for (j in split_index:(n_points - 1)) {
            line_layers[[length(line_layers) + 1]] <- annotate(
              "path",
              x = bezier_points$x[j:(j + 1)],
              y = bezier_points$y[j:(j + 1)],
              color = gradient_colors_end[j - split_index + 1],
              linewidth = adjusted_line_width,
              alpha = lines_data$alpha[i]
            )
          }
        } else {
          line_layers[[length(line_layers) + 1]] <- annotate(
            "path",
            x = bezier_points$x,
            y = bezier_points$y,
            color = start_color,
            linewidth = adjusted_line_width,
            alpha = lines_data$alpha[i],
            linetype = lines_data$line_style[i]
          )
        }

        # Add arrowhead for curved lines if needed
        arrow_type <- lines_data$arrow_type[i]
        if (line_type == "Curved Arrow" && !is.null(arrow_type) && !is.na(adjusted_arrow_size)) {
          dx_end <- bezier_points$x[nrow(bezier_points)] - bezier_points$x[nrow(bezier_points) - 1]
          dy_end <- bezier_points$y[nrow(bezier_points)] - bezier_points$y[nrow(bezier_points) - 1]
          norm_end <- sqrt(dx_end^2 + dy_end^2)

          if (lines_data$two_way[i]) {
            dx_start <- bezier_points$x[2] - bezier_points$x[1]
            dy_start <- bezier_points$y[2] - bezier_points$y[1]
            norm_start <- sqrt(dx_start^2 + dy_start^2)

            line_layers[[length(line_layers) + 1]] <- annotate(
              "segment",
              x = bezier_points$x[1], y = bezier_points$y[1],
              xend = bezier_points$x[1] - dx_start / norm_start * 1e-5,
              yend = bezier_points$y[1] - dy_start / norm_start * 1e-5,
              linewidth = adjusted_line_width,
              arrow = arrow(type = arrow_type, length = unit(adjusted_arrow_size, "inches")),
              color = if (lines_data$color_type[i] == "Gradient") gradient_colors_start[1] else start_color
            )
          }

          line_layers[[length(line_layers) + 1]] <- annotate(
            "segment",
            x = bezier_points$x[nrow(bezier_points)], y = bezier_points$y[nrow(bezier_points)],
            xend = bezier_points$x[nrow(bezier_points)] + dx_end / norm_end * 1e-5,
            yend = bezier_points$y[nrow(bezier_points)] + dy_end / norm_end * 1e-5,
            linewidth = adjusted_line_width,
            arrow = arrow(type = arrow_type, length = unit(adjusted_arrow_size, "inches")),
            color = if (lines_data$color_type[i] == "Gradient") gradient_colors_end[length(gradient_colors_end)] else end_color
          )
        }
      }
    }

    return(line_layers)
  })

  # Flatten the list of layers
  unlist(layers, recursive = FALSE)
}