R/line_clip.R

In EmilHvitfeldt/ggclipped: Add Special Case Geoms to 'ggplot2' Where Lines Overlap

#' Draw a rose or line_clip curve
#'
#' This geom allows you to draw the line_clip curve. A line_clip is a
#' curve traced by a point attached to a circle of radius r_min rolling around
#' the outside of a fixed circle of radius r_max, where the point is at a
#' distance h from the center of the interior circle. h is the same as r_min
#' by default.
#'
#' To unscale the curve, please set xscale and yscale to r_max + r_min + h.
#'
#' The curve follows the the parameterized form
#'
#' \deqn{x = (r_max + r_min) cos(\theta) - h * cos(\frac{r_max + r_min}{r_min} \theta)}
#' \deqn{x = (r_max + r_min) sin(\theta) - h * sin(\frac{r_max + r_min}{r_min} \theta)}
#'
#' these curves are closed when the radion \eqn{a / b} is rational. delta have
#' been scaled to be in the interval [0, 1].
#'
#' @references \url{http://mathworld.wolfram.com/line_clip.html}
#'     \url{http://xahlee.info/SpecialPlaneCurves_dir/line_clip_dir/line_clip.html}
#' @section Aesthetics:
#' geom_arc understand the following aesthetics (required aesthetics are in
#' bold):
#'
#' - **r_max**
#' - **r_min**
#' - h
#' - x0
#' - y0
#' - xscale
#' - yscale
#' - rotation
#' - color
#' - fill
#' - size
#' - linetype
#' - alpha
#' - lineend
#'
#' @section Computed variables:
#'
#' \describe{
#'  \item{x, y}{The coordinates for the points along the rose curve}
#' }
#'
#' @inheritParams ggplot2::geom_line
#' @inheritParams ggplot2::stat_identity
#'
#' @param clip_length Length of the clipped hole
#'
#' @author Emil Hvitfeldt
#'
#' @name geom_line_clip
#' @rdname geom_line_clip
#'
#' @examples
#' library(ggplot2)
#' data <- data.frame(rank = rep(0:1, 5),
#'                    time = rep(1:5, 2),
#'                    team = rep(0:1, each = 5))
#'
#' ggplot(data, aes(time, rank, color = factor(team))) +
#'   geom_line_clip(size = 2, clip_length = 0.05)
NULL

#' @rdname ggclipped-extensions
#' @format NULL
#' @usage NULL
#' @importFrom ggplot2 ggproto Stat aes
#' @export
StatLineClip <- ggproto('StatLineClip', Stat,
                        compute_layer = function(self, data, params, layout) {

                          if (is.null(data)) return(data)
                          data <- dplyr::arrange(data, group)

                          ddd <- as.matrix(data[c("x", "y", "group")])
                          meta <- dplyr::select(data, -x, -y)
                          ddd <- cbind(ddd, ref = ddd[, "group"])

                          start_index <- which(data$group > 1)[1]
                          group_index <- attr(data$group, "n") + 1

                          while (nrow(ddd) - start_index > 0) {
                            out_list <- list()
                            line_seq1 <- ddd[start_index + c(0, 1), ]
                            if (length(unique(line_seq1[, "group"])) > 1) {
                              start_index <- start_index + 1
                              next
                            }
                            step_index <- 1
                            while (start_index - step_index > 1) {
                              line_seq2 <- ddd[step_index + c(0, 1), ]
                              if (length(unique(line_seq2[, "group"])) > 1) {
                                step_index <- step_index + 1
                                next
                              }
                              x1 <- line_seq1[1, "x"]
                              x2 <- line_seq1[2, "x"]
                              x3 <- line_seq2[1, "x"]
                              x4 <- line_seq2[2, "x"]
                              y1 <- line_seq1[1, "y"]
                              y2 <- line_seq1[2, "y"]
                              y3 <- line_seq2[1, "y"]
                              y4 <- line_seq2[2, "y"]

                              convex_hull <- chull(rbind(line_seq1[, c("x", "y")], line_seq2[, c("x", "y")]))

                              cut <- unname(((y1 - y2) * (x1 - x3) + (x2 - x1) * (y1 - y3)) / ((x4 - x3) * (y1 - y2) - (x1 - x2) * (y4 - y3)))

                              if (cut > 0 && cut < 1 && !is.nan(cut) & (length(convex_hull) == 4)) {
                                seq_vector <- (line_seq2[2, c("x", "y")] - line_seq2[1, c("x", "y")])
                                mid_point <- seq_vector * cut

                                spacer <- seq_vector / sqrt(sum(seq_vector ^ 2)) * params$clip_length

                                cut1 <- cut2 <- line_seq2[1, ]
                                cut1[1:2] <- cut1[1:2] + mid_point - spacer
                                cut2[1:2] <- cut2[1:2] + mid_point + spacer
                                out <- rbind(line_seq2[1, ],
                                             cut1,
                                             cut2,
                                             line_seq2[2, ], deparse.level = 0)

                                out[, "group"] <- rep(group_index + 0:1, each = 2)

                                out_list <- c(out_list, list(out))

                                group_index <- group_index + 2


                                if (step_index != 1 & length(unique(ddd[step_index + c(0, -1), "group"])) == 1) {
                                  current_group <- ddd[step_index, "group"]
                                  ddd[seq(min(which(ddd[, "group"] == current_group)), step_index), "group"] <- group_index
                                  ddd[which(ddd[, "group"] == current_group), "group"] <- group_index + 1
                                  group_index <- group_index + 2
                                } else {
                                  ddd <- ddd[-step_index, ]
                                  start_index <- start_index - 1
                                  step_index <- step_index - 1
                                }
                              }

                              step_index <- step_index + 1
                            }

                            if (length(out_list) > 0) {
                              preend <- purrr::reduce(out_list, rbind)
                              ddd <- rbind(preend, ddd)
                              start_index <- start_index + nrow(preend)
                            }
                            start_index <- start_index + 1
                          }

                            data <- as.data.frame(ddd)
                            data <- dplyr::mutate(data, ref = as.integer(ref))
                            data <- suppressWarnings(dplyr::left_join(data, meta, by = c("ref" = "group")))
                            data <- dplyr::select(data, -ref)
                            data <- dplyr::distinct(data)

                          for (i in which(duplicated(dplyr::select(data, x, y)))) {
                            i_match <- intersect(
                              which(data[, "x"] == data[i, "x"]),
                              which(data[, "y"] == data[i, "y"])
                            )
                            i_match <- setdiff(i_match, i)

                            join_groups <- data[c(i_match, i), "group"]
                            data[data[, "group"] %in% join_groups, "group"] <- join_groups[1]
                          }

                          data
                        },
                        extra_params = c('clip_length')
)

#' @rdname geom_line_clip
#' @importFrom ggplot2 layer
#' @export
stat_line_clip <- function(mapping = NULL, data = NULL, geom = "line_clip",
                           position = "identity", clip_length = 0.1, show.legend = NA,
                           inherit.aes = TRUE, ...) {
  layer(
    stat = StatLineClip, data = data, mapping = mapping, geom = geom,
    position = position, show.legend = show.legend, inherit.aes = inherit.aes,
    params = list(clip_length = clip_length, ...)
  )
}

#' @rdname geom_line_clip
#' @importFrom ggplot2 layer GeomLine
#' @export
geom_line_clip <- function(mapping = NULL, data = NULL, stat = "line_clip",
                           position = "identity", clip_length = 0.1,
                           show.legend = NA, inherit.aes = TRUE, ...) {
  layer(data = data, mapping = mapping, stat = stat, geom = GeomLine,
        position = position, show.legend = show.legend, inherit.aes = inherit.aes,
        params = list(clip_length = clip_length, ...))
}