R/ModStore.R

In xni7/tidymodules: A robust framework for developing shiny modules

#' R6 Class Representing a ModStore
#'
#' @description
#' This class is used to create a storage for tidymodules objects.
#'
#' @details
#' Manage applications, sessions and modules.
#' 
#' @import shiny
#' 
#' @export
ModStore <- R6::R6Class(
  "ModStore",
  public = list(
    #' @description
    #' Create a new ModStore object.
    #' Should be called once by the TidyModule class.
    #' Not to be called directly outside TidyModule.
    #' The ModStore object can be retrieved from any TidyModule object, see example below.
    #' @examples
    #' MyModule <- R6::R6Class("MyModule", inherit = tidymodules::TidyModule)
    #' m <- MyModule$new()
    #' s <- m$getStore()
    #' @return A new `ModStore` object.
    initialize = function() {},
    #' @description
    #' Check if a module is stored in the current session.
    #' @param m TidyModule object.
    #' @examples
    #' MyModule <- R6::R6Class("MyModule", inherit = tidymodules::TidyModule)
    #' m <- MyModule$new()
    #' s <- m$getStore()
    #' s$isStored(m)
    isStored = function(m){
      s <- self$getSession(m)
      mod <- isolate(s$collection[[m$module_ns]])
      if(is.null(mod))
        return(FALSE)
      else
        return(TRUE)
    },
    #' @description
    #' Retrieve the global session 'global_session'.
    #' This is the session that exists outside the application server function 
    getGlobalSession = function(){
      sid <- "global_session"
      self$getSession(sid)
    },
    #' @description
    #' Retrieve a module session.
    #' This could be the global session or a user session.
    #' @param m TidyModule object.
    getSession = function(m){
      isolate({
        return(private$getS(m))
      })
    },
    #' @description
    #' Retrieve all sessions.
    getSessions = function(){
      return(private$sessions)
    },
    #' @description
    #' Retrieve all modules.
    #' @param m TidyModule object.
    getMods = function(m){
      s <- self$getSession(m)
      return(s$collection)
    },
    #' @description
    #' Retrieve modules connections.
    #' @param m TidyModule object.
    getEdges = function(m){
      s <- self$getSession(m)
      return(s$edges)
    },
    #' @description
    #' Add modules connections into ModStore.
    #' An edge is either a connection between a reactive object and a module 
    #' or between two modules.
    #' @param from list with three elements: m -> module, type -> input or output, port -> port Id.
    #' @param to list with three elements: m -> module, type -> input or output, port -> port Id.
    #' @param mode The type of edge, default to 'direct'.
    #' @param comment Any additional comment.
    addEdge = function(from,
                       to,
                       mode = "direct", 
                       comment = NA){
      
      
      fromId <- fname <- fport <- ftype <- fclass <- NA
      toId   <- tname <- tport <- ttype <- tclass <- NA
      s <- e <- d <- NULL
      
      isolate({
        
        if(is(to$m,"TidyModule")){
          s <- to$m$getSession()
          e <- self$getEdges(to$m)
          
          toId  <- to$m$module_ns
          tport   <- to$port
          tname   <- to$m$getPortName(to$port,to$type)
          ttype   <- to$type
          tclass  <- "TidyModule"
        }
        
        if(is(from$m,"TidyModule")){
          if(is.null(s)){
            s <- from$m$getSession()
            e <- self$getEdges(from$m)
          }
          
          fromId  <- from$m$module_ns
          fport   <- from$port
          fname   <- from$m$getPortName(from$port,from$type)
          ftype   <- from$type
          fclass  <- "TidyModule"
        
        # Handle tidymodules derived ports    
        }else if(!is.null(attr(from$m,"tidymodules")) &&
           attr(from$m,"tidymodules")){
          mod <- attr(from$m,"tidymodules_operation")
          if(!is.null(mod) && mod == "combine"){
            mode <- mod
            combinedPorts <- reactiveValuesToList(from$m)
            for(key in names(combinedPorts)){
              f <- combinedPorts[[key]]
              comment <- key
              fromId <- attr(f,"tidymodules_module_ns")
              fport <- attr(f,"tidymodules_port_id")
              ftype <- attr(f,"tidymodules_port_type")
              fname <- attr(f,"tidymodules_port_name")
              fclass  <- "TidyModule"
              
              comb_row <- data.frame(
                from  = fromId,
                fclass = fclass,
                fport = fport,
                ftype = ftype,
                fname = fname,
                to    = toId,
                tclass = tclass,
                tport = tport,
                ttype = ttype,
                tname = tname,
                mode  = mode,
                comment = comment
              )
              
              if(is.null(d))
                d <- comb_row
              else
                d <- rbind(d,comb_row)
            }
          }else{
            fromId <- attr(from$m,"tidymodules_module_ns")
            fport <- attr(from$m,"tidymodules_port_id")
            ftype <- attr(from$m,"tidymodules_port_type")
            fname <- attr(from$m,"tidymodules_port_name")
            fclass  <- "TidyModule"
          }
        }else if(is.reactive(from$m)){
          fromId <- attr(from$m,"observable")$.reactId
          comment <- attr(from$m,"observable")$.label
          # support for previous shiny version that don't have reactId (don't work with shiny 1.0.5)
          if(is.null(fromId))
            fromId <- comment
          fclass <- "reactive"
        }else{
          stop("Unknown 'from' entity in addEdge function ",class(from$m),"/n")
        }
        
        if(is.null(d))
          d <- data.frame(
            from  = fromId,
            fclass = fclass,
            fport = fport,
            ftype = ftype,
            fname = fname,
            to    = toId,
            tclass = tclass,
            tport = tport,
            ttype = ttype,
            tname = tname,
            mode  = mode,
            comment = comment,
            stringsAsFactors = FALSE
          )
        
        if(is.null(s) || s$sid == "global_session")
          stop("addEdge function error! Module has no session or session is global [",s$sid,"]")
        
        # track update time
        s$updated = Sys.time()
        
        if(length(s$edges)==0){
          s$edges <- d
        }else{
          key <- paste0(as.character(d[1,]),collapse = "|")
          keys <- apply(e,1,paste0,collapse = "|")
          if(key %in% keys)
            warning(paste0("Module mapping already exist!\n",key))
          else
            s$edges <- rbind(e,d)
        }
      })
    },
    #' @description
    #' Add module into the ModStore.
    #' @param m TidyModule object.
    addMod = function(m){
      isolate({
        s <- private$getS(m)
        ns <- as.character(m$module_ns)
        
        # if(!is.null(s$collection[[ns]]))
        #   stop(paste0("Module namespace ",ns," already stored!"))
        s$collection[[ns]] <- m
        if(!is.null(m$group)){
          g <- as.character(m$group)
          if(is.null(s$g_collection[[g]]))
            s$g_collection[[g]] <- list()
          s$g_collection[[g]][[ns]] <- m
        }
        if(!is.null(m$parent_ns)){
          p <- as.character(m$parent_ns)
          if(is.null(s$n_collection[[p]]))
            s$n_collection[[p]] <- list()
          s$n_collection[[p]][[ns]] <- m
        }
        # track update time
        s$updated = Sys.time()
        # TODO : Do we really need this line below ?  
        s$ns <- c(s$ns, as.character(m$module_ns))
      })
    },
    #' @description
    #' Delete a module from the ModStore.
    #' @param m TidyModule object.
    delMod = function(m){
      # TODO : Implement this function 
    },
    #' @description
    #' Print the ModStore object.
    print = function(){
      aid <- private$getAID()
      isolate({
        str(private$sessions[[aid]]$global_session$collection)
      })
    }
  ),
  private = list(
    sessions = reactiveValues(),
    sessionExist = function(sid){
      aid <- private$getAID()
      return(
        !is.null(private$sessions[[aid]]) &&
          !is.null(private$sessions[[aid]][[sid]])
      )
    },
    addSession = function(sid){
      aid <- private$getAID()
      if(is.null(private$sessions[[aid]])){
        private$sessions[[aid]] <- reactiveValues()
      }
      
      if(is.null(private$sessions[[aid]][[sid]])){
        private$sessions[[aid]][[sid]] <- reactiveValues(
          aid = aid,
          path = getwd(),
          sid = sid,
          count = 0,
          created = Sys.time(),
          updated = Sys.time(),
          collection = list(),
          ns = c(),
          edges = data.frame()
        )
      }else{ FALSE }
    },
    getS = function(m){
      sid <- m
      if(is(m,"TidyModule"))
        sid <-  m$getSessionId()
      aid <- private$getAID()
      if(!private$sessionExist(sid))
        private$addSession(sid)
      return(private$sessions[[aid]][[sid]])
    },
    getAID = function(){
      return(digest::digest(getwd(),algo = "md5"))
    }
  )
)