Having isolated or non-reactive columns inside of a reactive dataframe - r

Question

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

Answer 1

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)