R/web.R

In emajortaiwan/emajorDV:

#' Have web serve R chunk in your clipboard for you to paste
#'
#' @return
#' @export
#'
#' @examples none
copyServeChunk <- function(){
  clipr::write_clip(webserveText)
}
# addInternalData(webserveText)

#' Create a jquery experiemtal index page with body content from the copy of
#'  a webpage inspection element
#'
#' @return
#' @export
#'
#' @examples none
create_jqueryPage <- function(){
  clipr::read_clip() -> context
  stringr::str_which(index,"\\{replacementBlock\\}") -> loc_cut
  newContent <-
    c(
      index[1:(loc_cut-1)],
      context,
      index[-(1:loc_cut)]
    )
  writeLines(newContent,
             con="index.html")
  servr::httd(port="8080")-> out
  with(out, paste0("http://", host,":",port)) -> url0
  browseURL(url0)
  file.edit("index.html")
}

#' serve the last modified html (usually the latest knitted Rmd)
#'
#' @param path A character, default="."
#'
#' @return
#' @export
#'
#' @examples none
serveTheLastModified <- function(path="."){
  if(length(servr::daemon_list())!=0){
    servr::daemon_stop()
  }
  rootPath <- normalizePath(".")
  sconfig <- servr::server_config()
  host <- sconfig$host
  port <- sconfig$port
  allHtmls <- list.files(path = path, pattern = ".html$",
                         full.names = T)
  allHtmlsInfo <- file.info(allHtmls)
  loc_theLatest <- with(allHtmlsInfo, which(mtime == max(mtime)))
  html2open <- stringr::str_remove(
    allHtmls[[loc_theLatest]],
    glue::glue("^(\\.|{rootPath})"))
  url0 <- paste0("http://", host, ":", port, html2open)

  if (length(servr::daemon_list()) == 0) {
    servr::httd(
      dir=rootPath,
      port=port
    )
  }

  browseURL(url0)
}
#' Add JS html to the end of body to the latest modified html
#'
#' @param jsfile A character. The file path of your html js file
#' @param path A character. The path to your latest modified html file
#'
#' @return
#' @export
#'
#' @examples none
addJsHtml2Latest <- function(jsfile, path="."){
  jsHtml <- readLines(
    jsfile
  )
  list.files(path=path,pattern=".html$", full.names = T) -> allHtmls
  file.info(allHtmls) -> allHtmlsInfo
  with(allHtmlsInfo, which(mtime==max(mtime)))-> loc_theLatest
  newHtml <- allHtmls[[loc_theLatest]]
  readLines(newHtml) -> newHtmlLines
  stringr::str_which(newHtmlLines,"</body>") -> loc_bodyEnd
  revisedHtml <- c(newHtmlLines[1:(loc_bodyEnd-1)],
  jsHtml,
  newHtml[-(1:(loc_bodyEnd-1))])
  writeLines(
    revisedHtml,
    con=newHtml
  )
}

#' Knit active Rmd, add JS and serve based on params$after_body
#'
#' @return
#' @export
#'
#' @examples none
activeRmd_KnitAddJsServe <- function(){
  rstudioapi::getSourceEditorContext() -> activeSource
  activeSource$path -> activeRmd
  rmarkdown::render(activeRmd)
  knitr::knit_params(readLines(activeRmd)) -> params0
  jsfile <- ifelse(
    stringr::str_detect(params0$after_body$value,"^\\."),
    params0$after_body$value,
    file.path(dirname(activeRmd),params0$after_body$value)
  )

  addJsHtml2Latest(jsfile, path=dirname(activeRmd))
  serveActiveRmdRenderedHTML()
}

#' Serve the html generated by the active Rmd in RStudio
#'
#' @param webRoot A web root path, default=NULL means the activeRmd dir be root.
#' @return
#' @export
#'
#' @examples none
serveActiveRmdRenderedHTML <- function(webRoot=NULL){
  if(length(servr::daemon_list())!=0){
    servr::daemon_stop()
  }
  servr::server_config() -> sconfig
  sconfig$host -> host
  sconfig$port -> port
  rstudioapi::getSourceEditorContext() -> activeSource
  activeSource$path -> activeRmd
  # normalizePath(activeRmd) -> activeRmd
  # stringr::str_remove(activeRmd, rootPath) ->
  #   html2open
  if(is.null(webRoot)){
    webDirRoot <- dirname(activeRmd)
    activeRmd <- basename(activeRmd)
  } else {
    webDirRoot <- normalizePath(webRoot)
    activeRmd <- normalizePath(activeRmd)
    activeRmd <-
      stringr::str_remove(activeRmd, webDirRoot)
    activeRmd <- stringr::str_remove(activeRmd,"^/")
  }
  servr::httd(dir=webDirRoot,port=port) # 以activeRmd dir為web root

  stringr::str_replace(basename(activeRmd),"[rR]md$","html")-> html2open
  file.path("http://", paste0(host,":",port),html2open) -> url0

  sessionInfo() -> info
  if(stringr::str_detect(info$running,"[mM][aA][cC]")){
    system(glue::glue('open -a "Google Chrome" {url0}'))
  } else {
    browseURL(url0)
  }

}

#' Add JS to the Active Rmd's
#'
#' @return
#' @export
#'
#' @examples none
addJs2LatestHtmlServe <- function(){
  rstudioapi::getSourceEditorContext() -> activeSource
  activeSource$path -> activeRmd
  knitr::knit_params(readLines(activeRmd)) -> params
  addJsHtml2Latest(params$after_body$value)
  serveActiveRmdRenderedHTML()
}

#' Create web service
#'
#' @return
#' @export
#'
#' @examples none
webService <- function(){
  service <- list() #new.env(parent=globalenv())
  service$serveTheLastModified <- serveTheLastModified
  service$create_jqueryPage <- create_jqueryPage
  service$browse_last <- servr::browse_last
  service$addJsHtml2Latest <- addJsHtml2Latest
  service$addJs2LatestHtmlServe <- addJs2LatestHtmlServe
  service$serveActiveRmdRenderedHTML <- serveActiveRmdRenderedHTML
  service$activeRmd_KnitAddJsServe <- activeRmd_KnitAddJsServe
  service$copyServeChunk <- copyServeChunk
  service
}