Related
I'm trying to freeze the left-most column of the matrix rendered as a container via JS/CSS, as shown in the image below. I believe the issue lies with the line runjs("$('#container').scrollLeft(1000)") towards the bottom of the code. I keep fiddling with this line with no luck, as my JS/CSS skills are lacking. Any recommendations for solving this?
Code:
library(dplyr)
library(shiny)
library(shinyMatrix)
library(shinyjs)
mat3Rows <- c('Term A','Term B','Term C','Term D')
mat3Default <- data.frame('Series 1' = c(1, 24, 0, 100), row.names = mat3Rows) %>% as.matrix()
mat3Input <- function(inputId, mat3Default) {
matrixInput(
inputId = inputId,
label = "Input terms:",
value = mat3Default,
rows = list(extend = FALSE, names = TRUE),
cols = list(extend = TRUE, names = TRUE, editableNames = FALSE, delete = TRUE),
class = "numeric"
)
}
ui <- fluidPage(
useShinyjs(),
div(style = "margin-top: 20px"),
actionButton('modMat3','Modify')
)
server <- function(input,output,session)({
rv3 <- reactiveValues(
mat3 = mat3Input("mat3",mat3Default),
input = mat3Default,
colHeader = colnames(input)
)
mat3Inputs <- reactive({
df <- mat3Default
colnames(df) <- paste("Series", 1:ncol(df))
df[3:4, ] <- sprintf('%.2f%%', df[3:4, ])
df
})
observeEvent(input$modMat3, {
showModal(modalDialog(
wellPanel(div(style = "overflow-x: auto;", id = "container",rv3$mat3)),
footer = tagList(modalButton("Close"))
)
)
})
# Prevents input matrix 3 from scrunching as it expands
observeEvent(c(input$modMat3, input$mat3), {
print(paste0('$("#mat3").css("width","calc(100% + ', (dim(input$mat3)[2]-1 + dim(input$mat3)[2]%%2)*115, 'px")'))
runjs(paste0('$("#mat3").css("width","calc(100% + ', (dim(input$mat3)[2]-1 + dim(input$mat3)[2]%%2)*115, 'px")'))
runjs("$('#container').scrollLeft(1000)") # solution will be in this line
})
})
shinyApp(ui, server)
I'm trying to edit my datatable to put values as inputs. However, I would like to remove the numbers and scrolls from each cell, something similar to Excel/ SPSS cells.
The problem is in the following image:
I would like all cells to look approximately like this as if they were Excel/ SPSS cells:
Table code:
library(shiny)
library(shinydashboard)
library(DT)
library(tidyverse)
library(shinyjs)
header <- dashboardHeader(title = "Dashboard", titleWidth = 300)
sidebar <- dashboardSidebar(
width = 300,
sidebarMenu(
menuItem(
text = "Menu 1",
tabName = "menu1",
icon = icon("chart-line")
)
)
)
body <- dashboardBody(
HTML(
"<head>
<script>
$(function() {
setTimeout(function() {
$('.dt-rigth').dblclick();
}, 1000);
});
</script>
</head>"
),
tabItems(
tabItem(
tabName = "menu1",
titlePanel(
title = HTML(
"<text style='background-color:#008cba; color:#f2f2f2;'>Analysis</text>"
)
),
fluidPage(
column(
id = "menusss1",
width = 12,
column(
id = "correl",
width = 1,
DT::DTOutput("my_datatable"),
actionButton("go", label = "Plot Data")
),
column(
id = "correlplot",
width = 6,
plotOutput("my_plot")
)
)
)
)
)
)
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output) {
#initialize a blank dataframe
v <- reactiveValues(data = {
data.frame(x = numeric(0) ,y = numeric(0)) %>%
add_row(x = rep(0, 30) ,y = rep(0, 30))
})
#output the datatable based on the dataframe (and make it editable)
output$my_datatable <- DT::renderDataTable({
js <- "table.on('click', 'td', function() {
$(this).dblclick();
});"
DT::datatable(
data = v$data,
editable = TRUE,
rownames = FALSE,
selection = list(mode = 'none'),
callback = JS(js),
options = list(
searching = FALSE,
paging = FALSE,
ordering = FALSE,
info = FALSE,
autoWidth = TRUE
))
})
#when there is any edit to a cell, write that edit to the initial dataframe
#check to make sure it's positive, if not convert
observeEvent(input$my_datatable_cell_edit, {
#get values
info = input$my_datatable_cell_edit
i = as.numeric(info$row)
j = as.numeric(info$col)
k = as.numeric(info$value)
if(k < 0){ #convert to positive if negative
k <- k * -1
}
#write values to reactive
v$data[i,j] <- k
})
#render plot
output$my_plot <- renderPlot({
req(input$go) #require the input button to be non-0 (ie: don't load the plot when the app first loads)
isolate(v$data) %>% #don't react to any changes in the data
ggplot(aes(x,y)) +
geom_point() +
geom_smooth(method = "lm")
})
}
# Run the application
shinyApp(ui = ui, server = server)
EDIT
I created a js object to click just once and enter the values. Note that after a double click, the cell is approximately the way I would like. I tried to add a setTimeout(), but to no avail. I just wanted it to fill a bigger space and not have scroll. This way:
As if it were Excel/ SPSS or similar:
Firstly, to remove up/down arrows when cell editing and the (blue) inner border that appears when double clicking on the cell, custom css should be added in the ui as follows:
tags$style(HTML("table.dataTable tr td input:focus {outline: none; background: none; border:none;};
table.dataTable tr td input[type=number]::-webkit-inner-spin-button,
input[type=number]::-webkit-outer-spin-button {
-webkit-appearance: none;
margin: 0;
}"))
Then, to remove the numbers you can simply initialise the data frame with NAs instead of zeros:
v <- reactiveValues(data = {
data.frame(x = NA ,y = NA) %>%
add_row(x = rep(NA, 30) ,y = rep(NA, 30))
})
To add a green border around cells when the user is editing the values in them the following JS code should be added:
callback = JS("$('table').on('dblclick', 'td', function() {
$(this).css('border', '1px solid green');
});")
Putting all that together:
library(shiny)
library(shinydashboard)
library(DT)
library(tidyverse)
header <- dashboardHeader(title = "Dashboard", titleWidth = 300)
sidebar <- dashboardSidebar(
width = 300,
sidebarMenu(
menuItem(
text = "Menu 1",
tabName = "menuid1",
icon = icon("chart-line")))
)
body <- dashboardBody(
tabItems(
tabItem(
tabName = "menuid1",
titlePanel(
title = HTML("<text style='background-color:#008cba; color:#f2f2f2;'>Analysis</text>")),
fluidPage(
tags$style(HTML("table.dataTable tr td input:focus {outline: none; background: none; border:none;};
table.dataTable tr td input[type=number]::-webkit-inner-spin-button,
input[type=number]::-webkit-outer-spin-button {
-webkit-appearance: none;
margin: 0;
};")),
column(
id = "meuprimeiromenuid1",
width = 12,
column(
id = "correl",
width = 1,
DT::DTOutput("my_datatable"),
actionButton("go", label = "Plot Data")),
column(
id = "correlplot",
width = 6,
plotOutput("my_plot"))
))
))
)
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output) {
#initialize a blank dataframe
v <- reactiveValues(data = {
data.frame(x = NA ,y = NA) %>%
add_row(x = rep(NA, 30) ,y = rep(NA, 30))
})
callback = JS("$('table').on('dblclick', 'td', function() {
$(this).css('border', '1px solid green');
});")
#output the datatable based on the dataframe (and make it editable)
output$my_datatable <- DT::renderDataTable({
DT::datatable(
data = v$data,
editable = TRUE,
rownames = FALSE,
selection = list(mode = 'none'),
callback = callback,
options = list(
searching = FALSE,
paging = FALSE,
ordering = FALSE,
info = FALSE,
autoWidth = TRUE
))
})
#when there is any edit to a cell, write that edit to the initial dataframe
#check to make sure it's positive, if not convert
observeEvent(input$my_datatable_cell_edit, {
#get values
info = input$my_datatable_cell_edit
i = as.numeric(info$row)
j = as.numeric(info$col)+1
k = as.numeric(info$value)
if (!is.na(k) & k < 0) { #convert to positive if negative
k <- k * -1
}
#write values to reactive
v$data[i,j] <- k
})
#render plot
output$my_plot <- renderPlot({
# browser()
req(input$go) #require the input button to be non-0 (ie: don't load the plot when the app first loads)
isolate(v$data) %>% #don't react to any changes in the data
drop_na() %>%
ggplot(aes(x,y)) +
geom_point() +
geom_smooth(method = "lm")
})
}
# Run the application
shinyApp(ui = ui, server = server)
Also, two additional notes here:
(1) In the cell edit observe event, the variable regarding columns (j) should be increased by 1 given that column count begins at 0 and rownames are disabled.
(2) Given that now the data frame has its values initialised with NA adding appropriate checks for cell editing and when creating/rendering the plot might be required. For example, I've added a command to drop any row that contains value(s) that are NA before creating the plot (drop_na).
Is there a way to return all the selected points from a scatter plot in highchart via shiny? The idea is to dynamically exclude or include points to be used for regression. I would like to have the ability to select the desired points, write them to a dataframe and then perform a non-linear regression on them. So far, I'm able to select and deselect points from the chart by using the JavaScript code from here and here. I can't seem to be able to return the selected points to a dataframe.
Please see my attempt below.
#devtools::install_github("jbkunst/highcharter")
library(highcharter)
library(htmlwidgets)
library(shiny)
#http://jsfiddle.net/gh/get/jquery/3.1.1/highcharts/highcharts/tree/master/samples/highcharts/chart/events-selection-points/
# selectPointsByDrag
s1 <- JS("/**
* Custom selection handler that selects points and cancels the default zoom behaviour
*/
function selectPointsByDrag(e) {
// Select points
Highcharts.each(this.series, function (series) {
Highcharts.each(series.points, function (point) {
if (point.x >= e.xAxis[0].min && point.x <= e.xAxis[0].max &&
point.y >= e.yAxis[0].min && point.y <= e.yAxis[0].max) {
point.select(true, true);
}
});
});
// Fire a custom event
Highcharts.fireEvent(this, 'selectedpoints', { points: this.getSelectedPoints() });
return false; // Don't zoom
}")
# unselectByClick
s2 <- JS("/**
* On click, unselect all points
*/
function unselectByClick() {
var points = this.getSelectedPoints();
if (points.length > 0) {
Highcharts.each(points, function (point) {
point.select(false);
});
}
}")
shinyApp(
ui = fluidPage(
uiOutput("selection_ui"),
highchartOutput("plot_hc"),
tableOutput("view")
),
server = function(input, output) {
df <- data.frame(x = 1:50, y = 1:50, otherInfo = letters[11:15])
df_copy <- df
output$plot_hc <- renderHighchart({
highchart() %>%
hc_chart(zoomType = 'xy', events = list(selection = s1, click = s2)) %>%
hc_add_series(df, "scatter") %>%
hc_add_event_point(event = "select")
})
output$view <- renderTable({
data.table(x = input$plot_hc_select$x, y = input$plot_hc_select$y)
})
observeEvent(input$plot_hc, print(paste("plot_hc", input$plot_hc)))
output$selection_ui <- renderUI({
if(is.null(input$plot_hc_select)) return()
wellPanel("Coordinates of selected point: ",input$plot_hc_select$x, input$plot_hc_select$y)
})
}
)
Error: column or argument 1 is NULL
There is no straightforward way to achieve what you want, using only Highcharter or Highcharts (as far as I know). One simple way to do this though would be to store each selected point in an (javascript) array, and to pass it to R. Thanks to Shiny, this can be easily done using Shiny.onInputChange (see example here).
One could rewrite your shiny app like this to make it work:
1) In the s1 function, store the selected points in xArr.
2) Use Shiny.onInputChange to pass xArr to R. xArr will be accessible via input$R_xArr (I chose the name R_xArr, it is not an automatic assignment).
3) Use a reactiveValues to store the selected points on the R side.
4) Update these values with appropriate observers.
#devtools::install_github("jbkunst/highcharter")
library(highcharter)
library(htmlwidgets)
library(shiny)
library(data.table)
# selectPointsByDrag
s1 <- JS("/**
* Custom selection handler that selects points and cancels the default zoom behaviour
*/
function selectPointsByDrag(e) {
var xArr = []
// Select points
Highcharts.each(this.series, function (series) {
Highcharts.each(series.points, function (point) {
if (point.x >= e.xAxis[0].min && point.x <= e.xAxis[0].max &&
point.y >= e.yAxis[0].min && point.y <= e.yAxis[0].max) {
xArr.push(point.x);
point.select(true, true);
}
});
});
Shiny.onInputChange('R_xArr', xArr);
// Fire a custom event
Highcharts.fireEvent(this, 'selectedpoints', { points: this.getSelectedPoints() });
return false; // Don't zoom
}")
# unselectByClick
s2 <- JS("/**
* On click, unselect all points
*/
function unselectByClick() {
var points = this.getSelectedPoints();
if (points.length > 0) {
Highcharts.each(points, function (point) {
point.select(false);
});
}
}")
shinyApp(
ui = fluidPage(
highchartOutput("plot_hc"),
tableOutput("view")
),
server = function(input, output) {
df <- data.frame(x = 1:50, y = 1:50, otherInfo = letters[11:15])
output$plot_hc <- renderHighchart({
highchart() %>%
hc_chart(zoomType = 'xy', events = list(selection = s1, click = s2)) %>%
hc_add_series(df, "scatter") %>%
hc_add_event_point(event = "unselect")
})
selected.points <- reactiveValues(x = NULL, y = NULL)
output$view <- renderTable({
if (is.null(selected.points$x) || is.null(selected.points$y)) {
return(NULL)
} else {
data.table(x = selected.points$x, y = selected.points$y)
}
})
observeEvent(input$R_xArr, {
selected.points$x <- sort(unique(c(selected.points$x, input$R_xArr)))
selected.points$y <- df$y[df$x %in% selected.points$x]
})
observeEvent(input$plot_hc_unselect, {
selected.points$x <- NULL
selected.points$y <- NULL
})
}
)
Hope this helps.
trying to get node labels to be shown only on nodes that have been selected.
I found a similar question that wanted to only show edge labels on hover. The solution was this:
nodes <- data.frame(id = 1:3, label = 1:3)
edges <- data.frame(from = c(1,2), to = c(1,3), label = "Edge label", font.size = 0)
visNetwork(nodes, edges) %>%
visInteraction(hover = T) %>%
visEvents(hoverEdge = "function(e){
this.body.data.edges.update({id: e.edge, font: {size : 14}});
}") %>%
visEvents(blurEdge = "function(e){
this.body.data.edges.update({id: e.edge, font: {size : 0}});
}")
I've tried modifying this but I don't think I'm doing the javascript part right, I know JS hardly at all.
nodes <- data.frame(id = 1:3, label = 1:3)
edges <- data.frame(from = c(1,2), to = c(1,3), label = "Edge label", font.size = 0)
visNetwork(nodes, edges) %>%
visInteraction(hover = T) %>%
visEvents(selectNode= "function(e){
this.body.data.nodes.update({id: e.node, font: {size : 14}});
}") %>%
visEvents(deselectNode= "function(e){
this.body.data.nodes.update({id: e.node, font: {size : 0}});
}")
This instead causes a new node to be created every time I select or deselect a node. While sitting and clicking on them was a fun way to crash my Rsession, it unfortunately hasn't solved my problem.
I'm sure this is a simple fix but I've been through the visNetwork documentation and I'm just not finding what I need. Help appreciated!
This should do the trick. This JS is actually creating a variable based off both of the labels in the dataframe. I'm sure there's a more technical method to doing this, but it should still work just fine.
library(visNetwork)
nodes <- data.frame(id = 1:3, label = paste0(""), label_long = c('Label 1','Label 2','Label 3'))
edges <- data.frame(from = c(1,2), to = c(1,3), label = "Edge label", font.size = 0)
net <- visNetwork(nodes, edges) %>%
visInteraction(hover = T) %>%
visEvents(selectNode = "function(e){
var label_info = this.body.data.nodes.get({
fields: ['label', 'label_long'],
filter: function (item) {
return item.id === e.node
},
returnType :'Array'
});
this.body.data.nodes.update({id: e.node, label : label_info[0].label_long, label_long : label_info[0].label});
}") %>%
visEvents(blurNode = "function(e){
var label_info = this.body.data.nodes.get({
fields: ['label', 'label_long'],
filter: function (item) {
return item.id === e.node
},
returnType :'Array'
});
this.body.data.nodes.update({id: e.node, label : label_info[0].label_long, label_long : label_info[0].label});
}")
print(net)
I have this scatter plot where I want to zoom in an area and then subset a table to show only the data from the subsetted points. The first step is done by zoomType = "xy", but I'm having troubles on the second step. Could anyone give me a hint on how can I access the upper left and bottom right points coordinates of the zoomed area, so I can subset the table?
Thank you!
library("shiny")
library("highcharter")
ui <- shinyUI(
fluidPage(
column(width = 8, highchartOutput("hcontainer", height = "500px")),
column(width = 4, textOutput("text"))
)
)
server <- function(input, output) {
dscars <- round(mvrnorm(n = 20, mu = c(1, 1), Sigma = matrix(c(1,0,0,1),2)), 2)
dsplan <- round(mvrnorm(n = 10, mu = c(3, 4), Sigma = matrix(c(2,.5,2,2),2)), 2)
dstrck <- round(mvrnorm(n = 15, mu = c(5, 1), Sigma = matrix(c(1,.5,.5,1),2)), 2)
output$hcontainer <- renderHighchart({
canvasClickFunction <- JS("function(event) {Shiny.onInputChange('canvasClicked', [this.name, event.point.category]);}")
legendClickFunction <- JS("function(event) {Shiny.onInputChange('legendClicked', this.name);}")
highchart() %>%
hc_chart(type = "scatter", zoomType = "xy") %>%
hc_tooltip(
useHTML = T,
enabled = F,
pointFormat = paste0("<span style=\"color:{series.color};\">{series.options.icon}</span>",
"{series.name}: <b>[{point.x}, {point.y}]</b><br/>")
) %>%
hc_add_series(data = list.parse2(as.data.frame(dscars)),marker = list(symbol = fa_icon_mark("car")),icon = fa_icon("car"), name = "car") %>%
hc_add_series(data = list.parse2(as.data.frame(dsplan)),marker = list(symbol = fa_icon_mark("plane")),icon = fa_icon("plane"), name = "plane") %>%
hc_add_series(data = list.parse2(as.data.frame(dstrck)),marker = list(symbol = fa_icon_mark("truck")),icon = fa_icon("truck"), name = "truck") %>%
hc_plotOptions(series = list(stacking = FALSE, events = list(click = canvasClickFunction, legendItemClick = legendClickFunction)))
})
makeReactiveBinding("outputText")
observeEvent(input$canvasClicked, {
outputText <<- paste0("You clicked on series ", input$canvasClicked[1], " and the bar you clicked was from category ", input$canvasClicked[2], ".")
})
observeEvent(input$legendClicked, {
outputText <<- paste0("You clicked into the legend and selected series ", input$legendClicked, ".")
})
output$text <- renderText({
outputText
})
}
shinyApp(ui, server)
2nd Try
I tried something like:
selectionfunction<- JS("function(event) {Shiny.onInputChange('range', [event.xAxis, event.yAxis]);}")
with:
hc_plotOptions(series = list(stacking = FALSE, events = list( selection=selectionfunction )))
makeReactiveBinding("outputText")
observeEvent(input$range, {
outputText <<- paste0("x= ", input$range[1],"y= " ,input$range[2])
})
output$text <- renderText({
outputText
})
But it seems to me that the function selectionfunction is not called when I zoom the plot.
Almost a good solution
I found a almost functional solution:
library("shiny")
library("highcharter")
library("MASS")
ui <- shinyUI(
fluidPage(
column(width = 8, highchartOutput("hcontainer", height = "500px")),
column(width = 4, textOutput("text"))
)
)
server <- function(input, output) {
dscars <- round(mvrnorm(n = 20, mu = c(1, 1), Sigma = matrix(c(1,0,0,1),2)), 2)
dsplan <- round(mvrnorm(n = 10, mu = c(3, 4), Sigma = matrix(c(2,.5,2,2),2)), 2)
dstrck <- round(mvrnorm(n = 15, mu = c(5, 1), Sigma = matrix(c(1,.5,.5,1),2)), 2)
output$hcontainer <- renderHighchart({
selectionfunction <- JS("function(event) {
Shiny.onInputChange('canvasClicked2', [event.xAxis[0].min , event.xAxis[0].max , event.yAxis[0].min , event.yAxis[0].max ] );}")
highchart() %>%
hc_chart(type = "scatter", zoomType = "xy", events= list(selection=selectionfunction)) %>%
hc_tooltip(
useHTML = T,
enabled = F,
pointFormat = paste0("<span style=\"color:{series.color};\">{series.options.icon}</span>",
"{series.name}: <b>[{point.x}, {point.y}]</b><br/>")
) %>%
hc_add_series(data = list.parse2(as.data.frame(dscars)),marker = list(symbol = fa_icon_mark("car")),icon = fa_icon("car"), name = "car") %>%
hc_add_series(data = list.parse2(as.data.frame(dsplan)),marker = list(symbol = fa_icon_mark("plane")),icon = fa_icon("plane"), name = "plane") %>%
hc_add_series(data = list.parse2(as.data.frame(dstrck)),marker = list(symbol = fa_icon_mark("truck")),icon = fa_icon("truck"), name = "truck")
})
makeReactiveBinding("outputText")
observeEvent(input$canvasClicked, {
outputText <<- paste0("You clicked on series ", input$canvasClicked[1], " and the bar you clicked was from category ", input$canvasClicked[2],input$canvasClicked[3], ".")
})
observeEvent(input$canvasClicked2, {
outputText <<- paste0(input$canvasClicked2[1]," ",input$canvasClicked2[2]," ",input$canvasClicked2[3]," ",input$canvasClicked2[4])
})
output$text <- renderText({
outputText
})
}
shinyApp(ui, server)
The axis boundaries are correctly printed but with 1 step delay. Can someone help?
Final Solution
I found a solution by working on the JS function:
selectionfunction1 <- JS("function(event) {
var x_axis_min,x_axis_max,y_axis_min,y_axis_max;
if (event.xAxis) {
x_axis_min = Highcharts.numberFormat(event.xAxis[0].min, 2),
x_axis_max = Highcharts.numberFormat(event.xAxis[0].max, 2);
}else{
x_axis_min = 'reset',
x_axis_max = 'reset';
}
if (event.yAxis) {
y_axis_min = Highcharts.numberFormat(event.yAxis[0].min, 2),
y_axis_max = Highcharts.numberFormat(event.yAxis[0].max, 2);
}else{
y_axis_min = 'reset',
y_axis_max = 'reset';
}
Shiny.onInputChange('canvasClickedxmin', x_axis_min);
Shiny.onInputChange('canvasClickedxmax', x_axis_max);
Shiny.onInputChange('canvasClickedymin', y_axis_min);
Shiny.onInputChange('canvasClickedymax', y_axis_max);
}")