#' Create a HTML table containing the given list of elements
#'
#' @description Creates a HTML table containing the given list of elements.
#' Every element of the list should be a vector of the same length to ensure
#' correct design. The align parameter can be either a character, which will
#' result in all cells having the same alignment, a character vector showing
#' the alignment for every column or a list of character vectors specifying
#' the alignment of every cell.
#'
#' @param elements List of elements to show in the list, each element of the
#' list should be a row of the table. Can also be a data.frame with names used
#' as header.
#' @param id Optional, character specifying the elements id.
#' @param align Optional, character (vector) or list of characters showing the
#' alignment of the table for each column/cell, can be one of "left", "right"
#' or "center", defaults to "left", can be abbreviated.
#' @param head_align Optional character vector of header alignments, defaults to
#' "center", can be abbreviated.
#' @param borders Optional character specifying the desired borders to show. Can
#' be either a single character vector of length one with one of c("inner",
#' "outer", "all", "tex") or a list of character vectors specifying all
#' borders by hand. Possible values are "top", "right", "bottom", "left". The
#' first entry of the list will be used for the header row if given.
#' @author richard.kunze
#' @return HTML table
#' @export
#'
#' @examples ## Only run examples in interactive R sessions
#' if (interactive()) {
#'
#' library(shiny)
#' lets <- data.frame(lower = letters[1:5], UPPER = LETTERS[1:5])
#' shinyApp(
#' ui = fluidPage(
#' dq_space(), fluidRow(
#' column(3, dq_htmltable(
#' list(list("Description", icon("hashtag")),
#' list("Value", textInput("value", NULL)),
#' list("Result", textOutput("result"))),
#' borders = "inner"
#' )),
#' column(2, dq_htmltable(lets, borders = "outer")),
#' column(3, dq_htmltable(
#' list(c("Left", "Center", "Right"), c("Center", "Right", "Left")),
#' align = list(c("LEFT", "center", "right"), c("c", "R", "l")),
#' borders = "all"
#' )),
#' column(2, dq_htmltable(lets, borders = "tex")),
#' column(2, dq_htmltable(lets, borders = list(
#' c("top left", "bottom right"), # header
#' c("", ""), c("", ""), c("", ""), c("", ""), c("bottom", "bottom")
#' )))
#' )),
#' server = function(input, output) {
#' output$result <- renderText(input$value)
#' }
#' )
#'
#' }
dq_htmltable <- function(
elements, id = NULL,
align = "left", head_align = "center",
borders = "none"
) {
els <- elements
if (is.data.frame(els)) els <- as.data.frame(t(els))
header <- names(elements)
align <- fill_alignments(align, els)
head_align <- fill_alignments(head_align, header)
if (is.list(borders)) {
if (is.null(header)) {
head_borders <- NULL
body_borders <- borders
} else {
head_borders <- as.list(borders[[1]])
body_borders <- lapply(borders[-1], as.list)
}
} else {
head_borders <- head_borders(borders, header)
body_borders <- fill_borders(borders, els)
}
shiny::tags$table(
class = "dq-html-table", id = id,
if (!is.null(header)) {
shiny::tags$tr(
lapply(seq(header), function(i) {
shiny::tags$th(
header[[i]], class = paste(head_align[[i]], head_borders[[i]])
)
})
)
},
lapply(seq(els), function(r) {
shiny::tags$tr(
lapply(seq(els[[r]]), function(c) {
shiny::tags$td(
els[[r]][c],
class = paste(align[[r]][[c]], body_borders[[r]][[c]])
)
})
)
}),
init()
)
}
fill_alignments <- function(align, els) {
if (is.null(align)) {
align <- "left"
}
if (length(align) != length(els[[1]]) || is.list(align)) {
align <- lapply(align, rep_len, length(els[[1]]))
}
if (!is.list(align) || length(align) != length(els)) {
align <- lapply(seq(els), function(x) { unlist(align) })
}
lapply(align, function(a) {
a <- gsub("^r$", "right", tolower(a))
a <- gsub("^l$", "left", a)
paste0("align-", gsub("^c$", "center", a))
})
}
fill_borders <- function(type, els) {
r_max <- length(els)
c_max <- length(els[[1L]])
rows <- seq(r_max)
cols <- seq(c_max)
if (isTRUE(type == "inner")) {
lapply(rows, function(r) {
lapply(cols, function(c) {
paste(c(
if (c > 1) "left", if (c < c_max) "right",
if (r > 1) "top", if (r < r_max) "bottom"
), collapse = " ")
})
})
} else if (isTRUE(type == "outer")) {
lapply(rows, function(r) {
lapply(cols, function(c) {
paste(c(
if (c == 1) "left", if (c == c_max) "right",
if (r == 1) "top", if (r == r_max) "bottom"
), collapse = " ")
})
})
} else if (isTRUE(type == "all")) {
lapply(rows, function(r) {
lapply(cols, function(c) {
paste(c(
"right", if (c == 1) "left",
"bottom", if (r == 1) "top"
), collapse = " ")
})
})
} else if (isTRUE(type == "tex")) {
lapply(rows, function(r) {
lapply(cols, function(c) {
paste(c(
if (r == r_max) "bottom", if (r == 1) "top"
), collapse = " ")
})
})
} else {
lapply(rows, function(r) {
lapply(cols, function(c) { "" })
})
}
}
head_borders <- function(type, header) {
c_max <- length(header)
cols <- seq(c_max)
if (isTRUE(type == "inner")) {
lapply(seq(header), function(c) {
paste(c(
if (c > 1) "left", if (c < c_max) "right", "bottom"
), collapse = " ")
})
} else if (isTRUE(type == "outer")) {
lapply(seq(header), function(c) {
paste(c(
if (c == 1) "left", if (c == c_max) "right", "top", "bottom"
), collapse = " ")
})
} else if (isTRUE(type == "all")) {
lapply(seq(header), function(c) {
paste(c(
if (c == 1) "left", "right", "top", "bottom"
), collapse = " ")
})
} else if (isTRUE(type == "tex")) {
lapply(seq(header), function(c) {
paste(c(
"top", "bottom"
), collapse = " ")
})
} else {
lapply(seq(header), function(c) { "" })
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.