rdataframeshinyreactive
Having isolated or non-reactive columns inside of a reactive dataframe
I have a reactive dataframe (called selected_df()) in which I am trying to consolidate information from input$tableID_cells_selected and another dataframe.
The second reactive dataframe, called storage_df(), is 1 row and 2 columns. It collects the background color and text labels from action buttons that are pressed, and then that data stays static in storage_df() until a different button is pressed.
selected_df() then collects the info about whatever button was last pressed from storage_df() when a cell in the table is selected (or whenever input$plate_cells_selected is updated), and shows these data in the same row.
The problem is that the selected_df() must reference storage_df() inside of the reactive environment, so it updates all of the values in the cond_selected and color_selected columns from selected_df(). I don't want to have those old values from storage_df() updated and replaced with whatever new values exist in storage_df(). I want those old rows of selected_df() to keep those old values, and for the new rows of selected_df() to have the new values of storage_df(). So basically, storage)df() is updated upon button click, as it is reactive, but the references to storage_df() made by selected_df() would not be reactive.
I have a gif here that will hopefully explain what I am trying to do, in case this is confusing. This is a previous attempt but it is the closest that I have gotten to success. In the gif, the color and cond columns of selected_df() are set such as follows for example: cond_selected = isolate(paste0(rep(storage_df()[[1,2]]))), so that value changes when a new button is pressed. The first three rows of column cond_selected within selected_df() should ideally stay gse1, while the latter three rows should be cox8a. As you can see, this is not what happens.
In other words, this is what I have in these columns at the end of this gif:
And this is what I want in these columns:
With my latest attempt (included in my MRE). I thought if I were to only try to update the values of the last added row, as I think the selected_df() might be appended whenever a new cell is selected, then that might work. However, the app crashes and only gives this warning, which it usually gave because selected_df() had no rows before a cell was selected:
Warning: Error in [: subscript out of bounds
Also, here is my MRE and latest attempt, and what I currently need help trying to figure out:
library(shiny)
library(colourpicker)
library(dplyr)
library(DT)
library(glue)
library(shinyWidgets)
####Create the matrix and organization for the 96 well plate####
plate96 <- function(id) {
div(
style = "position: relative; height: 500px",
tags$style(HTML('
.wells {
transform: translateX(50%);
}
.wells table.dataTable tr:nth-child(9) td { /*for the row 9, need to make it not look like a row*/
border-bottom: unset;
}
.wells tbody tr td:not(:first-of-type) {
border: 1px solid black;
height: 15px;
width: 15px;
padding: 15px;
font-size: 0;
}
')),
div(
style = "position: absolute; left: 50%; transform: translateX(-100%);",
div(
class = "wells",
DTOutput(id, width = "90%", height= "100%")
)
)
)
}
####Create the matrix and organization for the 96 well plate####
renderPlate96 = function(id, colors = rep("white", 108)) {
plate <- matrix(1:108,
nrow = 9,
ncol = 12,
byrow = TRUE,
dimnames = list(LETTERS[1:9], 1:12))
colnames (plate) = stringr::str_pad(colnames(plate), 2, "left", "0")
return(plate_return1 <-
datatable(
plate,
options = list(dom = 't', ordering = F),
selection = list(mode = 'multiple',
target = "cell"),
class = 'cell-border compact'
) %>%
formatStyle(
1:12,
cursor = 'pointer',
backgroundColor = styleEqual(1:108, colors, default = NULL)
)
)
}
storage_df <- (data.frame(
matrix(ncol = 2, nrow = 1),
color_selected = NA,
cond_selected = NA
))
# app code
ui <- fluidPage(
plate96("plate"),
tags$b("Wells Selected:"),
verbatimTextOutput("plateWells_selected"),
br(),
helpText("Step 1: Add in a couple of buttons"),
numericInput("num_conds",
label = h3("Enter the number of treatments/ conditions"),
min = 1,
max = 20,
value = 1),
htmlOutput("cond_buttons", align = 'center'),
helpText("Step 2: Type in any name for a condition for the buttons"),
uiOutput("boxes_conds"),
helpText("Step 3: Choose any color for the buttons"),
uiOutput("cond_colors"),
helpText("Step 4: Select cells from the table above"),
DT::dataTableOutput("selected_table"),
DT::dataTableOutput("storage_table"),
)
server <- function(input, output, session){
### ★★ ↓↓↓↓ PROBLEM AREA ↓↓↓↓ ★★ ###
####Storage data.frame for when the buttons are clicked####
observeEvent(input$num_conds, {
lapply(1:input$num_conds, function(x){
observeEvent(input[[paste0("cond_buttons",x)]], {
newdf <- tibble(
color_selected = input[[paste0("colors",x)]],
cond_selected = input[[paste0("condID",x)]]
)
storage_df(newdf)
})
})
})
storage_df <- reactiveVal(tibble::tribble(
~color_selected, ~cond_selected
))
output$storage_table <- renderDataTable(
req(storage_df()),
options = list(paging = FALSE,
ordering = FALSE,
scrollx = FALSE,
searching = FALSE,
stringsAsFactors = FALSE
)
)
####Create a DT that stores the values of the cells selected in the plate####
selected_df <- reactive(data.frame(rows = req(input$plate_cells_selected[,1]),
columns = req(input$plate_cells_selected[,2]),
color_selected = 0,
cond_selected = 0,
stringsAsFactors = FALSE),
)
####Take out this portion of the code if trying to reproduce my GIF###
observeEvent(input$plate_cells_selected, {
selected_df() %>% mutate(selected_df(), color_selected = replace(color_selected, color_selected== '0', isolate(paste0(rep(storage_df()[[1,1]]))))
)})
####Take out this portion of the code if trying to reproduce my GIF###
output$selected_table <- renderDataTable(
req(selected_df()),
options = list(paging = FALSE,
ordering = FALSE,
scrollx = FALSE,
searching = FALSE,
lengthChange = FALSE
)
)
### ★★ ↑↑↑↑ PROBLEM AREA ↑↑↑↑ ★★ ###
#....#
#Past here isn't as important to the question...#
####Input for user browse and data upload####
output$contents <- renderTable({ req(input$data) })
#####Slider for frames per second####
output$value <- renderPrint({ input$Frames })
#####Check boxes for no-movement cell exclusion####
output$value <- renderPrint({ input$emptyWell_checkbox })
#####Number output for number of conditions#####
output$value <- renderPrint({ input$num_conds })
#### Condition boxes for UI text input####
output$boxes_conds <- renderUI({
num_conds = as.integer(input$num_conds)
lapply(1:num_conds, function(i) {
cond_names <- textInput(paste0("condID", i),
label = paste0("Treatment/ Conditions: ", i),
placeholder = "Enter condition..."
)
})
})
#### Color selection for UI input####
output$cond_colors <- renderUI({
num_conds = as.integer(input$num_conds)
lapply(1:num_conds, function(i) {
colourInput(paste0("colors", i),
label = (paste0("Select a color for condition ", i)),
show = c("both"),
value = "black",
palette = c("limited"),
)
})
})
#### Create action buttons for conditions to be selected####
output$cond_buttons <- renderUI({
num_conds = as.integer(input$num_conds)
lapply(1:num_conds, function(i) {
bg = input[[paste0("colors", i)]]
style = paste0(
collapse = " ",
glue("background-color:{bg};
color:#ffffff;
border-color:#000000")
)
label = input[[paste0("condID", i)]]
actionButton(paste0("cond_buttons", i),
label = label,
style = style,
)
})
})
####Create the 96 well plate image####
output$plate <- renderDT({
renderPlate96()
})
output$plateWells_selected <- renderPrint({
input$plate_cells_selected
})
}
shinyApp(ui = ui, server = server)
UPDATE UPON REQUEST
Here is a portion of the code needed to reproduce what you see in the GIF. This is not my latest attempt and is not what I need help with troubleshooting, this is merely to give what I used to make the GIF that explains what I want. Just replace the similar version of the code with this in my MRE and take out the mutate function. The mutate function to remove has been marked by comments in my MRE.
####Create a DT that stores the values of the cells selected in the plate####
selected_df <- reactive(data.frame(rows = req(input$plate_cells_selected[,1]),
columns = req(input$plate_cells_selected[,2]),
color_selected = isolate(paste0(rep(storage_df()[[1,1]]))),
cond_selected = isolate(paste0(rep(storage_df()[[1,2]]))),
stringsAsFactors = FALSE)
)
UPDATE, REPONSE TO YBS
Solution
Try this
# app code
ui <- fluidPage(
plate96("plate"),
tags$b("Wells Selected:"),
verbatimTextOutput("plateWells_selected"),
br(),
helpText("Step 1: Add in a couple of buttons"),
numericInput("num_conds",
label = h3("Enter the number of treatments/ conditions"),
min = 1,
max = 20,
value = 1),
htmlOutput("cond_buttons", align = 'center'),
helpText("Step 2: Type in any name for a condition for the buttons"),
uiOutput("boxes_conds"),
helpText("Step 3: Choose any color for the buttons"),
uiOutput("cond_colors"),
helpText("Step 4: Select cells from the table above"),
DTOutput("selected_table"),
DTOutput("storage_table"),
)
server <- function(input, output, session){
### ★★ ↓↓↓↓ PROBLEM AREA ↓↓↓↓ ★★ ###
# storage_df <- reactiveVal(tibble::tribble(
# ~color_selected, ~cond_selected
# ))
storage_df <- reactiveVal(storage)
####Storage data.frame for when the buttons are clicked####
observeEvent(input$num_conds, {
lapply(1:input$num_conds, function(x){
observeEvent(input[[paste0("cond_buttons",x)]], {
newdf <- data.frame(
color_selected = input[[paste0("colors",x)]],
cond_selected = input[[paste0("condID",x)]]
)
storage_df(newdf)
}, ignoreInit = TRUE)
})
})
output$storage_table <- renderDataTable(
req(storage_df()),
options = list(paging = FALSE,
ordering = FALSE,
scrollx = FALSE,
searching = FALSE,
stringsAsFactors = FALSE
)
)
selected <- reactiveValues(df=NULL,cum=NULL)
df1 <- data.frame()
observeEvent(input$plate_cells_selected, {
n = dim(req(input$plate_cells_selected))[1]
df1 <<- data.frame(rows = req(input$plate_cells_selected[,1]), columns = req(input$plate_cells_selected[,2]))
###Create a DT that stores the values of the cells selected in the plate####
selected$cum <- rbind(selected$df,data.frame(rows = input$plate_cells_selected[n,1],
columns = input$plate_cells_selected[n,2],
color_selected = storage_df()[1,1], cond_selected = storage_df()[1,2]))
}, ignoreNULL=FALSE)
observeEvent(selected$cum, {
n1 = dim(df1)[1]
n2 = dim(selected$cum)[1]
if (n1 > n2) { ## add a row
df <- selected$cum
}else df <- left_join(df1, selected$cum, by=c("rows","columns"))
selected$df <- df[!duplicated(df[,1:2]),]
#print(selected$df)
})
####Create a DT that stores the values of the cells selected in the plate####
# selected_df <- reactive(data.frame(rows = req(input$plate_cells_selected[,1]),
# columns = req(input$plate_cells_selected[,2]),
# stringsAsFactors = FALSE) %>% mutate(color_selected = c(0), cond_selected = c(0))
# )
output$selected_table <- renderDT(
#selected_df(),
selected$df,
options = list(paging = FALSE,
ordering = FALSE,
scrollx = FALSE,
searching = FALSE,
lengthChange = FALSE
)
)
### ★★ ↑↑↑↑ PROBLEM AREA ↑↑↑↑ ★★ ###
#....#
#Past here isn't as important to the question...#
####Input for user browse and data upload####
output$contents <- renderTable({ req(input$data) })
#####Slider for frames per second####
output$value <- renderPrint({ input$Frames })
#####Check boxes for no-movement cell exclusion####
output$value <- renderPrint({ input$emptyWell_checkbox })
#####Number output for number of conditions#####
output$value <- renderPrint({ input$num_conds })
#### Condition boxes for UI text input####
output$boxes_conds <- renderUI({
num_conds = as.integer(input$num_conds)
lapply(1:num_conds, function(i) {
cond_names <- textInput(paste0("condID", i),
label = paste0("Treatment/ Conditions: ", i),
placeholder = "Enter condition..."
)
})
})
#### Color selection for UI input####
output$cond_colors <- renderUI({
num_conds = as.integer(input$num_conds)
lapply(1:num_conds, function(i) {
colourInput(paste0("colors", i),
label = (paste0("Select a color for condition ", i)),
show = c("both"),
value = "black",
palette = c("limited"),
)
})
})
#### Create action buttons for conditions to be selected####
output$cond_buttons <- renderUI({
num_conds = as.integer(input$num_conds)
lapply(1:num_conds, function(i) {
bg = input[[paste0("colors", i)]]
style = paste0(
collapse = " ",
glue("background-color:{bg};
color:#ffffff;
border-color:#000000")
)
label = input[[paste0("condID", i)]]
actionButton(paste0("cond_buttons", i),
label = label,
style = style,
)
})
})
####Create the 96 well plate image####
output$plate <- renderDT({
renderPlate96()
})
output$plateWells_selected <- renderPrint({
input$plate_cells_selected
})
}
shinyApp(ui = ui, server = server)
- Rcpp Rf_warningcall compiler warnings
- Modify the name of factor variables in lm function(summary function)
- Extreme value analysis and quantile estimation using log Pearson type 3 (Pearson III) distribution - R vs Python
- How to hide NAs when using xlsx::saveWorkbook?
- How do I retrieve a simple numeric value from a named numeric vector in R?
- Matching pair-wise columns from left to right across rows in one dataframe to another dataframe and adding new columns with matching values
- Income to outcome flow chart in Sankey plotly R
- color mapping in geom_conn_bundle not showing correctly
- Print R package startup message AFTER automatic package conflict messages instead of before
- Summing a set of R dataframe rows (column-wise), while retaining the first n columns
- Added variable / partial regression plots for groups in an interaction?
- how to make a topoplot in R with coordinates variable distribution
- List of all functions in base R?
- Plotting multiple plots for different initial conditions in one graph
- Printing repetitively on the same line in R
- Generating UI/Server based on initial selection
- Subset dataframe based on pickerInput
- How to let user pick the data in R-shiny?
- Couldn't show my simple bar charts separately on Shiny R dashboardBody
- How to programmatically filter contents of a second shiny app displayed via iframe
- How to select specific interesting groups for the boxplot in R Shiny app?
- Crosstable and Plot grouping with reactive values
- Is there a way to make multiple Shiny picker inputs where the selections must be disjoint?
- Delay/avoid duplication of shiny server side functions until after credentials
- Predictions only returns value "1"
- How to display a busy indicator in a shiny app?
- Append doesn't work when writing to CSV in R
- Changing the start date of a gantt chart in DiagrammeR
- Check for installed packages before running install.packages()
- Compare two columns element-wise