Skip to content

GitLab

Commit 6324cdd6 authored by Pradat Yoann's avatar Pradat Yoann
Browse files

succesfully make plot extra table cols more rows more

parent b65662b8
Hide whitespace changes
Inline Side-by-side
R/gtables.R
View file @ 6324cdd6
......@@ -33,9 +33,9 @@ gtable_table <- function(d, widths, heights,
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"]]
tb_params <- table_params(d, fg_params, bg_params)
bg_params <- tb_params[["bg_params"]]
fg_params <- tb_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)))
......@@ -44,10 +44,19 @@ 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) + padding[1]
widths <- col_widths(frgds_grobs)
if(missing(heights))
heights <- row_heights(frgds_grobs) + padding[2]
heights <- row_heights(frgds_grobs)
## make the gtable matrix of foreground
g <- gtable_matrix(paste0(name, "-fg"),
......@@ -68,511 +77,32 @@ gtable_table <- function(d, widths, heights,
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]
# 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(paste0(name, "-fg"),
# grobs = frgds_grobs,
# g <- gtable_matrix("-bg",
# grobs = bkgds_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)
#
# heights = heights)
#
# 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)
# 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
#
# # 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,
# ## make the gtable matrix of foreground
# g <- gtable_matrix("-bg",
# grobs = bkgds_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))
#
# theme <- ttheme_awesome(base_size=8)
#
# pdf('testplot.pdf')
#
# g1 <- gtable_text(col, name="colhead-1",
# 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)
#
# g2 <- gtable_circle(d, name="circle",
# 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)
#
# g <- rbind(g1, g2, size="last")
#
# g2 <- gtable_add_cols(g2, pos=0, widths=unit(6, "cm"))
# g2 <- gtable_add_rows(g2, pos=0, heights=unit(8, "cm"))
# g2 <- gtable_add_rows(g2, pos=-1, heights=unit(8, "cm"))
# g2 <- gtable_add_cols(g2, pos=-1, widths=unit(6, "cm"))
# heights = heights)
#
# grid.draw(g2)
# out <- plot_grob(g, name="gtable_text_row_unwanted_padding.pdf", width=8, height=1)
#
# 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)
#
# load("../tests/testthat/testdata/DBS.rda")
#
# pdf("testplot.pdf")
#
# theme <- ttheme_awesome()
# d <- SummarizedExperiment::rowData(DBS)$name
# d <- matrix(rep(d, 5), nrow=5, byrow=T)
#
# g1 <- gtable_text(d, name="colhead-1",
# 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)
#
# g2 <- gtable_text(d, name="colhead-2",
# 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)
#
# g <- cbind(g1, g2, size="first")
#
# grid.draw(g)
#
# dev.off()
# pdf("testplot.pdf")
#
# library(grid)
# gt <- gtable(unit(1, "null"), unit(0.5, "null"))
# gt <- gtable_add_grob(gt, rectGrob(gp = gpar(fill = "black"), x=1, y=0.5), 1, 1)
#
# plot(gt)
# plot(cbind(gt, gt))
# plot(rbind(gt, gt))
#
# pad <- gtable_add_padding(gt, unit(1, "cm"))
# plot(pad)
# plot(cbind(pad, pad))
# plot(rbind(pad, pad))
#
# pad <- gtable_add_padding(pad, unit(-0.5, "cm"))
# plot(pad)
# plot(cbind(pad, pad))
# plot(rbind(pad, pad))
#
# dev.off()
#
# print("ok")
# load("../tests/testthat/testdata/DBS.rda")
# suppressMessages(library(SummarizedExperiment))
#
# d <- assays(DBS)$proportion
# theme <- ttheme_awesome()
#
# d <- norm_and_cat(d,ncat=theme$core$ncircle, vmax=0.5)
#
# ## map continuous values to [0,1]
# if (min(d) == max(d)){
# if (min(d) != 0){
# d_norm <- d/max(d)
# } else {
# d_norm <- d
# }
# } else {
# d_norm <- (d-min(d))/(max(d) - min(d))
# }
#
# ## bin into n_circle categories and map to [0,0.5]
# d_norm <- apply(d_norm, 1:2, function(x) round(x*theme$core$n_circle)/(2*theme$core$n_circle))
#
# cols <- colnames(d)
# rows <- rownames(d)
#
# g <- gtable_circle(d_norm, 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)
#
# if(!is.null(cols)){
# gc <- gtable_text(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)
# gc <- gtable_add_rows(gc, theme$rowhead$padding[1])
# g <- rbind_2(gc, g, "max")
#
#
# if(!is.null(rows)){
# if(!is.null(cols)) # need to add dummy cell
# rows <- c("", rows)
# gr <- gtable_text(rows, name="rowhead",
# 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)
# g <- cbind_2(gr, g, "max")
# }
#
# colnames(g) <- paste0("c", seq_len(ncol(g)))
# rownames(g) <- paste0("r", seq_len(nrow(g)))
# load("../tests/testthat/testdata/DBS.rda")
# suppressMessages(library(SummarizedExperiment))
#
# d <- assays(DBS)$proportion
# d <- apply(d, 1:2, function(x) round(x*10)/20)
# theme <- ttheme_awesome()
# #
# # 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
#
#
# circle_small_plot <- function(nc=2, nr=2, padding=grid::unit(c(0.01,0.01), "npc")){
# row_heights <- function(m){
# do.call(grid::unit.c, apply(m, 1, function(l)
# max(do.call(grid::unit.c, lapply(l, grid::grobHeight)))))
# }
#
# col_widths <- function(m){
# do.call(grid::unit.c, apply(m, 2, function(l)
# max(do.call(grid::unit.c, lapply(l, grid::grobWidth)))))
# }
#
# fg_params <- data.frame(r=c(unit(0.5, "npc")), fill=c("#6767f8"), lwd=c(0), col=c("white"), stringsAsFactors=F)
# bg_params <- data.frame(fill=c("#f2f2f2"), lwd=0, col=c("white"), stringsAsFactors=F)
#
#
# fg_params <- fg_params[rep(seq_len(nrow(fg_params)), each = nc*nr), ]
# bg_params <- bg_params[rep(seq_len(nrow(bg_params)), each = nc*nr), ]
#
# labels <- do.call(mapply, c(fg_params, list(FUN = circle_grob,
# SIMPLIFY=FALSE)))
# bkgds <- do.call(mapply, c(bg_params, list(FUN = rect_grob,
# SIMPLIFY=FALSE)))
#
# label_grobs <- matrix(labels, ncol = nc, byrow = FALSE)
# bkgds_grobs <- matrix(bkgds, ncol = nc, byrow = FALSE)
#
# # widths <- rep(max(col_widths(label_grobs)), nc) + padding[1]
# # 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::gtable_matrix(paste0(name, "-fg"),
# grobs = label_grobs,
# widths = widths,
# heights = heights, vp=vp)
#
# ## add the background
# g <- gtable::gtable_add_grob(g, bkgds_grobs,
# t=rep(seq_len(nr), length.out = nr*nc),
# l=rep(seq_len(nc), each = nr), z=0,
# name=paste0(name, "-bg"))
# g <- gtable::gtable_add_col_space(g, padding[1])
# g <- gtable::gtable_add_row_space(g, padding[2])
#
# g
# }
#
# pdf(file="gtable_circle_small.pdf")
#
# g <- circle_small_plot(nc=3, nr=2, padding=unit(c(0.01,0.01), "npc"))
#
# grid.draw(g)
# dev.off()
#
#
# pdf(file="gtable_circle_small.pdf")
#
# g1 <- circle_small_plot(nc=2, nr=4)
# g2 <- circle_small_plot(nc=1, nr=4)
#
# g <- cbind_2(g1, g2, "max")
#
# grid.draw(g)
# dev.off()
# as.vector(SummarizedExperiment::rowData(DBS)$description)
R/other_utils.R
View file @ 6324cdd6
......@@ -8,12 +8,12 @@ rep_along <- function(x, y) {
row_heights <- function(m){
do.call(grid::unit.c, apply(m, 1, function(l)
max(do.call(grid::unit.c, lapply(l, grid::grobHeight)))))
1.1*max(do.call(grid::unit.c, lapply(l, grid::grobHeight)))))
}
col_widths <- function(m){
do.call(grid::unit.c, apply(m, 2, function(l)
max(do.call(grid::unit.c, lapply(l, grid::grobWidth)))))
1.1*max(do.call(grid::unit.c, lapply(l, grid::grobWidth)))))
}
scalecat <- function(m, n_cat=10, vmax=0.5){
......
R/table_extra.R
View file @ 6324cdd6
......@@ -19,49 +19,86 @@
#' @examples
#' library(tableExtra)
extra_table_grob <- function(d, rows=rownames(d), cols=colnames(d),
theme = ttheme_awesome(), vp = NULL){
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,
n_cat = theme$core$n_cat,
r_max = theme$core$size - pmax(theme$core$padding))
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))
g <- gtable_table(d, name="circle",
widths=widths,
heights=heights,
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,
r_max=0.5*theme$core$size)
if(!is.null(cols)){
if (!is.null(cols_more)){
gc <- gtable_table(t(cols_more), name="colmore",
fg_fun=theme$colmore$fg_fun,
bg_fun=theme$colmore$bg_fun,
fg_params=theme$colmore$fg_params,
bg_params=theme$colmore$bg_params,
padding=theme$colmore$padding)
g <- rbind_2(gc, g, "max", height=theme$colmore$padding[1])
}
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,
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)
g <- rbind_2(gc, g, "max", height=theme$rowhead$padding[1])
g <- rbind_2(gc, g, "max", height=theme$colhead$padding[1])