How to programmatically filter contents of a second shiny app displayed via iframe

Question

My application server file looks like this :

packages <- c("shiny", "shinydashboard", "RColorBrewer", "DT", "readxl", "plotly", "shinyanimate", "tidyverse", "shinycssloaders", "gridExtra", "shinyjs", "shinymanager")

lapply(packages, library, character.only = TRUE)

credentials <- data.frame(
  user = c("A", "B", "C"),
  password = c("Admin", "User1", "User2"),
  admin = c(TRUE, FALSE, FALSE),
  permission = c("advanced", "basic", "basic"),
  job = c("CEO", "CTO", "DRH"),
  stringsAsFactors = FALSE)


server <- function(input, output, session) {
  
  res_auth <- secure_server(
    check_credentials = check_credentials(credentials)
  )
  
  
  # Create reactive values including all credentials
  creds_reactive <- reactive({
    reactiveValuesToList(res_auth)
  })
  
  observeEvent(creds_reactive()$job, {

  data <- subset(data, 
                   grepl(creds_reactive()$job,
                          ignore.case = TRUE,
                          Job))

  
output$ev <- renderUI ({
  data <- subset(data, 
                  grepl(creds_reactive()$job,
                        ignore.case = TRUE,
                        Job))
  tags$iframe(
    seamless = "seamless",
    src = "link to the second application",
    style = "overflow:hiden; overflow-x : hidden; overflow-y : hidden; height:90%; width : 125%; position : absolute; top : 50px; padding : 0;",
    height = "200%", width = "100%",#"100%", #2000, #transform = scale(10),
    #"transform-origin" = "top right",
    frameBorder = "0"
  )})
  })
}

I would like to apply a filter on my second application in the iframe.

For example if A connects, data in my second app will show only rows for CEO, if B connects, data in my second app will show only rows for CTO .....

My question is if there is a possibility to apply this filter to an external application?

I thank you in advance for your answers and for your time :).

Answer 1

The following script creates two shiny apps: The child_app is running in a seperate background R process (depending on how you deploy your app this might not be needed), which can be controlled (filtered) via query strings.

The parent_app displays the child_app in an iframe and changes the query string (iframe's src) depending on the user accessing the app (permission level):

library(shiny)
library(shinymanager)
library(callr)
library(datasets)
library(DT)

# create child_app --------------------------------------------------------
# which will be shown in an iframe of the parent_app and can be controlled by passing query strings
ui <- fluidPage(
  DT::DTOutput("filteredTable")
)

server <- function(input, output, session) {
  permission <- reactive({shiny::getQueryString(session)$permission})
  
  # req: if child_app is accessed without providing a permission query string nothing is shown
  # "virginica" is default (unknown permission level - query string other than "advanced" / "basic")
  # http://127.0.0.1:3838/?permission=unknown
  output$filteredTable <- DT::renderDT({
    permissionFilter <- switch(req(permission()),
                               "advanced" = "setosa",
                               "basic" = "versicolor",
                               "virginica")
    if(!is.null(permissionFilter) && permissionFilter %in% unique(iris$Species)){
      datasets::iris[datasets::iris$Species == permissionFilter,]
    } else {
      datasets::iris
    }
  })
}

child_app <- shinyApp(ui, server)

# run child_app in a background R process - not needed when e.g. hosted on shinyapps.io
child_app_process <- callr::r_bg(
  func = function(app) {
    shiny::runApp(
      appDir = app,
      port = 3838L,
      launch.browser = FALSE,
      host = "127.0.0.1" # child_app is accessible only locally (or via the iframe)
    )
  },
  args = list(child_app),
  supervise = TRUE
)
# child_app_process$is_alive()

# create parent app -------------------------------------------------------
credentials <- data.frame(
  user = c("admin", "user1", "user2"),
  password = c("admin", "user1", "user2"),
  admin = c(TRUE, FALSE, FALSE),
  permission = c("advanced", "basic", "basic"),
  job = c("CEO", "CTO", "DRH"),
  stringsAsFactors = FALSE)

ui <- fluidPage(
  fluidRow(tags$h2("My secure application"),
  verbatimTextOutput("auth_output"),
  uiOutput("child_app_iframe"))
)

ui <- secure_app(ui)

server <- function(input, output, session) {
  res_auth <- secure_server(
    check_credentials = check_credentials(credentials)
  )
  
  output$auth_output <- renderPrint({
    reactiveValuesToList(res_auth)
  })
  
  output$child_app_iframe <- renderUI({
    tags$iframe(
      src = sprintf("http://127.0.0.1:3838/?permission=%s", res_auth$permission),
      style = "border: none;
               overflow: hidden;
               height: 65vh;
               width : 100%;
               position: relative;
               top:15px;
               padding:0;"
      # position: absolute;
    )
    })
}

parent_app <- shinyApp(ui, server, onStart = function() {
  cat("Doing application setup\n")
  onStop(function() {
    cat("Doing application cleanup\n")
    child_app_process$kill() # kill child_app if parent_app is exited - not needed when hosted separately
  })
})

# run parent_app
runApp(appDir = parent_app,
       port = 3939L,
       launch.browser = TRUE,
       host = "0.0.0.0")

Please note the Species column:

---

Edit: Here is a clean multi-file approach avoiding nested render-functions (This needs to be adapted when used with shiny-server - please see my comments):

child_app.R:

library(shiny)
library(shinymanager)
library(datasets)
library(DT)

ui <- fluidPage(
  DT::DTOutput("filteredTable")
  )

server <- function(input, output, session) {
  permission <- reactive({shiny::getQueryString(session)$permission})
  
  table_data <- reactive({
    permissionFilter <- switch(req(permission()),
                               "advanced" = "setosa",
                               "basic" = "versicolor",
                               "virginica")
    if(!is.null(permissionFilter) && permissionFilter %in% unique(iris$Species)){
      datasets::iris[datasets::iris$Species == permissionFilter,]
    } else {
      NULL # don't show something without permission
    }
  })
  
  output$filteredTable <- DT::renderDT({
    table_data()
  })
    
}

child_app <- shinyApp(ui, server)

# run parent_app (local deployment)
runApp(
  appDir = child_app,
  port = 3838L,
  launch.browser = FALSE,
  host = "127.0.0.1" # child_app is accessible only locally (or via the iframe)
)

parent_app.R:

library(shiny)
library(shinymanager)
library(datasets)
library(DT)

credentials <- data.frame(
  user = c("admin", "user1", "user2"),
  password = c("admin", "user1", "user2"),
  permission = c("advanced", "basic", "basic"),
  stringsAsFactors = FALSE)

ui <- fluidPage(
  fluidRow(tags$h2("My secure application"),
           verbatimTextOutput("auth_output"),
           uiOutput("child_app_iframe"))
)

ui <- secure_app(ui)

server <- function(input, output, session) {
  res_auth <- secure_server(
    check_credentials = check_credentials(credentials)
  )
  
  output$auth_output <- renderPrint({
    reactiveValuesToList(res_auth)
  })
  
  output$child_app_iframe <- renderUI({
    tags$iframe(
      # src = sprintf("child_app_link/child_app/?permission=%s", res_auth$permission), # shiny-server
      src = sprintf("http://127.0.0.1:3838/?permission=%s", res_auth$permission), # local deployment
      style = "border: none;
               overflow: hidden;
               height: 500px;
               width : 95%;
               # position: relative;
               # top:15px;
               # padding:0;
      "
    )
  })
}

parent_app <- shinyApp(ui, server)

# run parent_app (local deployment)
runApp(appDir = parent_app,
       port = 3939L,
       launch.browser = TRUE,
       host = "0.0.0.0")