v0.99.0 successful run on PCAWG SBS counts data

.gitignore

 # Project specific
 **/tests/*.pdf
 
+# Tags
+*tags
+
 # Logs 
 log/
 *.log

DESCRIPTION

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

NAMESPACE

 # Generated by roxygen2: do not edit by hand
 
-S3method(str,gtable)
 export(combine)
-export(extra_table_grob)
 export(gtable_cbind)
 export(gtable_combine)
 export(gtable_rbind)
+export(table_extra_grob)
 export(ttheme_awesome)
 import(grid)
 import(gtable)
 importFrom(grid,unit.c)
 importFrom(gtable,gtable_add_rows)
+importFrom(methods,is)
 importFrom(utils,modifyList)
-importFrom(utils,str)

R/gtable_utils.R

 ## Misc. gtable functions
 ## Note: these functions were copied from the gridExtra package.
 
-##'Prints summary information on gtable objects
-##'@param object a gtable
-##'@param ... unused
-##'@importFrom utils str
-##'@method str gtable
-##' @noRd
-##'@export
-str.gtable <- function(object, ...){
-  cat(c("gtable, containing \ngrobs (", 
-        length(object[["grobs"]]), ") :"), sep="")
-  utils::str(vapply(object$grobs, as.character, character(1)))
-  cat("layout :\n")
-  utils::str(object[["layout"]])
-  cat("widths :\nunit vector of length", 
-      length(object[["widths"]]), "\n")
-  cat("heights :\nunit vector of length", 
-      length(object[["heights"]]), "\n")
-  for(element in c("respect", "rownames", 
-                   "name", "gp", "vp")){
-    cat(element, ":\n")
-    utils::str(object[[element]])
-  }
-}
-
-
-##'Combine gtables based on row/column names.
-##'@param ... gtables
-#' @aliases combine
-##'@rdname combine
-##'@param along dimension to align along, \code{1} = rows,
-##'\code{2} = cols. 
-##'@param join when x and y have different names, how should the difference be resolved? 
-##'\code{inner} keep names that appear in both, 
-##'\code{outer} keep names that appear in either, 
-##'\code{left} keep names from \code{x}, 
-##'and \code{right} keep names from \code{y}.
-##'@export
+#'Combine gtables based on row/column names.
+#'@param ... gtables
+#'@aliases combine
+#'@rdname combine
+#'@param along dimension to align along, \code{1} = rows,
+#'\code{2} = cols. 
+#'@param join when x and y have different names, how should the difference be resolved? 
+#'\code{inner} keep names that appear in both, 
+#'\code{outer} keep names that appear in either, 
+#'\code{left} keep names from \code{x}, 
+#'and \code{right} keep names from \code{y}.
+#'@export
 gtable_combine <- function (..., along = 1L, join = "outer") 
 {
   gtables <- list(...)

R/other_utils.R

@@ -16,32 +16,45 @@ col_widths <- function(m){
     1.1*max(do.call(grid::unit.c, lapply(l, grid::grobWidth)))))
 }
 
-scalecat <- function(m, m_min=NULL, m_max=NULL, n_cat=10, vmax=0.5){
-  if (is.null(m_min)){
-    m_min = min(m)
+rep_ifshort <- function(x, n, nc, nr){
+    if(length(x) >= n){
+      return(x[1:n]) 
+    } else # recycle 
+      return(rep(rep(x, length.out = nr), length.out= n)) 
+}
+
+breaks_scale <- function(d, d_min=NULL, d_max=NULL, breaks=10){
+  if (is.null(d_min)){
+    d_min = min(d)
   }
 
-  if (is.null(m_max)){
-    m_max = max(m)
+  if (is.null(d_max)){
+    d_max = max(d)
   }
 
-  if (m_min == m_max){
-    if (m_min != 0){
-      m <- m/m_max
+  if (d_min == d_max){
+    if (d_min != 0){
+      d <- d/d_max
     } else {
-      m <- m
+      d <- d
     }
   } else {
-    m <- (m-m_min)/(m_max - m_min)
+    d <- (d-d_min)/(d_max - d_min)
   }
-  
-  m <- apply(m, 1:2, function(x) round(x*n_cat)/(n_cat/vmax))
-  m
-}
 
-rep_ifshort <- function(x, n, nc, nr){
-    if(length(x) >= n){
-      return(x[1:n]) 
-    } else # recycle 
-      return(rep(rep(x, length.out = nr), length.out= n)) 
+  if (length(breaks)==1){
+    breaks <- seq(from=0, to=1, length.out=breaks+1)
+  } else {
+    breaks <- (breaks-d_min)/(d_max-d_min)
+  }
+
+  dint <- cut(d, labels=F, breaks=breaks, left.open=T)
+  dint <- (breaks[dint] + breaks[dint+1])/2
+  dint[is.na(dint)] <- 0
+  dcut <- matrix(dint, nrow=nrow(d), byrow=F)
+
+  # set max scale is 1
+  dcut <- dcut/max(dcut)
+
+  dcut
 }

R/pcwag_counts-data.R

+#' Mutation counts attributed to each mutational signature in each tumour.
+#'
+#' Data from the mutational signature analysis of Alexandrov et al. on the PCAWG data.
+#' The data is available as supplementary data to the paper "The repertoire of mutational signatures in human cancer"
+#' on the Synapse data repository syn11738669
+#' 
+#' \code{pcawg_counts} contains the mutation counts as attributed by the SigProfiler algorithm on the
+#' Single-Base-Substitution (SBSs) mutation catalogs of 2780 WGS tumours from the PCAWG.
+#'
+#' @format A data frame with 2780 rows and 68 variables
+#' \describe{
+#'   \item{Cancer.Types}{37 different cancer types}
+#'   \item{Sample.Names}{Unique tumour identifiers}
+#'   \item{Accuracy}{Cosine similarity between the tumour's mutational profile and the reconstructed mutational profile}
+#'   \item{SBSXXX}{Each SBSXXX variable represents the counts attributed to the signature SBSXXX in the corresponding
+#'     tumour}
+#' }
+#'
+#' @docType data
+#' @usage data(pcawg_counts)
+#' @keywords datasets
+#'
+#' @references 
+#' Alexandrov, L.B., Kim, J., Haradhvala, N.J. et al. The repertoire of mutational signatures in human cancer. 
+#' Nature 578, 94–101 (2020). \url{https://doi.org/10.1038/s41586-020-1943-3}
+#'
+#' @source Synapse collaborative compute space, <https://www.synapse.org/#!Synapse:syn11804065>
+#'
+#' @examples
+#' data(pcawg_counts)
+"pcawg_counts"

R/tableExtra.R

+#' tableExtra: A package for awesome tables
+#'
+#' 'tableExtra' provides a function to draw a table with grobs of varying size and colors to represent two different
+#' types of information about multiple variables in multiple samples.
+#' The package was originally developed to reproduce Figure 3 of Alexandrov, L.B., Kim, J., Haradhvala, N.J. et al. 
+#' The repertoire of mutational signatures in human cancer. Nature 578, 94–101 (2020).
+#' <https://doi.org/10.1038/s41586-020-1943-3>
+#'
+#' @docType package
+#' @author Yoann Pradat
+#' @name tableExtra
+#' @import gtable grid
+NULL

R/table_extra_grob.R

+#' @title Graphical display of a table with circles of varying scales and colours.
+#'
+#' The code is inspired by the [gridExtra::tableGrob()] function.
+#'
+#' @description Create a gtable containing circle grobs representing a numeric matrix.
+#' @param dscale a matrix
+#' @param dcolor (optional) a matrix
+#' @param rows (optional) a character vector
+#' @param cols (optional) a character vector
+#' @param theme list of theme parameters
+#' @param vp optional viewport
+#'
+#' @import gtable
+#' @importFrom gtable gtable_add_rows 
+#'
+#' @seealso [theme_awesome()]
+#'
+#' @return An R object of class \code{grob}
+#'
+#' @author Yoann Pradat
+#'
+#' @export
+#' @examples
+#' library(tableExtra)
+table_extra_grob <- function(dscale, dcolor=NULL,
+                             dscale_min=NULL, dscale_max=NULL,
+                             rows=rownames(dscale), cols=colnames(dscale), 
+                             rows_more=NULL, cols_more=NULL,
+                             theme=ttheme_awesome(), vp=NULL){
+
+  widths <- rep(theme$core$size, ncol(dscale))
+  heights <- rep(theme$core$size, nrow(dscale))
+
+  g <- gtable_table(dscale, name="circle",
+                    widths=widths,
+                    heights=heights,
+                    fg_fun=theme$core$fg_fun, 
+                    bg_fun=theme$core$bg_fun, 
+                    fg_params=theme$core$fg_params, 
+                    bg_params=theme$core$bg_params, 
+                    padding=theme$core$padding,
+                    scale_breaks=theme$core$scale_breaks,
+                    dscale_min=dscale_min,
+                    dscale_max=dscale_max,
+                    r_min=theme$core$scale_ratio*0.5*theme$core$size,
+                    r_max=0.5*theme$core$size,
+                    color_palette=theme$core$color_palette,
+                    color_breaks=theme$core$color_breaks,
+                    dcolor=dcolor)
+
+  if(!is.null(cols)){
+    if (!is.null(cols_more)){
+      for (cols_m_name in names(cols_more)){
+        cols_m <- cols_more[[cols_m_name]]
+        gc <- gtable_table(t(cols_m), name="colmore",
+                           fg_fun=theme$colmore$fg_fun, 
+                           bg_fun=theme$colmore$bg_fun, 
+                           fg_params=theme$colmore$fg_params, 
+                           bg_params=theme$colmore$bg_params, 
+                           padding=theme$colmore$padding)
+        g <- rbind_2(gc, g, "max", height=theme$colmore$padding[1])
+      }
+    }
+
+    gc <- gtable_table(t(cols), name="colhead",
+                       fg_fun=theme$colhead$fg_fun, 
+                       bg_fun=theme$colhead$bg_fun, 
+                       fg_params=theme$colhead$fg_params, 
+                       bg_params=theme$colhead$bg_params, 
+                       padding=theme$colhead$padding)
+    g <- rbind_2(gc, g, "max", height=theme$colhead$padding[1])
+  }
+
+  if(!is.null(rows)){
+    if(!is.null(cols)){
+      if(!is.null(cols_more))
+        rows <- c("", names(cols_more), rows)
+      else
+        rows <- c("", rows)
+      }
+    gr <- gtable_table(rows, name="rowhead",
+                       fg_fun=theme$rowhead$fg_fun, 
+                       bg_fun=theme$rowhead$bg_fun, 
+                       fg_params=theme$rowhead$fg_params, 
+                       bg_params=theme$rowhead$bg_params,
+                       padding=theme$rowhead$padding)
+    g <- cbind_2(gr, g, "max", width=theme$rowhead$padding[2])
+
+    if(!is.null(rows_more)){
+      for (rows_m_name in names(rows_more)){
+        if(!is.null(cols)){
+          if(!is.null(cols_more)){
+            rows_m <- c("", names(rows_more), rows_more[[rows_m_name]])
+          } else {
+            rows_m <- c("", rows_more[[rows_m_name]])
+          }
+        }
+
+        gr <- gtable_table(rows_m, name="rowmore",
+                           fg_fun=theme$rowmore$fg_fun, 
+                           bg_fun=theme$rowmore$bg_fun, 
+                           fg_params=theme$rowmore$fg_params, 
+                           bg_params=theme$rowmore$bg_params,
+                           padding=theme$rowmore$padding)
+        g <- cbind_2(g, gr, "max", width=theme$rowmore$padding[2])
+      }
+    }
+  }
+
+  colnames(g) <- paste0("c", seq_len(ncol(g)))
+  rownames(g) <- paste0("r", seq_len(nrow(g)))
+
+  if(!is.null(vp)) g$vp <- vp
+  g
+}

R/table_params.R

@@ -22,47 +22,55 @@ table_params <- function(d, fg_params, bg_params){
 #' Add circle scale parameters
 #'
 #' @param d data.frame or matrix
-#' @param n_cat integer indicating the number of differently-sized circles
+#' @param scale_breaks integer indicating the number of differently-sized circles
 #' @param r_max unit object indicating the maximum radius
 #'
 #' @importFrom grid unit.c 
 #'
 #' @author Yoann Pradat
 #' @keywords internal
-table_params_circle_scale <- function(d, n_cat=10, r_max=unit(10, "mm"), d_min=NULL, d_max=NULL){
-  d <- scalecat(d, d_min, d_max, n_cat=n_cat, vmax=1)
+table_params_circle_scale <- function(d, scale_breaks=10, r_min=unit(4, "mm"), r_max=unit(10, "mm"), d_min=NULL, 
+                                      d_max=NULL){
+  d <- breaks_scale(d=d, d_min=d_min, d_max=d_max, breaks=scale_breaks)
   d <- as.vector(d)
-  params <- list(r=do.call(unit.c, lapply(d, function(x) x*r_max)))
+  r_func <- function(x){
+    if (x==0){
+      return(unit(0,"mm"))
+    } else {
+      return(r_min + x*(r_max-r_min))
+    }
+  }
+  params <- list(r=do.call(unit.c, lapply(d, r_func)))
   return(params)
 }
 
 #' Add circle color parameters
 #'
 #' @param d data.frame or matrix
-#' @param pal a character vector of color names
-#' @param pal_breaks a numeric vector of break points
+#' @param color_palette a character vector of color names
+#' @param color_breaks a numeric vector of break points
 #'
 #' @importFrom methods is
 #'
 #' @author Yoann Pradat
 #' @keywords internal
-table_params_circle_color <- function(d, pal, pal_breaks=NULL){
+table_params_circle_color <- function(d, color_palette, color_breaks=NULL){
   if (is.null(d)){
     return(list())
   } else {
-    if (is.null(pal_breaks)){
-      pal_breaks <- length(pal)
+    if (is.null(color_breaks)){
+      color_breaks <- length(color_palette)
     }
-    if (is(pal_breaks,"integer")){
-      if (pal_breaks==1){
-        d <- as.matrix(pal, nrow=nrow(d), ncol=ncol(d))
+    if (is(color_breaks,"integer")){
+      if (color_breaks==1){
+        d <- as.matrix(color_palette, nrow=nrow(d), ncol=ncol(d))
       }
       else {
-        d <- cut(d, breaks=pal_breaks, right=F)
+        d <- cut(d, breaks=color_breaks, right=F)
       }
     } else {
-      d <- cut(d, breaks=pal_breaks, right=F)
-      levels(d) <- pal
+      d <- cut(d, breaks=color_breaks, right=F)
+      levels(d) <- color_palette
     }
     params <- list(fill=as.vector(d))
     return(params)
@@ -72,23 +80,22 @@ table_params_circle_color <- function(d, pal, pal_breaks=NULL){
 #' Add circle parameters
 #'
 #' @param d data.frame or matrix
-#' @param n_cat integer indicating the number of differently-sized circles
+#' @param scale_breaks integer indicating the number of differently-sized circles
 #' @param r_max unit object indicating the maximum radius
-#' @param pal a character vector of color names
-#' @param pal_breaks a numeric vector of break points
+#' @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_circle <- function(dscale, dcolor, n_cat, r_max, pal, pal_breaks, dscale_min=NULL, dscale_max=NULL){
-  if (missing(dscale_min)){
-    print("dscale is missing")
-  }
-  params_scale <- table_params_circle_scale(d=dscale, n_cat=n_cat, r_max=r_max, d_min=dscale_min, d_max=dscale_max)
+table_params_circle <- function(dscale, dcolor, scale_breaks, r_min, r_max,  color_palette, color_breaks, 
+                                dscale_min=NULL, dscale_max=NULL){
+  params_scale <- table_params_circle_scale(d=dscale, scale_breaks=scale_breaks, r_min=r_min, r_max=r_max, 
+                                            d_min=dscale_min, d_max=dscale_max)
 
   if(!missing(dcolor)){
-    params_color <- table_params_circle_color(d=dcolor, pal=pal, pal_breaks=pal_breaks)
+    params_color <- table_params_circle_color(d=dcolor, color_palette=color_palette, color_breaks=color_breaks)
     params <- c(params_scale, params_color)
   } else {
     params <- params_scale

R/table_extra.R → R/ttheme_awesome.R

-#' @aliases ttheme_awesome
-#' @title Graphical display of a textual table
-#'
-#' Builds on top of \code{tableGrob} from gridExtra R package.
-#'
-#' @describeIn circleTableGrog  return a grob
-#' @description Create a gtable containing circle grobs representing a numeric matrix.
-#' @param dscale a matrix
-#' @param dcolor (optional) a matrix
-#' @param rows (optional) a character vector
-#' @param cols (optional) a character vector
-#' @param theme list of theme parameters
-#' @param vp optional viewport
-#'
-#' @import gtable
-#' @importFrom gtable gtable_add_rows 
-#'
-#' @return A gtable.
-#'
-#' @author Yoann Pradat
-#'
-#' @export
-#' @examples
-#' library(tableExtra)
-extra_table_grob <- function(dscale, dcolor=NULL,
-                             dscale_min=NULL, dscale_max=NULL,
-                             rows=rownames(dscale), cols=colnames(dscale), 
-                             rows_more=NULL, cols_more=NULL,
-                             rows_more_title="",
-                             theme=ttheme_awesome(), vp=NULL){
-
-  widths <- rep(theme$core$size, ncol(dscale))
-  heights <- rep(theme$core$size, nrow(dscale))
-
-  g <- gtable_table(dscale, name="circle",
-                    widths=widths,
-                    heights=heights,
-                    fg_fun=theme$core$fg_fun, 
-                    bg_fun=theme$core$bg_fun, 
-                    fg_params=theme$core$fg_params, 
-                    bg_params=theme$core$bg_params, 
-                    padding=theme$core$padding,
-                    n_cat=theme$core$n_cat,
-                    r_max=0.5*theme$core$size,
-                    dscale_min=dscale_min,
-                    dscale_max=dscale_max,
-                    pal=theme$core$pal,
-                    pal_breaks=theme$core$pal_breaks,
-                    dcolor=dcolor)
-
-
-  if(!is.null(cols)){
-    if (!is.null(cols_more)){
-      for (cols_m_name in names(cols_more)){
-        cols_m <- cols_more[[cols_m_name]]
-        gc <- gtable_table(t(cols_m), name="colmore",
-                           fg_fun=theme$colmore$fg_fun, 
-                           bg_fun=theme$colmore$bg_fun, 
-                           fg_params=theme$colmore$fg_params, 
-                           bg_params=theme$colmore$bg_params, 
-                           padding=theme$colmore$padding)
-        g <- rbind_2(gc, g, "max", height=theme$colmore$padding[1])
-      }
-    }
-
-    gc <- gtable_table(t(cols), name="colhead",
-                       fg_fun=theme$colhead$fg_fun, 
-                       bg_fun=theme$colhead$bg_fun, 
-                       fg_params=theme$colhead$fg_params, 
-                       bg_params=theme$colhead$bg_params, 
-                       padding=theme$colhead$padding)
-    g <- rbind_2(gc, g, "max", height=theme$colhead$padding[1])
-  }
-
-  if(!is.null(rows)){
-    if(!is.null(cols)){
-      if(!is.null(cols_more))
-        rows <- c("", names(cols_more), rows)
-      else
-        rows <- c("", rows)
-      }
-    gr <- gtable_table(rows, name="rowhead",
-                       fg_fun=theme$rowhead$fg_fun, 
-                       bg_fun=theme$rowhead$bg_fun, 
-                       fg_params=theme$rowhead$fg_params, 
-                       bg_params=theme$rowhead$bg_params,
-                       padding=theme$rowhead$padding)
-    g <- cbind_2(gr, g, "max", width=theme$rowhead$padding[2])
-
-    if(!is.null(rows_more)){
-      if(!is.null(cols)){
-        if(!is.null(cols_more)){
-          rows_more <- c("", rows_more_title, rows_more)
-        } else {
-          rows_more <- c("", rows_more)
-        }
-      }
-
-      gr <- gtable_table(rows_more, name="rowmore",
-                         fg_fun=theme$rowmore$fg_fun, 
-                         bg_fun=theme$rowmore$bg_fun, 
-                         fg_params=theme$rowmore$fg_params, 
-                         bg_params=theme$rowmore$bg_params,
-                         padding=theme$rowmore$padding)
-      g <- cbind_2(g, gr, "max", width=theme$rowmore$padding[2])
-    }
-  }
-
-  colnames(g) <- paste0("c", seq_len(ncol(g)))
-  rownames(g) <- paste0("r", seq_len(nrow(g)))
-
-  if(!is.null(vp)) g$vp <- vp
-  g
-}
-
-
 #' Define theme for awesome table plot.
 #'
-#' @describeIn circleTableGrob default theme for circle tables
 #' @param base_size default font size
 #' @param base_colour default font colour
 #' @param base_family default font family
 #' @param core_size cell size for core background grobs
-#' @param n_cat number of size categories for core foreground grobs
-#' @param pal color palette for core foreground grobs
-#' @param pal_breaks breaks for color palette for core foreground grobs
+#' @param scale_breaks number of size categories for core foreground grobs or numeric vector of bin breaks
+#' @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 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
@@ -137,9 +21,10 @@ ttheme_awesome <- function(base_size=8,
                            base_colour="black", 
                            base_family="",
                            core_size=unit(10, "mm"),
-                           n_cat=10,
-                           pal="black",
-                           pal_breaks=NULL,
+                           scale_breaks=10,
+                           scale_ratio=0.25,
+                           color_palette="black",
+                           color_breaks=NULL,
                            parse=FALSE, 
                            padding=unit(c(0.3,0.3), "mm"), ...){
 
@@ -157,9 +42,10 @@ ttheme_awesome <- function(base_size=8,
                               default.units=core_size_unit,
                               lwd=0, col="white"),
                size=core_size,
-               n_cat=n_cat,
-               pal=pal,
-               pal_breaks=pal_breaks,
+               scale_breaks=scale_breaks,
+               scale_ratio=scale_ratio,
+               color_palette=color_palette,
+               color_breaks=color_breaks,
                padding=padding)
 
   colhead <- list(fg_fun=text_grob, 
@@ -227,5 +113,4 @@ ttheme_awesome <- function(base_size=8,
                   rowmore=rowmore)
 
   modifyList(default, list(...))
-
 }

man/pcawg_counts.Rd

+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/pcwag_counts-data.R
+\docType{data}
+\name{pcawg_counts}