Nothing
R/html.s
In Hmisc: Harrell Miscellaneous
Defines functions
htmlTranslate
htmlSpecial
htmlGreek
htmlVerbatim
html.default
html.data.frame
html.latex
html
Documented in
html
html.data.frame
html.default
htmlGreek
html.latex
htmlSpecial
htmlTranslate
htmlVerbatim
html <- function(object, ...) UseMethod('html')
html.latex <- function(object, file, where=c('cwd', 'tmp'),
method=c('hevea', 'htlatex'), rmarkdown=FALSE,
cleanup=TRUE, ...)
{
where <- match.arg(where)
method <- match.arg(method)
if(where == 'tmp') cleanup <- FALSE
if(rmarkdown && ! missing(file))
warning('do not specify file when rmarkdown=TRUE')
fi <- object$file
fibase <- gsub('\\.tex', '', fi)
if(missing(file)) file <- paste(fibase, 'html', sep='.')
if(rmarkdown) file <- character(0)
toConsole <- ! length(file) || file == ''
ehtml = function(content) { # Thanks to Yihui
if(! requireNamespace('htmltools', quietly=TRUE))
stop('htmltools package not installed')
content = htmltools::HTML(gsub('^.*?<body\\s*>|</body>.*$', '', content))
ss <- paste(fibase, '-enclosed.css', sep='')
src <- switch(where, cwd=getwd(), tmp=tempdir())
d = htmltools::htmlDependency(
'TeX4ht', '1.0.0', src = src, stylesheet = ss)
htmltools::attachDependencies(content, d)
}
sty <- object$style
if(length(sty))
sty <- paste('\\usepackage{', unique(sty), '}', sep='')
tmp <- switch(where,
cwd = paste(fibase, 'enclosed', sep='-'),
tmp = tempfile())
tmptex <- paste(tmp, 'tex', sep='.')
infi <- readLines(fi)
cat('\\documentclass{report}', sty,
if(method == 'hevea') '\\def\\tabularnewline{\\\\}',
'\\begin{document}', infi,
'\\end{document}\n', file=tmptex, sep='\n')
sc <- if(.Platform$OS.type == 'unix') ';' else '&'
## Create system call to convert enclosed latex file to html.
cmd <-
if(missing(file) || ! length(file) || file == '')
paste(optionsCmds(method), shQuote(tmptex))
else
paste(optionsCmds(method), '-o', file, shQuote(tmptex))
## perform system call
sys(cmd)
if(method == 'hevea' && ! toConsole) {
## Remove 2 bottom lines added by HeVeA
infi <- readLines(file)
i <- grep('<hr style="height:2"><blockquote class="quote"><em>This document was translated from L<sup>A</sup>T<sub>E</sub>X by', infi)
i <- c(i, grep('</em><a href="http://hevea.inria.fr/index.html"><em>H</em><em><span style="font-size:small"><sup>E</sup></span></em><em>V</em><em><span style="font-size:small"><sup>E</sup></span></em><em>A</em></a><em>.</em></blockquote></body>', infi))
if(length(i)) {
infi <- infi[- i]
writeLines(infi, file)
}
if(cleanup) {
bf <- gsub('\\.html', '', file)
unlink(c(paste(bf, 'haux', sep='.'),
paste(bf, 'enclosed.tex', sep='-')))
}
return(structure(list(file=file), class='html'))
}
if(cleanup && method == 'htlatex')
unlink(paste(tmp, c('tex', 'tmp','idv','lg','4tc','aux','dvi','log',
'xref','4ct'), sep='.'))
if(rmarkdown || toConsole) {
w <- readLines(paste(tmp, 'html', sep='.'))
if(rmarkdown) return(ehtml(w))
if(! length(file)) return(paste(w, collapse='\n'))
cat(w, sep='\n')
return(invisible())
}
structure(list(file=file), class='html')
}
html.data.frame <-
function(object,
file=paste(first.word(deparse(substitute(object))),
'html',sep='.'),
header, caption=NULL, rownames=FALSE,
align='r', align.header='c', bold.header=TRUE,
col.header='Black', border=2,
width=NULL, size=100, translate=FALSE,
append=FALSE, link=NULL, linkCol=1,
linkType=c('href','name'), disableq=FALSE, ...)
{
linkType <- match.arg(linkType)
mu <- markupSpecs$html
tr <- c(c='center', l='left', r='right')
align <- tr[align]
align.header <- tr[align.header]
trans <- if(translate) htmlTranslate else function(x) x
disableq <- if(disableq) ' data-quarto-disable-processing="true"' else ''
x <- as.matrix(object)
# for(i in 1:ncol(x)) {
# xi <- x[,i]
# if(is.numeric(object[,i]))
# x[,i] <- paste0('<div align=right>', xi, '</div>')
# }
if(rownames && length(r <- rownames(x)))
x <- cbind(Name=as.character(r), x)
b <- c('border: 1px solid gray;', 'border-collapse: collapse;')
## Give style a name hmisctablexxx where xxx is a random 6-digit integer
## because if you reuse the same style in the same document, style
## elements will affect tables that preceeded this one
sn <- paste0('hmisctable', floor(runif(1, 100000, 999999)))
psn <- paste0('.', sn)
## Duplicate specifications because can't get any single one to work
lua <- length(unique(align))
sty <- c('<style>',
paste0(psn, ' {'),
if(border == 0) 'border: none;' else b,
paste0('font-size: ', size, '%;'),
'}',
paste0(psn, ' td {'),
if(lua == 1) paste0('text-align: ', align, ';'),
'padding: 0 1ex 0 1ex;', ## top left bottom right
'}',
paste0(psn, ' th {'),
paste0('color: ', col.header, ';'),
paste0('text-align: ', align.header, ';'),
'padding: 0 1ex 0 1ex;',
if(bold.header) 'font-weight: bold;' else 'font-weight: normal;',
'}',
'</style>')
R <- c(sty, paste0('<table', disableq, ' class="', sn, '"',
if(length(width) == 1)
paste0(' width="', width, '"'),
if(border == 1) ' border="0"',
if(border == 2) ' border="1"', '>'))
if(length(caption))
R <- c(R, paste0('<caption>', mu$lcap(caption), '</caption>'))
if(missing(header)) header <- colnames(x)
if(length(header)) {
head <- trans(header)
head <- paste0('<th>', head, '</th>')
head <- paste0('<tr>', paste(head, collapse=''), '</tr>')
R <- c(R, head)
}
if(length(link)) {
if(is.matrix(link))
for(j in 1 : ncol(x))
x[, j] <- ifelse(link[, j] == '', x[, j],
paste0('<a ', linkType, '="', link[, j], '">',
trans(x[, j]), '</a>'))
# x[link != ''] <- paste('<a ',linkType,'="', link[link!=''],'">',
# trans(x[link != '']), '</a>', sep='')
else
x[,linkCol] <- ifelse(link == '', trans(x[, linkCol]),
paste0('<a ',linkType, '="', link, '">',
trans(x[, linkCol]), '</a>'))
}
for(i in 1 : nrow(x)) {
rowt <- if(lua == 1) paste0('<td>', x[i, ], '</td>')
else
paste0('<td style="text-align:', align, ';">',
x[i, ], '</td>')
R <- c(R, paste0('<tr>', paste(rowt, collapse=''), '</tr>'))
}
R <- c(R, '</table>')
if(is.logical(file) && ! file)
return(htmltools::HTML(paste0(R, '\n')))
cat(R, file=file, append=append && file != '', sep='\n')
structure(list(file=file), class='html')
}
html.default <- function(object,
file=paste(first.word(deparse(substitute(object))),
'html', sep='.'),
append=FALSE,
link=NULL, linkCol=1, linkType=c('href','name'),
...)
html.data.frame(object, file=file, append=append, link=link,
linkCol=linkCol, linkType=linkType, ...)
if(FALSE) {
show.html <- function(object)
{
browser <- .Options$help.browser
if(!length(browser))
browser <- .Options$browser
if(!length(browser))
browser <- 'netscape'
sys(paste(browser, object, if(.Platform$OS.type == 'unix') '&'))
invisible()
}
print.html <- function(x, ...) show.html(x)
}
htmlVerbatim <- function(..., size = 75, width = 85,
scroll=FALSE, rows=10, cols=100,
propts=NULL, omit1b=FALSE) {
if(scroll) {
nam <- as.character(sys.call()[2])
w <- paste0('<textarea class="scrollabletextbox" rows=', rows,
' cols=', cols, ' style="font-size:', size,
'%; font-family:Courier New;" name="', nam, '">')
}
else w <- paste0('<pre style="font-size:', size, '%;">')
op <- options(width=width)
propts <- c(propts, list(quote=FALSE))
for(x in list(...)) {
z <- capture.output(do.call('print', c(list(x), propts)))
if(omit1b && trimws(z[1]) == '') z <- z[-1]
if(omit1b) z[length(z)] <- sub('\n$', '', z[length(z)])
w <- c(w, z)
}
options(op)
## Remove trailing \n which is not needed since </pre> will follow
lw <- length(w)
if(lw > 1) w[-lw] <- paste0(w[-lw], '\n')
w <- c(w, if(scroll) '</textarea>\n' else '</pre>\n')
htmltools::HTML(w)
}
htmlGreek <- function(x, mult=FALSE, code=htmlSpecialType()) {
orig <- c('alpha','beta','gamma','delta','epsilon','varepsilon',
'zeta', 'eta',
'theta','vartheta','iota','kappa','lambda','mu','nu',
'xi','pi','varpi','rho','varrho','sigma','varsigma','tau',
'upsilon','phi','chi','psi','omega','Gamma','Delta',
'Theta','Lambda','Xi','Pi','Sigma','Upsilon','Phi','Psi','Omega')
l <- length(orig)
new <- if(code == 'unicode')
substring('\u3B1\u3B2\u3B3\u3B4\u3B5\u3F5\u3B6\u3B7\u3B8\u3D1\u3B9\u3BA\u3BB\u3BC\u3BD\u3BE\u3C0\u3D6\u3C1\u3F1\u3C3\u3C2\u3C4\u3C5\u3C6\u3C7\u3C8\u3C9\u393\u394\u398\u39B\u39E\u3A0\u3A3\u3A5\u3A6\u3A8\u3A9',
1 : l, 1 : l)
else
paste0('&#',
c(945,946,947,948,949,1013,950,951,952,977,953,954,955,956,957,958,
960,982,961,1009,963,962,964,965,966,967,968,969,915,916,920,923,
926,928,931,933,934,936,937),
';')
names(new) <- orig
if(mult) {
for(j in 1 : l) x <- gsub(paste0('\\<', orig[j], '\\>'), new[j], x)
return(x)
}
if(! all(x %in% orig)) stop(paste0('illegal Greek letter name:', x))
new[x]
}
htmlSpecial <- function(x, code=htmlSpecialType()) {
z <- c(nbsp = '160\u00A0',
thinsp = '8201\u2009',
emsp = '8195\u2003',
ensp = '8194\u2002',
plusmn = '177\u00B1',
times = '215\u00D7',
caret = '94\u005E',
frasl = '8260\u2044',
half = '189\u00BD',
angrt = '8735\u221F',
squarecrosshatch = '9638\u2586',
whitesquareverticalline = '9707\u25EB',
blackdowntriangle = '9660\u25BC',
mediumsmallwhitecircle = '9900\u26AC',
combiningcircumflexaccent = '770\u005E',
part = '8706\u2202')
u <- substring(z, nchar(z), nchar(z))
n <- substring(z, 1, nchar(z) - 1)
new <- if(code == 'unicode') u else paste0('&#', n, ';')
names(new) <- names(z)
if(! all(x %in% names(z))) stop(paste0('illegal character name:',
x[x %nin% names(z)]))
new[x]
}
markupSpecs <- list(html=list(
## <span> needed for text in plotly graphics
bold = function(..., span=TRUE)
if(span) paste0('<span style="font-weight:bold">', ..., '</span>')
else paste0('<strong>', ..., '</strong>'),
italics = function(...) paste0('<i>', ..., '</i>'),
math = function(...) paste0('<i>', ..., '</i>'),
ord = function(n) paste0(n, '<sup>', markupSpecs$all$ordsuffix(n),
'</sup>'),
code = function(...) paste0('<code style="font-size:0.8em">', ..., '</code>'),
sup = function(x, ...) paste0('<sup>', x, '</sup>'),
sub = function(x, ...) paste0('<sub>', x, '</sub>'),
size = function(..., pct) paste0('<span style="font-size: ', pct,
'%;">', paste(..., collapse=' '),
'</span>'),
smaller = function(...) paste0('<span style="font-size: 80%;">', ...,
'</span>'),
larger = function(...) paste0('<span style="font-size: 125%;">', ...,
'</span>'),
smaller2 = function(...) paste0('<span style="font-size: 64%;">', ...,
'</span>'),
larger2 = function(...) paste0('<span style="font-size: 156%;">', ...,
'</span>'),
center = function(...) paste0('<div align=center>', ..., '</div>'),
color = function(..., col) paste0('<font color="', col, '">', ...,
'</font>'),
## Break a long string into two lines with <br> inserted at a space
## between words that is close to the middle of the string
## Cole Beck 2018-10-18
addBreak = function(x, minbreak=30) {
sl <- nchar(x)
if(sl < minbreak) return(x)
si <- c(gregexpr(' ', x)[[1]])
ix <- si[which.min(abs(si - sl/2))]
p1 <- substr(x, 1, ix - 1)
p2 <- substr(x, ix + 1, sl)
paste0(p1, "<br>", p2)
},
subtext = function(..., color='blue')
paste0('<br><font size=1 color="', color, '">',
paste(unlist(list(...)), collapse=' '),
'</font>'),
cap = function(..., symbol=htmlSpecial('angrt')) { # figure caption formatting
## alternative: symbol='Figure:'; default is right angle
## use symbol=htmlSpecial('squarecrosshatch') for grid graph paper symbol
lcap <- htmlTranslate(paste(unlist(list(...)), collapse=' '), greek=TRUE)
paste0('<span style="font-family:Verdana;font-size:10px;">', symbol,
' </span><span style="font-family:Verdana;font-size:12px;color:MidnightBlue;">',
lcap, '</span>')
},
lcap = function(...) # for continuation of figure caption
paste0('<span style="font-family:Verdana;font-size:12px;color:MidnightBlue;">',
htmlTranslate(paste(unlist(list(...)), collapse=' '), greek=TRUE),
'</span>'),
tcap = function(..., symbol=htmlSpecial('whitesquareverticalline')) { # table caption formatting
# alt: symbol='Table:'; default is white square w/vertical bisecting line
lcap <- htmlTranslate(paste(unlist(list(...)), collapse=' '), greek=TRUE)
paste0('<span style="font-family:Verdana;font-size:10px;">', symbol,
' </span><span style="font-family:Verdana;font-size:12px;color:MidnightBlue;">',
lcap, '</span>')
},
ltcap = function(...) # for continuation of table caption
paste0('<span style="font-family:Verdana;font-size:12px;color:MidnightBlue;">',
htmlTranslate(paste(unlist(list(...)), collapse=' '), greek=TRUE),
'</span>'),
expcoll = function(vis, invis) {
id <- floor(runif(1, 100000, 999999)) # unique html id
paste0('<br><a href="#', id, '" id="', id,
'_earrows" class="earrows" onclick="expand_collapse(\'',
id, '\');">', htmlSpecial('blackdowntriangle'), '</a>',
vis, '<span id="', id,
'" style="display:none;">',
invis, '</span>')
},
expcolld = function(vis, invis)
paste0('<details><summary>', vis, ## htmlSpecial('blackdowntriangle'),
'</summary>', invis, '</details>'),
uncover = function(before, options, envir) {
## https://stackoverflow.com/questions/44866287
## usage: knitrSet(lang='markdown') # issues knit_hooks$set(uncover=uncover)
## <script>
## function uncover(id) {
## var x = document.getElementById(id);
## x.style.display = 'block';
## }
## </script>
##
## ```{r, uncover=TRUE, label='text for button', id='script'}
## 1 + 1
## ```
if (before) {
id <- options$id
label <- options$label
if(! length(label)) label <- 'Uncover'
button_string <- paste0("<button onclick=\"uncover('",
id, "')\">", label, "</button>")
div_string <- paste0("<div id = '", id,
"', style = 'display:none'>")
paste0(button_string, "\n", div_string)
}
else {
"</div>"
}
},
session = function(cite=TRUE, loadedOnly=FALSE, style=NULL) {
si <- sessionInfo()
if(! loadedOnly) si$loadedOnly <- NULL
# Need to default to html because non-RStudio knitting to .md
# will not know ultimate output format
if(! length(style))
style <- if(knitr::is_html_output() ) 'html' else
if(knitr::is_latex_output()) 'latex' else 'html'
tt <- function(x) switch(style,
text = x,
html = paste0('<tt>', x, '</tt>'),
latex = paste0('\\texttt{', x, '}'))
w <- c(if(style == 'html') '<pre>',
if(style == 'latex') toLatex(si, locale=FALSE) else
capture.output(print(si, locale=FALSE)),
if(style == 'html') '</pre>',
if(cite) 'To cite R in publications use:',
if(cite) capture.output(print(citation(), style=style)))
if(cite) {
s <- search()
for(pac in c('Hmisc', 'rms', 'rmsb', 'hreport', 'VGAM',
'data.table', 'ggplot2', 'rstan', 'survival')) {
if(paste0('package:', pac) %in% s) {
w <- c(w, paste0('\nTo cite the ', tt(pac),
' package in publications use:\n'))
w <- c(w, capture.output(print(citation(pac)[1], style=style)))
}
}
}
w <- paste0(w, '\n')
if(style == 'html') htmltools::HTML(w) else knitr::asis_output(w)
},
installcsl = function(cslname, rec=FALSE) {
if(rec) {
cat('Shows URLs:', 'american-medical-association',
'',
'Does not show URLs:', 'council-of-science-editors',
'american-medical-association-no-url', sep='\n')
return(invisible())
}
if(missing(cslname))
browseURL('https://www.zotero.org/styles')
else
download.file(paste0('https://raw.githubusercontent.com/citation-style-language/styles/master/',
cslname, '.csl'), paste0(cslname, '.csl'))
},
citeulikeShow = function(user, bibkeys=NULL, tags=NULL, file=NULL) {
if(length(file)) {
x <- readLines(file)
## See http://stackoverflow.com/questions/8613237
bibkeys <- unlist(regmatches(x, gregexpr("(?<=\\[@).*?(?=\\])",
x, perl=TRUE)))
}
if(length(bibkeys)) {
keys <- paste(paste0('bibkey%3A+', bibkeys), collapse='+OR+')
browseURL(paste0('http://www.citeulike.org/search/username?q=',
keys, '&search=Search+library&username=', user))
} else browseURL(paste0('http://www.citeulike.org/user/',
user, '/tag/', tags))
invisible(bibkeys)
},
widescreen = function(width='4000px')
htmltools::HTML(paste0('<style>div.main-container {max-width:',
width, ';}</style>')),
tocsize = function(width = '20%', maxwidth = '260px', maxheight='85%')
htmltools::HTML(paste0('<style>div.tocify {width: ', width,
'; max-width: ', maxwidth, '; max-height: ',
maxheight, ';}</style>')),
sectionNumberDepth = function() {
## Set depth for numbering sections the same as TOC depth
## See https://stackoverflow.com/questions/47124299/
toc_depth <- rmarkdown::metadata$output$html_document$toc_depth
sel <- paste0("h", (toc_depth + 1) : 10, collapse = " > span, ")
paste0("<style>", sel, " > .header-section-number { display: none; } </style>")
},
scroll = function(x, size=75, rows=10, cols=100,
font='', name='') {
w <- paste0('<div style="width: ', cols, 'ex; overflow: auto; height: ',
rows, 'ex;">')
c(w, x, '</div>')
},
chisq = function(x, ...)
# paste0('\u03C7&<span class="xscript" style="font-size: 75%;"><sup>2</sup><sub>', x,
# '</sub></span>')
if(missing(x)) paste0(htmlGreek('chi'),
'<sup>2</sup>')
else
paste0(htmlGreek('chi'),
markupSpecs$html$subsup(x, '2')),
fstat = function(x, ...)
paste0('<i>F</i><sub><span style="font-size: 80%;">',
x[1], htmlSpecial('thinsp'),
x[2], '</span></sub>'),
frac = function(a, b, size=82, ...)
paste0('<span style="font-size: ', size, '%;"><sup>',
a, '</sup>', htmlSpecial('frasl'),
'<sub>', b, '</sub></span>'),
half = function(...) htmlSpecial('half'),
subsup = function(a, b) paste0("<sup><span style='font-size: 70%;'>", b,
"</span></sup><sub style='position: relative; left: -.47em; bottom: -.4em;'><span style='font-size: 70%;'>",
a, "</span></sub>"),
varlabel = function(label, units='', size=75, hfill=FALSE) {
if(units=='') htmlTranslate(label, greek=TRUE)
else
if(hfill) paste0("<div style='float: left; text-align: left;'>",
htmlTranslate(label, greek=TRUE),
"</div><div style='float: right; text-align: right; font-family: Verdana; font-size:", size, "%;'>", htmlTranslate(units, greek=TRUE),
"</div>")
else
paste0(htmlTranslate(label, greek=TRUE), htmlSpecial('emsp'),
"<span style='font-family:Verdana;font-size:", size, "%;'>",
htmlTranslate(units, greek=TRUE), "</span>") },
rightAlign = function(x)
paste0("<div style='float: right; text-align: right;'>",
x, "</div>"),
space = htmlSpecial('nbsp'),
lspace = htmlSpecial('emsp'),
sspace = htmlSpecial('thinsp'),
smallskip= '<br><br>',
medskip = '<br><br><br>',
bigskip = '<br><br><br><br>',
lineskip = function(n) paste0('\n<p style="padding-top:', n, 'em;">'),
br = '<br>',
hrule = '<hr>',
hrulethin= '<hr class="thinhr">',
plminus = htmlSpecial('plusmn'),
times = htmlSpecial('times'),
xbar = '<span style="text-decoration: overline">X</span>',
overbar = function(x) paste0('<span style="text-decoration: overline">',
x, '</span>'),
unicode = '<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />',
styles = function(...) htmltools::HTML('
<style>
.earrows {color:silver;font-size:11px;}
fcap {
font-family: Verdana;
font-size: 12px;
color: MidnightBlue
}
smg {
font-family: Verdana;
font-size: 10px;
color: 󅒐
}
hr.thinhr { margin-top: 0.15em; margin-bottom: 0.15em; }
span.xscript {
position: relative;
}
span.xscript sub {
position: absolute;
left: 0.1em;
bottom: -1ex;
}
</style>
'),
## The following is to create html file so that can copy and paste unicode chars
## To do actual conversions best to use http://www.endmemo.com/unicode/unicodeconverter.php
unicodeshow = function(x, surr=TRUE, append=FALSE) {
if(surr) x <- paste0('&', x, ';')
cat('<meta charset="utf-8">', paste(x, collapse=''), '<br>', file='/tmp/z.html', append=append)
},
## Function to intersperse markdown with knitr chunk output, especially
## for chunks producing plotly graphics. The typical use is to intersperse
## figure captions and table of contents entries produced by putHcap()
## with plotly graphics. md is a list of character vectors, one element
## per chunk, and robj is a list of R objects to print
## Accounts for markdown being in caption text; knitr processes this
## See stackoverflow.com/questions/51803162
mdchunk = function(md=rep('', length(robj)), robj,
cnames=FALSE, w=NULL, h=NULL, caption=NULL,
results=NULL, method=c('knit_expand','knit_child')) {
method <- match.arg(method)
bn <- paste0('c', round(runif(1, 0, 1e6)))
n <- length(md)
if(length(robj) != n) stop('robj and md must have same length')
opts <- rep('echo=FALSE', n)
if(length(results)) opts <- paste0(opts, ',results="', results, '"')
if(length(w)) opts <- paste0(opts, ',fig.width=' , w)
if(length(h)) opts <- paste0(opts, ',fig.height=', h)
if(length(caption)) opts <- paste0(opts, ',fig.cap="', caption, '"')
if(length(cnames) == 1 && is.logical(cnames))
cnames <- if(cnames) paste0(bn, 1 : n) else rep('', n)
if(! all(cnames == '')) cnames <- paste0(cnames, ',')
for(i in 1 : n) {
pos <- 1
env <- as.environment(pos)
if(method == 'knit_expand') .obj. <- robj[[i]]
else assign('.obj.', robj[[i]], envir=env)
k <- c(md[[i]], paste0('```{r ', cnames[i], opts[i], '}'), '.obj.', '```')
## Original solution had cat(trimws(...)) but this caused
## section headings to be run into R output and markdown not recog.
switch(method,
knit_expand = cat(knitr::knit(text=knitr::knit_expand(text=k),
quiet=TRUE)),
knit_child = knitr::knit_child(text=k, quiet=TRUE)
)
}
},
## Function to define css for putting a background around a character string
## to make it look more like a button
## Usage: <p class="cssbutton">Text inside button</p>
cssbutton = function(color='DarkBlue', background='LightBlue', size='115%')
htmltools::HTML('
<style>
.rbutton {
font-family: Times;
font-size:', size, ';
color:', color, ';
background-color:', background, ';
}
</style>'),
## Function to high details using <details>...</details>
## Usage: `r cssbutton()` ... `r hideDetails('button text', ...)` ... </details>
hideDetails = function(txt)
htmltools::HTML('
<details><summary><p class="rbutton">', txt, '</p></summary>'),
totxt = function(txt, full=FALSE) {
if(full) {
if(! requireNamespace('htm2txt', quietly=FALSE))
stop('markupSpecs$html$totxt with full=TRUE requires htm2txt package')
return(htm2txt::htm2txt(txt))
}
rem <- c('<p>', '</p>', '</div>', '</span>', '<p .*?>', '<div .*?>',
'<span .*?>', '<br>', '<br />', '\\n', 'strong>', '</strong>',
'<tbody>', '</tbody>', '<tr>', '</tr>', '<td.*?>', '<font.*?>',
'<u>', '</u>', '<ul>', '</ul>', '<li>', '</li>', '</td>',
'<h[1-9] .*?>', '</h[1-9]>', '<b>', '</b>', '<table>', '</table>',
'<em>', '</em>')
for(a in rem) txt <- gsub(a, '', txt)
txt
}
),
latex = list(
bold = function(...) paste0('\\textbf{', ..., '}'),
italics = function(...) paste0('\\emph{', ..., '}'),
math = function(...) paste0('$', ..., '$'),
ord = function(n) paste0('$', n, '^\\textrm{',
markupSpecs$all$ordsuffix(n),
'}$'),
code = function(...) paste0('\\texttt{\\smaller ', ..., '}'),
sup = function(x, add='$') paste0(add, '^{',x, '}', add),
sub = function(x, add='$') paste0(add, '_{',x, '}', add),
smaller = function(...) paste0('{\\smaller ', ..., '}' ),
larger = function(...) paste0('{\\smaller[-1]{', ..., '}' ),
smaller2 = function(...) paste0('{\\smaller[2]{', ..., '}' ),
larger2 = function(...) paste0('{\\smaller[-2]{', ..., '}' ),
center = function(...) paste0('\\centerline{', ..., '}' ),
color = function(x, col) {
colcmd <- if(col == 'MidnightBlue') '\\textcolor[rgb]{0.1,0.1,0.44}'
else
paste0('\\textcolor{', col, '}')
paste0(colcmd, '{', x, '}')
},
chisq = function(x, add='$') if(missing(x)) paste0(add, '\\chi^{2}', add)
else paste0(add, '\\chi^{2}_{', x, '}', add),
fstat = function(x, add='$')
paste0(add, 'F_{', x[1], ',', x[2], '}', add),
frac = function(a, b, add='$', ...)
paste0(add, '\\frac{', a, '}{', b, '}', add),
half = function(add='$') paste0(add, '\\frac(1}{2}', add),
subsup = function(a, b) paste0('$_{', a, '}^{', b, '}$'),
varlabel = function(label, units='', hfill=FALSE, ...) {
if(units=='') return(label) else units <- latexTranslate(units)
fill <- if(hfill) '~\\hfill' else '~~~'
paste0(label, fill, '\\texttt{\\smaller[2] ',
gsub('\\*', ' ', units), '}')
},
space = '~',
lspace = '~~',
sspace = '\\,',
smallskip= '\\smallskip',
medskip = '\\medskip',
bigskip = '\\bigskip',
lineskip = function(n) paste0('\n\\vspace{', n, 'ex}\n\n'),
br = '\\\\',
hrule = '\\hrule',
plminus = '$\\pm$',
times = '$\\times$',
xbar = '$\\bar{X}$',
overbar = function(x) paste0('$\\overline{', x, '}$')
),
plain = list(
space = ' ',
lspace = ' ',
sspace = ' ',
br = '\n',
lineskip = function(n) paste(rep('\n', n), collapse=''),
hrule = '',
code = function(x) x,
ord = function(n) paste0(n, markupSpecs$all$ordsuffix(n)),
chisq = function(x, ...) if(missing(x)) 'chi-square'
else
paste0('chi-square(', x, ')'),
frac = function(a, b, ...) paste0(a, '/', b),
half = function(...) '1/2',
varlabel = function(label, units='', ...)
if(units == '') label else paste0(label, ' [', units, ']'),
times = 'x',
plminus = '+/-',
color = function(x, ...) x
),
markdown = list(
tof = function(file=.Options$FigCapFile, level=2, number=FALSE) {
if(! length(file) || file == '') stop('figure captions file not defined')
r <- readLines(file)
if(! length(r)) return()
r <- read.csv(file, header=FALSE)
names(r) <- c('label', 'figref', 'scap')
n <- nrow(r)
## Sort in descending order so last takes precendence if dups
r <- r[nrow(r) : 1, ]
isdup <- duplicated(r$label)
r <- r[! isdup, ]
r <- r[nrow(r) : 1, ]
figref <- r[[2]]
scap <- r[[3]]
head <- c('',
'<a name="LOF"></a>',
'',
paste(substring('####', 1, level), 'List of Figures',
if(! number) '{-}'),
'',
'| **Figure** | **Description** |',
'|:---|:---|')
w <- c(head, paste0('| ', figref, ' | ', scap, ' |'))
paste0(w, '\n')
},
# Function to start a verbatim quote if results='asis' in effect
# Works for all output formats in R markdown
squote <- function() { # start quote
r <- knitr::opts_current$get('results')
if(length(r) && r %in% c('asis', 'markup')) cat('\n```')
invisible()
},
# Function to close the quote if needed
equote <- function() { # end quote
r <- knitr::opts_current$get('results')
if(length(r) && r %in% c('asis', 'markup')) cat('```\n\n')
invisible()
},
# Function to print an object or inline text or both,
# verbatim quoting if needed (results='asis') in effect in chunk
# Inline text is printed with cat()
# Fractional numbers are rounded to the nearest dec digits for data frames
pr = function(x='', obj=NULL, inline=NULL, dec=3) {
r <- knitr::opts_current$get('results')
asis <- length(r) && r %in% c('asis', 'markup')
if(asis) cat('\n```\n')
if(any(x != '') || length(inline))
cat('\n', x, if(any(x != '')) ' ', inline, '\n\n', sep='')
if(length(obj)) {
if(is.data.frame(obj))
for(i in 1 : length(obj)) {
x <- obj[[i]]
if(is.numeric(x)) obj[[i]] <- round(x, dec)
}
print(obj, quote=FALSE)
}
if(asis) cat('```\n\n')
invisible()
}
), # end markdown
plotmath = list(
varlabel = function(label, units='', ...)
labelPlotmath(label, units)
),
all=list(
ordsuffix = function(n) {
l <- n - floor(n / 10) * 10
ifelse(n %in% 11:13, 'th',
ifelse(l == 1, 'st',
ifelse(l == 2, 'nd',
ifelse(l == 3, 'rd', 'th'))))
}
)
)
## For expand_collapse see http://dickervasti.com/wiki-style-text-expand-collapse-no-jquery.htm#01000
## Function to translate several expressions to html form.
## Arguments inn and out specify additional input and translated
## strings over the usual defaults.
htmlTranslate <- function(object, inn=NULL, out=NULL,
greek=FALSE, na='', code=htmlSpecialType(), ...)
{
if(! length(object) || all(trimws(object) == ''))
return(object)
text <- ifelse(is.na(object), na, as.character(object))
## Must translate & first so won't be converted to & when other
## symbols are translated
inn <- c("&", "|", "%", "#", "<=", "<", ">=", ">", "_", "\\243",
"\\$", inn, c("[", "(", "]", ")"))
w <- if(code == 'unicode')
substring('\u26\u7C\u25\u23\u2264\u3C\u2265\u3E\u5F\uA3\u24',
1:11, 1:11)
else
c("&", "|", "%", "#", "≤", "<", "≥",
">", "_", "£", "$") # 163 was 164
## htmlarrows.com
## markupSpecs$html$unicodeshow(out, surr=FALSE)
out <- c(w, out, c('[', '(', ']', ')'))
##See if string contains an ^ - superscript followed by a number
dig <- c('0','1','2','3','4','5','6','7','8','9')
for(i in 1 : length(text)) {
lt <- nchar(text[i])
x <- substring(text[i], 1 : lt, 1 : lt)
j <- x == '^'
if(any(j)) {
is <- ((1 : lt)[j])[1] #get first ^
remain <- x[-(1 : is)]
k <- remain %in% c(' ',',',')',']','\\','$')
if(remain[1] %in% dig ||
(length(remain) > 1 && remain[1] == '-' && remain[2] %in% dig))
k[-1] <- k[-1] | remain[-1] %nin% dig
ie <- if(any(k)) is + ((1 : length(remain))[k])[1]
else
length(x) + 1
substring2(text[i], is, ie - 1) <-
paste0('BEGINSUP', substring(text[i], is + 1, ie - 1), 'ENDSUP')
}
text[i] <- sedit(text[i], c(inn, '^', 'BEGINSUP', 'ENDSUP'),
c(out,
htmlSpecial('caret', code=code),
'<sup>', '</sup>'), wild.literal=TRUE)
if(greek) text[i] <- htmlGreek(text[i], code=code, mult=TRUE)
}
text
}
## markupSpecs$html$unicodeshow(c('#9660', 'chi', 'thinsp', 'frasl', 'emsp', 'plusmn', 'times'), append=TRUE)
Try the Hmisc package in your browser
Any scripts or data that you put into this service are public.
Hmisc documentation built on Sept. 12, 2023, 5:06 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions htmlTranslate htmlSpecial htmlGreek htmlVerbatim html.default html.data.frame html.latex html
Documented in html html.data.frame html.default htmlGreek html.latex htmlSpecial htmlTranslate htmlVerbatim
html <- function(object, ...) UseMethod('html')
html.latex <- function(object, file, where=c('cwd', 'tmp'),
method=c('hevea', 'htlatex'), rmarkdown=FALSE,
cleanup=TRUE, ...)
{
where <- match.arg(where)
method <- match.arg(method)
if(where == 'tmp') cleanup <- FALSE
if(rmarkdown && ! missing(file))
warning('do not specify file when rmarkdown=TRUE')
fi <- object$file
fibase <- gsub('\\.tex', '', fi)
if(missing(file)) file <- paste(fibase, 'html', sep='.')
if(rmarkdown) file <- character(0)
toConsole <- ! length(file) || file == ''
ehtml = function(content) { # Thanks to Yihui
if(! requireNamespace('htmltools', quietly=TRUE))
stop('htmltools package not installed')
content = htmltools::HTML(gsub('^.*?<body\\s*>|</body>.*$', '', content))
ss <- paste(fibase, '-enclosed.css', sep='')
src <- switch(where, cwd=getwd(), tmp=tempdir())
d = htmltools::htmlDependency(
'TeX4ht', '1.0.0', src = src, stylesheet = ss)
htmltools::attachDependencies(content, d)
}
sty <- object$style
if(length(sty))
sty <- paste('\\usepackage{', unique(sty), '}', sep='')
tmp <- switch(where,
cwd = paste(fibase, 'enclosed', sep='-'),
tmp = tempfile())
tmptex <- paste(tmp, 'tex', sep='.')
infi <- readLines(fi)
cat('\\documentclass{report}', sty,
if(method == 'hevea') '\\def\\tabularnewline{\\\\}',
'\\begin{document}', infi,
'\\end{document}\n', file=tmptex, sep='\n')
sc <- if(.Platform$OS.type == 'unix') ';' else '&'
## Create system call to convert enclosed latex file to html.
cmd <-
if(missing(file) || ! length(file) || file == '')
paste(optionsCmds(method), shQuote(tmptex))
else
paste(optionsCmds(method), '-o', file, shQuote(tmptex))
## perform system call
sys(cmd)
if(method == 'hevea' && ! toConsole) {
## Remove 2 bottom lines added by HeVeA
infi <- readLines(file)
i <- grep('<hr style="height:2"><blockquote class="quote"><em>This document was translated from L<sup>A</sup>T<sub>E</sub>X by', infi)
i <- c(i, grep('</em><a href="http://hevea.inria.fr/index.html"><em>H</em><em><span style="font-size:small"><sup>E</sup></span></em><em>V</em><em><span style="font-size:small"><sup>E</sup></span></em><em>A</em></a><em>.</em></blockquote></body>', infi))
if(length(i)) {
infi <- infi[- i]
writeLines(infi, file)
}
if(cleanup) {
bf <- gsub('\\.html', '', file)
unlink(c(paste(bf, 'haux', sep='.'),
paste(bf, 'enclosed.tex', sep='-')))
}
return(structure(list(file=file), class='html'))
}
if(cleanup && method == 'htlatex')
unlink(paste(tmp, c('tex', 'tmp','idv','lg','4tc','aux','dvi','log',
'xref','4ct'), sep='.'))
if(rmarkdown || toConsole) {
w <- readLines(paste(tmp, 'html', sep='.'))
if(rmarkdown) return(ehtml(w))
if(! length(file)) return(paste(w, collapse='\n'))
cat(w, sep='\n')
return(invisible())
}
structure(list(file=file), class='html')
}
html.data.frame <-
function(object,
file=paste(first.word(deparse(substitute(object))),
'html',sep='.'),
header, caption=NULL, rownames=FALSE,
align='r', align.header='c', bold.header=TRUE,
col.header='Black', border=2,
width=NULL, size=100, translate=FALSE,
append=FALSE, link=NULL, linkCol=1,
linkType=c('href','name'), disableq=FALSE, ...)
{
linkType <- match.arg(linkType)
mu <- markupSpecs$html
tr <- c(c='center', l='left', r='right')
align <- tr[align]
align.header <- tr[align.header]
trans <- if(translate) htmlTranslate else function(x) x
disableq <- if(disableq) ' data-quarto-disable-processing="true"' else ''
x <- as.matrix(object)
# for(i in 1:ncol(x)) {
# xi <- x[,i]
# if(is.numeric(object[,i]))
# x[,i] <- paste0('<div align=right>', xi, '</div>')
# }
if(rownames && length(r <- rownames(x)))
x <- cbind(Name=as.character(r), x)
b <- c('border: 1px solid gray;', 'border-collapse: collapse;')
## Give style a name hmisctablexxx where xxx is a random 6-digit integer
## because if you reuse the same style in the same document, style
## elements will affect tables that preceeded this one
sn <- paste0('hmisctable', floor(runif(1, 100000, 999999)))
psn <- paste0('.', sn)
## Duplicate specifications because can't get any single one to work
lua <- length(unique(align))
sty <- c('<style>',
paste0(psn, ' {'),
if(border == 0) 'border: none;' else b,
paste0('font-size: ', size, '%;'),
'}',
paste0(psn, ' td {'),
if(lua == 1) paste0('text-align: ', align, ';'),
'padding: 0 1ex 0 1ex;', ## top left bottom right
'}',
paste0(psn, ' th {'),
paste0('color: ', col.header, ';'),
paste0('text-align: ', align.header, ';'),
'padding: 0 1ex 0 1ex;',
if(bold.header) 'font-weight: bold;' else 'font-weight: normal;',
'}',
'</style>')
R <- c(sty, paste0('<table', disableq, ' class="', sn, '"',
if(length(width) == 1)
paste0(' width="', width, '"'),
if(border == 1) ' border="0"',
if(border == 2) ' border="1"', '>'))
if(length(caption))
R <- c(R, paste0('<caption>', mu$lcap(caption), '</caption>'))
if(missing(header)) header <- colnames(x)
if(length(header)) {
head <- trans(header)
head <- paste0('<th>', head, '</th>')
head <- paste0('<tr>', paste(head, collapse=''), '</tr>')
R <- c(R, head)
}
if(length(link)) {
if(is.matrix(link))
for(j in 1 : ncol(x))
x[, j] <- ifelse(link[, j] == '', x[, j],
paste0('<a ', linkType, '="', link[, j], '">',
trans(x[, j]), '</a>'))
# x[link != ''] <- paste('<a ',linkType,'="', link[link!=''],'">',
# trans(x[link != '']), '</a>', sep='')
else
x[,linkCol] <- ifelse(link == '', trans(x[, linkCol]),
paste0('<a ',linkType, '="', link, '">',
trans(x[, linkCol]), '</a>'))
}
for(i in 1 : nrow(x)) {
rowt <- if(lua == 1) paste0('<td>', x[i, ], '</td>')
else
paste0('<td style="text-align:', align, ';">',
x[i, ], '</td>')
R <- c(R, paste0('<tr>', paste(rowt, collapse=''), '</tr>'))
}
R <- c(R, '</table>')
if(is.logical(file) && ! file)
return(htmltools::HTML(paste0(R, '\n')))
cat(R, file=file, append=append && file != '', sep='\n')
structure(list(file=file), class='html')
}
html.default <- function(object,
file=paste(first.word(deparse(substitute(object))),
'html', sep='.'),
append=FALSE,
link=NULL, linkCol=1, linkType=c('href','name'),
...)
html.data.frame(object, file=file, append=append, link=link,
linkCol=linkCol, linkType=linkType, ...)
if(FALSE) {
show.html <- function(object)
{
browser <- .Options$help.browser
if(!length(browser))
browser <- .Options$browser
if(!length(browser))
browser <- 'netscape'
sys(paste(browser, object, if(.Platform$OS.type == 'unix') '&'))
invisible()
}
print.html <- function(x, ...) show.html(x)
}
htmlVerbatim <- function(..., size = 75, width = 85,
scroll=FALSE, rows=10, cols=100,
propts=NULL, omit1b=FALSE) {
if(scroll) {
nam <- as.character(sys.call()[2])
w <- paste0('<textarea class="scrollabletextbox" rows=', rows,
' cols=', cols, ' style="font-size:', size,
'%; font-family:Courier New;" name="', nam, '">')
}
else w <- paste0('<pre style="font-size:', size, '%;">')
op <- options(width=width)
propts <- c(propts, list(quote=FALSE))
for(x in list(...)) {
z <- capture.output(do.call('print', c(list(x), propts)))
if(omit1b && trimws(z[1]) == '') z <- z[-1]
if(omit1b) z[length(z)] <- sub('\n$', '', z[length(z)])
w <- c(w, z)
}
options(op)
## Remove trailing \n which is not needed since </pre> will follow
lw <- length(w)
if(lw > 1) w[-lw] <- paste0(w[-lw], '\n')
w <- c(w, if(scroll) '</textarea>\n' else '</pre>\n')
htmltools::HTML(w)
}
htmlGreek <- function(x, mult=FALSE, code=htmlSpecialType()) {
orig <- c('alpha','beta','gamma','delta','epsilon','varepsilon',
'zeta', 'eta',
'theta','vartheta','iota','kappa','lambda','mu','nu',
'xi','pi','varpi','rho','varrho','sigma','varsigma','tau',
'upsilon','phi','chi','psi','omega','Gamma','Delta',
'Theta','Lambda','Xi','Pi','Sigma','Upsilon','Phi','Psi','Omega')
l <- length(orig)
new <- if(code == 'unicode')
substring('\u3B1\u3B2\u3B3\u3B4\u3B5\u3F5\u3B6\u3B7\u3B8\u3D1\u3B9\u3BA\u3BB\u3BC\u3BD\u3BE\u3C0\u3D6\u3C1\u3F1\u3C3\u3C2\u3C4\u3C5\u3C6\u3C7\u3C8\u3C9\u393\u394\u398\u39B\u39E\u3A0\u3A3\u3A5\u3A6\u3A8\u3A9',
1 : l, 1 : l)
else
paste0('&#',
c(945,946,947,948,949,1013,950,951,952,977,953,954,955,956,957,958,
960,982,961,1009,963,962,964,965,966,967,968,969,915,916,920,923,
926,928,931,933,934,936,937),
';')
names(new) <- orig
if(mult) {
for(j in 1 : l) x <- gsub(paste0('\\<', orig[j], '\\>'), new[j], x)
return(x)
}
if(! all(x %in% orig)) stop(paste0('illegal Greek letter name:', x))
new[x]
}
htmlSpecial <- function(x, code=htmlSpecialType()) {
z <- c(nbsp = '160\u00A0',
thinsp = '8201\u2009',
emsp = '8195\u2003',
ensp = '8194\u2002',
plusmn = '177\u00B1',
times = '215\u00D7',
caret = '94\u005E',
frasl = '8260\u2044',
half = '189\u00BD',
angrt = '8735\u221F',
squarecrosshatch = '9638\u2586',
whitesquareverticalline = '9707\u25EB',
blackdowntriangle = '9660\u25BC',
mediumsmallwhitecircle = '9900\u26AC',
combiningcircumflexaccent = '770\u005E',
part = '8706\u2202')
u <- substring(z, nchar(z), nchar(z))
n <- substring(z, 1, nchar(z) - 1)
new <- if(code == 'unicode') u else paste0('&#', n, ';')
names(new) <- names(z)
if(! all(x %in% names(z))) stop(paste0('illegal character name:',
x[x %nin% names(z)]))
new[x]
}
markupSpecs <- list(html=list(
## <span> needed for text in plotly graphics
bold = function(..., span=TRUE)
if(span) paste0('<span style="font-weight:bold">', ..., '</span>')
else paste0('<strong>', ..., '</strong>'),
italics = function(...) paste0('<i>', ..., '</i>'),
math = function(...) paste0('<i>', ..., '</i>'),
ord = function(n) paste0(n, '<sup>', markupSpecs$all$ordsuffix(n),
'</sup>'),
code = function(...) paste0('<code style="font-size:0.8em">', ..., '</code>'),
sup = function(x, ...) paste0('<sup>', x, '</sup>'),
sub = function(x, ...) paste0('<sub>', x, '</sub>'),
size = function(..., pct) paste0('<span style="font-size: ', pct,
'%;">', paste(..., collapse=' '),
'</span>'),
smaller = function(...) paste0('<span style="font-size: 80%;">', ...,
'</span>'),
larger = function(...) paste0('<span style="font-size: 125%;">', ...,
'</span>'),
smaller2 = function(...) paste0('<span style="font-size: 64%;">', ...,
'</span>'),
larger2 = function(...) paste0('<span style="font-size: 156%;">', ...,
'</span>'),
center = function(...) paste0('<div align=center>', ..., '</div>'),
color = function(..., col) paste0('<font color="', col, '">', ...,
'</font>'),
## Break a long string into two lines with <br> inserted at a space
## between words that is close to the middle of the string
## Cole Beck 2018-10-18
addBreak = function(x, minbreak=30) {
sl <- nchar(x)
if(sl < minbreak) return(x)
si <- c(gregexpr(' ', x)[[1]])
ix <- si[which.min(abs(si - sl/2))]
p1 <- substr(x, 1, ix - 1)
p2 <- substr(x, ix + 1, sl)
paste0(p1, "<br>", p2)
},
subtext = function(..., color='blue')
paste0('<br><font size=1 color="', color, '">',
paste(unlist(list(...)), collapse=' '),
'</font>'),
cap = function(..., symbol=htmlSpecial('angrt')) { # figure caption formatting
## alternative: symbol='Figure:'; default is right angle
## use symbol=htmlSpecial('squarecrosshatch') for grid graph paper symbol
lcap <- htmlTranslate(paste(unlist(list(...)), collapse=' '), greek=TRUE)
paste0('<span style="font-family:Verdana;font-size:10px;">', symbol,
' </span><span style="font-family:Verdana;font-size:12px;color:MidnightBlue;">',
lcap, '</span>')
},
lcap = function(...) # for continuation of figure caption
paste0('<span style="font-family:Verdana;font-size:12px;color:MidnightBlue;">',
htmlTranslate(paste(unlist(list(...)), collapse=' '), greek=TRUE),
'</span>'),
tcap = function(..., symbol=htmlSpecial('whitesquareverticalline')) { # table caption formatting
# alt: symbol='Table:'; default is white square w/vertical bisecting line
lcap <- htmlTranslate(paste(unlist(list(...)), collapse=' '), greek=TRUE)
paste0('<span style="font-family:Verdana;font-size:10px;">', symbol,
' </span><span style="font-family:Verdana;font-size:12px;color:MidnightBlue;">',
lcap, '</span>')
},
ltcap = function(...) # for continuation of table caption
paste0('<span style="font-family:Verdana;font-size:12px;color:MidnightBlue;">',
htmlTranslate(paste(unlist(list(...)), collapse=' '), greek=TRUE),
'</span>'),
expcoll = function(vis, invis) {
id <- floor(runif(1, 100000, 999999)) # unique html id
paste0('<br><a href="#', id, '" id="', id,
'_earrows" class="earrows" onclick="expand_collapse(\'',
id, '\');">', htmlSpecial('blackdowntriangle'), '</a>',
vis, '<span id="', id,
'" style="display:none;">',
invis, '</span>')
},
expcolld = function(vis, invis)
paste0('<details><summary>', vis, ## htmlSpecial('blackdowntriangle'),
'</summary>', invis, '</details>'),
uncover = function(before, options, envir) {
## https://stackoverflow.com/questions/44866287
## usage: knitrSet(lang='markdown') # issues knit_hooks$set(uncover=uncover)
## <script>
## function uncover(id) {
## var x = document.getElementById(id);
## x.style.display = 'block';
## }
## </script>
##
## ```{r, uncover=TRUE, label='text for button', id='script'}
## 1 + 1
## ```
if (before) {
id <- options$id
label <- options$label
if(! length(label)) label <- 'Uncover'
button_string <- paste0("<button onclick=\"uncover('",
id, "')\">", label, "</button>")
div_string <- paste0("<div id = '", id,
"', style = 'display:none'>")
paste0(button_string, "\n", div_string)
}
else {
"</div>"
}
},
session = function(cite=TRUE, loadedOnly=FALSE, style=NULL) {
si <- sessionInfo()
if(! loadedOnly) si$loadedOnly <- NULL
# Need to default to html because non-RStudio knitting to .md
# will not know ultimate output format
if(! length(style))
style <- if(knitr::is_html_output() ) 'html' else
if(knitr::is_latex_output()) 'latex' else 'html'
tt <- function(x) switch(style,
text = x,
html = paste0('<tt>', x, '</tt>'),
latex = paste0('\\texttt{', x, '}'))
w <- c(if(style == 'html') '<pre>',
if(style == 'latex') toLatex(si, locale=FALSE) else
capture.output(print(si, locale=FALSE)),
if(style == 'html') '</pre>',
if(cite) 'To cite R in publications use:',
if(cite) capture.output(print(citation(), style=style)))
if(cite) {
s <- search()
for(pac in c('Hmisc', 'rms', 'rmsb', 'hreport', 'VGAM',
'data.table', 'ggplot2', 'rstan', 'survival')) {
if(paste0('package:', pac) %in% s) {
w <- c(w, paste0('\nTo cite the ', tt(pac),
' package in publications use:\n'))
w <- c(w, capture.output(print(citation(pac)[1], style=style)))
}
}
}
w <- paste0(w, '\n')
if(style == 'html') htmltools::HTML(w) else knitr::asis_output(w)
},
installcsl = function(cslname, rec=FALSE) {
if(rec) {
cat('Shows URLs:', 'american-medical-association',
'',
'Does not show URLs:', 'council-of-science-editors',
'american-medical-association-no-url', sep='\n')
return(invisible())
}
if(missing(cslname))
browseURL('https://www.zotero.org/styles')
else
download.file(paste0('https://raw.githubusercontent.com/citation-style-language/styles/master/',
cslname, '.csl'), paste0(cslname, '.csl'))
},
citeulikeShow = function(user, bibkeys=NULL, tags=NULL, file=NULL) {
if(length(file)) {
x <- readLines(file)
## See http://stackoverflow.com/questions/8613237
bibkeys <- unlist(regmatches(x, gregexpr("(?<=\\[@).*?(?=\\])",
x, perl=TRUE)))
}
if(length(bibkeys)) {
keys <- paste(paste0('bibkey%3A+', bibkeys), collapse='+OR+')
browseURL(paste0('http://www.citeulike.org/search/username?q=',
keys, '&search=Search+library&username=', user))
} else browseURL(paste0('http://www.citeulike.org/user/',
user, '/tag/', tags))
invisible(bibkeys)
},
widescreen = function(width='4000px')
htmltools::HTML(paste0('<style>div.main-container {max-width:',
width, ';}</style>')),
tocsize = function(width = '20%', maxwidth = '260px', maxheight='85%')
htmltools::HTML(paste0('<style>div.tocify {width: ', width,
'; max-width: ', maxwidth, '; max-height: ',
maxheight, ';}</style>')),
sectionNumberDepth = function() {
## Set depth for numbering sections the same as TOC depth
## See https://stackoverflow.com/questions/47124299/
toc_depth <- rmarkdown::metadata$output$html_document$toc_depth
sel <- paste0("h", (toc_depth + 1) : 10, collapse = " > span, ")
paste0("<style>", sel, " > .header-section-number { display: none; } </style>")
},
scroll = function(x, size=75, rows=10, cols=100,
font='', name='') {
w <- paste0('<div style="width: ', cols, 'ex; overflow: auto; height: ',
rows, 'ex;">')
c(w, x, '</div>')
},
chisq = function(x, ...)
# paste0('\u03C7&<span class="xscript" style="font-size: 75%;"><sup>2</sup><sub>', x,
# '</sub></span>')
if(missing(x)) paste0(htmlGreek('chi'),
'<sup>2</sup>')
else
paste0(htmlGreek('chi'),
markupSpecs$html$subsup(x, '2')),
fstat = function(x, ...)
paste0('<i>F</i><sub><span style="font-size: 80%;">',
x[1], htmlSpecial('thinsp'),
x[2], '</span></sub>'),
frac = function(a, b, size=82, ...)
paste0('<span style="font-size: ', size, '%;"><sup>',
a, '</sup>', htmlSpecial('frasl'),
'<sub>', b, '</sub></span>'),
half = function(...) htmlSpecial('half'),
subsup = function(a, b) paste0("<sup><span style='font-size: 70%;'>", b,
"</span></sup><sub style='position: relative; left: -.47em; bottom: -.4em;'><span style='font-size: 70%;'>",
a, "</span></sub>"),
varlabel = function(label, units='', size=75, hfill=FALSE) {
if(units=='') htmlTranslate(label, greek=TRUE)
else
if(hfill) paste0("<div style='float: left; text-align: left;'>",
htmlTranslate(label, greek=TRUE),
"</div><div style='float: right; text-align: right; font-family: Verdana; font-size:", size, "%;'>", htmlTranslate(units, greek=TRUE),
"</div>")
else
paste0(htmlTranslate(label, greek=TRUE), htmlSpecial('emsp'),
"<span style='font-family:Verdana;font-size:", size, "%;'>",
htmlTranslate(units, greek=TRUE), "</span>") },
rightAlign = function(x)
paste0("<div style='float: right; text-align: right;'>",
x, "</div>"),
space = htmlSpecial('nbsp'),
lspace = htmlSpecial('emsp'),
sspace = htmlSpecial('thinsp'),
smallskip= '<br><br>',
medskip = '<br><br><br>',
bigskip = '<br><br><br><br>',
lineskip = function(n) paste0('\n<p style="padding-top:', n, 'em;">'),
br = '<br>',
hrule = '<hr>',
hrulethin= '<hr class="thinhr">',
plminus = htmlSpecial('plusmn'),
times = htmlSpecial('times'),
xbar = '<span style="text-decoration: overline">X</span>',
overbar = function(x) paste0('<span style="text-decoration: overline">',
x, '</span>'),
unicode = '<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />',
styles = function(...) htmltools::HTML('
<style>
.earrows {color:silver;font-size:11px;}
fcap {
font-family: Verdana;
font-size: 12px;
color: MidnightBlue
}
smg {
font-family: Verdana;
font-size: 10px;
color: 󅒐
}
hr.thinhr { margin-top: 0.15em; margin-bottom: 0.15em; }
span.xscript {
position: relative;
}
span.xscript sub {
position: absolute;
left: 0.1em;
bottom: -1ex;
}
</style>
'),
## The following is to create html file so that can copy and paste unicode chars
## To do actual conversions best to use http://www.endmemo.com/unicode/unicodeconverter.php
unicodeshow = function(x, surr=TRUE, append=FALSE) {
if(surr) x <- paste0('&', x, ';')
cat('<meta charset="utf-8">', paste(x, collapse=''), '<br>', file='/tmp/z.html', append=append)
},
## Function to intersperse markdown with knitr chunk output, especially
## for chunks producing plotly graphics. The typical use is to intersperse
## figure captions and table of contents entries produced by putHcap()
## with plotly graphics. md is a list of character vectors, one element
## per chunk, and robj is a list of R objects to print
## Accounts for markdown being in caption text; knitr processes this
## See stackoverflow.com/questions/51803162
mdchunk = function(md=rep('', length(robj)), robj,
cnames=FALSE, w=NULL, h=NULL, caption=NULL,
results=NULL, method=c('knit_expand','knit_child')) {
method <- match.arg(method)
bn <- paste0('c', round(runif(1, 0, 1e6)))
n <- length(md)
if(length(robj) != n) stop('robj and md must have same length')
opts <- rep('echo=FALSE', n)
if(length(results)) opts <- paste0(opts, ',results="', results, '"')
if(length(w)) opts <- paste0(opts, ',fig.width=' , w)
if(length(h)) opts <- paste0(opts, ',fig.height=', h)
if(length(caption)) opts <- paste0(opts, ',fig.cap="', caption, '"')
if(length(cnames) == 1 && is.logical(cnames))
cnames <- if(cnames) paste0(bn, 1 : n) else rep('', n)
if(! all(cnames == '')) cnames <- paste0(cnames, ',')
for(i in 1 : n) {
pos <- 1
env <- as.environment(pos)
if(method == 'knit_expand') .obj. <- robj[[i]]
else assign('.obj.', robj[[i]], envir=env)
k <- c(md[[i]], paste0('```{r ', cnames[i], opts[i], '}'), '.obj.', '```')
## Original solution had cat(trimws(...)) but this caused
## section headings to be run into R output and markdown not recog.
switch(method,
knit_expand = cat(knitr::knit(text=knitr::knit_expand(text=k),
quiet=TRUE)),
knit_child = knitr::knit_child(text=k, quiet=TRUE)
)
}
},
## Function to define css for putting a background around a character string
## to make it look more like a button
## Usage: <p class="cssbutton">Text inside button</p>
cssbutton = function(color='DarkBlue', background='LightBlue', size='115%')
htmltools::HTML('
<style>
.rbutton {
font-family: Times;
font-size:', size, ';
color:', color, ';
background-color:', background, ';
}
</style>'),
## Function to high details using <details>...</details>
## Usage: `r cssbutton()` ... `r hideDetails('button text', ...)` ... </details>
hideDetails = function(txt)
htmltools::HTML('
<details><summary><p class="rbutton">', txt, '</p></summary>'),
totxt = function(txt, full=FALSE) {
if(full) {
if(! requireNamespace('htm2txt', quietly=FALSE))
stop('markupSpecs$html$totxt with full=TRUE requires htm2txt package')
return(htm2txt::htm2txt(txt))
}
rem <- c('<p>', '</p>', '</div>', '</span>', '<p .*?>', '<div .*?>',
'<span .*?>', '<br>', '<br />', '\\n', 'strong>', '</strong>',
'<tbody>', '</tbody>', '<tr>', '</tr>', '<td.*?>', '<font.*?>',
'<u>', '</u>', '<ul>', '</ul>', '<li>', '</li>', '</td>',
'<h[1-9] .*?>', '</h[1-9]>', '<b>', '</b>', '<table>', '</table>',
'<em>', '</em>')
for(a in rem) txt <- gsub(a, '', txt)
txt
}
),
latex = list(
bold = function(...) paste0('\\textbf{', ..., '}'),
italics = function(...) paste0('\\emph{', ..., '}'),
math = function(...) paste0('$', ..., '$'),
ord = function(n) paste0('$', n, '^\\textrm{',
markupSpecs$all$ordsuffix(n),
'}$'),
code = function(...) paste0('\\texttt{\\smaller ', ..., '}'),
sup = function(x, add='$') paste0(add, '^{',x, '}', add),
sub = function(x, add='$') paste0(add, '_{',x, '}', add),
smaller = function(...) paste0('{\\smaller ', ..., '}' ),
larger = function(...) paste0('{\\smaller[-1]{', ..., '}' ),
smaller2 = function(...) paste0('{\\smaller[2]{', ..., '}' ),
larger2 = function(...) paste0('{\\smaller[-2]{', ..., '}' ),
center = function(...) paste0('\\centerline{', ..., '}' ),
color = function(x, col) {
colcmd <- if(col == 'MidnightBlue') '\\textcolor[rgb]{0.1,0.1,0.44}'
else
paste0('\\textcolor{', col, '}')
paste0(colcmd, '{', x, '}')
},
chisq = function(x, add='$') if(missing(x)) paste0(add, '\\chi^{2}', add)
else paste0(add, '\\chi^{2}_{', x, '}', add),
fstat = function(x, add='$')
paste0(add, 'F_{', x[1], ',', x[2], '}', add),
frac = function(a, b, add='$', ...)
paste0(add, '\\frac{', a, '}{', b, '}', add),
half = function(add='$') paste0(add, '\\frac(1}{2}', add),
subsup = function(a, b) paste0('$_{', a, '}^{', b, '}$'),
varlabel = function(label, units='', hfill=FALSE, ...) {
if(units=='') return(label) else units <- latexTranslate(units)
fill <- if(hfill) '~\\hfill' else '~~~'
paste0(label, fill, '\\texttt{\\smaller[2] ',
gsub('\\*', ' ', units), '}')
},
space = '~',
lspace = '~~',
sspace = '\\,',
smallskip= '\\smallskip',
medskip = '\\medskip',
bigskip = '\\bigskip',
lineskip = function(n) paste0('\n\\vspace{', n, 'ex}\n\n'),
br = '\\\\',
hrule = '\\hrule',
plminus = '$\\pm$',
times = '$\\times$',
xbar = '$\\bar{X}$',
overbar = function(x) paste0('$\\overline{', x, '}$')
),
plain = list(
space = ' ',
lspace = ' ',
sspace = ' ',
br = '\n',
lineskip = function(n) paste(rep('\n', n), collapse=''),
hrule = '',
code = function(x) x,
ord = function(n) paste0(n, markupSpecs$all$ordsuffix(n)),
chisq = function(x, ...) if(missing(x)) 'chi-square'
else
paste0('chi-square(', x, ')'),
frac = function(a, b, ...) paste0(a, '/', b),
half = function(...) '1/2',
varlabel = function(label, units='', ...)
if(units == '') label else paste0(label, ' [', units, ']'),
times = 'x',
plminus = '+/-',
color = function(x, ...) x
),
markdown = list(
tof = function(file=.Options$FigCapFile, level=2, number=FALSE) {
if(! length(file) || file == '') stop('figure captions file not defined')
r <- readLines(file)
if(! length(r)) return()
r <- read.csv(file, header=FALSE)
names(r) <- c('label', 'figref', 'scap')
n <- nrow(r)
## Sort in descending order so last takes precendence if dups
r <- r[nrow(r) : 1, ]
isdup <- duplicated(r$label)
r <- r[! isdup, ]
r <- r[nrow(r) : 1, ]
figref <- r[[2]]
scap <- r[[3]]
head <- c('',
'<a name="LOF"></a>',
'',
paste(substring('####', 1, level), 'List of Figures',
if(! number) '{-}'),
'',
'| **Figure** | **Description** |',
'|:---|:---|')
w <- c(head, paste0('| ', figref, ' | ', scap, ' |'))
paste0(w, '\n')
},
# Function to start a verbatim quote if results='asis' in effect
# Works for all output formats in R markdown
squote <- function() { # start quote
r <- knitr::opts_current$get('results')
if(length(r) && r %in% c('asis', 'markup')) cat('\n```')
invisible()
},
# Function to close the quote if needed
equote <- function() { # end quote
r <- knitr::opts_current$get('results')
if(length(r) && r %in% c('asis', 'markup')) cat('```\n\n')
invisible()
},
# Function to print an object or inline text or both,
# verbatim quoting if needed (results='asis') in effect in chunk
# Inline text is printed with cat()
# Fractional numbers are rounded to the nearest dec digits for data frames
pr = function(x='', obj=NULL, inline=NULL, dec=3) {
r <- knitr::opts_current$get('results')
asis <- length(r) && r %in% c('asis', 'markup')
if(asis) cat('\n```\n')
if(any(x != '') || length(inline))
cat('\n', x, if(any(x != '')) ' ', inline, '\n\n', sep='')
if(length(obj)) {
if(is.data.frame(obj))
for(i in 1 : length(obj)) {
x <- obj[[i]]
if(is.numeric(x)) obj[[i]] <- round(x, dec)
}
print(obj, quote=FALSE)
}
if(asis) cat('```\n\n')
invisible()
}
), # end markdown
plotmath = list(
varlabel = function(label, units='', ...)
labelPlotmath(label, units)
),
all=list(
ordsuffix = function(n) {
l <- n - floor(n / 10) * 10
ifelse(n %in% 11:13, 'th',
ifelse(l == 1, 'st',
ifelse(l == 2, 'nd',
ifelse(l == 3, 'rd', 'th'))))
}
)
)
## For expand_collapse see http://dickervasti.com/wiki-style-text-expand-collapse-no-jquery.htm#01000
## Function to translate several expressions to html form.
## Arguments inn and out specify additional input and translated
## strings over the usual defaults.
htmlTranslate <- function(object, inn=NULL, out=NULL,
greek=FALSE, na='', code=htmlSpecialType(), ...)
{
if(! length(object) || all(trimws(object) == ''))
return(object)
text <- ifelse(is.na(object), na, as.character(object))
## Must translate & first so won't be converted to & when other
## symbols are translated
inn <- c("&", "|", "%", "#", "<=", "<", ">=", ">", "_", "\\243",
"\\$", inn, c("[", "(", "]", ")"))
w <- if(code == 'unicode')
substring('\u26\u7C\u25\u23\u2264\u3C\u2265\u3E\u5F\uA3\u24',
1:11, 1:11)
else
c("&", "|", "%", "#", "≤", "<", "≥",
">", "_", "£", "$") # 163 was 164
## htmlarrows.com
## markupSpecs$html$unicodeshow(out, surr=FALSE)
out <- c(w, out, c('[', '(', ']', ')'))
##See if string contains an ^ - superscript followed by a number
dig <- c('0','1','2','3','4','5','6','7','8','9')
for(i in 1 : length(text)) {
lt <- nchar(text[i])
x <- substring(text[i], 1 : lt, 1 : lt)
j <- x == '^'
if(any(j)) {
is <- ((1 : lt)[j])[1] #get first ^
remain <- x[-(1 : is)]
k <- remain %in% c(' ',',',')',']','\\','$')
if(remain[1] %in% dig ||
(length(remain) > 1 && remain[1] == '-' && remain[2] %in% dig))
k[-1] <- k[-1] | remain[-1] %nin% dig
ie <- if(any(k)) is + ((1 : length(remain))[k])[1]
else
length(x) + 1
substring2(text[i], is, ie - 1) <-
paste0('BEGINSUP', substring(text[i], is + 1, ie - 1), 'ENDSUP')
}
text[i] <- sedit(text[i], c(inn, '^', 'BEGINSUP', 'ENDSUP'),
c(out,
htmlSpecial('caret', code=code),
'<sup>', '</sup>'), wild.literal=TRUE)
if(greek) text[i] <- htmlGreek(text[i], code=code, mult=TRUE)
}
text
}
## markupSpecs$html$unicodeshow(c('#9660', 'chi', 'thinsp', 'frasl', 'emsp', 'plusmn', 'times'), append=TRUE)
Try the Hmisc package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.