Nothing
# Automatically generated from the noweb directory
print.pyears <- function(x, ...) {
if (!is.null(cl<- x$call)) {
cat("Call:\n")
dput(cl)
cat("\n")
}
if (is.null(x$data)) {
if (!is.null(x$event))
cat("Total number of events:", format(sum(x$event)), "\n")
cat ( "Total number of person-years tabulated:",
format(sum(x$pyears)),
"\nTotal number of person-years off table:",
format(x$offtable), "\n")
}
else {
if (!is.null(x$data$event))
cat("Total number of events:", format(sum(x$data$event)), "\n")
cat ( "Total number of person-years tabulated:",
format(sum(x$data$pyears)),
"\nTotal number of person-years off table:",
format(x$offtable), "\n")
}
if (!is.null(x$summary)) {
cat("Matches to the chosen rate table:\n ",
x$summary)
}
cat("Observations in the data set:", x$observations, "\n")
if (!is.null(x$na.action))
cat(" (", naprint(x$na.action), ")\n", sep='')
cat("\n")
invisible(x)
}
summary.pyears <- function(object, header=TRUE, call=header,
n= TRUE, event=TRUE, pyears=TRUE,
expected = TRUE, rate = FALSE, rr = expected,
ci.r = FALSE, ci.rr = FALSE, totals=FALSE,
legend=TRUE, vline = FALSE, vertical = TRUE,
nastring=".", conf.level=0.95,
scale= 1, ...) {
# Usual checks
if (!inherits(object, "pyears"))
stop("input must be a pyears object")
temp <- c(is.logical(header), is.logical(call), is.logical(n),
is.logical(event) , is.logical(pyears), is.logical(expected),
is.logical(rate), is.logical(ci.r), is.logical(rr),
is.logical(ci.rr), is.logical(vline), is.logical(vertical),
is.logical(legend), is.logical(totals))
tname <- c("header", "call", "n", "event", "pyears", "expected",
"rate", "ci.r", "rr", "ci.rr", "vline", "vertical",
"legend", "totals")
if (any(!temp) || length(temp) != 14 || any(is.na(temp))) {
stop("the ", paste(tname[!temp], collapse=", "),
"argument(s) must be single logical values")
}
if (!is.numeric(conf.level) || conf.level <=0 || conf.level >=1 |
length(conf.level) > 1 || is.na(conf.level) > 1)
stop("conf.level must be a single numeric between 0 and 1")
if (is.na(scale) || !is.numeric(scale) || length(scale) !=1 || scale <=0)
stop("scale must be a value > 0")
vname <- attr(terms(object), "term.labels") #variable names
if (!is.null(object$data)) {
# Extra work: restore the tables which had been unpacked into a df
# All of the categories are factors in this case
tdata <- object$data[vname] # the conditioning variables
dname <- lapply(tdata, function(x) {
if (is.factor(x)) levels(x) else sort(unique(x))}) # dimnames
dd <- sapply(dname, length) # dim of arrays
index <- tapply(tdata[,1], tdata)
restore <- c('n', 'event', 'pyears', 'expected') #do these, if present
restore <- restore[restore %in% names(object$data)]
new <- lapply(object$data[restore],
function(x) {
temp <- array(0L, dim=dd, dimnames=dname)
temp[index] <- x
temp} )
object <- c(object, new)
}
if (is.null(object$expected)) {
expected <- FALSE
rr <- FALSE
ci.rr <- FALSE
}
if (is.null(object$event)) {
event <- FALSE
rate <- FALSE
ci.r <- FALSE
rr <- FALSE
ci.rr <- FALSE
}
# print out the front matter
if (call && !is.null(object$call)) {
cat("Call: ")
dput(object$call)
cat("\n")
}
if (header) {
cat("number of observations =", object$observations)
if (length(object$omit))
cat(" (", naprint(object$omit), ")\n", sep="")
else cat("\n")
if (object$offtable > 0)
cat(" Total time lost (off table)", format(object$offtable), "\n")
cat("\n")
}
# Add in totals if requested
if (totals) {
# if the pyear object was based on any time dependent cuts, then
# the "n" component cannot be totaled up.
tcut <- if (is.null(object$tcut)) TRUE else object$tcut
object$n <- pytot(object$n, na=tcut)
object$pyears <- pytot(object$pyears)
if (event) object$event <- pytot(object$event)
if (expected) object$expected <- pytot(object$expected)
}
dd <- dim(object$n)
vname <- attr(terms(object), "term.labels") #variable names
# Put the elements to be printed onto a list
pname <- (tname[3:6])[c(n, event, pyears, expected)]
plist <- object[pname]
if (rate) {
pname <- c(pname, "rate")
plist$r <- scale* object$event/object$pyears
}
if (ci.r) {
pname <- c(pname, "ci.r")
plist$ci.r <- cipoisson(object$event, object$pyears, p=conf.level) *scale
}
if (rr) {
pname <- c(pname, "rr")
plist$rr <- object$event/object$expected
}
if (ci.rr) {
pname <- c(pname, "ci.rr")
plist$ci.rr <- cipoisson(object$event, object$expected, p=conf.level)
}
rname <- c(n = "N", event="Events",
pyears= "Time", expected= "Expected events",
rate = "Event rate", ci.r = "CI (rate)",
rr= "Obs/Exp", ci.rr= "CI (O/E)")
rname <- rname[pname]
if (length(dd) ==1) {
# 1 dimensional table
cname <- names(object$n) #category names
if (vertical) {
# The person-years objects list across the top, categories up and down
# This makes columns line up in a standard "R" way
# The first column label is the variable name, content is the categories
plist <- lapply(plist, pformat, nastring, ...) # make it character
pcol <- sapply(plist, function(x) nchar(x[1])) #width of each one
colwidth <- pmax(pcol, nchar(rname)) +2
for (i in 1:length(plist))
plist[[i]] <- strpad(plist[[i]], colwidth[i])
colwidth <- c(max(nchar(vname), nchar(cname)) +2, colwidth)
leftcol <- list(strpad(cname, colwidth[1]))
header <- strpad(c(vname, rname), colwidth)
}
else {
# in this case each column will have different types of objects in it
# alignment is the nuisance
newmat <- pybox(plist, length(plist[[1]]), nastring, ...)
colwidth <- pmax(nchar(cname), apply(nchar(newmat), 1, max)) +2
# turn the list sideways
plist <- split(newmat, row(newmat))
for (i in 1:length(plist))
plist[[i]] <- strpad(plist[[i]], colwidth[i])
colwidth <- c(max(nchar(vname), nchar(rname)) +2, colwidth)
leftcol <- list(strpad(rname, colwidth[1]))
header <- strpad(c(vname, cname), colwidth)
}
# Now print it
if (vline) { # use a pipe table
cat(paste(header, collapse = "|"), "\n")
cat(paste(strpad("-", colwidth, "-"), collapse="|"), "\n")
temp <- do.call("paste", c(leftcol, plist, list(sep ="|")))
cat(temp, sep= '\n')
}
else {
cat(paste(header, collapse = " "), "\n")
cat(paste(strpad("-", colwidth, "-"), collapse=" "), "\n")
temp <- do.call("paste", c(leftcol, plist, list(sep =" ")))
cat(temp, sep='\n')
}
} else {
# more than 1 dimension
if (header) {
# the header is itself a table
width <- max(nchar(rname))
if (vline) {
cat('+', strpad('-', width, '-'), "+\n", sep="")
cat(paste0('|',strpad(rname, width), '|'), sep='\n')
cat('+', strpad('-', width, '-'), "+\n\n", sep="")
} else {
cat(strpad('-', width, '-'), "\n")
cat(strpad(rname, width), sep='\n')
cat(strpad('-', width, '-'), "\n\n")
}
}
tname <- vname[1:2] #names for the row and col
rowname <- dimnames(object$n)[[1]]
colname <- dimnames(object$n)[[2]]
if (length(dd) > 2)
newmat <- pybox(plist, c(dd[1],dd[2], prod(dd[-(1:2)])),
nastring, ...)
else newmat <- pybox(plist, dd, nastring, ...)
if (length(dd) > 2) {
newmat <- pybox(plist, c(dd[1],dd[2], prod(dd[-(1:2)])),
nastring, ...)
outer.label <- do.call("expand.grid", dimnames(object$n)[-(1:2)])
temp <- names(outer.label)
for (i in 1:nrow(outer.label)) {
# first the caption, then data
cat(paste(":", paste(temp, outer.label[i,], sep="=")), '\n')
pyshow(newmat[,,i,], tname, rowname, colname, vline)
}
}
else {
newmat <- pybox(plist, dd, nastring, ...)
pyshow(newmat, tname, rowname, colname, vline)
}
}
invisible(object)
}
strpad <- function(x, width, pad=' ') {
# x = the string(s) to be padded out
# width = width of desired string.
nc <- nchar(x)
added <- width - nc
left <- pmax(0, floor(added/2)) # can't add negative space
right <- pmax(0, width - (nc + left)) # right will be >= left
if (all(right <=0)) {
if (length(x) >= length(width)) x # nothing needs to be done
else rep(x, length=length(width))
}
else {
# Each pad could be a different length.
# Make a long string from which we can take a portion
longpad <- paste(rep(pad, max(right)), collapse='')
paste0(substring(longpad, 1, left), x, substring(longpad,1, right))
}
}
pformat <- function(x, nastring, ...) {
# This is only called for single index tables, in vertical mode
# Any matrix will be a confidence interval
if (is.matrix(x))
ret <- paste(ifelse(is.na(x[,1]), nastring,
format(x[,1], ...)), "-",
ifelse(is.na(x[,2]), nastring,
format(x[,2], ...)))
else ret <- ifelse(is.na(x), nastring, format(x, ...))
}
pybox <- function(plist, dd, nastring, ...) {
ci <- (substring(names(plist), 1,3) == "ci.") # the CI components
int <- sapply(plist, function(x) all(x == floor(x) | is.na(x)))
int <- (!ci & int)
real<- (!ci & !int)
nc <- prod(dd)
final <- matrix("", nrow=nc, ncol=length(ci))
if (any(int)) { # integers
if (any(sapply(plist[int], length) != nc))
stop("programming length error, notify package author")
temp <- unlist(plist[int])
final[,int] <- ifelse(is.na(temp), nastring, format(temp))
}
if (any(real)) { # floating point
if (any(sapply(plist[real], length) != nc))
stop("programming length error, notify package author")
temp <- unlist(plist[real])
final[,real] <- ifelse(is.na(temp), nastring,
format(temp, ...))
}
if (any(ci)) {
if (any(sapply(plist[ci], length) != nc*2))
stop("programming length error, notify package author")
temp <- unlist(plist[ci])
temp <- array(ifelse(is.na(temp), nastring,
format(temp, ...)),
dim=c(nc, 2, sum(ci)))
final[,ci] <- paste(temp[,1,], temp[,2,], sep='-')
}
array(final, dim=c(dd, length(ci)))
}
pyshow <- function(dmat, labels, rowname, colname, vline) {
# Every column is the same width, except the first
colwidth <- c(max(nchar(rowname), nchar(labels[1])),
rep(max(nchar(dmat[1,1,]), nchar(colname)), length(colname)))
colwidth[2] <- max(colwidth[2], nchar(labels[2]))
ncol <- length(colwidth)
dd <- dim(dmat) # vector of length 3, third dim is the statistics
rline <- ceiling(dd[3]/2) #which line to put the row label on.
if (vline) { # use a grid table
cat("+", paste(strpad('-', colwidth, pad='-'), collapse='+'), "+\n",
sep='')
temp <- rep(' ', ncol); temp[2] <- labels[2]
cat("|", paste(strpad(temp, colwidth), collapse="|"), "|\n",
sep='')
cat("|", paste(strpad(c(labels[1], colname), colwidth), collapse="|"),
"|\n", sep='')
cat("+", paste(strpad('=', colwidth, pad='='), collapse="+"), "+\n",
sep='')
for (i in 1:dd[1]) {
for (j in 1:dd[3]) { #one printout line per stat
if (j==rline) temp <- c(rowname[i], dmat[i,,j])
else temp <- c("", dmat[i,,j])
cat("|", paste(strpad(temp, colwidth), collapse='|'), "|\n",
sep='')
}
cat("+", paste(strpad('-', colwidth, '-'), collapse='+'), "+\n",
sep='')
}
}
else { # use a multiline table
cat(paste(strpad('-', colwidth, '-'), collapse='-'), "\n")
temp <- rep(' ', ncol); temp[2] <- labels[2]
cat(paste(strpad(temp, colwidth), collapse=" "), "\n")
cat(paste(strpad(c(labels[1], colname), colwidth), collapse=" "),
"\n")
cat(paste(strpad('-', colwidth, pad='-'), collapse=" "), "\n")
for (i in 1:dd[1]) {
for (j in 1:dd[3]) { #one printout line per stat
if (j==rline) temp <- c(rowname[i], dmat[i,,j])
else temp <- c("", dmat[i,,j])
cat(paste(strpad(temp, colwidth), collapse=' '), "\n")
}
if (i< dd[1]) cat(" \n") #blank line
}
cat(paste(strpad('-', colwidth, '-'), collapse='-'), "\n")
}
}
pytot <- function(x, na=FALSE) {
dd <- dim(x)
if (length(dd) ==1) {
if (na) array(c(x, NA), dim= length(x) +1,
dimnames=list(c(dimnames(x)[[1]], "Total")))
else array(c(x, sum(x)), dim= length(x) +1,
dimnames=list(c(dimnames(x)[[1]], "Total")))
}
else if (length(dd) ==2) {
if (na) new <- rbind(cbind(x, NA), NA)
else {
new <- rbind(x, colSums(x))
new <- cbind(new, rowSums(new))
}
array(new, dim=dim(x) + c(1,1),
dimnames=list(c(dimnames(x)[[1]], "Total"),
c(dimnames(x)[[2]], "Total")))
}
else {
# The general case
index <- 1:length(dd)
if (na) sum1 <- sum2 <- sum3 <- NA
else {
sum1 <- apply(x, index[-1], sum) # row sums
sum2 <- apply(x, index[-2], sum) # col sums
sum3 <- apply(x, index[-(1:2)], sum) # total sums
}
# create a new matrix and then fill it in
d2 <- dd
d2[1:2] <- dd[1:2] +1
dname <- dimnames(x)
dname[[1]] <- c(dname[[1]], "Total")
dname[[2]] <- c(dname[[2]], "Total")
new <- array(x[1], dim=d2, dimnames=dname)
# say dim(x) =(5,8,4); we want new[6,-9,] <- sum1; new[-6,9,] <- sum2
# and new[6,9,] <- sum3
# if dim is longer, we need to add more commas
commas <- rep(',', length(dd) -2)
eval(parse(text=paste("new[1:dd[1], 1:dd[2]", commas, "] <- x")))
eval(parse(text=paste("new[ d2[1],-d2[2]", commas, "] <- sum1")))
eval(parse(text=paste("new[-d2[1], d2[2]", commas, "] <- sum2")))
eval(parse(text=paste("new[ d2[1], d2[2]", commas, "] <- sum3")))
new
}
}
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.