Commit b65662b8 authored by Pradat Yoann's avatar Pradat Yoann
Browse files

bug; bkgd does not change

parent 660af7ca
## Note: this functions is modified copy of gtable_table from the gridExtra package.
#' Build a table with text grobs.
#' Build a table with foreground and background grobs.
#'
#' This function is a copy of the internal function \code{gtable_table} of gridExtra package.
#'
#' @param d data.frame or matrix
#' @param width optional \code{unit.list} specifying the grob widths
#' @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
......@@ -15,58 +14,44 @@
#' @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.
#' @return A gtable.
#'
#' @importFrom gtable gtable_matrix gtable_add_grob
#'
#' @author Yoann Pradat
#' @keywords internal
gtable_text <- function(d, widths, heights,
gtable_table <- function(d, widths, heights,
fg_fun = text_grob, fg_params = list(),
bg_fun = rect_grob, bg_params = list(),
padding = unit(c(4, 4), "mm"),
name = "table", vp = NULL){
name = "table", vp = NULL, ...){
label_matrix <- as.matrix(d)
d <- as.matrix(d)
nc <- ncol(label_matrix)
nr <- nrow(label_matrix)
nc <- ncol(d)
nr <- nrow(d)
n <- nc*nr
## formatting parameters will be recycled iff
## there are fewer elements than needed
rep_ifshort <- function(x, n, nc, nr){
if(length(x) >= n){
return(x[1:n])
} else # recycle
return(rep(rep(x, length.out = nr), length.out= n))
}
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)
fg_params <- data.frame(fg_params,
label = as.vector(label_matrix), # colwise
stringsAsFactors=FALSE)
table_params <- table_params(d, fg_params, bg_params)
bg_params <- table_params[["bg_params"]]
fg_params <- table_params[["fg_params"]]
fg_params <- add_table_params(d, fg_params, fg_fun, ...)
bg_params <- data.frame(bg_params, stringsAsFactors=FALSE)
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)))
labels <- 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)))
label_grobs <- matrix(labels, ncol = nc, byrow = FALSE)
frgds_grobs <- matrix(frgds, ncol = nc, byrow = FALSE)
bkgds_grobs <- matrix(bkgds, ncol = nc, byrow = FALSE)
if(missing(widths))
widths <- col_widths(label_grobs) + 2 * padding[1]
widths <- col_widths(frgds_grobs) + padding[1]
if(missing(heights))
heights <- row_heights(label_grobs) + 2 * padding[2]
heights <- row_heights(frgds_grobs) + padding[2]
## place labels in a gtable
## make the gtable matrix of foreground
g <- gtable_matrix(paste0(name, "-fg"),
grobs = label_grobs,
grobs = frgds_grobs,
widths = widths,
heights = heights, vp=vp)
......@@ -83,99 +68,279 @@ gtable_text <- function(d, widths, heights,
g
}
#' Build a table with circle grobs.
#'
#' This function is a copy of the internal function \code{gtable_table} of gridExtra package.
#'
#' @param d data.frame or matrix
#' @param width 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 padding \code{unit.list} object specifying the padding between adjacent cells.
#' @param name optional name of the grob
#' @param vp optional viewport
#' @return A gtable.
#'
#' @importFrom gtable gtable_matrix gtable_add_grob
#'
#' @author Yoann Pradat
#' @keywords internal
gtable_circle <- function(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){
label_matrix <- as.matrix(d)
nc <- ncol(label_matrix)
nr <- nrow(label_matrix)
n <- nc*nr
## formatting parameters will be recycled iff
## there are fewer elements than needed
rep_ifshort <- function(x, n, nc, nr){
if(length(x) >= n){
return(x[1:n])
} else # recycle
return(rep(rep(x, length.out = nr), length.out= n))
}
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)
fg_params <- data.frame(fg_params,
r = as.vector(label_matrix), # colwise
stringsAsFactors=FALSE)
bg_params <- data.frame(bg_params, stringsAsFactors=FALSE)
labels <- 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)))
label_grobs <- matrix(labels, ncol = nc, byrow = FALSE)
bkgds_grobs <- matrix(bkgds, ncol = nc, byrow = FALSE)
# if(missing(widths))
# #widths <- rep(max(col_widths(label_grobs)), nc) + padding[1]
# widths <- rep(max(col_widths(label_grobs)), nc) + padding[1]
# if(missing(heights))
# #heights <- rep(max(row_heights(label_grobs)), nr) + padding[2]
# heights <- rep(max(row_heights(label_grobs)), nr) + padding[2]
widths <- rep(unit(1/max(nc,nr), "npc"), nc) - padding[1]
heights <- rep(unit(1/max(nc,nr), "npc"), nr) - padding[2]
## place labels in a gtable
g <- gtable_matrix(paste0(name, "-fg"),
grobs = label_grobs,
widths = widths,
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"))
## add padding
g <- gtable::gtable_add_col_space(g, padding[1])
g <- gtable::gtable_add_row_space(g, padding[2])
g
}
# library(grid)
# library(gtable)
# suppressMessages(library(SummarizedExperiment))
# load("../tests/testthat/testdata/DBS.rda")
#
# theme <- ttheme_awesome(base_size=8)
# cols <- t(colnames(DBS))
#
# name="colhead"
# fg_fun = theme$colhead$fg_fun
# bg_fun = theme$colhead$bg_fun
# fg_params = theme$colhead$fg_params
# bg_params = theme$colhead$bg_params
# padding=theme$colhead$padding
#
# d <- cols
#
# nc <- ncol(d)
# nr <- nrow(d)
# n <- nc*nr
#
# table_params <- table_params(d, fg_params, bg_params)
# bg_params <- table_params[["bg_params"]]
# fg_params <- table_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)
#
# pdf("testplot.pdf", width=6, height=6)
#
# widths <- col_widths(frgds_grobs) + padding[1]
# heights <- row_heights(frgds_grobs) + padding[2]
#
# ## make the gtable matrix of foreground
# g <- gtable_matrix(paste0(name, "-fg"),
# grobs = frgds_grobs,
# widths = widths,
# 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"))
#
# # add padding
# g <- gtable::gtable_add_col_space(g, padding[1])
# g <- gtable::gtable_add_row_space(g, padding[2])
#
# grid.draw(g)
#
# dev.off()
#
# gc <- gtable_table(t(cols), name="colhead",
# fg_fun = theme$colhead$fg_fun,
# bg_fun = theme$colhead$bg_fun,
# fg_params = theme$colhead$fg_params,
# bg_params = theme$colhead$bg_params,
# padding=theme$colhead$padding)
#
# gr <- gtable_table(rowData(DBS)$name, name="colhead",
# fg_fun = theme$rowhead$fg_fun,
# bg_fun = theme$rowhead$bg_fun,
# fg_params = theme$rowhead$fg_params,
# bg_params = theme$rowhead$bg_params,
# padding=theme$rowhead$padding)
#
#
# d = t(cols)
# d <- rowData(DBS)$name
#
# nc <- ncol(d)
# nr <- nrow(d)
# n <- nc*nr
#
#
#
# table_params <- table_params(d, fg_params, bg_params)
# bg_params <- table_params[["bg_params"]]
# fg_params <- table_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)
#
#
# all.equal(fg_fun, text_grob)
# #' Build a table with text grobs.
# #'
# #' This function is a copy of the internal function \code{gtable_table} of gridExtra package.
# #'
# #' @param d data.frame or matrix
# #' @param width 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 padding \code{unit.list} object specifying the padding between adjacent cells.
# #' @param name optional name of the grob
# #' @param vp optional viewport
# #' @return A gtable.
# #'
# #' @importFrom gtable gtable_matrix gtable_add_grob
# #'
# #' @author Yoann Pradat
# #' @keywords internal
# gtable_text <- function(d, widths, heights,
# fg_fun = text_grob, fg_params = list(),
# bg_fun = rect_grob, bg_params = list(),
# padding = unit(c(4, 4), "mm"),
# name = "table", vp = NULL){
#
# label_matrix <- as.matrix(d)
#
# nc <- ncol(label_matrix)
# nr <- nrow(label_matrix)
# n <- nc*nr
#
# ## formatting parameters will be recycled iff
# ## there are fewer elements than needed
# rep_ifshort <- function(x, n, nc, nr){
# if(length(x) >= n){
# return(x[1:n])
# } else # recycle
# return(rep(rep(x, length.out = nr), length.out= n))
# }
#
# 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)
#
# fg_params <- data.frame(fg_params,
# label = as.vector(label_matrix), # colwise
# stringsAsFactors=FALSE)
#
# bg_params <- data.frame(bg_params, stringsAsFactors=FALSE)
#
# labels <- 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)))
#
# label_grobs <- matrix(labels, ncol = nc, byrow = FALSE)
# bkgds_grobs <- matrix(bkgds, ncol = nc, byrow = FALSE)
#
# if(missing(widths))
# widths <- col_widths(label_grobs) + padding[1]
# if(missing(heights))
# heights <- row_heights(label_grobs) + padding[2]
#
# ## place labels in a gtable
# g <- gtable_matrix(paste0(name, "-fg"),
# grobs = label_grobs,
# widths = widths,
# 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"))
#
# # add padding
# g <- gtable::gtable_add_col_space(g, padding[1])
# g <- gtable::gtable_add_row_space(g, padding[2])
#
# g
# }
#
# #' Build a table with circle grobs.
# #'
# #' This function is a copy of the internal function \code{gtable_table} of gridExtra package.
# #'
# #' @param d data.frame or matrix
# #' @param width 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 padding \code{unit.list} object specifying the padding between adjacent cells.
# #' @param name optional name of the grob
# #' @param vp optional viewport
# #' @return A gtable.
# #'
# #' @importFrom gtable gtable_matrix gtable_add_grob
# #'
# #' @author Yoann Pradat
# #' @keywords internal
# gtable_circle <- function(d, widths, heights,
# fg_fun = text_grob, fg_params = list(),
# bg_fun = rect_grob, bg_params = list(),
# core_size = unit(10, "mm"),
# padding = unit(c(1, 1), "mm"),
# name = "table", vp = NULL){
#
# d <- as.matrix(d)
# nc <- ncol(d)
# nr <- nrow(d)
# n <- nc*nr
#
# fg_fun <- rect_grob()
#
#
# theme <- ttheme_awesome()
# fg_params <- theme$core$fg_params
#
# fg_params <- list(r=do.call(unit.c, lapply(sizes, function(x) x*core_size)))
#
#
# 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)
#
# fg_params <- data.frame(fg_params,
# r = do.call(unit.c, do.call(as.vector(d_matrix), # colwise
# stringsAsFactors=FALSE)
#
# bg_params <- data.frame(bg_params, stringsAsFactors=FALSE)
#
# labels <- 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)))
#
# label_grobs <- matrix(labels, ncol = nc, byrow = FALSE)
# bkgds_grobs <- matrix(bkgds, ncol = nc, byrow = FALSE)
#
# # if(missing(widths))
# # #widths <- rep(max(col_widths(label_grobs)), nc) + padding[1]
# # widths <- rep(max(col_widths(label_grobs)), nc) + padding[1]
# # if(missing(heights))
# # #heights <- rep(max(row_heights(label_grobs)), nr) + padding[2]
# # heights <- rep(max(row_heights(label_grobs)), nr) + padding[2]
#
# widths <- rep(core_size, nc) - padding[1]
# heights <- rep(core_size, nr) - padding[2]
#
# ## place labels in a gtable
# g <- gtable_matrix(paste0(name, "-fg"),
# grobs = label_grobs,
# widths = widths,
# 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"))
# ## add padding
# g <- gtable::gtable_add_col_space(g, padding[1])
# g <- gtable::gtable_add_row_space(g, padding[2])
#
# g
# }
# library(grid)
# library(gtable)
# load("../tests/testthat/testdata/DBS.rda")
#
#
# apply(d, 1:2, function(x) x * unit(1, "mm"))
#
# d <- SummarizedExperiment::assays(DBS)$proportion
# d <- norm_and_cat(d,ncat=theme$core$ncircle, vmax=0.5)
# col <- t(colnames(d))
......@@ -209,6 +374,11 @@ gtable_circle <- function(d, widths, heights,
#
# dev.off()
#
# col_widths <- function(m){
# do.call(grid::unit.c, apply(m, 2, function(l)
# max(do.call(grid::unit.c, lapply(l, grid::grobWidth)))))
# }
# library(gtable)
......
......@@ -16,7 +16,7 @@ col_widths <- function(m){
max(do.call(grid::unit.c, lapply(l, grid::grobWidth)))))
}
norm_and_cat <- function(m, ncat=10, vmax=0.5){
scalecat <- function(m, n_cat=10, vmax=0.5){
if (min(m) == max(m)){
if (min(m) != 0){
m <- m/max(m)
......@@ -27,6 +27,13 @@ norm_and_cat <- function(m, ncat=10, vmax=0.5){
m <- (m-min(m))/(max(m) - min(m))
}
m <- apply(m, 1:2, function(x) round(x*ncat)/(ncat/vmax))
m <- apply(m, 1:2, function(x) round(x*n_cat)/(n_cat/vmax))
m
}
rep_ifshort <- function(x, n, nc, nr){
if(length(x) >= n){
return(x[1:n])
} else # recycle
return(rep(rep(x, length.out = nr), length.out= n))
}
......@@ -8,7 +8,6 @@
#' @param se \code{SummarizedExperiment} object with rownames, colnames, rowData, colData.
#' @param theme list of theme parameters
#' @param vp optional viewport
#' @param ... further arguments to control the gtable
#'
#' @importFrom gtable gtable_add_rows
#'
......@@ -20,19 +19,20 @@
#' @examples
#' library(tableExtra)
extra_table_grob <- function(d, rows=rownames(d), cols=colnames(d),
theme = ttheme_awesome(), vp = NULL,...){
theme = ttheme_awesome(), vp = NULL){
d <- norm_and_cat(d, ncat=theme$core$ncircle, vmax=0.5)
g <- gtable_circle(d, name="core",
g <- gtable_table(d, name="core",
fg_fun = theme$core$fg_fun,
bg_fun = theme$core$bg_fun,
fg_params = theme$core$fg_params,
bg_params = theme$core$bg_params,
padding=theme$core$padding, ...)
padding = theme$core$padding,
n_cat = theme$core$n_cat,
r_max = theme$core$size - pmax(theme$core$padding))
if(!is.null(cols)){
gc <- gtable_text(t(cols), name="colhead",
gc <- gtable_table(t(cols), name="colhead",
fg_fun = theme$colhead$fg_fun,
bg_fun = theme$colhead$bg_fun,
fg_params = theme$colhead$fg_params,
......@@ -79,16 +79,19 @@ extra_table_grob <- function(d, rows=rownames(d), cols=colnames(d),
ttheme_awesome <- function(base_size=12,
base_colour="black",
base_family="",
ncircle=10,
core_size=unit(10,"mm"),
core_n_cat=10,
parse=FALSE,
padding = unit(c(1, 1), "mm"), ...){
core <- list(fg_fun = circle_grob,
fg_params = list(fill = c("#6767f8"), col="white", lwd=0),
bg_fun = rect_grob,
bg_params = list(fill = c("#f2f2f2","#e5e5e5"),
bg_params = list(x = core_size, y = core_size,
fill = c("#f2f2f2","#e5e5e5"),
lwd=0, col="white"),
ncircle = ncircle,
n_cat = core_n_cat,
size = core_size,
padding = padding)
colhead <- list(fg_fun = text_grob,
......@@ -100,7 +103,8 @@ ttheme_awesome <- function(base_size=12,
y = 0.05,
rot = 90),
bg_fun = rect_grob,
bg_params = list(fill = c("grey95"), lwd=0, col="white"),
bg_params = list(x = core_size, fill = c("black"),
lwd=0, col="black"),
padding = padding)
rowhead <- list(fg_fun = text_grob,
......@@ -111,7 +115,8 @@ ttheme_awesome <- function(base_size=12,
hjust = 1,
x = 0.95),
bg_fun = rect_grob,
bg_params = list(fill=c("grey95"), lwd=0, col="white"),
bg_params = list(y = core_size, fill=c("grey95"),
lwd=0, col="white"),
padding = padding)
default <- list(
......
#' Build a table of parameters.
#'
#' @param d data.frame or matrix
#' @param fg_params named list of params
#' @param bg_params named list of params
#'
#' @importFrom grid unit.c
#'
#' @author Yoann Pradat
#' @keywords internal
table_params <- function(d, fg_params, bg_params){
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))
}
#' 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
#'
#' @importFrom grid unit.c
#'
#' @author Yoann Pradat
#' @keywords internal
table_params_circle <- 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 text parameters
#'
#' @param d data.frame or matrix
#'
#' @author Yoann Pradat
#' @keywords internal
table_params_text <- function(d){
d <- as.vector(d)
params <- list(label=d)