├── tests ├── testthat.R ├── testthat │ ├── test-htmlTable-input_checks.R │ ├── test-txtMergeLines.R │ ├── test-theming.R │ ├── ters-htmlTable_cell_styles_via_prPrepareCSS.R │ ├── htmlTable_addHtmlTableStyle.R │ ├── test-htmlTable_escape_html.R │ ├── test-htmlTable-dimnames.R │ ├── test-htmlTable_dates.R │ ├── test-htmlTable_total.R │ ├── test-htmlTable_styles.R │ ├── test-tidyHtmlTable.R │ └── test-htmlTable_cgroup.R ├── visual_tests │ ├── pandoc_test.Rmd │ └── word_test.Rmd └── testInteractive.R ├── data └── SCB.rda ├── cran-comments.md ├── .travis.yml ├── R ├── htmlTable_render_knit_print.R ├── tidyHtmlTable_helpers_simplify_arg_list.R ├── tidyHtmlTable_helpers_safeLoadPkg.R ├── tidyHtmlTable_helpers_innerJoinByCommonCols.r ├── tidyHtmlTable_helpers_extractElementsAndConvertToTbl.R ├── tidyHtmlTable_helpers_getColTbl.R ├── htmlTable_helpers_skipRownames.R ├── data-SCB.R ├── tidyHtmlTable_helpers_bindDataListIntoColumns.r ├── tidyHtmlTable_helpers_getRowTbl.r ├── htmlTable_helpers_escapeHtml.R ├── htmlTable_helpers_convertDfFactors.R ├── prepGroupCounts.R ├── tidyHtmlTable_helpers_checkUniqueness.r ├── tidyHtmlTable_helpers_prAssertAndRetrieveValue.R ├── htmlTable_helpers_prepInputMatrixDimensions.R ├── tidyHtmlTable_helpers_removeRowsWithNA.r ├── htmlTable_helpers_isNotebook.R ├── htmlTable_helpers_mergeClr.R ├── concatHtmlTables.R ├── htmlTable_helpers_tblNo.R ├── deprecated.R ├── vector2string.R ├── htmlTable_helpers_addSemicolon2StrEnd.R ├── htmlTable_style_assertions.R ├── htmlTable_helpers_getRowlabelPos.R ├── htmlTable_helpers_prepareAlign.R ├── htmlTable_helpers_prepareColors.R ├── tblNo.R ├── htmlTable_render_prAddEmptySpacerCell.R ├── htmlTable_helpers_getAlign.R ├── htmlTableWidget.R ├── txtFrmt_round_data.frame.R ├── htmlTable_render_print.R ├── htmlTable_render_addCells.R ├── htmlTable_helpers_prepareCss.R ├── htmlTable_helpers_getStyle.R ├── htmlTable_render_getThead.R ├── htmlTable_helpers_attr4RgroupAdd.R ├── htmlTable_render_getRgroupLine.R └── htmlTable_render_getCgroupHeader.R ├── .Rbuildignore ├── inst ├── html_components │ └── button.html ├── htmlwidgets │ ├── htmlTableWidget.yaml │ ├── htmlTableWidget.js │ └── lib │ │ └── table_pagination │ │ ├── table_pagination.css │ │ └── table_pagination.js ├── examples │ ├── interactiveTable_example.R │ ├── data-SCB_example.R │ ├── tidyHtmlTable_example.R │ ├── concatHtmlTables_example.R │ └── htmlTable_example.R └── javascript │ ├── button.js │ └── toggler.js ├── .gitignore ├── man ├── prIsNotebook.Rd ├── prGetScriptString.Rd ├── outputInt.Rd ├── getHtmlTableTheme.Rd ├── splitLines4Table.Rd ├── innerJoinByCommonCols.Rd ├── pvalueFormatter.Rd ├── prepGroupCounts.Rd ├── prExtractElementsAndConvertToTbl.Rd ├── prBindDataListIntoColumns.Rd ├── prConvertDfFactors.Rd ├── prPrepareColors.Rd ├── prMergeClr.Rd ├── prAttr4RgroupAdd.Rd ├── tblNoLast.Rd ├── tblNoNext.Rd ├── prSkipRownames.Rd ├── getHtmlTableStyle.Rd ├── vector2string.Rd ├── prGetAlign.Rd ├── hasHtmlTableStyle.Rd ├── prAddSemicolon2StrEnd.Rd ├── prEscapeHtml.Rd ├── prGetStyle.Rd ├── prTblNo.Rd ├── prPrepInputMatrixDimensions.Rd ├── prPrepareCss.Rd ├── htmlTableWidget-shiny.Rd ├── txtInt.Rd ├── txtMergeLines.Rd ├── htmlTableWidget.Rd ├── prGetRowlabelPos.Rd ├── prAddEmptySpacerCell.Rd ├── SCB.Rd ├── prPrepareAlign.Rd ├── prAddCells.Rd ├── txtPval.Rd ├── prGetRgroupLine.Rd ├── prPrepareCgroup.Rd ├── concatHtmlTables.Rd ├── prGetCgroupHeader.Rd ├── interactiveTable.Rd ├── prGetThead.Rd └── txtRound.Rd ├── htmlTable.Rproj ├── .github └── ISSUE_TEMPLATE │ └── bug_report.md ├── DESCRIPTION ├── NAMESPACE ├── .lintr └── vignettes ├── tidyHtmlTable.Rmd ├── custom.css └── text_formatters.Rmd /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | 3 | test_check('htmlTable') 4 | -------------------------------------------------------------------------------- /data/SCB.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gforge/htmlTable/HEAD/data/SCB.rda -------------------------------------------------------------------------------- /cran-comments.md: -------------------------------------------------------------------------------- 1 | ## Test environments 2 | * Ubuntu install, 4.3.1 3 | * Winbuilder 4 | 5 | ## R CMD check results 6 | There were no ERRORs, WARNINGs, or NOTEs. 7 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Sample .travis.yml for R projects 2 | 3 | language: r 4 | warnings_are_errors: true 5 | sudo: required 6 | r_packages: 7 | - Hmisc 8 | - dplyr 9 | - tidyr 10 | -------------------------------------------------------------------------------- /R/htmlTable_render_knit_print.R: -------------------------------------------------------------------------------- 1 | #' @rdname htmlTable 2 | #' @importFrom knitr knit_print 3 | #' @importFrom knitr asis_output 4 | #' @export 5 | knit_print.htmlTable <- function(x, ...) { 6 | asis_output(x) 7 | } 8 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^CRAN-RELEASE$ 2 | ^.*\.Rproj$ 3 | ^\.Rproj\.user$ 4 | ^visual_tests 5 | ^cran-comments.md 6 | ^\.travis\.yml$ 7 | ^revdep$ 8 | ^.github 9 | ^doc$ 10 | ^Meta$ 11 | .lintr 12 | .vscode 13 | ^CRAN-SUBMISSION$ 14 | -------------------------------------------------------------------------------- /R/tidyHtmlTable_helpers_simplify_arg_list.R: -------------------------------------------------------------------------------- 1 | # Converts arguments from ... into a list and removes those that have been set 2 | # to NULL 3 | simplify_arg_list <- function(...) { 4 | x <- list(...) 5 | idx <- sapply(x, is.null) 6 | return(x[!idx]) 7 | } 8 | -------------------------------------------------------------------------------- /inst/html_components/button.html: -------------------------------------------------------------------------------- 1 |
%sign% 3 |
-------------------------------------------------------------------------------- /R/tidyHtmlTable_helpers_safeLoadPkg.R: -------------------------------------------------------------------------------- 1 | # You need the suggested package for this function 2 | safeLoadPkg <- function(pkg) { 3 | if (!requireNamespace(pkg, quietly = TRUE)) { 4 | stop("The package ", pkg, " is needed for this function to work. Please install it.", 5 | call. = FALSE 6 | ) 7 | } 8 | } 9 | -------------------------------------------------------------------------------- /inst/htmlwidgets/htmlTableWidget.yaml: -------------------------------------------------------------------------------- 1 | dependencies: 2 | - name: jquery 3 | version: 3.6.0 4 | src: "htmlwidgets/lib/jquery" 5 | script: jquery.min.js 6 | - name: table_pagination 7 | version: 0.1.0 8 | src: "htmlwidgets/lib/table_pagination" 9 | script: table_pagination.js 10 | stylesheet: table_pagination.css 11 | -------------------------------------------------------------------------------- /R/tidyHtmlTable_helpers_innerJoinByCommonCols.r: -------------------------------------------------------------------------------- 1 | #' A simple function for joining two tables by their 2 | #' intersected columns 3 | #' 4 | #' @param x `data.frame` 5 | #' @param y `data.frame` 6 | #' @return `data.frame` 7 | innerJoinByCommonCols <- function(x, y) { 8 | by <- intersect(names(x), names(y)) 9 | dplyr::inner_join(x, y, by = by) 10 | } 11 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # History files 2 | .Rhistory 3 | 4 | # Example code in package build process 5 | *-Ex.R 6 | 7 | # R data files from past sessions 8 | .Rdata 9 | 10 | # RStudio files 11 | .Rproj.user 12 | 13 | # Doc stuff to ignore 14 | tests/visual_tests/*.html 15 | tests/visual_tests/*.css 16 | inst/doc 17 | doc 18 | Meta 19 | *.tex 20 | revdep 21 | /doc/ 22 | /Meta/ 23 | -------------------------------------------------------------------------------- /R/tidyHtmlTable_helpers_extractElementsAndConvertToTbl.R: -------------------------------------------------------------------------------- 1 | #' Extract the elements and generate a table with unique elements 2 | #' 3 | #' @param x `list` with columns to be joined 4 | #' @param elements `char` vector with the elements to select 5 | prExtractElementsAndConvertToTbl <- function(x, elements) { 6 | x[elements] %>% 7 | prBindDataListIntoColumns() %>% 8 | dplyr::distinct() 9 | } 10 | -------------------------------------------------------------------------------- /R/tidyHtmlTable_helpers_getColTbl.R: -------------------------------------------------------------------------------- 1 | getColTbl <- function(x) { 2 | out <- prExtractElementsAndConvertToTbl(x, elements = c("cgroup", "header")) %>% 3 | dplyr::arrange_all() %>% 4 | # This is necessary in order to not generate NA values when setting 5 | # hidden elements to "" 6 | dplyr::mutate_if(is.factor, as.character) 7 | 8 | out$c_idx <- 1:nrow(out) 9 | return(out) 10 | } 11 | -------------------------------------------------------------------------------- /R/htmlTable_helpers_skipRownames.R: -------------------------------------------------------------------------------- 1 | #' Returns if rownames should be printed for the htmlTable 2 | #' 3 | #' @inheritParams htmlTable 4 | #' @keywords internal 5 | prSkipRownames <- function(rnames) { 6 | if (missing(rnames) || is.null(rnames) || length(rnames) == 0) { 7 | return(TRUE) 8 | } 9 | 10 | if (length(rnames) == 1 && rnames == FALSE) { 11 | return(TRUE) 12 | } 13 | 14 | return(FALSE) 15 | } 16 | -------------------------------------------------------------------------------- /tests/testthat/test-htmlTable-input_checks.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library('magrittr', warn.conflicts = FALSE) 3 | library('XML', warn.conflicts = FALSE) 4 | 5 | # Check that a css.cell passes without errors 6 | test_that("Check css.cell input", { 7 | expect_match(matrix(1:6, ncol=3) %>% 8 | addHtmlTableStyle(css.cell="background: red") %>% 9 | htmlTable, 10 | "background: red") 11 | }) 12 | -------------------------------------------------------------------------------- /man/prIsNotebook.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/htmlTable_helpers_isNotebook.R 3 | \name{prIsNotebook} 4 | \alias{prIsNotebook} 5 | \title{Detects if the call is made from within an RStudio Rmd file or a file 6 | with the html_notebook output set.} 7 | \usage{ 8 | prIsNotebook() 9 | } 10 | \description{ 11 | Detects if the call is made from within an RStudio Rmd file or a file 12 | with the html_notebook output set. 13 | } 14 | \keyword{internal} 15 | -------------------------------------------------------------------------------- /htmlTable.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: knitr 13 | LaTeX: pdfLaTeX 14 | 15 | StripTrailingWhitespace: Yes 16 | 17 | BuildType: Package 18 | PackageUseDevtools: Yes 19 | PackageInstallArgs: --no-multiarch --with-keep.source 20 | PackageCheckArgs: --as-cran 21 | PackageRoxygenize: rd,collate,namespace 22 | -------------------------------------------------------------------------------- /R/data-SCB.R: -------------------------------------------------------------------------------- 1 | #' Average age in Sweden 2 | #' 3 | #' For the vignettes there is a dataset downloaded by using the 4 | #' `get_pxweb_data()` call. The data is from 5 | #' SCB ([Statistics Sweden](https://www.scb.se//)) and downloaded 6 | #' using the [pxweb package](https://github.com/rOpenGov/pxweb): 7 | #' 8 | #' @example inst/examples/data-SCB_example.R 9 | #' 10 | #' @name SCB 11 | #' @docType data 12 | #' @author Max Gordon \email{max@@gforge.se} 13 | #' @references 14 | #' @keywords data 15 | NULL -------------------------------------------------------------------------------- /man/prGetScriptString.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/interactiveTable.R 3 | \name{prGetScriptString} 4 | \alias{prGetScriptString} 5 | \title{Gets a string with all the scripts merged into one script tag} 6 | \usage{ 7 | prGetScriptString(x) 8 | } 9 | \arguments{ 10 | \item{x}{An interactiveTable} 11 | } 12 | \value{ 13 | string 14 | } 15 | \description{ 16 | Each element has it's own script tags in otherwise an error will cause 17 | all the scripts to fail. 18 | } 19 | \keyword{internal} 20 | -------------------------------------------------------------------------------- /man/outputInt.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/deprecated.R 3 | \name{outputInt} 4 | \alias{outputInt} 5 | \title{Deprecated use \code{\link[=txtInt]{txtInt()}} instead.} 6 | \usage{ 7 | outputInt(...) 8 | } 9 | \arguments{ 10 | \item{...}{Passed to \code{\link[=txtInt]{txtInt()}}} 11 | } 12 | \description{ 13 | Deprecated use \code{\link[=txtInt]{txtInt()}} instead. 14 | } 15 | \examples{ 16 | \dontrun{ 17 | # Deprecated function 18 | outputInt(123456) 19 | } 20 | 21 | } 22 | \keyword{internal} 23 | -------------------------------------------------------------------------------- /R/tidyHtmlTable_helpers_bindDataListIntoColumns.r: -------------------------------------------------------------------------------- 1 | #' Merge columns into a tibble 2 | #' 3 | #' Almost the same as [tibble::tibble()] but it solves the issue 4 | #' with some of the arguments being columns and some just being vectors. 5 | #' 6 | #' @param dataList `list` with the columns/data.frames 7 | #' @return `data.frame` object 8 | prBindDataListIntoColumns <- function(dataList) { 9 | stopifnot(is.list(dataList)) 10 | dataList %>% 11 | purrr::keep(~ !is.null(.)) %>% 12 | do.call(dplyr::bind_cols, .) %>% 13 | tibble::as_tibble() 14 | } 15 | -------------------------------------------------------------------------------- /R/tidyHtmlTable_helpers_getRowTbl.r: -------------------------------------------------------------------------------- 1 | getRowTbl <- function(x) { 2 | out <- prExtractElementsAndConvertToTbl(x, 3 | elements = c("tspanner", "rgroup", "rnames", "rnames_unique") 4 | ) %>% 5 | dplyr::arrange() %>% 6 | # This is necessary in order to not generate NA values when setting 7 | # hidden elements to "" and this can't be in prExtractElementsAndConvertToTbl 8 | # as we need to be able to sort according to the column in getColTbl 9 | dplyr::mutate_if(is.factor, as.character) 10 | 11 | out$r_idx <- 1:nrow(out) 12 | return(out) 13 | } 14 | -------------------------------------------------------------------------------- /man/getHtmlTableTheme.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/htmlTable_theme.R 3 | \name{getHtmlTableTheme} 4 | \alias{getHtmlTableTheme} 5 | \title{Retrieve the \code{\link[=htmlTable]{htmlTable()}} theme list} 6 | \usage{ 7 | getHtmlTableTheme() 8 | } 9 | \value{ 10 | \code{list} with the styles to be applied to the table 11 | } 12 | \description{ 13 | A wrapper for a \code{\link[base:options]{getOption("htmlTable.theme")()}} call that 14 | returns the standard theme unless one is set. 15 | } 16 | \examples{ 17 | getHtmlTableTheme() 18 | } 19 | -------------------------------------------------------------------------------- /man/splitLines4Table.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/deprecated.R 3 | \name{splitLines4Table} 4 | \alias{splitLines4Table} 5 | \title{See \code{\link[=txtMergeLines]{txtMergeLines()}}} 6 | \usage{ 7 | splitLines4Table(...) 8 | } 9 | \arguments{ 10 | \item{...}{passed onto \code{\link[=txtMergeLines]{txtMergeLines()}}} 11 | } 12 | \description{ 13 | See \code{\link[=txtMergeLines]{txtMergeLines()}} 14 | } 15 | \examples{ 16 | \dontrun{ 17 | # Deprecated function 18 | splitLines4Table("hello", "world") 19 | } 20 | } 21 | \keyword{internal} 22 | -------------------------------------------------------------------------------- /man/innerJoinByCommonCols.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/tidyHtmlTable_helpers_innerJoinByCommonCols.r 3 | \name{innerJoinByCommonCols} 4 | \alias{innerJoinByCommonCols} 5 | \title{A simple function for joining two tables by their 6 | intersected columns} 7 | \usage{ 8 | innerJoinByCommonCols(x, y) 9 | } 10 | \arguments{ 11 | \item{x}{\code{data.frame}} 12 | 13 | \item{y}{\code{data.frame}} 14 | } 15 | \value{ 16 | \code{data.frame} 17 | } 18 | \description{ 19 | A simple function for joining two tables by their 20 | intersected columns 21 | } 22 | -------------------------------------------------------------------------------- /man/pvalueFormatter.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/deprecated.R 3 | \name{pvalueFormatter} 4 | \alias{pvalueFormatter} 5 | \title{Deprecated use \code{\link[=txtPval]{txtPval()}} instead} 6 | \usage{ 7 | pvalueFormatter(...) 8 | } 9 | \arguments{ 10 | \item{...}{Currently only used for generating warnings of deprecated call} 11 | } 12 | \description{ 13 | Deprecated use \code{\link[=txtPval]{txtPval()}} instead 14 | } 15 | \examples{ 16 | \dontrun{ 17 | # Deprecated function 18 | pvalueFormatter(c(0.10234,0.010234, 0.0010234, 0.000010234)) 19 | } 20 | } 21 | \keyword{internal} 22 | -------------------------------------------------------------------------------- /R/htmlTable_helpers_escapeHtml.R: -------------------------------------------------------------------------------- 1 | #' Remove html entities from table 2 | #' 3 | #' Removes the htmlEntities from table input data. Note that 4 | #' this also replaces $ signs in order to remove the MathJax 5 | #' issue. 6 | #' 7 | #' @importFrom htmltools htmlEscape 8 | #' 9 | #' @inheritParams htmlTable 10 | #' @return `x` without the html entities 11 | #' @family hidden helper functions for htmlTable 12 | prEscapeHtml <- function(x) { 13 | attributes_x <- attributes(x) 14 | x <- lapply(x, htmlEscape) 15 | x <- lapply(x, function(x) str_replace_all(x, "\\$", "$")) 16 | attributes(x) <- attributes_x 17 | return(x) 18 | } 19 | -------------------------------------------------------------------------------- /man/prepGroupCounts.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/prepGroupCounts.R 3 | \name{prepGroupCounts} 4 | \alias{prepGroupCounts} 5 | \title{Retrieves counts for rgroup, cgroup, & tspanner arguments} 6 | \usage{ 7 | prepGroupCounts(x) 8 | } 9 | \arguments{ 10 | \item{x}{The vector to process} 11 | } 12 | \value{ 13 | \code{list(n = rle$lengths, names = rle$values)} 14 | } 15 | \description{ 16 | This function is a wrapper to \code{\link[base:rle]{base::rle()}} that 17 | does exactly this but is a little too picky about input values. 18 | } 19 | \examples{ 20 | prepGroupCounts(c(1:3, 3:1)) 21 | } 22 | -------------------------------------------------------------------------------- /man/prExtractElementsAndConvertToTbl.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in 3 | % R/tidyHtmlTable_helpers_extractElementsAndConvertToTbl.R 4 | \name{prExtractElementsAndConvertToTbl} 5 | \alias{prExtractElementsAndConvertToTbl} 6 | \title{Extract the elements and generate a table with unique elements} 7 | \usage{ 8 | prExtractElementsAndConvertToTbl(x, elements) 9 | } 10 | \arguments{ 11 | \item{x}{\code{list} with columns to be joined} 12 | 13 | \item{elements}{\code{char} vector with the elements to select} 14 | } 15 | \description{ 16 | Extract the elements and generate a table with unique elements 17 | } 18 | -------------------------------------------------------------------------------- /man/prBindDataListIntoColumns.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/tidyHtmlTable_helpers_bindDataListIntoColumns.r 3 | \name{prBindDataListIntoColumns} 4 | \alias{prBindDataListIntoColumns} 5 | \title{Merge columns into a tibble} 6 | \usage{ 7 | prBindDataListIntoColumns(dataList) 8 | } 9 | \arguments{ 10 | \item{dataList}{\code{list} with the columns/data.frames} 11 | } 12 | \value{ 13 | \code{data.frame} object 14 | } 15 | \description{ 16 | Almost the same as \code{\link[tibble:tibble]{tibble::tibble()}} but it solves the issue 17 | with some of the arguments being columns and some just being vectors. 18 | } 19 | -------------------------------------------------------------------------------- /R/htmlTable_helpers_convertDfFactors.R: -------------------------------------------------------------------------------- 1 | #' Convert all factors to characters to print them as they expected 2 | #' 3 | #' @inheritParams htmlTable 4 | #' @return The data frame with factors as characters 5 | prConvertDfFactors <- function(x) { 6 | if (!"data.frame" %in% class(x)) { 7 | return(x) 8 | } 9 | 10 | i <- sapply(x, function(col) { 11 | ( 12 | ( 13 | !is.numeric(col) && 14 | !is.character(col) 15 | ) || 16 | ( 17 | inherits(col, "times") # For handlin Chron input 18 | ) 19 | ) 20 | }) 21 | 22 | if (any(i)) { 23 | x[i] <- lapply(x[i], as.character) 24 | } 25 | 26 | return(x) 27 | } 28 | -------------------------------------------------------------------------------- /man/prConvertDfFactors.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/htmlTable_helpers_convertDfFactors.R 3 | \name{prConvertDfFactors} 4 | \alias{prConvertDfFactors} 5 | \title{Convert all factors to characters to print them as they expected} 6 | \usage{ 7 | prConvertDfFactors(x) 8 | } 9 | \arguments{ 10 | \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} 11 | it takes a string of the class \code{htmlTable} as \code{x} argument.} 12 | } 13 | \value{ 14 | The data frame with factors as characters 15 | } 16 | \description{ 17 | Convert all factors to characters to print them as they expected 18 | } 19 | -------------------------------------------------------------------------------- /man/prPrepareColors.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/htmlTable_helpers_prepareColors.R 3 | \name{prPrepareColors} 4 | \alias{prPrepareColors} 5 | \title{Prepares the alternating colors} 6 | \usage{ 7 | prPrepareColors(clr, n = NULL, ng = NULL, gtxt) 8 | } 9 | \arguments{ 10 | \item{clr}{The colors} 11 | 12 | \item{n}{The number of rows/columns applicable to the color} 13 | 14 | \item{ng}{The n.rgroup/n.cgroup argument if applicable} 15 | 16 | \item{gtxt}{The rgroup/cgroup texts} 17 | } 18 | \value{ 19 | \code{character} A vector containing hexadecimal colors 20 | } 21 | \description{ 22 | Prepares the alternating colors 23 | } 24 | \keyword{internal} 25 | -------------------------------------------------------------------------------- /R/prepGroupCounts.R: -------------------------------------------------------------------------------- 1 | #' Retrieves counts for rgroup, cgroup, & tspanner arguments 2 | #' 3 | #' This function is a wrapper to [base::rle()] that 4 | #' does exactly this but is a little too picky about input values. 5 | #' 6 | #' @param x The vector to process 7 | #' @return `list(n = rle$lengths, names = rle$values)` 8 | #' @export 9 | #' @examples 10 | #' prepGroupCounts(c(1:3, 3:1)) 11 | prepGroupCounts <- function(x) { 12 | # Drop all classes but the base class as rle 13 | counts <- rle(as.vector(x)) 14 | ret <- list( 15 | n = counts$lengths, 16 | idx = cumsum(counts$lengths), 17 | names = counts$values 18 | ) 19 | structure(ret, 20 | class = c("htmlTable_group_count", class(ret)) 21 | ) 22 | } 23 | -------------------------------------------------------------------------------- /man/prMergeClr.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/htmlTable_helpers_mergeClr.R 3 | \name{prMergeClr} 4 | \alias{prMergeClr} 5 | \title{Merges multiple colors} 6 | \usage{ 7 | prMergeClr(clrs) 8 | } 9 | \arguments{ 10 | \item{clrs}{The colors} 11 | } 12 | \value{ 13 | \code{character} A hexadecimal color 14 | } 15 | \description{ 16 | Uses the \code{\link[grDevices:colorRamp]{colorRampPalette()}} for merging colors. 17 | \emph{Note:} When merging more than 2 colors the order in the color 18 | presentation matters. Each color is merged with its neigbors before 19 | merging with next. If there is an uneven number of colors the middle 20 | color is mixed with both left and right side. 21 | } 22 | \keyword{internal} 23 | -------------------------------------------------------------------------------- /tests/testthat/test-txtMergeLines.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | context("Test txtMergeLines") 3 | 4 | test_that("Check one argument with multiple new lines",{ 5 | out <- txtMergeLines("a 6 | b") 7 | expect_equal(length(gregexpr("
", out)[[1]]), 8 | 1) 9 | 10 | out <- txtMergeLines("a 11 | b 12 | c") 13 | expect_equal(length(gregexpr("
", out)[[1]]), 14 | 2) 15 | }) 16 | 17 | test_that("Check multiple arguments",{ 18 | out <- txtMergeLines("a", "b") 19 | expect_equal(length(gregexpr("
", out)[[1]]), 20 | 1) 21 | 22 | out <- txtMergeLines("a", "b", "c") 23 | expect_equal(length(gregexpr("
", out)[[1]]), 24 | 2) 25 | }) -------------------------------------------------------------------------------- /man/prAttr4RgroupAdd.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/htmlTable_helpers_attr4RgroupAdd.R 3 | \name{prAttr4RgroupAdd} 4 | \alias{prAttr4RgroupAdd} 5 | \title{Get the add attribute element} 6 | \usage{ 7 | prAttr4RgroupAdd(rgroup, rgroup_iterator, no_cols) 8 | } 9 | \arguments{ 10 | \item{rgroup}{A vector of character strings containing headings for row groups. 11 | \code{n.rgroup} must be present when \code{rgroup} is given. See 12 | detailed description in section below.} 13 | 14 | \item{rgroup_iterator}{The rgroup number of interest} 15 | 16 | \item{no_cols}{The \code{ncol(x)} of the core htmlTable x argument} 17 | } 18 | \description{ 19 | Gets the add element attribute if it exists. If non-existant it will 20 | return NULL. 21 | } 22 | \keyword{internal} 23 | -------------------------------------------------------------------------------- /man/tblNoLast.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/tblNo.R 3 | \name{tblNoLast} 4 | \alias{tblNoLast} 5 | \title{Gets the last table number} 6 | \usage{ 7 | tblNoLast(roman = getOption("table_counter_roman", FALSE)) 8 | } 9 | \arguments{ 10 | \item{roman}{Whether or not to use roman numbers instead 11 | of arabic. Can also be set through \code{options(table_caption_no_roman = TRUE)}} 12 | } 13 | \description{ 14 | The function relies on \code{options("table_counter")} 15 | in order to keep track of the last number. 16 | } 17 | \examples{ 18 | org_opts <- options(table_counter=1) 19 | tblNoLast() 20 | options(org_opts) 21 | } 22 | \seealso{ 23 | Other table functions: 24 | \code{\link{htmlTable}}, 25 | \code{\link{tblNoNext}()} 26 | } 27 | \concept{table functions} 28 | -------------------------------------------------------------------------------- /man/tblNoNext.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/tblNo.R 3 | \name{tblNoNext} 4 | \alias{tblNoNext} 5 | \title{Gets the next table number} 6 | \usage{ 7 | tblNoNext(roman = getOption("table_counter_roman", FALSE)) 8 | } 9 | \arguments{ 10 | \item{roman}{Whether or not to use roman numbers instead 11 | of arabic. Can also be set through \code{options(table_caption_no_roman = TRUE)}} 12 | } 13 | \description{ 14 | The function relies on \code{options("table_counter")} 15 | in order to keep track of the last number. 16 | } 17 | \examples{ 18 | org_opts <- options(table_counter=1) 19 | tblNoNext() 20 | options(org_opts) 21 | } 22 | \seealso{ 23 | Other table functions: 24 | \code{\link{htmlTable}}, 25 | \code{\link{tblNoLast}()} 26 | } 27 | \concept{table functions} 28 | -------------------------------------------------------------------------------- /man/prSkipRownames.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/htmlTable_helpers_skipRownames.R 3 | \name{prSkipRownames} 4 | \alias{prSkipRownames} 5 | \title{Returns if rownames should be printed for the htmlTable} 6 | \usage{ 7 | prSkipRownames(rnames) 8 | } 9 | \arguments{ 10 | \item{rnames}{Default row names are generated from \code{\link[base:colnames]{rownames(x)}}. If you 11 | provide \code{FALSE} then it will skip the row names. \emph{Note:} For \code{data.frames} 12 | if you do \code{\link[base:colnames]{rownames(my_dataframe) <- NULL}} it still has 13 | row names. Thus you need to use \code{FALSE} if you want to 14 | supress row names for \code{data.frames}.} 15 | } 16 | \description{ 17 | Returns if rownames should be printed for the htmlTable 18 | } 19 | \keyword{internal} 20 | -------------------------------------------------------------------------------- /man/getHtmlTableStyle.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/htmlTable_style_handlers.R 3 | \name{getHtmlTableStyle} 4 | \alias{getHtmlTableStyle} 5 | \title{Get style options for object} 6 | \usage{ 7 | getHtmlTableStyle(x) 8 | } 9 | \arguments{ 10 | \item{x}{The object intended for \code{\link[=htmlTable]{htmlTable()}}.} 11 | } 12 | \value{ 13 | A \code{list} if the attribute exists, otherwise \code{NULL} 14 | } 15 | \description{ 16 | A wrap around the \code{\link[base:attr]{base::attr()}} that retrieves the style 17 | attribute used by \code{\link[=htmlTable]{htmlTable()}} (\code{htmlTable.style}). 18 | } 19 | \examples{ 20 | library(magrittr) 21 | 22 | mx <- matrix(1:4, ncol = 2) 23 | colnames(mx) <- LETTERS[1:2] 24 | mx \%>\% 25 | addHtmlTableStyle(align = "l|r") \%>\% 26 | getHtmlTableStyle() 27 | } 28 | -------------------------------------------------------------------------------- /man/vector2string.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/vector2string.R 3 | \name{vector2string} 4 | \alias{vector2string} 5 | \title{Collapse vector to string} 6 | \usage{ 7 | vector2string( 8 | x, 9 | quotation_mark = "'", 10 | collapse = sprintf("\%s, \%s", quotation_mark, quotation_mark) 11 | ) 12 | } 13 | \arguments{ 14 | \item{x}{The vector to collapse} 15 | 16 | \item{quotation_mark}{The type of quote to use} 17 | 18 | \item{collapse}{The string that separates each element} 19 | } 20 | \value{ 21 | A string with \code{', '} separation 22 | } 23 | \description{ 24 | Merges all the values and outputs a string 25 | formatted as '1st element', '2nd element', ... 26 | } 27 | \examples{ 28 | vector2string(1:4) 29 | vector2string(c("a", "b'b", "c")) 30 | vector2string(c("a", "b'b", "c"), quotation_mark = '"') 31 | } 32 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/bug_report.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Bug report 3 | about: Create a report to help us improve 4 | 5 | --- 6 | 7 | **Describe the bug** 8 | A clear and concise description of what the bug is. Please check [StackOverflow](https://stackoverflow.com) firs using, tip: use [`[r] htmlTable`](https://stackoverflow.com/search?q=htmltable+%5Br%5D) as the search. 9 | 10 | **To Reproduce** 11 | Steps to reproduce the behavior: 12 | 13 | **Expected behavior** 14 | A clear and concise description of what you expected to happen. 15 | 16 | **Screenshots** 17 | If applicable, add screenshots to help explain your problem. 18 | 19 | **Versions (please complete the following information):** 20 | - OS: [e.g. iOS] 21 | - R IDE: [e.g. RStudio] 22 | - Package version [e.g. 1.12 - make sure you're using the latest] 23 | 24 | **Additional context** 25 | Add any other context about the problem here. 26 | -------------------------------------------------------------------------------- /inst/examples/interactiveTable_example.R: -------------------------------------------------------------------------------- 1 | library(magrittr) 2 | # A simple output 3 | long_txt <- "Lorem ipsum dolor sit amet, consectetur adipiscing elit, 4 | sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. 5 | Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi 6 | ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit 7 | in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur 8 | sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt 9 | mollit anim id est laborum" 10 | short_txt <- gsub("(^[^.]+).*", "\\1", long_txt) 11 | 12 | cbind(rep(short_txt, 2), 13 | rep(long_txt, 2)) %>% 14 | addHtmlTableStyle(col.rgroup = c("#FFF", "#EEF")) %>% 15 | interactiveTable(minimized.columns = ncol(.), 16 | header = c("Short", "Long"), 17 | rnames = c("First", "Second")) 18 | -------------------------------------------------------------------------------- /R/tidyHtmlTable_helpers_checkUniqueness.r: -------------------------------------------------------------------------------- 1 | # This checks to make sure that the mapping columns of the tidy dataset 2 | # uniquely specify a given value 3 | checkUniqueness <- function(tidyTableDataList) { 4 | tidyTableData <- do.call(cbind, tidyTableDataList) 5 | dupes <- tidyTableData %>% duplicated() 6 | if (sum(dupes) != 0) { 7 | core_msg <- paste0("The input parameters ", 8 | paste(paste0("\"", names(tidyTableData), "\""), collapse = ", "), 9 | " do not specify unique rows, have you forgotten one?.") 10 | duplicated_rows <- paste0("The following rows are duplicated: ", paste(which(dupes), collapse = ", ")) 11 | if (is.null(tidyTableDataList$rnames_unique)) { 12 | core_msg <- paste(core_msg, 13 | "Check if you intended to provide the rnames_unique (see the help page).") 14 | } 15 | stop(core_msg, "\n", duplicated_rows) 16 | } 17 | } 18 | -------------------------------------------------------------------------------- /inst/javascript/button.js: -------------------------------------------------------------------------------- 1 | $(document).ready(function(){ 2 | // Placeholder for button 3 | btn = "%btn%"; 4 | 5 | // Ad the button to each element 6 | $(".gmisc_table td").map(function(index, el){ 7 | if (el.innerHTML.length > %txt.maxlen% && el.getElementsByClassName("btn").length == 0) 8 | el.innerHTML += btn; 9 | }) 10 | 11 | $(".gmisc_table td .btn").map(function(index, el){ 12 | el.onclick = function(e){ 13 | var hidden = this.parentNode.getElementsByClassName("hidden"); 14 | if (this.textContent === "+"){ 15 | this.parentNode.childNodes[0].data = hidden[0].textContent; 16 | this.textContent = "-"; 17 | }else{ 18 | $(this.parentNode).append("") 19 | this.parentNode.childNodes[0].data = this.parentNode.textContent.substr(0, %txt.maxlen%) + "... "; 20 | this.textContent = "+"; 21 | } 22 | } 23 | }) 24 | }) 25 | -------------------------------------------------------------------------------- /man/prGetAlign.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/htmlTable_helpers_getAlign.R 3 | \name{prGetAlign} 4 | \alias{prGetAlign} 5 | \title{Gets alignment} 6 | \usage{ 7 | prGetAlign( 8 | align, 9 | index, 10 | style_list = NULL, 11 | spacerCell = FALSE, 12 | followed_by_spacer_cell = FALSE, 13 | previous_was_spacer_cell = FALSE 14 | ) 15 | } 16 | \arguments{ 17 | \item{align}{A character strings specifying column alignments, defaulting to \code{'c'} 18 | to center. Valid chars for alignments are l = left, c = center and r = right. You can also specify 19 | \code{align='c|c'} and other LaTeX tabular formatting. If you want to set the alignment of the 20 | rownames this string needst to be \code{ncol(x) + 1}, otherwise it automatically 21 | pads the string with a left alignment for the rownames.} 22 | 23 | \item{index}{The index of the align parameter of interest} 24 | } 25 | \description{ 26 | Gets alignment 27 | } 28 | \concept{hidden helper functions for} 29 | \keyword{internal} 30 | -------------------------------------------------------------------------------- /man/hasHtmlTableStyle.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/htmlTable_style_handlers.R 3 | \name{hasHtmlTableStyle} 4 | \alias{hasHtmlTableStyle} 5 | \title{Check if object has a style set to it} 6 | \usage{ 7 | hasHtmlTableStyle(x, style_name) 8 | } 9 | \arguments{ 10 | \item{x}{The object intended for \code{\link[=htmlTable]{htmlTable()}}.} 11 | 12 | \item{style_name}{A string that contains the style name.} 13 | } 14 | \value{ 15 | \code{logical} \code{TRUE} if the attribute and style is not \code{NULL} 16 | } 17 | \description{ 18 | If the attribute \code{htmlTable.style} is set it will check if 19 | the \code{style_name} exists and return a \code{logical}. 20 | } 21 | \examples{ 22 | library(magrittr) 23 | 24 | mx <- matrix(1:4, ncol = 2) 25 | colnames(mx) <- LETTERS[1:2] 26 | mx \%>\% 27 | addHtmlTableStyle(align = "l|r") \%>\% 28 | hasHtmlTableStyle("align") 29 | } 30 | \seealso{ 31 | Other htmlTableStyle: 32 | \code{\link{addHtmlTableStyle}()} 33 | } 34 | \concept{htmlTableStyle} 35 | -------------------------------------------------------------------------------- /R/tidyHtmlTable_helpers_prAssertAndRetrieveValue.R: -------------------------------------------------------------------------------- 1 | prAssertAndRetrieveValue <- function(x, 2 | value, 3 | name = deparse(substitute(value)), 4 | maxCols = 1, 5 | optional = FALSE) { 6 | if (missing(value)) { 7 | if (is.null(x[[name]])) { 8 | if (optional) { 9 | return(NULL) 10 | } 11 | 12 | stop( 13 | "You have not provided an argument", 14 | " and the data frame does not have a '", name, "' column" 15 | ) 16 | } 17 | return(x[[name]]) 18 | } 19 | 20 | # We are one-caller removed from the original call so we need to 21 | # do this nasty hack to get the parameter of the parent function 22 | orgName <- eval(substitute(substitute(value)), envir = parent.frame()) 23 | value <- dplyr::select(x, {{orgName}}) 24 | stopifnot(ncol(value) <= maxCols) 25 | if (maxCols > 1) { 26 | return(value) 27 | } 28 | 29 | return(value[[1]]) 30 | } 31 | -------------------------------------------------------------------------------- /tests/testthat/test-theming.R: -------------------------------------------------------------------------------- 1 | require(testthat) 2 | 3 | context('Theming for htmlTable') 4 | 5 | # A simple example 6 | test_that("Get current themes", { 7 | theme <- getHtmlTableTheme() 8 | expect_list(theme, names = "unique") 9 | valid_names <- Filter(function(x) !(x %in% c("theme", "")), 10 | names(as.list(setHtmlTableTheme))) 11 | expect_true(all(names(theme) %in% valid_names)) 12 | }) 13 | 14 | test_that("Set current theme", { 15 | newTheme <- setHtmlTableTheme(align = "l") 16 | theme <- getHtmlTableTheme() 17 | 18 | expect_equal(newTheme, theme) 19 | expect_equal(theme$align, "l") 20 | }) 21 | 22 | 23 | test_that("Style assertions", { 24 | expect_error(prAssertStyles(list("a")), regexp = "Must have names") 25 | expect_error(prAssertStyles(list(css.rgroup = "height: 100px", css.rnames = "width")), regexp = "css.rnames") 26 | expect_true(prAssertStyles(list(css.rnames = "width: 100px"))) 27 | 28 | expect_error(prAssertStyles(list(css.rnames = "width: 100px", css.tspanner = list(a = 2))), regexp = "list") 29 | }) 30 | -------------------------------------------------------------------------------- /R/htmlTable_helpers_prepInputMatrixDimensions.R: -------------------------------------------------------------------------------- 1 | #' Makes sure the input is correct 2 | #' 3 | #' Checks and converts dimensions into something the 4 | #' [htmlTable()] is comfortable with. 5 | #' 6 | #' @inheritParams htmlTable 7 | #' @keywords internal 8 | #' @family hidden helper functions for htmlTable 9 | prPrepInputMatrixDimensions <- function(x, header = NULL) { 10 | if (!is.null(dim(x))) { 11 | if (length(dim(x)) != 2) { 12 | stop( 13 | "Your table variable seems to have the wrong dimension,", 14 | " length(dim(x)) = ", length(dim(x)), " != 2" 15 | ) 16 | } 17 | return(x) 18 | } 19 | 20 | preset_styles <- getHtmlTableStyle(x) 21 | 22 | if (!is.numeric(x) && !is.character(x)) { 23 | x <- as.character(x) 24 | } 25 | 26 | ncol <- length(x) 27 | if (!is.null(header)) { 28 | ncol <- length(header) 29 | } 30 | 31 | ret <- matrix(x, ncol = ncol) 32 | 33 | # We need to make sures that the style info has been retained throughout 34 | attr(ret, style_attribute_name) <- preset_styles 35 | return(ret) 36 | } 37 | -------------------------------------------------------------------------------- /man/prAddSemicolon2StrEnd.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/htmlTable_helpers_addSemicolon2StrEnd.R 3 | \name{prAddSemicolon2StrEnd} 4 | \alias{prAddSemicolon2StrEnd} 5 | \title{Add a ; at the end} 6 | \usage{ 7 | prAddSemicolon2StrEnd(my_str) 8 | } 9 | \arguments{ 10 | \item{my_str}{The string that is to be processed} 11 | } 12 | \value{ 13 | \code{string} 14 | } 15 | \description{ 16 | The CSS expects a semicolon at the end of each argument 17 | this function just adds a semicolong if none is given 18 | and remove multiple semicolon if such exist 19 | } 20 | \seealso{ 21 | Other hidden helper functions for htmlTable: 22 | \code{\link{prAddCells}()}, 23 | \code{\link{prAddEmptySpacerCell}()}, 24 | \code{\link{prEscapeHtml}()}, 25 | \code{\link{prGetCgroupHeader}()}, 26 | \code{\link{prGetRowlabelPos}()}, 27 | \code{\link{prGetStyle}()}, 28 | \code{\link{prPrepInputMatrixDimensions}()}, 29 | \code{\link{prPrepareAlign}()}, 30 | \code{\link{prPrepareCgroup}()}, 31 | \code{\link{prTblNo}()} 32 | } 33 | \concept{hidden helper functions for htmlTable} 34 | \keyword{internal} 35 | -------------------------------------------------------------------------------- /inst/examples/data-SCB_example.R: -------------------------------------------------------------------------------- 1 | \dontrun{ 2 | # The data was generated through downloading via the API 3 | library(pxweb) 4 | 5 | # Get the last 15 years of data (the data always lags 1 year) 6 | current_year <- as.integer(format(Sys.Date(), "%Y")) -1 7 | SCB <- get_pxweb_data( 8 | url = "http://api.scb.se/OV0104/v1/doris/en/ssd/BE/BE0101/BE0101B/BefolkningMedelAlder", 9 | dims = list(Region = c('00', '01', '03', '25'), 10 | Kon = c('1', '2'), 11 | ContentsCode = c('BE0101G9'), 12 | Tid = (current_year-14):current_year), 13 | clean = TRUE) 14 | 15 | # Some cleaning was needed before use 16 | SCB$region <- factor(substring(as.character(SCB$region), 4)) 17 | Swe_ltrs <- c("å" = "å", 18 | "Å" = "Å", 19 | "ä" = "ä", 20 | "Ä" = "Ä", 21 | "ö" = "ö", 22 | "Ö" = "Ö") 23 | for (i in 1:length(Swe_ltrs)){ 24 | levels(SCB$region) <- gsub(names(Swe_ltrs)[i], 25 | Swe_ltrs[i], 26 | levels(SCB$region)) 27 | } 28 | 29 | save(SCB, file = "data/SCB.rda") 30 | } 31 | -------------------------------------------------------------------------------- /R/tidyHtmlTable_helpers_removeRowsWithNA.r: -------------------------------------------------------------------------------- 1 | # Removes rows containing NA values in any mapped columns from the tidy dataset 2 | removeRowsWithNA <- function(tidyTableDataList, skip_removal_warning = FALSE) { 3 | tidyTableData <- tidyTableDataList %>% tibble::as_tibble() 4 | 5 | hasNA <- tidyTableData %>% is.na() 6 | 7 | naPerRow <- hasNA %>% 8 | rowSums() 9 | 10 | keepIdx <- naPerRow == 0 11 | removed <- sum(naPerRow > 0) 12 | 13 | if (removed != 0) { 14 | naPerCol <- hasNA %>% colSums() 15 | naColumns <- colnames(hasNA)[naPerCol > 0] 16 | if (!skip_removal_warning) { 17 | warning(paste0( 18 | "NA values were detected in the following columns of ", 19 | "the tidy dataset: ", 20 | paste(naColumns, collapse = ", "), ". ", 21 | removed, " row(s) in the tidy dataset were removed." 22 | )) 23 | } 24 | } 25 | 26 | return(sapply(tidyTableDataList, 27 | function(x) { 28 | if (is.data.frame(x)) { 29 | return(x %>% dplyr::filter(keepIdx)) 30 | } 31 | 32 | return(x[keepIdx]) 33 | }, 34 | simplify = FALSE 35 | )) 36 | } 37 | -------------------------------------------------------------------------------- /tests/visual_tests/pandoc_test.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Pandoc test" 3 | output: 4 | html_document 5 | editor_options: 6 | chunk_output_type: inline 7 | --- 8 | 9 | ```{r} 10 | library(htmlTable) 11 | library(magrittr) 12 | mx <- matrix(1:4, ncol = 2) %>% 13 | set_colnames(c("A åäö¨", "B")) %>% 14 | set_rownames(letters[1:2]) 15 | mx %>% 16 | addHtmlTableStyle(align = "r|r") %>% 17 | htmlTable(cgroup = c("Some c-group", ""), 18 | n.cgroup = 1) 19 | ``` 20 | 21 | 22 | ```{r} 23 | mx[1] <- "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum" 24 | colnames(mx)[1] <- c("A") 25 | rownames(mx)[1] <- letters[1] 26 | interactiveTable(mx) 27 | ``` 28 | 29 | 30 | ```{r} 31 | mx <- matrix(rep(mx[1], 6), ncol = 2) 32 | interactiveTable(mx) 33 | ``` 34 | 35 | -------------------------------------------------------------------------------- /man/prEscapeHtml.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/htmlTable_helpers_escapeHtml.R 3 | \name{prEscapeHtml} 4 | \alias{prEscapeHtml} 5 | \title{Remove html entities from table} 6 | \usage{ 7 | prEscapeHtml(x) 8 | } 9 | \arguments{ 10 | \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} 11 | it takes a string of the class \code{htmlTable} as \code{x} argument.} 12 | } 13 | \value{ 14 | \code{x} without the html entities 15 | } 16 | \description{ 17 | Removes the htmlEntities from table input data. Note that 18 | this also replaces $ signs in order to remove the MathJax 19 | issue. 20 | } 21 | \seealso{ 22 | Other hidden helper functions for htmlTable: 23 | \code{\link{prAddCells}()}, 24 | \code{\link{prAddEmptySpacerCell}()}, 25 | \code{\link{prAddSemicolon2StrEnd}()}, 26 | \code{\link{prGetCgroupHeader}()}, 27 | \code{\link{prGetRowlabelPos}()}, 28 | \code{\link{prGetStyle}()}, 29 | \code{\link{prPrepInputMatrixDimensions}()}, 30 | \code{\link{prPrepareAlign}()}, 31 | \code{\link{prPrepareCgroup}()}, 32 | \code{\link{prTblNo}()} 33 | } 34 | \concept{hidden helper functions for htmlTable} 35 | -------------------------------------------------------------------------------- /R/htmlTable_helpers_isNotebook.R: -------------------------------------------------------------------------------- 1 | #' Detects if the call is made from within an RStudio Rmd file or a file 2 | #' with the html_notebook output set. 3 | #' @importFrom rstudioapi isAvailable getActiveDocumentContext 4 | #' @keywords internal 5 | prIsNotebook <- function() { 6 | if (!isAvailable()) { 7 | return(FALSE) 8 | } 9 | 10 | ctxt <- getActiveDocumentContext() 11 | if (grepl("\\.Rmd$", ctxt$path)) { 12 | return(prCheck4output2console(ctxt)) 13 | } 14 | 15 | # Look for html_notebook within the header if the file hasn't been saved 16 | contents <- ctxt$contents 17 | header <- grep("^---$", contents) 18 | if (length(header) == 2) { 19 | return(any(grepl( 20 | "html_notebook$", 21 | contents[min(header):max(header)] 22 | ))) 23 | } 24 | 25 | return(FALSE) 26 | } 27 | 28 | prCheck4output2console <- function(ctxt) { 29 | contents <- ctxt$contents 30 | header_boundary <- grep("^---$", contents) 31 | if (length(header_boundary) <= 1) { 32 | # Play it safe if the header is invalid 33 | return(TRUE) 34 | } 35 | 36 | header <- contents[header_boundary[1]:header_boundary[2]] 37 | return(!any(grepl("chunk_output_type: console", header))) 38 | } -------------------------------------------------------------------------------- /R/htmlTable_helpers_mergeClr.R: -------------------------------------------------------------------------------- 1 | #' Merges multiple colors 2 | #' 3 | #' Uses the [`colorRampPalette()`][grDevices::colorRamp] for merging colors. 4 | #' *Note:* When merging more than 2 colors the order in the color 5 | #' presentation matters. Each color is merged with its neigbors before 6 | #' merging with next. If there is an uneven number of colors the middle 7 | #' color is mixed with both left and right side. 8 | #' 9 | #' @param clrs The colors 10 | #' @return `character` A hexadecimal color 11 | #' @import magrittr 12 | #' @keywords internal 13 | #' @importFrom grDevices colorRampPalette 14 | #' @importFrom utils head 15 | prMergeClr <- function(clrs) { 16 | if (length(clrs) == 1) { 17 | return(clrs) 18 | } 19 | if (length(clrs) == 2) { 20 | return(colorRampPalette(clrs)(3)[2]) 21 | } 22 | 23 | split_lngth <- floor(length(clrs) / 2) 24 | left <- head(clrs, split_lngth) 25 | right <- tail(clrs, split_lngth) 26 | if (length(clrs) %% 2 == 1) { 27 | left %<>% 28 | c(clrs[split_lngth + 1]) 29 | right %<>% 30 | c(clrs[split_lngth + 1], .) 31 | } 32 | 33 | left <- prMergeClr(left) 34 | right <- prMergeClr(right) 35 | return(prMergeClr(c(left, right))) 36 | } 37 | -------------------------------------------------------------------------------- /tests/testInteractive.R: -------------------------------------------------------------------------------- 1 | library(htmlTable) 2 | 3 | interactiveTable(matrix(c("asdsadadadas", 4 | "DSASDS asd as dasd ad ads dasd dsa ADSADASDASD"), ncol = 2), 5 | minimized.columns = 2) 6 | 7 | interactiveTable(matrix(c("asdsadadadas", 8 | "DSASDS asd as dasd ad ads dasd dsa ADSADASDASD"), 9 | ncol = 2, 10 | nrow = 10), 11 | minimized.columns = 2, 12 | button = TRUE) 13 | 14 | 15 | knitr::knit_print(interactiveTable(matrix(c("asdsadadadas", 16 | "DSASDS asd as dasd ad ads dasd dsa ADSADASDASD"), 17 | ncol = 2, 18 | nrow = 10), 19 | minimized.columns = 2)) 20 | 21 | htmlTable:::print.interactiveTable( 22 | interactiveTable(matrix(c("asdsadadadas", 23 | "DSASDS asd as dasd ad ads dasd dsa ADSADASDASD"), 24 | ncol = 2, 25 | nrow = 10), 26 | minimized.columns = 2, 27 | button = TRUE)) 28 | -------------------------------------------------------------------------------- /R/concatHtmlTables.R: -------------------------------------------------------------------------------- 1 | #' Function for concatenating [htmlTable()]s 2 | #' 3 | #' @param tables A list of [htmlTable()]s to be concatenated 4 | #' @param headers Either a string or a vector of strings that function as 5 | #' a header for each table. If none is provided it will use the names of 6 | #' the table list or a numeric number. 7 | #' @return [htmlTable()] class object 8 | #' @example inst/examples/concatHtmlTables_example.R 9 | #' @export 10 | concatHtmlTables <- function(tables, headers = NULL) { 11 | assert_list(tables) 12 | 13 | if (is.null(headers)) { 14 | if (!is.null(names(tables))) { 15 | headers = sprintf("

%s

", names(tables)) 16 | } else { 17 | headers = sprintf("

Table no. %d

", 1:length(tables)) 18 | } 19 | } else { 20 | headers = rep(headers, length.out = length(tables)) 21 | } 22 | 23 | ret = paste(headers[1], tables[[1]]) 24 | for (i in 2:length(tables)) { 25 | ret = paste0( 26 | ret, 27 | headers[i], 28 | tables[[i]] 29 | ) 30 | } 31 | 32 | # Copy all the attributes from the first table 33 | attributes(ret) <- attributes(tables[[1]]) 34 | class(ret) <- c('htmlTable', class(tables[[1]])) 35 | return(ret) 36 | } 37 | -------------------------------------------------------------------------------- /R/htmlTable_helpers_tblNo.R: -------------------------------------------------------------------------------- 1 | #' Gets the table counter string 2 | #' 3 | #' Returns the string used for htmlTable to number the different tables. 4 | #' Uses options `table_counter`, `table_counter_str`, 5 | #' and `table_counter_roman` to produce the final string. You 6 | #' can set each option by simply calling `options()`. 7 | #' 8 | #' @param caption The caption if any 9 | #' @return `string` Returns a string formatted according to 10 | #' the table_counter_str and table_counter_roman. The number is 11 | #' decided by the table_counter variable 12 | #' @keywords internal 13 | #' @family hidden helper functions for htmlTable 14 | #' @importFrom utils as.roman 15 | prTblNo <- function(caption = NULL) { 16 | tc <- getOption("table_counter", FALSE) 17 | if (tc == FALSE) { 18 | if (is.null(caption)) { 19 | return("") 20 | } else { 21 | return(caption) 22 | } 23 | } 24 | 25 | table_template <- getOption("table_counter_str", "Table %s: ") 26 | out <- sprintf( 27 | table_template, 28 | ifelse(getOption("table_counter_roman", FALSE), 29 | as.character(as.roman(tc)), 30 | as.character(tc) 31 | ) 32 | ) 33 | if (!is.null(caption)) { 34 | out <- paste(out, caption) 35 | } 36 | 37 | return(out) 38 | } 39 | -------------------------------------------------------------------------------- /inst/htmlwidgets/htmlTableWidget.js: -------------------------------------------------------------------------------- 1 | HTMLWidgets.widget({ 2 | 3 | name: 'htmlTableWidget', 4 | 5 | type: 'output', 6 | 7 | factory: function(el, width, height) { 8 | 9 | return { 10 | 11 | renderValue: function(x) { 12 | $(el).empty(); 13 | // Select number of rows to see: 14 | var select_entries_div = document.createElement('div'); 15 | var select_entries_div_id = (el.id).concat('_entries'); 16 | $(select_entries_div).attr('id', select_entries_div_id); 17 | $(el).append(select_entries_div); 18 | // Add the table: 19 | $(el).append(x.thetable); 20 | /// The navigation bar: 21 | var nav_obj = document.createElement('div'); 22 | var nav_id = (el.id).concat('_nav'); 23 | $(nav_obj).attr('id', nav_id); 24 | $(el).append(nav_obj); 25 | // Set instance variables: 26 | var thetable = $(el).find('table'); 27 | $(el).css("position","relative"); 28 | $(el).css("clear","both"); 29 | $(thetable).css("width","100%"); 30 | table_pagination(thetable, nav_id, select_entries_div_id, x.options, el); 31 | }, 32 | 33 | resize: function(width, height) { 34 | 35 | } 36 | 37 | }; 38 | } 39 | }); 40 | -------------------------------------------------------------------------------- /R/deprecated.R: -------------------------------------------------------------------------------- 1 | # Deprecated function names 2 | 3 | #' See [txtMergeLines()] 4 | #' 5 | #' @param ... passed onto [txtMergeLines()] 6 | #' @examples 7 | #' \dontrun{ 8 | #' # Deprecated function 9 | #' splitLines4Table("hello", "world") 10 | #' } 11 | #' @keywords internal 12 | #' @export 13 | splitLines4Table <- function(...){ 14 | warning("splitLines4Table is deprecated, use txtMergeLines() instead") 15 | txtMergeLines(...) 16 | } 17 | 18 | #' Deprecated use [txtInt()] instead. 19 | #' 20 | #' @param ... Passed to [txtInt()] 21 | #' 22 | #' @examples 23 | #' \dontrun{ 24 | #' # Deprecated function 25 | #' outputInt(123456) 26 | #' } 27 | #' 28 | #' @keywords internal 29 | #' @export 30 | outputInt <- function(...){ 31 | warning("outputInt is deprecated, use txtInt() instead.") 32 | txtInt(...) 33 | } 34 | 35 | 36 | #' Deprecated use [txtPval()] instead 37 | #' 38 | #' @param ... Currently only used for generating warnings of deprecated call 39 | #' @examples 40 | #' \dontrun{ 41 | #' # Deprecated function 42 | #' pvalueFormatter(c(0.10234,0.010234, 0.0010234, 0.000010234)) 43 | #' } 44 | #' @export 45 | #' @keywords internal 46 | pvalueFormatter <- function(...){ 47 | warning("pvalueFormatter is deprecated, use txtPval() instead.") 48 | txtPval(...) 49 | } 50 | -------------------------------------------------------------------------------- /man/prGetStyle.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/htmlTable_helpers_getStyle.R 3 | \name{prGetStyle} 4 | \alias{prGetStyle} 5 | \title{Gets the CSS style element} 6 | \usage{ 7 | prGetStyle(...) 8 | } 9 | \arguments{ 10 | \item{...}{Styles can be provided as \code{vector}, \verb{named vector}, or \code{string}. 11 | If you provide a name, e.g. \code{background: blue}, \code{align="center"}, 12 | the function will convert the \code{align} into proper \code{align: center}.} 13 | } 14 | \value{ 15 | \code{string} Returns the codes merged into one string with 16 | correct CSS ; and : structure. 17 | } 18 | \description{ 19 | A function for checking, merging, and more 20 | with a variety of different style formats. 21 | } 22 | \seealso{ 23 | Other hidden helper functions for htmlTable: 24 | \code{\link{prAddCells}()}, 25 | \code{\link{prAddEmptySpacerCell}()}, 26 | \code{\link{prAddSemicolon2StrEnd}()}, 27 | \code{\link{prEscapeHtml}()}, 28 | \code{\link{prGetCgroupHeader}()}, 29 | \code{\link{prGetRowlabelPos}()}, 30 | \code{\link{prPrepInputMatrixDimensions}()}, 31 | \code{\link{prPrepareAlign}()}, 32 | \code{\link{prPrepareCgroup}()}, 33 | \code{\link{prTblNo}()} 34 | } 35 | \concept{hidden helper functions for htmlTable} 36 | \keyword{internal} 37 | -------------------------------------------------------------------------------- /man/prTblNo.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/htmlTable_helpers_tblNo.R 3 | \name{prTblNo} 4 | \alias{prTblNo} 5 | \title{Gets the table counter string} 6 | \usage{ 7 | prTblNo(caption = NULL) 8 | } 9 | \arguments{ 10 | \item{caption}{The caption if any} 11 | } 12 | \value{ 13 | \code{string} Returns a string formatted according to 14 | the table_counter_str and table_counter_roman. The number is 15 | decided by the table_counter variable 16 | } 17 | \description{ 18 | Returns the string used for htmlTable to number the different tables. 19 | Uses options \code{table_counter}, \code{table_counter_str}, 20 | and \code{table_counter_roman} to produce the final string. You 21 | can set each option by simply calling \code{options()}. 22 | } 23 | \seealso{ 24 | Other hidden helper functions for htmlTable: 25 | \code{\link{prAddCells}()}, 26 | \code{\link{prAddEmptySpacerCell}()}, 27 | \code{\link{prAddSemicolon2StrEnd}()}, 28 | \code{\link{prEscapeHtml}()}, 29 | \code{\link{prGetCgroupHeader}()}, 30 | \code{\link{prGetRowlabelPos}()}, 31 | \code{\link{prGetStyle}()}, 32 | \code{\link{prPrepInputMatrixDimensions}()}, 33 | \code{\link{prPrepareAlign}()}, 34 | \code{\link{prPrepareCgroup}()} 35 | } 36 | \concept{hidden helper functions for htmlTable} 37 | \keyword{internal} 38 | -------------------------------------------------------------------------------- /man/prPrepInputMatrixDimensions.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/htmlTable_helpers_prepInputMatrixDimensions.R 3 | \name{prPrepInputMatrixDimensions} 4 | \alias{prPrepInputMatrixDimensions} 5 | \title{Makes sure the input is correct} 6 | \usage{ 7 | prPrepInputMatrixDimensions(x, header = NULL) 8 | } 9 | \arguments{ 10 | \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} 11 | it takes a string of the class \code{htmlTable} as \code{x} argument.} 12 | 13 | \item{header}{A vector of character strings specifying column 14 | header, defaulting to \code{\link[base:colnames]{colnames(x)}}} 15 | } 16 | \description{ 17 | Checks and converts dimensions into something the 18 | \code{\link[=htmlTable]{htmlTable()}} is comfortable with. 19 | } 20 | \seealso{ 21 | Other hidden helper functions for htmlTable: 22 | \code{\link{prAddCells}()}, 23 | \code{\link{prAddEmptySpacerCell}()}, 24 | \code{\link{prAddSemicolon2StrEnd}()}, 25 | \code{\link{prEscapeHtml}()}, 26 | \code{\link{prGetCgroupHeader}()}, 27 | \code{\link{prGetRowlabelPos}()}, 28 | \code{\link{prGetStyle}()}, 29 | \code{\link{prPrepareAlign}()}, 30 | \code{\link{prPrepareCgroup}()}, 31 | \code{\link{prTblNo}()} 32 | } 33 | \concept{hidden helper functions for htmlTable} 34 | \keyword{internal} 35 | -------------------------------------------------------------------------------- /R/vector2string.R: -------------------------------------------------------------------------------- 1 | #' Collapse vector to string 2 | #' 3 | #' Merges all the values and outputs a string 4 | #' formatted as '1st element', '2nd element', ... 5 | #' 6 | #' @param x The vector to collapse 7 | #' @param collapse The string that separates each element 8 | #' @param quotation_mark The type of quote to use 9 | #' @return A string with `', '` separation 10 | #' @importFrom stringr str_replace_all 11 | #' @examples 12 | #' vector2string(1:4) 13 | #' vector2string(c("a", "b'b", "c")) 14 | #' vector2string(c("a", "b'b", "c"), quotation_mark = '"') 15 | #' @export 16 | vector2string <- function(x, 17 | quotation_mark = "'", 18 | collapse = sprintf("%s, %s", quotation_mark, quotation_mark)) { 19 | paste0( 20 | quotation_mark, 21 | paste(sapply(x, 22 | function(single_x) { 23 | str_replace_all( 24 | single_x, 25 | quotation_mark, 26 | sprintf("\\\\%s", quotation_mark) 27 | ) 28 | }, 29 | USE.NAMES = FALSE 30 | ), 31 | collapse = collapse 32 | ), 33 | quotation_mark 34 | ) 35 | } 36 | -------------------------------------------------------------------------------- /man/prPrepareCss.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/htmlTable_helpers_prepareCss.R 3 | \name{prPrepareCss} 4 | \alias{prPrepareCss} 5 | \title{Prepares the cell style} 6 | \usage{ 7 | prPrepareCss( 8 | x, 9 | css, 10 | rnames, 11 | header = NULL, 12 | name = deparse(substitute(css)), 13 | style_list = NULL 14 | ) 15 | } 16 | \arguments{ 17 | \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} 18 | it takes a string of the class \code{htmlTable} as \code{x} argument.} 19 | 20 | \item{css}{The CSS styles that are to be converted into 21 | a matrix.} 22 | 23 | \item{rnames}{Default row names are generated from \code{\link[base:colnames]{rownames(x)}}. If you 24 | provide \code{FALSE} then it will skip the row names. \emph{Note:} For \code{data.frames} 25 | if you do \code{\link[base:colnames]{rownames(my_dataframe) <- NULL}} it still has 26 | row names. Thus you need to use \code{FALSE} if you want to 27 | supress row names for \code{data.frames}.} 28 | 29 | \item{header}{A vector of character strings specifying column 30 | header, defaulting to \code{\link[base:colnames]{colnames(x)}}} 31 | 32 | \item{name}{The name of the CSS style that is prepared} 33 | } 34 | \value{ 35 | \code{matrix} 36 | } 37 | \description{ 38 | Prepares the cell style 39 | } 40 | \keyword{internal} 41 | -------------------------------------------------------------------------------- /tests/testthat/ters-htmlTable_cell_styles_via_prPrepareCSS.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | 3 | test_that("Test cell styles", { 4 | mx <- matrix(1:3, nrow = 2, ncol = 3, byrow = TRUE) 5 | mx_head <- LETTERS[1:ncol(mx)] 6 | mx_rnames <- LETTERS[1:nrow(mx)] 7 | expect_equal( 8 | dim(prPrepareCss(mx, "")), 9 | dim(mx) 10 | ) 11 | expect_equal( 12 | dim(prPrepareCss(mx, "", header = mx_head, rnames = mx_rnames)), 13 | dim(mx) 14 | ) 15 | 16 | expect_equal( 17 | dim(prPrepareCss(mx, "", header = mx_head, rnames = mx_rnames)), 18 | dim(mx) 19 | ) 20 | 21 | expect_equal( 22 | dim(prPrepareCss(mx, rep("", times = ncol(mx)))), 23 | dim(mx) 24 | ) 25 | 26 | expect_error(prPrepareCss(mx, rep("", times = nrow(mx)))) 27 | 28 | 29 | mx_cell.style <- matrix(c("a", "b", "c", "d"), nrow = 2, ncol = 4, byrow = TRUE) 30 | expect_equal( 31 | prPrepareCss(mx, mx_cell.style, rnames = mx_rnames)[2, 1], 32 | "b" 33 | ) 34 | 35 | expect_error(prPrepareCss(mx, mx_cell.style)) 36 | 37 | mx_cell.style <- matrix(c("a", "b", "c", "d"), nrow = 3, ncol = 4, byrow = TRUE) 38 | expect_equal( 39 | prPrepareCss(mx, mx_cell.style, 40 | header = mx_head, 41 | rnames = mx_rnames 42 | )[2, 1], 43 | "b" 44 | ) 45 | 46 | expect_error(prPrepareCss(mx, mx_cell.style, rnames = mx_rnames)) 47 | }) 48 | -------------------------------------------------------------------------------- /tests/testthat/htmlTable_addHtmlTableStyle.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(XML) 3 | 4 | test_that("Standard addHtmlTableStyle",{ 5 | mx <- matrix(1:6, ncol = 3) 6 | colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) 7 | 8 | 9 | expect_true(mx %>% 10 | addHtmlTableStyle(align = "r|r") %>% 11 | hasHtmlTableStyle("align")) 12 | 13 | style <- mx %>% 14 | addHtmlTableStyle(align = "r|r", 15 | # Check partial match.arg for "bottom" 16 | pos.caption = "bot") %>% 17 | getHtmlTableStyle() 18 | expect_list(style) 19 | 20 | 21 | expect_equal(style$align, "r|r") 22 | expect_equal(style$pos.caption, "bottom") 23 | 24 | expect_error(mx %>% addHtmlTableStyle(pos.caption = "invalid option"), regexp = "pos.caption") 25 | }) 26 | 27 | test_that("Wrap addHtmlTable should work", { 28 | firstWrapper <- function(x, css = c("large", "small")) { 29 | css.table <- match.arg(css) 30 | 31 | addHtmlTableStyle(x, css.table = css.table) 32 | } 33 | 34 | v <- firstWrapper(x = mtcars, css = "large") 35 | expect_equal(getHtmlTableStyle(v)$css.table, "large") 36 | 37 | secondWrapper <- function(x) { 38 | value <- "small" 39 | firstWrapper(x, css = value) 40 | } 41 | v <- secondWrapper(x = mtcars) 42 | expect_equal(getHtmlTableStyle(v)$css.table, "small") 43 | }) 44 | 45 | -------------------------------------------------------------------------------- /man/htmlTableWidget-shiny.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/htmlTableWidget.R 3 | \name{htmlTableWidget-shiny} 4 | \alias{htmlTableWidget-shiny} 5 | \alias{htmlTableWidgetOutput} 6 | \alias{renderHtmlTableWidget} 7 | \title{Shiny bindings for htmlTableWidget} 8 | \usage{ 9 | htmlTableWidgetOutput(outputId, width = "100\%", height = "400px") 10 | 11 | renderHtmlTableWidget(expr, env = parent.frame(), quoted = FALSE) 12 | } 13 | \arguments{ 14 | \item{outputId}{output variable to read from} 15 | 16 | \item{width, height}{Must be a valid CSS unit (like \code{'100\%'}, \code{'400px'}, \code{'auto'}) or a number, 17 | which will be coerced to a string and have \code{'px'} appended.} 18 | 19 | \item{expr}{An expression that generates a \code{\link[=htmlTableWidget]{htmlTableWidget()}}} 20 | 21 | \item{env}{The environment in which to evaluate \code{expr}.} 22 | 23 | \item{quoted}{Is \code{expr} a quoted expression (with \code{quote()})? This 24 | is useful if you want to save an expression in a variable.} 25 | } 26 | \description{ 27 | Output and render functions for using htmlTableWidget within Shiny 28 | applications and interactive Rmd documents. 29 | } 30 | \examples{ 31 | \dontrun{ 32 | # In the UI: 33 | htmlTableWidgetOutput("mywidget") 34 | # In the server: 35 | renderHtmlTableWidget({ 36 | htmlTableWidget(iris) 37 | }) 38 | } 39 | } 40 | -------------------------------------------------------------------------------- /R/htmlTable_helpers_addSemicolon2StrEnd.R: -------------------------------------------------------------------------------- 1 | #' Add a ; at the end 2 | #' 3 | #' The CSS expects a semicolon at the end of each argument 4 | #' this function just adds a semicolong if none is given 5 | #' and remove multiple semicolon if such exist 6 | #' 7 | #' @param my_str The string that is to be processed 8 | #' @return `string` 9 | #' @keywords internal 10 | #' @family hidden helper functions for htmlTable 11 | #' @importFrom utils tail 12 | prAddSemicolon2StrEnd <- function(my_str) { 13 | if (!is.null(names(my_str))) { 14 | tmp <- str_trim(my_str) 15 | names(tmp) <- names(my_str) 16 | my_str <- tmp 17 | } else { 18 | my_str <- str_trim(my_str) 19 | } 20 | my_str_n <- sapply(my_str, nchar, USE.NAMES = FALSE) 21 | if (any(my_str_n == 0)) { 22 | my_str <- my_str[my_str_n > 0] 23 | } 24 | 25 | if (length(my_str) == 0) { 26 | return("") 27 | } 28 | 29 | if (tail(strsplit(my_str, "")[[1]], 1) != ";") { 30 | n <- names(my_str) 31 | my_str <- sprintf("%s;", my_str) 32 | if (!is.null(n)) { 33 | names(my_str) <- n 34 | } 35 | } 36 | 37 | # Remove duplicated ; 38 | my_str <- gsub(";;+", ";", my_str) 39 | empty_str <- sapply(my_str, function(x) x == ";", USE.NAMES = FALSE) 40 | if (any(empty_str)) { 41 | my_str <- my_str[!empty_str] 42 | } 43 | 44 | if (length(my_str) == 0) { 45 | return("") 46 | } 47 | 48 | return(my_str) 49 | } 50 | -------------------------------------------------------------------------------- /man/txtInt.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/txtFrmt.R 3 | \name{txtInt} 4 | \alias{txtInt} 5 | \title{SI or English formatting of an integer} 6 | \usage{ 7 | txtInt( 8 | x, 9 | language = getOption("htmlTable.language", default = "en"), 10 | html = getOption("htmlTable.html", default = TRUE), 11 | ... 12 | ) 13 | } 14 | \arguments{ 15 | \item{x}{The integer variable} 16 | 17 | \item{language}{The ISO-639-1 two-letter code for the language of 18 | interest. Currently only English is distinguished from the ISO 19 | format using a ',' as the separator.} 20 | 21 | \item{html}{If the format is used in HTML context 22 | then the space should be a non-breaking space, \verb{ }} 23 | 24 | \item{...}{Passed to \code{\link[base:format]{base::format()}}} 25 | } 26 | \value{ 27 | \code{string} 28 | } 29 | \description{ 30 | English uses ',' between every 3 numbers while the 31 | SI format recommends a ' ' if x > 10^4. The scientific 32 | form 10e+? is furthermore avoided. 33 | } 34 | \examples{ 35 | txtInt(123) 36 | 37 | # Supplying a matrix 38 | txtInt(matrix(c(1234, 12345, 123456, 1234567), ncol = 2)) 39 | 40 | # Missing are returned as empty strings, i.e. "" 41 | txtInt(c(NA, 1e7)) 42 | 43 | } 44 | \seealso{ 45 | Other text formatters: 46 | \code{\link{txtMergeLines}()}, 47 | \code{\link{txtPval}()}, 48 | \code{\link{txtRound}()} 49 | } 50 | \concept{text formatters} 51 | -------------------------------------------------------------------------------- /man/txtMergeLines.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/txtFrmt.R 3 | \name{txtMergeLines} 4 | \alias{txtMergeLines} 5 | \title{A merges lines while preserving the line break for HTML/LaTeX} 6 | \usage{ 7 | txtMergeLines(..., html = 5) 8 | } 9 | \arguments{ 10 | \item{...}{The lines that you want to be joined} 11 | 12 | \item{html}{If HTML compatible output should be used. If \code{FALSE} 13 | it outputs LaTeX formatting. Note if you set this to 5 14 | then the HTML5 version of \emph{br} will be used: \verb{
} 15 | otherwise it uses the \verb{
} that is compatible 16 | with the XHTML-formatting.} 17 | } 18 | \value{ 19 | \code{string} with \code{asis_output} wrapping if html output is activated 20 | } 21 | \description{ 22 | This function helps you to do a table header with multiple lines 23 | in both HTML and in LaTeX. In HTML this isn't that tricky, you just use 24 | the \verb{
} command but in LaTeX I often find 25 | myself writing \code{vbox}/\code{hbox} stuff and therefore 26 | I've created this simple helper function 27 | } 28 | \examples{ 29 | txtMergeLines("hello", "world") 30 | txtMergeLines("hello", "world", html=FALSE) 31 | txtMergeLines("hello", "world", list("A list", "is OK")) 32 | 33 | } 34 | \seealso{ 35 | Other text formatters: 36 | \code{\link{txtInt}()}, 37 | \code{\link{txtPval}()}, 38 | \code{\link{txtRound}()} 39 | } 40 | \concept{text formatters} 41 | -------------------------------------------------------------------------------- /R/htmlTable_style_assertions.R: -------------------------------------------------------------------------------- 1 | prAssertStyleNames <- function(x, message) { 2 | if (any(x == "")) { 3 | stop(message, " Empty names not allowed.") 4 | } 5 | 6 | invalid_names <- prGetInvalidStyleNames(x) 7 | if (length(invalid_names) > 0) { 8 | stop(message, " See name(s): ", paste(invalid_names, collapse = ", ")) 9 | } 10 | } 11 | 12 | prGetInvalidStyleNames <- function(x) { 13 | valid_names <- Filter( 14 | function(x) !(x %in% c("theme", "")), 15 | names(formals(setHtmlTableTheme)) 16 | ) 17 | 18 | checked_names <- args %in% valid_names 19 | return(args[!checked_names]) 20 | } 21 | 22 | 23 | prAssertStyles <- function(style_list) { 24 | assert_list(style_list, names = "named", .var.name = deparse(substitute(style_list))) 25 | 26 | css_styles <- names(style_list)[startsWith(names(style_list), "css.")] 27 | for (style in css_styles) { 28 | prAssertStyle(style_list[[style]], name = style) 29 | } 30 | 31 | return(TRUE) 32 | } 33 | 34 | prAssertStyle <- function(elmnt, name) { 35 | assert_character(elmnt, 36 | min.chars = 0, 37 | min.len = 1, 38 | .var.name = name 39 | ) 40 | 41 | elmnts2check <- Filter( 42 | function(x) nchar(x) > 0, 43 | elmnt 44 | ) 45 | 46 | if (name != "css.class" && is.null(names(elmnts2check)) && length(elmnts2check) > 0) { 47 | assert_true(all(sapply(elmnts2check, function(e) grepl(":", e))), 48 | .var.name = name 49 | ) 50 | } 51 | } 52 | -------------------------------------------------------------------------------- /inst/javascript/toggler.js: -------------------------------------------------------------------------------- 1 | $(document).ready(function(){ 2 | $(".gmisc_table td .hidden").map(function(index, el){ 3 | el.parentNode.style["original-color"] = el.parentNode.style["background-color"]; 4 | el.parentNode.style["background-color"] = "#DDD"; 5 | }); 6 | 7 | getSelected = function(){ 8 | var t = ''; 9 | if(window.getSelection){ 10 | t = window.getSelection(); 11 | }else if(document.getSelection){ 12 | t = document.getSelection(); 13 | }else if(document.selection){ 14 | t = document.selection.createRange().text; 15 | } 16 | return t.toString(); 17 | }; 18 | 19 | $(".gmisc_table td").map(function(index, el){ 20 | this.style.cursor = "pointer"; 21 | el.onmouseup = function(e){ 22 | if (getSelected().length > 0) 23 | return; 24 | 25 | var hidden = this.getElementsByClassName("hidden"); 26 | if (hidden.length > 0){ 27 | this.innerHTML = hidden[0].textContent; 28 | this.style["background-color"] = this.style["original-color"]; 29 | 30 | }else{ 31 | $(this).append(""); 33 | 34 | this.childNodes[0].data = this.childNodes[0].data.substr(0, 20) + "... "; 35 | this.style["original-color"] = this.style["background-color"]; 36 | this.style["background-color"] = "#DDD"; 37 | } 38 | }; 39 | }); 40 | }); 41 | -------------------------------------------------------------------------------- /R/htmlTable_helpers_getRowlabelPos.R: -------------------------------------------------------------------------------- 1 | 2 | #' Gets the rowlabel position 3 | #' 4 | #' @inheritParams htmlTable 5 | #' @return `integer` Returns the position within the header rows 6 | #' to print the `rowlabel` argument 7 | #' @keywords internal 8 | #' @family hidden helper functions for htmlTable 9 | prGetRowlabelPos <- function(cgroup = NULL, pos.rowlabel, header = NULL) { 10 | no_cgroup_rows <- 11 | ifelse(!is.null(cgroup), 12 | nrow(cgroup), 13 | 0 14 | ) 15 | no_header_rows <- 16 | no_cgroup_rows + 17 | (!is.null(header)) * 1 18 | if (is.numeric(pos.rowlabel)) { 19 | if (pos.rowlabel < 1) { 20 | stop("You have specified a pos.rowlabel that is less than 1: ", pos.rowlabel) 21 | } else if (pos.rowlabel > no_header_rows) { 22 | stop( 23 | "You have specified a pos.rowlabel that more than the max limit, ", 24 | no_header_rows, 25 | ", you have provided: ", pos.rowlabel 26 | ) 27 | } 28 | } else { 29 | pos.rowlabel <- tolower(pos.rowlabel) 30 | if (pos.rowlabel %in% c("top")) { 31 | pos.rowlabel <- 1 32 | } else if (pos.rowlabel %in% c("bottom", "header")) { 33 | pos.rowlabel <- no_header_rows 34 | } else { 35 | stop( 36 | "You have provided an invalid pos.rowlabel text,", 37 | " only 'top', 'bottom' or 'header' are allowed,", 38 | " can't interpret '", pos.rowlabel, "'" 39 | ) 40 | } 41 | } 42 | 43 | return(pos.rowlabel) 44 | } 45 | -------------------------------------------------------------------------------- /man/htmlTableWidget.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/htmlTableWidget.R 3 | \name{htmlTableWidget} 4 | \alias{htmlTableWidget} 5 | \title{htmlTable with pagination widget} 6 | \usage{ 7 | htmlTableWidget( 8 | x, 9 | number_of_entries = c(10, 25, 100), 10 | width = NULL, 11 | height = NULL, 12 | elementId = NULL, 13 | ... 14 | ) 15 | } 16 | \arguments{ 17 | \item{x}{A data frame to be rendered} 18 | 19 | \item{number_of_entries}{a numeric vector with the number of entries per page to show. 20 | If there is more than one number given, the user will be able to show the number 21 | of rows per page in the table.} 22 | 23 | \item{width}{Fixed width for widget (in css units). The default is 24 | \code{NULL}, which results in intelligent automatic sizing based on the 25 | widget's container.} 26 | 27 | \item{height}{Fixed height for widget (in css units). The default is 28 | \code{NULL}, which results in intelligent automatic sizing based on the 29 | widget's container.} 30 | 31 | \item{elementId}{Use an explicit element ID for the widget (rather than an 32 | automatically generated one). Useful if you have other JavaScript that 33 | needs to explicitly discover and interact with a specific widget instance.} 34 | 35 | \item{...}{Additional parameters passed to htmlTable} 36 | } 37 | \value{ 38 | an htmlwidget showing the paginated table 39 | } 40 | \description{ 41 | This widget renders a table with pagination into an htmlwidget 42 | } 43 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: htmlTable 2 | Version: 2.4.3 3 | Title: Advanced Tables for Markdown/HTML 4 | Authors@R: c( 5 | person("Max", "Gordon", email = "max@gforge.se", 6 | role = c("aut", "cre")), 7 | person("Stephen", "Gragg", role=c("aut")), 8 | person("Peter", "Konings", role=c("aut"))) 9 | Maintainer: Max Gordon 10 | Description: Tables with state-of-the-art layout elements such as row spanners, 11 | column spanners, table spanners, zebra striping, and more. While allowing 12 | advanced layout, the underlying css-structure is simple in order to maximize 13 | compatibility with common word processors. The package also contains a few 14 | text formatting functions that help outputting text compatible with HTML/LaTeX. 15 | License: GPL (>= 3) 16 | URL: https://gforge.se/packages/ 17 | BugReports: https://github.com/gforge/htmlTable/issues 18 | Biarch: yes 19 | Depends: 20 | R (>= 4.1) 21 | Imports: 22 | stringr, 23 | knitr (>= 1.6), 24 | magrittr (>= 1.5), 25 | methods, 26 | checkmate, 27 | htmlwidgets, 28 | htmltools, 29 | rstudioapi (>= 0.6) 30 | Suggests: 31 | testthat, 32 | XML, 33 | xml2, 34 | Hmisc, 35 | rmarkdown, 36 | chron, 37 | lubridate, 38 | tibble, 39 | purrr, 40 | tidyselect, 41 | glue, 42 | rlang, 43 | tidyr (>= 0.7.2), 44 | dplyr (>= 0.7.4) 45 | Encoding: UTF-8 46 | NeedsCompilation: no 47 | VignetteBuilder: knitr 48 | RoxygenNote: 7.2.2 49 | Roxygen: list(markdown = TRUE) 50 | -------------------------------------------------------------------------------- /inst/examples/tidyHtmlTable_example.R: -------------------------------------------------------------------------------- 1 | library(tibble) 2 | library(dplyr) 3 | library(tidyr) 4 | 5 | # Prep and select basic data 6 | data("mtcars") 7 | base_data <- mtcars %>% 8 | rownames_to_column() %>% 9 | mutate(gear = paste(gear, "Gears"), 10 | cyl = paste(cyl, "Cylinders")) %>% 11 | select(rowname, cyl, gear, wt, mpg, qsec) 12 | 13 | base_data %>% 14 | pivot_longer(names_to = "per_metric", 15 | cols = c(wt, mpg, qsec)) %>% 16 | group_by(cyl, gear, per_metric) %>% 17 | summarise(value_Mean = round(mean(value), 1), 18 | value_Min = round(min(value), 1), 19 | value_Max = round(max(value), 1), 20 | .groups = "drop") %>% 21 | pivot_wider(names_from = per_metric, 22 | values_from = starts_with("value_")) %>% 23 | # Round the values into a nicer format where we want the weights to have two decimals 24 | txtRound(ends_with("_wt"), digits = 2) %>% 25 | txtRound(starts_with("value") & !ends_with("_wt"), digits = 1) %>% 26 | # Convert into long format 27 | pivot_longer(cols = starts_with("value_"), names_prefix = "value_") %>% 28 | separate(name, into = c("summary_stat", "per_metric")) %>% 29 | # Without sorting the row groups wont appear right 30 | # If the columns end up in the wrong order you may want to change the columns 31 | # into factors 32 | arrange(per_metric) %>% 33 | addHtmlTableStyle(align = "r") %>% 34 | tidyHtmlTable( 35 | header = gear, 36 | cgroup = cyl, 37 | rnames = summary_stat, 38 | rgroup = per_metric, 39 | skip_removal_warning = TRUE) 40 | -------------------------------------------------------------------------------- /man/prGetRowlabelPos.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/htmlTable_helpers_getRowlabelPos.R 3 | \name{prGetRowlabelPos} 4 | \alias{prGetRowlabelPos} 5 | \title{Gets the rowlabel position} 6 | \usage{ 7 | prGetRowlabelPos(cgroup = NULL, pos.rowlabel, header = NULL) 8 | } 9 | \arguments{ 10 | \item{cgroup}{A vector, matrix or list of character strings defining major column header. The default 11 | is to have none. These elements are also known as \emph{column spanners}. If you want a column \emph{not} 12 | to have a spanner then put that column as "". If you pass cgroup and \code{n.crgroup} as 13 | matrices you can have column spanners for several rows. See cgroup section below for details.} 14 | 15 | \item{header}{A vector of character strings specifying column 16 | header, defaulting to \code{\link[base:colnames]{colnames(x)}}} 17 | } 18 | \value{ 19 | \code{integer} Returns the position within the header rows 20 | to print the \code{rowlabel} argument 21 | } 22 | \description{ 23 | Gets the rowlabel position 24 | } 25 | \seealso{ 26 | Other hidden helper functions for htmlTable: 27 | \code{\link{prAddCells}()}, 28 | \code{\link{prAddEmptySpacerCell}()}, 29 | \code{\link{prAddSemicolon2StrEnd}()}, 30 | \code{\link{prEscapeHtml}()}, 31 | \code{\link{prGetCgroupHeader}()}, 32 | \code{\link{prGetStyle}()}, 33 | \code{\link{prPrepInputMatrixDimensions}()}, 34 | \code{\link{prPrepareAlign}()}, 35 | \code{\link{prPrepareCgroup}()}, 36 | \code{\link{prTblNo}()} 37 | } 38 | \concept{hidden helper functions for htmlTable} 39 | \keyword{internal} 40 | -------------------------------------------------------------------------------- /man/prAddEmptySpacerCell.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/htmlTable_render_prAddEmptySpacerCell.R 3 | \name{prAddEmptySpacerCell} 4 | \alias{prAddEmptySpacerCell} 5 | \title{Add an empty cell} 6 | \usage{ 7 | prAddEmptySpacerCell( 8 | x, 9 | style_list, 10 | cell_style, 11 | align_style, 12 | cell_tag = c("td", "th"), 13 | colspan = 1 14 | ) 15 | } 16 | \arguments{ 17 | \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} 18 | it takes a string of the class \code{htmlTable} as \code{x} argument.} 19 | 20 | \item{cell_style}{The style of the current cell that should be applied to all cells} 21 | 22 | \item{align_style}{The style from \code{\link[=prGetAlign]{prGetAlign()}}} 23 | 24 | \item{cell_tag}{What HTML tag to use} 25 | 26 | \item{colspan}{The number of rows each tag should span} 27 | } 28 | \value{ 29 | \code{string} 30 | } 31 | \description{ 32 | Depending on the \code{spacer.celltype} set in \code{\link[=addHtmlTableStyle]{addHtmlTableStyle()}} we 33 | will use different spacer cells. 34 | } 35 | \seealso{ 36 | Other hidden helper functions for htmlTable: 37 | \code{\link{prAddCells}()}, 38 | \code{\link{prAddSemicolon2StrEnd}()}, 39 | \code{\link{prEscapeHtml}()}, 40 | \code{\link{prGetCgroupHeader}()}, 41 | \code{\link{prGetRowlabelPos}()}, 42 | \code{\link{prGetStyle}()}, 43 | \code{\link{prPrepInputMatrixDimensions}()}, 44 | \code{\link{prPrepareAlign}()}, 45 | \code{\link{prPrepareCgroup}()}, 46 | \code{\link{prTblNo}()} 47 | } 48 | \concept{hidden helper functions for htmlTable} 49 | \keyword{internal} 50 | -------------------------------------------------------------------------------- /man/SCB.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/data-SCB.R 3 | \docType{data} 4 | \name{SCB} 5 | \alias{SCB} 6 | \title{Average age in Sweden} 7 | \description{ 8 | For the vignettes there is a dataset downloaded by using the 9 | \code{get_pxweb_data()} call. The data is from 10 | SCB (\href{https://www.scb.se//}{Statistics Sweden}) and downloaded 11 | using the \href{https://github.com/rOpenGov/pxweb}{pxweb package}: 12 | } 13 | \examples{ 14 | \dontrun{ 15 | # The data was generated through downloading via the API 16 | library(pxweb) 17 | 18 | # Get the last 15 years of data (the data always lags 1 year) 19 | current_year <- as.integer(format(Sys.Date(), "\%Y")) -1 20 | SCB <- get_pxweb_data( 21 | url = "http://api.scb.se/OV0104/v1/doris/en/ssd/BE/BE0101/BE0101B/BefolkningMedelAlder", 22 | dims = list(Region = c('00', '01', '03', '25'), 23 | Kon = c('1', '2'), 24 | ContentsCode = c('BE0101G9'), 25 | Tid = (current_year-14):current_year), 26 | clean = TRUE) 27 | 28 | # Some cleaning was needed before use 29 | SCB$region <- factor(substring(as.character(SCB$region), 4)) 30 | Swe_ltrs <- c("å" = "å", 31 | "Å" = "Å", 32 | "ä" = "ä", 33 | "Ä" = "Ä", 34 | "ö" = "ö", 35 | "Ö" = "Ö") 36 | for (i in 1:length(Swe_ltrs)){ 37 | levels(SCB$region) <- gsub(names(Swe_ltrs)[i], 38 | Swe_ltrs[i], 39 | levels(SCB$region)) 40 | } 41 | 42 | save(SCB, file = "data/SCB.rda") 43 | } 44 | } 45 | \references{ 46 | \url{https://www.scb.se/} 47 | } 48 | \author{ 49 | Max Gordon \email{max@gforge.se} 50 | } 51 | \keyword{data} 52 | -------------------------------------------------------------------------------- /tests/testthat/test-htmlTable_escape_html.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | 3 | test_that("HTML code is properly escaped", { 4 | expect_match( 5 | object = htmlTable(data.frame(a = "<3"), 6 | rnames = FALSE, 7 | escape.html = TRUE 8 | ), 9 | regexp = "<3" 10 | ) 11 | 12 | df_test <- data.frame( 13 | a = c("<3", "<3"), 14 | b = c("&2", ">2"), 15 | stringsAsFactors = FALSE 16 | ) 17 | matrix_test <- as.matrix(df_test, 18 | ncol = 2 19 | ) 20 | 21 | getCellContext <- function(tout) { 22 | tout %>% 23 | str_split("\n") %>% 24 | extract2(1) %>% 25 | as.list() %>% 26 | c(collapse = "_") %>% 27 | do.call(paste, .) %>% 28 | str_replace(".*(.+).*", "\\1") %>% 29 | str_split("% 30 | extract2(1) %>% 31 | Filter(function(x) grepl("", x), .) %>% 32 | str_replace(".*>([^<]+).*", "\\1") 33 | } 34 | 35 | expect_equivalent( 36 | htmlTable(df_test, 37 | rnames = FALSE, 38 | escape.html = TRUE 39 | ) %>% getCellContext(), 40 | htmlEscape(c(df_test[1,], df_test[2,])) 41 | ) 42 | 43 | expect_equivalent( 44 | htmlTable(matrix_test, 45 | rnames = FALSE, 46 | escape.html = TRUE 47 | ) %>% getCellContext(), 48 | htmlEscape(c(df_test[1,], df_test[2,])) 49 | ) 50 | 51 | tibble_test <- tibble::as_tibble(df_test) 52 | expect_equivalent( 53 | htmlTable(tibble_test, 54 | rnames = FALSE, 55 | escape.html = TRUE 56 | ) %>% getCellContext(), 57 | htmlEscape(c(df_test[1,], df_test[2,])) 58 | ) 59 | 60 | expect_equal(prEscapeHtml("$")[[1]], "$") 61 | }) 62 | -------------------------------------------------------------------------------- /R/htmlTable_helpers_prepareAlign.R: -------------------------------------------------------------------------------- 1 | #' Prepares the align to match the columns 2 | #' 3 | #' The alignment may be tricky and this function therefore simplifies 4 | #' this process by extending/shortening the alignment to match the 5 | #' correct number of columns. 6 | #' 7 | #' @param default_rn The default rowname alignment. This is an option 8 | #' as the header uses the same function and there may be differences in 9 | #' how the alignments should be implemented. 10 | #' @keywords internal 11 | #' @family hidden helper functions for htmlTable 12 | #' @inheritParams htmlTable 13 | prPrepareAlign <- function(align, x, rnames, default_rn = "l") { 14 | assert_character(align) 15 | 16 | if (length(align) > 1) { 17 | align <- paste(align, collapse = "") 18 | } 19 | 20 | segm_rgx <- "[^lrc]*[rlc][^lrc]*" 21 | no_elements <- length(strsplit(align, split = segm_rgx)[[1]]) 22 | no_cols <- ifelse(is.null(dim(x)), x, ncol(x)) 23 | if (!prSkipRownames(rnames)) { 24 | no_cols <- no_cols + 1 25 | if (no_elements < no_cols) { 26 | align <- paste0(default_rn, align) 27 | } 28 | } 29 | 30 | res_align <- align 31 | align <- "" 32 | for (i in 1:no_cols) { 33 | rmatch <- regexpr(segm_rgx, res_align) 34 | tmp_lrc <- substr(res_align, 1, rmatch + attr(rmatch, "match.length") - 1) 35 | res_align <- substring(res_align, rmatch + attr(rmatch, "match.length")) 36 | align <- paste0( 37 | align, 38 | tmp_lrc 39 | ) 40 | if (nchar(res_align) < 1 && 41 | i != no_cols) { 42 | align <- paste0( 43 | align, 44 | paste(rep(tmp_lrc, times = no_cols - i), collapse = "") 45 | ) 46 | break 47 | } 48 | } 49 | 50 | structure(align, 51 | n = no_cols, 52 | class = class(align) 53 | ) 54 | } 55 | -------------------------------------------------------------------------------- /inst/examples/concatHtmlTables_example.R: -------------------------------------------------------------------------------- 1 | library(magrittr) 2 | 3 | # Basic example 4 | tables <- list() 5 | output <- matrix(1:4, 6 | ncol = 2, 7 | dimnames = list(list("Row 1", "Row 2"), 8 | list("Column 1", "Column 2"))) 9 | tables[["Simple table"]] <- htmlTable(output) 10 | 11 | 12 | # An advanced output 13 | output <- matrix(ncol = 6, nrow = 8) 14 | 15 | for (nr in 1:nrow(output)) { 16 | for (nc in 1:ncol(output)) { 17 | output[nr, nc] <- 18 | paste0(nr, ":", nc) 19 | } 20 | } 21 | 22 | tables[["Fancy table"]] <- output %>% 23 | addHtmlTableStyle(align = "r", 24 | col.columns = c(rep("none", 2), 25 | rep("#F5FBFF", 4)), 26 | col.rgroup = c("none", "#F7F7F7"), 27 | css.cell = "padding-left: .5em; padding-right: .2em;") %>% 28 | htmlTable(header = paste(c("1st", "2nd", 29 | "3rd", "4th", 30 | "5th", "6th"), 31 | "hdr"), 32 | rnames = paste(c("1st", "2nd", 33 | "3rd", 34 | paste0(4:8, "th")), 35 | "row"), 36 | rgroup = paste("Group", LETTERS[1:3]), 37 | n.rgroup = c(2,4,nrow(output) - 6), 38 | cgroup = rbind(c("", "Column spanners", NA), 39 | c("", "Cgroup 1", "Cgroup 2†")), 40 | n.cgroup = rbind(c(1,2,NA), 41 | c(2,2,2)), 42 | caption = "Basic table with both column spanners (groups) and row groups", 43 | tfoot = "† A table footer commment", 44 | cspan.rgroup = 2) 45 | 46 | concatHtmlTables(tables) 47 | -------------------------------------------------------------------------------- /man/prPrepareAlign.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/htmlTable_helpers_prepareAlign.R 3 | \name{prPrepareAlign} 4 | \alias{prPrepareAlign} 5 | \title{Prepares the align to match the columns} 6 | \usage{ 7 | prPrepareAlign(align, x, rnames, default_rn = "l") 8 | } 9 | \arguments{ 10 | \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} 11 | it takes a string of the class \code{htmlTable} as \code{x} argument.} 12 | 13 | \item{rnames}{Default row names are generated from \code{\link[base:colnames]{rownames(x)}}. If you 14 | provide \code{FALSE} then it will skip the row names. \emph{Note:} For \code{data.frames} 15 | if you do \code{\link[base:colnames]{rownames(my_dataframe) <- NULL}} it still has 16 | row names. Thus you need to use \code{FALSE} if you want to 17 | supress row names for \code{data.frames}.} 18 | 19 | \item{default_rn}{The default rowname alignment. This is an option 20 | as the header uses the same function and there may be differences in 21 | how the alignments should be implemented.} 22 | } 23 | \description{ 24 | The alignment may be tricky and this function therefore simplifies 25 | this process by extending/shortening the alignment to match the 26 | correct number of columns. 27 | } 28 | \seealso{ 29 | Other hidden helper functions for htmlTable: 30 | \code{\link{prAddCells}()}, 31 | \code{\link{prAddEmptySpacerCell}()}, 32 | \code{\link{prAddSemicolon2StrEnd}()}, 33 | \code{\link{prEscapeHtml}()}, 34 | \code{\link{prGetCgroupHeader}()}, 35 | \code{\link{prGetRowlabelPos}()}, 36 | \code{\link{prGetStyle}()}, 37 | \code{\link{prPrepInputMatrixDimensions}()}, 38 | \code{\link{prPrepareCgroup}()}, 39 | \code{\link{prTblNo}()} 40 | } 41 | \concept{hidden helper functions for htmlTable} 42 | \keyword{internal} 43 | -------------------------------------------------------------------------------- /man/prAddCells.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/htmlTable_render_addCells.R 3 | \name{prAddCells} 4 | \alias{prAddCells} 5 | \title{Add a cell} 6 | \usage{ 7 | prAddCells( 8 | rowcells, 9 | cellcode, 10 | style_list, 11 | style, 12 | prepped_cell_css, 13 | cgroup_spacer_cells, 14 | has_rn_col, 15 | offset = 1, 16 | style_list_align_key = "align" 17 | ) 18 | } 19 | \arguments{ 20 | \item{rowcells}{The cells with the values that are to be added} 21 | 22 | \item{cellcode}{Type of cell, can either be \code{th} or \code{td}} 23 | 24 | \item{style_list}{The style_list} 25 | 26 | \item{style}{The cell style} 27 | 28 | \item{cgroup_spacer_cells}{The number of cells that occur between 29 | columns due to the cgroup arguments.} 30 | 31 | \item{has_rn_col}{Due to the alignment issue we need to keep track 32 | of if there has already been printed a rowname column or not and therefore 33 | we have this has_rn_col that is either 0 or 1.} 34 | 35 | \item{offset}{For rgroup rows there may be an offset != 1} 36 | } 37 | \value{ 38 | \code{string} Returns the string with the new cell elements 39 | } 40 | \description{ 41 | Adds a row of cells \verb{val...} to a table string for 42 | \code{\link[=htmlTable]{htmlTable()}} 43 | } 44 | \seealso{ 45 | Other hidden helper functions for htmlTable: 46 | \code{\link{prAddEmptySpacerCell}()}, 47 | \code{\link{prAddSemicolon2StrEnd}()}, 48 | \code{\link{prEscapeHtml}()}, 49 | \code{\link{prGetCgroupHeader}()}, 50 | \code{\link{prGetRowlabelPos}()}, 51 | \code{\link{prGetStyle}()}, 52 | \code{\link{prPrepInputMatrixDimensions}()}, 53 | \code{\link{prPrepareAlign}()}, 54 | \code{\link{prPrepareCgroup}()}, 55 | \code{\link{prTblNo}()} 56 | } 57 | \concept{hidden helper functions for htmlTable} 58 | \keyword{internal} 59 | -------------------------------------------------------------------------------- /R/htmlTable_helpers_prepareColors.R: -------------------------------------------------------------------------------- 1 | #' Prepares the alternating colors 2 | #' 3 | #' @param clr The colors 4 | #' @param n The number of rows/columns applicable to the color 5 | #' @param ng The n.rgroup/n.cgroup argument if applicable 6 | #' @param gtxt The rgroup/cgroup texts 7 | #' @return `character` A vector containing hexadecimal colors 8 | #' @import magrittr 9 | #' @keywords internal 10 | #' @importFrom grDevices col2rgb 11 | prPrepareColors <- function(clr, n = NULL, ng = NULL, gtxt) { 12 | clr <- sapply(clr, function(a_clr) { 13 | if (a_clr == "none") { 14 | return(a_clr) 15 | } 16 | if (grepl("^#[0-9ABCDEFabcdef]{3,3}$", a_clr)) { 17 | a_clr %<>% 18 | substring(first = 2) %>% 19 | strsplit(split = "") %>% 20 | unlist() %>% 21 | sapply(FUN = rep, times = 2) %>% 22 | paste(collapse = "") %>% 23 | tolower() %>% 24 | paste0("#", .) 25 | } else { 26 | a_clr %<>% 27 | col2rgb %>% 28 | as.hexmode() %>% 29 | as.character() %>% 30 | paste(collapse = "") %>% 31 | paste0("#", .) 32 | } 33 | }, USE.NAMES = FALSE) 34 | 35 | if (!is.null(ng)) { 36 | # Split groups into separate if the gtxt is "" 37 | if (any(gtxt == "")) { 38 | tmp <- c() 39 | for (i in 1:length(ng)) { 40 | if (gtxt[i] != "" && 41 | !is.na(gtxt[i])) { 42 | tmp <- c( 43 | tmp, 44 | ng[i] 45 | ) 46 | } else { 47 | tmp <- c( 48 | tmp, 49 | rep(1, ng[i]) 50 | ) 51 | } 52 | } 53 | ng <- tmp 54 | } 55 | 56 | clr <- rep(clr, length.out = length(ng)) 57 | attr(clr, "groups") <- 58 | Map(rep, clr, length.out = ng) 59 | } else if (!is.null(n)) { 60 | clr <- rep(clr, length.out = n) 61 | } 62 | 63 | return(clr) 64 | } 65 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(htmlTable,data.frame) 4 | S3method(htmlTable,default) 5 | S3method(htmlTable,matrix) 6 | S3method(interactiveTable,default) 7 | S3method(interactiveTable,htmlTable) 8 | S3method(knit_print,htmlTable) 9 | S3method(knit_print,interactiveTable) 10 | S3method(print,htmlTable) 11 | S3method(print,interactiveTable) 12 | S3method(tidyHtmlTable,data.frame) 13 | S3method(tidyHtmlTable,default) 14 | S3method(txtRound,data.frame) 15 | S3method(txtRound,default) 16 | S3method(txtRound,matrix) 17 | S3method(txtRound,table) 18 | export(addHtmlTableStyle) 19 | export(concatHtmlTables) 20 | export(getHtmlTableStyle) 21 | export(getHtmlTableTheme) 22 | export(hasHtmlTableStyle) 23 | export(htmlTable) 24 | export(htmlTableWidget) 25 | export(htmlTableWidgetOutput) 26 | export(interactiveTable) 27 | export(outputInt) 28 | export(prepGroupCounts) 29 | export(pvalueFormatter) 30 | export(renderHtmlTableWidget) 31 | export(setHtmlTableTheme) 32 | export(splitLines4Table) 33 | export(tblNoLast) 34 | export(tblNoNext) 35 | export(tidyHtmlTable) 36 | export(txtInt) 37 | export(txtMergeLines) 38 | export(txtPval) 39 | export(txtRound) 40 | export(vector2string) 41 | import(checkmate) 42 | import(htmlwidgets) 43 | import(magrittr) 44 | importFrom(grDevices,col2rgb) 45 | importFrom(grDevices,colorRampPalette) 46 | importFrom(htmltools,htmlEscape) 47 | importFrom(knitr,asis_output) 48 | importFrom(knitr,knit_print) 49 | importFrom(methods,formalArgs) 50 | importFrom(methods,setClass) 51 | importFrom(rstudioapi,getActiveDocumentContext) 52 | importFrom(rstudioapi,isAvailable) 53 | importFrom(stats,na.omit) 54 | importFrom(stringr,str_interp) 55 | importFrom(stringr,str_replace) 56 | importFrom(stringr,str_replace_all) 57 | importFrom(stringr,str_split) 58 | importFrom(stringr,str_trim) 59 | importFrom(utils,as.roman) 60 | importFrom(utils,browseURL) 61 | importFrom(utils,head) 62 | importFrom(utils,tail) 63 | -------------------------------------------------------------------------------- /man/txtPval.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/txtFrmt.R 3 | \name{txtPval} 4 | \alias{txtPval} 5 | \title{Formats the p-values} 6 | \usage{ 7 | txtPval(pvalues, lim.2dec = 10^-2, lim.sig = 10^-4, html = TRUE, ...) 8 | } 9 | \arguments{ 10 | \item{pvalues}{The p-values} 11 | 12 | \item{lim.2dec}{The limit for showing two decimals. E.g. 13 | the p-value may be \code{0.056} and we may want to keep the two decimals in order 14 | to emphasize the proximity to the all-mighty \code{0.05} p-value and set this to 15 | \eqn{10^-2}. This allows that a value of \code{0.0056} is rounded to \code{0.006} and this 16 | makes intuitive sense as the \code{0.0056} level as this is well below 17 | the \code{0.05} value and thus not as interesting to know the exact proximity to 18 | \code{0.05}. \emph{Disclaimer:} The \code{0.05}-limit is really silly and debated, unfortunately 19 | it remains a standard and this package tries to adapt to the current standards in order 20 | to limit publication associated issues.} 21 | 22 | \item{lim.sig}{The significance limit for the less than sign, i.e. the '\code{<}'} 23 | 24 | \item{html}{If the less than sign should be \code{<} or \verb{<} as needed for HTML output.} 25 | 26 | \item{...}{Currently only used for generating warnings of deprecated call parameters.} 27 | } 28 | \value{ 29 | vector 30 | } 31 | \description{ 32 | Gets formatted p-values. For instance 33 | you often want \code{0.1234} to be \code{0.12} while also 34 | having two values up until a limit, 35 | i.e. \code{0.01234} should be \code{0.012} while 36 | \code{0.001234} should be \code{0.001}. Furthermore you 37 | want to have \verb{< 0.001} as it becomes ridiculous 38 | to report anything below that value. 39 | } 40 | \examples{ 41 | txtPval(c(0.10234,0.010234, 0.0010234, 0.000010234)) 42 | } 43 | \seealso{ 44 | Other text formatters: 45 | \code{\link{txtInt}()}, 46 | \code{\link{txtMergeLines}()}, 47 | \code{\link{txtRound}()} 48 | } 49 | \concept{text formatters} 50 | -------------------------------------------------------------------------------- /man/prGetRgroupLine.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/htmlTable_render_getRgroupLine.R 3 | \name{prGetRgroupLine} 4 | \alias{prGetRgroupLine} 5 | \title{Gets the number of \code{rgroup} HTML line} 6 | \usage{ 7 | prGetRgroupLine( 8 | x, 9 | total_columns = NULL, 10 | rgroup = NULL, 11 | rgroup_iterator = NULL, 12 | cspan = NULL, 13 | rnames = NULL, 14 | style = NULL, 15 | cgroup_spacer_cells = NULL, 16 | style_list = NULL, 17 | prepped_row_css = NULL 18 | ) 19 | } 20 | \arguments{ 21 | \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} 22 | it takes a string of the class \code{htmlTable} as \code{x} argument.} 23 | 24 | \item{total_columns}{The total number of columns including the \code{rowlabel} and the 25 | spacer cells} 26 | 27 | \item{rgroup}{A vector of character strings containing headings for row groups. 28 | \code{n.rgroup} must be present when \code{rgroup} is given. See 29 | detailed description in section below.} 30 | 31 | \item{rgroup_iterator}{An integer indicating the \code{rgroup}} 32 | 33 | \item{cspan}{The column span of the current \code{rgroup}} 34 | 35 | \item{rnames}{Default row names are generated from \code{\link[base:colnames]{rownames(x)}}. If you 36 | provide \code{FALSE} then it will skip the row names. \emph{Note:} For \code{data.frames} 37 | if you do \code{\link[base:colnames]{rownames(my_dataframe) <- NULL}} it still has 38 | row names. Thus you need to use \code{FALSE} if you want to 39 | supress row names for \code{data.frames}.} 40 | 41 | \item{style}{The css style corresponding to the \code{rgroup} css style that includes 42 | the color specific for the \code{rgroup}, i.e. \code{col.rgroup}.} 43 | 44 | \item{cgroup_spacer_cells}{The vector indicating the position of the \code{cgroup} 45 | spacer cells} 46 | 47 | \item{prepped_row_css}{The \code{css.cell} information for this particular row.} 48 | } 49 | \description{ 50 | Gets the number of \code{rgroup} HTML line 51 | } 52 | \keyword{internal} 53 | -------------------------------------------------------------------------------- /R/tblNo.R: -------------------------------------------------------------------------------- 1 | #' Gets the last table number 2 | #' 3 | #' The function relies on `options("table_counter")` 4 | #' in order to keep track of the last number. 5 | #' 6 | #' @param roman Whether or not to use roman numbers instead 7 | #' of arabic. Can also be set through `options(table_caption_no_roman = TRUE)` 8 | #' 9 | #' @export 10 | #' @examples 11 | #' org_opts <- options(table_counter=1) 12 | #' tblNoLast() 13 | #' options(org_opts) 14 | #' @family table functions 15 | #' @importFrom utils as.roman 16 | tblNoLast <- function(roman = getOption("table_counter_roman", 17 | FALSE)){ 18 | last_no <- getOption("table_counter") 19 | if (is.logical(last_no) || 20 | is.null(last_no)){ 21 | stop("You cannot call the get last figure number", 22 | " when there has been no prior figure registerd.", 23 | " In other words, you need to call the fiCapNo()", 24 | " on a figure before you call this function.", 25 | " If you want the next number then call figCapNoNext()", 26 | " instead of this function.") 27 | } 28 | 29 | if (roman) 30 | last_no <- as.character(as.roman(last_no)) 31 | 32 | return(last_no) 33 | } 34 | 35 | #' Gets the next table number 36 | #' 37 | #' The function relies on `options("table_counter")` 38 | #' in order to keep track of the last number. 39 | #' 40 | #' @inheritParams tblNoLast 41 | #' @export 42 | #' @examples 43 | #' org_opts <- options(table_counter=1) 44 | #' tblNoNext() 45 | #' options(org_opts) 46 | #' @family table functions 47 | #' @importFrom utils as.roman 48 | tblNoNext <- function(roman = getOption("table_counter_roman", 49 | FALSE)){ 50 | last_no <- getOption("table_counter") 51 | if (is.logical(last_no)){ 52 | if (last_no == FALSE) 53 | stop("You cannot call the get last figure number", 54 | " when you have explicitly set the fig_cap_no", 55 | " option to false.") 56 | last_no <- 0 57 | 58 | }else if (is.null(last_no)){ 59 | last_no <- 0 60 | } 61 | 62 | next_no <- last_no + 1 63 | 64 | if (roman) 65 | next_no <- as.character(as.roman(next_no)) 66 | 67 | return(next_no) 68 | } 69 | -------------------------------------------------------------------------------- /man/prPrepareCgroup.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/htmlTable_helpers_prepareCgroup.R 3 | \name{prPrepareCgroup} 4 | \alias{prPrepareCgroup} 5 | \title{Prepares the cgroup argument} 6 | \usage{ 7 | prPrepareCgroup(x, cgroup = NULL, n.cgroup = NULL, style_list) 8 | } 9 | \arguments{ 10 | \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} 11 | it takes a string of the class \code{htmlTable} as \code{x} argument.} 12 | 13 | \item{cgroup}{A vector, matrix or list of character strings defining major column header. The default 14 | is to have none. These elements are also known as \emph{column spanners}. If you want a column \emph{not} 15 | to have a spanner then put that column as "". If you pass cgroup and \code{n.crgroup} as 16 | matrices you can have column spanners for several rows. See cgroup section below for details.} 17 | 18 | \item{n.cgroup}{An integer vector, matrix or list containing the number of columns for which each element in 19 | cgroup is a heading. For example, specify \code{cgroup=c("Major_1","Major_2")}, 20 | \code{n.cgroup=c(3,3)} if \code{"Major_1"} is to span columns 1-3 and 21 | \code{"Major_2"} is to span columns 4-6. 22 | \code{rowlabel} does not count in the column numbers. You can omit \code{n.cgroup} 23 | if all groups have the same number of columns. If the \code{n.cgroup} is one less than 24 | the number of columns in the matrix/data.frame then it automatically adds those.} 25 | } 26 | \value{ 27 | \code{list(cgroup, n.cgroup, align.cgroup, cgroup_spacer_cells)} 28 | } 29 | \description{ 30 | Due to the complicated structure of multilevel cgroups there 31 | some preparation for the cgroup options is required. 32 | } 33 | \seealso{ 34 | Other hidden helper functions for htmlTable: 35 | \code{\link{prAddCells}()}, 36 | \code{\link{prAddEmptySpacerCell}()}, 37 | \code{\link{prAddSemicolon2StrEnd}()}, 38 | \code{\link{prEscapeHtml}()}, 39 | \code{\link{prGetCgroupHeader}()}, 40 | \code{\link{prGetRowlabelPos}()}, 41 | \code{\link{prGetStyle}()}, 42 | \code{\link{prPrepInputMatrixDimensions}()}, 43 | \code{\link{prPrepareAlign}()}, 44 | \code{\link{prTblNo}()} 45 | } 46 | \concept{hidden helper functions for htmlTable} 47 | \keyword{internal} 48 | -------------------------------------------------------------------------------- /.lintr: -------------------------------------------------------------------------------- 1 | linters: with_defaults( 2 | line_length_linter(120), 3 | paren_brace_linter = NULL, # 229 4 | object_name_linter = NULL, # It is mostly camel case but there are historical mistakes that we have to liv with 5 | object_length_linter = NULL, # Short names are nice but internal long names are easier to work with 6 | infix_spaces_linter = NULL, # 126 7 | commas_linter = NULL, # 52 8 | spaces_left_parentheses_linter = NULL, # 52 9 | assignment_linter = NULL, # 29 10 | seq_linter = NULL, # 28 11 | single_quotes_linter = NULL, # 25 12 | cyclocomp_linter = NULL, # 12 13 | function_left_parentheses_linter = NULL, # 12 14 | object_usage_linter = NULL, # 7 15 | open_curly_linter = NULL, # 5 16 | trailing_whitespace_linter = NULL, # 2 17 | closed_curly_linter = NULL, # 1 18 | commented_code_linter = NULL, # 1 19 | dummy_linter = NULL 20 | ) 21 | exclusions: list( 22 | "data/SCB.rda", 23 | "man/addStyles.Rd", 24 | "man/concatHtmlTables.Rd", 25 | "man/getHtmlTableTheme.Rd", 26 | "man/htmlTable.Rd", 27 | "man/htmlTableWidget-shiny.Rd", 28 | "man/htmlTableWidget.Rd", 29 | "man/interactiveTable.Rd", 30 | "man/outputInt.Rd", 31 | "man/prAddCells.Rd", 32 | "man/prAddSemicolon2StrEnd.Rd", 33 | "man/prAttr4RgroupAdd.Rd", 34 | "man/prConvertDfFactors.Rd", 35 | "man/prEscapeHtml.Rd", 36 | "man/prGetAlign.Rd", 37 | "man/prGetCgroupHeader.Rd", 38 | "man/prGetRgroupLine.Rd", 39 | "man/prGetRowlabelPos.Rd", 40 | "man/prGetScriptString.Rd", 41 | "man/prGetStyle.Rd", 42 | "man/prGetThead.Rd", 43 | "man/prIsNotebook.Rd", 44 | "man/prMergeClr.Rd", 45 | "man/prPrepareAlign.Rd", 46 | "man/prPrepareCgroup.Rd", 47 | "man/prPrepareColors.Rd", 48 | "man/prPrepareCss.Rd", 49 | "man/prPrepInputMatrixDimensions.Rd", 50 | "man/prSkipRownames.Rd", 51 | "man/prTblNo.Rd", 52 | "man/pvalueFormatter.Rd", 53 | "man/SCB.Rd", 54 | "man/setHtmlTableTheme.Rd", 55 | "man/splitLines4Table.Rd", 56 | "man/tblNoLast.Rd", 57 | "man/tblNoNext.Rd", 58 | "man/tidyHtmlTable.Rd", 59 | "man/txtInt.Rd", 60 | "man/txtMergeLines.Rd", 61 | "man/txtPval.Rd", 62 | "man/txtRound.Rd", 63 | "man/vector2string.Rd", 64 | "vignettes/complex_tables.Rmd", 65 | "vignettes/custom.css", 66 | "vignettes/general.Rmd", 67 | "vignettes/tidyHtmlTable.Rmd" 68 | ) 69 | -------------------------------------------------------------------------------- /R/htmlTable_render_prAddEmptySpacerCell.R: -------------------------------------------------------------------------------- 1 | #' Add an empty cell 2 | #' 3 | #' 4 | #' Depending on the `spacer.celltype` set in [addHtmlTableStyle()] we 5 | #' will use different spacer cells. 6 | #' 7 | #' @param cell_style The style of the current cell that should be applied to all cells 8 | #' @param align_style The style from [prGetAlign()] 9 | #' @param cell_tag What HTML tag to use 10 | #' @param colspan The number of rows each tag should span 11 | #' 12 | #' @return `string` 13 | #' @keywords internal 14 | #' @inheritParams htmlTable 15 | #' @family hidden helper functions for htmlTable 16 | #' @importFrom stringr str_interp str_replace 17 | prAddEmptySpacerCell <- function(x, 18 | style_list, 19 | cell_style, 20 | align_style, 21 | cell_tag = c("td", "th"), 22 | colspan = 1) { 23 | str_to_append <- switch(style_list$spacer.celltype, 24 | single_empty = "<${TAG} style='${CELL_STYLE}' colspan=${COLSPAN}>${CONTENT}", 25 | skip = "", 26 | double_cell = paste("<${TAG} style='${CELL_STYLE}${CELL_STYLE_BORDER}' colspan=${COLSPAN}>${CONTENT}", 27 | "<${TAG} style='${CELL_STYLE}' colspan=${COLSPAN}>${CONTENT}")) 28 | 29 | if (is.null(str_to_append)) { 30 | stop("The cell style has not been implemented") 31 | } 32 | 33 | border_style = "" 34 | if (attr(align_style, "has_border")) { 35 | border_style = paste("border-right:", attr(align_style, "border_style")$default) 36 | } 37 | 38 | variables <- list(TAG = match.arg(cell_tag), 39 | CELL_STYLE = prGetStyle(style_list$spacer.css, 40 | cell_style), 41 | COLSPAN = colspan, 42 | CONTENT = style_list$spacer.content, 43 | CELL_STYLE_BORDER = border_style) 44 | str_to_append %<>% str_interp(variables) 45 | 46 | paste0(x, str_to_append) 47 | } 48 | 49 | 50 | prGetEmptySpacerCellSize <- function(style_list) { 51 | no <- switch(style_list$spacer.celltype, 52 | single_empty = 1, 53 | skip = 0, 54 | double_cell = 2) 55 | 56 | if (is.null(no)) { 57 | stop("The cell style has not been implemented") 58 | } 59 | 60 | return(no) 61 | } -------------------------------------------------------------------------------- /man/concatHtmlTables.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/concatHtmlTables.R 3 | \name{concatHtmlTables} 4 | \alias{concatHtmlTables} 5 | \title{Function for concatenating \code{\link[=htmlTable]{htmlTable()}}s} 6 | \usage{ 7 | concatHtmlTables(tables, headers = NULL) 8 | } 9 | \arguments{ 10 | \item{tables}{A list of \code{\link[=htmlTable]{htmlTable()}}s to be concatenated} 11 | 12 | \item{headers}{Either a string or a vector of strings that function as 13 | a header for each table. If none is provided it will use the names of 14 | the table list or a numeric number.} 15 | } 16 | \value{ 17 | \code{\link[=htmlTable]{htmlTable()}} class object 18 | } 19 | \description{ 20 | Function for concatenating \code{\link[=htmlTable]{htmlTable()}}s 21 | } 22 | \examples{ 23 | library(magrittr) 24 | 25 | # Basic example 26 | tables <- list() 27 | output <- matrix(1:4, 28 | ncol = 2, 29 | dimnames = list(list("Row 1", "Row 2"), 30 | list("Column 1", "Column 2"))) 31 | tables[["Simple table"]] <- htmlTable(output) 32 | 33 | 34 | # An advanced output 35 | output <- matrix(ncol = 6, nrow = 8) 36 | 37 | for (nr in 1:nrow(output)) { 38 | for (nc in 1:ncol(output)) { 39 | output[nr, nc] <- 40 | paste0(nr, ":", nc) 41 | } 42 | } 43 | 44 | tables[["Fancy table"]] <- output \%>\% 45 | addHtmlTableStyle(align = "r", 46 | col.columns = c(rep("none", 2), 47 | rep("#F5FBFF", 4)), 48 | col.rgroup = c("none", "#F7F7F7"), 49 | css.cell = "padding-left: .5em; padding-right: .2em;") \%>\% 50 | htmlTable(header = paste(c("1st", "2nd", 51 | "3rd", "4th", 52 | "5th", "6th"), 53 | "hdr"), 54 | rnames = paste(c("1st", "2nd", 55 | "3rd", 56 | paste0(4:8, "th")), 57 | "row"), 58 | rgroup = paste("Group", LETTERS[1:3]), 59 | n.rgroup = c(2,4,nrow(output) - 6), 60 | cgroup = rbind(c("", "Column spanners", NA), 61 | c("", "Cgroup 1", "Cgroup 2†")), 62 | n.cgroup = rbind(c(1,2,NA), 63 | c(2,2,2)), 64 | caption = "Basic table with both column spanners (groups) and row groups", 65 | tfoot = "† A table footer commment", 66 | cspan.rgroup = 2) 67 | 68 | concatHtmlTables(tables) 69 | } 70 | -------------------------------------------------------------------------------- /R/htmlTable_helpers_getAlign.R: -------------------------------------------------------------------------------- 1 | #' Gets alignment 2 | #' 3 | #' @param index The index of the align parameter of interest 4 | #' @family hidden helper functions for 5 | #' @keywords internal 6 | #' @inheritParams addHtmlTableStyle 7 | prGetAlign <- function(align, 8 | index, 9 | style_list = NULL, 10 | spacerCell = FALSE, 11 | followed_by_spacer_cell = FALSE, 12 | previous_was_spacer_cell = FALSE) { 13 | segm_rgx <- "[^lrc]*[rlc][^lrc]*" 14 | 15 | res_align <- align 16 | align <- "" 17 | # Loop to remove every element prior to the one of interest 18 | for (i in 1:index) { 19 | if (nchar(res_align) == 0) { 20 | stop("Requested column outside of span, ", index, " > ", i) 21 | } 22 | 23 | rmatch <- regexpr(segm_rgx, res_align) 24 | lrc_data <- substr(res_align, 1, rmatch + attr(rmatch, "match.length") - 1) 25 | res_align <- substring(res_align, rmatch + attr(rmatch, "match.length")) 26 | } 27 | 28 | styles <- c() 29 | border_in_spacer_cell <- FALSE 30 | if (!is.null(style_list) && style_list$spacer.celltype == "double_cell") { 31 | border_in_spacer_cell = TRUE 32 | } 33 | 34 | border_position <- NULL 35 | if (grepl("^\\|", lrc_data)) { 36 | border_position <- "left" 37 | } 38 | 39 | if (grepl("\\|$", lrc_data)) { 40 | border_position <- c(border_position, "right") 41 | } 42 | 43 | border_style <- list(default = getOption("htmlTable.css.border", default = "1px solid black")) 44 | 45 | if (!is.null(border_position)) { 46 | for (pos in border_position) { 47 | border_name <- paste0("border-", pos) 48 | border_style[[pos]] <- getOption(paste0("htmlTable.css.", border_name), 49 | default = border_style$default) 50 | 51 | if (!spacerCell && 52 | (!border_in_spacer_cell || 53 | (!followed_by_spacer_cell && pos == "right") || 54 | (!previous_was_spacer_cell && pos == "left"))) { 55 | styles[border_name] <- border_style[[pos]] 56 | } 57 | } 58 | } 59 | 60 | if (grepl("l", lrc_data)) { 61 | styles["text-align"] <- "left" 62 | } 63 | if (grepl("c", lrc_data)) { 64 | styles["text-align"] <- "center" 65 | } 66 | if (grepl("r", lrc_data)) { 67 | styles["text-align"] <- "right" 68 | } 69 | 70 | return(structure(styles, 71 | has_border = !is.null(border_position), 72 | border_position = border_position, 73 | border_style = border_style)) 74 | } 75 | -------------------------------------------------------------------------------- /R/htmlTableWidget.R: -------------------------------------------------------------------------------- 1 | #' htmlTable with pagination widget 2 | #' 3 | #' This widget renders a table with pagination into an htmlwidget 4 | #' 5 | #' @param x A data frame to be rendered 6 | #' @param number_of_entries a numeric vector with the number of entries per page to show. 7 | #' If there is more than one number given, the user will be able to show the number 8 | #' of rows per page in the table. 9 | #' @param ... Additional parameters passed to htmlTable 10 | #' @inheritParams htmlwidgets::createWidget 11 | #' @import htmlwidgets 12 | #' @return an htmlwidget showing the paginated table 13 | #' @export 14 | htmlTableWidget <- function(x, number_of_entries = c(10, 25, 100), 15 | width = NULL, height = NULL, elementId = NULL, 16 | ...) { 17 | rendered_table <- htmlTable(x, ...) 18 | 19 | # forward options and variables using the input list: 20 | input <- list( 21 | thetable = rendered_table, 22 | options = list(number_of_entries = number_of_entries) 23 | ) 24 | 25 | # create widget 26 | htmlwidgets::createWidget( 27 | name = "htmlTableWidget", 28 | x = input, 29 | width = width, 30 | height = height, 31 | package = "htmlTable", 32 | elementId = elementId 33 | ) 34 | } 35 | 36 | #' Shiny bindings for htmlTableWidget 37 | #' 38 | #' Output and render functions for using htmlTableWidget within Shiny 39 | #' applications and interactive Rmd documents. 40 | #' 41 | #' @param outputId output variable to read from 42 | #' @param width,height Must be a valid CSS unit (like `'100%'`, `'400px'`, `'auto'`) or a number, 43 | #' which will be coerced to a string and have `'px'` appended. 44 | #' @param expr An expression that generates a [htmlTableWidget()] 45 | #' @param env The environment in which to evaluate `expr`. 46 | #' @param quoted Is `expr` a quoted expression (with `quote()`)? This 47 | #' is useful if you want to save an expression in a variable. 48 | #' 49 | #' @name htmlTableWidget-shiny 50 | #' 51 | #' @examples 52 | #' \dontrun{ 53 | #' # In the UI: 54 | #' htmlTableWidgetOutput("mywidget") 55 | #' # In the server: 56 | #' renderHtmlTableWidget({ 57 | #' htmlTableWidget(iris) 58 | #' }) 59 | #' } 60 | #' @export 61 | htmlTableWidgetOutput <- function(outputId, width = "100%", height = "400px") { 62 | htmlwidgets::shinyWidgetOutput(outputId, "htmlTableWidget", width, height, package = "htmlTable") 63 | } 64 | 65 | #' @rdname htmlTableWidget-shiny 66 | #' @export 67 | renderHtmlTableWidget <- function(expr, env = parent.frame(), quoted = FALSE) { 68 | if (!quoted) { 69 | expr <- substitute(expr) 70 | } # force quoted 71 | htmlwidgets::shinyRenderWidget(expr, htmlTableWidgetOutput, env, quoted = TRUE) 72 | } 73 | -------------------------------------------------------------------------------- /R/txtFrmt_round_data.frame.R: -------------------------------------------------------------------------------- 1 | #' @export 2 | #' @rdname txtRound 3 | #' @section Tidy-select with `data.frame`: 4 | #' 5 | #' The `txtRound` can use `data.frame` for input. This allows us to use 6 | #' [tidyselect](https://tidyselect.r-lib.org/articles/tidyselect.html) 7 | #' patterns as popularized by **dplyr**. 8 | #' 9 | #' @examples 10 | #' 11 | #' # Using a data.frame directly 12 | #' library(magrittr) 13 | #' data("mtcars") 14 | #' # If we want to round all the numerical values 15 | #' mtcars %>% 16 | #' txtRound(digits = 1) 17 | #' 18 | #' # If we want only want to round some columns 19 | #' mtcars %>% 20 | #' txtRound(wt, qsec_txt = qsec, digits = 1) 21 | #' @importFrom methods formalArgs 22 | txtRound.data.frame <- function(x, ..., digits = 0L){ 23 | safeLoadPkg("tidyselect") 24 | vars <- tidyselect::eval_select(rlang::expr(c(...)), x) 25 | vars <- vars[!(names(vars) %in% formalArgs(txtRound.default))] 26 | 27 | if (length(vars) == 0) { 28 | vars <- sapply(x, is.numeric) 29 | vars <- sapply(names(vars)[vars], function(cn) which(cn == colnames(x))) 30 | } 31 | 32 | call <- as.list(match.call()) 33 | 34 | # Drop function & x call arguments 35 | call[[1]] <- NULL 36 | call[[1]] <- NULL 37 | call <- Filter(function(argument_value) !is.language(argument_value) && 38 | (!is.name(argument_value) || 39 | !(as.character(argument_value) %in% colnames(x))), 40 | call) 41 | 42 | if (length(vars) > 0) { 43 | for (i in 1:length(vars)) { 44 | call$digits <- prPickDigits(colname = colnames(x)[vars[i]], 45 | colindex = i, 46 | total_cols = ncol(x), 47 | digits = digits) 48 | x[[names(vars)[i]]] <- do.call(txtRound, 49 | c(list(x = x[[vars[i]]]), call)) 50 | } 51 | } 52 | 53 | return(x) 54 | } 55 | 56 | 57 | prPickDigits <- function(colname, colindex, total_cols, digits) { 58 | if (length(digits) == 1 && is.numeric(digits)) return(digits) 59 | 60 | if (is.null(names(digits))) { 61 | if (total_cols == length(digits)) { 62 | return(digits[colindex]) 63 | } 64 | stop("Either provide digits as a single numerical or", 65 | " a named vector/list that we can pick elements from") 66 | } 67 | 68 | stopifnot(all(sapply(digits, is.numeric))) 69 | 70 | if (colname %in% names(digits)) { 71 | return(digits[[colname]]) 72 | } 73 | 74 | if (".default" %in% names(digits)) { 75 | return(digits[[".default"]]) 76 | } 77 | 78 | stop("The column '", colname, "' (pos. ", colindex, ") was not among provided digits: '", 79 | paste(names(digits), collapse = "', '"), "' and no '.default' was found.") 80 | } -------------------------------------------------------------------------------- /tests/testthat/test-htmlTable-dimnames.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | 3 | context("htmlTable - dimnames") 4 | 5 | test_that("First dimname should be converted to rgroup, tspanner or rowlabel", { 6 | var1 <- LETTERS[1:3] 7 | var2 <- LETTERS[c(4:5, 5)] 8 | basic_label <- 9 | table(var1, var2) %>% 10 | htmlTable(css.rgroup = "background: blue") 11 | 12 | expect_match(basic_label, "]+background: blue[^>]+>var1", 13 | info = "Expect the variable name to appear as an rgroup") 14 | expect_match(basic_label, "]+>  A", 15 | info = "Expect the variable name to appear as an rgroup") 16 | expect_match(basic_label, "]+>  B", 17 | info = "Expect the variable name to appear as an rgroup") 18 | expect_match(basic_label, "]+>  C", 19 | info = "Expect the variable name to appear as an rgroup") 20 | 21 | tspanner_label <- 22 | table(var1, var2) %>% 23 | htmlTable(rgroup=c("alt"), 24 | n.rgroup=c(3), 25 | css.tspanner = "background: red", 26 | css.rgroup = "background: blue") 27 | 28 | expect_match(tspanner_label, "]+background: red[^>]+>var1", 29 | info = "Expect the variable name to appear as an tspanner") 30 | expect_match(tspanner_label, "]+background: blue[^>]+>alt", 31 | info = "Expect the rgroup name to appear as usual") 32 | expect_match(tspanner_label, "]+>  A") 33 | expect_match(tspanner_label, "]+>  B") 34 | expect_match(tspanner_label, "]+>  C") 35 | 36 | 37 | rowlabel_label <- 38 | table(var1, var2) %>% 39 | htmlTable(rgroup=c("alt"), 40 | n.rgroup=c(3), 41 | tspanner=c("alt2"), 42 | n.tspanner = c(3), 43 | css.tspanner = "background: red", 44 | css.rgroup = "background: blue") 45 | 46 | expect_match(rowlabel_label, "]+background: red[^>]+>alt2", 47 | info = "Expect the variable name to appear as an tspanner") 48 | expect_match(rowlabel_label, "]+background: blue[^>]+>alt", 49 | info = "Expect the rgroup name to appear as usual") 50 | expect_match(rowlabel_label, "]+>  A") 51 | expect_match(rowlabel_label, "]+>  B") 52 | expect_match(rowlabel_label, "]+>  C") 53 | }) 54 | 55 | test_that("Second dimname should be converted to cgroup", { 56 | var1 <- LETTERS[1:3] 57 | var2 <- LETTERS[c(4:5, 5)] 58 | basic_label <- 59 | table(var1, var2) %>% 60 | htmlTable 61 | 62 | expect_match(basic_label, "]+>var2", 63 | info = "Expect the variable name to appear as a cgroup") 64 | }) 65 | -------------------------------------------------------------------------------- /vignettes/tidyHtmlTable.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Using tidyHtmlTable" 3 | author: "Stephen Gragg" 4 | date: "`r Sys.Date()`" 5 | output: rmarkdown::html_vignette 6 | vignette: > 7 | %\VignetteIndexEntry{Using tidyHtmlTable} 8 | %\VignetteEncoding{UTF-8} 9 | %\VignetteEngine{knitr::rmarkdown} 10 | editor_options: 11 | chunk_output_type: console 12 | --- 13 | 14 | # Introduction 15 | 16 | `tidyHtmlTable` acts as a wrapper function for the `htmlTable` 17 | function allowing columns to be mapped from the input data to specific htmlTable 18 | parameters in a manner similar to ggplot2. 19 | 20 | # Some Examples 21 | 22 | ## Prepare Data 23 | 24 | We'll begin by turning the `mtcars` data into a tidy dataset. The 25 | `pivot_longer` function is called to collect 3 performance metrics into a pair 26 | of key and value columns. 27 | 28 | ```{r, message=FALSE} 29 | library(magrittr) 30 | library(tidyr) 31 | library(dplyr) 32 | library(htmlTable) 33 | library(tibble) 34 | 35 | td <- mtcars %>% 36 | as_tibble(rownames = "rnames") %>% 37 | pivot_longer(names_to = "per_metric", 38 | cols = c(hp, mpg, qsec)) 39 | ``` 40 | 41 | Now we will compute 4 summary statistics for each of the 3 performance metrics. 42 | This will be further grouped by number of cylinders and gears. 43 | 44 | ```{r} 45 | tidy_summary <- td %>% 46 | group_by(cyl, gear, per_metric) %>% 47 | summarise(Mean = round(mean(value), 1), 48 | SD = round(sd(value), 1), 49 | Min = round(min(value), 1), 50 | Max = round(max(value), 1), 51 | .groups = 'drop') %>% 52 | pivot_longer(names_to = "summary_stat", 53 | cols = c(Mean, SD, Min, Max)) %>% 54 | ungroup() %>% 55 | mutate(gear = paste(gear, "Gears"), 56 | cyl = paste(cyl, "Cylinders")) 57 | ``` 58 | 59 | At this point, we are ready to implement the `htmlTable` function. 60 | Essentially, this constructs an html table using arguments similar to the 61 | `htmlTable` function. However, whereas `htmlTable` required the user to manually 62 | arrange the data and specify the column groups, headers, row names, row-groups, 63 | etc., each of these components of the table is mapped to a column within the 64 | input data. 65 | 66 | ## Output html table 67 | 68 | ### Example 1 69 | 70 | ```{r, warning=FALSE} 71 | tidy_summary %>% 72 | arrange(per_metric, summary_stat) %>% 73 | addHtmlTableStyle(align = "r") %>% 74 | tidyHtmlTable(header = gear, 75 | cgroup = cyl, 76 | rnames = summary_stat, 77 | rgroup = per_metric) 78 | ``` 79 | 80 | ### Example 2 81 | 82 | ```{r, warning=FALSE} 83 | tidy_summary %>% 84 | arrange(cyl, gear) %>% 85 | addHtmlTableStyle(align = "r") %>% 86 | tidyHtmlTable(header = summary_stat, 87 | cgroup = per_metric, 88 | rnames = gear, 89 | rgroup = cyl) 90 | ``` 91 | -------------------------------------------------------------------------------- /man/prGetCgroupHeader.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/htmlTable_render_getCgroupHeader.R 3 | \name{prGetCgroupHeader} 4 | \alias{prGetCgroupHeader} 5 | \title{Retrieve a header row} 6 | \usage{ 7 | prGetCgroupHeader( 8 | x, 9 | cgroup_vec, 10 | n.cgroup_vec, 11 | cgroup_vec.just, 12 | row_no, 13 | top_row_style, 14 | rnames, 15 | rowlabel = NULL, 16 | cgroup_spacer_cells, 17 | style_list, 18 | prepped_cell_css, 19 | css_4_cgroup_vec 20 | ) 21 | } 22 | \arguments{ 23 | \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} 24 | it takes a string of the class \code{htmlTable} as \code{x} argument.} 25 | 26 | \item{cgroup_vec}{The \code{cgroup} may be a \code{matrix}, this is 27 | just one row of that \code{matrix}} 28 | 29 | \item{n.cgroup_vec}{The same as above but for the counter} 30 | 31 | \item{cgroup_vec.just}{The same as above bot for the justification} 32 | 33 | \item{row_no}{The row number within the header group. Useful for multi-row 34 | headers when we need to output the \code{rowlabel} at the \code{pos.rowlabel} 35 | level.} 36 | 37 | \item{top_row_style}{The top row has a special style depending on 38 | the \code{ctable} option in the \code{htmlTable} call.} 39 | 40 | \item{rnames}{Default row names are generated from \code{\link[base:colnames]{rownames(x)}}. If you 41 | provide \code{FALSE} then it will skip the row names. \emph{Note:} For \code{data.frames} 42 | if you do \code{\link[base:colnames]{rownames(my_dataframe) <- NULL}} it still has 43 | row names. Thus you need to use \code{FALSE} if you want to 44 | supress row names for \code{data.frames}.} 45 | 46 | \item{rowlabel}{If the table has row names or \code{rnames}, 47 | \code{rowlabel} is a character string containing the 48 | column heading for the \code{rnames}.} 49 | 50 | \item{cgroup_spacer_cells}{The spacer cells due to the multiple cgroup levels. 51 | With multiple rows in cgroup we need to keep track of how many spacer cells 52 | occur between the columns. This variable contains is of the size \code{ncol(x)-1} 53 | and 0 if there is no cgroup element between.} 54 | 55 | \item{style_list}{The list with all the styles} 56 | } 57 | \value{ 58 | \code{string} 59 | } 60 | \description{ 61 | This function retrieves a header row, i.e. a row 62 | within the \verb{} elements on top of the table. Used by 63 | \code{\link[=htmlTable]{htmlTable()}}. 64 | } 65 | \seealso{ 66 | Other hidden helper functions for htmlTable: 67 | \code{\link{prAddCells}()}, 68 | \code{\link{prAddEmptySpacerCell}()}, 69 | \code{\link{prAddSemicolon2StrEnd}()}, 70 | \code{\link{prEscapeHtml}()}, 71 | \code{\link{prGetRowlabelPos}()}, 72 | \code{\link{prGetStyle}()}, 73 | \code{\link{prPrepInputMatrixDimensions}()}, 74 | \code{\link{prPrepareAlign}()}, 75 | \code{\link{prPrepareCgroup}()}, 76 | \code{\link{prTblNo}()} 77 | } 78 | \concept{hidden helper functions for htmlTable} 79 | \keyword{internal} 80 | -------------------------------------------------------------------------------- /R/htmlTable_render_print.R: -------------------------------------------------------------------------------- 1 | #' @rdname htmlTable 2 | #' @param useViewer If you are using RStudio there is a viewer thar can render 3 | #' the table within that is envoced if in [base::interactive()] mode. 4 | #' Set this to `FALSE` if you want to remove that functionality. You can 5 | #' also force the function to call a specific viewer by setting this to a 6 | #' viewer function, e.g. `useViewer = utils::browseURL` if you want to 7 | #' override the default RStudio viewer. Another option that does the same is to 8 | #' set the `options(viewer=utils::browseURL)` and it will default to that 9 | #' particular viewer (this is how RStudio decides on a viewer). 10 | #' *Note:* If you want to force all output to go through the 11 | #' [base::cat()] the set `[options][base::options](htmlTable.cat = TRUE)`. 12 | #' @export 13 | #' @importFrom utils browseURL 14 | print.htmlTable <- function(x, useViewer, ...) { 15 | args <- attr(x, "...") 16 | # Use the latest ... from the print call 17 | # and override the original htmlTable call ... 18 | # if there is a conflict 19 | print_args <- list(...) 20 | for (n in names(print_args)) { 21 | args[[n]] <- print_args[[n]] 22 | } 23 | 24 | # Since the print may be called from another print function 25 | # it may be handy to allow functions to use attributes for the 26 | # useViewer parameter 27 | if (missing(useViewer)) { 28 | if ("useViewer" %in% names(args) && 29 | (is.logical(args$useViewer) || 30 | is.function(args$useViewer))) { 31 | useViewer <- args$useViewer 32 | args$useViewer <- NULL 33 | } else { 34 | useViewer <- TRUE 35 | } 36 | } 37 | 38 | if (interactive() && 39 | !getOption("htmlTable.cat", FALSE) && 40 | (is.function(useViewer) || 41 | useViewer != FALSE)) { 42 | if (is.null(args$file)) { 43 | args$file <- tempfile(fileext = ".html") 44 | } 45 | 46 | htmlPage <- paste("", 47 | "", 48 | "", 49 | "", 50 | "", 51 | "
", 52 | enc2utf8(x), 53 | "
", 54 | "", 55 | "", 56 | sep = "\n" 57 | ) 58 | # We only want to use those arguments that are actually in cat 59 | # anything else that may have inadvertadly slipped in should 60 | # be ignored or it will be added to the output 61 | cat_args <- args 62 | cat_args <- cat_args[names(cat_args) %in% names(formals(cat))[-1]] 63 | do.call(cat, c(htmlPage, cat_args)) 64 | 65 | if (is.function(useViewer)) { 66 | useViewer(args$file) 67 | } else { 68 | viewer <- getOption("viewer") 69 | if (!is.null(viewer) && 70 | is.function(viewer)) { 71 | # (code to write some content to the file) 72 | viewer(args$file) 73 | } else { 74 | utils::browseURL(args$file) 75 | } 76 | } 77 | } else { 78 | cat_args <- args 79 | cat_args <- cat_args[names(cat_args) %in% names(formals(cat))[-1]] 80 | do.call(cat, c(x, cat_args)) 81 | } 82 | 83 | invisible(x) 84 | } 85 | -------------------------------------------------------------------------------- /tests/testthat/test-htmlTable_dates.R: -------------------------------------------------------------------------------- 1 | require(testthat) 2 | require(lubridate, quietly = TRUE, warn.conflicts = FALSE) 3 | require(htmlTable, quietly = TRUE, warn.conflicts = FALSE) 4 | require(chron, quietly = TRUE, warn.conflicts = FALSE) 5 | 6 | context('dates within htmlTable') 7 | 8 | # A simple example 9 | test_that("should be converted into strings (if fails check availability of chron package)", { 10 | skip_if_not_installed("lubridate") 11 | skip_if_not_installed("chron") 12 | 13 | # Below example is created using lemna's example: 14 | # library(lubridate) 15 | # library(chron) 16 | # df_dates <- data.frame(ID = 1:3, 17 | # contact_Date = c(today(), 18 | # today() - 1, 19 | # today() - 2)) 20 | # 21 | # df_dates$contact_posix <- strptime(as.POSIXct(df_dates$contact_Date), 22 | # format = "%Y-%m-%d") 23 | # df_dates$contact_chron <- chron(as.character(df_dates$contact_Date), 24 | # format = "Y-m-d", 25 | # out.format = "Y-m-d") 26 | 27 | df_dates <- structure(list(contact_Date = structure(c(17092, 17091, 17090), 28 | class = "Date"), 29 | contact_posix = structure(list(sec = c(0, 0, 0), 30 | min = c(0L, 0L, 0L), 31 | hour = c(0L, 0L, 0L), 32 | mday = c(18L, 17L, 16L), 33 | mon = c(9L, 9L, 9L), 34 | year = c(116L, 116L, 116L), 35 | wday = c(2L, 1L, 0L), 36 | yday = c(291L, 290L, 289L), 37 | isdst = c(1L, 1L, 1L), 38 | zone = c("CEST", "CEST", "CEST"), 39 | gmtoff = c(NA_integer_, NA_integer_, NA_integer_)), 40 | .Names = c("sec", "min", "hour", "mday", "mon", "year", "wday", "yday", "isdst", "zone", "gmtoff"), 41 | class = c("POSIXlt", "POSIXt")), 42 | contact_chron = structure(c(17092, 17091, 17090), 43 | format = "Y-m-d", 44 | origin = structure(c(1, 1, 1970), .Names = c("month", "day", "year")), 45 | class = c("dates", "times"))), 46 | .Names = c("contact_Date", "contact_posix", "contact_chron"), 47 | row.names = c(NA, -3L), 48 | class = "data.frame") 49 | 50 | table_str <- htmlTable(df_dates, rnames = FALSE) 51 | expect_match(table_str, "[^<]+]+>2016-10-16[^<]+]+>2016-10-16[^<]+]+>(20|)16-10-16") 52 | }) 53 | -------------------------------------------------------------------------------- /tests/testthat/test-htmlTable_total.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | 3 | context("htmlTable - the total argument") 4 | test_that("Throws errors",{ 5 | mx <- matrix(1, ncol=3, nrow=6) 6 | expect_error(htmlTable(mx, total = c(TRUE, TRUE))) 7 | expect_error(htmlTable(mx, total = c(TRUE, TRUE), 8 | tspanner = letters[1:3], n.tspanner = rep(2, times = 3))) 9 | expect_error(htmlTable(mx, total = -1)) 10 | expect_error(htmlTable(mx, total = nrow(mx) + 1)) 11 | expect_error(htmlTable(mx, total = "asdasd")) 12 | }) 13 | 14 | test_that("Correct rows",{ 15 | mx <- matrix(1:6, ncol=3, nrow=6) 16 | table_str <- htmlTable(mx, 17 | css.total = "color: red", 18 | total=TRUE) 19 | expect_match(table_str, "]*>[^>]+color: red[^>]+>6") 20 | 21 | table_str <- htmlTable(mx, 22 | css.total = "color: red", 23 | total=4) 24 | expect_match(table_str, "]*>[^>]+color: red[^>]+>4") 25 | 26 | table_str <- htmlTable(mx, 27 | css.total = "color: red", 28 | total=c(4, 2)) 29 | expect_false(grepl("]*>[^>]+color: red[^>]+>[1356789]+", table_str)) 30 | expect_match(table_str, "]*>[^>]+color: red[^>]+>2") 31 | expect_match(table_str, "]*>[^>]+color: red[^>]+>4") 32 | 33 | table_str <- htmlTable(mx, 34 | css.total = "color: red", 35 | total=c(4, 2)) 36 | expect_false(grepl("]*>[^>]+color: red[^>]+>[1356789]+", table_str)) 37 | expect_match(table_str, "]*>[^>]+color: red[^>]+>2") 38 | expect_match(table_str, "]*>[^>]+color: red[^>]+>4") 39 | }) 40 | 41 | test_that("Check tspanner", { 42 | mx <- matrix(1:6, ncol=3, nrow=6) 43 | table_str <- htmlTable(mx, tspanner = letters[1:2], n.tspanner = c(3, 3), 44 | css.total = "color: red", 45 | total="tspanner") 46 | expect_false(grepl("]*>[^>]+color: red[^>]+>[1245789]+", table_str)) 47 | expect_match(table_str, "]*>[^>]+color: red[^>]+>3") 48 | expect_match(table_str, "]*>[^>]+color: red[^>]+>6") 49 | }) 50 | 51 | test_that("Check choosing css.style", { 52 | mx <- matrix(1:6, ncol=3, nrow=6) 53 | table_str <- htmlTable(mx, tspanner = letters[1:2], n.tspanner = c(3, 3), 54 | css.total = c("color: red", "color: green"), 55 | total="tspanner") 56 | expect_false(grepl("]*>[^>]+color: red[^>]+>[1245789]+", table_str)) 57 | expect_match(table_str, "]*>[^>]+color: red[^>]+>3") 58 | expect_match(table_str, "]*>[^>]+color: green[^>]+>6") 59 | }) 60 | 61 | test_that("The total should be added to the output if used with addmargins", { 62 | var1 <- LETTERS[1:3] 63 | var2 <- LETTERS[c(4:5, 5)] 64 | total_out <- 65 | table(var1, var2) %>% 66 | addmargins %>% 67 | htmlTable(css.total = "background: purple") 68 | 69 | expect_match(total_out, "]+background: purple[^>]+>[^>]*Sum", 70 | info = "Expect the variable name to appear as a cgroup") 71 | 72 | expect_match(total_out, "]*>var2", 73 | info = "Expect the variable name to appear as a cgroup") 74 | }) 75 | -------------------------------------------------------------------------------- /tests/testthat/test-htmlTable_styles.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(XML) 3 | 4 | context("htmlTable - styles check") 5 | 6 | test_that("Check that row styles are present",{ 7 | mx <- 8 | matrix(ncol=6, nrow=8) 9 | rownames(mx) <- paste(c("1st", "2nd", 10 | "3rd", 11 | paste0(4:8, "th")), 12 | "row") 13 | colnames(mx) <- paste(c("1st", "2nd", 14 | "3rd", 15 | paste0(4:6, "th")), 16 | "hdr") 17 | 18 | for (nr in 1:nrow(mx)){ 19 | for (nc in 1:ncol(mx)){ 20 | mx[nr, nc] <- 21 | paste0(nr, ":", nc) 22 | } 23 | } 24 | 25 | css.cell = rep("font-size: 1em", times = ncol(mx) + 1) 26 | css.cell[1] = "font-size: 2em" 27 | out <- htmlTable(mx, 28 | css.cell=css.cell, 29 | cgroup = c("Cgroup 1", "Cgroup 2"), 30 | n.cgroup = c(2,4)) 31 | for (n in rownames(mx)) { 32 | expect_match(out, sprintf("\n[^<]*]+>%s", n)) 33 | } 34 | for (nr in 1:nrow(mx)){ 35 | for (nc in 1:ncol(mx)){ 36 | expect_match(out, sprintf("\n[^<]*]+>%s", mx[nr, nc]) ) 37 | } 38 | } 39 | }) 40 | 41 | 42 | test_that("Check prPrepareCss",{ 43 | mx <- matrix(1:5, ncol = 5, nrow = 1) 44 | rownames(mx) <- "1st" 45 | colnames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:ncol(mx), "th")), "hdr") 46 | 47 | css.cell = rep("font-size: 1em", times = ncol(mx) + 1) 48 | css.cell[1] = "font-size: 2em" 49 | out <- prPrepareCss(mx, css = css.cell, header = names(mx), rnames = rownames(mx)) 50 | expect_equal(dim(out), dim(mx)) 51 | 52 | 53 | css.cell = matrix("padding-left: .5em;", nrow = nrow(mx) + 1, ncol = ncol(mx)) 54 | out <- prPrepareCss(mx, css = css.cell, header = colnames(mx), rnames = rownames(mx)) 55 | expect_equal(dim(out), dim(mx)) 56 | }) 57 | 58 | 59 | test_that("Test prGetStyle merge funciton", { 60 | styles <- c(background = "black", border ="1px solid grey") 61 | expect_equivalent(length(prGetStyle(styles)), 1) 62 | expect_match(prGetStyle(styles), "background: black;") 63 | expect_match(prGetStyle(styles), "border: [^;]+grey;") 64 | expect_match(prGetStyle(styles), "border: [^;]+grey;") 65 | expect_match(prGetStyle(styles, a=2), "border: [^;]+grey;") 66 | 67 | expect_error(prGetStyle(styles, "invalid style")) 68 | expect_error(prGetStyle(styles, "invalid style:")) 69 | expect_error(prGetStyle(styles, ":invalid style")) 70 | 71 | expect_match(prGetStyle(styles, "valid: style"), "valid: style;") 72 | expect_match(prGetStyle(styles, c(valid= "style")), "valid: style;") 73 | expect_match(prGetStyle(styles, c(valid= "style", valid1= "style")), "valid: style; valid1: style;") 74 | expect_match(prGetStyle(styles, c(valid= "style1", valid= "style2")), "valid: style2;") 75 | expect_match(prGetStyle(styles, c(valid= "style1", valid= "style2"), "valid: style3"), "valid: style3;") 76 | }) 77 | 78 | 79 | test_that("Later style has precedence", { 80 | styles <- c(background = "black", border ="1px solid grey") 81 | expect_match(prGetStyle(border = "2px solid red", styles), 82 | styles["border"]) 83 | expect_match(prGetStyle(styles, border = "2px solid red"), 84 | "2px solid red") 85 | }) 86 | -------------------------------------------------------------------------------- /inst/htmlwidgets/lib/table_pagination/table_pagination.css: -------------------------------------------------------------------------------- 1 | /* These styles have been adapted from DataTables: 2 | DataTables is designed and created by SpryMedia Ltd © 2007-2016. 3 | SpryMedia Ltd is registered in Scotland, company no. SC456502. 4 | 5 | MIT licensed 6 | 7 | https://datatables.net/ 8 | 9 | */ 10 | 11 | .page_button { 12 | box-sizing: border-box; 13 | display: inline-block; 14 | min-width: 1.5em; 15 | padding: 0.5em 1em; 16 | margin-left: 2px; 17 | text-align: center; 18 | text-decoration: none !important; 19 | cursor: pointer; 20 | color: #333 !important; 21 | border: 1px solid transparent; 22 | border-radius: 2px; 23 | } 24 | 25 | .page_button:active { 26 | background-color: #2b2b2b; 27 | background: -webkit-gradient(linear, left top, left bottom, color-stop(0%, #2b2b2b), color-stop(100%, #0c0c0c)); 28 | /* Chrome,Safari4+ */ 29 | background: -webkit-linear-gradient(top, #2b2b2b 0%, #0c0c0c 100%); 30 | /* Chrome10+,Safari5.1+ */ 31 | background: -moz-linear-gradient(top, #2b2b2b 0%, #0c0c0c 100%); 32 | /* FF3.6+ */ 33 | background: -ms-linear-gradient(top, #2b2b2b 0%, #0c0c0c 100%); 34 | /* IE10+ */ 35 | background: -o-linear-gradient(top, #2b2b2b 0%, #0c0c0c 100%); 36 | /* Opera 11.10+ */ 37 | background: linear-gradient(to bottom, #2b2b2b 0%, #0c0c0c 100%); 38 | /* W3C */ 39 | box-shadow: inset 0 0 3px #111; 40 | } 41 | 42 | .page_button:hover { 43 | color: white !important; 44 | border: 1px solid #111; 45 | background-color: #585858; 46 | background: -webkit-gradient(linear, left top, left bottom, color-stop(0%, #585858), color-stop(100%, #111)); 47 | /* Chrome,Safari4+ */ 48 | background: -webkit-linear-gradient(top, #585858 0%, #111 100%); 49 | /* Chrome10+,Safari5.1+ */ 50 | background: -moz-linear-gradient(top, #585858 0%, #111 100%); 51 | /* FF3.6+ */ 52 | background: -ms-linear-gradient(top, #585858 0%, #111 100%); 53 | /* IE10+ */ 54 | background: -o-linear-gradient(top, #585858 0%, #111 100%); 55 | /* Opera 11.10+ */ 56 | background: linear-gradient(to bottom, #585858 0%, #111 100%); 57 | /* W3C */ 58 | } 59 | 60 | 61 | .page_button_current { 62 | pointer-events: none; 63 | cursor: default; 64 | color: #333 !important; 65 | border: 1px solid #979797; 66 | background-color: white; 67 | background: -webkit-gradient(linear, left top, left bottom, color-stop(0%, white), color-stop(100%, #dcdcdc)); 68 | /* Chrome,Safari4+ */ 69 | background: -webkit-linear-gradient(top, white 0%, #dcdcdc 100%); 70 | /* Chrome10+,Safari5.1+ */ 71 | background: -moz-linear-gradient(top, white 0%, #dcdcdc 100%); 72 | /* FF3.6+ */ 73 | background: -ms-linear-gradient(top, white 0%, #dcdcdc 100%); 74 | /* IE10+ */ 75 | background: -o-linear-gradient(top, white 0%, #dcdcdc 100%); 76 | /* Opera 11.10+ */ 77 | background: linear-gradient(to bottom, white 0%, #dcdcdc 100%); 78 | /* W3C */ 79 | } 80 | 81 | .page_button_disabled { 82 | pointer-events: none; 83 | cursor: default; 84 | color: #666 !important; 85 | border: 1px solid transparent; 86 | background: transparent; 87 | box-shadow: none; 88 | } 89 | 90 | .page_button_disabled:hover { 91 | pointer-events: none; 92 | cursor: default; 93 | } 94 | 95 | #showing_entries_div { 96 | float:left; 97 | } 98 | 99 | #page_numbers_div { 100 | float: right; 101 | } -------------------------------------------------------------------------------- /man/interactiveTable.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/interactiveTable.R 3 | \name{interactiveTable} 4 | \alias{interactiveTable} 5 | \alias{interactiveTable.htmlTable} 6 | \alias{knit_print.interactiveTable} 7 | \alias{print.interactiveTable} 8 | \title{An interactive table that allows you to limit the size of boxes} 9 | \usage{ 10 | interactiveTable( 11 | x, 12 | ..., 13 | txt.maxlen = 20, 14 | button = getOption("htmlTable.interactiveTable.button", default = FALSE), 15 | minimized.columns = NULL, 16 | js.scripts = c() 17 | ) 18 | 19 | \method{interactiveTable}{htmlTable}( 20 | x, 21 | ..., 22 | txt.maxlen = 20, 23 | button = getOption("htmlTable.interactiveTable.button", default = FALSE), 24 | minimized.columns = NULL, 25 | js.scripts = c() 26 | ) 27 | 28 | \method{knit_print}{interactiveTable}(x, ...) 29 | 30 | \method{print}{interactiveTable}(x, useViewer, ...) 31 | } 32 | \arguments{ 33 | \item{x}{The table to be printed} 34 | 35 | \item{...}{The exact same parameters as \code{\link[=htmlTable]{htmlTable()}} uses} 36 | 37 | \item{txt.maxlen}{The maximum length of a text} 38 | 39 | \item{button}{Indicator if the cell should be clickable or if a button should appear with a plus/minus} 40 | 41 | \item{minimized.columns}{Notifies if any particular columns should be collapsed from start} 42 | 43 | \item{js.scripts}{If you want to add your own JavaScript code you can just add it here. 44 | All code is merged into one string where each section is wrapped in it's own 45 | \verb{} element.} 46 | 47 | \item{useViewer}{If you are using RStudio there is a viewer thar can render 48 | the table within that is envoced if in \code{\link[base:interactive]{base::interactive()}} mode. 49 | Set this to \code{FALSE} if you want to remove that functionality. You can 50 | also force the function to call a specific viewer by setting this to a 51 | viewer function, e.g. \code{useViewer = utils::browseURL} if you want to 52 | override the default RStudio viewer. Another option that does the same is to 53 | set the \code{options(viewer=utils::browseURL)} and it will default to that 54 | particular viewer (this is how RStudio decides on a viewer). 55 | \emph{Note:} If you want to force all output to go through the 56 | \code{\link[base:cat]{base::cat()}} the set \verb{[options][base::options](htmlTable.cat = TRUE)}.} 57 | } 58 | \value{ 59 | An htmlTable with a javascript attribute containing the code that is then printed 60 | } 61 | \description{ 62 | This function wraps the htmlTable and adds JavaScript code for toggling the amount 63 | of text shown in any particular cell. 64 | } 65 | \examples{ 66 | library(magrittr) 67 | # A simple output 68 | long_txt <- "Lorem ipsum dolor sit amet, consectetur adipiscing elit, 69 | sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. 70 | Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi 71 | ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit 72 | in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur 73 | sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt 74 | mollit anim id est laborum" 75 | short_txt <- gsub("(^[^.]+).*", "\\\\1", long_txt) 76 | 77 | cbind(rep(short_txt, 2), 78 | rep(long_txt, 2)) \%>\% 79 | addHtmlTableStyle(col.rgroup = c("#FFF", "#EEF")) \%>\% 80 | interactiveTable(minimized.columns = ncol(.), 81 | header = c("Short", "Long"), 82 | rnames = c("First", "Second")) 83 | } 84 | -------------------------------------------------------------------------------- /tests/visual_tests/word_test.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Pandoc test" 3 | output: 4 | html_document 5 | editor_options: 6 | chunk_output_type: inline 7 | --- 8 | 9 | ```{r echo=FALSE} 10 | knitr::opts_chunk$set(echo = FALSE, message=FALSE, warning=FALSE) 11 | ``` 12 | 13 | ```{r} 14 | library(htmlTable) 15 | library(magrittr) 16 | 17 | mx <- matrix(1:6, ncol=3) 18 | htmlTable(mx, 19 | caption = "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.", 20 | tfoot = "Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium, totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae dicta sunt explicabo. Nemo enim ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit, sed quia consequuntur magni dolores eos qui ratione voluptatem sequi nesciunt. Neque porro quisquam est, qui dolorem ipsum quia dolor sit amet, consectetur, adipisci velit, sed quia non numquam eius modi tempora incidunt ut labore et dolore magnam aliquam quaerat voluptatem. Ut enim ad minima veniam, quis nostrum exercitationem ullam corporis suscipit laboriosam, nisi ut aliquid ex ea commodi consequatur? Quis autem vel eum iure reprehenderit qui in ea voluptate velit esse quam nihil molestiae consequatur, vel illum qui dolorem eum fugiat quo voluptas nulla pariatur?") 21 | 22 | 23 | set.seed(1) 24 | mx <- matrix(runif(3*10)*10, ncol=3) %>% 25 | set_colnames(LETTERS[1:3]) %>% 26 | set_rownames(LETTERS[1:10]) 27 | 28 | txtRound(mx, 3) %>% 29 | htmlTable( 30 | align = "clr", 31 | caption = "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.", 32 | tfoot = "Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium, totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae dicta sunt explicabo. Nemo enim ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit, sed quia consequuntur magni dolores eos qui ratione voluptatem sequi nesciunt. 33 | † Neque porro quisquam est, qui dolorem ipsum quia dolor sit amet, consectetur, adipisci velit, sed quia non numquam eius modi tempora incidunt ut labore et dolore magnam aliquam quaerat voluptatem. Ut enim ad minima veniam, quis nostrum exercitationem ullam corporis suscipit laboriosam, nisi ut aliquid ex ea commodi consequatur? 34 | ‡ Quis autem vel eum iure reprehenderit qui in ea voluptate velit esse quam nihil molestiae consequatur, vel illum qui dolorem eum fugiat quo voluptas nulla pariatur?") 35 | 36 | htmlTable(mx, 37 | rgroup = c("Lorem", "ipsum", "dolor"), 38 | n.rgroup = c(2, 3), 39 | cgroup = c("", "Test"), 40 | n.cgroup = 1, 41 | align = "llr", 42 | caption = "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua.") 43 | ``` 44 | 45 | 46 | -------------------------------------------------------------------------------- /inst/examples/htmlTable_example.R: -------------------------------------------------------------------------------- 1 | library(magrittr) 2 | 3 | # Basic example 4 | output <- matrix(1:4, 5 | ncol = 2, 6 | dimnames = list(list("Row 1", "Row 2"), 7 | list("Column 1", "Column 2"))) 8 | htmlTable(output) 9 | invisible(readline(prompt = "Press [enter] to continue")) 10 | 11 | # An advanced output 12 | output <- matrix(ncol = 6, nrow = 8) 13 | 14 | for (nr in 1:nrow(output)) { 15 | for (nc in 1:ncol(output)) { 16 | output[nr, nc] <- 17 | paste0(nr, ":", nc) 18 | } 19 | } 20 | 21 | output %>% addHtmlTableStyle(align = "r", 22 | col.columns = c(rep("none", 2), 23 | rep("#F5FBFF", 4)), 24 | col.rgroup = c("none", "#F7F7F7"), 25 | css.cell = "padding-left: .5em; padding-right: .2em;") %>% 26 | htmlTable(header = paste(c("1st", "2nd", 27 | "3rd", "4th", 28 | "5th", "6th"), 29 | "hdr"), 30 | rnames = paste(c("1st", "2nd", 31 | "3rd", 32 | paste0(4:8, "th")), 33 | "row"), 34 | rgroup = paste("Group", LETTERS[1:3]), 35 | n.rgroup = c(2,4,nrow(output) - 6), 36 | cgroup = rbind(c("", "Column spanners", NA), 37 | c("", "Cgroup 1", "Cgroup 2†")), 38 | n.cgroup = rbind(c(1,2,NA), 39 | c(2,2,2)), 40 | caption = "Basic table with both column spanners (groups) and row groups", 41 | tfoot = "† A table footer commment", 42 | cspan.rgroup = 2) 43 | invisible(readline(prompt = "Press [enter] to continue")) 44 | 45 | # An advanced empty table 46 | suppressWarnings({ 47 | matrix(ncol = 6, 48 | nrow = 0) %>% 49 | addHtmlTableStyle(col.columns = c(rep("none", 2), 50 | rep("#F5FBFF", 4)), 51 | col.rgroup = c("none", "#F7F7F7"), 52 | css.cell = "padding-left: .5em; padding-right: .2em;") %>% 53 | htmlTable(align = "r", 54 | header = paste(c("1st", "2nd", 55 | "3rd", "4th", 56 | "5th", "6th"), 57 | "hdr"), 58 | cgroup = rbind(c("", "Column spanners", NA), 59 | c("", "Cgroup 1", "Cgroup 2†")), 60 | n.cgroup = rbind(c(1,2,NA), 61 | c(2,2,2)), 62 | caption = "Basic empty table with column spanners (groups) and ignored row colors", 63 | tfoot = "† A table footer commment", 64 | cspan.rgroup = 2) 65 | }) 66 | invisible(readline(prompt = "Press [enter] to continue")) 67 | 68 | # An example of how to use the css.cell for header styling 69 | simple_output <- matrix(1:4, ncol = 2) 70 | 71 | simple_output %>% 72 | addHtmlTableStyle(css.cell = rbind(rep("background: lightgrey; font-size: 2em;", 73 | times = ncol(simple_output)), 74 | matrix("", 75 | ncol = ncol(simple_output), 76 | nrow = nrow(simple_output)))) %>% 77 | htmlTable(header = LETTERS[1:2]) 78 | invisible(readline(prompt = "Press [enter] to continue")) 79 | 80 | # See vignette("tables", package = "htmlTable") 81 | # for more examples, also check out tidyHtmlTable() that manages 82 | # the group arguments for you through tidy-select syntax 83 | -------------------------------------------------------------------------------- /vignettes/custom.css: -------------------------------------------------------------------------------- 1 | body { 2 | background-color: #fff; 3 | margin: 1em auto; 4 | max-width: 700px; 5 | overflow: visible; 6 | padding-left: 2em; 7 | padding-right: 2em; 8 | font-family: "Open Sans", "Helvetica Neue", Helvetica, Arial, sans-serif; 9 | font-size: 14px; 10 | line-height: 1.35; 11 | } 12 | #header { 13 | text-align: center; 14 | } 15 | #TOC { 16 | clear: both; 17 | margin: 0 0 10px 10px; 18 | padding: 4px; 19 | width: 400px; 20 | border: 1px solid #CCCCCC; 21 | border-radius: 5px; 22 | background-color: #f6f6f6; 23 | font-size: 13px; 24 | line-height: 1.3; 25 | } 26 | #TOC .toctitle { 27 | font-weight: bold; 28 | font-size: 15px; 29 | margin-left: 5px; 30 | } 31 | #TOC ul { 32 | padding-left: 40px; 33 | margin-left: -1.5em; 34 | margin-top: 5px; 35 | margin-bottom: 5px; 36 | } 37 | #TOC ul ul { 38 | margin-left: -2em; 39 | } 40 | #TOC li { 41 | line-height: 16px; 42 | } 43 | table { 44 | margin: 1em auto; 45 | } 46 | 47 | p { 48 | margin: 0.5em 0; 49 | } 50 | blockquote { 51 | background-color: #f6f6f6; 52 | padding: 0.25em 0.75em; 53 | } 54 | hr { 55 | border-style: solid; 56 | border: none; 57 | border-top: 1px solid #777; 58 | margin: 28px 0; 59 | } 60 | dl { 61 | margin-left: 0; 62 | } 63 | dl dd { 64 | margin-bottom: 13px; 65 | margin-left: 13px; 66 | } 67 | dl dt { 68 | font-weight: bold; 69 | } 70 | ul { 71 | margin-top: 0; 72 | } 73 | ul li { 74 | list-style: circle outside; 75 | } 76 | ul ul { 77 | margin-bottom: 0; 78 | } 79 | pre, code { 80 | background-color: #f7f7f7; 81 | border-radius: 3px; 82 | color: #333; 83 | } 84 | pre { 85 | white-space: pre-wrap; /* Wrap long lines */ 86 | border-radius: 3px; 87 | margin: 5px 0px 10px 0px; 88 | padding: 10px; 89 | } 90 | pre:not([class]) { 91 | background-color: #f7f7f7; 92 | } 93 | code { 94 | font-family: Consolas, Monaco, 'Courier New', monospace; 95 | font-size: 85%; 96 | } 97 | p > code, li > code { 98 | padding: 2px 0px; 99 | } 100 | div.figure { 101 | text-align: center; 102 | } 103 | img { 104 | background-color: #FFFFFF; 105 | padding: 2px; 106 | border: 1px solid #DDDDDD; 107 | border-radius: 3px; 108 | border: 1px solid #CCCCCC; 109 | margin: 0 5px; 110 | } 111 | h1 { 112 | margin-top: 0; 113 | font-size: 35px; 114 | line-height: 40px; 115 | } 116 | h2 { 117 | border-bottom: 4px solid #f7f7f7; 118 | padding-top: 10px; 119 | padding-bottom: 2px; 120 | font-size: 145%; 121 | } 122 | h3 { 123 | border-bottom: 2px solid #f7f7f7; 124 | padding-top: 10px; 125 | font-size: 120%; 126 | } 127 | h4 { 128 | border-bottom: 1px solid #f7f7f7; 129 | margin-left: 8px; 130 | font-size: 105%; 131 | } 132 | h5, h6 { 133 | border-bottom: 1px solid #ccc; 134 | font-size: 105%; 135 | } 136 | a { 137 | color: #0033dd; 138 | text-decoration: none; 139 | } 140 | a:hover { 141 | color: #6666ff; } 142 | a:visited { 143 | color: #800080; } 144 | a:visited:hover { 145 | color: #BB00BB; } 146 | a[href^="http:"] { 147 | text-decoration: underline; } 148 | a[href^="https:"] { 149 | text-decoration: underline; } 150 | /* Colours from https://gist.github.com/robsimmons/1172277 */ 151 | code > span.kw { color: #555; font-weight: bold; } /* Keyword */ 152 | code > span.dt { color: #902000; } /* DataType */ 153 | code > span.dv { color: #40a070; } /* DecVal (decimal values) */ 154 | code > span.bn { color: #d14; } /* BaseN */ 155 | code > span.fl { color: #d14; } /* Float */ 156 | code > span.ch { color: #d14; } /* Char */ 157 | code > span.st { color: #d14; } /* String */ 158 | code > span.co { color: #888888; font-style: italic; } /* Comment */ 159 | code > span.ot { color: #007020; } /* OtherToken */ 160 | code > span.al { color: #ff0000; font-weight: bold; } /* AlertToken */ 161 | code > span.fu { color: #900; font-weight: bold; } /* Function calls */ 162 | code > span.er { color: #a61717; background-color: #e3d2d2; } /* ErrorTok */ -------------------------------------------------------------------------------- /R/htmlTable_render_addCells.R: -------------------------------------------------------------------------------- 1 | #' Add a cell 2 | #' 3 | #' Adds a row of cells `val...` to a table string for 4 | #' [htmlTable()] 5 | #' 6 | #' @inheritParams htmlTable 7 | #' @param rowcells The cells with the values that are to be added 8 | #' @param cellcode Type of cell, can either be `th` or `td` 9 | #' @param style The cell style 10 | #' @param cgroup_spacer_cells The number of cells that occur between 11 | #' columns due to the cgroup arguments. 12 | #' @param has_rn_col Due to the alignment issue we need to keep track 13 | #' of if there has already been printed a rowname column or not and therefore 14 | #' we have this has_rn_col that is either 0 or 1. 15 | #' @param offset For rgroup rows there may be an offset != 1 16 | #' @param style_list The style_list 17 | #' @return `string` Returns the string with the new cell elements 18 | #' @keywords internal 19 | #' @family hidden helper functions for htmlTable 20 | #' @importFrom stringr str_interp 21 | prAddCells <- function(rowcells, cellcode, style_list, style, prepped_cell_css, cgroup_spacer_cells, has_rn_col, offset = 1, style_list_align_key = "align") { 22 | cell_str <- "" 23 | style <- prAddSemicolon2StrEnd(style) 24 | 25 | previous_was_spacer_cell <- FALSE 26 | for (nr in offset:length(rowcells)) { 27 | cell_value <- rowcells[nr] 28 | # We don't want missing to be NA in a table, it should be empty 29 | if (is.na(cell_value)) { 30 | cell_value <- "" 31 | } 32 | 33 | followed_by_spacer_cell <- nr != length(rowcells) && 34 | nr <= length(cgroup_spacer_cells) && 35 | cgroup_spacer_cells[nr] > 0 36 | 37 | align_style <- prGetAlign(style_list[[style_list_align_key]], 38 | index = nr + has_rn_col, 39 | style_list = style_list, 40 | followed_by_spacer_cell = followed_by_spacer_cell, 41 | previous_was_spacer_cell = previous_was_spacer_cell) 42 | cell_style <- c(prepped_cell_css[nr], 43 | style) 44 | 45 | if (!is.null(style_list$col.columns)) { 46 | cell_style %<>% 47 | c(`background-color` = style_list$col.columns[nr]) 48 | } 49 | 50 | 51 | cell_str %<>% paste(str_interp("<${CELL_TAG} style='${STYLE}'>${CONTENT}", 52 | list(CELL_TAG = cellcode, 53 | STYLE = prGetStyle(cell_style, 54 | align_style), 55 | CONTENT = cell_value)), 56 | sep = "\n\t\t") 57 | 58 | # Add empty cell if not last column 59 | if (followed_by_spacer_cell) { 60 | align_style <- prGetAlign(style_list[[style_list_align_key]], 61 | index = nr + has_rn_col, 62 | style_list = style_list, 63 | spacerCell = TRUE, 64 | followed_by_spacer_cell = followed_by_spacer_cell, 65 | previous_was_spacer_cell = previous_was_spacer_cell) 66 | 67 | # The same style as previous but without align borders 68 | cell_style <- c( 69 | prepped_cell_css[nr], 70 | style, 71 | align_style 72 | ) 73 | spanner_style <- style 74 | 75 | if (!is.null(style_list$col.columns)) { 76 | if (style_list$col.columns[nr] == style_list$col.columns[nr + 1]) { 77 | spanner_style %<>% c(`background-color` = style_list$col.columns[nr]) 78 | } 79 | } 80 | 81 | cell_str %<>% 82 | paste("\n\t\t") %>% 83 | prAddEmptySpacerCell(style_list = style_list, 84 | cell_style = prGetStyle(cell_style, spanner_style), 85 | colspan = cgroup_spacer_cells[nr], 86 | cell_tag = cellcode, 87 | align_style = align_style) 88 | } 89 | 90 | previous_was_spacer_cell <- followed_by_spacer_cell 91 | } 92 | return(cell_str) 93 | } 94 | -------------------------------------------------------------------------------- /R/htmlTable_helpers_prepareCss.R: -------------------------------------------------------------------------------- 1 | #' Prepares the cell style 2 | #' 3 | #' @param css The CSS styles that are to be converted into 4 | #' a matrix. 5 | #' @param name The name of the CSS style that is prepared 6 | #' @inheritParams htmlTable 7 | #' @return `matrix` 8 | #' @keywords internal 9 | prPrepareCss <- function(x, css, rnames, header = NULL, name = deparse(substitute(css)), style_list = NULL) { 10 | if (is.null(style_list)) { 11 | css.header <- rep("", times = ncol(x)) 12 | css.rnames <- rep("", times = nrow(x) + !is.null(header)) 13 | } else { 14 | css.header <- rep(ifelse(is.null(style_list$css.header), 15 | "", 16 | style_list$css.header), 17 | times = ncol(x)) 18 | css.rnames <- rep(ifelse(is.null(style_list$css.rnames), 19 | "", 20 | style_list$css.rnames), 21 | times = nrow(x) + !missing(header)) 22 | } 23 | 24 | if (is.matrix(css)) { 25 | if (any(grepl("^[^:]*[a-zA-Z]+[:]*:", css))) { 26 | rownames(css) <- NULL 27 | colnames(css) <- NULL 28 | } 29 | if (ncol(css) == ncol(x) + 1 && 30 | !prSkipRownames(rnames)) { 31 | if (!is.null(header)) { 32 | if (nrow(css) == nrow(x) + 1) { 33 | css.rnames <- css[, 1] 34 | } else if (nrow(css) == nrow(x)) { 35 | css.rnames[2:length(css.rnames)] <- css[, 1] 36 | } else { 37 | stop( 38 | "There is an invalid number of rows for the ", name, " matrix.", 39 | " Your x argument has '", nrow(x), "' rows", 40 | " while your ", name, " has '", nrow(css), "' rows", 41 | " and there is a header" 42 | ) 43 | } 44 | } else if (nrow(x) == nrow(css)) { 45 | css.rnames <- css[, 1] 46 | } else { 47 | stop( 48 | "There is an invalid number of rows for the ", name, " matrix.", 49 | " Your x argument has '", nrow(x), "' rows", 50 | " while your ", name, " has '", nrow(css), "' rows", 51 | " (there is no header)" 52 | ) 53 | } 54 | 55 | css <- css[, -1, drop = FALSE] 56 | } else if (ncol(css) != ncol(x)) { 57 | stop( 58 | "There is an invalid number of columns for the ", name, " matrix.", 59 | " Your x argument has '", ncol(x), "' columns", 60 | " while your ", name, " has '", ncol(css), "' columns", 61 | " and there are ", ifelse(prSkipRownames(rnames), 62 | "no", "" 63 | ), 64 | " rownames." 65 | ) 66 | } 67 | 68 | if (nrow(css) == nrow(x) + 1 && !is.null(header)) { 69 | for (i in 1:length(css.header)) { 70 | css.header[i] <- prGetStyle(css.header[i], css[1, i]) 71 | } 72 | css <- css[-1, , drop = FALSE] 73 | } else if (nrow(css) != nrow(x)) { 74 | stop( 75 | "There is an invalid number of rows for the ", name, " matrix.", 76 | " Your x argument has '", nrow(x), "' rows", 77 | " while your ", name, " has '", nrow(css), "' rows", 78 | " and there is ", ifelse(is.null(header), "no", "a"), 79 | " header" 80 | ) 81 | } 82 | } else if (is.vector(css)) { 83 | if (length(css) == ncol(x) + 1) { 84 | css.rnames <- rep(css[1], nrow(x) + prSkipRownames(rnames)) 85 | css <- 86 | css[-1] 87 | } else if (length(css) == 1) { 88 | css.rnames <- rep(css, times = nrow(x) + !is.null(header)) 89 | } else if (length(css) != ncol(x)) { 90 | stop( 91 | "The length of your ", name, " vector '", length(css), "'", 92 | " does not correspond to the column length '", ncol(x), "'", 93 | " (there are ", ifelse(prSkipRownames(rnames), 94 | "no", "" 95 | ), 96 | " rownames)" 97 | ) 98 | } 99 | 100 | css <- matrix(css, 101 | nrow = nrow(x), 102 | ncol = ncol(x), 103 | byrow = TRUE 104 | ) 105 | } 106 | 107 | return(structure(css, 108 | rnames = css.rnames, 109 | header = css.header, 110 | class = class(css) 111 | )) 112 | } 113 | -------------------------------------------------------------------------------- /man/prGetThead.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/htmlTable_render_getThead.R 3 | \name{prGetThead} 4 | \alias{prGetThead} 5 | \title{Renders the table head (thead)} 6 | \usage{ 7 | prGetThead( 8 | x, 9 | header = NULL, 10 | cgroup = NULL, 11 | n.cgroup = NULL, 12 | caption = NULL, 13 | compatibility, 14 | total_columns, 15 | css.cgroup, 16 | top_row_style, 17 | rnames, 18 | rowlabel = NULL, 19 | cgroup_spacer_cells, 20 | prepped_cell_css, 21 | style_list, 22 | cell_style 23 | ) 24 | } 25 | \arguments{ 26 | \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} 27 | it takes a string of the class \code{htmlTable} as \code{x} argument.} 28 | 29 | \item{header}{A vector of character strings specifying column 30 | header, defaulting to \code{\link[base:colnames]{colnames(x)}}} 31 | 32 | \item{cgroup}{A vector, matrix or list of character strings defining major column header. The default 33 | is to have none. These elements are also known as \emph{column spanners}. If you want a column \emph{not} 34 | to have a spanner then put that column as "". If you pass cgroup and \code{n.crgroup} as 35 | matrices you can have column spanners for several rows. See cgroup section below for details.} 36 | 37 | \item{n.cgroup}{An integer vector, matrix or list containing the number of columns for which each element in 38 | cgroup is a heading. For example, specify \code{cgroup=c("Major_1","Major_2")}, 39 | \code{n.cgroup=c(3,3)} if \code{"Major_1"} is to span columns 1-3 and 40 | \code{"Major_2"} is to span columns 4-6. 41 | \code{rowlabel} does not count in the column numbers. You can omit \code{n.cgroup} 42 | if all groups have the same number of columns. If the \code{n.cgroup} is one less than 43 | the number of columns in the matrix/data.frame then it automatically adds those.} 44 | 45 | \item{caption}{Adds a table caption.} 46 | 47 | \item{compatibility}{Is default set to \code{LibreOffice} as some 48 | settings need to be in old HTML format as Libre Office can't 49 | handle some commands such as the css caption-alignment. Note: this 50 | option is not yet fully implemented for all details, in the future 51 | I aim to generate a HTML-correct table and one that is aimed 52 | at Libre Office compatibility. Word-compatibility is difficult as 53 | Word ignores most settings and destroys all layout attempts 54 | (at least that is how my 2010 version behaves). You can additinally use the 55 | \code{options(htmlTableCompat = "html")} if you want a change to apply 56 | to the entire document. 57 | MS Excel sometimes misinterprets certain cell data when opening HTML-tables (eg. 1/2 becomes 1. February). 58 | To avoid this please specify the correct Microsoft Office format for each cell in the table using the css.cell-argument. 59 | To make MS Excel interpret everything as text use "mso-number-format:\"\\@\"".} 60 | 61 | \item{total_columns}{The total number of columns including the rowlabel and the 62 | specer cells} 63 | 64 | \item{top_row_style}{The top row has a special style depending on 65 | the \code{ctable} option in the \code{htmlTable} call.} 66 | 67 | \item{rnames}{Default row names are generated from \code{\link[base:colnames]{rownames(x)}}. If you 68 | provide \code{FALSE} then it will skip the row names. \emph{Note:} For \code{data.frames} 69 | if you do \code{\link[base:colnames]{rownames(my_dataframe) <- NULL}} it still has 70 | row names. Thus you need to use \code{FALSE} if you want to 71 | supress row names for \code{data.frames}.} 72 | 73 | \item{rowlabel}{If the table has row names or \code{rnames}, 74 | \code{rowlabel} is a character string containing the 75 | column heading for the \code{rnames}.} 76 | 77 | \item{cgroup_spacer_cells}{The spacer cells due to the multiple cgroup levels. 78 | With multiple rows in cgroup we need to keep track of how many spacer cells 79 | occur between the columns. This variable contains is of the size \code{ncol(x)-1} 80 | and 0 if there is no cgroup element between.} 81 | 82 | \item{style_list}{The list with all the styles} 83 | } 84 | \value{ 85 | \code{string} Returns the html string for the \verb{...} element 86 | } 87 | \description{ 88 | Renders the table head (thead) 89 | } 90 | \keyword{internal} 91 | -------------------------------------------------------------------------------- /R/htmlTable_helpers_getStyle.R: -------------------------------------------------------------------------------- 1 | 2 | #' Gets the CSS style element 3 | #' 4 | #' A function for checking, merging, and more 5 | #' with a variety of different style formats. 6 | #' 7 | #' @param ... Styles can be provided as `vector`, `named vector`, or `string`. 8 | #' If you provide a name, e.g. `background: blue`, `align="center"`, 9 | #' the function will convert the `align` into proper `align: center`. 10 | #' @return `string` Returns the codes merged into one string with 11 | #' correct CSS ; and : structure. 12 | #' @keywords internal 13 | #' @import magrittr 14 | #' @family hidden helper functions for htmlTable 15 | prGetStyle <- function(...) { 16 | mergeNames <- function(sv) { 17 | sv <- sv[!is.na(sv)] 18 | if (!is.null(names(sv))) { 19 | sv <- 20 | mapply(function(n, v) { 21 | if (n == "") { 22 | return(v) 23 | } 24 | paste0(n, ": ", v) 25 | }, n = names(sv), v = sv, USE.NAMES = FALSE) 26 | } 27 | return(sv) 28 | } 29 | spltNames <- function(sv) { 30 | ret_sv <- c() 31 | for (i in 1:length(sv)) { 32 | ret_sv <- c( 33 | ret_sv, 34 | # Split on the ; in case it is not at the end/start 35 | unlist(strsplit(sv[i], "\\b;(\\b|\\W+)", perl = TRUE)) 36 | ) 37 | } 38 | return(ret_sv) 39 | } 40 | 41 | styles <- c() 42 | dots <- list(...) 43 | dots <- dots[sapply(dots, function(x) any(!is.na(x) & !is.null(x)))] 44 | if (length(dots) == 0) { 45 | return("") 46 | } 47 | 48 | for (i in 1:length(dots)) { 49 | element <- dots[[i]] 50 | if (length(element) == 1) { 51 | if (element == "") { 52 | next 53 | } 54 | 55 | if (!grepl("\\b[:](\\b|\\W+)", element, perl = TRUE)) { 56 | if (!is.null(names(element))) { 57 | element <- 58 | paste0(names(element), ": ", element) 59 | } else if (!is.null(names(dots)) && 60 | names(dots)[i] != "") { 61 | element <- 62 | paste0(names(dots)[i], ": ", element) 63 | } else if (element != "none") { 64 | stop( 65 | "The style should be formatted according to 'style_name: value'", 66 | " you have provided style '", element, "'" 67 | ) 68 | } 69 | } 70 | styles %<>% 71 | c(element) 72 | } else { 73 | if (!is.null(names(element))) { 74 | element <- mergeNames(element) 75 | } 76 | 77 | styles <- c( 78 | styles, 79 | spltNames(element) 80 | ) 81 | } 82 | } 83 | 84 | if (!all(grepl("^[^:]+:.+", styles))) { 85 | stop( 86 | "Invalid styles detected, one or more styles lack the needed style 'name: value': ", 87 | paste(paste0("'", styles[!grepl("^[^:]+:.+", styles)], "'"), collapse = ", ") 88 | ) 89 | } 90 | 91 | # Remove empty background colors - sometimes a background color appears with 92 | # just background-color:; for some unknown reason 93 | if (any(grepl("^background-color:( none|[ ]*;*$)", styles))) { 94 | styles <- styles[-grep("^background-color:( none|[ ]*;*$)", styles)] 95 | } 96 | 97 | # Merge background colors 98 | if (sum(grepl("^background-color:", styles)) > 1) { 99 | clrs <- styles[grep("^background-color:", styles)] 100 | clrs <- gsub("^background-color:[ ]*([^;]+);*", "\\1", clrs) 101 | clr <- prMergeClr(clrs) 102 | # Pick a color merge 103 | styles <- styles[-grep("^background-color:", styles)] 104 | styles <- 105 | c( 106 | styles, 107 | paste0("background-color: ", clr) 108 | ) 109 | } 110 | 111 | style_names <- gsub("^([^:]+).+", "\\1", styles) 112 | if (!any(duplicated(style_names))) { 113 | unique_styles <- styles 114 | } else { 115 | # Only select the last style if two of the same type 116 | # exist. This in order to avoid any conflicts. 117 | unique_styles <- c() 118 | for (n in unique(style_names)) { 119 | unique_styles <- 120 | c( 121 | unique_styles, 122 | styles[max(which(n == style_names))] 123 | ) 124 | } 125 | } 126 | 127 | unique_styles <- sapply(unique_styles, prAddSemicolon2StrEnd, USE.NAMES = FALSE) 128 | paste(unique_styles, collapse = " ") 129 | } 130 | -------------------------------------------------------------------------------- /man/txtRound.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/txtFrmt_round.R, R/txtFrmt_round_data.frame.R 3 | \name{txtRound} 4 | \alias{txtRound} 5 | \alias{txtRound.default} 6 | \alias{txtRound.table} 7 | \alias{txtRound.matrix} 8 | \alias{txtRound.data.frame} 9 | \title{A convenient rounding function} 10 | \usage{ 11 | txtRound(x, ...) 12 | 13 | \method{txtRound}{default}( 14 | x, 15 | digits = 0, 16 | digits.nonzero = NA, 17 | txt.NA = "", 18 | dec = getOption("htmlTable.decimal_marker", default = "."), 19 | scientific = NULL, 20 | txtInt_args = getOption("htmlTable.round_int", default = NULL), 21 | ... 22 | ) 23 | 24 | \method{txtRound}{table}(x, ...) 25 | 26 | \method{txtRound}{matrix}(x, digits = 0, excl.cols = NULL, excl.rows = NULL, ...) 27 | 28 | \method{txtRound}{data.frame}(x, ..., digits = 0L) 29 | } 30 | \arguments{ 31 | \item{x}{The value/vector/data.frame/matrix to be rounded} 32 | 33 | \item{...}{Passed to next method} 34 | 35 | \item{digits}{The number of digits to round each element to. For \code{matrix} 36 | or \code{data.frame} input you can provide a \code{vector}/\code{list}. An unnamed \code{vector}/\code{list} 37 | must equal the length of the columns to round. If you provide a named vector you 38 | can provide specify per column the number of digits, and then use \code{.default} 39 | for those columns that we don't need to have separate values for.} 40 | 41 | \item{digits.nonzero}{The number of digits to keep if the result is close to 42 | zero. Sometimes we have an entire table with large numbers only to have a 43 | few but interesting observation that are really interesting} 44 | 45 | \item{txt.NA}{The string to exchange \code{NA} with} 46 | 47 | \item{dec}{The decimal marker. If the text is in non-English decimal 48 | and string formatted you need to change this to the appropriate decimal 49 | indicator. The option for this is \code{htmlTable.decimal_marker}.} 50 | 51 | \item{scientific}{If the value should be in scientific format.} 52 | 53 | \item{txtInt_args}{A list of arguments to pass to \code{\link[=txtInt]{txtInt()}} if that is to be 54 | used for large values that may require a thousands separator. The option 55 | for this is \code{htmlTable.round_int}. If \code{TRUE} it will activate the \code{txtInt} 56 | functionality.} 57 | 58 | \item{excl.cols}{Columns to exclude from the rounding procedure when provided a matrix. 59 | This can be either a number or regular expression. Skipped if \code{x} is a vector.} 60 | 61 | \item{excl.rows}{Rows to exclude from the rounding procedure when provided a matrix. 62 | This can be either a number or regular expression.} 63 | } 64 | \value{ 65 | \code{matrix/data.frame} 66 | } 67 | \description{ 68 | Regular round often looses trailing 0:s as these are truncated, this function 69 | converts everything to strings with all 0:s intact so that tables have the 70 | correct representation, e.g. \code{txtRound(1.01, digits = 1)} turns into \code{1.0}. 71 | } 72 | \section{Tidy-select with \code{data.frame}}{ 73 | 74 | 75 | The \code{txtRound} can use \code{data.frame} for input. This allows us to use 76 | \href{https://tidyselect.r-lib.org/articles/tidyselect.html}{tidyselect} 77 | patterns as popularized by \strong{dplyr}. 78 | } 79 | 80 | \examples{ 81 | # Basic usage 82 | txtRound(1.023, digits = 1) 83 | # > "1.0" 84 | 85 | txtRound(pi, digits = 2) 86 | # > "3.14" 87 | 88 | txtRound(12344, digits = 1, txtInt_args = TRUE) 89 | # > "12,344.0" 90 | 91 | 92 | # Using matrix 93 | mx <- matrix(c(1, 1.11, 1.25, 94 | 2.50, 2.55, 2.45, 95 | 3.2313, 3, pi), 96 | ncol = 3, byrow=TRUE) 97 | txtRound(mx, digits = 1) 98 | #> [,1] [,2] [,3] 99 | #> [1,] "1.0" "1.1" "1.2" 100 | #> [2,] "2.5" "2.5" "2.5" 101 | #> [3,] "3.2" "3.0" "3.1" 102 | 103 | # Using a data.frame directly 104 | library(magrittr) 105 | data("mtcars") 106 | # If we want to round all the numerical values 107 | mtcars \%>\% 108 | txtRound(digits = 1) 109 | 110 | # If we want only want to round some columns 111 | mtcars \%>\% 112 | txtRound(wt, qsec_txt = qsec, digits = 1) 113 | } 114 | \seealso{ 115 | Other text formatters: 116 | \code{\link{txtInt}()}, 117 | \code{\link{txtMergeLines}()}, 118 | \code{\link{txtPval}()} 119 | } 120 | \concept{text formatters} 121 | -------------------------------------------------------------------------------- /tests/testthat/test-tidyHtmlTable.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(dplyr) 3 | library(tibble) 4 | library(purrr) 5 | library(glue) 6 | library(XML) 7 | library(xml2) 8 | library(stringr) 9 | 10 | # Add row names 11 | test_that("Basic tidyHtmlTable functionality", { 12 | skip_if_not_installed("tidyr") 13 | 14 | mx <- tribble(~value, ~header, ~name, ~rgroup, ~cgroup1, ~cgroup2, 15 | 1, 2, 3, 1, 1, 3, 16 | 2, 3, 4, 1, 2, 3, 17 | 3, 4, 5, 2, 2, 4) %>% 18 | mutate_at(vars(starts_with("cgroup")), ~glue("{name} cg", name = .)) %>% 19 | mutate(rgroup = glue("{name}_rg", name = rgroup), 20 | header = glue("{name}_h", name = header)) 21 | table_str <- mx %>% 22 | tidyHtmlTable(header = header, 23 | rowlabel = 'row', 24 | label = "test_table") 25 | 26 | parsed_table <- readHTMLTable(as.character(table_str))[["test_table"]] 27 | expect_equal(ncol(parsed_table), 4) 28 | expect_equal(nrow(parsed_table), length(mx$value)) 29 | expect_equal(parsed_table %>% 30 | filter(row == 3) %>% 31 | pluck("2_h") %>% 32 | as.character(), 33 | mx %>% 34 | filter(name == 3) %>% 35 | pluck("value") %>% 36 | as.character()) 37 | 38 | expect_equal(parsed_table %>% 39 | filter(row == 4) %>% 40 | pluck("3_h") %>% 41 | as.character(), 42 | mx %>% 43 | filter(name == 4) %>% 44 | pluck("value") %>% 45 | as.character()) 46 | 47 | expect_equal(parsed_table %>% 48 | filter(row == 5) %>% 49 | pluck("4_h") %>% 50 | as.character(), 51 | mx %>% 52 | filter(name == 5) %>% 53 | pluck("value") %>% 54 | as.character()) 55 | 56 | table_str <- mx %>% 57 | tidyHtmlTable(header = header, 58 | rgroup = rgroup, 59 | label = "test_table") 60 | 61 | parsed_table <- readHTMLTable(as.character(table_str))[["test_table"]] 62 | expect_equal(ncol(parsed_table), 4) 63 | expect_equal(nrow(parsed_table), length(mx$value) + length(mx$rgroup %>% unique)) 64 | 65 | table_str <- mx %>% 66 | tidyHtmlTable(header = header, 67 | rgroup = rgroup, 68 | hidden_rgroup = "1_rg", 69 | label = "test_table") 70 | parsed_table <- readHTMLTable(as.character(table_str))[["test_table"]] 71 | expect_equal(ncol(parsed_table), 4) 72 | expect_equal(nrow(parsed_table), length(mx$value) + length(mx$rgroup %>% unique) - 1) 73 | expect_match(table_str, "2_rg") 74 | expect_false(grepl("1_rg", table_str)) 75 | 76 | table_str <- mx %>% 77 | tidyHtmlTable(header = header, 78 | tspanner = rgroup, 79 | hidden_tspanner = "1_rg", 80 | label = "test_table") 81 | expect_match(table_str, "2_rg") 82 | expect_false(grepl("1_rg", table_str)) 83 | 84 | table_str <- mx %>% 85 | tidyHtmlTable(header = header, 86 | rgroup = rgroup, 87 | cgroup = cgroup1, 88 | label = "test_table") 89 | 90 | parsed_table <- readHTMLTable(as.character(table_str))[["test_table"]] 91 | expect_equal(colnames(parsed_table) %>% keep(~grepl("[0-9]", .)) %>% length, 92 | unique(mx$header) %>% length) 93 | expect_equal(ncol(parsed_table), 5) 94 | expect_equal(nrow(parsed_table), length(mx$value) + length(mx$rgroup %>% unique)) 95 | 96 | table_str <- mx %>% 97 | tidyHtmlTable(header = header, 98 | rgroup = rgroup, 99 | cgroup = starts_with("cgroup"), 100 | label = "test_table") 101 | 102 | parsed_table <- readHTMLTable(as.character(table_str))[["test_table"]] 103 | expect_equal(colnames(parsed_table) %>% keep(~grepl("[0-9]", .)) %>% length, 104 | unique(mx$header) %>% length) 105 | # Each cgroup generates a empty cell in-between which is how we detect the 106 | # cgroup as it adds these for layout purpose 107 | expect_equal(ncol(parsed_table), 3 + 1 + 2) 108 | expect_equal(nrow(parsed_table), length(mx$value) + length(mx$rgroup %>% unique)) 109 | }) 110 | 111 | 112 | 113 | -------------------------------------------------------------------------------- /R/htmlTable_render_getThead.R: -------------------------------------------------------------------------------- 1 | #' Renders the table head (thead) 2 | #' 3 | #' @inheritParams htmlTable 4 | #' @inheritParams prGetCgroupHeader 5 | #' @param total_columns The total number of columns including the rowlabel and the 6 | #' specer cells 7 | #' @return `string` Returns the html string for the `...` element 8 | #' @keywords internal 9 | #' @importFrom stringr str_interp 10 | prGetThead <- function(x, 11 | header = NULL, 12 | cgroup = NULL, n.cgroup = NULL, 13 | caption = NULL, 14 | compatibility, 15 | total_columns, 16 | css.cgroup, 17 | top_row_style, 18 | rnames, 19 | rowlabel = NULL, 20 | cgroup_spacer_cells, 21 | prepped_cell_css, 22 | style_list, 23 | cell_style) { 24 | first_row <- TRUE 25 | # Start the head 26 | head_str <- "\n\t" 27 | 28 | if (!is.null(caption) & 29 | compatibility == "LibreOffice" & 30 | !style_list$pos.caption %in% c("bottom", "below")) { 31 | head_str %<>% paste(str_interp("${CONTENT}", 32 | list(COLSPAN = total_columns, 33 | CONTENT = caption)), 34 | sep = "\n\t") 35 | } 36 | 37 | # Add the cgroup table header 38 | if (!is.null(cgroup)) { 39 | for (i in 1:nrow(cgroup)) { 40 | cgrp_str <- prGetCgroupHeader( 41 | x = x, 42 | cgroup_vec = cgroup[i, ], 43 | n.cgroup_vec = n.cgroup[i, ], 44 | cgroup_vec.just = style_list$align.cgroup[i, ], 45 | css_4_cgroup_vec = style_list$css.cgroup[i, ], 46 | row_no = i, 47 | top_row_style = top_row_style, 48 | rnames = rnames, 49 | rowlabel = rowlabel, 50 | style_list = style_list, 51 | cgroup_spacer_cells = cgroup_spacer_cells, 52 | prepped_cell_css = prepped_cell_css 53 | ) 54 | head_str %<>% 55 | paste0(cgrp_str) 56 | } 57 | first_row <- FALSE 58 | } 59 | 60 | 61 | # Add the header 62 | if (!is.null(header)) { 63 | header_rowlabel_str <- NA 64 | no_cgroup_rows <- ifelse(!is.null(cgroup), nrow(cgroup), 0) 65 | ts <- ifelse(no_cgroup_rows > 0, "", top_row_style) 66 | 67 | header_list <- NULL 68 | if (!is.null(rowlabel) && style_list$pos.rowlabel == no_cgroup_rows + 1) { 69 | header_list <- list(STYLE = prGetStyle(style_list$css.header.border_bottom, 70 | style_list$css.header[1], 71 | ts, 72 | attr(prepped_cell_css, "rnames")[1], 73 | align = prGetAlign(style_list$align.header, 1, style_list = style_list)), 74 | CONTENT = rowlabel) 75 | } else if (!prSkipRownames(rnames)) { 76 | header_list <- list(STYLE = prGetStyle(style_list$css.header.border_bottom, 77 | ts), 78 | CONTENT = "") 79 | } 80 | 81 | if (!is.null(header_list)) { 82 | header_rowlabel_str <- paste(str_interp("${CONTENT}", header_list), 83 | sep = "\n\t\t") 84 | } 85 | 86 | 87 | cell_style <- c(style_list$css.header.border_bottom) 88 | if (first_row) { 89 | cell_style %<>% c(top_row_style) 90 | } 91 | 92 | cell_str <- prAddCells( 93 | rowcells = header, 94 | cellcode = "th", 95 | style_list = style_list, 96 | style = cell_style, 97 | cgroup_spacer_cells = cgroup_spacer_cells, 98 | has_rn_col = !prSkipRownames(rnames) * 1, 99 | prepped_cell_css = attr(prepped_cell_css, "header"), 100 | style_list_align_key = "align.header" 101 | ) 102 | 103 | # The bottom border was ment to be here but it doesn't 104 | # work that well in the export 105 | if (is.na(header_rowlabel_str)) { 106 | head_str %<>% paste(paste0("", cell_str), 107 | "", 108 | sep = "\n\t") 109 | 110 | } else { 111 | head_str %<>% paste(paste0("", header_rowlabel_str, cell_str), 112 | "", 113 | sep = "\n\t") 114 | } 115 | 116 | first_row <- FALSE 117 | } 118 | 119 | ################################# 120 | # Close head and start the body # 121 | ################################# 122 | head_str %<>% 123 | paste0("\n\t") 124 | return(head_str) 125 | } 126 | -------------------------------------------------------------------------------- /R/htmlTable_helpers_attr4RgroupAdd.R: -------------------------------------------------------------------------------- 1 | #' Get the add attribute element 2 | #' 3 | #' Gets the add element attribute if it exists. If non-existant it will 4 | #' return NULL. 5 | #' 6 | #' @param rgroup_iterator The rgroup number of interest 7 | #' @param no_cols The `ncol(x)` of the core htmlTable x argument 8 | #' @inheritParams htmlTable 9 | #' @keywords internal 10 | #' @importFrom stats na.omit 11 | prAttr4RgroupAdd <- function(rgroup, rgroup_iterator, no_cols) { 12 | if (is.null(attr(rgroup, "add"))) { 13 | return(NULL) 14 | } 15 | 16 | add_elmnt <- attr(rgroup, "add") 17 | if (is.null(names(add_elmnt))) { 18 | if (is.null(dim(add_elmnt)) && 19 | length(add_elmnt) == sum(rgroup != "")) { 20 | if (!is.list(add_elmnt)) { 21 | add_elmnt <- as.list(add_elmnt) 22 | } 23 | names(add_elmnt) <- (1:length(rgroup))[rgroup != ""] 24 | } else if (!is.null(dim(add_elmnt)) && 25 | ncol(add_elmnt) %in% c(1, no_cols)) { 26 | 27 | # Convert matrix to stricter format 28 | tmp <- list() 29 | for (i in 1:nrow(add_elmnt)) { 30 | if (ncol(add_elmnt) == 1) { 31 | tmp[[i]] <- add_elmnt[i, ] 32 | } else { 33 | tmp2 <- as.list(add_elmnt[i, ]) 34 | names(tmp2) <- 1:no_cols 35 | tmp[[i]] <- tmp2 36 | } 37 | } 38 | if (nrow(add_elmnt) == sum(rgroup != "")) { 39 | names(tmp) <- (1:length(rgroup))[rgroup != ""] 40 | } else if (!is.null(rownames(add_elmnt))) { 41 | names(tmp) <- rownames(add_elmnt) 42 | } else { 43 | stop( 44 | "You have provided a matrix as the 45 | add attribute to rgroups without rows that either 46 | match the number of rgroups available '", length(rgroup[rgroup != ""]), "'", 47 | " (you provided '", nrow(add_elmnt), "' rows).", 48 | " And you also failed to have rownames." 49 | ) 50 | } 51 | add_elmnt <- tmp 52 | } else { 53 | stop( 54 | "The length of the rgroup 'add' attribute must either match", 55 | " (1) the length of the rgroup", 56 | " (2) or have names corresponding to the mapping integers" 57 | ) 58 | } 59 | } 60 | 61 | if (!is.list(add_elmnt) && 62 | !is.vector(add_elmnt)) { 63 | stop("The rgroup mus either be a list or a vector") 64 | } 65 | 66 | add_pos <- ifelse(grepl( 67 | "^[123456789][0-9]*$", 68 | names(add_elmnt) 69 | ), 70 | as.integer(names(add_elmnt)), 71 | NA 72 | ) 73 | if (any(is.na(add_pos))) { 74 | # Look for rgroup names that match to those not 75 | # found through the integer match 76 | # If found the number is assigned to the add_pos 77 | available_rgroups <- rgroup 78 | if (!all(is.na(add_pos))) { 79 | available_rgroups <- available_rgroups[-na.omit(add_pos)] 80 | } 81 | for (missing_pos in which(is.na(add_pos))) { 82 | row_label <- names(add_elmnt) 83 | if (row_label %in% available_rgroups) { 84 | available_rgroups <- 85 | available_rgroups[available_rgroups != row_label] 86 | pos <- which(rgroup == row_label) 87 | if (length(pos) > 1) { 88 | stop( 89 | "There seem to be two identical row groups ('", row_label, "')", 90 | " that you whish to assign a add columns to through the 'add'", 91 | " attribute for the rgroup element." 92 | ) 93 | } else { 94 | add_pos[missing_pos] <- pos 95 | } 96 | } 97 | } 98 | if (any(is.na(add_pos))) { 99 | failed_elements <- paste(names(add_elmnt)[is.na(add_pos)], collapse = "', '") 100 | available <- paste(rgroup, collapse = "', '") 101 | stop( 102 | "Failed to find matchin rgroup elements for: ", 103 | "'", failed_elements, "'", 104 | " from availabel rgroups: ", 105 | "'", available, "'" 106 | ) 107 | } 108 | names(add_elmnt) <- add_pos 109 | } 110 | 111 | if (!is.list(add_elmnt)) { 112 | add_elmnt <- as.list(add_elmnt) 113 | } 114 | 115 | if (any(add_pos < 1)) { 116 | stop("The rgroup 'add' attribute cannot have integer names below 1") 117 | } 118 | 119 | if (any(!add_pos <= length(rgroup)) || any(rgroup[add_pos] == "")) { 120 | no_rgroups_empty <- paste(which(rgroup == ""), collapse = ", ") 121 | prob_positions <- paste(add_pos[add_pos > length(rgroup) | add_pos %in% which(rgroup == "")], collapse = "', '") 122 | stop( 123 | "The rgroup 'add' attribute cannot have integer names indicating", 124 | " positions larger than the length of the rgroup", 125 | " (=", length(rgroup), ") or matches", 126 | " one of the empty groups (no. ", no_rgroups_empty, ").", 127 | " The problematic position(s):", 128 | " '", prob_positions, "'" 129 | ) 130 | } 131 | 132 | # Return the matching iterator 133 | if (rgroup_iterator %in% names(add_elmnt)) { 134 | return(add_elmnt[[as.character(rgroup_iterator)]]) 135 | } 136 | 137 | return(NULL) 138 | } 139 | -------------------------------------------------------------------------------- /tests/testthat/test-htmlTable_cgroup.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(XML) 3 | 4 | test_that("Check that dimensions are correct with cgroup usage",{ 5 | mx <- matrix(1:6, ncol = 3) 6 | colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) 7 | table_str <- htmlTable(mx, 8 | cgroup = c("a", "b"), 9 | n.cgroup=c(1, 2)) 10 | parsed_table <- readHTMLTable(as.character(table_str))[[1]] 11 | expect_equal(ncol(parsed_table), ncol(mx) + 1, 12 | info = "Cols did not match") 13 | expect_equal(nrow(parsed_table), 14 | nrow(mx), info="Rows did not match") 15 | 16 | expect_warning(htmlTable(mx, 17 | cgroup=c("a", "b", "c"), 18 | n.cgroup=c(1, 2, 0))) 19 | 20 | expect_error(htmlTable(mx, 21 | cgroup=c("a", "b", "c"), 22 | n.cgroup=c(1, 2, 10))) 23 | 24 | table_str <- htmlTable(mx, 25 | cgroup=rbind(c("aa", NA), 26 | c("a", "b")), 27 | n.cgroup=rbind(c(2, NA), 28 | c(1, 2))) 29 | parsed_table <- readHTMLTable(as.character(table_str))[[1]] 30 | expect_equal(ncol(parsed_table), ncol(mx) + 1, 31 | info="Cols did not match for multilevel cgroup") 32 | 33 | 34 | table_str <- htmlTable(mx, 35 | cgroup=rbind(c("aa", "bb"), 36 | c("a", "b")), 37 | n.cgroup=rbind(c(2, 1), 38 | c(1, 2))) 39 | parsed_table <- readHTMLTable(as.character(table_str))[[1]] 40 | expect_equal(ncol(parsed_table), ncol(mx) + 2, 41 | info="Cols did not match for multilevel cgroup") 42 | 43 | table_str <- htmlTable(mx, 44 | cgroup=c("a", "b"), 45 | n.cgroup=c(2, 1), 46 | tspanner=c("First spanner", 47 | "Secon spanner"), 48 | n.tspanner=c(1,1)) 49 | expect_match(table_str, "td[^>]*colspan='4'[^>]*>First spanner", 50 | info="The expected number of columns should be 4") 51 | expect_match(table_str, "td[^>]*colspan='4'[^>]*>Secon spanner", 52 | info="The expected number of columns should be 4") 53 | 54 | expect_error(htmlTable(mx, 55 | cgroup=c("a", "b"), 56 | n.cgroup=c(2, 1), 57 | tspanner=c("First spanner", 58 | "Secon spanner"), 59 | n.tspanner=c(1,2))) 60 | 61 | 62 | mx <- rbind(mx, 63 | mx, 64 | mx, 65 | mx) 66 | table_str <- htmlTable(mx, 67 | rnames = LETTERS[1:nrow(mx)], 68 | cgroup=rbind(c("aa", "bb"), 69 | c("a", "b")), 70 | n.cgroup=rbind(c(2, 1), 71 | c(1, 2)), 72 | rgroup=paste(1:4, "rgroup"), 73 | n.rgroup=rep(2, 4), 74 | tspanner=c("First tspanner", 75 | "Second tspanner"), 76 | n.tspanner=c(4,4)) 77 | 78 | expect_match(table_str, "td[^>]*colspan='6'[^>]*>1 rgroup", 79 | info="The expected number of columns should be 6") 80 | expect_match(table_str, "td[^>]*colspan='6'[^>]*>2 rgroup", 81 | info="The expected number of columns should be 6") 82 | 83 | parsed_table <- readHTMLTable(as.character(table_str))[[1]] 84 | expect_equal(as.character(parsed_table[1,1]), 85 | "First tspanner") 86 | expect_equal(as.character(parsed_table[2,1]), 87 | "1 rgroup") 88 | expect_equal(as.character(parsed_table[8,1]), 89 | "Second tspanner") 90 | expect_equal(as.character(parsed_table[9,1]), 91 | "3 rgroup") 92 | }) 93 | 94 | test_that("Flexible number of cgroups",{ 95 | mx <- matrix(1:6, ncol=3) 96 | colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) 97 | 98 | expect_error(htmlTable(mx, 99 | cgroup = c("", "__test__"), 100 | n.cgroup = 1:3)) 101 | 102 | expect_error(htmlTable(mx, 103 | cgroup = c("", "__test__", ""), 104 | n.cgroup = 1)) 105 | 106 | out <- htmlTable(mx, 107 | cgroup = c("", "__test__"), 108 | n.cgroup = 1) 109 | expect_match(out, 110 | "colspan='2'[^>]*>__test__<") 111 | }) 112 | 113 | 114 | test_that("Assume last element for n.cgroup",{ 115 | mx <- matrix(1:6, ncol=3) 116 | colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) 117 | 118 | out <- htmlTable(mx, 119 | cgroup = "__test__") 120 | expect_match(out, 121 | "colspan='3'[^>]*>__test__<") 122 | 123 | }) 124 | -------------------------------------------------------------------------------- /vignettes/text_formatters.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Text formatters" 3 | author: "Max Gordon" 4 | date: "`r Sys.Date()`" 5 | VignetteBuilder: knitr, rmarkdown 6 | output: 7 | rmarkdown::html_vignette: 8 | css: custom.css 9 | keep_md: true 10 | toc: true 11 | vignette: > 12 | %\VignetteIndexEntry{Text formatters} 13 | %\usepackage[utf8]{inputenc} 14 | %\VignetteEngine{knitr::rmarkdown} 15 | editor_options: 16 | chunk_output_type: inline 17 | --- 18 | 19 | Text formatters 20 | =============== 21 | 22 | Bundled with this package are some text formatting functions. The purpose of these is to convert numeric values into character/text that is more pleasent in publication tables. 23 | 24 | txtRound 25 | -------- 26 | 27 | While `base::round()` is an excellent function in most cases we often want a table to retain trailing 0:s. E.g. 28 | 29 | ```{r message=FALSE} 30 | library(htmlTable) 31 | library(dplyr) 32 | library(magrittr) 33 | data("mtcars") 34 | 35 | mtcars %<>% 36 | mutate(am = factor(am, levels = 0:1, labels = c("Automatic", "Manual")), 37 | vs = factor(vs, levels = 0:1, labels = c("V-shaped", "straight"))) 38 | 39 | mtcars %>% 40 | head(3) %>% 41 | select(Transmission = am, Gas = mpg, Weight = wt) %>% 42 | htmlTable() 43 | ``` 44 | 45 | doesn't look visually that great, instead we would prefer to have something like this: 46 | 47 | ```{r} 48 | mtcars %>% 49 | head(3) %>% 50 | select(Transmission = am, Gas = mpg, Weight = wt) %>% 51 | txtRound(digits = 1) %>% 52 | htmlTable() 53 | ``` 54 | 55 | ### Single/vector values 56 | 57 | At the core of the `txtRound` is the single/vector value conversion: 58 | 59 | ```{r} 60 | txtRound(c(1, 1.1034), digits = 2) 61 | 62 | # Use a character to convert 63 | txtRound("1.2333", digits = 2) 64 | ``` 65 | 66 | If you have some values that need thousand separation you can also add `txtInt_args`. 67 | 68 | ```{r} 69 | # Large numbers can be combined with the txtInt option 70 | txtRound(12345.12, digits = 1, txtInt_args = TRUE) 71 | 72 | txtRound(12345.12, digits = 1, txtInt_args = list(language = "se", html = FALSE)) 73 | ``` 74 | 75 | ### Data frames 76 | 77 | As seen in the introduction we can use data frames for input. We can here rename the converted columns: 78 | 79 | ```{r} 80 | mtcars %>% 81 | head(3) %>% 82 | select(mpg, wt) %>% 83 | txtRound(mpg, wt_txt = wt, digits = 1) 84 | ``` 85 | 86 | And we can specify the number of decimals that we're interested in per column: 87 | 88 | ```{r} 89 | mtcars %>% 90 | head(3) %>% 91 | select(mpg, qsec, wt) %>% 92 | txtRound(digits = list(wt = 2, .default = 1)) 93 | ``` 94 | 95 | ### Matrix 96 | 97 | We can also feed a matrix into the `txtRound`: 98 | 99 | ```{r} 100 | mtcars_matrix <- mtcars %>% 101 | select(mpg, qsec, wt) %>% 102 | head(3) %>% 103 | as.matrix() 104 | 105 | mtcars_matrix %>% 106 | txtRound(digits = 1) 107 | ``` 108 | 109 | Here we have some options of excluding columns/rows using regular expressions: 110 | 111 | ```{r} 112 | mtcars_matrix %>% 113 | txtRound(excl.cols = "^wt$", 114 | excl.rows = "^Mazda RX4$", 115 | digits = 1) 116 | ``` 117 | 118 | Similarly to the data.frame we can use the same syntax to pick column specific digits: 119 | 120 | ```{r} 121 | mtcars_matrix %>% 122 | txtRound(digits = list(mpg = 0, wt = 2, .default = 1)) 123 | ``` 124 | 125 | txtInt 126 | ------ 127 | 128 | While scientific format is useful if familiar with the syntax it can be difficult to grasp for scholars with a less mathematical background. Therefore the thousand separator style can be quite useful, also known as [digital grouping](https://en.wikipedia.org/wiki/Decimal_separator#Digit_grouping): 129 | 130 | ```{r} 131 | txtInt(1e7) 132 | ``` 133 | 134 | As Swedish and many other languages rely on space (SI-standard) we can specify language as a parameter. Note that as we don't want to have line breaks within a digit we can use [non-breaking space](https://en.wikipedia.org/wiki/Non-breaking_space) for keeping the number intact (the html-code is ` `): 135 | 136 | ```{r} 137 | txtInt(1e7, language = "SI", html = FALSE) 138 | 139 | txtInt(1e7, language = "SI", html = TRUE) 140 | ``` 141 | 142 | Note that there are the option `htmlTable.language` and `htmlTable.html` that you can use for the input of these parameters. 143 | 144 | txtPval 145 | ------- 146 | 147 | The p-value is perhaps the most controversial of statistical output, nevertheless it is still needed and used correctly it has it's use. P-values are frequently rounded as the decimals are not as important. The `txtPval` is a convenient function with some defaults that correspond to typical uses in medical publications. 148 | 149 | ```{r} 150 | txtPval(c(0.1233213, 0.035, 0.001, 0.000001), html = FALSE) 151 | 152 | # The < sign is less-than in html code '<' 153 | txtPval(c(0.05, 0.001, 0.000001), html = TRUE) 154 | ``` 155 | 156 | txtMergeLines 157 | ------------- 158 | 159 | In html we indicate new line using *<br />* while the latex style uses *hbox*. To help with these two there is the `txtMergeLines` that merges lines into one properly formatted unit: 160 | 161 | ```{r} 162 | txtMergeLines("Line 1", 163 | "Line 2", 164 | "Line 3") 165 | ``` 166 | 167 | Note that you can also use a single multi-line string: 168 | 169 | ```{r} 170 | txtMergeLines("Line 1 171 | Line 2 172 | Line 3") 173 | ``` 174 | 175 | 176 | ```{r} 177 | txtMergeLines("Line 1 178 | Line 2 179 | Line 3", 180 | html = FALSE) 181 | ``` 182 | 183 | -------------------------------------------------------------------------------- /R/htmlTable_render_getRgroupLine.R: -------------------------------------------------------------------------------- 1 | #' Gets the number of `rgroup` HTML line 2 | #' 3 | #' @param total_columns The total number of columns including the `rowlabel` and the 4 | #' spacer cells 5 | #' @param cspan The column span of the current `rgroup` 6 | #' @param style The css style corresponding to the `rgroup` css style that includes 7 | #' the color specific for the `rgroup`, i.e. `col.rgroup`. 8 | #' @param cgroup_spacer_cells The vector indicating the position of the `cgroup` 9 | #' spacer cells 10 | #' @param prepped_row_css The `css.cell` information for this particular row. 11 | #' @param rgroup_iterator An integer indicating the `rgroup` 12 | #' @inheritParams htmlTable 13 | #' @keywords internal 14 | prGetRgroupLine <- function(x, 15 | total_columns = NULL, 16 | rgroup = NULL, 17 | rgroup_iterator = NULL, 18 | cspan = NULL, 19 | rnames = NULL, 20 | style = NULL, 21 | cgroup_spacer_cells = NULL, 22 | style_list = NULL, 23 | prepped_row_css = NULL) { 24 | ret_str <- "" 25 | rgroup_elmnt <- rgroup[rgroup_iterator] 26 | add_elmnt <- prAttr4RgroupAdd( 27 | rgroup = rgroup, 28 | rgroup_iterator = rgroup_iterator, 29 | no_cols = ncol(x) 30 | ) 31 | 32 | ## this will allow either css.rgroup or col.rgroup to 33 | ## color the rgroup label rows 34 | if (is.numeric(cspan) && 35 | cspan < ncol(x) || 36 | !is.null(add_elmnt)) { 37 | filler_cells <- rep("", ncol(x)) 38 | 39 | if (!is.null(add_elmnt)) { 40 | if (!is.numeric(cspan)) { 41 | cspan <- ncol(x) + 1 * !prSkipRownames(rnames) 42 | } 43 | 44 | if (length(add_elmnt) > 1) { 45 | if (is.null(names(add_elmnt))) { 46 | stop( 47 | "The rgroup 'add' attribute element no '", rgroup_iterator, "'", 48 | " either be a single element or a named list/vector" 49 | ) 50 | } 51 | 52 | add_pos <- as.integer(names(add_elmnt)) 53 | if (any(is.na(add_pos)) || 54 | any(add_pos < 1) || 55 | any(add_pos > ncol(x))) { 56 | stop( 57 | "You have provided invalid element position for rgroup = '", rgroup_elmnt, "'", 58 | " the attribute seeems to be a list but the names are invalid", 59 | " '", paste(names(add_elmnt), collapse = "', '"), "'", 60 | " they should be integers between 1 and ", ncol(x) 61 | ) 62 | } 63 | 64 | first_pos <- min(add_pos) - 1 + 1 * !prSkipRownames(rnames) 65 | if (is.null(cspan)) { 66 | cspan <- first_pos 67 | } else { 68 | cspan <- min( 69 | cspan, 70 | first_pos 71 | ) 72 | } 73 | 74 | for (ii in 1:length(add_pos)) { 75 | filler_cells[add_pos[ii]] <- add_elmnt[[ii]] 76 | } 77 | } else if (length(add_elmnt) == 1) { 78 | if (is.null(names(add_elmnt)) || 79 | names(add_elmnt) == "last") { 80 | add_pos <- ncol(x) 81 | } else { 82 | add_pos <- as.integer(names(add_elmnt)) 83 | if (is.na(add_pos) || 84 | add_pos < 1 || 85 | add_pos > ncol(x)) { 86 | stop( 87 | "You have provided invalid element position for rgroup = '", rgroup_elmnt, "'", 88 | " the attribute seeems to be a list but the name is invalid", 89 | " '", names(add_elmnt), "'", 90 | " it should be an integer between 1 and ", ncol(x) 91 | ) 92 | } 93 | } 94 | 95 | first_pos <- add_pos - 1 + 1 * !prSkipRownames(rnames) 96 | if (is.null(cspan)) { 97 | cspan <- first_pos 98 | } else { 99 | cspan <- min( 100 | cspan, 101 | first_pos 102 | ) 103 | } 104 | 105 | filler_cells[add_pos] <- add_elmnt 106 | } else { 107 | stop( 108 | "The attribute to the rgroup '", rgroup_elmnt, "'", 109 | " does not have a length!" 110 | ) 111 | } 112 | } 113 | 114 | true_span <- cspan + 115 | sum(cgroup_spacer_cells[0:(cspan - 1 * !prSkipRownames(rnames))]) * prGetEmptySpacerCellSize(style_list = style_list) 116 | ret_str %<>% 117 | sprintf( 118 | "%s\n\t%s", 119 | ., 120 | true_span, 121 | prGetStyle(style), 122 | paste0( 123 | style_list$padding.tspanner, 124 | rgroup_elmnt 125 | ) 126 | ) 127 | 128 | 129 | cols_left <- ncol(x) - (cspan - 1 * !prSkipRownames(rnames)) 130 | cell_str <- prAddCells( 131 | rowcells = filler_cells, 132 | cellcode = "td", 133 | style_list = style_list, 134 | style = style, 135 | cgroup_spacer_cells = cgroup_spacer_cells, 136 | has_rn_col = !prSkipRownames(rnames) * 1, 137 | offset = ncol(x) - cols_left + 1, 138 | prepped_cell_css = prepped_row_css 139 | ) 140 | ret_str %<>% 141 | paste0(cell_str) 142 | 143 | 144 | ret_str %<>% paste0("") 145 | } else { 146 | ret_str %<>% 147 | sprintf( 148 | "%s\n\t%s", 149 | ., 150 | total_columns, 151 | prGetStyle(style), 152 | paste0( 153 | style_list$padding.tspanner, 154 | rgroup_elmnt 155 | ) 156 | ) 157 | } 158 | 159 | return(ret_str) 160 | } 161 | -------------------------------------------------------------------------------- /R/htmlTable_render_getCgroupHeader.R: -------------------------------------------------------------------------------- 1 | #' Retrieve a header row 2 | #' 3 | #' This function retrieves a header row, i.e. a row 4 | #' within the `` elements on top of the table. Used by 5 | #' [htmlTable()]. 6 | #' 7 | #' @param cgroup_vec The `cgroup` may be a `matrix`, this is 8 | #' just one row of that `matrix` 9 | #' @param n.cgroup_vec The same as above but for the counter 10 | #' @param cgroup_vec.just The same as above bot for the justification 11 | #' @param row_no The row number within the header group. Useful for multi-row 12 | #' headers when we need to output the `rowlabel` at the `pos.rowlabel` 13 | #' level. 14 | #' @param style_list The list with all the styles 15 | #' @param top_row_style The top row has a special style depending on 16 | #' the `ctable` option in the `htmlTable` call. 17 | #' @param cgroup_spacer_cells The spacer cells due to the multiple cgroup levels. 18 | #' With multiple rows in cgroup we need to keep track of how many spacer cells 19 | #' occur between the columns. This variable contains is of the size `ncol(x)-1` 20 | #' and 0 if there is no cgroup element between. 21 | #' @return `string` 22 | #' @keywords internal 23 | #' @inheritParams htmlTable 24 | #' @family hidden helper functions for htmlTable 25 | #' @importFrom stringr str_interp 26 | prGetCgroupHeader <- function(x, 27 | cgroup_vec, 28 | n.cgroup_vec, 29 | cgroup_vec.just, 30 | row_no, top_row_style, 31 | rnames, 32 | rowlabel = NULL, 33 | cgroup_spacer_cells, 34 | style_list, 35 | prepped_cell_css, 36 | css_4_cgroup_vec) { 37 | header_str <- "\n\t" 38 | if (row_no == 1) { 39 | ts <- top_row_style 40 | } else { 41 | ts <- "" 42 | } 43 | 44 | if (!is.null(rowlabel)) { 45 | if (row_no == style_list$pos.rowlabel) { 46 | header_str %<>% sprintf( 47 | "%s\n\t\t%s", 48 | ., 49 | prGetStyle( 50 | c(`font-weight` = 900), 51 | ts, 52 | attr(prepped_cell_css, "rnames")[1] 53 | ), 54 | rowlabel 55 | ) 56 | } else { 57 | header_str %<>% 58 | sprintf( 59 | "%s\n\t\t", 60 | ., 61 | prGetStyle(ts) 62 | ) 63 | } 64 | } else if (!prSkipRownames(rnames)) { 65 | header_str %<>% sprintf( 66 | "%s\n\t\t", 67 | ., 68 | prGetStyle(ts) 69 | ) 70 | } 71 | 72 | for (i in 1:length(cgroup_vec)) { 73 | if (!is.na(n.cgroup_vec[i])) { 74 | start_column <- ifelse(i == 1, 75 | 1, 76 | sum(n.cgroup_vec[1:(i - 1)], na.rm = TRUE) + 1 77 | ) 78 | 79 | # 10 3-1 80 | # 0 0 1 81 | colspan <- n.cgroup_vec[i] + 82 | ifelse(start_column > length(cgroup_spacer_cells) || n.cgroup_vec[i] == 1, 83 | 0, 84 | ifelse(start_column == 1, 85 | sum(cgroup_spacer_cells[1:(n.cgroup_vec[i] - 1)]), 86 | ifelse(sum(n.cgroup_vec[1:i], na.rm = TRUE) == ncol(x), 87 | sum(cgroup_spacer_cells[start_column:length(cgroup_spacer_cells)]), 88 | sum(cgroup_spacer_cells[start_column:((start_column - 1) + (n.cgroup_vec[i] - 1))]) 89 | ) 90 | ) * prGetEmptySpacerCellSize(style_list = style_list) 91 | ) 92 | 93 | 94 | header_align <- prGetAlign(cgroup_vec.just, 95 | index = i, 96 | style_list = style_list) 97 | if (nchar(cgroup_vec[i]) == 0) { # Removed as this may now be on purpose || is.na(cgroup_vec[i])) 98 | header_values <- list(COLSPAN = colspan, 99 | STYLE = prGetStyle(c(`font-weight` = 900), 100 | ts, 101 | header_align, 102 | css_4_cgroup_vec[i]), 103 | CONTENT = "") 104 | } else { 105 | header_values <- list(COLSPAN = colspan, 106 | STYLE = prGetStyle(c(`font-weight` = 900, 107 | `border-bottom` = "1px solid grey"), 108 | ts, 109 | header_align, 110 | css_4_cgroup_vec[i]), 111 | CONTENT = cgroup_vec[i]) 112 | } 113 | 114 | header_str %<>% paste(str_interp("${CONTENT}", 115 | header_values), 116 | sep = "\n\t\t") 117 | 118 | # If not last then add a filler cell between the row categories 119 | # this is also the reason that we need the cgroup_spacer_cells 120 | if (i != sum(!is.na(cgroup_vec))) { 121 | bottom_border_style = str_interp("border-bottom: ${STYLE};", 122 | list(STYLE = style_list$spacer.css.cgroup.bottom.border)) 123 | header_str %<>% prAddEmptySpacerCell(style_list = style_list, 124 | cell_style = prGetStyle(bottom_border_style, 125 | ts), 126 | align_style = header_align, 127 | cell_tag = "th") 128 | } 129 | } 130 | } 131 | header_str %<>% 132 | paste0("\n\t") 133 | 134 | return(header_str) 135 | } 136 | -------------------------------------------------------------------------------- /inst/htmlwidgets/lib/table_pagination/table_pagination.js: -------------------------------------------------------------------------------- 1 | /** 2 | * Refreshes the table and the navigation bar 3 | * @param table the table to paginate 4 | * @param nav_id the div where the pagination menu will appear 5 | * @param currPage the page of the table to show 6 | * @param rowsShown the number of rows to show per page 7 | */ 8 | function refresh_table(table, nav_id, currPage, rowsShown) { 9 | "use strict"; 10 | function append_link_to_page(pagenum, text, container) { 11 | var pagelink; 12 | pagelink = document.createElement("a"); 13 | $(pagelink).attr('href','#').attr('data-page', pagenum). 14 | addClass('page_button').text(text); 15 | $(container).append(pagelink); 16 | return pagelink; 17 | } 18 | 19 | function showing_x_to_y_of_z_entries(startItem, endItem, rowsTotal) { 20 | var showing_entries_div = document.createElement('div'); 21 | $(showing_entries_div).attr('id', 'showing_entries_div'); 22 | if (+rowsTotal === 0) { 23 | $(showing_entries_div).append('No entries.'); 24 | } else { 25 | $(showing_entries_div).append('Showing ' +(+startItem+1) + 26 | ' to ' +endItem + ' of ' +rowsTotal + ' entries.'); 27 | } 28 | return showing_entries_div; 29 | } 30 | 31 | function first_previous_1_2_3_4_next_last(currPage, numPages, table, nav_id, rowsShown) { 32 | // First Previous 4 5 6 7 8 9 10 Next Last 33 | var page_numbers_div = document.createElement('div'); 34 | if (numPages <= 1) { 35 | // Empty div if there are no pages to change 36 | return page_numbers_div; 37 | } 38 | $(page_numbers_div).attr('id', 'page_numbers_div'); 39 | 40 | // Page: First and Previous 41 | var pagefirst = append_link_to_page(0, 'First', page_numbers_div); 42 | var pageprev = append_link_to_page(+currPage-1, 'Previous', page_numbers_div); 43 | if (+currPage === 0) { 44 | $(pagefirst).addClass('page_button_disabled'); 45 | $(pageprev).addClass('page_button_disabled'); 46 | } 47 | 48 | var spanpagenumber = document.createElement('span'); 49 | $(page_numbers_div).append(spanpagenumber); 50 | var start_nearby_pages = Math.max(0, +currPage-3); 51 | var end_nearby_pages = Math.min(+numPages-1, +currPage+3); 52 | for (var i = start_nearby_pages; i <= end_nearby_pages; i++) { 53 | // Page: i 54 | var page_i = append_link_to_page(i, 1+i, spanpagenumber); 55 | if (+currPage === +i) { 56 | $(page_i).addClass('page_button_current'); 57 | } 58 | } 59 | // Page: Next and Last 60 | var pagenext = append_link_to_page(+currPage+1, "Next", page_numbers_div); 61 | var pagelast = append_link_to_page(+numPages-1, "Last", page_numbers_div); 62 | if (+currPage === +numPages-1) { 63 | $(pagenext).addClass('page_button_disabled'); 64 | $(pagelast).addClass('page_button_disabled'); 65 | } 66 | 67 | $(page_numbers_div).find('a').bind('click', function() { 68 | var currPage = $(this).attr('data-page'); 69 | refresh_table(table, nav_id, +currPage, +rowsShown); 70 | }); 71 | return page_numbers_div; 72 | } 73 | 74 | var navobj = document.getElementById(nav_id); 75 | var rowsTotal = $(table).find('tbody').find('tr').length; 76 | var startItem = currPage * rowsShown; 77 | var endItem = Math.min(startItem + rowsShown, rowsTotal); 78 | var numPages; 79 | if (+rowsShown > 0) { 80 | numPages = Math.ceil(1.0*rowsTotal/rowsShown); 81 | } else { 82 | numPages = 0; 83 | } 84 | 85 | // Show the chosen rows: 86 | $(table).find('tbody').find('tr').css('opacity','0.0').hide().slice(startItem, endItem). 87 | css('display','table-row').animate({opacity:1}, 300); 88 | 89 | // Rewrite the navigation panel below the table on each page click 90 | $(navobj).empty(); 91 | // Showing 31 to 40 entries out of 150 entries: 92 | $(navobj).append(showing_x_to_y_of_z_entries(startItem, endItem, rowsTotal)); 93 | // First Previous 1 2 3 4 5 Next Last 94 | $(navobj).append(first_previous_1_2_3_4_next_last(currPage, numPages, 95 | table, nav_id, rowsShown)); 96 | } 97 | 98 | /** 99 | * Adds pagination options to a table 100 | * @param table the table to be paginated 101 | * @param nav_id A string with the id of the div that will contain both the "Showing 11 to 20 of 100 entries" and the pagination buttons (First Previous 1 2 3 Next Last) 102 | * @param select_entries_div_id A string with the id of the div where "Show [10|25|100] entries" selection box will be placed 103 | * @param options Currently only one option accepted: options.number_of_entries = [10, 20, 30]. It controls the possible number of rows per page to show. 104 | */ 105 | function table_pagination(table, nav_id, select_entries_div_id, options) { 106 | "use strict"; 107 | //
108 | var select_entries_div = document.getElementById(select_entries_div_id); 109 | $(select_entries_div).empty(); 110 | 111 | // Get the possible entries per page: 112 | var select_entries_allowed = options.number_of_entries; 113 | if (select_entries_allowed.length === 0) { 114 | select_entries_allowed = [10, 25, 100]; 115 | } 116 | 117 | // If select_entries_allowed is a scalar, do not offer a select: 118 | if (!$.isArray(select_entries_allowed)) { 119 | refresh_table(table, nav_id, 0, +select_entries_allowed); 120 | return; 121 | } 122 | // Otherwise show the select menu: 123 | var label_entries = document.createElement('label'); 124 | var select_entries = document.createElement('select'); 125 | var select_entries_id = select_entries_div_id.concat('_select'); 126 | $(label_entries).attr('for', select_entries_id); 127 | $(label_entries).append('Show '); 128 | $(select_entries).attr('id', select_entries_id); 129 | for (var i=0;i