Commit 22f99fae authored by Pradat Yoann's avatar Pradat Yoann

v0.99.4 add legend 1 and legend 2 aside

parent b0d78adc
Pipeline #10621 failed with stages
in 1 minute
Package: tableExtra Package: tableExtra
Title: Draws an awesome table Title: Draws an awesome table
Version: 0.99.3 Version: 0.99.4
Authors@R: Authors@R:
person(given = "Yoann", person(given = "Yoann",
family = "Pradat", family = "Pradat",
......
# 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
...@@ -14,7 +14,8 @@ ...@@ -14,7 +14,8 @@
#' @param padding \code{unit.list} object specifying the padding between adjacent cells. #' @param padding \code{unit.list} object specifying the padding between adjacent cells.
#' @param name optional name of the grob #' @param name optional name of the grob
#' @param vp optional viewport #' @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. #' @return A gtable.
#' #'
#' @import gtable #' @import gtable
...@@ -23,9 +24,9 @@ ...@@ -23,9 +24,9 @@
#' @keywords internal #' @keywords internal
gtable_table <- function(d, widths, heights, gtable_table <- function(d, widths, heights,
fg_fun = text_grob, fg_params = list(), 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"), padding = unit(c(4, 4), "mm"),
name = "table", vp = NULL, ...){ name = "table", vp = NULL, rep_mode="row", ...){
d <- as.matrix(d) d <- as.matrix(d)
...@@ -33,16 +34,12 @@ gtable_table <- function(d, widths, heights, ...@@ -33,16 +34,12 @@ gtable_table <- function(d, widths, heights,
nr <- nrow(d) nr <- nrow(d)
n <- nc*nr n <- nc*nr
tb_params <- table_params(d, fg_params, bg_params) tb_params <- table_params(d, fg_params, bg_params, rep_mode)
bg_params <- tb_params[["bg_params"]]
fg_params <- tb_params[["fg_params"]] fg_params <- tb_params[["fg_params"]]
fg_params <- add_table_params(d, fg_params, fg_fun, ...) fg_params <- add_table_params(d, fg_params, fg_fun, ...)
frgds <- do.call(mapply, c(fg_params, list(FUN = fg_fun, SIMPLIFY=FALSE))) 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) frgds_grobs <- matrix(frgds, ncol = nc, byrow = FALSE)
bkgds_grobs <- matrix(bkgds, ncol = nc, byrow = FALSE)
if(missing(widths)) if(missing(widths))
widths <- col_widths(frgds_grobs) widths <- col_widths(frgds_grobs)
...@@ -56,10 +53,16 @@ gtable_table <- function(d, widths, heights, ...@@ -56,10 +53,16 @@ gtable_table <- function(d, widths, heights,
heights = heights, vp=vp) heights = heights, vp=vp)
## add the background ## add the background
g <- gtable_add_grob(g, bkgds_grobs, if (!is.null(bg_params)){
t=rep(seq_len(nr), length.out = n), bg_params <- tb_params[["bg_params"]]
l=rep(seq_len(nc), each = nr), z=0, bkgds <- do.call(mapply, c(bg_params, list(FUN = bg_fun, SIMPLIFY=FALSE)))
name=paste0(name, "-bg")) 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 # add padding
g <- gtable_add_col_space(g, padding[1]) g <- gtable_add_col_space(g, padding[1])
...@@ -67,3 +70,84 @@ gtable_table <- function(d, widths, heights, ...@@ -67,3 +70,84 @@ gtable_table <- function(d, widths, heights,
g 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
}
...@@ -16,11 +16,19 @@ col_widths <- function(m){ ...@@ -16,11 +16,19 @@ col_widths <- function(m){
1.1*max(do.call(grid::unit.c, lapply(l, grid::grobWidth))))) 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){ if(length(x) >= n){
return(x[1:n]) return(x[1:n])
} else # recycle } else {
return(rep(rep(x, length.out = nr), length.out= n)) # 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){ breaks_scale <- function(d, d_min=NULL, d_max=NULL, breaks=10){
......
...@@ -50,6 +50,7 @@ table_extra_grob <- function(dscale, dcolor=NULL, ...@@ -50,6 +50,7 @@ table_extra_grob <- function(dscale, dcolor=NULL,
scale_breaks=theme$core$scale_breaks, scale_breaks=theme$core$scale_breaks,
dscale_min=dscale_min, dscale_min=dscale_min,
dscale_max=dscale_max, dscale_max=dscale_max,
rep_mode=theme$core$rep_mode,
r_min=theme$core$scale_ratio*0.5*theme$core$size, r_min=theme$core$scale_ratio*0.5*theme$core$size,
r_max=0.5*theme$core$size, r_max=0.5*theme$core$size,
color_palette=theme$core$color_palette, color_palette=theme$core$color_palette,
......
...@@ -8,15 +8,19 @@ ...@@ -8,15 +8,19 @@
#' #'
#' @author Yoann Pradat #' @author Yoann Pradat
#' @keywords internal #' @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) nc <- ncol(d)
nr <- nrow(d) nr <- nrow(d)
n <- nc*nr n <- nc*nr
fg_params <- lapply(fg_params, rep_ifshort, n = n, nc = nc, nr = nr) fg_params <- lapply(fg_params, rep_ifshort, n = n, nc = nc, nr = nr, rep_mode=rep_mode)
bg_params <- lapply(bg_params, rep_ifshort, n = n, nc = nc, nr = nr)
if (!is.null(bg_params)){
return(list(fg_params=fg_params, bg_params=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 #' Add circle scale parameters
...@@ -52,7 +56,7 @@ table_params_circle_scale <- function(d, scale_breaks=10, r_min=unit(4, "mm"), r ...@@ -52,7 +56,7 @@ table_params_circle_scale <- function(d, scale_breaks=10, r_min=unit(4, "mm"), r
#' #'
#' @author Yoann Pradat #' @author Yoann Pradat
#' @keywords internal #' @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)){ if (is.null(d)){
return(list()) return(list())
} else { } else {
...@@ -75,6 +79,27 @@ table_params_circle_color <- function(d, color_palette, color_breaks=NULL){ ...@@ -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 #' Add circle parameters
#' #'
#' @param d data.frame or matrix #' @param d data.frame or matrix
...@@ -93,7 +118,7 @@ table_params_circle <- function(dscale, dcolor, scale_breaks, r_min, r_max, col ...@@ -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) d_min=dscale_min, d_max=dscale_max)
if(!missing(dcolor)){ 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) params <- c(params_scale, params_color)
} else { } else {
params <- params_scale params <- params_scale
...@@ -127,6 +152,8 @@ add_table_params <- function(d, params, fun, ...){ ...@@ -127,6 +152,8 @@ add_table_params <- function(d, params, fun, ...){
extra_params <- table_params_circle(d, ...) extra_params <- table_params_circle(d, ...)
} else if (all.equal(fun, text_grob)==T) { } else if (all.equal(fun, text_grob)==T) {
extra_params <- table_params_text(d) extra_params <- table_params_text(d)
} else if (all.equal(fun, rect_grob)==T) {
extra_params <- table_params_rect(d, ...)
} else { } else {
stop("unsupported value of fun") stop("unsupported value of fun")
} }
......
...@@ -8,6 +8,7 @@ ...@@ -8,6 +8,7 @@
#' @param scale_ratio ratio of minimum to maximum core foreground grobs sizes #' @param scale_ratio ratio of minimum to maximum core foreground grobs sizes
#' @param color_palette color palette for core foreground grobs #' @param color_palette color palette for core foreground grobs
#' @param color_breaks bin breaks for 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 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 padding length-2 unit vector specifying the horizontal and vertical padding of text within each cell
#' @param ... extra parameters added to the theme list #' @param ... extra parameters added to the theme list
...@@ -25,6 +26,7 @@ ttheme_awesome <- function(base_size=8, ...@@ -25,6 +26,7 @@ ttheme_awesome <- function(base_size=8,
scale_ratio=0.25, scale_ratio=0.25,
color_palette="black", color_palette="black",
color_breaks=NULL, color_breaks=NULL,
rep_mode="col",
parse=FALSE, parse=FALSE,
padding=unit(c(0.3,0.3), "mm"), ...){ padding=unit(c(0.3,0.3), "mm"), ...){
...@@ -41,6 +43,7 @@ ttheme_awesome <- function(base_size=8, ...@@ -41,6 +43,7 @@ ttheme_awesome <- function(base_size=8,
height=core_size_value, height=core_size_value,
default.units=core_size_unit, default.units=core_size_unit,
lwd=0, col="white"), lwd=0, col="white"),
rep_mode=rep_mode,
size=core_size, size=core_size,
scale_breaks=scale_breaks, scale_breaks=scale_breaks,
scale_ratio=scale_ratio, scale_ratio=scale_ratio,
......
assets/table_extra_grob_pcawg.png

545 KB | W: | H:

assets/table_extra_grob_pcawg.png

786 KB | W: | H:

assets/table_extra_grob_pcawg.png
assets/table_extra_grob_pcawg.png
assets/table_extra_grob_pcawg.png
assets/table_extra_grob_pcawg.png
  • 2-up
  • Swipe
  • Onion skin
"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"
% 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}
...@@ -10,11 +10,12 @@ gtable_table( ...@@ -10,11 +10,12 @@ gtable_table(
heights, heights,
fg_fun = text_grob, fg_fun = text_grob,
fg_params = list(), fg_params = list(),
bg_fun = rect_grob, bg_fun = NULL,
bg_params = list(), bg_params = NULL,
padding = unit(c(4, 4), "mm"), padding = unit(c(4, 4), "mm"),
name = "table", name = "table",
vp = NULL, vp = NULL,
rep_mode = "row",
... ...
) )
} }
...@@ -39,7 +40,9 @@ gtable_table( ...@@ -39,7 +40,9 @@ gtable_table(
\item{vp}{optional viewport} \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{ \value{
A gtable. A gtable.
......
...@@ -4,7 +4,7 @@ ...@@ -4,7 +4,7 @@
\alias{table_params} \alias{table_params}
\title{Build a table of parameters.} \title{Build a table of parameters.}
\usage{ \usage{
table_params(d, fg_params, bg_params) table_params(d, fg_params, bg_params = NULL, rep_mode = "row")
} }
\arguments{ \arguments{
\item{d}{data.frame or matrix} \item{d}{data.frame or matrix}
......
% Generated by roxygen2: do not edit by hand % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/table_params.R % Please edit documentation in R/table_params.R
\name{table_params_circle_color} \name{table_params_color}
\alias{table_params_circle_color} \alias{table_params_color}
\title{Add circle color parameters} \title{Add circle color parameters}
\usage{ \usage{
table_params_circle_color(d, color_palette, color_breaks = NULL) table_params_color(d, color_palette, color_breaks = NULL)
} }
\arguments{ \arguments{
\item{d}{data.frame or matrix} \item{d}{data.frame or matrix}
......
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/table_params.R
\name{table_params_rect}
\alias{table_params_rect}