#' Connect boxes with an arrow
#'
#' The function creates a grob that links two boxes together. It looks for
#' which side it should attach the arrow, e.g. if the start is on top of
#' the bottom it should attach to the bottom edge of ther start box and then
#' to the top at the end.
#'
#' The exact positions of the line is stored at the \code{attr(..., "line")}.
#' If you want to draw your own custom line all you need to do is check which
#' \code{attr(my_line, "line")$x} and \code{attr(my_line, "line")$y} you want
#' to attach to and then create your own custom \code{\link[grid:grid.lines]{linesGrob}}.
#'
#' @param start The start box
#' @param end The end box
#' @param type How the boxes are stacked. The \code{L} alternative generates a
#' straight line up/down and then turns to righT/left for connecting with the end.
#' The \code{-} generates a straight horizontal arrow. The \code{Z} creates a
#' horizontal line that looks like a \code{Z} with 90 degree turns. The option
#' \code{N} allows for vertical lines.
#' @param subelmnt If we have a split box we can specify the right/left x as the
#' connector point.
#' @param lty_gp The \code{\link[grid]{gpar}} for the line. Set
#' \code{connectGrob} option if you want to customize all the arrows at once.
#' @param arrow_obj The arrow spec according to \code{\link[grid]{arrow}}. Set
#' \code{connectGrobArrow} option if you want to customize all the arrows at once.
#'
#' @return grob with an arrow
#' @export
#'
#' @importFrom checkmate assert_class
#' @family flowchart components
#' @rdname connect
#' @example inst/examples/connectGrob_example.R
connectGrob <- function(
start,
end,
type = c("vertical", "horizontal", "L", "-", "Z", "N"),
subelmnt = c("right", "left"),
lty_gp = getOption("connectGrob",
default = gpar(fill = "black")
),
arrow_obj = getOption("connectGrobArrow",
default = arrow(ends = "last", type = "closed")
)) {
assert_class(start, "box")
assert_class(end, "box")
assert_class(lty_gp, "gpar")
assert_class(arrow_obj, "arrow")
# We use the coordinates provided with the boxes
start <- coords(start)
end <- coords(end)
type <- match.arg(type)
if (missing(subelmnt)) {
subelmnt <- ""
} else {
subelmnt <- sprintf("%s_", match.arg(subelmnt))
}
getX4elmnt <- function(elmnt, side = c("left", "right", "x")) {
side <- match.arg(side)
if (side == "x" && !is.null(elmnt[[sprintf("%s%s", subelmnt, side)]])) {
return(elmnt[[sprintf("%s%s", subelmnt, side)]])
} else {
return(elmnt[[side]])
}
}
line <- list()
cnvrt <- function(val) {
convertHeight(val, unitTo = "mm", valueOnly = TRUE)
}
if (type %in% c("L", "-")) {
if (type == "-") {
line$y <- unit.c(end$y, end$y, end$y)
} else {
line$y <- unit.c(start$bottom, end$y, end$y)
}
if (cnvrt(getX4elmnt(start, "x")) < cnvrt(getX4elmnt(end, "x"))) {
line$x <- unit.c(getX4elmnt(start, "x"), getX4elmnt(start, "x"), end$left)
} else {
line$x <- unit.c(getX4elmnt(start, "x"), getX4elmnt(start, "x"), end$right)
}
} else if (type == "Z") {
if (prCnvrtX(start$x) < prCnvrtX(end$x)) {
line$x <- unit.c(
start$right,
start$right + distance(start, end, type = "h", half = TRUE),
start$right + distance(start, end, type = "h", half = TRUE),
end$left
)
} else {
line$x <- unit.c(
start$left,
start$left - distance(start, end, type = "h", half = TRUE),
start$left - distance(start, end, type = "h", half = TRUE),
end$right
)
}
line$y <- unit.c(
start$y,
start$y,
end$y,
end$y
)
} else if (type == "N") {
dist_y <- distance(start, end, type = "v", half = TRUE)
if (prCnvrtY(start$y) < prCnvrtY(end$y)) {
line$y <- unit.c(
start$top,
start$top + dist_y,
start$top + dist_y,
end$bottom
)
} else {
line$y <- unit.c(
start$bottom,
start$bottom - dist_y,
start$bottom - dist_y,
end$top
)
}
line$x <- unit.c(
getX4elmnt(start, "x"),
getX4elmnt(start, "x"),
getX4elmnt(end, "x"),
getX4elmnt(end, "x")
)
} else if (type == "vertical") {
line$x <- unit.c(getX4elmnt(start, "x"), getX4elmnt(end, "x"))
if (cnvrt(start$y) < cnvrt(end$y)) {
line$y <- unit.c(start$top, end$bottom)
} else {
line$y <- unit.c(start$bottom, end$top)
}
} else {
line$y <- unit.c(start$y, end$y)
if (cnvrt(getX4elmnt(start, "x")) < cnvrt(getX4elmnt(end, "x"))) {
line$x <- unit.c(start$right, end$left)
} else {
line$x <- unit.c(start$left, end$right)
}
}
lg <- linesGrob(
x = line$x,
y = line$y,
gp = lty_gp,
arrow = arrow_obj
)
structure(lg,
line = line,
class = c("connect_boxes", class(lg))
)
}
#' The print/plot calls the \code{\link[grid]{grid.draw}} function on the object
#' @param x The grob to print/plot
#' @param ... Passed to \code{\link[grid]{grid.draw}}
#' @rdname connect
#' @export
print.connect_boxes <- function(x, ...) {
grid.draw(x, ...)
}
#' @rdname connect
#' @export
plot.connect_boxes <- print.connect_boxes
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.