R/TidyModule.R
In xni7/tidymodules: A robust framework for developing shiny modules
#' TidyModule R6 Class, parent of all modules
#'
#' @description
#' This is the main class provided by tidymodules and should be the parent of all tidymodules modules.
#' It provides methods for defining input and output communication ports, managing module namespace and many other useful features.
#'
#' @import R6
#' @import shiny
#'
#' @export
TidyModule <- R6::R6Class(
"TidyModule",
public = list(
#' @field id ID of the module.
id = NULL,
#' @field name Name of the module as generated or provided by the user.
name = NULL,
#' @field module_ns Module namespace, unique identifier for the module.
module_ns = NULL,
#' @field parent_ns Parent module namespace in case of nested modules.
parent_ns = NULL,
#' @field parent_mod Reference to parent module in case of nested modules.
parent_mod = NULL,
#' @field pass_ports logical value indicating if the module should pass its ports to any nested modules. This is initialized with the `inherit` argument of `new()`.
pass_ports = NULL,
#' @field group Group name of the module.
group = NULL,
#' @field created Initialization time of the module.
created = NULL,
#' @field order Initialization order.
order = NULL,
#' @field i reactive list of input ports.
i = NULL,
#' @field o reactive list of output ports.
o = NULL,
#' @field port_names list of input and output port names.
port_names = NULL,
# o = NULL,
# i = NULL,
#' @description
#' Create a new tidymodules module.
#' @param id Unique Id to assign to the module. Default to a generated Id using module's class and order of initialization.
#' @param inherit logical value indicating if a nested module should inherits the parent's input ports. Default to TRUE
#' @param group Module group name. Added to module's Id to make it unique. Optional
#' @return A new `TidyModule` object.
initialize = function(id = NULL, inherit = TRUE, group = NULL) {
#### Initialize ModStore #######
if(is.null(private$shared$store))
private$shared$store <- ModStore$new()
self$pass_ports <- inherit
ses <- self$getSession()
isolate({
ses$count <- ses$count+1
self$order <- ses$count
})
onStop(function(){
# reset session module count and edge table when app stop
ses$count <- 0
ses$edges <- data.frame()
})
self$name <- ifelse(
is.null(id),
paste0(class(self)[[1]],"-",isolate({ses$count }))
,private$sanitizeID(id,"Id"))
if(!is.null(group)){
g <- private$sanitizeID(group,"Group")
self$id <- paste0(g,"-",self$name)
self$group <- g
}else{
self$id <- self$name
}
################# Handle nested module here ################
############### Find and set the parent module #############
# case 1 : nested module directly initialized in attribute definition of parent
# This type of initialization should trigger an error
# Because the parent module need to be initialized first
# TODO : Find a way to prevent this....
# if(class(sys.frame(9)$inherit) == "R6ClassGenerator")
# stop(paste0("Error in definition of module ",sys.frame(9)$classname,
# "! Nested module ",self$id," should be defined either in initialize() or server() of parent!"))
# case 2 :
# for n = 2:3 => nested module initialized in initialze() or server() functions of parent
# for n = 4:10 => same as before but support nested functions or module inheritance
for(n in 2:10){
self$parent_mod<-parent.env(parent.frame(n))$self
if(!is.null(self$parent_mod) && is(self$parent_mod,"TidyModule"))
break
}
#browser()
# case 3 : Dynamically created module in an observe function of server()
if(is.null(self$parent_mod) || !is(self$parent_mod,"TidyModule"))
#self$parent_mod<-parent.env(parent.env(parent.frame(3)))$self
self$parent_mod<-parent.env(parent.env(parent.env(parent.frame(3))))$self
# At the end we save the parent ns & server arguments if any
if(!is.null(self$parent_mod) &&
is(self$parent_mod,"TidyModule")){
self$parent_ns <- self$parent_mod$module_ns
}else{
self$parent_mod <- NULL
}
self$module_ns <- ifelse(
is.null(self$parent_ns),
self$id,
paste0(self$parent_ns,"-",self$id))
#### Capture ShinySession #######
private$shiny_session <- shiny::getDefaultReactiveDomain()
self$created <- Sys.time()
# check that the module namespace is unique in the current session
if(self$isStored() &&
as.character(mod(self$module_ns)$created) == as.character(self$created))
stop(paste0("Module namespace collision!\n",
"Make sure that the namespace Id ",self$module_ns," is only used once."))
private$shared$store$addMod(self)
private$initFields()
# Only transfer parent ports in dynamic mode
# i.e. when the child module is initialized on the server
if(!self$isGlobal() &&
!is.null(self$parent_mod) &&
is(self$parent_mod,"TidyModule") &&
self$pass_ports)
self$parent_mod %:i:% self
},
#' @description
#' namespace function used to generate unique Id for HTML elements.
#' @param id Id of HTML element / shiny input.
#' @return A unique string Id.
ns = function(id){
NS(self$module_ns, id)
},
#' @description
#' Get module session Id. This function rely on a shiny output object to find the right session Id.
#' @return The Session Id of the module.
getSessionId = function(){
return(getSessionId(private$shiny_session))
},
#' @description
#' Alias to the `ui` function.
#' @param ... arguments passed to the ui function.
render = function(...){
self$ui(...)
},
#' @description
#' UI function generating the module HTML elements.
#' This function is eventually implemented in the child module to give the module a visual representation.
#' Please note that a module can have many visual representations.
#' @param ... arguments passed to ui
#' @return Empty tagList()
ui = function(...){
return(tagList())
},
#' @description
#' server function to be overwritten and called by child module.
#' @param input shiny input.
#' @param output shiny output.
#' @param session shiny session.
server = function(input,
output,
session){
# Need to isolate this block to avoid unecessary triggers
isolate({
private$shiny_session <- session
private$shiny_input <- input
private$shiny_output <- output
})
},
#' @description
#' Preview the module in a gadget.
view = function(){
s <- function(input, output, session){
callModules()
self$server(input, output, session)
}
app <- shinyApp(ui = miniUI::miniPage(self$ui()), server = s)
viewer <- dialogViewer(paste0("Preview of ",self$module_ns))
#viewer <- paneViewer(300)
#viewer <- browserViewer()
runGadget(app, viewer = viewer, stopOnCancel = TRUE)
},
#' @description
#' Function wrapper for port definition expression.
#' @param x expression
definePort = function(x){
isolate(x)
},
#' @description
#' Function wrapper for port assignment expression.
#' @param x expression
assignPort = function(x){
# TODO: There must be a better way to do that
# Only add observe in non-reactive context
if(is.null(shiny:::.getReactiveEnvironment()$.currentContext))
observe({
isolate(x)
})
else
isolate(x)
},
#' @description
#' Add input port function. To be called within `definePort` function
#' @param name port name. must be a unique input port name.
#' @param description port description.
#' @param sample sample dataset consumed by this port. Mandatory!
#' @param is_parent Is the port inherited from the parent module.
#' @param inherit Should the port be passed to nested module. default to TRUE.
#' @param input This argument should be ignored. Only here for backward compatibility.
addInputPort = function(
name = NULL,
description = NULL,
sample = NULL,
input = FALSE,
is_parent = FALSE,
inherit = TRUE){
private$addPort(
type = "input",
name = name,
description = description,
sample = sample,
is_parent = is_parent,
inherit = inherit
)
},
#' @description
#' Function for filling an input port.
#' Called within the `assignPort` function
#' @param id Port name or Id .
#' @param input The reacive object.
updateInputPort = function(
id = NULL,
input = NULL){
private$updatePort(id = id,port = input, type = "input")
},
#' @description
#' This function add a set of input ports to the module.
#' @param inputs reactivevalues with the input ports.
#' @param is_parent Are the ports from a parent module. Default to FALSE.
updateInputPorts = function(
inputs = NULL,
is_parent = FALSE){
private$updatePorts(ports = inputs, type = "input", is_parent = is_parent)
},
#' @description
#' Get an input port from the module.
#' @param id Name or Id of the port.
#' @return A module input port. A reactivevalues object with name, description, sample, is_parent and port elements.
getInputPort = function(id = 1){
return(private$getPort(id,"input"))
},
#' @description
#' Alias to the `getInputPort()` function.
#' @param id Name or Id of the port.
#' @return A module input port. A reactivevalues object with name, description, sample, is_parent and port elements.
iport = function(id = 1){
return(self$getInputPort(id))
},
#' @description
#' Get all the input ports as a reactivevalues object.
#' @return A reactivevalues object.
getInputPorts = function(){
return(private$getPorts("input"))
},
#' @description
#' Get a input port slot.
#' @param id Name or Id of the port.
#' @param w boolean to enable module session check. default to TRUE.
#' @return A reactive function.
getInput = function(id = 1, w = TRUE){
if(w && self$isGlobal() && !UtilityModule$new()$isGlobal()){
cmd <- paste0('mod("',self$module_ns,'")$getInput(',ifelse(is.character(id),paste0('"',id,'"'),id),')')
warning(paste(
"You are trying to access a global session module port from a user session.",
"Is this intended? If not, use the code below instead.",
cmd, sep= "\n"))
}
r <- private$get(id)
# special handling for inherited input ports
# since they are wraped in a reactive
if(private$getPort(id)$parent)
r <- r()
return(r)
},
#' @description
#' Execute an input port slot, that is, the reactive function stored in the port.
#' The `require` argument which is `TRUE` by default allows you disable checking if the port is Truthy.
#' See `shiny::req` function.
#' @param id Name or Id of the port.
#' @param require Check that the port is available.
#' @return Output of the reacive function execution.
execInput = function(id = 1, require = TRUE){
mod <- getMod(self$module_ns)
r <- mod$getInput(id)
if(require)
req(r)
return(r())
},
#' @description
#' Function for filling an output port.
#' Called within the `assignPort` function
#' @param id Port name or Id .
#' @param output The reacive object.
updateOutputPort = function(
id = NULL,
output = NULL){
private$updatePort(id = id,port = output, type = "output")
},
#' @description
#' This function add a set of output ports to the module.
#' @param outputs reactivevalues with the output ports.
#' @param is_parent Are the ports from a parent module. Default to FALSE.
updateOutputPorts = function(
outputs = NULL,
is_parent = FALSE){
private$updatePorts(ports = outputs, type = "output", is_parent = is_parent)
},
#' @description
#' Add output port function. To be called within `definePort` function
#' @param name port name. must be a unique output port name.
#' @param description port description.
#' @param sample sample dataset returned by this port. Mandatory!
#' @param is_parent Is the port inherited from the parent module.
#' @param output This argument should be ignored. Only here for backward compatibility.
addOutputPort = function(
name = NULL,
description = NULL,
sample = NULL,
output = FALSE,
is_parent = FALSE){
private$addPort(
type = "output",
name = name,
description = description,
sample = sample,
is_parent = is_parent
)
},
#' @description
#' Utility function that returns a port name from the Id.
#' @param id Port Id
#' @param type Port type, input or output.
#' @return Port name.
getPortName = function(id = NULL, type = "input"){
port <- private$getPort(id,type)
return(port$name)
},
#' @description
#' Get an output port from the module.
#' @param id Name or Id of the port.
#' @return A module output port. A reactivevalues object with name, description, sample, is_parent and port elements.
getOutputPort = function(id = 1){
return(private$getPort(id,"output"))
},
#' @description
#' Alias to the `getOutputPort()` function.
#' @param id Name or Id of the port.
#' @return A module output port. A reactivevalues object with name, description, sample, is_parent and port elements.
oport = function(id = 1){
return(self$getOutputPort(id))
},
#' @description
#' Get all the output ports as a reactivevalues object.
#' @return A reactivevalues object.
getOutputPorts = function(){
return(private$getPorts("output"))
},
#' @description
#' Get a output port slot.
#' @param id Name or Id of the port.
#' @param w boolean to enable module session check. default to TRUE.
#' @return A reactive function.
getOutput = function(id = 1, w = TRUE){
if(w && self$isGlobal() && !UtilityModule$new()$isGlobal()){
cmd <- paste0('mod("',self$module_ns,'")$getOutput(',ifelse(is.character(id),paste0('"',id,'"'),id),')')
warning(paste(
"You are trying to access a global session module port from a user session.",
"Is this intended? If not, use the code below instead.",
cmd, sep= "\n"))
}
return(private$get(id, "output"))
},
#' @description
#' Execute an output port slot, that is, the reactive function stored in the port.
#' The `require` argument which is `TRUE` by default allows you disable checking if the port is Truthy.
#' See `shiny::req` function.
#' @param id Name or Id of the port.
#' @param require Check that the port is available.
#' @return Output of the reacive function execution.
execOutput = function(id = 1, require = TRUE){
mod <- getMod(self$module_ns)
r <- mod$getOutput(id)
if(require)
req(r)
return(r())
},
#' @description
#' Function for retrieving the central ModStore.
#' @return The `ModStore` object.
getStore = function(){
return(private$shared$store)
},
#' @description
#' Utility function that counts the number of input ports.
#' @return The input ports count.
countInputPort = function(){
return(private$countPort("input"))
},
#' @description
#' Utility function that counts the number of output ports.
#' @return The output ports count.
countOutputPort = function(){
return(private$countPort("output"))
},
#' @description
#' Alias to the `callModule` function.
#' @param ... arguments passed to the `server` function of the module.
use = function(...){
self$callModule(...)
},
#' @description
#' callModule function. Similar to shiny callModule. Used to inject the server logic into the application.
#' This function don't need the user to provide a namespace Id as a module already knows its identity.
#' Options provided as arguments will be passed to the server function of the module.
#' Note that the module reference `self` might not be the one injected.
#' @param ... arguments passed to the `server` function of the module.
callModule = function(...){
# arguments from server environment
output <- parent.frame()$output
input <- parent.frame()$output
session <- parent.frame()$session
if(is.null(session))
session <- shiny::getDefaultReactiveDomain()
disable_cache <- getCacheOption()
if(!self$isGlobal()){
self$doServer(...)
}else{
isolate({
currentSession <- UtilityModule$new()$getSession()
globalSession <- UtilityModule$new()$getGlobalSession()
# currentSession <- mod$getSession()
# globalSession <- self$getGlobalSession()
currentSession$edges <- data.frame()
currentSession$count <- globalSession$count
cloneMod <- is.null(currentSession$collection[[self$module_ns]])
})
if(cloneMod || disable_cache){
mod <- self$deepClone(output,input,session)
mod$doServer(...)
}else{
getMod(self$module_ns)$doServer(...)
}
}
},
#' @description
#' Function to check if the module is store in the current session.
#' @return logical value.
isStored = function(){
return(self$getStore()$isStored(self))
},
#' @description
#' Check if the session attached to the module is the `global_session`.
#' @return logical value.
isGlobal = function(){
if(self$getSessionId() == "global_session")
return(TRUE)
else
return(FALSE)
},
#' @description
#' Get the current session.
#' @return A reactivevalues object with the following elements.
#' aid = application Id
#' path = application path
#' sid = session Id
#' count = current module count
#' created = session creation time
#' updated = session update time
#' collection = list of session modules
#' edges = list of connection edges
getSession = function(){
return(self$getStore()$getSession(self))
},
#' @description
#' Get the global session.
#' @return A reactivevalues object with the following elements.
#' aid = application Id
#' path = application path
#' sid = "global_session"
#' count = session module count
#' created = session creation time
#' updated = session update time
#' collection = list of session modules
#' edges = empty data.frame
getGlobalSession = function(){
return(self$getStore()$getGlobalSession())
},
#' @description
#' Function interfacing with shiny's callModule.
#' @param ... arguments passed to the `server` function of the module.
doServer = function(...){
callModule(self$server,self$id,...)
},
#' @description
#' Utility function to retrieve a port definition in the form of a list.
#' This is a useful function to learn about a specific port.
#' @param type Port type, input or output.
#' @param id Name or Id of port.
#' @return List of the port definition.
getPortDef = function(type = NULL, id = 1){
port <- NULL
if(is.null(type) || !type %in% c("input","output"))
stop("type must be one of input/output")
isolate({
port <- private$getPort(id,type)
reactiveValuesToList(port)
})
},
#' @description
#' Module printing function.
#' Print the structure of a module.
#' @examples
#' MyModule <- R6::R6Class("MyModule", inherit = tidymodules::TidyModule)
#' m <- MyModule$new()
#' m
print = function(){
isolate({
cat(paste0("Module Namespace ",self$module_ns,"\n"))
if(!is.null(self$group))
cat(paste0("Module Group ",self$group,"\n"))
cat(paste0("Module Session ",self$getSessionId(),"\n"))
cat(paste0("- Class ",paste0(class(self),collapse = " << "),"\n"))
cat(paste0("- Input [",self$countInputPort(),"]\n"))
private$printPorts("input")
cat(paste0("- Output [",self$countOutputPort(),"]\n"))
private$printPorts("output")
})
},
#' @description
#' Module cloning function.
#' Take care of ports (cloning reactive objects) and nested modules.
#' Note that the Ids/namespace are not changed.
#' @param o Optional shiny output.
#' @param i Optional shiny input
#' @param s Optional shiny input
#' @return A cloned module.
deepClone = function(o = NULL, i = NULL, s = NULL){
isolate({
copy <- self$clone()
copy$reset(o,i,s)
for(type in c("input","output")){
if(private$countPort(type) > 0)
for(idx in 1:private$countPort(type)){
po <- private$getPort(idx,type)
# Don't add port inherited from parent module
# They will be added by parent, see below...
if(po$parent)
next
if(type == "input")
copy$addInputPort(
name = po$name,
description = po$description,
sample = po$sample,
inherit = po$inherit)
else
copy$addOutputPort(
name = po$name,
description = po$description,
sample = po$sample)
}
}
copy$created <- Sys.time()
self$getStore()$addMod(copy)
# Now deep clone the module attributes (also check list) that are TidyModules, i.e. nested modules
for(at in names(self)){
if(is(self[[at]],"TidyModule") &&
at != "parent_mod"){ # When module attribute is a nested module
copy[[at]] <- self[[at]]$deepClone(o,i,s)
copy[[at]]$parent_mod <- copy
self$getStore()$addMod(copy[[at]])
# Now add ports to child if any
if(copy[[at]]$pass_ports)
copy %:i:% copy[[at]]
} else if(is.list(self[[at]]) &&
length(copy[[at]]) > 0 &&
!at %in% c("port_names","i","o")){ # Check list for modules
l <- self[[at]]
for(k in 1:length(l)){
if(is(l[[k]],"TidyModule")){
l[[k]] <- l[[k]]$deepClone(o,i,s)
l[[k]]$parent_mod <- copy
self$getStore()$addMod(l[[k]])
# Now add ports to child if any
if(l[[k]]$pass_ports)
copy %:i:% l[[k]]
}
}
copy[[at]] <- l
}
}
})
return(copy)
},
#' @description
#' This function reset the ports.
#' @param o Optional shiny output.
#' @param i Optional shiny input
#' @param s Optional shiny input
reset = function(o = NULL, i = NULL, s = NULL){
private$initFields()
if(!is.null(o))
private$shiny_output <- o
if(!is.null(i))
private$shiny_input <- i
if(!is.null(s))
private$shiny_session <- s
},
#' @description
#' Retrieve the shiny input.
#' @return Shiny input object.
getShinyInput = function(){
return(private$shiny_input)
},
#' @description
#' Retrieve the shiny output.
#' @return Shiny output object.
getShinyOutput = function(){
return(private$shiny_output)
},
#' @description
#' Retrieve the shiny output.
#' @return Shiny session object.
getShinySession = function(){
return(private$shiny_session)
}
),
private = list(
shared = { e <- new.env(); e$store <- NULL ; e },
shiny_input = NULL,
shiny_output = NULL,
shiny_session = NULL,
initFields = function(){
self$i <- reactiveValues()
self$o <- reactiveValues()
self$port_names <- reactiveValues()
},
sanitizeID = function(id,type){
if(!grepl("[a-z][\\w-]*",id,ignore.case = TRUE,perl = TRUE) ||
grepl('[>~!@\\$%\\^&\\*\\(\\)\\+=,./\';:"\\?><\\[\\]\\\\{}\\|`#]',id,ignore.case = TRUE,perl = TRUE))
stop(paste(paste0("The provided ",type," must begin with a letter `[A-Za-z]` and may be followed by any number of letters, digits `[0-9]`, hyphens `-`, underscores `_`."),
"You should not use the following characters as they have a special meaning on the UI ( CSS / jQuery ).",
"> ~ ! @ $ % ^ & * ( ) + = , . / ' ; : \" ? > < [ ] \ { } | ` #",sep = "\n"))
return(id)
},
countPort = function(type = "input"){
key = ifelse(type == "input", "i" , "o")
return(length(names(self[[key]])))
},
addPort = function(
type = "input",
name = NULL,
description = paste0("Short description for this module's ",type),
sample = NULL,
port = FALSE,
is_parent = FALSE,
inherit = TRUE){
stopifnot(!is.null(name) && !is.null(sample))
rv <- reactiveValues(
name = name,
description = description,
sample = sample,
parent = is_parent,
inherit = inherit
)
p = port
attr(rv,"tidymodules") <- TRUE
attr(rv,"tidymodules_port_def") <- TRUE
attr(rv,"tidymodules_port_type") <- type
attr(rv,"tidymodules_port_id") <- private$countPort(type)+1
attr(rv,"tidymodules_port_name") <- name
attr(rv,"tidymodules_port_description") <- description
attr(rv,"tidymodules_port_sample") <- sample
attr(rv,"tidymodules_is_parent") <- is_parent
attr(rv,"tidymodules_inherit") <- inherit
attr(rv,"tidymodules_module_ns") <- self$module_ns
# Only add attributes to port at definition
if(is.logical(p)){
attr(p,"tidymodules") <- TRUE
attr(p,"tidymodules_port_slot") <- TRUE
attr(p,"tidymodules_port_type") <- type
attr(p,"tidymodules_port_id") <- private$countPort(type)+1
attr(p,"tidymodules_port_name") <- name
attr(p,"tidymodules_port_description") <- description
attr(p,"tidymodules_port_sample") <- sample
attr(p,"tidymodules_is_parent") <- is_parent
attr(p,"tidymodules_inherit") <- inherit
attr(p,"tidymodules_module_ns") <- self$module_ns
}
rv[["port"]] <- p
key = ifelse(type == "input", "i" , "o")
existing_port <- self[[key]][[name]]
if(!is.null(existing_port) && is.reactivevalues(existing_port)){
warning(paste0("Skip adding ",type," port '",name,"' to ",self$module_ns,
" ! Port already defined ",
ifelse(existing_port$parent,
paste0("and inherited from parent ",self$parent_ns),
"!"
)
)
)
}else{
self[[key]][[name]] <- rv
nv <- self$port_names[[type]]
self$port_names[[type]] <- c(nv,name)
}
},
updatePort = function(id = NULL, port = NULL, type = "input"){
stopifnot((!is.null(id)))
if(!is.null(port)){
if(is.reactivevalues(port)){
if(!is.null(attr(port,"tidymodules_operation")) &&
attr(port,"tidymodules_operation") == "combine"){
# We need to modify the combined reactive list here to remove the port sctructure
isolate({
p <- reactiveValues()
for (k in names(port)) {
p[[k]] <- port[[k]]$port
}
port <- p
})
} else if(!is.null(attr(port,"tidymodules_port_def")) &&
attr(port,"tidymodules_port_def")){
port <- port$port
}else{
stop(paste0(deparse(substitute(port))," is reactive list (reactiveValues). Provide a reactive function instead."))
}
}else if(!is.reactive(port)){
stop(paste0(deparse(substitute(port))," is not reactive"))
}
key = ifelse(type == "input", "i" , "o")
if(is.numeric(id)){
if(!id %in% seq(1,private$countPort(type))){
stop(paste0("Port Update Failure: Numeric ",type," port [",id,"] not found in Module definition"))
}else{
id<-self$port_names[[type]][id]
}
}
if(is.character(id) && !id %in% names(self[[key]])){
stop(paste0("Port Update Failure: Character ",type," port [",id,"] not found in Module definition"))
}
# Attach module information to the output port
# This will facilitate storage of module edges
isolate({
# Don't allow update of inherited port
if(self[[key]][[id]][["parent"]])
stop(paste0("Updating ",type," port '",id,"' inherited from parent ",self$parent_ns," is not permitted!"))
attrs <- attributes(self[[key]][[id]][["port"]])
if(type == "output")
for(a in names(attrs))
if(grepl("tidymodules",a))
attr(port,a) <- attrs[[a]]
self[[key]][[id]][["port"]] <- port
})
}
},
updatePorts = function(ports = NULL, type = "input", is_parent = FALSE){
stopifnot(!is.null(ports))
if(!is.reactivevalues(ports))
stop(paste0(deparse(substitute(ports))," is not a reactive list"))
key = ifelse(type == "input", "i" , "o")
isolate({
for(p in names(ports)){
if(p %in% self$port_names[[type]]){
stop(paste0("Adding port name ",p," to module ",self$module_ns," failed, it already exist in ",type," port definition."))
}else{
port <- ports[[p]]
rport <- port$port
# couple of functions for managing inherited ports
getParentReactive <- function(p){
parent_mod_ns <- attr(p,"tidymodules_module_ns")
r <- reactive({
force(p)
force(self)
force(parent_mod_ns)
m <- self$parent_mod
if(!is.null(parent_mod_ns)){
m <- mod(parent_mod_ns)
}else{
warning(paste0("Couldn't find parent module while passing input ports to ",self$module_ns))
}
if(type == "input")
m$getInput(p$name)
else
m$getOutput(p$name)
})
# copy tm attributes
attrs <- attributes(p$port)
for(a in names(attrs))
if(grepl("tidymodules",a))
attr(r,a) <- attrs[[a]]
r
}
if(is_parent)
rport <- getParentReactive(port)
if(!(is_parent && !port$inherit))
private$addPort(
type = type,
name = port$name,
description = port$description,
sample = port$sample,
port = rport,
is_parent = is_parent,
inherit = port$inherit
)
}
}
})
},
get = function(id = 1,type = "input"){
data.port <- private$getPort(id, type)
req(data.port)
return(data.port[["port"]])
},
getPort = function(id = 1,type = "input"){
key = ifelse(type == "input", "i" , "o")
if(private$countPort(type) == 0){
warning(paste0("Module ",self$module_ns," has no ",type," ports"))
return(NULL)
}
if(is.numeric(id)){
if(!id %in% seq(1,private$countPort(type))){
warning(paste0("Numeric ",type," port [",id,"] not found in Module definition"))
return(NULL)
}else{
id<-self$port_names[[type]][id]
}
}
if(is.character(id) && !id %in% names(self[[key]])){
warning(paste0("Character ",type," port [",id,"] not found in Module definition"))
return(NULL)
}
return(self[[key]][[id]])
},
getPorts = function(type = "input"){
key = ifelse(type == "input", "i" , "o")
if(private$countPort(type) == 0)
return(NULL)
return(self[[key]])
},
printPorts = function(type = "input"){
if(private$countPort(type)>0)
for (p in 1:private$countPort(type)) {
port <- private$getPort(p,type)
pport <- NULL
if(port$parent){
if(type == "input")
pport <- self$parent_mod$getInputPort(port$name)
else
pport <- self$parent_mod$getOutputPort(port$name)
}
cat(
paste0("(",p,") ",
ifelse(
port$parent,
"(Inherit) ",
""),
port$name,
" => ",
ifelse(port$parent,
ifelse(is.reactive(pport$port) || pport$port,"OK","Empty"),
ifelse(is.reactive(port$port) || port$port,"OK","Empty")
),
"\n"
)
)
}
},
trimParentNS = function(){
if(!is.null(self$parent_ns)){
return(
sub(
paste0(self$parent_ns,"-"),
"",
self$module_ns
)
)
} else {
return(self$module_ns)
}
}
)
)
xni7/tidymodules documentation built on Dec. 23, 2021, 7:10 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.
#' TidyModule R6 Class, parent of all modules
#'
#' @description
#' This is the main class provided by tidymodules and should be the parent of all tidymodules modules.
#' It provides methods for defining input and output communication ports, managing module namespace and many other useful features.
#'
#' @import R6
#' @import shiny
#'
#' @export
TidyModule <- R6::R6Class(
"TidyModule",
public = list(
#' @field id ID of the module.
id = NULL,
#' @field name Name of the module as generated or provided by the user.
name = NULL,
#' @field module_ns Module namespace, unique identifier for the module.
module_ns = NULL,
#' @field parent_ns Parent module namespace in case of nested modules.
parent_ns = NULL,
#' @field parent_mod Reference to parent module in case of nested modules.
parent_mod = NULL,
#' @field pass_ports logical value indicating if the module should pass its ports to any nested modules. This is initialized with the `inherit` argument of `new()`.
pass_ports = NULL,
#' @field group Group name of the module.
group = NULL,
#' @field created Initialization time of the module.
created = NULL,
#' @field order Initialization order.
order = NULL,
#' @field i reactive list of input ports.
i = NULL,
#' @field o reactive list of output ports.
o = NULL,
#' @field port_names list of input and output port names.
port_names = NULL,
# o = NULL,
# i = NULL,
#' @description
#' Create a new tidymodules module.
#' @param id Unique Id to assign to the module. Default to a generated Id using module's class and order of initialization.
#' @param inherit logical value indicating if a nested module should inherits the parent's input ports. Default to TRUE
#' @param group Module group name. Added to module's Id to make it unique. Optional
#' @return A new `TidyModule` object.
initialize = function(id = NULL, inherit = TRUE, group = NULL) {
#### Initialize ModStore #######
if(is.null(private$shared$store))
private$shared$store <- ModStore$new()
self$pass_ports <- inherit
ses <- self$getSession()
isolate({
ses$count <- ses$count+1
self$order <- ses$count
})
onStop(function(){
# reset session module count and edge table when app stop
ses$count <- 0
ses$edges <- data.frame()
})
self$name <- ifelse(
is.null(id),
paste0(class(self)[[1]],"-",isolate({ses$count }))
,private$sanitizeID(id,"Id"))
if(!is.null(group)){
g <- private$sanitizeID(group,"Group")
self$id <- paste0(g,"-",self$name)
self$group <- g
}else{
self$id <- self$name
}
################# Handle nested module here ################
############### Find and set the parent module #############
# case 1 : nested module directly initialized in attribute definition of parent
# This type of initialization should trigger an error
# Because the parent module need to be initialized first
# TODO : Find a way to prevent this....
# if(class(sys.frame(9)$inherit) == "R6ClassGenerator")
# stop(paste0("Error in definition of module ",sys.frame(9)$classname,
# "! Nested module ",self$id," should be defined either in initialize() or server() of parent!"))
# case 2 :
# for n = 2:3 => nested module initialized in initialze() or server() functions of parent
# for n = 4:10 => same as before but support nested functions or module inheritance
for(n in 2:10){
self$parent_mod<-parent.env(parent.frame(n))$self
if(!is.null(self$parent_mod) && is(self$parent_mod,"TidyModule"))
break
}
#browser()
# case 3 : Dynamically created module in an observe function of server()
if(is.null(self$parent_mod) || !is(self$parent_mod,"TidyModule"))
#self$parent_mod<-parent.env(parent.env(parent.frame(3)))$self
self$parent_mod<-parent.env(parent.env(parent.env(parent.frame(3))))$self
# At the end we save the parent ns & server arguments if any
if(!is.null(self$parent_mod) &&
is(self$parent_mod,"TidyModule")){
self$parent_ns <- self$parent_mod$module_ns
}else{
self$parent_mod <- NULL
}
self$module_ns <- ifelse(
is.null(self$parent_ns),
self$id,
paste0(self$parent_ns,"-",self$id))
#### Capture ShinySession #######
private$shiny_session <- shiny::getDefaultReactiveDomain()
self$created <- Sys.time()
# check that the module namespace is unique in the current session
if(self$isStored() &&
as.character(mod(self$module_ns)$created) == as.character(self$created))
stop(paste0("Module namespace collision!\n",
"Make sure that the namespace Id ",self$module_ns," is only used once."))
private$shared$store$addMod(self)
private$initFields()
# Only transfer parent ports in dynamic mode
# i.e. when the child module is initialized on the server
if(!self$isGlobal() &&
!is.null(self$parent_mod) &&
is(self$parent_mod,"TidyModule") &&
self$pass_ports)
self$parent_mod %:i:% self
},
#' @description
#' namespace function used to generate unique Id for HTML elements.
#' @param id Id of HTML element / shiny input.
#' @return A unique string Id.
ns = function(id){
NS(self$module_ns, id)
},
#' @description
#' Get module session Id. This function rely on a shiny output object to find the right session Id.
#' @return The Session Id of the module.
getSessionId = function(){
return(getSessionId(private$shiny_session))
},
#' @description
#' Alias to the `ui` function.
#' @param ... arguments passed to the ui function.
render = function(...){
self$ui(...)
},
#' @description
#' UI function generating the module HTML elements.
#' This function is eventually implemented in the child module to give the module a visual representation.
#' Please note that a module can have many visual representations.
#' @param ... arguments passed to ui
#' @return Empty tagList()
ui = function(...){
return(tagList())
},
#' @description
#' server function to be overwritten and called by child module.
#' @param input shiny input.
#' @param output shiny output.
#' @param session shiny session.
server = function(input,
output,
session){
# Need to isolate this block to avoid unecessary triggers
isolate({
private$shiny_session <- session
private$shiny_input <- input
private$shiny_output <- output
})
},
#' @description
#' Preview the module in a gadget.
view = function(){
s <- function(input, output, session){
callModules()
self$server(input, output, session)
}
app <- shinyApp(ui = miniUI::miniPage(self$ui()), server = s)
viewer <- dialogViewer(paste0("Preview of ",self$module_ns))
#viewer <- paneViewer(300)
#viewer <- browserViewer()
runGadget(app, viewer = viewer, stopOnCancel = TRUE)
},
#' @description
#' Function wrapper for port definition expression.
#' @param x expression
definePort = function(x){
isolate(x)
},
#' @description
#' Function wrapper for port assignment expression.
#' @param x expression
assignPort = function(x){
# TODO: There must be a better way to do that
# Only add observe in non-reactive context
if(is.null(shiny:::.getReactiveEnvironment()$.currentContext))
observe({
isolate(x)
})
else
isolate(x)
},
#' @description
#' Add input port function. To be called within `definePort` function
#' @param name port name. must be a unique input port name.
#' @param description port description.
#' @param sample sample dataset consumed by this port. Mandatory!
#' @param is_parent Is the port inherited from the parent module.
#' @param inherit Should the port be passed to nested module. default to TRUE.
#' @param input This argument should be ignored. Only here for backward compatibility.
addInputPort = function(
name = NULL,
description = NULL,
sample = NULL,
input = FALSE,
is_parent = FALSE,
inherit = TRUE){
private$addPort(
type = "input",
name = name,
description = description,
sample = sample,
is_parent = is_parent,
inherit = inherit
)
},
#' @description
#' Function for filling an input port.
#' Called within the `assignPort` function
#' @param id Port name or Id .
#' @param input The reacive object.
updateInputPort = function(
id = NULL,
input = NULL){
private$updatePort(id = id,port = input, type = "input")
},
#' @description
#' This function add a set of input ports to the module.
#' @param inputs reactivevalues with the input ports.
#' @param is_parent Are the ports from a parent module. Default to FALSE.
updateInputPorts = function(
inputs = NULL,
is_parent = FALSE){
private$updatePorts(ports = inputs, type = "input", is_parent = is_parent)
},
#' @description
#' Get an input port from the module.
#' @param id Name or Id of the port.
#' @return A module input port. A reactivevalues object with name, description, sample, is_parent and port elements.
getInputPort = function(id = 1){
return(private$getPort(id,"input"))
},
#' @description
#' Alias to the `getInputPort()` function.
#' @param id Name or Id of the port.
#' @return A module input port. A reactivevalues object with name, description, sample, is_parent and port elements.
iport = function(id = 1){
return(self$getInputPort(id))
},
#' @description
#' Get all the input ports as a reactivevalues object.
#' @return A reactivevalues object.
getInputPorts = function(){
return(private$getPorts("input"))
},
#' @description
#' Get a input port slot.
#' @param id Name or Id of the port.
#' @param w boolean to enable module session check. default to TRUE.
#' @return A reactive function.
getInput = function(id = 1, w = TRUE){
if(w && self$isGlobal() && !UtilityModule$new()$isGlobal()){
cmd <- paste0('mod("',self$module_ns,'")$getInput(',ifelse(is.character(id),paste0('"',id,'"'),id),')')
warning(paste(
"You are trying to access a global session module port from a user session.",
"Is this intended? If not, use the code below instead.",
cmd, sep= "\n"))
}
r <- private$get(id)
# special handling for inherited input ports
# since they are wraped in a reactive
if(private$getPort(id)$parent)
r <- r()
return(r)
},
#' @description
#' Execute an input port slot, that is, the reactive function stored in the port.
#' The `require` argument which is `TRUE` by default allows you disable checking if the port is Truthy.
#' See `shiny::req` function.
#' @param id Name or Id of the port.
#' @param require Check that the port is available.
#' @return Output of the reacive function execution.
execInput = function(id = 1, require = TRUE){
mod <- getMod(self$module_ns)
r <- mod$getInput(id)
if(require)
req(r)
return(r())
},
#' @description
#' Function for filling an output port.
#' Called within the `assignPort` function
#' @param id Port name or Id .
#' @param output The reacive object.
updateOutputPort = function(
id = NULL,
output = NULL){
private$updatePort(id = id,port = output, type = "output")
},
#' @description
#' This function add a set of output ports to the module.
#' @param outputs reactivevalues with the output ports.
#' @param is_parent Are the ports from a parent module. Default to FALSE.
updateOutputPorts = function(
outputs = NULL,
is_parent = FALSE){
private$updatePorts(ports = outputs, type = "output", is_parent = is_parent)
},
#' @description
#' Add output port function. To be called within `definePort` function
#' @param name port name. must be a unique output port name.
#' @param description port description.
#' @param sample sample dataset returned by this port. Mandatory!
#' @param is_parent Is the port inherited from the parent module.
#' @param output This argument should be ignored. Only here for backward compatibility.
addOutputPort = function(
name = NULL,
description = NULL,
sample = NULL,
output = FALSE,
is_parent = FALSE){
private$addPort(
type = "output",
name = name,
description = description,
sample = sample,
is_parent = is_parent
)
},
#' @description
#' Utility function that returns a port name from the Id.
#' @param id Port Id
#' @param type Port type, input or output.
#' @return Port name.
getPortName = function(id = NULL, type = "input"){
port <- private$getPort(id,type)
return(port$name)
},
#' @description
#' Get an output port from the module.
#' @param id Name or Id of the port.
#' @return A module output port. A reactivevalues object with name, description, sample, is_parent and port elements.
getOutputPort = function(id = 1){
return(private$getPort(id,"output"))
},
#' @description
#' Alias to the `getOutputPort()` function.
#' @param id Name or Id of the port.
#' @return A module output port. A reactivevalues object with name, description, sample, is_parent and port elements.
oport = function(id = 1){
return(self$getOutputPort(id))
},
#' @description
#' Get all the output ports as a reactivevalues object.
#' @return A reactivevalues object.
getOutputPorts = function(){
return(private$getPorts("output"))
},
#' @description
#' Get a output port slot.
#' @param id Name or Id of the port.
#' @param w boolean to enable module session check. default to TRUE.
#' @return A reactive function.
getOutput = function(id = 1, w = TRUE){
if(w && self$isGlobal() && !UtilityModule$new()$isGlobal()){
cmd <- paste0('mod("',self$module_ns,'")$getOutput(',ifelse(is.character(id),paste0('"',id,'"'),id),')')
warning(paste(
"You are trying to access a global session module port from a user session.",
"Is this intended? If not, use the code below instead.",
cmd, sep= "\n"))
}
return(private$get(id, "output"))
},
#' @description
#' Execute an output port slot, that is, the reactive function stored in the port.
#' The `require` argument which is `TRUE` by default allows you disable checking if the port is Truthy.
#' See `shiny::req` function.
#' @param id Name or Id of the port.
#' @param require Check that the port is available.
#' @return Output of the reacive function execution.
execOutput = function(id = 1, require = TRUE){
mod <- getMod(self$module_ns)
r <- mod$getOutput(id)
if(require)
req(r)
return(r())
},
#' @description
#' Function for retrieving the central ModStore.
#' @return The `ModStore` object.
getStore = function(){
return(private$shared$store)
},
#' @description
#' Utility function that counts the number of input ports.
#' @return The input ports count.
countInputPort = function(){
return(private$countPort("input"))
},
#' @description
#' Utility function that counts the number of output ports.
#' @return The output ports count.
countOutputPort = function(){
return(private$countPort("output"))
},
#' @description
#' Alias to the `callModule` function.
#' @param ... arguments passed to the `server` function of the module.
use = function(...){
self$callModule(...)
},
#' @description
#' callModule function. Similar to shiny callModule. Used to inject the server logic into the application.
#' This function don't need the user to provide a namespace Id as a module already knows its identity.
#' Options provided as arguments will be passed to the server function of the module.
#' Note that the module reference `self` might not be the one injected.
#' @param ... arguments passed to the `server` function of the module.
callModule = function(...){
# arguments from server environment
output <- parent.frame()$output
input <- parent.frame()$output
session <- parent.frame()$session
if(is.null(session))
session <- shiny::getDefaultReactiveDomain()
disable_cache <- getCacheOption()
if(!self$isGlobal()){
self$doServer(...)
}else{
isolate({
currentSession <- UtilityModule$new()$getSession()
globalSession <- UtilityModule$new()$getGlobalSession()
# currentSession <- mod$getSession()
# globalSession <- self$getGlobalSession()
currentSession$edges <- data.frame()
currentSession$count <- globalSession$count
cloneMod <- is.null(currentSession$collection[[self$module_ns]])
})
if(cloneMod || disable_cache){
mod <- self$deepClone(output,input,session)
mod$doServer(...)
}else{
getMod(self$module_ns)$doServer(...)
}
}
},
#' @description
#' Function to check if the module is store in the current session.
#' @return logical value.
isStored = function(){
return(self$getStore()$isStored(self))
},
#' @description
#' Check if the session attached to the module is the `global_session`.
#' @return logical value.
isGlobal = function(){
if(self$getSessionId() == "global_session")
return(TRUE)
else
return(FALSE)
},
#' @description
#' Get the current session.
#' @return A reactivevalues object with the following elements.
#' aid = application Id
#' path = application path
#' sid = session Id
#' count = current module count
#' created = session creation time
#' updated = session update time
#' collection = list of session modules
#' edges = list of connection edges
getSession = function(){
return(self$getStore()$getSession(self))
},
#' @description
#' Get the global session.
#' @return A reactivevalues object with the following elements.
#' aid = application Id
#' path = application path
#' sid = "global_session"
#' count = session module count
#' created = session creation time
#' updated = session update time
#' collection = list of session modules
#' edges = empty data.frame
getGlobalSession = function(){
return(self$getStore()$getGlobalSession())
},
#' @description
#' Function interfacing with shiny's callModule.
#' @param ... arguments passed to the `server` function of the module.
doServer = function(...){
callModule(self$server,self$id,...)
},
#' @description
#' Utility function to retrieve a port definition in the form of a list.
#' This is a useful function to learn about a specific port.
#' @param type Port type, input or output.
#' @param id Name or Id of port.
#' @return List of the port definition.
getPortDef = function(type = NULL, id = 1){
port <- NULL
if(is.null(type) || !type %in% c("input","output"))
stop("type must be one of input/output")
isolate({
port <- private$getPort(id,type)
reactiveValuesToList(port)
})
},
#' @description
#' Module printing function.
#' Print the structure of a module.
#' @examples
#' MyModule <- R6::R6Class("MyModule", inherit = tidymodules::TidyModule)
#' m <- MyModule$new()
#' m
print = function(){
isolate({
cat(paste0("Module Namespace ",self$module_ns,"\n"))
if(!is.null(self$group))
cat(paste0("Module Group ",self$group,"\n"))
cat(paste0("Module Session ",self$getSessionId(),"\n"))
cat(paste0("- Class ",paste0(class(self),collapse = " << "),"\n"))
cat(paste0("- Input [",self$countInputPort(),"]\n"))
private$printPorts("input")
cat(paste0("- Output [",self$countOutputPort(),"]\n"))
private$printPorts("output")
})
},
#' @description
#' Module cloning function.
#' Take care of ports (cloning reactive objects) and nested modules.
#' Note that the Ids/namespace are not changed.
#' @param o Optional shiny output.
#' @param i Optional shiny input
#' @param s Optional shiny input
#' @return A cloned module.
deepClone = function(o = NULL, i = NULL, s = NULL){
isolate({
copy <- self$clone()
copy$reset(o,i,s)
for(type in c("input","output")){
if(private$countPort(type) > 0)
for(idx in 1:private$countPort(type)){
po <- private$getPort(idx,type)
# Don't add port inherited from parent module
# They will be added by parent, see below...
if(po$parent)
next
if(type == "input")
copy$addInputPort(
name = po$name,
description = po$description,
sample = po$sample,
inherit = po$inherit)
else
copy$addOutputPort(
name = po$name,
description = po$description,
sample = po$sample)
}
}
copy$created <- Sys.time()
self$getStore()$addMod(copy)
# Now deep clone the module attributes (also check list) that are TidyModules, i.e. nested modules
for(at in names(self)){
if(is(self[[at]],"TidyModule") &&
at != "parent_mod"){ # When module attribute is a nested module
copy[[at]] <- self[[at]]$deepClone(o,i,s)
copy[[at]]$parent_mod <- copy
self$getStore()$addMod(copy[[at]])
# Now add ports to child if any
if(copy[[at]]$pass_ports)
copy %:i:% copy[[at]]
} else if(is.list(self[[at]]) &&
length(copy[[at]]) > 0 &&
!at %in% c("port_names","i","o")){ # Check list for modules
l <- self[[at]]
for(k in 1:length(l)){
if(is(l[[k]],"TidyModule")){
l[[k]] <- l[[k]]$deepClone(o,i,s)
l[[k]]$parent_mod <- copy
self$getStore()$addMod(l[[k]])
# Now add ports to child if any
if(l[[k]]$pass_ports)
copy %:i:% l[[k]]
}
}
copy[[at]] <- l
}
}
})
return(copy)
},
#' @description
#' This function reset the ports.
#' @param o Optional shiny output.
#' @param i Optional shiny input
#' @param s Optional shiny input
reset = function(o = NULL, i = NULL, s = NULL){
private$initFields()
if(!is.null(o))
private$shiny_output <- o
if(!is.null(i))
private$shiny_input <- i
if(!is.null(s))
private$shiny_session <- s
},
#' @description
#' Retrieve the shiny input.
#' @return Shiny input object.
getShinyInput = function(){
return(private$shiny_input)
},
#' @description
#' Retrieve the shiny output.
#' @return Shiny output object.
getShinyOutput = function(){
return(private$shiny_output)
},
#' @description
#' Retrieve the shiny output.
#' @return Shiny session object.
getShinySession = function(){
return(private$shiny_session)
}
),
private = list(
shared = { e <- new.env(); e$store <- NULL ; e },
shiny_input = NULL,
shiny_output = NULL,
shiny_session = NULL,
initFields = function(){
self$i <- reactiveValues()
self$o <- reactiveValues()
self$port_names <- reactiveValues()
},
sanitizeID = function(id,type){
if(!grepl("[a-z][\\w-]*",id,ignore.case = TRUE,perl = TRUE) ||
grepl('[>~!@\\$%\\^&\\*\\(\\)\\+=,./\';:"\\?><\\[\\]\\\\{}\\|`#]',id,ignore.case = TRUE,perl = TRUE))
stop(paste(paste0("The provided ",type," must begin with a letter `[A-Za-z]` and may be followed by any number of letters, digits `[0-9]`, hyphens `-`, underscores `_`."),
"You should not use the following characters as they have a special meaning on the UI ( CSS / jQuery ).",
"> ~ ! @ $ % ^ & * ( ) + = , . / ' ; : \" ? > < [ ] \ { } | ` #",sep = "\n"))
return(id)
},
countPort = function(type = "input"){
key = ifelse(type == "input", "i" , "o")
return(length(names(self[[key]])))
},
addPort = function(
type = "input",
name = NULL,
description = paste0("Short description for this module's ",type),
sample = NULL,
port = FALSE,
is_parent = FALSE,
inherit = TRUE){
stopifnot(!is.null(name) && !is.null(sample))
rv <- reactiveValues(
name = name,
description = description,
sample = sample,
parent = is_parent,
inherit = inherit
)
p = port
attr(rv,"tidymodules") <- TRUE
attr(rv,"tidymodules_port_def") <- TRUE
attr(rv,"tidymodules_port_type") <- type
attr(rv,"tidymodules_port_id") <- private$countPort(type)+1
attr(rv,"tidymodules_port_name") <- name
attr(rv,"tidymodules_port_description") <- description
attr(rv,"tidymodules_port_sample") <- sample
attr(rv,"tidymodules_is_parent") <- is_parent
attr(rv,"tidymodules_inherit") <- inherit
attr(rv,"tidymodules_module_ns") <- self$module_ns
# Only add attributes to port at definition
if(is.logical(p)){
attr(p,"tidymodules") <- TRUE
attr(p,"tidymodules_port_slot") <- TRUE
attr(p,"tidymodules_port_type") <- type
attr(p,"tidymodules_port_id") <- private$countPort(type)+1
attr(p,"tidymodules_port_name") <- name
attr(p,"tidymodules_port_description") <- description
attr(p,"tidymodules_port_sample") <- sample
attr(p,"tidymodules_is_parent") <- is_parent
attr(p,"tidymodules_inherit") <- inherit
attr(p,"tidymodules_module_ns") <- self$module_ns
}
rv[["port"]] <- p
key = ifelse(type == "input", "i" , "o")
existing_port <- self[[key]][[name]]
if(!is.null(existing_port) && is.reactivevalues(existing_port)){
warning(paste0("Skip adding ",type," port '",name,"' to ",self$module_ns,
" ! Port already defined ",
ifelse(existing_port$parent,
paste0("and inherited from parent ",self$parent_ns),
"!"
)
)
)
}else{
self[[key]][[name]] <- rv
nv <- self$port_names[[type]]
self$port_names[[type]] <- c(nv,name)
}
},
updatePort = function(id = NULL, port = NULL, type = "input"){
stopifnot((!is.null(id)))
if(!is.null(port)){
if(is.reactivevalues(port)){
if(!is.null(attr(port,"tidymodules_operation")) &&
attr(port,"tidymodules_operation") == "combine"){
# We need to modify the combined reactive list here to remove the port sctructure
isolate({
p <- reactiveValues()
for (k in names(port)) {
p[[k]] <- port[[k]]$port
}
port <- p
})
} else if(!is.null(attr(port,"tidymodules_port_def")) &&
attr(port,"tidymodules_port_def")){
port <- port$port
}else{
stop(paste0(deparse(substitute(port))," is reactive list (reactiveValues). Provide a reactive function instead."))
}
}else if(!is.reactive(port)){
stop(paste0(deparse(substitute(port))," is not reactive"))
}
key = ifelse(type == "input", "i" , "o")
if(is.numeric(id)){
if(!id %in% seq(1,private$countPort(type))){
stop(paste0("Port Update Failure: Numeric ",type," port [",id,"] not found in Module definition"))
}else{
id<-self$port_names[[type]][id]
}
}
if(is.character(id) && !id %in% names(self[[key]])){
stop(paste0("Port Update Failure: Character ",type," port [",id,"] not found in Module definition"))
}
# Attach module information to the output port
# This will facilitate storage of module edges
isolate({
# Don't allow update of inherited port
if(self[[key]][[id]][["parent"]])
stop(paste0("Updating ",type," port '",id,"' inherited from parent ",self$parent_ns," is not permitted!"))
attrs <- attributes(self[[key]][[id]][["port"]])
if(type == "output")
for(a in names(attrs))
if(grepl("tidymodules",a))
attr(port,a) <- attrs[[a]]
self[[key]][[id]][["port"]] <- port
})
}
},
updatePorts = function(ports = NULL, type = "input", is_parent = FALSE){
stopifnot(!is.null(ports))
if(!is.reactivevalues(ports))
stop(paste0(deparse(substitute(ports))," is not a reactive list"))
key = ifelse(type == "input", "i" , "o")
isolate({
for(p in names(ports)){
if(p %in% self$port_names[[type]]){
stop(paste0("Adding port name ",p," to module ",self$module_ns," failed, it already exist in ",type," port definition."))
}else{
port <- ports[[p]]
rport <- port$port
# couple of functions for managing inherited ports
getParentReactive <- function(p){
parent_mod_ns <- attr(p,"tidymodules_module_ns")
r <- reactive({
force(p)
force(self)
force(parent_mod_ns)
m <- self$parent_mod
if(!is.null(parent_mod_ns)){
m <- mod(parent_mod_ns)
}else{
warning(paste0("Couldn't find parent module while passing input ports to ",self$module_ns))
}
if(type == "input")
m$getInput(p$name)
else
m$getOutput(p$name)
})
# copy tm attributes
attrs <- attributes(p$port)
for(a in names(attrs))
if(grepl("tidymodules",a))
attr(r,a) <- attrs[[a]]
r
}
if(is_parent)
rport <- getParentReactive(port)
if(!(is_parent && !port$inherit))
private$addPort(
type = type,
name = port$name,
description = port$description,
sample = port$sample,
port = rport,
is_parent = is_parent,
inherit = port$inherit
)
}
}
})
},
get = function(id = 1,type = "input"){
data.port <- private$getPort(id, type)
req(data.port)
return(data.port[["port"]])
},
getPort = function(id = 1,type = "input"){
key = ifelse(type == "input", "i" , "o")
if(private$countPort(type) == 0){
warning(paste0("Module ",self$module_ns," has no ",type," ports"))
return(NULL)
}
if(is.numeric(id)){
if(!id %in% seq(1,private$countPort(type))){
warning(paste0("Numeric ",type," port [",id,"] not found in Module definition"))
return(NULL)
}else{
id<-self$port_names[[type]][id]
}
}
if(is.character(id) && !id %in% names(self[[key]])){
warning(paste0("Character ",type," port [",id,"] not found in Module definition"))
return(NULL)
}
return(self[[key]][[id]])
},
getPorts = function(type = "input"){
key = ifelse(type == "input", "i" , "o")
if(private$countPort(type) == 0)
return(NULL)
return(self[[key]])
},
printPorts = function(type = "input"){
if(private$countPort(type)>0)
for (p in 1:private$countPort(type)) {
port <- private$getPort(p,type)
pport <- NULL
if(port$parent){
if(type == "input")
pport <- self$parent_mod$getInputPort(port$name)
else
pport <- self$parent_mod$getOutputPort(port$name)
}
cat(
paste0("(",p,") ",
ifelse(
port$parent,
"(Inherit) ",
""),
port$name,
" => ",
ifelse(port$parent,
ifelse(is.reactive(pport$port) || pport$port,"OK","Empty"),
ifelse(is.reactive(port$port) || port$port,"OK","Empty")
),
"\n"
)
)
}
},
trimParentNS = function(){
if(!is.null(self$parent_ns)){
return(
sub(
paste0(self$parent_ns,"-"),
"",
self$module_ns
)
)
} else {
return(self$module_ns)
}
}
)
)
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.