Feature formatters

DESCRIPTION

@@ -18,4 +18,5 @@ Imports:
     glue,
     htmlwidgets,
     purrr,
+    readr,
     shiny

NAMESPACE

@@ -9,6 +9,7 @@ export(set_progress_formatter)
 export(set_star_formatter)
 export(set_tick_cross_formatter)
 export(tabulator)
+export(tabulatorContext)
 export(tabulatorOutput)
 export(tabulator_options)
 export(trigger_download)

R/columns.R

@@ -57,16 +57,109 @@ add_filter_to_columns <- function(columns) {
   return(columns)
 }
 
-# Formatters
+# Formatters ####
+
+# Plain Text
+#' @export
+set_plaintext_formatter <- function(widget, column, number_of_stars, hoz_align = "left") {
+  col_update <- list(formatter = "plaintext", hozAlign = hoz_align)
+  modify_col_def(widget, column, col_update)
+}
+
+# Text Area
+#' @export
+set_textarea_formatter <- function(widget, column, hoz_align = "left") {
+  col_update <- list(formatter = "textarea", hozAlign = hoz_align)
+  modify_col_def(widget, column, col_update)
+}
+
+# HTML
+#' @export
+set_html_formatter <- function(widget, column, hoz_align = "left") {
+  col_update <- list(formatter = "html", hozAlign = hoz_align)
+  modify_col_def(widget, column, col_update)
+}
+
+# Money
+#' @export
+set_money_formatter <- function(widget, column, decimal = ",", thousand = ".",
+                                symbol = "£", symbolAfter = "p",
+                                negativeSign = T, precision = F,
+                                hoz_align = "left") {
+  col_update <- list(
+    formatter = "money",
+    formatterParams = list(
+      decimal = decimal,
+      thousand = thousand,
+      symbol = symbol,
+      symbolAfter = symbolAfter,
+      negativeSign = negativeSign,
+      precision = precision
+    ),
+    hozAlign = hoz_align
+  )
+  modify_col_def(widget, column, col_update)
+}
+
+# Image
+#' @export
+set_image_formatter <- function(widget, column, height = "50px", width = "50px",
+                                urlPrefix = "http://website.com/images/",
+                                urlSuffix = ".png", hoz_align = "center") {
+  col_update <- list(
+    formatter = "image",
+    formatterParams = list(
+      height = height,
+      width = width,
+      urlPrefix = urlPrefix,
+      urlSuffix = urlSuffix
+    ),
+    hozAlign = hoz_align
+  )
+  modify_col_def(widget, column, col_update)
+}
+
+# Link
+#' @export
+
+set_link_formatter <- function(widget, column, labelField = "", urlPrefix = "",
+                               target = "_blank", hoz_align = "left") {
+  col_update <- list(
+    formatter = "link",
+    formatterParams = list(
+      labelField = labelField,
+      urlPrefix = urlPrefix,
+      target = target
+    )
+  )
+
+  modify_col_def(widget, column, col_update)
+}
+
+# Star
 #' @export
 set_star_formatter <- function(widget, column, number_of_stars, hoz_align = "center") {
-  col_update <- list(formatter = "star", formatterParams = list(stars = number_of_stars), hozAlign = hoz_align)
+  col_update <- list(
+    formatter = "star",
+    formatterParams = list(stars = number_of_stars),
+    hozAlign = hoz_align
+  )
   modify_col_def(widget, column, col_update)
 }
 
+
+# Progress
 #' @export
-set_progress_formatter <- function(widget, column, hoz_align = "left") {
-  col_update <- list(formatter = "progress", hozAlign = hoz_align)
+set_progress_formatter <- function(widget, column, min = 0, max = 10, color = c("green", "orange", "red"),
+                                   legendColor = "#000000", legendAlign = "center", hoz_align = "left") {
+  col_update <- list(
+    formatter = "progress",
+    formatterParams = list(
+      min = min, max = max, color = color,
+      legendColor = legendColor, legendAlign = legendAlign
+    ),
+    hozAlign = hoz_align
+  )
   modify_col_def(widget, column, col_update)
 }
 
@@ -76,6 +169,7 @@ set_tick_cross_formatter <- function(widget, column) {
   modify_col_def(widget, column, col_update)
 }
 
+
 modify_col_def <- function(widget, column, col_update) {
   for (index in 1:length(widget$x$options$columns)) {
     if (widget$x$options$columns[[index]]$field == column) {

R/tabulator.R

@@ -1,31 +1,47 @@
-#' <Add Title>
-#'
-#' <Add Description>
+#' Create a Tabulator Widget
 #'
+#' @param data (data.frame or list): In spreadsheet mode data needs to be a list or \code{NULL}
+#'  for an empty spreadsheet.
+#' @param options (list): Setup options. See \code{\link{tabulator_options}}.
+#' @param editable (bool): Whether the table is editable.
+#' @param theme (character): Theme to apply to the table.
+#' @param width Width of the widget.
+#' @param height Height of the widget.
+#' @param element_id description
+#' @param ... Named arguments that are appended to the \code{options} parameter.
 #' @import htmlwidgets
-#'
 #' @export
-tabulator <- function(data, options = tabulator_options(),
-                      rtabulator_auto_columns = TRUE,
-                      editable = FALSE,
-                      width = NULL, height = NULL, elementId = NULL, ...) {
+tabulator <- function(
+    data,
+    options = tabulator_options(),
+    rtabulator_auto_columns = TRUE,
+    editable = FALSE,
+    theme = c("default", "midnight", "modern", "simple", "site", "bootstrap3", "bootstrap4", "bootstrap5", "bulma", "materialize", "semanticui"),
+    width = NULL,
+    height = NULL,
+    element_id = NULL,
+    ...) {
   if (is.null(options)) options <- list()
 
   options <- utils::modifyList(options, list(...))
   if (isTRUE(options$spreadsheet)) {
     # ...
   } else {
     data <- fix_colnames(data)
-    if (rtabulator_auto_columns && is.null(options$columns)) {
+    if (getOption("rtabulator.auto_columns", TRUE) && is.null(options$columns)) {
       options$columns <- create_columns(data, editor = editable)
     }
 
     data <- set_auto_id(data)
   }
 
+  theme <- match.arg(theme)
+  stylesheet_text <- ifelse(theme == "default", NA, read_tabulator_theme(theme))
+
   x <- list(
     data = data,
-    options = keys_to_camel_case(compact(options))
+    options = keys_to_camel_case(compact(options)),
+    stylesheetText = stylesheet_text
   )
 
 
@@ -36,7 +52,7 @@ tabulator <- function(data, options = tabulator_options(),
     width = width,
     height = height,
     package = "rtabulator",
-    elementId = elementId
+    elementId = element_id
   )
 }
 

R/tabulator_context.R

@@ -14,6 +14,10 @@ invoke_method <- function(widget, method_name, ...) {
   invisible(widget)
 }
 
+#' Create a Tabulator Context
+#' @param output_id (character): A tabulator output id.
+#' @param session shiny session object
+#' @export
 tabulatorContext <- function(output_id, session = shiny::getDefaultReactiveDomain()) {
   ctx <- list(
     id = output_id,

R/themes.R

@@ -0,0 +1,9 @@
+read_tabulator_theme <- function(
+    theme = c("midnight", "modern", "simple", "site", "bootstrap3", "bootstrap4", "bootstrap5", "bulma", "materialize", "semanticui")) {
+  theme <- match.arg(theme)
+  file_name <- system.file(
+    glue::glue("htmlwidgets/libs/tabulator/tabulator_{theme}.min.css"),
+    package = "rtabulator"
+  )
+  return(readr::read_file(file_name))
+}

inst/htmlwidgets/libs/tabulator/get-themes.sh

@@ -0,0 +1,10 @@
+version=6.2.5
+for base_theme in midnight modern simple site; do
+  echo $base_theme
+  curl -O https://unpkg.com/tabulator-tables@${version}/dist/css/tabulator_${base_theme}.min.css
+done
+
+for framework_theme in bootstrap3 bootstrap4 bootstrap5 bulma materialize semanticui; do
+  echo $framework_theme
+  curl -O https://unpkg.com/tabulator-tables@${version}/dist/css/tabulator_${framework_theme}.min.css
+done

inst/htmlwidgets/rtabulator.js

@@ -80,6 +80,12 @@
     let table = null;
     function renderValue(payload) {
       console.log(payload);
+      if (payload.stylesheetText) {
+        document.head.insertAdjacentHTML(
+          "beforeend",
+          `<style>${payload.stylesheetText}</style>`
+        );
+      }
       if (payload.options === null) {
         payload.options = {};
       }