我已经构建了一个R / Shiny应用程序,它使用线性回归来预测某些指标。
为了使这个应用程序更具交互性,我需要添加一个折线图,在这里我可以拖动折线图的点,捕获新点并根据新点预测值。
基本上,我正在寻找R Shiny中的qazxsw poi。有关如何实现这一目标的任何帮助?
您可以使用R / Shiny + d3.js进行操作:可以在下面找到预览,可重现的示例,代码和演练。
编辑次数:12/2018 - 请参阅MrGrumble的评论:
“对于d3 v5,我必须将事件从dragstart和dragend重命名为开始和结束,并将行var drag = d3.behavior.drag()更改为var drag d3.drag()。”
可重复的例子:
最简单的方法是克隆此存储库(something like this)。
预习:
Sry因为gif质量差:https://github.com/Timag/DraggableRegressionPoints
说明:
代码基于d3.js + shiny + R.它包括一个自定义闪亮功能,我命名为。您可以设置圆的颜色和半径。实施可以在renderDragableChart()
找到。
R-> d3.js-> R的相互作用:
数据点的位置最初在R中设置。请参阅server.R:
DragableFunctions.R
图形通过d3.js呈现。必须在那里添加诸如线等的附加物。主要的噱头应该是这些点是可拖动的,并且应该将更改发送给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
和.on('dragstart', function(d, i) {}
实现的,后者用.on('dragend', function(d, i) {}
实现。
代码:
长子。 [R
包括在Shiny.onInputChange("JsData", coord);
中定义的自定义闪亮函数DragableChartOutput()
。
DragableFunctions.R
server.R
除了自定义功能library(shiny)
shinyUI( bootstrapPage(
fluidRow(
column(width = 3,
DragableChartOutput("mychart")
),
column(width = 9,
verbatimTextOutput("regression")
)
)
))
外,还基本闪亮。
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)
现在我们只剩下生成d3.js代码了。这是在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)
}
}
完成的。基本上必须创建圆圈并且必须添加“可拖动功能”。一旦拖动动作完成,我们希望将更新的数据发送到R.这在ChartRendering.js
中使用.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");
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)