-
Notifications
You must be signed in to change notification settings - Fork 50
/
Copy pathViewer.R
121 lines (108 loc) · 2.99 KB
/
Viewer.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
#' @importFrom utils browseURL
NULL
#' Display an \code{\link{rtable}} object in the Viewer pane in RStudio or in a
#' browser
#'
#' The table will be displayed using the bootstrap styling for tables.
#'
#' @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
#'
#' @return not meaningful. Called for the side effect of opening a browser or viewer pane.
#'
#' @examples
#'
#' if(interactive()) {
#' sl5 <- factor(iris$Sepal.Length > 5, levels = c(TRUE, FALSE),
#' labels = c("S.L > 5", "S.L <= 5"))
#'
#' df <- cbind(iris, sl5 = sl5)
#'
#' lyt <- basic_table() %>%
#' split_cols_by("sl5") %>%
#' analyze("Sepal.Length")
#'
#' tbl <- build_table(lyt, df)
#'
#' 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, ...) {
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, "VTableTree")) {
as_html(x, ...)
} else {
stop("object of class rtable or shiny tag excepted for ", name)
}
}
x_tag <- check_convert(x, "x", FALSE)
y_tag <- check_convert(y, "y", TRUE)
html_output <- if (is.null(y)) {
x_tag
} else {
tags$div(class = "container-fluid", htmltools::tags$div(class = "row",
tags$div(class = "col-xs-6", x_tag),
tags$div(class = "col-xs-6", y_tag)
))
}
sandbox_folder <- file.path(tempdir(), "rtable")
if (!dir.exists(sandbox_folder)) {
dir.create(sandbox_folder, recursive = TRUE)
pbs <- file.path(path.package(package = "rtables"), "bootstrap/")
file.copy(list.files(pbs, full.names = TRUE, recursive = FALSE), sandbox_folder, recursive = TRUE)
# list.files(sandbox_folder)
}
# get html name
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 == n_try) {
stop("too many html rtables created, restart your session")
}
}
html_bs <- tags$html(
lang = "en",
tags$head(
tags$meta(charset = "utf-8"),
tags$meta("http-equiv" = "X-UA-Compatible", content = "IE=edge"),
tags$meta(name = "viewport",
content = "width=device-width, initial-scale=1"),
tags$title("rtable"),
tags$link(href = "css/bootstrap.min.css",
rel = "stylesheet")
),
tags$body(
html_output
)
)
cat(
paste("<!DOCTYPE html>\n", htmltools::doRenderTags(html_bs)),
file = htmlFile, append = FALSE
)
viewer <- getOption("viewer")
if (!is.null(viewer)) {
viewer(htmlFile)
} else {
browseURL(htmlFile)
}
}