The following code is doing like: If we brush and select several points, these points would be turned to color magenta temporarily; (if we click on the plot panel, they would be recovered to original color) then, if we click the "active color" button, these brushed points would be turned to corresponding selected color permanently. (if we click on the plot panel, they would not be recovered to original color).
library(ggplot2)
library(shiny)
library(colourpicker)
ui <- fluidPage(
verticalLayout(
actionButton("active_color",
"active color"),
colourInput("color", "color", value = "red", showColour = "background"),
plotOutput("plot", brush = "plot_brush", click = "plot_click"),
verbatimTextOutput("info")
)
)
server <- function(input, output) {
g <- ggplot(mtcars, mapping = aes(x = wt, y = mpg)) + geom_point()
values <- reactiveValues(active_color = 0)
observeEvent(input$active_color, {
values$active_color <- 1
})
observeEvent(input$plot_click, {
values$active_color <- 0
})
output$plot <- renderPlot({
# create ggplot
build <- ggplot_build(g)
len_layer <- length(build$data)
x <- build$data[[len_layer]]$x
y <- build$data[[len_layer]]$y
# brush information
brush_info <- input$plot_brush
id_x <- which(x >= brush_info$xmin & x <= brush_info$xmax)
id_y <- which(y >= brush_info$ymin & y <= brush_info$ymax)
# brush index
id <- intersect(id_x, id_y)
color_vec <- build$data[[len_layer]]$colour
if(length(id) > 0) {
if(values$active_color != 0) {
color_vec[id] <- input$color
g <<- g + geom_point(colour = color_vec)
}
color_vec[id] <-"magenta"
g <- g + geom_point(colour = color_vec)
}
g
})
output$info <- renderPrint({
input$plot_brush
})
}
shinyApp(ui, server)
The code works fine. However, if I make a little change on server function.
server <- function(input, output) {
g <- ggplot(mtcars, mapping = aes(x = wt, y = mpg)) + geom_point()
values <- reactiveValues(active_color = 0)
observeEvent(input$active_color, {
values$active_color <- 1
})
observeEvent(input$plot_click, {
values$active_color <- 0
})
output$plot <- renderPlot({
# the change I made here
make_change(g, input, values)
})
output$info <- renderPrint({
input$plot_brush
})
}
make_change <- function(g, input, values) {
build <- ggplot_build(g)
len_layer <- length(build$data)
x <- build$data[[len_layer]]$x
y <- build$data[[len_layer]]$y
# brush information
brush_info <- input$plot_brush
id_x <- which(x >= brush_info$xmin & x <= brush_info$xmax)
id_y <- which(y >= brush_info$ymin & y <= brush_info$ymax)
# brush index
id <- intersect(id_x, id_y)
color_vec <- build$data[[len_layer]]$colour
if(length(id) > 0) {
if(values$active_color != 0) {
color_vec[id] <- input$color
g <<- g + geom_point(colour = color_vec)
}
color_vec[id] <-"magenta"
g <- g + geom_point(colour = color_vec)
}
g
}
It is very similar to the old server function, the only difference is I extract all the code in renderPlot
and make it a new function make_change
. If we run, we can find the temporary selection (color to magenta) works fine, but the permanent color change does not work any more.
It seems like <<-
works well in renderPlot()
, however, it doesn't work if it is in a function and the function is in renderPlot()
.
Is it possible to make the second server work as well as the first one? Since I want to write a generic function, if I use the first one, the serer function is too long, too hard to read and modify.
The diagnosis of the problem here is incorrect. The problem is not related to whether or not <<-
is inside a function or inside a render. The problem here is related to the scoping of the g
variable.
In fact, a super simple "fix" would be to simply define the ggplot initially with <<-
rather than with <-
. Another similar "fix" would be to pull out the initial ggplot definition to be outside of the server, in the global environment. Both of these would fix the issue at hand, but I would suggest doing some reading on scoping rules in R in general and in Shiny in particular, and doing some reading on how <<-
works and why it's dangerous. Using the <<-
operator often leads to unexpected results if you don't have a very deep understanding of it and scoping rules.
I kept saying "fix" in quotes because it will technically fix the problem, but I think the code design could be refactored.
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.