v0.99.4 add legend 1 and legend 2 aside

DESCRIPTION

 Package: tableExtra
 Title: Draws an awesome table
-Version: 0.99.3
+Version: 0.99.4
 Authors@R: 
     person(given = "Yoann",
            family = "Pradat",

Makefile

+# prepare the package for release
+PKGNAME := $(shell sed -n "s/Package: *\([^ ]*\)/\1/p" DESCRIPTION)
+PKGVERS := $(shell sed -n "s/Version: *\([^ ]*\)/\1/p" DESCRIPTION)
+PKGSRC  := $(shell basename `pwd`)
+R ?= R
+
+build:
+	$(R) CMD build --no-manual .
+
+install: build-cran
+	$(R) CMD INSTALL $(PKGNAME)_$(PKGVERS).tar.gz
+
+build-cran:
+	$(R) CMD build .
+
+check: build-cran
+	$(R) CMD check $(PKGNAME)_$(PKGVERS).tar.gz --as-cran
+
+manual:
+	$(R) -e 'devtools::document();devtools::build_manual(path=".")'
+
+test:
+	$(R) -e 'if (any(as.data.frame(devtools::test())[["failed"]] > 0)) stop("Some tests failed.")'
+
+ctags: 
+	ctags -R R
+
+clean:
+	$(RM) -r $(PKGNAME).Rcheck/
+	$(RM) -f tags
+	$(RM) -f $(PKGNAME)_$(PKGVERS).pdf
+ 
+clean-all: clean
+	$(RM) -r $(PKGNAME)_$(PKGVERS).tar.gz 

R/gtables.R

@@ -14,7 +14,8 @@
 #' @param padding \code{unit.list} object specifying the padding between adjacent cells.
 #' @param name optional name of the grob
 #' @param vp optional viewport
-#' @param ... additional parameters passed to add_table_params.
+#' @param rep_mode optional parameter passed to \code{table_params}.
+#' @param ... additional parameters passed to \code{add_table_params}.
 #' @return A gtable.
 #'
 #' @import gtable
@@ -23,9 +24,9 @@
 #' @keywords internal
 gtable_table <- function(d, widths, heights,
                          fg_fun = text_grob, fg_params = list(),
-                         bg_fun = rect_grob, bg_params = list(),
+                         bg_fun = NULL, bg_params = NULL,
                          padding = unit(c(4, 4), "mm"),
-                         name = "table", vp = NULL, ...){
+                         name = "table", vp = NULL, rep_mode="row", ...){
 
   d <- as.matrix(d)
 
@@ -33,16 +34,12 @@ gtable_table <- function(d, widths, heights,
   nr <- nrow(d)
   n <- nc*nr
 
-  tb_params <- table_params(d, fg_params, bg_params)
-  bg_params <- tb_params[["bg_params"]]
+  tb_params <- table_params(d, fg_params, bg_params, rep_mode)
   fg_params <- tb_params[["fg_params"]]
   fg_params <- add_table_params(d, fg_params, fg_fun, ...)
 
   frgds <- do.call(mapply, c(fg_params, list(FUN = fg_fun, SIMPLIFY=FALSE)))
-  bkgds <- do.call(mapply, c(bg_params, list(FUN = bg_fun, SIMPLIFY=FALSE)))
-
   frgds_grobs <- matrix(frgds, ncol = nc, byrow = FALSE)
-  bkgds_grobs <- matrix(bkgds, ncol = nc, byrow = FALSE)
 
   if(missing(widths))
     widths <- col_widths(frgds_grobs)
@@ -56,10 +53,16 @@ gtable_table <- function(d, widths, heights,
                      heights = heights, vp=vp)
   
   ## add the background
-  g <- gtable_add_grob(g, bkgds_grobs, 
-                       t=rep(seq_len(nr), length.out = n), 
-                       l=rep(seq_len(nc), each = nr), z=0, 
-                       name=paste0(name, "-bg"))
+  if (!is.null(bg_params)){
+    bg_params <- tb_params[["bg_params"]]
+    bkgds <- do.call(mapply, c(bg_params, list(FUN = bg_fun, SIMPLIFY=FALSE)))
+    bkgds_grobs <- matrix(bkgds, ncol = nc, byrow = FALSE)
+
+    g <- gtable_add_grob(g, bkgds_grobs, 
+                         t=rep(seq_len(nr), length.out = n), 
+                         l=rep(seq_len(nc), each = nr), z=0, 
+                         name=paste0(name, "-bg"))
+  }
   
   # add padding
   g <- gtable_add_col_space(g, padding[1])
@@ -67,3 +70,84 @@ gtable_table <- function(d, widths, heights,
 
   g
 }
+
+#' Build a grob containing a legend.
+#'
+#' Build a grob with a legend inside.
+#'
+#' @param d data.frame or matrix
+#' @param widths optional \code{unit.list} specifying the grob widths
+#' @param heights optional \code{unit.list} specifying the grob heights
+#' @param fg_fun grob-drawing function
+#' @param fg_params  named list of params passed to fg_fun
+#' @param bg_fun grob-drawing function 
+#' @param bg_params  named list of params passed to bg_fun
+#' @param title_x \code{unit} specifying the x position of the title
+#' @param title_y \code{unit} specifying the x position of the title
+#' @param title_label character vector
+#' @param padding \code{unit.list} object specifying the padding between adjacent cells.
+#' @param name optional name of the grob
+#' @param vp optional viewport
+#' @param ... additional parameters passed to \code{add_table_params}.
+#' @return A gtable.
+#'
+#' @import gtable
+#'
+#' @author Yoann Pradat
+#' @keywords internal
+gtable_legend <- function(d, labels, widths, heights, fg_fun, fg_params, bg_fun=NULL, bg_params=NULL,
+                          title_x=NULL, title_y=NULL, title_label="Title", title_gp=gpar(fontsize=10), 
+                          labels_pad=unit(-1,"mm"), labels_gp=gpar(fontsize=6), padding=unit(0.3, "mm"),
+                          name="legend", vp=NULL, orientation="horizontal", ...){
+
+  # legend body
+  g <- gtable_table(d, name=name,
+                    widths=widths,
+                    heights=heights,
+                    fg_fun=fg_fun,
+                    bg_fun=bg_fun, 
+                    fg_params=fg_params, 
+                    bg_params=bg_params, 
+                    padding=padding, ...)
+
+  # legend title
+  g_title <- textGrob(label=title_label, 
+                      x=title_x,
+                      y=title_y,
+                      just="centre", 
+                      gp=title_gp)
+  g <- gtable_add_grob(g, g_title, t=1, l=1, b=1, r=1, name=paste0(name, "_title"), clip="off")
+
+  # legend labels
+  if (orientation=="horizontal"){
+    x <- unit(0, attr(padding, "unit"))
+    for (i in 1:length(labels)){
+      g_label <- textGrob(label=labels[i], 
+                          x=x,
+                          y=labels_pad, 
+                          just="centre", 
+                          gp=labels_gp)
+      g <- gtable_add_grob(g, g_label, t=1, l=1, b=1, r=1, name=paste0(name, "_label_", i), clip="off")
+      if (i < length(labels)){
+        x <- x + widths[i] + padding[2]
+      }
+    }
+  } else if (orientation=="vertical"){
+    y <- (-1)*sum(heights) + heights[1] + (-1)*(length(heights)-1)*padding[1]
+    for (i in 1:length(labels)){
+      g_label <- textGrob(label=labels[i], 
+                          x=labels_pad,
+                          y=y, 
+                          just="centre", 
+                          gp=labels_gp)
+      g <- gtable_add_grob(g, g_label, t=1, l=1, b=1, r=1, name=paste0(name, "_label_", i), clip="off")
+      if (i < length(labels)){
+        y <- y + heights[i] + padding[1]
+      }
+    }
+  } else {
+    stop("Unsupported value '", orientation, "' of orientation. Choose 'vertical' or 'horizontal'")
+  }
+
+  g
+}

R/other_utils.R

@@ -16,11 +16,19 @@ col_widths <- function(m){
     1.1*max(do.call(grid::unit.c, lapply(l, grid::grobWidth)))))
 }
 
-rep_ifshort <- function(x, n, nc, nr){
+rep_ifshort <- function(x, n, nc, nr, rep_mode){
     if(length(x) >= n){
       return(x[1:n]) 
-    } else # recycle 
-      return(rep(rep(x, length.out = nr), length.out= n)) 
+    } else {
+      # recycle
+      if (rep_mode=="row"){
+        return(rep(rep(x, length.out=nr), length.out=n)) 
+      } else if (rep_mode=="col") {
+        return(as.vector(matrix(rep(rep(x, length.out=nc), length.out=n), byrow=T, nrow=nr)))
+      } else {
+        stop(paste0("Unsupported value '", rep_mode,"' of rep_mode. Choose 'col' or 'row'"))
+      }
+    }
 }
 
 breaks_scale <- function(d, d_min=NULL, d_max=NULL, breaks=10){

R/table_extra_grob.R

@@ -50,6 +50,7 @@ table_extra_grob <- function(dscale, dcolor=NULL,
                     scale_breaks=theme$core$scale_breaks,
                     dscale_min=dscale_min,
                     dscale_max=dscale_max,
+                    rep_mode=theme$core$rep_mode,
                     r_min=theme$core$scale_ratio*0.5*theme$core$size,
                     r_max=0.5*theme$core$size,
                     color_palette=theme$core$color_palette,

R/table_params.R

@@ -8,15 +8,19 @@
 #'
 #' @author Yoann Pradat
 #' @keywords internal
-table_params <- function(d, fg_params, bg_params){
+table_params <- function(d, fg_params, bg_params=NULL, rep_mode="row"){
   nc <- ncol(d)
   nr <- nrow(d)
   n <- nc*nr
   
-  fg_params <- lapply(fg_params, rep_ifshort, n = n, nc = nc, nr = nr)
-  bg_params <- lapply(bg_params, rep_ifshort, n = n, nc = nc, nr = nr)
-  
-  return(list(fg_params=fg_params, bg_params=bg_params))
+  fg_params <- lapply(fg_params, rep_ifshort, n = n, nc = nc, nr = nr, rep_mode=rep_mode)
+
+  if (!is.null(bg_params)){
+    bg_params <- lapply(bg_params, rep_ifshort, n = n, nc = nc, nr = nr, rep_mode=rep_mode)
+    return(list(fg_params=fg_params, bg_params=bg_params))
+  } else {
+    return(list(fg_params=fg_params))
+  }
 }
 
 #' Add circle scale parameters
@@ -52,7 +56,7 @@ table_params_circle_scale <- function(d, scale_breaks=10, r_min=unit(4, "mm"), r
 #'
 #' @author Yoann Pradat
 #' @keywords internal
-table_params_circle_color <- function(d, color_palette, color_breaks=NULL){
+table_params_color <- function(d, color_palette, color_breaks=NULL){
   if (is.null(d)){
     return(list())
   } else {
@@ -75,6 +79,27 @@ table_params_circle_color <- function(d, color_palette, color_breaks=NULL){
   }
 }
 
+#' Add rect parameters
+#'
+#' @param d data.frame or matrix
+#' @param scale_breaks integer indicating the number of differently-sized circles
+#' @param r_max unit object indicating the maximum radius
+#' @param color_palette a character vector of color names
+#' @param color_breaks a numeric vector of break points
+#'
+#' @importFrom grid unit.c 
+#'
+#' @author Yoann Pradat
+#' @keywords internal
+table_params_rect <- function(dcolor, color_palette=NULL, color_breaks=NULL){
+  params <- NULL
+  if (!is.null(color_palette)){
+    params_color <- table_params_color(d=dcolor, color_palette=color_palette, color_breaks=color_breaks)
+    params <- c(params, params_color)
+  }
+  return(params)
+}
+
 #' Add circle parameters
 #'
 #' @param d data.frame or matrix
@@ -93,7 +118,7 @@ table_params_circle <- function(dscale, dcolor, scale_breaks, r_min, r_max,  col
                                             d_min=dscale_min, d_max=dscale_max)
 
   if(!missing(dcolor)){
-    params_color <- table_params_circle_color(d=dcolor, color_palette=color_palette, color_breaks=color_breaks)
+    params_color <- table_params_color(d=dcolor, color_palette=color_palette, color_breaks=color_breaks)
     params <- c(params_scale, params_color)
   } else {
     params <- params_scale
@@ -127,6 +152,8 @@ add_table_params <- function(d, params, fun, ...){
     extra_params <- table_params_circle(d, ...)
   } else if (all.equal(fun, text_grob)==T) {
     extra_params <- table_params_text(d)
+  } else if (all.equal(fun, rect_grob)==T) { 
+    extra_params <- table_params_rect(d, ...)
   } else {
     stop("unsupported value of fun")
   }

R/ttheme_awesome.R

@@ -8,6 +8,7 @@
 #' @param scale_ratio ratio of minimum to maximum core foreground grobs sizes
 #' @param color_palette color palette for core foreground grobs
 #' @param color_breaks bin breaks for color palette for core foreground grobs
+#' @param rep_mode 'col' or 'row'. Used when recycling fg_params or bg_params to make a matrix of params.
 #' @param parse logical, default behaviour for parsing text as plotmath
 #' @param padding length-2 unit vector specifying the horizontal and vertical padding of text within each cell
 #' @param ... extra parameters added to the theme list
@@ -25,6 +26,7 @@ ttheme_awesome <- function(base_size=8,
                            scale_ratio=0.25,
                            color_palette="black",
                            color_breaks=NULL,
+                           rep_mode="col",
                            parse=FALSE, 
                            padding=unit(c(0.3,0.3), "mm"), ...){
 
@@ -41,6 +43,7 @@ ttheme_awesome <- function(base_size=8,
                               height=core_size_value,
                               default.units=core_size_unit,
                               lwd=0, col="white"),
+               rep_mode=rep_mode,
                size=core_size,
                scale_breaks=scale_breaks,
                scale_ratio=scale_ratio,

data-raw/cosmic_v3_aetiologies.csv

+"Aetiology","Signature"
+"Spontaneous deamination of 5-methylcytosine (clock-like signature)","SBS1"
+"Activity of APOBEC family of cytidine deaminases","SBS2"
+"Defective homologous recombination DNA damage repair","SBS3"
+"Tobacco smoking","SBS4"
+"Unknown (clock-like signature)","SBS5"
+"Defective DNA mismatch repair","SBS6"
+"Ultraviolet light exposure","SBS7a"
+"Ultraviolet light exposure","SBS7b"
+"Ultraviolet light exposure","SBS7c"
+"Ultraviolet light exposure","SBS7d"
+"Unknown","SBS8"
+"Polimerase eta somatic hypermutation activity","SBS9"
+"Polymerase epsilon exonuclease domain mutations","SBS10a"
+"Polymerase epsilon exonuclease domain mutations","SBS10b"
+"Temozolomide treatment","SBS11"
+"Unknown","SBS12"
+"Activity of APOBEC family of cytidine deaminases","SBS13"
+"Concurrent polymerase epsilon mutation and defective DNA mismatch repair","SBS14"
+"Defective DNA mismatch repair","SBS15"
+"Unknown","SBS16"
+"Unknown","SBS17a"
+"Unknown","SBS17b"
+"Damage by reactive oxygen species","SBS18"
+"Unknown","SBS19"
+"Concurrent POLD1 mutations and defective DNA mismatch repair","SBS20"
+"Defective DNA mismatch repair","SBS21"
+"Aristolochic acid exposure","SBS22"
+"Unknown","SBS23"
+"Aflatoxin exposure","SBS24"
+"Chemotherapy treatment","SBS25"
+"Defective DNA mismatch repair","SBS26"
+"Possible sequencing artefact","SBS27"
+"Unknown","SBS28"
+"Tobacco chewing","SBS29"
+"Defective DNA base excision repair due to NTHL1 mutations","SBS30"
+"Platinum chemotherapy treatment","SBS31"
+"Azathioprine treatment","SBS32"
+"Unknown","SBS33"
+"Unknown","SBS34"
+"Platinum chemotherapy treatment","SBS35"
+"Defective DNA base excision repair due to MUTYH mutations","SBS36"
+"Unknown","SBS37"
+"Indirect effect of ultraviolet light","SBS38"
+"Unknown","SBS39"
+"Unknown","SBS40"
+"Unknown","SBS41"
+"Haloalkane exposure","SBS42"
+"Possible sequencing artefact","SBS43"
+"Defective DNA mismatch repair","SBS44"
+"Possible sequencing artefact","SBS45"
+"Possible sequencing artefact","SBS46"
+"Possible sequencing artefact","SBS47"
+"Possible sequencing artefact","SBS48"
+"Possible sequencing artefact","SBS49"
+"Possible sequencing artefact","SBS50"
+"Possible sequencing artefact","SBS51"
+"Possible sequencing artefact","SBS52"
+"Possible sequencing artefact","SBS53"
+"Possible sequencing artefact","SBS54"
+"Possible sequencing artefact","SBS55"
+"Possible sequencing artefact","SBS56"
+"Possible sequencing artefact","SBS57"
+"Possible sequencing artefact","SBS58"
+"Possible sequencing artefact","SBS59"
+"Possible sequencing artefact","SBS60"
+"Activity of activation-induced cytidine deaminase (AID)","SBS84"
+"Indirect effects of activation-induced cytidine deaminase (AID)","SBS85"
+"Unknown chemotherapy treatment","SBS86"
+"Thiopurine chemotherapy treatment","SBS87"
+"Colibactin exposure (E.coli bacteria carrying pks pathogenicity island)","SBS88"
+"Unknown","SBS89"
+"Duocarmycin exposure","SBS90"

man/gtable_legend.Rd

+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/gtables.R
+\name{gtable_legend}
+\alias{gtable_legend}
+\title{Build a grob containing a legend.}
+\usage{
+gtable_legend(
+  d,
+  labels,
+  widths,
+  heights,
+  fg_fun,
+  fg_params,
+  bg_fun = NULL,
+  bg_params = NULL,
+  title_x = NULL,
+  title_y = NULL,
+  title_label = "Title",
+  title_gp = gpar(fontsize = 10),
+  labels_pad = unit(-1, "mm"),
+  labels_gp = gpar(fontsize = 6),
+  padding = unit(0.3, "mm"),
+  name = "legend",
+  vp = NULL,
+  orientation = "horizontal",
+  ...
+)
+}
+\arguments{
+\item{d}{data.frame or matrix}
+
+\item{widths}{optional \code{unit.list} specifying the grob widths}
+
+\item{heights}{optional \code{unit.list} specifying the grob heights}
+
+\item{fg_fun}{grob-drawing function}
+
+\item{fg_params}{named list of params passed to fg_fun}
+
+\item{bg_fun}{grob-drawing function}
+
+\item{bg_params}{named list of params passed to bg_fun}
+
+\item{title_x}{\code{unit} specifying the x position of the title}
+
+\item{title_y}{\code{unit} specifying the x position of the title}
+
+\item{title_label}{character vector}
+
+\item{padding}{\code{unit.list} object specifying the padding between adjacent cells.}
+
+\item{name}{optional name of the grob}
+
+\item{vp}{optional viewport}
+
+\item{...}{additional parameters passed to \code{add_table_params}.}
+}
+\value{
+A gtable.
+}
+\description{
+Build a grob with a legend inside.
+}
+\author{
+Yoann Pradat
+}
+\keyword{internal}

man/gtable_table.Rd

@@ -10,11 +10,12 @@ gtable_table(
   heights,
   fg_fun = text_grob,
   fg_params = list(),
-  bg_fun = rect_grob,
-  bg_params = list(),
+  bg_fun = NULL,
+  bg_params = NULL,
   padding = unit(c(4, 4), "mm"),
   name = "table",
   vp = NULL,
+  rep_mode = "row",
   ...
 )
 }
@@ -39,7 +40,9 @@ gtable_table(
 
 \item{vp}{optional viewport}
 
-\item{...}{additional parameters passed to add_table_params.}
+\item{rep_mode}{optional parameter passed to \code{table_params}.}
+
+\item{...}{additional parameters passed to \code{add_table_params}.}
 }
 \value{
 A gtable.

man/table_params.Rd

@@ -4,7 +4,7 @@
 \alias{table_params}
 \title{Build a table of parameters.}
 \usage{
-table_params(d, fg_params, bg_params)
+table_params(d, fg_params, bg_params = NULL, rep_mode = "row")
 }
 \arguments{
 \item{d}{data.frame or matrix}

man/table_params_circle_color.Rd → man/table_params_color.Rd

 % Generated by roxygen2: do not edit by hand
 % Please edit documentation in R/table_params.R
-\name{table_params_circle_color}
-\alias{table_params_circle_color}
+\name{table_params_color}
+\alias{table_params_color}
 \title{Add circle color parameters}
 \usage{
-table_params_circle_color(d, color_palette, color_breaks = NULL)
+table_params_color(d, color_palette, color_breaks = NULL)
 }
 \arguments{
 \item{d}{data.frame or matrix}

man/table_params_rect.Rd

+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/table_params.R
+\name{table_params_rect}
+\alias{table_params_rect}
+\title{Add rect parameters}
+\usage{
+table_params_rect(dcolor, color_palette = NULL, color_breaks = NULL)
+}
+\arguments{
+\item{color_palette}{a character vector of color names}
+
+\item{color_breaks}{a numeric vector of break points}
+
+\item{d}{data.frame or matrix}
+
+\item{scale_breaks}{integer indicating the number of differently-sized circles}
+
+\item{r_max}{unit object indicating the maximum radius}
+}
+\description{
+Add rect parameters
+}
+\author{
+Yoann Pradat
+}
+\keyword{internal}

man/ttheme_awesome.Rd

@@ -13,6 +13,7 @@ ttheme_awesome(
   scale_ratio = 0.25,
   color_palette = "black",
   color_breaks = NULL,
+  rep_mode = "col",
   parse = FALSE,
   padding = unit(c(0.3, 0.3), "mm"),
   ...
@@ -35,6 +36,8 @@ ttheme_awesome(
 
 \item{color_breaks}{bin breaks for color palette for core foreground grobs}
 
+\item{rep_mode}{'col' or 'row'. Used when recycling fg_params or bg_params to make a matrix of params.}
+
 \item{parse}{logical, default behaviour for parsing text as plotmath}
 
 \item{padding}{length-2 unit vector specifying the horizontal and vertical padding of text within each cell}

tests/testthat/helper.R

@@ -15,4 +15,4 @@ plot_grob <- function(g, name, width=NULL, height=NULL){
 }
 
 # Aetiologies for PCAWG
-
+SBS_aetiology <- read.csv("../../data-raw/cosmic_v3_aetiologies.csv", stringsAsFactors=F)

tests/testthat/test-legend.R

+test_that("legend circle grob", {
+  scale_breaks <- seq(from=0, to=1, by=0.1)
+
+  theme <- ttheme_awesome(base_size=12,
+                          rep_mode="col",
+                          core_size=unit(5, "mm"), 
+                          scale_breaks=scale_breaks,
+                          color_palette=NULL, 
+                          color_breaks=NULL)
+
+  g <- gtable_legend(d=t(scale_breaks[2:length(scale_breaks)]),
+                     labels=scale_breaks,
+                     widths=rep(theme$core$size, length(scale_breaks)-1),
+                     heights=theme$core$size,
+                     fg_fun=theme$core$fg_fun,