[英]R shiny: How to copy data derived from plotly_selection events into a data frame/table and update each time by pressing an actionButton?
我正在整理一个 shiny 应用程序来处理一些运动员 GPS 数据。 本质上，我希望构建我的脚本，以便每次用户在 plotly plot 上选择感兴趣的区域并单击“添加” actionButton按钮时，下表将添加计算的Start_time 、 Time_at_peak 、 Max_velocity 、 Time_to_peak Distance_to_peak值。
该问题可以在下面的 GIF 中看到： - 一旦选择了感兴趣的区域并单击了“添加”按钮，第一个值似乎是正确的。 但是，当用户选择要添加到表中的第二个感兴趣区域时，它会覆盖初始条目，并且每次进行新选择时都会继续覆盖。 这似乎是因为代码位于observeEvent(event_data("plotly_selected")内，令人困惑的是，它需要在其中才能计算感兴趣的变量。
我目前有点难过，似乎找不到任何相关信息。 因此，任何指导将不胜感激！
这是一个我们可以上传到应用程序的一些测试数据的链接： https://wetransfer.com/downloads/5a7c5da5a7647bdbe133eb3fdac79c6b20211119052848/afe3e5
library(shiny)
library(readr)
library(DT)
library(dplyr)
library(plotly)
library(lubridate)
library(tidyr)
library(purrr)
library(htmlwidgets)
library(shinydashboard)
library(dashboardthemes)
library(shinyjs)
x_df <- data.frame(Start_time = character(1), Time_at_peak = character(1), Max_velocity = integer(1),
Time_to_peak = integer(1), Distance_to_peak = integer(1))
x_df$Start_time <- as.character("0:00:00.0")
x_df$Time_at_peak <- as.character("0:00:00.0")
x_df$Max_velocity <- as.integer(0)
x_df$Time_to_peak <- as.integer(0)
x_df$Distance_to_peak <- as.integer(0)
runApp(shinyApp(
ui=(fluidPage(
titlePanel("Event to Table"),
mainPanel(
fileInput(
inputId = "filedata",
label = "Upload data file (.csv)",
accept = c(".csv")),
plotlyOutput('myPlot'),br(),br(),br(),br(),
DTOutput("testing"), br(), br(),
fluidRow(
valueBoxOutput("starttime", width = 2),
valueBoxOutput("endtime", width = 2),
valueBoxOutput("maxvelocity", width = 2),
valueBoxOutput("timediff", width = 3),
valueBoxOutput("distance", width = 3)
),
useShinyjs(),
fluidRow(
div(style = "text-align:center", actionButton("Add", "Add Data to Table"),
downloadButton("export", "Export Table as .CSV"))), br(),
DTOutput(outputId = "table")))
),
server = (function(input, output, session) {
data<-reactive({
req(input$filedata)
read.csv(input$filedata$datapath, header = TRUE)%>%
rename(Velocity = 'Speed..m.s.',
Player = 'Player.Display.Name',
Latitude = 'Lat',
Longtitude = 'Lon',
AccelImpulse = 'Instantaneous.Acceleration.Impulse',
HeartRate = 'Heart.Rate..bpm.')
})
observe({
thedata<-data()
updateSelectInput(session, 'y', choices = names(data))
})
output$myPlot = renderPlotly({
plot_ly(data = data(), x = ~Time, y = ~Velocity, height = 450,
marker =list(color = 'rgb(132,179,202)', size = 0.1),
line = list(color = 'rgb(132,179,202)', size = 0.1, width = 0.9),
type = 'scatter', mode = 'markers+lines') %>%
layout(dragmode = "select",
showlegend = F,
title = list(text = 'Velocity Trace', font = list(size = 20)),
xaxis = list(title = list(text = "", standoff = 0), nticks = 10),
yaxis = list(title = list(text = "Velocity (m/s)"), nticks = 5, gridcolor = "#46505a"),
font = list(color = 'black'),
margin = list(t = 70))
})
observeEvent(event_data("plotly_selected"), {
event.data <- event_data("plotly_selected")
if (max(event.data$y) < 1.5) {
maxvel <- (max(event.data$y))
maxpos <- match(maxvel, event.data$y)
}
else {
filter1 <- filter (event.data, event.data$y > 1.5)
maxvel <- (max(filter1$y))
maxpos <- match(maxvel, event.data$y)
}
zero_val <- function(x) x == 0
zero_index <- event.data$y[1:maxpos] %>% detect_index(zero_val, .dir = "backward")
if (zero_index==0) {starttime <- event.data$x[1]}
else {starttime <- event.data$x[zero_index]}
endvel <- which.max(event.data$y)
endtime <- event.data$x[endvel]
timediff <- paste(today(), endtime) %>% as_datetime() - paste(today(), starttime) %>% as_datetime()
sprint <- as_tibble(event.data$y[zero_index:endvel])
ms <- as_tibble(rep(0.1, count(sprint)))
time_vel <- cbind(ms, sprint)
distance <- sum(time_vel[1]*time_vel[2])
sprintselect <- as_tibble(cbind(Start_time = starttime,
Time_at_peak = endtime,
Max_velocity = round(maxvel, 2),
Time_to_peak = round(timediff, 1),
Distance_to_peak = round(distance, 1)))
values <- reactiveValues()
values$df <- x_df
addData <- observe({
if(input$Add > 0) {
newLine <- isolate(data.frame(Start_time = sprintselect$Start_time, Time_at_peak = sprintselect$Time_at_peak,
Max_velocity = sprintselect$Max_velocity,
Time_to_peak = sprintselect$Time_to_peak,
Distance_to_peak = sprintselect$Distance_to_peak,
stringsAsFactors= FALSE))
values$df <- isolate(rbind(values$df, newLine))}
})
output$testing <- renderDataTable({values$df})
})
})
))
我已经设法弄清楚并认为我会发布答案而不是删除问题 - 以防万一有人想要做类似的事情并且他们不确定如何去做。
首先，我从一开始就删除了预填充的表x_df - 它不再需要。
虽然我认为代码需要正确地放在observeEvent(event_data("plotly_selected")到 function 中，但它没有 - 谢天谢地，因为这是问题的根源。相反，我使用observeEvent(input$Add, { (这是使用的正确代码，而不是if(input$Add > 0) ) 将事件锚定到单击添加按钮。
values <- reactiveValues()被放置在observeEvent()之外，如果它是第一个选择，则使用 IF 语句将数据单独添加到values$df数据框中，或者将其绑定到现有保存的数据.
这是新代码和演示的 GIF。
library(shiny)
library(readr)
library(DT)
library(dplyr)
library(plotly)
library(lubridate)
library(tidyr)
library(purrr)
library(htmlwidgets)
library(shinydashboard)
library(dashboardthemes)
library(shinyjs)
runApp(shinyApp(
ui=(fluidPage(
titlePanel("Event to Table"),
mainPanel(
fileInput(
inputId = "filedata",
label = "Upload data file (.csv)",
accept = c(".csv")),
plotlyOutput('myPlot'),br(),br(),br(),br(),
DTOutput("testing"), br(), br(),
fluidRow(
valueBoxOutput("starttime", width = 2),
valueBoxOutput("endtime", width = 2),
valueBoxOutput("maxvelocity", width = 2),
valueBoxOutput("timediff", width = 3),
valueBoxOutput("distance", width = 3)
),
useShinyjs(),
fluidRow(
div(style = "text-align:center", actionButton("Add", "Add Data to Table"),
downloadButton("export", "Export Table as .CSV"))), br(),
DTOutput(outputId = "table")))
),
server = (function(input, output, session) {
values <- reactiveValues(df_data = NULL)
data<-reactive({
req(input$filedata)
read.csv(input$filedata$datapath, header = TRUE)%>%
rename(Velocity = 'Speed..m.s.',
Player = 'Player.Display.Name',
Latitude = 'Lat',
Longtitude = 'Lon',
AccelImpulse = 'Instantaneous.Acceleration.Impulse',
HeartRate = 'Heart.Rate..bpm.')
})
observe({
thedata<-data()
updateSelectInput(session, 'y', choices = names(data))
})
output$myPlot = renderPlotly({
plot_ly(data = data(), x = ~Time, y = ~Velocity, height = 450,
marker =list(color = 'rgb(132,179,202)', size = 0.1),
line = list(color = 'rgb(132,179,202)', size = 0.1, width = 0.9),
type = 'scatter', mode = 'markers+lines') %>%
layout(dragmode = "select",
showlegend = F,
title = list(text = 'Velocity Trace', font = list(size = 20)),
xaxis = list(title = list(text = "", standoff = 0), nticks = 10),
yaxis = list(title = list(text = "Velocity (m/s)"), nticks = 5, gridcolor = "#46505a"),
font = list(color = 'black'),
margin = list(t = 70))
})
observeEvent(input$Add, {
event.data <- event_data("plotly_selected")
if (max(event.data$y) < 1.5) {
maxvel <- (max(event.data$y))
maxpos <- match(maxvel, event.data$y)
}
else {
filter1 <- filter (event.data, event.data$y > 1.5)
maxvel <- (max(filter1$y))
maxpos <- match(maxvel, event.data$y)
}
zero_val <- function(x) x == 0
zero_index <- event.data$y[1:maxpos] %>% detect_index(zero_val, .dir = "backward")
if (zero_index==0) {starttime <- event.data$x[1]}
else {starttime <- event.data$x[zero_index]}
endvel <- which.max(event.data$y)
endtime <- event.data$x[endvel]
timediff <- paste(today(), endtime) %>% as_datetime() - paste(today(), starttime) %>% as_datetime()
sprint <- as_tibble(event.data$y[zero_index:endvel])
ms <- as_tibble(rep(0.1, count(sprint)))
time_vel <- cbind(ms, sprint)
distance <- sum(time_vel[1]*time_vel[2])
sprintselect <- as_tibble(cbind(Start_time = starttime,
Time_at_peak = endtime,
Max_velocity = round(maxvel, 2),
Time_to_peak = round(timediff, 1),
Distance_to_peak = round(distance, 1)))
newLine <- isolate(data.frame(Start_time = sprintselect$Start_time, Time_at_peak = sprintselect$Time_at_peak,
Max_velocity = sprintselect$Max_velocity,
Time_to_peak = sprintselect$Time_to_peak,
Distance_to_peak = sprintselect$Distance_to_peak,
stringsAsFactors= FALSE))
if (is.null(values$df)){
values$df <- newLine}
else {
values$df <- isolate(rbind(values$df, newLine))}
output$testing <- renderDataTable({values$df})
})
})
))
R 闪亮：如何在每次按下 actionButton 时更新反应数据框而不创建新的反应数据框？
[英]R shiny: How to get an reactive data frame updated each time pressing an actionButton without creating a new reactive data frame?
如何在运行时通过单击 R 中的 actionButton 来更新数据
[英]How to to update data by clicking actionButton in R in runtime
无法通过actionButton（）更新Shiny + RMySQL中的SQL数据
[英]Cannot Update SQL data in Shiny + RMySQL by actionButton()
使用 R Shiny 中的 actionButton 更新新表
[英]Update new table with rows appended using actionButton in R Shiny
声明:本站的技术帖子网页，遵循CC BY-SA 4.0协议，如果您需要转载，请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.