Question

我使用shiny来查询SQL数据库。从数据我产生一个瓷砖地图。我希望用户能够单击一个图块，以选择数据，之后图块会改变颜色。我有点工作，但瓷砖几乎立即变回原来的颜色。这是一个例子：

Server.R

userInteractionEnabled=NO

ui.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") 
})

})

所以我的问题是，如何让颜色变化坚持下去？也许我需要创建反应值？也许我需要一个完全不同的方法？感谢

Answer 1

问题是，当更改update时，会重新绘制ggplot，将所选点设置为空数据框。这将从数据框中删除所有选定的点并恢复着色。

您可以尝试仅在至少有一个选定点时更改数据框，我将数据框存储在无效值中，您可以使用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

在我看来，另一种更为简单的解决方案是使用reactiveVal来监视选择。示例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)

使用plot_click反复更新ot tile map - Shiny

2 个答案: