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

DESCRIPTION

@@ -16,3 +16,6 @@ Suggests:
     testthat
 Depends: 
     R (>= 2.10)
+Imports: 
+    gtable,
+    grid

NAMESPACE

@@ -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)

R/gtables.R

@@ -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)

R/table_extra.R

@@ -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, 

R/table_params.R

@@ -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

man/add_table_params.Rd

+% 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}

man/circleTableGrob.Rd

@@ -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.

man/circleTableGrog.Rd

@@ -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.

man/circle_grob.Rd

@@ -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{

man/gtable_circle.Rd

-% 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}

man/gtable_text.Rd → man/gtable_table.Rd

 % 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.

man/rect_grob.Rd

@@ -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{