first I know there is a lot of threads covering my problem, I read them all, but I did not manage to do it. I got a list of 10 data.frame which I built through the following code :
list_of_df=list()
for (i in seq(1,10)){
number_row=sample(seq(5,10),size = 1)
num=seq(1,number_row)
val=sample(x = letters,size = number_row,replace = TRUE )
df=data.frame(num=num,
val=val)
rownames(df)=NULL
list_of_df[[i]]=df
}
I want the user to enter n, the number of tables he wants to see. And then display n random tables from the list_of_df. I want to display those tables inside tabs. Here is what I did, I grabbed some ideas here and there, but obviously it does not work and I do not know why.
library(shiny)
# ui function
ui = pageWithSidebar(
headerPanel('Dynamic Tabs'),
sidebarPanel(
numericInput(inputId = "numput",label = "number of tables",value = 1,min = 1,max = 5)
),
mainPanel(
uiOutput('mytabs')
)
)
# server function
server = function(input, output, session){
random_tables<- reactive({
index=sample(seq(1,10),size = input$numput,replace=FALSE)
list_of_df[[index]]
})
size<-reactive({
length(random_tables())
})
for (i in 1:size()) {
local({
my_i <- i
tablename <- paste("table_", my_i, sep="")
output[[tablename]] <- renderTable({
random_tables()[[i]]
})
})
}
output$mytabs = renderUI({
nTabs = size()
myTabs = lapply(paste0('table_', 1: nTabs), function(x){
tabPanel(x, tableOutput(x))
})
do.call(tabsetPanel, myTabs)
})
}
shinyApp(ui, server)
So, if you see what I should do ...
Here is a working version:
library(shiny)
# ui function
ui = pageWithSidebar(
headerPanel('Dynamic Tabs'),
sidebarPanel(
numericInput(inputId = 'numput',label = "number of tables",value = 1,min = 1,max = 5)
),
mainPanel(
uiOutput('mytabs')
)
)
# server function
server = function(input, output, session){
list_of_df=list()
for (i in seq(1,10)){
number_row=sample(seq(5,10),size = 1)
num=seq(1,number_row)
val=sample(x = letters,size = number_row,replace = TRUE )
df=data.frame(num=num,
val=val)
rownames(df)=NULL
list_of_df[[i]]=df
}
random_tables<- reactive({
index=sample(seq(1,10),size = input$numput,replace=FALSE)
list_of_df[index]
})
size<-reactive({
input$numput
})
observe({
lapply(seq_len(size()), function(i) {
local({
my_i <- i
tablename <- paste("table_", my_i, sep="")
output[[tablename]] <- renderTable({
random_tables()[[i]]
})
})
})
})
output$mytabs = renderUI({
nTabs = size()
myTabs = lapply(paste0('table_', seq_len(nTabs)), function(x){
tabPanel(x, tableOutput(x))
})
do.call(tabsetPanel, myTabs)
})
}
shinyApp(ui=ui,server=server)
A couple issues, you subset the list with double brackets, but it isn't working like you think it is, you need single brackets. Next when you select a single table random_table() is a data.frame so when you call length you get 2, the number of columns. So just use the input$numput for size() since they are the same anyways. Also, I put the dynamic output in an observe so that it can access the reactive size(). A small thing, but I used seq_len instead of 1:aNumber since it is more robust.
Hope this helps
Related
I am new to Shiny. What I want to do in my application is, running & displaying some part of the code only when a condition on another calculation is met.
The conditionalPanel works fine with the conditions on input values but I could not figure out how to do this with the 'output' values, i.e., conditionally on the output values of the functions. Below is my example code:
library(shiny)
msLocation <- "msLoc"
searchMWText <- "searchMW"
bid <- "2333333"
fulltext <- "fullDisplay"
ui <- fluidPage(
titlePanel("Run server codes conditionally"),
sidebarLayout(
sidebarPanel(
helpText("Evaluate input and run different parts of the code depending on the output functions"),
br(),
sliderInput("rand", "select seed", min = 1, max = 50, step = 1, value = 1)
),
mainPanel(
fluidRow(conditionalPanel("output.rand == 1"),
tags$h4("Here comes the default part"),
br(),
textOutput("defaultCalc")),
fluidRow(conditionalPanel("output.randomint != 1",
tags$h4("I can evaluate if the chosen number is even or odd."),
br(),
textOutput("evenodd")
),
fluidRow(conditionalPanel("output.evenodd == 'Number is even'",
tags$h4("Number even calculation "),
textOutput("msLoc"),
br(),
textOutput("searchMW"),
br(),
textOutput("defaultID"),
br()
),
fluidRow(conditionalPanel("output.evenodd == 'Number is odd'",
tags$h4("Here is some id:", textOutput("id")),
textOutput("displayFull")
)
)
)
)
)))
#
server <- function(input, output) {
rand1 <- reactive({
if(is.null(input$rand)){return(NULL)}
rn <- input$rand
return(rn)
})
randomint <- reactive({
seedn <- rand1()
set.seed(seedn)
rint <- sample(1:50, 1)
return(rint)
})
calc1 <- reactive({
intn <- randomint()
modn <- intn %% 2
return(modn)
})
evenOdd <- reactive({
modn <- calc1()
if(modn == 0){valueText = "Number is even"}
if(modn != 0){valueText = "Number is odd"}
return(valueText)
})
idtext <- reactive({
idint <- sample(1:10000, 3)
idint <- as.character(idint)
idint <- paste(idint, collapse = "")
return(idint)
})
output$defaultCalc <- renderText({
as.character(randomint())
})
output$evenodd <- renderText({
evenOdd()
})
output$searchMW <- renderText({
searchMWText
})
output$defaultID <- renderText({
bid
})
output$id <- renderText({
idtext()
})
output$displayFull <- renderText({
fulltext
})
}
shinyApp(ui = ui, server = server)
The problem is, the parts after default always appear, e..g., 'Here is some id' text always appears and this is not what I want. I want to display 'Here is some id' and run the calculation (idtext) only when the number is odd.The number is not coming from the slider input, the slider input is providing the seed only. The number is also calculated and depends on its value, the other parts should be run and displayed. Until the user selects a slider input value, only the 'default part' should be displayed and nothing else.
I searched a lot and could not find a solution that mentions the conditions on output. What is the best way to solve this?
Do:
randomint <- reactive({
seedn <- rand1()
set.seed(seedn)
rint <- sample(1:50, 1)
return(rint)
})
output$randomint <- reactive(randomint())
outputOptions(output, "randomint", suspendWhenHidden = FALSE)
Then you can use "output.randomint !== 1".
I have been trying to reconstruct the following simplistic Shiny app using modules since I believe that will be the best way to organize this code inside a much larger application where I will use these kinds of linked-slider-numeric inputs in many places.
However, I cannot figure out how to achieve the same kind of functionality from within a module.
Here's an example app that works exactly as intended, but not using modules:
library(shiny)
# Let's build a linked Slider and Numeric Input
server <- function(input, output) {
values <- reactiveValues(numval=1)
observe({
values$numval <- input$slider
})
observe({
values$numval <- input$number
})
output$slide <- renderUI({
sliderInput(
inputId = 'slider'
,label = 'SN'
,min = 0
,max = 10
,value = values$numval
)})
output$num <- renderUI({
numericInput(
inputId = 'number'
,label = 'SN'
,value = values$numval
,min = 0
,max = 10
)
})
}
ui <- fluidPage(
uiOutput('slide'),
uiOutput('num')
)
shinyApp(ui, server)
Here's my attempt. (Note that "mortalityRate" and associated strings are just an example of the variable name(s) I'll be using later). I have tried several variations on this attempt, but inevitably I get errors, usually indicating I'm doing something that can only be done inside a reactive context:
numericSliderUI <- function(id, label = "Enter value", min = 1, max = 40, value) {
ns <- NS(id)
tagList(
sliderInput(inputId = paste0(ns(id), "Slider"), label = label, min = min, max = max, value = value),
numericInput(inputId = paste0(ns(id), "Numeric"), label = label, min = min, max = max, value = value)
)
}
numericSlider <-
function(input,
output,
session,
value,
mortalityRateSlider,
mortalityRateNumeric
) {
values <- reactiveValues(mortalityRate = value())
observe({
values[['mortalityRate']] <- mortalityRateSlider()
})
observe({
values[['mortalityRate']] <- mortalityRateNumeric()
})
return( reactive( values[['mortalityRate']] ) )
}
library(shiny)
# source("modules.R") # I keep the modules in a separate file, but they're just pasted above for convenience here on StackOverflow.
ui <- fluidPage(
uiOutput('mortalityRate')
)
server <- function(input, output) {
values <- reactiveValues(mortalityRate = 1)
mortalityRateValue <- callModule(
numericSlider,
id = 'mortalityRate',
value = values[['mortalityRate']],
mortalityRateSlider = reactive( input$mortalityRateSlider ),
mortalityRateNumeric = reactive( input$mortalityRateNumeric )
)
values[['mortalityRate']] <- reactive( mortalityRateValue() )
output$mortalityRate <- renderUI(numericSliderUI('mortalityRate', value = values[['mortalityRate']]))
}
shinyApp(ui = ui, server = server)
I know that I must be doing something wrong with the reactiveValues and the way I'm using the observe statements inside the module, but this is my best attempt at using the module structure, so any help figuring out what I'm doing wrong would be very helpful.
Here is working code. There are a variety of changes, so I'll direct you to this Github page that also sets up a structure for using renderUI with modules. In general, I think the problems in your code involved trying to define reactive values inside the callModule function, and in passing the values of the sliders and numeric box back and forth.
Other features of using modules are that in your actual UI call, you need to call the UI module, where in turn you can call uiOutput. Inside renderUI is where you can set up the inputs. Additionally, inside modules you don't need the session namespaces, but you do need to wrap those ids in session$ns() to ensure they work across modules.
UI and Server Modules:
numericSliderUI <- function(id) {
ns <- NS(id)
uiOutput(ns('mortalityRate'))
}
numericSlider <- function(input, output, session) {
values <- reactiveValues(mortalityRate = 1)
observe({
values[['mortalityRate']] <- input$Slider
})
observe({
values[['mortalityRate']] <- input$Numeric
})
output$mortalityRate <- renderUI(
tagList(
sliderInput(inputId = session$ns("Slider"), label = "Enter value:", min = 1, max = 40, value = values[['mortalityRate']]),
numericInput(inputId = session$ns("Numeric"), label = "Enter value:", min = 1, max = 40, value = values[['mortalityRate']])
)
)
return(list(value = reactive({values[['mortalityRate']]})))
}
UI and Server functions:
ui <- fluidPage(
numericSliderUI('mortalityRate')
)
server <- function(input, output, session) {
mortalityRateValue <- callModule(numericSlider, 'mortalityRate')
}
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))
What I want to do is to make the output from the for loop run available for many render outputs in Shiny App.
I created the simple example of my problem.
There is the same for loop in each renderPrint() function.
Can I code that in such a way that the for loop is moved outside render*() functions?
I've found examples how to use reactives in loops but haven't found a solution to the reversed task.
Thank you for your help and attention.
library(shiny)
ui <- fluidPage(sidebarLayout(
sidebarPanel(
numericInput(
inputId = "seed",
label = "Set seed:",
value = 1
),
numericInput(
inputId = "Number",
label = "Number:",
value = 1,
min = 1,
step = 1
)
),
mainPanel(
verbatimTextOutput("summary"),
dataTableOutput("table"),
verbatimTextOutput("data")
)
))
server <- function(input, output) {
a <- reactive({
set.seed(input$seed)
rnorm(input$Number, 2, 1)
})
b <- reactive({
5 * a()
})
rn <- reactive({
c(1:input$Number)
})
fun <- function(x, y) {
x + y
}
Table <- reactive({
data.frame(rn = rn(),
a = a(),
b = b())
})
output$table <- renderDataTable({
Table()
})
output$summary <- renderPrint({
for (i in Table()$rn) {
print (fun(Table()$a[i], Table()$b[i]))
}
})
output$data <- renderPrint({
for (i in Table()$rn) {
print (fun(Table()$a[i], Table()$b[i]))
}
})
}
shinyApp(ui = ui, server = server)
Extract the for loop into a function. You can use reactive values in functions with no problem, as long as you're not calling the function outside a reactive context (render*, reactive, observe).
Example:
printTable <- function() {
for (i in Table()$rn) {
print (fun(Table()$a[i], Table()$b[i]))
}
}
output$summary <- renderPrint({
printTable()
})
output$data <- renderPrint({
printTable()
})
or more efficiently, you could capture the print output as a string and just re-use it:
capturedTableString <- reactive({
capture.output({
for (i in Table()$rn) {
print (fun(Table()$a[i], Table()$b[i]))
}
})
})
printTable <- function() {
cat(capturedTableString(), sep = "\n")
}
output$summary <- renderPrint({
printTable()
})
I am trying to dynamically render multiple text output from multiple text input. I tried to use this very helpfull example and this one too.
This conversation is also helpfull.
But when I try to adapt this examples on the following script, I have a problem of output update. Apparently, only the last element was read and updated. It's probably a reactivity problem but it seems to be difficult to associate reactive{()} and renderUI{()}functions.
rm(list = ls())
library(shiny)
creatDataElem <- function(ne, input) {
x1 <- lapply(1:ne, function(i) {
textInput(paste0("elemName", i),
label = h4(strong("Name of dataset element")),
value = "")
})
return(x1)
}
ui = (fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput("elemNb",
"Number of elements", value = 1, min = 1,
max = 3)
,
conditionalPanel(
condition = "input.elemNb == 1",
creatDataElem(1)
),
conditionalPanel(
condition = "input.elemNb == 2",
creatDataElem(2)
),
conditionalPanel(
condition = "input.elemNb == 3",
creatDataElem(3)
)
),
mainPanel(
uiOutput("nameElem")
)
)
)
)
server = function(input, output, session) {
max_elem <- 3
# Name
output$nameElem <-renderUI({
nameElem_output_list <- lapply(1:input$elemNb, function(i) {
elemName <- paste0("elemName", i)
tags$div(class = "group-output",
verbatimTextOutput(elemName)
)
})
do.call(tagList, nameElem_output_list)
})
for (i in 1:max_elem) {
local({
force(i)
my_i <- i
elemName <- paste0("elemName", my_i)
output[[elemName]] <- renderPrint(input[[elemName]])
})
}
}
runApp(list(ui = ui, server = server))
The idea with a reactive({}) function is to add an independant object (a function in this case) like:
nameElem <- reactive({
if (input$goElem == 0) {
return()
} else {
isolate({
if (is.null(input$elemName)) {
return()
} else if (test(input$elemName)) {
return("TEST RESULT")
} else {
return(input$elemName)
}
})
}
})
and to use renderUI on this object (with an ActionButton).
So, if someone knows why the output does not return the good object...
I think one of your problems is that your creatDataElem function is such that when it is called with argument ne=3, the first and second textInput elements are created again (and their value "lost").
Anyway, I think one solution would be to create those textInput elements as an "uiOutput".
You'll find a possible solution below which (I think) does what you want.
Lise
rm(list = ls())
library(shiny)
ui = (fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput("elemNb",
"Number of elements", value = 1, min = 1,
max = 3),
uiOutput("myUI")
),
mainPanel(
uiOutput("nameElem")
)
)
)
)
server = function(input, output, session) {
output$myUI=renderUI({
w=""
for (i in 1:input$elemNb){
w=paste0(w,
textInput(paste0("elemName",i),label='Name of dataset element'))
}
HTML(w)
})
output$nameElem <-renderUI({
elems=c("<div>")
for(i in 1:input$elemNb){
elems=paste(elems,"</div><div>",input[[paste0("elemName",i)]])
}
elems=paste0(elems,"</div>")
HTML(elems)
})
}
runApp(list(ui = ui, server = server))
Found a solution:
library(readr)
library(dplyr)
library(shiny)
df <- data.frame(symbol = 1:10)
uiOutput("myUI")
createUI <- function(dfID, symbol) {
div(class="flex-box",paste0(symbol, " - 10"))
}
output$myUI <- renderUI({
w <- lapply(seq_len(nrow(df)), function(i) {
createUI(i, df[i,"symbol"])
})
do.call(fluidPage,w)
})