R/dtsmartr.R

In dtsmartr: Interactive Virtualized Data Explorer Grid Widget

#' Generate Configuration Options for dtsmartr
#'
#' Helper function to specify UI customization, initial grid visibility states,
#' and rendering options for the dtsmartr interactive grid widget.
#'
#' @param advanced_filter Logical. If `TRUE` (default), renders the multi-condition Advanced Query Builder panel.
#' @param show_labels Logical. If `TRUE` (default), displays R column attributes (like 'label') in table headers.
#' @param column_picker Logical. If `TRUE` (default), displays the top-right column show/hide visibility dropdown.
#' @param allow_export Logical. If `TRUE` (default), displays clipboard copy buttons and the R & SQL "Query Code" generator modal.
#' @param theme Character. Specifies the UI color theme: `"auto"` (default, inherits from browser settings), `"light"`, or `"dark"`.
#' @param na_string Character. Custom string placeholder displayed in cells with missing values (`NA` or `null`). Defaults to `"NA"`.
#' @param hidden_columns Character vector. Vector of column names to hide by default on initial widget rendering.
#'
#' @return A named list of validated configuration settings.
#' @export
#'
#' @examples
#' dtsmartr_options(advanced_filter = FALSE, hidden_columns = c("STUDYID", "USUBJID"))
dtsmartr_options <- function(
    advanced_filter = TRUE,
    show_labels     = TRUE,
    column_picker   = TRUE,
    allow_export    = TRUE,
    theme           = "auto",
    na_string       = "NA",
    hidden_columns  = NULL
) {
  # ── Validations ─────────────────────────────────────────────────────────────
  if (!is.logical(advanced_filter) || length(advanced_filter) != 1L) {
    stop("`advanced_filter` must be a single logical value (TRUE/FALSE).", call. = FALSE)
  }
  if (!is.logical(show_labels) || length(show_labels) != 1L) {
    stop("`show_labels` must be a single logical value (TRUE/FALSE).", call. = FALSE)
  }
  if (!is.logical(column_picker) || length(column_picker) != 1L) {
    stop("`column_picker` must be a single logical value (TRUE/FALSE).", call. = FALSE)
  }
  if (!is.logical(allow_export) || length(allow_export) != 1L) {
    stop("`allow_export` must be a single logical value (TRUE/FALSE).", call. = FALSE)
  }
  theme <- match.arg(theme, c("auto", "light", "dark"))

  if (!is.character(na_string) || length(na_string) != 1L) {
    stop("`na_string` must be a single character string.", call. = FALSE)
  }
  if (!is.null(hidden_columns) && !is.character(hidden_columns)) {
    stop("`hidden_columns` must be a character vector or NULL.", call. = FALSE)
  }

  list(
    advanced_filter = advanced_filter,
    show_labels     = show_labels,
    column_picker   = column_picker,
    allow_export    = allow_export,
    theme           = theme,
    na_string       = na_string,
    hidden_columns  = if (is.null(hidden_columns)) list() else as.list(hidden_columns)
  )
}

#' dtsmartr - Interactive virtualized data explorer grid widget
#'
#' Renders a high-performance, virtualized data grid powered by React to explore
#' datasets, filter dynamically, and generate reproducible queries.
#'
#' @param data A `data.frame` to explore.
#' @param width Widget width. Defaults to `"100%"`.
#' @param height Widget height. Defaults to `"100vh"` (full screen/viewport).
#' @param elementId CSS ID for the widget container.
#' @param datasetName Custom string name representing the dataset in generated reproducible code. If omitted, automatically extracts the R variable name.
#' @param options Named list of UI options generated by [dtsmartr_options()].
#' @param skip_routing Logical. Internal flag used by [save_dtsmartr()] to
#'   bypass the automatic re-routing to [dtsmartr_launch()] for large datasets.
#'   End users should not set this parameter. Defaults to `FALSE`.
#'
#' @return An object of class `htmlwidget` (and sub-class `dtsmartr`) representing
#'   the interactive virtualized grid. In interactive R sessions, this will
#'   display the explorer in the RStudio/Positron Viewer pane or system browser.
#'
#' @import htmlwidgets
#' @importFrom jsonlite toJSON
#'
#' @examples
#' if (interactive()) {
#'   dtsmartr(mtcars, options = dtsmartr_options(hidden_columns = "cyl"))
#' }
#'
#' @export
dtsmartr <- function(
    data,
    width         = NULL,
    height        = NULL,
    elementId     = NULL,
    datasetName   = NULL,
    options       = dtsmartr_options(),
    skip_routing  = FALSE
) {
  if (!is.data.frame(data)) {
    stop("`data` must be a data.frame", call. = FALSE)
  }

  # ── Performance Check & Threshold Routing ──────────────────────────────────
  if (nrow(data) > 50000 && !isTRUE(skip_routing)) {
    # skip_routing = TRUE is set internally by save_dtsmartr() so the widget
    # is always returned as an object for file export — never re-routed.
    #
    # If we are already inside a running Shiny server (e.g. called from
    # renderDtsmartr inside dtsmartr_launch), do NOT call runApp() again —
    # that would trigger the "Can't call runApp() from within runApp()" error.
    # In that context the browser is already open, so just warn and continue.
    if (isTRUE(shiny::isRunning())) {
      warning(
        "Dataset exceeds 50,000 rows. ",
        "Rendering inside the active Shiny session. ",
        "Consider reducing the dataset for best performance.",
        call. = FALSE
      )
    } else if (interactive()) {
      message("Dataset exceeds 50,000 rows. Automatically re-routing to dtsmartr_launch() for external browser rendering to prevent IDE freezing...")
      return(dtsmartr_launch(data = data, options = options))
    } else {
      warning("Dataset exceeds 50,000 rows. Freezing or slow performance may occur inside the Viewer pane. Consider using dtsmartr_launch().", call. = FALSE)
    }
  }

  # ── Capture dataset name ───────────────────────────────────────────────────
  if (is.null(datasetName)) {
    ds_name <- deparse(substitute(data))
    if (length(ds_name) > 1) ds_name <- paste(ds_name, collapse = "")
    if (nchar(ds_name) > 40 || grepl("[\\\\(\\\\)\\\\{\\\\}]", ds_name)) {
      ds_name <- "df"
    }
  } else {
    ds_name <- as.character(datasetName)[1]
  }

  # ── Detect column types ────────────────────────────────────────────────────
  get_col_type <- function(col) {
    if (is.logical(col))   return("logical")
    if (is.integer(col))   return("integer")
    if (is.numeric(col))   return("numeric")
    if (is.factor(col))    return("factor")
    if (inherits(col, c("Date", "POSIXct", "POSIXlt"))) return("datetime")
    if (is.character(col)) return("character")
    return(class(col)[1])
  }

  metadata <- lapply(names(data), function(col_name) {
    col_data <- data[[col_name]]
    lbl      <- attr(col_data, "label", exact = TRUE)
    list(
      name          = col_name,
      type          = get_col_type(col_data),
      unique_values = length(unique(col_data)),
      label         = if (!is.null(lbl) && nzchar(trimws(lbl)))
                        trimws(as.character(lbl))
                      else
                        NULL
    )
  })

  # Coerce factors / dates to character for clean JSON serialization
  data_clean <- as.data.frame(
    lapply(data, function(col) {
      if (is.factor(col)) return(as.character(col))
      if (inherits(col, c("Date", "POSIXct", "POSIXlt"))) return(as.character(col))
      col
    }),
    stringsAsFactors = FALSE,
    check.names      = FALSE
  )
  rownames(data_clean) <- rownames(data)

  x <- list(
    data         = data_clean,
    metadata     = metadata,
    dataset_name = ds_name,
    options      = options
  )

  # Create htmlwidget
  htmlwidgets::createWidget(
    name      = 'dtsmartr',
    x         = x,
    width     = width,
    height    = height,
    package   = 'dtsmartr',
    elementId = elementId
  )
}

#' Called by HTMLWidgets to produce the widget's root element.
#' @noRd
widget_html.dtsmartr <- function(id, style, class, ...) {
  # Add CSS rules to make body and html occupy 100% of height and prevent body margin/padding/overflow
  # only when it is rendered as the primary standalone page (inside #htmlwidget_container).
  full_screen_css <- htmltools::tags$style(htmltools::HTML(sprintf("
    html:has(#htmlwidget_container), body:has(#htmlwidget_container) {
      margin: 0 !important;
      padding: 0 !important;
      width: 100%% !important;
      height: 100%% !important;
      overflow: hidden !important;
    }
    #htmlwidget_container {
      width: 100%% !important;
      height: 100%% !important;
      margin: 0 !important;
      padding: 0 !important;
    }
    #%s {
      width: 100%% !important;
      height: 100vh !important;
    }
  ", id)))

  htmltools::attachDependencies(
    htmltools::tags$div(
      id = id, 
      class = class, 
      style = style,
      full_screen_css
    ),
    list(
      reactR::html_dependency_corejs(),
      reactR::html_dependency_react(),
      reactR::html_dependency_reacttools()
    )
  )
}

#' Shiny bindings for dtsmartr
#'
#' Output and render functions for using dtsmartr within Shiny
#' applications and interactive Rmd documents.
#'
#' @param outputId output variable to read from
#' @param width,height Must be a valid CSS unit (like \code{'100\%'},
#'   \code{'400px'}, \code{'auto'}) or a number, which will be coerced to a
#'   string and have \code{'px'} appended.
#' @param expr An expression that generates a dtsmartr
#' @param env The environment in which to evaluate \code{expr}.
#' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
#'   is useful if you want to save an expression in a variable.
#'
#' @return `dtsmartrOutput` returns a Shiny output element of class `shiny.tag.list`
#'   that can be placed in a Shiny user interface.
#'   `renderDtsmartr` returns a Shiny render function of class `shiny.render.function`
#'   that can be assigned to an output slot.
#'
#' @name dtsmartr-shiny
#'
#' @export
dtsmartrOutput <- function(outputId, width = '100%', height = '400px'){
  htmlwidgets::shinyWidgetOutput(outputId, 'dtsmartr', width, height, package = 'dtsmartr')
}

#' @rdname dtsmartr-shiny
#' @export
renderDtsmartr <- function(expr, env = parent.frame(), quoted = FALSE) {
  if (!quoted) { expr <- substitute(expr) } # force quoted
  htmlwidgets::shinyRenderWidget(expr, dtsmartrOutput, env, quoted = TRUE)
}