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

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

基本上，我正在寻找 something like this 在 RShiny 中。对如何实现这一目标有任何帮助吗？

最佳答案

您可以使用 R/Shiny + d3.js 来完成:可以在下面找到预览、可重现的示例、代码和演练。

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

“对于 d3 v5，我必须将事件从 dragstart 和 dragend 重命名为开始和结束，并将行 var drag = d3.behavior.drag() 更改为 var drag d3.drag()。”

可重现的例子:

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

预览:

对不起 gif 质量差:

解释:

代码基于d3.js+shiny+R。它包含一个自定义 Shiny 函数，我将其命名为 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

包含一个自定义 Shiny 函数 DragableChartOutput()，它在 DragableFunctions.R 中定义。

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

server.R

除了自定义函数 renderDragableChart() 之外，还有基本的 Shiny 效果。

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, width="500px", height="500px") {
  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", 坐标);});.可以在 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");

关于javascript - R/Shiny 中的可拖动折线图，我们在Stack Overflow上找到一个类似的问题： https://stackoverflow.com/questions/47280032/