Nothing
# Xpose 4
# An R-based population pharmacokinetic/
# pharmacodynamic model building aid for NONMEM.
# Copyright (C) 1998-2004 E. Niclas Jonsson and Mats Karlsson.
# Copyright (C) 2005-2008 Andrew C. Hooker, Justin J. Wilkins,
# Mats O. Karlsson and E. Niclas Jonsson.
# Copyright (C) 2009-2010 Andrew C. Hooker, Mats O. Karlsson and
# E. Niclas Jonsson.
# This file is a part of Xpose 4.
# Xpose 4 is free software; you can redistribute it and/or
# modify it under the terms of the GNU Lesser General Public License
# as published by the Free Software Foundation, either version 3
# of the License, or (at your option) any later version.
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU Lesser General Public License for more details.
# You should have received a copy of the GNU Lesser General Public License
# along with this program. A copy can be cound in the R installation
# directory under \share\licenses. If not, see http://www.gnu.org/licenses/.
#' Print tables or text in a grid object
#'
#' These functions take an array of values and labels or an array of text and
#' add it to one or many grid viewports in an orderly fashion.
#'
#'
#' @aliases add.grid.table add.grid.text
#' @param txt The text or table values to add to the grid object.
#' @param col.nams the column names of the table values
#' @param ystart The y location to start printing in the grid viewport
#' @param xstart The x location to start printing in the grid viewport
#' @param start.pt The start point (row) in the table array to start printing
#' @param vp The viewport(s) to add the table or text to
#' @param vp.num the viewport number in \code{vp} to start printing to
#' @param minrow The minimum rows before printing more columns to use in the
#' table
#' @param cell.padding padding between cells in the table
#' @param mult.col.padding padding between multiple columns in the table
#' @param col.optimize should we column optimize (\code{TRUE}) or row optimize
#' (\code{FALSE})
#' @param equal.widths Should all columns have equal widths
#' @param space.before.table Should there be a space before the table
#' @param center.table should we center the table in the viewport?
#' @param use.rect Should we make rectangles with background color around the
#' table entries \code{TRUE} or \code{FALSE}
#' @param fill.type Which rectangles should be filled. Allowed values are
#' \code{"all"}, \code{"top"}, \code{"side"}, \code{"both"} and \code{NULL}.
#' @param fill.col The color of the filled rectangles
#' @param cell.lines.lty The line-type for the lines between the cells, using
#' the same values as lty.
#' @param \dots Other arguments passed to the various functions.
#' @return A List is returned with the following components \item{ystart }{new
#' starting point for new text} \item{stop.pt }{null if everything gets
#' printed} \item{vp.num }{the viewport needed for next text printed}
#' \item{xpose.table }{A grob object that can be plotted.}
#' @author Andrew Hooker
#' @seealso \code{\link{runsum}}, \code{\link[grid]{grid.text}}
#' @keywords methods
#' @export add.grid.table
add.grid.table <- function(txt, # list of character vectors
# corresponding to
# columns in table
# list(parnam, parval)
col.nams=NULL, # collumn names c("col1","col2")
ystart, # y-coordinate in viewport to start
xstart=unit(0,"npc"), # x coordinate in viewport
start.pt=1, # point in lists to start
vp, # list of viewport names list(vp1,vp2)
vp.num=1, # number of viewport to begin with
minrow=5, # minimum rows in each column
cell.padding=0.5, # padding in each cell of table
# in character units
mult.col.padding=1, # padding between
# new new columns of the table
col.optimize=TRUE, # get maximum columns or rows in viewport
equal.widths=FALSE, # should all columns have equal widths
space.before.table=1,
center.table=FALSE,
use.rect=FALSE,
fill.type=NULL, # all,top,side,both,NULL
fill.col="grey",
cell.lines.lty=0,
...) {
## to do:
##
## add grid rectangles if asked for
## table title
for(k in vp.num:length(vp)){
vp.num = k
pushViewport(vp[[k]])
wdth <- rep(0,length(txt))
ncols <- length(txt)
npar <- length(txt[[1]])
for (i in 1:ncols){
wdth[i] <- convertWidth(max(unit(rep(1, length(txt[[i]])),"strwidth",
data = as.list(txt[[i]])))+unit(cell.padding,"char"),
"npc",valueOnly=TRUE)
if(!is.null(col.nams)) {
tmp <- convertWidth(max(unit(rep(1, length(col.nams[i])),"strwidth",
data = as.list(col.nams[i])))
+unit(cell.padding,"char"),
"npc",valueOnly=TRUE)
if(tmp>wdth[i]) wdth[i]=tmp
}
}
if (equal.widths){
wdth[1:length(wdth)]=max(wdth)
}
wdth.tot <- sum(wdth) + convertWidth(unit(mult.col.padding,"char"),"npc",valueOnly=TRUE)
vp.lines.left <- convertHeight(ystart,"lines",valueOnly=TRUE)
vp.width.left <- 1 - convertWidth(xstart,"npc",valueOnly=TRUE)
ncol.grps.avail <- floor(vp.width.left/wdth.tot) # a multiple of ncols
nrows.avail <- floor(vp.lines.left)
xtra.space <- vp.width.left - wdth.tot*ncol.grps.avail
upViewport()
## make sure we have space for table
if (ncol.grps.avail==0){
warning("fontsize too large for table to print")
ret.list <- list(ystart = ystart, # new starting point for new text
stop.pt = NULL,
vp.num = vp.num # the viewport needed for this to work
)
return(ret.list)
}
if (nrows.avail<2){
space.avail <- TRUE
if(!is.null(col.nams)||nrows.avail==0){
space.avail <- FALSE
stop.pt <- start.pt
}
} else {
space.avail <- TRUE
}
## Decide how many rows in each column of parameters
if (col.optimize){
if(npar <= minrow*ncol.grps.avail) {
ncol.grps.needed <- ceiling(npar/minrow)
if(ncol.grps.needed==1) par.in.col <- npar
if(ncol.grps.needed > 1) par.in.col <- minrow
} else {
par.in.col <- ceiling(npar/ncol.grps.avail)
ncol.grps.needed <- ncol.grps.avail
}
} else { # row optimize
ncol.grps.needed <- ceiling(npar/nrows.avail)
if(ncol.grps.needed==1) par.in.col <- npar
if(ncol.grps.needed > 1) par.in.col <- nrows.avail
}
## To make it easier to print the parameters we add empty entries
## to fill all columns
max.par <- ncol.grps.needed*par.in.col
extra.pars <- max.par-npar
tmp.txt <- txt
if(extra.pars > 0) {
for (i in 1:ncols){
tmp.txt[[i]][(npar+1):max.par] <- ""
}
}
xpose.table <- gTree(name="xpose.table")
for( i in 1:ncol.grps.needed) {
range.to.print <-
(1+(i-1)*par.in.col+(start.pt-1)):(i*par.in.col)
## Print out table
wdth.prev.cols <- 0
for (j in 1:ncols){
ystart=ystart
xstart=(i-1)*unit(wdth.tot,"npc")+unit(wdth.prev.cols,"npc")
if (center.table){
xstart = xstart + unit(xtra.space/2,"npc") +
unit((ncol.grps.avail - ncol.grps.needed)*wdth.tot/2,"npc")
}
col.txt <- tmp.txt[[j]]
## add column names
if(!is.null(col.nams)) {
if(!all(col.txt[range.to.print]=="")){
col.txt <- c(col.nams[j],col.txt[range.to.print])
} else {
col.txt <- c(" ",col.txt[range.to.print])
}
}
## add column text
if(space.avail) {
fill.type.tmp <- fill.type
if(!is.null(fill.type)){
if(fill.type=="top") fill.type.tmp <- "firstonly"
if(fill.type=="both"){
fill.type.tmp <- "firstonly"
if(j==1) fill.type.tmp <- "all"
}
}
txt.marker <- add.grid.text(txt=col.txt,
ystart=ystart,
xstart=xstart,
start.pt=1,
vp=list(vp[[k]]),
vp.num=1,
spaces.before=space.before.table,
wdth=wdth[j],
fill.type=fill.type.tmp,
fill.col=fill.col,
cell.lines.lty=cell.lines.lty,
xpose.table=xpose.table,
use.rect=use.rect,
...)
xpose.table <- txt.marker$xpose.table
}
wdth.prev.cols <- wdth.prev.cols+wdth[j]
}
}
if(space.avail) {
ystart <- txt.marker$ystart
stop.pt <- txt.marker$stop.pt
}
if (!is.null(stop.pt)){
start.pt=stop.pt
ystart=unit(1,"npc")
xstart <- unit(0,"npc")
} else{
break
}
}
ret.list <- list(ystart = ystart, # new starting point for new text
stop.pt = stop.pt, # null if everything gets printed
vp.num = vp.num, # the viewport needed for this to work
xpose.table=xpose.table # a grob object
)
return(ret.list)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.