This is in reference to the code written by YBS in another question. If YBS happens to see this and is interested/has the time to answer, I would love to hear your input :D
I have been looking at trying to use mapply to make this work, but I haven't figured this out yet. As of now, I have a code that uses a system of for loops (which I know isn't ideal for dataframes, but I figured I may as well try the easy base option first) that works well when the values in selected$df are completely static and the loops are outside of an observeEvent. However, as soon as I implant the loops into an observeEvent, colors_df and conds_df are no
longer updated. I do not get an error message, however. I'm not sure if this is because I'm trying to use for loops inside of observeEvent or if I'm trying to index selected$df incorrectly.
Obviously, I would love to use whatever preferred methods there are. However, because of how I'm trying to use the indices from selected$df to replace data in my colors_df and conds_df tables, this has proven difficult to use apply variants (or at least I haven't figured it out yet).
Here is my reproducible example, sorry that it's a little long. I would normally cut it down more by taking out some of the reactives but I'm wondering they are part of the reason why this isn't working.
NOTE: There are instructional steps listed as helpText in the app to make it work.
library(shiny)
library(dplyr)
library(DT)
library(glue)
library(shinyWidgets)
library(colourpicker)
library(shinyjs)
####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)
)
)
}
# app code
ui <- fluidPage(
useShinyjs(),
plate96("plate"),
tags$b("Wells Selected:"),
DTOutput("selected_table"),
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("storage_table"),
DT::dataTableOutput("colors_table"),
DT::dataTableOutput("conds_table"),
)
server <- function(input, output, session){
### **** Problem Area **** ####
observeEvent(req(input$plate_cells_selected), {
delay(500,
for(i in 1:nrow(selected$df)) {
#For selecting any individual cells, coordinating the indices between the cell_selected and the conds and colors data.frames
if (selected$df[i,1] < 9 && selected$df[i,2] > 0) {
colors_df[selected$df[i,1], selected$df[i,2]] <- selected$df[i,3]
conds_df[selected$df[i,1], selected$df[i,2]] <- selected$df[i,4]
}
#For selecting all cells in a row if the letters are selected
else if (selected$df[i,2] == 0) {
for(x in seq(12)) {
colors_df[selected$df[i,1], x] <- selected$df[i,3]
conds_df[selected$df[i,1], x] <- selected$df[i,4]
}
}
#For selecting all the cells in a column if the 9th cell is selected
else if (selected$df[i,1] == 9) {
for(x in seq(8)) {
colors_df[x, selected$df[i,2]] <- selected$df[i,3]
conds_df[x, selected$df[i,2]] <- selected$df[i,4]
}
}
}
)})
###End problem area###
####Storage data.frame for when the buttons are clicked####
storage <- (data.frame(
color_selected = NA,
cond_selected = NA
))
storage_df <- reactiveVal(storage)
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,scope=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$scope <- 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],
stringsAsFactors = FALSE))
}, ignoreNULL=FALSE)
observeEvent(selected$scope, {
n1 = dim(df1)[1]
n2 = dim(selected$scope)[1]
if (n1 > n2) { ## add a row
df <- selected$scope
}else df <- left_join(df1,
selected$scope,
by=c("rows","columns"))
selected$df <- df[!duplicated(df[,1:2]),]
})
output$selected_table <- renderDT(
selected$df,
options = list(paging = FALSE,
ordering = FALSE,
scrollx = FALSE,
searching = FALSE,
lengthChange = FALSE,
stringsAsFactors = FALSE
)
)
####data.frame for color information####
colors_df <- data.frame(
matrix(ncol = 12, nrow = 8)
)
output$colors_table <- renderDataTable(
colors_df,
options = list(paging = FALSE,
ordering = FALSE,
scrollx = FALSE,
searching = FALSE,
stringsAsFactors = FALSE
)
)
####data.frame for condition information####
conds_df <- data.frame(
matrix(ncol = 12, nrow = 8)
)
output$conds_table <- renderDataTable(
conds_df,
options = list(paging = FALSE,
ordering = FALSE,
scrollx = FALSE,
searching = FALSE,
stringsAsFactors = FALSE
)
)
####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) {
colourpicker::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)
CodePudding user response：
You have multiple issues here. You need reactive dataframes to display the last two tables. You can use local() in a for loop (to deal with lazy evaluation) or lapply in an observer. I have shown both examples here. Try this
library(shiny)
library(dplyr)
library(DT)
library(glue)
library(shinyWidgets)
library(colourpicker)
library(shinyjs)
####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)
)
)
}
# app code
ui <- fluidPage(
useShinyjs(),
plate96("plate"),
tags$b("Wells Selected:"),
DTOutput("selected_table"),
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("storage_table"),
DT::dataTableOutput("colors_table"),
DT::dataTableOutput("conds_table"),
)
server <- function(input, output, session){
### **** Problem Area **** ####
observeEvent(req(input$plate_cells_selected), {
delay(500,
for(i in 1:nrow(selected$df)) {
local({
i <- i
#For selecting any individual cells, coordinating the indices between the cell_selected and the conds and colors data.frames
if (selected$df[i,1] < 9 && selected$df[i,2] > 0) {
colors$df[selected$df[i,1], selected$df[i,2]] <- selected$df[i,3]
conds$df[selected$df[i,1], selected$df[i,2]] <- selected$df[i,4]
}
#For selecting all cells in a row if the letters are selected
else if (selected$df[i,2] == 0) {
lapply(1:12, function(x){
#for(x in seq(12)) {
colors$df[selected$df[i,1], x] <- selected$df[i,3]
conds$df[selected$df[i,1], x] <- selected$df[i,4]
#}
})
}
#For selecting all the cells in a column if the 9th cell is selected
else if (selected$df[i,1] == 9) {
lapply(1:8, function(x){
#for(x in seq(8)) {
colors$df[x, selected$df[i,2]] <- selected$df[i,3]
conds$df[x, selected$df[i,2]] <- selected$df[i,4]
#}
})
}
})
}
)})
###End problem area###
####Storage data.frame for when the buttons are clicked####
storage <- (data.frame(
color_selected = NA,
cond_selected = NA
))
storage_df <- reactiveVal(storage)
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,scope=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$scope <- 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],
stringsAsFactors = FALSE))
}, ignoreNULL=FALSE)
observeEvent(selected$scope, {
n1 = dim(df1)[1]
n2 = dim(selected$scope)[1]
if (n1 > n2) { ## add a row
df <- selected$scope
}else df <- left_join(df1,
selected$scope,
by=c("rows","columns"))
selected$df <- df[!duplicated(df[,1:2]),]
})
output$selected_table <- renderDT(
selected$df,
options = list(paging = FALSE,
ordering = FALSE,
scrollx = FALSE,
searching = FALSE,
lengthChange = FALSE,
stringsAsFactors = FALSE
)
)
####data.frame for color information####
colors <- reactiveValues(df = data.frame(
matrix(ncol = 12, nrow = 8)
))
output$colors_table <- renderDataTable(
colors$df,
options = list(paging = FALSE,
ordering = FALSE,
scrollx = FALSE,
searching = FALSE,
stringsAsFactors = FALSE
)
)
####data.frame for condition information####
conds <- reactiveValues(df = data.frame(
matrix(ncol = 12, nrow = 8)
))
output$conds_table <- renderDataTable(
conds$df,
options = list(paging = FALSE,
ordering = FALSE,
scrollx = FALSE,
searching = FALSE,
stringsAsFactors = FALSE
)
)
####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) {
colourpicker::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)