##' @include utils.R
##' @include gwidgets-app.R
NULL
## scripts to load apps
## return an instance of this singleton class
R_http <- setRefClass("R_http",
contains="Singleton",
fields=c("started", "loaded", "R"), # fake, just to keep down warnings
methods=list(
initialize=function(...) {
Class <<- setRefClass("Class",
fields=list(
"R"="ANY",
"port"="numeric",
"started"="logical",
"loaded"="logical"),
methods=list(
initialize=function(...) {
initFields(started=FALSE,
loaded=FALSE,
R=Rhttpd$new()
)
callSuper(...)
},
start=function(...) {
if(started)
return()
cur_port <- tools::startDynamicHelp(start=NA)
assign("port", cur_port, .self)
started <<- TRUE
return()
## this isn't working anymore?
env = environment(tools::startDynamicHelp)
cur_port <- get("httpdPort", env)
cur_port <- tools:::httpdPort
if(cur_port > 0) {
if(cur_port != port) {
message(sprintf("Web server already started on port %s", cur_port))
assign("port", cur_port, .self)
}
started <<- TRUE
} else {
## pass in listen="external.ip"
## message(sprintf("Starting server on port %s", port))
## options(help.ports=port) ## port is failing!!!
out <- R$start(...)
env = environment(tools::startDynamicHelp)
assign("port", get("httpdPort", env), .self)
started <<- TRUE
}
},
load_gw=function(session_manager=make_session_manager()) {
if(loaded) return()
## gWidgetsWWW, static files
gWidgetsWWW <- Rook::Static$new(
urls = c("/images", "/javascript", "/css"),
root = system.file("base", package="gWidgetsWWW2")
)
R$add(RhttpdApp$new(gWidgetsWWW, name="gWidgetsWWW2"))
## tmpdir
tmpApp <- Rook::Static$new(
urls=c("/tmp"),
root=tempdir()
)
R$add(RhttpdApp$new(tmpApp, name="tmp"))
## This handles the AJAX calls
R$add(GWidgetsAppAjax$new(session_manager=session_manager), name="gwappAJAX")
loaded <<- TRUE
},
load_app=function(
script_name,
app_name=gsub("\\..*", "", basename(script_name)),
session_manager=make_session_manager(),
open_page=TRUE,
show.log=FALSE,
webpage = NULL,
# authenticator=NULL,
...) {
options("Rhttpd_debug"=as.logical(show.log))
## Make the page
if(is.null(webpage))
webpage <-WebPage$new(url="/", app_name=app_name, ...)
else
webpage$app_name <- app_name
R$add(RhttpdApp$new(webpage, name=app_name))
## message(list("*** making app ***", app_name))
## Make the app
gwapp <- gWidgetsWWW2:::GWidgetsApp$new(url="/",
app_name=app_name,
script=script_name,
session_manager=session_manager)
R$add(RhttpdApp$new(gwapp, name=sprintf("app_%s", app_name)))
if(open_page) {
## message("load page, port:", port, "app name: ", app_name)
browseURL(sprintf("http://127.0.0.1:%s/custom/%s", port, app_name))
}
invisible(gwapp)
},
load_dirapp=function(
dir_name, ...) {
"
##' Load an app in a directory
##'
##' @param dirname The directory name (with full path). We make several assuptions:
##' 1. `dir/*.R` has one answer, or we take `index.R`, or we take first alphabetically;
##' 2. `app_name` is `basename(dir_name)`;
##' @note This function sets the working directory to `dir`.
##' @export
##' @return creates the app
"
sep <- .Platform$file.sep
dir_name <- gsub(sprintf("%s*$", sep), "", dir_name)
app_name <- basename(dir_name)
r_files <- Sys.glob(sprintf("%s%s*.R", dir_name, sep))
if(length(r_files) == 0) {
stop(gettext(sprintf("No R files found in %s", dir_name)))
} else if(length(r_files) == 1) {
r_file <- r_files
} else {
ind <- match("index.R", basename(r_files))
r_file <- ifelse(is.na(ind), r_files[1], r_files[ind])
}
## How to do make_session
## how to do Authentification?
setwd(dir_name)
load_app(
script_name=r_file,
app_name=app_name,
...
)
}
))
callSuper(...)
}
))$new()
## put this in zzz.R
r_httpd <- R_http$get_instance()
##' Load a web app defined by a gWidgetsWWW2 script
##'
##' There are two basic tasks that gWidgetsWWW2 does: a) create the
##' javascript to populate a page (or part of the page) and b) create
##' a means for AJAX requests between the web browser and the R
##' process. For b) there isn't much to say except that it is supposed
##' to just work.
##'
##' As for a) there are things one can pay attention to. The simplest
##' case is really pretty simple. Write some script, save it to a file
##' and call this function with the script name (and path if needed).
##' This simple case will create a full screen app. Each app runs in
##' its own environment in the R session, so running lots of instances
##' can be expensive. That is, don't expect gWidgetsWWW2 to scale.
##'
##' To embed an app within a web page, use an \code{iframe} tag.
##'
##' @param script_name path to gWidgetsWWW2 script
##' @param app_name base name for script, unique per project. Derived
##' from script name if not specified.
##' @param show.log If TRUE, logged information is written to the console.
##' @param port Initial port for Rhttpd server, provided it hasn't already started.
##' @param session_manager an instance of \code{make_session_manager}
##' @param open_page logical. If \code{TRUE} call \code{browseURL} to open the app.
##' @param ... Passed to WebPage object. Named arguments
##' \code{body} and \code{head} can be used to insert information into
##' each, such as loading of style sheets etc. through \code{head}. One can
##' also subclass \code{WebPage} and pass this in via \code{webpage}.
##' @export
##' @examples
##' ## open an app that takes the entire page
##' gw_script <- system.file("examples/ex-hello-world.R", package="gWidgetsWWW2")
##' if(interactive()) load_app(gw_script, "HelloApp")
load_app <- function(script_name,
app_name=NULL,
port=NULL,
session_manager=make_session_manager(),
open_page=TRUE,
show.log=FALSE,
...
) {
if (!file.exists(script_name))
stop(sprintf("Script %s does not exist", script_name))
if(is.null(app_name))
app_name <- gsub("\\..*", "", basename(script_name))
if (!is.null(port))
options(help.ports=port)
r_httpd <- R_http$get_instance()
r_httpd$start() # if not started
r_httpd$load_gw(session_manager)
## now load app
r_httpd$load_app(script_name, app_name, session_manager, open_page, show.log,
##authenticator,
...)
}
##' Load an app in a directory
##'
##' @param dir_name The directory name (with full path). We make several assuptions:
##' 1) \code{dir/*.R} has one answer, or we
##' take \code{index.R}, or we take first alphabetically; 2)
##' \code{app_name} is \code{basename(dir_name)}; 3)
##' \code{brew/*rhtml} is empty (fullscreen), has one value, or has
##' \code{index.rhtml} or we take first alphabetically; 4)
##' authenticator (XXX to be determined, for now calls
##' \code{make_session_manager})
##' @param ... passed to \code{load_dir} reference class method of
##' \code{R_http} instance.
##' @export
##' @return creates the app
load_dirapp <- function(dir_name, ...) {
r_httpd <- R_http$get_instance()
r_httpd$load_dirapp(dir_name, ...)
}
##' Load all apps in the directory specified
##'
##' Loads all files with "r" or "R" extension in the specified directory
##' @param dir_name directory name
##' @param session_manager session manager
##' @export
##' @return list of return values from \code{load_app}
load_dir <- function(dir_name, session_manager=make_session_manager()) {
f <- list.files(dir_name, full.names=TRUE)
f <- Filter(function(x) grepl("[rR]$", x), f)
sapply(f, load_app, session_manager=session_manager, open_page=FALSE, simplify=FALSE)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.