I am using highcharter library. I want to split (or filter) other charts and tables based on selection in particular category of pie (doughnut) chart. My below code is working fine.
Desired result - When user clicks on pie again after selection, it should remove filtering. Below code captures last clicked category and it matches with the current selection using curre() and lstre() reactive values.
Issue When user clicks on pie more than twice, last clicked category matches with the current selected category so it does not perform any filtering.
I tried hc_add_event_point(event = "unselect"), it does not let user select particular category of pie more than twice.
library("shiny")
library("highcharter")
library(dplyr)
ui <- shinyUI(
fluidPage(
column(width = 8, highchartOutput("hcontainer", height = "500px")),
column(width = 4, textOutput("text")),
column(width = 4, dataTableOutput('temptable')))
)
server <- function(input, output) {
a <- data.frame(b = LETTERS[1:5], c = 11:15)
aa <- data.frame(b = LETTERS[1:5])
output$hcontainer <- renderHighchart({
canvasClickFunction <- JS("function(event) {Shiny.setInputValue('canvasClicked', [this.name, event.point.name, Math.random()]);}")
legendClickFunction <- JS("function(event) {Shiny.setInputValue('legendClicked', this.name);}")
highchart() %>%
hc_chart(type="pie") %>%
hc_add_series_labels_values(labels = a$b, values = a$c,
innerSize = '60%',
allowPointSelect= TRUE,
slicedOffset = 20,
states = list(
select = list(
color= NULL,
borderWidth = 5,
borderColor = '#ccc'
))) %>%
hc_plotOptions(series = list(
events = list(click = canvasClickFunction,
legendItemClick = legendClickFunction))) %>%
hc_add_event_point(event = "unselect")
})
makeReactiveBinding("outputText")
rv <- reactiveValues(lstval=0,curval=0)
observeEvent(input$canvasClicked[2], {
rv$lstval <- rv$curval;
rv$curval <- input$canvasClicked[2]}
)
curre <- reactive({req(input$canvasClicked[2]); input$canvasClicked[2]; rv$curval})
lstre <- reactive({req(input$canvasClicked[2]); input$canvasClicked[2]; rv$lstval})
observeEvent(input$canvasClicked, {
outputText <<- paste0("You clicked on series ", input$canvasClicked[1], " and the bar you clicked was from category ", input$canvasClicked[2],
input$plot_hc_unselect, ".")
})
observeEvent(input$legendClicked, {
outputText <<- paste0("You clicked into the legend and selected series ", input$legendClicked, ".")
})
output$text <- renderText({
outputText
})
output$temptable <- renderDataTable(
if (length(input$canvasClicked[2])>0) {
if (curre()!=lstre())
aa %>% filter(b==input$canvasClicked[2])
else {
aa
}
}
else {aa}
)
}
shinyApp(ui, server)
Related
we have currently a large number of exercises (for math) that need to be categorized according to an existing table of contents. Each exercise has a unique number. This number should be placed into the table of contents. The depth of the toc is 3, so we have chapters, sections and subsections.
I want three drop down lists for each of the (many) exercises. The first one selects the chapter, the second the section, and the third the subsection. I can solve this with two filtered lists that depend on certain filtering of a list seperated into chapter, section, subsection. That works fine for few exercises. But, i have to make the filtered lists for each exercise seperately. That is exactly the problem. I do not want to maintain 500 lists (two per exercise)
Is there any way to hardcode this? I do not want to scroll through the many subsections each time and I need a error control. So, one should not be able to select chapter 3 and then subsection 3 from chapter 4.
EDIT: Link to Google Sheet:
https://docs.google.com/spreadsheets/d/e/2PACX-1vSsRqFlLIkpgIrw18GBDLdUEl0FFmF5hSXIe2oAXztz9N50VNiO0eCP3cAB20KOgHU4nfH6gBFCWmyT/pubhtml
1. Separate the data and the dropdows
That's a best practice, because you will need to have some auxiliary cells to create the dependency
2. Create a simple data validation dropdown
Do it for the first column in a separate sheet
3. Create the auxiliary cells
Filter the second column with the values you have in the data validation to show the values adjacent to the first column
=FILTER(B2:B,A2:A=Dropdowns!$A$2)
4. Repeat the process with as many columns you have
Here is the sample spreadsheet for you to have an idea how to implement it
https://docs.google.com/spreadsheets/d/1VPsx1hfKuZDifMgrREOvUb4xEIvbVODnKPuRDWZUOF8/edit?usp=sharing
Update
I'm working on a script, I created two functions, at the moment they're not achieving the step you want, but I'm thinking on looping the number of columns as the same way I'm doing it with the rows.
const menuSheet = 'Values';
const dataSheet = 'Data';
const wsValues = SpreadsheetApp.getActiveSpreadsheet().getSheetByName(menuSheet);
const wsData = SpreadsheetApp.getActiveSpreadsheet().getSheetByName(dataSheet);
const data = wsData.getRange(2, 1, wsData.getLastRow() - 1, 3).getValues();
let firstCol = 1;
let secondCol = 2;
let thirdCol = 3;
/*
function setDropdownDependenciesTest() {
const list = ['a', 'b']
const cell = wsValues.getRange('C2')
setDropdownDependencies(list, cell)
}
*/
function onEdit(e) {
const activeCell = e.range
let val = activeCell.getValue()
let row = activeCell.getRow()
let column = activeCell.getColumn()
let wsName = activeCell.getSheet().getName()
if (wsName === menuSheet && column === firstCol && row > 1) {
applyFirstValidation(val, row)
} else if (wsName == menuSheet && column === secondCol && row > 1) {
applySecondValidation(val, row)
}
}
function applyFirstValidation(val, row) {
if (val === "") {
wsValues.getRange(row, secondCol).clearContent()
wsValues.getRange(row, secondCol).clearDataValidations()
wsValues.getRange(row, thirdCol).clearContent()
wsValues.getRange(row, thirdCol).clearDataValidations()
} else {
wsValues.getRange(row, secondCol).clearContent()
wsValues.getRange(row, secondCol).clearDataValidations()
wsValues.getRange(row, thirdCol).clearContent()
wsValues.getRange(row, thirdCol).clearDataValidations()
let filteredData = data.filter(info => {
return info[0] === val;
})
let listToApply = filteredData.map(info => {
return info[1]
})
let cell = wsValues.getRange(row, secondCol)
setDropdownDependencies(listToApply, cell)
}
}
function applySecondValidation(val, row) {
if (val === "") {
wsValues.getRange(row, thirdCol).clearContent()
wsValues.getRange(row, thirdCol).clearDataValidations()
} else {
wsValues.getRange(row, thirdCol).clearContent()
let firstColValue = wsValues.getRange(row, firstCol).getValue()
let filteredData = data.filter(info => {
return info[0] === firstColValue && info[1] === val;
})
let listToApply = filteredData.map(info => {
return info[2]
})
let cell = wsValues.getRange(row, thirdCol)
setDropdownDependencies(listToApply, cell)
}
}
function setDropdownDependencies(list, cell) {
const rule = SpreadsheetApp
.newDataValidation()
.requireValueInList(list)
.setAllowInvalid(false)
.build()
cell.setDataValidation(rule)
}
I want to generate a tooltip as described on the Google site (https://developers.google.com/chart/interactive/docs/gallery/treemap#tooltips),
and i cannot figure out how.
I took the example from https://fslab.org/XPlot/chart/google-treemap-chart.html and want to modify it, so that i have custom tooltips:
let tt =
Tooltip (
//...
)
let options =
Options(
title = "Treemap",
minColor= "#009688",
midColor= "#f7f7f7",
maxColor= "#ee8100",
headerHeight = 50,
headerColor = "#9ebcda",
fontColor = "black",
tooltip = tt,
showTooltips = true,
showScale = true
)
data
|> Chart.Treemap
|> Chart.WithOptions options
|> Chart.WithLabels
[
"Location"
"Parent"
"Market trade volume (size)"
"Market increase/decrease (color)"
]
|> Chart.Show
Is it possible to save and restore selections of a shinyTree?
I found a solution deleting the selections
R Shiny - Updating shinyTree node selections
but I need to save the selections and restore them later for example, by an actionButton
This is not possible with shinyTree only. Some functions of the underlying jsTree library have to be called directly and the values passed from JavaScript to R and vice-versa.
I made a small example, which should help you as a starting point.
If you save a selection via button-click, R sends a custom message to JavaScript, which will get the selected IDs and returns it to R via Shiny.setInputValue.
The selected ID's are then saved in the reactiveValues selectionRV, but you could save them in a file or database if needed.
library(shiny)
library(shinyTree)
library(shinyjs)
js <- HTML("
$(document).on('shiny:connected', function(event) {
Shiny.addCustomMessageHandler('saveselection', function(e) {
var selection = $('#tree').jstree().get_selected();
Shiny.setInputValue('treeselection', selection, {priority: 'event'});
});
})
")
## ui ####################
ui <- fluidPage(
useShinyjs(),
tags$head(tags$script(js)),
actionButton("deselect", "Deselect all"),
actionButton("savesele", "Save Selection"),
actionButton("restoresele", "Restore Selection"),
shinyTree("tree", dragAndDrop = TRUE,types= #Types is in the same format that jstree expects
"{
'#': { 'max_children' : 2, 'max_depth' : 4, 'valid_children' : ['root'] },
'root' : { 'valid_children' : ['file'] },
'default' : { 'valid_children' : ['default','file'] },
'file' : { 'icon' : 'fa fa-file', 'valid_children' : [] }
}"
)
)
## server ####################
server <- function(input, output, session) {
treeData <- reactive({
rootstrc <- structure(list(
SubListA = structure(list(
leaf1 = structure("",sttype="file",sticon="fa fa-signal"),
leaf2 = structure("",sttype="file",sticon="fa fa-signal"),
leaf3 = structure("",sttype="file",sticon="fa fa-signal")),
sttype="root",stopened=F,sticon="fa fa-signal"
),
SubListB = structure(list(
leafA = structure("",sttype="default",sticon="glyphicon glyphicon-leaf"),
leafB = structure("",sttype="default",sticon="shinyTree/icon.png"),
leafC = structure("",sttype="default",sticon="fa fa-signal")
),stopened=F,sttype="root",sticon="fa fa-signal")
),
sttype="root",stopened=F,sticon="fa fa-signal"
)
list(
root1 = rootstrc,
root2 = rootstrc,
root3 = rootstrc,
root4 = rootstrc
)
})
output$tree <- renderTree({
treeData()
})
selectionRV <- reactiveValues(list = NULL)
observeEvent(input$deselect, {
runjs("$('#tree').jstree().deselect_all()")
})
observeEvent(input$savesele, {
session$sendCustomMessage("saveselection", message)
})
observeEvent(input$restoresele, {
req(input$treeselection)
tmp <- paste0("[", paste(input$treeselection, collapse = ","), "]")
js <- sprintf("$('#tree').jstree().select_node(%s)", tmp)
runjs(js)
})
}
shinyApp(ui, server)
Is it possible to store a hidden values for the categories in a highcharter chart so that the hidden value is returned when the chart is clicked?
The code below (altered from this answer) displays the category that is clicked using input$canvasClicked[2], with the categories added to the chart with hc_xAxis(categories = a$b). Instead, is is possible to have a$b_alt be returned from the click event while still having a$b as the categories displayed in the chart? The purpose is to separate the formatting of the chart categories from the underlying values.
library("shiny")
library("highcharter")
ui <- shinyUI(
fluidPage(
column(width = 8, highchartOutput("hcontainer", height = "500px")),
column(width = 4, textOutput("text"))
)
)
server <- function(input, output) {
a <- data.frame(b = LETTERS[1:10], b_alt = LETTERS[11:20], c = 11:20, d = 21:30, e = 31:40)
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_xAxis(categories = a$b) %>%
hc_add_series(name = "c", data = a$c) %>%
hc_add_series(name = "d", data = a$d) %>%
hc_add_series(name = "e", data = a$e) %>%
hc_plotOptions(series = list(stacking = FALSE, events = list(click = canvasClickFunction, legendItemClick = legendClickFunction))) %>%
hc_chart(type = "column")
})
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)
You can put your b_alt variable to the first series as additional info:
hc_add_series(name = "c", additionalInfo = a$b_alt, data = a$c) %>%
Then you can find this additionalInfo variable in first series object here:
event.point.series.chart.series[0].options.additionalInfo[event.point.index]
Whole code:
library("shiny")
library("highcharter")
ui <- shinyUI(
fluidPage(
column(width = 8, highchartOutput("hcontainer", height = "500px")),
column(width = 4, textOutput("text"))
)
)
server <- function(input, output) {
a <- data.frame(b = LETTERS[1:10], b_alt = LETTERS[11:20], c = 11:20, d = 21:30, e = 31:40)
output$hcontainer <- renderHighchart({
canvasClickFunction <- JS("function(event) {Shiny.onInputChange('canvasClicked', [this.name, event.point.series.chart.series[0].options.additionalInfo[event.point.index]]);}")
legendClickFunction <- JS("function(event) {Shiny.onInputChange('legendClicked', this.name);}")
highchart() %>%
hc_xAxis(categories = a$b) %>%
hc_add_series(name = "c", additionalInfo = a$b_alt, data = a$c) %>%
hc_add_series(name = "d", data = a$d) %>%
hc_add_series(name = "e", data = a$e) %>%
hc_plotOptions(series = list(events = list(click = canvasClickFunction, legendItemClick = legendClickFunction))) %>%
hc_chart(type = "column")
})
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)
I was wondering how to set the width of an rChart using % as opposed to px. I noticed in the source code that it defaults to pixels. I'm trying to use it in a shiny app, and fixed with charts seem to be an issue as they don't scale with the rest of the user interface. Is there a way around this?
This should be considered a hack, since neither rCharts or most of the libraries have built in responsive behavior. However, one change would be to define your own renderChart function with this behavior. Something like this might work if you define in the server piece of shiny.
renderChart_pct <- function(expr, env = parent.frame(), quoted = FALSE) {
func <- shiny::exprToFunction(expr, env, quoted)
function() {
rChart_ <- func()
cht_style <- sprintf("<style>.rChart {width: %s; height: %s} </style>",
#### change these here to desired %
"100%", "100%")
cht <- paste(capture.output(rChart_$print()), collapse = '\n')
HTML(paste(c(cht_style, cht), collapse = '\n'))
}
}
Then use renderChart_pct instead of renderChart2. You'll probably notice that the result will not be truly responsive. Altogether, here would be an example with dPlot.
library(shiny)
library(rCharts)
renderChart_pct <- function(expr, env = parent.frame(), quoted = FALSE) {
func <- shiny::exprToFunction(expr, env, quoted)
function() {
rChart_ <- func()
cht_style <- sprintf("<style>.rChart {width: %s; height: %s} </style>",
"100%", "100%")
cht <- paste(capture.output(rChart_$print()), collapse = '\n')
HTML(paste(c(cht_style, cht), collapse = '\n'))
}
}
ui = shinyUI(fluidPage(
fluidRow(
column(4,
h1("Filler Header")
)
,column(8,
div (
showOutput("myChart", "dimple")
)
)
)
))
server = function(input,output){
output$myChart <- renderChart_pct({
d = dPlot(
x~x
, data = data.frame(x=1:10)
, type = "line"
, height = 500
, width = NULL
)
})
}
runApp( list(ui=ui,server=server))