Skip to content

GitLab

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

v0.99.4 add legend 1 and legend 2 aside

parent b0d78adc
Pipeline #10621 failed with stages
in 1 minute
Hide whitespace changes
Inline Side-by-side
DESCRIPTION
View file @ 22f99fae
Package: tableExtra
Title: Draws an awesome table
Version: 0.99.3
Version: 0.99.4
Authors@R:
person(given = "Yoann",
family = "Pradat",
......
Makefile 0 → 100644
View file @ 22f99fae
# 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
View file @ 22f99fae
......@@ -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
View file @ 22f99fae
......@@ -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
View file @ 22f99fae
......@@ -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
View file @ 22f99fae
......@@ -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
View file @ 22f99fae
......@@ -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,
......
assets/table_extra_grob_pcawg.png
View replaced file @ b0d78adc View file @ 22f99fae
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
data-raw/cosmic_v3_aetiologies.csv 0 → 100644
View file @ 22f99fae
"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 0 → 100644
View file @ 22f99fae
% 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
View file @ 22f99fae
......@@ -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
View file @ 22f99fae
......@@ -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
View file @ 22f99fae
% 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 0 → 100644
View file @ 22f99fae
% 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
View file @ 22f99fae
......@@ -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
View file @ 22f99fae
......@@ -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)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment