Skip to content

GitLab

T
tableExtra
Commit 128e66ba authored by Pradat Yoann's avatar Pradat Yoann
Browse files
Options

v0.99.0 successful run on PCAWG SBS counts data

parent b1a6bb6a
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 750 additions and 248 deletions
.gitignore
View file @ 128e66ba
# Project specific
**/tests/*.pdf
# Tags
*tags
# Logs
log/
*.log
......
DESCRIPTION
View file @ 128e66ba
Package: tableExtra
Title: Draws an awesome table
Version: 0.0.0.9000
Version: 0.99.0
Authors@R:
person(given = "Yoann",
family = "Pradat",
......
NAMESPACE
View file @ 128e66ba
# 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
View file @ 128e66ba
## 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
View file @ 128e66ba
......@@ -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 0 → 100644
View file @ 128e66ba
#' 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 0 → 100644
View file @ 128e66ba
#' 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 0 → 100644
View file @ 128e66ba
#' @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
View file @ 128e66ba
......@@ -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
View file @ 128e66ba
#' @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 0 → 100644
View file @ 128e66ba
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/pcwag_counts-data.R
\docType{data}
\name{pcawg_counts}
\alias{pcawg_counts}
\title{Mutation counts attributed to each mutational signature in each tumour.}
\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}
}
}
\source{
Synapse collaborative compute space, \url{https://www.synapse.org/#!Synapse:syn11804065}
}
\usage{