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

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

parent 6324cdd6
......@@ -16,3 +16,6 @@ Suggests:
testthat
Depends:
R (>= 2.10)
Imports:
gtable,
grid
......@@ -8,8 +8,8 @@ export(gtable_combine)
export(gtable_rbind)
export(ttheme_awesome)
import(grid)
importFrom(gtable,gtable_add_grob)
import(gtable)
importFrom(grid,unit.c)
importFrom(gtable,gtable_add_rows)
importFrom(gtable,gtable_matrix)
importFrom(utils,modifyList)
importFrom(utils,str)
......@@ -17,7 +17,7 @@
#' @param ... additional parameters passed to add_table_params.
#' @return A gtable.
#'
#' @importFrom gtable gtable_matrix gtable_add_grob
#' @import gtable
#'
#' @author Yoann Pradat
#' @keywords internal
......@@ -44,15 +44,6 @@ gtable_table <- function(d, widths, heights,
frgds_grobs <- matrix(frgds, 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))
widths <- col_widths(frgds_grobs)
if(missing(heights))
......@@ -71,38 +62,8 @@ gtable_table <- function(d, widths, heights,
name=paste0(name, "-bg"))
# add padding
g <- gtable::gtable_add_col_space(g, padding[1])
g <- gtable::gtable_add_row_space(g, padding[2])
g <- gtable_add_col_space(g, padding[1])
g <- gtable_add_row_space(g, padding[2])
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 @@
#'
#' @describeIn circleTableGrog return a grob
#' @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 vp optional viewport
#'
#' @import gtable
#' @importFrom gtable gtable_add_rows
#'
#' @return A gtable.
......@@ -18,15 +22,16 @@
#' @export
#' @examples
#' 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_title="", cols_more_title="",
theme=ttheme_awesome(), vp=NULL){
widths <- rep(theme$core$size, ncol(d))
heights <- rep(theme$core$size, nrow(d))
widths <- rep(theme$core$size, ncol(dscale))
heights <- rep(theme$core$size, nrow(dscale))
g <- gtable_table(d, name="circle",
g <- gtable_table(dscale, name="circle",
widths=widths,
heights=heights,
fg_fun=theme$core$fg_fun,
......@@ -34,7 +39,12 @@ extra_table_grob <- function(d, rows=rownames(d), cols=colnames(d),
fg_params=theme$core$fg_params,
bg_params=theme$core$bg_params,
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_more)){
......@@ -79,7 +89,6 @@ extra_table_grob <- function(d, rows=rownames(d), cols=colnames(d),
rows_more <- c("", rows_more)
}
}
print(rows_more)
gr <- gtable_table(rows_more, name="rowmore",
fg_fun=theme$rowmore$fg_fun,
......@@ -105,8 +114,13 @@ extra_table_grob <- function(d, rows=rownames(d), cols=colnames(d),
#' @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 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
#'
#' @importFrom utils modifyList
#'
......@@ -117,7 +131,9 @@ ttheme_awesome <- function(base_size=8,
base_colour="black",
base_family="",
core_size=unit(10, "mm"),
core_n_cat=10,
n_cat=10,
pal="black",
pal_breaks=NULL,
parse=FALSE,
padding=unit(c(0.3,0.3), "mm"), ...){
......@@ -127,15 +143,17 @@ ttheme_awesome <- function(base_size=8,
core_size_value <- as.numeric(core_size)
core_size_unit <- attr(core_size, "unit")
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_params=list(fill=c("#f2f2f2","#e5e5e5"),
width=core_size_value,
height=core_size_value,
default.units=core_size_unit,
lwd=0, col="white"),
n_cat=core_n_cat,
size=core_size,
n_cat=n_cat,
pal=pal,
pal_breaks=pal_breaks,
padding=padding)
colhead <- list(fg_fun=text_grob,
......
......@@ -19,7 +19,7 @@ table_params <- function(d, fg_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 n_cat integer indicating the number of differently-sized circles
......@@ -29,13 +29,70 @@ table_params <- function(d, fg_params, bg_params){
#'
#' @author Yoann Pradat
#' @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 <- as.vector(d)
params <- list(r=do.call(unit.c, lapply(d, function(x) x*r_max)))
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
#'
#' @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 @@
\title{Define theme for awesome table plot.}
\usage{
ttheme_awesome(
base_size = 12,
base_size = 8,
base_colour = "black",
base_family = "",
n_circle = 10,
core_size = unit(10, "mm"),
n_cat = 10,
pal = "black",
pal_breaks = NULL,
parse = FALSE,
padding = unit(c(0.005, 0.005), "npc"),
padding = unit(c(0.3, 0.3), "mm"),
...
)
}
......@@ -21,9 +24,19 @@ ttheme_awesome(
\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{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{
Define theme for awesome table plot.
......
......@@ -8,22 +8,30 @@
Builds on top of \code{tableGrob} from gridExtra R package.}
\usage{
extra_table_grob(
d,
rows = rownames(d),
cols = colnames(d),
dscale,
dcolor = NULL,
rows = rownames(dscale),
cols = colnames(dscale),
rows_more = NULL,
cols_more = NULL,
rows_more_title = "",
cols_more_title = "",
theme = ttheme_awesome(),
vp = NULL,
...
vp = NULL
)
}
\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{
A gtable.
......
......@@ -5,7 +5,7 @@
\title{Vectorised version of circleGrob}
\usage{
circle_grob(
r = unit(0.48, "npc"),
r = unit(5, "mm"),
fill = "black",
col = "black",
lty = "solid",
......@@ -18,9 +18,9 @@ circle_grob(
lex = 1,
name = NULL,
vp = NULL,
x = 0.5,
y = 0.5,
default.units = "npc"
x = unit(0.5, "npc"),
y = unit(0.5, "npc"),
default.units = "mm"
)
}
\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
% Please edit documentation in R/gtables.R
\name{gtable_text}
\alias{gtable_text}
\title{Build a table with text grobs.}
\name{gtable_table}
\alias{gtable_table}
\title{Build a table with foreground and background grobs.}
\usage{
gtable_text(
gtable_table(
d,
widths,
heights,
......@@ -14,12 +14,15 @@ gtable_text(
bg_params = list(),
padding = unit(c(4, 4), "mm"),
name = "table",
vp = NULL
vp = NULL,
...
)
}
\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}
......@@ -36,7 +39,7 @@ gtable_text(
\item{vp}{optional viewport}
\item{width}{optional \code{unit.list} specifying the grob widths}
\item{...}{additional parameters passed to add_table_params.}
}
\value{
A gtable.
......
......@@ -20,11 +20,11 @@ rect_grob(
just = "centre",
hjust = 0.5,
vjust = 0.5,
width = unit(1, "npc") - unit(2, "scaledpts"),
height = unit(1, "npc") - unit(2, "scaledpts"),
x = 0.5,
y = 0.5,
default.units = "npc"
width = unit(100, "mm"),
height = unit(100, "mm"),
x = unit(0.5, "npc"),
y = unit(0.5, "npc"),
default.units = "mm"
)
}
\value{
......
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/table_params.R
\name{table_params}
\alias{table_params}
\title{Build a table of parameters.}
\usage{
table_params(d, fg_params, bg_params)
}
\arguments{
\item{d}{data.frame or matrix}
\item{fg_params}{named list of params}
\item{bg_params}{named list of params}
}
\description{
Build a table of parameters.
}
\author{
Yoann Pradat
}
\keyword{internal}
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/table_params.R
\name{table_params_circle}
\alias{table_params_circle}
\title{Add circle parameters}
\usage{
table_params_circle(dscale, dcolor, n_cat, r_max, pal, pal_breaks)
}
\arguments{
\item{n_cat}{integer indicating the number of differently-sized circles}
\item{r_max}{unit object indicating the maximum radius}
\item{pal}{a character vector of color names}
\item{pal_breaks}{a numeric vector of break points}
\item{d}{data.frame or matrix}
}
\description{
Add circle parameters
}
\author{
Yoann Pradat
}
\keyword{internal}
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/table_params.R
\name{table_params_text}
\alias{table_params_text}
\title{Add text parameters}
\usage{
table_params_text(d)
}
\arguments{
\item{d}{data.frame or matrix}
}
\description{
Add text parameters
}
\author{
Yoann Pradat
}
\keyword{internal}
suppressMessages(library(SummarizedExperiment))
load("testdata/DBS.rda")
test_that("load test data DBS.rda works", {
load("testdata/DBS.rda")
expect_equal(nrow(DBS), 11)
expect_equal(ncol(DBS), 12)
expect_true(is(DBS, "SummarizedExperiment"))
......
test_that("extra table grob", {
load("testdata/DBS.rda")
theme <- ttheme_awesome()
theme <- ttheme_awesome(core_size=unit(5, "mm"))
d <- SummarizedExperiment::assays(DBS)$proportion
g <- extra_table_grob(d, rows=rownames(d), cols=colnames(d),
theme=theme)
out <- plot_grob(g, name="extra_table_grob_big.pdf", width=6, height=6)
out <- plot_grob(g, name="extra_table_grob.pdf", width=4, height=4)
expect_true(out$plot_success)
})
test_that("extra table grob", {
load("testdata/DBS.rda")
test_that("extra table grob cols more", {
theme <- ttheme_awesome(core_size=unit(5, "mm"))
d <- SummarizedExperiment::assays(DBS)$proportion
g <- extra_table_grob(d, rows=rownames(d), cols=colnames(d),
cols_more=SummarizedExperiment::colData(DBS)$description, cols_more_title="n=",
theme=theme)
out <- plot_grob(g, name="extra_table_grob.pdf", width=4, height=4)
out <- plot_grob(g, name="extra_table_grob_cols_more.pdf", width=4, height=4)
expect_true(out$plot_success)
})
test_that("extra table grob cols more", {
load("testdata/DBS.rda")
test_that("extra table grob cols more rows more no color", {
theme <- ttheme_awesome(core_size=unit(5, "mm"))
d <- SummarizedExperiment::assays(DBS)$proportion
g <- extra_table_grob(d, rows=rownames(d), cols=colnames(d),
cols_more=SummarizedExperiment::colData(DBS)$description, cols_more_title="n=",