CODEWITHSUNDEEP
rshinypins
firmo23
firmo23

Reputation: 8454

Update data and parameter of a deployed shiny app via initial shiny app in which the deployed is displayed as url

I have the shiny app below in which when the user uploads an excel file then a selectInput() with its column names is displayed and also a url that leads to a deployed shiny app.

This deployed shiny app is now deployed with data<-iris and y<-Petal.Length but what I want to do is to pass to it the uploaded file as data and the selected column name as y. Then it will work (no problem with this)

How can I achieve it? I know that maybe one option would with an API and another with the pins package but Im not sure how to do it. Of course Im open to alternative solution.

initial app

# Install and load necessary packages
library(shiny)
library(pins)

# Define the UI
ui <- fluidPage(
  titlePanel("Shiny App with Link"),
  column(3, fileInput("file1", "Upload File", multiple = FALSE, accept = c(".csv", ".xlsx", ".xls"))),
  uiOutput("select"),
  uiOutput("tab"),

)

# Define the server
server <- function(input, output,session) {
  
  url <- a("Shinyapp", href="https://deniz4shinyml.shinyapps.io/iris/")
  output$tab <- renderUI({
    req(input$file1)
    tagList("URL link:", url)
  })
  
  file_info <- reactive({
    req(input$file1)
           "xlsx" = readxl::read_excel(input$file1$datapath)

  })
  
  #####pins######
  board_rsc <- pins::board_connect()
  board_rsc %>% pin_write(file_info())
  ######pins#####
  
  output$select<-renderUI({
    req(input$file1)
    selectInput("sel","select one column",choices = unique(colnames(file_info())),
                selected = unique(colnames(file_info()))[1],
                multiple = F)
  })
}

# Run the app
shinyApp(ui, server)

deployed app

# Load required libraries
library(shiny)
library(ggplot2)
library(pins)

# Load Iris dataset
data<-iris
y<-"Petal.Length"

######pin section
#data<-pin_read(board_rsc)
#y=?
########

# Define the UI for the Shiny app
ui <- fluidPage(
  titlePanel("Iris Sepal Scatterplot"),
  sidebarLayout(
    sidebarPanel(
    ),
    mainPanel(
      plotOutput("scatterplot")
    )
  )
)

# Define the server logic for the Shiny app
server <- function(input, output) {
  output$scatterplot <- renderPlot({
    ggplot(data, aes(x = Sepal.Length, y = data[[y]])) +
      geom_point() 
  })
}

# Run the Shiny app
shinyApp(ui, server)

Upvotes: 1

Views: 131

Answers (3)

YBS
YBS

Reputation: 21349

While the above answers look fine, I will give another answer using pins package.

First pin a dataset to be used by deployed app.

library(pins)

os <- Sys.info()[['sysname']]

if (os == "Windows"){       ####### local laptop folder for initial set-up
  my_psr_board <- board_folder("C:/Users/yourpath")
} else if (os == "Linux"){  ##############     for publishing on Posit WorkBench
  ## connect to Posit Connect
  my_psr_board <- pins::board_connect()
}

df_pinned <- mtcars
pins::pin_write(my_psr_board, x = df_pinned, name = "df_pinned", type="rds")

Then you deploy your app which uses this pinned dataset named df_pinned.

library(shiny)
library(ggplot2)
library(pins)
library(dplyr)

# Define the UI for the Shiny app
ui <- fluidPage(
  titlePanel("Iris Sepal Scatterplot"),
  sidebarLayout(
    sidebarPanel( uiOutput("xy")
    ),
    mainPanel(
      plotOutput("scatterplot")
    )
  )
)

os <- Sys.info()[['sysname']]

if (os == "Windows"){       ####### local laptop folder for initial set-up
  user = ""
  my_psr_board <- board_folder("C:/Users/yourpath")
} else if (os == "Linux"){  ##############     for publishing on Posit WorkBench
  user = "<userID>/"  ### replace userID with your actual user ID
  ## connect to Posit Connect
  my_psr_board <- pins::board_connect()
}

# Define the server logic for the Shiny app
server <- function(input, output) {
  data_pinned <- reactive({
    dataset <- "df_pinned"
    pin_read(my_psr_board,paste0(user,dataset))
  })
  
  output$xy <- renderUI({
    req(data_pinned())
    tagList(
      selectInput("xvar", "Choose variable for x-axis", choices = names(data_pinned())),
      selectInput("yvar", "Choose variable for y-axis", choices = names(data_pinned()), selected = names(data_pinned())[2])
    )
  })
  
  data <- reactive({
    req(data_pinned(),input$xvar,input$yvar)
    df <- data_pinned() %>% dplyr::select(input$xvar,input$yvar)
    df
  })
  
  output$scatterplot <- renderPlot({
    req(data(),input$xvar,input$yvar)
    ggplot(data(), aes(x = .data[[input$xvar]], y = .data[[input$yvar]])) +
      geom_point() 
  })
}

# Run the Shiny app
shinyApp(ui, server)

Next set-up your initial app that allows user to select the csv file to be pinned.

# Install and load necessary packages
library(shiny)
library(pins)
library(readxl)

# Define the UI
ui <- fluidPage(
  titlePanel("Shiny App with Link"),
  column(3, fileInput("file1", "Upload File", multiple = FALSE, accept = c(".csv"))),
  # uiOutput("select"),
  uiOutput("tab"),

)

os <- Sys.info()[['sysname']]

if (os == "Windows"){       ####### local laptop folder for initial set-up
  
  my_psr_board <- board_folder("C:/Users/yourpath")
} else if (os == "Linux"){  ##############     for publishing on Posit WorkBench
  
  ## connect to Posit Connect
  my_psr_board <- pins::board_connect()
}

# Define the server
server <- function(input, output,session) {

  url <- a("Shinyapp", href="https://deniz4shinyml.shinyapps.io/iris/")
  output$tab <- renderUI({
    req(input$file1)
    tagList("URL link:", url)
  })

  file_info <- reactive({
    req(input$file1)
    newdf = read.csv(input$file1$datapath)
    newdf
  })

  observeEvent(file_info(), {
    df_pinned <- file_info()
    pins::pin_write(my_psr_board, x = df_pinned, name = "df_pinned", type="rds")
  })

}

# Run the app
shinyApp(ui, server)

Please note that in this set-up I am selecting x and y variables in the deployed app. You can change it to the initial app. Also, you can easily modify to select other files other than csv. Also, you need to include the correct URL of the deployed app.

Upvotes: 1

St&#233;phane Laurent
St&#233;phane Laurent

Reputation: 84659

To elaborate my comment, using parameters, your initial app would look like:

ui <- fluidPage(
  titlePanel("Shiny App with Link"),
  fileInput("file1", "Upload File", multiple = FALSE, accept = c(".csv", ".xlsx", ".xls")),
  uiOutput("select"),
  uiOutput("tab")
)

server <- function(input, output,session) {
  
  output$tab <- renderUI({
    jsonData <- jsonlite::toJSON(Data())
    parameters <- 
      paste0("data=", URLencode(jsonData), "&y=", URLencode(input$sel))
    url <- paste0("https://deniz4shinyml.shinyapps.io/iris/?", parameters)
    tags$a("Shinyapp", href = url)
  }) |> bindEvent(input$sel)
  
  Data <- eventReactive(input$file1, {
    path <- input$file1$datapath
    ext <- tools::file_ext(path)
    switch(
      ext,
      xlsx = readxl::read_xlsx(path),
      xls  = readxl::read_xls(path),
      csv  = read.csv(path)
    )
  })
  
  output$select <- renderUI({
    selectInput(
      "sel", "select one column", choices = colnames(Data()),
      multiple = FALSE
    )
  }) |> bindEvent(Data())
}

And the deployed app would look like:

ui <- fluidPage(
  titlePanel("Iris Sepal Scatterplot"),
  sidebarLayout(
    sidebarPanel(),
    mainPanel(
      plotOutput("scatterplot")
    )
  )
)

server <- function(input, output, session) {
  
  Data <- reactiveVal()
  y <- reactiveVal()
  
  observe({
    query <- parseQueryString(session$clientData$url_search)
    Data(jsonlite::fromJSON(query$data))
    y(query$y)
  })
  
  output$scatterplot <- renderPlot({
    ggplot(Data(), aes(x = Sepal.Length, y = .data[[y()]])) +
      geom_point() 
  }) |> bindEvent(Data(), y())
}

But as I said, if the dataset is large, this would generate a long url which is not acceptable in some browsers. One way to reduce is to send only the selected column.

Or, instead of using a URL parameter for the data, upload the data to a Gist with the gistr package, put the Gist identifiant in a URL parameter, and in the deployed app, use gistr to get the data from this Gist.

Edit: using JSON blob

If you don't have a Github account, you can use the JSON blob website to store the data and retrieve it in the deployed app. Below I show how to do so by using the httr2 package to perform the HTTP requests.

Initial app:

library(shiny)
library(httr2)

ui <- fluidPage(
  titlePanel("Shiny App with Link"),
  fileInput("file1", "Upload File", multiple = FALSE, accept = c(".csv", ".xlsx", ".xls")),
  uiOutput("select"),
  uiOutput("tab")
)

server <- function(input, output,session) {
  
  output$tab <- renderUI({
    dataToSend <- list(data = Data(), y = input$sel)
    # send the data to jsonBlob
    req <- request("https://jsonblob.com/api/jsonBlob")
    post <- req |>
      req_body_json(dataToSend) |> 
      req_perform()
    # get the url of the posted data
    blobURL <- resp_header(post, "location")
    #
    parameters <- paste0("url=", URLencode(blobURL))
    url <- paste0("https://deniz4shinyml.shinyapps.io/iris/?", parameters)
    tags$a("Shinyapp", href = url)
  }) |> bindEvent(input$sel)
  
  Data <- eventReactive(input$file1, {
    path <- input$file1$datapath
    ext <- tools::file_ext(path)
    switch(
      ext,
      xlsx = readxl::read_xlsx(path),
      xls  = readxl::read_xls(path),
      csv  = read.csv(path)
    )
  })
  
  output$select <- renderUI({
    selectInput(
      "sel", "select one column", choices = colnames(Data()),
      multiple = FALSE
    )
  }) |> bindEvent(Data())
}

shinyApp(ui, server)

Deployed app:

library(shiny)
library(httr2)

ui <- fluidPage(
  titlePanel("Iris Sepal Scatterplot"),
  sidebarLayout(
    sidebarPanel(),
    mainPanel(
      plotOutput("scatterplot")
    )
  )
)

server <- function(input, output, session) {
  
  Data <- reactiveVal()
  y <- reactiveVal()
  
  observe({
    query <- parseQueryString(session$clientData$url_search)
    url <- query$url
    if(!is.null(url)) {
      # get the contents of the blob at this url
      List <- request(url) |> req_perform() |> resp_body_json()
      Data(List$data)
      y(List$y)
    } else {
      print("hmm.. strange!")
    }
  })
  
  output$scatterplot <- renderPlot({
    ggplot(Data(), aes(x = Sepal.Length, y = .data[[y()]])) +
      geom_point() 
  }) |> bindEvent(Data(), y())
}

Upvotes: 1

thothal
thothal

Reputation: 20399

You could rewrite your deployed app such that

  1. It accepts POST requests.
  2. In this POST request you receive your data and your column name and store it in a global variable.
  3. You send a redirection status to tell the original app that it should redirect to the "normal" landing page.
  4. In your server function, you assign a session specific name to the global variable in order to deal with concurrent requests (otherwise all users would see the same data as we use a global variable.

Below a POC.

Deployed App

library(shiny)
library(htmltools)
library(jsonlite)

params <- list()

ui <- function(req) {
  if (identical(req$REQUEST_METHOD, "GET")) {
    ## Handle the "normal" app
    fluidPage(
      fluidRow(
        column(width = 8L,
               tableOutput("table")
        ),
        column(width = 2L,
               tags$p("Passed column name:",
                      textOutput("column", inline = TRUE)))
      )
    )
  } else if (identical(req$REQUEST_METHOD, "POST")) {
    # Handle the POST
    body <- rawToChar(req$rook.input$read(-1))
    ## store the parameters
    params <<- c(params, latest = list(fromJSON(body)))
    httpResponse(
      status = 303L,
      headers = list(Location = paste0("http://", req$HTTP_HOST))
    )
  }
}
attr(ui, "http_methods_supported") <- c("GET", "POST")

server <- function(input, output, session) {
  ### store params with unique id to allow for a per session copy of data
  params[[session$token]] <- params$latest
  params$latest <<- NULL
  
  output$table <- renderTable({
    shiny::validate(
      need(!is.null(params[[session$token]]$data), 
           "No data provided, app should be kicked off with a POST")
    )
    params[[session$token]]$data
  })
  
  output$column <- renderText({
    shiny::validate(
      need(!is.null(params[[session$token]]$column),
           "No column name provided, app should be kicked off with a POST")
    )
    params[[session$token]]$column
  })
}

shinyApp(ui, server)

Local App

library(shiny)
library(httr)
library(jsonlite)
library(magrittr)

jscode <- HTML("
Shiny.addCustomMessageHandler('redirect', function(message) {
  window.location = message.location;
});")

ui <- fluidPage(
  tags$head(tags$script(jscode)), 
  fluidRow(
    column(width = 4L, 
           selectInput("dataset", "Select Data Source", c("mtcars", "iris"))
    ),
    column(width = 4L, 
           selectInput("column", "Select Column", names(mtcars))
    ), 
    column(width = 4L, style = "margin-top: 25px;",
           actionButton("send", "Send Data")
    )
  )
  
)

server <- function(input, output, session) {
  my_data <- reactive({
    get(req(input$dataset))
  })
  
  observe({
    updateSelectInput(session, "column", choices = names(my_data()))
  })
  
  observe({
    deployed_app_url <- "http://127.0.0.1:7770" 
    rq <- POST(deployed_app_url,
               config(followlocation = 0),
               body = list(data = my_data(),
                           column = input$column),
               encode = "json")
    session$sendCustomMessage("redirect", 
                              list(location = rq$headers$location))
  }) %>% 
    bindEvent(input$send)
}

shinyApp(ui, server)

Live

Gif showing the flow between teh 2 apps

Update

If you do not want to move from the local app to the deployed app, simply change your local app slightly:

ui <- fluidPage(
  tags$head(tags$script(jscode)), 
  fluidRow(
    column(width = 4L, 
           selectInput("dataset", "Select Data Source", c("mtcars", "iris"))
    ),
    column(width = 4L, 
           selectInput("column", "Select Column", names(mtcars))
    ), 
    column(width = 4L, style = "margin-top: 25px;",
           actionButton("send", "Send Data")
    )
  ),
  fluidRow(
    column(width = 12L,
           uiOutput("lnk"))
  )
)

server <- function(input, output, session) {
  my_data <- reactive({
    get(req(input$dataset))
  })
  
  observe({
    updateSelectInput(session, "column", choices = names(my_data()))
  })
  
  output$lnk <- renderUI({
    deployed_app_url <- "http://127.0.0.1:7770" 
    rq <- POST(deployed_app_url,
               config(followlocation = 0),
               body = list(data = my_data(),
                           column = input$column),
               encode = "json")
    tags$a(href = rq$headers$location, "Deployed App", target = "_blank")
    # session$sendCustomMessage("redirect", 
    #                           list(location = ))
  }) %>% 
    bindEvent(input$send)
    
}

N.B. The renderUI is an overkill, as the link to the deployed app won't change anyways. However, this workflow makes sure that we send the data at least once before proceeding, so making the link conditional on an inital POST makes sense to me.

Upvotes: 1

Related Questions