Cpp11 (#359)

DESCRIPTION

@@ -19,7 +19,6 @@ License: MIT + file LICENSE
 Encoding: UTF-8
 LazyData: TRUE
 Imports:
-    Rcpp (>= 0.12.2),
     dplyr,
     ggforce (>= 0.3.1),
     grid,
@@ -50,7 +49,8 @@ Suggests:
     covr,
     sf,
     sfnetworks
-LinkingTo: Rcpp
+LinkingTo: 
+    cpp11
 RoxygenNote: 7.3.1
 Depends:
     R (>= 2.10),

NAMESPACE

@@ -272,7 +272,6 @@ import(tidygraph)
 import(vctrs)
 importFrom(MASS,bandwidth.nrd)
 importFrom(MASS,kde2d)
-importFrom(Rcpp,sourceCpp)
 importFrom(dplyr,"%>%")
 importFrom(dplyr,arrange)
 importFrom(dplyr,do)
@@ -420,4 +419,4 @@ importFrom(utils,tail)
 importFrom(viridis,scale_color_viridis)
 importFrom(viridis,scale_colour_viridis)
 importFrom(viridis,scale_fill_viridis)
-useDynLib(ggraph)
+useDynLib(ggraph, .registration = TRUE)

R/cappedPath.R

@@ -96,8 +96,15 @@ makeContent.cappedpathgrob <- function(x) {
   start.cap2 <- convertHeight(x$start.cap2, 'mm', TRUE)
   end.cap2 <- convertHeight(x$end.cap2, 'mm', TRUE)
   truncated <- cut_lines(
-    x_new, y_new, as.integer(x$id), start.cap, start.cap2,
-    end.cap, end.cap2, x$start.captype, x$end.captype
+    as.numeric(x_new),
+    as.numeric(y_new),
+    as.integer(x$id),
+    as.numeric(start.cap),
+    as.numeric(start.cap2),
+    as.numeric(end.cap),
+    as.numeric(end.cap2),
+    as.character(x$start.captype),
+    as.character(x$end.captype)
   )
   keep <- !is.na(truncated$x)
   if (!any(keep)) {

R/cpp11.R

@@ -0,0 +1,45 @@
+# Generated by cpp11: do not edit by hand
+
+cactusTree <- function(parent, order, weight, scale, overlap, upright) {
+  .Call(`_ggraph_cactusTree`, parent, order, weight, scale, overlap, upright)
+}
+
+pack <- function(areas) {
+  .Call(`_ggraph_pack`, areas)
+}
+
+circlePackLayout <- function(parent, weight) {
+  .Call(`_ggraph_circlePackLayout`, parent, weight)
+}
+
+dendrogram_spread <- function(graph, starts, y, leaf, repel, pad, ratio) {
+  .Call(`_ggraph_dendrogram_spread`, graph, starts, y, leaf, repel, pad, ratio)
+}
+
+force_bundle_iter <- function(edges_xy, K, C, P, P_rate, S, I, I_rate, compatibility_threshold, eps) {
+  .Call(`_ggraph_force_bundle_iter`, edges_xy, K, C, P, P_rate, S, I, I_rate, compatibility_threshold, eps)
+}
+
+hTree <- function(parent, order) {
+  .Call(`_ggraph_hTree`, parent, order)
+}
+
+partitionTree <- function(parent, order, weight, height) {
+  .Call(`_ggraph_partitionTree`, parent, order, weight, height)
+}
+
+cut_lines <- function(x, y, id, start_width, start_height, end_width, end_height, start_type, end_type) {
+  .Call(`_ggraph_cut_lines`, x, y, id, start_width, start_height, end_width, end_height, start_type, end_type)
+}
+
+pathAttr <- function(group, alpha, width, lty, colour, ngroups) {
+  .Call(`_ggraph_pathAttr`, group, alpha, width, lty, colour, ngroups)
+}
+
+splitTreemap <- function(parent, order, weight, width, height) {
+  .Call(`_ggraph_splitTreemap`, parent, order, weight, width, height)
+}
+
+unrooted <- function(parent, order, length, daylight, tol, rotation_mod, maxiter) {
+  .Call(`_ggraph_unrooted`, parent, order, length, daylight, tol, rotation_mod, maxiter)
+}

R/geom_edge.R

@@ -30,7 +30,14 @@ GeomEdgePath <- ggproto('GeomEdgePath', GeomPath,
     if (nrow(data) < 2) {
       return(zeroGrob())
     }
-    attr <- pathAttr(data, length(unique0(data$group)))
+    attr <- pathAttr(
+      as.integer(data$group),
+      as.numeric(data$edge_alpha),
+      as.numeric(data$edge_width),
+      as.character(data$edge_linetype),
+      as.character(data$edge_colour),
+      length(unique0(data$group))
+    )
 
     if (all(is.na(data$start_cap))) {
       start_captype <- 'circle'

R/geom_edge_bundle_force.R

@@ -280,24 +280,14 @@ force_bundle <- function(data, K, C, P, S, P_rate, I, I_rate, compatibility_thre
 
   # initialize matrix with coordinates
   m <- nrow(data)
-  elist <- lapply(seq_len(m), function(i) {
-    matrix(as.vector(data[i, ]), ncol = 2, byrow = TRUE)
-  })
 
-  # main force bundling routine
-  elist <- force_bundle_iter(
-    data, elist, K, C, P, P_rate,
-    S, I, I_rate, compatibility_threshold, eps
-  )
+  mode(data) <- 'numeric'
 
-  # assemble data frame
-  segments <- nrow(elist[[1]])
-  elist <- inject(rbind(!!!elist))
-
-  data_frame0(
-    x = elist[, 1],
-    y = elist[, 2],
-    group = rep(seq_len(m), each = segments)
+  # main force bundling routine
+  force_bundle_iter(
+    data, as.numeric(K), as.integer(C), as.integer(P), as.integer(P_rate),
+    as.numeric(S), as.integer(I), as.numeric(I_rate),
+    as.numeric(compatibility_threshold), as.numeric(eps)
   )
 }
 

R/ggraph-package.R

@@ -7,7 +7,6 @@
 #' @import ggplot2 tidygraph rlang vctrs
 #' @importFrom memoise memoise
 #' @importFrom lifecycle deprecated
-#' @importFrom Rcpp sourceCpp
-#' @useDynLib ggraph
+#' @useDynLib ggraph, .registration = TRUE
 ## usethis namespace: end
 NULL

R/layout_cactustree.R

@@ -50,7 +50,14 @@ layout_tbl_graph_cactustree <- function(graph, direction = "out", weight = NULL,
     weight <- as.numeric(degree(graph, mode = direction) == 0)
   }
   hierarchy <- tree_to_hierarchy(graph, direction, NULL, weight, NULL)
-  layout <- cactusTree(hierarchy$parent, hierarchy$order, hierarchy$weight, scale_factor, overlap, upright)[-1, ]
+  layout <- cactusTree(
+    as.integer(hierarchy$parent),
+    as.integer(hierarchy$order),
+    as.numeric(hierarchy$weight),
+    as.numeric(scale_factor),
+    as.numeric(overlap),
+    as.logical(upright)
+  )[-1, ]
   nodes <- data_frame0(
     x = layout[, 1],
     y = layout[, 2],

R/layout_circlepack.R

@@ -56,7 +56,10 @@ layout_tbl_graph_circlepack <- function(graph, weight = NULL, circular = FALSE,
   sort.by <- enquo(sort.by)
   sort.by <- eval_tidy(sort.by, .N())
   hierarchy <- tree_to_hierarchy(graph, direction, sort.by, weight)
-  nodes <- circlePackLayout(hierarchy$parent, hierarchy$weight)[-1, ]
+  nodes <- circlePackLayout(
+    as.integer(hierarchy$parent),
+    as.numeric(hierarchy$weight)
+  )[-1, ]
   nodes <- data_frame0(
     x = nodes[, 1],
     y = nodes[, 2],

R/layout_dendrogram.R

@@ -78,7 +78,15 @@ layout_tbl_graph_dendrogram <- function(graph, circular = FALSE, offset = pi / 2
   startnode <- which(degree(graph, mode = reverse_dir) == 0)
   if (length(startnode) < 1) cli::cli_abort('The graph doesn\'t contain a root node')
   neighbors <- lapply(adjacent_vertices(graph, seq_len(gorder(graph)), direction), as.integer)
-  nodes$x <- dendrogram_spread(neighbors, startnode, nodes$y, nodes$leaf, repel, pad, ratio)
+  nodes$x <- dendrogram_spread(
+    neighbors,
+    as.integer(startnode),
+    as.numeric(nodes$y),
+    as.logical(nodes$leaf),
+    as.logical(repel),
+    as.numeric(pad),
+    as.numeric(ratio)
+  )
   graph <- add_direction(graph, nodes)
   if (circular) {
     radial <- radial_trans(

R/layout_htree.R

@@ -38,7 +38,7 @@ layout_tbl_graph_htree <- function(graph, sort.by = NULL, direction = 'out', cir
   sort.by <- enquo(sort.by)
   sort.by <- eval_tidy(sort.by, .N())
   hierarchy <- tree_to_hierarchy(graph, direction, sort.by, NULL)
-  layout <- hTree(hierarchy$parent, hierarchy$order)[-1, ]
+  layout <- hTree(as.integer(hierarchy$parent), as.integer(hierarchy$order))[-1, ]
   nodes <- data_frame0(
     x = layout[, 1],
     y = layout[, 2],

R/layout_partition.R

@@ -65,7 +65,12 @@ layout_tbl_graph_partition <- function(graph, weight = NULL, circular = FALSE, h
   sort.by <- enquo(sort.by)
   sort.by <- eval_tidy(sort.by, .N())
   hierarchy <- tree_to_hierarchy(graph, direction, sort.by, weight, height)
-  layout <- partitionTree(hierarchy$parent, hierarchy$order, hierarchy$weight, hierarchy$height)[-1, ]
+  layout <- partitionTree(
+    as.integer(hierarchy$parent),
+    as.integer(hierarchy$order),
+    as.numeric(hierarchy$weight),
+    as.numeric(hierarchy$height)
+  )[-1, ]
   if (circular) {
     if (const.area) {
       y0 <- sqrt(layout[, 2])

R/layout_treemap.R

@@ -77,7 +77,13 @@ layout_tbl_graph_treemap <- function(graph, algorithm = 'split', weight = NULL,
   hierarchy <- tree_to_hierarchy(graph, direction, sort.by, weight)
   layout <- switch(
     algorithm,
-    split = splitTreemap(hierarchy$parent, hierarchy$order, hierarchy$weight, width, height),
+    split = splitTreemap(
+      as.integer(hierarchy$parent),
+      as.integer(hierarchy$order),
+      as.numeric(hierarchy$weight),
+      as.numeric(width),
+      as.numeric(height)
+    ),
     cli::cli_abort('Unknown treemap algorithm')
   )[-1, ]
   nodes <- data_frame0(

R/layout_unrooted.R

@@ -43,7 +43,15 @@ layout_tbl_graph_unrooted <- function(graph, daylight = TRUE, length = NULL, tol
   length <- enquo(length)
   length <- eval_tidy(length, .E())
   hierarchy <- tree_to_hierarchy(graph, 'out', seq_len(gorder(graph)), weight = NULL, length)
-  layout <- unrooted(hierarchy$parent, hierarchy$order, hierarchy$height, daylight, tolerance, rotation_mod, maxiter)[-1, ]
+  layout <- unrooted(
+    as.integer(hierarchy$parent),
+    as.integer(hierarchy$order),
+    as.numeric(hierarchy$height),
+    as.logical(daylight),
+    as.numeric(tolerance),
+    as.numeric(rotation_mod),
+    as.integer(maxiter)
+  )[-1, ]
   nodes <- data_frame0(
     x = layout[, 1],
     y = layout[, 2],

R/pack.R

@@ -0,0 +1,38 @@
+#' Pack circles together
+#'
+#' This function is a direct interface to the circle packing algorithm used by
+#' \code{\link{layout_tbl_graph_circlepack}}. It takes a vector of sizes and
+#' returns the x and y position of each circle as a two-column matrix.
+#'
+#' @param areas A vector of circle areas
+#'
+#' @return A matrix with two columns and the same number of rows as the length
+#' of the "areas" vector. The matrix has the following attributes added:
+#' "enclosing_radius" giving the radius of the smallest enclosing circle, and
+#' "front_chain" giving the terminating members of the front chain (see
+#' Wang \emph{et al}. 2006).
+#'
+#' @references
+#' Wang, W., Wang, H. H., Dai, G., & Wang, H. (2006). \emph{Visualization of
+#' large hierarchical data by circle packing}. Chi, 517-520.
+#'
+#' @export
+#'
+#' @examples
+#' library(ggforce)
+#' sizes <- sample(10, 100, TRUE)
+#'
+#' position <- pack_circles(sizes)
+#' data <- data.frame(x = position[,1], y = position[,2], r = sqrt(sizes/pi))
+#'
+#' ggplot() +
+#'   geom_circle(aes(x0 = x, y0 = y, r = r), data = data, fill = 'steelblue') +
+#'   geom_circle(aes(x0 = 0, y0 = 0, r = attr(position, 'enclosing_radius'))) +
+#'   geom_polygon(aes(x = x, y = y),
+#'                data = data[attr(position, 'front_chain'), ],
+#'                fill = NA,
+#'                colour = 'black')
+#'
+pack_circles <- function(areas) {
+  pack(as.numeric(areas))
+}

src/.gitignore

@@ -0,0 +1,3 @@
+*.o
+*.so
+*.dll