htmlTable/0000755000176200001440000000000013572030437012172 5ustar liggesusershtmlTable/NAMESPACE0000644000176200001440000000255713572023061013415 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(htmlTable,data.frame) S3method(htmlTable,default) S3method(htmlTable,matrix) S3method(interactiveTable,default) S3method(knit_print,htmlTable) S3method(knit_print,interactiveTable) S3method(print,htmlTable) S3method(print,interactiveTable) S3method(tidyHtmlTable,data.frame) S3method(tidyHtmlTable,default) S3method(txtRound,data.frame) S3method(txtRound,default) S3method(txtRound,matrix) S3method(txtRound,table) export(concatHtmlTables) export(htmlTable) export(htmlTableWidget) export(htmlTableWidgetOutput) export(interactiveTable) export(outputInt) export(pvalueFormatter) export(renderHtmlTableWidget) export(splitLines4Table) export(tblNoLast) export(tblNoNext) export(tidyHtmlTable) export(txtInt) export(txtMergeLines) export(txtPval) export(txtRound) export(vector2string) import(checkmate) import(htmlwidgets) import(magrittr) importFrom(grDevices,col2rgb) importFrom(grDevices,colorRampPalette) importFrom(htmltools,htmlEscape) importFrom(knitr,asis_output) importFrom(knitr,knit_print) importFrom(methods,setClass) importFrom(rstudioapi,getActiveDocumentContext) importFrom(rstudioapi,isAvailable) importFrom(stats,na.omit) importFrom(stringr,str_replace) importFrom(stringr,str_replace_all) importFrom(stringr,str_trim) importFrom(utils,as.roman) importFrom(utils,browseURL) importFrom(utils,head) importFrom(utils,tail) htmlTable/README.md0000644000176200001440000014503413412375537013466 0ustar liggesusers[![Build Status](https://travis-ci.org/gforge/htmlTable.svg?branch=master)](https://travis-ci.org/gforge/htmlTable) [![](https://cranlogs.r-pkg.org/badges/htmlTable)](https://cran.r-project.org/package=htmlTable) Basics ====== The **htmlTable** package is intended for generating tables using [HTML](http://en.wikipedia.org/wiki/HTML) formatting. This format is compatible with [Markdown](http://rmarkdown.rstudio.com/) when used for HTML-output. The most basic table can easily be created by just passing a `matrix` or a `data.frame` to the `htmlTable`-function: ```r library(htmlTable) # A simple output output <- matrix(1:4, ncol=2, dimnames = list(list("Row 1", "Row 2"), list("Column 1", "Column 2"))) htmlTable(output) ```
Column 1 Column 2
Row 1 1 3
Row 2 2 4
As of version 1.0.2 you **no longer need** to specify `results='asis'` for each `knitr` chunk. Advanced ======== While it may be sufficient for basic tables a more advanced layout is often needed in medical publications with elements such as: * row groups * column spanners * table spanners * caption * table footer * zebra coloring (also know as *banding*): + rows + columns As many journals require that a MS Word-document is submitted it is furthermore also important that the table imports correctly to a word processor, i.e. that the table doesn't only look nice in a web browser but also in the final document. The `htmlTable`-function is written for all these purposes. **Note:** Due to GitHub CSS-styles the rows get automatically zebra-striped (in a bad way), borders get overridden and I haven't been able to figure out how to change this. See the vignette for a correct example: `vignette("general", package = "htmlTable")` For demonstration purposes we will setup a basic matrix: ```r mx <- matrix(ncol=6, nrow=8) rownames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:8, "th")), "row") colnames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:6, "th")), "hdr") for (nr in 1:nrow(mx)){ for (nc in 1:ncol(mx)){ mx[nr, nc] <- paste0(nr, ":", nc) } } ``` Row groups ---------- The purpose of the row groups is to group variables that belong to the same group, e.g. a factored variable with more than two levels often benefit from grouping variables together. ```r htmlTable(mx, rgroup = paste("Group", LETTERS[1:3]), n.rgroup = c(2,4,nrow(mx) - 6)) ```
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Group A
  1st row 1:1 1:2 1:3 1:4 1:5 1:6
  2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Group B
  3rd row 3:1 3:2 3:3 3:4 3:5 3:6
  4th row 4:1 4:2 4:3 4:4 4:5 4:6
  5th row 5:1 5:2 5:3 5:4 5:5 5:6
  6th row 6:1 6:2 6:3 6:4 6:5 6:6
Group C
  7th row 7:1 7:2 7:3 7:4 7:5 7:6
  8th row 8:1 8:2 8:3 8:4 8:5 8:6
We can easily mix row groups with regular variables by having an empty row group name `""`: ```r htmlTable(mx, rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,4,nrow(mx) - 6)) ```
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Group A
  1st row 1:1 1:2 1:3 1:4 1:5 1:6
  2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Group B
  3rd row 3:1 3:2 3:3 3:4 3:5 3:6
  4th row 4:1 4:2 4:3 4:4 4:5 4:6
  5th row 5:1 5:2 5:3 5:4 5:5 5:6
  6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6
When mixing row groups with variables without row groups we may want to omit the bold formatting of the row group label: ```r htmlTable(mx, css.rgroup = "", rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,4,nrow(mx) - 6)) ```
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Group A
  1st row 1:1 1:2 1:3 1:4 1:5 1:6
  2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Group B
  3rd row 3:1 3:2 3:3 3:4 3:5 3:6
  4th row 4:1 4:2 4:3 4:4 4:5 4:6
  5th row 5:1 5:2 5:3 5:4 5:5 5:6
  6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6
Column spanners --------------- A column spanner spans 2 or more columns: ```r htmlTable(mx, cgroup = c("Cgroup 1", "Cgroup 2"), n.cgroup = c(2,4)) ```
Cgroup 1  Cgroup 2
1st hdr 2nd hdr   3rd hdr 4th hdr 5th hdr 6th hdr
1st row 1:1 1:2   1:3 1:4 1:5 1:6
2nd row 2:1 2:2   2:3 2:4 2:5 2:6
3rd row 3:1 3:2   3:3 3:4 3:5 3:6
4th row 4:1 4:2   4:3 4:4 4:5 4:6
5th row 5:1 5:2   5:3 5:4 5:5 5:6
6th row 6:1 6:2   6:3 6:4 6:5 6:6
7th row 7:1 7:2   7:3 7:4 7:5 7:6
8th row 8:1 8:2   8:3 8:4 8:5 8:6
It can sometimes be convenient to have column spanners in multiple levels: ```r htmlTable(mx, cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2")), n.cgroup = rbind(c(1,2,NA), c(2,2,2))) ```
  Column spanners
  Cgroup 1  Cgroup 2
1st hdr 2nd hdr   3rd hdr 4th hdr   5th hdr 6th hdr
1st row 1:1 1:2   1:3 1:4   1:5 1:6
2nd row 2:1 2:2   2:3 2:4   2:5 2:6
3rd row 3:1 3:2   3:3 3:4   3:5 3:6
4th row 4:1 4:2   4:3 4:4   4:5 4:6
5th row 5:1 5:2   5:3 5:4   5:5 5:6
6th row 6:1 6:2   6:3 6:4   6:5 6:6
7th row 7:1 7:2   7:3 7:4   7:5 7:6
8th row 8:1 8:2   8:3 8:4   8:5 8:6
Above example allows the column spanner to be a sum of the underlying cgroups (see n.cgroup), this is not required by the function: ```r htmlTable(mx, cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2")), n.cgroup = rbind(c(1,5,NA), c(2,1,3))) ```
  Column spanners
  Cgroup 1  Cgroup 2
1st hdr   2nd hdr   3rd hdr   4th hdr 5th hdr 6th hdr
1st row 1:1   1:2   1:3   1:4 1:5 1:6
2nd row 2:1   2:2   2:3   2:4 2:5 2:6
3rd row 3:1   3:2   3:3   3:4 3:5 3:6
4th row 4:1   4:2   4:3   4:4 4:5 4:6
5th row 5:1   5:2   5:3   5:4 5:5 5:6
6th row 6:1   6:2   6:3   6:4 6:5 6:6
7th row 7:1   7:2   7:3   7:4 7:5 7:6
8th row 8:1   8:2   8:3   8:4 8:5 8:6
Table spanners -------------- A table spanner is similar to rgroup but has the primary purpose of combining 2 or more tables with the same columns into one: ```r htmlTable(mx, tspanner = paste("Spanner", LETTERS[1:3]), n.tspanner = c(2,4,nrow(mx) - 6)) ```
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Spanner A
1st row 1:1 1:2 1:3 1:4 1:5 1:6
2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Spanner B
3rd row 3:1 3:2 3:3 3:4 3:5 3:6
4th row 4:1 4:2 4:3 4:4 4:5 4:6
5th row 5:1 5:2 5:3 5:4 5:5 5:6
6th row 6:1 6:2 6:3 6:4 6:5 6:6
Spanner C
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6
Table caption ------------- The table caption is simply the table description and can be either located above or below the table: ```r htmlTable(mx[1:2,1:2], caption="A table caption above") ```
Table 5: A table caption above
1st hdr 2nd hdr
1st row 1:1 1:2
2nd row 2:1 2:2
```r htmlTable(mx[1:2,1:2], pos.caption = "bottom", caption="A table caption below") ```
1st hdr 2nd hdr
1st row 1:1 1:2
2nd row 2:1 2:2
Table 6: A table caption below
A more interesting detail that the function allows for is table numbering, initialized by: ```r options(table_counter = TRUE) ``` ```r htmlTable(mx[1:2,1:2], caption="A table caption with a numbering") ```
Table 1: A table caption with a numbering
1st hdr 2nd hdr
1st row 1:1 1:2
2nd row 2:1 2:2
As we often want to reference the table number in the text there are two associated functions: ```r tblNoLast() ``` ``` ## [1] 1 ``` ```r tblNoNext() ``` ``` ## [1] 2 ``` Table footer ------------ The footer usually contains specifics regarding variables and is always located at the foot of the table: ```r htmlTable(mx[1:2,1:2], tfoot="A table footer") ```
1st hdr 2nd hdr
1st row 1:1 1:2
2nd row 2:1 2:2
A table footer
Putting it all together ----------------------- Now if we want to do everything in one table it may look like this: ```r htmlTable(mx, align="r", rgroup = paste("Group", LETTERS[1:3]), n.rgroup = c(2,4,nrow(mx) - 6), cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = rbind(c(1,2,NA), c(2,2,2)), caption="A table with column spanners, row groups, and zebra striping", tfoot="† A table footer commment", cspan.rgroup = 2, col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;") ```
Table 2: A table with column spanners, row groups, and zebra striping
  Column spanners
  Cgroup 1  Cgroup 2†
1st hdr 2nd hdr   3rd hdr 4th hdr   5th hdr 6th hdr
Group A    
  1st row 1:1 1:2   1:3 1:4   1:5 1:6
  2nd row 2:1 2:2   2:3 2:4   2:5 2:6
Group B    
  3rd row 3:1 3:2   3:3 3:4   3:5 3:6
  4th row 4:1 4:2   4:3 4:4   4:5 4:6
  5th row 5:1 5:2   5:3 5:4   5:5 5:6
  6th row 6:1 6:2   6:3 6:4   6:5 6:6
Group C    
  7th row 7:1 7:2   7:3 7:4   7:5 7:6
  8th row 8:1 8:2   8:3 8:4   8:5 8:6
† A table footer comment
htmlTable/data/0000755000176200001440000000000013407215301013073 5ustar liggesusershtmlTable/data/SCB.rda0000644000176200001440000000124513407215301014174 0ustar liggesusersVMn@8?"VlPV,8Jv{X!NZl;, p\}Ì=kTU)#|/3f/A~PgY\UVnR%Va[ =Uw[Ux[\Oɬ5YeMVZHfU-g'(6¡*5X=^1S04k NhVrlrGyX,]ЬGa bs ^-whtmlTable/man/0000755000176200001440000000000013414117305012740 5ustar liggesusershtmlTable/man/txtRound.Rd0000644000176200001440000000376313572022513015070 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/txtFrmt.R \name{txtRound} \alias{txtRound} \alias{txtRound.default} \alias{txtRound.data.frame} \alias{txtRound.table} \alias{txtRound.matrix} \title{A convenient rounding function} \usage{ txtRound(x, ...) \method{txtRound}{default}( x, digits = 0, digits.nonzero = NA, txt.NA = "", dec = ".", scientific, ... ) \method{txtRound}{data.frame}(x, ...) \method{txtRound}{table}(x, ...) \method{txtRound}{matrix}(x, digits = 0, excl.cols, excl.rows, ...) } \arguments{ \item{x}{The value/vector/data.frame/matrix to be rounded} \item{...}{Passed to next method} \item{digits}{The number of digits to round each element to. If you provide a vector each element will apply to the corresponding columns.} \item{digits.nonzero}{The number of digits to keep if the result is close to zero. Sometimes we have an entire table with large numbers only to have a few but interesting observation that are really interesting} \item{txt.NA}{The string to exchange NA with} \item{dec}{The decimal marker. If the text is in non-english decimal and string formatted you need to change this to the apropriate decimal indicator.} \item{scientific}{If the value should be in scientific format.} \item{excl.cols}{Columns to exclude from the rounding procedure. This can be either a number or regular expression. Skipped if x is a vector.} \item{excl.rows}{Rows to exclude from the rounding procedure. This can be either a number or regular expression.} } \value{ \code{matrix/data.frame} } \description{ If you provide a string value in X the function will try to round this if a numeric text is present. If you want to skip certain rows/columns then use the excl.* arguments. } \examples{ mx <- matrix(c(1, 1.11, 1.25, 2.50, 2.55, 2.45, 3.2313, 3, pi), ncol = 3, byrow=TRUE) txtRound(mx, 1) } \seealso{ Other text formatters: \code{\link{txtMergeLines}()}, \code{\link{txtPval}()} } \concept{text formatters} htmlTable/man/prAttr4RgroupAdd.Rd0000644000176200001440000000125713407215301016401 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prAttr4RgroupAdd} \alias{prAttr4RgroupAdd} \title{Get the add attribute element} \usage{ prAttr4RgroupAdd(rgroup, rgroup_iterator, no_cols) } \arguments{ \item{rgroup}{A vector of character strings containing headings for row groups. \code{n.rgroup} must be present when \code{rgroup} is given. See detailed description in section below.} \item{rgroup_iterator}{The rgroup number of interest} \item{no_cols}{The \code{ncol(x)} of the core htmlTable x argument} } \description{ Gets the add element attribute if it exists. If non-existant it will return NULL. } \keyword{internal} htmlTable/man/txtPval.Rd0000644000176200001440000000316013572022513014672 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/txtFrmt.R \name{txtPval} \alias{txtPval} \title{Formats the p-values} \usage{ txtPval(pvalues, lim.2dec = 10^-2, lim.sig = 10^-4, html = TRUE, ...) } \arguments{ \item{pvalues}{The p-values} \item{lim.2dec}{The limit for showing two decimals. E.g. the p-value may be 0.056 and we may want to keep the two decimals in order to emphasize the proximity to the all-mighty 0.05 p-value and set this to \eqn{10^-2}. This allows that a value of 0.0056 is rounded to 0.006 and this makes intuitive sense as the 0.0056 level as this is well below the 0.05 value and thus not as interesting to know the exact proximity to 0.05. \emph{Disclaimer:} The 0.05-limit is really silly and debated, unfortunately it remains a standard and this package tries to adapt to the current standards in order to limit publication associated issues.} \item{lim.sig}{The significance limit for the less than sign, i.e. the '<'} \item{html}{If the less than sign should be < or < as needed for html output.} \item{...}{Currently only used for generating warnings of deprecated call parameters.} } \value{ vector } \description{ Gets formatted p-values. For instance you often want 0.1234 to be 0.12 while also having two values up until a limit, i.e. 0.01234 should be 0.012 while 0.001234 should be 0.001. Furthermore you want to have < 0.001 as it becomes ridiculous to report anything below that value. } \examples{ txtPval(c(0.10234,0.010234, 0.0010234, 0.000010234)) } \seealso{ Other text formatters: \code{\link{txtMergeLines}()}, \code{\link{txtRound}()} } \concept{text formatters} htmlTable/man/htmlTable.Rd0000644000176200001440000005236313572022513015155 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable.R \name{htmlTable} \alias{htmlTable} \alias{htmlTable.default} \alias{knit_print.htmlTable} \alias{print.htmlTable} \title{Outputting HTML tables} \usage{ htmlTable(x, ...) \method{htmlTable}{default}( x, header, rnames, rowlabel, caption, tfoot, label, rgroup, n.rgroup, cgroup, n.cgroup, tspanner, n.tspanner, total, align = paste(rep("c", ncol(x)), collapse = ""), align.header = paste(rep("c", ncol(x)), collapse = ""), align.cgroup, css.rgroup = "font-weight: 900;", css.rgroup.sep = "", css.tspanner = "font-weight: 900; text-align: left;", css.tspanner.sep = "border-top: 1px solid #BEBEBE;", css.total = "border-top: 1px solid #BEBEBE; font-weight: 900;", css.cell = "", css.cgroup = "", css.class = "gmisc_table", css.table = "margin-top: 1em; margin-bottom: 1em;", pos.rowlabel = "bottom", pos.caption = "top", col.rgroup = "none", col.columns = "none", padding.rgroup = "  ", padding.tspanner = "", ctable = TRUE, compatibility = getOption("htmlTableCompat", "LibreOffice"), cspan.rgroup = "all", escape.html = FALSE, ... ) \method{knit_print}{htmlTable}(x, ...) \method{print}{htmlTable}(x, useViewer, ...) } \arguments{ \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} \item{...}{Passed on to \code{print.htmlTable} function and any argument except the \code{useViewer} will be passed on to the \code{\link[base]{cat}} functions arguments.} \item{header}{A vector of character strings specifying column header, defaulting to \code{\link[base]{colnames}(x)}} \item{rnames}{Default rownames are generated from \code{\link[base]{rownames}(x)}. If you provide \code{FALSE} then it will skip the rownames. \emph{Note:} For \code{data.frames} if you do \code{\link[base]{rownames}(my_dataframe) <- NULL} it still has rownames. Thus you need to use \code{FALSE} if you want to surpress rownames for \code{data.frames}.} \item{rowlabel}{If the table has rownames or \code{rnames}, rowlabel is a character string containing the column heading for the \code{rnames}.} \item{caption}{Adds a table caption.} \item{tfoot}{Adds a table footer (uses the \code{} html element). The output is run through \code{\link{txtMergeLines}} simplifying the generation of multiple lines.} \item{label}{A text string representing a symbolic label for the table for referencing as an anchor. All you need to do is to reference the table, for instance \code{see table 2}. This is known as the element's id attribute, i.e. table id, in HTML linguo, and should be unique id for an HTML element in contrast to the \code{css.class} element attribute.} \item{rgroup}{A vector of character strings containing headings for row groups. \code{n.rgroup} must be present when \code{rgroup} is given. See detailed description in section below.} \item{n.rgroup}{An integer vector giving the number of rows in each grouping. If \code{rgroup} is not specified, \code{n.rgroup} is just used to divide off blocks of rows by horizontal lines. If \code{rgroup} is given but \code{n.rgroup} is omitted, \code{n.rgroup} will default so that each row group contains the same number of rows. If you want additional rgroup column elements to the cells you can sett the "add" attribute to \code{rgroup} through \code{attr(rgroup, "add")}, see below explaining section.} \item{cgroup}{A vector, matrix or list of character strings defining major column header. The default is to have none. These elements are also known as \emph{column spanners}. If you want a column \emph{not} to have a spanner then put that column as "". If you pass cgroup and \code{n.crgroup} as matrices you can have column spanners for several rows. See cgroup section below for details.} \item{n.cgroup}{An integer vector, matrix or list containing the number of columns for which each element in cgroup is a heading. For example, specify \code{cgroup=c("Major_1","Major_2")}, \code{n.cgroup=c(3,3)} if \code{"Major_1"} is to span columns 1-3 and \code{"Major_2"} is to span columns 4-6. \code{rowlabel} does not count in the column numbers. You can omit \code{n.cgroup} if all groups have the same number of columns. If the n.cgroup is one less than the number of columns in the matrix/data.frame then it automatically adds those.} \item{tspanner}{The table spanner is somewhat of a table header that you can use when you want to join different tables with the same columns.} \item{n.tspanner}{An integer vector with the number of rows or rgroups in the original matrix that the table spanner should span. If you have provided one fewer n.tspanner elements the last will be imputed from the number of rgroups (if you have provided `rgroup` and `sum(n.tspanner) < length(rgroup)`) or the number of rows in the table.} \item{total}{The last row is sometimes a row total with a border on top and bold fonts. Set this to \code{TRUE} if you are interested in such a row. If you want a total row at the end of each table spanner you can set this to \code{"tspanner"}.} \item{align}{A character strings specifying column alignments, defaulting to \code{\link[base]{paste}(rep('c',ncol(x)),collapse='')} to center. Valid alignments are l = left, c = center and r = right. You can also specify \code{align='c|c'} and other LaTeX tabular formatting. If you want to set the alignment of the rownames this string needst to be \code{ncol(x) + 1}, otherwise it automatically pads the string with a left alignment for the rownames.} \item{align.header}{A character strings specifying alignment for column header, defaulting to centered, i.e. \code{\link[base]{paste}(rep('c',ncol(x)),collapse='')}.} \item{align.cgroup}{The justification of the \code{cgroups}} \item{css.rgroup}{CSS style for the rgorup, if different styles are wanted for each of the rgroups you can just specify a vector with the number of elements} \item{css.rgroup.sep}{The line between different rgroups. The line is set to the TR element of the lower rgroup, i.e. you have to set the border-top/padding-top etc to a line with the expected function. This is only used for rgroups that are printed. You can specify different separators if you give a vector of rgroup - 1 length (this is since the first rgroup doesn't have a separator).} \item{css.tspanner}{The CSS style for the table spanner} \item{css.tspanner.sep}{The line between different spanners} \item{css.total}{The css of the total row} \item{css.cell}{The css.cell element allows you to add any possible CSS style to your table cells. See section below for details.} \item{css.cgroup}{The same as \code{css.class} but for cgroup formatting.} \item{css.class}{The html CSS class for the table. This allows directing html formatting through \href{http://www.w3schools.com/Css/}{CSS} directly at all instances of that class. \emph{Note:} unfortunately the CSS is frequently ignored by word processors. This option is mostly inteded for web-presentations.} \item{css.table}{You can specify the the style of the table-element using this parameter} \item{pos.rowlabel}{Where the rowlabel should be positioned. This value can be \code{"top"}, \code{"bottom"}, \code{"header"}, or a integer between \code{1} and \code{nrow(cgroup) + 1}. The options \code{"bottom"} and \code{"header"} are the same, where the row label is presented at the same level as the header.} \item{pos.caption}{Set to \code{"bottom"} to position a caption below the table instead of the default of \code{"top"}.} \item{col.rgroup}{Alternating colors (zebra striping/banded rows) for each \code{rgroup}; one or two colors is recommended and will be recycled.} \item{col.columns}{Alternating colors for each column.} \item{padding.rgroup}{Generally two non-breakings spaces, i.e. \code{  }, but some journals only have a bold face for the rgroup and leaves the subelements unindented.} \item{padding.tspanner}{The table spanner is usually without padding but you may specify padding similar to \code{padding.rgroup} and it will be added to all elements, including the rgroup elements. This allows for a 3-level hierarchy if needed.} \item{ctable}{If the table should have a double top border or a single a' la LaTeX ctable style} \item{compatibility}{Is default set to \code{LibreOffice} as some settings need to be in old html format as Libre Office can't handle some commands such as the css caption-alignment. Note: this option is not yet fully implemented for all details, in the future I aim to generate a html-correct table and one that is aimed at Libre Office compatibility. Word-compatibility is difficult as Word ignores most settings and destroys all layout attempts (at least that is how my 2010 version behaves). You can additinally use the \code{options(htmlTableCompat = "html")} if you want a change to apply to the entire document. MS Excel sometimes misinterprets certain cell data when opening HTML-tables (eg. 1/2 becomes 1. February). To avoid this please specify the correct Microsoft Office format for each cell in the table using the css.cell-argument. To make MS Excel interpret everything as text use "mso-number-format:\"\\@\"".} \item{cspan.rgroup}{The number of columns that an \code{rgroup} should span. It spans by default all columns but you may want to limit this if you have column colors that you want to retain.} \item{escape.html}{logical: should HTML characters be escaped? Defaults to FALSE.} \item{useViewer}{If you are using RStudio there is a viewer thar can render the table within that is envoced if in \code{\link[base]{interactive}} mode. Set this to \code{FALSE} if you want to remove that functionality. You can also force the function to call a specific viewer by setting this to a viewer function, e.g. \code{useViewer = utils::browseURL} if you want to override the default RStudio viewer. Another option that does the same is to set the \code{options(viewer=utils::browseURL)} and it will default to that particular viewer (this is how RStudio decides on a viewer). \emph{Note:} If you want to force all output to go through the \code{\link[base]{cat}()} the set \code{\link[base]{options}(htmlTable.cat = TRUE)}.} } \value{ \code{string} Returns a string of class htmlTable } \description{ This is a function for outputting a more advanced table than what \pkg{xtable}, \pkg{ztable}, or \pkg{knitr}'s \code{\link[knitr]{kable}()} allows. It's aim is to provide the \pkg{Hmisc} \code{\link[Hmisc]{latex}()} colgroup and rowgroup functions in HTML. The html-output is designed for maximum compatibility with LibreOffice/OpenOffice. } \section{Multiple rows of column spanners \code{cgroup}}{ If you want to have a column spanner in multiple levels you can set the \code{cgroup} and \code{n.cgroup} arguments to a \code{matrix} or \code{list}. If the different levels have different number of elements and you have provided a **matrix** you need to set the ones that lack elements to NA. For instance \code{cgroup = rbind(c("first", "second", NA), c("a", "b", "c"))}. And the corresponding n,cgroup would be \code{n.cgroup = rbind(c(1, 2, NA), c(2, 1, 2))}. for a table consisting of 5 columns. The "first" spans the first two columns, the "second" spans the last three columns, "a" spans the first two, "b" the middle column, and "c" the last two columns. It is recommended to use `list` as you will not have to bother with the `NA`. If you want leav a cgroup empty then simply provide `""` as the cgroup. } \section{The \code{rgroup} argument}{ The rgroup allows you to smoothly group rows. Each row within a group receives an indention of two blank spaces and are grouped with their corresponing rgroup element. The \code{sum(n.rgroup)} should always be equal or less than the matrix rows. If less then it will pad the remaining rows with either an empty rgroup, i.e. an "" or if the rgroup is one longer than the n.rgroup the last n.rgroup element will be calculated through \code{nrow(x) - sum(n.rgroup)} in order to make the table generating smoother. } \section{The add attribute to \code{rgroup}}{ You can now have an additional element at the rgroup level by specifying the \code{attr(rgroup, 'add')}. The value can either be a \code{vector}, a \code{list}, or a \code{matrix}. See \code{vignette("general", package = "htmlTable")} for examples. \itemize{ \item{A \code{vector} of either equal number of rgroups to the number of rgroups that aren't empty, i.e. \code{rgroup[rgroup != ""]}. Or a named vector where the name must correspond to either an rgroup or to an rgroup number.} \item{A \code{list} that has exactly the same requirements as the vector. In addition to the previous we can also have a list with column numbers within as names within the list.} \item{A \code{matrix} with the dimensiont \code{nrow(x) x ncol(x)} or \code{nrow(x) x 1} where the latter is equivalent to a named vector. If you have \code{rownames} these will resolve similarly to the names to the \code{list}/\code{vector} arguments. The same thing applies to \code{colnames}. } } } \section{Important \pkg{knitr}-note}{ This funciton will only work with \pkg{knitr} outputting \emph{html}, i.e. markdown mode. As the function returns raw html-code the compatibility with non-html formatting is limited, even with \href{http://johnmacfarlane.net/pandoc/}{pandoc}. Thanks to the the \code{\link[knitr]{knit_print}} and the \code{\link[knitr]{asis_output}} the \code{results='asis'} is \emph{no longer needed} except within for-loops. If you have a knitr-chunk with a for loop and use \code{print()} to produce raw html you must set the chunk option \code{results='asis'}. \code{Note}: the print-function relies on the \code{\link[base]{interactive}()} function for determining if the output should be sent to a browser or to the terminal. In vignettes and other directly knitted documents you may need to either set \code{useViewer = FALSE} alternatively set \code{options(htmlTable.cat = TRUE)}. } \section{RStudio's notebook}{ RStudio has an interactive notebook that allows output directly into the document. In order for the output to be properly formatted it needs to have the \code{class} of \code{html}. The \code{htmlTable} tries to identify if the environment is a notebook document (uses the rstudio api and identifies if its a file with and `Rmd` file ending or if ther is an element with `html_notebook`). If you don't want this behaviour you can remove it using the `options(htmlTable.skip_notebook = TRUE)` } \section{Table counter}{ If you set the option table_counter you will get a Table 1,2,3 etc before each table, just set \code{options(table_counter=TRUE)}. If you set it to a number then that number will correspond to the start of the table_counter. The \code{table_counter} option will also contain the number of the last table, this can be useful when referencing it in text. By setting the option \code{options(table_counter_str = "Table \%s: ")} you can manipulate the counter table text that is added prior to the actual caption. Note, you should use the \code{\link{sprintf}} \code{\%s} instead of \code{\%d} as the software converts all numbers to characters for compatibility reasons. If you set \code{options(table_counter_roman = TRUE)} then the table counter will use Roman numumerals instead of Arabic. } \section{The \code{css.cell} argument}{ The \code{css.cell} parameter allows you to add any possible CSS style to your table cells. \code{css.cell} can be either a vector or a matrix. If \code{css.cell} is a \emph{vector}, it's assumed that the styles should be repeated throughout the rows (that is, each element in css.cell specifies the style for a whole column of 'x'). In the case of \code{css.cell} being a \emph{matrix} of the same size of the \code{x} argument, each element of \code{x} gets the style from the corresponding element in css.cell. Additionally, the number of rows of \code{css.cell} can be \code{nrow(x) + 1} so the first row of of \code{css.cell} specifies the style for the header of \code{x}; also the number of columns of \code{css.cell} can be \code{ncol(x) + 1} to include the specification of style for row names of \code{x}. Note that the \code{text-align} CSS field in the \code{css.cell} argument will be overriden by the \code{align} argument. } \section{Empty dataframes}{ An empty dataframe will result in a warning and output an empty table, provided that rgroup and n.rgroup are not specified. All other row layout options will be ignored. } \section{Browsers and possible issues}{ \emph{Copy-pasting:} As you copy-paste results into Word you need to keep the original formatting. Either right click and choose that paste option or click on the icon appearing after a paste. Currently the following compatibitilies have been tested with MS Word 2013: \itemize{ \item{\bold{Internet Explorer} (v. 11.20.10586.0) Works perfectly when copy-pasting into Word} \item{\bold{RStudio} (v. 0.99.448) Works perfectly when copy-pasting into Word. \emph{Note:} can have issues with multiline cgroups - see \href{http://code.google.com/p/chromium/issues/detail?id=305130}{bug}} \item{\bold{Chrome} (v. 47.0.2526.106) Works perfectly when copy-pasting into Word. \emph{Note:} can have issues with multiline cgroups - see \href{http://code.google.com/p/chromium/issues/detail?id=305130}{bug}} \item{\bold{Firefox} (v. 43.0.3) Works poorly - looses font-styling, lines and general feel} \item{\bold{Edge} (v. 25.10586.0.0) Works poorly - looses lines and general feel} } \emph{Direct word processor opening:} Opening directly in LibreOffice or Word is no longer recommended. You get much prettier results using the cut-and-paste option. Note that when using complex cgroup alignments with multiple levels not every browser is able to handle this. For instance the RStudio webkit browser seems to have issues with this and a \href{http://code.google.com/p/chromium/issues/detail?id=305130}{bug has been filed}. As the table uses html for rendering you need to be aware of that headers, rownames, and cell values should try respect this for optimal display. Browsers try to compensate and frequently the tables still turn out fine but it is not advized. Most importantly you should try to use \code{<} instead of \code{<} and \code{>} instead of \code{>}. You can find a complete list of html characters \href{http://ascii.cl/htmlcodes.htm}{here}. } \examples{ # Store all output into a list in order to # output everything at once at the end all_tables <- list() # A simple output output <- matrix(1:4, ncol=2, dimnames = list(list("Row 1", "Row 2"), list("Column 1", "Column 2"))) htmlTable(output) -> all_tables[["Basic table"]] # An advanced output output <- matrix(ncol=6, nrow=8) for (nr in 1:nrow(output)){ for (nc in 1:ncol(output)){ output[nr, nc] <- paste0(nr, ":", nc) } } htmlTable(output, align="r", header = paste(c("1st", "2nd", "3rd", "4th", "5th", "6th"), "hdr"), rnames = paste(c("1st", "2nd", "3rd", paste0(4:8, "th")), "row"), rgroup = paste("Group", LETTERS[1:3]), n.rgroup = c(2,4,nrow(output) - 6), cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = rbind(c(1,2,NA), c(2,2,2)), caption="Basic table with both column spanners (groups) and row groups", tfoot="† A table footer commment", cspan.rgroup = 2, col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;") -> all_tables[["Advanced table"]] # An advanced empty table output <- matrix(ncol = 6, nrow = 0) htmlTable(output, align="r", header = paste(c("1st", "2nd", "3rd", "4th", "5th", "6th"), "hdr"), cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = rbind(c(1,2,NA), c(2,2,2)), caption="Basic empty table with column spanners (groups) and ignored row colors", tfoot="† A table footer commment", cspan.rgroup = 2, col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;") -> all_tables[["Empty table"]] # An example of how to use the css.cell for header styling simple_output <- matrix(1:4, ncol=2) htmlTable(simple_output, header = LETTERS[1:2], css.cell = rbind(rep("background: lightgrey; font-size: 2em;", times=ncol(simple_output)), matrix("", ncol=ncol(simple_output), nrow=nrow(simple_output)))) -> all_tables[["Header formatting"]] concatHtmlTables(all_tables) # See vignette("tables", package = "htmlTable") # for more examples } \seealso{ \code{\link{txtMergeLines}}, \code{\link[Hmisc]{latex}} Other table functions: \code{\link{tblNoLast}()}, \code{\link{tblNoNext}()} } \concept{table functions} htmlTable/man/prGetRowlabelPos.Rd0000644000176200001440000000310413572022513016461 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prGetRowlabelPos} \alias{prGetRowlabelPos} \title{Gets the rowlabel position} \usage{ prGetRowlabelPos(cgroup, pos.rowlabel, header) } \arguments{ \item{cgroup}{A vector, matrix or list of character strings defining major column header. The default is to have none. These elements are also known as \emph{column spanners}. If you want a column \emph{not} to have a spanner then put that column as "". If you pass cgroup and \code{n.crgroup} as matrices you can have column spanners for several rows. See cgroup section below for details.} \item{pos.rowlabel}{Where the rowlabel should be positioned. This value can be \code{"top"}, \code{"bottom"}, \code{"header"}, or a integer between \code{1} and \code{nrow(cgroup) + 1}. The options \code{"bottom"} and \code{"header"} are the same, where the row label is presented at the same level as the header.} \item{header}{A vector of character strings specifying column header, defaulting to \code{\link[base]{colnames}(x)}} } \value{ \code{integer} Returns the position within the header rows to print the \code{rowlabel} argument } \description{ Gets the rowlabel position } \seealso{ Other hidden helper functions for htmlTable: \code{\link{prAddCells}()}, \code{\link{prAddSemicolon2StrEnd}()}, \code{\link{prEscapeHtml}()}, \code{\link{prGetCgroupHeader}()}, \code{\link{prGetStyle}()}, \code{\link{prPrepareAlign}()}, \code{\link{prPrepareCgroup}()}, \code{\link{prTblNo}()} } \concept{hidden helper functions for htmlTable} \keyword{internal} htmlTable/man/pvalueFormatter.Rd0000644000176200001440000000072113407215301016404 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/deprecated.R \name{pvalueFormatter} \alias{pvalueFormatter} \title{Deprecated use \code{\link{txtPval}} instead} \usage{ pvalueFormatter(...) } \arguments{ \item{...}{Currently only used for generating warnings of deprecated call} } \description{ Deprecated use \code{\link{txtPval}} instead } \examples{ pvalueFormatter(c(0.10234,0.010234, 0.0010234, 0.000010234)) } \keyword{internal} htmlTable/man/SCB.Rd0000644000176200001440000000273013407215301013635 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-SCB.R \docType{data} \name{SCB} \alias{SCB} \title{Average age in Sweden} \description{ For the vignettes there is a dataset downloaded by using the \code{get_pxweb_data()} call. The data is from SCB (\href{http://scb.se/}{Statistics Sweden}) and downloaded using the \href{https://github.com/rOpenGov/pxweb}{pxweb package}: } \examples{ \dontrun{ # The data was generated through downloading via the API library(pxweb) # Get the last 15 years of data (the data always lags 1 year) current_year <- as.integer(format(Sys.Date(), "\%Y")) -1 SCB <- get_pxweb_data( url = "http://api.scb.se/OV0104/v1/doris/en/ssd/BE/BE0101/BE0101B/BefolkningMedelAlder", dims = list(Region = c('00', '01', '03', '25'), Kon = c('1', '2'), ContentsCode = c('BE0101G9'), Tid = (current_year-14):current_year), clean = TRUE) # Some cleaning was needed before use SCB$region <- factor(substring(as.character(SCB$region), 4)) Swe_ltrs <- c("å" = "å", "Å" = "Å", "ä" = "ä", "Ä" = "Ä", "ö" = "ö", "Ö" = "Ö") for (i in 1:length(Swe_ltrs)){ levels(SCB$region) <- gsub(names(Swe_ltrs)[i], Swe_ltrs[i], levels(SCB$region)) } save(SCB, file = "data/SCB.rda") } } \references{ \url{http://scb.se} } \author{ Max Gordon \email{max@gforge.se} } \keyword{data} htmlTable/man/prConvertDfFactors.Rd0000644000176200001440000000105313407215301017001 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable.R \name{prConvertDfFactors} \alias{prConvertDfFactors} \title{Convert all factors to characters to print them as they expected} \usage{ prConvertDfFactors(x) } \arguments{ \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} } \value{ The data frame with factors as characters } \description{ Convert all factors to characters to print them as they expected } htmlTable/man/vector2string.Rd0000644000176200001440000000131613572022513016044 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/vector2string.R \name{vector2string} \alias{vector2string} \title{Collapse vector to string} \usage{ vector2string( x, quotation_mark = "'", collapse = sprintf("\%s, \%s", quotation_mark, quotation_mark) ) } \arguments{ \item{x}{The vector to collapse} \item{quotation_mark}{The type of quote to use} \item{collapse}{The string that separates each element} } \value{ A string with \code{', '} separation } \description{ Merges all the values and outputs a string formatted as '1st element', '2nd element', ... } \examples{ vector2string(1:4) vector2string(c("a","b'b", "c")) vector2string(c("a","b'b", "c"), quotation_mark = '"') } htmlTable/man/prGetStyle.Rd0000644000176200001440000000213113572022513015327 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prGetStyle} \alias{prGetStyle} \title{Gets the CSS style element} \usage{ prGetStyle(...) } \arguments{ \item{...}{All styles here are merged with the first parameter. If you provide a name, e.g. \code{styles="background: blue", align="center"} the function will convert the \code{align} into proper \code{align: center}.} \item{styles}{The styles can be provided as \code{vector}, \code{named vector}, or \code{string}.} } \value{ \code{string} Returns the codes merged into one string with correct CSS ; and : structure. } \description{ A funciton for checking, merging, and more with a variety of different style formats. } \seealso{ Other hidden helper functions for htmlTable: \code{\link{prAddCells}()}, \code{\link{prAddSemicolon2StrEnd}()}, \code{\link{prEscapeHtml}()}, \code{\link{prGetCgroupHeader}()}, \code{\link{prGetRowlabelPos}()}, \code{\link{prPrepareAlign}()}, \code{\link{prPrepareCgroup}()}, \code{\link{prTblNo}()} } \concept{hidden helper functions for htmlTable} \keyword{internal} htmlTable/man/outputInt.Rd0000644000176200001440000000056513407215301015245 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/deprecated.R \name{outputInt} \alias{outputInt} \title{Deprecated use \code{\link{txtInt}} instead.} \usage{ outputInt(...) } \arguments{ \item{...}{Passed to \code{\link{txtInt}}} } \description{ Deprecated use \code{\link{txtInt}} instead. } \examples{ outputInt(123456) } \keyword{internal} htmlTable/man/prGetRgroupLine.Rd0000644000176200001440000000425713572022513016330 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_render.R \name{prGetRgroupLine} \alias{prGetRgroupLine} \title{Gets the number of rgroup htmlLine} \usage{ prGetRgroupLine( x, total_columns, rgroup, rgroup_iterator, cspan, rnames, align, style, cgroup_spacer_cells, col.columns, css.row, padding.tspanner ) } \arguments{ \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} \item{total_columns}{The total number of columns including the rowlabel and the spacer cells} \item{rgroup}{A vector of character strings containing headings for row groups. \code{n.rgroup} must be present when \code{rgroup} is given. See detailed description in section below.} \item{rgroup_iterator}{An integer indicating the rgroup} \item{cspan}{The column span of the current rgroup} \item{rnames}{Default rownames are generated from \code{\link[base]{rownames}(x)}. If you provide \code{FALSE} then it will skip the rownames. \emph{Note:} For \code{data.frames} if you do \code{\link[base]{rownames}(my_dataframe) <- NULL} it still has rownames. Thus you need to use \code{FALSE} if you want to surpress rownames for \code{data.frames}.} \item{align}{A character strings specifying column alignments, defaulting to \code{\link[base]{paste}(rep('c',ncol(x)),collapse='')} to center. Valid alignments are l = left, c = center and r = right. You can also specify \code{align='c|c'} and other LaTeX tabular formatting. If you want to set the alignment of the rownames this string needst to be \code{ncol(x) + 1}, otherwise it automatically pads the string with a left alignment for the rownames.} \item{style}{The css style corresponding to the rgroup css style that includes the color specific for the rgroup, i.e. \code{col.rgroup}.} \item{cgroup_spacer_cells}{The vector indicating the position of the cgroup spacer cells} \item{col.columns}{Alternating colors for each column.} \item{css.row}{The css.cell information for this particular row.} \item{padding.tspanner}{The tspanner padding} } \description{ Gets the number of rgroup htmlLine } \keyword{internal} htmlTable/man/splitLines4Table.Rd0000644000176200001440000000061113407215301016404 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/deprecated.R \name{splitLines4Table} \alias{splitLines4Table} \title{See \code{\link{txtMergeLines}}} \usage{ splitLines4Table(...) } \arguments{ \item{...}{passed onto \code{\link{txtMergeLines}}} } \description{ See \code{\link{txtMergeLines}} } \examples{ splitLines4Table("hello", "world") } \keyword{internal} htmlTable/man/concatHtmlTables.Rd0000644000176200001440000000663613407215301016466 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/concatHtmlTables.R \name{concatHtmlTables} \alias{concatHtmlTables} \title{Funciton for concatenating htmlTables} \usage{ concatHtmlTables(tables, headers) } \arguments{ \item{tables}{A list of html tables to be concatenated} \item{headers}{Either a string or a vector of strings that function as a header for each table. If none is provided it will use the names of the table list or a numeric number.} } \value{ htmlTable class object } \description{ Funciton for concatenating htmlTables } \examples{ # Store all output into a list in order to # output everything at once at the end all_tables <- list() # A simple output output <- matrix(1:4, ncol=2, dimnames = list(list("Row 1", "Row 2"), list("Column 1", "Column 2"))) htmlTable(output) -> all_tables[["Basic table"]] # An advanced output output <- matrix(ncol=6, nrow=8) for (nr in 1:nrow(output)){ for (nc in 1:ncol(output)){ output[nr, nc] <- paste0(nr, ":", nc) } } htmlTable(output, align="r", header = paste(c("1st", "2nd", "3rd", "4th", "5th", "6th"), "hdr"), rnames = paste(c("1st", "2nd", "3rd", paste0(4:8, "th")), "row"), rgroup = paste("Group", LETTERS[1:3]), n.rgroup = c(2,4,nrow(output) - 6), cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = rbind(c(1,2,NA), c(2,2,2)), caption="Basic table with both column spanners (groups) and row groups", tfoot="† A table footer commment", cspan.rgroup = 2, col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;") -> all_tables[["Advanced table"]] # An advanced empty table output <- matrix(ncol = 6, nrow = 0) htmlTable(output, align="r", header = paste(c("1st", "2nd", "3rd", "4th", "5th", "6th"), "hdr"), cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = rbind(c(1,2,NA), c(2,2,2)), caption="Basic empty table with column spanners (groups) and ignored row colors", tfoot="† A table footer commment", cspan.rgroup = 2, col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;") -> all_tables[["Empty table"]] # An example of how to use the css.cell for header styling simple_output <- matrix(1:4, ncol=2) htmlTable(simple_output, header = LETTERS[1:2], css.cell = rbind(rep("background: lightgrey; font-size: 2em;", times=ncol(simple_output)), matrix("", ncol=ncol(simple_output), nrow=nrow(simple_output)))) -> all_tables[["Header formatting"]] concatHtmlTables(all_tables) # See vignette("tables", package = "htmlTable") # for more examples } htmlTable/man/tidyHtmlTable.Rd0000644000176200001440000001077513572022513016010 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tidyHtmlTable.R \name{tidyHtmlTable} \alias{tidyHtmlTable} \title{Generate an htmlTable using a ggplot2-like interface} \usage{ tidyHtmlTable( x, value = "value", header = "header", rnames = "rnames", rgroup = NULL, hidden_rgroup = NULL, cgroup1 = NULL, cgroup2 = NULL, tspanner = NULL, hidden_tspanner = NULL, ... ) } \arguments{ \item{x}{Tidy data used to build the \code{htmlTable}} \item{value}{The column containing values filling individual cells of the output \code{htmlTable}} \item{header}{The column in \code{x} specifying column headings} \item{rnames}{The column in \code{x} specifying row names} \item{rgroup}{The column in \code{x} specifying row groups} \item{hidden_rgroup}{rgroup values that will be hidden.} \item{cgroup1}{The column in \code{x} specifying the inner most column groups} \item{cgroup2}{The column in \code{x} specifying the outer most column groups} \item{tspanner}{The column in \code{x} specifying tspanner groups} \item{hidden_tspanner}{tspanner values that will be hidden.} \item{...}{Additional arguments that will be passed to the inner \code{htmlTable} function} } \value{ Returns html code that will build a pretty table } \description{ Builds an \code{htmlTable} by mapping columns from the input data, \code{x}, to elements of an output \code{htmlTable} (e.g. rnames, header, etc.) } \section{Column-mapping parameters}{ The \code{tidyHtmlTable} function is designed to work like ggplot2 in that columns from \code{x} are mapped to specific parameters from the \code{htmlTable} function. At minimum, \code{x} must contain the names of columns mapping to \code{rnames}, \code{header}, and \code{rnames}. \code{header} and \code{rnames} retain the same meaning as in the htmlTable function. \code{value} contains the individual values that will be used to fill each cell within the output \code{htmlTable}. A full list of parameters from \code{htmlTable} which may be mapped to columns within \code{x} include: \itemize{ \item \code{value} \item \code{header} \item \code{rnames} \item \code{rgroup} \item \code{cgroup1} \item \code{cgroup2} \item \code{tspanner} } Note that unlike in \code{htmlTable} which contains \code{cgroup}, and which may specify a variable number of column groups, \code{tidyhtmlTable} contains the parameters \code{cgroup1} and \code{cgroup2}. These parameters correspond to the inward most and outward most column groups respectively. Also note that the coordinates of each \code{value} within \code{x} must be unambiguously mapped to a position within the output \code{htmlTable}. Therefore, the each row-wise combination the variables specified above contained in \code{x} must be unique. } \section{Hidden values}{ \code{htmlTable} Allows for some values within \code{rgroup}, \code{cgroup}, etc. to be specified as \code{""}. The following parameters allow for specific values to be treated as if they were a string of length zero in the \code{htmlTable} function. \itemize{ \item \code{hidden_rgroup} \item \code{hidden_tspanner} } } \section{Additional dependencies}{ In order to run this function you also must have \code{\link[dplyr]{dplyr}} and \code{\link[tidyr]{tidyr}} packages installed. These have been removed due to the additional 20 Mb that these dependencies added (issue #47). The particular functions required are: \itemize{ \item \code{\link[dplyr]{dplyr}}: \code{mutate_at}, \code{select}, \code{pull}, \code{slice}, \code{filter}, \code{arrange_at}, \code{mutate_if}, \code{is.grouped_df}, \code{left_join} \item \code{\link[tidyr]{tidyr}}: \code{spread} } } \examples{ \dontrun{ library(tidyverse) mtcars \%>\% rownames_to_column \%>\% select(rowname, cyl, gear, hp, mpg, qsec) \%>\% gather(per_metric, value, hp, mpg, qsec) \%>\% group_by(cyl, gear, per_metric) \%>\% summarise(Mean = round(mean(value), 1), SD = round(sd(value), 1), Min = round(min(value), 1), Max = round(max(value), 1)) \%>\% gather(summary_stat, value, Mean, SD, Min, Max) \%>\% ungroup \%>\% mutate(gear = paste(gear, "Gears"), cyl = paste(cyl, "Cylinders")) \%>\% tidyHtmlTable(header = "gear", cgroup1 = "cyl", cell_value = "value", rnames = "summary_stat", rgroup = "per_metric") } } \seealso{ \code{\link{htmlTable}} } htmlTable/man/prGetScriptString.Rd0000644000176200001440000000067113407215301016665 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/interactiveTable.R \name{prGetScriptString} \alias{prGetScriptString} \title{Gets a string with all the scripts merged into one script tag} \usage{ prGetScriptString(x) } \arguments{ \item{x}{An interactiveTable} } \value{ string } \description{ Each element has it's own script tags in otherwise an error will cause all the scripts to fail. } \keyword{internal} htmlTable/man/interactiveTable.Rd0000644000176200001440000000605313572022513016521 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/interactiveTable.R \name{interactiveTable} \alias{interactiveTable} \alias{interactiveTable.htmlTable} \alias{knit_print.interactiveTable} \alias{print.interactiveTable} \title{An interactive table that allows you to limit the size of boxes} \usage{ interactiveTable( x, ..., txt.maxlen = 20, button = FALSE, minimized.columns, js.scripts = c() ) \method{interactiveTable}{htmlTable}( tbl, txt.maxlen = 20, button = FALSE, minimized.columns, js.scripts = c() ) \method{knit_print}{interactiveTable}(x, ...) \method{print}{interactiveTable}(x, useViewer, ...) } \arguments{ \item{x}{The interactive table that is to be printed} \item{...}{The exact same parameters as \code{\link{htmlTable}} uses} \item{txt.maxlen}{The maximum length of a text} \item{button}{Indicator if the cell should be clickable or if a button should appear with a plus/minus} \item{minimized.columns}{Notifies if any particular columns should be collapsed from start} \item{js.scripts}{If you want to add your own JavaScript code you can just add it here. All code is merged into one string where each section is wrapped in it's own \code{} element.} \item{tbl}{An htmlTable object can be directly passed into the function} \item{useViewer}{If you are using RStudio there is a viewer thar can render the table within that is envoced if in \code{\link[base]{interactive}} mode. Set this to \code{FALSE} if you want to remove that functionality. You can also force the function to call a specific viewer by setting this to a viewer function, e.g. \code{useViewer = utils::browseURL} if you want to override the default RStudio viewer. Another option that does the same is to set the \code{options(viewer=utils::browseURL)} and it will default to that particular viewer (this is how RStudio decides on a viewer). \emph{Note:} If you want to force all output to go through the \code{\link[base]{cat}()} the set \code{\link[base]{options}(htmlTable.cat = TRUE)}.} } \value{ An htmlTable with a javascript attribute containing the code that is then printed } \description{ This function wraps the htmlTable and adds JavaScript code for toggling the amount of text shown in any particular cell. } \examples{ # A simple output long_txt <- "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" short_txt <- gsub("(^[^.]+).*", "\\\\1", long_txt) output <- cbind(rep(short_txt, 2), rep(long_txt, 2)) interactiveTable(output, minimized.columns = ncol(output), header = c("Short", "Long"), rnames = c("First", "Second"), col.rgroup = c("#FFF", "#EEF")) } htmlTable/man/prSkipRownames.Rd0000644000176200001440000000127413407215301016214 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prSkipRownames} \alias{prSkipRownames} \title{Returns if rownames should be printed for the htmlTable} \usage{ prSkipRownames(rnames) } \arguments{ \item{rnames}{Default rownames are generated from \code{\link[base]{rownames}(x)}. If you provide \code{FALSE} then it will skip the rownames. \emph{Note:} For \code{data.frames} if you do \code{\link[base]{rownames}(my_dataframe) <- NULL} it still has rownames. Thus you need to use \code{FALSE} if you want to surpress rownames for \code{data.frames}.} } \description{ Returns if rownames should be printed for the htmlTable } \keyword{internal} htmlTable/man/prAddCells.Rd0000644000176200001440000000370213572022513015247 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prAddCells} \alias{prAddCells} \title{Add a cell} \usage{ prAddCells( rowcells, cellcode, align, style, cgroup_spacer_cells, has_rn_col, col.columns, offset = 1, css.cell ) } \arguments{ \item{rowcells}{The cells with the values that are to be added} \item{cellcode}{Type of cell, can either be \code{th} or \code{td}} \item{align}{A character strings specifying column alignments, defaulting to \code{\link[base]{paste}(rep('c',ncol(x)),collapse='')} to center. Valid alignments are l = left, c = center and r = right. You can also specify \code{align='c|c'} and other LaTeX tabular formatting. If you want to set the alignment of the rownames this string needst to be \code{ncol(x) + 1}, otherwise it automatically pads the string with a left alignment for the rownames.} \item{style}{The cell style} \item{cgroup_spacer_cells}{The number of cells that occur between columns due to the cgroup arguments.} \item{has_rn_col}{Due to the alignment issue we need to keep track of if there has already been printed a rowname column or not and therefore we have this has_rn_col that is either 0 or 1.} \item{col.columns}{Alternating colors for each column.} \item{offset}{For rgroup rows there may be an offset != 1} \item{css.cell}{The css.cell but only for this row compared to the htmlTable matrix} } \value{ \code{string} Returns the string with the new cell elements } \description{ Adds a row of cells val... to a table string for \code{\link{htmlTable}} } \seealso{ Other hidden helper functions for htmlTable: \code{\link{prAddSemicolon2StrEnd}()}, \code{\link{prEscapeHtml}()}, \code{\link{prGetCgroupHeader}()}, \code{\link{prGetRowlabelPos}()}, \code{\link{prGetStyle}()}, \code{\link{prPrepareAlign}()}, \code{\link{prPrepareCgroup}()}, \code{\link{prTblNo}()} } \concept{hidden helper functions for htmlTable} \keyword{internal} htmlTable/man/prPrepareCss.Rd0000644000176200001440000000212313407215301015633 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prPrepareCss} \alias{prPrepareCss} \title{Prepares the cell style} \usage{ prPrepareCss(x, css, rnames, header, name = deparse(substitute(css))) } \arguments{ \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} \item{css}{The CSS styles that are to be converted into a matrix.} \item{rnames}{Default rownames are generated from \code{\link[base]{rownames}(x)}. If you provide \code{FALSE} then it will skip the rownames. \emph{Note:} For \code{data.frames} if you do \code{\link[base]{rownames}(my_dataframe) <- NULL} it still has rownames. Thus you need to use \code{FALSE} if you want to surpress rownames for \code{data.frames}.} \item{header}{A vector of character strings specifying column header, defaulting to \code{\link[base]{colnames}(x)}} \item{name}{The name of the CSS style that is prepared} } \value{ \code{matrix} } \description{ Prepares the cell style } \keyword{internal} htmlTable/man/txtInt.Rd0000644000176200001440000000155013412664215014527 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/txtFrmt.R \name{txtInt} \alias{txtInt} \title{SI or English formatting of an integer} \usage{ txtInt(x, language = "en", html = TRUE, ...) } \arguments{ \item{x}{The integer variable} \item{language}{The ISO-639-1 two-letter code for the language of interest. Currently only english is distinguished from the ISO format using a ',' as the separator.} \item{html}{If the format is used in html context then the space should be a non-breaking space, \code{ }} \item{...}{Passed to \code{\link[base]{format}}} } \value{ \code{string} } \description{ English uses ',' between every 3 numbers while the SI format recommends a ' ' if x > 10^4. The scientific form 10e+? is furthermore avoided. } \examples{ txtInt(123) txtInt(1234) txtInt(12345) txtInt(123456) } \concept{text formatters#'} htmlTable/man/prGetThead.Rd0000644000176200001440000001110513572022513015255 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_render.R \name{prGetThead} \alias{prGetThead} \title{Renders the table head (thead)} \usage{ prGetThead( x, header, cgroup, n.cgroup, caption, pos.caption, compatibility, total_columns, align.cgroup, css.cgroup, top_row_style, rnames, rowlabel, pos.rowlabel, cgroup_spacer_cells, css.cell, align.header, cell_style ) } \arguments{ \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} \item{header}{A vector of character strings specifying column header, defaulting to \code{\link[base]{colnames}(x)}} \item{cgroup}{A vector, matrix or list of character strings defining major column header. The default is to have none. These elements are also known as \emph{column spanners}. If you want a column \emph{not} to have a spanner then put that column as "". If you pass cgroup and \code{n.crgroup} as matrices you can have column spanners for several rows. See cgroup section below for details.} \item{n.cgroup}{An integer vector, matrix or list containing the number of columns for which each element in cgroup is a heading. For example, specify \code{cgroup=c("Major_1","Major_2")}, \code{n.cgroup=c(3,3)} if \code{"Major_1"} is to span columns 1-3 and \code{"Major_2"} is to span columns 4-6. \code{rowlabel} does not count in the column numbers. You can omit \code{n.cgroup} if all groups have the same number of columns. If the n.cgroup is one less than the number of columns in the matrix/data.frame then it automatically adds those.} \item{caption}{Adds a table caption.} \item{pos.caption}{Set to \code{"bottom"} to position a caption below the table instead of the default of \code{"top"}.} \item{compatibility}{Is default set to \code{LibreOffice} as some settings need to be in old html format as Libre Office can't handle some commands such as the css caption-alignment. Note: this option is not yet fully implemented for all details, in the future I aim to generate a html-correct table and one that is aimed at Libre Office compatibility. Word-compatibility is difficult as Word ignores most settings and destroys all layout attempts (at least that is how my 2010 version behaves). You can additinally use the \code{options(htmlTableCompat = "html")} if you want a change to apply to the entire document. MS Excel sometimes misinterprets certain cell data when opening HTML-tables (eg. 1/2 becomes 1. February). To avoid this please specify the correct Microsoft Office format for each cell in the table using the css.cell-argument. To make MS Excel interpret everything as text use "mso-number-format:\"\\@\"".} \item{total_columns}{The total number of columns including the rowlabel and the specer cells} \item{align.cgroup}{The justification of the \code{cgroups}} \item{css.cgroup}{The same as \code{css.class} but for cgroup formatting.} \item{top_row_style}{The top row has a special style depending on the \code{ctable} option in the \code{htmlTable} call.} \item{rnames}{Default rownames are generated from \code{\link[base]{rownames}(x)}. If you provide \code{FALSE} then it will skip the rownames. \emph{Note:} For \code{data.frames} if you do \code{\link[base]{rownames}(my_dataframe) <- NULL} it still has rownames. Thus you need to use \code{FALSE} if you want to surpress rownames for \code{data.frames}.} \item{rowlabel}{If the table has rownames or \code{rnames}, rowlabel is a character string containing the column heading for the \code{rnames}.} \item{pos.rowlabel}{Where the rowlabel should be positioned. This value can be \code{"top"}, \code{"bottom"}, \code{"header"}, or a integer between \code{1} and \code{nrow(cgroup) + 1}. The options \code{"bottom"} and \code{"header"} are the same, where the row label is presented at the same level as the header.} \item{cgroup_spacer_cells}{The spacer cells due to the multiple cgroup levels. With multiple rows in cgroup we need to keep track of how many spacer cells occur between the columns. This variable contains is of the size \code{ncol(x)-1} and 0 if there is no cgroup element between.} \item{css.cell}{The css.cell element allows you to add any possible CSS style to your table cells. See section below for details.} \item{align.header}{A character strings specifying alignment for column header, defaulting to centered, i.e. \code{\link[base]{paste}(rep('c',ncol(x)),collapse='')}.} } \value{ \code{string} Returns the html string for the \code{...} element } \description{ Renders the table head (thead) } \keyword{internal} htmlTable/man/txtMergeLines.Rd0000644000176200001440000000214413572022513016023 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/txtFrmt.R \name{txtMergeLines} \alias{txtMergeLines} \title{A merges lines while preserving the line break for html/LaTeX} \usage{ txtMergeLines(..., html = 5) } \arguments{ \item{...}{The lines that you want to be joined} \item{html}{If HTML compatible output should be used. If \code{FALSE} it outputs LaTeX formatting. Note if you set this to 5 then the html5 version of \emph{br} will be used: \code{
} otherwise it uses the \code{
} that is compatible with the xhtml-formatting.} } \value{ string } \description{ This function helps you to do a multiline table header in both html and in LaTeX. In html this isn't that tricky, you just use the
command but in LaTeX I often find myself writing vbox/hbox stuff and therefore I've created this simple helper function } \examples{ txtMergeLines("hello", "world") txtMergeLines("hello", "world", html=FALSE) txtMergeLines("hello", "world", list("A list", "is OK")) } \seealso{ Other text formatters: \code{\link{txtPval}()}, \code{\link{txtRound}()} } \concept{text formatters} htmlTable/man/prPrepareCgroup.Rd0000644000176200001440000000404613572022513016354 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prPrepareCgroup} \alias{prPrepareCgroup} \title{Prepares the cgroup argument} \usage{ prPrepareCgroup(x, cgroup, n.cgroup, align.cgroup, css.cgroup) } \arguments{ \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} \item{cgroup}{A vector, matrix or list of character strings defining major column header. The default is to have none. These elements are also known as \emph{column spanners}. If you want a column \emph{not} to have a spanner then put that column as "". If you pass cgroup and \code{n.crgroup} as matrices you can have column spanners for several rows. See cgroup section below for details.} \item{n.cgroup}{An integer vector, matrix or list containing the number of columns for which each element in cgroup is a heading. For example, specify \code{cgroup=c("Major_1","Major_2")}, \code{n.cgroup=c(3,3)} if \code{"Major_1"} is to span columns 1-3 and \code{"Major_2"} is to span columns 4-6. \code{rowlabel} does not count in the column numbers. You can omit \code{n.cgroup} if all groups have the same number of columns. If the n.cgroup is one less than the number of columns in the matrix/data.frame then it automatically adds those.} \item{align.cgroup}{The justification of the \code{cgroups}} \item{css.cgroup}{The same as \code{css.class} but for cgroup formatting.} } \value{ \code{list(cgroup, n.cgroup, align.cgroup, cgroup_spacer_cells)} } \description{ Due to the complicated structure of multilevel cgroups there some preparation for the cgroup options is required. } \seealso{ Other hidden helper functions for htmlTable: \code{\link{prAddCells}()}, \code{\link{prAddSemicolon2StrEnd}()}, \code{\link{prEscapeHtml}()}, \code{\link{prGetCgroupHeader}()}, \code{\link{prGetRowlabelPos}()}, \code{\link{prGetStyle}()}, \code{\link{prPrepareAlign}()}, \code{\link{prTblNo}()} } \concept{hidden helper functions for htmlTable} \keyword{internal} htmlTable/man/htmlTableWidget-shiny.Rd0000644000176200001440000000221613407215301017435 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTableWidget.R \name{htmlTableWidget-shiny} \alias{htmlTableWidget-shiny} \alias{htmlTableWidgetOutput} \alias{renderHtmlTableWidget} \title{Shiny bindings for htmlTableWidget} \usage{ htmlTableWidgetOutput(outputId, width = "100\%", height = "400px") renderHtmlTableWidget(expr, env = parent.frame(), quoted = FALSE) } \arguments{ \item{outputId}{output variable to read from} \item{width, height}{Must be a valid CSS unit (like \code{'100\%'}, \code{'400px'}, \code{'auto'}) or a number, which will be coerced to a string and have \code{'px'} appended.} \item{expr}{An expression that generates a htmlTableWidget} \item{env}{The environment in which to evaluate \code{expr}.} \item{quoted}{Is \code{expr} a quoted expression (with \code{quote()})? This is useful if you want to save an expression in a variable.} } \description{ Output and render functions for using htmlTableWidget within Shiny applications and interactive Rmd documents. } \examples{ \dontrun{ # In the UI: htmlTableWidgetOutput("mywidget") # In the server: renderHtmlTableWidget({htmlTableWidget(iris)}) } } htmlTable/man/prEscapeHtml.Rd0000644000176200001440000000163213572022513015621 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prEscapeHtml} \alias{prEscapeHtml} \title{Remove html entities from table} \usage{ prEscapeHtml(x) } \arguments{ \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} } \value{ \code{x} without the html entities } \description{ Removes the htmlEntities from table input data. Note that this also replaces $ signs in order to remove the MathJax issue. } \seealso{ Other hidden helper functions for htmlTable: \code{\link{prAddCells}()}, \code{\link{prAddSemicolon2StrEnd}()}, \code{\link{prGetCgroupHeader}()}, \code{\link{prGetRowlabelPos}()}, \code{\link{prGetStyle}()}, \code{\link{prPrepareAlign}()}, \code{\link{prPrepareCgroup}()}, \code{\link{prTblNo}()} } \concept{hidden helper functions for htmlTable} htmlTable/man/prTblNo.Rd0000644000176200001440000000202313572022513014605 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prTblNo} \alias{prTblNo} \title{Gets the table counter string} \usage{ prTblNo(caption) } \arguments{ \item{The}{caption} } \value{ \code{string} Returns a string formatted according to the table_counter_str and table_counter_roman. The number is decided by the table_counter variable } \description{ Returns the string used for htmlTable to number the different tables. Uses options \code{table_counter}, \code{table_counter_str}, and \code{table_counter_roman} to produce the final string. You can set each option by simply calling \code{options()}. } \seealso{ Other hidden helper functions for htmlTable: \code{\link{prAddCells}()}, \code{\link{prAddSemicolon2StrEnd}()}, \code{\link{prEscapeHtml}()}, \code{\link{prGetCgroupHeader}()}, \code{\link{prGetRowlabelPos}()}, \code{\link{prGetStyle}()}, \code{\link{prPrepareAlign}()}, \code{\link{prPrepareCgroup}()} } \concept{hidden helper functions for htmlTable} \keyword{internal} htmlTable/man/prPrepareColors.Rd0000644000176200001440000000105413407215301016346 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prPrepareColors} \alias{prPrepareColors} \title{Prepares the alternating colors} \usage{ prPrepareColors(clr, n, ng, gtxt) } \arguments{ \item{clr}{The colors} \item{n}{The number of rows/columns applicable to the color} \item{ng}{The n.rgroup/n.cgroup argument if applicable} \item{gtxt}{The rgroup/cgroup texts} } \value{ \code{character} A vector containing hexadecimal colors } \description{ Prepares the alternating colors } \keyword{internal} htmlTable/man/prGetAlign.Rd0000644000176200001440000000145213412664215015272 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prGetAlign} \alias{prGetAlign} \title{Gets alignment} \usage{ prGetAlign(align, index) } \arguments{ \item{align}{A character strings specifying column alignments, defaulting to \code{\link[base]{paste}(rep('c',ncol(x)),collapse='')} to center. Valid alignments are l = left, c = center and r = right. You can also specify \code{align='c|c'} and other LaTeX tabular formatting. If you want to set the alignment of the rownames this string needst to be \code{ncol(x) + 1}, otherwise it automatically pads the string with a left alignment for the rownames.} \item{index}{The index of the align parameter of interest} } \description{ Gets alignment } \concept{hidden helper functions for} \keyword{internal} htmlTable/man/tblNoLast.Rd0000644000176200001440000000126113572022513015132 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable.R \name{tblNoLast} \alias{tblNoLast} \title{Gets the last table number} \usage{ tblNoLast(roman = getOption("table_counter_roman", FALSE)) } \arguments{ \item{roman}{Whether or not to use roman numbers instead of arabic. Can also be set through \code{options(table_caption_no_roman = TRUE)}} } \description{ The function relies on \code{options("table_counter")} in order to keep track of the last number. } \examples{ org_opts <- options(table_counter=1) tblNoLast() options(org_opts) } \seealso{ Other table functions: \code{\link{htmlTable}}, \code{\link{tblNoNext}()} } \concept{table functions} htmlTable/man/tblNoNext.Rd0000644000176200001440000000126113572022513015145 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable.R \name{tblNoNext} \alias{tblNoNext} \title{Gets the next table number} \usage{ tblNoNext(roman = getOption("table_counter_roman", FALSE)) } \arguments{ \item{roman}{Whether or not to use roman numbers instead of arabic. Can also be set through \code{options(table_caption_no_roman = TRUE)}} } \description{ The function relies on \code{options("table_counter")} in order to keep track of the last number. } \examples{ org_opts <- options(table_counter=1) tblNoNext() options(org_opts) } \seealso{ Other table functions: \code{\link{htmlTable}}, \code{\link{tblNoLast}()} } \concept{table functions} htmlTable/man/prMergeClr.Rd0000644000176200001440000000117313407215301015270 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prMergeClr} \alias{prMergeClr} \title{Merges multiple colors} \usage{ prMergeClr(clrs) } \arguments{ \item{clrs}{The colors} } \value{ \code{character} A hexadecimal color } \description{ Uses the \code{\link[grDevices]{colorRampPalette}} for merging colors. \emph{Note:} When merging more than 2 colors the order in the color presentation matters. Each color is merged with its neigbors before merging with next. If there is an uneven number of colors the middle color is mixed with both left and right side. } \keyword{internal} htmlTable/man/prGetCgroupHeader.Rd0000644000176200001440000000551113572022513016604 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prGetCgroupHeader} \alias{prGetCgroupHeader} \title{Retrieve a header row} \usage{ prGetCgroupHeader( x, cgroup_vec, n.cgroup_vec, cgroup_vec.just, css.cgroup_vec, row_no, top_row_style, rnames, rowlabel, pos.rowlabel, cgroup_spacer_cells, css.cell ) } \arguments{ \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} \item{cgroup_vec}{The cgroup may be a matrix, this is just one row of that matrix} \item{n.cgroup_vec}{The same as above but for the counter} \item{cgroup_vec.just}{The same as above bot for the justificaiton} \item{css.cgroup_vec}{The CSS row corresponding to the current row} \item{row_no}{The row number within the header group. Useful for multirow headers when we need to output the rowlabel at the \code{pos.rowlabel} level.} \item{top_row_style}{The top row has a special style depending on the \code{ctable} option in the \code{htmlTable} call.} \item{rnames}{Default rownames are generated from \code{\link[base]{rownames}(x)}. If you provide \code{FALSE} then it will skip the rownames. \emph{Note:} For \code{data.frames} if you do \code{\link[base]{rownames}(my_dataframe) <- NULL} it still has rownames. Thus you need to use \code{FALSE} if you want to surpress rownames for \code{data.frames}.} \item{rowlabel}{If the table has rownames or \code{rnames}, rowlabel is a character string containing the column heading for the \code{rnames}.} \item{pos.rowlabel}{Where the rowlabel should be positioned. This value can be \code{"top"}, \code{"bottom"}, \code{"header"}, or a integer between \code{1} and \code{nrow(cgroup) + 1}. The options \code{"bottom"} and \code{"header"} are the same, where the row label is presented at the same level as the header.} \item{cgroup_spacer_cells}{The spacer cells due to the multiple cgroup levels. With multiple rows in cgroup we need to keep track of how many spacer cells occur between the columns. This variable contains is of the size \code{ncol(x)-1} and 0 if there is no cgroup element between.} \item{css.cell}{The css.cell element allows you to add any possible CSS style to your table cells. See section below for details.} } \value{ \code{string} } \description{ This function retrieves a header row, i.e. a row within the elements on top of the table. Used by \code{\link{htmlTable}}. } \seealso{ Other hidden helper functions for htmlTable: \code{\link{prAddCells}()}, \code{\link{prAddSemicolon2StrEnd}()}, \code{\link{prEscapeHtml}()}, \code{\link{prGetRowlabelPos}()}, \code{\link{prGetStyle}()}, \code{\link{prPrepareAlign}()}, \code{\link{prPrepareCgroup}()}, \code{\link{prTblNo}()} } \concept{hidden helper functions for htmlTable} \keyword{internal} htmlTable/man/prAddSemicolon2StrEnd.Rd0000644000176200001440000000152313572022513017336 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prAddSemicolon2StrEnd} \alias{prAddSemicolon2StrEnd} \title{Add a ; at the end} \usage{ prAddSemicolon2StrEnd(my_str) } \arguments{ \item{my_str}{The string that is to be processed} } \value{ \code{string} } \description{ The CSS expects a semicolon at the end of each argument this function just adds a semicolong if none is given and remove multiple semicolon if such exist } \seealso{ Other hidden helper functions for htmlTable: \code{\link{prAddCells}()}, \code{\link{prEscapeHtml}()}, \code{\link{prGetCgroupHeader}()}, \code{\link{prGetRowlabelPos}()}, \code{\link{prGetStyle}()}, \code{\link{prPrepareAlign}()}, \code{\link{prPrepareCgroup}()}, \code{\link{prTblNo}()} } \concept{hidden helper functions for htmlTable} \keyword{internal} htmlTable/man/htmlTableWidget.Rd0000644000176200001440000000242513572022513016313 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTableWidget.R \name{htmlTableWidget} \alias{htmlTableWidget} \title{htmlTable with pagination widget} \usage{ htmlTableWidget( x, number_of_entries = c(10, 25, 100), width = NULL, height = NULL, elementId = NULL, ... ) } \arguments{ \item{x}{A data frame to be rendered} \item{number_of_entries}{a numeric vector with the number of entries per page to show. If there is more than one number given, the user will be able to show the number of rows per page in the table.} \item{width}{Fixed width for widget (in css units). The default is \code{NULL}, which results in intelligent automatic sizing based on the widget's container.} \item{height}{Fixed height for widget (in css units). The default is \code{NULL}, which results in intelligent automatic sizing based on the widget's container.} \item{elementId}{Use an explicit element ID for the widget (rather than an automatically generated one). Useful if you have other JavaScript that needs to explicitly discover and interact with a specific widget instance.} \item{...}{Additional parameters passed to htmlTable} } \value{ an htmlwidget showing the paginated table } \description{ This widget renders a table with pagination into an htmlwidget } htmlTable/man/prIsNotebook.Rd0000644000176200001440000000063113407215301015642 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable.R \name{prIsNotebook} \alias{prIsNotebook} \title{Detects if the call is made from within an RStudio Rmd file or a file with the html_notebook output set.} \usage{ prIsNotebook() } \description{ Detects if the call is made from within an RStudio Rmd file or a file with the html_notebook output set. } \keyword{internal} htmlTable/man/prPrepareAlign.Rd0000644000176200001440000000366013572022513016150 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prPrepareAlign} \alias{prPrepareAlign} \title{Prepares the align to match the columns} \usage{ prPrepareAlign(align, x, rnames, default_rn = "l") } \arguments{ \item{align}{A character strings specifying column alignments, defaulting to \code{\link[base]{paste}(rep('c',ncol(x)),collapse='')} to center. Valid alignments are l = left, c = center and r = right. You can also specify \code{align='c|c'} and other LaTeX tabular formatting. If you want to set the alignment of the rownames this string needst to be \code{ncol(x) + 1}, otherwise it automatically pads the string with a left alignment for the rownames.} \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} \item{rnames}{Default rownames are generated from \code{\link[base]{rownames}(x)}. If you provide \code{FALSE} then it will skip the rownames. \emph{Note:} For \code{data.frames} if you do \code{\link[base]{rownames}(my_dataframe) <- NULL} it still has rownames. Thus you need to use \code{FALSE} if you want to surpress rownames for \code{data.frames}.} \item{default_rn}{The default rowname alignment. This is an option as the header uses the same function and there may be differences in how the alignments should be implemented.} } \description{ The alignment may be tricky and this function therefore simplifies this process by extending/shortening the alignment to match the correct number of columns. } \seealso{ Other hidden helper functions for htmlTable: \code{\link{prAddCells}()}, \code{\link{prAddSemicolon2StrEnd}()}, \code{\link{prEscapeHtml}()}, \code{\link{prGetCgroupHeader}()}, \code{\link{prGetRowlabelPos}()}, \code{\link{prGetStyle}()}, \code{\link{prPrepareCgroup}()}, \code{\link{prTblNo}()} } \concept{hidden helper functions for htmlTable} \keyword{internal} htmlTable/DESCRIPTION0000644000176200001440000000257513572030437013711 0ustar liggesusersPackage: htmlTable Version: 1.13.3 Date: 2019-12-04 Title: Advanced Tables for Markdown/HTML Authors@R: c( person("Max", "Gordon", email = "max@gforge.se", role = c("aut", "cre")), person("Stephen", "Gragg", role=c("aut")), person("Peter", "Konings", role=c("aut"))) Maintainer: Max Gordon Description: Tables with state-of-the-art layout elements such as row spanners, column spanners, table spanners, zebra striping, and more. While allowing advanced layout, the underlying css-structure is simple in order to maximize compatibility with word processors such as 'MS Word' or 'LibreOffice'. The package also contains a few text formatting functions that help outputting text compatible with HTML/LaTeX. License: GPL (>= 3) URL: http://gforge.se/packages/ BugReports: https://github.com/gforge/htmlTable/issues Biarch: yes Imports: stringr, knitr (>= 1.6), magrittr (>= 1.5), methods, checkmate, htmlwidgets, htmltools, rstudioapi (>= 0.6) Suggests: testthat, XML, xtable, ztable, Hmisc, reshape, rmarkdown, pander, chron, lubridate, tibble, tidyr (>= 0.7.2), dplyr (>= 0.7.4) Encoding: UTF-8 NeedsCompilation: no VignetteBuilder: knitr RoxygenNote: 7.0.2 Packaged: 2019-12-04 21:50:14 UTC; max Author: Max Gordon [aut, cre], Stephen Gragg [aut], Peter Konings [aut] Repository: CRAN Date/Publication: 2019-12-04 22:20:15 UTC htmlTable/build/0000755000176200001440000000000013572025026013267 5ustar liggesusershtmlTable/build/vignette.rds0000644000176200001440000000043413572025026015627 0ustar liggesusersRN0tMQ>wD*qAlZKlC?aڡzzgƻ;kB(+ffs|Wpmd,y1ז6b^ܮT{o0 =ݟبaOf||chhy:]#&v+qrxO_wCyBSo?b|ɇ@X4  $ 7{`ViR.ܯﱣWALpȊK7 ~~C\htmlTable/tests/0000755000176200001440000000000013407215301013324 5ustar liggesusershtmlTable/tests/testthat/0000755000176200001440000000000013572030437015174 5ustar liggesusershtmlTable/tests/testthat/test-htmlTable_total.R0000644000176200001440000000570713407215301021414 0ustar liggesuserslibrary(testthat) context("htmlTable - the total argument") test_that("Throws errors",{ mx <- matrix(1, ncol=3, nrow=6) expect_error(htmlTable(mx, total = c(TRUE, TRUE))) expect_error(htmlTable(mx, total = c(TRUE, TRUE), tspanner = letters[1:3], n.tspanner = rep(2, times = 3))) expect_error(htmlTable(mx, total = -1)) expect_error(htmlTable(mx, total = nrow(mx) + 1)) expect_error(htmlTable(mx, total = "asdasd")) }) test_that("Correct rows",{ mx <- matrix(1:6, ncol=3, nrow=6) table_str <- htmlTable(mx, css.total = "color: red", total=TRUE) expect_match(table_str, "]*>[^>]+color: red[^>]+>6") table_str <- htmlTable(mx, css.total = "color: red", total=4) expect_match(table_str, "]*>[^>]+color: red[^>]+>4") table_str <- htmlTable(mx, css.total = "color: red", total=c(4, 2)) expect_false(grepl("]*>[^>]+color: red[^>]+>[1356789]+", table_str)) expect_match(table_str, "]*>[^>]+color: red[^>]+>2") expect_match(table_str, "]*>[^>]+color: red[^>]+>4") table_str <- htmlTable(mx, css.total = "color: red", total=c(4, 2)) expect_false(grepl("]*>[^>]+color: red[^>]+>[1356789]+", table_str)) expect_match(table_str, "]*>[^>]+color: red[^>]+>2") expect_match(table_str, "]*>[^>]+color: red[^>]+>4") }) test_that("Check tspanner", { mx <- matrix(1:6, ncol=3, nrow=6) table_str <- htmlTable(mx, tspanner = letters[1:2], n.tspanner = c(3, 3), css.total = "color: red", total="tspanner") expect_false(grepl("]*>[^>]+color: red[^>]+>[1245789]+", table_str)) expect_match(table_str, "]*>[^>]+color: red[^>]+>3") expect_match(table_str, "]*>[^>]+color: red[^>]+>6") }) test_that("Check choosing css.style", { mx <- matrix(1:6, ncol=3, nrow=6) table_str <- htmlTable(mx, tspanner = letters[1:2], n.tspanner = c(3, 3), css.total = c("color: red", "color: green"), total="tspanner") expect_false(grepl("]*>[^>]+color: red[^>]+>[1245789]+", table_str)) expect_match(table_str, "]*>[^>]+color: red[^>]+>3") expect_match(table_str, "]*>[^>]+color: green[^>]+>6") }) test_that("The total should be added to the output if used with addmargins", { var1 <- LETTERS[1:3] var2 <- LETTERS[c(4:5, 5)] total_out <- table(var1, var2) %>% addmargins %>% htmlTable(css.total = "background: purple") expect_match(total_out, "]+background: purple[^>]+>[^>]*Sum", info = "Expect the variable name to appear as a cgroup") expect_match(total_out, "]*>var2", info = "Expect the variable name to appear as a cgroup") }) htmlTable/tests/testthat/test-txtFrmt.R0000644000176200001440000001606313412664215017752 0ustar liggesuserslibrary('testthat') context('txtInt') test_that("Add zero", { expect_equal(txtInt(5), "5") expect_equal(txtInt(106), "106") expect_equal(txtInt(1006), "1,006") expect_equal(txtInt(c(5, 106, 10006)), c("5", "106", "10,006")) expect_equal(txtInt(1000, language = "se", html = TRUE), "1000") expect_equal(txtInt(10000, language = "se", html = TRUE), "10 000") expect_equal(txtInt(10000, language = "se", html = FALSE), "10 000") mtrx <- matrix(seq(from = 10, to = 10000, length.out = 3*6), ncol = 3, nrow = 6) mtrx <- round(mtrx) int_mtrx <- txtInt(mtrx) expect_equal(dim(mtrx), dim(int_mtrx)) expect_equal(int_mtrx[3,1], txtInt(mtrx[3,1])) }) test_that("Throw nsmall warning", { expect_warning(txtInt(.5), regexp = "The function can only be served integers") expect_silent(txtInt(.5, nsmall=1)) expect_warning(txtInt(c(.5, .5)), regexp = "The function can only be served integers") expect_silent(txtInt(c(.5, .5), nsmall=2)) }) context('txtPval') test_that("Add zero", { expect_equal(txtPval(.5, lim.2dec=10^-1), "0.50") expect_equal(txtPval(.06, lim.2dec=10^-1), "0.06") expect_equal(txtPval(.06, lim.2dec=10^-2), "0.060") expect_equal(txtPval(.06451, lim.2dec=10^-3), "0.065") expect_equal(txtPval(.00006451, lim.sig=10^-3), "< 0.001") expect_warning(txtPval("a", lim.sig = 10^-3)) }) context('txtRound') test_that("Numerical matrices",{ test_mx <- matrix(c(1, 1.11, 1.25, 2.50, 2.55, 2.45, 3.2313, 3, pi), ncol = 3, byrow=TRUE) expect_equivalent(txtRound(test_mx, 1), t(apply(test_mx, 1, function(x) sprintf("%.1f", x)))) expect_equivalent(txtRound(test_mx, 1, excl.cols = 2)[2,2], as.character(test_mx[2,2])) expect_equivalent(txtRound(test_mx, 1, excl.rows = 2)[2,2], as.character(test_mx[2,2])) expect_equivalent(txtRound(test_mx, 1, excl.cols = 2)[2,1], sprintf("%.1f", test_mx[2,1])) expect_equivalent(txtRound(test_mx, 1, excl.rows = 2)[1,1], sprintf("%.1f", test_mx[1,1])) expect_equivalent(txtRound(test_mx, 1, excl.cols = 2)[2,3], sprintf("%.1f", test_mx[2,3])) rownames(test_mx) <- letters[1:nrow(test_mx)] colnames(test_mx) <- LETTERS[1:ncol(test_mx)] expect_equivalent(txtRound(test_mx, 1, excl.cols = "A")[3,"A"], as.character(test_mx[3,"A"])) expect_equivalent(txtRound(test_mx, 1, excl.cols = "A")[3,"C"], sprintf("%.1f", test_mx[3,"C"])) expect_equivalent(txtRound(test_mx, 1, excl.rows = "a")["a", 3], as.character(test_mx["a", 3])) expect_equivalent(txtRound(test_mx, 1, excl.rows = "a")["c", 3], sprintf("%.1f", test_mx["c", 3])) expect_equivalent(txtRound(matrix(c(NA, 2.22), ncol=1), 1)[1,1], "") expect_equivalent(txtRound(matrix(c(NA, 2.22), ncol=1), 1, txt.NA = "missing")[1,1], "missing") expect_error(txtRound(test_mx, digits = c(2, 3, 4, 5))) expect_error(txtRound(test_mx, digits = c(2, 3))) }) test_that("Character matrices",{ test_mx <- matrix(c(1, 1.11, 1.25, 2.50, 2.55, 2.45, 3.2313, 3, pi), ncol = 3, byrow=TRUE) ch_test_mx <- cbind(test_mx, "a") expect_equivalent(txtRound(ch_test_mx, 1)[,1:ncol(test_mx)], t(apply(test_mx, 1, function(x) sprintf("%.1f", x)))) expect_equivalent(txtRound(test_mx, 1, excl.cols = 2)[2,2], as.character(test_mx[2,2])) expect_equivalent(txtRound(test_mx, 1, excl.rows = 2)[2,2], as.character(test_mx[2,2])) expect_equivalent(txtRound(test_mx, 1, excl.cols = 2)[2,1], sprintf("%.1f", test_mx[2,1])) expect_equivalent(txtRound(test_mx, 1, excl.rows = 2)[1,1], sprintf("%.1f", test_mx[1,1])) }) test_that("Supplying a data.frame",{ test_df <- matrix(c(1, 1.11, 1.25, 2.50, 2.55, 2.45, 3.2313, 3, pi), ncol = 3, byrow=TRUE) %>% as.data.frame() test_df$text = LETTERS[1:nrow(test_df)] expect_equal(dim(txtRound(test_df, 1)), dim(test_df)) expect_equivalent(as.matrix(txtRound(test_df, 1)[,1:3]), t(apply(test_df[,1:3], 1, function(x) sprintf("%.1f", x)))) expect_equal(txtRound(test_df, 1)$text, test_df$text) }) test_that("Supplying a table",{ out <- txtRound(table(1:4, 4:1)) expect_equal(nrow(out), 4) expect_equal(ncol(out), 4) }) test_that("Supplying a vector for the digits",{ w <- matrix((1:8)/7, ncol=4) w_out <- txtRound(w, digits=1:4) for (digits in 1:4) expect_equivalent(w_out[,digits], sprintf(paste0("%.", digits, "f"), w[,digits]), paste("Expected the number of digits to be", digits)) }) test_that("The txtRound should accept without warning a vector",{ w <- c(.1, .2, .7) expect_silent(w_out <- txtRound(w)) expect_equivalent(w_out, c("0", "0", "1")) w_out <- txtRound(w, digits = 0:2) expect_equivalent(w_out, c("0", "0.2", "0.70")) expect_error(txtRound(w, digits = 0:20)) }) test_that("Numbers that round to 0 should not have -, i.e. no -0.0",{ expect_equal(txtRound(matrix(-.01), digits = 1), matrix("0.0")) expect_equal(txtRound(matrix("-.01"), digits = 0), matrix("0")) }) test_that("Character vectors work", { test_str <- c("AA 2 2A", "-1.2 aaa", "-1", "2.8888") correct_str <- c("2.0", "-1.2", "-1.0", "2.9") for (i in 1:length(test_str)) expect_equivalent(txtRound(test_str[i], digits = 1), correct_str[i], info = paste("Test case", i)) }) test_that("Keep minimila digits", { expect_equal(txtRound(c(0.1, 0.01, 0.001), digits = 2), c("0.10", "0.01","0.00")) expect_equal(txtRound(c(0.1, 0.01, 0.0018, 0.0012, 0.00012), digits = 2, digits.nonzero = 3), c("0.10", "0.01","0.002","0.001","0.00")) expect_equal(txtRound(c(10.1, 0.1, 0.0012, 0.0012), digits = c(0, 2, 2, 2), digits.nonzero = c(1,2,2,3)), c("10", "0.10", "0.00", "0.001")) }) test_that("Peter's issues raised in #34", { expect_silent(txtRound(c(1, 2, 3, 4))) expect_silent(txtRound(c(1, 2, 3, NA))) expect_silent(txtRound(c(NA, NA, NA, NA))) }) test_that("Scientific notation",{ expect_equal(txtRound("1.1234", 1), "1.1") expect_equal(txtRound("1.1234e1", 1), "1.12e+01") expect_equal(txtRound("1.1234e+01", 1), "1.12e+01") expect_equal(txtRound("1.1234321e2", 2), "1.1234e+02") # Doesn't work due to depares(substitute()) limitations # expect_equal(txtRound(1.1234321e2, 2), "1.1234e+02") expect_equal(txtRound(1.1234321e2, 2, scientific = TRUE), "1.1234e+02") expect_equal(txtRound("1.1234321e2", 2, scientific = FALSE), "112.34") }) htmlTable/tests/testthat/test-interactiveTable.R0000644000176200001440000003002213407215301021546 0ustar liggesuserslibrary('testthat') library('XML') context('interactiveTable') # A simple example test_that("With empty rownames(mx) it should skip those", { mx <- matrix(1:6, ncol=3) table_str <- interactiveTable(mx) expect_false(grepl("", table_str)) expect_false(grepl("[^>]+>NA", table_str)) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) table_str <- interactiveTable(mx) expect_true(grepl("", table_str)) expect_false(grepl("[^>]+>NA", table_str)) }) test_that("Empty cell names should be replaced with ''", { mx <- matrix(1:6, ncol=3) mx[1,1] <- NA table_str <- interactiveTable(mx) expect_false(grepl("[^>]+>NA", table_str)) }) test_that("The variable name should not be in the tables first row if no rownames(mx)", { mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) table_str <- interactiveTable(mx) expect_false(grepl("[^<]*[^>]+>mx", table_str)) }) test_that("A rowlabel without rownames indicates some kind of error and should throw an error", { mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) expect_error(interactiveTable(mx, rowlabel="not_mx")) }) # Add rownames test_that("The rowname should appear", { mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) rownames(mx) <- LETTERS[1:NROW(mx)] table_str <- interactiveTable(mx) class(table_str) <- "character" parsed_table <- readHTMLTable(table_str)[[1]] expect_equal(ncol(parsed_table), ncol(mx) + 1) expect_match(table_str, "]*>[^>]+>A") expect_match(table_str, "]*>[^>]+>B") }) test_that("Check that basic output are the same as the provided matrix", { mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) table_str <- interactiveTable(mx) class(table_str) <- "character" parsed_table <- readHTMLTable(table_str)[[1]] expect_equal(ncol(parsed_table), ncol(mx), info="Cols did not match") expect_equal(nrow(parsed_table), nrow(mx), info="Rows did not match") expect_true(all(mx == parsed_table), info="Some cells don't match the inputted cells") }) test_that("rnames = FALSE it should skip those", { mx <- matrix(1:6, ncol=3) rownames(mx) <- c("Row A", "Row B") table_str <- interactiveTable(mx, rnames = FALSE) expect_false(grepl("FALSE", table_str)) expect_false(grepl("Row A", table_str)) }) test_that("Test style formatter", { styles <- c(background = "black", border ="1px solid grey") expect_equivalent(length(prGetStyle(styles)), 1) expect_match(prGetStyle(styles), "background: black;") expect_match(prGetStyle(styles), "border: [^;]+grey;") expect_match(prGetStyle(styles), "border: [^;]+grey;") expect_match(prGetStyle(styles, a=2), "border: [^;]+grey;") expect_error(prGetStyle(styles, "invalid style")) expect_error(prGetStyle(styles, "invalid style:")) expect_error(prGetStyle(styles, ":invalid style")) expect_match(prGetStyle(styles, "valid: style"), "valid: style;") expect_match(prGetStyle(styles, c(valid= "style")), "valid: style;") expect_match(prGetStyle(styles, c(valid= "style", valid1= "style")), "valid: style; valid1: style;") expect_match(prGetStyle(styles, c(valid= "style1", valid= "style2")), "valid: style2;") expect_match(prGetStyle(styles, c(valid= "style1", valid= "style2"), "valid: style3"), "valid: style3;") }) test_that("Test align functions", { expect_equivalent(nchar(prPrepareAlign("lr", x = matrix(1, ncol=10))), 10) expect_equivalent(nchar(prPrepareAlign("lr", x = matrix(1, ncol=2))), 2) expect_equivalent(nchar(prPrepareAlign("lr", x = matrix(1, ncol=2), rnames = TRUE)), 3) expect_equivalent(nchar(prPrepareAlign("l", x = matrix(1, ncol=2), rnames = TRUE)), 3) expect_equivalent(nchar(prPrepareAlign("", x = matrix(1, ncol=2, nrow=2), rnames = TRUE)), 3) expect_equivalent(attr(prPrepareAlign("r|rlt|r|", x = matrix(1, ncol=2, nrow=2), rnames = TRUE), "n"), 3) expect_equivalent(attr(prPrepareAlign("r|rcl|lt|r|", x = matrix(1, ncol=5, nrow=2), rnames = TRUE), "n"), 6) expect_match(prPrepareAlign("r|rcl|lt|r|", x = matrix(1, ncol=5, nrow=2), rnames = TRUE), "^r") expect_match(prPrepareAlign("l|r|", x = matrix(1, ncol=3, nrow=2), rnames = TRUE), "^l|r|r|$") align_str <- prPrepareAlign("r|rcl|lt|r|", x = matrix(1, ncol=5, nrow=2), rnames = TRUE) expect_true("right" %in% prGetAlign(align_str, 1)) expect_true("right" %in% prGetAlign(align_str, 2)) expect_true("center" %in% prGetAlign(align_str, 3)) expect_true("left" %in% prGetAlign(align_str, 4)) expect_true("left" %in% prGetAlign(align_str, 5)) expect_true("right" %in% prGetAlign(align_str, 6)) expect_true("border-right" %in% names(prGetAlign(align_str, 1))) expect_true("border-right" %in% names(prGetAlign(align_str, 4))) expect_true("border-right" %in% names(prGetAlign(align_str, 5))) expect_true("border-right" %in% names(prGetAlign(align_str, 6))) expect_equivalent(length(prGetAlign(align_str, 1)), 2) expect_equivalent(length(prGetAlign(align_str, 2)), 1) expect_equivalent(length(prGetAlign(align_str, 6)), 2) align_str <- prPrepareAlign("|c|rc", x = matrix(1, ncol=2, nrow=2), rnames = TRUE) expect_true("border-right" %in% names(prGetAlign(align_str, 1))) expect_true("border-left" %in% names(prGetAlign(align_str, 1))) expect_true("center" %in% prGetAlign(align_str, 1)) mx <- matrix(1:6, ncol=3) rownames(mx) <- c("Row A", "Row B") table_str <- interactiveTable(mx, rname = FALSE) expect_match(table_str, "text-align: center;[^>]*>1") expect_match(table_str, "text-align: center;[^>]*>3") expect_match(table_str, "text-align: center;[^>]*>5") table_str <- interactiveTable(mx) expect_match(table_str, "text-align: left;[^>]*>Row A") expect_match(table_str, "text-align: center;[^>]*>1") expect_match(table_str, "text-align: center;[^>]*>3") expect_match(table_str, "text-align: center;[^>]*>5") table_str <- interactiveTable(mx, align="r") expect_match(table_str, "text-align: left;[^>]*>Ro") expect_match(table_str, "text-align: right;[^>]*>1") expect_match(table_str, "text-align: right;[^>]*>3") expect_match(table_str, "text-align: right;[^>]*>5") table_str <- interactiveTable(mx, align="|ll|r|r|") expect_match(table_str, "text-align: left;[^>]*>Ro") expect_match(table_str, "text-align: left;[^>]*>1") expect_match(table_str, "text-align: right;[^>]*>3") expect_match(table_str, "text-align: right;[^>]*>5") expect_match(table_str, "border-left:[^>]*>Ro") expect_match(table_str, "border-right:[^>]*>1") expect_match(table_str, "border-right:[^>]*>3") expect_match(table_str, "border-right:[^>]*>5") }) test_that("Check color function",{ expect_equivalent(prPrepareColors(c("white", "#444444"), 2), c("#ffffff", "#444444")) expect_equivalent(prPrepareColors(c("white", "#444444"), 3), c("#ffffff", "#444444", "#ffffff")) expect_equivalent(prPrepareColors(c("white", "#444"), 3), c("#ffffff", "#444444", "#ffffff")) expect_null(attr(prPrepareColors(c("white", "#444444"), 3), "groups")) expect_equivalent(attr(prPrepareColors(c("white", "#444444"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c")), "groups")[[1]], c("#ffffff", "#ffffff")) expect_equivalent(attr(prPrepareColors(c("white", "#444444"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c")), "groups")[[2]], c("#444444", "#444444", "#444444")) expect_equivalent(attr(prPrepareColors(c("white", "#444444"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c")), "groups")[[3]], c("#ffffff")) expect_equivalent(attr(prPrepareColors(c("white", "#444444", "none"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c")), "groups")[[3]], c("none")) expect_equivalent(attr(prPrepareColors(c("white", "none"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c")), "groups")[[2]], c("none", "none", "none")) ## Test the merge colors expect_equal(prMergeClr(c("white", "#444444")), colorRampPalette(c("#FFFFFF", "#444444"))(3)[2]) expect_equal(prMergeClr(c("red", "#444444")), colorRampPalette(c("red", "#444444"))(3)[2]) expect_equal(prMergeClr(c("#444444", "red")), colorRampPalette(c("red", "#444444"))(3)[2]) expect_equal(prMergeClr(c("#FFFFFF", "#FFFFFF", "#FFFFFF")), "#FFFFFF") expect_equal(prMergeClr(c("#FFFFFF", "#FFFFFF", "#000000", "#000000")), prMergeClr(c("#FFFFFF", "#000000"))) expect_equal(prMergeClr(c("#000000", "#FFFFFF", "#FFFFFF")), prMergeClr(c("#FFFFFF", "#FFFFFF", "#000000"))) expect_equal(prMergeClr(c("#000000", "#FFFFFF", "#000000")), prMergeClr(c("#FFFFFF", "#000000", "#FFFFFF"))) }) test_that("Test cell styles",{ mx <- matrix(1:3, nrow=2, ncol=3, byrow = TRUE) mx_head <- LETTERS[1:ncol(mx)] mx_rnames <- LETTERS[1:nrow(mx)] expect_equal(dim(prPrepareCss(mx, "")), dim(mx)) expect_equal(dim(prPrepareCss(mx, "", header = mx_head, rnames = mx_rnames)), dim(mx)) expect_equal(dim(prPrepareCss(mx, "", header = mx_head, rnames = mx_rnames)), dim(mx)) expect_equal(dim(prPrepareCss(mx, rep("", times=ncol(mx)))), dim(mx)) expect_error(prPrepareCss(mx, rep("", times=nrow(mx)))) mx_cell.style <- matrix(c("a", "b", "c", "d"), nrow=2, ncol=4, byrow = TRUE) expect_equal(prPrepareCss(mx, mx_cell.style, rnames = mx_rnames)[2,1], "b") expect_error(prPrepareCss(mx, mx_cell.style)) mx_cell.style <- matrix(c("a", "b", "c", "d"), nrow=3, ncol=4, byrow = TRUE) expect_equal(prPrepareCss(mx, mx_cell.style, header = mx_head, rnames = mx_rnames)[2,1], "b") expect_error(prPrepareCss(mx, mx_cell.style, rnames = mx_rnames)) }) test_that("Test prAddSemicolon2StrEnd",{ test_str <- "background: white" expect_equal(prAddSemicolon2StrEnd(test_str), paste0(test_str, ";")) test_str <- c("", "", `background-color` = "none") expect_equivalent(prAddSemicolon2StrEnd(test_str), paste0(test_str[3], ";")) expect_equal(names(prAddSemicolon2StrEnd(test_str)), names(test_str[3])) }) test_that("Problem with naming in stringr 1.0.0", { style_bug <- structure(c("", "font-weight: 900;", "#f7f7f7"), .Names = c("", "", "background-color")) expect_false(is.null(names(prAddSemicolon2StrEnd(style_bug)))) expect_match(prGetStyle(style_bug), regexp = "^font-weight: 900; background-color: #f7f7f7") }) test_that("Handling data.frames with factors",{ tmp <- data.frame(a = 1:3, b = factor(x = 1:3, labels = c("Unique_Factor_1", "Factor_2", "Factor_3"))) str <- interactiveTable(tmp) expect_true(grepl("Unique_Factor_1", str)) tmp <- data.frame(a = 1, b = factor(x = 1, labels = c("1.2"))) expect_true(txtRound(tmp)$b == 1) }) test_that("Check Javascript string",{ js <- prGetScriptString(structure(1:3, javascript= c("a", "B"))) expect_gt(length(strsplit(js, "]*colspan='4'[^>]*>First spanner", info="The expected number of columns should be 4") expect_match(table_str, "td[^>]*colspan='4'[^>]*>Secon spanner", info="The expected number of columns should be 4") expect_error(htmlTable(mx, cgroup=c("a", "b"), n.cgroup=c(2, 1), tspanner=c("First spanner", "Secon spanner"), n.tspanner=c(1,2))) mx <- rbind(mx, mx, mx, mx) table_str <- htmlTable(mx, rnames = LETTERS[1:nrow(mx)], cgroup=rbind(c("aa", "bb"), c("a", "b")), n.cgroup=rbind(c(2, 1), c(1, 2)), rgroup=paste(1:4, "rgroup"), n.rgroup=rep(2, 4), tspanner=c("First tspanner", "Second tspanner"), n.tspanner=c(4,4)) expect_match(table_str, "td[^>]*colspan='6'[^>]*>1 rgroup", info="The expected number of columns should be 6") expect_match(table_str, "td[^>]*colspan='6'[^>]*>2 rgroup", info="The expected number of columns should be 6") parsed_table <- readHTMLTable(as.character(table_str))[[1]] expect_equal(as.character(parsed_table[1,1]), "First tspanner") expect_equal(as.character(parsed_table[2,1]), "1 rgroup") expect_equal(as.character(parsed_table[8,1]), "Second tspanner") expect_equal(as.character(parsed_table[9,1]), "3 rgroup") }) test_that("Flexible number of cgroups",{ mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) expect_error(htmlTable(mx, cgroup = c("", "__test__"), n.cgroup = 1:3)) expect_error(htmlTable(mx, cgroup = c("", "__test__", ""), n.cgroup = 1)) out <- htmlTable(mx, cgroup = c("", "__test__"), n.cgroup = 1) expect_match(out, "colspan='2'[^>]*>__test__<") }) test_that("Assume last element for n.cgroup",{ mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) out <- htmlTable(mx, cgroup = "__test__") expect_match(out, "colspan='3'[^>]*>__test__<") }) htmlTable/tests/testthat/test-htmlTable-dimnames.R0000644000176200001440000000502613407215301021776 0ustar liggesuserslibrary(testthat) context("htmlTable - dimnames") test_that("First dimname should be converted to rgroup, tspanner or rowlabel", { var1 <- LETTERS[1:3] var2 <- LETTERS[c(4:5, 5)] basic_label <- table(var1, var2) %>% htmlTable(css.rgroup = "background: blue") expect_match(basic_label, "]+background: blue[^>]+>var1", info = "Expect the variable name to appear as an rgroup") expect_match(basic_label, "]+>  A", info = "Expect the variable name to appear as an rgroup") expect_match(basic_label, "]+>  B", info = "Expect the variable name to appear as an rgroup") expect_match(basic_label, "]+>  C", info = "Expect the variable name to appear as an rgroup") tspanner_label <- table(var1, var2) %>% htmlTable(rgroup=c("alt"), n.rgroup=c(3), css.tspanner = "background: red", css.rgroup = "background: blue") expect_match(tspanner_label, "]+background: red[^>]+>var1", info = "Expect the variable name to appear as an tspanner") expect_match(tspanner_label, "]+background: blue[^>]+>alt", info = "Expect the rgroup name to appear as usual") expect_match(tspanner_label, "]+>  A") expect_match(tspanner_label, "]+>  B") expect_match(tspanner_label, "]+>  C") rowlabel_label <- table(var1, var2) %>% htmlTable(rgroup=c("alt"), n.rgroup=c(3), tspanner=c("alt2"), n.tspanner = c(3), css.tspanner = "background: red", css.rgroup = "background: blue") expect_match(rowlabel_label, "]+background: red[^>]+>alt2", info = "Expect the variable name to appear as an tspanner") expect_match(rowlabel_label, "]+background: blue[^>]+>alt", info = "Expect the rgroup name to appear as usual") expect_match(rowlabel_label, "]+>  A") expect_match(rowlabel_label, "]+>  B") expect_match(rowlabel_label, "]+>  C") }) test_that("Second dimname should be converted to cgroup", { var1 <- LETTERS[1:3] var2 <- LETTERS[c(4:5, 5)] basic_label <- table(var1, var2) %>% htmlTable expect_match(basic_label, "]+>var2", info = "Expect the variable name to appear as a cgroup") }) htmlTable/tests/testthat/test-htmlTable-input_checks.R0000644000176200001440000000045013407215301022654 0ustar liggesuserslibrary('testthat') library('magrittr', warn.conflicts = FALSE) library('XML', warn.conflicts = FALSE) context('htmlTable') # Check that a css.cell passes without errors test_that("Check inputs", { mx <- matrix(1:6, ncol=3) css.cell ="background: red" htmlTable(mx, css.cell=css.cell) }) htmlTable/tests/testthat/test-htmlTable.R0000644000176200001440000004345613541473554020233 0ustar liggesuserslibrary('testthat') library('XML') library('tibble') context('htmlTable') # A simple example test_that("With empty rownames(mx) it should skip those", { mx <- matrix(1:6, ncol=3) table_str <- htmlTable(mx) expect_false(grepl("", table_str)) expect_false(grepl("[^>]+>NA", table_str)) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) table_str <- htmlTable(mx) expect_true(grepl("", table_str)) expect_false(grepl("[^>]+>NA", table_str)) }) test_that("Empty cell names should be replaced with ''", { mx <- matrix(1:6, ncol=3) mx[1,1] <- NA table_str <- htmlTable(mx) expect_false(grepl("[^>]+>NA", table_str)) }) test_that("The variable name should not be in the tables first row if no rownames(mx)", { mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) table_str <- htmlTable(mx) expect_false(grepl("[^<]*[^>]+>mx", table_str)) }) test_that("A rowlabel without rownames indicates some kind of error and should throw an error", { mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) expect_error(htmlTable(mx, rowlabel="not_mx")) }) # Add rownames test_that("The rowname should appear", { mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) rownames(mx) <- LETTERS[1:NROW(mx)] table_str <- htmlTable(mx) parsed_table <- readHTMLTable(as.character(table_str))[[1]] expect_equal(ncol(parsed_table), ncol(mx) + 1) expect_match(table_str, "]*>[^>]+>A") expect_match(table_str, "]*>[^>]+>B") }) test_that("Check that basic output are the same as the provided matrix", { mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) table_str <- htmlTable(mx) parsed_table <- readHTMLTable(as.character(table_str))[[1]] expect_equal(ncol(parsed_table), ncol(mx), info="Cols did not match") expect_equal(nrow(parsed_table), nrow(mx), info="Rows did not match") expect_true(all(mx == parsed_table), info="Some cells don't match the inputted cells") }) test_that("rnames = FALSE it should skip those", { mx <- matrix(1:6, ncol=3) rownames(mx) <- c("Row A", "Row B") table_str <- htmlTable(mx, rnames = FALSE) expect_false(grepl("FALSE", table_str)) expect_false(grepl("Row A", table_str)) }) test_that("Test style formatter", { styles <- c(background = "black", border ="1px solid grey") expect_equivalent(length(prGetStyle(styles)), 1) expect_match(prGetStyle(styles), "background: black;") expect_match(prGetStyle(styles), "border: [^;]+grey;") expect_match(prGetStyle(styles), "border: [^;]+grey;") expect_match(prGetStyle(styles, a=2), "border: [^;]+grey;") expect_error(prGetStyle(styles, "invalid style")) expect_error(prGetStyle(styles, "invalid style:")) expect_error(prGetStyle(styles, ":invalid style")) expect_match(prGetStyle(styles, "valid: style"), "valid: style;") expect_match(prGetStyle(styles, c(valid= "style")), "valid: style;") expect_match(prGetStyle(styles, c(valid= "style", valid1= "style")), "valid: style; valid1: style;") expect_match(prGetStyle(styles, c(valid= "style1", valid= "style2")), "valid: style2;") expect_match(prGetStyle(styles, c(valid= "style1", valid= "style2"), "valid: style3"), "valid: style3;") }) test_that("Test align functions", { expect_equivalent(nchar(prPrepareAlign("lr", x = matrix(1, ncol=10))), 10) expect_equivalent(nchar(prPrepareAlign("lr", x = matrix(1, ncol=2))), 2) expect_equivalent(nchar(prPrepareAlign("lr", x = matrix(1, ncol=2), rnames = TRUE)), 3) expect_equivalent(nchar(prPrepareAlign("l", x = matrix(1, ncol=2), rnames = TRUE)), 3) expect_equivalent(nchar(prPrepareAlign("", x = matrix(1, ncol=2, nrow=2), rnames = TRUE)), 3) expect_equivalent(attr(prPrepareAlign("r|rlt|r|", x = matrix(1, ncol=2, nrow=2), rnames = TRUE), "n"), 3) expect_equivalent(attr(prPrepareAlign("r|rcl|lt|r|", x = matrix(1, ncol=5, nrow=2), rnames = TRUE), "n"), 6) expect_match(prPrepareAlign("r|rcl|lt|r|", x = matrix(1, ncol=5, nrow=2), rnames = TRUE), "^r") expect_match(prPrepareAlign("l|r|", x = matrix(1, ncol=3, nrow=2), rnames = TRUE), "^l|r|r|$") align_str <- prPrepareAlign("r|rcl|lt|r|", x = matrix(1, ncol=5, nrow=2), rnames = TRUE) expect_true("right" %in% prGetAlign(align_str, 1)) expect_true("right" %in% prGetAlign(align_str, 2)) expect_true("center" %in% prGetAlign(align_str, 3)) expect_true("left" %in% prGetAlign(align_str, 4)) expect_true("left" %in% prGetAlign(align_str, 5)) expect_true("right" %in% prGetAlign(align_str, 6)) expect_true("border-right" %in% names(prGetAlign(align_str, 1))) expect_true("border-right" %in% names(prGetAlign(align_str, 4))) expect_true("border-right" %in% names(prGetAlign(align_str, 5))) expect_true("border-right" %in% names(prGetAlign(align_str, 6))) expect_equivalent(length(prGetAlign(align_str, 1)), 2) expect_equivalent(length(prGetAlign(align_str, 2)), 1) expect_equivalent(length(prGetAlign(align_str, 6)), 2) align_str <- prPrepareAlign("|c|rc", x = matrix(1, ncol=2, nrow=2), rnames = TRUE) expect_true("border-right" %in% names(prGetAlign(align_str, 1))) expect_true("border-left" %in% names(prGetAlign(align_str, 1))) expect_true("center" %in% prGetAlign(align_str, 1)) mx <- matrix(1:6, ncol=3) rownames(mx) <- c("Row A", "Row B") table_str <- htmlTable(mx, rname = FALSE) expect_match(table_str, "text-align: center;[^>]*>1") expect_match(table_str, "text-align: center;[^>]*>3") expect_match(table_str, "text-align: center;[^>]*>5") table_str <- htmlTable(mx) expect_match(table_str, "text-align: left;[^>]*>Row A") expect_match(table_str, "text-align: center;[^>]*>1") expect_match(table_str, "text-align: center;[^>]*>3") expect_match(table_str, "text-align: center;[^>]*>5") table_str <- htmlTable(mx, align="r") expect_match(table_str, "text-align: left;[^>]*>Ro") expect_match(table_str, "text-align: right;[^>]*>1") expect_match(table_str, "text-align: right;[^>]*>3") expect_match(table_str, "text-align: right;[^>]*>5") table_str <- htmlTable(mx, align="|ll|r|r|") expect_match(table_str, "text-align: left;[^>]*>Ro") expect_match(table_str, "text-align: left;[^>]*>1") expect_match(table_str, "text-align: right;[^>]*>3") expect_match(table_str, "text-align: right;[^>]*>5") expect_match(table_str, "border-left:[^>]*>Ro") expect_match(table_str, "border-right:[^>]*>1") expect_match(table_str, "border-right:[^>]*>3") expect_match(table_str, "border-right:[^>]*>5") }) test_that("Check color function",{ expect_equivalent(prPrepareColors(c("white", "#444444"), 2), c("#ffffff", "#444444")) expect_equivalent(prPrepareColors(c("white", "#444444"), 3), c("#ffffff", "#444444", "#ffffff")) expect_equivalent(prPrepareColors(c("white", "#444"), 3), c("#ffffff", "#444444", "#ffffff")) expect_null(attr(prPrepareColors(c("white", "#444444"), 3), "groups")) expect_equivalent(attr(prPrepareColors(c("white", "#444444"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c")), "groups")[[1]], c("#ffffff", "#ffffff")) expect_equivalent(attr(prPrepareColors(c("white", "#444444"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c")), "groups")[[2]], c("#444444", "#444444", "#444444")) expect_equivalent(attr(prPrepareColors(c("white", "#444444"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c")), "groups")[[3]], c("#ffffff")) expect_equivalent(attr(prPrepareColors(c("white", "#444444", "none"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c")), "groups")[[3]], c("none")) expect_equivalent(attr(prPrepareColors(c("white", "none"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c")), "groups")[[2]], c("none", "none", "none")) ## Test the merge colors expect_equal(prMergeClr(c("white", "#444444")), colorRampPalette(c("#FFFFFF", "#444444"))(3)[2]) expect_equal(prMergeClr(c("red", "#444444")), colorRampPalette(c("red", "#444444"))(3)[2]) expect_equal(prMergeClr(c("#444444", "red")), colorRampPalette(c("red", "#444444"))(3)[2]) expect_equal(prMergeClr(c("#FFFFFF", "#FFFFFF", "#FFFFFF")), "#FFFFFF") expect_equal(prMergeClr(c("#FFFFFF", "#FFFFFF", "#000000", "#000000")), prMergeClr(c("#FFFFFF", "#000000"))) expect_equal(prMergeClr(c("#000000", "#FFFFFF", "#FFFFFF")), prMergeClr(c("#FFFFFF", "#FFFFFF", "#000000"))) expect_equal(prMergeClr(c("#000000", "#FFFFFF", "#000000")), prMergeClr(c("#FFFFFF", "#000000", "#FFFFFF"))) }) test_that("Test cell styles",{ mx <- matrix(1:3, nrow=2, ncol=3, byrow = TRUE) mx_head <- LETTERS[1:ncol(mx)] mx_rnames <- LETTERS[1:nrow(mx)] expect_equal(dim(prPrepareCss(mx, "")), dim(mx)) expect_equal(dim(prPrepareCss(mx, "", header = mx_head, rnames = mx_rnames)), dim(mx)) expect_equal(dim(prPrepareCss(mx, "", header = mx_head, rnames = mx_rnames)), dim(mx)) expect_equal(dim(prPrepareCss(mx, rep("", times=ncol(mx)))), dim(mx)) expect_error(prPrepareCss(mx, rep("", times=nrow(mx)))) mx_cell.style <- matrix(c("a", "b", "c", "d"), nrow=2, ncol=4, byrow = TRUE) expect_equal(prPrepareCss(mx, mx_cell.style, rnames = mx_rnames)[2,1], "b") expect_error(prPrepareCss(mx, mx_cell.style)) mx_cell.style <- matrix(c("a", "b", "c", "d"), nrow=3, ncol=4, byrow = TRUE) expect_equal(prPrepareCss(mx, mx_cell.style, header = mx_head, rnames = mx_rnames)[2,1], "b") expect_error(prPrepareCss(mx, mx_cell.style, rnames = mx_rnames)) }) test_that("Test prAddSemicolon2StrEnd",{ test_str <- "background: white" expect_equal(prAddSemicolon2StrEnd(test_str), paste0(test_str, ";")) test_str <- c("", "", `background-color` = "none") expect_equivalent(prAddSemicolon2StrEnd(test_str), paste0(test_str[3], ";")) expect_equal(names(prAddSemicolon2StrEnd(test_str)), names(test_str[3])) }) test_that("Problem with naming in stringr 1.0.0", { style_bug <- structure(c("", "font-weight: 900;", "#f7f7f7"), .Names = c("", "", "background-color")) expect_false(is.null(names(prAddSemicolon2StrEnd(style_bug)))) expect_match(prGetStyle(style_bug), regexp = "^font-weight: 900; background-color: #f7f7f7") }) test_that("Handling data.frames with factors",{ tmp <- data.frame(a = 1:3, b = factor(x = 1:3, labels = c("Unique_Factor_1", "Factor_2", "Factor_3"))) str <- htmlTable(tmp) expect_true(grepl("Unique_Factor_1", str)) tmp <- data.frame(a = 1, b = factor(x = 1, labels = c("1.2"))) expect_true(txtRound(tmp)$b == 1) }) context('htmlTable - empty table') test_that("has header elements", { empty_dataframe <- data.frame(a = numeric(), b = factor(levels = c("level one", "level two"))) expect_warning({ table_str <- htmlTable(empty_dataframe) }) expect_match(table_str, "[^<]*[^>]+>[^<]+[^>]+>a[^>]+>b[^<]+") expect_match(table_str, "[^<]+") expect_warning({ table_str <- htmlTable(empty_dataframe, rnames = TRUE, rowlabel = "Row number", cgroup = "Spanner", n.cgroup = 2, col.rgroup = c("white", "gray"), caption = "This is a caption", tfoot = "This is a footnote") }) expect_match(table_str, "[^<]*[^>]+>[^<]+[^>]+>a[^>]+>b[^<]+") expect_match(table_str, "[^<]+") expect_match(table_str, "]+>\\s*This is a footnote", perl=TRUE) expect_match(table_str, "]+>\\s*This is a caption", perl=TRUE) }) test_that("An empty dataframe returns an empty table with a warning", { empty_dataframe <- data.frame(a = numeric(), b = factor(levels = c("level one", "level two"))) expect_warning(htmlTable(empty_dataframe), regexp = "empty_dataframe") empty_matrix <- empty_dataframe %>% as.matrix() expect_warning(htmlTable(empty_matrix), regexp = "empty_matrix") expect_warning(htmlTable(empty_dataframe)) expect_warning(htmlTable(empty_dataframe, cgroup = "Spanner", n.cgroup = 2)) expect_warning(htmlTable(empty_dataframe, cgroup = "Spanner", n.cgroup = 2, caption = "Caption", tfoot = "Footnote")) expect_warning(htmlTable(empty_dataframe, col.rgroup = c("white", "gray"))) expect_warning(htmlTable(empty_dataframe, rnames = TRUE, rowlabel = "Row number", cgroup = "Spanner", n.cgroup = 2, col.rgroup = c("white", "gray"))) expect_warning(htmlTable(empty_dataframe, rnames = TRUE, rowlabel = "Row number", cgroup = "Spanner", n.cgroup = 2, col.rgroup = c("white", "gray"), caption = "This is a caption", tfoot = "This is a footnote")) }) test_that("HTML code is properly escaped", { expect_match( object = htmlTable(data.frame(a = "<3"), rnames = FALSE, escape.html = TRUE), regexp = "<3") df_test <- data.frame(a = c("<3", "<3"), b = c("&2", ">2"), stringsAsFactors = FALSE) matrix_test <- as.matrix(df_test, ncol = 2) expect_identical(htmlTable(df_test, rnames = FALSE, escape.html = TRUE), structure("\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n
ab
<3&2
<3>2
", class = c("htmlTable","character"), ... = list())) expect_identical(htmlTable(matrix_test, rnames = FALSE, escape.html = TRUE), structure("\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n
ab
<3&2
<3>2
", class = c("htmlTable","character"), ... = list())) tibble_test <- as.tibble(df_test) expect_identical(htmlTable(tibble_test, rnames = FALSE, escape.html = TRUE), structure("\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n
ab
<3&2
<3>2
", class = c("htmlTable","character"), ... = list())) expect_equal(prEscapeHtml("$")[[1]], "$") }) htmlTable/tests/testthat/test-htmlTable_styles.R0000644000176200001440000000321113407215301021600 0ustar liggesuserslibrary(testthat) library(XML) context("htmlTable - styles check") test_that("Check that row styles are present",{ mx <- matrix(ncol=6, nrow=8) rownames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:8, "th")), "row") colnames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:6, "th")), "hdr") for (nr in 1:nrow(mx)){ for (nc in 1:ncol(mx)){ mx[nr, nc] <- paste0(nr, ":", nc) } } css.cell = rep("font-size: 1em", times = ncol(mx) + 1) css.cell[1] = "font-size: 2em" out <- htmlTable(mx, css.cell=css.cell, cgroup = c("Cgroup 1", "Cgroup 2"), n.cgroup = c(2,4)) for (n in rownames(mx)) { expect_match(out, sprintf("\n[^<]*]+>%s", n)) } for (nr in 1:nrow(mx)){ for (nc in 1:ncol(mx)){ expect_match(out, sprintf("\n[^<]*]+>%s", mx[nr, nc]) ) } } }) test_that("Check prPrepareCss",{ mx <- matrix(1:5, ncol=5, nrow=1) rownames(mx) <- "1st" colnames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:ncol(mx), "th")), "hdr") css.cell = rep("font-size: 1em", times = ncol(mx) + 1) css.cell[1] = "font-size: 2em" out <- prPrepareCss(mx, css = css.cell, header = names(mx), rnames = rownames(mx)) expect_equal(dim(out), dim(mx)) css.cell = matrix("padding-left: .5em;", nrow = nrow(mx) + 1, ncol = ncol(mx)) out <- prPrepareCss(mx, css = css.cell, header=names(mx), rnames = rownames(mx)) expect_equal(dim(out), dim(mx)) }) htmlTable/tests/testthat/test-htmlTable_dates.R0000644000176200001440000000562313541427252021377 0ustar liggesusersrequire(testthat) require(lubridate, quietly = TRUE, warn.conflicts = FALSE) require(htmlTable, quietly = TRUE, warn.conflicts = FALSE) require(chron, quietly = TRUE, warn.conflicts = FALSE) context('dates within htmlTable') # A simple example test_that("should be converted into strings", { # Below example is created using lemna's example: # library(lubridate) # library(chron) # df_dates <- data.frame(ID = 1:3, # contact_Date = c(today(), # today() - 1, # today() - 2)) # # df_dates$contact_posix <- strptime(as.POSIXct(df_dates$contact_Date), # format = "%Y-%m-%d") # df_dates$contact_chron <- chron(as.character(df_dates$contact_Date), # format = "Y-m-d", # out.format = "Y-m-d") df_dates <-structure(list(contact_Date = structure(c(17092, 17091, 17090), class = "Date"), contact_posix = structure(list(sec = c(0, 0, 0), min = c(0L, 0L, 0L), hour = c(0L, 0L, 0L), mday = c(18L, 17L, 16L), mon = c(9L, 9L, 9L), year = c(116L, 116L, 116L), wday = c(2L, 1L, 0L), yday = c(291L, 290L, 289L), isdst = c(1L, 1L, 1L), zone = c("CEST", "CEST", "CEST"), gmtoff = c(NA_integer_, NA_integer_, NA_integer_)), .Names = c("sec", "min", "hour", "mday", "mon", "year", "wday", "yday", "isdst", "zone", "gmtoff"), class = c("POSIXlt", "POSIXt")), contact_chron = structure(c(17092, 17091, 17090), format = "Y-m-d", origin = structure(c(1, 1, 1970), .Names = c("month", "day", "year")), class = c("dates", "times"))), .Names = c("contact_Date", "contact_posix", "contact_chron"), row.names = c(NA, -3L), class = "data.frame") table_str <- htmlTable(df_dates, rnames = FALSE) expect_match(table_str, "[^<]+]+>2016-10-16[^<]+]+>2016-10-16[^<]+]+>(20|)16-10-16") })htmlTable/tests/testthat/test-htmlTable_rgroup_tspanner.R0000644000176200001440000002140213407215301023507 0ustar liggesuserslibrary(testthat) library(XML) context("htmlTable - the rgroup argument") test_that("Check that rgroup has the appropriate padding", { mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) rownames(mx) <- sprintf("Row %s", LETTERS[1:NROW(mx)]) out <- htmlTable(mx, rgroup = paste("rgroup", 1:2), n.rgroup = rep(1, 2)) expect_match(out, "]*>]*>rgroup 1") expect_match(out, "]*>[^<]*]*>  Row A") expect_match(out, "]*>]*>rgroup 2") expect_match(out, "]*>[^<]*]*>  Row B") out <- htmlTable(mx, rgroup = paste("rgroup", 1:2), n.rgroup = rep(1, 2), padding.rgroup = "ll") expect_match(out, "]*>]*>rgroup 1") expect_match(out, "]*>[^<]*]*>llRow A") out <- htmlTable(mx, rgroup = paste("rgroup", 1:2), n.rgroup = rep(1, 2), tspanner = paste("tspanner", 1:2), n.tspanner = rep(1, 2), padding.tspanner = "ii", padding.rgroup = "ll") expect_match(out, "]*>]*>iirgroup 1") expect_match(out, "]*>[^<]*]*>iillRow A") }) test_that("Check that dimensions are correct with rgroup usage", { mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) table_str <- suppressWarnings(htmlTable(mx, rgroup=c("test1", "test2"), n.rgroup=c(1,1))) parsed_table <- readHTMLTable(as.character(table_str))[[1]] expect_equal(ncol(parsed_table), ncol(mx), info="Cols did not match") expect_equal(nrow(parsed_table), nrow(mx) + 2, info="Rows did not match") expect_equal(as.character(parsed_table[1,1]), "test1", info="The rgroup did not match") expect_equal(as.character(parsed_table[3,1]), "test2", info="The rgroup did not match") expect_equal(as.character(parsed_table[2,1]), as.character(mx[1,1]), info="The row values did not match") expect_equal(as.character(parsed_table[4,1]), as.character(mx[2,1]), info="The row values did not match") expect_warning(htmlTable(mx, rgroup=c("test1", "test2", "test3"), n.rgroup=c(1,1, 0))) expect_error(suppressWarnings(htmlTable(mx, roup=c("test1", "test2", "test3"), rgroup=c(1,1, 10)))) mx[2,1] <- "second row" table_str <- htmlTable(mx, rnames=letters[1:2], rgroup=c("test1", ""), n.rgroup=c(1,1)) expect_match(table_str, "]*>second row", info="The second row should not have any spacers") parsed_table <- readHTMLTable(as.character(table_str))[[1]] expect_equal(nrow(parsed_table), nrow(mx) + 1, info="Rows did not match") }) test_that("Check rgroup attribute",{ mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) rownames(mx) <- sprintf("Row %s", LETTERS[1:NROW(mx)]) rgroup <- paste("rgroup", 1:2) attr(rgroup, "add") <- "test" expect_error(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2))) attr(rgroup, "add") <- c("test 1", "test 2") expect_match(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)), "]+colspan[ ]*=[ ]*'3'[^>]+>rgroup 1[^<]*]*>test 1") expect_match(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)), "]+colspan[ ]*=[ ]*'3'[^>]+>rgroup 1[^<]*]*>test 1") attr(rgroup, "add") <- c(`1` = "test c") expect_match(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)), "]+colspan[ ]*=[ ]*'3'[^>]+>rgroup 1[^<]*]*>test c") expect_match(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2), css.rgroup = ""), "]+colspan[ ]*=[ ]*'3'[^>]+>rgroup 1[^<]*]*>test c") attr(rgroup, "add") <- list(`2` = "test d") expect_match(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)), "]+colspan[ ]*=[ ]*'3'[^>]+>rgroup 2[^<]*]*>test d") attr(rgroup, "add") <- list(`1` = list(`2` = "test d")) expect_match(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)), "]+colspan[ ]*=[ ]*'2'[^>]+>rgroup 1[^<]*]*>test d") attr(rgroup, "add") <- list(`1` = list(`2` = "test d", `3` = "test e")) expect_match(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)), "]+colspan[ ]*=[ ]*'2'[^>]+>rgroup 1[^<]*]*>test d[^<]*]*>test e") attr(rgroup, "add") <- list(`1` = list(`44` = "test d")) expect_error(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2))) attr(rgroup, "add") <- list(`1` = list(`asda` = "test d")) expect_error(suppressWarnings(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)))) attr(rgroup, "add") <- list(`1` = list(`-23` = "test d")) expect_error(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2))) attr(rgroup, "add") <- list(`-1` = list(`3` = "test d")) expect_error(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2))) attr(rgroup, "add") <- list(`23` = list(`3` = "test d")) expect_error(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2))) rgroup[2] <- "" attr(rgroup, "add") <- list(`2` = "test d") expect_error(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2))) attr(rgroup, "add") <- list("test d") expect_match(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)), "test d") attr(rgroup, "add") <- list("test d", "test e") expect_error(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2))) }) test_that("Check rgroup attribute without CSS",{ mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) rownames(mx) <- sprintf("Row %s", LETTERS[1:NROW(mx)]) rgroup <- paste("rgroup", 1:2) attr(rgroup, "add") <- list(`1` = "test d") expect_match(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2), css.rgroup = ""), "]+>rgroup 1[^<]*]*>test d") }) test_that("Check rgroup attribute with matrix",{ mx <- matrix(1:6, ncol=2) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) rownames(mx) <- sprintf("Row %s", LETTERS[1:NROW(mx)]) rgroup <- c(paste("rgroup", 1:2), "") attr(rgroup, "add") <- matrix(c("test a", "test b"), ncol = 1) out <- htmlTable(mx, rgroup = rgroup, n.rgroup = c(1, 1), css.rgroup = "") expect_match(out, "]+>rgroup 1[^<]*]*>test a") expect_match(out, "]+>rgroup 2[^<]*]*>test b") rgroup <- c(paste("rgroup", 1:2), "") add_mtrx <- matrix(1:4, ncol = 2) attr(rgroup, "add") <- add_mtrx out <- htmlTable(mx, rgroup = rgroup, n.rgroup = c(1, 1), css.rgroup = "") expect_match(out, paste0("]+>rgroup 1", paste(sprintf("[^<]*]*>%d", add_mtrx[1,]), collapse = ""), "[^<]*]+>rgroup 2", paste(sprintf("[^<]*]*>%d", add_mtrx[2,]), collapse = ""), "[^<]*]+>rgroup 2", paste(sprintf("[^<]*]*>%d", add_mtrx[1,]), collapse = ""), "[^<]*]+>rgroup 1", "[^<]*", out)[[1]]), 1) out <- txtMergeLines("a b c") expect_equal(length(gregexpr("
", out)[[1]]), 2) }) test_that("Check multiple arguments",{ out <- txtMergeLines("a", "b") expect_equal(length(gregexpr("
", out)[[1]]), 1) out <- txtMergeLines("a", "b", "c") expect_equal(length(gregexpr("
", out)[[1]]), 2) })htmlTable/tests/testInteractive.R0000644000176200001440000000210113407215301016616 0ustar liggesuserslibrary(htmlTable) interactiveTable(matrix(c("asdsadadadas", "DSASDS asd as dasd ad ads dasd dsa ADSADASDASD"), ncol = 2), minimized.columns = 2) interactiveTable(matrix(c("asdsadadadas", "DSASDS asd as dasd ad ads dasd dsa ADSADASDASD"), ncol = 2, nrow = 10), minimized.columns = 2, button = TRUE) knitr::knit_print(interactiveTable(matrix(c("asdsadadadas", "DSASDS asd as dasd ad ads dasd dsa ADSADASDASD"), ncol = 2, nrow = 10), minimized.columns = 2)) htmlTable:::print.interactiveTable( interactiveTable(matrix(c("asdsadadadas", "DSASDS asd as dasd ad ads dasd dsa ADSADASDASD"), ncol = 2, nrow = 10), minimized.columns = 2, button = TRUE)) htmlTable/tests/visual_tests/0000755000176200001440000000000013414117305016054 5ustar liggesusershtmlTable/tests/visual_tests/htmlTable_vtests.R0000644000176200001440000001143113414126420021521 0ustar liggesusersmx <- matrix(1:6, ncol=3) colnames(mx) <- c("A", "B", "C") rownames(mx) <- letters[1:2] ## col.rgroup does not break css.group htmlTable(mx, n.rgroup=c(2), rgroup=c("Nice!"), n.cgroup=c(2,1), cgroup=c("First", "Second"), css.group = "font-weight:900; background-color:#f2f2f2;") colnames(mx) <- NULL htmlTable(mx) htmlTable(mx[1,,drop=FALSE]) htmlTable(mx, n.rgroup=2, rgroup="A") htmlTable(mx, tspanner = "AA", n.tspanner = 2, n.rgroup=2, rgroup="A") htmlTable(mx, tspanner = "AA", n.tspanner = 2, padding.tspanner = "  ", n.rgroup=2, rgroup="A") htmlTable(mx, tspanner = "AA", n.tspanner = 2) htmlTable(mx, n.rgroup=2, rgroup="A", padding.rgroup = "") # This will cause the table to look strange # but forcing >/< is a bigger constraint # that may be undesirable for more advanced users. mx[1,1] <- "< = <" mx[1,2] <- "22" mx[1,3] <- "3" mx[2,1] <- "" htmlTable(mx) mx <- matrix(1:9, ncol=3) colnames(mx) <- LETTERS[1:3] rownames(mx) <- letters[1:3] mx_3_times <- rbind(mx, mx, mx) htmlTable(mx_3_times, css.tspanner.sep="border-top: 2px solid red;", rgroup = rep(c("Group a", "Group b and c"), times=3), n.rgroup = rep(c(1,2), times=3), tspanner=c("First", "Second", "Third"), n.tspanner=rep(nrow(mx), times=3), rowlabel = '', col.rgroup = c('white','lightblue1'), tfoot = "Some footer text", caption="Caption text") htmlTable(mx_3_times, css.tspanner.sep=c("border-top: 2px solid red;", "border-top: 2px solid blue;"), rgroup = rep(c("Group a", "Group b and c"), times=3), n.rgroup = rep(c(1,2), times=3), tspanner=c("First", "Second", "Third"), n.tspanner=rep(nrow(mx), times=3), rowlabel = '', col.rgroup = c('white','lightblue1'), tfoot = "Some footer text", caption="Caption text") htmlTable(mx_3_times, css.tspanner.sep=c("border-top: 2px solid red;", "border-top: 2px solid blue;"), rgroup = rep(c("Group a", "Group b and c"), times=3), n.rgroup = rep(c(1,2), times=3), tspanner=c("First", "Second", "Third"), n.tspanner=rep(nrow(mx), times=3), rowlabel = '', col.rgroup = c('white','lightblue1'), col.columns = c('none','#CCCCCC'), tfoot = "Some footer text", caption="Caption text") htmlTable(mx_3_times, css.tspanner.sep=c("border-top: 2px solid red;", "border-top: 12px solid blue;"), rgroup = rep(c("Group a", "Group b and c"), times=3), n.rgroup = rep(c(1,2), times=3), tspanner=c("First", "Second", "Third"), n.tspanner=rep(nrow(mx), times=3), rowlabel = '', tfoot = "Some footer text", caption="Caption text") htmlTable(mx_3_times, css.tspanner = "color: purple; font-weight: bold;", css.tspanner.sep="border-top: 2px solid red;", rgroup = rep(c("Group a", "Group b and c"), times=3), n.rgroup = rep(c(1,2), times=3), tspanner=c("First", "Second", "Third"), n.tspanner=rep(nrow(mx), times=3), rowlabel = '', tfoot = "Some footer text", caption="Caption text") htmlTable(mx_3_times, padding.tspanner="+", padding.rgroup="-", css.tspanner = "color: purple; font-weight: bold;", css.tspanner.sep="border-top: 2px solid red;", rgroup = rep(c("Group a", "Group b and c"), times=3), n.rgroup = rep(c(1,2), times=3), tspanner=c("First", "Second", "Third"), n.tspanner=rep(nrow(mx), times=3), rowlabel = '', tfoot = "† Some footnote ‡ Another footnote", caption="Caption text") rbind( `Group A` = c(20, 380), `Group B` = c(110, 1230), `Group C` = c(2, 56), `Group D` = c(17, 33), `Group A` = c(40, 360), `Group B` = c(230, 1100), `Group C` = c(8, 50), `Group D` = c(10, 40) ) %>% apply(1, function(x) { sapply(x, function(count) c( txtInt(count), sprintf("(%s)", txtRound(count/sum(x) * 100, 1)))) %>% c(txtInt(sum(x)), .) }) %>% t %>% htmlTable(header = c("Total", rep(c("No", "(%)"), times = 2)), n.cgroup=list(c(1,2,2)), cgroup=list(c("", "Cases", "Controls")), rgroup = rep(c("Aspirin", "Intermittent compression"), times = 2), n.rgroup = rep(2, times = 4), tspanner = c("First experiment", "Second experiment"), n.tspanner = c(2), align = "r", caption = "Extremely fake data") htmlTable/tests/visual_tests/word_test.Rmd0000644000176200001440000000657013407215301020537 0ustar liggesusers--- title: "Pandoc test" output: html_document --- ```{r echo=FALSE} knitr::opts_chunk$set(echo = FALSE, message=FALSE, warning=FALSE) ``` ```{r} library(htmlTable) mx <- matrix(1:6, ncol=3) htmlTable(mx, 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.", 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?") set.seed(1) mx <- matrix(runif(3*10)*10, ncol=3) colnames(mx) <- LETTERS[1:3] rownames(mx) <- LETTERS[1:10] library(magrittr) txtRound(mx, 3) %>% htmlTable( align = "clr", 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.", 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?") htmlTable(mx, rgroup = c("Lorem", "ipsum", "dolor"), n.rgroup = c(2, 3), cgroup = c("", "Test"), n.cgroup = 1, align = "llr", caption = "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua.") ``` htmlTable/tests/visual_tests/pandoc_test.Rmd0000644000176200001440000000141713407215301021023 0ustar liggesusers--- title: "Pandoc test" output: html_document --- ```{r} library(htmlTable) mx <- matrix(1, ncol=1) colnames(mx) <- c("A") rownames(mx) <- letters[1] htmlTable(mx) ``` ```{r} 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" colnames(mx) <- c("A") rownames(mx) <- letters[1] interactiveTable(mx) ``` ```{r} mx <- matrix(rep(mx, 6), ncol = 2) interactiveTable(mx) ``` htmlTable/tests/testthat.R0000644000176200001440000000005513407215301015307 0ustar liggesuserslibrary('testthat') test_check('htmlTable') htmlTable/vignettes/0000755000176200001440000000000013572025026014200 5ustar liggesusershtmlTable/vignettes/tidyHtmlTable.Rmd0000644000176200001440000000443513407215301017412 0ustar liggesusers--- title: "Using tidyHtmlTable" author: "Stephen Gragg" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Using tidyHtmlTable} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- # Introduction `tidyHtmlTable` acts as a wrapper function for the `htmlTable` function allowing columns to be mapped from the input data to specific htmlTable parameters in a manner similar to ggplot2. # Some Examples ## Prepare Data We'll begin by turning the `mtcars` data into a tidy dataset. The `gather` function is called to collect 3 performance metrics into a pair of key and value columns. ```{r, message=FALSE} library(magrittr) library(tidyr) library(dplyr) library(htmlTable) library(tibble) td <- mtcars %>% rownames_to_column %>% select(rowname, cyl, gear, hp, mpg, qsec) %>% gather(per_metric, value, hp, mpg, qsec) ``` Now we will compute 4 summary statistics for each of the 3 performance metrics. This will be further grouped by number of cylinders and gears. ```{r} tidy_summary <- td %>% group_by(cyl, gear, per_metric) %>% summarise(Mean = round(mean(value), 1), SD = round(sd(value), 1), Min = round(min(value), 1), Max = round(max(value), 1)) %>% gather(summary_stat, value, Mean, SD, Min, Max) %>% ungroup %>% mutate(gear = paste(gear, "Gears"), cyl = paste(cyl, "Cylinders")) ``` At this point, we are ready to implement the `htmlTable` function. Essentially, this constructs an html table using arguments similar to the `htmlTable` function. However, whereas `htmlTable` required the user to manually arrange the data and specify the column groups, headers, row names, row-groups, etc., each of these components of the table is mapped to a column within the input data. ## Output html table ### Example 1 ```{r} tidy_summary %>% tidyHtmlTable(header = "gear", cgroup1 = "cyl", cell_value = "value", rnames = "summary_stat", rgroup = "per_metric") ``` ### Example 2 ```{r} tidy_summary %>% tidyHtmlTable(header = "summary_stat", cgroup1 = "per_metric", cell_value = "value", rnames = "gear", rgroup = "cyl") ``` htmlTable/vignettes/tables.Rmd0000644000176200001440000003752313407215301016122 0ustar liggesusers--- title: "Tables with htmlTable and some alternatives" author: "Max Gordon" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: toc: true css: custom.css vignette: > %\VignetteIndexEntry{Tables with htmlTable and some alternatives} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- Introduction ============ Tables are an essential part of publishing, well... anything. I therefore want to explore the options available for generating these in markdown. It is important to remember that there are two ways of generating tables in markdown: 1. Markdown tables 2. HTML tables As the `htmlTable`-package is all about [HTML](http://en.wikipedia.org/wiki/HTML) tables we will start with these. HTML tables =========== Tables are possibly the most tested HTML-element out there. In early web design this was the only feature that browsers handled uniformly, and therefore became the standard way of doing layout for a long period. HTML-tables are thereby an excellent template for generating advanced tables in statistics. There are currently a few different implementations that I've encountered, the **xtable**, **ztable**, the **format.tables**, and my own **htmlTable** function. The `format.tables` is unfortunately not yet on CRAN and will not be part of this vignette due to CRAN rules. If you are interested you can find it [here](https://github.com/SwedishPensionsAgency/format.tables). The `htmlTable`-package -------------------------------------- I developed the `htmlTable` in order to get tables matching those available in top medical journals. After finding no HTML-alternative to the `Hmisc::latex` function on [Stack Overflow](http://stackoverflow.com/questions/11950703/html-with-multicolumn-table-in-markdown-using-knitr) I wrote a basic function allowing column spanners and row groups. Below is a basic example on these two: ```{r} output <- matrix(paste("Content", LETTERS[1:16]), ncol=4, byrow = TRUE) library(htmlTable) htmlTable(output, header = paste(c("1st", "2nd", "3rd", "4th"), "header"), rnames = paste(c("1st", "2nd", "3rd", "4th"), "row"), rgroup = c("Group A", "Group B"), n.rgroup = c(2,2), cgroup = c("Cgroup 1", "Cgroup 2†"), n.cgroup = c(2,2), caption="Basic table with both column spanners (groups) and row groups", tfoot="† A table footer commment") ``` ### Example based upon Swedish statistics In order to make a more interesting example we will try to look at how the average age changes between Swedish counties the last 15 years. **Goal: visualize migration patterns**. The dataset has been downloaded from Statistics Sweden and is attached to the htmlTable-package. We will start by reshaping our tidy dataset into a more table adapted format. ```{r, results='markup'} data(SCB) # The SCB has three other coulmns and one value column library(reshape) SCB$region <- relevel(SCB$region, "Sweden") SCB <- cast(SCB, year ~ region + sex, value = "values") # Set rownames to be year rownames(SCB) <- SCB$year SCB$year <- NULL # The dataset now has the rows names(SCB) # and the dimensions dim(SCB) ``` The next step is to calculate two new columns: * Δint = The change within each group since the start of the observation. * Δstd = The change in relation to the overall age change in Sweden. To convey all these layers of information will create a table with multiple levels of column spanners:
County
Men   Women
AgeΔint.Δext.   AgeΔint.Δext.
```{r} mx <- NULL for (n in names(SCB)){ tmp <- paste0("Sweden_", strsplit(n, "_")[[1]][2]) mx <- cbind(mx, cbind(SCB[[n]], SCB[[n]] - SCB[[n]][1], SCB[[n]] - SCB[[tmp]])) } rownames(mx) <- rownames(SCB) colnames(mx) <- rep(c("Age", "Δint", "Δstd"), times = ncol(SCB)) mx <- mx[,c(-3, -6)] # This automated generation of cgroup elements is # somewhat of an overkill cgroup <- unique(sapply(names(SCB), function(x) strsplit(x, "_")[[1]][1], USE.NAMES = FALSE)) n.cgroup <- sapply(cgroup, function(x) sum(grepl(paste0("^", x), names(SCB))), USE.NAMES = FALSE)*3 n.cgroup[cgroup == "Sweden"] <- n.cgroup[cgroup == "Sweden"] - 2 cgroup <- rbind(c(cgroup, rep(NA, ncol(SCB) - length(cgroup))), Hmisc::capitalize( sapply(names(SCB), function(x) strsplit(x, "_")[[1]][2], USE.NAMES = FALSE))) n.cgroup <- rbind(c(n.cgroup, rep(NA, ncol(SCB) - length(n.cgroup))), c(2,2, rep(3, ncol(cgroup) - 2))) print(cgroup) print(n.cgroup) ``` Next step is to output the table after rounding to the correct number of decimals. The `txtRound` function helps with this, as it uses the `sprintf` function instead of the `round` the resulting strings have the correct number of decimals, i.e. 1.02 will by round become 1 while we want it to retain the last decimal, i.e. be shown as 1.0. ```{r} htmlTable(txtRound(mx, 1), cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("First period", "Second period", "Third period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average")) ``` In order to increase the readability we may want to separate the Sweden columns from the county columns, one way is to use the align option with a |. Note that in 1.0 the function continues with the same alignment until the end, i.e. you no longer need count to have the exact right number of columns in your alignment argument. ```{r} htmlTable(txtRound(mx, 1), align="rrrr|r", cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("First period", "Second period", "Third period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average")) ``` If we still feel that we want more separation it is always possible to add colors. ```{r} htmlTable(txtRound(mx, 1), col.columns = c(rep("#E6E6F0", 4), rep("none", ncol(mx) - 4)), align="rrrr|r", cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("First period", "Second period", "Third period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average")) ``` If we add a color to the row group and restrict the rgroup spanner we may even have a more visual aid. ```{r} htmlTable(txtRound(mx, 1), col.rgroup = c("none", "#FFFFCC"), col.columns = c(rep("#EFEFF0", 4), rep("none", ncol(mx) - 4)), align="rrrr|r", cgroup = cgroup, n.cgroup = n.cgroup, # I use the   - the no breaking space as I don't want to have a # row break in the row group. This adds a little space in the table # when used together with the cspan.rgroup=1. rgroup = c("1st period", "2nd period", "3rd period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average"), cspan.rgroup = 1) ``` If you want to further add to the visual hints you can use specific HTML-code and insert it into the cells. Here we will color the Δstd according to color. By default htmlTable does not escape HTML characters. ```{r} cols_2_clr <- grep("Δstd", colnames(mx)) # We need a copy as the formatting causes the matrix to loos # its numerical property out_mx <- txtRound(mx, 1) min_delta <- min(mx[,cols_2_clr]) span_delta <- max(mx[,cols_2_clr]) - min(mx[,cols_2_clr]) for (col in cols_2_clr){ out_mx[, col] <- mapply(function(val, strength) paste0("", val, ""), val = out_mx[,col], strength = round((mx[,col] - min_delta)/span_delta*100 + 1), USE.NAMES = FALSE) } htmlTable(out_mx, caption = "Average age in Sweden counties over a period of 15 years. The Norbotten county is typically known for having a negative migration pattern compared to Stockholm, while Uppsala has a proportionally large population of students.", pos.rowlabel = "bottom", rowlabel="Year", col.rgroup = c("none", "#FFFFCC"), col.columns = c(rep("#EFEFF0", 4), rep("none", ncol(mx) - 4)), align="rrrr|r", cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("1st period", "2nd period", "3rd period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint corresponds to the change since start", "Δstd corresponds to the change compared to national average"), cspan.rgroup = 1) ``` Although a graph most likely does the visualization task better, tables are good at conveying detailed information. It is in my mind without doubt easier in the latest version to find the pattern in the data. Lastly I would like to thank [Stephen Few](http://www.amazon.com/Show-Me-Numbers-Designing-Enlighten/dp/0970601999), [ThinkUI](http://www.thinkui.co.uk/resources/effective-design-of-data-tables/), [ACAPS](https://www.acaps.org/sites/acaps/files/resources/files/table_design_september_2012.pdf), and [LabWrite](http://www.ncsu.edu/labwrite/res/gh/gh-tables.html) for inspiration. Other alternatives ------------------ ### The `ztable`-package A promising and interesting alternative package is the `ztable` package. The package can also export to LaTeX and if you need this functionality it may be a good choice. The grouping for columns is currently (version 0.1.5) not working entirely as expected and the html-code does not fully validate, but the package is under active development and will hopefully soon be a fully functional alternative. ```{r, message=FALSE, results='asis'} library(ztable) options(ztable.type="html") zt <- ztable(out_mx, caption = "Average age in Sweden counties over a period of 15 years. The Norbotten county is typically known for having a negative migration pattern compared to Stockholm, while Uppsala has a proportionally large population of students.", zebra.type = 1, zebra = "peach", align=paste(rep("r", ncol(out_mx) + 1), collapse = "")) # zt <- addcgroup(zt, # cgroup = cgroup, # n.cgroup = n.cgroup) # Causes an error: # Error in if (result <= length(vlines)) { : zt <- addrgroup(zt, rgroup = c("1st period", "2nd period", "3rd period"), n.rgroup = rep(5, 3)) print(zt) ``` ### The `xtable`-package The `xtable` is a solution that delivers both HTML and LaTeX. The syntax is very similar to `kable`: ```{r, results='asis'} output <- matrix(sprintf("Content %s", LETTERS[1:4]), ncol=2, byrow=TRUE) colnames(output) <- c("1st header", "2nd header") rownames(output) <- c("1st row", "2nd row") library(xtable) print(xtable(output, caption="A test table", align = c("l", "c", "r")), type="html") ``` The downside with the function is that you need to change output depending on your target and there is not that much advantage compared to `kable`. Markdown tables =============== Raw tables ---------- A markdown table is fairly straight forward and are simple to manually create. Just write the plain text below:
1st Header  | 2nd Header
----------- | -------------
Content A   | Content B
Content C   | Content D
And you will end up with this beauty: 1st Header | 2nd Header ----------- | ------------- Content A | Content B Content C | Content D The `knitr::kable` function --------------------------- Now this is not the R way, we want to use a function that does this. The **knitr** comes with a table function well suited for this, **kable**: ```{r} library(knitr) kable(output, caption="A test table", align = c("c", "r")) ``` The advantage with the `kable` function is that it outputs true markdown tables and these can through the [pandoc](http://johnmacfarlane.net/pandoc/README.html#tables) system be converted to any document format. Some of the downsides are: * Lack of adding row groups and column groups * No control over cell formatting * No control over borders * ... The `pander::pandoc.table` function ----------------------------------- Another option is to use the pander function that can help with text-formatting inside a markdown-compatible table (Thanks Gergely Daróczi for the tip). Here's a simple example: ```{r, results='asis'} library(pander) pandoc.table(output, emphasize.rows = 1, emphasize.strong.cols = 2) ``` More *raw* markdown tables -------------------------- There are a few more text alternatives available when designing tables. I included these from the manual for completeness.
| Right | Left | Default | Center |
|------:|:-----|---------|:------:|
|   12  |  12  |    12   |    12  |
|  123  |  123 |   123   |   123  |
|    1  |    1 |     1   |     1  |

: Demonstration of pipe table syntax.
| Right | Left | Default | Center | |------:|:-----|---------|:------:| | 12 | 12 | 12 | 12 | | 123 | 123 | 123 | 123 | | 1 | 1 | 1 | 1 | : Demonstration of pipe table syntax.
: Sample grid table.

+---------------+---------------+--------------------+
| Fruit         | Price         | Advantages         |
+===============+===============+====================+
| Bananas       | $1.34         | - built-in wrapper |
|               |               | - bright color     |
+---------------+---------------+--------------------+
| Oranges       | $2.10         | - cures scurvy     |
|               |               | - tasty            |
+---------------+---------------+--------------------+
: Sample grid table. +---------------+---------------+--------------------+ | Fruit | Price | Advantages | +===============+===============+====================+ | Bananas | $1.34 | - built-in wrapper | | | | - bright color | +---------------+---------------+--------------------+ | Oranges | $2.10 | - cures scurvy | | | | - tasty | +---------------+---------------+--------------------+htmlTable/vignettes/general.Rmd0000644000176200001440000002445413414117305016267 0ustar liggesusers--- title: "The htmlTable package" author: "Max Gordon" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: css: custom.css keep_md: true toc: true vignette: > %\VignetteIndexEntry{How-to use htmlTable} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- Basics ====== The **htmlTable** package is intended for generating tables using [HTML](http://en.wikipedia.org/wiki/HTML) formatting. This format is compatible with [Markdown](http://rmarkdown.rstudio.com/) when used for HTML-output. The most basic table can easily be created by just passing a `matrix` or a `data.frame` to the `htmlTable`-function: ```{r} library(htmlTable) library(magrittr) # A simple output matrix(1:4, ncol=2, dimnames = list(c("Row 1", "Row 2"), c("Column 1", "Column 2"))) %>% htmlTable ``` The function is also aware of the dimnames: ```{r} # A simple output matrix(1:4, ncol=2, dimnames = list(rows = c("Row 1", "Row 2"), cols = c("Column 1", "Column 2"))) %>% htmlTable ``` This can be convenient when working with the `base::table` function: ```{r} data("mtcars") with(mtcars, table(cyl, gear)) %>% addmargins %>% htmlTable ``` As of version 1.1 you **no longer need** to specify `results='asis'` for each `knitr` chunk. Table caption ------------- The table caption is simply the table description and can be either located above or below: ```{r} output <- matrix(1:4, ncol=2, dimnames = list(c("Row 1", "Row 2"), c("Column 1", "Column 2"))) htmlTable(output, ctable=c("solid", "double"), caption="A table caption above") ``` The caption defaults to above but by setting the `pos.caption` argument to "bottom" it appears below the table. ```{r} htmlTable(output, pos.caption = "bottom", caption="A table caption below") ``` Cell alignment -------------- Cell alignment is specified through the `align`, `align.header`, `align.cgroup` arguments. For aligning the cell values just use `align`. The argument can accept either a vector or a string, although supplying it with a string is the simplest option as in the example below: ```{r} htmlTable(1:3, rnames = "Row 1", align = "lcr", header = c("'l' = left", "'c' = center", "'r' = right"), caption = "The alignment is set through the align options. Available alternatives are l, r, c as designated by the below table.") ``` Note that you can specify a string shorter than the number of columns. This can be useful if you have plenty of columns and you simply want all remaining columns to keep the alignment of the last column. To align the row name you can just add another letter to the string while the header is aligned through the `align.header` argument: ```{r} htmlTable(1:3, rnames = "Row 1", align = "clcr", align.header = "lcr", header = c("'l' = left", "'c' = center", "'r' = right"), caption = "The alignment is set through the align options. Available alternatives are l, r, c as designated by the below table.") ``` Advanced ======== While it may be sufficient for basic tables a more advanced layout is often needed in medical articles with elements such as: * row groups * column spanners * table spanners * total row * table footer * zebra coloring (also known as *banding*): + rows + columns As many journals require that a MS Word-document is submitted it is furthermore also important that the table imports correctly to a word processor, i.e. that the table also looks nice in the final document not only in the browser. The `htmlTable`-function is written for all these purposes. For demonstration purposes we will setup a basic matrix: ```{r} mx <- matrix(ncol=6, nrow=8) rownames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:8, "th")), "row") colnames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:6, "th")), "hdr") for (nr in 1:nrow(mx)){ for (nc in 1:ncol(mx)){ mx[nr, nc] <- paste0(nr, ":", nc) } } ``` Row groups ---------- The purpose of the row groups is to group variables that belong to the same group, e.g. a factored variable with more than two levels often benefit from grouping variables together. ```{r} htmlTable(mx, rgroup = paste("Group", LETTERS[1:3]), n.rgroup = c(2,4,nrow(mx) - 6)) ``` We can easily mix row groups with regular variables by having an empty row group name `""`: ```{r} htmlTable(mx, rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,4,nrow(mx) - 6)) ``` When mixing row groups with variables without row groups we may want to omit the bold formatting of the row group label: ```{r} htmlTable(mx, css.rgroup = "", rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,4,nrow(mx) - 6)) ``` The `rgroup` is most commonly a single row without any additional cells but sometimes you may want to have a p-value or similar at the end of the row. This can be achieved by setting the 'add' attribute to the `rgroup`: ```{r} rgroup <- c(paste("Group", LETTERS[1:2]), "") attr(rgroup, "add") <- list(`2` = "More") htmlTable(mx, rgroup = rgroup, n.rgroup = c(2,4,nrow(mx) - 6)) ``` Column spanners --------------- A column spanner spans 2 or more columns: ```{r} htmlTable(mx, cgroup = c("Cgroup 1", "Cgroup 2"), n.cgroup = c(2,4)) ``` It can sometimes be convenient to have column spanners in multiple levels: ```{r} htmlTable(mx, cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2")), n.cgroup = rbind(c(1,2,NA), c(2,2,2))) ``` Above example allows the column spanner to be a sum of the underlying cgroups (see n.cgroup), this is not required by the function and you can also provide a `list` with elements that allows you to skip the `NA` at the end of the matrix: ```{r} htmlTable(mx, cgroup = list(c("Super column spanner", ""), c("", "Another cgroup"), c("", "Cgroup 1", "Cgroup 2")), n.cgroup = list(c(5,1), c(1,2), c(2,2,2))) ``` Table spanners -------------- A table spanner is similar to rgroup but has the primary purpose of combining 2 or more tables with the same columns into one: ```{r} htmlTable(mx, tspanner = paste("Spanner", LETTERS[1:3]), n.tspanner = c(2,4,nrow(mx) - 6)) ``` Note that you actually don't need the last `n.tspanner`, i.e. you can simplify the above to: ```{r} htmlTable(mx, tspanner = paste("Spanner", LETTERS[1:3]), n.tspanner = c(2,4)) ``` Similarly you can use the number rgroups included in each tspanner instead of actual rows. This is convenient as the tspannners must align with underlying rgroups. Total row --------- Many financial tables use the concept of a total row at the end that sums the above elements: ```{r} htmlTable(mx[1:3,], total=TRUE) ``` This can also be combined with table spanners: ```{r} htmlTable(mx, total = "tspanner", css.total = c("border-top: 1px dashed grey;", "border-top: 1px dashed grey;", "border-top: 1px solid grey; font-weight: 900"), tspanner = paste("Spanner", LETTERS[1:3]), n.tspanner = c(2,4,nrow(mx) - 6)) ``` Table numbering --------------- The htmlTable has built-in numbering, initialized by: ```{r} options(table_counter = TRUE) ``` ```{r} htmlTable(mx[1:2,1:2], caption="A table caption with a numbering") ``` As we often want to reference the table number in the text there are two associated functions: ```{r} tblNoLast() tblNoNext() ``` ```{r} htmlTable(mx[1:2,1:2], caption="Another table with numbering") ``` If you want to start the counter at 2 you can instead of setting table_counter to `TRUE` set it to 1. Note that you need to set the value to one less as each time the table is called the counter is incremented by one. You can also turn off the feature by: ```{r} options(table_counter = FALSE) ``` Table footer ------------ The footer usually contains specifics regarding variables and is always located at the foot of the table: ```{r} htmlTable(mx[1:2,1:2], tfoot="A table footer") ``` Zebra coloring (or banded colors) ------------------------------------ Zebra coloring is also know as an alternating color pattern or row shading. It is most commonly applied to rows: ```{r} htmlTable(mx, col.rgroup = c("none", "#F7F7F7")) ``` The zebra coloring in `htmlTable` is unique in that it follows the rgroups. The zebra striping is centered around the rgroup although rows with no set rgroup, i.e. "" will have alternating colors event though they programatically are within the same group: ```{r} htmlTable(mx, col.rgroup = c("none", "#F7F7F7"), rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,2,nrow(mx) - 4)) ``` We can also color the columns: ```{r} htmlTable(mx, col.columns = c("none", "#F7F7F7")) ``` Or do both (note that the colors blend at the intersections): ```{r} htmlTable(mx, col.rgroup = c("none", "#F9FAF0"), col.columns = c("none", "#F1F0FA")) ``` Putting it all together ----------------------- Now if we want to do everything in one table it may look like this: ```{r} rgroup = paste("Group", LETTERS[1:3]) attr(rgroup, "add") <- list(`3` = "Group p-value < 0.001") htmlTable(mx, align="r", rgroup = rgroup, n.rgroup = c(2,4), tspanner = paste("Spanner", LETTERS[1:2]), n.tspanner = c(1), cgroup = list(c("", "Column spanners"), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = list(c(1,5), c(2,2,2)), caption="A table with column spanners, row groups, and zebra striping", tfoot="† A table footer commment", cspan.rgroup = 2, col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;") ``` htmlTable/vignettes/custom.css0000644000176200001440000000575213407215301016227 0ustar liggesusersbody { background-color: #fff; margin: 1em auto; max-width: 700px; overflow: visible; padding-left: 2em; padding-right: 2em; font-family: "Open Sans", "Helvetica Neue", Helvetica, Arial, sans-serif; font-size: 14px; line-height: 1.35; } #header { text-align: center; } #TOC { clear: both; margin: 0 0 10px 10px; padding: 4px; width: 400px; border: 1px solid #CCCCCC; border-radius: 5px; background-color: #f6f6f6; font-size: 13px; line-height: 1.3; } #TOC .toctitle { font-weight: bold; font-size: 15px; margin-left: 5px; } #TOC ul { padding-left: 40px; margin-left: -1.5em; margin-top: 5px; margin-bottom: 5px; } #TOC ul ul { margin-left: -2em; } #TOC li { line-height: 16px; } table { margin: 1em auto; } p { margin: 0.5em 0; } blockquote { background-color: #f6f6f6; padding: 0.25em 0.75em; } hr { border-style: solid; border: none; border-top: 1px solid #777; margin: 28px 0; } dl { margin-left: 0; } dl dd { margin-bottom: 13px; margin-left: 13px; } dl dt { font-weight: bold; } ul { margin-top: 0; } ul li { list-style: circle outside; } ul ul { margin-bottom: 0; } pre, code { background-color: #f7f7f7; border-radius: 3px; color: #333; } pre { white-space: pre-wrap; /* Wrap long lines */ border-radius: 3px; margin: 5px 0px 10px 0px; padding: 10px; } pre:not([class]) { background-color: #f7f7f7; } code { font-family: Consolas, Monaco, 'Courier New', monospace; font-size: 85%; } p > code, li > code { padding: 2px 0px; } div.figure { text-align: center; } img { background-color: #FFFFFF; padding: 2px; border: 1px solid #DDDDDD; border-radius: 3px; border: 1px solid #CCCCCC; margin: 0 5px; } h1 { margin-top: 0; font-size: 35px; line-height: 40px; } h2 { border-bottom: 4px solid #f7f7f7; padding-top: 10px; padding-bottom: 2px; font-size: 145%; } h3 { border-bottom: 2px solid #f7f7f7; padding-top: 10px; font-size: 120%; } h4 { border-bottom: 1px solid #f7f7f7; margin-left: 8px; font-size: 105%; } h5, h6 { border-bottom: 1px solid #ccc; font-size: 105%; } a { color: #0033dd; text-decoration: none; } a:hover { color: #6666ff; } a:visited { color: #800080; } a:visited:hover { color: #BB00BB; } a[href^="http:"] { text-decoration: underline; } a[href^="https:"] { text-decoration: underline; } /* Class described in http://benjeffrey.com/posts/pandoc-syntax-highlighting-css Colours from https://gist.github.com/robsimmons/1172277 */ code > span.kw { color: #555; font-weight: bold; } /* Keyword */ code > span.dt { color: #902000; } /* DataType */ code > span.dv { color: #40a070; } /* DecVal (decimal values) */ code > span.bn { color: #d14; } /* BaseN */ code > span.fl { color: #d14; } /* Float */ code > span.ch { color: #d14; } /* Char */ code > span.st { color: #d14; } /* String */ code > span.co { color: #888888; font-style: italic; } /* Comment */ code > span.ot { color: #007020; } /* OtherToken */ code > span.al { color: #ff0000; font-weight: bold; } /* AlertToken */ code > span.fu { color: #900; font-weight: bold; } /* Function calls */ code > span.er { color: #a61717; background-color: #e3d2d2; } /* ErrorTok */htmlTable/NEWS0000644000176200001440000001344713572012522012675 0ustar liggesusersNEWS for the htmlTable package Changes for 1.13.3 ------------------ * Prepared for R 4.0 Changes for 1.13.1 ------------------ * Bug fix for cgroup as list argument * The n.tspanner now also accepts number of rgroups Changes for 1.13 ------------------ * Added the ability to have cgroup arguments as a list * Fixed n.rgoup bug with css * Improved the general vignette * Added vector2string - a convenience function when you want to output a vector into a string * Added digits.nonzero to txtRound function that allows more digits with values close to zero * Force encoding for print.htmlTable when outputting a table using the viewer (Issue #61) Changes for 1.12 ---------------- * Added scientific notation to txtRound (Issue #35) Changes for 1.11.4 ------------------ * Fix $ MathJax bug (Issue #57) Changes for 1.11.3 ------------------ * Fix single-row css.cell bug (Issue #54) Changes for 1.11.2 ------------------ * Set htmlEscape to default to FALSE as some features depend on the ability to be able to send html formatted strings. Changes for 1.11.1v ------------------ * Removed tidyr and dplyr from dependencies (issue #47) Changes for 1.11.0 ------------------ * Strings are now escaped using htmltools::htmlEscape - issue #40 (thanks Peter Konings) * Tidy data interface - issue #42 (thanks Stephen Gragg) Changes for 1.10.1 ----------------- * Fixed bug with rownames styling (thanks Shira Mitchell) Changes for 1.10 ----------------- * Added conversion of dimnames into row/column labels * Added detection of sum row/colum when using base::table * fixed cgroup bug with automated n.cgroup calculations * fixed output to viewport when not in RStudio notebook (thanks Peter Konings) * fixed vector input for txtRound warning Changes for 1.9 ----------------- * txtInt handles nsmall warning when working with non-atomic numbers (issue #23) * fixed output for RStudio notebook (issue #26) Changes for 1.8 ----------------- * txtRound now throws an error when provided a too short vector of digits (thanks Peter Konings) * css.cell has improved docs and added checkmate to verify format (thanks maverickg) * Added concatHtmlTables for merging multiple tables into one string element of class htmlTable * Fixed CRAN bugs in dev version Changes for 1.7 ----------------- * Added ability to print matrix & data.frame without any rows, i.e. empty (thanks Peter Konings) * Added table border flexibility via the ctable argument (Thanks raredd) * Added option of having row-group separators for no-named row groups (Thanks, prof. Harrell) * Fixed bug with outputting dates (issue #14) Changes for 1.6 ----------------- * The txtRound now properly handles vector digits argument * The txtRound is now a S3-function and handles data.frame objects in a cleaner way Changes for 1.5 ----------------- * Added better description for how to use the add attribute for rgroups * Extended the add attribute for rgroup to accept matrices * The n.rgroup/rgroup are automaticaly completed with the last rows if sum(n.rgroup) is less than the total number of rows * Similar applies to n.cgroup/cgroup * Fixed the line-merge so that all new lines get an
-tag * Added an interactiveTable for allowing tables with cells that have resizeable content * Added css.table for table element css styling Changes for 1.4 --------------- * Handles data.frames with factors - thanks Sergio Oller #4 Changes for 1.3 --------------- * Prepared for API-changes with stringr 1.0 * The txtRound can now handle vectors and single values Changes for 1.2 ----------------- * Fixed table counter update * The htmlTable can now also accept vectors * Removed the format.df from Hmisc as it converted & to \& with unexpected results. This functionality has also been superseeded by the txtRound function. Changes for 1.1 ----------------- * Added the option of having an attribute on the rgroup in case there is an interest of adding more data to that particular row * Added a fix for the pandoc tab bug * knit_print implemented removing the need for results='asis' except for within for-loops * Removed the capitalize tspanner css as this may cause confusion with limited word processor compatibility * Added htmlTable tests * txtRound now also rounds character matrices * Added a detailed vignette with the primary features of htmlTable * Added the option of having a total row * The pos.caption can now also be "below" * Fixed minor bug with numbering not beeing turned off with options(table_counter = FALSE) * Zebra striping now works for rgroups mixed with "" * txtRound returns "" by default if value missing. This can also be specified with the txt.NA option Changes for 1.0 ----------------- * The htmlTable and associated txt-functions are now separated from Gmisc * Argument name changes for htmlTable for better consistency and logic: rowname -> rnames headings -> header halign -> align.header cgroup.just -> align.cgroup rgroupCSSstyle -> css.rgroup rgroupCSSseparator -> css.rgroup.sep tspannerCSSstyle -> css.tspanner tspannerCSSseparator -> css.tspanner.sep tableCSSclass -> css.table.class rowlabel.pos -> pos.rowlabel caption.loc -> pos.caption altcol -> col.rgroup * htmlTable can now handle rnames = FALSE in order to surpress rownames * htmlTable now defaults to the layout of ctable as this is the more commonly found layout among medical papers * htmlTable rgroup has the additional padding.rgroup for those that want to change the no-breaking space padding * htmlTable tfoot is automatically run through txtMergeLines in order to retain wrapped text * Renamed splitLines4Table to txtMergeLines, outputInt to txtInt, pvalueFormatter to txtPval and these follow now the argument style of htmlTable * Added txtRound for rounding matrices. The problem with round() is that 1.01 rounds to 1 instead of "1.0" that is wanted for output. * Multiple bug-fixes htmlTable/R/0000755000176200001440000000000013414117305012366 5ustar liggesusershtmlTable/R/vector2string.R0000644000176200001440000000206413412664215015333 0ustar liggesusers#' Collapse vector to string #' #' Merges all the values and outputs a string #' formatted as '1st element', '2nd element', ... #' #' @param x The vector to collapse #' @param collapse The string that separates each element #' @param quotation_mark The type of quote to use #' @return A string with \code{', '} separation #' @importFrom stringr str_replace_all #' @examples #' vector2string(1:4) #' vector2string(c("a","b'b", "c")) #' vector2string(c("a","b'b", "c"), quotation_mark = '"') #' @export vector2string <- function(x, quotation_mark = "'", collapse = sprintf("%s, %s", quotation_mark, quotation_mark)) { paste0(quotation_mark, paste(sapply(x, function(single_x) { str_replace_all(single_x, quotation_mark, sprintf("\\\\%s", quotation_mark)) }, USE.NAMES = FALSE), collapse = collapse), quotation_mark ) } htmlTable/R/deprecated.R0000644000176200001440000000171113407215301014606 0ustar liggesusers# Deprecated function names #' See \code{\link{txtMergeLines}} #' #' @param ... passed onto \code{\link{txtMergeLines}} #' @examples #' splitLines4Table("hello", "world") #' @keywords internal #' @export splitLines4Table <- function(...){ warning("splitLines4Table is deprecated, use txtMergeLines() instead") txtMergeLines(...) } #' Deprecated use \code{\link{txtInt}} instead. #' #' @param ... Passed to \code{\link{txtInt}} #' #' @examples #' outputInt(123456) #' #' @keywords internal #' @export outputInt <- function(...){ warning("outputInt is deprecated, use txtInt() instead.") txtInt(...) } #' Deprecated use \code{\link{txtPval}} instead #' #' @param ... Currently only used for generating warnings of deprecated call #' @examples #' pvalueFormatter(c(0.10234,0.010234, 0.0010234, 0.000010234)) #' @export #' @keywords internal pvalueFormatter <- function(...){ warning("pvalueFormatter is deprecated, use txtPval() instead.") txtPval(...) }htmlTable/R/interactiveTable.R0000644000176200001440000002107013407215301015773 0ustar liggesusers#' An interactive table that allows you to limit the size of boxes #' #' This function wraps the htmlTable and adds JavaScript code for toggling the amount #' of text shown in any particular cell. #' #' @param ... The exact same parameters as \code{\link{htmlTable}} uses #' @param txt.maxlen The maximum length of a text #' @param button Indicator if the cell should be clickable or if a button should appear with a plus/minus #' @param minimized.columns Notifies if any particular columns should be collapsed from start #' @param js.scripts If you want to add your own JavaScript code you can just add it here. #' All code is merged into one string where each section is wrapped in it's own #' \code{} element. #' @return An htmlTable with a javascript attribute containing the code that is then printed #' @export #' @example inst/examples/interactiveTable_example.R #' @rdname interactiveTable interactiveTable <- function(x, ..., txt.maxlen = 20, button = FALSE, minimized.columns, js.scripts = c()){ UseMethod("interactiveTable") } getButtonDiv <- function(sign = "-"){ template <- system.file("html_components/button.html", package = "htmlTable") if (template == "") stop("Could not find the button template file") template <- readChar(template, nchars = file.info(template)$size) gsub("%sign%", sign, template) %>% gsub("[\n\r]", " ", .) } #' @export interactiveTable.default <- function(x, ..., txt.maxlen = 20, button = FALSE, minimized.columns, js.scripts = c()){ if ("data.frame" %in% class(x)) x <- prConvertDfFactors(x) if (!missing(minimized.columns)){ if (is.character(minimized.columns)){ if (minimized.columns != "last") stop("If you want to provide a character for columns you must", " provide 'last' - '", minimized.columns, "' has not yet", " been implemented.") minimized.columns <- ncol(x) }else if(is.logical(minimized.columns)){ minimized.columns <- which(minimized.columns) }else if(!is.numeric(minimized.columns)){ stop("Expecting the minimized columns to either be numbers or logical parameters") }else if(max(minimized.columns) > ncol(x)){ stop("You can't minimize columns larger than the number of columns available.", "I.e. ", paste(minimized.columns[minimized.columns > ncol(x)], collapse =", "), " > ", ncol(x)) } if(!is.null(dim(minimized.columns))){ stop("Can only handle column vectors for minimization") } addon_elements <- paste("... ", "") if (button){ addon_elements <- paste(addon_elements, getButtonDiv("+")) } for (col_no in minimized.columns){ for (row_no in 1:nrow(x)){ if (nchar(x[row_no, col_no]) > txt.maxlen){ x[row_no, col_no] <- paste0(substr(x[row_no, col_no], 1, txt.maxlen), gsub("%span_inner_text%", x[row_no, col_no], addon_elements)) } } } # Pass false to allow warning later on minimized.columns <- FALSE } tbl <- htmlTable(x, escape.html=FALSE, ...) return(interactiveTable(tbl, txt.maxlen = 20, button = button, minimized.columns = minimized.columns, js.scripts = js.scripts)) } #' @param tbl An htmlTable object can be directly passed into the function #' @rdname interactiveTable interactiveTable.htmlTable <- function(tbl, txt.maxlen = 20, button = FALSE, minimized.columns, js.scripts = c()){ if (!missing(minimized.columns) && all(minimized.columns != FALSE)) stop("Can't minimize columns after creating the htmlTable. Try calling the function directly with the input data that you used for htmlTable") class(tbl) <- c("interactiveTable", class(tbl)) if (button) { template <- system.file("javascript/button.js", package = "htmlTable") if (template == "") stop("Could not find the javascript button template file") template <- readChar(template, nchars = file.info(template)$size) attr(tbl, "javascript") <- c(js.scripts, template %>% gsub("%txt.maxlen%", txt.maxlen, .) %>% gsub("%btn%", getButtonDiv(), .)) }else{ template <- system.file("javascript/toggler.js", package = "htmlTable") if (template == "") stop("Could not find the javascript toggler template file") template <- readChar(template, nchars = file.info(template)$size) attr(tbl, "javascript") <- c(js.scripts, template %>% gsub("%txt.maxlen%", txt.maxlen, .)) } return(tbl) } #' @rdname interactiveTable #' @importFrom knitr knit_print #' @importFrom knitr asis_output #' @export knit_print.interactiveTable<- function(x, ...){ if (getOption("interactiveTable_knitprint", FALSE)){ asis_output(x) }else{ options(interactiveTable_knitprint = TRUE) asis_output(paste(x, attr(x, "javascript"))) } } #' Gets a string with all the scripts merged into one script tag #' #' Each element has it's own script tags in otherwise an error will cause #' all the scripts to fail. #' #' @param x An interactiveTable #' @return string #' @keywords internal prGetScriptString <- function(x){ scripts <- attr(x, "javascript") if (is.null(scripts)) stop("You have provided an object of class ", class(x), " that does not contain a javascript attribute") sapply(scripts, USE.NAMES = FALSE, FUN = function(s){ if (s == "") return("") paste("") }) %>% paste(collapse = "\n\n \n") } #' @rdname interactiveTable #' @param x The interactive table that is to be printed #' @inheritParams htmlTable #' @export print.interactiveTable <- function(x, useViewer, ...){ args <- attr(x, "...") # Use the latest ... from the print call # and override the original htmlTable call ... # if there is a conflict print_args <- list(...) for (n in names(print_args)){ args[[n]] <- print_args[[n]] } # Since the print may be called from another print function # it may be handy to allow functions to use attributes for the # useViewer parameter if (missing(useViewer)){ if ("useViewer" %in% names(args) && (is.logical(args$useViewer) || is.function(args$useViewer))){ useViewer <- args$useViewer args$useViewer <- NULL }else{ useViewer <- TRUE } } if (interactive() && !getOption("htmlTable.cat", FALSE) && (is.function(useViewer) || useViewer != FALSE)) { if (is.null(args$file)){ args$file <- tempfile(fileext=".html") } htmlPage <- paste("", "", "", "", "", "", "
", x, "
", prGetScriptString(x), "", "", sep="\n") # We only want to use those arguments that are actually in cat # anything else that may have inadvertadly slipped in should # be ignored or it will be added to the output cat_args <- args cat_args <- cat_args[names(cat_args) %in% names(formals(cat))[-1]] do.call(cat, c(htmlPage, cat_args)) if (is.function(useViewer)){ useViewer(args$file) }else{ viewer <- getOption("viewer") if (!is.null(viewer) && is.function(viewer)){ # (code to write some content to the file) viewer(args$file) }else{ utils::browseURL(args$file) } } }else{ cat_args <- args cat_args <- cat_args[names(cat_args) %in% names(formals(cat))[-1]] do.call(cat, c(x, cat_args)) cat(prGetScriptString(x)) } invisible(x) } htmlTable/R/htmlTable.R0000644000176200001440000014045313572013241014433 0ustar liggesusers#' Outputting HTML tables #' #' This is a function for outputting a more advanced #' table than what \pkg{xtable}, \pkg{ztable}, or \pkg{knitr}'s #' \code{\link[knitr]{kable}()} allows. #' It's aim is to provide the \pkg{Hmisc} \code{\link[Hmisc]{latex}()} #' colgroup and rowgroup functions in HTML. The html-output is designed for #' maximum compatibility with LibreOffice/OpenOffice. #' #' @section Multiple rows of column spanners \code{cgroup}: #' #' If you want to have a column spanner in multiple levels you can #' set the \code{cgroup} and \code{n.cgroup} arguments to a \code{matrix} or #' \code{list}. #' #' If the different levels have different number of elements and you have #' provided a **matrix** you need to set the ones that lack elements to NA. For instance #' \code{cgroup = rbind(c("first", "second", NA), c("a", "b", "c"))}. #' And the corresponding n,cgroup would be \code{n.cgroup = rbind(c(1, 2, NA), c(2, 1, 2))}. #' for a table consisting of 5 columns. The "first" spans the first two columns, #' the "second" spans the last three columns, "a" spans the first two, "b" #' the middle column, and "c" the last two columns. #' #' It is recommended to use `list` as you will not have to bother with the `NA`. #' #' If you want leav a cgroup empty then simply provide `""` as the cgroup. #' #' @section The \code{rgroup} argument: #' #' The rgroup allows you to smoothly group rows. Each row within a group #' receives an indention of two blank spaces and are grouped with their #' corresponing rgroup element. The \code{sum(n.rgroup)} should always #' be equal or less than the matrix rows. If less then it will pad the #' remaining rows with either an empty rgroup, i.e. an "" or if the #' rgroup is one longer than the n.rgroup the last n.rgroup element will #' be calculated through \code{nrow(x) - sum(n.rgroup)} in order to make #' the table generating smoother. #' #' @section The add attribute to \code{rgroup}: #' #' You can now have an additional element at the rgroup level by specifying the #' \code{attr(rgroup, 'add')}. The value can either be a \code{vector}, a \code{list}, #' or a \code{matrix}. See \code{vignette("general", package = "htmlTable")} for examples. #' \itemize{ #' \item{A \code{vector} of either equal number of rgroups to the number #' of rgroups that aren't empty, i.e. \code{rgroup[rgroup != ""]}. Or a named vector where #' the name must correspond to either an rgroup or to an rgroup number.} #' \item{A \code{list} that has exactly the same requirements as the vector. #' In addition to the previous we can also have a list with column numbers within #' as names within the list.} #' \item{A \code{matrix} with the dimensiont \code{nrow(x) x ncol(x)} or #' \code{nrow(x) x 1} where the latter is equivalent to a named vector. #' If you have \code{rownames} these will resolve similarly to the names to the #' \code{list}/\code{vector} arguments. The same thing applies to \code{colnames}. #' } #' } #' #' @section Important \pkg{knitr}-note: #' #' This funciton will only work with \pkg{knitr} outputting \emph{html}, i.e. #' markdown mode. As the function returns raw html-code #' the compatibility with non-html formatting is limited, #' even with \href{http://johnmacfarlane.net/pandoc/}{pandoc}. #' #' Thanks to the the \code{\link[knitr]{knit_print}} and the #' \code{\link[knitr]{asis_output}} #' the \code{results='asis'} is \emph{no longer needed} except within for-loops. #' If you have a knitr-chunk with a for loop and use \code{print()} to produce #' raw html you must set the chunk option \code{results='asis'}. \code{Note}: #' the print-function relies on the \code{\link[base]{interactive}()} function #' for determining if the output should be sent to a browser or to the terminal. #' In vignettes and other directly knitted documents you may need to either set #' \code{useViewer = FALSE} alternatively set \code{options(htmlTable.cat = TRUE)}. #' #' @section RStudio's notebook: #' #' RStudio has an interactive notebook that allows output directly into the document. #' In order for the output to be properly formatted it needs to have the \code{class} #' of \code{html}. The \code{htmlTable} tries to identify if the environment is a #' notebook document (uses the rstudio api and identifies if its a file with and `Rmd` #' file ending or if ther is an element with `html_notebook`). If you don't want this #' behaviour you can remove it using the `options(htmlTable.skip_notebook = TRUE)` #' #' @section Table counter: #' #' If you set the option table_counter you will get a Table 1,2,3 #' etc before each table, just set \code{options(table_counter=TRUE)}. If #' you set it to a number then that number will correspond to the start of #' the table_counter. The \code{table_counter} option will also contain the number #' of the last table, this can be useful when referencing it in text. By #' setting the option \code{options(table_counter_str = "Table \%s: ")} #' you can manipulate the counter table text that is added prior to the #' actual caption. Note, you should use the \code{\link{sprintf}} \code{\%s} #' instead of \code{\%d} as the software converts all numbers to characters #' for compatibility reasons. If you set \code{options(table_counter_roman = TRUE)} #' then the table counter will use Roman numumerals instead of Arabic. #' #'@section The \code{css.cell} argument: #' #' The \code{css.cell} parameter allows you to add any possible CSS style #' to your table cells. \code{css.cell} can be either a vector or a matrix. #' #' If \code{css.cell} is a \emph{vector}, it's assumed that the styles should be repeated #' throughout the rows (that is, each element in css.cell specifies the style #' for a whole column of 'x'). #' #' In the case of \code{css.cell} being a \emph{matrix} of the same size of the \code{x} argument, #' each element of \code{x} gets the style from the corresponding element in css.cell. Additionally, #' the number of rows of \code{css.cell} can be \code{nrow(x) + 1} so the first row of of \code{css.cell} #' specifies the style for the header of \code{x}; also the number of columns of \code{css.cell} #' can be \code{ncol(x) + 1} to include the specification of style for row names of \code{x}. #' #' Note that the \code{text-align} CSS field in the \code{css.cell} argument will be overriden #' by the \code{align} argument. #' #'@section Empty dataframes: #' An empty dataframe will result in a warning and output an empty table, provided that #' rgroup and n.rgroup are not specified. All other row layout options will be ignored. #' #' @section Browsers and possible issues: #' #' \emph{Copy-pasting:} As you copy-paste results into Word you need to keep #' the original formatting. Either right click and choose that paste option or click #' on the icon appearing after a paste. Currently the following compatibitilies #' have been tested with MS Word 2013: #' #' \itemize{ #' \item{\bold{Internet Explorer} (v. 11.20.10586.0) Works perfectly when copy-pasting into Word} #' \item{\bold{RStudio} (v. 0.99.448) Works perfectly when copy-pasting into Word. #' \emph{Note:} can have issues with multiline cgroups - #' see \href{http://code.google.com/p/chromium/issues/detail?id=305130}{bug}} #' \item{\bold{Chrome} (v. 47.0.2526.106) Works perfectly when copy-pasting into Word. #' \emph{Note:} can have issues with multiline cgroups - #' see \href{http://code.google.com/p/chromium/issues/detail?id=305130}{bug}} #' \item{\bold{Firefox} (v. 43.0.3) Works poorly - looses font-styling, lines and general feel} #' \item{\bold{Edge} (v. 25.10586.0.0) Works poorly - looses lines and general feel} #' } #' #' #' \emph{Direct word processor opening:} Opening directly in LibreOffice or Word is no longer #' recommended. You get much prettier results using the cut-and-paste option. #' #' Note that when using complex cgroup alignments with multiple levels #' not every browser is able to handle this. For instance the RStudio #' webkit browser seems to have issues with this and a #' \href{http://code.google.com/p/chromium/issues/detail?id=305130}{bug has been filed}. #' #' As the table uses html for rendering you need to be aware of that headers, #' rownames, and cell values should try respect this for optimal display. Browsers #' try to compensate and frequently the tables still turn out fine but it is #' not advized. Most importantly you should try to use #' \code{<} instead of \code{<} and #' \code{>} instead of \code{>}. You can find a complete list #' of html characters \href{http://ascii.cl/htmlcodes.htm}{here}. #' #' @param x The matrix/data.frame with the data. For the \code{print} and \code{knit_print} #' it takes a string of the class \code{htmlTable} as \code{x} argument. #' @param header A vector of character strings specifying column #' header, defaulting to \code{\link[base]{colnames}(x)} #' @param rnames Default rownames are generated from \code{\link[base]{rownames}(x)}. If you #' provide \code{FALSE} then it will skip the rownames. \emph{Note:} For \code{data.frames} #' if you do \code{\link[base]{rownames}(my_dataframe) <- NULL} it still has #' rownames. Thus you need to use \code{FALSE} if you want to #' surpress rownames for \code{data.frames}. #' @param rowlabel If the table has rownames or \code{rnames}, #' rowlabel is a character string containing the #' column heading for the \code{rnames}. #' @param caption Adds a table caption. #' @param tfoot Adds a table footer (uses the \code{} html element). The #' output is run through \code{\link{txtMergeLines}} simplifying the generation #' of multiple lines. #' @param label A text string representing a symbolic label for the #' table for referencing as an anchor. All you need to do is to reference the #' table, for instance \code{see table 2}. This is #' known as the element's id attribute, i.e. table id, in HTML linguo, and should #' be unique id for an HTML element in contrast to the \code{css.class} element attribute. #' #' @param align A character strings specifying column alignments, defaulting to #' \code{\link[base]{paste}(rep('c',ncol(x)),collapse='')} to center. Valid alignments are #' l = left, c = center and r = right. You can also specify \code{align='c|c'} and #' other LaTeX tabular formatting. If you want to set the alignment of the #' rownames this string needst to be \code{ncol(x) + 1}, otherwise it automatically #' pads the string with a left alignment for the rownames. #' @param align.header A character strings specifying alignment for column header, #' defaulting to centered, i.e. \code{\link[base]{paste}(rep('c',ncol(x)),collapse='')}. #' @param align.cgroup The justification of the \code{cgroups} #' #' @param rgroup A vector of character strings containing headings for row groups. #' \code{n.rgroup} must be present when \code{rgroup} is given. See #' detailed description in section below. #' @param n.rgroup An integer vector giving the number of rows in each grouping. If \code{rgroup} #' is not specified, \code{n.rgroup} is just used to divide off blocks of rows by horizontal #' lines. If \code{rgroup} is given but \code{n.rgroup} is omitted, \code{n.rgroup} will #' default so that each row group contains the same number of rows. If you want additional #' rgroup column elements to the cells you can sett the "add" attribute to \code{rgroup} through #' \code{attr(rgroup, "add")}, see below explaining section. #' @param cgroup A vector, matrix or list of character strings defining major column header. The default #' is to have none. These elements are also known as \emph{column spanners}. If you want a column \emph{not} #' to have a spanner then put that column as "". If you pass cgroup and \code{n.crgroup} as #' matrices you can have column spanners for several rows. See cgroup section below for details. #' @param n.cgroup An integer vector, matrix or list containing the number of columns for which each element in #' cgroup is a heading. For example, specify \code{cgroup=c("Major_1","Major_2")}, #' \code{n.cgroup=c(3,3)} if \code{"Major_1"} is to span columns 1-3 and #' \code{"Major_2"} is to span columns 4-6. #' \code{rowlabel} does not count in the column numbers. You can omit \code{n.cgroup} #' if all groups have the same number of columns. If the n.cgroup is one less than #' the number of columns in the matrix/data.frame then it automatically adds those. #' @param tspanner The table spanner is somewhat of a table header that #' you can use when you want to join different tables with the same columns. #' @param n.tspanner An integer vector with the number of rows or rgroups in the original #' matrix that the table spanner should span. If you have provided one fewer n.tspanner elements #' the last will be imputed from the number of rgroups (if you have provided `rgroup` and #' `sum(n.tspanner) < length(rgroup)`) or the number of rows in the table. #' @param total The last row is sometimes a row total with a border on top and #' bold fonts. Set this to \code{TRUE} if you are interested in such a row. If you #' want a total row at the end of each table spanner you can set this to \code{"tspanner"}. #' #' @param css.rgroup CSS style for the rgorup, if different styles are wanted for each of the #' rgroups you can just specify a vector with the number of elements #' @param css.rgroup.sep The line between different rgroups. The line is set to the TR element #' of the lower rgroup, i.e. you have to set the border-top/padding-top etc to a line with #' the expected function. This is only used for rgroups that are printed. You can specify #' different separators if you give a vector of rgroup - 1 length (this is since the first #' rgroup doesn't have a separator). #' @param css.tspanner The CSS style for the table spanner #' @param css.tspanner.sep The line between different spanners #' @param css.total The css of the total row #' @param css.cell The css.cell element allows you to add any possible CSS style to your #' table cells. See section below for details. #' @param css.class The html CSS class for the table. This allows directing html #' formatting through \href{http://www.w3schools.com/Css/}{CSS} #' directly at all instances of that class. \emph{Note:} unfortunately the #' CSS is frequently ignored by word processors. This option #' is mostly inteded for web-presentations. #' @param css.table You can specify the the style of the table-element using this parameter #' @param css.cgroup The same as \code{css.class} but for cgroup formatting. #' #' @param pos.rowlabel Where the rowlabel should be positioned. This value can be \code{"top"}, #' \code{"bottom"}, \code{"header"}, or a integer between \code{1} and \code{nrow(cgroup) + 1}. The options #' \code{"bottom"} and \code{"header"} are the same, where the row label is presented at the same level as #' the header. #' @param pos.caption Set to \code{"bottom"} to position a caption below the table #' instead of the default of \code{"top"}. #' @param cspan.rgroup The number of columns that an \code{rgroup} should span. It spans #' by default all columns but you may want to limit this if you have column colors #' that you want to retain. #' #' @param ... Passed on to \code{print.htmlTable} function and any argument except the #' \code{useViewer} will be passed on to the \code{\link[base]{cat}} functions arguments. #' #' @param col.rgroup Alternating colors (zebra striping/banded rows) for each \code{rgroup}; one or two colors #' is recommended and will be recycled. #' @param col.columns Alternating colors for each column. #' #' @param padding.rgroup Generally two non-breakings spaces, i.e. \code{  }, but some #' journals only have a bold face for the rgroup and leaves the subelements unindented. #' @param padding.tspanner The table spanner is usually without padding but you may specify padding #' similar to \code{padding.rgroup} and it will be added to all elements, including the rgroup elements. #' This allows for a 3-level hierarchy if needed. #' @param ctable If the table should have a double top border or a single a' la LaTeX ctable style #' @param compatibility Is default set to \code{LibreOffice} as some #' settings need to be in old html format as Libre Office can't #' handle some commands such as the css caption-alignment. Note: this #' option is not yet fully implemented for all details, in the future #' I aim to generate a html-correct table and one that is aimed #' at Libre Office compatibility. Word-compatibility is difficult as #' Word ignores most settings and destroys all layout attempts #' (at least that is how my 2010 version behaves). You can additinally use the #' \code{options(htmlTableCompat = "html")} if you want a change to apply #' to the entire document. #' MS Excel sometimes misinterprets certain cell data when opening HTML-tables (eg. 1/2 becomes 1. February). #' To avoid this please specify the correct Microsoft Office format for each cell in the table using the css.cell-argument. #' To make MS Excel interpret everything as text use "mso-number-format:\"\\@\"". #' @param escape.html logical: should HTML characters be escaped? Defaults to FALSE. #' @return \code{string} Returns a string of class htmlTable #' #' @example inst/examples/htmlTable_example.R #' #' @seealso \code{\link{txtMergeLines}}, #' \code{\link[Hmisc]{latex}} #' #' @export #' @rdname htmlTable #' @family table functions htmlTable <- function(x, ...){ UseMethod("htmlTable") } `.` <- "magrittr RCM check issue" #' @importFrom stringr str_replace str_replace_all str_trim #' @importFrom htmltools htmlEscape #' @import checkmate #' @import magrittr #' @rdname htmlTable #' @export htmlTable.default <- function(x, header, rnames, rowlabel, caption, tfoot, label, # Grouping rgroup, n.rgroup, cgroup, n.cgroup, tspanner, n.tspanner, total, # Alignment align = paste(rep('c',ncol(x)),collapse=''), align.header= paste(rep('c',ncol(x)),collapse=''), align.cgroup, # CSS stuff css.rgroup = "font-weight: 900;", css.rgroup.sep = "", css.tspanner = "font-weight: 900; text-align: left;", css.tspanner.sep = "border-top: 1px solid #BEBEBE;", css.total = "border-top: 1px solid #BEBEBE; font-weight: 900;", css.cell = "", css.cgroup = "", css.class = "gmisc_table", css.table = "margin-top: 1em; margin-bottom: 1em;", # Positions pos.rowlabel = "bottom", pos.caption='top', # Colors col.rgroup = 'none', col.columns = 'none', # More alternatives padding.rgroup = "  ", padding.tspanner = "", ctable = TRUE, compatibility = getOption("htmlTableCompat", "LibreOffice"), cspan.rgroup = "all", escape.html = FALSE, ...) { if (isTRUE(escape.html)) { x <- prEscapeHtml(x) } if (is.null(dim(x))){ if (!is.numeric(x) && !is.character(x)){ x <- as.character(x) } x <- matrix(x, ncol = ifelse(missing(header), length(x), length(header))) }else if (length(dim(x)) != 2) { stop("Your table variable seems to have the wrong dimension,", " length(dim(x)) = ", length(dim(x)) , " != 2") } if (missing(rgroup) && !missing(n.rgroup)){ # Add "" rgroups corresponding to the n.rgroups rgroup = rep("", length.out=length(n.rgroup)) } # Unfortunately in knitr there seems to be some issue when the # rnames is specified immediately as: rnames=rownames(x) if (missing(rnames)){ if (any(is.null(rownames(x)) == FALSE)) rnames <- rownames(x) if (any(is.null(rownames(x))) && !missing(rgroup)){ warning("You have not specified rnames but you seem to have rgroups.", " If you have the first column as rowname but you want the rgroups", " to result in subhedings with indentation below then, ", " you should change the rnames to the first column and then", " remove it from the table matrix (the x argument object).") } } if (!missing(rowlabel) && prSkipRownames(rnames)) stop("You can't have a row label and no rownames.", " Either remove the rowlabel argument", ", set the rnames argument", ", or set the rownames of the x argument.") if (missing(header) && !is.null(colnames(x))){ header<-colnames(x) }else if(!missing(header)){ if (length(header) != ncol(x)) stop("You have a header with ", length(header), " cells", " while your output matrix has only ", ncol(x), " columns") } # Fix alignment to match with the matrix align <- prPrepareAlign(align, x, rnames) align.header <- prPrepareAlign(align.header, x, rnames, default_rn = "c") if (tolower(compatibility) %in% c("libreoffice", "libre office", "open office", "openoffice", "word", "ms word", "msword")){ compatibility <- "LibreOffice" } if (!missing(rgroup)){ if (missing(n.rgroup)) stop("You need to specify the argument n.rgroup if you want to use rgroups") if (any(n.rgroup < 1)){ warning("You have provided rgroups with less than 1 elements,", " these will therefore be removed: ", paste(sprintf("'%s' = %d", rgroup, n.rgroup)[n.rgroup < 1], collapse=", ")) rgroup <- rgroup[n.rgroup >= 1] n.rgroup <- n.rgroup[n.rgroup >= 1] } # Sanity check for rgroup if (sum(n.rgroup) > nrow(x)){ stop("Your rows are fewer than suggested by the n.rgroup,", " i.e. ", sum(n.rgroup) , "(n.rgroup) > ", nrow(x), "(rows in x)") } if (sum(n.rgroup) < nrow(x) && (length(n.rgroup) == length(rgroup) - 1 || length(n.rgroup) == length(rgroup))){ # Add an empty rgroup if missing if (length(n.rgroup) == length(rgroup)) rgroup <- c(rgroup, "") # Calculate the remaining rows and add those n.rgroup <- c(n.rgroup, nrow(x) - sum(n.rgroup)) }else if (sum(n.rgroup) != nrow(x)){ stop("Your n.rgroup doesn't add up") } # Sanity checks css.rgroup and prepares the style if (length(css.rgroup) > 1 && length(css.rgroup) != length(rgroup)) stop(sprintf("You must provide the same number of styles as the rgroups, %d != %d", length(css.rgroup), length(rgroup))) else if(length(css.rgroup) == 1){ css.rgroup <- prGetStyle(css.rgroup) if (length(rgroup) > 0) css.rgroup <- rep(css.rgroup, length.out=length(rgroup)) } else { for (i in 1:length(css.rgroup)) css.rgroup[i] <- prGetStyle(css.rgroup[i]) } # Sanity checks css.rgroup.sep and prepares the style if (length(css.rgroup.sep) > 1 && length(css.rgroup.sep) != length(rgroup)-1) stop(sprintf("You must provide the same number of separators as the rgroups - 1, %d != %d", length(css.rgroup.sep), length(rgroup)-1)) else if(length(css.rgroup.sep) == 1){ css.rgroup.sep <- prAddSemicolon2StrEnd(css.rgroup.sep) if (length(rgroup) > 0) css.rgroup.sep <- rep(css.rgroup.sep, length.out=length(rgroup)) } else { for (i in 1:length(css.rgroup.sep)) css.rgroup.sep[i] <- prAddSemicolon2StrEnd(css.rgroup.sep[i]) } cspan.rgroup <- rep(cspan.rgroup, length.out = length(rgroup)) } ## this will convert color names to hexadecimal (easier for user) ## but also leaves hex format unchanged col.rgroup <- prPrepareColors(col.rgroup, n = nrow(x), ng = n.rgroup, gtxt = rgroup) col.columns <- prPrepareColors(col.columns, ncol(x)) if (!missing(tspanner)){ # Sanity checks css.tspanner and prepares the style if (length(css.tspanner) > 1 && length(css.tspanner) != length(tspanner)) stop(sprintf("You must provide the same number of styles as the tspanners, %d != %d", length(css.tspanner), length(tspanner))) else if(length(css.tspanner) == 1){ css.tspanner <- prAddSemicolon2StrEnd(css.tspanner) if (length(tspanner) > 0) css.tspanner <- rep(css.tspanner, length.out=length(tspanner)) } else { for (i in 1:length(css.tspanner)) css.tspanner[i] <- prAddSemicolon2StrEnd(css.tspanner[i]) } # Sanity checks css.tspanner.sep and prepares the style if (length(css.tspanner.sep) > 1 && length(css.tspanner.sep) != length(tspanner)-1) stop(sprintf("You must provide the same number of separators as the tspanners - 1, %d != %d", length(css.tspanner.sep), length(tspanner)-1)) else if(length(css.tspanner.sep) == 1){ css.tspanner.sep <- prGetStyle(css.tspanner.sep) if (length(tspanner) > 0) css.tspanner.sep <- rep(css.tspanner.sep, length.out=length(tspanner)-1) } else { for (i in 1:length(css.tspanner.sep)) css.tspanner.sep[i] <- prGetStyle(css.tspanner.sep[i]) } } # Convert dimnames to something useful if (!is.null(names(dimnames(x)))) { # First dimname is always the variable name for the row dimname4row <- names(dimnames(x))[1] if (!is.null(dimname4row) && dimname4row != "") { # Use rgroup or tspanner as this is visually more separated than rowlabel # if these are available if (missing(rgroup)) { rgroup <- dimname4row n.rgroup <- nrow(x) } else if (missing(tspanner)) { tspanner <- dimname4row n.tspanner <- nrow(x) } else if (missing(rowlabel)) { rowlabel <- dimname4row } } # Second dimname is always the variable name for the columns dimname4col <- names(dimnames(x))[2] if (!is.null(dimname4col) && dimname4col != "") { # Use rgroup or tspanner as this is visually more separated than rowlabel # if these are available if (missing(cgroup)) { cgroup <- dimname4col n.cgroup <- ncol(x) # If this is a addmargins object we shouldn't have the cspanner including the # sum marker if (!missing(total) && total && grepl("^sum$", tail(colnames(x), 1), ignore.case = TRUE)) { cgroup %<>% c("") n.cgroup <- c(n.cgroup[1] -1, 1) } } } } # Sanity check for tspanner if (!missing(tspanner)){ if (missing(n.tspanner)) stop("You need to specify the argument n.tspanner if you want to use table spanners") if (any(n.tspanner < 1)) { stop("You have provided invalid number of rows in the n.tspanner argument - minimum is 1, you have: ", vector2string(n.tspanner), " where no. ", vector2string(which(n.tspanner)), " was less than 1") } if (length(n.tspanner) == length(tspanner) - 1) { if (missing(rgroup) || sum(n.tspanner) > length(rgroup)) { n.tspanner = append(n.tspanner, nrow(x) - sum(n.tspanner)) } else { n.tspanner = append(n.tspanner, length(rgroup) - sum(n.tspanner)) } } if (any(n.tspanner < 1)) { stop("You have more tspannners than n.tspanner while the number of rows doesn't leave room for more tspanners") } if(sum(n.tspanner) != nrow(x)) { if (missing(rgroup)) stop(sprintf("Your rows don't match in the n.tspanner, i.e. %d != %d", sum(n.tspanner), nrow(x))) if (sum(n.tspanner) != length(rgroup)) stop(sprintf("Your rows don't match either the total number of rows '%d' or the number of rgroups '%d' the sum of n.tspanner %d", nrow(x), length(rgroup), sum(n.tspanner))) org_nt <- n.tspanner for (i in 1:length(n.tspanner)) { offset <- sum(org_nt[0:(i-1)]) + 1 n.tspanner[i] = sum(n.rgroup[offset:(offset + org_nt[i] - 1)]) } } # Make sure there are no collisions with rgrou if (!missing(n.rgroup)) { for (i in 1:length(n.tspanner)){ rows <- sum(n.tspanner[1:i]) if (!rows %in% cumsum(n.rgroup)) stop("There is no splitter that matches the table spanner ", tspanner[i], " (no. ", i, ") with rgroup splits.", " The missing row splitter should be on row number ", rows, " and is not in the n.rgroup list: ", vector2string(n.rgroup), " note, it should match the cumulative sum n.rgroup", vector2string(cumsum(n.rgroup))) } } } # With multiple rows in cgroup we need to keep track of # how many spacer cells occur between the groups cgroup_spacer_cells <- rep(0, times=(ncol(x)-1)) # Sanity check for cgroup if (!missing(cgroup)){ ret <- prPrepareCgroup(x = x, cgroup = cgroup, n.cgroup = n.cgroup, align.cgroup = align.cgroup, css.cgroup = css.cgroup) # TODO: use attach/environment recoding cgroup <- ret$cgroup n.cgroup <- ret$n.cgroup align.cgroup <- ret$align.cgroup cgroup_spacer_cells <- ret$cgroup_spacer_cells css.cgroup <- ret$css.cgroup } pos.rowlabel <- prGetRowlabelPos(cgroup, pos.rowlabel, header) tc <- getOption("table_counter", FALSE) if (tc){ # Count which table it currently is if (is.numeric(tc)) tc <- tc + 1 else tc <- 1 options(table_counter = tc) } # The id works just as well as any anchor table_id <- getOption("table_counter", "") if (!missing(label)){ table_id <- sprintf(" id='%s'", label) }else if(is.numeric(table_id)){ table_id <- paste0(" id='table_", table_id, "'") }else if(table_id == FALSE){ table_id <- "" } # A column counter that is used for total_columns <- ncol(x)+!prSkipRownames(rnames) if(!missing(cgroup)){ if (!is.matrix(cgroup)){ total_columns <- total_columns + length(cgroup) - 1 }else{ total_columns <- total_columns + sum(cgroup_spacer_cells) } } if (missing(total) || (is.logical(total) && all(total == FALSE))){ total = c() }else if (is.logical(total)){ if (length(total) == 1){ total <- nrow(x) }else if(length(total) == nrow(x)){ total <- which(total) }else if(!missing(n.tspanner) && length(total) == length(n.tspanner)){ total <- cumsum(n.tspanner)[total] }else{ stop("You have provided an invalid 'total' argument:", " '", paste(total, collapse="', '"), "'.", " Logical values accepted are either single TRUE elements", ", of the same length as the output matrix (", nrow(x), ")", ", or of the same length as the tspanner (", ifelse(missing(n.tspanner), "not provided", length(n.tspanner)), ").") } }else if (is.numeric(total)){ if (any(!total %in% 1:nrow(x))) stop("You have indicated an invalid row as the total row.", " Valid rows are only 1 to ", nrow(x), " and you have provided invalid row(s): ", "'", paste(total[!total %in% 1:nrow(x)], collapse="', '"), "'") }else if (all(total == "tspanner")){ total <- cumsum(n.tspanner) }else{ stop("You have provided an invalid 'total' argument:", " '", paste(total, collapse="', '"), "' ", " of the class ", paste(class(total), collapse = " & "), ".", " The function currently only accepts logical or numerical", " values.") } css.total <- rep(css.total, length.out = length(total)) assert( check_matrix(css.cell), check_character(css.cell) ) css.cell <- prPrepareCss(x, css = css.cell, rnames = rnames, header = header) ############################### # Start building table string # ############################### table_str <- sprintf("", paste(css.class, collapse=", "), paste(css.table, collapse = "; "), table_id) # Theoretically this should be added to the table but the # import to word processors works then less well and therefore I've # constructed this work-around with borders for the top and bottom cells first_row <- TRUE; if (isTRUE(ctable)){ top_row_style = "border-top: 2px solid grey;" bottom_row_style = "border-bottom: 2px solid grey;" } else if (any(ctable %in% c('single', 'double'))) { ctable <- rep_len(ctable, 2L) ctable[ctable %in% 'single'] <- 'solid' top_row_style = ifelse(ctable[1] == 'solid', "border-top: 2px solid grey;", "border-top: 4px double grey;") bottom_row_style = ifelse(ctable[2] == 'solid', "border-bottom: 2px solid grey;", "border-bottom: 4px double grey;") } else { top_row_style = "border-top: 4px double grey;" bottom_row_style = "border-bottom: 1px solid grey;" } # Add caption according to standard HTML if (!missing(caption)){ # Combine a table counter if provided caption <- paste0("\n\t", prTblNo(caption)) if(compatibility != "LibreOffice"){ if (pos.caption %in% c("bottom", "below")){ table_str %<>% paste0("\n\t") } } if (!missing(header) || !missing(cgroup) || !missing(caption)){ thead <- prGetThead(x = x, header = header, cgroup = cgroup, n.cgroup = n.cgroup, caption = caption, pos.caption = pos.caption, compatibility = compatibility, total_columns = total_columns, align.cgroup = align.cgroup, css.cgroup = css.cgroup, top_row_style = top_row_style, rnames = rnames, rowlabel = rowlabel, pos.rowlabel = pos.rowlabel, cgroup_spacer_cells = cgroup_spacer_cells, css.cell = css.cell, align.header = align.header, cell_style = cell_style) first_row <- FALSE table_str %<>% paste0(thead) } table_str %<>% paste0("\n\t") if (missing(rgroup)) row_clrs <- col.rgroup else row_clrs <- unlist(attr(col.rgroup, "group")) rgroup_iterator <- 0 tspanner_iterator <- 0 if(nrow(x) > 0){ for (row_nr in 1:nrow(x)){ rname_style = attr(css.cell, "rnames")[row_nr] # First check if there is a table spanner that should be applied if (!missing(tspanner) && (row_nr == 1 || row_nr > sum(n.tspanner[1:tspanner_iterator]))){ tspanner_iterator = tspanner_iterator + 1 rs <- c(rname_style, css.tspanner[tspanner_iterator]) # Use a separator from the one above if this # at least the second spanner. Graphically this # appears as if underneath the group while it's # actually above but this merges into one line if (tspanner_iterator > 1){ rs %<>% c(css.tspanner.sep[tspanner_iterator-1]) } if (first_row){ rs %<>% c(top_row_style) } table_str %<>% sprintf("%s\n\t", ., total_columns, prGetStyle(rs), tspanner[tspanner_iterator]) first_row <- FALSE } # Add the row group if any # and it's: # - first row # - the row belongs to the next row group rgroup_sep_style <- FALSE if (!missing(rgroup) && (row_nr == 1 || row_nr > sum(n.rgroup[1:rgroup_iterator]))){ rgroup_iterator = rgroup_iterator + 1 rs <- c(rname_style, css.rgroup[rgroup_iterator], `background-color` = col.rgroup[rgroup_iterator]) # Use a separator from the one above if this # at least the second group. Graphically this # appears as if underneath the group while it's # actually above but this merges into one line if (rgroup_iterator > 1){ rs <- c(rs, css.rgroup.sep[rgroup_iterator-1]) } # Only add if there is anything in the group if (is.na(rgroup[rgroup_iterator]) == FALSE && rgroup[rgroup_iterator] != ""){ if (first_row){ rs <- c(rs, top_row_style) } rgroup_str <- prGetRgroupLine(x = x, total_columns = total_columns, rgroup = rgroup, rgroup_iterator = rgroup_iterator, cspan = cspan.rgroup[rgroup_iterator], rnames = rnames, style = rs, align = align, cgroup_spacer_cells = cgroup_spacer_cells, col.columns = col.columns, css.row = css.cell[row_nr,], padding.tspanner = padding.tspanner) table_str %<>% paste(rgroup_str) first_row <- FALSE }else if(rgroup_iterator > 1 && css.rgroup.sep[rgroup_iterator-1] != ""){ # Add the separator if the rgroup wasn't added so that it's included in the regular cells rgroup_sep_style = css.rgroup.sep[rgroup_iterator-1] } } cell_style <- rs <- paste("background-color:", row_clrs[row_nr]) if (first_row){ rs %<>% c(top_row_style) cell_style %<>% c(top_row_style) }else if(rgroup_sep_style != FALSE){ rs %<>% c(rgroup_sep_style) } first_row <- FALSE if (row_nr == nrow(x)){ cell_style %<>% c(bottom_row_style) } if (row_nr %in% total){ cell_style %<>% c(css.total[which(row_nr == total)]) } if (prGetStyle(rs) == ""){ table_str %<>% paste0("\n\t") }else{ table_str %<>% sprintf("%s\n\t", ., prGetStyle(rs)) } if (!prSkipRownames(rnames)){ pdng <- padding.tspanner # Minor change from original function. If the group doesn't have # a group name then there shouldn't be any indentation if (!missing(rgroup) && rgroup_iterator > 0 && is.na(rgroup[rgroup_iterator]) == FALSE && rgroup[rgroup_iterator] != ""){ pdng %<>% paste0(padding.rgroup) } # The padding doesn't work well with the Word import - well nothing really works well with word... # table_str <- sprintf("%s\n\t\t", table_str, rnames[row_nr]) table_str %<>% sprintf("%s\n\t\t", ., prGetStyle(c(rname_style, cell_style), align=prGetAlign(align, 1)), pdng, rnames[row_nr]) } cell_str <- prAddCells(rowcells = x[row_nr,], cellcode = "td", align = align, style = cell_style, cgroup_spacer_cells = cgroup_spacer_cells, has_rn_col = !prSkipRownames(rnames)*1, col.columns = col.columns, css.cell = css.cell[row_nr, ]) table_str %<>% paste0(cell_str, "\n\t") } } # Close body table_str %<>% paste0("\n\t") if (!missing(caption) & compatibility == "LibreOffice" & pos.caption %in% c("bottom", "below")){ table_str %<>% sprintf("%s\n\t", ., total_columns, caption) } # Add footer if (!missing(tfoot)){ # Initiate the tfoot table_str %<>% sprintf("%s\n\t") } # Close table table_str %<>% paste0("\n
") }else{ table_str %<>% paste0("\n\t") } table_str %<>% paste0(caption, "
%s
%s%s%s
%s
", ., total_columns) # Add the actual tfoot to a new row table_str %<>% paste0("\n\t", txtMergeLines(tfoot)) # Close the tfoot table_str %<>% paste0("
") # Fix indentation issue with pandoc v1.13 table_str %<>% gsub("\t", "", .) class(table_str) <- c("htmlTable", class(table_str)) attr(table_str, "...") <- list(...) # Add html class if this is a table inside a notebook for inline output if (!getOption('htmlTable.skip_notebook', FALSE) && prIsNotebook()) { class(table_str) <- c("html", class(table_str)) attr(table_str, "html") <- TRUE } return(table_str) } #' Detects if the call is made from within an RStudio Rmd file or a file #' with the html_notebook output set. #' @importFrom rstudioapi isAvailable getActiveDocumentContext #' @keywords internal prIsNotebook <- function() { if (!isAvailable()) { return(FALSE) } ctxt <- getActiveDocumentContext() if (grepl("\\.Rmd$", ctxt$path)) { return(TRUE) } # Look for html_notebook within the header if the file hasn't been saved contents <- ctxt$contents header <- grep("^---$", contents) if (length(header) == 2) { return(any(grepl("html_notebook$", contents[min(header) : max(header)]))) } return(FALSE) } #' Convert all factors to characters to print them as they expected #' #' @inheritParams htmlTable #' @return The data frame with factors as characters prConvertDfFactors <- function(x){ if (!"data.frame" %in% class(x)) return(x) i <- sapply(x, function(col) ( ( !is.numeric(col) && !is.character(col) ) || ( inherits(col, "times") # For handlin Chron input ) ) ) if(any(i)){ x[i] <- lapply(x[i], as.character) } return (x) } #' @export htmlTable.data.frame <- function(x, ...) { # deal gracefully with an empty dataframe - issue a warning. if(nrow(x) == 0){ warning(paste(deparse(substitute(x)), "is an empty object")) } htmlTable.default(prConvertDfFactors(x),...) } #' @export htmlTable.matrix <- function(x, total, ...) { # deal gracefully with an empty matrix - issue a warning. if(nrow(x) == 0){ warning(paste(deparse(substitute(x)), "is an empty object")) } if (all(class(x) %in% c("table", "matrix", "array")) && !is.null(rownames(x)) && grepl("^sum$", tail(rownames(x), 1), ignore.case = TRUE) && missing(total)) { total = TRUE } htmlTable.default(x, total = total, ...) } #' @importFrom methods setClass setClass("htmlTable", contains = "character") #' @rdname htmlTable #' @importFrom knitr knit_print #' @importFrom knitr asis_output #' @export knit_print.htmlTable<- function(x, ...){ asis_output(x) } #' @rdname htmlTable #' @param useViewer If you are using RStudio there is a viewer thar can render #' the table within that is envoced if in \code{\link[base]{interactive}} mode. #' Set this to \code{FALSE} if you want to remove that functionality. You can #' also force the function to call a specific viewer by setting this to a #' viewer function, e.g. \code{useViewer = utils::browseURL} if you want to #' override the default RStudio viewer. Another option that does the same is to #' set the \code{options(viewer=utils::browseURL)} and it will default to that #' particular viewer (this is how RStudio decides on a viewer). #' \emph{Note:} If you want to force all output to go through the #' \code{\link[base]{cat}()} the set \code{\link[base]{options}(htmlTable.cat = TRUE)}. #' @export #' @importFrom utils browseURL print.htmlTable<- function(x, useViewer, ...){ args <- attr(x, "...") # Use the latest ... from the print call # and override the original htmlTable call ... # if there is a conflict print_args <- list(...) for (n in names(print_args)){ args[[n]] <- print_args[[n]] } # Since the print may be called from another print function # it may be handy to allow functions to use attributes for the # useViewer parameter if (missing(useViewer)){ if ("useViewer" %in% names(args) && (is.logical(args$useViewer) || is.function(args$useViewer))){ useViewer <- args$useViewer args$useViewer <- NULL }else{ useViewer <- TRUE } } if (interactive() && !getOption("htmlTable.cat", FALSE) && (is.function(useViewer) || useViewer != FALSE)) { if (is.null(args$file)){ args$file <- tempfile(fileext=".html") } htmlPage <- paste("", "", "", "", "", "
", enc2utf8(x), "
", "", "", sep="\n") # We only want to use those arguments that are actually in cat # anything else that may have inadvertadly slipped in should # be ignored or it will be added to the output cat_args <- args cat_args <- cat_args[names(cat_args) %in% names(formals(cat))[-1]] do.call(cat, c(htmlPage, cat_args)) if (is.function(useViewer)){ useViewer(args$file) }else{ viewer <- getOption("viewer") if (!is.null(viewer) && is.function(viewer)){ # (code to write some content to the file) viewer(args$file) }else{ utils::browseURL(args$file) } } }else{ cat_args <- args cat_args <- cat_args[names(cat_args) %in% names(formals(cat))[-1]] do.call(cat, c(x, cat_args)) } invisible(x) } #' Gets the last table number #' #' The function relies on \code{options("table_counter")} #' in order to keep track of the last number. #' #' @param roman Whether or not to use roman numbers instead #' of arabic. Can also be set through \code{options(table_caption_no_roman = TRUE)} #' #' @export #' @examples #' org_opts <- options(table_counter=1) #' tblNoLast() #' options(org_opts) #' @family table functions #' @importFrom utils as.roman tblNoLast <- function(roman = getOption("table_counter_roman", FALSE)){ last_no <- getOption("table_counter") if (is.logical(last_no) || is.null(last_no)){ stop("You cannot call the get last figure number", " when there has been no prior figure registerd.", " In other words, you need to call the fiCapNo()", " on a figure before you call this function.", " If you want the next number then call figCapNoNext()", " instead of this function.") } if (roman) last_no <- as.character(as.roman(last_no)) return(last_no) } #' Gets the next table number #' #' The function relies on \code{options("table_counter")} #' in order to keep track of the last number. #' #' @inheritParams tblNoLast #' @export #' @examples #' org_opts <- options(table_counter=1) #' tblNoNext() #' options(org_opts) #' @family table functions #' @importFrom utils as.roman tblNoNext <- function(roman = getOption("table_counter_roman", FALSE)){ last_no <- getOption("table_counter") if (is.logical(last_no)){ if (last_no == FALSE) stop("You cannot call the get last figure number", " when you have explicitly set the fig_cap_no", " option to false.") last_no <- 0 }else if (is.null(last_no)){ last_no <- 0 } next_no <- last_no + 1 if (roman) next_no <- as.character(as.roman(next_no)) return(next_no) } htmlTable/R/tidyHtmlTable.R0000644000176200001440000003557113407215301015267 0ustar liggesusers#' Generate an htmlTable using a ggplot2-like interface #' #' Builds an \code{htmlTable} by mapping columns from the input data, \code{x}, #' to elements of an output \code{htmlTable} (e.g. rnames, header, etc.) #' #' @section Column-mapping parameters: #' The \code{tidyHtmlTable} function is designed to work like ggplot2 in that #' columns from \code{x} are mapped to specific parameters from the #' \code{htmlTable} function. At minimum, \code{x} must contain the names #' of columns mapping to \code{rnames}, \code{header}, and \code{rnames}. #' \code{header} and \code{rnames} retain the same meaning as in the #' htmlTable function. \code{value} contains the individual values that will #' be used to fill each cell within the output \code{htmlTable}. #' #' A full list of parameters from \code{htmlTable} which may be mapped to #' columns within \code{x} include: #' #' \itemize{ #' \item \code{value} #' \item \code{header} #' \item \code{rnames} #' \item \code{rgroup} #' \item \code{cgroup1} #' \item \code{cgroup2} #' \item \code{tspanner} #' } #' #' Note that unlike in \code{htmlTable} which contains \code{cgroup}, #' and which may specify a variable number of column groups, #' \code{tidyhtmlTable} contains the parameters \code{cgroup1} and #' \code{cgroup2}. These parameters correspond to the inward most and outward #' most column groups respectively. #' #' Also note that the coordinates of each \code{value} within \code{x} must be #' unambiguously mapped to a position within the output \code{htmlTable}. #' Therefore, the each row-wise combination the variables specified above #' contained in \code{x} must be unique. #' #' @section Hidden values: #' \code{htmlTable} Allows for some values within \code{rgroup}, #' \code{cgroup}, etc. to be specified as \code{""}. The following parameters #' allow for specific values to be treated as if they were a string of length #' zero in the \code{htmlTable} function. #' #' \itemize{ #' \item \code{hidden_rgroup} #' \item \code{hidden_tspanner} #' } #' @section Additional dependencies: #' In order to run this function you also must have \code{\link[dplyr]{dplyr}} and #' \code{\link[tidyr]{tidyr}} packages installed. These have been removed due to #' the additional 20 Mb that these dependencies added (issue #47). The particular #' functions required are: #' #' \itemize{ #' \item \code{\link[dplyr]{dplyr}}: #' \code{mutate_at}, #' \code{select}, #' \code{pull}, #' \code{slice}, #' \code{filter}, #' \code{arrange_at}, #' \code{mutate_if}, #' \code{is.grouped_df}, #' \code{left_join} #' \item \code{\link[tidyr]{tidyr}}: \code{spread} #' } #' #' @param x Tidy data used to build the \code{htmlTable} #' @param value The column containing values filling individual cells of the #' output \code{htmlTable} #' @param header The column in \code{x} specifying column headings #' @param rnames The column in \code{x} specifying row names #' @param rgroup The column in \code{x} specifying row groups #' @param hidden_rgroup rgroup values that will be hidden. #' @param cgroup1 The column in \code{x} specifying the inner most column #' groups #' @param cgroup2 The column in \code{x} specifying the outer most column #' groups #' @param tspanner The column in \code{x} specifying tspanner groups #' @param hidden_tspanner tspanner values that will be hidden. #' @param ... Additional arguments that will be passed to the inner #' \code{htmlTable} function #' @return Returns html code that will build a pretty table #' @export #' @seealso \code{\link{htmlTable}} #' @examples #' \dontrun{ #' library(tidyverse) #' mtcars %>% #' rownames_to_column %>% #' select(rowname, cyl, gear, hp, mpg, qsec) %>% #' gather(per_metric, value, hp, mpg, qsec) %>% #' group_by(cyl, gear, per_metric) %>% #' summarise(Mean = round(mean(value), 1), #' SD = round(sd(value), 1), #' Min = round(min(value), 1), #' Max = round(max(value), 1)) %>% #' gather(summary_stat, value, Mean, SD, Min, Max) %>% #' ungroup %>% #' mutate(gear = paste(gear, "Gears"), #' cyl = paste(cyl, "Cylinders")) %>% #' tidyHtmlTable(header = "gear", #' cgroup1 = "cyl", #' cell_value = "value", #' rnames = "summary_stat", #' rgroup = "per_metric") #' } tidyHtmlTable <- function(x, value = "value", header = "header", rnames = "rnames", rgroup = NULL, hidden_rgroup = NULL, cgroup1 = NULL, cgroup2 = NULL, tspanner = NULL, hidden_tspanner = NULL, ...) { UseMethod("tidyHtmlTable") } #' @export tidyHtmlTable.default <- function(x, ...) { stop("x must be of class data.frame") } #' @export tidyHtmlTable.data.frame <- function(x, value = "value", header = "header", rnames = "rnames", rgroup = NULL, hidden_rgroup = NULL, cgroup1 = NULL, cgroup2 = NULL, tspanner = NULL, hidden_tspanner = NULL, ...) { # You need the suggested package for this function safeLoadPkg("dplyr") safeLoadPkg("tidyr") argument_checker(x, value = value, header = header, rnames = rnames, rgroup = rgroup, hidden_rgroup = NULL, cgroup1 = cgroup1, cgroup2 = cgroup2, tspanner = tspanner, hidden_tspanner = NULL) check_uniqueness(x, header = header, rnames = rnames, rgroup = rgroup, cgroup1 = cgroup1, cgroup2 = cgroup2, tspanner = tspanner) x <- remove_na_rows(x, header = header, rnames = rnames, rgroup = rgroup, cgroup1 = cgroup1, cgroup2 = cgroup2, tspanner = tspanner) # Create tables from which to gather row, column, and tspanner names # and indices row_ref_tbl <- x %>% get_row_tbl(rnames = rnames, rgroup = rgroup, tspanner = tspanner) # Hide row groups specified in hidden_rgroup if (!(is.null(hidden_rgroup))) { row_ref_tbl <- row_ref_tbl %>% dplyr::mutate_at(rgroup, function(x){ifelse(x %in% hidden_rgroup, "", x)}) } # Hide tspanners specified in hidden_tspanner if (!(is.null(hidden_tspanner))) { row_ref_tbl <- row_ref_tbl %>% dplyr::mutate_at(tspanner, function(x){ifelse(x %in% hidden_tspanner, "", x)}) } col_ref_tbl <- x %>% get_col_tbl(header = header, cgroup1 = cgroup1, cgroup2 = cgroup2) # Format the values for display to_select <- c("r_idx", "c_idx", value) formatted_df <- x %>% add_col_idx(header = header, cgroup1 = cgroup1, cgroup2 = cgroup2) %>% add_row_idx(rnames = rnames, rgroup = rgroup, tspanner = tspanner) %>% dplyr::select(to_select) %>% dplyr::mutate_at(value, as.character) %>% # Spread will fill missing values (both explict and implicit) with the # same value, so we need to convert these values to a character if we want # them to show up correctly in the final table tidyr::spread(key = "c_idx", value = value, fill = "") formatted_df$r_idx <- NULL # Get names and indices for row groups and tspanners htmlTable_args <- list(x = formatted_df, rnames = row_ref_tbl %>% dplyr::pull(rnames), header = col_ref_tbl %>% dplyr::pull(header), ...) if (!is.null(rgroup)) { # This will take care of a problem in which adjacent row groups # with the same value will cause rgroup and tspanner collision comp_val <- row_ref_tbl %>% dplyr::pull(rgroup) if (!is.null(tspanner)) { comp_val <- paste0(comp_val, row_ref_tbl %>% dplyr::pull(tspanner)) } lens <- rle(comp_val)$lengths idx <- cumsum(lens) htmlTable_args$rgroup <- row_ref_tbl %>% dplyr::slice(idx) %>% dplyr::pull(rgroup) htmlTable_args$n.rgroup <- lens } if (!is.null(tspanner)) { htmlTable_args$tspanner <- rle(row_ref_tbl %>% dplyr::pull(tspanner))$value htmlTable_args$n.tspanner <- rle(row_ref_tbl %>% dplyr::pull(tspanner))$lengths } # Get names and indices for column groups if(!is.null(cgroup1)) { cgroup1_out <- rle(col_ref_tbl %>% dplyr::pull(cgroup1))$value n.cgroup1 <- rle(col_ref_tbl %>% dplyr::pull(cgroup1))$lengths if(!is.null(cgroup2)) { cgroup2_out <- rle(col_ref_tbl %>% dplyr::pull(cgroup2))$value n.cgroup2 <- rle(col_ref_tbl %>% dplyr::pull(cgroup2))$lengths len_diff <- length(cgroup1_out) - length(cgroup2_out) if (len_diff < 0) { stop("cgroup2 cannot contain more categories than cgroup1") } else if (len_diff > 0) { cgroup2_out <- c(cgroup2, rep(NA, len_diff)) n.cgroup2 <- c(n.cgroup2, rep(NA, len_diff)) } cgroup1_out <- rbind(cgroup2, cgroup1) n.cgroup1 <- rbind(n.cgroup2, n.cgroup1) } htmlTable_args$cgroup <- cgroup1_out htmlTable_args$n.cgroup <- n.cgroup1 } do.call(htmlTable, htmlTable_args) } # You need the suggested package for this function safeLoadPkg <- function(pkg) { if (!requireNamespace(pkg, quietly = TRUE)) { stop("The package ", pkg, " is needed for this function to work. Please install it.", call. = FALSE) } } # Removes rows containing NA values in any mapped columns from the tidy dataset remove_na_rows <- function(x, ...) { cols <- as.character(get_col_vars(...)) na.log <- x %>% dplyr::select(cols) %>% is.na na.row.sums <- na.log %>% rowSums keep.idx <- na.row.sums == 0 removed <- sum(na.row.sums > 0) if (removed != 0) { na.col.sums <- na.log %>% colSums na.cols <- colnames(na.log)[na.col.sums > 0] warning(paste0("NA values were detected in the following columns of ", "the tidy dataset: ", paste(na.cols, collapse = ", "), ". ", removed, " row(s) in the tidy dataset were removed.")) } return(x %>% dplyr::filter(keep.idx)) } # This checks to make sure that the mapping columns of the tidy dataset # uniquely specify a given value check_uniqueness <- function(x, ...) { # Get arguments args <- simplify_arg_list(...) cols <- as.character(args) dupes <- x %>% dplyr::select(cols) %>% duplicated if (sum(dupes) != 0) { stop(paste0("The input parameters ", paste(paste0("\"", names(args), "\""), collapse = ", "), " do not specify unique rows. The following rows ", "are duplicated: ", paste(which(dupes), collapse = ", "))) } } # Converts arguments from ... into a list and removes those that have been set # to NULL simplify_arg_list <- function(...) { x <- list(...) idx <- sapply(x, is.null) return(x[!idx]) } # This function gets arguments from ..., removes those that are NULL, # and then subsets those that should map tidy data columns to htmlTable # parameters get_col_vars <- function(...) { out <- simplify_arg_list(...) return(out[names(out) %in% c("value", "header", "rnames", "rgroup", "cgroup1", "cgroup2", "tspanner")]) } # Checks a variety of assumptions about input arguments and prepares an # appropriate error message if those assumptions are violated argument_checker <- function(x, ...) { # Check if x is a grouped tbl_df if(dplyr::is.grouped_df(x)) { stop("x cannot be a grouped_df") } # Check that all the input are characters all_args <- simplify_arg_list(...) idx <- which(!sapply(all_args, is.character)) if (length(idx) > 0) { stop("The following parameters must be of type character: ", paste(names(all_args)[idx], collapse = ", ")) } # Check that all of the arguments that would be used map columns to # character attributes are of length 1 col_vars <- get_col_vars(...) idx <- which(sapply(col_vars, length) > 1) if (length(idx) > 0) { stop("The following parameters must be of length 1: ", paste(names(col_vars)[idx], collapse = ", ")) } # Find column variables that are not columns in the dataset idx <- which(!(as.character(col_vars) %in% colnames(x))) if (length(idx) > 0) { stop("The following arguments need values that correspond to column ", "names in x: ", paste0(names(col_vars), " = ", as.character(col_vars), collapse = ", ")) } } get_col_tbl <- function(x, header, cgroup1 = NULL, cgroup2 = NULL) { cols <- c(cgroup2, cgroup1, header) out <- x %>% dplyr::select(cols) %>% unique %>% dplyr::arrange_at(cols) %>% # This is necessary in order to not generate NA values when setting # hidden elements to "" dplyr::mutate_if(is.factor, as.character) out$c_idx <- 1:nrow(out) return(out) } get_row_tbl <- function(x, rnames, rgroup = NULL, tspanner = NULL) { cols <- c(tspanner, rgroup, rnames) out <- x %>% dplyr::select(cols) %>% unique %>% dplyr::arrange_at(cols) %>% # This is necessary in order to not generate NA values when setting # hidden elements to "" dplyr::mutate_if(is.factor, as.character) out$r_idx <- 1:nrow(out) return(out) } add_col_idx <- function(x, header, cgroup1 = NULL, cgroup2 = NULL) { cols <- c(cgroup2, cgroup1, header) col_idx_df <- x %>% get_col_tbl(header = header, cgroup1 = cgroup1, cgroup2 = cgroup2) out <- suppressWarnings( x %>% dplyr::left_join(col_idx_df, cols) ) return(out) } add_row_idx <- function(x, rnames, rgroup = NULL, tspanner = NULL) { cols <- c(tspanner, rgroup, rnames) row_idx_df <- x %>% get_row_tbl(rnames = rnames, rgroup = rgroup, tspanner = tspanner) out <- suppressWarnings( x %>% dplyr::left_join(row_idx_df, by = cols) ) return(out) } htmlTable/R/concatHtmlTables.R0000644000176200001440000000201013407215301015726 0ustar liggesusers#' Funciton for concatenating htmlTables #' #' @param tables A list of html tables to be concatenated #' @param headers Either a string or a vector of strings that function as #' a header for each table. If none is provided it will use the names of #' the table list or a numeric number. #' @return htmlTable class object #' @example inst/examples/htmlTable_example.R #' @export concatHtmlTables <- function(tables, headers) { assert_list(tables) if (missing(headers)){ if (!is.null(names(tables))) { headers = sprintf("

%s

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

Table no. %d

", 1:length(tables)) } } else { headers = rep(headers, length.out = length(tables)) } ret = paste(headers[1], tables[[1]]) for (i in 2:length(tables)) { ret = paste0( ret, headers[i], tables[[i]] ) } # Copy all the attributes from the first table attributes(ret) <- attributes(tables[[1]]) class(ret) <- c('htmlTable', class(tables[[1]])) return (ret) }htmlTable/R/htmlTable_helpers.R0000644000176200001440000010560013541425171016155 0ustar liggesusers#' Gets the table counter string #' #' Returns the string used for htmlTable to number the different tables. #' Uses options \code{table_counter}, \code{table_counter_str}, #' and \code{table_counter_roman} to produce the final string. You #' can set each option by simply calling \code{options()}. #' #' @param The caption #' @return \code{string} Returns a string formatted according to #' the table_counter_str and table_counter_roman. The number is #' decided by the table_counter variable #' @keywords internal #' @family hidden helper functions for htmlTable #' @importFrom utils as.roman prTblNo <- function (caption) { tc <- getOption("table_counter", FALSE) if (tc == FALSE){ if (missing(caption)) return("") else return(caption) } table_template <- getOption("table_counter_str", "Table %s: ") out <- sprintf(table_template, ifelse(getOption("table_counter_roman", FALSE), as.character(as.roman(tc)), as.character(tc))) if (!missing(caption)) out <- paste(out, caption) return(out) } #' Remove html entities from table #' #' Removes the htmlEntities from table input data. Note that #' this also replaces $ signs in order to remove the MathJax #' issue. #' #' @importFrom htmltools htmlEscape #' #' @inheritParams htmlTable #' @return \code{x} without the html entities #' @family hidden helper functions for htmlTable prEscapeHtml <- function(x) { attributes_x <- attributes(x) x <- lapply(x, htmlEscape) x <- lapply(x, function(x) str_replace_all(x, "\\$", "$")) attributes(x) <- attributes_x return (x) } #' Gets the CSS style element #' #' A funciton for checking, merging, and more #' with a variety of different style formats. #' #' @param styles The styles can be provided as \code{vector}, #' \code{named vector}, or \code{string}. #' @param ... All styles here are merged with the first parameter. #' If you provide a name, e.g. \code{styles="background: blue", align="center"} #' the function will convert the \code{align} into proper \code{align: center}. #' @return \code{string} Returns the codes merged into one string with #' correct CSS ; and : structure. #' @keywords internal #' @import magrittr #' @family hidden helper functions for htmlTable prGetStyle <- function(...){ mergeNames <- function(sv){ sv <- sv[!is.na(sv)] if (!is.null(names(sv))){ sv <- mapply(function(n, v){ if (n == "") return(v) paste0(n, ": ", v) }, n=names(sv), v=sv, USE.NAMES=FALSE) } return(sv) } spltNames <- function(sv){ ret_sv <- c() for (i in 1:length(sv)) ret_sv <- c(ret_sv, # Split on the ; in case it is not at the end/start unlist(strsplit(sv[i], "\\b;(\\b|\\W+)", perl=TRUE))) return(ret_sv) } styles <- c() dots <- list(...) if (length(dots) == 0) return("") for (i in 1:length(dots)){ element <- dots[[i]] if (length(element) == 1){ if (element == "") next if (!grepl("\\b[:](\\b|\\W+)", element, perl=TRUE)){ if(!is.null(names(element))){ element <- paste0(names(element), ": ", element) }else if(!is.null(names(dots)) && names(dots)[i] != ""){ element <- paste0(names(dots)[i], ": ", element) }else if(element != "none") { stop("The style should be formatted according to 'style_name: value'", " you have provided style '", element,"'") } } styles %<>% c(element) }else{ if (!is.null(names(element))){ element <- mergeNames(element) } styles <- c(styles, spltNames(element)) } } if (!all(grepl("^[^:]+:.+", styles))) stop("Invalid styles detected, one or more styles lack the needed style 'name: value': ", paste(paste0("'", styles[!grepl("^[^:]+:.+", styles)], "'"), collapse=", ")) # Remove empty background colors - sometimes a background color appears with # just background-color:; for some unknown reason if (any(grepl("^background-color:( none|[ ]*;*$)", styles))){ styles <- styles[-grep("^background-color:( none|[ ]*;*$)", styles)] } # Merge background colors if (sum(grepl("^background-color:", styles)) > 1){ clrs <- styles[grep("^background-color:", styles)] clrs <- gsub("^background-color:[ ]*([^;]+);*", "\\1", clrs) clr <- prMergeClr(clrs) # Pick a color merge styles <- styles[-grep("^background-color:", styles)] styles <- c(styles, paste0("background-color: ", clr)) } style_names <- gsub("^([^:]+).+", "\\1", styles) if (!any(duplicated(style_names))){ unique_styles <- styles }else{ # Only select the last style if two of the same type # exist. This in order to avoid any conflicts. unique_styles <- c() for(n in unique(style_names)){ unique_styles <- c(unique_styles, styles[max(which(n == style_names))]) } } unique_styles <- sapply(unique_styles, prAddSemicolon2StrEnd, USE.NAMES = FALSE) paste(unique_styles, collapse=" ") } #' Add a ; at the end #' #' The CSS expects a semicolon at the end of each argument #' this function just adds a semicolong if none is given #' and remove multiple semicolon if such exist #' #' @param my_str The string that is to be processed #' @return \code{string} #' @keywords internal #' @family hidden helper functions for htmlTable #' @importFrom utils tail prAddSemicolon2StrEnd <- function(my_str){ if (!is.null(names(my_str))){ tmp <- str_trim(my_str) names(tmp) <- names(my_str) my_str <- tmp }else{ my_str <- str_trim(my_str) } my_str_n <- sapply(my_str, nchar, USE.NAMES = FALSE) if (any(my_str_n == 0)) my_str <- my_str[my_str_n > 0] if(length(my_str) == 0) return("") if (tail(strsplit(my_str, "")[[1]], 1) != ";"){ n <- names(my_str) my_str <- sprintf("%s;", my_str) if (!is.null(n)) names(my_str) <- n } # Remove duplicated ; my_str <- gsub(";;+", ";", my_str) empty_str <- sapply(my_str, function(x) x == ";", USE.NAMES = FALSE) if (any(empty_str)) my_str <- my_str[!empty_str] if(length(my_str) == 0) return("") return (my_str) } #' Retrieve a header row #' #' This function retrieves a header row, i.e. a row #' within the elements on top of the table. Used by #' \code{\link{htmlTable}}. #' #' @param cgroup_vec The cgroup may be a matrix, this is #' just one row of that matrix #' @param n.cgroup_vec The same as above but for the counter #' @param cgroup_vec.just The same as above bot for the justificaiton #' @param row_no The row number within the header group. Useful for multirow #' headers when we need to output the rowlabel at the \code{pos.rowlabel} #' level. #' @param css.cgroup_vec The CSS row corresponding to the current row #' @param top_row_style The top row has a special style depending on #' the \code{ctable} option in the \code{htmlTable} call. #' @param cgroup_spacer_cells The spacer cells due to the multiple cgroup levels. #' With multiple rows in cgroup we need to keep track of how many spacer cells #' occur between the columns. This variable contains is of the size \code{ncol(x)-1} #' and 0 if there is no cgroup element between. #' @return \code{string} #' @keywords internal #' @inheritParams htmlTable #' @family hidden helper functions for htmlTable prGetCgroupHeader <- function(x, cgroup_vec, n.cgroup_vec, cgroup_vec.just, css.cgroup_vec, row_no, top_row_style, rnames, rowlabel, pos.rowlabel, cgroup_spacer_cells, css.cell){ header_str <- "\n\t" if (row_no == 1) ts <- top_row_style else ts <- "" if (!missing(rowlabel)){ if (row_no == pos.rowlabel) header_str %<>% sprintf("%s\n\t\t%s", ., prGetStyle(c(`font-weight`=900), ts, attr(css.cell, "rnames")[1]), rowlabel) else header_str %<>% sprintf("%s\n\t\t", ., prGetStyle(ts)) }else if (!prSkipRownames(rnames)){ header_str %<>% sprintf("%s\n\t\t", ., prGetStyle(ts)) } for (i in 1:length(cgroup_vec)){ if (!is.na(n.cgroup_vec[i])){ start_column <- ifelse(i == 1, 1, sum(n.cgroup_vec[1:(i-1)], na.rm=TRUE) + 1) # 10 3-1 # 0 0 1 colspan <- n.cgroup_vec[i] + ifelse(start_column > length(cgroup_spacer_cells) || n.cgroup_vec[i] == 1, 0, ifelse(start_column == 1, sum(cgroup_spacer_cells[1:(n.cgroup_vec[i]-1)]), ifelse(sum(n.cgroup_vec[1:i], na.rm=TRUE) == ncol(x), sum(cgroup_spacer_cells[start_column:length(cgroup_spacer_cells)]), sum(cgroup_spacer_cells[start_column:((start_column-1) + (n.cgroup_vec[i]-1))])))) if (nchar(cgroup_vec[i]) == 0)# Removed as this may now be on purpose || is.na(cgroup_vec[i])) header_str %<>% sprintf("%s\n\t\t", ., colspan, prGetStyle(c(`font-weight`=900), ts, align=prGetAlign(cgroup_vec.just, i), css.cgroup_vec[i])) else header_str %<>% sprintf("%s\n\t\t%s", ., colspan, prGetStyle(c(`font-weight`=900, `border-bottom`="1px solid grey"), ts, align=prGetAlign(cgroup_vec.just, i), css.cgroup_vec[i]), cgroup_vec[i]) # If not last then add a filler cell between the row categories # this is also the reason that we need the cgroup_spacer_cells if (i != sum(!is.na(cgroup_vec))) header_str %<>% sprintf("%s ", ., ts) } } header_str %<>% paste0("\n\t") return(header_str) } #' Prepares the cgroup argument #' #' Due to the complicated structure of multilevel cgroups there #' some preparation for the cgroup options is required. #' #' @inheritParams htmlTable #' @return \code{list(cgroup, n.cgroup, align.cgroup, cgroup_spacer_cells)} #' @keywords internal #' @family hidden helper functions for htmlTable prPrepareCgroup <- function(x, cgroup, n.cgroup, align.cgroup, css.cgroup){ cgroup_spacer_cells <- rep(0, times=(ncol(x)-1)) # The cgroup is by for compatibility reasons handled as a matrix if (is.list(cgroup)) { if (!is.list(n.cgroup)) stop("If cgroup is a list then so must n.cgroup") if (length(n.cgroup) != length(cgroup)) stop("Different length of cgroup and n.cgroup") if (!all(sapply(cgroup, is.vector))) stop("The cgroup list consist of vectors") lengths <- sapply(n.cgroup, sum) if (any(is.na(lengths))) stop("The cgroup has invalid lengths!") for (i in 1:length(cgroup)) { if (length(cgroup[[i]]) != length(n.cgroup[[i]])) stop("The cgroup and n.cgroup elemennt's lengths don't match for the ", i, "th element") } ncols <- max(lengths, na.rm=TRUE) if (any(sapply(lengths, function(l) ncol(x) %% l != 0))) { stop("Invalid size of lists: ", vector2string(lengths), " each element should be be able to evenly divide ", ncol(x)) } cgroup_mtrx <- matrix(nrow = length(cgroup), ncol = ncols) n.cgroup_mtrx <- matrix(nrow = length(cgroup), ncol = ncols) for (i in 1:length(cgroup)) { for (ii in 1:length(cgroup[[i]])) { cgroup_mtrx[i, ii] <- cgroup[[i]][ii] n.cgroup_mtrx[i, ii] <- n.cgroup[[i]][ii] } } cgroup <- cgroup_mtrx n.cgroup <- n.cgroup_mtrx } else if (!is.matrix(cgroup)){ cgroup <- matrix(cgroup, nrow=1) if (missing(n.cgroup)) n.cgroup <- matrix(NA, nrow=1) else{ if (any(n.cgroup < 1)){ warning("You have provided cgroups with less than 1 element,", " these will therefore be removed: ", paste(sprintf("'%s' = %d", cgroup, n.cgroup)[n.cgroup < 1], collapse=", ")) cgroup <- cgroup[,n.cgroup >= 1, drop=FALSE] n.cgroup <- n.cgroup[n.cgroup >= 1] } if (ncol(cgroup) != length(n.cgroup)){ n.cgroup <- n.cgroup[n.cgroup > 0] if (ncol(cgroup) < length(n.cgroup)) stop("You have provided too many n.cgroup,", " it should have the same length or one less than the cgroup (", ncol(cgroup), ")", " but it has the length of ", length(n.cgroup)) if (ncol(cgroup) - 1 < length(n.cgroup)) stop("You have provided too few n.cgroup,", " it should have the ate the length or one less than the cgroup (", ncol(cgroup), ")", " but it has the length of ", length(n.cgroup)) if (ncol(cgroup) - 1 == length(n.cgroup)) n.cgroup <- c(n.cgroup, ncol(x) - sum(n.cgroup)) } n.cgroup <- matrix(n.cgroup, nrow=1) } }else if(missing(n.cgroup)){ stop("If you specify the cgroup argument as a matrix you have to", " at the same time specify the n.cgroup argument.") } # Go bottom up as the n.cgroup can be based on the previous # n.cgroup row. for (i in nrow(cgroup):1){ # The row is empty and filled with NA's then we check # that it is possible to evenly split the cgroups among # the columns of the table if (all(is.na(n.cgroup[i,])) && ncol(x) %% length(cgroup[i,]) == 0){ # This generates the n.cgroup if this is missing n.cgroup[i,] <- rep(ncol(x)/length(cgroup[i,]), times=length(cgroup[i,])) }else if(any(n.cgroup[i,!is.na(n.cgroup[i,])] < 1)){ stop("You have in n.cgroup row no ", i, " cell(s) with < 1") }else if(sum(n.cgroup[i,], na.rm=TRUE) != ncol(x)){ ncgroupFixFromBelowGroup <- function(nc, i){ if (i+1 > nrow(nc)) stop("You have provided an invalid nc", " where it has fewer rows than the one of interest") # Select those below that are not missing row_below <- nc[i + 1, !is.na(nc[i + 1, ])] # The first position to start start_pos <- 1 # This is a slightly complicated run that took a while to figure out # and I'm still afraid of ever having to debug this section. for (ii in 1:ncol(nc)){ if (!is.na(nc[i, ii])){ # Need to find where to begin tha addition pos <- ifelse(any(start_pos > cumsum(row_below)), tail(which(start_pos > cumsum(row_below)), 1) + 1, 1) # Change the value to the rows below values that add up to this row # if the nc value is 1 and start position is 1 -> 1:(1+1-1) -> 1:1 -> 1 # if the nc value is 2 and start position is 2 -> 2:(2+2-1) -> 2:3 # if the nc value is 2 and start position is 1 -> 1:(1+2-1) -> 1:2 nc[i, ii] <- sum(row_below[pos:(pos + nc[i, ii] - 1)]) # Update the new start position: # if first run and nc is 2 then 1 + 2 -> 3 i.e. # next run the start_pos is 3 and lets say that nc is 3 then 3 + 3 -> 6 start_pos <- start_pos + nc[i, ii] } } # Return the full object return(nc) } # This grouping can be based upon the next row if (i < nrow(cgroup) && sum(n.cgroup[i, ], na.rm = TRUE) == sum(!is.na(n.cgroup[i + 1, ]))) { n.cgroup <- ncgroupFixFromBelowGroup(n.cgroup, i) }else{ stop(sprintf("Your columns don't match in the n.cgroup for the %d header row, i.e. %d != %d", i, sum(n.cgroup[i,], na.rm=TRUE), ncol(x))) } } if (!all(is.na(n.cgroup[i, ]) == is.na(cgroup[i, ]))){ stop("On header row (the cgroup argument) no ", i, " you fail to get the NA's matching.", "\n The n.cgroup has elements no:", sprintf(" '%s'", paste(which(is.na(n.cgroup[i, ])), collapse=", ")), " missing while cgroup has elements no:", sprintf(" '%s'", paste(which(is.na(cgroup[i, ])), collapse=", ")), " missing.", "\n If the NA's don't occur at the same point", " the software can't decide what belongs where.", "\n The full cgroup row: ", paste(cgroup[i, ], collapse=", "), "\n The full n.cgroup row: ", paste(n.cgroup[i, ], collapse=", "), "\n Example: for a two row cgroup it would be:", " n.cgroup = rbind(c(1, NA), c(2, 1)) and", " cgroup = rbind(c('a', NA), c('b', 'c'))") } # Add a spacer cell for each cgroup. If two cgroups # on different rows have the same separation then it # is enough to have one spacer. for (ii in 1:(length(n.cgroup[i, ])-1)){ if (!is.na(n.cgroup[i, ii]) && sum(n.cgroup[i, 1:ii], na.rm=TRUE) <= length(cgroup_spacer_cells)) cgroup_spacer_cells[sum(n.cgroup[i, 1:ii], na.rm=TRUE)] <- 1 } } # Get alignment if (missing(align.cgroup)){ align.cgroup <- apply(n.cgroup, 1, function(nc) paste(rep("c", times=sum(!is.na(nc))), collapse="")) align.cgroup <- matrix(align.cgroup, ncol = 1) }else{ if (NROW(align.cgroup) != nrow(n.cgroup)) stop("You have different dimensions for your align.cgroup and your cgroups, ", NROW(align.cgroup), " (just) !=", nrow(n.cgroup), " (n.cgroup)") # An old leftover behaviour from the latex() function if (NCOL(align.cgroup) > 1) align.cgroup <- apply(align.cgroup, 1, function(x) paste(ifelse(is.na(x), "", x), collapse="")) align.cgroup <- mapply(prPrepareAlign, align = align.cgroup, x = apply(n.cgroup, 1, function(nc) sum(!is.na(nc))), rnames=FALSE) align.cgroup <- matrix(align.cgroup, ncol=1) } css.cgroup <- prPrepareCss(x = cgroup, css = css.cgroup) return(list(cgroup = cgroup, n.cgroup = n.cgroup, align.cgroup = align.cgroup, cgroup_spacer_cells = cgroup_spacer_cells, css.cgroup = css.cgroup)) } #' Gets the rowlabel position #' #' @inheritParams htmlTable #' @return \code{integer} Returns the position within the header rows #' to print the \code{rowlabel} argument #' @keywords internal #' @family hidden helper functions for htmlTable prGetRowlabelPos <- function (cgroup, pos.rowlabel, header) { no_cgroup_rows <- ifelse(!missing(cgroup), nrow(cgroup), 0) no_header_rows <- no_cgroup_rows + (!missing(header))*1 if (is.numeric(pos.rowlabel)){ if(pos.rowlabel < 1) stop("You have specified a pos.rowlabel that is less than 1: ", pos.rowlabel) else if (pos.rowlabel > no_header_rows) stop("You have specified a pos.rowlabel that more than the max limit, ", no_header_rows, ", you have provided: ", pos.rowlabel) }else{ pos.rowlabel <- tolower(pos.rowlabel) if (pos.rowlabel %in% c("top")) pos.rowlabel <- 1 else if (pos.rowlabel %in% c("bottom", "header")) pos.rowlabel <- no_header_rows else stop("You have provided an invalid pos.rowlabel text,", " only 'top', 'bottom' or 'header' are allowed,", " can't interpret '", pos.rowlabel, "'") } return(pos.rowlabel) } #' Add a cell #' #' Adds a row of cells val... to a table string for #' \code{\link{htmlTable}} #' #' @inheritParams htmlTable #' @param rowcells The cells with the values that are to be added #' @param cellcode Type of cell, can either be \code{th} or \code{td} #' @param style The cell style #' @param cgroup_spacer_cells The number of cells that occur between #' columns due to the cgroup arguments. #' @param has_rn_col Due to the alignment issue we need to keep track #' of if there has already been printed a rowname column or not and therefore #' we have this has_rn_col that is either 0 or 1. #' @param offset For rgroup rows there may be an offset != 1 #' @param css.cell The css.cell but only for this row compared to the htmlTable matrix #' @return \code{string} Returns the string with the new cell elements #' @keywords internal #' @family hidden helper functions for htmlTable prAddCells <- function(rowcells, cellcode, align, style, cgroup_spacer_cells, has_rn_col, col.columns, offset = 1, css.cell){ cell_str <- "" style = prAddSemicolon2StrEnd(style) for (nr in offset:length(rowcells)){ cell_value <- rowcells[nr] # We don't want missing to be NA in a table, it should be empty if (is.na(cell_value)) cell_value <- "" cell_style <- c(css.cell[nr], style, prGetAlign(align, nr + has_rn_col)) if (!missing(col.columns)){ cell_style %<>% c(`background-color` = col.columns[nr]) } cell_str %<>% sprintf("%s\n\t\t<%s style='%s'>%s", ., cellcode, prGetStyle(cell_style), cell_value, cellcode) # Add empty cell if not last column if (nr != length(rowcells) && nr <= length(cgroup_spacer_cells) && cgroup_spacer_cells[nr] > 0){ spanner_style <- style if (!missing(col.columns)){ if (col.columns[nr] == col.columns[nr + 1]){ spanner_style %<>% c(`background-color` = col.columns[nr]) } } cell_str %<>% sprintf("%s\n\t\t<%s style='%s' colspan='%d'> ", ., cellcode, prGetStyle(spanner_style), cgroup_spacer_cells[nr], cellcode) } } return (cell_str) } #' Gets alignment #' #' @param index The index of the align parameter of interest #' @family hidden helper functions for #' @keywords internal #' @inheritParams htmlTable prGetAlign <- function(align, index) { segm_rgx <- "[^lrc]*[rlc][^lrc]*" res_align <- align align <- "" # Loop to remove every element prior to the one of interest for (i in 1:index){ if (nchar(res_align) == 0) stop("Requested column outside of span, ", index, " > ", i) rmatch <- regexpr(segm_rgx, res_align) lrc_data <- substr(res_align, 1, rmatch + attr(rmatch, "match.length") - 1) res_align <- substring(res_align, rmatch + attr(rmatch, "match.length")) } styles <- c() if (grepl("^[|]", lrc_data)) styles["border-left"] = "1px solid black" if (grepl("[|]$", lrc_data)) styles["border-right"] = "1px solid black" if (grepl("l", lrc_data)) styles["text-align"] = "left" if (grepl("c", lrc_data)) styles["text-align"] = "center" if (grepl("r", lrc_data)) styles["text-align"] = "right" return(styles) } #' Prepares the align to match the columns #' #' The alignment may be tricky and this function therefore simplifies #' this process by extending/shortening the alignment to match the #' correct number of columns. #' #' @param default_rn The default rowname alignment. This is an option #' as the header uses the same function and there may be differences in #' how the alignments should be implemented. #' @keywords internal #' @family hidden helper functions for htmlTable #' @inheritParams htmlTable prPrepareAlign <- function (align, x, rnames, default_rn = "l") { if (length(align) > 1) align <- paste(align, collapse="") segm_rgx <- "[^lrc]*[rlc][^lrc]*" no_elements <- length(strsplit(align, split = segm_rgx)[[1]]) no_cols <- ifelse(is.null(dim(x)), x, ncol(x)) if (!prSkipRownames(rnames)){ no_cols <- no_cols + 1 if (no_elements < no_cols){ align <- paste0(default_rn, align) } } res_align <- align align <- "" for (i in 1:no_cols){ rmatch <- regexpr(segm_rgx, res_align) tmp_lrc <- substr(res_align, 1, rmatch + attr(rmatch, "match.length") - 1) res_align <- substring(res_align, rmatch + attr(rmatch, "match.length")) align <- paste0(align, tmp_lrc) if (nchar(res_align) < 1 && i != no_cols){ align <- paste0(align, paste(rep(tmp_lrc, times=no_cols - i), collapse="")) break; } } structure(align, n = no_cols, class = class(align)) } #' Returns if rownames should be printed for the htmlTable #' #' @inheritParams htmlTable #' @keywords internal prSkipRownames <- function(rnames){ if(missing(rnames)) return(TRUE) if (length(rnames) == 1 && rnames == FALSE) return(TRUE) return(FALSE) } #' Prepares the alternating colors #' #' @param clr The colors #' @param n The number of rows/columns applicable to the color #' @param ng The n.rgroup/n.cgroup argument if applicable #' @param gtxt The rgroup/cgroup texts #' @return \code{character} A vector containing hexadecimal colors #' @import magrittr #' @keywords internal #' @importFrom grDevices col2rgb prPrepareColors <- function(clr, n, ng, gtxt){ clr <- sapply(clr, function(a_clr){ if(a_clr == "none") return(a_clr) if (grepl("^#[0-9ABCDEFabcdef]{3,3}$", a_clr)){ a_clr %<>% substring(first = 2) %>% strsplit(split = "") %>% unlist %>% sapply(FUN = rep, times=2) %>% paste(collapse="") %>% tolower %>% paste0("#", .) }else{ a_clr %<>% col2rgb %>% as.hexmode %>% as.character %>% paste(collapse="") %>% paste0("#", .) } }, USE.NAMES=FALSE) if(!missing(ng)){ # Split groups into separate if the gtxt is "" if (any(gtxt == "")){ tmp <- c() for (i in 1:length(ng)){ if (gtxt[i] != "" && !is.na(gtxt[i])){ tmp <- c(tmp, ng[i]) }else{ tmp <- c(tmp, rep(1, ng[i])) } } ng <- tmp } clr <- rep(clr, length.out = length(ng)) attr(clr, "groups") <- Map(rep, clr, length.out = ng) }else if(!missing(n)){ clr <- rep(clr, length.out = n) } return(clr) } #' Merges multiple colors #' #' Uses the \code{\link[grDevices]{colorRampPalette}} for merging colors. #' \emph{Note:} When merging more than 2 colors the order in the color #' presentation matters. Each color is merged with its neigbors before #' merging with next. If there is an uneven number of colors the middle #' color is mixed with both left and right side. #' #' @param clrs The colors #' @return \code{character} A hexadecimal color #' @import magrittr #' @keywords internal #' @importFrom grDevices colorRampPalette #' @importFrom utils head prMergeClr<- function(clrs){ if (length(clrs) == 1) return(clrs) if (length(clrs) == 2) return(colorRampPalette(clrs)(3)[2]) split_lngth <- floor(length(clrs)/2) left <- head(clrs, split_lngth) right <- tail(clrs, split_lngth) if (length(clrs) %% 2 == 1){ left %<>% c(clrs[split_lngth + 1]) right %<>% c(clrs[split_lngth + 1], .) } left <- prMergeClr(left) right <- prMergeClr(right) return(prMergeClr(c(left, right))) } #' Prepares the cell style #' #' @param css The CSS styles that are to be converted into #' a matrix. #' @param name The name of the CSS style that is prepared #' @inheritParams htmlTable #' @return \code{matrix} #' @keywords internal prPrepareCss <- function(x, css, rnames, header, name = deparse(substitute(css))){ css.header <- rep("", times = ncol(x)) css.rnames <- rep("", times = nrow(x) + !missing(header)) if (is.matrix(css)){ if (any(grepl("^[^:]*[a-zA-Z]+[:]*:", css))){ rownames(css) <- NULL colnames(css) <- NULL } if (ncol(css) == ncol(x) + 1 && !prSkipRownames(rnames)){ if (!missing(header)){ if (nrow(css) == nrow(x) + 1){ css.rnames <- css[,1] }else if(nrow(css) == nrow(x)){ css.rnames[2:length(css.rnames)] <- css[,1] }else{ stop("There is an invalid number of rows for the ", name ," matrix.", " Your x argument has '", nrow(x), "' rows", " while your ", name ," has '", nrow(css), "' rows", " and there is a header") } }else if(nrow(x) == nrow(css)){ css.rnames <- css[,1] }else{ stop("There is an invalid number of rows for the ", name ," matrix.", " Your x argument has '", nrow(x), "' rows", " while your ", name ," has '", nrow(css), "' rows", " (there is no header)") } css <- css[,-1,drop=FALSE] }else if (ncol(css) != ncol(x)){ stop("There is an invalid number of columns for the ", name ," matrix.", " Your x argument has '", ncol(x), "' columns", " while your ", name ," has '", ncol(css), "' columns", " and there are ", ifelse(prSkipRownames(rnames), "no", ""), " rownames.") } if (nrow(css) == nrow(x) + 1 && !missing(header)){ css.header <- css[1,] css <- css[-1,,drop=FALSE] }else if(nrow(css) != nrow(x)){ stop("There is an invalid number of rows for the ", name ," matrix.", " Your x argument has '", nrow(x), "' rows", " while your ", name ," has '", nrow(css), "' rows", " and there is ", ifelse(missing(header), "no", "a"), " header") } }else if(is.vector(css)){ if (length(css) == ncol(x) + 1){ css.rnames = rep(css[1], nrow(x) + prSkipRownames(rnames)) css <- css[-1] }else if(length(css) != ncol(x) && length(css) != 1){ stop("The length of your ", name ," vector '", length(css) ,"'", " does not correspond to the column length '", ncol(x) ,"'", " (there are ", ifelse(prSkipRownames(rnames), "no", ""), " rownames)") } css <- matrix(css, nrow=nrow(x), ncol=ncol(x), byrow = TRUE) } return(structure(css, rnames = css.rnames, header = css.header, class=class(css))) } #' Get the add attribute element #' #' Gets the add element attribute if it exists. If non-existant it will #' return NULL. #' #' @param rgroup_iterator The rgroup number of interest #' @param no_cols The \code{ncol(x)} of the core htmlTable x argument #' @inheritParams htmlTable #' @keywords internal #' @importFrom stats na.omit prAttr4RgroupAdd <- function (rgroup, rgroup_iterator, no_cols) { if (is.null(attr(rgroup, "add"))) return(NULL) add_elmnt <- attr(rgroup, "add") if (is.null(names(add_elmnt))){ if (is.null(dim(add_elmnt)) && length(add_elmnt) == sum(rgroup != "")){ if (!is.list(add_elmnt)) add_elmnt <- as.list(add_elmnt) names(add_elmnt) <- (1:length(rgroup))[rgroup != ""] }else if(!is.null(dim(add_elmnt)) && ncol(add_elmnt) %in% c(1, no_cols)){ # Convert matrix to stricter format tmp <- list() for (i in 1:nrow(add_elmnt)){ if (ncol(add_elmnt) == 1){ tmp[[i]] <- add_elmnt[i,] }else{ tmp2 <- as.list(add_elmnt[i,]) names(tmp2) <- 1:no_cols tmp[[i]] <- tmp2 } } if (nrow(add_elmnt) == sum(rgroup != "")){ names(tmp) <- (1:length(rgroup))[rgroup != ""] } else if (!is.null(rownames(add_elmnt))){ names(tmp) <- rownames(add_elmnt) } else { stop("You have provided a matrix as the add attribute to rgroups without rows that either match the number of rgroups available '", length(rgroup[rgroup != ""]), "'", " (you provided '", nrow(add_elmnt), "' rows).", " And you also failed to have rownames.") } add_elmnt <- tmp }else{ stop("The length of the rgroup 'add' attribute must either match", " (1) the length of the rgroup", " (2) or have names corresponding to the mapping integers") } } if (!is.list(add_elmnt) && !is.vector(add_elmnt)) stop("The rgroup mus either be a list or a vector") add_pos <- ifelse(grepl("^[123456789][0-9]*$", names(add_elmnt)), as.integer(names(add_elmnt)), NA) if (any(is.na(add_pos))){ # Look for rgroup names that match to those not # found through the integer match # If found the number is assigned to the add_pos available_rgroups <- rgroup if (!all(is.na(add_pos))) available_rgroups <- available_rgroups[-na.omit(add_pos)] for (missing_pos in which(is.na(add_pos))){ row_label <- names(add_elmnt) if (row_label %in% available_rgroups){ available_rgroups <- available_rgroups[available_rgroups != row_label] pos <- which(rgroup == row_label) if (length(pos) > 1){ stop("There seem to be two identical row groups ('", row_label, "')", " that you whish to assign a add columns to through the 'add'", " attribute for the rgroup element.") }else{ add_pos[missing_pos] <- pos } } } if (any(is.na(add_pos))) stop("Failed to find matchin rgroup elements for: ", "'", paste(names(add_elmnt)[is.na(add_pos)], collapse = "', '"), "'", " from availabel rgroups: ", "'", paste(rgroup, collapse = "', '"), "'") names(add_elmnt) <- add_pos } if (!is.list(add_elmnt)) add_elmnt <- as.list(add_elmnt) if (any(add_pos < 1)) stop("The rgroup 'add' attribute cannot have integer names below 1") if (any(!add_pos <= length(rgroup)) || any(rgroup[add_pos] == "")) stop("The rgroup 'add' attribute cannot have integer names indicating", " positions larger than the length of the rgroup", " (=", length(rgroup), ") or matches", " one of the empty groups (no. ", paste(which(rgroup == ""), collapse = ", "), ").", " The problematic position(s):", " '", paste(add_pos[add_pos > length(rgroup) | add_pos %in% which(rgroup == "")], collapse="', '") ,"'") # Return the matching iterator if (rgroup_iterator %in% names(add_elmnt)){ return(add_elmnt[[as.character(rgroup_iterator)]]) } return(NULL) } htmlTable/R/htmlTableWidget.R0000644000176200001440000000462413407215301015574 0ustar liggesusers#' htmlTable with pagination widget #' #' This widget renders a table with pagination into an htmlwidget #' #' @param x A data frame to be rendered #' @param number_of_entries a numeric vector with the number of entries per page to show. #' If there is more than one number given, the user will be able to show the number #' of rows per page in the table. #' @param ... Additional parameters passed to htmlTable #' @inheritParams htmlwidgets::createWidget #' @import htmlwidgets #' @return an htmlwidget showing the paginated table #' @export htmlTableWidget <- function(x, number_of_entries = c(10, 25, 100), width = NULL, height = NULL, elementId = NULL, ...) { rendered_table <- htmlTable(x, ...) # forward options and variables using the input list: input <- list( thetable = rendered_table, options = list(number_of_entries = number_of_entries) ) # create widget htmlwidgets::createWidget( name = 'htmlTableWidget', x = input, width = width, height = height, package = 'htmlTable', elementId = elementId ) } #' Shiny bindings for htmlTableWidget #' #' Output and render functions for using htmlTableWidget within Shiny #' applications and interactive Rmd documents. #' #' @param outputId output variable to read from #' @param width,height Must be a valid CSS unit (like \code{'100\%'}, #' \code{'400px'}, \code{'auto'}) or a number, which will be coerced to a #' string and have \code{'px'} appended. #' @param expr An expression that generates a htmlTableWidget #' @param env The environment in which to evaluate \code{expr}. #' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This #' is useful if you want to save an expression in a variable. #' #' @name htmlTableWidget-shiny #' #' @examples #' \dontrun{ #' # In the UI: #' htmlTableWidgetOutput("mywidget") #' # In the server: #' renderHtmlTableWidget({htmlTableWidget(iris)}) #' } #' @export htmlTableWidgetOutput <- function(outputId, width = '100%', height = '400px'){ htmlwidgets::shinyWidgetOutput(outputId, 'htmlTableWidget', width, height, package = 'htmlTable') } #' @rdname htmlTableWidget-shiny #' @export renderHtmlTableWidget <- function(expr, env = parent.frame(), quoted = FALSE) { if (!quoted) { expr <- substitute(expr) } # force quoted htmlwidgets::shinyRenderWidget(expr, htmlTableWidgetOutput, env, quoted = TRUE) } htmlTable/R/txtFrmt.R0000644000176200001440000002542413412664215014175 0ustar liggesusers#' A merges lines while preserving the line break for html/LaTeX #' #' This function helps you to do a multiline #' table header in both html and in LaTeX. In #' html this isn't that tricky, you just use #' the
command but in LaTeX I often find #' myself writing vbox/hbox stuff and therefore #' I've created this simple helper function #' #' @param ... The lines that you want to be joined #' @param html If HTML compatible output should be used. If \code{FALSE} #' it outputs LaTeX formatting. Note if you set this to 5 #' then the html5 version of \emph{br} will be used: \code{
} #' otherwise it uses the \code{
} that is compatible #' with the xhtml-formatting. #' @return string #' #' @examples #' txtMergeLines("hello", "world") #' txtMergeLines("hello", "world", html=FALSE) #' txtMergeLines("hello", "world", list("A list", "is OK")) #' #' @family text formatters #' @export txtMergeLines <- function(..., html = 5){ strings <- c() for (i in list(...)){ if (is.list(i)){ for(c in i) strings <- append(strings, i) }else{ strings <- append(strings, i) } } if (length(strings) == 0){ return("") } if (length(strings) == 1){ strings <- gsub("\n", ifelse(html == 5, "
\n", "
\n"), strings) return(strings) } ret <- ifelse(html != FALSE, "", "\\vbox{") first <- TRUE for (line in strings){ line <- as.character(line) if (first) ret <- paste0(ret, ifelse(html != FALSE, line, sprintf("\\hbox{\\strut %s}", line))) else ret <- paste0(ret, ifelse(html != FALSE, paste(ifelse(html == 5, "
\n", "
\n"), line), sprintf("\\hbox{\\strut %s}", line))) first <- FALSE } ret <- ifelse(html, ret, paste0(ret, "}")) return(ret) } #' SI or English formatting of an integer #' #' English uses ',' between every 3 numbers while the #' SI format recommends a ' ' if x > 10^4. The scientific #' form 10e+? is furthermore avoided. #' #' @param x The integer variable #' @param language The ISO-639-1 two-letter code for the language of #' interest. Currently only english is distinguished from the ISO #' format using a ',' as the separator. #' @param html If the format is used in html context #' then the space should be a non-breaking space, \code{ } #' @param ... Passed to \code{\link[base]{format}} #' @return \code{string} #' #' @examples #' txtInt(123) #' txtInt(1234) #' txtInt(12345) #' txtInt(123456) #' #' @family text formatters#' #' @export txtInt <- function(x, language = "en", html = TRUE, ...){ if (length(x) > 1){ ret <- sapply(x, txtInt, language=language, html=TRUE, ...) if (is.matrix(x)){ ret <- matrix(ret, nrow=nrow(x)) rownames(ret) <- rownames(x) colnames(ret) <- colnames(x) } return(ret) } if (abs(x - round(x)) > .Machine$double.eps^0.5 && !"nsmall" %in% names(list(...))) warning("The function can only be served integers, '", x, "' is not an integer.", " There will be issues with decimals being lost if you don't add the nsmall parameter.") if (language == "en") return(format(x, big.mark=",", scientific=FALSE, ...)) if(x >= 10^4) return(format(x, big.mark=ifelse(html, " ", " "), scientific=FALSE, ...)) return(format(x, scientific=FALSE, ...)) } #' Formats the p-values #' #' Gets formatted p-values. For instance #' you often want 0.1234 to be 0.12 while also #' having two values up until a limit, #' i.e. 0.01234 should be 0.012 while #' 0.001234 should be 0.001. Furthermore you #' want to have < 0.001 as it becomes ridiculous #' to report anything below that value. #' #' @param pvalues The p-values #' @param lim.2dec The limit for showing two decimals. E.g. #' the p-value may be 0.056 and we may want to keep the two decimals in order #' to emphasize the proximity to the all-mighty 0.05 p-value and set this to #' \eqn{10^-2}. This allows that a value of 0.0056 is rounded to 0.006 and this #' makes intuitive sense as the 0.0056 level as this is well below #' the 0.05 value and thus not as interesting to know the exact proximity to #' 0.05. \emph{Disclaimer:} The 0.05-limit is really silly and debated, unfortunately #' it remains a standard and this package tries to adapt to the current standards in order #' to limit publication associated issues. #' @param lim.sig The significance limit for the less than sign, i.e. the '<' #' @param html If the less than sign should be < or < #' as needed for html output. #' @param ... Currently only used for generating warnings of deprecated call #' parameters. #' @return vector #' #' @examples #' txtPval(c(0.10234,0.010234, 0.0010234, 0.000010234)) #' @family text formatters #' @rdname txtPval #' @export txtPval <- function(pvalues, lim.2dec = 10^-2, lim.sig = 10^-4, html=TRUE, ...){ if (is.logical(html)) html <- ifelse(html, "< ", "< ") sapply(pvalues, function(x, lim.2dec, lim.sig, lt_sign){ if (is.na(as.numeric(x))){ warning("The value: '", x, "' is non-numeric and txtPval", " can't therefore handle it") return (x) } if (x < lim.sig) return(sprintf("%s%s", lt_sign, format(lim.sig, scientific=FALSE))) if (x > lim.2dec) return(format(x, digits=2, nsmall=-floor(log10(x))+1)) return(format(x, digits=1, scientific=FALSE)) }, lim.sig=lim.sig, lim.2dec = lim.2dec, lt_sign = html) } #' A convenient rounding function #' #' If you provide a string value in X the function will try to round this if #' a numeric text is present. If you want to skip certain rows/columns then #' use the excl.* arguments. #' #' @param x The value/vector/data.frame/matrix to be rounded #' @param digits The number of digits to round each element to. #' If you provide a vector each element will apply to the corresponding columns. #' @param digits.nonzero The number of digits to keep if the result is close to #' zero. Sometimes we have an entire table with large numbers only to have a #' few but interesting observation that are really interesting #' @param excl.cols Columns to exclude from the rounding procedure. #' This can be either a number or regular expression. Skipped if x is a vector. #' @param excl.rows Rows to exclude from the rounding procedure. #' This can be either a number or regular expression. #' @param txt.NA The string to exchange NA with #' @param dec The decimal marker. If the text is in non-english decimal #' and string formatted you need to change this to the apropriate decimal #' indicator. #' @param scientific If the value should be in scientific format. #' @param ... Passed to next method #' @return \code{matrix/data.frame} #' #' @examples #' mx <- matrix(c(1, 1.11, 1.25, #' 2.50, 2.55, 2.45, #' 3.2313, 3, pi), #' ncol = 3, byrow=TRUE) #' txtRound(mx, 1) #' @export #' @rdname txtRound #' @family text formatters txtRound <- function(x, ...){ UseMethod("txtRound") } #' @export #' @rdname txtRound txtRound.default = function(x, digits = 0, digits.nonzero = NA, txt.NA = "", dec = ".", scientific, ...){ if(length(digits) != 1 & length(digits) != length(x)) stop("You have ", length(digits), " digits specifications but a vector of length ", length(x), ": ", paste(x, collapse=", ")) if (length(x) > 1) { return(mapply(txtRound.default, x = x, digits = digits, digits.nonzero = digits.nonzero, txt.NA = txt.NA, dec = dec, ...)) } if (!is.na(digits.nonzero)) { if (!is.numeric(digits.nonzero) || floor(digits.nonzero) != digits.nonzero ) { stop("The digits.nonzero should be an integer, you provided: ", digits.nonzero) } if (digits.nonzero < digits) { stop("The digits.nonzero must be smaller than digits") } } dec_str <- sprintf("^[^0-9\\%s-]*([\\-]{0,1}(([0-9]*|[0-9]+[ 0-9]+)[\\%s]|)[0-9]+(e[+]{0,1}[0-9]+|))(|[^0-9]+.*)$", dec, dec) if (is.na(x)) return(txt.NA) if (!is.numeric(x) && !grepl(dec_str, x)) return(x) if (is.character(x) && grepl(dec_str, x)){ if (dec != ".") x <- gsub(dec, ".", x) if (grepl("[0-9.]+e[+]{0,1}[0-9]+", x) && missing(scientific)) { scientific <- TRUE } # Select the first occurring number # remove any spaces indicating thousands # and convert to numeric x <- sub(dec_str, "\\1", x) %>% gsub(" ", "", .) %>% as.numeric } if (!is.na(digits.nonzero)) { decimal_position <- floor(log10(x)) if (decimal_position < -digits && decimal_position >= -digits.nonzero) { digits <- -decimal_position } } if (round(x, digits) == 0) x <- 0 if (!missing(scientific) && scientific) { x <- round(x, digits) return(format(x, scientific = TRUE)) } sprintf(paste0("%.", digits, "f"), x) } #' @export #' @rdname txtRound txtRound.data.frame <- function(x, ...){ i <- sapply(x, is.factor) if (any(i)){ x[i] <- lapply(x[i], as.character) } x <- as.matrix(x) x <- txtRound.matrix(x, ...) return (as.data.frame(x, stringsAsFactors = FALSE)) } #' @rdname txtRound #' @export txtRound.table <- function(x, ...){ if (is.na(ncol(x))) { dim(x) <- c(1, nrow(x)) } return(txtRound.matrix(x, ...)) } #' @rdname txtRound #' @export txtRound.matrix <- function(x, digits = 0, excl.cols, excl.rows, ...){ if(length(dim(x)) > 2) stop("The function only accepts vectors/matrices/data.frames as primary argument") rows <- 1L:nrow(x) if (!missing(excl.rows)){ if (is.character(excl.rows)){ excl.rows <- grep(excl.rows, rownames(x)) } if (length(excl.rows) > 0) rows <- rows[-excl.rows] } cols <- 1L:(ifelse(is.na(ncol(x)), 1, ncol(x))) if (!missing(excl.cols)){ if (is.character(excl.cols)){ excl.cols <- grep(excl.cols, colnames(x)) } if (length(excl.cols) > 0) cols <- cols[-excl.cols] } if (length(cols) == 0) stop("No columns to round") if (length(rows) == 0) stop("No rows to round") if(length(digits) != 1 & length(digits) != length(cols)) stop("You have ", length(digits), " digits specifications but ", length(cols), " columns to apply them to: ", paste(cols, collapse = ", ")) ret_x <- x for (row in rows){ ret_x[row, cols] <- mapply(txtRound, x = x[row, cols], digits = digits, ..., USE.NAMES = FALSE) } return(ret_x) } htmlTable/R/htmlTable_render.R0000644000176200001440000002146113407215301015765 0ustar liggesusers#' Renders the table head (thead) #' #' @inheritParams htmlTable #' @inheritParams prGetCgroupHeader #' @param total_columns The total number of columns including the rowlabel and the #' specer cells #' @return \code{string} Returns the html string for the \code{...} element #' @keywords internal prGetThead <- function (x, header, cgroup, n.cgroup, caption, pos.caption, compatibility, total_columns, align.cgroup, css.cgroup, top_row_style, rnames, rowlabel, pos.rowlabel, cgroup_spacer_cells, css.cell, align.header, cell_style) { first_row <- TRUE # Start the head head_str <- "\n\t" if (!missing(caption) & compatibility == "LibreOffice" & !pos.caption %in% c("bottom", "below")){ head_str %<>% sprintf("%s\n\t%s", ., total_columns, caption) } # Add the cgroup table header if (!missing(cgroup)){ for (i in 1:nrow(cgroup)){ cgrp_str <- prGetCgroupHeader(x = x, cgroup_vec = cgroup[i,], n.cgroup_vec = n.cgroup[i,], cgroup_vec.just = align.cgroup[i, ], css.cgroup_vec = css.cgroup[i,], row_no = i, top_row_style = top_row_style, rnames = rnames, rowlabel = rowlabel, pos.rowlabel = pos.rowlabel, cgroup_spacer_cells = cgroup_spacer_cells, css.cell = css.cell) head_str %<>% paste0(cgrp_str) } first_row <- FALSE } # Add the header if (!missing(header)){ # The bottom border was ment to be here but it doesn't # work that well in the export head_str %<>% paste0("\n\t") no_cgroup_rows <- ifelse(!missing(cgroup), nrow(cgroup), 0) ts <- ifelse(no_cgroup_rows > 0, "", top_row_style) if (!missing(rowlabel) && pos.rowlabel == no_cgroup_rows + 1){ head_str %<>% sprintf("%s\n\t\t%s", ., prGetStyle(c(`font-weight` = 900, `border-bottom` = "1px solid grey"), ts, attr(css.cell, "rnames")[1], align=prGetAlign(align.header, 1)), rowlabel) }else if(!prSkipRownames(rnames)){ head_str %<>% sprintf("%s\n\t\t ", ., prGetStyle(c(`border-bottom`="1px solid grey"), ts)) } cell_style <- "border-bottom: 1px solid grey;" if (first_row){ cell_style %<>% c(top_row_style) } cell_str <- prAddCells(rowcells = header, cellcode = "th", align = align.header, style=cell_style, cgroup_spacer_cells = cgroup_spacer_cells, has_rn_col = !prSkipRownames(rnames)*1, css.cell = attr(css.cell, "header")) head_str %<>% paste0(cell_str, "\n\t") first_row <- FALSE } ################################# # Close head and start the body # ################################# head_str %<>% paste0("\n\t") return(head_str) } #' Gets the number of rgroup htmlLine #' #' @param total_columns The total number of columns including the rowlabel and the #' spacer cells #' @param cspan The column span of the current rgroup #' @param style The css style corresponding to the rgroup css style that includes #' the color specific for the rgroup, i.e. \code{col.rgroup}. #' @param cgroup_spacer_cells The vector indicating the position of the cgroup #' spacer cells #' @param css.row The css.cell information for this particular row. #' @param padding.tspanner The tspanner padding #' @param rgroup_iterator An integer indicating the rgroup #' @inheritParams htmlTable #' @keywords internal prGetRgroupLine <- function(x, total_columns, rgroup, rgroup_iterator, cspan, rnames, align, style, cgroup_spacer_cells, col.columns, css.row, padding.tspanner){ ret_str <- "" rgroup_elmnt <- rgroup[rgroup_iterator] add_elmnt <- prAttr4RgroupAdd(rgroup = rgroup, rgroup_iterator = rgroup_iterator, no_cols = ncol(x)) ## this will allow either css.rgroup or col.rgroup to ## color the rgroup label rows if (is.numeric(cspan) && cspan < ncol(x) || !is.null(add_elmnt)){ filler_cells <- rep("", ncol(x)) if (!is.null(add_elmnt)){ if (!is.numeric(cspan)) cspan <- ncol(x) + 1*!prSkipRownames(rnames) if (length(add_elmnt) > 1){ if (is.null(names(add_elmnt))) stop("The rgroup 'add' attribute element no '", rgroup_iterator, "'", " either be a single element or a named list/vector") add_pos <- as.integer(names(add_elmnt)) if (any(is.na(add_pos)) || any(add_pos < 1) || any(add_pos > ncol(x))) stop("You have provided invalid element position for rgroup = '", rgroup_elmnt, "'", " the attribute seeems to be a list but the names are invalid", " '", paste(names(add_elmnt), collapse="', '"), "'", " they should be integers between 1 and ", ncol(x)) first_pos <- min(add_pos) - 1 + 1*!prSkipRownames(rnames) if (missing(cspan)){ cspan <- first_pos }else{ cspan <- min(cspan, first_pos) } for (ii in 1:length(add_pos)){ filler_cells[add_pos[ii]] <- add_elmnt[[ii]] } }else if(length(add_elmnt) == 1){ if (is.null(names(add_elmnt)) || names(add_elmnt) == "last"){ add_pos <- ncol(x) }else{ add_pos <- as.integer(names(add_elmnt)) if (is.na(add_pos) || add_pos < 1 || add_pos > ncol(x)) stop("You have provided invalid element position for rgroup = '", rgroup_elmnt, "'", " the attribute seeems to be a list but the name is invalid", " '", names(add_elmnt), "'", " it should be an integer between 1 and ", ncol(x)) } first_pos <- add_pos - 1 + 1*!prSkipRownames(rnames) if (missing(cspan)){ cspan <- first_pos }else{ cspan <- min(cspan, first_pos) } filler_cells[add_pos] <- add_elmnt }else{ stop("The attribute to the rgroup '", rgroup_elmnt, "'", " does not have a length!") } } true_span <- cspan + sum(cgroup_spacer_cells[0:(cspan- 1*!prSkipRownames(rnames))]) ret_str %<>% sprintf("%s\n\t%s", ., true_span, prGetStyle(style), paste0(padding.tspanner, rgroup_elmnt)) cols_left <- ncol(x) - (cspan - 1*!prSkipRownames(rnames)) cell_str <- prAddCells(rowcells = filler_cells, cellcode = "td", align = align, style = style, cgroup_spacer_cells = cgroup_spacer_cells, has_rn_col = !prSkipRownames(rnames)*1, col.columns = col.columns, offset = ncol(x) - cols_left + 1, css.cell = css.row) ret_str %<>% paste0(cell_str) ret_str %<>% paste0("") }else{ ret_str %<>% sprintf("%s\n\t%s", ., total_columns, prGetStyle(style), paste0(padding.tspanner, rgroup_elmnt)) } return(ret_str) } htmlTable/R/data-SCB.R0000644000176200001440000000071413407215301014026 0ustar liggesusers#' Average age in Sweden #' #' For the vignettes there is a dataset downloaded by using the #' \code{get_pxweb_data()} call. The data is from #' SCB (\href{http://scb.se/}{Statistics Sweden}) and downloaded #' using the \href{https://github.com/rOpenGov/pxweb}{pxweb package}: #' #' @example inst/examples/data-SCB_example.R #' #' @name SCB #' @docType data #' @author Max Gordon \email{max@@gforge.se} #' @references \url{http://scb.se} #' @keywords data NULLhtmlTable/MD50000644000176200001440000001273613572030437012513 0ustar liggesusers651ac4d090ea0853457d31a75fe2d3ba *DESCRIPTION b5de2ec519d78397b02280e370087b9d *NAMESPACE 42970ecb3beb9d4c0257139a56b8d095 *NEWS 4ba04ab5a578cfaa6ccb0113987e05be *R/concatHtmlTables.R 0a7b300ff1836b60c280f44946884a42 *R/data-SCB.R dfc10ac67c7cb7e33113578a615c579c *R/deprecated.R 0f007dd0681dcba9a36297fec3852b01 *R/htmlTable.R 732dbe9aaadad1cccd73935108fb3eea *R/htmlTableWidget.R 5ef30a7c54b1416491d823a0dc0316a7 *R/htmlTable_helpers.R 45023ab0143b188197c7cc5f3c008bec *R/htmlTable_render.R cfb8527fbb078c0299ad5e153c999461 *R/interactiveTable.R 828fe4e8664292fc0c4388ac14bd2028 *R/tidyHtmlTable.R 60926872ec5cb0bc9c04b1ac31155504 *R/txtFrmt.R 7bc6d5c7f6f22e2574b0e73f909f438b *R/vector2string.R fc7c9af4b9035d6e828f0cd09dbb78a0 *README.md 937a8046adb1fd5b06559420e3b722b9 *build/vignette.rds e38a7a346e35171e1b34f7712b29dd82 *data/SCB.rda 8ba33dba4c68594528c8fd4b354dac7e *inst/doc/general.R ef1b4c53088ab6b29b8c159f2b44a28c *inst/doc/general.Rmd de305015835c3119e569f8e4000cf7fe *inst/doc/general.html 9931e5562b0ac66b276b852ec853ea11 *inst/doc/tables.R 6555781409a61ffe9c634ed7728888ec *inst/doc/tables.Rmd 05f7e776728cebc5bfb892a052c55f75 *inst/doc/tables.html a95bbe9aa8ef344e821261a7e76e5c6e *inst/doc/tidyHtmlTable.R 0de6b877436f1a477d9d983006f1d2d6 *inst/doc/tidyHtmlTable.Rmd 85398808a0176750d7cd8977a5d7302c *inst/doc/tidyHtmlTable.html 8e55a3031e1e5fb4765e104befa34226 *inst/examples/data-SCB_example.R 204038bdcb327dac21ad17e09899657c *inst/examples/htmlTable_example.R 8f1e5f4ae6112104733be8c95b473c1b *inst/examples/interactiveTable_example.R 02be25da98a52b5cf49b4df8d5e0de2e *inst/html_components/button.html 132f309e3f83db888152d7106ec41bcf *inst/htmlwidgets/htmlTableWidget.js b534145c47d837b203eae77c639b682e *inst/htmlwidgets/htmlTableWidget.yaml 12b40fddbb08ec43e278e7d8a0ab5543 *inst/htmlwidgets/lib/jquery/jquery-AUTHORS.txt e071abda8fe61194711cfc2ab99fe104 *inst/htmlwidgets/lib/jquery/jquery.min.js 36cb4d79c25bf7b3aefbe78327681a0f *inst/htmlwidgets/lib/table_pagination/table_pagination.css d677798e4c1f10fb8f9f4d623564a414 *inst/htmlwidgets/lib/table_pagination/table_pagination.js d2ca198a2b8d36ed4a82c76ce10de625 *inst/javascript/button.js 1b709ec9de931d7f62fd71c56686d268 *inst/javascript/toggler.js c5c5a3bd0e76b4d2aa1a94185fcc41b2 *man/SCB.Rd f5fa21a1981671161e2f9fa3b46770b4 *man/concatHtmlTables.Rd 4b9bef98da44f47f597800a1b6f9dcb1 *man/htmlTable.Rd 965911c6035294c6785722f9df7dc4ca *man/htmlTableWidget-shiny.Rd b753e6c0e431bc34e7eb5b2ac8aa6f1c *man/htmlTableWidget.Rd cca5ba4e8794b52a67dbbee532d2c43b *man/interactiveTable.Rd 1d4b62195d6b0cebc885ebc997c0d8f3 *man/outputInt.Rd a45693ab727a604cae1eb89d026f980b *man/prAddCells.Rd 53da8440c6c6a93d12922a6c805d3a0d *man/prAddSemicolon2StrEnd.Rd 358f15fb143435cd2cd1484dc093bf38 *man/prAttr4RgroupAdd.Rd 76e210287d14fa0d550f0d38be1b8e6a *man/prConvertDfFactors.Rd 855d572dd78466d272171841849adc90 *man/prEscapeHtml.Rd dbf10107a4a017d68db1722f9c86c965 *man/prGetAlign.Rd b789a4b2f1d3d3aaf0d36f8b7aa93877 *man/prGetCgroupHeader.Rd 08003b7a1b2a5b4889545f5a201a2f3b *man/prGetRgroupLine.Rd 0ebefe0da7ee9fad270ddad39b8e2dd1 *man/prGetRowlabelPos.Rd 17d61f0b76ffbb46864d54a2a7560ec6 *man/prGetScriptString.Rd 06631b046f48d5c0d87b6cc6c5509638 *man/prGetStyle.Rd 334bf5bc3e2acc68ec1780254e5c8c95 *man/prGetThead.Rd 43c238ff510b047a9d50b480312c8bef *man/prIsNotebook.Rd 9ef87d0912259960f4c153aa947f1613 *man/prMergeClr.Rd 838b3b16241056750a3192d0b9e1e6e6 *man/prPrepareAlign.Rd f74fd101050b6a2d90ef4e8c38e0a7b0 *man/prPrepareCgroup.Rd b9bda2c250588d9187a3837964d07982 *man/prPrepareColors.Rd ba71e2e05abd3bcf569e0e7f88c6564f *man/prPrepareCss.Rd a1d5a44c02b87fc6e13a9a5e0c6bef7e *man/prSkipRownames.Rd d0cc71180ce78afe2af478293d5815dc *man/prTblNo.Rd f6b8aafc6b18ab7cb3c7d3ed1db95206 *man/pvalueFormatter.Rd 6b9adbc42cbc476c6a10e59d45ce0e1a *man/splitLines4Table.Rd 126e831e8d8c9bfc41f77154931c52f7 *man/tblNoLast.Rd 330edc69dc49683aec511009a3d4d769 *man/tblNoNext.Rd 56e0bc2daca0865452678d548c600db9 *man/tidyHtmlTable.Rd 735910129d29699511344ad04e292bf7 *man/txtInt.Rd be27738b2b9f5d9a1f825bf8390e8c0b *man/txtMergeLines.Rd d34a9e6e365e8da809b03af3f3a15d48 *man/txtPval.Rd 416d83cdd3cced72fe6fb8844c3f9bed *man/txtRound.Rd 8440af828b9848d6b48415a462de1a93 *man/vector2string.Rd 97e588c07c3f56549f7f555ce9435f5a *tests/testInteractive.R 34c42ed0d95bac6a734802a6058ac24b *tests/testthat.R 143947f822f6d4d110d85263c162649f *tests/testthat/test-htmlTable-dimnames.R dbf536e883987e602f73b0a61682101e *tests/testthat/test-htmlTable-input_checks.R 754e85384c1b9619df616800b7680a37 *tests/testthat/test-htmlTable.R fc7c21b881b5a2ecff1fb2d0cff5370d *tests/testthat/test-htmlTable_cgroup.R b5b7f4d8c1284e0b3bda96c8c7e60b73 *tests/testthat/test-htmlTable_dates.R 297550643a58a2ca2096d02b6abdf0c6 *tests/testthat/test-htmlTable_rgroup_tspanner.R d84af5d5185034638e7130f9e58c968c *tests/testthat/test-htmlTable_styles.R 329931dd4fa34307a266ed6eff882b5c *tests/testthat/test-htmlTable_total.R 1aeb8453906adb294d503f425f1cb07b *tests/testthat/test-interactiveTable.R f32d19cec6d4a13021b4e62a38b7f0fc *tests/testthat/test-txtFrmt.R 994d6e332d8a5c81bff240129144fc81 *tests/testthat/test-txtMergeLines.R d162c59223842781b6b8a2021323ad40 *tests/visual_tests/htmlTable_vtests.R 90dbb5b3ab5af03614efa3190e6eff0d *tests/visual_tests/pandoc_test.Rmd 2799ffff91c04e0d3095292c22d51330 *tests/visual_tests/word_test.Rmd e8bb6bd46c06578b7c3daf0995d19624 *vignettes/custom.css ef1b4c53088ab6b29b8c159f2b44a28c *vignettes/general.Rmd 6555781409a61ffe9c634ed7728888ec *vignettes/tables.Rmd 0de6b877436f1a477d9d983006f1d2d6 *vignettes/tidyHtmlTable.Rmd htmlTable/inst/0000755000176200001440000000000013572025026013145 5ustar liggesusershtmlTable/inst/examples/0000755000176200001440000000000013407215301014755 5ustar liggesusershtmlTable/inst/examples/data-SCB_example.R0000644000176200001440000000172213407215301020133 0ustar liggesusers\dontrun{ # The data was generated through downloading via the API library(pxweb) # Get the last 15 years of data (the data always lags 1 year) current_year <- as.integer(format(Sys.Date(), "%Y")) -1 SCB <- get_pxweb_data( url = "http://api.scb.se/OV0104/v1/doris/en/ssd/BE/BE0101/BE0101B/BefolkningMedelAlder", dims = list(Region = c('00', '01', '03', '25'), Kon = c('1', '2'), ContentsCode = c('BE0101G9'), Tid = (current_year-14):current_year), clean = TRUE) # Some cleaning was needed before use SCB$region <- factor(substring(as.character(SCB$region), 4)) Swe_ltrs <- c("å" = "å", "Å" = "Å", "ä" = "ä", "Ä" = "Ä", "ö" = "ö", "Ö" = "Ö") for (i in 1:length(Swe_ltrs)){ levels(SCB$region) <- gsub(names(Swe_ltrs)[i], Swe_ltrs[i], levels(SCB$region)) } save(SCB, file = "data/SCB.rda") } htmlTable/inst/examples/interactiveTable_example.R0000644000176200001440000000145213407215301022102 0ustar liggesusers# A simple output long_txt <- "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" short_txt <- gsub("(^[^.]+).*", "\\1", long_txt) output <- cbind(rep(short_txt, 2), rep(long_txt, 2)) interactiveTable(output, minimized.columns = ncol(output), header = c("Short", "Long"), rnames = c("First", "Second"), col.rgroup = c("#FFF", "#EEF")) htmlTable/inst/examples/htmlTable_example.R0000644000176200001440000000552513407215301020536 0ustar liggesusers# Store all output into a list in order to # output everything at once at the end all_tables <- list() # A simple output output <- matrix(1:4, ncol=2, dimnames = list(list("Row 1", "Row 2"), list("Column 1", "Column 2"))) htmlTable(output) -> all_tables[["Basic table"]] # An advanced output output <- matrix(ncol=6, nrow=8) for (nr in 1:nrow(output)){ for (nc in 1:ncol(output)){ output[nr, nc] <- paste0(nr, ":", nc) } } htmlTable(output, align="r", header = paste(c("1st", "2nd", "3rd", "4th", "5th", "6th"), "hdr"), rnames = paste(c("1st", "2nd", "3rd", paste0(4:8, "th")), "row"), rgroup = paste("Group", LETTERS[1:3]), n.rgroup = c(2,4,nrow(output) - 6), cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = rbind(c(1,2,NA), c(2,2,2)), caption="Basic table with both column spanners (groups) and row groups", tfoot="† A table footer commment", cspan.rgroup = 2, col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;") -> all_tables[["Advanced table"]] # An advanced empty table output <- matrix(ncol = 6, nrow = 0) htmlTable(output, align="r", header = paste(c("1st", "2nd", "3rd", "4th", "5th", "6th"), "hdr"), cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = rbind(c(1,2,NA), c(2,2,2)), caption="Basic empty table with column spanners (groups) and ignored row colors", tfoot="† A table footer commment", cspan.rgroup = 2, col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;") -> all_tables[["Empty table"]] # An example of how to use the css.cell for header styling simple_output <- matrix(1:4, ncol=2) htmlTable(simple_output, header = LETTERS[1:2], css.cell = rbind(rep("background: lightgrey; font-size: 2em;", times=ncol(simple_output)), matrix("", ncol=ncol(simple_output), nrow=nrow(simple_output)))) -> all_tables[["Header formatting"]] concatHtmlTables(all_tables) # See vignette("tables", package = "htmlTable") # for more examples htmlTable/inst/doc/0000755000176200001440000000000013572025026013712 5ustar liggesusershtmlTable/inst/doc/tables.html0000644000176200001440000075566413572025025016100 0ustar liggesusers Tables with htmlTable and some alternatives

Tables with htmlTable and some alternatives

Max Gordon

2019-12-04

Introduction

Tables are an essential part of publishing, well… anything. I therefore want to explore the options available for generating these in markdown. It is important to remember that there are two ways of generating tables in markdown:

  1. Markdown tables
  2. HTML tables

As the htmlTable-package is all about HTML tables we will start with these.

HTML tables

Tables are possibly the most tested HTML-element out there. In early web design this was the only feature that browsers handled uniformly, and therefore became the standard way of doing layout for a long period. HTML-tables are thereby an excellent template for generating advanced tables in statistics. There are currently a few different implementations that I’ve encountered, the xtable, ztable, the format.tables, and my own htmlTable function. The format.tables is unfortunately not yet on CRAN and will not be part of this vignette due to CRAN rules. If you are interested you can find it here.

The htmlTable-package

I developed the htmlTable in order to get tables matching those available in top medical journals. After finding no HTML-alternative to the Hmisc::latex function on Stack Overflow I wrote a basic function allowing column spanners and row groups. Below is a basic example on these two:

Basic table with both column spanners (groups) and row groups
Cgroup 1   Cgroup 2†
1st header 2nd header   3rd header 4th header
Group A
  1st row Content A Content B   Content C Content D
  2nd row Content E Content F   Content G Content H
Group B
  3rd row Content I Content J   Content K Content L
  4th row Content M Content N   Content O Content P
† A table footer commment

Example based upon Swedish statistics

In order to make a more interesting example we will try to look at how the average age changes between Swedish counties the last 15 years. Goal: visualize migration patterns.

The dataset has been downloaded from Statistics Sweden and is attached to the htmlTable-package. We will start by reshaping our tidy dataset into a more table adapted format.

## [1] "Sweden_men"              "Sweden_women"           
## [3] "Norrbotten county_men"   "Norrbotten county_women"
## [5] "Stockholm county_men"    "Stockholm county_women" 
## [7] "Uppsala county_men"      "Uppsala county_women"
## [1] 15  8

The next step is to calculate two new columns:

  • Δint = The change within each group since the start of the observation.
  • Δstd = The change in relation to the overall age change in Sweden.

To convey all these layers of information will create a table with multiple levels of column spanners:

County
Men   Women
Age Δint. Δext.   Age Δint. Δext.
##      [,1]     [,2]                [,3]               [,4]             [,5] 
## [1,] "Sweden" "Norrbotten county" "Stockholm county" "Uppsala county" NA   
## [2,] "Men"    "Women"             "Men"              "Women"          "Men"
##      [,6]    [,7]  [,8]   
## [1,] NA      NA    NA     
## [2,] "Women" "Men" "Women"
##      [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8]
## [1,]    4    6    6    6   NA   NA   NA   NA
## [2,]    2    2    3    3    3    3    3    3

Next step is to output the table after rounding to the correct number of decimals. The txtRound function helps with this, as it uses the sprintf function instead of the round the resulting strings have the correct number of decimals, i.e. 1.02 will by round become 1 while we want it to retain the last decimal, i.e. be shown as 1.0.

Sweden   Norrbotten county   Stockholm county   Uppsala county
Men   Women   Men   Women   Men   Women   Men   Women
Age Δint   Age Δint   Age Δint Δstd   Age Δint Δstd   Age Δint Δstd   Age Δint Δstd   Age Δint Δstd   Age Δint Δstd
First period
  1999 38.9 0.0   41.5 0.0   39.7 0.0 0.8   41.9 0.0 0.4   37.3 0.0 -1.6   40.1 0.0 -1.4   37.2 0.0 -1.7   39.3 0.0 -2.2
  2000 39.0 0.1   41.6 0.1   40.0 0.3 1.0   42.2 0.3 0.6   37.4 0.1 -1.6   40.1 0.0 -1.5   37.5 0.3 -1.5   39.4 0.1 -2.2
  2001 39.2 0.3   41.7 0.2   40.2 0.5 1.0   42.5 0.6 0.8   37.5 0.2 -1.7   40.1 0.0 -1.6   37.6 0.4 -1.6   39.6 0.3 -2.1
  2002 39.3 0.4   41.8 0.3   40.5 0.8 1.2   42.8 0.9 1.0   37.6 0.3 -1.7   40.2 0.1 -1.6   37.8 0.6 -1.5   39.7 0.4 -2.1
  2003 39.4 0.5   41.9 0.4   40.7 1.0 1.3   43.0 1.1 1.1   37.7 0.4 -1.7   40.2 0.1 -1.7   38.0 0.8 -1.4   39.8 0.5 -2.1
Second period
  2004 39.6 0.7   42.0 0.5   40.9 1.2 1.3   43.1 1.2 1.1   37.8 0.5 -1.8   40.3 0.2 -1.7   38.1 0.9 -1.5   40.0 0.7 -2.0
  2005 39.7 0.8   42.0 0.5   41.1 1.4 1.4   43.4 1.5 1.4   37.9 0.6 -1.8   40.3 0.2 -1.7   38.3 1.1 -1.4   40.1 0.8 -1.9
  2006 39.8 0.9   42.1 0.6   41.3 1.6 1.5   43.5 1.6 1.4   37.9 0.6 -1.9   40.2 0.1 -1.9   38.5 1.3 -1.3   40.4 1.1 -1.7
  2007 39.8 0.9   42.1 0.6   41.5 1.8 1.7   43.8 1.9 1.7   37.8 0.5 -2.0   40.1 0.0 -2.0   38.6 1.4 -1.2   40.5 1.2 -1.6
  2008 39.9 1.0   42.1 0.6   41.7 2.0 1.8   44.0 2.1 1.9   37.8 0.5 -2.1   40.1 0.0 -2.0   38.7 1.5 -1.2   40.5 1.2 -1.6
Third period
  2009 39.9 1.0   42.1 0.6   41.9 2.2 2.0   44.2 2.3 2.1   37.8 0.5 -2.1   40.0 -0.1 -2.1   38.8 1.6 -1.1   40.6 1.3 -1.5
  2010 40.0 1.1   42.1 0.6   42.1 2.4 2.1   44.4 2.5 2.3   37.8 0.5 -2.2   40.0 -0.1 -2.1   38.9 1.7 -1.1   40.6 1.3 -1.5
  2011 40.1 1.2   42.2 0.7   42.3 2.6 2.2   44.5 2.6 2.3   37.9 0.6 -2.2   39.9 -0.2 -2.3   39.0 1.8 -1.1   40.7 1.4 -1.5
  2012 40.2 1.3   42.2 0.7   42.4 2.7 2.2   44.6 2.7 2.4   37.9 0.6 -2.3   39.9 -0.2 -2.3   39.1 1.9 -1.1   40.8 1.5 -1.4
  2013 40.2 1.3   42.2 0.7   42.4 2.7 2.2   44.7 2.8 2.5   38.0 0.7 -2.2   39.9 -0.2 -2.3   39.2 2.0 -1.0   40.9 1.6 -1.3
Δint correspnds to the change since start

Δstd corresponds to the change compared to national average

In order to increase the readability we may want to separate the Sweden columns from the county columns, one way is to use the align option with a |. Note that in 1.0 the function continues with the same alignment until the end, i.e. you no longer need count to have the exact right number of columns in your alignment argument.

Sweden   Norrbotten county   Stockholm county   Uppsala county
Men   Women   Men   Women   Men   Women   Men   Women
Age Δint   Age Δint   Age Δint Δstd   Age Δint Δstd   Age Δint Δstd   Age Δint Δstd   Age Δint Δstd   Age Δint Δstd
First period
  1999 38.9 0.0   41.5 0.0   39.7 0.0 0.8   41.9 0.0 0.4   37.3 0.0 -1.6   40.1 0.0 -1.4   37.2 0.0 -1.7   39.3 0.0 -2.2
  2000 39.0 0.1   41.6 0.1   40.0 0.3 1.0   42.2 0.3 0.6   37.4 0.1 -1.6   40.1 0.0 -1.5   37.5 0.3 -1.5   39.4 0.1 -2.2
  2001 39.2 0.3   41.7 0.2   40.2 0.5 1.0   42.5 0.6 0.8   37.5 0.2 -1.7   40.1 0.0 -1.6   37.6 0.4 -1.6   39.6 0.3 -2.1
  2002 39.3 0.4   41.8 0.3   40.5 0.8 1.2   42.8 0.9 1.0   37.6 0.3 -1.7   40.2 0.1 -1.6   37.8 0.6 -1.5   39.7 0.4 -2.1
  2003 39.4 0.5   41.9 0.4   40.7 1.0 1.3   43.0 1.1 1.1   37.7 0.4 -1.7   40.2 0.1 -1.7   38.0 0.8 -1.4   39.8 0.5 -2.1
Second period
  2004 39.6 0.7   42.0 0.5   40.9 1.2 1.3   43.1 1.2 1.1   37.8 0.5 -1.8   40.3 0.2 -1.7   38.1 0.9 -1.5   40.0 0.7 -2.0
  2005 39.7 0.8   42.0 0.5   41.1 1.4 1.4   43.4 1.5 1.4   37.9 0.6 -1.8   40.3 0.2 -1.7   38.3 1.1 -1.4   40.1 0.8 -1.9
  2006 39.8 0.9   42.1 0.6   41.3 1.6 1.5   43.5 1.6 1.4   37.9 0.6 -1.9   40.2 0.1 -1.9   38.5 1.3 -1.3   40.4 1.1 -1.7
  2007 39.8 0.9   42.1 0.6   41.5 1.8 1.7   43.8 1.9 1.7   37.8 0.5 -2.0   40.1 0.0 -2.0   38.6 1.4 -1.2   40.5 1.2 -1.6
  2008 39.9 1.0   42.1 0.6   41.7 2.0 1.8   44.0 2.1 1.9   37.8 0.5 -2.1   40.1 0.0 -2.0   38.7 1.5 -1.2   40.5 1.2 -1.6
Third period
  2009 39.9 1.0   42.1 0.6   41.9 2.2 2.0   44.2 2.3 2.1   37.8 0.5 -2.1   40.0 -0.1 -2.1   38.8 1.6 -1.1   40.6 1.3 -1.5
  2010 40.0 1.1   42.1 0.6   42.1 2.4 2.1   44.4 2.5 2.3   37.8 0.5 -2.2   40.0 -0.1 -2.1   38.9 1.7 -1.1   40.6 1.3 -1.5
  2011 40.1 1.2   42.2 0.7   42.3 2.6 2.2   44.5 2.6 2.3   37.9 0.6 -2.2   39.9 -0.2 -2.3   39.0 1.8 -1.1   40.7 1.4 -1.5
  2012 40.2 1.3   42.2 0.7   42.4 2.7 2.2   44.6 2.7 2.4   37.9 0.6 -2.3   39.9 -0.2 -2.3   39.1 1.9 -1.1   40.8 1.5 -1.4
  2013 40.2 1.3   42.2 0.7   42.4 2.7 2.2   44.7 2.8 2.5   38.0 0.7 -2.2   39.9 -0.2 -2.3   39.2 2.0 -1.0   40.9 1.6 -1.3
Δint correspnds to the change since start

Δstd corresponds to the change compared to national average

If we still feel that we want more separation it is always possible to add colors.

Sweden   Norrbotten county   Stockholm county   Uppsala county
Men   Women   Men   Women   Men   Women   Men   Women
Age Δint   Age Δint   Age Δint Δstd   Age Δint Δstd   Age Δint Δstd   Age Δint Δstd   Age Δint Δstd   Age Δint Δstd
First period
  1999 38.9 0.0   41.5 0.0   39.7 0.0 0.8   41.9 0.0 0.4   37.3 0.0 -1.6   40.1 0.0 -1.4   37.2 0.0 -1.7   39.3 0.0 -2.2
  2000 39.0 0.1   41.6 0.1   40.0 0.3 1.0   42.2 0.3 0.6   37.4 0.1 -1.6   40.1 0.0 -1.5   37.5 0.3 -1.5   39.4 0.1 -2.2
  2001 39.2 0.3   41.7 0.2   40.2 0.5 1.0   42.5 0.6 0.8   37.5 0.2 -1.7   40.1 0.0 -1.6   37.6 0.4 -1.6   39.6 0.3 -2.1
  2002 39.3 0.4   41.8 0.3   40.5 0.8 1.2   42.8 0.9 1.0   37.6 0.3 -1.7   40.2 0.1 -1.6   37.8 0.6 -1.5   39.7 0.4 -2.1
  2003 39.4 0.5   41.9 0.4   40.7 1.0 1.3   43.0 1.1 1.1   37.7 0.4 -1.7   40.2 0.1 -1.7   38.0 0.8 -1.4   39.8 0.5 -2.1
Second period
  2004 39.6 0.7   42.0 0.5   40.9 1.2 1.3   43.1 1.2 1.1   37.8 0.5 -1.8   40.3 0.2 -1.7   38.1 0.9 -1.5   40.0 0.7 -2.0
  2005 39.7 0.8   42.0 0.5   41.1 1.4 1.4   43.4 1.5 1.4   37.9 0.6 -1.8   40.3 0.2 -1.7   38.3 1.1 -1.4   40.1 0.8 -1.9
  2006 39.8 0.9   42.1 0.6   41.3 1.6 1.5   43.5 1.6 1.4   37.9 0.6 -1.9   40.2 0.1 -1.9   38.5 1.3 -1.3   40.4 1.1 -1.7
  2007 39.8 0.9   42.1 0.6   41.5 1.8 1.7   43.8 1.9 1.7   37.8 0.5 -2.0   40.1 0.0 -2.0   38.6 1.4 -1.2   40.5 1.2 -1.6
  2008 39.9 1.0   42.1 0.6   41.7 2.0 1.8   44.0 2.1 1.9   37.8 0.5 -2.1   40.1 0.0 -2.0   38.7 1.5 -1.2   40.5 1.2 -1.6
Third period
  2009 39.9 1.0   42.1 0.6   41.9 2.2 2.0   44.2 2.3 2.1   37.8 0.5 -2.1   40.0 -0.1 -2.1   38.8 1.6 -1.1   40.6 1.3 -1.5
  2010 40.0 1.1   42.1 0.6   42.1 2.4 2.1   44.4 2.5 2.3   37.8 0.5 -2.2   40.0 -0.1 -2.1   38.9 1.7 -1.1   40.6 1.3 -1.5
  2011 40.1 1.2   42.2 0.7   42.3 2.6 2.2   44.5 2.6 2.3   37.9 0.6 -2.2   39.9 -0.2 -2.3   39.0 1.8 -1.1   40.7 1.4 -1.5
  2012 40.2 1.3   42.2 0.7   42.4 2.7 2.2   44.6 2.7 2.4   37.9 0.6 -2.3   39.9 -0.2 -2.3   39.1 1.9 -1.1   40.8 1.5 -1.4
  2013 40.2 1.3   42.2 0.7   42.4 2.7 2.2   44.7 2.8 2.5   38.0 0.7 -2.2   39.9 -0.2 -2.3   39.2 2.0 -1.0   40.9 1.6 -1.3
Δint correspnds to the change since start

Δstd corresponds to the change compared to national average

If we add a color to the row group and restrict the rgroup spanner we may even have a more visual aid.

Sweden   Norrbotten county   Stockholm county   Uppsala county
Men   Women   Men   Women   Men   Women   Men   Women
Age Δint   Age Δint   Age Δint Δstd   Age Δint Δstd   Age Δint Δstd   Age Δint Δstd   Age Δint Δstd   Age Δint Δstd
1st period              
  1999 38.9 0.0   41.5 0.0   39.7 0.0 0.8   41.9 0.0 0.4   37.3 0.0 -1.6   40.1 0.0 -1.4   37.2 0.0 -1.7   39.3 0.0 -2.2
  2000 39.0 0.1   41.6 0.1   40.0 0.3 1.0   42.2 0.3 0.6   37.4 0.1 -1.6   40.1 0.0 -1.5   37.5 0.3 -1.5   39.4 0.1 -2.2
  2001 39.2 0.3   41.7 0.2   40.2 0.5 1.0   42.5 0.6 0.8   37.5 0.2 -1.7   40.1 0.0 -1.6   37.6 0.4 -1.6   39.6 0.3 -2.1
  2002 39.3 0.4   41.8 0.3   40.5 0.8 1.2   42.8 0.9 1.0   37.6 0.3 -1.7   40.2 0.1 -1.6   37.8 0.6 -1.5   39.7 0.4 -2.1
  2003 39.4 0.5   41.9 0.4   40.7 1.0 1.3   43.0 1.1 1.1   37.7 0.4 -1.7   40.2 0.1 -1.7   38.0 0.8 -1.4   39.8 0.5 -2.1
2nd period              
  2004 39.6 0.7   42.0 0.5   40.9 1.2 1.3   43.1 1.2 1.1   37.8 0.5 -1.8   40.3 0.2 -1.7   38.1 0.9 -1.5   40.0 0.7 -2.0
  2005 39.7 0.8   42.0 0.5   41.1 1.4 1.4   43.4 1.5 1.4   37.9 0.6 -1.8   40.3 0.2 -1.7   38.3 1.1 -1.4   40.1 0.8 -1.9
  2006 39.8 0.9   42.1 0.6   41.3 1.6 1.5   43.5 1.6 1.4   37.9 0.6 -1.9   40.2 0.1 -1.9   38.5 1.3 -1.3   40.4 1.1 -1.7
  2007 39.8 0.9   42.1 0.6   41.5 1.8 1.7   43.8 1.9 1.7   37.8 0.5 -2.0   40.1 0.0 -2.0   38.6 1.4 -1.2   40.5 1.2 -1.6
  2008 39.9 1.0   42.1 0.6   41.7 2.0 1.8   44.0 2.1 1.9   37.8 0.5 -2.1   40.1 0.0 -2.0   38.7 1.5 -1.2   40.5 1.2 -1.6
3rd period              
  2009 39.9 1.0   42.1 0.6   41.9 2.2 2.0   44.2 2.3 2.1   37.8 0.5 -2.1   40.0 -0.1 -2.1   38.8 1.6 -1.1   40.6 1.3 -1.5
  2010 40.0 1.1   42.1 0.6   42.1 2.4 2.1   44.4 2.5 2.3   37.8 0.5 -2.2   40.0 -0.1 -2.1   38.9 1.7 -1.1   40.6 1.3 -1.5
  2011 40.1 1.2   42.2 0.7   42.3 2.6 2.2   44.5 2.6 2.3   37.9 0.6 -2.2   39.9 -0.2 -2.3   39.0 1.8 -1.1   40.7 1.4 -1.5
  2012 40.2 1.3   42.2 0.7   42.4 2.7 2.2   44.6 2.7 2.4   37.9 0.6 -2.3   39.9 -0.2 -2.3   39.1 1.9 -1.1   40.8 1.5 -1.4
  2013 40.2 1.3   42.2 0.7   42.4 2.7 2.2   44.7 2.8 2.5   38.0 0.7 -2.2   39.9 -0.2 -2.3   39.2 2.0 -1.0   40.9 1.6 -1.3
Δint correspnds to the change since start

Δstd corresponds to the change compared to national average

If you want to further add to the visual hints you can use specific HTML-code and insert it into the cells. Here we will color the Δstd according to color. By default htmlTable does not escape HTML characters.

Average age in Sweden counties over a period of 15 years. The Norbotten county is typically known for having a negative migration pattern compared to Stockholm, while Uppsala has a proportionally large population of students.
Sweden   Norrbotten county   Stockholm county   Uppsala county
Men   Women   Men   Women   Men   Women   Men   Women
Year Age Δint   Age Δint   Age Δint Δstd   Age Δint Δstd   Age Δint Δstd   Age Δint Δstd   Age Δint Δstd   Age Δint Δstd
1st period              
  1999 38.9 0.0   41.5 0.0   39.7 0.0 0.8   41.9 0.0 0.4   37.3 0.0 -1.6   40.1 0.0 -1.4   37.2 0.0 -1.7   39.3 0.0 -2.2
  2000 39.0 0.1   41.6 0.1   40.0 0.3 1.0   42.2 0.3 0.6   37.4 0.1 -1.6   40.1 0.0 -1.5   37.5 0.3 -1.5   39.4 0.1 -2.2
  2001 39.2 0.3   41.7 0.2   40.2 0.5 1.0   42.5 0.6 0.8   37.5 0.2 -1.7   40.1 0.0 -1.6   37.6 0.4 -1.6   39.6 0.3 -2.1
  2002 39.3 0.4   41.8 0.3   40.5 0.8 1.2   42.8 0.9 1.0   37.6 0.3 -1.7   40.2 0.1 -1.6   37.8 0.6 -1.5   39.7 0.4 -2.1
  2003 39.4 0.5   41.9 0.4   40.7 1.0 1.3   43.0 1.1 1.1   37.7 0.4 -1.7   40.2 0.1 -1.7   38.0 0.8 -1.4   39.8 0.5 -2.1
2nd period              
  2004 39.6 0.7   42.0 0.5   40.9 1.2 1.3   43.1 1.2 1.1   37.8 0.5 -1.8   40.3 0.2 -1.7   38.1 0.9 -1.5   40.0 0.7 -2.0
  2005 39.7 0.8   42.0 0.5   41.1 1.4 1.4   43.4 1.5 1.4   37.9 0.6 -1.8   40.3 0.2 -1.7   38.3 1.1 -1.4   40.1 0.8 -1.9
  2006 39.8 0.9   42.1 0.6   41.3 1.6 1.5   43.5 1.6 1.4   37.9 0.6 -1.9   40.2 0.1 -1.9   38.5 1.3 -1.3   40.4 1.1 -1.7
  2007 39.8 0.9   42.1 0.6   41.5 1.8 1.7   43.8 1.9 1.7   37.8 0.5 -2.0   40.1 0.0 -2.0   38.6 1.4 -1.2   40.5 1.2 -1.6
  2008 39.9 1.0   42.1 0.6   41.7 2.0 1.8   44.0 2.1 1.9   37.8 0.5 -2.1   40.1 0.0 -2.0   38.7 1.5 -1.2   40.5 1.2 -1.6
3rd period              
  2009 39.9 1.0   42.1 0.6   41.9 2.2 2.0   44.2 2.3 2.1   37.8 0.5 -2.1   40.0 -0.1 -2.1   38.8 1.6 -1.1   40.6 1.3 -1.5
  2010 40.0 1.1   42.1 0.6   42.1 2.4 2.1   44.4 2.5 2.3   37.8 0.5 -2.2   40.0 -0.1 -2.1   38.9 1.7 -1.1   40.6 1.3 -1.5
  2011 40.1 1.2   42.2 0.7   42.3 2.6 2.2   44.5 2.6 2.3   37.9 0.6 -2.2   39.9 -0.2 -2.3   39.0 1.8 -1.1   40.7 1.4 -1.5
  2012 40.2 1.3   42.2 0.7   42.4 2.7 2.2   44.6 2.7 2.4   37.9 0.6 -2.3   39.9 -0.2 -2.3   39.1 1.9 -1.1   40.8 1.5 -1.4
  2013 40.2 1.3   42.2 0.7   42.4 2.7 2.2   44.7 2.8 2.5   38.0 0.7 -2.2   39.9 -0.2 -2.3   39.2 2.0 -1.0   40.9 1.6 -1.3
Δint corresponds to the change since start

Δstd corresponds to the change compared to national average

Although a graph most likely does the visualization task better, tables are good at conveying detailed information. It is in my mind without doubt easier in the latest version to find the pattern in the data.

Lastly I would like to thank Stephen Few, ThinkUI, ACAPS, and LabWrite for inspiration.

Other alternatives

The ztable-package

A promising and interesting alternative package is the ztable package. The package can also export to LaTeX and if you need this functionality it may be a good choice. The grouping for columns is currently (version 0.1.5) not working entirely as expected and the html-code does not fully validate, but the package is under active development and will hopefully soon be a fully functional alternative.

Average age in Sweden counties over a period of 15 years. The Norbotten county is typically known for having a negative migration pattern compared to Stockholm, while Uppsala has a proportionally large population of students.
  Age Δint Age Δint Age Δint Δstd Age Δint Δstd Age Δint Δstd Age Δint Δstd Age Δint Δstd Age Δint Δstd
1st period
1999 38.9 0.0 41.5 0.0 39.7 0.0 0.8 41.9 0.0 0.4 37.3 0.0 -1.6 40.1 0.0 -1.4 37.2 0.0 -1.7 39.3 0.0 -2.2
2000 39.0 0.1 41.6 0.1 40.0 0.3 1.0 42.2 0.3 0.6 37.4 0.1 -1.6 40.1 0.0 -1.5 37.5 0.3 -1.5 39.4 0.1 -2.2
2001 39.2 0.3 41.7 0.2 40.2 0.5 1.0 42.5 0.6 0.8 37.5 0.2 -1.7 40.1 0.0 -1.6 37.6 0.4 -1.6 39.6 0.3 -2.1
2002 39.3 0.4 41.8 0.3 40.5 0.8 1.2 42.8 0.9 1.0 37.6 0.3 -1.7 40.2 0.1 -1.6 37.8 0.6 -1.5 39.7 0.4 -2.1
2003 39.4 0.5 41.9 0.4 40.7 1.0 1.3 43.0 1.1 1.1 37.7 0.4 -1.7 40.2 0.1 -1.7 38.0 0.8 -1.4 39.8 0.5 -2.1
2nd period
2004 39.6 0.7 42.0 0.5 40.9 1.2 1.3 43.1 1.2 1.1 37.8 0.5 -1.8 40.3 0.2 -1.7 38.1 0.9 -1.5 40.0 0.7 -2.0
2005 39.7 0.8 42.0 0.5 41.1 1.4 1.4 43.4 1.5 1.4 37.9 0.6 -1.8 40.3 0.2 -1.7 38.3 1.1 -1.4 40.1 0.8 -1.9
2006 39.8 0.9 42.1 0.6 41.3 1.6 1.5 43.5 1.6 1.4 37.9 0.6 -1.9 40.2 0.1 -1.9 38.5 1.3 -1.3 40.4 1.1 -1.7
2007 39.8 0.9 42.1 0.6 41.5 1.8 1.7 43.8 1.9 1.7 37.8 0.5 -2.0 40.1 0.0 -2.0 38.6 1.4 -1.2 40.5 1.2 -1.6
2008 39.9 1.0 42.1 0.6 41.7 2.0 1.8 44.0 2.1 1.9 37.8 0.5 -2.1 40.1 0.0 -2.0 38.7 1.5 -1.2 40.5 1.2 -1.6
3rd period
2009 39.9 1.0 42.1 0.6 41.9 2.2 2.0 44.2 2.3 2.1 37.8 0.5 -2.1 40.0 -0.1 -2.1 38.8 1.6 -1.1 40.6 1.3 -1.5
2010 40.0 1.1 42.1 0.6 42.1 2.4 2.1 44.4 2.5 2.3 37.8 0.5 -2.2 40.0 -0.1 -2.1 38.9 1.7 -1.1 40.6 1.3 -1.5
2011 40.1 1.2 42.2 0.7 42.3 2.6 2.2 44.5 2.6 2.3 37.9 0.6 -2.2 39.9 -0.2 -2.3 39.0 1.8 -1.1 40.7 1.4 -1.5
2012 40.2 1.3 42.2 0.7 42.4 2.7 2.2 44.6 2.7 2.4 37.9 0.6 -2.3 39.9 -0.2 -2.3 39.1 1.9 -1.1 40.8 1.5 -1.4
2013 40.2 1.3 42.2 0.7 42.4 2.7 2.2 44.7 2.8 2.5 38.0 0.7 -2.2 39.9 -0.2 -2.3 39.2 2.0 -1.0 40.9 1.6 -1.3

The xtable-package

The xtable is a solution that delivers both HTML and LaTeX. The syntax is very similar to kable:

A test table
1st header 2nd header
1st row Content A Content B
2nd row Content C Content D

The downside with the function is that you need to change output depending on your target and there is not that much advantage compared to kable.

Markdown tables

Raw tables

A markdown table is fairly straight forward and are simple to manually create. Just write the plain text below:

1st Header  | 2nd Header
----------- | -------------
Content A   | Content B
Content C   | Content D

And you will end up with this beauty:

1st Header 2nd Header
Content A Content B
Content C Content D

The knitr::kable function

Now this is not the R way, we want to use a function that does this. The knitr comes with a table function well suited for this, kable:

A test table
1st header 2nd header
1st row Content A Content B
2nd row Content C Content D

The advantage with the kable function is that it outputs true markdown tables and these can through the pandoc system be converted to any document format. Some of the downsides are:

  • Lack of adding row groups and column groups
  • No control over cell formatting
  • No control over borders

The pander::pandoc.table function

Another option is to use the pander function that can help with text-formatting inside a markdown-compatible table (Thanks Gergely Daróczi for the tip). Here’s a simple example:

  1st header 2nd header
1st row Content A Content B
2nd row Content C Content D

More raw markdown tables

There are a few more text alternatives available when designing tables. I included these from the manual for completeness.

| Right | Left | Default | Center |
|------:|:-----|---------|:------:|
|   12  |  12  |    12   |    12  |
|  123  |  123 |   123   |   123  |
|    1  |    1 |     1   |     1  |

: Demonstration of pipe table syntax.
Demonstration of pipe table syntax.
Right Left Default Center
12 12 12 12
123 123 123 123
1 1 1 1
: Sample grid table.

+---------------+---------------+--------------------+
| Fruit         | Price         | Advantages         |
+===============+===============+====================+
| Bananas       | $1.34         | - built-in wrapper |
|               |               | - bright color     |
+---------------+---------------+--------------------+
| Oranges       | $2.10         | - cures scurvy     |
|               |               | - tasty            |
+---------------+---------------+--------------------+
Sample grid table.
Fruit Price Advantages
Bananas $1.34
  • built-in wrapper
  • bright color
Oranges $2.10
  • cures scurvy
  • tasty
htmlTable/inst/doc/tidyHtmlTable.Rmd0000644000176200001440000000443513407215301017124 0ustar liggesusers--- title: "Using tidyHtmlTable" author: "Stephen Gragg" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Using tidyHtmlTable} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- # Introduction `tidyHtmlTable` acts as a wrapper function for the `htmlTable` function allowing columns to be mapped from the input data to specific htmlTable parameters in a manner similar to ggplot2. # Some Examples ## Prepare Data We'll begin by turning the `mtcars` data into a tidy dataset. The `gather` function is called to collect 3 performance metrics into a pair of key and value columns. ```{r, message=FALSE} library(magrittr) library(tidyr) library(dplyr) library(htmlTable) library(tibble) td <- mtcars %>% rownames_to_column %>% select(rowname, cyl, gear, hp, mpg, qsec) %>% gather(per_metric, value, hp, mpg, qsec) ``` Now we will compute 4 summary statistics for each of the 3 performance metrics. This will be further grouped by number of cylinders and gears. ```{r} tidy_summary <- td %>% group_by(cyl, gear, per_metric) %>% summarise(Mean = round(mean(value), 1), SD = round(sd(value), 1), Min = round(min(value), 1), Max = round(max(value), 1)) %>% gather(summary_stat, value, Mean, SD, Min, Max) %>% ungroup %>% mutate(gear = paste(gear, "Gears"), cyl = paste(cyl, "Cylinders")) ``` At this point, we are ready to implement the `htmlTable` function. Essentially, this constructs an html table using arguments similar to the `htmlTable` function. However, whereas `htmlTable` required the user to manually arrange the data and specify the column groups, headers, row names, row-groups, etc., each of these components of the table is mapped to a column within the input data. ## Output html table ### Example 1 ```{r} tidy_summary %>% tidyHtmlTable(header = "gear", cgroup1 = "cyl", cell_value = "value", rnames = "summary_stat", rgroup = "per_metric") ``` ### Example 2 ```{r} tidy_summary %>% tidyHtmlTable(header = "summary_stat", cgroup1 = "per_metric", cell_value = "value", rnames = "gear", rgroup = "cyl") ``` htmlTable/inst/doc/tidyHtmlTable.R0000644000176200001440000000252413572025026016606 0ustar liggesusers## ---- message=FALSE----------------------------------------------------------- library(magrittr) library(tidyr) library(dplyr) library(htmlTable) library(tibble) td <- mtcars %>% rownames_to_column %>% select(rowname, cyl, gear, hp, mpg, qsec) %>% gather(per_metric, value, hp, mpg, qsec) ## ----------------------------------------------------------------------------- tidy_summary <- td %>% group_by(cyl, gear, per_metric) %>% summarise(Mean = round(mean(value), 1), SD = round(sd(value), 1), Min = round(min(value), 1), Max = round(max(value), 1)) %>% gather(summary_stat, value, Mean, SD, Min, Max) %>% ungroup %>% mutate(gear = paste(gear, "Gears"), cyl = paste(cyl, "Cylinders")) ## ----------------------------------------------------------------------------- tidy_summary %>% tidyHtmlTable(header = "gear", cgroup1 = "cyl", cell_value = "value", rnames = "summary_stat", rgroup = "per_metric") ## ----------------------------------------------------------------------------- tidy_summary %>% tidyHtmlTable(header = "summary_stat", cgroup1 = "per_metric", cell_value = "value", rnames = "gear", rgroup = "cyl") htmlTable/inst/doc/tables.R0000644000176200001440000002047213572025024015312 0ustar liggesusers## ----------------------------------------------------------------------------- output <- matrix(paste("Content", LETTERS[1:16]), ncol=4, byrow = TRUE) library(htmlTable) htmlTable(output, header = paste(c("1st", "2nd", "3rd", "4th"), "header"), rnames = paste(c("1st", "2nd", "3rd", "4th"), "row"), rgroup = c("Group A", "Group B"), n.rgroup = c(2,2), cgroup = c("Cgroup 1", "Cgroup 2†"), n.cgroup = c(2,2), caption="Basic table with both column spanners (groups) and row groups", tfoot="† A table footer commment") ## ---- results='markup'-------------------------------------------------------- data(SCB) # The SCB has three other coulmns and one value column library(reshape) SCB$region <- relevel(SCB$region, "Sweden") SCB <- cast(SCB, year ~ region + sex, value = "values") # Set rownames to be year rownames(SCB) <- SCB$year SCB$year <- NULL # The dataset now has the rows names(SCB) # and the dimensions dim(SCB) ## ----------------------------------------------------------------------------- mx <- NULL for (n in names(SCB)){ tmp <- paste0("Sweden_", strsplit(n, "_")[[1]][2]) mx <- cbind(mx, cbind(SCB[[n]], SCB[[n]] - SCB[[n]][1], SCB[[n]] - SCB[[tmp]])) } rownames(mx) <- rownames(SCB) colnames(mx) <- rep(c("Age", "Δint", "Δstd"), times = ncol(SCB)) mx <- mx[,c(-3, -6)] # This automated generation of cgroup elements is # somewhat of an overkill cgroup <- unique(sapply(names(SCB), function(x) strsplit(x, "_")[[1]][1], USE.NAMES = FALSE)) n.cgroup <- sapply(cgroup, function(x) sum(grepl(paste0("^", x), names(SCB))), USE.NAMES = FALSE)*3 n.cgroup[cgroup == "Sweden"] <- n.cgroup[cgroup == "Sweden"] - 2 cgroup <- rbind(c(cgroup, rep(NA, ncol(SCB) - length(cgroup))), Hmisc::capitalize( sapply(names(SCB), function(x) strsplit(x, "_")[[1]][2], USE.NAMES = FALSE))) n.cgroup <- rbind(c(n.cgroup, rep(NA, ncol(SCB) - length(n.cgroup))), c(2,2, rep(3, ncol(cgroup) - 2))) print(cgroup) print(n.cgroup) ## ----------------------------------------------------------------------------- htmlTable(txtRound(mx, 1), cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("First period", "Second period", "Third period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average")) ## ----------------------------------------------------------------------------- htmlTable(txtRound(mx, 1), align="rrrr|r", cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("First period", "Second period", "Third period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average")) ## ----------------------------------------------------------------------------- htmlTable(txtRound(mx, 1), col.columns = c(rep("#E6E6F0", 4), rep("none", ncol(mx) - 4)), align="rrrr|r", cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("First period", "Second period", "Third period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average")) ## ----------------------------------------------------------------------------- htmlTable(txtRound(mx, 1), col.rgroup = c("none", "#FFFFCC"), col.columns = c(rep("#EFEFF0", 4), rep("none", ncol(mx) - 4)), align="rrrr|r", cgroup = cgroup, n.cgroup = n.cgroup, # I use the   - the no breaking space as I don't want to have a # row break in the row group. This adds a little space in the table # when used together with the cspan.rgroup=1. rgroup = c("1st period", "2nd period", "3rd period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average"), cspan.rgroup = 1) ## ----------------------------------------------------------------------------- cols_2_clr <- grep("Δstd", colnames(mx)) # We need a copy as the formatting causes the matrix to loos # its numerical property out_mx <- txtRound(mx, 1) min_delta <- min(mx[,cols_2_clr]) span_delta <- max(mx[,cols_2_clr]) - min(mx[,cols_2_clr]) for (col in cols_2_clr){ out_mx[, col] <- mapply(function(val, strength) paste0("", val, ""), val = out_mx[,col], strength = round((mx[,col] - min_delta)/span_delta*100 + 1), USE.NAMES = FALSE) } htmlTable(out_mx, caption = "Average age in Sweden counties over a period of 15 years. The Norbotten county is typically known for having a negative migration pattern compared to Stockholm, while Uppsala has a proportionally large population of students.", pos.rowlabel = "bottom", rowlabel="Year", col.rgroup = c("none", "#FFFFCC"), col.columns = c(rep("#EFEFF0", 4), rep("none", ncol(mx) - 4)), align="rrrr|r", cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("1st period", "2nd period", "3rd period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint corresponds to the change since start", "Δstd corresponds to the change compared to national average"), cspan.rgroup = 1) ## ---- message=FALSE, results='asis'------------------------------------------- library(ztable) options(ztable.type="html") zt <- ztable(out_mx, caption = "Average age in Sweden counties over a period of 15 years. The Norbotten county is typically known for having a negative migration pattern compared to Stockholm, while Uppsala has a proportionally large population of students.", zebra.type = 1, zebra = "peach", align=paste(rep("r", ncol(out_mx) + 1), collapse = "")) # zt <- addcgroup(zt, # cgroup = cgroup, # n.cgroup = n.cgroup) # Causes an error: # Error in if (result <= length(vlines)) { : zt <- addrgroup(zt, rgroup = c("1st period", "2nd period", "3rd period"), n.rgroup = rep(5, 3)) print(zt) ## ---- results='asis'---------------------------------------------------------- output <- matrix(sprintf("Content %s", LETTERS[1:4]), ncol=2, byrow=TRUE) colnames(output) <- c("1st header", "2nd header") rownames(output) <- c("1st row", "2nd row") library(xtable) print(xtable(output, caption="A test table", align = c("l", "c", "r")), type="html") ## ----------------------------------------------------------------------------- library(knitr) kable(output, caption="A test table", align = c("c", "r")) ## ---- results='asis'---------------------------------------------------------- library(pander) pandoc.table(output, emphasize.rows = 1, emphasize.strong.cols = 2) htmlTable/inst/doc/tables.Rmd0000644000176200001440000003752313407215301015634 0ustar liggesusers--- title: "Tables with htmlTable and some alternatives" author: "Max Gordon" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: toc: true css: custom.css vignette: > %\VignetteIndexEntry{Tables with htmlTable and some alternatives} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- Introduction ============ Tables are an essential part of publishing, well... anything. I therefore want to explore the options available for generating these in markdown. It is important to remember that there are two ways of generating tables in markdown: 1. Markdown tables 2. HTML tables As the `htmlTable`-package is all about [HTML](http://en.wikipedia.org/wiki/HTML) tables we will start with these. HTML tables =========== Tables are possibly the most tested HTML-element out there. In early web design this was the only feature that browsers handled uniformly, and therefore became the standard way of doing layout for a long period. HTML-tables are thereby an excellent template for generating advanced tables in statistics. There are currently a few different implementations that I've encountered, the **xtable**, **ztable**, the **format.tables**, and my own **htmlTable** function. The `format.tables` is unfortunately not yet on CRAN and will not be part of this vignette due to CRAN rules. If you are interested you can find it [here](https://github.com/SwedishPensionsAgency/format.tables). The `htmlTable`-package -------------------------------------- I developed the `htmlTable` in order to get tables matching those available in top medical journals. After finding no HTML-alternative to the `Hmisc::latex` function on [Stack Overflow](http://stackoverflow.com/questions/11950703/html-with-multicolumn-table-in-markdown-using-knitr) I wrote a basic function allowing column spanners and row groups. Below is a basic example on these two: ```{r} output <- matrix(paste("Content", LETTERS[1:16]), ncol=4, byrow = TRUE) library(htmlTable) htmlTable(output, header = paste(c("1st", "2nd", "3rd", "4th"), "header"), rnames = paste(c("1st", "2nd", "3rd", "4th"), "row"), rgroup = c("Group A", "Group B"), n.rgroup = c(2,2), cgroup = c("Cgroup 1", "Cgroup 2†"), n.cgroup = c(2,2), caption="Basic table with both column spanners (groups) and row groups", tfoot="† A table footer commment") ``` ### Example based upon Swedish statistics In order to make a more interesting example we will try to look at how the average age changes between Swedish counties the last 15 years. **Goal: visualize migration patterns**. The dataset has been downloaded from Statistics Sweden and is attached to the htmlTable-package. We will start by reshaping our tidy dataset into a more table adapted format. ```{r, results='markup'} data(SCB) # The SCB has three other coulmns and one value column library(reshape) SCB$region <- relevel(SCB$region, "Sweden") SCB <- cast(SCB, year ~ region + sex, value = "values") # Set rownames to be year rownames(SCB) <- SCB$year SCB$year <- NULL # The dataset now has the rows names(SCB) # and the dimensions dim(SCB) ``` The next step is to calculate two new columns: * Δint = The change within each group since the start of the observation. * Δstd = The change in relation to the overall age change in Sweden. To convey all these layers of information will create a table with multiple levels of column spanners:
County
Men   Women
AgeΔint.Δext.   AgeΔint.Δext.
```{r} mx <- NULL for (n in names(SCB)){ tmp <- paste0("Sweden_", strsplit(n, "_")[[1]][2]) mx <- cbind(mx, cbind(SCB[[n]], SCB[[n]] - SCB[[n]][1], SCB[[n]] - SCB[[tmp]])) } rownames(mx) <- rownames(SCB) colnames(mx) <- rep(c("Age", "Δint", "Δstd"), times = ncol(SCB)) mx <- mx[,c(-3, -6)] # This automated generation of cgroup elements is # somewhat of an overkill cgroup <- unique(sapply(names(SCB), function(x) strsplit(x, "_")[[1]][1], USE.NAMES = FALSE)) n.cgroup <- sapply(cgroup, function(x) sum(grepl(paste0("^", x), names(SCB))), USE.NAMES = FALSE)*3 n.cgroup[cgroup == "Sweden"] <- n.cgroup[cgroup == "Sweden"] - 2 cgroup <- rbind(c(cgroup, rep(NA, ncol(SCB) - length(cgroup))), Hmisc::capitalize( sapply(names(SCB), function(x) strsplit(x, "_")[[1]][2], USE.NAMES = FALSE))) n.cgroup <- rbind(c(n.cgroup, rep(NA, ncol(SCB) - length(n.cgroup))), c(2,2, rep(3, ncol(cgroup) - 2))) print(cgroup) print(n.cgroup) ``` Next step is to output the table after rounding to the correct number of decimals. The `txtRound` function helps with this, as it uses the `sprintf` function instead of the `round` the resulting strings have the correct number of decimals, i.e. 1.02 will by round become 1 while we want it to retain the last decimal, i.e. be shown as 1.0. ```{r} htmlTable(txtRound(mx, 1), cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("First period", "Second period", "Third period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average")) ``` In order to increase the readability we may want to separate the Sweden columns from the county columns, one way is to use the align option with a |. Note that in 1.0 the function continues with the same alignment until the end, i.e. you no longer need count to have the exact right number of columns in your alignment argument. ```{r} htmlTable(txtRound(mx, 1), align="rrrr|r", cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("First period", "Second period", "Third period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average")) ``` If we still feel that we want more separation it is always possible to add colors. ```{r} htmlTable(txtRound(mx, 1), col.columns = c(rep("#E6E6F0", 4), rep("none", ncol(mx) - 4)), align="rrrr|r", cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("First period", "Second period", "Third period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average")) ``` If we add a color to the row group and restrict the rgroup spanner we may even have a more visual aid. ```{r} htmlTable(txtRound(mx, 1), col.rgroup = c("none", "#FFFFCC"), col.columns = c(rep("#EFEFF0", 4), rep("none", ncol(mx) - 4)), align="rrrr|r", cgroup = cgroup, n.cgroup = n.cgroup, # I use the   - the no breaking space as I don't want to have a # row break in the row group. This adds a little space in the table # when used together with the cspan.rgroup=1. rgroup = c("1st period", "2nd period", "3rd period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average"), cspan.rgroup = 1) ``` If you want to further add to the visual hints you can use specific HTML-code and insert it into the cells. Here we will color the Δstd according to color. By default htmlTable does not escape HTML characters. ```{r} cols_2_clr <- grep("Δstd", colnames(mx)) # We need a copy as the formatting causes the matrix to loos # its numerical property out_mx <- txtRound(mx, 1) min_delta <- min(mx[,cols_2_clr]) span_delta <- max(mx[,cols_2_clr]) - min(mx[,cols_2_clr]) for (col in cols_2_clr){ out_mx[, col] <- mapply(function(val, strength) paste0("", val, ""), val = out_mx[,col], strength = round((mx[,col] - min_delta)/span_delta*100 + 1), USE.NAMES = FALSE) } htmlTable(out_mx, caption = "Average age in Sweden counties over a period of 15 years. The Norbotten county is typically known for having a negative migration pattern compared to Stockholm, while Uppsala has a proportionally large population of students.", pos.rowlabel = "bottom", rowlabel="Year", col.rgroup = c("none", "#FFFFCC"), col.columns = c(rep("#EFEFF0", 4), rep("none", ncol(mx) - 4)), align="rrrr|r", cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("1st period", "2nd period", "3rd period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint corresponds to the change since start", "Δstd corresponds to the change compared to national average"), cspan.rgroup = 1) ``` Although a graph most likely does the visualization task better, tables are good at conveying detailed information. It is in my mind without doubt easier in the latest version to find the pattern in the data. Lastly I would like to thank [Stephen Few](http://www.amazon.com/Show-Me-Numbers-Designing-Enlighten/dp/0970601999), [ThinkUI](http://www.thinkui.co.uk/resources/effective-design-of-data-tables/), [ACAPS](https://www.acaps.org/sites/acaps/files/resources/files/table_design_september_2012.pdf), and [LabWrite](http://www.ncsu.edu/labwrite/res/gh/gh-tables.html) for inspiration. Other alternatives ------------------ ### The `ztable`-package A promising and interesting alternative package is the `ztable` package. The package can also export to LaTeX and if you need this functionality it may be a good choice. The grouping for columns is currently (version 0.1.5) not working entirely as expected and the html-code does not fully validate, but the package is under active development and will hopefully soon be a fully functional alternative. ```{r, message=FALSE, results='asis'} library(ztable) options(ztable.type="html") zt <- ztable(out_mx, caption = "Average age in Sweden counties over a period of 15 years. The Norbotten county is typically known for having a negative migration pattern compared to Stockholm, while Uppsala has a proportionally large population of students.", zebra.type = 1, zebra = "peach", align=paste(rep("r", ncol(out_mx) + 1), collapse = "")) # zt <- addcgroup(zt, # cgroup = cgroup, # n.cgroup = n.cgroup) # Causes an error: # Error in if (result <= length(vlines)) { : zt <- addrgroup(zt, rgroup = c("1st period", "2nd period", "3rd period"), n.rgroup = rep(5, 3)) print(zt) ``` ### The `xtable`-package The `xtable` is a solution that delivers both HTML and LaTeX. The syntax is very similar to `kable`: ```{r, results='asis'} output <- matrix(sprintf("Content %s", LETTERS[1:4]), ncol=2, byrow=TRUE) colnames(output) <- c("1st header", "2nd header") rownames(output) <- c("1st row", "2nd row") library(xtable) print(xtable(output, caption="A test table", align = c("l", "c", "r")), type="html") ``` The downside with the function is that you need to change output depending on your target and there is not that much advantage compared to `kable`. Markdown tables =============== Raw tables ---------- A markdown table is fairly straight forward and are simple to manually create. Just write the plain text below:
1st Header  | 2nd Header
----------- | -------------
Content A   | Content B
Content C   | Content D
And you will end up with this beauty: 1st Header | 2nd Header ----------- | ------------- Content A | Content B Content C | Content D The `knitr::kable` function --------------------------- Now this is not the R way, we want to use a function that does this. The **knitr** comes with a table function well suited for this, **kable**: ```{r} library(knitr) kable(output, caption="A test table", align = c("c", "r")) ``` The advantage with the `kable` function is that it outputs true markdown tables and these can through the [pandoc](http://johnmacfarlane.net/pandoc/README.html#tables) system be converted to any document format. Some of the downsides are: * Lack of adding row groups and column groups * No control over cell formatting * No control over borders * ... The `pander::pandoc.table` function ----------------------------------- Another option is to use the pander function that can help with text-formatting inside a markdown-compatible table (Thanks Gergely Daróczi for the tip). Here's a simple example: ```{r, results='asis'} library(pander) pandoc.table(output, emphasize.rows = 1, emphasize.strong.cols = 2) ``` More *raw* markdown tables -------------------------- There are a few more text alternatives available when designing tables. I included these from the manual for completeness.
| Right | Left | Default | Center |
|------:|:-----|---------|:------:|
|   12  |  12  |    12   |    12  |
|  123  |  123 |   123   |   123  |
|    1  |    1 |     1   |     1  |

: Demonstration of pipe table syntax.
| Right | Left | Default | Center | |------:|:-----|---------|:------:| | 12 | 12 | 12 | 12 | | 123 | 123 | 123 | 123 | | 1 | 1 | 1 | 1 | : Demonstration of pipe table syntax.
: Sample grid table.

+---------------+---------------+--------------------+
| Fruit         | Price         | Advantages         |
+===============+===============+====================+
| Bananas       | $1.34         | - built-in wrapper |
|               |               | - bright color     |
+---------------+---------------+--------------------+
| Oranges       | $2.10         | - cures scurvy     |
|               |               | - tasty            |
+---------------+---------------+--------------------+
: Sample grid table. +---------------+---------------+--------------------+ | Fruit | Price | Advantages | +===============+===============+====================+ | Bananas | $1.34 | - built-in wrapper | | | | - bright color | +---------------+---------------+--------------------+ | Oranges | $2.10 | - cures scurvy | | | | - tasty | +---------------+---------------+--------------------+htmlTable/inst/doc/general.R0000644000176200001440000001636413572025021015457 0ustar liggesusers## ----------------------------------------------------------------------------- library(htmlTable) library(magrittr) # A simple output matrix(1:4, ncol=2, dimnames = list(c("Row 1", "Row 2"), c("Column 1", "Column 2"))) %>% htmlTable ## ----------------------------------------------------------------------------- # A simple output matrix(1:4, ncol=2, dimnames = list(rows = c("Row 1", "Row 2"), cols = c("Column 1", "Column 2"))) %>% htmlTable ## ----------------------------------------------------------------------------- data("mtcars") with(mtcars, table(cyl, gear)) %>% addmargins %>% htmlTable ## ----------------------------------------------------------------------------- output <- matrix(1:4, ncol=2, dimnames = list(c("Row 1", "Row 2"), c("Column 1", "Column 2"))) htmlTable(output, ctable=c("solid", "double"), caption="A table caption above") ## ----------------------------------------------------------------------------- htmlTable(output, pos.caption = "bottom", caption="A table caption below") ## ----------------------------------------------------------------------------- htmlTable(1:3, rnames = "Row 1", align = "lcr", header = c("'l' = left", "'c' = center", "'r' = right"), caption = "The alignment is set through the align options. Available alternatives are l, r, c as designated by the below table.") ## ----------------------------------------------------------------------------- htmlTable(1:3, rnames = "Row 1", align = "clcr", align.header = "lcr", header = c("'l' = left", "'c' = center", "'r' = right"), caption = "The alignment is set through the align options. Available alternatives are l, r, c as designated by the below table.") ## ----------------------------------------------------------------------------- mx <- matrix(ncol=6, nrow=8) rownames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:8, "th")), "row") colnames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:6, "th")), "hdr") for (nr in 1:nrow(mx)){ for (nc in 1:ncol(mx)){ mx[nr, nc] <- paste0(nr, ":", nc) } } ## ----------------------------------------------------------------------------- htmlTable(mx, rgroup = paste("Group", LETTERS[1:3]), n.rgroup = c(2,4,nrow(mx) - 6)) ## ----------------------------------------------------------------------------- htmlTable(mx, rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,4,nrow(mx) - 6)) ## ----------------------------------------------------------------------------- htmlTable(mx, css.rgroup = "", rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,4,nrow(mx) - 6)) ## ----------------------------------------------------------------------------- rgroup <- c(paste("Group", LETTERS[1:2]), "") attr(rgroup, "add") <- list(`2` = "More") htmlTable(mx, rgroup = rgroup, n.rgroup = c(2,4,nrow(mx) - 6)) ## ----------------------------------------------------------------------------- htmlTable(mx, cgroup = c("Cgroup 1", "Cgroup 2"), n.cgroup = c(2,4)) ## ----------------------------------------------------------------------------- htmlTable(mx, cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2")), n.cgroup = rbind(c(1,2,NA), c(2,2,2))) ## ----------------------------------------------------------------------------- htmlTable(mx, cgroup = list(c("Super column spanner", ""), c("", "Another cgroup"), c("", "Cgroup 1", "Cgroup 2")), n.cgroup = list(c(5,1), c(1,2), c(2,2,2))) ## ----------------------------------------------------------------------------- htmlTable(mx, tspanner = paste("Spanner", LETTERS[1:3]), n.tspanner = c(2,4,nrow(mx) - 6)) ## ----------------------------------------------------------------------------- htmlTable(mx, tspanner = paste("Spanner", LETTERS[1:3]), n.tspanner = c(2,4)) ## ----------------------------------------------------------------------------- htmlTable(mx[1:3,], total=TRUE) ## ----------------------------------------------------------------------------- htmlTable(mx, total = "tspanner", css.total = c("border-top: 1px dashed grey;", "border-top: 1px dashed grey;", "border-top: 1px solid grey; font-weight: 900"), tspanner = paste("Spanner", LETTERS[1:3]), n.tspanner = c(2,4,nrow(mx) - 6)) ## ----------------------------------------------------------------------------- options(table_counter = TRUE) ## ----------------------------------------------------------------------------- htmlTable(mx[1:2,1:2], caption="A table caption with a numbering") ## ----------------------------------------------------------------------------- tblNoLast() tblNoNext() ## ----------------------------------------------------------------------------- htmlTable(mx[1:2,1:2], caption="Another table with numbering") ## ----------------------------------------------------------------------------- options(table_counter = FALSE) ## ----------------------------------------------------------------------------- htmlTable(mx[1:2,1:2], tfoot="A table footer") ## ----------------------------------------------------------------------------- htmlTable(mx, col.rgroup = c("none", "#F7F7F7")) ## ----------------------------------------------------------------------------- htmlTable(mx, col.rgroup = c("none", "#F7F7F7"), rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,2,nrow(mx) - 4)) ## ----------------------------------------------------------------------------- htmlTable(mx, col.columns = c("none", "#F7F7F7")) ## ----------------------------------------------------------------------------- htmlTable(mx, col.rgroup = c("none", "#F9FAF0"), col.columns = c("none", "#F1F0FA")) ## ----------------------------------------------------------------------------- rgroup = paste("Group", LETTERS[1:3]) attr(rgroup, "add") <- list(`3` = "Group p-value < 0.001") htmlTable(mx, align="r", rgroup = rgroup, n.rgroup = c(2,4), tspanner = paste("Spanner", LETTERS[1:2]), n.tspanner = c(1), cgroup = list(c("", "Column spanners"), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = list(c(1,5), c(2,2,2)), caption="A table with column spanners, row groups, and zebra striping", tfoot="† A table footer commment", cspan.rgroup = 2, col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;") htmlTable/inst/doc/tidyHtmlTable.html0000644000176200001440000007203013572025026017350 0ustar liggesusers Using tidyHtmlTable

Using tidyHtmlTable

Stephen Gragg

2019-12-04

Introduction

tidyHtmlTable acts as a wrapper function for the htmlTable function allowing columns to be mapped from the input data to specific htmlTable parameters in a manner similar to ggplot2.

Some Examples

Prepare Data

We’ll begin by turning the mtcars data into a tidy dataset. The gather function is called to collect 3 performance metrics into a pair of key and value columns.

Now we will compute 4 summary statistics for each of the 3 performance metrics. This will be further grouped by number of cylinders and gears.

At this point, we are ready to implement the htmlTable function. Essentially, this constructs an html table using arguments similar to the htmlTable function. However, whereas htmlTable required the user to manually arrange the data and specify the column groups, headers, row names, row-groups, etc., each of these components of the table is mapped to a column within the input data.

Output html table

Example 1

4 Cylinders   6 Cylinders   8 Cylinders
3 Gears 4 Gears 5 Gears   3 Gears 4 Gears 5 Gears   3 Gears 5 Gears
hp
  Max 97 109 113   110 123 175   245 335
  Mean 97 76 102   107.5 116.5 175   194.2 299.5
  Min 97 52 91   105 110 175   150 264
  SD 20.1 15.6   3.5 7.5   33.4 50.2
mpg
  Max 21.5 33.9 30.4   21.4 21 19.7   19.2 15.8
  Mean 21.5 26.9 28.2   19.8 19.8 19.7   15.1 15.4
  Min 21.5 21.4 26   18.1 17.8 19.7   10.4 15
  SD 4.8 3.1   2.3 1.6   2.8 0.6
qsec
  Max 20 22.9 16.9   20.2 18.9 15.5   18 14.6
  Mean 20 19.6 16.8   19.8 17.7 15.5   17.1 14.6
  Min 20 18.5 16.7   19.4 16.5 15.5   15.4 14.5
  SD 1.5 0.1   0.6 1.1   0.8 0.1

Example 2

hp   mpg   qsec
Max Mean Min SD   Max Mean Min SD   Max Mean Min SD
4 Cylinders
  3 Gears 97 97 97   21.5 21.5 21.5   20 20 20
  4 Gears 109 76 52 20.1   33.9 26.9 21.4 4.8   22.9 19.6 18.5 1.5
  5 Gears 113 102 91 15.6   30.4 28.2 26 3.1   16.9 16.8 16.7 0.1
6 Cylinders
  3 Gears 110 107.5 105 3.5   21.4 19.8 18.1 2.3   20.2 19.8 19.4 0.6
  4 Gears 123 116.5 110 7.5   21 19.8 17.8 1.6   18.9 17.7 16.5 1.1
  5 Gears 175 175 175   19.7 19.7 19.7   15.5 15.5 15.5
8 Cylinders
  3 Gears 245 194.2 150 33.4   19.2 15.1 10.4 2.8   18 17.1 15.4 0.8
  5 Gears 335 299.5 264 50.2   15.8 15.4 15 0.6   14.6 14.6 14.5 0.1
htmlTable/inst/doc/general.html0000644000176200001440000037121413572025022016221 0ustar liggesusers The htmlTable package

The htmlTable package

Max Gordon

2019-12-04

Basics

The htmlTable package is intended for generating tables using HTML formatting. This format is compatible with Markdown when used for HTML-output. The most basic table can easily be created by just passing a matrix or a data.frame to the htmlTable-function:

Column 1 Column 2
Row 1 1 3
Row 2 2 4

The function is also aware of the dimnames:

cols
Column 1 Column 2
rows
  Row 1 1 3
  Row 2 2 4

This can be convenient when working with the base::table function:

gear  
3 4 5   Sum
cyl
  4 1 8 2   11
  6 2 4 1   7
  8 12 0 2   14
  Sum 15 12 5   32

As of version 1.1 you no longer need to specify results='asis' for each knitr chunk.

Table caption

The table caption is simply the table description and can be either located above or below:

A table caption above
Column 1 Column 2
Row 1 1 3
Row 2 2 4

The caption defaults to above but by setting the pos.caption argument to “bottom” it appears below the table.

Column 1 Column 2
Row 1 1 3
Row 2 2 4
A table caption below

Cell alignment

Cell alignment is specified through the align, align.header, align.cgroup arguments. For aligning the cell values just use align. The argument can accept either a vector or a string, although supplying it with a string is the simplest option as in the example below:

The alignment is set through the align options. Available alternatives are l, r, c as designated by the below table.
‘l’ = left ‘c’ = center ‘r’ = right
Row 1 1 2 3

Note that you can specify a string shorter than the number of columns. This can be useful if you have plenty of columns and you simply want all remaining columns to keep the alignment of the last column. To align the row name you can just add another letter to the string while the header is aligned through the align.header argument:

The alignment is set through the align options. Available alternatives are l, r, c as designated by the below table.
‘l’ = left ‘c’ = center ‘r’ = right
Row 1 1 2 3

Advanced

While it may be sufficient for basic tables a more advanced layout is often needed in medical articles with elements such as:

  • row groups
  • column spanners
  • table spanners
  • total row
  • table footer
  • zebra coloring (also known as banding):
    • rows
    • columns

As many journals require that a MS Word-document is submitted it is furthermore also important that the table imports correctly to a word processor, i.e. that the table also looks nice in the final document not only in the browser. The htmlTable-function is written for all these purposes.

For demonstration purposes we will setup a basic matrix:

Row groups

The purpose of the row groups is to group variables that belong to the same group, e.g. a factored variable with more than two levels often benefit from grouping variables together.

1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Group A
  1st row 1:1 1:2 1:3 1:4 1:5 1:6
  2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Group B
  3rd row 3:1 3:2 3:3 3:4 3:5 3:6
  4th row 4:1 4:2 4:3 4:4 4:5 4:6
  5th row 5:1 5:2 5:3 5:4 5:5 5:6
  6th row 6:1 6:2 6:3 6:4 6:5 6:6
Group C
  7th row 7:1 7:2 7:3 7:4 7:5 7:6
  8th row 8:1 8:2 8:3 8:4 8:5 8:6

We can easily mix row groups with regular variables by having an empty row group name "":

1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Group A
  1st row 1:1 1:2 1:3 1:4 1:5 1:6
  2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Group B
  3rd row 3:1 3:2 3:3 3:4 3:5 3:6
  4th row 4:1 4:2 4:3 4:4 4:5 4:6
  5th row 5:1 5:2 5:3 5:4 5:5 5:6
  6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

When mixing row groups with variables without row groups we may want to omit the bold formatting of the row group label:

1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Group A
  1st row 1:1 1:2 1:3 1:4 1:5 1:6
  2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Group B
  3rd row 3:1 3:2 3:3 3:4 3:5 3:6
  4th row 4:1 4:2 4:3 4:4 4:5 4:6
  5th row 5:1 5:2 5:3 5:4 5:5 5:6
  6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

The rgroup is most commonly a single row without any additional cells but sometimes you may want to have a p-value or similar at the end of the row. This can be achieved by setting the ‘add’ attribute to the rgroup:

1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Group A
  1st row 1:1 1:2 1:3 1:4 1:5 1:6
  2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Group B More
  3rd row 3:1 3:2 3:3 3:4 3:5 3:6
  4th row 4:1 4:2 4:3 4:4 4:5 4:6
  5th row 5:1 5:2 5:3 5:4 5:5 5:6
  6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

Column spanners

A column spanner spans 2 or more columns:

Cgroup 1   Cgroup 2
1st hdr 2nd hdr   3rd hdr 4th hdr 5th hdr 6th hdr
1st row 1:1 1:2   1:3 1:4 1:5 1:6
2nd row 2:1 2:2   2:3 2:4 2:5 2:6
3rd row 3:1 3:2   3:3 3:4 3:5 3:6
4th row 4:1 4:2   4:3 4:4 4:5 4:6
5th row 5:1 5:2   5:3 5:4 5:5 5:6
6th row 6:1 6:2   6:3 6:4 6:5 6:6
7th row 7:1 7:2   7:3 7:4 7:5 7:6
8th row 8:1 8:2   8:3 8:4 8:5 8:6

It can sometimes be convenient to have column spanners in multiple levels:

  Column spanners
  Cgroup 1   Cgroup 2
1st hdr 2nd hdr   3rd hdr 4th hdr   5th hdr 6th hdr
1st row 1:1 1:2   1:3 1:4   1:5 1:6
2nd row 2:1 2:2   2:3 2:4   2:5 2:6
3rd row 3:1 3:2   3:3 3:4   3:5 3:6
4th row 4:1 4:2   4:3 4:4   4:5 4:6
5th row 5:1 5:2   5:3 5:4   5:5 5:6
6th row 6:1 6:2   6:3 6:4   6:5 6:6
7th row 7:1 7:2   7:3 7:4   7:5 7:6
8th row 8:1 8:2   8:3 8:4   8:5 8:6

Above example allows the column spanner to be a sum of the underlying cgroups (see n.cgroup), this is not required by the function and you can also provide a list with elements that allows you to skip the NA at the end of the matrix:

Super column spanner  
  Another cgroup
  Cgroup 1   Cgroup 2
1st hdr 2nd hdr   3rd hdr 4th hdr   5th hdr   6th hdr
1st row 1:1 1:2   1:3 1:4   1:5   1:6
2nd row 2:1 2:2   2:3 2:4   2:5   2:6
3rd row 3:1 3:2   3:3 3:4   3:5   3:6
4th row 4:1 4:2   4:3 4:4   4:5   4:6
5th row 5:1 5:2   5:3 5:4   5:5   5:6
6th row 6:1 6:2   6:3 6:4   6:5   6:6
7th row 7:1 7:2   7:3 7:4   7:5   7:6
8th row 8:1 8:2   8:3 8:4   8:5   8:6

Table spanners

A table spanner is similar to rgroup but has the primary purpose of combining 2 or more tables with the same columns into one:

1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Spanner A
1st row 1:1 1:2 1:3 1:4 1:5 1:6
2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Spanner B
3rd row 3:1 3:2 3:3 3:4 3:5 3:6
4th row 4:1 4:2 4:3 4:4 4:5 4:6
5th row 5:1 5:2 5:3 5:4 5:5 5:6
6th row 6:1 6:2 6:3 6:4 6:5 6:6
Spanner C
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

Note that you actually don’t need the last n.tspanner, i.e. you can simplify the above to:

1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Spanner A
1st row 1:1 1:2 1:3 1:4 1:5 1:6
2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Spanner B
3rd row 3:1 3:2 3:3 3:4 3:5 3:6
4th row 4:1 4:2 4:3 4:4 4:5 4:6
5th row 5:1 5:2 5:3 5:4 5:5 5:6
6th row 6:1 6:2 6:3 6:4 6:5 6:6
Spanner C
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

Similarly you can use the number rgroups included in each tspanner instead of actual rows. This is convenient as the tspannners must align with underlying rgroups.

Total row

Many financial tables use the concept of a total row at the end that sums the above elements:

1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
1st row 1:1 1:2 1:3 1:4 1:5 1:6
2nd row 2:1 2:2 2:3 2:4 2:5 2:6
3rd row 3:1 3:2 3:3 3:4 3:5 3:6

This can also be combined with table spanners:

1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Spanner A
1st row 1:1 1:2 1:3 1:4 1:5 1:6
2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Spanner B
3rd row 3:1 3:2 3:3 3:4 3:5 3:6
4th row 4:1 4:2 4:3 4:4 4:5 4:6
5th row 5:1 5:2 5:3 5:4 5:5 5:6
6th row 6:1 6:2 6:3 6:4 6:5 6:6
Spanner C
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

Table numbering

The htmlTable has built-in numbering, initialized by:

Table 1: A table caption with a numbering
1st hdr 2nd hdr
1st row 1:1 1:2
2nd row 2:1 2:2

As we often want to reference the table number in the text there are two associated functions:

## [1] 1
## [1] 2
Table 2: Another table with numbering
1st hdr 2nd hdr
1st row 1:1 1:2
2nd row 2:1 2:2

If you want to start the counter at 2 you can instead of setting table_counter to TRUE set it to 1. Note that you need to set the value to one less as each time the table is called the counter is incremented by one. You can also turn off the feature by:

Zebra coloring (or banded colors)

Zebra coloring is also know as an alternating color pattern or row shading. It is most commonly applied to rows:

1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
1st row 1:1 1:2 1:3 1:4 1:5 1:6
2nd row 2:1 2:2 2:3 2:4 2:5 2:6
3rd row 3:1 3:2 3:3 3:4 3:5 3:6
4th row 4:1 4:2 4:3 4:4 4:5 4:6
5th row 5:1 5:2 5:3 5:4 5:5 5:6
6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

The zebra coloring in htmlTable is unique in that it follows the rgroups. The zebra striping is centered around the rgroup although rows with no set rgroup, i.e. "" will have alternating colors event though they programatically are within the same group:

1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Group A
  1st row 1:1 1:2 1:3 1:4 1:5 1:6
  2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Group B
  3rd row 3:1 3:2 3:3 3:4 3:5 3:6
  4th row 4:1 4:2 4:3 4:4 4:5 4:6
5th row 5:1 5:2 5:3 5:4 5:5 5:6
6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

We can also color the columns:

1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
1st row 1:1 1:2 1:3 1:4 1:5 1:6
2nd row 2:1 2:2 2:3 2:4 2:5 2:6
3rd row 3:1 3:2 3:3 3:4 3:5 3:6
4th row 4:1 4:2 4:3 4:4 4:5 4:6
5th row 5:1 5:2 5:3 5:4 5:5 5:6
6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

Or do both (note that the colors blend at the intersections):

1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
1st row 1:1 1:2 1:3 1:4 1:5 1:6
2nd row 2:1 2:2 2:3 2:4 2:5 2:6
3rd row 3:1 3:2 3:3 3:4 3:5 3:6
4th row 4:1 4:2 4:3 4:4 4:5 4:6
5th row 5:1 5:2 5:3 5:4 5:5 5:6
6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

Putting it all together

Now if we want to do everything in one table it may look like this:

A table with column spanners, row groups, and zebra striping
  Column spanners
  Cgroup 1   Cgroup 2†
1st hdr   2nd hdr   3rd hdr 4th hdr   5th hdr 6th hdr
Spanner A
Group A    
  1st row 1:1   1:2   1:3 1:4   1:5 1:6
  2nd row 2:1   2:2   2:3 2:4   2:5 2:6
Spanner B
Group B    
  3rd row 3:1   3:2   3:3 3:4   3:5 3:6
  4th row 4:1   4:2   4:3 4:4   4:5 4:6
  5th row 5:1   5:2   5:3 5:4   5:5 5:6
  6th row 6:1   6:2   6:3 6:4   6:5 6:6
Group C     Group p-value < 0.001
  7th row 7:1   7:2   7:3 7:4   7:5 7:6
  8th row 8:1   8:2   8:3 8:4   8:5 8:6
† A table footer commment
htmlTable/inst/doc/general.Rmd0000644000176200001440000002445413414117305016001 0ustar liggesusers--- title: "The htmlTable package" author: "Max Gordon" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: css: custom.css keep_md: true toc: true vignette: > %\VignetteIndexEntry{How-to use htmlTable} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- Basics ====== The **htmlTable** package is intended for generating tables using [HTML](http://en.wikipedia.org/wiki/HTML) formatting. This format is compatible with [Markdown](http://rmarkdown.rstudio.com/) when used for HTML-output. The most basic table can easily be created by just passing a `matrix` or a `data.frame` to the `htmlTable`-function: ```{r} library(htmlTable) library(magrittr) # A simple output matrix(1:4, ncol=2, dimnames = list(c("Row 1", "Row 2"), c("Column 1", "Column 2"))) %>% htmlTable ``` The function is also aware of the dimnames: ```{r} # A simple output matrix(1:4, ncol=2, dimnames = list(rows = c("Row 1", "Row 2"), cols = c("Column 1", "Column 2"))) %>% htmlTable ``` This can be convenient when working with the `base::table` function: ```{r} data("mtcars") with(mtcars, table(cyl, gear)) %>% addmargins %>% htmlTable ``` As of version 1.1 you **no longer need** to specify `results='asis'` for each `knitr` chunk. Table caption ------------- The table caption is simply the table description and can be either located above or below: ```{r} output <- matrix(1:4, ncol=2, dimnames = list(c("Row 1", "Row 2"), c("Column 1", "Column 2"))) htmlTable(output, ctable=c("solid", "double"), caption="A table caption above") ``` The caption defaults to above but by setting the `pos.caption` argument to "bottom" it appears below the table. ```{r} htmlTable(output, pos.caption = "bottom", caption="A table caption below") ``` Cell alignment -------------- Cell alignment is specified through the `align`, `align.header`, `align.cgroup` arguments. For aligning the cell values just use `align`. The argument can accept either a vector or a string, although supplying it with a string is the simplest option as in the example below: ```{r} htmlTable(1:3, rnames = "Row 1", align = "lcr", header = c("'l' = left", "'c' = center", "'r' = right"), caption = "The alignment is set through the align options. Available alternatives are l, r, c as designated by the below table.") ``` Note that you can specify a string shorter than the number of columns. This can be useful if you have plenty of columns and you simply want all remaining columns to keep the alignment of the last column. To align the row name you can just add another letter to the string while the header is aligned through the `align.header` argument: ```{r} htmlTable(1:3, rnames = "Row 1", align = "clcr", align.header = "lcr", header = c("'l' = left", "'c' = center", "'r' = right"), caption = "The alignment is set through the align options. Available alternatives are l, r, c as designated by the below table.") ``` Advanced ======== While it may be sufficient for basic tables a more advanced layout is often needed in medical articles with elements such as: * row groups * column spanners * table spanners * total row * table footer * zebra coloring (also known as *banding*): + rows + columns As many journals require that a MS Word-document is submitted it is furthermore also important that the table imports correctly to a word processor, i.e. that the table also looks nice in the final document not only in the browser. The `htmlTable`-function is written for all these purposes. For demonstration purposes we will setup a basic matrix: ```{r} mx <- matrix(ncol=6, nrow=8) rownames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:8, "th")), "row") colnames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:6, "th")), "hdr") for (nr in 1:nrow(mx)){ for (nc in 1:ncol(mx)){ mx[nr, nc] <- paste0(nr, ":", nc) } } ``` Row groups ---------- The purpose of the row groups is to group variables that belong to the same group, e.g. a factored variable with more than two levels often benefit from grouping variables together. ```{r} htmlTable(mx, rgroup = paste("Group", LETTERS[1:3]), n.rgroup = c(2,4,nrow(mx) - 6)) ``` We can easily mix row groups with regular variables by having an empty row group name `""`: ```{r} htmlTable(mx, rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,4,nrow(mx) - 6)) ``` When mixing row groups with variables without row groups we may want to omit the bold formatting of the row group label: ```{r} htmlTable(mx, css.rgroup = "", rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,4,nrow(mx) - 6)) ``` The `rgroup` is most commonly a single row without any additional cells but sometimes you may want to have a p-value or similar at the end of the row. This can be achieved by setting the 'add' attribute to the `rgroup`: ```{r} rgroup <- c(paste("Group", LETTERS[1:2]), "") attr(rgroup, "add") <- list(`2` = "More") htmlTable(mx, rgroup = rgroup, n.rgroup = c(2,4,nrow(mx) - 6)) ``` Column spanners --------------- A column spanner spans 2 or more columns: ```{r} htmlTable(mx, cgroup = c("Cgroup 1", "Cgroup 2"), n.cgroup = c(2,4)) ``` It can sometimes be convenient to have column spanners in multiple levels: ```{r} htmlTable(mx, cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2")), n.cgroup = rbind(c(1,2,NA), c(2,2,2))) ``` Above example allows the column spanner to be a sum of the underlying cgroups (see n.cgroup), this is not required by the function and you can also provide a `list` with elements that allows you to skip the `NA` at the end of the matrix: ```{r} htmlTable(mx, cgroup = list(c("Super column spanner", ""), c("", "Another cgroup"), c("", "Cgroup 1", "Cgroup 2")), n.cgroup = list(c(5,1), c(1,2), c(2,2,2))) ``` Table spanners -------------- A table spanner is similar to rgroup but has the primary purpose of combining 2 or more tables with the same columns into one: ```{r} htmlTable(mx, tspanner = paste("Spanner", LETTERS[1:3]), n.tspanner = c(2,4,nrow(mx) - 6)) ``` Note that you actually don't need the last `n.tspanner`, i.e. you can simplify the above to: ```{r} htmlTable(mx, tspanner = paste("Spanner", LETTERS[1:3]), n.tspanner = c(2,4)) ``` Similarly you can use the number rgroups included in each tspanner instead of actual rows. This is convenient as the tspannners must align with underlying rgroups. Total row --------- Many financial tables use the concept of a total row at the end that sums the above elements: ```{r} htmlTable(mx[1:3,], total=TRUE) ``` This can also be combined with table spanners: ```{r} htmlTable(mx, total = "tspanner", css.total = c("border-top: 1px dashed grey;", "border-top: 1px dashed grey;", "border-top: 1px solid grey; font-weight: 900"), tspanner = paste("Spanner", LETTERS[1:3]), n.tspanner = c(2,4,nrow(mx) - 6)) ``` Table numbering --------------- The htmlTable has built-in numbering, initialized by: ```{r} options(table_counter = TRUE) ``` ```{r} htmlTable(mx[1:2,1:2], caption="A table caption with a numbering") ``` As we often want to reference the table number in the text there are two associated functions: ```{r} tblNoLast() tblNoNext() ``` ```{r} htmlTable(mx[1:2,1:2], caption="Another table with numbering") ``` If you want to start the counter at 2 you can instead of setting table_counter to `TRUE` set it to 1. Note that you need to set the value to one less as each time the table is called the counter is incremented by one. You can also turn off the feature by: ```{r} options(table_counter = FALSE) ``` Table footer ------------ The footer usually contains specifics regarding variables and is always located at the foot of the table: ```{r} htmlTable(mx[1:2,1:2], tfoot="A table footer") ``` Zebra coloring (or banded colors) ------------------------------------ Zebra coloring is also know as an alternating color pattern or row shading. It is most commonly applied to rows: ```{r} htmlTable(mx, col.rgroup = c("none", "#F7F7F7")) ``` The zebra coloring in `htmlTable` is unique in that it follows the rgroups. The zebra striping is centered around the rgroup although rows with no set rgroup, i.e. "" will have alternating colors event though they programatically are within the same group: ```{r} htmlTable(mx, col.rgroup = c("none", "#F7F7F7"), rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,2,nrow(mx) - 4)) ``` We can also color the columns: ```{r} htmlTable(mx, col.columns = c("none", "#F7F7F7")) ``` Or do both (note that the colors blend at the intersections): ```{r} htmlTable(mx, col.rgroup = c("none", "#F9FAF0"), col.columns = c("none", "#F1F0FA")) ``` Putting it all together ----------------------- Now if we want to do everything in one table it may look like this: ```{r} rgroup = paste("Group", LETTERS[1:3]) attr(rgroup, "add") <- list(`3` = "Group p-value < 0.001") htmlTable(mx, align="r", rgroup = rgroup, n.rgroup = c(2,4), tspanner = paste("Spanner", LETTERS[1:2]), n.tspanner = c(1), cgroup = list(c("", "Column spanners"), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = list(c(1,5), c(2,2,2)), caption="A table with column spanners, row groups, and zebra striping", tfoot="† A table footer commment", cspan.rgroup = 2, col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;") ``` htmlTable/inst/javascript/0000755000176200001440000000000013407215301015305 5ustar liggesusershtmlTable/inst/javascript/toggler.js0000644000176200001440000000237113407215301017311 0ustar liggesusers$(document).ready(function(){ $(".gmisc_table td .hidden").map(function(index, el){ el.parentNode.style["original-color"] = el.parentNode.style["background-color"]; el.parentNode.style["background-color"] = "#DDD"; }); getSelected = function(){ var t = ''; if(window.getSelection){ t = window.getSelection(); }else if(document.getSelection){ t = document.getSelection(); }else if(document.selection){ t = document.selection.createRange().text; } return t.toString(); }; $(".gmisc_table td").map(function(index, el){ this.style.cursor = "pointer"; el.onmouseup = function(e){ if (getSelected().length > 0) return; var hidden = this.getElementsByClassName("hidden"); if (hidden.length > 0){ this.innerHTML = hidden[0].textContent; this.style["background-color"] = this.style["original-color"]; }else{ $(this).append(""); this.childNodes[0].data = this.childNodes[0].data.substr(0, 20) + "... "; this.style["original-color"] = this.style["background-color"]; this.style["background-color"] = "#DDD"; } }; }); }); htmlTable/inst/javascript/button.js0000644000176200001440000000155613407215301017165 0ustar liggesusers$(document).ready(function(){ // Placeholder for button btn = "%btn%"; // Ad the button to each element $(".gmisc_table td").map(function(index, el){ if (el.innerHTML.length > %txt.maxlen% && el.getElementsByClassName("btn").length == 0) el.innerHTML += btn; }) $(".gmisc_table td .btn").map(function(index, el){ el.onclick = function(e){ var hidden = this.parentNode.getElementsByClassName("hidden"); if (this.textContent === "+"){ this.parentNode.childNodes[0].data = hidden[0].textContent; this.textContent = "-"; }else{ $(this.parentNode).append("") this.parentNode.childNodes[0].data = this.parentNode.textContent.substr(0, %txt.maxlen%) + "... "; this.textContent = "+"; } } }) }) htmlTable/inst/htmlwidgets/0000755000176200001440000000000013407215301015472 5ustar liggesusershtmlTable/inst/htmlwidgets/lib/0000755000176200001440000000000013407215301016240 5ustar liggesusershtmlTable/inst/htmlwidgets/lib/jquery/0000755000176200001440000000000013407215301017557 5ustar liggesusershtmlTable/inst/htmlwidgets/lib/jquery/jquery.min.js0000644000176200001440000025126513407215301022231 0ustar liggesusers/*! jQuery v3.1.1 | (c) jQuery Foundation | jquery.org/license */ !function(a,b){"use strict";"object"==typeof module&&"object"==typeof module.exports?module.exports=a.document?b(a,!0):function(a){if(!a.document)throw new Error("jQuery requires a window with a document");return b(a)}:b(a)}("undefined"!=typeof window?window:this,function(a,b){"use strict";var c=[],d=a.document,e=Object.getPrototypeOf,f=c.slice,g=c.concat,h=c.push,i=c.indexOf,j={},k=j.toString,l=j.hasOwnProperty,m=l.toString,n=m.call(Object),o={};function p(a,b){b=b||d;var c=b.createElement("script");c.text=a,b.head.appendChild(c).parentNode.removeChild(c)}var q="3.1.1",r=function(a,b){return new r.fn.init(a,b)},s=/^[\s\uFEFF\xA0]+|[\s\uFEFF\xA0]+$/g,t=/^-ms-/,u=/-([a-z])/g,v=function(a,b){return b.toUpperCase()};r.fn=r.prototype={jquery:q,constructor:r,length:0,toArray:function(){return f.call(this)},get:function(a){return null==a?f.call(this):a<0?this[a+this.length]:this[a]},pushStack:function(a){var b=r.merge(this.constructor(),a);return b.prevObject=this,b},each:function(a){return r.each(this,a)},map:function(a){return this.pushStack(r.map(this,function(b,c){return a.call(b,c,b)}))},slice:function(){return this.pushStack(f.apply(this,arguments))},first:function(){return this.eq(0)},last:function(){return this.eq(-1)},eq:function(a){var b=this.length,c=+a+(a<0?b:0);return this.pushStack(c>=0&&c0&&b-1 in a)}var x=function(a){var b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u="sizzle"+1*new Date,v=a.document,w=0,x=0,y=ha(),z=ha(),A=ha(),B=function(a,b){return a===b&&(l=!0),0},C={}.hasOwnProperty,D=[],E=D.pop,F=D.push,G=D.push,H=D.slice,I=function(a,b){for(var c=0,d=a.length;c+~]|"+K+")"+K+"*"),S=new RegExp("="+K+"*([^\\]'\"]*?)"+K+"*\\]","g"),T=new RegExp(N),U=new RegExp("^"+L+"$"),V={ID:new RegExp("^#("+L+")"),CLASS:new RegExp("^\\.("+L+")"),TAG:new RegExp("^("+L+"|[*])"),ATTR:new RegExp("^"+M),PSEUDO:new RegExp("^"+N),CHILD:new RegExp("^:(only|first|last|nth|nth-last)-(child|of-type)(?:\\("+K+"*(even|odd|(([+-]|)(\\d*)n|)"+K+"*(?:([+-]|)"+K+"*(\\d+)|))"+K+"*\\)|)","i"),bool:new RegExp("^(?:"+J+")$","i"),needsContext:new RegExp("^"+K+"*[>+~]|:(even|odd|eq|gt|lt|nth|first|last)(?:\\("+K+"*((?:-\\d)?\\d*)"+K+"*\\)|)(?=[^-]|$)","i")},W=/^(?:input|select|textarea|button)$/i,X=/^h\d$/i,Y=/^[^{]+\{\s*\[native \w/,Z=/^(?:#([\w-]+)|(\w+)|\.([\w-]+))$/,$=/[+~]/,_=new RegExp("\\\\([\\da-f]{1,6}"+K+"?|("+K+")|.)","ig"),aa=function(a,b,c){var d="0x"+b-65536;return d!==d||c?b:d<0?String.fromCharCode(d+65536):String.fromCharCode(d>>10|55296,1023&d|56320)},ba=/([\0-\x1f\x7f]|^-?\d)|^-$|[^\0-\x1f\x7f-\uFFFF\w-]/g,ca=function(a,b){return b?"\0"===a?"\ufffd":a.slice(0,-1)+"\\"+a.charCodeAt(a.length-1).toString(16)+" ":"\\"+a},da=function(){m()},ea=ta(function(a){return a.disabled===!0&&("form"in a||"label"in a)},{dir:"parentNode",next:"legend"});try{G.apply(D=H.call(v.childNodes),v.childNodes),D[v.childNodes.length].nodeType}catch(fa){G={apply:D.length?function(a,b){F.apply(a,H.call(b))}:function(a,b){var c=a.length,d=0;while(a[c++]=b[d++]);a.length=c-1}}}function ga(a,b,d,e){var f,h,j,k,l,o,r,s=b&&b.ownerDocument,w=b?b.nodeType:9;if(d=d||[],"string"!=typeof a||!a||1!==w&&9!==w&&11!==w)return d;if(!e&&((b?b.ownerDocument||b:v)!==n&&m(b),b=b||n,p)){if(11!==w&&(l=Z.exec(a)))if(f=l[1]){if(9===w){if(!(j=b.getElementById(f)))return d;if(j.id===f)return d.push(j),d}else if(s&&(j=s.getElementById(f))&&t(b,j)&&j.id===f)return d.push(j),d}else{if(l[2])return G.apply(d,b.getElementsByTagName(a)),d;if((f=l[3])&&c.getElementsByClassName&&b.getElementsByClassName)return G.apply(d,b.getElementsByClassName(f)),d}if(c.qsa&&!A[a+" "]&&(!q||!q.test(a))){if(1!==w)s=b,r=a;else if("object"!==b.nodeName.toLowerCase()){(k=b.getAttribute("id"))?k=k.replace(ba,ca):b.setAttribute("id",k=u),o=g(a),h=o.length;while(h--)o[h]="#"+k+" "+sa(o[h]);r=o.join(","),s=$.test(a)&&qa(b.parentNode)||b}if(r)try{return G.apply(d,s.querySelectorAll(r)),d}catch(x){}finally{k===u&&b.removeAttribute("id")}}}return i(a.replace(P,"$1"),b,d,e)}function ha(){var a=[];function b(c,e){return a.push(c+" ")>d.cacheLength&&delete b[a.shift()],b[c+" "]=e}return b}function ia(a){return a[u]=!0,a}function ja(a){var b=n.createElement("fieldset");try{return!!a(b)}catch(c){return!1}finally{b.parentNode&&b.parentNode.removeChild(b),b=null}}function ka(a,b){var c=a.split("|"),e=c.length;while(e--)d.attrHandle[c[e]]=b}function la(a,b){var c=b&&a,d=c&&1===a.nodeType&&1===b.nodeType&&a.sourceIndex-b.sourceIndex;if(d)return d;if(c)while(c=c.nextSibling)if(c===b)return-1;return a?1:-1}function ma(a){return function(b){var c=b.nodeName.toLowerCase();return"input"===c&&b.type===a}}function na(a){return function(b){var c=b.nodeName.toLowerCase();return("input"===c||"button"===c)&&b.type===a}}function oa(a){return function(b){return"form"in b?b.parentNode&&b.disabled===!1?"label"in b?"label"in b.parentNode?b.parentNode.disabled===a:b.disabled===a:b.isDisabled===a||b.isDisabled!==!a&&ea(b)===a:b.disabled===a:"label"in b&&b.disabled===a}}function pa(a){return ia(function(b){return b=+b,ia(function(c,d){var e,f=a([],c.length,b),g=f.length;while(g--)c[e=f[g]]&&(c[e]=!(d[e]=c[e]))})})}function qa(a){return a&&"undefined"!=typeof a.getElementsByTagName&&a}c=ga.support={},f=ga.isXML=function(a){var b=a&&(a.ownerDocument||a).documentElement;return!!b&&"HTML"!==b.nodeName},m=ga.setDocument=function(a){var b,e,g=a?a.ownerDocument||a:v;return g!==n&&9===g.nodeType&&g.documentElement?(n=g,o=n.documentElement,p=!f(n),v!==n&&(e=n.defaultView)&&e.top!==e&&(e.addEventListener?e.addEventListener("unload",da,!1):e.attachEvent&&e.attachEvent("onunload",da)),c.attributes=ja(function(a){return a.className="i",!a.getAttribute("className")}),c.getElementsByTagName=ja(function(a){return a.appendChild(n.createComment("")),!a.getElementsByTagName("*").length}),c.getElementsByClassName=Y.test(n.getElementsByClassName),c.getById=ja(function(a){return o.appendChild(a).id=u,!n.getElementsByName||!n.getElementsByName(u).length}),c.getById?(d.filter.ID=function(a){var b=a.replace(_,aa);return function(a){return a.getAttribute("id")===b}},d.find.ID=function(a,b){if("undefined"!=typeof b.getElementById&&p){var c=b.getElementById(a);return c?[c]:[]}}):(d.filter.ID=function(a){var b=a.replace(_,aa);return function(a){var c="undefined"!=typeof a.getAttributeNode&&a.getAttributeNode("id");return c&&c.value===b}},d.find.ID=function(a,b){if("undefined"!=typeof b.getElementById&&p){var c,d,e,f=b.getElementById(a);if(f){if(c=f.getAttributeNode("id"),c&&c.value===a)return[f];e=b.getElementsByName(a),d=0;while(f=e[d++])if(c=f.getAttributeNode("id"),c&&c.value===a)return[f]}return[]}}),d.find.TAG=c.getElementsByTagName?function(a,b){return"undefined"!=typeof b.getElementsByTagName?b.getElementsByTagName(a):c.qsa?b.querySelectorAll(a):void 0}:function(a,b){var c,d=[],e=0,f=b.getElementsByTagName(a);if("*"===a){while(c=f[e++])1===c.nodeType&&d.push(c);return d}return f},d.find.CLASS=c.getElementsByClassName&&function(a,b){if("undefined"!=typeof b.getElementsByClassName&&p)return b.getElementsByClassName(a)},r=[],q=[],(c.qsa=Y.test(n.querySelectorAll))&&(ja(function(a){o.appendChild(a).innerHTML="",a.querySelectorAll("[msallowcapture^='']").length&&q.push("[*^$]="+K+"*(?:''|\"\")"),a.querySelectorAll("[selected]").length||q.push("\\["+K+"*(?:value|"+J+")"),a.querySelectorAll("[id~="+u+"-]").length||q.push("~="),a.querySelectorAll(":checked").length||q.push(":checked"),a.querySelectorAll("a#"+u+"+*").length||q.push(".#.+[+~]")}),ja(function(a){a.innerHTML="";var b=n.createElement("input");b.setAttribute("type","hidden"),a.appendChild(b).setAttribute("name","D"),a.querySelectorAll("[name=d]").length&&q.push("name"+K+"*[*^$|!~]?="),2!==a.querySelectorAll(":enabled").length&&q.push(":enabled",":disabled"),o.appendChild(a).disabled=!0,2!==a.querySelectorAll(":disabled").length&&q.push(":enabled",":disabled"),a.querySelectorAll("*,:x"),q.push(",.*:")})),(c.matchesSelector=Y.test(s=o.matches||o.webkitMatchesSelector||o.mozMatchesSelector||o.oMatchesSelector||o.msMatchesSelector))&&ja(function(a){c.disconnectedMatch=s.call(a,"*"),s.call(a,"[s!='']:x"),r.push("!=",N)}),q=q.length&&new RegExp(q.join("|")),r=r.length&&new RegExp(r.join("|")),b=Y.test(o.compareDocumentPosition),t=b||Y.test(o.contains)?function(a,b){var c=9===a.nodeType?a.documentElement:a,d=b&&b.parentNode;return a===d||!(!d||1!==d.nodeType||!(c.contains?c.contains(d):a.compareDocumentPosition&&16&a.compareDocumentPosition(d)))}:function(a,b){if(b)while(b=b.parentNode)if(b===a)return!0;return!1},B=b?function(a,b){if(a===b)return l=!0,0;var d=!a.compareDocumentPosition-!b.compareDocumentPosition;return d?d:(d=(a.ownerDocument||a)===(b.ownerDocument||b)?a.compareDocumentPosition(b):1,1&d||!c.sortDetached&&b.compareDocumentPosition(a)===d?a===n||a.ownerDocument===v&&t(v,a)?-1:b===n||b.ownerDocument===v&&t(v,b)?1:k?I(k,a)-I(k,b):0:4&d?-1:1)}:function(a,b){if(a===b)return l=!0,0;var c,d=0,e=a.parentNode,f=b.parentNode,g=[a],h=[b];if(!e||!f)return a===n?-1:b===n?1:e?-1:f?1:k?I(k,a)-I(k,b):0;if(e===f)return la(a,b);c=a;while(c=c.parentNode)g.unshift(c);c=b;while(c=c.parentNode)h.unshift(c);while(g[d]===h[d])d++;return d?la(g[d],h[d]):g[d]===v?-1:h[d]===v?1:0},n):n},ga.matches=function(a,b){return ga(a,null,null,b)},ga.matchesSelector=function(a,b){if((a.ownerDocument||a)!==n&&m(a),b=b.replace(S,"='$1']"),c.matchesSelector&&p&&!A[b+" "]&&(!r||!r.test(b))&&(!q||!q.test(b)))try{var d=s.call(a,b);if(d||c.disconnectedMatch||a.document&&11!==a.document.nodeType)return d}catch(e){}return ga(b,n,null,[a]).length>0},ga.contains=function(a,b){return(a.ownerDocument||a)!==n&&m(a),t(a,b)},ga.attr=function(a,b){(a.ownerDocument||a)!==n&&m(a);var e=d.attrHandle[b.toLowerCase()],f=e&&C.call(d.attrHandle,b.toLowerCase())?e(a,b,!p):void 0;return void 0!==f?f:c.attributes||!p?a.getAttribute(b):(f=a.getAttributeNode(b))&&f.specified?f.value:null},ga.escape=function(a){return(a+"").replace(ba,ca)},ga.error=function(a){throw new Error("Syntax error, unrecognized expression: "+a)},ga.uniqueSort=function(a){var b,d=[],e=0,f=0;if(l=!c.detectDuplicates,k=!c.sortStable&&a.slice(0),a.sort(B),l){while(b=a[f++])b===a[f]&&(e=d.push(f));while(e--)a.splice(d[e],1)}return k=null,a},e=ga.getText=function(a){var b,c="",d=0,f=a.nodeType;if(f){if(1===f||9===f||11===f){if("string"==typeof a.textContent)return a.textContent;for(a=a.firstChild;a;a=a.nextSibling)c+=e(a)}else if(3===f||4===f)return a.nodeValue}else while(b=a[d++])c+=e(b);return c},d=ga.selectors={cacheLength:50,createPseudo:ia,match:V,attrHandle:{},find:{},relative:{">":{dir:"parentNode",first:!0}," ":{dir:"parentNode"},"+":{dir:"previousSibling",first:!0},"~":{dir:"previousSibling"}},preFilter:{ATTR:function(a){return a[1]=a[1].replace(_,aa),a[3]=(a[3]||a[4]||a[5]||"").replace(_,aa),"~="===a[2]&&(a[3]=" "+a[3]+" "),a.slice(0,4)},CHILD:function(a){return a[1]=a[1].toLowerCase(),"nth"===a[1].slice(0,3)?(a[3]||ga.error(a[0]),a[4]=+(a[4]?a[5]+(a[6]||1):2*("even"===a[3]||"odd"===a[3])),a[5]=+(a[7]+a[8]||"odd"===a[3])):a[3]&&ga.error(a[0]),a},PSEUDO:function(a){var b,c=!a[6]&&a[2];return V.CHILD.test(a[0])?null:(a[3]?a[2]=a[4]||a[5]||"":c&&T.test(c)&&(b=g(c,!0))&&(b=c.indexOf(")",c.length-b)-c.length)&&(a[0]=a[0].slice(0,b),a[2]=c.slice(0,b)),a.slice(0,3))}},filter:{TAG:function(a){var b=a.replace(_,aa).toLowerCase();return"*"===a?function(){return!0}:function(a){return a.nodeName&&a.nodeName.toLowerCase()===b}},CLASS:function(a){var b=y[a+" "];return b||(b=new RegExp("(^|"+K+")"+a+"("+K+"|$)"))&&y(a,function(a){return b.test("string"==typeof a.className&&a.className||"undefined"!=typeof a.getAttribute&&a.getAttribute("class")||"")})},ATTR:function(a,b,c){return function(d){var e=ga.attr(d,a);return null==e?"!="===b:!b||(e+="","="===b?e===c:"!="===b?e!==c:"^="===b?c&&0===e.indexOf(c):"*="===b?c&&e.indexOf(c)>-1:"$="===b?c&&e.slice(-c.length)===c:"~="===b?(" "+e.replace(O," ")+" ").indexOf(c)>-1:"|="===b&&(e===c||e.slice(0,c.length+1)===c+"-"))}},CHILD:function(a,b,c,d,e){var f="nth"!==a.slice(0,3),g="last"!==a.slice(-4),h="of-type"===b;return 1===d&&0===e?function(a){return!!a.parentNode}:function(b,c,i){var j,k,l,m,n,o,p=f!==g?"nextSibling":"previousSibling",q=b.parentNode,r=h&&b.nodeName.toLowerCase(),s=!i&&!h,t=!1;if(q){if(f){while(p){m=b;while(m=m[p])if(h?m.nodeName.toLowerCase()===r:1===m.nodeType)return!1;o=p="only"===a&&!o&&"nextSibling"}return!0}if(o=[g?q.firstChild:q.lastChild],g&&s){m=q,l=m[u]||(m[u]={}),k=l[m.uniqueID]||(l[m.uniqueID]={}),j=k[a]||[],n=j[0]===w&&j[1],t=n&&j[2],m=n&&q.childNodes[n];while(m=++n&&m&&m[p]||(t=n=0)||o.pop())if(1===m.nodeType&&++t&&m===b){k[a]=[w,n,t];break}}else if(s&&(m=b,l=m[u]||(m[u]={}),k=l[m.uniqueID]||(l[m.uniqueID]={}),j=k[a]||[],n=j[0]===w&&j[1],t=n),t===!1)while(m=++n&&m&&m[p]||(t=n=0)||o.pop())if((h?m.nodeName.toLowerCase()===r:1===m.nodeType)&&++t&&(s&&(l=m[u]||(m[u]={}),k=l[m.uniqueID]||(l[m.uniqueID]={}),k[a]=[w,t]),m===b))break;return t-=e,t===d||t%d===0&&t/d>=0}}},PSEUDO:function(a,b){var c,e=d.pseudos[a]||d.setFilters[a.toLowerCase()]||ga.error("unsupported pseudo: "+a);return e[u]?e(b):e.length>1?(c=[a,a,"",b],d.setFilters.hasOwnProperty(a.toLowerCase())?ia(function(a,c){var d,f=e(a,b),g=f.length;while(g--)d=I(a,f[g]),a[d]=!(c[d]=f[g])}):function(a){return e(a,0,c)}):e}},pseudos:{not:ia(function(a){var b=[],c=[],d=h(a.replace(P,"$1"));return d[u]?ia(function(a,b,c,e){var f,g=d(a,null,e,[]),h=a.length;while(h--)(f=g[h])&&(a[h]=!(b[h]=f))}):function(a,e,f){return b[0]=a,d(b,null,f,c),b[0]=null,!c.pop()}}),has:ia(function(a){return function(b){return ga(a,b).length>0}}),contains:ia(function(a){return a=a.replace(_,aa),function(b){return(b.textContent||b.innerText||e(b)).indexOf(a)>-1}}),lang:ia(function(a){return U.test(a||"")||ga.error("unsupported lang: "+a),a=a.replace(_,aa).toLowerCase(),function(b){var c;do if(c=p?b.lang:b.getAttribute("xml:lang")||b.getAttribute("lang"))return c=c.toLowerCase(),c===a||0===c.indexOf(a+"-");while((b=b.parentNode)&&1===b.nodeType);return!1}}),target:function(b){var c=a.location&&a.location.hash;return c&&c.slice(1)===b.id},root:function(a){return a===o},focus:function(a){return a===n.activeElement&&(!n.hasFocus||n.hasFocus())&&!!(a.type||a.href||~a.tabIndex)},enabled:oa(!1),disabled:oa(!0),checked:function(a){var b=a.nodeName.toLowerCase();return"input"===b&&!!a.checked||"option"===b&&!!a.selected},selected:function(a){return a.parentNode&&a.parentNode.selectedIndex,a.selected===!0},empty:function(a){for(a=a.firstChild;a;a=a.nextSibling)if(a.nodeType<6)return!1;return!0},parent:function(a){return!d.pseudos.empty(a)},header:function(a){return X.test(a.nodeName)},input:function(a){return W.test(a.nodeName)},button:function(a){var b=a.nodeName.toLowerCase();return"input"===b&&"button"===a.type||"button"===b},text:function(a){var b;return"input"===a.nodeName.toLowerCase()&&"text"===a.type&&(null==(b=a.getAttribute("type"))||"text"===b.toLowerCase())},first:pa(function(){return[0]}),last:pa(function(a,b){return[b-1]}),eq:pa(function(a,b,c){return[c<0?c+b:c]}),even:pa(function(a,b){for(var c=0;c=0;)a.push(d);return a}),gt:pa(function(a,b,c){for(var d=c<0?c+b:c;++d1?function(b,c,d){var e=a.length;while(e--)if(!a[e](b,c,d))return!1;return!0}:a[0]}function va(a,b,c){for(var d=0,e=b.length;d-1&&(f[j]=!(g[j]=l))}}else r=wa(r===g?r.splice(o,r.length):r),e?e(null,g,r,i):G.apply(g,r)})}function ya(a){for(var b,c,e,f=a.length,g=d.relative[a[0].type],h=g||d.relative[" "],i=g?1:0,k=ta(function(a){return a===b},h,!0),l=ta(function(a){return I(b,a)>-1},h,!0),m=[function(a,c,d){var e=!g&&(d||c!==j)||((b=c).nodeType?k(a,c,d):l(a,c,d));return b=null,e}];i1&&ua(m),i>1&&sa(a.slice(0,i-1).concat({value:" "===a[i-2].type?"*":""})).replace(P,"$1"),c,i0,e=a.length>0,f=function(f,g,h,i,k){var l,o,q,r=0,s="0",t=f&&[],u=[],v=j,x=f||e&&d.find.TAG("*",k),y=w+=null==v?1:Math.random()||.1,z=x.length;for(k&&(j=g===n||g||k);s!==z&&null!=(l=x[s]);s++){if(e&&l){o=0,g||l.ownerDocument===n||(m(l),h=!p);while(q=a[o++])if(q(l,g||n,h)){i.push(l);break}k&&(w=y)}c&&((l=!q&&l)&&r--,f&&t.push(l))}if(r+=s,c&&s!==r){o=0;while(q=b[o++])q(t,u,g,h);if(f){if(r>0)while(s--)t[s]||u[s]||(u[s]=E.call(i));u=wa(u)}G.apply(i,u),k&&!f&&u.length>0&&r+b.length>1&&ga.uniqueSort(i)}return k&&(w=y,j=v),t};return c?ia(f):f}return h=ga.compile=function(a,b){var c,d=[],e=[],f=A[a+" "];if(!f){b||(b=g(a)),c=b.length;while(c--)f=ya(b[c]),f[u]?d.push(f):e.push(f);f=A(a,za(e,d)),f.selector=a}return f},i=ga.select=function(a,b,c,e){var f,i,j,k,l,m="function"==typeof a&&a,n=!e&&g(a=m.selector||a);if(c=c||[],1===n.length){if(i=n[0]=n[0].slice(0),i.length>2&&"ID"===(j=i[0]).type&&9===b.nodeType&&p&&d.relative[i[1].type]){if(b=(d.find.ID(j.matches[0].replace(_,aa),b)||[])[0],!b)return c;m&&(b=b.parentNode),a=a.slice(i.shift().value.length)}f=V.needsContext.test(a)?0:i.length;while(f--){if(j=i[f],d.relative[k=j.type])break;if((l=d.find[k])&&(e=l(j.matches[0].replace(_,aa),$.test(i[0].type)&&qa(b.parentNode)||b))){if(i.splice(f,1),a=e.length&&sa(i),!a)return G.apply(c,e),c;break}}}return(m||h(a,n))(e,b,!p,c,!b||$.test(a)&&qa(b.parentNode)||b),c},c.sortStable=u.split("").sort(B).join("")===u,c.detectDuplicates=!!l,m(),c.sortDetached=ja(function(a){return 1&a.compareDocumentPosition(n.createElement("fieldset"))}),ja(function(a){return a.innerHTML="","#"===a.firstChild.getAttribute("href")})||ka("type|href|height|width",function(a,b,c){if(!c)return a.getAttribute(b,"type"===b.toLowerCase()?1:2)}),c.attributes&&ja(function(a){return a.innerHTML="",a.firstChild.setAttribute("value",""),""===a.firstChild.getAttribute("value")})||ka("value",function(a,b,c){if(!c&&"input"===a.nodeName.toLowerCase())return a.defaultValue}),ja(function(a){return null==a.getAttribute("disabled")})||ka(J,function(a,b,c){var d;if(!c)return a[b]===!0?b.toLowerCase():(d=a.getAttributeNode(b))&&d.specified?d.value:null}),ga}(a);r.find=x,r.expr=x.selectors,r.expr[":"]=r.expr.pseudos,r.uniqueSort=r.unique=x.uniqueSort,r.text=x.getText,r.isXMLDoc=x.isXML,r.contains=x.contains,r.escapeSelector=x.escape;var y=function(a,b,c){var d=[],e=void 0!==c;while((a=a[b])&&9!==a.nodeType)if(1===a.nodeType){if(e&&r(a).is(c))break;d.push(a)}return d},z=function(a,b){for(var c=[];a;a=a.nextSibling)1===a.nodeType&&a!==b&&c.push(a);return c},A=r.expr.match.needsContext,B=/^<([a-z][^\/\0>:\x20\t\r\n\f]*)[\x20\t\r\n\f]*\/?>(?:<\/\1>|)$/i,C=/^.[^:#\[\.,]*$/;function D(a,b,c){return r.isFunction(b)?r.grep(a,function(a,d){return!!b.call(a,d,a)!==c}):b.nodeType?r.grep(a,function(a){return a===b!==c}):"string"!=typeof b?r.grep(a,function(a){return i.call(b,a)>-1!==c}):C.test(b)?r.filter(b,a,c):(b=r.filter(b,a),r.grep(a,function(a){return i.call(b,a)>-1!==c&&1===a.nodeType}))}r.filter=function(a,b,c){var d=b[0];return c&&(a=":not("+a+")"),1===b.length&&1===d.nodeType?r.find.matchesSelector(d,a)?[d]:[]:r.find.matches(a,r.grep(b,function(a){return 1===a.nodeType}))},r.fn.extend({find:function(a){var b,c,d=this.length,e=this;if("string"!=typeof a)return this.pushStack(r(a).filter(function(){for(b=0;b1?r.uniqueSort(c):c},filter:function(a){return this.pushStack(D(this,a||[],!1))},not:function(a){return this.pushStack(D(this,a||[],!0))},is:function(a){return!!D(this,"string"==typeof a&&A.test(a)?r(a):a||[],!1).length}});var E,F=/^(?:\s*(<[\w\W]+>)[^>]*|#([\w-]+))$/,G=r.fn.init=function(a,b,c){var e,f;if(!a)return this;if(c=c||E,"string"==typeof a){if(e="<"===a[0]&&">"===a[a.length-1]&&a.length>=3?[null,a,null]:F.exec(a),!e||!e[1]&&b)return!b||b.jquery?(b||c).find(a):this.constructor(b).find(a);if(e[1]){if(b=b instanceof r?b[0]:b,r.merge(this,r.parseHTML(e[1],b&&b.nodeType?b.ownerDocument||b:d,!0)),B.test(e[1])&&r.isPlainObject(b))for(e in b)r.isFunction(this[e])?this[e](b[e]):this.attr(e,b[e]);return this}return f=d.getElementById(e[2]),f&&(this[0]=f,this.length=1),this}return a.nodeType?(this[0]=a,this.length=1,this):r.isFunction(a)?void 0!==c.ready?c.ready(a):a(r):r.makeArray(a,this)};G.prototype=r.fn,E=r(d);var H=/^(?:parents|prev(?:Until|All))/,I={children:!0,contents:!0,next:!0,prev:!0};r.fn.extend({has:function(a){var b=r(a,this),c=b.length;return this.filter(function(){for(var a=0;a-1:1===c.nodeType&&r.find.matchesSelector(c,a))){f.push(c);break}return this.pushStack(f.length>1?r.uniqueSort(f):f)},index:function(a){return a?"string"==typeof a?i.call(r(a),this[0]):i.call(this,a.jquery?a[0]:a):this[0]&&this[0].parentNode?this.first().prevAll().length:-1},add:function(a,b){return this.pushStack(r.uniqueSort(r.merge(this.get(),r(a,b))))},addBack:function(a){return this.add(null==a?this.prevObject:this.prevObject.filter(a))}});function J(a,b){while((a=a[b])&&1!==a.nodeType);return a}r.each({parent:function(a){var b=a.parentNode;return b&&11!==b.nodeType?b:null},parents:function(a){return y(a,"parentNode")},parentsUntil:function(a,b,c){return y(a,"parentNode",c)},next:function(a){return J(a,"nextSibling")},prev:function(a){return J(a,"previousSibling")},nextAll:function(a){return y(a,"nextSibling")},prevAll:function(a){return y(a,"previousSibling")},nextUntil:function(a,b,c){return y(a,"nextSibling",c)},prevUntil:function(a,b,c){return y(a,"previousSibling",c)},siblings:function(a){return z((a.parentNode||{}).firstChild,a)},children:function(a){return z(a.firstChild)},contents:function(a){return a.contentDocument||r.merge([],a.childNodes)}},function(a,b){r.fn[a]=function(c,d){var e=r.map(this,b,c);return"Until"!==a.slice(-5)&&(d=c),d&&"string"==typeof d&&(e=r.filter(d,e)),this.length>1&&(I[a]||r.uniqueSort(e),H.test(a)&&e.reverse()),this.pushStack(e)}});var K=/[^\x20\t\r\n\f]+/g;function L(a){var b={};return r.each(a.match(K)||[],function(a,c){b[c]=!0}),b}r.Callbacks=function(a){a="string"==typeof a?L(a):r.extend({},a);var b,c,d,e,f=[],g=[],h=-1,i=function(){for(e=a.once,d=b=!0;g.length;h=-1){c=g.shift();while(++h-1)f.splice(c,1),c<=h&&h--}),this},has:function(a){return a?r.inArray(a,f)>-1:f.length>0},empty:function(){return f&&(f=[]),this},disable:function(){return e=g=[],f=c="",this},disabled:function(){return!f},lock:function(){return e=g=[],c||b||(f=c=""),this},locked:function(){return!!e},fireWith:function(a,c){return e||(c=c||[],c=[a,c.slice?c.slice():c],g.push(c),b||i()),this},fire:function(){return j.fireWith(this,arguments),this},fired:function(){return!!d}};return j};function M(a){return a}function N(a){throw a}function O(a,b,c){var d;try{a&&r.isFunction(d=a.promise)?d.call(a).done(b).fail(c):a&&r.isFunction(d=a.then)?d.call(a,b,c):b.call(void 0,a)}catch(a){c.call(void 0,a)}}r.extend({Deferred:function(b){var c=[["notify","progress",r.Callbacks("memory"),r.Callbacks("memory"),2],["resolve","done",r.Callbacks("once memory"),r.Callbacks("once memory"),0,"resolved"],["reject","fail",r.Callbacks("once memory"),r.Callbacks("once memory"),1,"rejected"]],d="pending",e={state:function(){return d},always:function(){return f.done(arguments).fail(arguments),this},"catch":function(a){return e.then(null,a)},pipe:function(){var a=arguments;return r.Deferred(function(b){r.each(c,function(c,d){var e=r.isFunction(a[d[4]])&&a[d[4]];f[d[1]](function(){var a=e&&e.apply(this,arguments);a&&r.isFunction(a.promise)?a.promise().progress(b.notify).done(b.resolve).fail(b.reject):b[d[0]+"With"](this,e?[a]:arguments)})}),a=null}).promise()},then:function(b,d,e){var f=0;function g(b,c,d,e){return function(){var h=this,i=arguments,j=function(){var a,j;if(!(b=f&&(d!==N&&(h=void 0,i=[a]),c.rejectWith(h,i))}};b?k():(r.Deferred.getStackHook&&(k.stackTrace=r.Deferred.getStackHook()),a.setTimeout(k))}}return r.Deferred(function(a){c[0][3].add(g(0,a,r.isFunction(e)?e:M,a.notifyWith)),c[1][3].add(g(0,a,r.isFunction(b)?b:M)),c[2][3].add(g(0,a,r.isFunction(d)?d:N))}).promise()},promise:function(a){return null!=a?r.extend(a,e):e}},f={};return r.each(c,function(a,b){var g=b[2],h=b[5];e[b[1]]=g.add,h&&g.add(function(){d=h},c[3-a][2].disable,c[0][2].lock),g.add(b[3].fire),f[b[0]]=function(){return f[b[0]+"With"](this===f?void 0:this,arguments),this},f[b[0]+"With"]=g.fireWith}),e.promise(f),b&&b.call(f,f),f},when:function(a){var b=arguments.length,c=b,d=Array(c),e=f.call(arguments),g=r.Deferred(),h=function(a){return function(c){d[a]=this,e[a]=arguments.length>1?f.call(arguments):c,--b||g.resolveWith(d,e)}};if(b<=1&&(O(a,g.done(h(c)).resolve,g.reject),"pending"===g.state()||r.isFunction(e[c]&&e[c].then)))return g.then();while(c--)O(e[c],h(c),g.reject);return g.promise()}});var P=/^(Eval|Internal|Range|Reference|Syntax|Type|URI)Error$/;r.Deferred.exceptionHook=function(b,c){a.console&&a.console.warn&&b&&P.test(b.name)&&a.console.warn("jQuery.Deferred exception: "+b.message,b.stack,c)},r.readyException=function(b){a.setTimeout(function(){throw b})};var Q=r.Deferred();r.fn.ready=function(a){return Q.then(a)["catch"](function(a){r.readyException(a)}),this},r.extend({isReady:!1,readyWait:1,holdReady:function(a){a?r.readyWait++:r.ready(!0)},ready:function(a){(a===!0?--r.readyWait:r.isReady)||(r.isReady=!0,a!==!0&&--r.readyWait>0||Q.resolveWith(d,[r]))}}),r.ready.then=Q.then;function R(){d.removeEventListener("DOMContentLoaded",R), a.removeEventListener("load",R),r.ready()}"complete"===d.readyState||"loading"!==d.readyState&&!d.documentElement.doScroll?a.setTimeout(r.ready):(d.addEventListener("DOMContentLoaded",R),a.addEventListener("load",R));var S=function(a,b,c,d,e,f,g){var h=0,i=a.length,j=null==c;if("object"===r.type(c)){e=!0;for(h in c)S(a,b,h,c[h],!0,f,g)}else if(void 0!==d&&(e=!0,r.isFunction(d)||(g=!0),j&&(g?(b.call(a,d),b=null):(j=b,b=function(a,b,c){return j.call(r(a),c)})),b))for(;h1,null,!0)},removeData:function(a){return this.each(function(){W.remove(this,a)})}}),r.extend({queue:function(a,b,c){var d;if(a)return b=(b||"fx")+"queue",d=V.get(a,b),c&&(!d||r.isArray(c)?d=V.access(a,b,r.makeArray(c)):d.push(c)),d||[]},dequeue:function(a,b){b=b||"fx";var c=r.queue(a,b),d=c.length,e=c.shift(),f=r._queueHooks(a,b),g=function(){r.dequeue(a,b)};"inprogress"===e&&(e=c.shift(),d--),e&&("fx"===b&&c.unshift("inprogress"),delete f.stop,e.call(a,g,f)),!d&&f&&f.empty.fire()},_queueHooks:function(a,b){var c=b+"queueHooks";return V.get(a,c)||V.access(a,c,{empty:r.Callbacks("once memory").add(function(){V.remove(a,[b+"queue",c])})})}}),r.fn.extend({queue:function(a,b){var c=2;return"string"!=typeof a&&(b=a,a="fx",c--),arguments.length\x20\t\r\n\f]+)/i,ka=/^$|\/(?:java|ecma)script/i,la={option:[1,""],thead:[1,"","
"],col:[2,"","
"],tr:[2,"","
"],td:[3,"","
"],_default:[0,"",""]};la.optgroup=la.option,la.tbody=la.tfoot=la.colgroup=la.caption=la.thead,la.th=la.td;function ma(a,b){var c;return c="undefined"!=typeof a.getElementsByTagName?a.getElementsByTagName(b||"*"):"undefined"!=typeof a.querySelectorAll?a.querySelectorAll(b||"*"):[],void 0===b||b&&r.nodeName(a,b)?r.merge([a],c):c}function na(a,b){for(var c=0,d=a.length;c-1)e&&e.push(f);else if(j=r.contains(f.ownerDocument,f),g=ma(l.appendChild(f),"script"),j&&na(g),c){k=0;while(f=g[k++])ka.test(f.type||"")&&c.push(f)}return l}!function(){var a=d.createDocumentFragment(),b=a.appendChild(d.createElement("div")),c=d.createElement("input");c.setAttribute("type","radio"),c.setAttribute("checked","checked"),c.setAttribute("name","t"),b.appendChild(c),o.checkClone=b.cloneNode(!0).cloneNode(!0).lastChild.checked,b.innerHTML="",o.noCloneChecked=!!b.cloneNode(!0).lastChild.defaultValue}();var qa=d.documentElement,ra=/^key/,sa=/^(?:mouse|pointer|contextmenu|drag|drop)|click/,ta=/^([^.]*)(?:\.(.+)|)/;function ua(){return!0}function va(){return!1}function wa(){try{return d.activeElement}catch(a){}}function xa(a,b,c,d,e,f){var g,h;if("object"==typeof b){"string"!=typeof c&&(d=d||c,c=void 0);for(h in b)xa(a,h,c,d,b[h],f);return a}if(null==d&&null==e?(e=c,d=c=void 0):null==e&&("string"==typeof c?(e=d,d=void 0):(e=d,d=c,c=void 0)),e===!1)e=va;else if(!e)return a;return 1===f&&(g=e,e=function(a){return r().off(a),g.apply(this,arguments)},e.guid=g.guid||(g.guid=r.guid++)),a.each(function(){r.event.add(this,b,e,d,c)})}r.event={global:{},add:function(a,b,c,d,e){var f,g,h,i,j,k,l,m,n,o,p,q=V.get(a);if(q){c.handler&&(f=c,c=f.handler,e=f.selector),e&&r.find.matchesSelector(qa,e),c.guid||(c.guid=r.guid++),(i=q.events)||(i=q.events={}),(g=q.handle)||(g=q.handle=function(b){return"undefined"!=typeof r&&r.event.triggered!==b.type?r.event.dispatch.apply(a,arguments):void 0}),b=(b||"").match(K)||[""],j=b.length;while(j--)h=ta.exec(b[j])||[],n=p=h[1],o=(h[2]||"").split(".").sort(),n&&(l=r.event.special[n]||{},n=(e?l.delegateType:l.bindType)||n,l=r.event.special[n]||{},k=r.extend({type:n,origType:p,data:d,handler:c,guid:c.guid,selector:e,needsContext:e&&r.expr.match.needsContext.test(e),namespace:o.join(".")},f),(m=i[n])||(m=i[n]=[],m.delegateCount=0,l.setup&&l.setup.call(a,d,o,g)!==!1||a.addEventListener&&a.addEventListener(n,g)),l.add&&(l.add.call(a,k),k.handler.guid||(k.handler.guid=c.guid)),e?m.splice(m.delegateCount++,0,k):m.push(k),r.event.global[n]=!0)}},remove:function(a,b,c,d,e){var f,g,h,i,j,k,l,m,n,o,p,q=V.hasData(a)&&V.get(a);if(q&&(i=q.events)){b=(b||"").match(K)||[""],j=b.length;while(j--)if(h=ta.exec(b[j])||[],n=p=h[1],o=(h[2]||"").split(".").sort(),n){l=r.event.special[n]||{},n=(d?l.delegateType:l.bindType)||n,m=i[n]||[],h=h[2]&&new RegExp("(^|\\.)"+o.join("\\.(?:.*\\.|)")+"(\\.|$)"),g=f=m.length;while(f--)k=m[f],!e&&p!==k.origType||c&&c.guid!==k.guid||h&&!h.test(k.namespace)||d&&d!==k.selector&&("**"!==d||!k.selector)||(m.splice(f,1),k.selector&&m.delegateCount--,l.remove&&l.remove.call(a,k));g&&!m.length&&(l.teardown&&l.teardown.call(a,o,q.handle)!==!1||r.removeEvent(a,n,q.handle),delete i[n])}else for(n in i)r.event.remove(a,n+b[j],c,d,!0);r.isEmptyObject(i)&&V.remove(a,"handle events")}},dispatch:function(a){var b=r.event.fix(a),c,d,e,f,g,h,i=new Array(arguments.length),j=(V.get(this,"events")||{})[b.type]||[],k=r.event.special[b.type]||{};for(i[0]=b,c=1;c=1))for(;j!==this;j=j.parentNode||this)if(1===j.nodeType&&("click"!==a.type||j.disabled!==!0)){for(f=[],g={},c=0;c-1:r.find(e,this,null,[j]).length),g[e]&&f.push(d);f.length&&h.push({elem:j,handlers:f})}return j=this,i\x20\t\r\n\f]*)[^>]*)\/>/gi,za=/\s*$/g;function Da(a,b){return r.nodeName(a,"table")&&r.nodeName(11!==b.nodeType?b:b.firstChild,"tr")?a.getElementsByTagName("tbody")[0]||a:a}function Ea(a){return a.type=(null!==a.getAttribute("type"))+"/"+a.type,a}function Fa(a){var b=Ba.exec(a.type);return b?a.type=b[1]:a.removeAttribute("type"),a}function Ga(a,b){var c,d,e,f,g,h,i,j;if(1===b.nodeType){if(V.hasData(a)&&(f=V.access(a),g=V.set(b,f),j=f.events)){delete g.handle,g.events={};for(e in j)for(c=0,d=j[e].length;c1&&"string"==typeof q&&!o.checkClone&&Aa.test(q))return a.each(function(e){var f=a.eq(e);s&&(b[0]=q.call(this,e,f.html())),Ia(f,b,c,d)});if(m&&(e=pa(b,a[0].ownerDocument,!1,a,d),f=e.firstChild,1===e.childNodes.length&&(e=f),f||d)){for(h=r.map(ma(e,"script"),Ea),i=h.length;l")},clone:function(a,b,c){var d,e,f,g,h=a.cloneNode(!0),i=r.contains(a.ownerDocument,a);if(!(o.noCloneChecked||1!==a.nodeType&&11!==a.nodeType||r.isXMLDoc(a)))for(g=ma(h),f=ma(a),d=0,e=f.length;d0&&na(g,!i&&ma(a,"script")),h},cleanData:function(a){for(var b,c,d,e=r.event.special,f=0;void 0!==(c=a[f]);f++)if(T(c)){if(b=c[V.expando]){if(b.events)for(d in b.events)e[d]?r.event.remove(c,d):r.removeEvent(c,d,b.handle);c[V.expando]=void 0}c[W.expando]&&(c[W.expando]=void 0)}}}),r.fn.extend({detach:function(a){return Ja(this,a,!0)},remove:function(a){return Ja(this,a)},text:function(a){return S(this,function(a){return void 0===a?r.text(this):this.empty().each(function(){1!==this.nodeType&&11!==this.nodeType&&9!==this.nodeType||(this.textContent=a)})},null,a,arguments.length)},append:function(){return Ia(this,arguments,function(a){if(1===this.nodeType||11===this.nodeType||9===this.nodeType){var b=Da(this,a);b.appendChild(a)}})},prepend:function(){return Ia(this,arguments,function(a){if(1===this.nodeType||11===this.nodeType||9===this.nodeType){var b=Da(this,a);b.insertBefore(a,b.firstChild)}})},before:function(){return Ia(this,arguments,function(a){this.parentNode&&this.parentNode.insertBefore(a,this)})},after:function(){return Ia(this,arguments,function(a){this.parentNode&&this.parentNode.insertBefore(a,this.nextSibling)})},empty:function(){for(var a,b=0;null!=(a=this[b]);b++)1===a.nodeType&&(r.cleanData(ma(a,!1)),a.textContent="");return this},clone:function(a,b){return a=null!=a&&a,b=null==b?a:b,this.map(function(){return r.clone(this,a,b)})},html:function(a){return S(this,function(a){var b=this[0]||{},c=0,d=this.length;if(void 0===a&&1===b.nodeType)return b.innerHTML;if("string"==typeof a&&!za.test(a)&&!la[(ja.exec(a)||["",""])[1].toLowerCase()]){a=r.htmlPrefilter(a);try{for(;c1)}});function Ya(a,b,c,d,e){return new Ya.prototype.init(a,b,c,d,e)}r.Tween=Ya,Ya.prototype={constructor:Ya,init:function(a,b,c,d,e,f){this.elem=a,this.prop=c,this.easing=e||r.easing._default,this.options=b,this.start=this.now=this.cur(),this.end=d,this.unit=f||(r.cssNumber[c]?"":"px")},cur:function(){var a=Ya.propHooks[this.prop];return a&&a.get?a.get(this):Ya.propHooks._default.get(this)},run:function(a){var b,c=Ya.propHooks[this.prop];return this.options.duration?this.pos=b=r.easing[this.easing](a,this.options.duration*a,0,1,this.options.duration):this.pos=b=a,this.now=(this.end-this.start)*b+this.start,this.options.step&&this.options.step.call(this.elem,this.now,this),c&&c.set?c.set(this):Ya.propHooks._default.set(this),this}},Ya.prototype.init.prototype=Ya.prototype,Ya.propHooks={_default:{get:function(a){var b;return 1!==a.elem.nodeType||null!=a.elem[a.prop]&&null==a.elem.style[a.prop]?a.elem[a.prop]:(b=r.css(a.elem,a.prop,""),b&&"auto"!==b?b:0)},set:function(a){r.fx.step[a.prop]?r.fx.step[a.prop](a):1!==a.elem.nodeType||null==a.elem.style[r.cssProps[a.prop]]&&!r.cssHooks[a.prop]?a.elem[a.prop]=a.now:r.style(a.elem,a.prop,a.now+a.unit)}}},Ya.propHooks.scrollTop=Ya.propHooks.scrollLeft={set:function(a){a.elem.nodeType&&a.elem.parentNode&&(a.elem[a.prop]=a.now)}},r.easing={linear:function(a){return a},swing:function(a){return.5-Math.cos(a*Math.PI)/2},_default:"swing"},r.fx=Ya.prototype.init,r.fx.step={};var Za,$a,_a=/^(?:toggle|show|hide)$/,ab=/queueHooks$/;function bb(){$a&&(a.requestAnimationFrame(bb),r.fx.tick())}function cb(){return a.setTimeout(function(){Za=void 0}),Za=r.now()}function db(a,b){var c,d=0,e={height:a};for(b=b?1:0;d<4;d+=2-b)c=ba[d],e["margin"+c]=e["padding"+c]=a;return b&&(e.opacity=e.width=a),e}function eb(a,b,c){for(var d,e=(hb.tweeners[b]||[]).concat(hb.tweeners["*"]),f=0,g=e.length;f1)},removeAttr:function(a){return this.each(function(){r.removeAttr(this,a)})}}),r.extend({attr:function(a,b,c){var d,e,f=a.nodeType;if(3!==f&&8!==f&&2!==f)return"undefined"==typeof a.getAttribute?r.prop(a,b,c):(1===f&&r.isXMLDoc(a)||(e=r.attrHooks[b.toLowerCase()]||(r.expr.match.bool.test(b)?ib:void 0)), void 0!==c?null===c?void r.removeAttr(a,b):e&&"set"in e&&void 0!==(d=e.set(a,c,b))?d:(a.setAttribute(b,c+""),c):e&&"get"in e&&null!==(d=e.get(a,b))?d:(d=r.find.attr(a,b),null==d?void 0:d))},attrHooks:{type:{set:function(a,b){if(!o.radioValue&&"radio"===b&&r.nodeName(a,"input")){var c=a.value;return a.setAttribute("type",b),c&&(a.value=c),b}}}},removeAttr:function(a,b){var c,d=0,e=b&&b.match(K);if(e&&1===a.nodeType)while(c=e[d++])a.removeAttribute(c)}}),ib={set:function(a,b,c){return b===!1?r.removeAttr(a,c):a.setAttribute(c,c),c}},r.each(r.expr.match.bool.source.match(/\w+/g),function(a,b){var c=jb[b]||r.find.attr;jb[b]=function(a,b,d){var e,f,g=b.toLowerCase();return d||(f=jb[g],jb[g]=e,e=null!=c(a,b,d)?g:null,jb[g]=f),e}});var kb=/^(?:input|select|textarea|button)$/i,lb=/^(?:a|area)$/i;r.fn.extend({prop:function(a,b){return S(this,r.prop,a,b,arguments.length>1)},removeProp:function(a){return this.each(function(){delete this[r.propFix[a]||a]})}}),r.extend({prop:function(a,b,c){var d,e,f=a.nodeType;if(3!==f&&8!==f&&2!==f)return 1===f&&r.isXMLDoc(a)||(b=r.propFix[b]||b,e=r.propHooks[b]),void 0!==c?e&&"set"in e&&void 0!==(d=e.set(a,c,b))?d:a[b]=c:e&&"get"in e&&null!==(d=e.get(a,b))?d:a[b]},propHooks:{tabIndex:{get:function(a){var b=r.find.attr(a,"tabindex");return b?parseInt(b,10):kb.test(a.nodeName)||lb.test(a.nodeName)&&a.href?0:-1}}},propFix:{"for":"htmlFor","class":"className"}}),o.optSelected||(r.propHooks.selected={get:function(a){var b=a.parentNode;return b&&b.parentNode&&b.parentNode.selectedIndex,null},set:function(a){var b=a.parentNode;b&&(b.selectedIndex,b.parentNode&&b.parentNode.selectedIndex)}}),r.each(["tabIndex","readOnly","maxLength","cellSpacing","cellPadding","rowSpan","colSpan","useMap","frameBorder","contentEditable"],function(){r.propFix[this.toLowerCase()]=this});function mb(a){var b=a.match(K)||[];return b.join(" ")}function nb(a){return a.getAttribute&&a.getAttribute("class")||""}r.fn.extend({addClass:function(a){var b,c,d,e,f,g,h,i=0;if(r.isFunction(a))return this.each(function(b){r(this).addClass(a.call(this,b,nb(this)))});if("string"==typeof a&&a){b=a.match(K)||[];while(c=this[i++])if(e=nb(c),d=1===c.nodeType&&" "+mb(e)+" "){g=0;while(f=b[g++])d.indexOf(" "+f+" ")<0&&(d+=f+" ");h=mb(d),e!==h&&c.setAttribute("class",h)}}return this},removeClass:function(a){var b,c,d,e,f,g,h,i=0;if(r.isFunction(a))return this.each(function(b){r(this).removeClass(a.call(this,b,nb(this)))});if(!arguments.length)return this.attr("class","");if("string"==typeof a&&a){b=a.match(K)||[];while(c=this[i++])if(e=nb(c),d=1===c.nodeType&&" "+mb(e)+" "){g=0;while(f=b[g++])while(d.indexOf(" "+f+" ")>-1)d=d.replace(" "+f+" "," ");h=mb(d),e!==h&&c.setAttribute("class",h)}}return this},toggleClass:function(a,b){var c=typeof a;return"boolean"==typeof b&&"string"===c?b?this.addClass(a):this.removeClass(a):r.isFunction(a)?this.each(function(c){r(this).toggleClass(a.call(this,c,nb(this),b),b)}):this.each(function(){var b,d,e,f;if("string"===c){d=0,e=r(this),f=a.match(K)||[];while(b=f[d++])e.hasClass(b)?e.removeClass(b):e.addClass(b)}else void 0!==a&&"boolean"!==c||(b=nb(this),b&&V.set(this,"__className__",b),this.setAttribute&&this.setAttribute("class",b||a===!1?"":V.get(this,"__className__")||""))})},hasClass:function(a){var b,c,d=0;b=" "+a+" ";while(c=this[d++])if(1===c.nodeType&&(" "+mb(nb(c))+" ").indexOf(b)>-1)return!0;return!1}});var ob=/\r/g;r.fn.extend({val:function(a){var b,c,d,e=this[0];{if(arguments.length)return d=r.isFunction(a),this.each(function(c){var e;1===this.nodeType&&(e=d?a.call(this,c,r(this).val()):a,null==e?e="":"number"==typeof e?e+="":r.isArray(e)&&(e=r.map(e,function(a){return null==a?"":a+""})),b=r.valHooks[this.type]||r.valHooks[this.nodeName.toLowerCase()],b&&"set"in b&&void 0!==b.set(this,e,"value")||(this.value=e))});if(e)return b=r.valHooks[e.type]||r.valHooks[e.nodeName.toLowerCase()],b&&"get"in b&&void 0!==(c=b.get(e,"value"))?c:(c=e.value,"string"==typeof c?c.replace(ob,""):null==c?"":c)}}}),r.extend({valHooks:{option:{get:function(a){var b=r.find.attr(a,"value");return null!=b?b:mb(r.text(a))}},select:{get:function(a){var b,c,d,e=a.options,f=a.selectedIndex,g="select-one"===a.type,h=g?null:[],i=g?f+1:e.length;for(d=f<0?i:g?f:0;d-1)&&(c=!0);return c||(a.selectedIndex=-1),f}}}}),r.each(["radio","checkbox"],function(){r.valHooks[this]={set:function(a,b){if(r.isArray(b))return a.checked=r.inArray(r(a).val(),b)>-1}},o.checkOn||(r.valHooks[this].get=function(a){return null===a.getAttribute("value")?"on":a.value})});var pb=/^(?:focusinfocus|focusoutblur)$/;r.extend(r.event,{trigger:function(b,c,e,f){var g,h,i,j,k,m,n,o=[e||d],p=l.call(b,"type")?b.type:b,q=l.call(b,"namespace")?b.namespace.split("."):[];if(h=i=e=e||d,3!==e.nodeType&&8!==e.nodeType&&!pb.test(p+r.event.triggered)&&(p.indexOf(".")>-1&&(q=p.split("."),p=q.shift(),q.sort()),k=p.indexOf(":")<0&&"on"+p,b=b[r.expando]?b:new r.Event(p,"object"==typeof b&&b),b.isTrigger=f?2:3,b.namespace=q.join("."),b.rnamespace=b.namespace?new RegExp("(^|\\.)"+q.join("\\.(?:.*\\.|)")+"(\\.|$)"):null,b.result=void 0,b.target||(b.target=e),c=null==c?[b]:r.makeArray(c,[b]),n=r.event.special[p]||{},f||!n.trigger||n.trigger.apply(e,c)!==!1)){if(!f&&!n.noBubble&&!r.isWindow(e)){for(j=n.delegateType||p,pb.test(j+p)||(h=h.parentNode);h;h=h.parentNode)o.push(h),i=h;i===(e.ownerDocument||d)&&o.push(i.defaultView||i.parentWindow||a)}g=0;while((h=o[g++])&&!b.isPropagationStopped())b.type=g>1?j:n.bindType||p,m=(V.get(h,"events")||{})[b.type]&&V.get(h,"handle"),m&&m.apply(h,c),m=k&&h[k],m&&m.apply&&T(h)&&(b.result=m.apply(h,c),b.result===!1&&b.preventDefault());return b.type=p,f||b.isDefaultPrevented()||n._default&&n._default.apply(o.pop(),c)!==!1||!T(e)||k&&r.isFunction(e[p])&&!r.isWindow(e)&&(i=e[k],i&&(e[k]=null),r.event.triggered=p,e[p](),r.event.triggered=void 0,i&&(e[k]=i)),b.result}},simulate:function(a,b,c){var d=r.extend(new r.Event,c,{type:a,isSimulated:!0});r.event.trigger(d,null,b)}}),r.fn.extend({trigger:function(a,b){return this.each(function(){r.event.trigger(a,b,this)})},triggerHandler:function(a,b){var c=this[0];if(c)return r.event.trigger(a,b,c,!0)}}),r.each("blur focus focusin focusout resize scroll click dblclick mousedown mouseup mousemove mouseover mouseout mouseenter mouseleave change select submit keydown keypress keyup contextmenu".split(" "),function(a,b){r.fn[b]=function(a,c){return arguments.length>0?this.on(b,null,a,c):this.trigger(b)}}),r.fn.extend({hover:function(a,b){return this.mouseenter(a).mouseleave(b||a)}}),o.focusin="onfocusin"in a,o.focusin||r.each({focus:"focusin",blur:"focusout"},function(a,b){var c=function(a){r.event.simulate(b,a.target,r.event.fix(a))};r.event.special[b]={setup:function(){var d=this.ownerDocument||this,e=V.access(d,b);e||d.addEventListener(a,c,!0),V.access(d,b,(e||0)+1)},teardown:function(){var d=this.ownerDocument||this,e=V.access(d,b)-1;e?V.access(d,b,e):(d.removeEventListener(a,c,!0),V.remove(d,b))}}});var qb=a.location,rb=r.now(),sb=/\?/;r.parseXML=function(b){var c;if(!b||"string"!=typeof b)return null;try{c=(new a.DOMParser).parseFromString(b,"text/xml")}catch(d){c=void 0}return c&&!c.getElementsByTagName("parsererror").length||r.error("Invalid XML: "+b),c};var tb=/\[\]$/,ub=/\r?\n/g,vb=/^(?:submit|button|image|reset|file)$/i,wb=/^(?:input|select|textarea|keygen)/i;function xb(a,b,c,d){var e;if(r.isArray(b))r.each(b,function(b,e){c||tb.test(a)?d(a,e):xb(a+"["+("object"==typeof e&&null!=e?b:"")+"]",e,c,d)});else if(c||"object"!==r.type(b))d(a,b);else for(e in b)xb(a+"["+e+"]",b[e],c,d)}r.param=function(a,b){var c,d=[],e=function(a,b){var c=r.isFunction(b)?b():b;d[d.length]=encodeURIComponent(a)+"="+encodeURIComponent(null==c?"":c)};if(r.isArray(a)||a.jquery&&!r.isPlainObject(a))r.each(a,function(){e(this.name,this.value)});else for(c in a)xb(c,a[c],b,e);return d.join("&")},r.fn.extend({serialize:function(){return r.param(this.serializeArray())},serializeArray:function(){return this.map(function(){var a=r.prop(this,"elements");return a?r.makeArray(a):this}).filter(function(){var a=this.type;return this.name&&!r(this).is(":disabled")&&wb.test(this.nodeName)&&!vb.test(a)&&(this.checked||!ia.test(a))}).map(function(a,b){var c=r(this).val();return null==c?null:r.isArray(c)?r.map(c,function(a){return{name:b.name,value:a.replace(ub,"\r\n")}}):{name:b.name,value:c.replace(ub,"\r\n")}}).get()}});var yb=/%20/g,zb=/#.*$/,Ab=/([?&])_=[^&]*/,Bb=/^(.*?):[ \t]*([^\r\n]*)$/gm,Cb=/^(?:about|app|app-storage|.+-extension|file|res|widget):$/,Db=/^(?:GET|HEAD)$/,Eb=/^\/\//,Fb={},Gb={},Hb="*/".concat("*"),Ib=d.createElement("a");Ib.href=qb.href;function Jb(a){return function(b,c){"string"!=typeof b&&(c=b,b="*");var d,e=0,f=b.toLowerCase().match(K)||[];if(r.isFunction(c))while(d=f[e++])"+"===d[0]?(d=d.slice(1)||"*",(a[d]=a[d]||[]).unshift(c)):(a[d]=a[d]||[]).push(c)}}function Kb(a,b,c,d){var e={},f=a===Gb;function g(h){var i;return e[h]=!0,r.each(a[h]||[],function(a,h){var j=h(b,c,d);return"string"!=typeof j||f||e[j]?f?!(i=j):void 0:(b.dataTypes.unshift(j),g(j),!1)}),i}return g(b.dataTypes[0])||!e["*"]&&g("*")}function Lb(a,b){var c,d,e=r.ajaxSettings.flatOptions||{};for(c in b)void 0!==b[c]&&((e[c]?a:d||(d={}))[c]=b[c]);return d&&r.extend(!0,a,d),a}function Mb(a,b,c){var d,e,f,g,h=a.contents,i=a.dataTypes;while("*"===i[0])i.shift(),void 0===d&&(d=a.mimeType||b.getResponseHeader("Content-Type"));if(d)for(e in h)if(h[e]&&h[e].test(d)){i.unshift(e);break}if(i[0]in c)f=i[0];else{for(e in c){if(!i[0]||a.converters[e+" "+i[0]]){f=e;break}g||(g=e)}f=f||g}if(f)return f!==i[0]&&i.unshift(f),c[f]}function Nb(a,b,c,d){var e,f,g,h,i,j={},k=a.dataTypes.slice();if(k[1])for(g in a.converters)j[g.toLowerCase()]=a.converters[g];f=k.shift();while(f)if(a.responseFields[f]&&(c[a.responseFields[f]]=b),!i&&d&&a.dataFilter&&(b=a.dataFilter(b,a.dataType)),i=f,f=k.shift())if("*"===f)f=i;else if("*"!==i&&i!==f){if(g=j[i+" "+f]||j["* "+f],!g)for(e in j)if(h=e.split(" "),h[1]===f&&(g=j[i+" "+h[0]]||j["* "+h[0]])){g===!0?g=j[e]:j[e]!==!0&&(f=h[0],k.unshift(h[1]));break}if(g!==!0)if(g&&a["throws"])b=g(b);else try{b=g(b)}catch(l){return{state:"parsererror",error:g?l:"No conversion from "+i+" to "+f}}}return{state:"success",data:b}}r.extend({active:0,lastModified:{},etag:{},ajaxSettings:{url:qb.href,type:"GET",isLocal:Cb.test(qb.protocol),global:!0,processData:!0,async:!0,contentType:"application/x-www-form-urlencoded; charset=UTF-8",accepts:{"*":Hb,text:"text/plain",html:"text/html",xml:"application/xml, text/xml",json:"application/json, text/javascript"},contents:{xml:/\bxml\b/,html:/\bhtml/,json:/\bjson\b/},responseFields:{xml:"responseXML",text:"responseText",json:"responseJSON"},converters:{"* text":String,"text html":!0,"text json":JSON.parse,"text xml":r.parseXML},flatOptions:{url:!0,context:!0}},ajaxSetup:function(a,b){return b?Lb(Lb(a,r.ajaxSettings),b):Lb(r.ajaxSettings,a)},ajaxPrefilter:Jb(Fb),ajaxTransport:Jb(Gb),ajax:function(b,c){"object"==typeof b&&(c=b,b=void 0),c=c||{};var e,f,g,h,i,j,k,l,m,n,o=r.ajaxSetup({},c),p=o.context||o,q=o.context&&(p.nodeType||p.jquery)?r(p):r.event,s=r.Deferred(),t=r.Callbacks("once memory"),u=o.statusCode||{},v={},w={},x="canceled",y={readyState:0,getResponseHeader:function(a){var b;if(k){if(!h){h={};while(b=Bb.exec(g))h[b[1].toLowerCase()]=b[2]}b=h[a.toLowerCase()]}return null==b?null:b},getAllResponseHeaders:function(){return k?g:null},setRequestHeader:function(a,b){return null==k&&(a=w[a.toLowerCase()]=w[a.toLowerCase()]||a,v[a]=b),this},overrideMimeType:function(a){return null==k&&(o.mimeType=a),this},statusCode:function(a){var b;if(a)if(k)y.always(a[y.status]);else for(b in a)u[b]=[u[b],a[b]];return this},abort:function(a){var b=a||x;return e&&e.abort(b),A(0,b),this}};if(s.promise(y),o.url=((b||o.url||qb.href)+"").replace(Eb,qb.protocol+"//"),o.type=c.method||c.type||o.method||o.type,o.dataTypes=(o.dataType||"*").toLowerCase().match(K)||[""],null==o.crossDomain){j=d.createElement("a");try{j.href=o.url,j.href=j.href,o.crossDomain=Ib.protocol+"//"+Ib.host!=j.protocol+"//"+j.host}catch(z){o.crossDomain=!0}}if(o.data&&o.processData&&"string"!=typeof o.data&&(o.data=r.param(o.data,o.traditional)),Kb(Fb,o,c,y),k)return y;l=r.event&&o.global,l&&0===r.active++&&r.event.trigger("ajaxStart"),o.type=o.type.toUpperCase(),o.hasContent=!Db.test(o.type),f=o.url.replace(zb,""),o.hasContent?o.data&&o.processData&&0===(o.contentType||"").indexOf("application/x-www-form-urlencoded")&&(o.data=o.data.replace(yb,"+")):(n=o.url.slice(f.length),o.data&&(f+=(sb.test(f)?"&":"?")+o.data,delete o.data),o.cache===!1&&(f=f.replace(Ab,"$1"),n=(sb.test(f)?"&":"?")+"_="+rb++ +n),o.url=f+n),o.ifModified&&(r.lastModified[f]&&y.setRequestHeader("If-Modified-Since",r.lastModified[f]),r.etag[f]&&y.setRequestHeader("If-None-Match",r.etag[f])),(o.data&&o.hasContent&&o.contentType!==!1||c.contentType)&&y.setRequestHeader("Content-Type",o.contentType),y.setRequestHeader("Accept",o.dataTypes[0]&&o.accepts[o.dataTypes[0]]?o.accepts[o.dataTypes[0]]+("*"!==o.dataTypes[0]?", "+Hb+"; q=0.01":""):o.accepts["*"]);for(m in o.headers)y.setRequestHeader(m,o.headers[m]);if(o.beforeSend&&(o.beforeSend.call(p,y,o)===!1||k))return y.abort();if(x="abort",t.add(o.complete),y.done(o.success),y.fail(o.error),e=Kb(Gb,o,c,y)){if(y.readyState=1,l&&q.trigger("ajaxSend",[y,o]),k)return y;o.async&&o.timeout>0&&(i=a.setTimeout(function(){y.abort("timeout")},o.timeout));try{k=!1,e.send(v,A)}catch(z){if(k)throw z;A(-1,z)}}else A(-1,"No Transport");function A(b,c,d,h){var j,m,n,v,w,x=c;k||(k=!0,i&&a.clearTimeout(i),e=void 0,g=h||"",y.readyState=b>0?4:0,j=b>=200&&b<300||304===b,d&&(v=Mb(o,y,d)),v=Nb(o,v,y,j),j?(o.ifModified&&(w=y.getResponseHeader("Last-Modified"),w&&(r.lastModified[f]=w),w=y.getResponseHeader("etag"),w&&(r.etag[f]=w)),204===b||"HEAD"===o.type?x="nocontent":304===b?x="notmodified":(x=v.state,m=v.data,n=v.error,j=!n)):(n=x,!b&&x||(x="error",b<0&&(b=0))),y.status=b,y.statusText=(c||x)+"",j?s.resolveWith(p,[m,x,y]):s.rejectWith(p,[y,x,n]),y.statusCode(u),u=void 0,l&&q.trigger(j?"ajaxSuccess":"ajaxError",[y,o,j?m:n]),t.fireWith(p,[y,x]),l&&(q.trigger("ajaxComplete",[y,o]),--r.active||r.event.trigger("ajaxStop")))}return y},getJSON:function(a,b,c){return r.get(a,b,c,"json")},getScript:function(a,b){return r.get(a,void 0,b,"script")}}),r.each(["get","post"],function(a,b){r[b]=function(a,c,d,e){return r.isFunction(c)&&(e=e||d,d=c,c=void 0),r.ajax(r.extend({url:a,type:b,dataType:e,data:c,success:d},r.isPlainObject(a)&&a))}}),r._evalUrl=function(a){return r.ajax({url:a,type:"GET",dataType:"script",cache:!0,async:!1,global:!1,"throws":!0})},r.fn.extend({wrapAll:function(a){var b;return this[0]&&(r.isFunction(a)&&(a=a.call(this[0])),b=r(a,this[0].ownerDocument).eq(0).clone(!0),this[0].parentNode&&b.insertBefore(this[0]),b.map(function(){var a=this;while(a.firstElementChild)a=a.firstElementChild;return a}).append(this)),this},wrapInner:function(a){return r.isFunction(a)?this.each(function(b){r(this).wrapInner(a.call(this,b))}):this.each(function(){var b=r(this),c=b.contents();c.length?c.wrapAll(a):b.append(a)})},wrap:function(a){var b=r.isFunction(a);return this.each(function(c){r(this).wrapAll(b?a.call(this,c):a)})},unwrap:function(a){return this.parent(a).not("body").each(function(){r(this).replaceWith(this.childNodes)}),this}}),r.expr.pseudos.hidden=function(a){return!r.expr.pseudos.visible(a)},r.expr.pseudos.visible=function(a){return!!(a.offsetWidth||a.offsetHeight||a.getClientRects().length)},r.ajaxSettings.xhr=function(){try{return new a.XMLHttpRequest}catch(b){}};var Ob={0:200,1223:204},Pb=r.ajaxSettings.xhr();o.cors=!!Pb&&"withCredentials"in Pb,o.ajax=Pb=!!Pb,r.ajaxTransport(function(b){var c,d;if(o.cors||Pb&&!b.crossDomain)return{send:function(e,f){var g,h=b.xhr();if(h.open(b.type,b.url,b.async,b.username,b.password),b.xhrFields)for(g in b.xhrFields)h[g]=b.xhrFields[g];b.mimeType&&h.overrideMimeType&&h.overrideMimeType(b.mimeType),b.crossDomain||e["X-Requested-With"]||(e["X-Requested-With"]="XMLHttpRequest");for(g in e)h.setRequestHeader(g,e[g]);c=function(a){return function(){c&&(c=d=h.onload=h.onerror=h.onabort=h.onreadystatechange=null,"abort"===a?h.abort():"error"===a?"number"!=typeof h.status?f(0,"error"):f(h.status,h.statusText):f(Ob[h.status]||h.status,h.statusText,"text"!==(h.responseType||"text")||"string"!=typeof h.responseText?{binary:h.response}:{text:h.responseText},h.getAllResponseHeaders()))}},h.onload=c(),d=h.onerror=c("error"),void 0!==h.onabort?h.onabort=d:h.onreadystatechange=function(){4===h.readyState&&a.setTimeout(function(){c&&d()})},c=c("abort");try{h.send(b.hasContent&&b.data||null)}catch(i){if(c)throw i}},abort:function(){c&&c()}}}),r.ajaxPrefilter(function(a){a.crossDomain&&(a.contents.script=!1)}),r.ajaxSetup({accepts:{script:"text/javascript, application/javascript, application/ecmascript, application/x-ecmascript"},contents:{script:/\b(?:java|ecma)script\b/},converters:{"text script":function(a){return r.globalEval(a),a}}}),r.ajaxPrefilter("script",function(a){void 0===a.cache&&(a.cache=!1),a.crossDomain&&(a.type="GET")}),r.ajaxTransport("script",function(a){if(a.crossDomain){var b,c;return{send:function(e,f){b=r("