'widgetize' <- function(obj,...) {
# if (!requireNamespace("widgetframe",quietly=.isPackageInUse()))
# return(browse(obj))
# widgetframe::frameWidget(obj)
if (is.null(obj))
return(invisible(obj))
if (!.isKnitr()) {
if (is.character(obj)) {
return(cat(obj,sep="\n"))
}
# cat("not knit","a\n")
return(browse(obj,...))
}
# if (.isRemark())
# return(browse(obj,...))
if (inherits(obj,c("datatables")))
return(browse(obj,...))
if (inherits(obj,c("htmlwidget"))) {
# cat("htmlwidget 1","\n")
# cat("knitr:",c(knitr="knitr" %in% loadedNamespaces()),"\n")
# cat("asis:",knitr::opts_current$get("results")=="asis","\n")
# cat("class:",class(obj),"\n")
if ("knitr" %in% loadedNamespaces()) {
if (!isTRUE(knitr::opts_chunk$get("customized_rendering")))
return(obj)
if (isTRUE(knitr::opts_current$get("results")=="asis")) {
# cat("asis 2","\n")
return(browse(obj,...))
}
}
}
if (!inherits(obj,c("htmlwidget","knitr_kable"))) {
# cat("htmlwidget 3","\n")
return(browse(obj,...))
}
# cat("obj 4","\n")
obj
}
'browse' <- '.open' <- function(...) {
arglist <- list(...)
if (length(ind <- grep("^ref$",ignore.case=FALSE,names(arglist)))) {
ind2 <- tail(ind,1)
reflab <- arglist[[ind2]]
arglist[ind2] <- NULL
}
else
reflab <- NULL
if (length(ind <- grep("^dpi$",ignore.case=FALSE,names(arglist)))) {
ind2 <- tail(ind,1)
dpi <- arglist[[ind2]]
arglist[ind2] <- NULL
}
else
dpi <- NULL
if (length(ind <- grep("^height$",ignore.case=FALSE,names(arglist)))) {
ind2 <- tail(ind,1)
height <- arglist[[ind2]]
arglist[ind2] <- NULL
}
else
height <- NULL
if (length(ind <- grep("^width$",ignore.case=FALSE,names(arglist)))) {
ind2 <- tail(ind,1)
width <- arglist[[ind2]]
arglist[ind2] <- NULL
}
else
width <- NULL
if (length(ind <- grep("^output$",ignore.case=FALSE,names(arglist)))) {
ind2 <- tail(ind,1)
output <- arglist[[ind2]]
arglist[ind2] <- NULL
}
else
output <- NULL
if (length(ind <- grep("^link$",ignore.case=FALSE,names(arglist)))) {
ind2 <- tail(ind,1)
link <- arglist[[ind2]]
arglist[ind2] <- NULL
}
else
link <- FALSE
if (length(ind <- .grep("verb(ose)*",names(arglist)))) {
ind2 <- tail(ind,1)
verbose <- arglist[[ind2]]
arglist[ind2] <- NULL
}
else
verbose <- FALSE # !.isPackageInUse()
if (length(ind <- .grep("(fig\\.cap|caption)",names(arglist)))) {
ind2 <- tail(ind,1)
cap <- arglist[[ind2]]
arglist[ind2] <- NULL
}
else
cap <- NULL
cl <- lapply(arglist,class)
aname <- NULL
if ((length(cl)==1)&&(cl=="list")) {
aname <- names(arglist)
arglist <- arglist[[1]]
cl <- lapply(arglist,class)
# if (verbose)
# str(cl)
}
oname <- names(arglist)
if (sum(nchar(oname))==0) {
if ((!is.null(aname))&&(length(aname)==1)) {
oname <- rep("",length(arglist))
oname[length(oname)] <- aname
}
else
oname <- NULL
}
if ((is.null(oname))&&(!is.null(cap)))
oname <- cap
if (is.null(reflab))
reflab <- if (T) rep("",length(arglist))
else paste(sample(letters,4,replace=TRUE),collapse="")
if ((length(arglist)>1)&&(length(reflab)==1))
reflab <- paste0(reflab,seq_along(arglist))
if ((length(arglist)>1)&&(length(dpi)==1))
dpi <- rep(dpi,length(arglist))
if (all(nchar(reflab)>0))
reflab <- paste0(" ",reflab)
k <- 0L
# return(oname)
ret <- lapply(arglist,function(obj) {
k <<- k+1L
if (verbose)
print(k)
ret2 <- NULL
if (is.character(obj)) {
if (!file.exists(obj)) { ## e.g.,Rplots%02d.png
obj <- head(dir(path=dirname(obj)
,pattern=gsub("\\%(\\d+)*d","\\\\d+",obj)
,full.names=TRUE),1)
}
if (!length(obj))
return(ret2)
if (length(grep("\\.(png|gif)$",basename(obj))))
cmd <- c(paste0("```{r",reflab[k]
,", echo=F"
,if (!is.null(oname)) paste0(", fig.cap=",dQuote(oname[k]))
,"}")
,paste0("knitr::include_graphics(",dQuote(obj)
,if (!is.null(dpi)) paste0(",dpi=",dpi[k])
# ,",height=",dQuote(paste0(round(4.8*96,1),"px"))
,")")
,"```")
else
cmd <- NULL
if (!.isKnitr()) {
if ((verbose)&&(!is.null(cmd)))
cat(cmd,sep="\n")
ret2 <- browseURL(normalizePath(obj))
}
else {
cmd <- knitr::knit_child(text=cmd,quiet=TRUE)
cat(cmd,sep="\n")
ret2 <- invisible(NULL)
}
}
if (inherits(obj,"mapview"))
obj <- methods::slot(obj,"map")
# if (inherits(obj,"tmap")) {
# if (requireNamspace("tmap"))
# obj <- tmap::tmap_leaflet(obj)
# }
if (inherits(obj,c("tmap","htmlwidget"))) {
isUrsaCache <- !identical(normalizePath(.ursaCacheDir()),tempdir())
if (!isUrsaCache & is.null(output))
return(ret2)
cond2 <- requireNamespace("htmlwidgets",quietly=.isPackageInUse())
if (!cond2)
return(ret2)
ftemp <- tempfile(fileext=".rds")
o <- obj[grep("dependencies",names(obj),invert=TRUE)]
saveRDS(o,ftemp)
md5 <- tools::md5sum(ftemp)
file.remove(ftemp)
if (is.null(output)) {
if (!.isKnitr())
output <- file.path(.ursaCacheDir(),"knit")
else
output <- file.path(knitr::opts_chunk$get("fig.path"))
}
else {
# TODO 'if (length(grep("\\.html$",output)))...'
output <- normalizePath(output)
}
if (!dir.exists(output))
dir.create(output,recursive=TRUE)
if (!.isKnitr()) {
libdir <- file.path(output,"site_libs")
fname <- file.path(output,paste0("htmlwidget_",unname(md5),".html"))
}
else {
libdir <- file.path("libs")
fname <- file.path(output,paste0("widget_"
,knitr::opts_current$get("label")
,"_",unname(md5)
,".html"))
caption <- knitr::opts_current$get("fig.cap")
if ((is.null(oname))&&(!is.null(caption)))
oname <- caption
}
if (!file.exists(fname)) {
# obj <- htmlwidgets::prependContent(obj,htmltools::HTML("<style>iframe {border: 3px solid magenta;}</style>"))
if (requireNamespace("widgetframe",quietly=.isPackageInUse())) {
obj <- widgetframe::frameableWidget(obj)
}
if (!.isPackageInUse())
opW <- options(warn=1)
htmlwidgets::saveWidget(obj,file=fname,libdir=libdir
,selfcontained=FALSE
,knitrOptions=list(hello="World")
)
if (!.isPackageInUse())
options(opW)
}
if (T | !.isKnitr()) {
a <- readLines(fname,encoding="UTF-8")
a <- grep("application/json.+data-for=\\\"htmlwidget",a,value=TRUE)
id <- gsub("^.+visdat\\W+([0-9a-f]+)\\W+.+$","\\1",a)
if ((nchar(id)>4)&&(nchar(id)<36)) {
a <- gsub(id,"gggg",a)
a <- gsub("(^.+htmlwidget\\W+)([0-9a-f]+)(\\W+.+$)","\\1hhhhh\\3",a)
saveRDS(a,ftemp)
md5 <- unname(tools::md5sum(ftemp))
file.remove(ftemp)
ename <- fname
if (!.isKnitr())
fname <- file.path(dirname(fname),paste0("htmlwidget-",md5,".html"))
else
fname <- file.path(dirname(fname),paste0("widget_"
,knitr::opts_current$get("label")
,"_",unname(md5)
,".html"))
file.rename(ename,fname)
}
}
# oname <- "PUT YOUR CAPTION HERE"
fname <- gsub("\\\\","/",fname)
if ((T | !.isKnitr())&&(length(grep("^(/\\w|[A-Z\\:\\w])",fname))))
fname <- paste0("file:///",fname)
# cap <- paste0("<a href=",URLencode(fname),">",oname[k],"</a>")
if (link) {
cap <- paste0("^[🔗](",URLencode(fname),")^") ## []{style=\"opacity: 0.3\"}
# cap <- paste0("<span style=\"color: magenta;\">[🔗](",URLencode(fname),")</span>") ## []{style=\"opacity: 0.3\"}
}
else
cap <- ""
if ((!is.null(oname))&&(nchar(oname[k])>0))
cap <- paste(oname[k],cap)
iframe <- paste0("knitr::include_url(",dQuote(fname))
if (!is.null(height)) {
if (is.character(height))
iframe <- paste0(iframe,",height=",dQuote(height))
if (is.numeric(height))
iframe <- paste0(iframe,",height=",dQuote(height)) ## dQuote(height,c("","px")[1])
}
iframe <- paste0(iframe,")")
cmd <- c(paste0("```{r",reflab[k]
,", echo=F"
# ,if (!is.null(oname)) paste0(", fig.cap=",dQuote(oname[k]))
,if (T | !nchar(cap)) paste0(", fig.cap=",dQuote(cap))
,paste0(", out.extra=",dQuote("class=\\\'ursa-widgetize\\\'"))
,"}")
##~ ,paste0("knitr::include_url(",dQuote(fname)
##~ #,",height=",dQuote(paste0(round(4.8*96,1),"px"))
##~ ,")")
,iframe
,"```"
# ,""
# ,paste0("[link to widget](",fname,"){style=\"font-size: 75%;\"}")
# ,paste0("[🔗](",URLencode(fname),"){style=\"font-size: 75%; opacity: 0.6;\" class=\"noprint\"}")
)
# print(iframe)
# print(cmd)
# str(knitr::opts_current$get())
if (!.isKnitr()) {
if (verbose)
cat(cmd,sep="\n")
ret2 <- browseURL(fname)
}
else {
if (T) {
if (.isRemark()) {
if (is.null(height))
height <- knitr::opts_current$get("out.height")
if (is.null(width))
width <- "100%"
suffix <- paste0(" style=\"height:",height,"px; width=",width,"\"")
}
else
suffix <- ""
cmd <- c(paste0("<div class=\"framed\"",suffix,">"),cmd,"</div>")
}
# writeLines(cmd,"c:/tmp/cap.Rmd")
# knitr::asis_output(cmd)
if (!.isRemark()) {
cmd <- knitr::knit_child(text=cmd,quiet=TRUE)
}
else {
cmd <- paste0("<div class=\"figure\">\n"
,"<div class=\"framed\"",suffix,">\n"
,"<iframe src=",dQuote(fname)
,ifelse(is.null(width),"",paste0(" width=",dQuote(width)))
,ifelse(is.null(height),"",paste0(" height=",dQuote(height)))
," class=",dQuote("ursa-widgetize"),">"
,"</iframe>\n"
,"</div>\n"
,if (nchar(cap))
paste0("<p class=",dQuote("caption"),">"
,cap," </p>\n")
,"</div>")
}
# print(cmd)
cat(cmd,sep="\n")
ret2 <- invisible(NULL)
}
##~ inventory <- .ursaCacheInventory()
##~ if (file.exists(inventory)) {
##~ was <- utils::read.table(inventory,sep=",",encoding=enc)
##~ colnames(was) <- c("time","stamp","visits","size","src","dst")
##~ }
##~ else
##~ was <- NULL
##~ data.frame(time=format(Sys.time(),"%Y-%m-%dT%H:%M:%SZ",tz="UTC")
##~ ,stamp=as.integer(file.mtime(fname))
##~ ,visits=0L
##~ ,size=file.size(fname)
##~ ,src=basename(fname)
##~ ,dst=basename(fname)
##~ )
# da <- rbind(was,da)
##~ utils::write.table(da,quote=TRUE,col.names=FALSE,row.name=FALSE,sep=","
##~ ,file=inventory,append=TRUE,fileEncoding="UTF-8")
if ((isUrsaCache)&&(!.ursaCacheFind(fname))) {
da <- .ursaCacheRecord(fname)
.ursaCacheWrite(da,append=TRUE)
}
}
ret2
})
if (length(ret)==1)
ret <- ret[[1]]
invisible(ret)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.