dev/R_ggraph/geom_edge_elbow.R

In kbodwin/longnet: What the Package Does (One Line, Title Case)

#' Draw edges as elbows
#'
#' This geom draws edges as an angle in the same manner as known from classic
#' dendrogram plots of hierarchical clustering results. In case a circular
#' transformation has been applied the first line segment will be drawn as an
#' arc as expected. This geom is only applicable to layouts that return a
#' direction for the edges (currently [layout_tbl_graph_dendrogram()],
#' [layout_tbl_graph_partition()] and
#' [layout_tbl_graph_igraph()] with the `"tree"` algorithm).
#'
#' @inheritSection geom_edge_link Edge variants
#' @inheritSection geom_edge_link Edge aesthetic name expansion
#'
#' @section Aesthetics:
#' `geom_edge_elbow` and `geom_edge_elbow0` understand the following
#' aesthetics. Bold aesthetics are automatically set, but can be overridden.
#'
#' - **x**
#' - **y**
#' - **xend**
#' - **yend**
#' - **circular**
#' - **direction**
#' - edge_colour
#' - edge_width
#' - edge_linetype
#' - edge_alpha
#' - filter
#'
#' `geom_edge_elbow2` understand the following aesthetics. Bold aesthetics are
#' automatically set, but can be overridden.
#'
#' - **x**
#' - **y**
#' - **group**
#' - **circular**
#' - **direction**
#' - edge_colour
#' - edge_width
#' - edge_linetype
#' - edge_alpha
#' - filter
#'
#' `geom_edge_elbow` and `geom_edge_elbow2` furthermore takes the following
#' aesthetics.
#'
#' - start_cap
#' - end_cap
#' - label
#' - label_pos
#' - label_size
#' - angle
#' - hjust
#' - vjust
#' - family
#' - fontface
#' - lineheight
#'
#' @section Computed variables:
#'
#' \describe{
#'  \item{index}{The position along the path (not computed for the *0 version)}
#' }
#'
#' @inheritParams geom_edge_link
#' @inheritParams ggplot2::geom_path
#' @inheritParams geom_edge_diagonal
#'
#' @author Thomas Lin Pedersen
#'
#' @family geom_edge_*
#'
#' @examples
#' require(tidygraph)
#' irisDen <- hclust(dist(iris[1:4], method='euclidean'), method='ward.D2') %>%
#'   as_tbl_graph() %>%
#'   mutate(class = sample(letters[1:3], n(), TRUE)) %>%
#'   activate(edges) %>%
#'   mutate(class = sample(letters[1:3], n(), TRUE))
#'
#' ggraph(irisDen, 'dendrogram', circular = TRUE) +
#'   geom_edge_elbow(aes(alpha = ..index..))
#'
#' ggraph(irisDen, 'dendrogram') +
#'   geom_edge_elbow2(aes(colour = node.class))
#'
#' ggraph(irisDen, 'dendrogram', height = height) +
#'   geom_edge_elbow0(aes(colour = class))
#'
#' @rdname geom_edge_elbow
#' @name geom_edge_elbow
#'
NULL

#' @rdname ggraph-extensions
#' @format NULL
#' @usage NULL
#' @importFrom ggforce radial_trans
#' @export
StatEdgeElbow <- ggproto('StatEdgeElbow', Stat,
    compute_panel = function(data, scales, flipped = FALSE, n = 100) {
        if (data$circular[1] && n %% 2 == 1) {
            n <- n + 1
        }
        if (!data$circular[1] && n %% 2 == 0) {
            n <- n + 1
        }
        index <- seq(0, 1, length.out = n)
        if (any(data$circular)) {
            circId <- which(data$circular)
            dataCirc <- data[circId, ]
            radial <- radial_trans(c(0, 1), c(2*pi, 0), pad = 0, offset = 0)
            start <- atan2(dataCirc$y, dataCirc$x)
            radiiStart <- sqrt(dataCirc$x^2 + dataCirc$y^2)
            radiiEnd <- sqrt(dataCirc$xend^2 + dataCirc$yend^2)
            angelDiff <- (dataCirc$x*dataCirc$xend + dataCirc$y*dataCirc$yend) /
             (radiiStart*radiiEnd)
            angelDiff[is.nan(angelDiff)] <- 0
            angelDiff <- suppressWarnings(acos(angelDiff))
            angelDiff[is.nan(angelDiff)] <- 0
            end <- start + ifelse(dataCirc$direction == 'left',
                                  -angelDiff, angelDiff)
            angles <- unlist(Map(seq, from = start, to = end, length.out = n/2))
            radii <- rep(sqrt(data$y[circId]^2 + data$x[circId]^2), each = n/2)
            pathCirc <- radial$transform(r = radii, a = angles)
            pathCirc$group <- rep(circId, each = n/2)
            pathCirc$index <- rep(index[seq_len(n/2)], length(circId))
            radiiRel <- radiiStart / radiiEnd
            elbowX <- dataCirc$xend * radiiRel
            elbowY <- dataCirc$yend * radiiRel
            elbowX <- unlist(Map(seq, from = elbowX, to = dataCirc$xend,
                                 length.out = n/2))
            elbowY <- unlist(Map(seq, from = elbowY, to = dataCirc$yend,
                                 length.out = n/2))
            pathCirc <- rbind(pathCirc,
                              data.frame(x = elbowX,
                                         y = elbowY,
                                         group = pathCirc$group,
                                         index = rep(index[seq_len(n/2) + n/2],
                                                     length(circId))))
            pathCirc <- cbind(pathCirc, data[pathCirc$group, !names(data) %in%
                                                 c('x', 'y', 'xend', 'yend')])
        }
        if (any(!data$circular)) {
            pathLin <- lapply(which(!data$circular), function(i) {
                if (flipped) {
                    path <- data.frame(
                        x = approx(c(data$x[i], data$x[i], data$xend[i]),
                                   n = n)$y,
                        y = approx(c(data$y[i], data$yend[i], data$yend[i]),
                                   n = n)$y,
                        group = i,
                        index = index
                    )
                } else {
                    path <- data.frame(
                        x = approx(c(data$x[i], data$xend[i], data$xend[i]),
                                   n = n)$y,
                        y = approx(c(data$y[i], data$y[i], data$yend[i]),
                                   n = n)$y,
                        group = i,
                        index = index
                    )
                }
                cbind(path, data[rep(i, nrow(path)), !names(data) %in%
                                     c('x', 'y', 'xend', 'yend')])
            })
            pathLin <- do.call(rbind, pathLin)

            if (any(data$circular)) {
                paths <- rbind(pathLin, pathCirc)
            } else {
                paths <- pathLin
            }
        } else {
            paths <- pathCirc
        }
        paths[order(paths$group), ]
    },
    setup_data = function(data, params) {
        if (any(names(data) == 'filter')) {
            if (!is.logical(data$filter)) {
                stop('filter must be logical')
            }
            data <- data[data$filter, names(data) != 'filter']
        }
        data
    },
    default_aes = aes(filter = TRUE),
    required_aes = c('x', 'y', 'xend', 'yend', 'circular', 'direction')
)
#' @rdname geom_edge_elbow
#'
#' @export
geom_edge_elbow <- function(mapping = NULL, data = get_edges(),
                            position = "identity", arrow = NULL,
                            flipped = FALSE, n = 100, lineend = "butt",
                            linejoin = "round", linemitre = 1,
                            label_colour = 'black',  label_alpha = 1,
                            label_parse = FALSE, check_overlap = FALSE,
                            angle_calc = 'rot', force_flip = TRUE,
                            label_dodge = NULL, label_push = NULL,
                            show.legend = NA, ...) {
    mapping <- completeEdgeAes(mapping)
    mapping <- aesIntersect(mapping, aes_(x=~x, y=~y, xend=~xend, yend=~yend,
                                          circular=~circular,
                                          direction=~direction))
    layer(data = data, mapping = mapping, stat = StatEdgeElbow,
          geom = GeomEdgePath, position = position, show.legend = show.legend,
          inherit.aes = FALSE,
          params = expand_edge_aes(
              list(arrow = arrow, lineend = lineend, linejoin = linejoin,
                   linemitre = linemitre, na.rm = FALSE, n = n,
                   interpolate = FALSE, flipped = flipped,
                   label_colour = label_colour, label_alpha = label_alpha,
                   label_parse = label_parse, check_overlap = check_overlap,
                   angle_calc = angle_calc, force_flip = force_flip,
                   label_dodge = label_dodge, label_push = label_push, ...)
          )
    )
}
#' @rdname ggraph-extensions
#' @format NULL
#' @usage NULL
#' @export
StatEdgeElbow2 <- ggproto('StatEdgeElbow2', Stat,
    compute_panel = function(data, scales, flipped = FALSE, n = 100) {
        posCols <- c('x', 'y', 'group', 'circular', 'direction', 'PANEL')
        data <- data[order(data$group), ]
        posData <- cbind(data[c(TRUE, FALSE), posCols], data[c(FALSE, TRUE),
                                                             c('x', 'y')])
        names(posData) <- c(posCols, 'xend', 'yend')
        newData <- StatEdgeElbow$compute_panel(posData, scales, flipped, n)
        extraCols <- !names(data) %in% posCols
        index <- match(seq_len(nrow(posData)), newData$group)
        index <- as.vector(rbind(index, index + 1))
        newData$.interp <- TRUE
        newData$.interp[index] <- FALSE
        if (sum(extraCols) != 0) {
            for (i in names(data)[extraCols]) {
                newData[[i]] <- NA
                newData[[i]][index] <- data[[i]]
            }
        }
        newData
    },
    setup_data = function(data, params) {
        if (any(names(data) == 'filter')) {
            if (!is.logical(data$filter)) {
                stop('filter must be logical')
            }
            data <- data[data$filter, names(data) != 'filter']
        }
        data
    },
    default_aes = aes(filter = TRUE),
    required_aes = c('x', 'y', 'group', 'circular', 'direction')
)
#' @rdname geom_edge_elbow
#'
#' @export
geom_edge_elbow2 <- function(mapping = NULL, data = get_edges('long'),
                             position = "identity", arrow = NULL,
                             flipped = FALSE, n = 100, lineend = "butt",
                             linejoin = "round", linemitre = 1,
                             label_colour = 'black',  label_alpha = 1,
                             label_parse = FALSE, check_overlap = FALSE,
                             angle_calc = 'rot', force_flip = TRUE,
                             label_dodge = NULL, label_push = NULL,
                             show.legend = NA, ...) {
    mapping <- completeEdgeAes(mapping)
    mapping <- aesIntersect(mapping, aes_(x=~x, y=~y, group=~edge.id,
                                          circular=~circular,
                                          direction=~direction))
    layer(data = data, mapping = mapping, stat = StatEdgeElbow2,
          geom = GeomEdgePath, position = position, show.legend = show.legend,
          inherit.aes = FALSE,
          params = expand_edge_aes(
              list(arrow = arrow, lineend = lineend, linejoin = linejoin,
                   linemitre = linemitre, na.rm = FALSE, n = n,
                   interpolate = TRUE, flipped = flipped,
                   label_colour = label_colour, label_alpha = label_alpha,
                   label_parse = label_parse, check_overlap = check_overlap,
                   angle_calc = angle_calc, force_flip = force_flip,
                   label_dodge = label_dodge, label_push = label_push, ...)
          )
    )
}
#' @rdname ggraph-extensions
#' @format NULL
#' @usage NULL
#' @export
StatEdgeElbow0 <- ggproto('StatEdgeElbow0', Stat,
    compute_panel = function(data, scales, flipped = FALSE) {
        if (any(data$circular)) {
            circId <- which(data$circular)
            dataCirc <- data[circId, ]
            radial <- radial_trans(c(0, 1), c(2*pi, 0), pad = 0, offset = 0)
            start <- atan2(dataCirc$y, dataCirc$x)
            angelDiff <- (dataCirc$x*dataCirc$xend + dataCirc$y*dataCirc$yend) /
                (sqrt(dataCirc$x^2 + dataCirc$y^2) *
                     sqrt(dataCirc$xend^2 + dataCirc$yend^2))
            angelDiff[is.nan(angelDiff)] <- 0
            angelDiff <- suppressWarnings(acos(angelDiff))
            angelDiff[is.nan(angelDiff)] <- 0
            end <- start + ifelse(dataCirc$direction == 'left',
                                  -angelDiff, angelDiff)
            angles <- unlist(Map(seq, from = start, to = end, length.out = 50))
            radii <- rep(sqrt(data$y[circId]^2 + data$x[circId]^2), each = 50)
            pathCirc <- radial$transform(r = radii, a = angles)
            pathCirc$group <- rep(circId, each = 50)
            pathCirc <- rbind(pathCirc,
                              data.frame(x = data$xend[circId],
                                         y = data$yend[circId],
                                         group = circId))
            pathCirc <- cbind(pathCirc, data[pathCirc$group, !names(data) %in%
                                                 c('x', 'y', 'xend', 'yend')])
        }
        if (any(!data$circular)) {
            pathLin <- lapply(which(!data$circular), function(i) {
                if (flipped) {
                    path <- data.frame(
                        x = c(data$x[i], data$x[i], data$xend[i]),
                        y = c(data$y[i], data$yend[i], data$yend[i]),
                        group = i
                    )
                } else {
                    path <- data.frame(
                        x = c(data$x[i], data$xend[i], data$xend[i]),
                        y = c(data$y[i], data$y[i], data$yend[i]),
                        group = i
                    )
                }
                cbind(path, data[rep(i, nrow(path)), !names(data) %in%
                                     c('x', 'y', 'xend', 'yend')])
            })
            pathLin <- do.call(rbind, pathLin)

            if (any(data$circular)) {
                paths <- rbind(pathLin, pathCirc)
            } else {
                paths <- pathLin
            }
        } else {
            paths <- pathCirc
        }
        paths[order(paths$group), ]
    },
    setup_data = function(data, params) {
        if (any(names(data) == 'filter')) {
            if (!is.logical(data$filter)) {
                stop('filter must be logical')
            }
            data <- data[data$filter, names(data) != 'filter']
        }
        data
    },
    default_aes = aes(filter = TRUE),
    required_aes = c('x', 'y', 'xend', 'yend', 'circular', 'direction')
)
#' @rdname geom_edge_elbow
#'
#' @export
geom_edge_elbow0 <- function(mapping = NULL, data = get_edges(),
                            position = "identity", arrow = NULL, flipped = FALSE,
                            lineend = "butt", show.legend = NA, ...) {
    mapping <- completeEdgeAes(mapping)
    mapping <- aesIntersect(mapping, aes_(x=~x, y=~y, xend=~xend, yend=~yend,
                                          circular=~circular,
                                          direction=~direction))
    layer(data = data, mapping = mapping, stat = StatEdgeElbow0,
          geom = GeomEdgePath, position = position, show.legend = show.legend,
          inherit.aes = FALSE,
          params = expand_edge_aes(
              list(arrow = arrow, lineend = lineend, na.rm = FALSE,
                        interpolate = FALSE, flipped = flipped, ...)
          )
    )
}