R/interactiveTable.R

In htmlTable: Advanced Tables for Markdown/HTML

#' An interactive table that allows you to limit the size of boxes
#'
#' This function wraps the htmlTable and adds JavaScript code for toggling the amount
#' of text shown in any particular cell.
#'
#' @param x The table to be printed
#' @param ... The exact same parameters as [htmlTable()] uses
#' @param txt.maxlen The maximum length of a text
#' @param button Indicator if the cell should be clickable or if a button should appear with a plus/minus
#' @param minimized.columns Notifies if any particular columns should be collapsed from start
#' @param js.scripts If you want to add your own JavaScript code you can just add it here.
#'  All code is merged into one string where each section is wrapped in it's own
#'  `<scrip></script>` element.
#' @return An htmlTable with a javascript attribute containing the code that is then printed
#' @export
#' @example inst/examples/interactiveTable_example.R
#' @rdname interactiveTable
interactiveTable <- function(x,
                             ...,
                             txt.maxlen = 20,
                             button = getOption("htmlTable.interactiveTable.button", default = FALSE),
                             minimized.columns = NULL,
                             js.scripts = c()) {
  UseMethod("interactiveTable")
}

getButtonDiv <- function(sign = "-") {
  template <- system.file("html_components/button.html", package = "htmlTable")
  if (template == "") {
    stop("Could not find the button template file")
  }

  template <- readChar(template, nchars = file.info(template)$size)
  gsub("%sign%", sign, template) %>%
    gsub("[\n\r]", " ", .)
}

#' @export
#' @method interactiveTable default
interactiveTable.default <- function(x,
                                     ...,
                                     txt.maxlen = 20,
                                     button = getOption("htmlTable.interactiveTable.button", default = FALSE),
                                     minimized.columns = NULL,
                                     js.scripts = c()) {
  if ("data.frame" %in% class(x)) {
    x <- prConvertDfFactors(x)
  }
  if (!is.null(minimized.columns)) {
    if (is.character(minimized.columns)) {
      if (minimized.columns != "last") {
        stop(
          "If you want to provide a character for columns you must",
          " provide 'last' - '", minimized.columns, "' has not yet",
          " been implemented."
        )
      }
      minimized.columns <- ncol(x)
    } else if (is.logical(minimized.columns)) {
      minimized.columns <- which(minimized.columns)
    } else if (!is.numeric(minimized.columns)) {
      stop("Expecting the minimized columns to either be numbers or logical parameters")
    } else if (max(minimized.columns) > ncol(x)) {
      stop(
        "You can't minimize columns larger than the number of columns available.",
        "I.e. ", paste(minimized.columns[minimized.columns > ncol(x)], collapse = ", "),
        " > ", ncol(x)
      )
    }

    if (!is.null(dim(minimized.columns))) {
      stop("Can only handle column vectors for minimization")
    }

    addon_elements <- paste(
      "... ",
      "<span class='hidden' style='display: none'>%span_inner_text%</span>"
    )
    if (button) {
      addon_elements <- paste(
        addon_elements,
        getButtonDiv("+")
      )
    }
    for (col_no in minimized.columns) {
      for (row_no in 1:nrow(x)) {
        if (nchar(x[row_no, col_no]) > txt.maxlen) {
          x[row_no, col_no] <-
            paste0(
              substr(x[row_no, col_no], 1, txt.maxlen),
              gsub("%span_inner_text%", x[row_no, col_no], addon_elements)
            )
        }
      }
    }
    # Pass false to allow warning later on
    minimized.columns <- FALSE
  }
  tbl <- htmlTable(x, escape.html = FALSE, ...)
  return(interactiveTable(tbl,
    txt.maxlen = 20,
    button = button,
    minimized.columns = minimized.columns,
    js.scripts = js.scripts
  ))
}

#' @method interactiveTable htmlTable
#' @rdname interactiveTable
#' @export
interactiveTable.htmlTable <- function(x,
                                       ...,
                                       txt.maxlen = 20,
                                       button = getOption("htmlTable.interactiveTable.button", default = FALSE),
                                       minimized.columns = NULL,
                                       js.scripts = c()) {
  if (!is.null(minimized.columns) && all(minimized.columns != FALSE)) {
    stop(
      "Can't minimize columns after creating the htmlTable.",
      " Try calling the function directly with the input data that you used for htmlTable"
    )
  }

  class(x) <- c("interactiveTable", class(x))
  if (button) {
    template <- system.file("javascript/button.js", package = "htmlTable")
    if (template == "") {
      stop("Could not find the javascript button template file")
    }
    template <- readChar(template, nchars = file.info(template)$size)

    attr(x, "javascript") <- c(
      js.scripts,
      template %>%
        gsub("%txt.maxlen%", txt.maxlen, .) %>%
        gsub("%btn%", getButtonDiv(), .)
    )
  } else {
    template <- system.file("javascript/toggler.js", package = "htmlTable")
    if (template == "") {
      stop("Could not find the javascript toggler template file")
    }
    template <- readChar(template, nchars = file.info(template)$size)

    attr(x, "javascript") <- c(
      js.scripts,
      template %>%
        gsub("%txt.maxlen%", txt.maxlen, .)
    )
  }

  return(x)
}

#' @rdname interactiveTable
#' @importFrom knitr knit_print
#' @importFrom knitr asis_output
#' @export
knit_print.interactiveTable <- function(x, ...) {
  if (getOption("interactiveTable_knitprint", FALSE)) {
    asis_output(x)
  } else {
    options(interactiveTable_knitprint = TRUE)
    asis_output(paste(
      x,
      attr(x, "javascript")
    ))
  }
}

#' Gets a string with all the scripts merged into one script tag
#'
#' Each element has it's own script tags in otherwise an error will cause
#' all the scripts to fail.
#'
#' @param x An interactiveTable
#' @return string
#' @keywords internal
prGetScriptString <- function(x) {
  scripts <- attr(x, "javascript")
  if (is.null(scripts)) {
    stop("You have provided an object of class ", class(x), " that does not contain a javascript attribute")
  }

  sapply(scripts,
    USE.NAMES = FALSE,
    FUN = function(s) {
      if (s == "") {
        return("")
      }

      paste(
        "<script type = \"text/javascript\" language = \"javascript\">",
        s,
        "</script>"
      )
    }
  ) %>%
    paste(collapse = "\n\n <!-- *** Next script group *** !-->\n")
}

#' @rdname interactiveTable
#' @inheritParams htmlTable
#' @export
print.interactiveTable <- function(x, useViewer, ...) {
  args <- attr(x, "...")
  # Use the latest ... from the print call
  # and override the original htmlTable call ...
  # if there is a conflict
  print_args <- list(...)
  for (n in names(print_args)) {
    args[[n]] <- print_args[[n]]
  }

  # Since the print may be called from another print function
  # it may be handy to allow functions to use attributes for the
  # useViewer parameter
  if (missing(useViewer)) {
    if ("useViewer" %in% names(args) &&
      (is.logical(args$useViewer) ||
        is.function(args$useViewer))) {
      useViewer <- args$useViewer
      args$useViewer <- NULL
    } else {
      useViewer <- TRUE
    }
  }

  if (interactive() &&
    !getOption("htmlTable.cat", FALSE) &&
    (is.function(useViewer) ||
      useViewer != FALSE)) {
    if (is.null(args$file)) {
      args$file <- tempfile(fileext = ".html")
    }

    htmlPage <- paste("<html>",
      "<head>",
      "<meta http-equiv=\"Content-type\" content=\"text/html; charset=UTF-8\">",
      "<script src=\"https://ajax.googleapis.com/ajax/libs/jquery/3.7.1/jquery.min.js\"></script>",
      "</head>",
      "<body>",
      "<div style=\"margin: 0 auto; display: table; margin-top: 1em;\">",
      x,
      "</div>",
      prGetScriptString(x),
      "</body>",
      "</html>",
      sep = "\n"
    )
    # We only want to use those arguments that are actually in cat
    # anything else that may have inadvertadly slipped in should
    # be ignored or it will be added to the output
    cat_args <- args
    cat_args <- cat_args[names(cat_args) %in% names(formals(cat))[-1]]
    do.call(cat, c(htmlPage, cat_args))

    if (is.function(useViewer)) {
      useViewer(args$file)
    } else {
      viewer <- getOption("viewer")
      if (!is.null(viewer) &&
        is.function(viewer)) {
        # (code to write some content to the file)
        viewer(args$file)
      } else {
        utils::browseURL(args$file)
      }
    }
  } else {
    cat_args <- args
    cat_args <- cat_args[names(cat_args) %in% names(formals(cat))[-1]]
    do.call(cat, c(x, cat_args))
    cat(prGetScriptString(x))
  }

  invisible(x)
}