Following this answer I'm trying to create an app that will output a plot based on the value I will pass to the app via URL
library(shiny)
shinyApp(
ui = fluidPage(
mainPanel(
plotOutput("plot")
)
),
server = function(input, output, session) {
observe({
query <- parseQueryString(session$clientData$url_search)
if (!is.null(query[['text']])) {
n <- query[['text']]
}
})
output$plot <- renderPlot({
# Add a little noise to the cars data
plot(cars[sample(nrow(cars), n), ])
})
}
)
Yet I don't know where/how I should store/pass the value of the variable n so to transfer it from observe() to renderPlot().
Try this. Note that n is defined as a per-session global variable, and notice the global assignment operator <<-
library(shiny)
shinyApp(
ui = fluidPage(
mainPanel(
plotOutput("plot")
)
),
server = function(input, output, session) {
n <- 5
observe({
query <- parseQueryString(session$clientData$url_search)
if (!is.null(query[['text']])) {
n <<- query[['text']]
}
})
output$plot <- renderPlot({
# Add a little noise to the cars data
plot(cars[sample(nrow(cars), n), ])
})
}
)
Related
Is it possible to get some R object used in Shiny?
For example, in the following code, I want to get text string inputted by users.
However, the .Last.value dose not the desired text string.
ref
How to store the returned value from a Shiny module in reactiveValues?
Ex code
returnUI = function(id) {
ns <- NS(id)
tagList(
textInput(ns("txt"), "Write something")
)
}
returnServer = function(input, output, session) {
myreturn <- reactiveValues()
observe({ myreturn$txt <- input$txt })
return(myreturn)
}
library(shiny)
source("modules/module_1.R")
ui <- fluidPage(
returnUI("returntxt"),
textOutput("mytxt")
)
server <- function(input, output, session) {
myvals <- reactiveValues(
txt = NULL
)
mytxt <- callModule(returnServer, "returntxt")
observe({
myvals$txt <- mytxt$txt
print(myvals$txt)
})
output$mytxt <- renderText({ myvals$txt })
}
shinyApp(ui, server)
.Last.value
Yes, you can push variables to the global environment (your usual workspace) from a Shiny app running in your console:
library(shiny)
ui <- fluidPage(
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30)
),
mainPanel(NULL)
)
)
server <- function(input, output) {
observe({
my_global_env <- globalenv()
my_global_env$x <- input$bins
})
}
shinyApp(ui = ui, server = server)
How can I pass additional arguments to a reactive context in Shiny? The purpose is to handover the arguments to the reactive context ("callback") when it is evaluated.
Think of the following Shiny server code. How can I make output$some print "some", output$different print "different" and so on?
for(i in c("some","different","values"){
output[[i]] <- renderText({
# i gets evaluated at some later point in time,
# and thus will always print "values"
i
})
}
The example below is intended to make the two render contexts reactive to the corresponding reactive value text1 and text2, but of course it only makes both depend on text2.
library(shiny)
ui <- fluidPage(
titlePanel("Test"),
sidebarLayout(
sidebarPanel(
),
mainPanel(
htmlOutput("text1"),
textOutput("text2"),
actionButton("test_btn1",label="test1"),
actionButton("test_btn2",label="test2")
)
)
)
server <- function(input, output) {
rv <- reactiveValues(
"text1"=NULL,
"text2"=NULL
)
bindings <- list(
list("var"="text1",
"function"=renderUI),
list("var"="text2",
"function"=renderText)
)
for(i in bindings){
output[[i[["var"]]]] <- i[["function"]]({
# i is always the second element unfortunately
rv[[i[["var"]]]]
})
}
observeEvent(input$test_btn1,{
rv$text1 <- tags$p("new value 1")
})
observeEvent(input$test_btn2,{
rv$text2 <- "new value 2"
})
}
shinyApp(ui = ui, server = server)
Try Map() instead of the for loop so the function gets called through each iteration:
library(shiny)
ui <- fluidPage(
titlePanel("Test"),
sidebarLayout(
sidebarPanel(
),
mainPanel(
htmlOutput("text1"),
textOutput("text2"),
actionButton("test_btn1",label="test1"),
actionButton("test_btn2",label="test2")
)
)
)
server <- function(input, output) {
rv <- reactiveValues(
"text1"=NULL,
"text2"=NULL
)
bindings <- list(
list("var"="text1",
"function"=renderUI),
list("var"="text2",
"function"=renderText)
)
Map(function(i){
output[[bindings[[i]][["var"]]]] <- bindings[[i]][["function"]]({
# i is always the second element unfortunately
rv[[bindings[[i]][["var"]]]]
})
}, 1:2)
observeEvent(input$test_btn1,{
rv$text1 <- "new value 1"
})
observeEvent(input$test_btn2,{
rv$text2 <- "new value 2"
})
}
shinyApp(ui = ui, server = server)
I want to create a UI module, insert it, and obtain an input object from the server module. I then want to observe events on this input object.
Currently, I return an input object as a reactive value from callModule. However, the observer I create only fires once (on initialisation).
Can anyone tell me if what I am trying to do is possible, and where I'm going wrong? Code attached. Thanks in advance.
John
app.R
library(shiny)
source("added.R")
source("addedUI.R")
# Define UI for application that draws a histogram
ui <- fluidPage(
actionButton("add_id", "Add"),
actionButton("print_id", "Print list"),
tags$hr(),
tags$div(id = "div"),
tags$hr()
)
# Define server logic required to draw a histogram
server <- function(input, output) {
id <- 0
rv <- list()
next_id <- function()
{
id <<- id + 1
return (as.character(id))
}
observeEvent(input$print_id,
{
print(rv)
})
observeEvent(input$add_id,
{
x <- next_id()
ui <- addedUI(x)
insertUI(selector = sprintf("#%s", "div"), where = "beforeEnd", ui = ui)
rv[[x]] <<- callModule(added, x)
observeEvent(rv[[x]],
{
print(sprintf("Observed %s: ", x))
})
print(rv)
})
}
# Run the application
shinyApp(ui = ui, server = server)
added.R
added <- function(input, output, session)
{
return (reactive(input$text_id))
}
addedUI.R
addedUI <- function(id)
{
ns <- NS(id)
tags$div(textInput(ns("text_id"), "Text", value = "Abc"))
}
You need to use observeEvent(rv[[x]](), ...) to read the current value from the reactive. Otherwise you recieve the reference to the reactive object, which is not observable. Same for the print_id observer.
library(shiny)
added <- function(input, output, session)
{
return (reactive(input$text_id))
}
addedUI.R
addedUI <- function(id)
{
ns <- NS(id)
tags$div(textInput(ns("text_id"), "Text", value = "Abc"))
}
# Define UI for application that draws a histogram
ui <- fluidPage(
actionButton("add_id", "Add"),
actionButton("print_id", "Print list"),
tags$hr(),
tags$div(id = "div"),
tags$hr()
)
# Define server logic required to draw a histogram
server <- function(input, output) {
id <- 0
rv <- list()
next_id <- function()
{
id <<- id + 1
return (as.character(id))
}
observeEvent(input$print_id,
{
print(lapply(rv, function(x){x()}))
})
observeEvent(input$add_id,
{
x <- next_id()
ui <- addedUI(x)
insertUI(selector = sprintf("#%s", "div"), where = "beforeEnd", ui = ui)
rv[[x]] <<- callModule(added, x)
observeEvent(rv[[x]](),
{
print(sprintf("Observed %s: ", x))
})
print(rv)
})
}
# Run the application
shinyApp(ui = ui, server = server)
Because my shiny app has become quite large I've recently put some code into modules (also to reuse the code multiple times in different places). Somehow parts of the code do not work anymore as expected.
In this example I have a module which filters data according to input elements and return a reactive data.frame. In the mainPanel I have a module which creates a dataTable from the filtered data. But the reactivity does not work, when I change the selectInput, the dataTable does not update.
library(shiny)
library(DT)
filtersUI <- function(id) {
ns <- NS(id)
selectizeInput(
ns("Species"), label = "Species",
choices = levels(iris$Species),
selected = "virginica"
)
}
filters <- function(input, output, session, .data) {
inputs <- reactive({
list("Species" = input[["Species"]])
})
reactive({
.data[.data$Species %in% inputs()[["Species"]], ]
})
}
dataTableUI <- function(id) {
ns <- NS(id)
DT::dataTableOutput(ns("data.table"))
}
dataTable <- function(input, output, session, .data) {
output$data.table <- DT::renderDataTable({
DT::datatable(.data)
})
}
appUI <- function(id) {
ns <- NS(id)
sidebarLayout(
sidebarPanel(
filtersUI(ns("filter"))
),
mainPanel(
dataTableUI(ns("data.table"))
)
)
}
app <- function(input, output, session, .data) {
data.subset <- callModule(filters, "filter", .data = .data)
callModule(dataTable, "data.table", .data = data.subset())
}
ui <- fluidPage(
appUI("app")
)
server <- function(input, output, session) {
callModule(app, "app", .data = iris)
}
shinyApp(ui, server)
But when copying the code from the subModules into the app module, the code works fine:
library(shiny)
library(DT)
appUI <- function(id) {
ns <- NS(id)
sidebarLayout(
sidebarPanel(
selectizeInput(
ns("Species"), label = "Species",
choices = levels(iris$Species),
selected = "virginica"
)
),
mainPanel(
DT::dataTableOutput(ns("data.table"))
)
)
}
app <- function(input, output, session, .data) {
inputs <- reactive({
list("Species" = input[["Species"]])
})
data.subset <- reactive({
.data[.data$Species %in% inputs()[["Species"]], ]
})
output$data.table <- DT::renderDataTable({
DT::datatable(data.subset())
})
}
ui <- fluidPage(
appUI("app")
)
server <- function(input, output, session) {
callModule(app, "app", .data = iris)
}
shinyApp(ui, server)
I know the modular structure looks like overkill in this simple example, but in my real app I have lots of code in the modules, which I deleted to make this example minimal. So it would be nice to have a solution using the same modular structure as in the first code snippet. Any ideas why it fails?
You did a very nice job creating a repoducible example with submodules. However, the issue does in fact not have anything to do with submodules. You just need to pass the reactive object data.subset differently. Instead of
callModule(dataTable, "data.table", .data = data.subset())
you should use
callModule(dataTable, "data.table", .data = data.subset)
to pass the reactive itself rather than its current value. The value can then be "resolved" in DT::renderDataTable like this
output$data.table <- DT::renderDataTable({
DT::datatable({.data()})
})
The way you coded it, the data at "construction time" i.e. the unfiltered dataset is sent to the module and it can't be observed along the way.
To be clear: The commented lines (## remove parantheses here and ## add parantheses here) are the only ones I changed from your original code.
library(shiny)
library(DT)
filtersUI <- function(id) {
ns <- NS(id)
selectizeInput(
ns("Species"), label = "Species",
choices = levels(iris$Species),
selected = "virginica"
)
}
filters <- function(input, output, session, .data) {
inputs <- reactive({
list("Species" = input[["Species"]])
})
reactive({
.data[.data$Species %in% inputs()[["Species"]], ]
})
}
dataTableUI <- function(id) {
ns <- NS(id)
DT::dataTableOutput(ns("data.table"))
}
dataTable <- function(input, output, session, .data) {
output$data.table <- DT::renderDataTable({
DT::datatable({.data()}) ## add parantheses here
})
}
appUI <- function(id) {
ns <- NS(id)
sidebarLayout(
sidebarPanel(
filtersUI(ns("filter"))
),
mainPanel(
dataTableUI(ns("data.table"))
)
)
}
app <- function(input, output, session, .data) {
data.subset <- callModule(filters, "filter", .data = .data)
callModule(dataTable, "data.table", .data = data.subset) ## remove parantheses here
}
ui <- fluidPage(
appUI("app")
)
server <- function(input, output, session) {
callModule(app, "app", .data = iris)
}
shinyApp(ui, server)
To sum things up, here is a quote from Joe Cheng to a similar issue
Hi Mark, the code in linkedScatter itself is correct; but when calling callModule, you want to pass the reactive itself by name (car_data) without reading it (car_data()).
callModule(linkedScatter, "scatters", car_data)
This is similar to how you can pass a function by name to something like lapply:
lapply(letters, toupper) # works
lapply(letters, toupper()) # doesn't work
I'm trying to pass the node value of a simple network as an argument to a function in Shiny R. However, I'm getting this error:
Error in rsqlite_send_query: no such column: input$id
Can anyone help with this issue? Thanks.
library(shiny)
library(networkD3)
ui <- shinyUI(fluidPage(
fluidRow(
column(4, simpleNetworkOutput("simple")),
column(4, DT::dataTableOutput("table"))
)
))
server <- shinyServer(function(input, output, session) {
session$onSessionEnded(stopApp)
output$simple <- renderSimpleNetwork({
sn<-simpleNetwork(df)
sn$x$options$clickAction = 'Shiny.onInputChange("id",d.name)'
sn
})
output$table <- DT::renderDataTable(DT::datatable(get(funct(input$id))))
})
shinyApp(ui = ui, server = server)
take out the deparse and substitute from your sprintf command, and add single quotes around the value you want to match in the SQL statement you're generating
get rid of the get function because you're not trying to "get" an object
for example....
library(shiny)
library(networkD3)
library(DT)
library(sqldf)
df <- read.csv(header = T, text = '
source,name,age,hair
dad,Jon X,18,brown
dad,Jon Y,22,blonde
')
funct <-
function (n) {
isp <- sprintf("Select df.age From df Where df.name='%s';", n)
isd <- sqldf::sqldf(isp)
return(isd)
}
ui <- shinyUI(fluidPage(
fluidRow(
column(4, simpleNetworkOutput("simple")),
column(4, DT::dataTableOutput("table"))
)
))
server <- shinyServer(function(input, output, session) {
session$onSessionEnded(stopApp)
output$simple <- renderSimpleNetwork({
sn<-simpleNetwork(df)
sn$x$options$clickAction = 'Shiny.onInputChange("id",d.name)'
sn
})
output$table <- DT::renderDataTable(DT::datatable(funct(input$id)))
})
shinyApp(ui = ui, server = server)
however, if all you want is to display a value associated with a given selection, I highly suggest drastically reducing the complexity to something like this
library(shiny)
library(networkD3)
df <- read.csv(header = T, text = '
source,name,age,hair
dad,Jon X,18,brown
dad,Jon Y,22,blonde
')
ui <- shinyUI(fluidPage(
fluidRow(
column(4, simpleNetworkOutput("simple")),
column(4, textOutput("text"))
)
))
server <- shinyServer(function(input, output, session) {
session$onSessionEnded(stopApp)
output$simple <- renderSimpleNetwork({
sn <- simpleNetwork(df)
sn$x$options$clickAction <- 'Shiny.onInputChange("id", d.name)'
sn
})
output$text <- renderPrint({ df$age[df$name == input$id] })
})
shinyApp(ui = ui, server = server)