R/tt_bootstrap.R

In tinytable: Simple and Configurable Tables in 'HTML', 'LaTeX', 'Markdown', 'Word', 'PNG', 'PDF', and 'Typst' Formats

setMethod(
  f = "tt_eval",
  signature = "tinytable_bootstrap",
  definition = function(x, ...) {
    template <- readLines(
      system.file("templates/bootstrap.html", package = "tinytable")
    )

    mathjax <- get_option("tinytable_html_mathjax", default = FALSE)
    assert_flag(mathjax, name = "tinytable_html_mathjax")
    if (isFALSE(mathjax)) {
      template <- paste(template, collapse = "\n")
      sta <- "    <!-- tinytable mathjax start -->"
      end <- "    <!-- tinytable mathjax end -->"
      template <- lines_drop_between(template, sta, end, fixed = TRUE)
      template <- strsplit(template, "\n")[[1]]
    }

    quartoprocessing <- get_option(
      "tinytable_quarto_disable_processing",
      default = TRUE
    )
    assert_flag(quartoprocessing, name = "tinytable_quarto_disable_processing")
    if (isFALSE(quartoprocessing)) {
      template <- sub(
        "data-quarto-disable-processing='true'",
        "data-quarto-disable-processing='false'",
        template,
        fixed = TRUE
      )
    }

    # caption
    if (length(x@caption) != 1) {
      template <- sub(
        "$tinytable_BOOTSTRAP_CAPTION",
        "",
        template,
        fixed = TRUE
      )
    } else {
      template <- sub(
        "$tinytable_BOOTSTRAP_CAPTION",
        sprintf("<caption>%s</caption>", x@caption),
        template,
        fixed = TRUE
      )
    }

    # note
    if (length(x@notes) == 0) {
      template <- sub(
        "$tinytable_BOOTSTRAP_NOTE",
        "",
        template,
        fixed = TRUE
      )
    } else {
      notes_tmp <- NULL
      for (k in seq_along(x@notes)) {
        if (!is.null(names(x@notes))) {
          if (is.list(x@notes[[k]])) {
            tmp <- sprintf(
              "<tr><td colspan='%s'><sup>%s</sup> %s</td></tr>",
              ncol(x),
              names(x@notes)[k],
              x@notes[[k]]$text
            )
            # note is a string
          } else {
            tmp <- sprintf(
              "<tr><td colspan='%s'><sup>%s</sup> %s</td></tr>",
              ncol(x),
              names(x@notes)[k],
              x@notes[k]
            )
          }
        } else {
          tmp <- sprintf(
            "<tr><td colspan='%s'>%s</td></tr>",
            ncol(x),
            x@notes[[k]]
          )
        }
        notes_tmp <- c(notes_tmp, tmp)
      }
      notes <- paste(notes_tmp, collapse = "\n")
      notes <- paste0("<tfoot>", notes, "</tfoot>")
      template <- sub(
        "$tinytable_BOOTSTRAP_NOTE",
        notes,
        template,
        fixed = TRUE
      )
      for (ii in seq_along(notes)) {
        x <- style_tt(x, i = nrow(x) + ii, align = "l")
      }
    }

    # width
    if (length(x@width) == 1) {
      template <- sub(
        "width: auto;",
        sprintf(
          "table-layout: fixed; width: %s%% !important;",
          round(x@width * 100)
        ),
        template,
        fixed = TRUE
      )
    } else if (length(x@width) > 1) {
      template <- sub(
        "width: auto;",
        sprintf(
          "table-layout: fixed; width: %s%% !important;",
          round(sum(x@width) * 100)
        ),
        template,
        fixed = TRUE
      )
    }

    # (pseudo-)unique table IDs
    id <- get_id("")
    x@id <- id

    # table and styling function in JS must have different names when there is more than one table on a page.
    template <- gsub(
      "styleCell",
      paste0("styleCell_", id),
      template,
      fixed = TRUE
    )
    template <- gsub(
      "spanCell",
      paste0("spanCell_", id),
      template,
      fixed = TRUE
    )
    template <- gsub(
      "$tinytable_TABLE_ID",
      paste0("tinytable_", id),
      template,
      fixed = TRUE
    )

    # header
    idx <- grep("$tinytable_BOOTSTRAP_HEADER", template, fixed = TRUE)
    if (length(colnames(x)) > 0) {
      header <- sprintf('    <th scope="col">%s</th>', colnames(x))
      header <- c("  <tr>", header, "  </tr>")
      header <- paste(strrep(" ", 11), header)
    } else {
      header <- NULL
    }
    template <- c(
      template[1:(idx - 1)],
      header,
      template[(idx + 1):length(template)]
    )
    # body
    makerow <- function(k) {
      out <- c(
        "  <tr>",
        sprintf("    <td>%s</td>", k),
        "  </tr>"
      )
      return(out)
    }
    body <- apply(x@table_dataframe, 1, makerow)
    idx <- grep("$tinytable_BOOTSTRAP_BODY", template, fixed = TRUE)
    template <- c(
      template[1:(idx - 1)],
      paste(strrep(" ", 13), body),
      template[(idx + 1):length(template)]
    )

    out <- paste(template, collapse = "\n")

    # before style_eval()
    x@table_string <- out

    if (length(x@bootstrap_class) == 0) {
      if (
        is.null(x@theme[[1]]) ||
          is.function(x@theme[[1]]) ||
          isTRUE("default" %in% x@theme[[1]])
      ) {
        x <- theme_tt(x, "default")
      }
    } else if (is.character(x@theme[[1]])) {
      if ("bootstrap" %in% x@theme[[1]]) {
        x <- style_tt(x, bootstrap_class = "table")
      } else if ("striped" %in% x@theme[[1]]) {
        x <- style_tt(x, bootstrap_class = "table table-striped")
      } else if ("grid" %in% x@theme[[1]]) {
        x <- style_tt(x, bootstrap_class = "table table-bordered")
      } else if ("void" %in% x@theme[[1]]) {
        x <- style_tt(x, bootstrap_class = "table table-borderless")
      }
    }

    if (length(x@width) > 1) {
      for (j in seq_len(ncol(x))) {
        css <- sprintf("width: %s%%;", x@width[j] / sum(x@width) * 100)
        x <- style_tt(x, j = j, bootstrap_css = css)
      }
    }

    return(x)
  }
)

bootstrap_setting <- function(x, new, component = "row") {
  att <- attributes(x)
  out <- strsplit(x, "\n")[[1]]
  if (component == "row") {
    idx <- grep("tinytable rows before this", out)
  } else if (component == "column") {
    idx <- grep("tinytable columns before this", out)
  } else if (component == "cell") {
    idx <- utils::tail(grep("</script>", out, fixed = TRUE), 1)
    # idx <- grep("tinytable cells before this", out)
  } else if (component == "css") {
    idx <- grep("</style>", out, fixed = TRUE)
  } else if (component == "newrows") {
    idx <- grep("tinytable new rows before this", out)
  }
  out <- c(
    out[1:(idx - 1)],
    new,
    out[idx:length(out)]
  )
  out <- paste(out, collapse = "\n")
  attributes(out) <- att
  class(out) <- class(x)
  return(out)
}