Connectogram support

NAMESPACE

@@ -15,7 +15,9 @@ export(StatBspline2)
 export(StatCircle)
 export(StatLink)
 export(StatLink2)
+export(StatLinkPie)
 export(StatPie)
+export(StatTextPie)
 export(geom_arc)
 export(geom_arc_bar)
 export(geom_bezier)
@@ -41,7 +43,9 @@ export(stat_bspline2)
 export(stat_circle)
 export(stat_link)
 export(stat_link2)
+export(stat_link_pie)
 export(stat_pie)
+export(stat_text_pie)
 export(theme_no_axes)
 export(trans_reverser)
 importFrom(MASS,fractions)

R/arc_bar.R

@@ -81,6 +81,10 @@
 #' @param geom, stat Override the default connection between \code{geom_arc_bar}
 #' and \code{stat_arc_bar}.
 #'
+#' @param offset - for pie geom. Default=pi/2. Modifies orientation of the chart. Use
+#' for switching between horizontal and vertical.
+#'
+#' @param direction - for pie geom. Default = 1. Negative switches to anticlockwise.
 #' @author Thomas Lin Pedersen
 #'
 #' @name geom_arc_bar
@@ -155,7 +159,7 @@ stat_arc_bar  <- function(mapping = NULL, data = NULL, geom = "arc_bar",
 #' @importFrom dplyr group_by_ do
 #' @export
 StatPie <- ggproto('StatPie', Stat,
-    compute_panel = function(data, scales, n = 360, sep = 0) {
+    compute_panel = function(data, scales, n = 360, sep = 0, offset=pi/2, direction=1) {
         data <- data %>% group_by_(~x0, ~y0) %>%
             do({
                 angles <- cumsum(.$amount)
@@ -167,25 +171,140 @@ StatPie <- ggproto('StatPie', Stat,
                 data.frame(
                     as.data.frame(.),
                     start = c(0, angles[-length(angles)]) + c(0, seps[-length(seps)]) + sep/2,
-                    end = angles + seps -sep/2,
+                    end = angles + seps - sep/2,
                     stringsAsFactors = FALSE
                 )
             })
-        arcPaths(as.data.frame(data), n)
+        arcPaths(as.data.frame(data), n, offset=offset, direction=direction)
     },
 
     required_aes = c('x0', 'y0', 'r0','r', 'amount')
 )
+#' @rdname geom_arc_bar
+#' @importFrom ggplot2 layer
+#' @export
+StatLinkPie <- ggproto('StatLinkPie', Stat,
+                   compute_panel = function(data, scales, n = 100, sep = 0, offset=pi/2, direction=1) {
+                     data <- data %>% group_by_(~x0, ~y0) %>%
+                       do({
+                         ## Bit tricky - need to support multiple links
+                         ## per node, but the calculation of middle
+                         ## can't repeat. Just have to ensure that there
+                         ## are as many "start" entries as necessary
+                         ## Make sure angles aren't duplicated
+                         dd <- .[!duplicated(.$sourcenode), ]
+                         angles <- cumsum(dd$amount)
+                         seps <- cumsum(sep * seq_along(angles))
+                         if (max(seps) >= 2*pi) {
+                           stop('Total separation exceeds circle circumference. Try lowering "sep"')
+                         }
+                         angles <- angles/max(angles) * (2*pi - max(seps))
+                         ## Set up source and destination for curves.
+                         start <- c(0, angles[-length(angles)]) + c(0, seps[-length(seps)])
+                         end <- angles + seps -sep/2
+                         middle <-  (start+end)/2
+                         ## Now we need to create a data frame suitable for links
+                         ## The curve expects a start, midpoint and end in
+                         ## consecutive rows.
+                         linkframe <- .[!is.na(.$destinationnode),]
+                         startangidx <- match(linkframe$sourcenode, dd$sourcenode)
+                         endangidx <- match(linkframe$destinationnode, dd$sourcenode)
+                         startang <- middle[startangidx]
+                         endang <- middle[endangidx]
+                         ## use start end here, but they refer to different ideas
+                         ## than the pie versions
+                         data.frame(
+                           as.data.frame(linkframe),
+                           start=startang,
+                           end=endang,
+                           stringsAsFactors = FALSE
+                         )
+                       })
+                     arcLinks(as.data.frame(data), n, offset=offset, direction=direction)
+                   },
+                   required_aes = c('x0', 'y0', 'r0','r', 'amount')
+)
+
+#' @rdname geom_arc_bar
+#' @importFrom ggplot2 layer
+#' @export
+StatTextPie <- ggproto('StatTextPie', Stat,
+                       compute_panel = function(data, scales, n = 360, sep = 0, offset=pi/2, direction=1) {
+                         data <- data %>% group_by_(~x0, ~y0) %>%
+                           do({
+                             ## Bit tricky - need to support multiple links
+                             ## per node, but the calculation of middle
+                             ## can't repeat. Just have to ensure that there
+                             ## are as many "start" entries as necessary
+                             ## Make sure angles aren't duplicated
+                             dd <- .[!duplicated(.$sourcenode), ]
+                             angles <- cumsum(dd$amount)
+                             seps <- cumsum(sep * seq_along(angles))
+                             if (max(seps) >= 2*pi) {
+                               stop('Total separation exceeds circle circumference. Try lowering "sep"')
+                             }
+                             angles <- angles/max(angles) * (2*pi - max(seps))
+                             ## Set up source and destination for curves.
+                             start <- c(0, angles[-length(angles)]) + c(0, seps[-length(seps)])
+                             end <- angles + seps -sep/2
+                             middle <-  (start+end)/2
+                             ## Now we need to create a data frame suitable for text
+                             startang <- middle
+                             ## use start end here, but they refer to different ideas
+                             ## than the pie versions
+                             data.frame(
+                               as.data.frame(dd),
+                               start=startang,
+                               stringsAsFactors = FALSE
+                             )
+                           })
+                         res <- arcText(as.data.frame(data), n, offset=offset, direction=direction)
+                         return(res)
+                       },
+                       required_aes = c('x0', 'y0', 'r0','r', 'amount'),
+                       default_aes=aes(angle=..textangle..)
+)
+
+#' @rdname geom_arc_bar
+#' @importFrom ggplot2 layer
+#' @export
+stat_link_pie  <- function(mapping = NULL, data = NULL, geom = "arc_bar",
+                      position = "identity", n = 100, sep = 0, offset=pi/2,
+                      direction=1, na.rm = FALSE,
+                      show.legend = NA, inherit.aes = TRUE, ...) {
+  layer(
+    stat = StatLinkPie, data = data, mapping = mapping, geom = geom,
+    position = position, show.legend = show.legend, inherit.aes = inherit.aes,
+    params = list(na.rm = na.rm, n = n, sep = sep, offset=offset, direction=direction, ...)
+  )
+}
+
+#' @rdname geom_arc_bar
+#' @importFrom ggplot2 layer
+#' @export
+stat_text_pie <- function(mapping = NULL, data = NULL, geom = "text_pie",
+                           position = "identity", n = 360, sep = 0, offset=pi/2,
+                           direction=1, na.rm = FALSE,
+                           show.legend = NA, inherit.aes = TRUE, ...) {
+  layer(
+    stat = StatTextPie, data = data, mapping = mapping, geom = geom,
+    position = position, show.legend = show.legend, inherit.aes = inherit.aes,
+    params = list(na.rm = na.rm, n = n, sep = sep, offset=offset, direction=direction, ...)
+  )
+}
+
+
 #' @rdname geom_arc_bar
 #' @importFrom ggplot2 layer
 #' @export
 stat_pie  <- function(mapping = NULL, data = NULL, geom = "arc_bar",
-                      position = "identity", n = 360, sep = 0, na.rm = FALSE,
+                      position = "identity", n = 360, sep = 0, offset=pi/2,
+                      direction=1, na.rm = FALSE,
                       show.legend = NA, inherit.aes = TRUE, ...) {
     layer(
         stat = StatPie, data = data, mapping = mapping, geom = geom,
         position = position, show.legend = show.legend, inherit.aes = inherit.aes,
-        params = list(na.rm = na.rm, n = n, sep = sep, ...)
+        params = list(na.rm = na.rm, n = n, sep = sep, offset=offset, direction=direction, ...)
     )
 }
 #' @rdname ggforce-extensions
@@ -196,6 +315,8 @@ stat_pie  <- function(mapping = NULL, data = NULL, geom = "arc_bar",
 GeomArcBar <- ggproto('GeomArcBar', GeomPolygon,
     default_aes = list(colour = 'black', fill = NA, size = 0.5, linetype = 1, alpha = NA)
 )
+
+
 #' @rdname geom_arc_bar
 #' @importFrom ggplot2 layer
 #' @export
@@ -207,8 +328,8 @@ geom_arc_bar <- function(mapping = NULL, data = NULL, stat = "arc_bar",
           params = list(na.rm = na.rm, n = n, ...))
 }
 
-arcPaths <- function(data, n) {
-    trans <- radial_trans(c(0, 1), c(0, 2*pi), pad = 0)
+arcPaths <- function(data, n, offset=pi/2, direction=1) {
+    trans <- radial_trans(c(0, 1), c(0, 2*pi), pad = 0, offset=offset, direction=direction)
     data <- data[data$start != data$end, ]
     data$nControl <- ceiling(n/(2*pi) * abs(data$end - data$start))
     data$nControl[data$nControl < 3] <- 3
@@ -257,3 +378,42 @@ arcPaths <- function(data, n) {
     }
     paths[, !names(paths) %in% c('x0', 'y0', 'exploded')]
 }
+
+arcLinks <- function(data, n=100, offset=pi/2, direction=1) {
+  trans <- radial_trans(c(0, 1), c(0, 2*pi), pad = 0, offset=offset, direction=direction)
+  extraData <- !names(data) %in% c('r0', 'r', 'start', 'end')
+  ## transform the start and end angles
+  nControls <- table(data$group)
+  p1 <- trans$transform(data$r, data$start)
+  p2 <- trans$transform(data$r, data$end)
+  ## merge them to go start/control/end
+  ## and add centres
+  p1x <- p1[,"x"] + data$x0
+  p1y <- p1[,"y"] + data$y0
+  p2x <- p2[,"x"] + data$x0
+  p2y <- p2[,"y"] + data$y0
+  ppx <- c(rbind(p1x, data$x0, p2x))
+  ppy <- c(rbind(p1y, data$y0, p2y))
+
+  ppall <- data.frame(x=ppx, y=ppy, id=rep(1:nrow(data), rep(3,nrow(data))))
+  paths <- getBeziers(ppall$x, ppall$y, ppall$id, n)
+  paths <- data.frame(x = paths$paths[,1], y = paths$paths[,2], group = paths$pathID)
+  paths$index <- rep(seq(0, 1, length.out = n), length(nControls))
+  dataIndex <- rep(match(unique(data$group), data$group), each = n)
+  paths2<-cbind(paths, data[dataIndex, !names(data) %in% c('x', 'y', 'group'), drop = FALSE])
+  paths2[, !names(paths) %in% c('x0', 'y0', 'exploded')]
+}
+
+arcText <- function(data, n=360, offset=pi/2, direction=1) {
+  ## text angle in degrees
+  trans <- radial_trans(c(0, 1), c(0, 2*pi), pad = 0, offset=offset, direction=direction)
+  extraData <- !names(data) %in% c('r0', 'r', 'start')
+  ## transform the start and end angles
+  nControls <- table(data$group)
+  p1 <- trans$transform(data$r, data$start)
+  ## add centres
+  p1x <- p1[,"x"] + data$x0
+  p1y <- p1[,"y"] + data$y0
+  result <- data.frame(x=p1x, y=p1y, textangle=(-data$start+offset)*180/pi, data[ ,!names(data) %in% extraData ])
+  return(result)
+}

R/bezier.R

@@ -127,6 +127,7 @@ StatBezier <- ggproto('StatBezier', Stat,
         data <- data[order(data$group),]
         paths <- getBeziers(data$x, data$y, data$group, params$n)
         paths <- data.frame(x = paths$paths[,1], y = paths$paths[,2], group = paths$pathID)
+
         paths$index <- rep(seq(0, 1, length.out = params$n), length(nControls))
         dataIndex <- rep(match(unique(data$group), data$group), each = params$n)
         cbind(paths, data[dataIndex, !names(data) %in% c('x', 'y', 'group'), drop = FALSE])

R/trans.R

@@ -67,6 +67,7 @@ power_trans <- function(n) {
 #' @param clip Should input data be clipped to r.range and a.range or be allowed
 #' to extend beyond. Defaults to FALSE (no clipping)
 #'
+#' @param direction. Clockwise (1)/anticlockwise(-1) - default=1.
 #' @return A trans object. The transform method for the object takes an r
 #' (radius) and a (angle) argument and returns a data.frame with x and y columns
 #' with rows for each element in r/a. The inverse method takes an x and y
@@ -96,7 +97,7 @@ power_trans <- function(n) {
 #' ggplot() + geom_path(aes(x=x, y=y), data = cart, color='forestgreen') +
 #'   geom_path(aes(x=r, y=a), data = rad, color='firebrick')
 #'
-radial_trans <- function(r.range, a.range, offset = pi/2, pad = 0.5,
+radial_trans <- function(r.range, a.range, offset = pi/2, pad = 0.5, direction=1,
                          clip = FALSE) {
     a.range[which.min(a.range)] <- min(a.range) - pad
     a.range[which.max(a.range)] <- max(a.range) + pad
@@ -121,6 +122,7 @@ radial_trans <- function(r.range, a.range, offset = pi/2, pad = 0.5,
             } else {
                 a <- offset + (a - a.range[1])/diff(a.range) * -2*pi
             }
+            a <- sign(direction) * a
             data.frame(x = r*cos(a), y = r*sin(a))
         },
         inverse = function(x, y) {

vignettes/bert_lh_aparc.a2009s_area.csv

@@ -0,0 +1,2 @@
+lh.aparc.a2009s.area,lh_G_and_S_frontomargin_area,lh_G_and_S_occipital_inf_area,lh_G_and_S_paracentral_area,lh_G_and_S_subcentral_area,lh_G_and_S_transv_frontopol_area,lh_G_and_S_cingul-Ant_area,lh_G_and_S_cingul-Mid-Ant_area,lh_G_and_S_cingul-Mid-Post_area,lh_G_cingul-Post-dorsal_area,lh_G_cingul-Post-ventral_area,lh_G_cuneus_area,lh_G_front_inf-Opercular_area,lh_G_front_inf-Orbital_area,lh_G_front_inf-Triangul_area,lh_G_front_middle_area,lh_G_front_sup_area,lh_G_Ins_lg_and_S_cent_ins_area,lh_G_insular_short_area,lh_G_occipital_middle_area,lh_G_occipital_sup_area,lh_G_oc-temp_lat-fusifor_area,lh_G_oc-temp_med-Lingual_area,lh_G_oc-temp_med-Parahip_area,lh_G_orbital_area,lh_G_pariet_inf-Angular_area,lh_G_pariet_inf-Supramar_area,lh_G_parietal_sup_area,lh_G_postcentral_area,lh_G_precentral_area,lh_G_precuneus_area,lh_G_rectus_area,lh_G_subcallosal_area,lh_G_temp_sup-G_T_transv_area,lh_G_temp_sup-Lateral_area,lh_G_temp_sup-Plan_polar_area,lh_G_temp_sup-Plan_tempo_area,lh_G_temporal_inf_area,lh_G_temporal_middle_area,lh_Lat_Fis-ant-Horizont_area,lh_Lat_Fis-ant-Vertical_area,lh_Lat_Fis-post_area,lh_Pole_occipital_area,lh_Pole_temporal_area,lh_S_calcarine_area,lh_S_central_area,lh_S_cingul-Marginalis_area,lh_S_circular_insula_ant_area,lh_S_circular_insula_inf_area,lh_S_circular_insula_sup_area,lh_S_collat_transv_ant_area,lh_S_collat_transv_post_area,lh_S_front_inf_area,lh_S_front_middle_area,lh_S_front_sup_area,lh_S_interm_prim-Jensen_area,lh_S_intrapariet_and_P_trans_area,lh_S_oc_middle_and_Lunatus_area,lh_S_oc_sup_and_transversal_area,lh_S_occipital_ant_area,lh_S_oc-temp_lat_area,lh_S_oc-temp_med_and_Lingual_area,lh_S_orbital_lateral_area,lh_S_orbital_med-olfact_area,lh_S_orbital-H_Shaped_area,lh_S_parieto_occipital_area,lh_S_pericallosal_area,lh_S_postcentral_area,lh_S_precentral-inf-part_area,lh_S_precentral-sup-part_area,lh_S_suborbital_area,lh_S_subparietal_area,lh_S_temporal_inf_area,lh_S_temporal_sup_area,lh_S_temporal_transverse_area,lh_WhiteSurfArea_area
+bert,789.0,1133.0,968.0,862.0,491.0,1537.0,1009.0,906.0,346.0,183.0,1354.0,864.0,160.0,936.0,2758.0,4567.0,330.0,438.0,1452.0,967.0,1154.0,1926.0,723.0,1591.0,1738.0,2257.0,2196.0,1321.0,1635.0,1706.0,784.0,357.0,347.0,1465.0,248.0,764.0,2081.0,1823.0,248.0,270.0,980.0,1349.0,1203.0,1702.0,2031.0,728.0,336.0,1126.0,1343.0,452.0,293.0,1697.0,1002.0,1666.0,440.0,2211.0,852.0,548.0,249.0,745.0,1477.0,261.0,492.0,869.0,1706.0,535.0,1866.0,1000.0,778.0,519.0,495.0,743.0,3239.0,257.0,81870.2