Reactive update ot tile map using plot_click - Shiny - r

Question

I am using shiny to query an SQL database. From the data I produce a tile map. I would like the user to be able to click a tile, to select data, after which the tile changes colour. I have got it working slightly but the tile changes back to the original colour almost immediately. Here is an example:
Server.R
library(data.table)
# Create example data
Row <- 1:4
Col <- 1:4
Batch <- c("A","B")
dd <- expand.grid(Row,Col, Batch)
colnames(dd) <- c("Row","Col","Batch")
#Write to memory
con <- dbConnect(RSQLite::SQLite(), ":memory:")
dbWriteTable(con, "dd", dd)
query <- function(...) dbGetQuery(con, ...)
shinyServer(function(input, output, session){
id <- eventReactive(input$do, {input$batch})
# Search by batch: either A or B. Create column "selected" to represent which tile has been clicked lower down i.e. 0 = not selected, 1=selected
wid <- reactive({
if(input$do==0) return ( )
quer <- paste("Select Row, Col, '0' as selected from dd where Batch='",id(),"'", sep="")
data.frame(query(quer))
})
# Output of clicked tile
output$plot_clicked_points <- renderDataTable({
dat <- wid()
res <- nearPoints(dat, input$plot_click,
threshold = 100, maxpoints = 1)
data.table(res)
})
#Update dataframe by changing "selected" tile to 1
update <- reactive({
dat <- wid()
res <- nearPoints(dat, input$plot_click,
threshold = 100, maxpoints = 1)
DT <- data.table(dat)
DT[(Row==res$Row & Col==res$Col), selected:=1]
})
# Produce tile map with colour of tile based on whether it is the most recently clicked i.e. "selected" should now be = 1
output$map <- renderPlot({
ggplot(update(), aes(Row,Col, fill=factor(selected))) + geom_tile(colour="white")
})
})
ui.R
library(shiny)
library(ggplot2)
library(RMySQL)
shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
textInput("batch", label = "Batch ID", value=""),
actionButton("do", label = "Search")
),
mainPanel(
dataTableOutput(outputId="plot_clicked_points"),
plotOutput("map", click = "plot_click")
))))
So my question is, how do I get the colour change to stick? Maybe I need to create reactiveValues? Maybe I need a different approach altogether? Thanks

Answer 1

The issue is that when update is changed, the ggplot is redrawn which sets the selected points to an empty data frame. This removes all the selected points from your data frame and reverts the coloring.
You could try changing the data frame only when there is at least one selected point, I stored the data frame in a reactive value, you can access using values$data:
values <- reactiveValues()
observe({
if(input$do==0) return ( )
quer <- paste("Select Row, Col, '0' as selected from dd where Batch='",id(),"'", sep="")
print(data.frame(query(quer)))
values$data = data.frame(query(quer))
})
#Update dataframe by changing "selected" tile to 1
observe({
res <- nearPoints(values$data, input$plot_click,
threshold = 100, maxpoints = 1)
if(!is.null(res)) {
if(nrow(res)>=1){
selected <- rep(0,nrow(values$data))
selected[which(values$data$Row==res$Row & values$data$Col==res$Col)] <- 1
values$data$selected <- selected
}
}
})
# Produce tile map with colour of tile based on whether it is the most recently clicked i.e. "selected" should now be = 1
output$map <- renderPlot({
ggplot(values$data, aes(Row,Col, fill=factor(selected))) + geom_tile(colour="white")
})

Answer 2

Another in my opinion slightly more simple solution would be to use a reactiveVal to monitor selection. Example app.R:
library(shiny)
library(ggplot2)
library(dplyr)
dataset = expand.grid(time=paste("m_", 1:10), op=paste("om_", 1:20)) %>% mutate(wip=row_number())
server <- function(input, output) {
tileSelect <- reactiveVal(data_frame())
output$wip_map <- renderPlot({
p = ggplot(fakewip, aes(time, op, fill = wip)) + geom_tile()
if (nrow(tileSelect()) > 0) {
p + geom_tile(color="red", size=2, fill=NA, data=tileSelect())
}else{
p
}
})
observeEvent(input$plot_click, {
tileSelect(nearPoints(dataset, input$plot_click, threshold = 100, maxpoints=1))
})
# reset selection with double click
observeEvent(input$plot_dblclick, {
tileSelect(data_frame())
})
}
ui <- fluidPage(
title = "Heatmap Select",
plotOutput("wip_map", click = "plot_click", dblclick = "plot_dblclick")
)
shinyApp(ui = ui, server = server)