Related
In my case, users can add as many date pairs as they want. First, I want to calculate the difference between these date pairs. Then, get the sum of all of these differences as an output. My progress so far is below. The result is "0" all the time. I believe there is a problem in output$text. Could you help me with this one?
library(shiny)
ui <- fluidPage(sidebarLayout(
sidebarPanel(
width = 3,
wellPanel(
id = "date_box",
dateInput(
inputId = "entranceDate",
label = "Entry Date",
format = "mm/dd/yy",
weekstart = 1
),
dateInput(
inputId = "exitDate",
label = "Exit Date",
format = "mm/dd/yy",
weekstart = 1
),
actionButton(inputId = "rm", label = "-"),
actionButton(inputId = "add", label = "+")
),
actionButton("calculate", "Calculate")
),
mainPanel(fluidRow(textOutput("text")))
)#sidebarLayout
)#fluid page
server <- function(input, output, session) {
input_counter <- reactiveVal(0)
observeEvent(input$add, {
input_counter(input_counter() + 1)
insertUI(
selector = "#date_box",
where = "beforeBegin",
ui = wellPanel(
id = paste0("selectize_div", input_counter()),
dateInput(
paste0("entranceDate", input_counter()),
label = "Entry Date",
format = "mm/dd/yy",
weekstart = 1
),
dateInput(
paste0("exitDate", input_counter()),
label = "Exit Date",
format = "mm/dd/yy",
weekstart = 1
)
)
)
})
observeEvent(input$rm, {
removeUI(selector = paste0("#selectize_div", input_counter()))
input_counter(input_counter() - 1)
})
#This is the part that doesn't work, I guess:
output$text <- eventReactive(input$calculate, {
input_exit_dates <-
as.Date(names(dateInput)[grepl("^exitDate", names(dateInput))])
input_entrance_dates <-
as.Date(names(dateInput)[grepl("^entranceDate", names(dateInput))])
Date_difference_in_days <-
difftime(input_exit_dates, input_entrance_dates, units = "days")
days <- sum(Date_difference_in_days)
#print(days)
})
}
shinyApp(ui, server)
I'm currently building a Shiny dashboard in R and I'm currently building a mechanism that would allow some user to comment some datatable inside it, and I got this mechanism done and sorted (as you can see on the code below). My problem is when I add the comments and refresh the page, the comments go away (as they should). Is there any way to save the datatable and keep the changes saved for any user to see, even after I refresh the dashboard page?
Thanks if you read this far :)
Please find a reproducible example below:
library(shiny)
library(DT)
dt <- data.table(
ID = c('Order 1','Order 2', 'Order 3', 'Order 4'),
Name = c('John','Peter','Anna','Richard')
)
ui <- fluidPage(
fluidRow(
column(2, pickerInput(inputId = 'selectID',
label = 'Select order ID to comment on:',
choices = c('Order 1','Order 2', 'Order 3', 'Order 4'),
selected='',
multiple=FALSE)),
column(2, textInput(inputId = 'comment',
label ='Please add comment in the text box:',
value = "", width = NULL,
placeholder = NULL))
,
column(1, actionButton(inputId = "button",
label = "Add Comment",
size = "extra-small",
style = "margin-top:25px"
)
)
),
fluidRow(
column(12,
dataTableOutput('data')
)
)
)
server <- function(input, output, session){
dt_comments <- reactiveVal({
data.table(
ID = character(0),
Comment = character(0),
stringsAsFactors = FALSE
)
})
dt_current <- reactive({
dt <- dt
## merge with current comments
if(nrow(dt_comments()) > 0)
dt <- merge(dt, dt_comments(), by = "ID", all.x = TRUE)
return(dt)
})
observeEvent(input$button, {
req(input$selectID)
## update df_comments by adding comments
dt_comments_new <- rbind(dt_comments(),
data.table(ID = input$selectID, Comment = input$comment)
)
## if duplicated id's keep only most recent rows
dt_comments_new <- dt_comments_new[!duplicated(dt_comments_new$ID, fromLast = TRUE), , drop = FALSE]
dt_comments(dt_comments_new)
})
output$data <- DT::renderDataTable({
req(dt_current())
dt2 <- dt_current()
## show comments if non-empty
showComments <- is.null(dt2$Comment) || !all(is.na(dt2$Comment))
DT::datatable(dt2,
editable = TRUE,
options = list(
columnDefs = list(
list(targets = ncol(dt2), visible = showComments)
)
)
)
})
}
shinyApp(ui = ui, server = server)
This question is an extension of the question I posted: this question
I created a dataframe with 3 columns: num, id and val. I want my shiny app to do the following:
a dataframe dat is filtered by num column
select an value from id column from dat (selectInput).
add text comment in a text box (textInput)
click on an action button
A new column called comment is created in the data table, text comments are added to the comment column in the row where id equals the value selected.
The code is below. I cannot figure out why it's not working.
Thank a lot in advance!
library(shiny)
library(DT)
dat = data.frame(num=rep(1:2, each=5), id=rep(LETTERS[1:5],2), val=rnorm(10))
ui = fluidPage(
fluidRow(
column(12, selectInput('selectNum', label='Select Num',
choices=1:10, selected='')),
column(2, selectInput(inputId = 'selectID',
label = 'Select ID2',
choices = LETTERS[1:10],
selected='',
multiple=TRUE)),
column(6, textInput(inputId = 'comment',
label ='Please add comment in the text box:',
value = "", width = NULL,
placeholder = NULL)),
column(2, actionButton(inputId = "button",
label = "Add Comment"))
),
fluidRow (
column(12, DT::dataTableOutput('data') )
)
)
server <- function(input, output, session) {
## make df reactive
df = reactive ({ dat %>% filter(num %in% input$selectNum) })
df_current <- reactiveVal(df())
observeEvent(input$button, {
req(df_current())
## update df by adding comments
df_new <- df_current()
df_new[df_current()$id %in% input$selectID, "Comment"] <- input$comment
df_current(df_new)
})
output$data <- DT::renderDataTable({
req(df_current())
DT::datatable(df_current(),
options = list(orderClasses = TRUE,
lengthMenu = c(5, 10, 20), pageLength = 5))
})
shinyApp(ui=ui, server=server)
Instead of using a reactive/eventReactive statement for df, it might be more natural to keep track of previously inputted comments in the Comment column using a reactiveVal object for df. See also the responses to this question: R Shiny: reactiveValues vs reactive. If you prefer to use a reactive/eventReactive statement for df it is probably better to work with a separate object to store previous input comments (instead of incorporating it into the reactive statement for df).
library(shiny)
library(DT)
dat = data.frame(num=1:10, id=LETTERS[1:10], val=rnorm(10))
ui = fluidPage(
fluidRow(
column(12, selectInput('selectNum', label='Select Num',
choices=1:10)),
column(2, selectInput(inputId = 'selectID',
label = 'Select ID2',
choices = LETTERS[1:10],
selected='',
multiple=TRUE)),
column(6, textInput(inputId = 'comment',
label ='Please add comment in the text box:',
value = "", width = NULL,
placeholder = NULL)),
column(2, actionButton(inputId = "button",
label = "Add Comment"))
),
fluidRow (
column(12, DT::dataTableOutput('data') )
)
)
server <- function(input, output, session) {
## make df reactive
df_current <- reactiveVal(dat)
observeEvent(input$button, {
req(df_current(), input$selectID %in% dat$id)
## update df by adding comments
df_new <- df_current()
df_new[df_current()$id %in% input$selectID, "Comment"] <- input$comment
df_current(df_new)
})
output$data <- DT::renderDataTable({
req(df_current())
## filter df_current by 'selectNum'
df_filtered <- df_current()[df_current()$num %in% input$selectNum, ]
## show comments if non-empty
showComments <- is.null(df_filtered$Comment) || !all(is.na(df_filtered$Comment))
DT::datatable(df_filtered,
options = list(orderClasses = TRUE,
lengthMenu = c(5, 10, 20), pageLength = 5,
columnDefs = list(
list(targets = ncol(df_filtered), visible = showComments)
)
)
)
})
}
shinyApp(ui=ui, server=server)
Edit: below an edited server function that using df_current <- reactive({...}) instead of df_current <- reactiveVal({...}) and defining a separate reactiveVal object to keep track of the comments.
server <- function(input, output, session) {
## initialize separate reactive object for comments
df_comments <- reactiveVal({
data.frame(
id = character(0),
Comment = character(0),
stringsAsFactors = FALSE
)
})
## reactive object df
df_current <- reactive({
## reactivity that df depends on
## currently df = dat does not change
df <- dat
## merge with current comments
if(nrow(df_comments()) > 0)
df <- merge(df, df_comments(), by = "id", all.x = TRUE)
return(df)
})
observeEvent(input$button, {
req(input$selectID)
## update df_comments by adding comments
df_comments_new <- rbind(df_comments(),
data.frame(id = input$selectID, Comment = input$comment)
)
## if duplicated id's keep only most recent rows
df_comments_new <- df_comments_new[!duplicated(df_comments_new$id, fromLast = TRUE), , drop = FALSE]
df_comments(df_comments_new)
})
output$data <- DT::renderDataTable({
req(df_current())
## filter df_current by 'selectNum'
df_filtered <- df_current()[df_current()$num %in% input$selectNum, ]
## show comments if non-empty
showComments <- is.null(df_filtered$Comment) || !all(is.na(df_filtered$Comment))
DT::datatable(df_filtered,
options = list(orderClasses = TRUE,
lengthMenu = c(5, 10, 20), pageLength = 5,
columnDefs = list(
list(targets = ncol(df_filtered), visible = showComments)
)
)
)
})
}
There you have got a working example.
I think the thing is that you are trying to update a value through an observeEvent which is not good according to the documentation. ?observeEvent
Use observeEvent whenever you want to perform an action in response to an event. (Note that "recalculate a value" does not generally count as performing an action–see eventReactive for that.)
library(shiny)
library(DT)
dat = data.frame(num=1:10, id=LETTERS[1:10], val=rnorm(10))
ui = fluidPage(
fluidRow(
column(12, selectInput('selectNum', label='Select Num',
choices=1:10, selected='')),
column(2, selectInput(inputId = 'selectID',
label = 'Select ID2',
choices = LETTERS[1:10],
selected='',
multiple=TRUE)),
column(6, textInput(inputId = 'comment',
label ='Please add comment in the text box:',
value = "", width = NULL,
placeholder = NULL)),
column(2, actionButton(inputId = "button",
label = "Add Comment"))
),
fluidRow (
column(12, DT::dataTableOutput('data') )
)
)
server <- function(input, output, session) {
## make df reactive
df_current = reactive({
df = dat %>% filter(num %in% input$selectNum)
if(input$button != 0) {
input$button
df[df$id %in% input$selectID, "Comment"] <- isolate(input$comment)
}
return(df)
})
output$data <- DT::renderDataTable({
req(df_current())
DT::datatable(df_current(),
options = list(orderClasses = TRUE,
lengthMenu = c(5, 10, 20), pageLength = 5))
})
}
shinyApp(ui=ui, server=server)
So you can either go with your reactive value or using eventReactive as stated in the doc.
I try to build a small shinyapp with two inputs. The second input should use values from the first input. This works fine if "single" values are passed. In the following examples, the slideinput takes the values from the radio buttons, either 1, 5 or 10 year and then adjusts the sliderinput going back 1, 5, 10 years respectively. So far so.
library(shiny)
library(lubridate)
ui = fluidPage(
titlePanel("Changing the values of inputs"),
fluidRow(
radioButtons("control_num",
"Choose time span:",
choiceNames = list("10 years",
"5 years",
"1 year"),
choiceValues = list(10,
5,
3 ),
inline = T),
sliderInput(inputId = "inSlider2",
label = "timeline:",
min = as.Date("2001-01-01") ,
max = as.Date("2016-12-31"),
value = c(as.Date( "2011-01-01") , as.Date("2013-01-01" ) ),
step = 1,
width = "90%"
)
)
)
server = function(input, output, session) {
observe({
c_num <- as.numeric( input$control_num )
c_num1 <- as.Date("2016-12-31") - years( c_num )
c_num2 <- as.Date("2016-12-31")
# Slider range input
updateSliderInput(session, "inSlider2",
value = c(c_num1 , c_num2) )
})
}
shinyApp(ui = ui, server = server)
However, if I want to pass a list of lists, e.g. several date ranges, say calendar year 2015, 2014 and 2013. Each of these consists of a list of two dates: start date (1st Jan) and end date (31st Dec).
The problems shows up when I try to pass this list of lists in "choiceValues" instead of a list of values.
library(shiny)
library(lubridate)
ui = fluidPage(
titlePanel("Changing the values of inputs from the server"),
fluidRow(
radioButtons("control_num2",
"Choose time span:",
choiceNames = list("2015",
"2014",
"2013"),
choiceValues = list(c(as.Date("2015-01-01" ), as.Date("2015-12-31") ),
c(as.Date("2014-01-01" ), as.Date("2014-12-31") ),
c(as.Date("2013-01-01" ), as.Date("2013-12-31") )
),
inline = T),
sliderInput(inputId = "inSlider2",
label = "timeliner:",
min = as.Date("2001-01-01") ,
max = as.Date("2016-12-31"),
value = c(as.Date( "2011-01-01") , as.Date("2013-01-01" ) ),
step = 1,
width = "90%"
)
)
)
server = function(input, output, session) {
observe({
c_num <- input$control_num2
c_num1 <- as.list(input$control_num2 )
# used to check the structure of the input variable
updateNumericInput(session, "control_num2",
label = paste("Input ", c_num,
"Input as list: ", c_num1,
"First element of list: ", c_num1[1] ),
value = c_num)
# Slider range input
updateSliderInput(session, "inSlider2",
value = c_num )
})
}
shinyApp(ui = ui, server = server)
When the parameters is evaluated in the observe part of the code, the "input$conrol_num" is always taken as a list of character with length of one.
I had some warnings along these lines.
So I guess there is no possiblity to pass a list of lists here. What would be an elegant way to solve the problem?
I don't thinks it's possible to have lists or vectors as values in an input. Try having a unique id string for each value, pass that on to the server, then look up the value in a named list. e.g.
# in UI
radioButtons("control_num2",
"Choose time span:",
choiceNames = c("2015","2014","2013"),
choiceValues = c("year2015", "year2014", "year2015")
inline = T)
# in server
idmap <- list("year2015" = c(as.Date("2015-01-01" ), as.Date("2015-12-31") ),
"year2014" = c(as.Date("2014-01-01" ), as.Date("2014-12-31") ),
"year2013" = c(as.Date("2013-01-01" ), as.Date("2013-12-31") ))
observe({
req(input$control_num2)
c_num <- idmap[[input$control_num2]]
# Slider range input
updateSliderInput(session, "inSlider2",
value = c_num )
})
[edit] sorry, there was a typo in updateSliderInput. Complete working version:
library(shiny)
library(lubridate)
ui = fluidPage(
titlePanel("Changing the values of inputs from the server"),
fluidRow(
radioButtons("control_num2",
"Choose time span:",
choices=c("2015"="year2015", "2014"="year2014", "2013"="year2013"),
inline = T),
sliderInput(inputId = "inSlider2",
label = "timeliner:",
min = as.Date("2001-01-01") ,
max = as.Date("2016-12-31"),
value = c(as.Date( "2011-01-01") , as.Date("2013-01-01" ) ),
step = 1,
width = "90%")))
server = function(input, output, session) {
idmap <- list("year2015" = c(as.Date("2015-01-01" ), as.Date("2015-12-31") ),
"year2014" = c(as.Date("2014-01-01" ), as.Date("2014-12-31") ),
"year2013" = c(as.Date("2013-01-01" ), as.Date("2013-12-31") ))
observe({
req(input$control_num2)
c_num <- idmap[[input$control_num2]]
# Slider range input
updateSliderInput(session, "inSlider2",
value = c_num )
})
}
shinyApp(ui = ui, server = server)
I learned to use dynamic select input in my shiny application from the Rstudio shiny examples (http://shiny.rstudio.com/gallery/update-input-demo.html). Everything seemed to be OK, but an error occurred. I tested a lot and found the error was due to the dynamic select input used (the observe function in the server.R). But I can't figure out how to fix it. Any help would be highly appreciated. Thanks!
To save space, some of the code was not shown.
server.R
load("./data/genomicVar.RData")
load("./data/geneInfo.RData")
fetchInfoByMsu <- function(locus="") {...}
fetchSnpByMsu <- function(locus="") {...}
fetchIndelByMsu <- function(locus="") {...}
fetchSvByMsu <- function(locus="") {...}
fetchExpByMsu <- function(locus="") {...}
fetchInfoByBin <- function(binNumber="") {...}
fetchGeneByBin <- function(binNumber="") {...}
shinyServer(function(input, output, session) {
output$mytable1 = renderDataTable({...})
output$mytable2 = renderDataTable({...})
output$mytable3 = renderDataTable({...})
output$mytable4 = renderDataTable({...})
output$mytable5 = renderDataTable({...})
output$mytable6 = renderDataTable({...})
output$mytable7 = renderDataTable({...})
observe({
c_bin <- input$bin
c_gene <- fetchGeneByBin(input$bin)
c_gene <- c_gene$locus
# Select input
s_options <- list()
for (i in c_gene) {
s_options[[i]] <- i
}
# Change values for input$inSelect
updateSelectInput(session, "inSelect",
choices = s_options,
selected = c_gene[1]
)
})
output$mytable8 = renderDataTable({...})
output$mytable9 = renderDataTable({...})
output$mytable10 = renderDataTable({...})
output$mytable11 = renderDataTable({...})
output$mytable12 = renderDataTable({...})
})
UI.R
shinyUI(fluidPage(
fluidRow(
absolutePanel(
textInput("msu", label = h4("MSU genomic locus:"),
value = "LOC_Os07g15770"),
tabsetPanel(
tabPanel(strong('Information'), dataTableOutput("mytable1")),
tabPanel(strong('SNP'), dataTableOutput("mytable2")),
tabPanel(strong('Indels'), dataTableOutput("mytable3")),
tabPanel(strong('SVs'), dataTableOutput("mytable4")),
tabPanel(strong('Expression'), dataTableOutput("mytable5"))
),
br(),
p(HTML("<b><div style='background-color:#FADDF2;border:1px solid
blue;'></div></b>")),
textInput("bin", label = h4("Bin ID:"), value = "Bin1078"),
tabsetPanel(
tabPanel(strong('Information'), dataTableOutput("mytable6")),
tabPanel(strong('Gene'), dataTableOutput("mytable7"))
),
wellPanel(
selectInput("inSelect", strong("Select gene:"),
c("gene 1" = "option1",
"gene 2" = "option2"))
),
tabsetPanel(
tabPanel(strong('Information'), dataTableOutput("mytable8")),
tabPanel(strong('SNP'), dataTableOutput("mytable9")),
tabPanel(strong('Indels'), dataTableOutput("mytable10")),
tabPanel(strong('SVs'), dataTableOutput("mytable11")),
tabPanel(strong('Expression'), dataTableOutput("mytable12"))
),
br(),
p(HTML("<b><div style='background-color:#FADDF2;border:1px solid
blue;'></div></b>")),
right=5, left=10
)
)
))
I prefer using uiOutput for dynamic inputs, see this minimal example:
ui.R
shinyUI(fluidPage(
fluidRow(
absolutePanel(
#select bin
textInput("bin", label = h4("Bin ID:"), value = 1),
#dynamic options based on selected bin
uiOutput("inSelect")
)
)
)
)
server.R
shinyServer(function(input, output, session){
#genes dataframe
df <- data.frame(bin=c(1,1,1,2,2,2),
gene=c(12,13,14,21,23,24))
#dynamic select
output$inSelect <- renderUI({
selectInput("inSelect", strong("Select gene:"),
choices = df[ df$bin==input$bin,"gene"])
})
})