Trying to understand how to create observeEvent()'s to catch changes to an arbitrary number of dynamically-created RHandsontables. Has anyone successfully done this before?
The code below shows creation of the dynamic tables. The comments towards the bottom indicate the inputs I would like to track, but the observeEvents need to account for an arbitrary set of input names.
library(shiny)
library(dplyr)
library(rhandsontable)
library(purrr)
ui <- fluidPage(
uiOutput('tables')
)
server <- function(input, output) {
mtcars$slc <- sample(c('aaa','bbb'),nrow(mtcars),replace=TRUE)
df <- mtcars
getSlice <- function(df_tmp,slca){
print(slca)
df_tmp <- df_tmp %>% filter(slc==slca)
df_tmp
}
output$tables <- renderUI({
slices <- unique(df$slc)
input_dfs <- map(slices,~getSlice(df,.x))
for(i in 1:length(slices)){
local({
i <- i
print(input_dfs[[i]])
output[[slices[i]]] <- renderRHandsontable(rhandsontable(input_dfs[[i]]))
})
}
out <- map(slices,function(x){
rHandsontableOutput(x)
})
print(out)
out
})
### How do I create observeEvents for...
# input$aaa$changes$changes
# input$bbb$changes$changes
# input$arbitrarySlice$changes$changes
}
shinyApp(ui = ui, server = server)
You can iteratively add observeEvents using lapply() as shown:
library(shiny)
library(dplyr)
library(rhandsontable)
library(purrr)
ui <- fluidPage(
uiOutput("tables")
)
server <- function(input, output) {
mtcars$slc <- sample(c("aaa", "bbb"), nrow(mtcars), replace = TRUE)
df <- mtcars
getSlice <- function(df_tmp, slca) {
print(slca)
df_tmp <- df_tmp %>% filter(slc == slca)
df_tmp
}
output$tables <- renderUI({
slices <- unique(df$slc)
input_dfs <- map(slices, ~ getSlice(df, .x))
for (i in 1:length(slices)) {
local({
i <- i
print(input_dfs[[i]])
output[[slices[i]]] <- renderRHandsontable(rhandsontable(input_dfs[[i]]))
})
}
out <- map(slices, function(x) {
rHandsontableOutput(x)
})
print(out)
out
})
### How do I create observeEvents for...
# input$aaa$changes$changes
# input$bbb$changes$changes
# input$arbitrarySlice$changes$changes
### Iteratively add observeEvent()
lapply(unique(df$slc), function(slice) {
observeEvent(input[[slice]]$changes$changes, {
print(paste(slice, "has been updated!"))
print(input[[slice]][["changes"]])
})
})
}
shinyApp(ui = ui, server = server)
Related
I am trying to do something that is quite simple to achieve in R script but I am struggling to replicate when part of a Shiny app. I am reading a file using ‘reactive({})’ (this part in the test code provided below has been replaced with test dataset, lines 13-16). I would like to take variable ‘Species’ entries and assign them to the data frame row names. I have tried two approaches
Inside the “reactive({})” statement, lines 13-16
By creating a new data frame df1, lines 18-20
but both ways don’t work for some reason.
Big thank you in advance!
library(shiny)
library(DT)
library(datasets)
ui <- basicPage("",
DT::dataTableOutput("table"),
verbatimTextOutput("head1"),
verbatimTextOutput("head2")
)
server <- function(input, output, session) {
df <- reactive({
df <- data.frame(v1=c("a", "b"), v2=c(10,20))
# row.names(df) <- df[,1] # THIS DOES NOT WORK
})
df1 <- reactive({ # THIS ALSO DOESN'T WORK
row.names(df()) <- df()[,1]
})
# Show data in a table ----
output$table <- DT::renderDataTable({
datatable(
{df()},
filter = 'top',
class="cell-border stripe",
rownames = TRUE
) # end of datatable
})
output$head1 <- renderPrint({
head(df())
})
output$head2 <- renderPrint({
head(df1())
})
}
shinyApp(ui = ui, server = server)
Try this
library(shiny)
library(DT)
library(datasets)
ui <- basicPage("",
DTOutput("table"),
DTOutput("head1"),
DTOutput("head2")
)
server <- function(input, output, session) {
df <- reactive({
df <- data.frame(v1=c("a", "b"), v2=c(10,20))
row.names(df) <- df[,1] # THIS WORKs
df
})
df1 <- reactive({ # THIS ALSO WORKs
data <- df()
row.names(data) <- df()[,1]
data
})
# Show data in a table ----
output$table <- renderDT({
datatable(
{df()},
filter = 'top',
class="cell-border stripe",
rownames = TRUE
) # end of datatable
})
output$head1 <- renderDT({
head(df())
})
output$head2 <- renderDT({
head(df1())
})
}
shinyApp(ui = ui, server = server)
I am trying to use auto generated selectInput IDs inside the reactive element or observe event. When I explicitly write the input IDs like input$dfSelect1,input$dfSelect2,input$dfSelect3, it works as I wanted.
Since I don't know in advance how many IDs will be there (data will be user input), I need to create same input ID strings as automated, but it doesn't recognize it as a trigger in observe event or a input data in reactive element.
Here is the minimal reproducible example of my problem. if you comment out the line 1 req(input$dfSelect1,input$dfSelect2,input$dfSelect3) and line 2 dfx <- data.frame(carb = c(input$dfSelect1,input$dfSelect2,input$dfSelect3),stringsAsFactors = F) and remove the comment from the following lines, this will be the case I am trying to do.
any idea how to pass these values?
library(dplyr)
library(DT)
exdata <- head(mtcars, 3)
exdata$ROWs <- row.names(exdata)
ui <- fluidPage(
headerPanel("Example"),
mainPanel(
uiOutput("selectionUI"),
uiOutput("tableOutput")
)
)
server <- function(input, output, server) {
### reqString result <- input$dfSelect1,input$dfSelect2,input$dfSelect3
reqString <- noquote(paste0(unlist(lapply(1:length(sort(unique(row.names(exdata)))),function(i) {paste0("input$dfSelect",i,"")})),collapse = ","))
values <- reactiveValues(
upload_state = NULL
)
observe({
### 1-USE the line below with reqString instead -doesn't work ##
req(input$dfSelect1,input$dfSelect2,input$dfSelect3)
# req(reqString)
values$upload_state <- 'uploaded'
})
output$selectionUI <- renderUI({
df <- sort(unique(row.names(exdata)))
wellPanel(
lapply(1:length(df), function(i) {selectizeInput(paste0("dfSelect",i,""),df[i],choices=c("", unique(exdata$carb)))})
)
})
completeTable <- reactive({
browser()
if (is.null(values$upload_state)) {
return(exdata)
}else if (values$upload_state == 'uploaded') {
### 2-USE the line below with reqString instead -doesn't work##
dfx <- data.frame(carb = c(input$dfSelect1,input$dfSelect2,input$dfSelect3),stringsAsFactors = F)
# dfx <- data.frame(carb = c(reqString),stringsAsFactors = F)
dfx <- data.frame(carb =as.numeric(unlist(dfx)))
dataJoin <- exdata %>% left_join(dfx,by=("carb"))
}
})
output$tableOutput <- renderUI({
DT::dataTableOutput("dataTableServer")
})
output$dataTableServer <- DT::renderDataTable({
DT::datatable(completeTable())
})
}
shinyApp(ui = ui, server = server)
You can index input using [[ instead of $:
sapply(1:length(sort(unique(row.names(exdata)))),
FUN=function(x) req(input[[paste0("dfSelect", x)]]))
and
l <- sapply(1:length(sort(unique(row.names(exdata)))),
FUN=function(x) input[[paste0("dfSelect", x)]])
dfx <- data.frame(carb = l,stringsAsFactors = F)
In my reactive dataframe, one column has a reactive name (chosen by the user) and I would like to generate a column whose values are the logarithm of the original column. To do so, I use mutate in the dplyr package. However, when I try to make the name of this new column reactive, there's an error.
For example, in the code below, I name the new column "logarithm" and it works fine:
library(shiny)
library(DT)
library(data.table)
library(dplyr)
ui <- fluidPage(
titlePanel(""),
fluidRow(
checkboxInput(inputId = "logarithm",
label = "Log(variable)"),
dataTableOutput("my_df"),
textInput("new_name",
label = "New_name"),
actionButton("new_name2", "Validate")
)
)
server <- function(input, output) {
data <- head(mtcars[, 1:3])
reactive_data <- eventReactive(input$new_name2, {
colnames(data) <- c("mpg", "cyl", input$new_name)
data
})
output$my_df <- renderDataTable({
data <- reactive_data()
if(input$logarithm){
data %>%
mutate(logarithm = log(data[, input$new_name]))
}
else {
data
}
})
}
shinyApp(ui = ui, server = server)
But change "logarithm" by "logarithm(input$new_name)" and it won't work anymore.
Does anybody have a solution?
Based on this question and answer
if(input$logarithm){
log_name <- paste0('logarithm(', input$new_name, ')')
data %>%
mutate(!!log_name := log(data[, input$new_name]))
}
Full code:
library(shiny)
library(DT)
library(data.table)
library(dplyr)
ui <- fluidPage(
titlePanel(""),
fluidRow(
checkboxInput(inputId = "logarithm",
label = "Log(variable)"),
dataTableOutput("my_df"),
textInput("new_name",
label = "New_name"),
actionButton("new_name2", "Validate")
)
)
server <- function(input, output) {
data <- head(mtcars[, 1:3])
reactive_data <- eventReactive(input$new_name2, {
colnames(data) <- c("mpg", "cyl", input$new_name)
data
})
output$my_df <- renderDataTable({
data <- reactive_data()
if(input$logarithm){
log_name <- paste0('logarithm(', input$new_name, ')')
data %>%
mutate(!!log_name := log(data[, input$new_name]))
}
else {
data
}
})
}
shinyApp(ui = ui, server = server)
In the MRE below, the user is asked to filled in a table from which a curved is plotted. To mimic some computation, occurring on the table before producing graphical output, I added a Sys.sleep(). You will see that if the table is filled sufficiently fast, i.e. faster than the Sys.sleep(), the application become unusable and have to be killed.
I believe this is because table rendering is occurring after computation/sleep and plot rendering. How should I address this issue to make the app react in real time and still be usable ?
library(shiny)
library(rhandsontable)
library(ggplot2)
DF <- data.frame(x=integer(0), y=integer(0))
ui <- shinyUI(fluidPage(
mainPanel(
rHandsontableOutput("hot"),
plotOutput("plot1")
)
))
server <- shinyServer(function(input, output) {
values <- reactiveValues()
observe({
if (!is.null(input$hot)) {
DF <- hot_to_r(input$hot)
} else {
if (is.null(values[["DF"]]))
DF <- DF
else
DF <- values[["DF"]]
}
values[["DF"]] <- DF
})
output$hot <- renderRHandsontable({
rhandsontable(values[["DF"]], stretchH = "all", minRows=5)
})
output$plot1 <- renderPlot({
table <- {
Sys.sleep(.4)
values[["DF"]]
}
ggplot(data=table) + geom_line(aes(x=x, y=y))
})
})
shinyApp(ui=ui, server=server)
Considering a user filling in by hand a rhandsontable, I would like to implement a time related condition to proceed with table analysis and plot. E.g. if nothing has been added to table during the last 2 seconds, proceed, otherwise await till the 2 seconds are past.
I tried with validate() or simple condition (like below). It does not work because observe() is accessed immediately after table is modified, at that time the time related condition is false. When the condition should be true, the observe() function is not accessed anymore so condition is not tested...
I tried to provide a MRE but I have trouble defending the need for such feature in a simple example. The need is related to computation time of analysis and plot.
library(shiny)
library(rhandsontable)
library(ggplot2)
DF <- data.frame(x=integer(0), y=integer(0))
ui <- shinyUI(fluidPage(
mainPanel(
rHandsontableOutput("hot"),
plotOutput("plot1")
)
))
server <- shinyServer(function(input, output) {
values <- reactiveValues()
values$table <- DF
values$accessDF <- 0
observe({
if (!is.null(input$hot)) {
DF <- hot_to_r(input$hot)
values$accessDF <- Sys.time() # reset awaiting time when table is incremented
} else {
if (is.null(values[["DF"]]))
DF <- DF
else
DF <- values[["DF"]]
}
values[["DF"]] <- DF
})
output$hot <- renderRHandsontable({
rhandsontable(values[["DF"]], stretchH = "all", minRows=5)
})
observe({
if (Sys.time() - values$accessDF > 2){ # unfornate try...
# some modification of the table occuring here
values$table <- values$DF
}
})
output$plot1 <- renderPlot({
ggplot(data=values$table) + geom_line(aes(x=x, y=y))
})
})
shinyApp(ui=ui, server=server)
Another way is to let your plot depend on a debounced reactive expression that contains the reactive value:
library(shiny)
library(rhandsontable)
library(ggplot2)
ui <- shinyUI(fluidPage(
mainPanel(
rHandsontableOutput("hot"),
plotOutput("plot1")
)
))
server <- function(input, output, session) {
rv = reactiveVal(data.frame(x = integer(0), y = integer(0)))
r2 = reactive(rv()) |>
debounce(2000)
output$hot <- renderRHandsontable({
rhandsontable(rv(), stretchH = "all", minRows = 5)
})
output$plot1 <- renderPlot({
ggplot(r2(), aes(x = x, y = y)) +
geom_point(na.rm = TRUE) +
geom_line(na.rm = TRUE)
})
observeEvent(input$hot$changes, {
rv(hot_to_r(input$hot))
})
}
shinyApp(ui = ui, server = server)
I found one solution. Use reactiveTimer() to force the observe() to activate even though no variable it observes has been updated.
in server:
autoInvalidate <- reactiveTimer(200) # to activate observer every 200 ms
and then in observe()
autoInvalidate()
followed by the condition
if (Sys.time() - values$accessDF > 2){ # unfornate try...
# some modification of the table occuring here
values$table <- values$DF
}
see https://shiny.rstudio.com/reference/shiny/1.0.0/reactiveTimer.html