R/Shiny 中的可拖动折线图

Posted 2023-03-24

【中文标题】R/Shiny 中的可拖动折线图

【英文标题】：Draggable line chart in R/Shiny

【发布时间】：2018-04-27 01:29:31

【问题描述】：

我已经构建了一个 R/Shiny 应用程序，它使用线性回归来预测一些指标。

为了让这个应用更具交互性，我需要添加一个折线图，在这里我可以拖动折线图的点，捕捉新的点并根据新点预测值。

基本上，我在 RShiny 中寻找 something like this。关于如何实现这一点的任何帮助？

【问题讨论】：

您也可以查看googleVis，他们似乎有一些与您的需求相似的东西

组合它们将给出静态图。我希望使图形具有交互性，因此如果我将点从 (x1,y1) 更改为 (x2,y2)，我的后端方程应该捕获新点并抛出更新的结果。请帮忙！

可以使用 plotly 构建交互式图形，参见例如plot.ly/r/shinyapp-linked-click

寻找像这样的可拖动图形：bl.ocks.org/denisemauldin/538bfab8378ac9c3a32187b4d7aed2c2 如果我使用线性回归，拖动该点应该会改变我的预测值。在这方面的任何帮助将不胜感激

你看到了吗：github.com/Yang-Tang/shinyjqui

【参考方案1】：

您可以使用 R/Shiny + d3.js 做到这一点：可以在下面找到预览、可重现的示例、代码和演练。

编辑：12/2018 - 查看 MrGrumble 的评论：

“使用 d3 v5，我必须将事件从 dragstart 和 dragend 重命名为 start 和 end，并将行 var drag = d3.behavior.drag() 更改为 var drag d3.drag()。”

可重现的例子：

最简单的方法是克隆此存储库 (https://github.com/Timag/DraggableRegressionPoints)。

预览：

对于糟糕的 gif 质量表示抱歉：

说明：

代码基于d3.js+shiny+R。它包括一个自定义闪亮功能，我将其命名为renderDragableChart()。您可以设置圆圈的颜色和半径。 实现可以在DragableFunctions.R找到。

R->d3.js->R的交互：

数据点的位置最初是在 R 中设置的。参见 server.R：

df <- data.frame(x = seq(20,150, length.out = 10) + rnorm(10)*8,
                 y = seq(20,150, length.out = 10) + rnorm(10)*8)
df$y[1] = df$y[1] + 80

图形通过 d3.js 渲染。必须在此处添加诸如线条等添加。 主要噱头应该是点是可拖动的，并且应该将更改发送到 R。 第一个用.on('dragstart', function(d, i) 和.on('dragend', function(d, i) 实现，后者用Shiny.onInputChange("JsData", coord);实现。

代码：

ui.R

包括在DragableFunctions.R 中定义的自定义闪亮函数DragableChartOutput()。

library(shiny)
shinyUI( bootstrapPage( 
  fluidRow(
    column(width = 3,
           DragableChartOutput("mychart")
    ),
    column(width = 9,
           verbatimTextOutput("regression")
    )
  )
))

server.R

除了自定义函数renderDragableChart()之外，也是基本的闪亮。

library(shiny)
options(digits=2)
df <- data.frame(x = seq(20,150, length.out = 10) + rnorm(10)*8,
                 y = seq(20,150, length.out = 10) + rnorm(10)*8)
df$y[1] = df$y[1] + 80
#plot(df)
shinyServer( function(input, output, session) 

  output$mychart <- renderDragableChart(
    df
  , r = 3, color = "purple")
  
  output$regression <- renderPrint(
    if(!is.null(input$JsData))
      mat <- matrix(as.integer(input$JsData), ncol = 2, byrow = TRUE)
      summary(lm(mat[, 2] ~  mat[, 1]))
    else
      summary(lm(df$y ~  df$x))
    
  )
)

函数在DragableFunctions.R中定义。注意，它也可以用library(htmlwidgets) 来实现。我决定长期实现它，因为它并不难，而且你对界面有更多的了解。

library(shiny)

dataSelect <- reactiveValues(type = "all")

# To be called from ui.R
DragableChartOutput <- function(inputId, , ) 
  style <- sprintf("width: %s; height: %s;",
    validateCssUnit(width), validateCssUnit(height))
  tagList(
    tags$script(src = "d3.v3.min.js"),
    includeScript("ChartRendering.js"),
    div(id=inputId, class="Dragable", style = style,
      tag("svg", list())
    )
  )


# To be called from server.R
renderDragableChart <- function(expr, env = parent.frame(), quoted = FALSE, color = "orange", r = 10) 
  installExprFunction(expr, "data", env, quoted)
  function()
    data <- lapply(1:dim(data())[1], function(idx) list(x = data()$x[idx], y = data()$y[idx], r = r))
    list(data = data, col = color)
   

现在我们只剩下生成 d3.js 代码了。这是在 ChartRendering.js 中完成的。基本上必须创建圆圈并添加“可拖动功能”。拖动完成后，我们希望将更新的数据发送到 R。这在 .on('dragend',.) 和 Shiny.onInputChange("JsData", coord);); 中实现。可以通过server.R 和input$JsData 访问此数据。

var col = "orange";
var coord = [];
var binding = new Shiny.OutputBinding();

binding.find = function(scope) 
  return $(scope).find(".Dragable");
;

binding.renderValue = function(el, data) 
  var $el = $(el);
  var boxWidth = 600;  
  var boxHeight = 400;
  dataArray = data.data
  col = data.col
    var box = d3.select(el) 
            .append('svg')
            .attr('class', 'box')
            .attr('width', boxWidth)
            .attr('height', boxHeight);     
        var drag = d3.behavior.drag()  
        .on('dragstart', function(d, i)  
                box.select("circle:nth-child(" + (i + 1) + ")")
                .style('fill', 'red'); 
            )
            .on('drag', function(d, i)  
              box.select("circle:nth-child(" + (i + 1) + ")")
                .attr('cx', d3.event.x)
                .attr('cy', d3.event.y);
            )
      .on('dragend', function(d, i)  
                circle.style('fill', col);
                coord = []
                d3.range(1, (dataArray.length + 1)).forEach(function(entry) 
                  sel = box.select("circle:nth-child(" + (entry) + ")")
                  coord = d3.merge([coord, [sel.attr("cx"), sel.attr("cy")]])                 
                )
                console.log(coord)
        Shiny.onInputChange("JsData", coord);
            );
            
        var circle = box.selectAll('.draggableCircle')  
                .data(dataArray)
                .enter()
                .append('svg:circle')
                .attr('class', 'draggableCircle')
                .attr('cx', function(d)  return d.x; )
                .attr('cy', function(d)  return d.y; )
                .attr('r', function(d)  return d.r; )
                .call(drag)
                .style('fill', col);
;

// Regsiter new Shiny binding
Shiny.outputBindings.register(binding, "shiny.Dragable");

【讨论】：

这个函数也可以用来画线和调整顶点吗？

一般来说是的。该图是通过 d3.js 生成的。所以它必须在那里添加。

是的，这是一个非常好的功能！我不想手动奖励赏金，因为我不知道@savita，但你的回答完全值得，而且无论如何都是无与伦比的；）

使用 d3 v5，我不得不将事件从 dragstart 和 dragend 重命名为 start 和 end，并将行 var drag = d3.behavior.drag() 更改为 var drag d3.drag()。

【参考方案2】：

您也可以在 plotly 中使用闪亮的可编辑形状来做到这一点：

library(plotly)
library(purrr)
library(shiny)

ui <- fluidPage(
  fluidRow(
    column(5, verbatimTextOutput("summary")),
    column(7, plotlyOutput("p"))
  )
)

server <- function(input, output, session) 

  rv <- reactiveValues(
    x = mtcars$mpg,
    y = mtcars$wt
  )
  grid <- reactive(
    data.frame(x = seq(min(rv$x), max(rv$x), length = 10))
  )
  model <- reactive(
    d <- data.frame(x = rv$x, y = rv$y)
    lm(y ~ x, d)
  )

  output$p <- renderPlotly(
    # creates a list of circle shapes from x/y data
    circles <- map2(rv$x, rv$y, 
      ~list(
        type = "circle",
        # anchor circles at (mpg, wt)
        xanchor = .x,
        yanchor = .y,
        # give each circle a 2 pixel diameter
        x0 = -4, x1 = 4,
        y0 = -4, y1 = 4,
        xsizemode = "pixel", 
        ysizemode = "pixel",
        # other visual properties
        fillcolor = "blue",
        line = list(color = "transparent")
      )
    )

    # plot the shapes and fitted line
    plot_ly() %>%
      add_lines(x = grid()$x, y = predict(model(), grid()), color = I("red")) %>%
      layout(shapes = circles) %>%
      config(edits = list(shapePosition = TRUE))
  )

  output$summary <- renderPrint(a
    summary(model())
  )

  # update x/y reactive values in response to changes in shape anchors
  observe(
    ed <- event_data("plotly_relayout")
    shape_anchors <- ed[grepl("^shapes.*anchor$", names(ed))]
    if (length(shape_anchors) != 2) return()
    row_index <- unique(readr::parse_number(names(shape_anchors)) + 1)
    pts <- as.numeric(shape_anchors)
    rv$x[row_index] <- pts[1]
    rv$y[row_index] <- pts[2]
  )



shinyApp(ui, server)

【讨论】：

这是否适用于 ggplot 对象？