Question

这个问题与我几天前有所解决的另一个问题有关。

我的意图：

上传包含多个列的csv。
绘制线条和点图中的每一列。
允许用户从图中选择两个不同的点，称为第一个/最后一个。该程序总是点击最后两个点，命令他们找到第一个/最后一个（第一个＆lt; = last）。

由于列可能因数据集不同而不同，我必须动态创建应用程序的结构，问题是我在observeEvent内的每个图中嵌入了一个observeEvent（当用户更改输入数据集时））。问题是click的observeEvent取决于加载的数据集（不同的列）。

我在应用程序中所做的是创建一个包含所有绘图中所有点击的池，并在需要时从每个绘图中提取最新的两个，并使用此信息修改颜色为绿色和红色的绘图。 / p>

创建两个样本数据集：

inputdata<-data.frame(weekno=1:20, weekna=letters[1:20])
inputdata$normal<-dnorm(inputdata$weekno,10)
inputdata$beta<-dbeta(inputdata$weekno, 1, 1)
inputdata$gamma<-dgamma(inputdata$weekno, 1, 1)
inputdata$logistic<-dlogis(inputdata$weekno,10)
inputdata$poisson<-dpois(inputdata$weekno, 2)
test1<-inputdata[c("normal","gamma")]
row.names(test1)<-inputdata$weekna
test2<-inputdata[c("normal","logistic")]
row.names(test2)<-inputdata$weekna
write.csv(test1, file="test1.csv")
write.csv(test2, file="test2.csv")

该应用：

library(ggplot2)
library(shiny)
library(shinydashboard)

tail.order<-function(i.data, i.n, i.order){
  res<-tail(i.data, n=i.n)
  res<-res[order(res[i.order]),]
  res$id.tail<-1:NROW(res)
  res
}

extract.two<-function(i.data, i.order, i.column){
  #data<-unique(i.data, fromLast=T)
  data<-i.data
  results <- do.call("rbind", by(data, data[i.column], tail.order, i.n=2, i.order=i.order))
  return(results)
}

ui <- fluidPage(
  fluidRow(
    column(4,fileInput('file', "Load file")),
    column(8,uiOutput("maintab"))
  )
)

server <- function(input, output) {

  values <- reactiveValues(origdata = NULL, plotdata = NULL, clickdata=NULL, dummy = TRUE)

  read_data <- reactive({
    infile <- input$file
    inpath <- infile$datapath
    inname <- infile$name
    if(is.null(infile)) readdata<-NULL else readdata<-read.csv(inpath, row.names=1)
    readdata
  })

  observeEvent(input$file, {
    datfile <- read_data()
    seasons<-names(datfile)
    plotdata<-cbind(data.frame(weekno=1:NROW(datfile),weekna=rownames(datfile), stringsAsFactors = F), datfile)
    origdata<-plotdata
    for (s in seasons) eval(parse(text=paste0("plotdata$'",as.character(s),"_color'<-'1'")))
    values$origdata <- origdata
    values$plotdata <- plotdata
    values$clickdata <- data.frame()
    rm("origdata", "plotdata")
    lapply(seasons, function(s){output[[paste0("plot_",as.character(s))]] <- renderPlot({
      ggplot(values$plotdata, aes_(x=as.name("weekno"), y=as.name(s))) +
        geom_point(aes_(as.name("weekno"), as.name(s), colour=as.name(paste0(s,"_color")), size=as.name(paste0(s,"_color")))) +
        scale_color_manual(values = c("1" = "grey", "2" = "red", "3" = "green")) +
        scale_size_manual(values = c("1" = 4, "2" = 6, "3" = 6)) +
        geom_line(aes_(x=as.name("weekno"), y=as.name(s)), color="#000000") +
        ggthemes::theme_few() +
        guides(color=FALSE, size=FALSE)
    })})
    lapply(seasons,function(s){
      observeEvent(input[[paste0("plot_",as.character(s),"_click")]], {
        np <- nearPoints(values$origdata, input[[paste0("plot_",as.character(s),"_click")]], maxpoints=1 , threshold = 10000)
        values$clickdata<-rbind(values$clickdata,cbind(data.frame(variable=as.character(s), stringsAsFactors = F), np))
        if (NROW(values$clickdata)>0){
          p0<-extract.two(values$clickdata,"weekno","variable")
          p1<-subset(p0, variable==as.character(s) & id.tail==1)
          p2<-subset(p0, variable==as.character(s) & id.tail==2)
          if (NROW(p1)>0) {
            values$plotdata[values$plotdata[,paste0(as.character(s),"_color")]=="2", paste0(as.character(s),"_color")]<-"1"
            values$plotdata[values$origdata$weekno==p1$weekno,paste0(as.character(s),"_color")]<-"2"
          }
          if (NROW(p2)>0){
            values$plotdata[values$plotdata[,paste0(as.character(s),"_color")]=="3",paste0(as.character(s),"_color")]<-"1"
            values$plotdata[values$origdata$weekno==p2$weekno,paste0(as.character(s),"_color")]<-"3"
          }
        }
      })
    })
  })

  output$maintab <- renderUI({
    datfile <- read_data()
    seasons<-names(datfile)
    do.call(tabsetPanel,
            c(
              lapply(seasons,function(s){
                call("tabPanel",s,call("plotOutput", outputId=paste0("plot_",as.character(s)),
                                       click = paste0("plot_",as.character(s),"_click")))
              }),
              list(
                tabPanel("First & last",tableOutput("results")),
                tabPanel("Clicks",tableOutput("resultsfull"))
              )
            )
    )
  })

  output$results<-renderTable({
    if (NROW(values$clickdata)>0) extract.two(values$clickdata,"weekno","variable")
  })

  output$resultsfull<-renderTable({
    values$clickdata
  })

}

shinyApp(ui, server)

重现错误：

打开test1.csv，创建每列的observeEvent（“_click”）。打开test2.csv，创建每列的observeEvent（“_click”）。

由于test1.csv和test2.csv第一列被称为“normal”，因此observeEvent $ normal_click被创建两次，所以当我点击该图时，它会将点击两次点击到“点击池”（因为那里）是两个与“normal_click”相关的observeEvent。

当我从“点击池”中提取最新的两个点时，它会两次检索相同的点（我点击的点并存储了两次，因为有两个observeEvents_click到同一个图中）。

我知道要通过取消注释来解决问题：

#data<-unique(i.data, fromLast=T)

通过这种方式，它可以删除重复项，但也拒绝告诉应用程序第一个和最后一个使用相同点的机会（首先可以等于最后一个）。而且这个解决方案并不优雅，因为结构问题仍然存在。

有关如何解决此问题的任何提示？

Answer 1

我发现另一篇文章谈到了另一个引导我解决问题的问题。

我创建了一个observeEvent列表，该列表已创建为不允许复制相同的observeEvent（称为idscreated）。

library(ggplot2)
library(shiny)
library(shinydashboard)

tail.order<-function(i.data, i.n, i.order){
  res<-tail(i.data, n=i.n)
  res<-res[order(res[i.order]),]
  res$id.tail<-1:NROW(res)
  res
}

extract.two<-function(i.data, i.order, i.column){
  data<-i.data
  results <- do.call("rbind", by(data, data[i.column], tail.order, i.n=2, i.order=i.order))
  return(results)
}

ui <- fluidPage(
  fluidRow(
    column(4,fileInput('file', "Load file")),
    column(8,uiOutput("maintab"))
  )
)

server <- function(input, output) {

  values <- reactiveValues(origdata = NULL, plotdata = NULL, clickdata=NULL, idscreated = character())

  read_data <- reactive({
    infile <- input$file
    inpath <- infile$datapath
    inname <- infile$name
    if(is.null(infile)) readdata<-NULL else readdata<-read.csv(inpath, row.names=1)
    readdata
  })

  observeEvent(read_data(), {
    datfile <- read_data()
    seasons<-names(datfile)
    plotdata<-cbind(data.frame(weekno=1:NROW(datfile),weekna=rownames(datfile), stringsAsFactors = F), datfile)
    origdata<-plotdata
    for (s in seasons) eval(parse(text=paste0("plotdata$'",as.character(s),"_color'<-'1'")))
    values$origdata <- origdata
    values$plotdata <- plotdata
    values$clickdata <- data.frame()
    rm("origdata", "plotdata")
    lapply(seasons, function(s){output[[paste0("plot_",as.character(s))]] <- renderPlot({
      ggplot(values$plotdata, aes_(x=as.name("weekno"), y=as.name(s))) +
        geom_point(aes_(as.name("weekno"), as.name(s), colour=as.name(paste0(s,"_color")), size=as.name(paste0(s,"_color")))) +
        scale_color_manual(values = c("1" = "grey", "2" = "red", "3" = "green", "4" = "purple")) +
        scale_size_manual(values = c("1" = 4, "2" = 6, "3" = 6, "4" = 8)) +
        geom_line(aes_(x=as.name("weekno"), y=as.name(s)), color="#000000") +
        ggthemes::theme_few() +
        guides(color=FALSE, size=FALSE)
    })})
    lapply(seasons,function(s){
      nameid<-paste0("plot_",as.character(s),"_click")
      if (!(nameid %in% values$idscreated)){
        values$idscreated<-c(values$idscreated,nameid)
      observeEvent(input[[nameid]], {
        np <- nearPoints(values$origdata, input[[nameid]], maxpoints=1 , threshold = 10000)
        values$clickdata<-rbind(values$clickdata,cbind(data.frame(variable=as.character(s), stringsAsFactors = F), np))
        if (NROW(values$clickdata)>0){
          p0<-extract.two(values$clickdata,"weekno","variable")
          p1<-subset(p0, variable==as.character(s) & id.tail==1)
          p2<-subset(p0, variable==as.character(s) & id.tail==2)
          if (NROW(p1)>0) {
            values$plotdata[values$plotdata[,paste0(as.character(s),"_color")]!="3", paste0(as.character(s),"_color")]<-"1"
            values$plotdata[values$origdata$weekno==p1$weekno,paste0(as.character(s),"_color")]<-"2"
          }
          if (NROW(p2)>0){
            values$plotdata[values$plotdata[,paste0(as.character(s),"_color")]!="2", paste0(as.character(s),"_color")]<-"1"
            values$plotdata[values$origdata$weekno==p2$weekno,paste0(as.character(s),"_color")]<-"3"
          }
          if (NROW(p1)>0 & NROW(p2)>0){
            if (p1$weekno==p2$weekno){
              values$plotdata[, paste0(as.character(s),"_color")]<-"1"
              values$plotdata[values$origdata$weekno==p1$weekno,paste0(as.character(s),"_color")]<-"4"
            }
          }

        }
      })
      }

    })
  })

  output$maintab <- renderUI({
    datfile <- read_data()
    seasons<-names(datfile)
    do.call(tabsetPanel,
            c(
              lapply(seasons,function(s){
                call("tabPanel",s,call("plotOutput", outputId=paste0("plot_",as.character(s)),
                                       click = paste0("plot_",as.character(s),"_click")))
              }),
              list(
                tabPanel("First & last",tableOutput("results")),
                tabPanel("Clicks",tableOutput("resultsfull"))
              )
            )
    )
  })

  output$results<-renderTable({
    if (NROW(values$clickdata)>0) extract.two(values$clickdata,"weekno","variable")
  })

  output$resultsfull<-renderTable({
    values$clickdata
  })

}

shinyApp(ui, server)

嵌套两个observeEvent会复制被动事件

1 个答案: