adding a logo to a grid.table PDF output in R - r

I have a table output in pdf format and I want to customise it to bring in line with a corporate theme. However, I'm new to this area in R and still finding it difficult to find my feet in adding logos.
My original dataset is composed of over 600 rows of data and is sensitive, so I've used a sample dataset to demonstrate. So far, I've got the following code using the grid and gridExtra packages:
library(grid)
library(gridExtra)
Data <- data.frame(Staff = c("Rod","Barry","Cheiny"),
M1 = c(50,40,55),
M2 = c(60,50,55),
M3 = c(55,50,45))
maxrow <- c(35);
npages <- ceiling(nrow(Data)/maxrow);
pdf("Data.pdf", height = 11, width = 10)
idx <- seq(1, maxrow)
grid.table(Data, rows = NULL, theme = ttheme_minimal())
grid.text("data",gp = gpar(fontsize = 12,fontface = "bold",alpha = 0.5),
vjust = -40,
hjust = -0.5)
for (i in 2:npages){
grid.newpage();
if(i*maxrow <= nrow(Data)) {
idx <- seq(1+((i-1)*maxrow), i*maxrow)
}else{
idx <- seq(1+((i-1)*maxrow), nrow(Data))
}
grid.table(Data, rows =NULL, theme = ttheme_minimal())
}
dev.off()
I'm getting a reasonable output at the moment, but I want to add a logo to each of the pages generated.
Anyone know how to add a logo that will repeat across all the pages?

It's easy to add elements with grid.draw(), but the design is up to you
library(grid)
library(gridExtra)
Data <- data.frame(Staff = c("Rod","Barry","Cheiny"),
M1 = c(50,40,55),
M2 = c(60,50,55),
M3 = c(55,50,45))
library(png)
img <- readPNG(system.file("img", "Rlogo.png", package="png"))
footer <- grobTree(rectGrob(y=0,vjust=0,gp=gpar(fill="grey97",col=NA), height=unit(1,"in")),
textGrob(y=unit(0.5,"in"), expression(Corporate^TM~line~(c))),
rasterGrob(img, x=1, hjust=1,y=unit(0.5,"in"),height=unit(1,"in")-unit(2,"mm")))
maxrow <- c(35);
npages <- ceiling(nrow(Data)/maxrow);
pdf("Data.pdf", height = 11, width = 10)
idx <- seq(1, maxrow)
grid.table(Data, rows = NULL, theme = ttheme_minimal())
grid.draw(footer)
grid.text("data",gp = gpar(fontsize = 12,fontface = "bold",alpha = 0.5),
vjust = -40,
hjust = -0.5)
for (i in 2:npages){
grid.newpage();
if(i*maxrow <= nrow(Data)) {
idx <- seq(1+((i-1)*maxrow), i*maxrow)
}else{
idx <- seq(1+((i-1)*maxrow), nrow(Data))
}
grid.table(Data, rows =NULL, theme = ttheme_minimal())
grid.draw(footer)
}
dev.off()

Related

How to make inactive multiple line R code in a script

I do have a long R script and I don't want to delete a part of this R script. Is there any way to avoid running this multiple line R code in the script or should I need to insert # at the beginning of each of these lines?
I don't want to run this whole below code but want to run the code which follow it?
alpha = 0.01
sigtabresTreatment6Genus_T1_vs_T3 = resTreatment6Genus_T1_vs_T3[which(resTreatment6Genus_T1_vs_T3$padj < alpha), ]
sigtabresTreatment6Genus_T1_vs_T3 = cbind(as(sigtabresTreatment6Genus_T1_vs_T3, "data.frame"), as(tax_table(physeq6Genus)[rownames(sigtabresTreatment6Genus_T1_vs_T3), ], "matrix"))
head(sigtabresTreatment6Genus_T1_vs_T3)
dim(sigtabresTreatment6Genus_T1_vs_T3)
library("ggplot2")
theme_set(theme_bw())
scale_fill_discrete <- function(palname = "Set1", ...) {
scale_fill_brewer(palette = palname, ...)
}
# Phylum order
x = tapply(sigtabresTreatment6Genus_T1_vs_T3$log2FoldChange, sigtabresTreatment6Genus_T1_vs_T3$Phylum, function(x) max(x))
x = sort(x, TRUE)
sigtabresTreatment6Genus_T1_vs_T3$Phylum = factor(as.character(sigtabresTreatment6Genus_T1_vs_T3$Phylum), levels=names(x))
# Genus order
x = tapply(sigtabresTreatment6Genus_T1_vs_T3$log2FoldChange, sigtabresTreatment6Genus_T1_vs_T3$Genus, function(x) max(x))
x = sort(x, TRUE)
sigtabresTreatment6Genus_T1_vs_T3$Genus = factor(as.character(sigtabresTreatment6Genus_T1_vs_T3$Genus), levels=names(x))
pdf("DESeq2-Soil-batch1-DEG-T1_vs_T3_pval.01.pdf", width = 8, height = 6);
ggplot(sigtabresTreatment6Genus_T1_vs_T3, aes(x=Genus, y=log2FoldChange, color=Phylum)) + geom_point(size=6)+theme(axis.text.x = element_text(angle = -90, hjust = 0, vjust=0.5))
dev.off();
write.csv(sigtabresTreatment6Genus_T1_vs_T3,"sigResult-Treatment6Genus_T1_vs_T3")
###############
Further R code that needs to run
###########
Many thanks
Yogesh

How to change the position of the zoomed area from facet_zoom()?

With facet_zoom() from the ggforce package one can create nice zooms to highlight certain regions of a plot. Unfortunately, when zooming in on the y axis the original plot is always on the right side.
Is there a way to place the original plot on the left?
This would feel more intuitive to first look at the main plot and then at the zoomed region. As an example I would like to swap the position of the two facets in this plot:
(No reproducible example added, since I believe this is a question about the existence of a certain functionality.)
I've tweaked the current code for FacetZoom on GitHub to swop the horizontal order from [zoom, original] to [original, zoom]. The changes aren't complicated, but they are scattered throughout draw_panels() function's code, so the full code is rather long.
Result:
# example 1, with split = FALSE, horizontal = TRUE (i.e. default settings)
p1 <- ggplot(mtcars, aes(x = mpg, y = disp, colour = factor(cyl))) +
geom_point() +
theme_bw()
p1 + ggtitle("Original") + facet_zoom(y = disp > 300)
p1 + ggtitle("Modified") + facet_zoom2(y = disp > 300)
# example 2, with split = TRUE
p2 <- ggplot(iris, aes(Petal.Length, Petal.Width, colour = Species)) +
geom_point() +
theme_bw()
p2 + ggtitle("Original") +
facet_zoom(xy = Species == "versicolor", split = TRUE)
p2 + ggtitle("Modified") +
facet_zoom2(xy = Species == "versicolor", split = TRUE)
Code used (I've commented out the original code, where modified code is used, & indicated the packages for functions from other packages):
library(ggplot)
library(ggforce)
library(grid)
# define facet_zoom2 function to use FacetZoom2 instead of FacetZoom
# (everything else is the same as facet_zoom)
facet_zoom2 <- function(x, y, xy, zoom.data, xlim = NULL, ylim = NULL,
split = FALSE, horizontal = TRUE, zoom.size = 2,
show.area = TRUE, shrink = TRUE) {
x <- if (missing(x)) if (missing(xy)) NULL else lazyeval::lazy(xy) else lazyeval::lazy(x)
y <- if (missing(y)) if (missing(xy)) NULL else lazyeval::lazy(xy) else lazyeval::lazy(y)
zoom.data <- if (missing(zoom.data)) NULL else lazyeval::lazy(zoom.data)
if (is.null(x) && is.null(y) && is.null(xlim) && is.null(ylim)) {
stop("Either x- or y-zoom must be given", call. = FALSE)
}
if (!is.null(xlim)) x <- NULL
if (!is.null(ylim)) y <- NULL
ggproto(NULL, FacetZoom2,
shrink = shrink,
params = list(
x = x, y = y, xlim = xlim, ylim = ylim, split = split, zoom.data = zoom.data,
zoom.size = zoom.size, show.area = show.area,
horizontal = horizontal
)
)
}
# define FacetZoom as a ggproto object that inherits from FacetZoom,
# with a modified draw_panels function. the compute_layout function references
# the version currently on GH, which is slightly different from the CRAN
# package version.
FacetZoom2 <- ggproto(
"FacetZoom2",
ggforce::FacetZoom,
compute_layout = function(data, params) {
layout <- rbind( # has both x & y dimension
data.frame(name = 'orig', SCALE_X = 1L, SCALE_Y = 1L),
data.frame(name = 'x', SCALE_X = 2L, SCALE_Y = 1L),
data.frame(name = 'y', SCALE_X = 1L, SCALE_Y = 2L),
data.frame(name = 'full', SCALE_X = 2L, SCALE_Y = 2L),
data.frame(name = 'orig_true', SCALE_X = 1L, SCALE_Y = 1L),
data.frame(name = 'zoom_true', SCALE_X = 1L, SCALE_Y = 1L)
)
if (is.null(params$y) && is.null(params$ylim)) { # no y dimension
layout <- layout[c(1,2, 5:6),]
} else if (is.null(params$x) && is.null(params$xlim)) { # no x dimension
layout <- layout[c(1,3, 5:6),]
}
layout$PANEL <- seq_len(nrow(layout))
layout
},
draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord,
data, theme, params) {
if (is.null(params$x) && is.null(params$xlim)) {
params$horizontal <- TRUE
} else if (is.null(params$y) && is.null(params$ylim)) {
params$horizontal <- FALSE
}
if (is.null(theme[['zoom']])) {
theme$zoom <- theme$strip.background
}
if (is.null(theme$zoom.x)) {
theme$zoom.x <- theme$zoom
}
if (is.null(theme$zoom.y)) {
theme$zoom.y <- theme$zoom
}
axes <- render_axes(ranges, ranges, coord, theme, FALSE)
panelGrobs <- ggforce:::create_panels(panels, axes$x, axes$y)
panelGrobs <- panelGrobs[seq_len(length(panelGrobs) - 2)]
if ('full' %in% layout$name && !params$split) {
panelGrobs <- panelGrobs[c(1, 4)]
}
# changed coordinates in indicator / lines to zoom from
# the opposite horizontal direction
if ('y' %in% layout$name) {
if (!inherits(theme$zoom.y, 'element_blank')) {
zoom_prop <- scales::rescale(
y_scales[[2]]$dimension(ggforce:::expansion(y_scales[[2]])),
from = y_scales[[1]]$dimension(ggforce:::expansion(y_scales[[1]])))
indicator <- polygonGrob(
x = c(0, 0, 1, 1), # was x = c(1, 1, 0, 0),
y = c(zoom_prop, 1, 0),
gp = gpar(col = NA, fill = alpha(theme$zoom.y$fill, 0.5)))
lines <- segmentsGrob(
x0 = c(1, 1), x1 = c(0, 0), # was x0 = c(0, 0), x1 = c(1, 1)
y0 = c(0, 1), y1 = zoom_prop,
gp = gpar(col = theme$zoom.y$colour,
lty = theme$zoom.y$linetype,
lwd = theme$zoom.y$size,
lineend = 'round'))
indicator_h <- grobTree(indicator, lines)
} else {
indicator_h <- zeroGrob()
}
}
if ('x' %in% layout$name) {
if (!inherits(theme$zoom.x, 'element_blank')) {
zoom_prop <- scales::rescale(x_scales[[2]]$dimension(ggforce:::expansion(x_scales[[2]])),
from = x_scales[[1]]$dimension(ggforce:::expansion(x_scales[[1]])))
indicator <- polygonGrob(c(zoom_prop, 1, 0), c(1, 1, 0, 0),
gp = gpar(col = NA, fill = alpha(theme$zoom.x$fill, 0.5)))
lines <- segmentsGrob(x0 = c(0, 1), y0 = c(0, 0), x1 = zoom_prop, y1 = c(1, 1),
gp = gpar(col = theme$zoom.x$colour,
lty = theme$zoom.x$linetype,
lwd = theme$zoom.x$size,
lineend = 'round'))
indicator_v <- grobTree(indicator, lines)
} else {
indicator_v <- zeroGrob()
}
}
if ('full' %in% layout$name && params$split) {
space.x <- theme$panel.spacing.x
if (is.null(space.x)) space.x <- theme$panel.spacing
space.x <- unit(5 * as.numeric(convertUnit(space.x, 'cm')), 'cm')
space.y <- theme$panel.spacing.y
if (is.null(space.y)) space.y <- theme$panel.spacing
space.y <- unit(5 * as.numeric(convertUnit(space.y, 'cm')), 'cm')
# change horizontal order of panels from [zoom, original] to [original, zoom]
# final <- gtable::gtable_add_cols(panelGrobs[[3]], space.x)
# final <- cbind(final, panelGrobs[[1]], size = 'first')
# final_tmp <- gtable::gtable_add_cols(panelGrobs[[4]], space.x)
# final_tmp <- cbind(final_tmp, panelGrobs[[2]], size = 'first')
final <- gtable::gtable_add_cols(panelGrobs[[1]], space.x)
final <- cbind(final, panelGrobs[[3]], size = 'first')
final_tmp <- gtable::gtable_add_cols(panelGrobs[[2]], space.x)
final_tmp <- cbind(final_tmp, panelGrobs[[4]], size = 'first')
final <- gtable::gtable_add_rows(final, space.y)
final <- rbind(final, final_tmp, size = 'first')
final <- gtable::gtable_add_grob(final, list(indicator_h, indicator_h),
c(2, 6), 3, c(2, 6), 5,
z = -Inf, name = "zoom-indicator")
final <- gtable::gtable_add_grob(final, list(indicator_v, indicator_v),
3, c(2, 6), 5,
z = -Inf, name = "zoom-indicator")
heights <- unit.c(
unit(max_height(list(axes$x[[1]]$top, axes$x[[3]]$top)), 'cm'),
unit(1, 'null'),
unit(max_height(list(axes$x[[1]]$bottom, axes$x[[3]]$bottom)), 'cm'),
space.y,
unit(max_height(list(axes$x[[2]]$top, axes$x[[4]]$top)), 'cm'),
unit(params$zoom.size, 'null'),
unit(max_height(list(axes$x[[2]]$bottom, axes$x[[4]]$bottom)), 'cm')
)
# swop panel width specifications according to the new horizontal order
widths <- unit.c(
# unit(max_width(list(axes$y[[3]]$left, axes$y[[4]]$left)), 'cm'),
# unit(params$zoom.size, 'null'),
# unit(max_height(list(axes$y[[3]]$right, axes$y[[4]]$right)), 'cm'),
# space.x,
# unit(max_width(list(axes$y[[1]]$left, axes$y[[2]]$left)), 'cm'),
# unit(1, 'null'),
# unit(max_height(list(axes$y[[1]]$right, axes$y[[2]]$right)), 'cm')
unit(max_width(list(axes$y[[1]]$left, axes$y[[2]]$left)), 'cm'),
unit(1, 'null'),
unit(max_height(list(axes$y[[1]]$right, axes$y[[2]]$right)), 'cm'),
space.x,
unit(max_width(list(axes$y[[3]]$left, axes$y[[4]]$left)), 'cm'),
unit(params$zoom.size, 'null'),
unit(max_height(list(axes$y[[3]]$right, axes$y[[4]]$right)), 'cm')
)
final$heights <- heights
final$widths <- widths
} else {
if (params$horizontal) {
space <- theme$panel.spacing.x
if (is.null(space)) space <- theme$panel.spacing
space <- unit(5 * as.numeric(convertUnit(space, 'cm')), 'cm')
heights <- unit.c(
unit(max_height(list(axes$x[[1]]$top, axes$x[[2]]$top)), 'cm'),
unit(1, 'null'),
unit(max_height(list(axes$x[[1]]$bottom, axes$x[[2]]$bottom)), 'cm')
)
# change horizontal order of panels from [zoom, original] to [original, zoom]
# first <- gtable::gtable_add_cols(panelGrobs[[2]], space)
# first <- cbind(final, panelGrobs[[1]], size = 'first')
final <- gtable::gtable_add_cols(panelGrobs[[1]], space)
final <- cbind(final, panelGrobs[[2]], size = "first")
final$heights <- heights
# swop panel width specifications according to the new horizontal order
# unit(c(params$zoom.size, 1), 'null')
final$widths[panel_cols(final)$l] <- unit(c(1, params$zoom.size), 'null')
final <- gtable::gtable_add_grob(final, indicator_h, 2, 3, 2, 5,
z = -Inf, name = "zoom-indicator")
} else {
space <- theme$panel.spacing.y
if (is.null(space)) space <- theme$panel.spacing
space <- unit(5 * as.numeric(convertUnit(space, 'cm')), 'cm')
widths <- unit.c(
unit(max_width(list(axes$y[[1]]$left, axes$y[[2]]$left)), 'cm'),
unit(1, 'null'),
unit(max_height(list(axes$y[[1]]$right, axes$y[[2]]$right)), 'cm')
)
final <- gtable::gtable_add_rows(panelGrobs[[1]], space)
final <- rbind(final, panelGrobs[[2]], size = 'first')
final$widths <- widths
final$heights[panel_rows(final)$t] <- unit(c(1, params$zoom.size), 'null')
final <- gtable::gtable_add_grob(final, indicator_v, 3, 2, 5,
z = -Inf, name = "zoom-indicator")
}
}
final
}
)
Note: create_panels and expansion are un-exported functions from the ggforce package, so I referenced them with triple colons. This isn't robust for writing packages, but should suffice as a temporary workaround.
Update 30 Oct 2019: A suggestion for those seeing errors like Invalid 'type' (list) of argument after trying to use this solution as-is. The issue is likely due to updates made to the ggforcepackage since this solution was developed. To get the code in this solution working again, install the version of ggforce that was available when the solution was developed. This can be done with the devtools package pointing to the 4008a2e commit:
devtools::install_github("thomasp85/ggforce", ref = '4008a2e')

Print a yaml file to a pdf in R

Does anyone know of a way to print a nicely-formatted yaml file to a PDF in R? I'm using the yaml package to load the yaml file, and was wondering what the best way was to turn the keys and values into a nicely-formatted table to be printed to a PDF.
Here is what I have so far, but it's producing a single column whose entries have vectors of NA values:
print_inputs = function(inputs_yaml) {
pdf(file='inputs_page.pdf', onefile=TRUE)
mytheme = ttheme_default(
core=list(fg_params=list(hjust=0, x=0.05)),
rowhead=list(fg_params=list(hjust=0, x=0)),
base_size = 5,
base_colour = "black",
base_family = "",
parse = FALSE,
padding = unit(c(4, 4), "mm"))
mat = create_empty_table(0,2)
for (name in names(inputs_yaml)) {
value = unlist(inputs_yaml[[name]])
mat = rbind(mat, c(name, value))
}
mat = array_split(mat, 25)
for (m in mat) { grid.table(mat, theme=mytheme); grid.newpage(); }
dev.off()
}
create_empty_table <- function(num_rows, num_cols) {
frame <- data.frame(matrix(NA, nrow = num_rows, ncol = num_cols))
return(frame)
}
array_split <- function(data, number_of_chunks) {
rowIdx <- seq_len(nrow(data))
lapply(split(rowIdx, cut(rowIdx, pretty(rowIdx, number_of_chunks))), function(x) data[x, ])
}
yaml_file = yaml.load_file('~/Downloads/inputs__towrite.yaml')
print_inputs(yaml_file)
Here is my solution (basically just calling toString on the values in the yaml file):
print_inputs <- function(inputs_yaml) {
pdf(file='inputs_page.pdf', onefile=TRUE, height=15)
inputs_theme = ttheme_default(
core=list(fg_params=list(hjust=0, x=0.05)),
rowhead=list(fg_params=list(hjust=0, x=0)),
base_size = 5,
base_colour = "black",
base_family = "",
parse = FALSE,
padding = unit(c(4, 2), "mm"))
mat = matrix(ncol=2)
for (name in names(inputs_yaml)) {
value = unlist(inputs_yaml[[name]])
value = gsub(',', '\n', toString(value))
value = gsub('File\n', '', value)
mat = rbind(mat, c(toString(name), value))
}
grid.table(mat, theme=inputs_theme)
dev.off()
}

Export large dataframe to a pdf file

I want to export my dataframe to a pdf file. Dataframe is pretty large, so it is causing problems while exporting. I used gridExtra package as specified here writing data frame to pdf table but it did not work for my dataframe as it contains a lot of data.
Any ideas how it can be achieved?
Code:
library(gridExtra)
df <- data.frame(replicate(10,sample(0:1,1000,rep=TRUE)))
pdf(file = "df2.pdf")
grid.table(df)
dev.off()
#Baqir, you can try solution given on this link:
https://thusithamabotuwana.wordpress.com/2016/01/02/creating-pdf-documents-with-rrstudio/
It will be like this:
library(grid)
library(gridExtra)
df <- data.frame(replicate(10,sample(0:1,1000,rep=TRUE)))
dim(df)
maxrow = 35
npages = ceiling(nrow(df)/maxrow)
pdf("test.pdf", height = 11, width = 8.5)
idx = seq(1, maxrow)
grid.table(df[idx,],rows = NULL)
for(i in 2:npages){
grid.newpage();
if(i*maxrow <= nrow(df)){
idx = seq(1+((i-1)*maxrow), i * maxrow)
}
else{
idx = seq(1+((i-1)*maxrow), nrow(df))
}
grid.table(df[idx, ],rows = NULL)
}
dev.off()
Hope this works!
#Pryore, I found some part of the solution from the link:
link
Here is the code for header and footer.
Hope this works!
makeHeader <- function(headerText= "your header", size= 1, color= grey(.5))
{
require(grid)
pushViewport(viewport())
grid.text(label= headerText,
x = unit(1,"npc") - unit(110, "mm"),
y = unit(270.8, "mm"),
gp=gpar(cex= size, col=color))
popViewport()
}
makeFootnote <- function(footnoteText= "your footnote",
size= 1, color= grey(.5))
{
require(grid)
pushViewport(viewport())
grid.text(label= footnoteText ,
x = unit(1,"npc") - unit(27, "mm"),
y = unit(3, "mm"),
gp=gpar(cex= size, col=color))
popViewport()
}
library(grid)
library(gridExtra)
df <- data.frame(replicate(10,sample(0:1,1000,rep=TRUE)))
dim(df)
maxrow = 35
npages = ceiling(nrow(df)/maxrow)
pdf("trial.pdf", height = 11, width = 8.5)
idx = seq(1, maxrow)
grid.table(df[idx,],rows = NULL)
for(i in 1:npages){
grid.newpage();
makeFootnote()
makeHeader()
if(i*maxrow <= nrow(df)){
idx = seq(1+((i-1)*maxrow), i * maxrow)
}
else{
idx = seq(1+((i-1)*maxrow), nrow(df))
}
grid.table(df[idx, ],rows = NULL)
}
dev.off()

align axes in double plot ggplot R

How can I align the two ggplots in the following function so that the x-axis is corresponding between the table and the graph ? As it is now the interval between the "ticks" is less in the table. Any ideas?
//M
Edit: Forgot to give credit to the learnr website for the table plotting method....
function ggkm:
ggkm<-function(time,event,stratum="-1",tit="",xscale=round(seq(0,max(time),by=max(time)/10),0)) {
lev<-levels(factor(stratum))
w2<-lev[1]!="-1"
if (w2) {stratum<-as.factor(stratum)}
m2s<-Surv(time,as.numeric(event))
if (w2) {fit <- survfit(m2s~stratum)}
else fit<-survfit(m2s~-1)
w<-fit$time
k<-fit$surv
o<-length(levels(stratum))
strata<-c(rep(names(fit$strata[1:o]),fit$strata[1:o]))
lev2<-levels(as.factor(strata))
upper<-fit$upper
lower<-fit$lower
if (w2) {f<-data.frame(w,k,strata,upper,lower)}
else f<-data.frame(w,k,upper,lower)
if (w2) {r<-ggplot (f,aes(x=w,y=k,fill=strata,group=strata))+geom_line(aes(color=strata))+scale_fill_brewer(f$strata,palette="Set1")+scale_color_brewer(f$strata,palette="Set1")}
else r<-ggplot(f,aes(x=w,y=k))+geom_line()
r<-r+geom_ribbon(aes(ymin=lower,ymax=upper),alpha=0.3)+opts(title=tit)
r<-r+opts(panel.grid.minor=theme_blank(),panel.grid.major=theme_blank(),panel.background=theme_blank(),axis.line=theme_segment())
r<-r+opts(legend.position=c(0.8,0.8))
#r<-r+opts(legend.title="")
if (w2) {
r<-r+scale_fill_brewer("",palette="Set1",breaks=lev2,labels=lev)+scale_color_brewer("",palette="Set1",breaks=lev2,labels=lev)
}
r<-r+geom_hline(yintercept=0.5,linetype=2)
r+expand_limits(x = 0, y = 0)+scale_x_continuous("Observation time (months)",expand = c(0, 0),breaks=xscale,labels=xscale,limits=c(min(xscale),max(xscale)))+scale_y_continuous("Probability of overall survival (proportion)",expand = c(0,0))->r
##number at risk table
u<-llply(names(fit$strata),function(x) rep(x,fit$strata[x]))
p<-ldply(u,function(x) data.frame(x))
fit2<-data.frame(p,fit$n.risk,fit$surv,fit$time,fit$n.event)
q<-dlply(fit2,.(x),function(g) data.frame(g$fit.n.risk,g$fit.surv,g$fit.time,g$fit.n.event))
e<-ldply(q,function(y){
o<-ldply(xscale,function(x) y[min(which((x-y$g.fit.time<0))),1])
oo<-cbind(o,xscale)
})
melt(e,id=c("xscale","x"))->e2
e2$strata<-as.factor(e2$x)
cast(subset(e2,e2$variable!="x.time"),strata~xscale,identity)->e3
#e3[["strata"]]<-names(e3[["strata"]])
dg<-ggplot(e2,aes(x=xscale,y=strata,color=strata,label=format(factor(value),nsmall=1)))+geom_text(size=2.5)+theme_bw()+scale_color_brewer(e2$strata,palette="Set1")
#levels(e2$strata)<-lev
dg<-dg+scale_y_discrete(limits=e2$strata)+expand_limits(x=0,y=0)
dg<-dg+opts(panel.grid.minor=theme_blank(),panel.grid.major=theme_blank(),panel.background=theme_blank(),axis.line=theme_blank())
dg<-dg+opts(panel.border=theme_blank(),axis.text.x=theme_blank(),axis.text.y=theme_blank(),axis.ticks=theme_blank())
#dg<-dg+opts(panel.border=theme_blank(),axis.text.x=theme_blank(),axis.ticks=theme_blank())
dg<-dg+opts(plot.margin = unit(c(-0.5,1, 0, 0.5), "lines")) + xlab(NULL) + ylab(NULL)+labs(colour="")
dg<-dg+opts(legend.position="none")
##Same page
Layout <- grid.layout(nrow = 2, ncol = 1, heights = unit(c(2,0.25), c("null", "null")))
grid.show.layout(Layout)
vplayout <- function(...) {
grid.newpage()
pushViewport(viewport(layout = Layout))
}
subplot <- function(x, y) viewport(layout.pos.row = x,layout.pos.col = y)
mmplot <- function(a, b) {
vplayout()
print(a, vp = subplot(1, 1))
print(b, vp = subplot(2, 1))
}
t<-mmplot(r, dg)
return(t)
}
example using ggkm (albeit a poor dataset)
library(survival)
require(ggplot2)
data(leukemia)
with(leukemia,ggkm(time,status,x,tit="Leukemia"))

Resources