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)
})
Related
I am working in a shiny app to compare multiple items according to an input defined by the user. The code works fine but I have an issue. I do not know what function I should apply in order to display the results of some computing as tables in the right side of the app. The code of the app is next:
library(shiny)
library(shinydashboard)
#Function
compute <- function(firstitem,seconditem)
{
Sum <- firstitem+seconditem
Difference <- firstitem+seconditem
Product <- firstitem*seconditem
Ratio <- firstitem/seconditem
Res <- data.frame(C1=Sum,C2=Difference,C3=Product,C4=Ratio)
return(Res)
}
#App
ui = shinyUI(fluidPage(
titlePanel("Compare"),
sidebarLayout(
sidebarPanel(
numericInput("numitems", label = "Number of items to compare?",
min = 1, max = 5, value = 1),
uiOutput("period_cutpoints"),
uiOutput("period_cutpoints2"),
actionButton("submit", "Submit")
),
mainPanel(
textOutput("numitems"),
textOutput("cutpoints")
)
)
))
server = shinyServer(function(input, output, session) {
output$period_cutpoints<-renderUI({
req(input$numitems)
lapply(1:(input$numitems), function(i) {
numericInput(inputId=paste0("firstitem",i),
label=paste0("Enter the value of first item ", i, ":"),value = 0)
})
})
output$period_cutpoints2<-renderUI({
req(input$numitems)
lapply(1:(input$numitems), function(i) {
numericInput(inputId=paste0("seconditem",i),
label=paste0("Enter the value of second item ", i, ":"),value = 0)
})
})
seldates <- reactiveValues(x=NULL)
observeEvent(input$submit, {
seldates$x <- list()
lapply(1:(input$numitems), function(i) {
seldates$x[[i]] <- compute(firstitem = input[[paste0("firstitem", i)]],seconditem = input[[paste0("seconditem", i)]])
})
})
output$cutpoints <- renderText({as.character(seldates$x)})
})
shinyApp(ui = ui, server = server)
It is working but my issue is that I do not know how to set the content of seldates, which are dataframes, as tables that should appear one after another. This task is done with output$cutpoints but I can not get them as Tables:
Does anybody know how can I fix this issue? Many thanks!
Try this
library(shiny)
library(shinydashboard)
library(DT)
#Function
compute <- function(firstitem,seconditem)
{
Sum <- firstitem+seconditem
Difference <- firstitem+seconditem
Product <- firstitem*seconditem
Ratio <- firstitem/seconditem
Res <- data.frame(C1=Sum,C2=Difference,C3=Product,C4=Ratio)
return(Res)
}
#App
ui = shinyUI(fluidPage(
titlePanel("Compare"),
sidebarLayout(
sidebarPanel(
numericInput("numitems", label = "Number of items to compare?",
min = 1, max = 5, value = 1),
uiOutput("period_cutpoints"),
uiOutput("period_cutpoints2"),
actionButton("submit", "Submit")
),
mainPanel(
textOutput("numitems"),
textOutput("cutpoints"),
uiOutput("t1")
)
)
))
server = shinyServer(function(input, output, session) {
output$period_cutpoints<-renderUI({
req(input$numitems)
lapply(1:(input$numitems), function(i) {
numericInput(inputId=paste0("firstitem",i),
label=paste0("Enter the value of first item ", i, ":"),value = i)
})
})
output$period_cutpoints2<-renderUI({
req(input$numitems)
lapply(1:(input$numitems), function(i) {
numericInput(inputId=paste0("seconditem",i),
label=paste0("Enter the value of second item ", i, ":"),value = i+i)
})
})
seldates <- reactiveValues(x=NULL)
observeEvent(input$submit, {
seldates$x <- list()
lapply(1:(input$numitems), function(i) {
seldates$x[[i]] <- compute(firstitem = input[[paste0("firstitem", i)]],seconditem = input[[paste0("seconditem", i)]])
})
})
output$cutpoints <- renderText({as.character(seldates$x)})
observeEvent(input$submit, {
lapply(1:(input$numitems), function(i) {
output[[paste0("table",i)]] <- renderDT(seldates$x[[i]])
})
output$t1 <- renderUI({
tagList(
lapply(1:(input$numitems), function(i) {
DTOutput(paste0("table",i))
})
)
})
})
})
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 am developing the Shiny app and I am unable to sum the values entered in dynamically created textInput.
The RCode used is as follows:
ui <- fluidPage(
fluidRow(
column(3, offset = 3,wellPanel(textOutput("text2"))),
column(3,wellPanel(textOutput("text3"))),
column(3,wellPanel(textOutput("text4")))
)
)
server <- function(input, output, session){
observeEvent(input$view, {
output$inputGroup = renderUI({
#code for generating textBoxes and corresponding Id's dynamically
input_list <- lapply(1:(nrow(df())*3), function(i) {
inputName <- paste("id", i, sep = "")
textInputRow<-function (inputId,value)
{
textAreaInput(inputName,"", width = "200px", height = "43px", resize = "horizontal")
}
column(4,
textInputRow(inputName, "")
)
})
do.call(tagList, input_list)
})
})
#code for adding the values and displaying the sum
output$text2 <- renderText({
tot = nrow(df())*3
sum1 = 0
for(lim in 1:tot){
if(lim %% 3 == 1){
inp = paste("id",lim)
sum1 = sum1 + input[[inp]]
}
}
})
}
shinyApp(ui = ui, server = server)
The output is :
Can anyone help me with this code?
While your question is modified, Here's a reproducible code for summing values entered in the textbox:
## Only run examples in interactive R sessions
if (interactive()) {
ui <- fluidPage(
textInput("input1", "Input1", 1),
textInput("input2", "Input2", 2),
tags$h3('Result:'),
verbatimTextOutput("value")
)
server <- function(input, output) {
output$value <- renderText({ as.numeric(input$input1) + as.numeric(input$input2)})
}
shinyApp(ui, server)
}
SelectInput function in ui is supposed to give me an option to choose "YES" or "NO". When "NO" is selected, it will choose the " if(("NO" %in% input$qualify_pit))" block in renderDataTable function in server and execute that perfectly. However, when I choose "YES" option, its block does not run, not displaying any table. I tried everything to get it to run its block (if(("YES" %in% input$qualify_pit))) but to no avail.
library(shiny)
library(shinythemes)
library(DT)
pit <- read.csv("PIT_STAT.csv")
pit_stat <- c("MLB_name","MLBId","LastName","FirstName","LW","W","L","Sv","BS","HLD","G","GS","CG","GF","QS","SHO","IP","BFP","H","X1B","X2B","X3B",
"HR","R","ER","SH","SF","HBP","BB","IBB","BB_noIBB","K","WP","BLK","GB","FB","LD","POPU","SB",
"CS","PKO","SVO","OUTS","K9","BB9","AVG","BABIP","HR9","GB_percent","HRperFB","ERA","KperBB",
"K_percent","BB_percent","K_minus_BB","WHIP","LD_percent","FB_percent","GBperFB")
pit_def <- c("MLB_name","MLBId","LastName","FirstName","LW","W","L","ERA","IP","H","HR","R","ER","BB","K","K9","BB9","HR9","WHIP",
"GB_percent","FB_percent","LD_percent","K_percent","BB_percent","KperBB","K_minus_BB")
ui <- shinyUI(fluidPage(
shinythemes::themeSelector(),
theme = shinytheme("paper"),
titlePanel("WSFB Stats Lab"),
fluidRow(
uiOutput("uis")
),
fluidRow(
tabsetPanel(id = "tabs",
tabPanel("Pitch Table",dataTableOutput("pitch_table"))
)
)
)
)
server <- shinyServer(function(input, output, session){
output$uis <- renderUI({
if(input$tabs == "Pitch Table")
{
pit <- read.csv("PIT_STAT.csv")
pit_stat <- c("MLB_name","MLBId","LastName","FirstName","LW","W","L","Sv","BS","HLD","G","GS","CG","GF","QS","SHO","IP","BFP","H","X1B","X2B","X3B",
"HR","R","ER","SH","SF","HBP","BB","IBB","BB_noIBB","K","WP","BLK","GB","FB","LD","POPU","SB",
"CS","PKO","SVO","OUTS","K9","BB9","AVG","BABIP","HR9","GB_percent","HRperFB","ERA","KperBB",
"K_percent","BB_percent","K_minus_BB","WHIP","LD_percent","FB_percent","GBperFB")
pit_def <- c("MLB_name","MLBId","LastName","FirstName","LW","W","L","ERA","IP","H","HR","R","ER","BB","K","K9","BB9","HR9","WHIP",
"GB_percent","FB_percent","LD_percent","K_percent","BB_percent","KperBB","K_minus_BB")
wellPanel(
checkboxGroupInput('show_vars', 'Variables to display', pit_stat, inline = TRUE, selected = pit_def),
selectInput("qualify_pit","MIN IP:",choices = c("YES","NO"))
)
}
})
output$pitch_table <- renderDataTable({
if(("YES" %in% input$qualify_pit))
{
pit <- read.csv("PIT_STAT.csv")
pit2 <- pit[pit$IP >= 162,]
DT::datatable(pit2[,input$show_vars, drop = FALSE])
}
if(("NO" %in% input$qualify_pit))
{
pit <- read.csv("PIT_STAT.csv")
DT::datatable(pit[,input$show_vars, drop = FALSE])
}
})
})
shinyApp(ui = ui, server = server)
It works with NO because the DT:datatable is the last expression of the function, therefore it is the implicit return value.
But for the YES, which is not the last evaluation (the if("NO" %in%... is), you have to explicitly use return:
return(DT::datatable(pit2[,input$show_vars, drop = FALSE]))
Otherwise you can simply use else
output$pitch_table <- renderDataTable({
if(("YES" %in% input$qualify_pit))
{
DT::datatable(pit[pit$IP >= 162,input$show_vars, drop = FALSE])
}
else
{
DT::datatable(pit[,input$show_vars, drop = FALSE])
}
})
For more details about using return you can read this thread
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