Multiwindow App - RStudio Connect and pins

Nov 16, 2021 · 9 min read · R shiny javascript rsconnect ·

An earlier post described a multiwindow shiny app that demonstrated how three shiny apps could be handled by a fourth with data passing between them. This extends the concept, running all apps on RStudio Connect and manages the communication using the {pins} library. Data is passed between the apps using a json file attached to a pin on an RStudio Connect board. When the app is exited, the pin is deleted.

Folder Structure

The folder structure is identical to the shiny server version, under the multiwindow project folder:

 1multiwindow
 2├── launcher  
 3│   ├── app.R
 4│   └── www  
 5│       └── script.js  
 6├── app_options  
 7│   └── app.R  
 8├── app_graphics  
 9│   └── app.R  
10└── app_details  
11   └── app.R

There are four apps along with a javascript file which handles opening windows:

launcher/app.R - an app that manages opening and closing the other shiny apps as well as defining the json file location.
launcher/www/script.js - a javascript file that opens shiny apps in minimal browser windows of specified size and location.
app_options/app.R - a simple app that allows the user to select a number of options and writes them to a json file.
app_graphics/app.R - a simple app that reads in the json file and plots a chart.
app_details/app.R - a simple app that reads in the json file and outputs the file contents.

Concept

launcher controls opening and closing of the other three apps (app_options, app_graphics and app_details). Communication is handled using a pin.

graph TB subgraph launcher app_options --> pin; pin --> app_graphics; pin --> app_details; end

When the app is exited the pin is deleted.

Code

launcher/app.R

  1## App lauuncher
  2## This app manages all others
  3
  4
  5library(shiny)
  6library(shinyWidgets)
  7library(stringi)
  8library(pins)
  9
 10server <- function(input, output, session) {
 11  
 12  ## register board
 13  pins::board_register_rsconnect("HL_board", account = "liebeha1")
 14
 15  ## create a pin name
 16  pin_name <- stringi::stri_rand_strings(1, length = 8)
 17  
 18  url_base <- ** RSTUDIO CONNECT URL **
 19  
 20  ## define app windows
 21  app_windows <- data.frame(
 22    name = c("app_options", "app_graphics", "app_details"),
 23    app = c("447", "448", "449"),
 24    launch_delay = c(0, 2000, 0),
 25    height = c(0.25, 0.4, 0.25),
 26    width = c(0.095, 0.2, 0.095),
 27    left = c(0.02, 0.02, 0.125),
 28    top = c(0.02, 0.33, 0.02),
 29    closable = c(TRUE, TRUE, TRUE),
 30    stringsAsFactors = FALSE
 31  )
 32  app_windows$url <- paste0(url_base, app_windows$app, "/?pin=", pin_name)
 33  
 34  ## launch all apps
 35  for (i in 1:nrow(app_windows)) {
 36    Sys.sleep(app_windows[i, ]$launch_delay / 1000)
 37    session$sendCustomMessage("launch_app", app_windows[i, ])
 38  }
 39  
 40  observe({
 41    req(!is.null(input$txt_com_file))
 42    session$sendCustomMessage("disable", "txt_com_file")
 43  })
 44  
 45  output$ui_communications <- renderUI({
 46    column(10, offset = 1, textInput("txt_com_file", label = "Pin ID", width = "100%", value = pin_name))
 47  })
 48  
 49  
 50  
 51  # app_options ------------------------------------------------------------------
 52  
 53  
 54  ## options UI
 55  output$ui_app_options <- renderUI({
 56    fluidRow(
 57      column(1, offset = 1, style = "margin-top: 8px;", prettySwitch("swt_app_options", status = "success", label = NULL, inline = TRUE, bigger = TRUE, value = TRUE)),
 58      column(5, h4("shiny app: setting options")),
 59      column(2, offset = 1, actionBttn("but_close_all", label = "Close All", style = "simple", color = "warning", size = "sm"))
 60    )
 61  })
 62  
 63  ## switch enable
 64  observe({
 65    req(!is.null(input$swt_app_options))
 66    if (!app_windows[1, ]$closable) {
 67      session$sendCustomMessage("disable", "swt_app_options")
 68    }
 69  })
 70  
 71  ## close app_options
 72  observeEvent(input$swt_app_options, {
 73    if (input$swt_app_options == TRUE) {
 74      session$sendCustomMessage("launch_app", app_windows[1, ])
 75    } else {
 76      session$sendCustomMessage("close_app", app_windows[1, ])
 77    }
 78  })
 79  
 80  # app_graphics ------------------------------------------------------------------
 81  
 82  
 83  ## graphics UI
 84  output$ui_app_graphics <- renderUI({
 85    fluidRow(
 86      column(1, offset = 1, style = "margin-top: 8px;", prettySwitch("swt_app_graphics", status = "success", label = NULL, inline = TRUE, bigger = TRUE, value = TRUE)),
 87      column(5, h4("shiny app: plotting graphics")),
 88      column(2, offset = 1, actionBttn("but_exit", label = "EXIT", style = "simple", color = "danger", size = "sm"))
 89    )
 90  })
 91  
 92  ## switch enable
 93  observe({
 94    req(!is.null(input$swt_app_graphics))
 95    if (!app_windows[2, ]$closable) {
 96      session$sendCustomMessage("disable", "swt_app_graphics")
 97    }
 98  })
 99  
100  ## close app_options
101  observeEvent(input$swt_app_graphics, {
102    if (input$swt_app_graphics == TRUE) {
103      session$sendCustomMessage("launch_app", app_windows[2, ])
104    } else {
105      session$sendCustomMessage("close_app", app_windows[2, ])
106    }
107  })
108  
109  # app_details ------------------------------------------------------------------
110  
111  
112  ## details UI
113  output$ui_app_details <- renderUI({
114    fluidRow(
115      column(1, offset = 1, style = "margin-top: 8px;", prettySwitch("swt_app_details", status = "success", label = NULL, inline = TRUE, bigger = TRUE, value = TRUE)),
116      column(5, h4("shiny app: setting details"))
117    )
118  })
119  
120  ## switch enable
121  observe({
122    req(!is.null(input$swt_app_details))
123    if (!app_windows[3, ]$closable) {
124      session$sendCustomMessage("disable", "swt_app_details")
125    }
126  })
127  
128  ## close app_options
129  observeEvent(input$swt_app_details, {
130    if (input$swt_app_details == TRUE) {
131      session$sendCustomMessage("launch_app", app_windows[3, ])
132    } else {
133      session$sendCustomMessage("close_app", app_windows[3, ])
134    }
135  })
136  
137  ## close all apps
138  observeEvent(input$but_close_all, {
139    for (i in 1:nrow(app_windows)) {
140      session$sendCustomMessage("close_app", app_windows[i, ])
141    }
142  })
143  
144  
145  ## exit application
146  observeEvent(input$but_exit, {
147    
148    ## remove pin
149    pins::pin_remove(name = pin_name, board = "HL_board")
150
151    ## close all windows
152    for (i in 1:nrow(app_windows)) {
153      session$sendCustomMessage("close_app", app_windows[i, ])
154    }
155    
156    ## close window and finish
157    shiny::stopApp()
158    
159  })
160  
161  
162}
163
164ui <- fluidPage(
165  tags$head(
166    tags$script(type = "text/javascript", src = "script.js")
167  ),
168  br(),
169  br(),
170  fluidRow(column(10, offset = 1, 
171                  panel(status = "primary", heading = "App Launcher",
172                        panel(status = "danger", heading = "Communications",
173                              uiOutput("ui_communications")
174                        ),
175                        br(),
176                        panel(status = "danger", heading = "App Windows",
177                              fluidRow(uiOutput("ui_app_options")),
178                              fluidRow(uiOutput("ui_app_graphics")),
179                              fluidRow(uiOutput("ui_app_details"))
180                        )
181                  )
182  ))
183)
184
185shinyApp(ui = ui, server = server)

In this code, app_windows holds parameters for the three app windows. Two new parameters are included compared to the original version. app now holds the RStudio Connect app refernce number which is used to execute the app and launch_delay is a delay in milliseconds to wait before starting an app - it's used to ensure that the pin exists before starting the second app.

launcher/www/script.js

 1var shiny_app_options = "";
 2var shiny_app_graphics = "";
 3var shiny_app_details = "";
 4
 5// launch a shiny app
 6Shiny.addCustomMessageHandler('launch_app', function(x) {
 7  scr_height = window.screen.height;
 8  scr_width = window.screen.width;
 9  window_height = scr_height * x.height;
10  window_width = scr_width * x.width;
11  window_left = scr_width * x.left;
12  window_top = scr_height * x.top;
13  window_options = "height=" + window_height + ", width=" + window_width + ", left=" + window_left + ", top=" + window_top;
14  
15  if (x.name == "app_options") {
16    shiny_app_options = window.open(x.url, x.name, window_options);
17  } else if (x.name == "app_graphics") {
18    shiny_app_graphics = window.open(x.url, x.name, window_options);
19  } else if (x.name == "app_details") {
20    shiny_app_details = window.open(x.url, x.name, window_options);
21  }
22});
23
24// close a shiny app
25Shiny.addCustomMessageHandler('close_app', function(x) {
26  // can't pass window name as variable to close so have to hardcode :(
27  if (x.name == "app_options") {
28    shiny_app_options.close();
29  } else if (x.name == "app_graphics") {
30    shiny_app_graphics.close();
31  } else if (x.name == "app_details") {
32    shiny_app_details.close();
33  }
34});
35
36// disable a shiny input
37Shiny.addCustomMessageHandler('disable', function(id) {
38  var input_type = $("#" + id).prop("type");
39  if (input_type.startsWith("select")) {
40    $("#" + id)[0].selectize.disable();
41  } else {
42    $("#" + id).prop("disabled", true);
43  }
44});

app_options/app.R

 1## app_options
 2## A simple app that offers a series of options
 3
 4library(pins)
 5library(shiny)
 6library(shinyWidgets)
 7library(jsonlite)
 8
 9server <- function(input, output, session) {
10  
11  ## register board
12  pins::board_register_rsconnect("HL_board", account = "liebeha1")
13
14  ## extract pin id from url
15  pin_id <- reactive({
16    query <- parseQueryString(session$clientData$url_search)
17    if (!is.null(query$pin)) {
18      query$pin
19    } else {
20      ""
21    }
22  })
23  
24  output$ui_axes <- renderUI({
25    req(input$sel_data)
26    ## select x and y parameters from numeric columns
27    df <- get(input$sel_data)
28    columns <- names(df)[sapply(df, class) == "numeric"]
29    tagList(
30      selectizeInput("sel_x", "X parameter", choices = columns),
31      selectizeInput("sel_y", "Y parameter", choices = columns)
32    )
33  })
34  
35  ## write file when updating parameter
36  observeEvent(input$sel_data, {
37    write_file()
38  })
39  
40  observeEvent(input$sel_x, {
41    write_file()
42  })
43  
44  observeEvent(input$sel_y, {
45    write_file()
46  })
47  
48  ## write a file
49  write_file <- function() {
50    if (pin_id() != "") {
51      output <- list(
52        data = input$sel_data,
53        x = input$sel_x,
54        y = input$sel_y
55      )
56      json_out <- toJSON(output, auto_unbox = TRUE, null = "null")
57      
58      ## pin data
59      pin(json_out, name = pin_id(), board = "HL_board")
60
61    }
62  }
63}
64
65ui <- fluidPage(
66  br(),
67  br(),
68  panel(heading = "Options", status = "primary",
69        selectizeInput("sel_data", "dataset", choices = c("iris", "mtcars")),
70        uiOutput("ui_axes")
71        )
72)
73
74shinyApp(ui, server)

app_graphics/app.R

 1## app_graphics
 2## A simple app that draws a ggplot
 3
 4library(pins)
 5library(shiny)
 6library(shinyWidgets)
 7library(ggplot2)
 8library(jsonlite)
 9
10server <- function(input, output, session) {
11  
12  ## register board
13  pins::board_register_rsconnect("HL_board", account = "liebeha1")
14
15  ## extract pin id from url
16  pin_id <- reactive({
17    query <- parseQueryString(session$clientData$url_search)
18    if (!is.null(query$pin)) {
19      query$pin
20    } else {
21      ""
22    }
23  })
24  
25  ## retrieve pin data
26  json_data <- pin_reactive(name = pin_id(), board = "HL_board", interval = 2000)
27  
28  output$plt <- renderPlot({
29
30    data <- fromJSON(json_data())
31    params <- c("data", "x", "y")
32    
33    ## check all plotting parameters are present
34    if (all(sapply(params, function(x) !is.null(data[[x]])))) {
35      ggplot(get(data[["data"]]), aes(x = .data[[data[["x"]]]], y = .data[[data[["y"]]]])) +
36        geom_point() +
37        labs(title = paste0("Plot data = ", data[["data"]]),
38             x = data[["x"]], 
39             y = data[["y"]])
40    }
41  })
42  
43}
44
45ui <- fluidPage(
46  br(),
47  br(),
48  panel(heading = "Graphics", status = "primary",
49        plotOutput("plt")
50  )
51)
52
53shinyApp(ui, server)

app_details/app.R

 1## app_details
 2## A simple app that lists some details
 3
 4library(pins)
 5library(shiny)
 6library(shinyWidgets)
 7library(jsonlite)
 8
 9server <- function(input, output, session) {
10  
11  ## register board
12  pins::board_register_rsconnect("HL_board", account = "liebeha1")
13
14  ## extract pin id from url
15  pin_id <- reactive({
16    query <- parseQueryString(session$clientData$url_search)
17    if (!is.null(query$pin)) {
18      query$pin
19    } else {
20      ""
21    }
22  })
23  
24  ## retrieve pin data
25  json_data <- pin_reactive(name = pin_id(), board = "HL_board", interval = 2000)
26
27  output$txt_details <- renderPrint({
28    req(json_data())
29    prettify(json_data())
30  })
31  
32}
33
34ui <- fluidPage(
35  br(),
36  br(),
37  panel(heading = "Output", status = "primary",
38        verbatimTextOutput("txt_details")
39  )
40)
41
42shinyApp(ui, server)

Output is very similar to the shiny server version. The launcher app now contains an additional button (EXIT) which performs a closedown procedure of closing all the other app windows and removing the pin.