Commit 4354909c authored by Pradat Yoann's avatar Pradat Yoann

v0.99.1 and add gitlab-ci.yml

parent 34f1ddad
image: rocker/r-base
stages:
- dependencies
- build
- document
- check
- test
- install
variables:
CODECOV_TOKEN: "b524d434-9189-48fc-a919-72e40de8cd22"
before_script:
- apt-get update
install_dependencies:
stage: dependencies
script:
- apt-get install --yes --no-install-recommends r-cran-devtools
- R -e 'devtools::install_deps(dependencies=c("Depends", "Imports", "Suggests"))'
buildbinary:
stage: build
script:
- R -e 'devtools::build(binary=T)'
documentation:
stage: document
script:
- R -e 'devtools::document()'
checkerrors:
stage: check
script:
- R -e 'if (!identical(devtools::check(document = FALSE, args = "--no-tests")[["errors"]], character(0))) stop("Check with Errors")'
unittests:
stage: test
script:
- R -e 'if (any(as.data.frame(devtools::test())[["failed"]] > 0)) stop("Some tests failed.")'
codecov:
stage: test
script:
- R -e 'covr::codecov()'
install:
stage: install
script:
- R -e 'devtools::install()'
Package: tableExtra
Title: Draws an awesome table
Version: 0.99.0
Version: 0.99.1
Authors@R:
person(given = "Yoann",
family = "Pradat",
......@@ -13,7 +13,9 @@ LazyData: true
Roxygen: list(markdown = TRUE)
RoxygenNote: 7.1.1
Suggests:
testthat
testthat,
dplyr,
tibble
Depends:
R (>= 2.10)
Imports:
......
# Generated by roxygen2: do not edit by hand
export(combine)
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_cols)
importFrom(gtable,gtable_add_rows)
importFrom(methods,is)
importFrom(utils,modifyList)
## Misc. gtable functions
## Note: these functions were copied from the gridExtra package.
#'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(...)
Reduce(function(x, y) combine_2(x, y,
along = along,
join = join),
gtables)
}
#' @rdname combine
#' @export
combine <- function (..., along = 1L, join = "outer") {
.Deprecated("gtable_combine")
gtable_combine(..., along=along, join=join)
#' Insert unit
#'
#' Helper for [rbind_2] and [cbind_2].
#'
#' @param x x param
#' @param values values param
#' @param after (optional) after param
#'
#' @keywords internal
insert.unit <- function (x, values, after = length(x)) {
lengx <- length(x)
if (lengx == 0) return(values)
if (length(values) == 0) return(x)
if (after <= 0) {
unit.c(values, x)
} else if (after >= lengx) {
unit.c(x, values)
} else {
unit.c(x[1L:after], values, x[(after + 1L):lengx])
}
}
z_normalise <- function (x, i = 1)
{
x$layout$z <- rank(x$layout$z, ties.method = "first") + i -
1
x$layout$z <- rank(x$layout$z, ties.method = "first") + i - 1
x
}
......@@ -54,58 +48,63 @@ z_arrange_gtables <- function (gtables, z)
gtables
}
insert.unit <- function (x, values, after = length(x)) {
lengx <- length(x)
if (lengx == 0) return(values)
if (length(values) == 0) return(x)
if (after <= 0) {
unit.c(values, x)
} else if (after >= lengx) {
unit.c(x, values)
} else {
unit.c(x[1L:after], values, x[(after + 1L):lengx])
}
}
##'rbind gtables
##'@rdname bind
##'@param ... gtables
##'@param size how should the widths be calculated?
##'\code{max} maximum of all widths
##'\code{min} minimum of all widths
##'\code{first} widths/heights of first gtable
##'\code{last} widths/heights of last gtable
##'@param z optional z level
##'@export
gtable_rbind <- function(..., size = "max", z = NULL) {
#' rbind two or more gtables
#'
#' @rdname bind
#' @param ... gtables
#' @param size how should the widths be calculated?
#' \enumerate{
#' \item \code{max} maximum of all widths
#' \item \code{min} minimum of all widths
#' \item \code{first} widths/heights of first gtable
#' \item \code{last} widths/heights of last gtable
#' }
#' @param height padding height between grobs
#' @param z optional z level
#' @export
gtable_rbind <- function(..., size = "max", height = NULL, z = NULL) {
gtables <- list(...)
if (!is.null(z)) {
gtables <- z_arrange_gtables(gtables, z)
}
Reduce(function(x, y) rbind_2(x, y, size = size), gtables)
Reduce(function(x, y) rbind_2(x, y, size=size, height=height), gtables)
}
##'cbind gtables
##'@rdname bind
##'@export
gtable_cbind <- function(..., size = "max", z = NULL) {
#' cbind two or more gtables
#'
#' @rdname bind
#' @param width padding width between grobs
#' @export
gtable_cbind <- function(..., size = "max", width = NULL, z = NULL) {
gtables <- list(...)
if (!is.null(z)) {
gtables <- z_arrange_gtables(gtables, z)
}
Reduce(function(x, y) cbind_2(x, y, size = size), gtables)
Reduce(function(x, y) cbind_2(x, y, size=size, width=width), gtables)
}
#' rbind two gtables
#'
#' @param x
#' @param size how should the widths be calculated?
#' \enumerate{
#' \item \code{max} maximum of all widths
#' \item \code{min} minimum of all widths
#' \item \code{first} widths/heights of first gtable
#' \item \code{last} widths/heights of last gtable
#' }
#' @param height padding height between grobs
#'
#' @importFrom gtable gtable_add_rows
#'
#' @keywords internal
rbind_2 <- function(x, y, size = "max", height=NULL) {
stopifnot(ncol(x) == ncol(y))
if (nrow(x) == 0) return(y)
if (nrow(y) == 0) return(x)
if (!is.null(height)){
x <- gtable::gtable_add_rows(x, height)
x <- gtable_add_rows(x, height)
}
y$layout$t <- y$layout$t + nrow(x)
......@@ -129,13 +128,28 @@ rbind_2 <- function(x, y, size = "max", height=NULL) {
x
}
#' cbind two gtables
#'
#' @param x
#' @param size how should the widths be calculated?
#' \enumerate{
#' \item \code{max} maximum of all widths
#' \item \code{min} minimum of all widths
#' \item \code{first} widths/heights of first gtable
#' \item \code{last} widths/heights of last gtable
#' }
#' @param width padding width between grobs
#'
#' @importFrom gtable gtable_add_cols
#'
#' @keywords internal
cbind_2 <- function(x, y, size = "max", width=NULL) {
stopifnot(nrow(x) == nrow(y))
if (ncol(x) == 0) return(y)
if (ncol(y) == 0) return(x)
if (!is.null(width)){
x <- gtable::gtable_add_cols(x, width)
x <- gtable_add_cols(x, width)
}
y$layout$l <- y$layout$l + ncol(x)
......@@ -159,91 +173,114 @@ cbind_2 <- function(x, y, size = "max", width=NULL) {
x
}
# #'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(...)
# Reduce(function(x, y) combine_2(x, y,
# along = along,
# join = join),
# gtables)
# }
#
#
combine_2 <- function(x, y, along = 1L, join = "outer") {
aligned <- align_2(x, y, along = along, join = join)
switch(along,
cbind_2(aligned$x, aligned$y,
size="max"),
rbind_2(aligned$x, aligned$y,
size="max"),
stop("along > 2 no implemented"))
}
align_2 <- function(x, y, along = 1L, join = "outer") {
join <- match.arg(join, c("left", "right", "inner", "outer"))
names_x <- dimnames(x)[[along]]
names_y <- dimnames(y)[[along]]
if (is.null(names_x) || is.null(names_y)) {
stop("Both gtables must have names along dimension to be aligned")
}
idx <- switch(join,
left = names_x,
right = names_y,
inner = intersect(names_x, names_y),
outer = union(names_x, names_y)
)
list(
x = gtable_reindex(x, idx, along),
y = gtable_reindex(y, idx, along)
)
}
gtable_reindex <- function(x, index, along = 1L) {
stopifnot(is.character(index))
if (length(dim(x)) > 2L || along > 2L) {
stop("reindex only supports 2d objects")
}
old_index <- switch(along, rownames(x), colnames(x))
stopifnot(!is.null(old_index))
if (identical(index, old_index)) {
return(x)
}
if (!(old_index %contains% index)) {
missing <- setdiff(index, old_index)
# Create and add dummy space rows
if (along == 1L) {
spacer <- gtable(
widths = unit(rep(0, ncol(x)), "cm"),
heights = rep_along(unit(0, "cm"), missing),
rownames = missing)
x <- rbind(x, spacer, size = "first")
} else if (along == 2L){
spacer <- gtable(
heights = unit(rep(0, nrow(x)), "cm"),
widths = rep_along(unit(0, "cm"), missing),
colnames = missing)
x <- cbind(x, spacer, size = "first")
}
}
# Reorder & subset
switch(along,
x[index, ],
x[, index])
}
gtable_remove_grob <- function(x, pattern, which = 1L,
fixed = FALSE, trim=TRUE){
matches <- grep(pattern, x$layout$name, fixed = fixed)
tokeep <- setdiff(seq_len(length(x)), matches[which])
x$layout <- x$layout[tokeep, , drop = FALSE]
x$grobs <- x$grobs[tokeep]
if(trim)
x <- gtable_trim(x)
x
}
#
# combine_2 <- function(x, y, along = 1L, join = "outer") {
# aligned <- align_2(x, y, along = along, join = join)
# switch(along,
# cbind_2(aligned$x, aligned$y,
# size="max"),
# rbind_2(aligned$x, aligned$y,
# size="max"),
# stop("along > 2 no implemented"))
# }
#
#
#
# align_2 <- function(x, y, along = 1L, join = "outer") {
# join <- match.arg(join, c("left", "right", "inner", "outer"))
#
# names_x <- dimnames(x)[[along]]
# names_y <- dimnames(y)[[along]]
#
# if (is.null(names_x) || is.null(names_y)) {
# stop("Both gtables must have names along dimension to be aligned")
# }
#
# idx <- switch(join,
# left = names_x,
# right = names_y,
# inner = intersect(names_x, names_y),
# outer = union(names_x, names_y)
# )
#
# list(
# x = gtable_reindex(x, idx, along),
# y = gtable_reindex(y, idx, along)
# )
# }
#
#
# gtable_reindex <- function(x, index, along = 1L) {
# stopifnot(is.character(index))
# if (length(dim(x)) > 2L || along > 2L) {
# stop("reindex only supports 2d objects")
# }
# old_index <- switch(along, rownames(x), colnames(x))
# stopifnot(!is.null(old_index))
#
# if (identical(index, old_index)) {
# return(x)
# }
#
# if (!(old_index %contains% index)) {
# missing <- setdiff(index, old_index)
# # Create and add dummy space rows
#
# if (along == 1L) {
# spacer <- gtable(
# widths = unit(rep(0, ncol(x)), "cm"),
# heights = rep_along(unit(0, "cm"), missing),
# rownames = missing)
# x <- rbind(x, spacer, size = "first")
# } else if (along == 2L){
# spacer <- gtable(
# heights = unit(rep(0, nrow(x)), "cm"),
# widths = rep_along(unit(0, "cm"), missing),
# colnames = missing)
#
# x <- cbind(x, spacer, size = "first")
# }
# }
#
#
# # Reorder & subset
#
# switch(along,
# x[index, ],
# x[, index])
# }
#
#
# gtable_remove_grob <- function(x, pattern, which = 1L,
# fixed = FALSE, trim=TRUE){
# matches <- grep(pattern, x$layout$name, fixed = fixed)
# tokeep <- setdiff(seq_len(length(x)), matches[which])
# x$layout <- x$layout[tokeep, , drop = FALSE]
# x$grobs <- x$grobs[tokeep]
# if(trim)
# x <- gtable_trim(x)
# x
# }
......@@ -12,8 +12,8 @@
#' \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}
#' \item{SBS1}{Single-base-substitution signature 1. See <https://cancer.sanger.ac.uk/cosmic/signatures/SBS/SBS1.tt>}
#' ...
#' }
#'
#' @docType data
......
......@@ -4,16 +4,24 @@
#'
#' @description Create a gtable containing circle grobs representing a numeric matrix.
#' @param dscale a matrix
#' @param dscale_min value for setting the minimum scale size of foreground grobs. Entries in the \code{dscale} matrix
#' below \code{dscale_min} will have a scale of 0 (no grob).
#' @param dscale_max value for setting the maximum scale size of foreground grobs. Entries in the \code{dscale} matrix
#' above \code{dscale_max} will have a scale of 0 (no grob).
#' @param dcolor (optional) a matrix
#' @param rows (optional) a character vector
#' @param cols (optional) a character vector
#' @param rows_more (optional) a named list of additional columns (right-part) of the plot for describing the rows. The
#' list names will be used as column headers.
#' @param cols_more (optional) a named list of additional rows (top-part) of the plot for describing the columns The
#' list names will be used as row headers.
#' @param theme list of theme parameters
#' @param vp optional viewport
#'
#' @import gtable
#' @importFrom gtable gtable_add_rows
#'
#' @seealso [theme_awesome()]
#' @seealso [ttheme_awesome()]
#'
#' @return An R object of class \code{grob}
#'
......@@ -58,7 +66,7 @@ table_extra_grob <- function(dscale, dcolor=NULL,
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])
g <- gtable_rbind(gc, g, size="max", height=theme$colmore$padding[1])
}
}
......@@ -84,7 +92,7 @@ table_extra_grob <- function(dscale, dcolor=NULL,
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])
g <- gtable_cbind(gr, g, size="max", width=theme$rowhead$padding[2])
if(!is.null(rows_more)){
for (rows_m_name in names(rows_more)){
......@@ -102,7 +110,7 @@ table_extra_grob <- function(dscale, dcolor=NULL,
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])
g <- gtable_cbind(g, gr, size="max", width=theme$rowmore$padding[2])
}
}
}
......
......@@ -50,8 +50,6 @@ table_params_circle_scale <- function(d, scale_breaks=10, r_min=unit(4, "mm"), r
#' @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, color_palette, color_breaks=NULL){
......@@ -61,7 +59,7 @@ table_params_circle_color <- function(d, color_palette, color_breaks=NULL){
if (is.null(color_breaks)){
color_breaks <- length(color_palette)
}
if (is(color_breaks,"integer")){
if (length(color_breaks)==1){
if (color_breaks==1){
d <- as.matrix(color_palette, nrow=nrow(d), ncol=ncol(d))
}
......
......@@ -3,25 +3,31 @@
\name{gtable_rbind}
\alias{gtable_rbind}
\alias{gtable_cbind}
\title{rbind gtables}
\title{rbind two or more gtables}
\usage{
gtable_rbind(..., size = "max", z = NULL)
gtable_rbind(..., size = "max", height = NULL, z = NULL)
gtable_cbind(..., size = "max", z = NULL)
gtable_cbind(..., size = "max", width = NULL, z = NULL)
}
\arguments{
\item{...}{gtables}
\item{size}{how should the widths be calculated?
\code{max} maximum of all widths
\code{min} minimum of all widths
\code{first} widths/heights of first gtable
\code{last} widths/heights of last gtable}
\enumerate{
\item \code{max} maximum of all widths
\item \code{min} minimum of all widths
\item \code{first} widths/heights of first gtable
\item \code{last} widths/heights of last gtable
}}
\item{height}{padding height between grobs}
\item{z}{optional z level}
\item{width}{padding width between grobs}
}
\description{
rbind gtables
rbind two or more gtables
cbind gtables
cbind two or more gtables
}
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/gtable_utils.R
\name{cbind_2}
\alias{cbind_2}
\title{cbind two gtables}
\usage{
cbind_2(x, y, size = "max", width = NULL)
}
\arguments{
\item{x}{}
\item{size}{how should the widths be calculated?
\enumerate{
\item \code{max} maximum of all widths
\item \code{min} minimum of all widths
\item \code{first} widths/heights of first gtable
\item \code{last} widths/heights of last gtable
}}
\item{width}{padding width between grobs}
}
\description{
cbind two gtables
}
\keyword{internal}
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/gtable_utils.R
\name{gtable_combine}
\alias{gtable_combine}