#' An S4 class for Exhibit objects.
#'
#' @importFrom dplyr %>%
#' @importFrom purrr detect every is_function
#' @slot title Title for exhibit
#' @slot subtitle Subtitle for exhibit
#' @slot caption Caption for exhibit
#' @slot gens List of exhibit generators. Each generator must be a function that
#' returns an exhibit component (e.g., a plot).
#' @name exhibitr-class
exhibitr <- setClass("exhibitr",
slots = list(title = "character",
subtitle = "character",
caption = "character",
gens = "list"),
validity = function(object){
if (!(object@gens %>% every(is_function))){
return("Not all generators are functions")
}
})
#' @rdname exhibitr-class
setMethod("initialize",
signature = c("exhibitr"),
definition = function(.Object, ...,
title = character(0),
subtitle = character(0),
caption = character(0),
gens = list()){
.Object@title <- title
.Object@subtitle <- subtitle
.Object@caption <- caption
.Object@gens <- c(list(...), gens)
invisible(.Object)
})
#' Constructor wrapper for exhibitr
#'
#' @export
#' @name exhibitr
#' @rdname exhibitr-class
exhibitr
#' List exhibit components
#'
#' @export
#' @param object Object to list generators of
setGeneric("xb_gens",
def = function(object) standardGeneric("xb_gens"))
#' @rdname xb_gens
setMethod("xb_gens",
signature = "exhibitr",
definition = function(object) names(object@gens))
#' @rdname exhibitr-class
setMethod("[[",
signature = c(x = "exhibitr", i = "ANY", j = "ANY" ),
definition = function(x, i, j = NULL, ...){
rez <- x@gens[[i]]
if (!is.null(rez)) return(rez)
if (i == "plot"){
rez <- x@gens %>% detect(~ inherits(.x, "xbc_highchart"))
if (!is.null(rez)) return(rez)
rez <- x@gens %>% detect(~ inherits(.x, "xbc_plot"))
if (!is.null(rez)) return(rez)
}
})
#' @rdname exhibitr-class
setMethod("[",
signature = c(x = "exhibitr", i = "ANY", j = "ANY"),
definition = function(x, i, j = NULL){
x@gens[i]
})
#' @rdname exhibitr-class
setMethod("$",
signature = c("exhibitr"),
definition = function(x, name){
x[[as.character(name)]]
})
#' Class definition for exhibit component generator
#'
#' @export
xbc_gen <- setClass(
"xbc_gen",
slots = list(
shinyOutput = "function",
shinyRenderer = "function"
),
contains = "function"
)
#' Contructor function for xbc_gen
#'
#' @name xbc_gen
#' @rdname xbc_gen-class
#' @export
xbc_gen
#' S4 Class for plot component generator
#'
#' @export
xbc_plot <- setClass(
"xbc_plot",
prototype = prototype(
shinyOutput = shiny::plotOutput,
shinyRenderer = shiny::renderPlot
),
contains = "xbc_gen"
)
#' Constructor for xbc_plot
#'
#' @export
#' @rdname xbc_plot-class
#' @name xbc_plot
xbc_plot
#' S4 Class for datatable component generator
#'
#' @export
xbc_datatable <- setClass(
"xbc_datatable",
prototype = prototype(
shinyOutput = DT::dataTableOutput,
shinyRenderer = DT::renderDataTable
),
contains = c("xbc_gen")
)
#' Constructor for xbc_datatable
#'
#' @export
#' @rdname xbc_datatable-class
#' @name xbc_datatable
xbc_datatable
#' S4 class for highchart component generator
#'
#' @export
xbc_highchart <- setClass(
"xbc_highchart",
prototype = prototype(
shinyOutput = highcharter::highchartOutput,
shinyRenderer = highcharter::renderHighchart
),
contains = c("xbc_gen")
)
#' Constructor for xbc_highchart
#'
#' @rdname xbc_highchart-class
#' @name xbc_highchart
xbc_highchart
setGeneric("create_ui",
def = function(object, id, ...) standardGeneric("create_ui"))
setMethod("create_ui",
signature = c("xbc_gen"),
definition = function(object, id, ...){
object@shinyOutput(id, ...)
})
setGeneric("xb_run",
def = function(object, ...) standardGeneric("xb_run"))
#' @importFrom purrr map_if
setMethod("xb_run",
signature("xbc_gen"),
definition = function(object, ...){
object@shinyRenderer({
argz <- list(...) %>% map_if(is.reactive, ~ .x())
invoke(object, argz)
})
})
#' Generate shiny module from exhibit components or objects
#'
#' @export
setGeneric("xb_shiny_module",
def = function(object, ...) standardGeneric("xb_shiny_module"))
#' @rdname xb_shiny_module
setMethod("xb_shiny_module",
signature = "xbc_gen",
definition = function(object, ...){
.dots <- list(...)
ui <- function(id, ...){
ns <- NS(id)
## object@shinyOutput(ns("xbcgen"))
xb_ui(object, ns("xbcgen"))
}
server <- function(input, output, session, ...){
output$xbcgen <- xb_run(object, ...)
}
list(ui = ui, server = server)
})
#' @rdname xb_shiny_module
setMethod("xb_shiny_module",
signature = "NULL",
definition = function(object, ...){
list(
ui = function(...) NULL,
server = function(...) NULL
)
})
#' @rdname xb_shiny_module
#' @importFrom purrr lift_dl discard map map2 lift
#' @param .inner List of functions to be applied to the component outputs.
setMethod("xb_shiny_module",
signature = "exhibitr",
definition = function(object, ..., elems = "plot"){
xbc_list <- object[elems]
xbc_modules <- xbc_list %>% map(xb_shiny_module)
ui <- function(id, ..., .inner = identity, .outer = tagList){
ns <- NS(id)
ids <- elems %>% map(ns)
ui_funcs <- xbc_modules %>% map("ui")
tagz <- map2(ui_funcs, ids, invoke)
lift(.outer)(tagz)
}
server <- function(input, output, session, ...){
.dots = list(...)
.f <- function(module, elem){
cm_args <- c(module$server, elem, .dots)
invoke(callModule, cm_args)
}
map2(xbc_modules, elems, .f)
}
list(ui = ui, server = server)
})
#' Create shiny module with tabs.
#'
#' @export
setGeneric("xb_tabs_module",
def = function(object, elems = "plot", ...) standardGeneric("xb_tabs_module"))
#' @rdname xb_tabs_module
setMethod("xb_tabs_module",
signature = "exhibitr",
definition = function(object, elems = "plot", ..., titles = NULL){
.dots <- list(...)
xbc_list <- object[elems]
xbc_modules <- xbc_list %>% map(xb_shiny_module)
tabtitles <- titles %||% elems
ui <- function(id, ..., .outer = tabsetPanel){
ns <- NS(id)
ids <- elems %>% map(ns)
## ui_funcs <- xbc_modules %>% map("ui")
## tagz <- map2(ui_funcs, ids, invoke)
tagz <- map2(xbc_list, ids, xb_ui)
tabargs <- tabtitles %>% map(~ list(title = .x)) %>%
list(tagz) %>% purrr::transpose()
tabz <- tabargs %>% map(lift_dl(tabPanel))
ts_args <- c(tabz, list(...))
lift_dl(.outer)(ts_args)
}
server <- function(input, output, session, ...){
.dots = list(...)
server_funcs <- map(xbc_list, xb_server_func)
.f <- function(module, elem){
## cm_args <- c(module$server, elem, .dots)
cm_args <- c(module, elem, .dots)
## invoke(callModule, cm_args)
invoke(xb_module, cm_args)
}
## map2(xbc_modules, elems, .f)
map2(xbc_list, elems, .f)
}
list(ui = ui, server = server)
})
xb_server_func <- function(object, ...) UseMethod("xb_server_func")
xb_server_func.default <- function(object, ..., elems = NULL){
object$server
}
setGeneric("xb_server_func")
## setGeneric("xb_server_func",
## def = function(object, ..., elems = NULL) standardGeneric("xb_server_func"))
setMethod("xb_server_func",
signature = "xbc_gen",
definition = function(object, ...){
function(input, output, session, ...){
output$xbcgen <- xb_run(object, ...)
}
})
setMethod("xb_server_func",
signature = "exhibitr",
definition = function(object, ..., elems = NULL){
elems <- elems %||% xb_gens(object)
server <- function(input, output, session, ...){
.dots <- list(...)
.f <- function(elem){
cm_args <- c(xb_server_func(object[[elem]]), elem, .dots)
invoke(callModule, cm_args)
}
map(elems, .f)
}
server
})
#' @importFrom memoise memoise
xb_srv_m <- memoise(xb_server_func)
#' Generic function for generating ui components.
#'
#' @rdname xb_ui
#' @export
setGeneric("xb_ui",
def = function(object, id, ...) standardGeneric("xb_ui"))
#' @rdname xb_ui
setMethod(
"xb_ui",
signature = "xbc_gen",
definition = function(object, id, ...){
ns <- NS(id)
object@shinyOutput(ns("xbcgen"), ...)
})
#' @importFrom purrr map2 %||%
#' @rdname xb_ui
setMethod(
"xb_ui",
signature = "exhibitr",
definition = function(object, id, ..., elems = NULL){
ns <- NS(id)
elems <- elems %||% xb_gens(object)
ids <- map(elems, ns)
tagz <- object[elems] %>% map2(ids, xb_ui)
lift(tagList)(tagz)
})
setGeneric(
"xb_module",
def = function(object, id, ...) standardGeneric("xb_module"))
setMethod(
"xb_module",
signature = "xbc_gen",
definition = function(object, id, ...){
srvr <- xb_server_func(object)
callModule(srvr, id = id, ...)
}
)
setMethod(
"xb_module",
signature = "exhibitr",
definition = function(object, id, ..., elems = NULL){
srvr <- xb_server_func(object, elems = elems)
callModule(srvr, id = id, ...)
}
)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.