as per #12, Viewer accepts objects of class shiny.tag and as_html acc…

…epts arguments class.table, class.tr, class.th, and class.td

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: rtables
 Title: Reporting Tables
-Version: 0.1.0.5
+Version: 0.1.0.6
 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.0.1
+RoxygenNote: 6.1.0
 VignetteBuilder: knitr
 URL: https://github.com/roche/rtables, https://roche.github.io/rtables/
 BugReports: https://github.com/roche/rtables/issues

NEWS.md

@@ -1,4 +1,9 @@
 
+## rtable 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
 
 * added `sprintf_format` for formatting rcells (thanks to Doug Kelkhoff for the suggestion)

R/Viewer.R

@@ -3,31 +3,64 @@
 #' 
 #' The table will be displayed using the bootstrap styling for tables.
 #' 
-#' @inheritParams dim.rtable
-#' @param y optional second rtable object
+#' @param x object of class \code{rtable} or \code{shiny.tag} (defined in \code{htmltools})
+#' @param y optional second argument of same type as \code{x}
 #' @param row.names.bold row.names.bold boolean, make rownames bold
+#' @param ... arguments passed to \code{as_html}
 #' 
 #' 
 #' @export
-Viewer <- function(x, y = NULL, row.names.bold = FALSE) {
+#' 
+#' 
+#' @examples 
+#' 
+#' \dontrun{
+#' sl5 <- factor(iris$Sepal.Length > 5, levels = c(TRUE, FALSE),
+#'    labels = c("S.L > 5", "S.L <= 5"))
+#' 
+#' tbl <- rtabulate(iris$Species, col_by=sl5)
+#' 
+#' Viewer(tbl)
+#' Viewer(tbl, tbl)
+#' 
+#' 
+#' tbl2 <-htmltools::tags$div(
+#'   class = "table-responsive",
+#'   as_html(tbl, class.table = "table")
+#' )
+#' 
+#' Viewer(tbl, tbl2)
+#' 
+#' }
+Viewer <- function(x, y = NULL, row.names.bold = FALSE, ...) {
 
-  if (!is(x, "rtable")) stop("x is expected to be an rtable")
-  if (!is.null(y) && !is(y, "rtable")) stop("y is expected to be an rtable if specified")
+  check_convert <- function(x, name, accept_NULL = FALSE) {
+    if (accept_NULL && is.null(x)) {
+      NULL
+    } else if (is(x, "shiny.tag")) {
+      x
+    } else if (is(x, "rtable")) {
+      as_html(x, ...)
+    } else {
+      stop("object of class rtable or shiny tag excepted for ", name)
+    }
+  }
 
-  viewer <- getOption("viewer")
+  x_tag <- check_convert(x, "x", FALSE)
+  y_tag <- check_convert(y, "y", TRUE)
 
-  tbl_html <- if (is.null(y)) {
-    as_html(x)
+  html_output <- if (is.null(y)) {
+    x_tag
   } else {
     htmltools::tags$div(
       class = ".container-fluid",
       htmltools::tags$div(
         class= "col-xs-6",
-        as_html(x)
+        x_tag
       ),
       htmltools::tags$div(
         class= "col-xs-6",
-        as_html(y)
+        y_tag
       )
     )
   }
@@ -42,12 +75,13 @@ Viewer <- function(x, y = NULL, row.names.bold = FALSE) {
   }
 
   # get html name
-  for (i in 1:10000) {
+  n_try <- 10000
+  for (i in seq_len(n_try)) {
     htmlFile <- file.path(sandbox_folder, paste0("table", i, ".html"))
 
     if (!file.exists(htmlFile)) {
       break
-    } else if (i == 10000) {
+    } else if (i == n_try) {
       stop("too many html rtables created, restart your session")
     }
   }
@@ -62,7 +96,7 @@ Viewer <- function(x, y = NULL, row.names.bold = FALSE) {
       tags$link(href="css/bootstrap.min.css", rel="stylesheet")
     ),
     tags$body(
-      tbl_html
+      html_output
     )
   )
 
@@ -71,7 +105,6 @@ Viewer <- function(x, y = NULL, row.names.bold = FALSE) {
     file = htmlFile, append = FALSE
   )
 
-
   viewer <- getOption("viewer")
 
   if (!is.null(viewer)) {

R/as_html.R

@@ -23,6 +23,10 @@
 #' 
 #' as_html(tbl)
 #' 
+#' as_html(tbl, class.table = "table", class.tr = "row")
+#' 
+#' as_html(tbl, class.td = "aaa")
+#' 
 as_html <- function(x, ...) {
   UseMethod("as_html", x)  
 }
@@ -43,38 +47,42 @@ as_html.default <- function(x, ...) {
 # Convert an rtable object to html
 # 
 # @param x an object of class \code{\link{rtable}}
-# @param class class attributes for the table in html
-# @param ... arguments passed on to \code{shiny::tags$table}
+# @param class.table class attributes for the table in html
+# @param ... arguments passed on to methods
 # 
 # @return an object of class \code{shinyTag}
 
 #' @export
-as_html.rtable <- function(x, class = "table table-condensed table-hover",
-                           body_cell_class = NULL,
-                           header_cell_class = NULL,
+as_html.rtable <- function(x, class.table = "table table-condensed table-hover",
                            ...) {
 
   ncol <- ncol(x)
 
   header <- attr(x, "header")
   body <- x
-
-
 
   tags$table(
-    class = class,
-  #  tags$tr(tagList(tags$th(""), lapply(col_headers, tags$th, align="center", class="text-center"))), 
-    lapply(header, as_html, ncol = ncol, cell_tag = tags$th, ...),
-    lapply(x, as_html, ncol = ncol, ...)
+    class = class.table,
+    lapply(header, as_html, ncol = ncol, is_header = TRUE, ...),
+    lapply(body, as_html, ncol = ncol, is_header = FALSE, ...)
   )
 
 }
 
 #' @export
-as_html.rrow <- function(x, ncol, cell_tag = tags$td, ...) {
+as_html.rrow <- function(x, ncol, is_header, 
+                         class.tr = NULL, class.td = NULL, class.th = NULL, ...) {
+
+  (is.logical(is_header) && length(is_header) == 1) || stop("is_header is supposed to be a boolean")
+
+  cell_tag <- if (is_header) {
+    function(...) tags$th(class = class.th, ...)
+  } else {
+    function(...) tags$td(class = class.td, ...)
+  }
 
   indent <- attr(x, "indent")
-  row.name <- attr(x,"row.name")
+  row.name <- attr(x, "row.name")
 
   cells <- if (length(x) == 0) {
     cell_tag(row.name, class=paste("rowname", "text-left"), colspan = as.character(ncol+1))
@@ -105,5 +113,5 @@ as_html.rrow <- function(x, ncol, cell_tag = tags$td, ...) {
     }
   }
 
-  tags$tr(cells)
+  tags$tr(cells, class = class.tr)
 }