Nothing
# tangram a general purpose table toolkit for R
# Copyright (C) 2017-2018 Shawn Garbett
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU 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 General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
#' Create a NEJM style range
#'
#' Construct a cell which has the range of the given data in NEJM style
#'
#' @param x numeric vector whose range is desired
#' @param format numeric or character; an argument to pass to the formatting function
#' @param ... additional arguments to passed to cell()
nejm_range <- function(x, format, ...)
{
if(is.na(format) || is.null(format)) format <- format_guess(x)
if(sum(!is.na(x)) == 0) return(cell("\u2014", ...))
if(is.infinite(min(x, na.rm=TRUE))) return(cell("\u2014", ...))
cell(paste0(render_f(min(x,na.rm=TRUE),format), "\u2014", render_f(max(x, na.rm=TRUE), format)), ...)
}
#' Create an cell_fraction (S3) in NEJM style of the given data
#'
#' A cell object contains a statistical result of a fraction/percentage in nejm style
#'
#' @param numerator numeric; The value of the numerator
#' @param denominator numeric; The value of the denominator
#' @param format numeric or character; a string formatting directive
#' @param ... optional extra information to attach
#' @return A cell_fraction object.
#' @export
#' @examples
#' nejm_fraction(1, 4, 3)
nejm_fraction <- function(numerator, denominator, format=NULL, ...)
{
#format <- if(inherits(format,"numeric")) format - 2 else format
percent <- 100*numerator/denominator
if(is.na(format) || is.null(format)) format <- format_guess(percent)
percent <- render_f(percent, format)
cell(paste0(str_pad(numerator, nchar(as.character(denominator))),
"/",
denominator,
" (",
percent,
")"), ...)
}
#' Create a interquartile range cell object of the given data NEJM style
#'
#' Construct a cell which has the 3 interquartile ranges specified.
#'
#' @param x numeric vector whose sample quantiles are wanted. NA and NaN values are not allowed in numeric vectors unless na.rm is TRUE.
#' @param format numeric or character; Significant digits or fmt to pass to sprintf
#' @param na.rm logical; if true, any NA and NaN's are removed from x before the quantiles are computed.
#' @param names logical; if true, the result has a names attribute. Set to FALSE for speedup with many probs.
#' @param type integer; specify algorithm to use in constructing quantile. See quantile for more information.
#' @param msd logical; compute an msd attribute containing mean and standard deviation
#' @param quant numeric; The quantiles to display. Should be an odd length vector, since the center value is highlighted.
#' @param ... additional arguments to constructing cell
#'
#' @return A cell_quantile object.
#' @export
#' @importFrom stats quantile
#' @importFrom stats sd
#' @examples
#' require(stats)
#' nejm_iqr(rnorm(100), '3')
nejm_iqr <- function(x,
format = NA,
na.rm = TRUE,
names = FALSE,
type = 8,
msd = FALSE,
quant = c(0.25, 0.50, 0.75),
...
)
{
if(!is.null(quant) && length(quant) %% 2 == 0)
stop("hmisc_iqr quant argument must be an odd length")
if(is.null(quant)) ql <- "" else
{
m <- median(1:length(quant))
y <- quantile(x, quant, na.rm, names, type)
if(is.na(format)) format <- format_guess(y)
ql <- "\u2014"
if(sum(!is.na(y)) > 0)
{
ql <- sapply(y, function(x) render_f(x, format))
ql <- paste0(ql[m], " (",
paste0(ql[1:(m-1)], collapse="\u2014"),
"\u2014",
paste0(ql[(m+1):length(quant)], collapse="\u2014"),
")")
}
}
if(msd) ql <- paste0(ql, "\u00A0\u00A0",
render_f(mean(x, na.rm=TRUE), format),
"\u00b1",
render_f(sd(x, na.rm=TRUE), format)
)
cell(ql, ...)
}
#' Cell Generation functions for nejm default
#'
#' Each function here is called when a cell is generated. Overriding these in a formula call will allows
#' one to customize exactly how each cell's contents are generated.
#'
#' While this serves as the base template for transforms, it is by no means required if one develops their
#' own bundle of data transforms. One can create ay number of cell level styling choices.
#'
#' @include cell-hmisc.R
#' @keywords data
#' @export
nejm_cell <- list(
n = cell_n,
range = nejm_range,
iqr = nejm_iqr,
fraction = nejm_fraction,
fstat = hmisc_fstat,
chi2 = hmisc_chi2,
spearman = hmisc_spearman,
wilcox = hmisc_wilcox,
p = hmisc_p
)
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.