release 0.5.1

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: visOmopResults
 Title: Graphs and Tables for OMOP Results
-Version: 0.5.0
+Version: 0.5.1999
 Authors@R: c(
     person(
         "Martí", "Català", , "marti.catalasabate@ndorms.ox.ac.uk", 
@@ -37,16 +37,18 @@ Imports:
     generics,
     glue,
     lifecycle,
-    omopgenerics (> 0.3),
+    omopgenerics (>= 0.3.1),
     purrr,
     rlang,
     stringr,
     tidyr
 Suggests: 
     covr,
+    DT,
     flextable (>= 0.9.5),
     ggplot2,
     gt,
+    htmltools,
     knitr,
     officer,
     palmerpenguins,

NAMESPACE

@@ -20,6 +20,7 @@ export(groupColumns)
 export(importSummarisedResult)
 export(mockSummarisedResult)
 export(pivotEstimates)
+export(plotColumns)
 export(scatterPlot)
 export(settings)
 export(settingsColumns)
@@ -29,6 +30,7 @@ export(splitGroup)
 export(splitStrata)
 export(strataColumns)
 export(suppress)
+export(tableColumns)
 export(tableOptions)
 export(tableStyle)
 export(tableType)

R/datatableInternal.R

@@ -0,0 +1,129 @@
+datatableInternal <- function(x,
+                              delim = "\n",
+                              style = "default",
+                              caption = NULL,
+                              groupColumn = NULL) {
+
+  # Package checks
+  rlang::check_installed("DT")
+  rlang::check_installed("htmltools")
+
+  style <- validateStyle(style, "datatable")
+  options <- style[c(
+    "scrollX", "scrollY", "scrollCollapse", "pageLength", "lengthMenu",
+    "searchHighlight", "scroller", "deferRender", "fixedColumns",
+    "fixedHeader"
+  )]
+  options <- options[!sapply(options, is.null)]
+
+  # Eliminate prefixes
+  colnames(x) <- gsub("\\[header\\]|\\[header_level\\]|\\[header_name\\]|\\[column_name\\]", "", colnames(x))
+
+  # groupColumn
+  if (length(groupColumn) > 0) {
+    nameGroup <- names(groupColumn)
+    x <- x |>
+      tidyr::unite(
+        !!nameGroup, groupColumn[[1]], sep = "; ", remove = TRUE, na.rm = TRUE
+      ) |>
+      dplyr::relocate(!!nameGroup)
+    options$rowGroup = list(dataSrc = 1)
+  }
+
+  # header
+  header <- colnames(x)
+  container <- paste0("<table class='display'><thead><tr>", paste0("<th>", header, "</th>", collapse = " "), "</tr></thead></table>")
+  if (any(grepl(delim, header))) {
+    header_split <- stringr::str_split(header, paste0("\\", delim))
+
+    levels <- sapply(header_split, length)
+    max_depth <- max(levels)
+    if (length(unique(levels)) > max_depth) {
+      cli::cli_abort("In this package version, all headers must have the same number of levels.")
+    }
+
+    inHtml <- NULL
+    for (ii in 1:max_depth) {
+      levelHeaders <- sapply(header_split, function(x){x[ii]})
+      levelHeaders <- levelHeaders[!is.na(levelHeaders)]
+      levelHeadersTable <- table(levelHeaders)
+
+      if (ii != max_depth) {
+        html.ii <- lapply(unique(levelHeaders), function(item) {
+          if (levelHeadersTable[item] == 1) {
+            paste0("<th rowspan='", max_depth, "'>", item, "</th>")
+          } else {
+            paste0("<th colspan ='", levelHeadersTable[item], "'>", item, "</th>")
+          }
+        }) |> unlist() |> paste0(collapse = "\n")
+        html.ii <- paste0("<tr>", html.ii, "</tr>")
+
+      } else {
+        html.ii <- paste0("<th>", levelHeaders, "</th>", collapse = "\n")
+      }
+
+      inHtml <- c(inHtml, paste0("<tr>", html.ii, "</tr>"))
+    }
+
+    container <- paste0("<table class='display'>",paste0("<thead>", inHtml |> paste0(collapse = "\n"), "</thead>"), "</table>")
+  }
+
+  # datatable
+  if (is.null(style$filter)) {
+    DT::datatable(
+      x,
+      options = options,
+      caption =  htmltools::tags$caption(
+        style = style$caption, caption
+      ),
+      rownames = style$rownames,
+      extensions = list("FixedColumns", "FixedHeader", "Responsive", "RowGroup", "Scroller"),
+      container = container
+    )
+  } else {
+    DT::datatable(
+      x,
+      options = options,
+      caption =  htmltools::tags$caption(
+        style = style$caption, caption
+      ),
+      filter = style$filter,
+      rownames = style$rownames,
+      extensions = list("FixedColumns", "FixedHeader", "Responsive", "RowGroup", "Scroller"),
+      container = container
+    )
+  }
+}
+
+datatableStyleInternal <- function(styleName) {
+  styles <- list(
+    "default" = list(
+      # "header" = list(),
+      # "header_name" = list(),
+      # "header_level" = list(),
+      # "column_name" = list(),
+      # "group_label" = list(),
+      # "title" = list(),
+      # "subtitle" = list(),
+      # "body" = list()
+      "caption" = 'caption-side: bottom; text-align: center;',
+      "scrollX" = TRUE,
+      "scrollY" = 400,
+      "scroller" = TRUE,
+      "deferRender" = TRUE,
+      "scrollCollapse" = TRUE,
+      "fixedColumns" = list(leftColumns = 0, rightColumns = 0),
+      "fixedHeader" = TRUE,
+      "pageLength" = 10,
+      "lengthMenu" = c(5, 10, 20, 50, 100),
+      "filter" = "bottom",
+      "searchHighlight" = TRUE,
+      "rownames" = FALSE
+    )
+  )
+  if (!styleName %in% names(styles)) {
+    cli::cli_inform(c("i" = "{styleName} does not correspon to any of our defined styles. Returning default style."))
+    styleName <- "default"
+  }
+  return(styles[[styleName]])
+}

R/formatTable.R

@@ -12,9 +12,9 @@
 #' gt/flextable style.
 #' Keep in mind that styling code is different for gt and flextable. To see
 #' the "deafult" style code use `tableStyle()`.
-#' @param na How to display missing values.
-#' @param title Title of the table, or NULL for no title.
-#' @param subtitle Subtitle of the table, or NULL for no subtitle.
+#' @param na How to display missing values. Not used for "datatable".
+#' @param title Title of the table, or NULL for no title. Not used for "datatable".
+#' @param subtitle Subtitle of the table, or NULL for no subtitle. Not used for "datatable".
 #' @param caption Caption for the table, or NULL for no caption. Text in
 #' markdown formatting style (e.g. `*Your caption here*` for caption in
 #' italics).
@@ -23,11 +23,11 @@
 #' joined by "_". To assign a custom group name, provide a named list such as:
 #' list(`newGroupName` = c("variable_name", "variable_level"))
 #' @param groupAsColumn Whether to display the group labels as a column
-#' (TRUE) or rows (FALSE).
-#' @param groupOrder Order in which to display group labels.
+#' (TRUE) or rows (FALSE). Not used for "datatable".
+#' @param groupOrder Order in which to display group labels. Not used for "datatable".
 #' @param merge Names of the columns to merge vertically when consecutive row
 #' cells have identical values. Alternatively, use "all_columns" to apply this
-#' merging to all columns, or use NULL to indicate no merging.
+#' merging to all columns, or use NULL to indicate no merging. Not used for "datatable".
 #'
 #' @return A flextable object.
 #'
@@ -149,8 +149,14 @@ formatTable <- function(x,
         groupOrder = groupOrder,
         merge = merge
       )
-  } else if ("tibble") {
-    return(x)
+  } else if (type == "datatable") {
+    x <- x |>
+      datatableInternal(
+        delim = delim,
+        style = style,
+        caption = caption,
+        groupColumn = groupColumn
+      )
   }
   return(x)
 }

R/helperTableFunctions.R → R/helperFunctions.R

@@ -80,6 +80,23 @@ tableStyle <- function(type = "gt", styleName = "default") {
       "body" = list()
     ) |>
       rlang::expr()
+  } else if (type == "datatable") {
+    list(
+        "caption" = 'caption-side: bottom; text-align: center;',
+        "scrollX" = TRUE,
+        "scrollY" = 400,
+        "scroller" = TRUE,
+        "deferRender" = TRUE,
+        "scrollCollapse" = TRUE,
+        "fixedColumns" = list(leftColumns = 1, rightColumns = 1),
+        "fixedHeader" = TRUE,
+        "pageLength" = 10,
+        "lengthMenu" = c(5, 10, 20, 50, 100),
+        "filter" = "bottom",
+        "searchHighlight" = TRUE,
+        "rownames" = FALSE
+    ) |>
+      rlang::expr()
   }
 }
 
@@ -99,6 +116,53 @@ tableStyle <- function(type = "gt", styleName = "default") {
 #' tableType()
 #'
 tableType <- function() {
-  c("gt", "flextable", "tibble")
+  c("gt", "flextable", "tibble", "datatable")
+}
+
+
+#' Columns for the table functions
+#'
+#' @description
+#' Names of the columns that can be used in the input arguments for the table
+#' functions.
+#'
+#' @param result A `<summarised_result>` object.
+#'
+#' @return A character vector of supported columns for tables.
+#'
+#' @export
+#'
+#' @examples
+#' result <- mockSummarisedResult()
+#' tableColumns(result)
+#'
+tableColumns <- function(result) {
+  result <- omopgenerics::validateResultArgument(result)
+  return(
+    c("cdm_name", groupColumns(result), strataColumns(result), "variable_name",
+      "variable_level", "estimate_name", additionalColumns(result),
+      settingsColumns(result))
+  )
 }
 
+
+#' Columns for the plot functions
+#'
+#' @description
+#' Names of the columns that can be used in the input arguments for the plot
+#' functions.
+#'
+#' @param result A `<summarised_result>` object.
+#'
+#' @return A character vector of supported columns for plots.
+#'
+#' @export
+#'
+#' @examples
+#' result <- mockSummarisedResult()
+#' plotColumns(result)
+#'
+plotColumns <- function(result) {
+  result <- omopgenerics::validateResultArgument(result)
+  return(c(tidyColumns(result)))
+}