r - 具有自适应数据框的闪亮应用程序，用于更改点分析

Question

我正在尝试构建一个应用程序，它可以让您从多个分布中生成数据点，并对生成的数据运行变化点分析。这个想法是：

1. 选择所需的分布
2. 所需分布的输入参数
3. 按下按钮将生成的数据附加到主数据框
4. 按下按钮时，自动运行变化点分析并输出带有垂直线的数据图，显示变化点并输出拟合摘要

应用代码

library(shiny)
library(plotly)
Sys.setlocale("LC_ALL", "Latvian")

#changepoint detection packages
library(changepoint)

#misc packages
library(tidyverse)
library(magrittr)

ui <- fluidPage(
  titlePanel("Changepoint detection using R packages"),
  sidebarLayout(
    sidebarPanel(
      tabsetPanel(
        tabPanel("Generate data",
                 selectInput("distribution", "Distribution", choices = c("Normal", "Uniform")),
                 uiOutput("ui_selected"),
                 actionButton("button_click", "Add")
                 )
      )
    ),
    mainPanel(
      plotly::plotlyOutput("cpts"),
      verbatimTextOutput("summary")
    )
  )
)

server <- function(input, output) {
  output$ui_selected <- renderUI({
    
    if (input$distribution == 'Normal'){
      list(numericInput("mean", "Mean", 0),
      numericInput("sd", "Standard deviation", 1),
      numericInput("length", "Length", 30),
      numericInput("seed", "Seed", 123))
    } else if (input$distribution == 'Uniform'){
      list(numericInput("minimum", "Min value", 0),
      numericInput("maximum", "Max value", 1),
      numericInput("length", "Length", 30),
      numericInput("seed", "Seed", 123))
    }
  })
  
  data <- data.frame(x = numeric(0), y = numeric(0))
  
  observeEvent(input$button_click,{
    if (input$distribution == 'Normal'){
      set.seed(input$seed)
      a <- rnorm(input$length, input$mean, input$sd)
      b <- data.frame(x = seq(length(data$x)+1, length(a)), y = a)
      data <- rbind.data.frame(data, b)
    }
    if (input$distribution == 'Uniform'){
      set.seed(input$seed)
      a <- runif(input$length, input$min, input$max)
      b <- data.frame(x = seq(length(data$x)+1, length(a)), y = a)
      data <- rbind.data.frame(data, b)
    }
  })
  
  
  rval_changepoint_fit <- eventReactive(input$button_click,{
    changepoint_fit <- cpt.mean(data$y, method = "PELT")
    changepoint_fit
  })
  
  output$cpts <- plotly::renderPlotly({
    ggplot(data, aes(x = x, y = y))+
      geom_line()+
      geom_vline(xintercept = cpts(rval_changepoint_fit()), col = "red")})
  
  output$summary <- renderPrint({rval_changepoint_fit()})
  
}

shinyApp(ui = ui, server = server)

我已经使用预设数据集测试了该应用程序，它似乎可以工作，但是，当我实现生成数据的能力时，它给了我一个错误：

Warning: Error in multiple.mean.norm: Minimum segment legnth is too large to include a change in this data
  [No stack trace available]
Warning: Error in multiple.mean.norm: Minimum segment legnth is too large to include a change in this data
  [No stack trace available]

我会很感激任何建议。

标签： rshiny

Answer 1

前面：

• 你使用data.frame$x（两次），它应该是data$x；
• 您也有排序问题，也许使用x = nrow(data) + seq(input$length); 和
• 对于这两者，我发现 usingdata偶尔会与函数混淆utils::data，请考虑使用与常见的 base-R 函数不同的名称

---

让我解释一下我是如何解决这个问题的。到目前为止，这不是唯一的机制，但它在我的开发环境中运行良好。

一个步骤是插入browser()每个（可能的）反应块并逐行跟踪它（在控制台上，这不适用于 shinyapps.io 或任何其他闪亮的“服务器”）。然而，对于较大的应用程序，这可能是繁重、缓慢的，坦率地说，它可能不会在第一次（或第十次）通过一个块时发现错误。（而且您可能会忘记删除browser()...的所有实例）

因此，了解哪条线路导致错误非常有帮助。为此，R 可以提供堆栈跟踪（通过traceback()），但是当在闪亮中运行时，当您需要它时可能很难获得它（并且它是瞬态的）。获得即时行号提示（如果可能）的一种技术是：

options(
  error = function() {
    sink(stderr())
    on.exit(sink(NULL))
    traceback(3, max.lines = 1L)
    if (!interactive()) {
      q(status = 1)
    }
  }
)

(function() { 1                  # line 1
   2                             # line 2
   3                             # line 3
   stop("quux")                  # line 4
 })()                            # line 5
# Error in (function() { : quux
# 2: stop("quux") at #4                     <---- line 4 of my anonymous function
# 1: (function() {
#     ...

因此，让我们将其应用于您的应用程序。我将您的应用程序保存到一个.R文件中，因此行号可能与您的不完全一致，但这些步骤仍将继续执行。

shinyApp(ui = ui, server = server)

# [1] "LC_COLLATE=Latvian_Latvia.1257;LC_CTYPE=Latvian_Latvia.1257;LC_MONETARY=Latvian_Latvia.1257;LC_NUMERIC=C;LC_TIME=Latvian_Latvia.1257"
# Listening on http://127.0.0.1:3877
# Warning: Error in $: object of type 'closure' is not subsettable
#   79: seq
#   77: observeEventHandler [~/StackOverflow/11362744/61855868.R#55]
#    6: runApp
#    4: print.shiny.appobj
#    2: ss
#    1: .ess.source

（有一个提示：当 R 抱怨 时'closure' is not subsettable，这意味着您认为某些东西是数据（并尝试用$or对其进行子集化[），而实际上它是 a function。）

查看第 53-57 行，我们有

      set.seed(input$seed)
      a <- rnorm(input$length, input$mean, input$sd)
      b <- data.frame(x = seq(length(data.frame$x)+1, length(a)), y = a)
      data <- rbind.data.frame(data, b)
    }

中线是 call length(data.frame$x)+1，其中data.frame$x“显然”不正确。我认为您的意思是使用data您之前定义的几行框架。changepoint（它在您的三个输出中正确引用。）

第 61 行也是如此。

添加browser()到每个observe/reactive块的开头的替代方案会给您带来相同的结论。

旁注：

1. 命名变量data也可能产生'closure'错误，因为如果您不定义它，那么对它的任何操作都将处理 function utils::data。很多人命名他们的东西data，但这可能是一个模糊的错误（特别是如果你不知道什么是闭包）。

2. 在概念上迭代地构建一个data.frame作品，但它的扩展性很差。每次即使只添加一行，它也会在内存中创建所有其他行的完整副本。这样做几次还不错，但是以后会变得很昂贵（并且数据更大）。请参阅R Inferno中的第 2 章，不断增长的对象。（对于您在这里所做的事情，它可能不会变得很大，并且可能没有简单的方法来解决它。请记住它。）

3. 您确实 create data，但该实例是内部的，observeEvent并且不会覆盖data <- data.frame(...)您在其上方仅定义的几行。虽然您可以使用全局分配<<-来更新框架，但依赖于该框架的所有输出都不会对其更改做出反应。当您拥有可以像这样更改（和/或应该手动创建）并且应该触发响应式更新的数据时，那么您应该将其设为reactive数据。

   我会将您应用程序的中间部分更改为：

     mydata <- reactiveVal(data.frame(x = numeric(0), y = numeric(0)))
   
     observeEvent(input$button_click,{
       if (input$distribution == 'Normal'){
         set.seed(input$seed)
         a <- rnorm(input$length, input$mean, input$sd)
         b <- data.frame(x = seq(length(mydata()$x)+1, length(a)), y = a)
         mydata( rbind.data.frame(mydata(), b) )
       }
       if (input$distribution == 'Uniform'){
         set.seed(input$seed)
         a <- runif(input$length, input$min, input$max)
         b <- data.frame(x = seq(length(mydata()$x)+1, length(a)), y = a)
         mydata( rbind.data.frame(mydata(), b) )
       }
     })
   

   （请注意，我将其重命名为mydata，并且因为它是响应式数据，您需要使用mydata()它来检索它的值，并mydata(newval)覆盖它的值。）

4. 我认为您的使用seq(length(...)+1, length(a))略有缺陷。请注意，按一次按钮后，您的数据将有 30 行。假设您更改input$length为 20 并再次按下按钮，该呼叫将是seq(30+1, 20)，这不一定是您想要的。也许x = nrow(mydata()) + seq(input$length)？