Commit 839e5713 authored by Pradat Yoann's avatar Pradat Yoann
Browse files

successfully run tests with color; devtools::check() does not pass though

parent 6324cdd6
...@@ -16,3 +16,6 @@ Suggests: ...@@ -16,3 +16,6 @@ Suggests:
testthat testthat
Depends: Depends:
R (>= 2.10) R (>= 2.10)
Imports:
gtable,
grid
...@@ -8,8 +8,8 @@ export(gtable_combine) ...@@ -8,8 +8,8 @@ export(gtable_combine)
export(gtable_rbind) export(gtable_rbind)
export(ttheme_awesome) export(ttheme_awesome)
import(grid) import(grid)
importFrom(gtable,gtable_add_grob) import(gtable)
importFrom(grid,unit.c)
importFrom(gtable,gtable_add_rows) importFrom(gtable,gtable_add_rows)
importFrom(gtable,gtable_matrix)
importFrom(utils,modifyList) importFrom(utils,modifyList)
importFrom(utils,str) importFrom(utils,str)
...@@ -17,7 +17,7 @@ ...@@ -17,7 +17,7 @@
#' @param ... additional parameters passed to add_table_params. #' @param ... additional parameters passed to add_table_params.
#' @return A gtable. #' @return A gtable.
#' #'
#' @importFrom gtable gtable_matrix gtable_add_grob #' @import gtable
#' #'
#' @author Yoann Pradat #' @author Yoann Pradat
#' @keywords internal #' @keywords internal
...@@ -44,15 +44,6 @@ gtable_table <- function(d, widths, heights, ...@@ -44,15 +44,6 @@ gtable_table <- function(d, widths, heights,
frgds_grobs <- matrix(frgds, ncol = nc, byrow = FALSE) frgds_grobs <- matrix(frgds, ncol = nc, byrow = FALSE)
bkgds_grobs <- matrix(bkgds, ncol = nc, byrow = FALSE) bkgds_grobs <- matrix(bkgds, ncol = nc, byrow = FALSE)
# print(unlist(bkgds[[1]]))
# # change default bg width/height
# bkgd_grob <- rect_grob(width=unit(12, "mm"), height=unit(4, "mm"))
# bkgd_grob <- rect_grob(width=unit(12, "mm"), height=unit(4, "mm"))
# bkgds_grobs <- matrix(lapply(1:nc, function(x) return(bkgd_grob)), ncol=nc)
# widths <- rep(unit(12, "mm"), ncol(bkgds_grobs))
# heights <- unit(4, "mm")
if(missing(widths)) if(missing(widths))
widths <- col_widths(frgds_grobs) widths <- col_widths(frgds_grobs)
if(missing(heights)) if(missing(heights))
...@@ -71,38 +62,8 @@ gtable_table <- function(d, widths, heights, ...@@ -71,38 +62,8 @@ gtable_table <- function(d, widths, heights,
name=paste0(name, "-bg")) name=paste0(name, "-bg"))
# add padding # add padding
g <- gtable::gtable_add_col_space(g, padding[1]) g <- gtable_add_col_space(g, padding[1])
g <- gtable::gtable_add_row_space(g, padding[2]) g <- gtable_add_row_space(g, padding[2])
g g
} }
# bkgd_grob <- rect_grob(width=unit(10, "mm"), height=unit(4, "mm"))
# bkgds_grobs <- gList(bkgd_grob,bkgd_grob,bkgd_grob,bkgd_grob,bkgd_grob,bkgd_grob,bkgd_grob,bkgd_grob)
# widths <- rep(bkgd_grob$width, ncol(bkgds_grobs))
# heights <- bkgd_grob$height
#
# ## make the gtable matrix of foreground
# g <- gtable_matrix("-bg",
# grobs = bkgds_grobs,
# widths = widths,
# heights = heights)
#
# bkgd_grob <- rect_grob(width=unit(10, "mm"), height=unit(4, "mm"))
# bkgds_grobs <- matrix(lapply(1:12, function(x) return(bkgd_grob)), ncol=12)
# widths <- rep(bkgd_grob$width, ncol(bkgds_grobs))
# heights <- bkgd_grob$height
#
# ## make the gtable matrix of foreground
# g <- gtable_matrix("-bg",
# grobs = bkgds_grobs,
# widths = widths,
# heights = heights)
#
# out <- plot_grob(g, name="gtable_text_row_unwanted_padding.pdf", width=8, height=1)
#
#
# suppressMessages(library(SummarizedExperiment))
# load("../tests/testthat/testdata/DBS.rda")
# as.vector(SummarizedExperiment::rowData(DBS)$description)
...@@ -5,10 +5,14 @@ ...@@ -5,10 +5,14 @@
#' #'
#' @describeIn circleTableGrog return a grob #' @describeIn circleTableGrog return a grob
#' @description Create a gtable containing circle grobs representing a numeric matrix. #' @description Create a gtable containing circle grobs representing a numeric matrix.
#' @param se \code{SummarizedExperiment} object with rownames, colnames, rowData, colData. #' @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 theme list of theme parameters
#' @param vp optional viewport #' @param vp optional viewport
#' #'
#' @import gtable
#' @importFrom gtable gtable_add_rows #' @importFrom gtable gtable_add_rows
#' #'
#' @return A gtable. #' @return A gtable.
...@@ -18,15 +22,16 @@ ...@@ -18,15 +22,16 @@
#' @export #' @export
#' @examples #' @examples
#' library(tableExtra) #' library(tableExtra)
extra_table_grob <- function(d, rows=rownames(d), cols=colnames(d), extra_table_grob <- function(dscale, dcolor=NULL,
rows=rownames(dscale), cols=colnames(dscale),
rows_more=NULL, cols_more=NULL, rows_more=NULL, cols_more=NULL,
rows_more_title="", cols_more_title="", rows_more_title="", cols_more_title="",
theme=ttheme_awesome(), vp=NULL){ theme=ttheme_awesome(), vp=NULL){
widths <- rep(theme$core$size, ncol(d)) widths <- rep(theme$core$size, ncol(dscale))
heights <- rep(theme$core$size, nrow(d)) heights <- rep(theme$core$size, nrow(dscale))
g <- gtable_table(d, name="circle", g <- gtable_table(dscale, name="circle",
widths=widths, widths=widths,
heights=heights, heights=heights,
fg_fun=theme$core$fg_fun, fg_fun=theme$core$fg_fun,
...@@ -34,7 +39,12 @@ extra_table_grob <- function(d, rows=rownames(d), cols=colnames(d), ...@@ -34,7 +39,12 @@ extra_table_grob <- function(d, rows=rownames(d), cols=colnames(d),
fg_params=theme$core$fg_params, fg_params=theme$core$fg_params,
bg_params=theme$core$bg_params, bg_params=theme$core$bg_params,
padding=theme$core$padding, padding=theme$core$padding,
r_max=0.5*theme$core$size) n_cat=theme$core$n_cat,
r_max=0.5*theme$core$size,
pal=theme$core$pal,
pal_breaks=theme$core$pal_breaks,
dcolor=dcolor)
if(!is.null(cols)){ if(!is.null(cols)){
if (!is.null(cols_more)){ if (!is.null(cols_more)){
...@@ -79,7 +89,6 @@ extra_table_grob <- function(d, rows=rownames(d), cols=colnames(d), ...@@ -79,7 +89,6 @@ extra_table_grob <- function(d, rows=rownames(d), cols=colnames(d),
rows_more <- c("", rows_more) rows_more <- c("", rows_more)
} }
} }
print(rows_more)
gr <- gtable_table(rows_more, name="rowmore", gr <- gtable_table(rows_more, name="rowmore",
fg_fun=theme$rowmore$fg_fun, fg_fun=theme$rowmore$fg_fun,
...@@ -105,8 +114,13 @@ extra_table_grob <- function(d, rows=rownames(d), cols=colnames(d), ...@@ -105,8 +114,13 @@ extra_table_grob <- function(d, rows=rownames(d), cols=colnames(d),
#' @param base_size default font size #' @param base_size default font size
#' @param base_colour default font colour #' @param base_colour default font colour
#' @param base_family default font family #' @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 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
#' #'
#' @importFrom utils modifyList #' @importFrom utils modifyList
#' #'
...@@ -117,7 +131,9 @@ ttheme_awesome <- function(base_size=8, ...@@ -117,7 +131,9 @@ ttheme_awesome <- function(base_size=8,
base_colour="black", base_colour="black",
base_family="", base_family="",
core_size=unit(10, "mm"), core_size=unit(10, "mm"),
core_n_cat=10, n_cat=10,
pal="black",
pal_breaks=NULL,
parse=FALSE, parse=FALSE,
padding=unit(c(0.3,0.3), "mm"), ...){ padding=unit(c(0.3,0.3), "mm"), ...){
...@@ -127,15 +143,17 @@ ttheme_awesome <- function(base_size=8, ...@@ -127,15 +143,17 @@ ttheme_awesome <- function(base_size=8,
core_size_value <- as.numeric(core_size) core_size_value <- as.numeric(core_size)
core_size_unit <- attr(core_size, "unit") core_size_unit <- attr(core_size, "unit")
core <- list(fg_fun=circle_grob, core <- list(fg_fun=circle_grob,
fg_params=list(fill=c("#6767f8"), col="white", lwd=0), fg_params=list(col="white", lwd=0),
bg_fun=rect_grob, bg_fun=rect_grob,
bg_params=list(fill=c("#f2f2f2","#e5e5e5"), bg_params=list(fill=c("#f2f2f2","#e5e5e5"),
width=core_size_value, width=core_size_value,
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"),
n_cat=core_n_cat,
size=core_size, size=core_size,
n_cat=n_cat,
pal=pal,
pal_breaks=pal_breaks,
padding=padding) padding=padding)
colhead <- list(fg_fun=text_grob, colhead <- list(fg_fun=text_grob,
......
...@@ -19,7 +19,7 @@ table_params <- function(d, fg_params, bg_params){ ...@@ -19,7 +19,7 @@ table_params <- function(d, fg_params, bg_params){
return(list(fg_params=fg_params, bg_params=bg_params)) return(list(fg_params=fg_params, bg_params=bg_params))
} }
#' Add circle parameters #' Add circle scale parameters
#' #'
#' @param d data.frame or matrix #' @param d data.frame or matrix
#' @param n_cat integer indicating the number of differently-sized circles #' @param n_cat integer indicating the number of differently-sized circles
...@@ -29,13 +29,70 @@ table_params <- function(d, fg_params, bg_params){ ...@@ -29,13 +29,70 @@ table_params <- function(d, fg_params, bg_params){
#' #'
#' @author Yoann Pradat #' @author Yoann Pradat
#' @keywords internal #' @keywords internal
table_params_circle <- function(d, n_cat=10, r_max=unit(10, "mm")){ table_params_circle_scale <- function(d, n_cat=10, r_max=unit(10, "mm")){
d <- scalecat(d, n_cat=n_cat, vmax=1) d <- scalecat(d, n_cat=n_cat, vmax=1)
d <- as.vector(d) d <- as.vector(d)
params <- list(r=do.call(unit.c, lapply(d, function(x) x*r_max))) params <- list(r=do.call(unit.c, lapply(d, function(x) x*r_max)))
return(params) 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
#'
#' @importFrom methods is
#'
#' @author Yoann Pradat
#' @keywords internal
table_params_circle_color <- function(d, pal, pal_breaks=NULL){
if (is.null(d)){
return(list())
} else {
if (is.null(pal_breaks)){
pal_breaks <- length(pal)
}
if (is(pal_breaks,"integer")){
if (pal_breaks==1){
d <- as.matrix(pal, nrow=nrow(d), ncol=ncol(d))
}
else {
d <- cut(d, breaks=pal_breaks, right=F)
}
} else {
d <- cut(d, breaks=pal_breaks, right=F)
levels(d) <- pal
}
params <- list(fill=as.vector(d))
return(params)
}
}
#' Add circle parameters
#'
#' @param d data.frame or matrix
#' @param n_cat 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
#'
#' @importFrom grid unit.c
#'
#' @author Yoann Pradat
#' @keywords internal
table_params_circle <- function(dscale, dcolor, n_cat, r_max, pal, pal_breaks){
params_scale <- table_params_circle_scale(d=dscale, n_cat=n_cat, r_max=r_max)
if(!missing(dcolor)){
params_color <- table_params_circle_color(d=dcolor, pal=pal, pal_breaks=pal_breaks)
params <- c(params_scale, params_color)
} else {
params <- params_scale
}
return(params)
}
#' Add text parameters #' Add text parameters
#' #'
#' @param d data.frame or matrix #' @param d data.frame or matrix
......
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/table_params.R
\name{add_table_params}
\alias{add_table_params}
\title{Add parameter specific to the grob class.}
\usage{
add_table_params(d, params, fun, ...)
}
\arguments{
\item{d}{data.frame or matrix}
\item{params}{named list of table params}
\item{fun}{a function that returns a grob object.}
}
\description{
Add parameter specific to the grob class.
}
\author{
Yoann Pradat
}
\keyword{internal}
...@@ -5,12 +5,15 @@ ...@@ -5,12 +5,15 @@
\title{Define theme for awesome table plot.} \title{Define theme for awesome table plot.}
\usage{ \usage{
ttheme_awesome( ttheme_awesome(
base_size = 12, base_size = 8,
base_colour = "black", base_colour = "black",
base_family = "", base_family = "",
n_circle = 10, core_size = unit(10, "mm"),
n_cat = 10,
pal = "black",
pal_breaks = NULL,
parse = FALSE, parse = FALSE,
padding = unit(c(0.005, 0.005), "npc"), padding = unit(c(0.3, 0.3), "mm"),
... ...
) )
} }
...@@ -21,9 +24,19 @@ ttheme_awesome( ...@@ -21,9 +24,19 @@ ttheme_awesome(
\item{base_family}{default font family} \item{base_family}{default font family}
\item{core_size}{cell size for core background grobs}
\item{n_cat}{number of size categories for core foreground grobs}
\item{pal}{color palette for core foreground grobs}
\item{pal_breaks}{breaks for color palette for core foreground grobs}
\item{parse}{logical, default behaviour for parsing text as plotmath} \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} \item{padding}{length-2 unit vector specifying the horizontal and vertical padding of text within each cell}
\item{...}{extra parameters added to the theme list}
} }
\description{ \description{
Define theme for awesome table plot. Define theme for awesome table plot.
......
...@@ -8,22 +8,30 @@ ...@@ -8,22 +8,30 @@
Builds on top of \code{tableGrob} from gridExtra R package.} Builds on top of \code{tableGrob} from gridExtra R package.}
\usage{ \usage{
extra_table_grob( extra_table_grob(
d, dscale,
rows = rownames(d), dcolor = NULL,
cols = colnames(d), rows = rownames(dscale),
cols = colnames(dscale),
rows_more = NULL,
cols_more = NULL,
rows_more_title = "",
cols_more_title = "",
theme = ttheme_awesome(), theme = ttheme_awesome(),
vp = NULL, vp = NULL
...
) )
} }
\arguments{ \arguments{
\item{theme}{list of theme parameters} \item{dscale}{a matrix}
\item{vp}{optional viewport} \item{dcolor}{(optional) a matrix}
\item{rows}{(optional) a character vector}
\item{...}{further arguments to control the gtable} \item{cols}{(optional) a character vector}
\item{se}{\code{SummarizedExperiment} object with rownames, colnames, rowData, colData.} \item{theme}{list of theme parameters}
\item{vp}{optional viewport}
} }
\value{ \value{
A gtable. A gtable.
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
\title{Vectorised version of circleGrob} \title{Vectorised version of circleGrob}
\usage{ \usage{
circle_grob( circle_grob(
r = unit(0.48, "npc"), r = unit(5, "mm"),
fill = "black", fill = "black",
col = "black", col = "black",
lty = "solid", lty = "solid",
...@@ -18,9 +18,9 @@ circle_grob( ...@@ -18,9 +18,9 @@ circle_grob(
lex = 1, lex = 1,
name = NULL, name = NULL,
vp = NULL, vp = NULL,
x = 0.5, x = unit(0.5, "npc"),
y = 0.5, y = unit(0.5, "npc"),
default.units = "npc" default.units = "mm"
) )
} }
\value{ \value{
......
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/gtables.R
\name{gtable_circle}
\alias{gtable_circle}
\title{Build a table with circle grobs.}
\usage{
gtable_circle(
d,
widths,
heights,
fg_fun = text_grob,
fg_params = list(),
bg_fun = rect_grob,
bg_params = list(),
padding = unit(c(0.01, 0.01), "npc"),
name = "table",
vp = NULL
)
}
\arguments{
\item{d}{data.frame or matrix}
\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{padding}{\code{unit.list} object specifying the padding between adjacent cells.}
\item{name}{optional name of the grob}
\item{vp}{optional viewport}
\item{width}{optional \code{unit.list} specifying the grob widths}
}
\value{
A gtable.
}
\description{
This function is a copy of the internal function \code{gtable_table} of gridExtra package.
}
\author{
Yoann Pradat
}
\keyword{internal}
% Generated by roxygen2: do not edit by hand % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/gtables.R % Please edit documentation in R/gtables.R
\name{gtable_text} \name{gtable_table}
\alias{gtable_text} \alias{gtable_table}
\title{Build a table with text grobs.} \title{Build a table with foreground and background grobs.}
\usage{ \usage{
gtable_text( gtable_table(
d, d,
widths, widths,
heights, heights,
...@@ -14,12 +14,15 @@ gtable_text( ...@@ -14,12 +14,15 @@ gtable_text(
bg_params = list(), bg_params = list(),
padding = unit(c(4, 4), "mm"), padding = unit(c(4, 4), "mm"),
name = "table", name = "table",
vp = NULL vp = NULL,
...
) )
} }
\arguments{ \arguments{
\item{d}{data.frame or matrix} \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{heights}{optional \code{unit.list} specifying the grob heights}
\item{fg_fun}{grob-drawing function} \item{fg_fun}{grob-drawing function}
...@@ -36,7 +39,7 @@ gtable_text( ...@@ -36,7 +39,7 @@ gtable_text(
\item{vp}{optional viewport} \item{vp}{optional viewport}
\item{width}{optional \code{unit.list} specifying the grob widths} \item{...}{additional parameters passed to add_table_params.}
} }
\value{ \value{
A gtable. A gtable.
......
...@@ -20,11 +20,11 @@ rect_grob( ...@@ -20,11 +20,11 @@ rect_grob(
just = "centre", just = "centre",
hjust = 0.5, hjust = 0.5,
vjust = 0.5, vjust = 0.5,
width = unit(1, "npc") - unit(2, "scaledpts"), width = unit(100, "mm"),
height = unit(1, "npc") - unit(2, "scaledpts"), height = unit(100, "mm"),
x = 0.5, x = unit(0.5, "npc"),
y = 0.5, y = unit(0.5, "npc"),
default.units = "npc" default.units = "mm"
) )
} }
\value{