Estateira
commented
2 years ago I made a few changes, now it works that when the points on the charts are dragged, the rhandsontable also gets updated with the new values (the same values which were previously only shown in output$outTab)
library(shiny)
library(dplyr)
library(rhandsontable)
library(purrr)
library(plotly)
maxX = 100
n = maxX + 1
startDF <- data.frame(X = c(0, 20, 30, maxX), Y = c(1, 2, 3, 4))
ui <- fluidPage(
column(
3,
h4("Editable handsontable"),
rHandsontableOutput('table'),
br(),
h4("Values to update in handsontable from moving blue dots on figure"),
textOutput("newPoint"),
h4("Now we can see that the tables are equal"),
tableOutput("outTab")
),
column(
6,
h4("Click and drag blue markers to change the curve"),
plotlyOutput("p")
)
)
server <- function(input, output, session) {
rv <- reactiveValues()
rv$tab <- startDF
#editable handsontable with QC only updates with correct values
df <- eventReactive(input$table , {
if (is.null(input$table)) {
df <- rv$tab
dfOld <<- df
} else {
df <- hot_to_r(input$table)
# Quality control
# Rule 1: maintain X values in correct order with extreme values as 0 and maxX
ifelse(
df$X[1] != 0 |
df$X[1] >= df$X[2] |
df$X[2] >= df$X[3] |
df$X[3] >= df$X[4] |
df$X[4] != maxX,
df$X <- dfOld$X,
df$X <- df$X
)
}
dfOld <- df
df
},
ignoreNULL = F)
output$table <- renderRHandsontable({
rhandsontable(df()) %>%
#hot_col("Parameter", readOnly = TRUE)%>%
hot_validate_numeric(
col = 'X',
min = 0,
max = maxX,
allowInvalid = FALSE
) %>%
hot_validate_numeric(col = 'Y',
min = 0,
allowInvalid = FALSE)
})
observe(rv$tab <- df())
observeEvent(rv$tab$X |
rv$tab$Y , {
rv$mySpline <- as.data.frame(spline(
rv$tab$X,
rv$tab$Y,
xmin = 0,
xmax = maxX,
n = n
)) %>%
mutate(y = ifelse(y < 0, 0, y))
maxY <- 1.5 * (max(c(rv$mySpline$y)))
mySpline <- rv$mySpline
circles <- map2(
rv$tab$X,
rv$tab$Y,
~ list(
type = "circle",
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 = "blue")
)
)
# # # plot the shapes and fitted line
p = plot_ly() %>%
add_lines(
x = ~ rv$mySpline$x,
y = ~ rv$mySpline$y,
name = "Response curve",
line = list(color = "black")
) %>%
layout(
shapes = c(circles),
xaxis = list(range = c(0, maxX), fixedrange = TRUE),
yaxis = list(range = c(0, maxY))
) %>%
config(edits = list(shapePosition = TRUE))
output$p <- renderPlotly(p)
})
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$tab[row_index, 1:2] <- pts
print(rv$tab)
output$table <- renderRHandsontable( rhandsontable((rv$tab)))
output$outTab <- renderTable(rv$tab)
output$newPoint <-
renderText(paste("Altered point: row =", row_index, "X =", pts[1], "Y=", pts[2]))
})
}
shinyApp(ui, server)
nevilamos
I am creating an shinyapp to allow users to change the shape of a curve by either editing xy values in a table, which are then plotted in plotly line chart, or alternatively, by dragging markers on the chart - in this case I would like the change in xy coordinates of the markers on the chart to be updated in the table. So the rhandsontable changes the chart and the chart changes the rhadsontable
The code for getting the xy markervalues and redrawing the spline come from https://github.com/plotly/plotly.R/blob/master/inst/examples/shiny/drag_markers/app.R
here is the example - only working from table to chart not chart to table: