我正在制作一个有各种情节的闪亮应用。其中一些需要不同的UI小部件，我使用renderUI创建。对于其中一个图，为了正确地将标签设置为子集（geom_label_repel），我认为我需要使用输入作为eventReactive依赖项。问题是，此输入仅针对一个特定绘图呈现，并且对于所有其他绘图甚至不存在。当我尝试将它放入eventReactive时，一切都会中断。
我已经尝试过有条件地将它放在eventReactive中，但要么是无效的，要么我只是不知道如何正确地执行它。我尝试过这样的事情：
eventReactive({
if(exists(input$sel_name)) {
input$button
input$sel_name
} else {
input$button
}},{
handlerExp
})
这是我相当广泛的例子。我在应用程序中嵌入了更具体的解释 - 我认为这比在帖子中更方便。希望这不是坏形式，如果是，请告诉我：
library(ggplot2)
library(ggrepel)
library(shiny)
library(dplyr)
library(stringr)
# Sample Data ####
orgid <- c(rep(1, 3),
rep(2, 3),
rep(3, 2),
rep(4, 2),
rep(5, 3),
rep(6, 2),
rep(7, 3),
rep(8, 2),
rep(9, 3))
year <- c(2012, 2013, 2014,
2012, 2013, 2014,
2012, 2013,
2013, 2014,
2012, 2013, 2014,
2013, 2014,
2012, 2013, 2014,
2012, 2013,
2012, 2013, 2014)
y <- c(10, 20, 30,
60, 70, 50,
100, 90,
55, 65,
5, 15, 30,
200, 180,
65, 95, 130,
170, 155,
140, 130, 190
)
label <- c(rep("Tom" , 3),
rep("Dick" , 3),
rep("Harry", 2),
rep("Ed" , 2),
rep("Sam" , 3),
rep("Hank" , 2),
rep("Dan" , 3),
rep("Trey" , 2),
rep("Steve", 3))
df <- data.frame(orgid, year, y, label)
#####
ui <- pageWithSidebar(
headerPanel('Plot Label Reactivity Problem'),
sidebarPanel(width=3,
selectInput(inputId = "plot_selector",
label = "Plot Selector",
choices = c("Other Plots" = "a","The Plot in Question" = "b"),
selected = "a"),
uiOutput(outputId = "react_ui"),
actionButton(inputId = 'button', label = "Submit")
),
mainPanel(plotOutput('plot'),
h5("-Problem: The labels on 'The Plot in Question' don't behave as desired.
I'll explain below, but if you play around with the plot,
it will become obvious that they aren't working"),
h5("-Desired Behavior:"),
tags$div(
tags$ul(
tags$li("'The Plot in Question' is just one of many plots available in this tool and is the only one that uses the 'Select Name:' multiple selectInput"),
tags$li("When it is selected some filters (here, just one checkboxGroupInput) and a multiple selectInput are rendered"),
tags$li("The user can filter the dataset down as desired and submit. Two things should happen:"),
tags$ol(tags$li("The data (as filtered) is plotted"),
tags$li("The choices of the 'Select Name:' selectInput initialize to the unique values of names in the filtered data")),
tags$li("As the user selects names from the selectInput, they are highlighted based on the ggplot aesthetics"),
tags$li("Also, and this is where the problem is, I want the right-most (latest year for which data exists) point to receive a label"),
tags$ul(tags$li("I'm doing this using geom_label_repel and using a dplyr call to the data argument to subset the labels")),
tags$li("While the aesthetics work as desired, the labels only appear if you submit again, which is undesired, plus it reinitializes the UI and clears the aesthetics")),
h5("-I think I have a decent understanding of why this is happening:"),
tags$ul(
tags$li("The plot object is in an eventReactive dependent on the submit button so it doesn't react to the selectInput being changed (although, it makes me wonder why the
plot aesthetics react to the selectInput)")),
h5("-The only thing I can think to do is add input$sel_name (the selectInput) to the eventReactive dependency for the plot, but the issue is that other plots use the button
but don't have input$sel_name even rendered"),
h5("-When I try this, the plot doesn't work at all"),
h5("-I've tried things like putting an if statement in the eventReactive that creates the plot object that checks whether input$sel_name exists, but no luck"),
h5("-At one point I had this thing working as desired - I had the entire ggplot call in the renderPlot, however, I need to store the ggplot object to an object so I can
send it to a downloadHandler and download the plot as a .pdf"),
h5("-I realize this is a fairly involved example app, but I really need to get this working. I hope I've explained the problem and desired behavior sufficiently. I'd be happy
to clarify anything."),
h4("Thank you!"))))
server <- function(input,output,session) {
# List for storing user inputs
userInputs <- list(initial = c("D", "E", "H", "S", "T"))
# observeEvent to update list to carry user input over when input re-rendered
observeEvent({input$initial}, {
userInputs$initial <<- input$initial
})
# Render Dynamic UI
output$react_ui <- renderUI({
if(input$plot_selector == "b") {
tagList(
checkboxGroupInput(inputId = "initial",
label = "Show Names Beginning With:",
choices = c("D", "E", "H", "S", "T"),
selected = userInputs$initial),
selectInput(inputId = 'sel_name',
label = 'Select Name:',
choices = if(input$button==0) {
c("")
} else {
unique(sort(filtered_data()$label))
},
multiple = TRUE)
)}
})
# Reactive function to apply filters (just one in the example: initial of the name) to the data
filtered_data <- eventReactive(input$button,{
df %>% filter(str_sub(label,1,1) %in% input$initial)
})
# Reactive function to create the ggplot object
plot <- eventReactive({
input$button
#input$sel_name
}, {
plt <- filtered_data() %>%
ggplot(aes(x = year,
y = y,
group = orgid,
label = label)) +
geom_line(aes(size = label %in% input$sel_name,
color = label %in% input$sel_name,
alpha = label %in% input$sel_name)) +
geom_point(aes(shape = label %in% input$sel_name,
color = label %in% input$sel_name,
alpha = label %in% input$sel_name),
size = 4) +
geom_label_repel(data = df %>%
filter(label %in% input$sel_name) %>%
group_by(orgid) %>%
filter(year == max(year))) +
scale_color_manual(values = c("FALSE" = "black",
"TRUE" = "red"),
guide = FALSE) +
scale_size_manual(values = c("FALSE" = 1,
"TRUE" = 2),
guide = FALSE) +
scale_shape_manual(values = c("FALSE" = 1,
"TRUE" = 24),
guide = FALSE) +
scale_alpha_manual(values = c("FALSE" = 0.1,
"TRUE" = 1),
guide = FALSE) +
labs(title = "The Plot in Question",
y = "Fictitious Variable of Interest",
x = "Year") +
scale_x_continuous(breaks = unique(filtered_data()$year))
return(plt)
})
# Render the Plot
output$plot <- renderPlot(plot())
}
shinyApp(ui=ui, server=server)