I am building a relatively complicated app, where I have dynamic number of inputs titled:
d1, d2 .. dn. At one point I wanted to try addressing multiple inputs at the same time with:
input[[grep(pattern="d+[[:digit:]]",input)]]
which of course caused an error:
Must use single string to index into reactivevalues
So I was wondering whether someone knew an elegant way to do such a thing?
You can use names on input :
grep(pattern = "d+[[:digit:]]", x = names(input), value = TRUE)
A working example :
library("shiny")
ui <- fluidPage(
fluidRow(
column(
width = 6,
lapply(
X = 1:6,
FUN = function(i) {
sliderInput(inputId = paste0("d", i), label = i, min = 0, max = 10, value = i)
}
)
),
column(
width = 6,
verbatimTextOutput(outputId = "test")
)
)
)
server <- function(input, output){
output$test <- renderPrint({
sapply(grep(pattern = "d+[[:digit:]]", x = names(input), value = TRUE), function(x) input[[x]])
})
}
shinyApp(ui = ui, server = server)
Related
I have a bit of renderUI code that created numeric input boxes and populates them from a list.
it looks like this:
output$Small1A <- renderUI({
numericInput("Small1A","",min = 0, max = 100, value = Reduction()$Reduction[Reduction()$Category == "Small1A"])
})
Reduction() is a list that is preloaded with some default values or can be loaded from a file.
It looks like this
Category Reduction
Small1A 0.5
Small2A 0.5
...
Medium3D 0.5
...
Huge7E 7.4
there are 140 Elements (Small, Medium, Large, Huge) 1-7 and A-E
these are grouped on the UI as 5 collapsible boxes each with a 4x7 grid in.
column(1, offset = 1, uiOutput("Small1A")),
column(1, offset = 0, uiOutput("Small2A")),
(and so)
It seems like I should be able to replace the 140 renderUI statements with something neater, given the regularity of the source. How would you do this?
Here is an approach using lapply as suggestef in the comments. I am using some dummy data to show how you'd combine lapply with a custom numericInput function.
library(shiny)
some_values <- data.frame(Names = LETTERS[1:10], Values = seq(1, 100, 10))
make_num_in <- function(val) {
numericInput(
paste("in", val, sep = "_"),
paste("in", val, sep = "_"),
min = 0,
max = 100,
value = some_values[some_values$Names == val, "Values"]
)
}
ui <- basicPage(
column(5,
actionButton("show1", "show 1"),
uiOutput("box1"),
actionButton("show2", "show 2"),
uiOutput("box2")
),
column(5,
textOutput("input_A"),
textOutput("input_F")
)
)
server <- function(input, output, session) {
observeEvent(input$show1, {
output$box1 <-
renderUI({
tagList(lapply(LETTERS[1:5], make_num_in))
})
})
observeEvent(input$show2, {
output$box2 <-
renderUI({
tagList(lapply(LETTERS[6:10], make_num_in))
})
})
output$input_A <- renderText(paste("input A is: ", input[["in_A"]]))
output$input_F <- renderText(paste("input F is: ", input[["in_F"]]))
}
shinyApp(ui, server)
I am building a relatively complicated app, where I have dynamic number of inputs titled:
d1, d2 .. dn. At one point I wanted to try addressing multiple inputs at the same time with:
input[[grep(pattern="d+[[:digit:]]",input)]]
which of course caused an error:
Must use single string to index into reactivevalues
So I was wondering whether someone knew an elegant way to do such a thing?
You can use names on input :
grep(pattern = "d+[[:digit:]]", x = names(input), value = TRUE)
A working example :
library("shiny")
ui <- fluidPage(
fluidRow(
column(
width = 6,
lapply(
X = 1:6,
FUN = function(i) {
sliderInput(inputId = paste0("d", i), label = i, min = 0, max = 10, value = i)
}
)
),
column(
width = 6,
verbatimTextOutput(outputId = "test")
)
)
)
server <- function(input, output){
output$test <- renderPrint({
sapply(grep(pattern = "d+[[:digit:]]", x = names(input), value = TRUE), function(x) input[[x]])
})
}
shinyApp(ui = ui, server = server)
I would like to create many multiple selectize inputs which are connected with each other. In other words : if an item is selected in one of the selectizeinputs i would like that it disappears from the other selectizeinputs' choices. In addition, i would like that the number of selectize inputs corresponds to the number selected in a numericinput.
The example below is working. The only question I have left is on the following line :
X = 1:100, ####### QUESTION HERE
Instead of 1:100, i would like to put something like 1:input$ui_number but I have the following error in R :
Error in .getReactiveEnvironment()$currentContext() : Operation not allowed without an active reactive context.
And if I put a "reactive" or an "observe" function around the lapply, the observeEvent does not work anymore. Any trick for me ?
Thank you for your help !
modalities <- LETTERS[1:10]
library(shiny)
app <- shinyApp(
ui = tabPanel("Change modalities",
numericInput("ui_number", label="Number of modalities",min = 1, max = 4, value=3),
uiOutput("renderui")
),
server = function(input, output, session) {
output$renderui <- renderUI({
output = tagList()
for(i in 1:input$ui_number){
output[[i]] = tagList()
output[[i]][[1]] = selectizeInput(paste0("ui_mod_choose",i), label=paste0("Modality ",i),choices=modalities, multiple = TRUE)
}
return(output)
})
lapply(
X = 1:100, ####### QUESTION HERE
FUN = function(j){
observeEvent({
input[[paste0("ui_mod_choose",j)]]
},
{
sapply(1:input$ui_number,function(i){
vecteur <- do.call(c,lapply((1:input$ui_number)[-i],function(i){input[[paste0("ui_mod_choose",i)]]}))
updateSelectizeInput(session,paste0("ui_mod_choose",i),choices= modalities[!modalities %in% vecteur],selected = input[[paste0("ui_mod_choose",i)]])
})
},
ignoreNULL = FALSE)
}
)
observeEvent({
input$ui_num
},
{
sapply(1:nput$ui_num,function(i){
updateSelectizeInput(session,paste0("ui_mod_choose",i),choice= modalities,selected=NULL)
})
}
)
}
)
runApp(app)
You could have a single observe() instead of multiple observeEvent():
library(shiny)
modalities <- LETTERS[1:10]
ui = tabPanel("Change modalities",
numericInput("ui_number", label = "Number of modalities",
min = 1, max = 4, value = 3),
uiOutput("renderui"))
server = function(input, output, session) {
# Generate modalities select lists
output$renderui <- renderUI({
output = tagList()
for (i in seq_len(input$ui_number)) {
output[[i]] = selectizeInput(paste0("ui_mod_choose", i),
label = paste0("Modality ", i),
choices = modalities, multiple = TRUE)
}
return(output)
})
# Remove selected modalities from other select lists
observe({
n <- isolate(input$ui_number)
for (i in seq_len(n)) {
vecteur <- unlist(lapply((1:n)[-i], function(i)
input[[paste0("ui_mod_choose",i)]]))
updateSelectizeInput(session, paste0("ui_mod_choose",i),
choices = setdiff(modalities, vecteur),
selected = input[[paste0("ui_mod_choose",i)]])
}
})
}
runApp(shinyApp(ui, server))
I'm running into the error "Error in <-: invalid (NULL) left side of assignment" over and over again as I attempt to take a reactive object in Shiny and further manipulate it. I've provided an illustrative example below.
testdf <- data.frame(row1 = c(1,3,6), row2 = c(7, 5, 1))
ui <- fluidPage(
titlePanel("Education in Tanzania"),
sidebarLayout(
sidebarPanel(
#Select aggregation level of data
selectInput("AggregationSelect",
label = "Aggregation",
choices = list("School" = 1,
"District" = 2,
"Region" = 3),
selected = 1)
),
mainPanel(
DT::dataTableOutput("OutputTable")
)
)
)
server <- function(input, output) {
Output1 <- reactive({
testdf
})
observe({
if(2 %in% input$AggregationSelect) {
observe({Output1()$name[3] <- "b"})
} else if(3 %in% input$AggregationSelect) {
observe({Output1()$name[2] <- "c"})
} else if(1 %in% input$AggregationSelect) {
observe({Output1()$name[1] <- "a"})
}
})
output$OutputTable <- {DT::renderDataTable({
DT::datatable(Output1(),
options = list(pagelength = 25,
searching = TRUE,
paging = TRUE,
lengthChange = FALSE),
rownames = FALSE)
})
}
}
shinyApp(ui = ui, server = server)
What I need to do in my actual code is assemble a dataframe through the UI (which I am able to do and therefore have just subbed a random df in here) and then add some information (represented here with the added "names" column) based on what has been selected in the UI. It seems like it shouldn't be all that difficult to add a column to a df, but within the reactive object context, nothing I have attempted has worked. Other ways to modify reactive objects are welcome as long as they can be applied to more complex multi-step scenarios - there's no way I can get everything I need bundled into the initial assignment of the reactive object.
Reactive expressions cannot be modified from outside. You can only modify reactive values.
Generally you should never need to use observe. Use reactive expression if you don't need side effect, use reactive values with observeEvent when needed.
You must read reactive tutorials before going forward. There are quite some concepts need to be understood before you can do anything complex, especially the "force update habit". You need to let Shiny do the update properly and setup the logic correctly.
I suggest you read all the tutorials, articles about reactive in RStudio website, then watch the reactive tutorial video in Shiny conference.
Im not 100% what you're doing but I think its best if you use eventReactive that would listen to your selectInput. Note that I added the variable names to the dataframe:
library(shiny)
testdf <- data.frame(names = c(1,3,6), row2 = c(7, 5, 1))
ui <- fluidPage(
titlePanel("Education in Tanzania"),
sidebarLayout(
sidebarPanel(
#Select aggregation level of data
selectInput("AggregationSelect", label = "Aggregation",
choices = list("School" = 1, "District" = 2, "Region" = 3),selected = 1)
),
mainPanel(
DT::dataTableOutput("OutputTable")
)
)
)
server <- function(input, output) {
Output1 <- eventReactive(input$AggregationSelect,{
if(input$AggregationSelect %in% "2"){
testdf$name[3] <- "b"
return(testdf)
}
else if(input$AggregationSelect %in% "3"){
testdf$name[2] <- "c"
return(testdf)
}
else if(input$AggregationSelect %in% "1"){
testdf$name[1] <- "a"
return(testdf)
}
else{
return(testdf)
}
})
output$OutputTable <- {DT::renderDataTable({
print(Output1())
DT::datatable(Output1(),options = list(pagelength = 25,searching = TRUE,paging = TRUE,lengthChange = FALSE),rownames = FALSE)
})
}
}
shinyApp(ui = ui, server = server)
As per my understanding of your problem, i've tweaked you code as following :
testdf <- data.frame(name = c(1,2,3), freq = c(100, 200, 300))
ui <- fluidPage(
titlePanel("Education in Tanzania"),
sidebarLayout(
sidebarPanel(
#Select aggregation level of data
selectInput("AggregationSelect",
label = "Aggregation",
choices = list("School" = 1,
"District" = 2,
"Region" = 3))
),
mainPanel(
DT::dataTableOutput("OutputTable")
)
))
server <- function(input, output) {
Output1 <- reactive({
input$AggregationSelect
selection <- input$AggregationSelect
if(2 %in% selection){
testdf$name[3] <- "b"
}
else if(3 %in% selection){
testdf$name[2] <- "c"
}
else if(1 %in% selection){
testdf$name[1] <- "a"
}
testdf
})
output$OutputTable <- {DT::renderDataTable({
DT::datatable(Output1(),
options = list(pagelength = 25,
searching = TRUE,
paging = TRUE,
lengthChange = FALSE),
rownames = FALSE)
})
}}
shinyApp(ui = ui, server = server)
In my shiny app I have a dynamic input using renderUI.
This works very well, and another part of the program captures the input of the sliders.
When the application changes of status (e.g. when the button "update model" is pressed) I still need to display / use sliders with similar labels but as they are "new" the value needs to be re-initialised to zero.
The problem is that the sliders have a memory. If I re-use the same inputId
paste0(Labv[i], "_v",buttn)
shiny will have the old value associated to it.
Currently my code is using the variable buttn to bypass the problem: every time the status changes I create "new" sliders.
On the other hand the more the users will use the app, the more garbage will be collected into shiny.
I tried to use renderUI to send the list of elements to NULL, experimenting with sending a list of
updateTextInput(session, paste0(lbs[i],"_v",buttn),
label = NULL, value = NULL )
or tags$div("foo", NULL) but in each case the actual variable was rendered as text, which is worst!
# Added simplified example
library(shiny)
library(data.table)
#
dt_ = data.table( Month = month.abb[1:5],
A=rnorm(5, mean = 5, sd = 4),
B=rnorm(5, mean = 5, sd = 4),
C=rnorm(5, mean = 5, sd = 4),
D=rnorm(5, mean = 5, sd = 4),
E=rnorm(5, mean = 5, sd = 4))
dt_[,id :=.I]
dt <- copy(dt_)
setkey(dt_, "Month")
setkey(dt, "Month")
shinyApp(
ui = fluidPage(
fluidRow(
column(4,
actionButton("saveButton", "Update Model"))),
fluidRow(
column(6, dataTableOutput('DT')),
column(3, br(),br(),checkboxGroupInput("pick",h6("Picker"),
month.abb[1:5])),
column(3, uiOutput('foo'))),
fluidRow(
column(4, verbatimTextOutput('vals')))
),
server = function(session,input, output) {
valPpu <- reactiveValues()
valPpu$buttonF <- 1
valPpu$dt_ <- dt_
##
output$DT <- renderDataTable({
if(length(input$pick) > 0 ) {
# browser()
isolate( { labs <- input$pick } ) #
buttn <- valPpu$buttonF
iter <- length(labs)
valLabs <- sapply(1:iter, function(i) {
as.numeric(input[[paste0(labs[i],"_v",buttn)]]) })
if( iter == sum(sapply(valLabs,length)) ) {
cPerc <- valLabs
cPerc <- as.data.table(cPerc)
cPercDt <- cbind(Month=labs,cPerc)
ival <- which(dt[["Month"]]
%in% cPercDt[["Month"]])
setkey(cPercDt, "Month")
for(j in LETTERS[1:5]) set(dt_, i=ival,
j=j, dt[cPercDt][[j]] * (1 + dt_[cPercDt][["cPerc"]]) )
valPpu$dt_ <- dt_
} }
dt_[order(id),]
}, options = list(
scrollX = TRUE,
scrollY = "250px" ,
scrollCollapse = TRUE,
paging = FALSE,
searching = FALSE,
ordering = FALSE )
)
##
output$foo <- renderUI({
if(is.null(input$saveButton)) { return() }
if(length(input$pick) > 0 ) {
labs <- input$pick
iter <- length(labs)
buttn <- isolate(valPpu$buttonF )
valLabs <- sapply(1:iter, function(i) {
if(is.null(input[[paste0(labs[i],"_v",buttn)]] )) {
0
} else { as.numeric(input[[paste0(labs[i],"_v",buttn)]]) }
})
#
toRender <- lapply(1:iter, function(i) {
sliderInput(inputId = paste0(labs[i], "_v",buttn),
label = h6(paste0(labs[i],"")),
min = -1,
max = 1,
step = 0.01,
value = valLabs[i],
# format = "##0.#%",
ticks = FALSE, animate = FALSE)
})
toRender
}
})
observe({
if(is.null(input$saveButton)) { return() }
if(input$saveButton < valPpu$buttonF) { return() }
valPpu$buttonF <- valPpu$buttonF + 1
dt <<- valPpu$dt_
# TODO: add proper saving code
})
}
)
In the actual app the checkboxGroupInput is also driven from the server with renderUI and is reset when the "update model" is pressed. Also, there are more "events" in the UI that I haven't added to the code.
Any idea?
So your current approach actually works. FWIW, the sliders have been removed from HTML, so you do not need to worry about that. For the old values stored in input, such as input[['Jan_v1']] when the button has been clicked twice (and you only need input[['Jan_v2']]), I do not see why you care so much about them unless your total memory is less than a few kilobytes, because you only need a few bytes to store these values. It is probably true that you cannot remove these values from input, but I'd suggest you not spend time on this issue until it becomes a real problem.