Skip to content

GitLab

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

succesfully make plot extra table cols more rows more

parent b65662b8
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 452 additions and 715 deletions
R/gtables.R
View file @ 6324cdd6
This diff is collapsed.
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
This diff is collapsed.
R/vectorgrobs.R
View file @ 6324cdd6
......@@ -68,11 +68,11 @@ rect_grob <- function(fill = "white",
just = "centre",
hjust = 0.5,
vjust = 0.5,
width = unit(10, "mm"),
height = unit(10, "mm"),
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"){
rectGrob(x = x,
y = y,
......@@ -112,9 +112,9 @@ circle_grob <- function(r=unit(5, "mm"),
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"){
circleGrob(r = r,
x = x,
......
tests/testthat/helper-plot.R
View file @ 6324cdd6
......@@ -5,5 +5,5 @@ plot_grob <- function(g, name, width=NULL, height=NULL){
onefile=T)
grid::grid.draw(g)
grDevices::dev.off()
invisible(list(plot.success=T))
invisible(list(plot_success=T))
}
tests/testthat/test-extra_table_grob.R
View file @ 6324cdd6
# test_that("extra table grob", {
# load("testdata/DBS.rda")
#
# d <- SummarizedExperiment::assays(DBS)$proportion
# theme <- ttheme_awesome()
#
# g <- extra_table_grob(d, rows=rownames(d), cols=colnames(d),
# theme=theme)
#
# out <- plot_grob(g, name="extra_table_grob.pdf")
# expect_true(out$plot.success)
# })
test_that("extra table grob", {
load("testdata/DBS.rda")
theme <- ttheme_awesome()
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)
expect_true(out$plot_success)
})
test_that("extra table grob", {
load("testdata/DBS.rda")
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.pdf", width=4, height=4)
expect_true(out$plot_success)
})
test_that("extra table grob cols more", {
load("testdata/DBS.rda")
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_cols_more.pdf", width=4, height=4)
expect_true(out$plot_success)
})
test_that("extra table grob cols more rows more", {
load("testdata/DBS.rda")
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=",
rows_more=SummarizedExperiment::rowData(DBS)$description, rows_more_title="Proposied aetiology",
theme=theme)
out <- plot_grob(g, name="extra_table_grob_cols_more_rows_more.pdf", width=5, height=4)
expect_true(out$plot_success)
})
tests/testthat/test-gtable_utils.R
View file @ 6324cdd6
......@@ -4,14 +4,14 @@ test_that("rbind_2 on text row", {
theme <- ttheme_awesome()
d <- t(SummarizedExperiment::colData(DBS)$description)
g1 <- gtable_text(d, name="colhead-1",
g1 <- gtable_table(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",
g2 <- gtable_table(d, name="colhead-2",
fg_fun = theme$colhead$fg_fun,
bg_fun = theme$colhead$bg_fun,
fg_params = theme$colhead$fg_params,
......@@ -20,8 +20,8 @@ test_that("rbind_2 on text row", {
g <- rbind_2(g1, g2, "max", height=theme$core$padding[1])
out <- plot_grob(g, name="gtable_rbind_2_text_row.pdf")
expect_true(out$plot.success)
out <- plot_grob(g, name="gtable_rbind_2_text_row.pdf", width=4, height=1)
expect_true(out$plot_success)
})
test_that("rbind_2 on text mat", {
......@@ -31,24 +31,24 @@ test_that("rbind_2 on text mat", {
d <- SummarizedExperiment::rowData(DBS)$name
d <- matrix(rep(d, 5), nrow=5, byrow=T)
g1 <- gtable_text(d, name="rowhead-1",
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)
g1 <- gtable_table(d, name="rowhead-1",
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)
g2 <- gtable_text(d, name="rowhead-2",
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)
g2 <- gtable_table(d, name="rowhead-2",
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 <- rbind(g1, g2, size="first")
g <- rbind_2(g1, g2, size="first", height=theme$rowhead$padding[1])
out <- plot_grob(g, name="gtable_rbind_2_text_mat.pdf")
expect_true(out$plot.success)
out <- plot_grob(g, name="gtable_rbind_2_text_mat.pdf", width=4, height=3)
expect_true(out$plot_success)
})
......@@ -56,56 +56,66 @@ test_that("cbind_2 on table circle", {
load("testdata/DBS.rda")
theme <- ttheme_awesome()
d <- SummarizedExperiment::assays(DBS)$proportion
d <- norm_and_cat(d,ncat=theme$core$ncircle, vmax=0.5)
g1 <- 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)
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 <- cbind_2(g1, g2, "max", width=theme$core$padding[1])
out <- plot_grob(g, name="gtable_circle_cbind.pdf")
expect_true(out$plot.success)
widths <- rep(theme$core$size, ncol(d))
heights <- rep(theme$core$size, nrow(d))
g1 <- 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)
g2 <- 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)
g <- cbind_2(g1, g2, "max", width=theme$core$padding[2])
out <- plot_grob(g, name="gtable_circle_cbind.pdf", width=10, height=6)
expect_true(out$plot_success)
})
test_that("rbind_2 on table text - circle", {
load("testdata/DBS.rda")
theme <- ttheme_awesome()
d <- SummarizedExperiment::assays(DBS)$proportion
d <- norm_and_cat(d,ncat=theme$core$ncircle, vmax=0.5)
col <- t(colnames(d))
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_2(g1, g2, size="last", height=theme$core$padding[2])
g <- rbind(g1, g2, size="last")
#col <- t(colData(DBS)$description)
#heights <- unit(30, "mm")
g1 <- gtable_table(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)
widths <- rep(theme$core$size, ncol(d))
heights <- rep(theme$core$size, nrow(d))
g2 <- 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)
g <- rbind_2(g1, g2, size="last", height=theme$core$padding[1])
out <- plot_grob(g, name="gtable_rbind_2_text_circle.pdf")
expect_true(out$plot.success)
expect_true(out$plot_success)
})
tests/testthat/test-gtables.R
View file @ 6324cdd6
test_that("gtable text row", {
test_that("gtable text row no padding", {
load("testdata/DBS.rda")
theme <- ttheme_awesome(base_colour="blue")
theme <- ttheme_awesome(padding=unit(c(0,0), "mm"))
d <- t(SummarizedExperiment::colData(DBS)$description)
widths <- rep(theme$core$size, ncol(d))
heights <- unit(4, "mm")
gc <- gtable_table(d, 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,
widths=widths,
heights=heights,
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)
out <- plot_grob(gc, name="gtable_text_row.pdf", width=4, height=1)
expect_true(out$plot.success)
out <- plot_grob(gc, name="gtable_text_row_no_padding.pdf", width=8, height=1)
expect_true(out$plot_success)
})
test_that("gtable text row with padding", {
load("testdata/DBS.rda")
theme <- ttheme_awesome(padding=unit(c(2,0), "mm"))
d <- t(SummarizedExperiment::colData(DBS)$description)
widths <- rep(theme$core$size, ncol(d))
heights <- unit(4, "mm")
gc <- gtable_table(d, name="colhead",
widths=widths,
heights=heights,
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)
out <- plot_grob(gc, name="gtable_text_row_with_padding.pdf", width=8, height=1)
expect_true(out$plot_success)
})
test_that("gtable text col", {
load("testdata/DBS.rda")
theme <- ttheme_awesome()
theme <- ttheme_awesome(padding=unit(c(0,0), "mm"))
d <- as.matrix(SummarizedExperiment::rowData(DBS))
heights <- rep(theme$core$size, nrow(d))
gr <- gtable_table(d, name="rowhead",
heights=heights,
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)
out <- plot_grob(gr, name="gtable_text_col.pdf", width=1, height=4.5)
expect_true(out$plot_success)
})
test_that("gtable text mat no padding", {
load("testdata/DBS.rda")
theme <- ttheme_awesome(padding=unit(c(0,0), "mm"))
d <- SummarizedExperiment::rowData(DBS)$name
d <- matrix(rep(d, 5), nrow=5, byrow=T)
widths <- rep(theme$core$size, ncol(d))
heights <- rep(theme$core$size, nrow(d))
gr <- gtable_table(d, 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,
widths=widths,
heights=heights,
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)
out <- plot_grob(gr, name="gtable_text_col.pdf", width=1, height=4)
expect_true(out$plot.success)
out <- plot_grob(gr, name="gtable_text_mat_no_padding.pdf")
expect_true(out$plot_success)
})
test_that("gtable text mat", {
test_that("gtable text mat with padding", {
load("testdata/DBS.rda")
theme <- ttheme_awesome()
theme <- ttheme_awesome(padding=unit(c(1,1), "mm"))
d <- SummarizedExperiment::rowData(DBS)$name
d <- matrix(rep(d, 5), nrow=5, byrow=T)
widths <- rep(theme$core$size, ncol(d))
heights <- rep(theme$core$size, nrow(d))
gr <- gtable_table(d, 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,
widths=widths,
heights=heights,
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)
out <- plot_grob(gr, name="gtable_text_mat.pdf")
expect_true(out$plot.success)
out <- plot_grob(gr, name="gtable_text_mat_with_padding.pdf")
expect_true(out$plot_success)
})
# test_that("gtable circle", {
# load("testdata/DBS.rda")
#
# theme <- ttheme_awesome()
#
# d <- SummarizedExperiment::assays(DBS)$proportion
# d <- norm_and_cat(d,ncat=theme$core$ncircle, vmax=0.5)
#
# g <- 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)
#
# out <- plot_grob(g, name="gtable_circle.pdf")
# expect_true(out$plot.success)
# })
test_that("gtable circle", {
load("testdata/DBS.rda")
theme <- ttheme_awesome()
d <- SummarizedExperiment::assays(DBS)$proportion
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=unit(5, "mm"))
out <- plot_grob(g, name="gtable_circle.pdf")
expect_true(out$plot_success)
})
tests/testthat/test-vectorgrobs.R
View file @ 6324cdd6
......@@ -7,11 +7,13 @@ test_that("text grob", {
expect_true(is(g, "text"))
out <- plot_grob(g, name="text_grob.pdf", width=1, height=1)
expect_true(out$plot.success)
expect_true(out$plot_success)
})
test_that("rect grob", {
g <- rect_grob(fill="grey80",
g <- rect_grob(width=unit(10, "mm"),
height=unit(10, "mm"),
fill="grey80",
col="black",
lty="solid",
cex=1)
......@@ -20,11 +22,29 @@ test_that("rect grob", {
expect_true(is(g, "rect"))
out <- plot_grob(g, name="rect_grob.pdf", width=1, height=1)
expect_true(out$plot.success)
expect_true(out$plot_success)
})
test_that("rect grob", {
g <- rect_grob(x=unit(0.5, "mm"),
y=unit(0.5, "mm"),
width=unit(10,"mm"),
height=unit(10,"mm"),
fill="grey80",
col="black",
lty="solid",
cex=1)
expect_true(is(g, "grob"))
expect_true(is(g, "rect"))
out <- plot_grob(g, name="rect_grob_xy.pdf", width=1, height=1)
expect_true(out$plot_success)
})
test_that("circle grob", {
g <- circle_grob(fill="grey80",
g <- circle_grob(r=unit(5, "mm"),
fill="grey80",
col="black",
lty="solid",
cex=1)
......@@ -33,7 +53,7 @@ test_that("circle grob", {
expect_true(is(g, "circle"))
out <- plot_grob(g, name="circle_grob.pdf", width=1, height=1)
expect_true(out$plot.success)
expect_true(out$plot_success)
})
test_that("circle rect grob", {
......@@ -44,9 +64,9 @@ test_that("circle rect grob", {
lty="solid",
cex=1)
gr <- rect_grob(fill="white",
x = 0.5,
y = 0.5,
gr <- rect_grob(width=unit(10,"mm"),
height=unit(10,"mm"),
fill="white",
col="black",
lty="solid",
cex=1)
......@@ -56,7 +76,7 @@ test_that("circle rect grob", {
expect_true(is(g, "grob"))
out <- plot_grob(g, name="rect_circle_grob.pdf", width=1, height=1)
expect_true(out$plot.success)
expect_true(out$plot_success)
})
test_that("circle rect grob small", {
......@@ -67,9 +87,9 @@ test_that("circle rect grob small", {
lty="solid",
cex=1)
gr <- rect_grob(fill="white",
x = 0.5,
y = 0.5,
gr <- rect_grob(width=unit(10,"mm"),
height=unit(10,"mm"),
fill="white",
col="black",
lty="solid",
cex=1)
......@@ -79,5 +99,5 @@ test_that("circle rect grob small", {
expect_true(is(g, "grob"))
out <- plot_grob(g, name="rect_circle_grob_small.pdf", width=4, height=4)
expect_true(out$plot.success)
expect_true(out$plot_success)
})
tests/testthat/testdata/DBS.R
View file @ 6324cdd6
......@@ -55,12 +55,12 @@ assays[["median"]] <- data
rows.desc <- c("Ultraviolet light exposure", "Tobacco Smokin and other", "POLE mutation", "", "Platinum treatment", "",