Required classes for our style of building/running shiny applications (no documentation)

DESCRIPTION

@@ -9,3 +9,10 @@ License: GPL (>= 3)
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.3.3
+Imports: 
+    R6,
+    rlang,
+    shiny
+Suggests: 
+    AVSDevR.DBClient,
+    AVSDevR.ShinyDisconnectHandler

NAMESPACE

@@ -1,2 +1,14 @@
 # Generated by roxygen2: do not edit by hand
 
+export(AdminLTEApplication)
+export(FrameApplication)
+export(SessionLogger)
+export(SessionLoggerConsole)
+export(SessionLoggerDB)
+export(UFApplication)
+export(UFDashboardApplication)
+export(UFFrameApplication)
+import(R6)
+import(rlang)
+import(shiny)
+importFrom(R6,R6Class)

R/aaa.R

@@ -0,0 +1,5 @@
+#' @importFrom R6 R6Class
+#' @import R6
+#' @import rlang
+#' @import shiny
+NULL

R/adminLTEApplication.R

@@ -0,0 +1,31 @@
+
+#' @export
+AdminLTEApplication <- R6::R6Class(
+  "AdminLTEApplication",
+  inherit = FrameApplication,
+  public = list(
+    withSkin = function(skin) {
+      private$skin <- skin
+      invisible(self)
+    },
+    frameUI = function() {
+      super$ui()
+    },
+    ui = function() {
+      ui <- shiny::tags$body(
+        class = paste0("hold-transition skin-", private$skin),
+        `data-skin` = private$skin,
+        style = "min-height: 611px; padding-top: 20px",
+        shinydashboardPlus:::addDeps(
+          super$ui(),
+          md = FALSE,
+          options = NULL
+        )
+      )
+      shiny:::setLang(ui, private$language)
+    }
+  ),
+  private = list(
+    skin = "blue"
+  )
+)

R/frameApplication.R

@@ -0,0 +1,143 @@
+
+#' @export
+FrameApplication <- R6::R6Class(
+  "FrameApplication",
+  public = list(
+    initialize = function(appPage = NULL, language = NULL) {
+      if (!is.null(appPage)) {
+        private$appPage <- appPage
+      } else {
+        private$appPage <- modules::use("pages/application.R")
+      }
+      if (!is.null(language)) {
+        private$language <- language
+      }
+      invisible(self)
+    },
+    withSessionLogger = function(sessionLogger) {
+      if (!inherits(sessionLogger, "SessionLogger")) {
+        rlang::abort("sessionLogger is not an instance of SessionLogger class")
+      }
+      private$sessionLogger <- sessionLogger
+      invisible(self)
+    },
+    withBootstrap4Shim = function() {
+      private$withBS4 <- TRUE
+      invisible(self)
+    },
+    getSessionDBClient = function(
+      session, db_config = NULL, allowFailure = FALSE
+    ) {
+      # Check DBClient package is installed
+      if (!rlang::is_installed("AVSDevR.DBClient")) {
+        return(NULL)
+      }
+
+      # Check connection configuration is available
+      db_conn <- AVSDevR.DBClient::DBConnection$new()
+      if (is.null(db_config)) {
+        if (!db_conn$loadConfiguration(TRUE)) {
+          return(NULL)
+        }
+      } else {
+        db_conn$configure(db_config)
+      }
+
+      # Try and connect
+      if (!db_conn$connect()) {
+        if (allowFailure) {
+          rlang::abort(
+            "Failed to connect to database - database not available or not \
+            created"
+          )
+        }
+        return(NULL)
+      }
+      db_conn$disconnectOnSessionEnd(session)
+
+      # Create the client instance
+      AVSDevR.DBClient::DBClient$new(db_conn)
+    },
+    ui = function() {
+      if (file.exists("widgets/menu.R")) {
+        # Multi-frame application
+        frame <- do.call(tabItems, private$appPage$tabs("application"))
+        frame_tabs <- sapply(frame$children, function(tab) {
+          tab$attr$`data-tabName`
+        })
+
+        menu <- modules::use("widgets/menu.R")
+        menu_tabs <- unname(sapply(
+          menu$ui, function(ti) {
+            ti$children[[1]]$attr$`data-value`
+          }
+        ))
+
+        if (!identical(sort(menu_tabs), sort(frame_tabs))) {
+          rlang::abort(
+            "Tab names in widgets/menu.R do not match tab names in \
+            pages/application.R!"
+          )
+        }
+      } else {
+        # Single frame application
+        frame <- shiny::fluidPage(
+          title = private$appPage$title(),
+          private$appPage$ui("application")
+        )
+      }
+
+      ui <- shiny::tagList(
+        shiny::tags$head(
+          shiny::singleton(
+            shinyjs::useShinyjs(debug = getOption("debug.shinyjs", FALSE))
+          )
+        ),
+        frame,
+        if (rlang::is_installed("AVSDevR.ShinyDisconnectHandler")) {
+          AVSDevR.ShinyDisconnectHandler::useBannerDisconnectHandler()
+        }
+      )
+
+      if (private$withBS4) {
+        # Attach boostrap 4 css shim
+        if (getOption("shiny.minified", TRUE)) {
+          css <- "bootstrap-4-shim.min.css"
+        } else {
+          css <- "bootstrap-4-shim.css"
+        }
+        uiDeps <- htmltools::htmlDependency(
+          "AVSDevR.ShinyApplication",
+          as.character(utils::packageVersion("AVSDevR.ShinyApplication")),
+          c(file = system.file(package = "AVSDevR.ShinyApplication")),
+          stylesheet = css
+        )
+        ui <- htmltools::attachDependencies(ui, uiDeps)
+      }
+
+      # Set the language
+      shiny:::setLang(ui, private$language)
+    },
+    server = function(input, output, session, ...) {
+      if (!is.null(private$sessionLogger)) {
+        private$sessionLogger$attachSession(session)
+      }
+
+      shiny::callModule(
+        private$appPage$server,
+        "application",
+        db_client = self$getSessionDBClient(session),
+        ...
+      )
+    },
+    app = function() {
+      shiny::shinyApp(self$ui(), self$server)
+    }
+  ),
+  private = list(
+    appPage = NULL,
+    language = "en",
+    sessionLogger = NULL,
+    withBS4 = FALSE
+  )
+)

R/sessionLogger.R

@@ -0,0 +1,128 @@
+#' @export
+SessionLogger <- R6::R6Class(
+  "SessionLogger",
+  public = list(
+    wrap = function(app) {
+      wrapped_server <- function(input, output, session, ...) {
+        self$attachSession(session)
+        app$serverFuncSource()(input, output, session, ...)
+      }
+
+      app$serverFuncSource <- function() {
+        wrapped_server
+      }
+
+      app
+    },
+    attachSession = function(session) {
+      private$onSessionStarted(session)
+      session$onSessionEnded(function() {
+        private$onSessionEnded(session)
+      })
+    }
+  ),
+  private = list(
+    getClientIp = function(session) {
+      if ("HTTP_X_REAL_IP" %in% names(session$request)) {
+        if (getOption("debug", FALSE)) {
+          cat("Using client IP from HTTP_X_REAL_IP\n")
+        }
+        client_ip <- session$request$HTTP_X_REAL_IP
+      } else if ("HTTP_X_FORWARDED_FOR" %in% names(session$request)) {
+        if (getOption("debug", FALSE)) {
+          cat("Using client IP from HTTP_X_FORWARDED_FOR\n")
+        }
+        client_ip <- strsplit(session$request$HTTP_X_FORWARDED_FOR, ",")[[1]][[1]]
+      } else if ("REMOTE_ADDR" %in% names(session$request)) {
+        if (getOption("debug", FALSE)) {
+          cat("Using client IP from REMOTE_ADDR\n")
+        }
+        client_ip <- session$request$REMOTE_ADDR
+      } else {
+        if (getOption("debug", FALSE)) {
+          cat("Warning: No client IP found\n")
+        }
+        client_ip <- "x.x.x.x"
+      }
+    },
+
+    onSessionStarted = function(session) {
+      private$logSessionEvent("session_started", session)
+    },
+
+    onSessionEnded = function(session) {
+      private$logSessionEvent("session_ended", session)
+    },
+
+    logSessionEvent = function(
+      event, session = shiny::getDefaultReactiveDomain()
+    ) {
+    }
+  )
+)
+
+#' @export
+SessionLoggerConsole <- R6::R6Class(
+  "SessionLoggerConsole",
+  inherit = SessionLogger,
+  public = list(),
+  private = list(
+    logSessionEvent = function(
+      event, session = shiny::getDefaultReactiveDomain()
+    ) {
+      event_row <- tibble::tibble(
+        app_name = basename(getwd()),
+        app_pid = Sys.getpid(),
+        client_ip = private$getClientIp(session),
+        user_id = session$userData$user_id,
+        session_token = session$token,
+        !!event := lubridate::now()
+      )
+
+      # nolint start: line_length_linter
+      cat("~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n")
+      dplyr::glimpse(event_row)
+      cat("~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n")
+      # nolint end
+    }
+  )
+)
+
+#' @export
+SessionLoggerDB <- R6::R6Class(
+  "SessionLoggerDB",
+  inherit = SessionLogger,
+  public = list(
+    initialize = function(db_client) {
+      if (is.null(conn) || !R6::is.R6(conn) || !inherits(conn, "DBClient")) {
+        stop("DBClient instance required!")
+      }
+      private$db_client <- db_client
+    }
+  ),
+  private = list(
+    db_client = NULL,
+
+    logSessionEvent = function(
+      event, session = shiny::getDefaultReactiveDomain()
+    ) {
+      db_client$connect()
+      on.exit({
+        db_client$disconnect()
+      })
+
+      event_row <- tibble::tibble(
+        app_name = basename(getwd()),
+        app_pid = Sys.getpid(),
+        client_ip = getClientIp(session),
+        user_id = session$userData$user_id,
+        session_token = session$token,
+        !!event := lubridate::now()
+      )
+
+      private$db_client$upsertRows(
+        "shiny_sessions", event_row, key_name = "session_token"
+      )
+    }
+  )
+)

R/ufApplication.R

@@ -0,0 +1,34 @@
+#' @export
+UFApplication <- R6::R6Class(
+  "UFApplication",
+  inherit = AdminLTEApplication,
+  public = list(
+    configureUF = function(
+      uri, with_users = TRUE, user_optional = FALSE, app_name = NULL
+    ) {
+      private$ufURI <- uri
+      if (is.logical(with_users)) {
+        private$with_users <- with_users
+      }
+      if (is.logical(user_optional)) {
+        private$user_optional <- user_optional
+      }
+      if (!is.null(app_name)) {
+        private$app_name <- app_name
+      }
+      invisible(self)
+    },
+    app = function() {
+      AVSDevR.UserFrosting::ufWrapApplication(
+        super$app(), private$ufURI, private$with_users,
+        private$user_optional, private$app_name
+      )
+    }
+  ),
+  private = list(
+    ufURI = NULL,
+    with_users = TRUE,
+    user_optional = FALSE,
+    app_name = NULL
+  )
+)

R/ufDashboardApplication.R

@@ -0,0 +1,95 @@
+#' @export
+UFDashboardApplication <- R6::R6Class(
+  "UFDashboardApplication",
+  inherit = UFApplication,
+  public = list(
+    withSidebarCollapsed = function() {
+      private$sidebar_collapsed <- TRUE
+      invisible(self)
+    },
+    ui = function() {
+      if (file.exists("widgets/help.R")) {
+        private$mHelp <- modules::use("widgets/help.R")
+      }
+      if (file.exists("widgets/title.R")) {
+        private$mDashboardTitle <- modules::use("widgets/title.R")
+      }
+      if (file.exists("widgets/menu.R")) {
+        private$mDashboardMenu <- modules::use("widgets/menu.R")
+      }
+
+      # Create a UI
+      ui <- shinydashboard::dashboardPage(
+        header = shinydashboard::dashboardHeader(
+          title = if (!is.null(private$mDashboardTitle)) {
+            private$mDashboardTitle$ui
+          } else {
+            private$appPage$title()
+          },
+          .list = c(
+            # Help links
+            if (!is.null(private$mHelp)) list(private$mHelp$ui("help")),
+
+            # UF stuff
+            if (length(private$with_users) == 0 || private$with_users) {
+              list(AVSDevR.UserFrosting::ufUiTopbar())
+            }
+          )
+        ),
+        sidebar = shinydashboard::dashboardSidebar(
+          collapsed = !(
+            length(private$sidebar_collapsed) == 0
+            || private$sidebar_collapsed == FALSE
+          ),
+          shiny::div(
+            id = "mainSidebar",
+
+            # UF stuff
+            if (length(private$with_users) == 0 || private$with_users) {
+              AVSDevR.UserFrosting::ufUiSidebar()
+            },
+
+            # Normal sidebar
+            shinydashboard::sidebarMenu(
+              id = "mainMenu",
+              shiny::tags$li(class = "header", "NAVIGATION"),
+
+              if (!is.null(private$mDashboardMenu)) private$mDashboardMenu$ui
+            )
+          )
+        ),
+        body = shinydashboard::dashboardBody(self$frameUI()),
+        title = private$appPage$title(),
+        skin = private$skin
+      )
+
+      # Set the language
+      shiny:::setLang(ui, private$language)
+    },
+    server = function(
+      input, output, session, ufApi = NULL, ufUser = NULL, ...
+    ) {
+      # Load help menu server (if supplied)
+      if (!is.null(private$mHelp)) {
+        shiny::callModule(private$mHelp$server, "help")
+      }
+
+      # Load UF server (if user support required)
+      if (length(private$with_users) == 0 || private$with_users) {
+        shiny::callModule(AVSDevR.UserFrosting::ufServer, "UF", ufApi)
+      }
+
+      # Launch the frame
+      super$server(
+        input, output, session, ufApi = ufApi, ufUser = ufUser, ...
+      )
+    }
+  ),
+  private = list(
+    sidebar_collapsed = FALSE,
+
+    mHelp = NULL,
+    mDashboardTitle = NULL,
+    mDashboardMenu = NULL
+  )
+)

R/ufFrameApplication.R

@@ -0,0 +1,7 @@
+#' @export
+UFFrameApplication <- R6::R6Class(
+  "UFFrameApplication",
+  inherit = UFApplication,
+  public = list(),
+  private = list()
+)