Merge pull request #19 from Roche/devel

release v0.1.1

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: rtables
 Title: Reporting Tables
-Version: 0.1.0.6
+Version: 0.1.1
 Authors@R: c(
   person("Adrian", "Waddell", email = "[email protected]", role = c("aut", "cre"))
   )
@@ -18,7 +18,7 @@ Suggests:
 License: Apache License 2.0 | file LICENSE
 Encoding: UTF-8
 LazyData: true
-RoxygenNote: 6.1.0
+RoxygenNote: 6.1.1
 VignetteBuilder: knitr
 URL: https://github.com/roche/rtables, https://roche.github.io/rtables/
 BugReports: https://github.com/roche/rtables/issues

NAMESPACE

@@ -10,6 +10,7 @@ S3method(as_html,rrow)
 S3method(as_html,rtable)
 S3method(dim,rheader)
 S3method(dim,rtable)
+S3method(levels,no_by)
 S3method(names,rtable)
 S3method(print,rcell)
 S3method(print,rrow)
@@ -23,24 +24,31 @@ S3method(rtabulate,factor)
 S3method(rtabulate,logical)
 S3method(rtabulate,numeric)
 S3method(toString,rtable)
+S3method(unlist,rtable)
 export("header<-")
 export(Viewer)
 export(as.rtable)
 export(as_html)
 export(compare_rtables)
 export(format_rcell)
 export(header)
+export(header_add_N)
 export(indented_row.names)
 export(is.no_by)
 export(list_rcell_format_labels)
 export(no_by)
+export(order_rrows)
+export(order_rtables)
+export(rbindl_rtables)
 export(rcell)
 export(rheader)
 export(rrow)
 export(rrowl)
 export(rtable)
 export(rtablel)
 export(rtabulate)
+export(sort_rrows)
+export(sort_rtables)
 export(sprintf_format)
 importFrom(htmltools,tagList)
 importFrom(htmltools,tags)

NEWS.md

@@ -1,16 +1,24 @@
 
-## rtable 0.1.0.6
+
+## rtables 0.1.1
+
+* `rtablulate` family of functions do not support the `row_*_data_args` arguments anymore. Instead, the `col_wise_args` argument is introduced.
+* add functions `order_rrows`, `sort_rrows`, `order_rtables`, and `sort_rtables` are introduced.
+* prevent `rtables` from being unlisted with `unlist.rtables`
+
+
+## rtables 0.1.0.6
 
 * `Viewer` now also accepts objects of class `shiny.tag` (defined in package `htmltools`)
 * `as.html` accepts `class.table`, `class.tr`, `class.th`, and `class.td` as an argument
 
-## rtable 0.1.0.5
+## rtables 0.1.0.5
 
 * added `sprintf_format` for formatting rcells (thanks to Doug Kelkhoff for the suggestion)
 * added `"(N=xx)"` and `">999.9"` format labels
-* `rtabulate` has now an argument `col_total` and shows by default the numbers of elements associated with a column
+* `rtabulate` has now an argument `col_N` and the function `col_N()`
 
-## rtable 0.1.0
+## rtables 0.1.0
 
 Version `0.1.0` is a major re-design with lots of internal refactoring and the
 following API changes:
@@ -37,6 +45,6 @@ single `rrow`  and by setting `row.name` to `NULL`.
 * `indented_row.names` function added
 
 
-## rtable 0.0.1
+## rtables 0.0.1
 
 * Initial public release

R/accessors_modifiers.R

@@ -243,62 +243,3 @@ set_rrow_attrs <- function(rrow, row.name, indent) {
   rrow
 }
 
-#' stack rtable objects 
-#' 
-#' @param ... \code{\link{rtable}} objects
-#' 
-#' @return an \code{\link{rtable}} object
-#' 
-#' @export
-#' 
-#' @examples 
-#' 
-#' mtbl <- rtable(
-#'   header = rheader(
-#'     rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan=2)),
-#'     rrow(NULL, "mean", "median", "mean", "median")
-#'   ),
-#'   rrow(
-#'     row.name = "All Species",
-#'     mean(iris$Sepal.Length), median(iris$Sepal.Length),
-#'     mean(iris$Petal.Length), median(iris$Petal.Length),
-#'     format = "xx.xx"
-#'   )
-#' )
-#' 
-#' mtbl2 <- with(subset(iris, Species == 'setosa'), rtable(
-#'   header = rheader(
-#'     rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan=2)),
-#'     rrow(NULL, "mean", "median", "mean", "median")
-#'   ),
-#'   rrow(
-#'     row.name = "Setosa",
-#'     mean(Sepal.Length), median(Sepal.Length),
-#'     mean(Petal.Length), median(Petal.Length),
-#'     format = "xx.xx"
-#'   )
-#' ))
-#' 
-#' tbl <- rbind(mtbl, mtbl2)
-#' 
-#' tbl
-#' 
-rbind.rtable <- function(...) {
-
-  dots <- Filter(Negate(is.null), list(...))
-
-  if (!are(dots, "rtable")) stop("not all elements are of type rtable")
-
-  headers <- lapply(dots, header)
-  ref_header <- headers[[1]]
-
-  same_headers <- vapply(headers[-1], function(h) {
-    identical(h, ref_header)
-  }, logical(1))
-
-  if (!all(same_headers)) stop("not all rtables have the same header")
-
-  body <- unlist(dots, recursive = FALSE)
-
-  rtablel(header = ref_header, body)
-}

R/as_html.R

@@ -44,14 +44,13 @@ as_html.default <- function(x, ...) {
   stop("no as_html method for class ", class(x))
 }
 
-# Convert an rtable object to html
-# 
-# @param x an object of class \code{\link{rtable}}
-# @param class.table class attributes for the table in html
-# @param ... arguments passed on to methods
-# 
-# @return an object of class \code{shinyTag}
-
+#' Convert an rtable object to html
+#' 
+#' @inheritParams as_html
+#' @param class.table class attributes for \code{<table>} html object
+#' 
+#' @return an object of class \code{shinyTag}
+#' 
 #' @export
 as_html.rtable <- function(x, class.table = "table table-condensed table-hover",
                            ...) {

R/header_add_N.R

@@ -0,0 +1,34 @@
+
+#' Add N=xx to header
+#' 
+#' Helper function used to add the population total (N) in the 
+#' column header of \code{\link{rtable}} object.
+#' 
+#' @param x \code{rtable}
+#' @param N vector with counts to be displayed in the header. The
+#'   length must match the number of columns in \code{x}
+#'   
+#' @export
+#' 
+#' @examples 
+#' 
+#' tbl <- rtable(
+#'  header = letters[1:3],
+#'  rrow("X", 1, 2, 3),
+#'  rrow("Y", 4, 5, 6)
+#' )
+#' 
+#' tbl
+#' 
+#' header_add_N(tbl, 1:3)
+#' 
+header_add_N <- function(x, N) {
+  is(x, "rtable") || stop("x is expected to be an rtable")
+  length(N) == ncol(x) || stop("dimension missmatch")
+
+  header(x) <- rheader(
+    header(x)[[1]],
+    rrowl("", N, format = "(N=xx)")
+  )
+  x
+}

R/rbind.R

@@ -0,0 +1,104 @@
+#' Stack rtable objects 
+#' 
+#' Note that the columns order are not mached by the header: the first table
+#' header is taken as the reference.
+#' 
+#' @param ... \code{\link{rtable}} objects
+#' @param gap number of empty rows to add between tables
+#' 
+#' @return an \code{\link{rtable}} object
+#' 
+#' @export
+#' 
+#' @examples 
+#' 
+#' mtbl <- rtable(
+#'   header = rheader(
+#'     rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan=2)),
+#'     rrow(NULL, "mean", "median", "mean", "median")
+#'   ),
+#'   rrow(
+#'     row.name = "All Species",
+#'     mean(iris$Sepal.Length), median(iris$Sepal.Length),
+#'     mean(iris$Petal.Length), median(iris$Petal.Length),
+#'     format = "xx.xx"
+#'   )
+#' )
+#' 
+#' mtbl2 <- with(subset(iris, Species == 'setosa'), rtable(
+#'   header = rheader(
+#'     rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan=2)),
+#'     rrow(NULL, "mean", "median", "mean", "median")
+#'   ),
+#'   rrow(
+#'     row.name = "Setosa",
+#'     mean(Sepal.Length), median(Sepal.Length),
+#'     mean(Petal.Length), median(Petal.Length),
+#'     format = "xx.xx"
+#'   )
+#' ))
+#' 
+#' tbl <- rbind(mtbl, mtbl2)
+#' tbl
+#' 
+#' tbl <- rbind(mtbl, mtbl2, gap = 1)
+#' tbl 
+#' 
+#' tbl <- rbind(mtbl, mtbl2, gap = 2)
+#' tbl 
+#' 
+rbind.rtable <- function(..., gap = 0) {
+  dots <- Filter(Negate(is.null), list(...))
+  rbindl_rtables(dots, gap = gap)
+}
+
+#' Stack a list of rtables
+#' 
+#' See \code{\link{rbind.rtable}} for details
+#' 
+#' @param x a list of rtable objects
+#' @inheritParams rbind.rtable
+#' 
+#' @export
+#' 
+rbindl_rtables <- function(x, gap = 0) {
+
+  stopifnot(is.list(x))
+  stopifnot(are(x, "rtable"))
+  stopifnot(length(x) > 0)
+  stopifnot(is.numeric(gap), gap >= 0)
+
+  if (!num_all_equal(vapply(x, ncol, numeric(1))))
+    stop("non-matching number of columns between tables")
+
+  tbl <- if (gap != 0) {
+    gap_rows <- replicate(gap, rrow(), simplify = FALSE)
+    Reduce(function(tbl1, tbl2) c(tbl1, gap_rows, tbl2), x)
+  } else {
+    unlist(x, recursive = FALSE)
+  }
+
+  ref_header <- header(x[[1]])  
+  class(tbl) <- "rtable"
+  attr(tbl, "header") <- ref_header
+  attr(tbl, "nrow") <- length(tbl)
+  attr(tbl, "ncol") <- ncol(ref_header)
+
+  tbl
+}  
+
+
+#' Unlist method for rtables
+#'
+#' rtable objects should not be unlisted. This allows us to create nested lists with rtables objects and then flatten
+#' them to a list of rtable objects.
+#'
+#' @inheritParams base::unlist
+#'
+#' @return rtable object
+#'
+#' @method unlist rtable
+#' @export
+unlist.rtable <- function(x, recursive = TRUE, use.names = TRUE) {
+  x
+}