Skip to content

GitLab

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

bug; bkgd does not change

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