How to correclty use MutationObserve in Shiny app - r

I'm trying to observe changes to css using javascript mutationObserver in Shiny. I'm using rhandsontable because we can change the width of a table element in the app, and I'm trying to pick up this change iwth the mutationObserver.
The javascript doesn't seem to be working. I'm unsure why. Nothing is logged to the console, no alert message, and shiny doesn't register the variable being set by javascript.
MutationObserver code
jsCode <- "
const observer = new MutationObserver(
# this function runs when something is observed.
function(mutations){
console.log('activated')
var i;
var text;
var widthArray = [];
text = ''
for (i = 0; i < document.getElementsByClassName('htCore')[0].getElementsByTagName('col').length; i++) {
text += document.getElementsByClassName('htCore')[0].getElementsByTagName('col')[i].style.width + '<br>';
widthArray.push(document.getElementsByClassName('htCore')[0].getElementsByTagName('col')[i].style.width);
}
alert(text)
Shiny.setInputValue('colWidth', widthArray);
}
)
const cols = document.getElementsByClassName('htCore')[0].getElementsByTagName('col')
observer.observe(cols, {
attributes: true # observe when attributes of ul.bears change (width, height)
})
"
Shiny code:
library(shiny)
library(rhandsontable)
ui <- fluidPage(
tags$head(tags$script(HTML(jsCode))),
rhandsontable::rHandsontableOutput("dataTable")
)
server <- function(input, output, session) {
df = data.frame(
company = c('a', 'b', 'c', 'd'),
bond = c(0.2, 1, 0.3, 0),
equity = c(0.7, 0, 0.5, 1),
cash = c(0.1, 0, 0.2, 0),
stringsAsFactors = FALSE
)
output$dataTable <- renderRHandsontable({
rhandsontable(df, manualColumnResize = TRUE, manualRowResize = TRUE)
})
observeEvent(input$colWidth, {
print(input$colWidth)
})
}
shinyApp(ui, server)

This works:
jsCode <- "
$(document).on('shiny:connected', function(){
setTimeout(function(){
const observer = new MutationObserver(
function(mutations){
console.log('activated')
var i;
var text;
var widthArray = [];
text = ''
for (i = 0; i < document.getElementsByClassName('htCore')[0].getElementsByTagName('col').length; i++) {
text += document.getElementsByClassName('htCore')[0].getElementsByTagName('col')[i].style.width + '<br>';
widthArray.push(document.getElementsByClassName('htCore')[0].getElementsByTagName('col')[i].style.width);
}
alert(text)
Shiny.setInputValue('colWidth', widthArray);
}
)
const cols = document.getElementsByClassName('htCore')[0].getElementsByTagName('colgroup')[0]
observer.observe(cols, {
attributes: true, subtree: true
});
}, 500);
});
"

Related

Problem getting current list of input values in Shiny

I'm having quite a few problems to get the updated values from several coonditionalPanels. I created a reactive variable parList which should contain the parN_sig input variables. These variables should come from conditional panels and they are all named parN_sig. I do not know why but I always end up getting values from the double_sig panel when another panel is shown at the UI.
Here's my code:
ui.r
jscode <- "
shinyjs.disableTab = function(name) {
var tab = $('.nav li a[data-value=' + name + ']');
tab.bind('click.tab', function(e) {
e.preventDefault();
return false;
});
tab.addClass('disabled');
}
shinyjs.enableTab = function(name) {
var tab = $('.nav li a[data-value=' + name + ']');
tab.unbind('click.tab');
tab.removeClass('disabled');
}
"
css <- "
.nav li a.disabled {
background-color: #aaa !important;
color: #333 !important;
cursor: not-allowed !important;
border-color: #aaa !important;
}"
# Create Shiny object
library(shiny)
library(shinythemes)
library(shinyjs)
library(ggplot2)
library(grid)
library(egg)
# source("input.r")
source("functions.r")
formula_tabs<-tabsetPanel(
tabPanel("double_sig",
withMathJax("$$y=d+\\frac{a}{1+exp^{-b*(t-c)}}+\\frac{e}{1+exp^{-f*(t-g)}}$$")
),
tabPanel("gompertz",
withMathJax("$$y=b*exp^{\\ln(\\frac{c}{b})*exp^{-a*t}}$$")
),
tabPanel("verhulst",
withMathJax("$$y=\\frac{b*c}{b+(b-c)*exp^{-a*t}}$$")
),
id = "formulas",
type = "tabs"
)
fluidPage(useShinyjs(),theme = shinytheme("lumen"),useShinyjs(),tags$style("#params { display:none; } #formulas { display:none; }"),
extendShinyjs(text = jscode),inlineCSS(css),
navbarPage("Protein turnover model",id="tabs",
tabsetPanel(tabPanel("Input data",
checkboxInput("multiple","Single file",value = FALSE),
uiOutput("mult_files"),
uiOutput("sing_file"),
actionButton("disp_distr","Show distributions"),
plotOutput("distr_plot"),
plotOutput("distr_stade")
),
tabPanel("Weight fitting",
fileInput("weight_data","Choose weight data to be fitted",accept = c("text/csv")),
div(style="display:inline-block",selectInput("method_we","Select fitting formula",choices = c("Logistic"="verhulst","Gompertz"="gompertz","Empiric"="empirique","Log polynomial"="log_poly","Double sigmoid"="double_sig"))),
div(style="display:inline-block",formula_tabs), ## "Contois"="contois",,"Noyau"="seed",
conditionalPanel("input.method_we=='verhulst'",textInput("par1_sig","Enter value of a",value =0.1),
textInput("par2_sig","Enter value of b",value = 100),
textInput("par3_sig","Enter value of c",value = 1)),
conditionalPanel("input.method_we=='gompertz'",textInput("par1_sig","Enter value of a",value =0.065),
textInput("par2_sig","Enter value of b",value = 114.39),
textInput("par3_sig","Enter value of c",value = 0.52)),
conditionalPanel("input.method_we=='empirique'",textInput("par1_sig","Enter value of a",value =5.38),
textInput("par2_sig","Enter value of b",value = 8),
textInput("par3_sig","Enter value of c",value = 7)),
conditionalPanel("input.method_we=='double_sig'",textInput("par1_sig","Enter value of a",value = 48),
textInput("par2_sig","Enter value of b",value = 0.144),
textInput("par3_sig","Enter value of c",value = 35),
textInput("par4_sig","Enter value of d",value = 0.4),
textInput("par5_sig","Enter value of e",value = 48),
textInput("par6_sig","Enter value of f",value = 0.042),
textInput("par7_sig","Enter value of g",value = 90)),
actionButton("fit_op","Fit"),
plotOutput("fitplot")
),
tabPanel("mRNA fitting and calculation",
textInput("ksmin","Value of ksmin",value =3*4*3*3.6*24),
selectInput("fit_mrna","Select fitting formula",choices=c("3rd degree polynomial"="3_deg","6th degree polynomial"="6_deg","3rd degree logarithmic polynomial"="3_deg_log")),
actionButton("run_loop","Run calculation"),
disabled(downloadButton("downFile","Save results"))
),
tabPanel("Results",id="tabRes",
uiOutput("select_res"),
plotOutput("fit_prot_plot")
)
))
)
server.r
library(shiny)
library(shinythemes)
library(shinyjs)
library(ggplot2)
library(grid)
library(egg)
# source("input.r")
source("functions.r")
function(input, output, session) {
js$disableTab("tabRes")
fit_op<-reactiveValues(data=NULL)
run_calc<-reactiveValues(data=NULL)
en_but<-reactiveValues(enable=FALSE)
theme<<-theme(panel.background = element_blank(),panel.border=element_rect(fill=NA),panel.grid.major = element_blank(),panel.grid.minor = element_blank(),strip.background=element_blank(),axis.text.x=element_text(colour="black"),axis.text.y=element_text(colour="black"),axis.ticks=element_line(colour="black"),plot.margin=unit(c(1,1,1,1),"line"))
output$mult_files<-renderUI({
if (!input$multiple){
tagList(fileInput("prot_file","Choose protein file"),
fileInput("mrna_file","Choose transcript file"))
}
})
output$sing_file<-renderUI({
if (input$multiple){
tagList(textInput("protein_tab","Name of protein tab",value = "Proteines"),
textInput("rna_tab","Name of mRNA tab",value = "Transcrits"),
fileInput("data_file","Choose xls/xlsx file",accept=c(".xls",".xlsx")))
}
})
observeEvent(input$method_we, {
# updateTabsetPanel(session, "params", selected = input$method_we)
updateTabsetPanel(session,"formulas",selected = input$method_we)
})
observe({
if(!is.null(input$data_file)){
inFile<-input$data_file
list_data<-loadData(inFile$datapath,input$rna_tab,input$protein_tab,poids=F)
mrna_data<-list_data$mrna
prot_data<-list_data$prot
test_list<-list_data$parse
test_list<<-sample(test_list,3)
clean_mrna_data<<-mrna_data[,-which(is.na(as.numeric(as.character(colnames(mrna_data)))))]
clean_prot_data<<-prot_data[,-which(is.na(as.numeric(as.character(colnames(prot_data)))))]
}
})
observe({
if((!is.null(input$prot_file)) & (!is.null(input$mrna_file))){
protFile<-input$prot_file
mrnaFile<-input$mrna_file
prot_data<-loadData(protFile$datapath,"","",poids=F)
mrna_data<-loadData(mrnaFile$datapath,"","",poids=F)
clean_mrna_data<<-mrna_data[,-which(is.na(as.numeric(as.character(colnames(mrna_data)))))]
clean_prot_data<<-prot_data[,-which(is.na(as.numeric(as.character(colnames(prot_data)))))]
total_data<-merge(mrna_data,prot_data)
lista<-vector("list",nrow(mrna_data))
for (i in seq(1,nrow(total_data))){
lista[[i]]<-list("Protein_ID"=total_data[i,"Protein"],"Transcrit_ID"=total_data[i,"Transcrit"],"Transcrit_val"=as.matrix(total_data[i,3:29]),"Protein_val"=as.matrix(total_data[i,30:ncol(total_data)]),"DPA"=t)
}
# test_list<<-lista
test_list<<-sample(lista,3)
}
})
observeEvent(input$disp_distr,{
print("Plotting...")
output$distr_plot<-renderPlot({print(combineGraphs(clean_mrna_data,clean_prot_data,"",moyenne = T))})
print("Finished")
})
# parList<-reactiveValues()
# observe({
# for (i in reactiveValuesToList(input)){
# print(i)
# if (grepl("par[1-9]+_sig",i,perl = T)){
# newlist[[input[[i]]]]<-input[[i]]
# }
# }
# # })
parList<-reactive({
x<-reactiveValuesToList(input)
x_ind<-grep("par[1-9]+",names(x),perl = T)
newlist<-vector("list",length(x_ind))
names(newlist)<-names(x[x_ind])
for (el in names(newlist)){
newlist[[el]]<-as.numeric(as.character(input[[el]]))
}
names(newlist)<-gsub("_sig","",names(newlist))
newlist<-newlist[order(names(newlist))]
newlist
})
observeEvent(input$fit_op,{
browser()
print(parList())
inFile<-input$weight_data
days_kiwi<-rep(c(0,13,26,39,55,76,118,179,222), each = 3)
poids_data<-loadData(inFile$datapath,"","",poids=T)
print("Fitting...")
tryCatch({
coefs_poids<<-fitPoids_v2(poids_data[,1],poids_data[,2],input$method_we,parList())
},
warning = function(warn){
showNotification(paste0(warn), type = 'warning')
},
error = function(err){
showNotification(paste0(err), type = 'err')
})
print(coefs_poids$coefs)
val_mu<-mu(c(poids_data$DPA),input$method_we,coefs_poids$coefs,coefs_poids$formula,dpa_analyse = NULL)
data_mu<-data.frame("DPA"=c(poids_data$DPA),"Mu"=val_mu)
g_mu<<-ggplot(data_mu,aes(x=DPA,y=Mu))+geom_line()+theme+xlab("DPA")+ylab("Growth rate (days^-1)")
fit_op$state<-TRUE
print("Finished!!")
output$fitplot<-renderPlot({
req((fit_op$state)==TRUE,exists("coefs_poids"))
ggarrange(coefs_poids$graph,g_mu,ncol=2)
})
})
observeEvent(input$run_loop,{
if (input$fit_mrna!=""){
ksmin=as.numeric(as.character(input$ksmin))
score=0
cont<-0
poids_coef<<-coefs_poids$coefs
formula_poids<<-coefs_poids$formula
mess<-showNotification(paste("Running..."),duration = NULL,type = "message")
for (el in test_list){
tryCatch({
run_calc$run<-TRUE
cont<-cont+1
print(cont)
norm_data<-normaMean(el$Protein_val,el$Transcrit_val,ksmin)
fittedmrna<<-fit_testRNA(el$DPA,norm_data$mrna,"3_deg")
par_k<-solgss_Borne(el$DPA,as.vector(norm_data$prot),as.numeric(norm_data$ks),score)
par_k[["plot_fit_prot"]]<-plotFitProt(el$DPA,as.vector(norm_data$prot),par_k$prot_fit)
X<-matrice_sens(el$DPA,par_k[["solK"]][,1])
diff<-(par_k[["error"]][["errg"]][1]*norm(as.vector(norm_data$prot),"2"))^2
par_k[["corr_matrix"]]<-matrice_corr(X,length(norm_data$prot),diff)
if (!is.null(par_k)){
test_list[[cont]]$SOL<-par_k
# write.csv(test_list[[cont]][["SOL"]][["solK"]],paste("solK/",paste(test_list[[cont]][["Transcrit_ID"]],"_Sol_ks_kd.csv"),sep = ""))
}
},error=function(e){showNotification(paste0("Protein fitting not achieved for ",el$Transcrit_ID,sep=" "),type = "error",duration = NULL)})
}
valid_res<<-Filter(function(x) {length(x) > 5}, test_list)
print(valid_res[[1]])
mess<-showNotification(paste("Finished!!"),duration = NULL,type = "message")
en_but$enable<-TRUE
}
})
output$downFile<-downloadHandler(
filename = function(){
paste("results_KsKd-",Sys.Date(),".zip",sep="")
},
content = function(file){
owd <- setwd(tempdir())
on.exit(setwd(owd))
files <- NULL;
for (res in valid_res){
fileName<-paste(res[["Transcrit_ID"]],"_Sol_ks_kd.csv",sep = "")
write.csv(res[["SOL"]][["solK"]],fileName)
files<-c(files,fileName)
}
zip(zipfile = file,files = files)
if(file.exists(paste0(file, ".zip"))) {file.rename(paste0(file, ".zip"), file)}
},contentType = "application/zip"
)
observe({
if (en_but$enable){
enable("downFile")
}
})
}
I recently started using Shiny, so any help would be extremely appreciated. Thanks in advance!
Welcome to SO.
You've identified the problem yourself: "...are all named parN_sig". That means you don't have several inputs, you only have one. So you always get the value of (say) input$par2_sig from the first conditional panel regardless of which panel you're trying to access.
You have two options:
Provide unique names for every textInput. That will be a pain. Or...
Use modules. They take a bit of getting used to, but are worth the effrt in the end.
If you set the module up correctly, you'll be able to use the same module for each conditional panel, even though they have different numbers of textinputs.
See this page for help on creating your first module.

Draggable interactive bar chart Rshiny

I would love to know if building something like this is possible is RShiny. I have experience with interactive plots/charts using plotly, ggplot and ggplotly but I can't see how to do something like this. I love how the graph engages the user to make a guess and then shows the real data.
If anyone could please point me in the direction of any documentation I will be forever grateful!
https://www.mathematica-mpr.com/dataviz/race-to-the-top
Here is a Shiny implementation of this jsfiddle.
library(shiny)
library(jsonlite)
barChartInput <- function(inputId, width = "100%", height = "400px",
data, category, value, minValue, maxValue,
color = "rgb(208,32,144)"){
tags$div(id = inputId, class = "amchart",
style = sprintf("width: %s; height: %s;", width, height),
`data-data` = as.character(toJSON(data)),
`data-category` = category,
`data-value` = value,
`data-min` = minValue,
`data-max` = maxValue,
`data-color` = color)
}
dat <- data.frame(
country = c("USA", "China", "Japan", "Germany", "UK", "France"),
visits = c(3025, 1882, 1809, 1322, 1122, 1114)
)
ui <- fluidPage(
tags$head(
tags$script(src = "http://www.amcharts.com/lib/4/core.js"),
tags$script(src = "http://www.amcharts.com/lib/4/charts.js"),
tags$script(src = "http://www.amcharts.com/lib/4/themes/animated.js"),
tags$script(src = "barchartBinding.js")
),
fluidRow(
column(8,
barChartInput("mybarchart", data = dat,
category = "country", value = "visits",
minValue = 0, maxValue = 3500)),
column(4,
tags$label("Data:"),
verbatimTextOutput("data"),
br(),
tags$label("Change:"),
verbatimTextOutput("change"))
)
)
server <- function(input, output){
output[["data"]] <- renderPrint({
if(is.null(input[["mybarchart"]])){
dat
}else{
fromJSON(input[["mybarchart"]])
}
})
output[["change"]] <- renderPrint({ input[["mybarchart_change"]] })
}
shinyApp(ui, server)
The file barchartBinding.js, to put in the www subfolder of the app file:
var barchartBinding = new Shiny.InputBinding();
$.extend(barchartBinding, {
find: function (scope) {
return $(scope).find(".amchart");
},
getValue: function (el) {
return null;
},
subscribe: function (el, callback) {
$(el).on("change.barchartBinding", function (e) {
callback();
});
},
unsubscribe: function (el) {
$(el).off(".barchartBinding");
},
initialize: function (el) {
var id = el.getAttribute("id");
var $el = $(el);
var data = $el.data("data");
var dataCopy = $el.data("data");
var categoryName = $el.data("category");
var valueName = $el.data("value");
var minValue = $el.data("min");
var maxValue = $el.data("max");
var barColor = $el.data("color");
am4core.useTheme(am4themes_animated);
var chart = am4core.create(id, am4charts.XYChart);
chart.hiddenState.properties.opacity = 0; // this makes initial fade in effect
chart.data = data;
chart.padding(40, 40, 0, 0);
chart.maskBullets = false; // allow bullets to go out of plot area
var text = chart.plotContainer.createChild(am4core.Label);
text.text = "Drag column bullet to change its value";
text.y = 92;
text.x = am4core.percent(100);
text.horizontalCenter = "right";
text.zIndex = 100;
text.fillOpacity = 0.7;
// category axis
var categoryAxis = chart.xAxes.push(new am4charts.CategoryAxis());
categoryAxis.title.text = categoryName;
categoryAxis.title.fontWeight = "bold";
categoryAxis.dataFields.category = categoryName;
categoryAxis.renderer.grid.template.disabled = true;
categoryAxis.renderer.minGridDistance = 50;
// value axis
var valueAxis = chart.yAxes.push(new am4charts.ValueAxis());
valueAxis.title.text = valueName;
valueAxis.title.fontWeight = "bold";
// we set fixed min/max and strictMinMax to true, as otherwise value axis will adjust min/max while dragging and it won't look smooth
valueAxis.strictMinMax = true;
valueAxis.min = minValue;
valueAxis.max = maxValue;
valueAxis.renderer.minWidth = 60;
// series
var series = chart.series.push(new am4charts.ColumnSeries());
series.dataFields.categoryX = categoryName;
series.dataFields.valueY = valueName;
series.tooltip.pointerOrientation = "vertical";
series.tooltip.dy = -8;
series.sequencedInterpolation = true;
series.defaultState.interpolationDuration = 1500;
series.columns.template.strokeOpacity = 0;
// label bullet
var labelBullet = new am4charts.LabelBullet();
series.bullets.push(labelBullet);
labelBullet.label.text = "{valueY.value.formatNumber('#.')}";
labelBullet.strokeOpacity = 0;
labelBullet.stroke = am4core.color("#dadada");
labelBullet.dy = -20;
// series bullet
var bullet = series.bullets.create();
bullet.stroke = am4core.color("#ffffff");
bullet.strokeWidth = 3;
bullet.opacity = 0; // initially invisible
bullet.defaultState.properties.opacity = 0;
// resize cursor when over
bullet.cursorOverStyle = am4core.MouseCursorStyle.verticalResize;
bullet.draggable = true;
// create hover state
var hoverState = bullet.states.create("hover");
hoverState.properties.opacity = 1; // visible when hovered
// add circle sprite to bullet
var circle = bullet.createChild(am4core.Circle);
circle.radius = 8;
// while dragging
bullet.events.on("drag", event => {
handleDrag(event);
});
bullet.events.on("dragstop", event => {
handleDrag(event);
var dataItem = event.target.dataItem;
dataItem.column.isHover = false;
event.target.isHover = false;
dataCopy[dataItem.index][valueName] = dataItem.values.valueY.value;
Shiny.setInputValue(id, JSON.stringify(dataCopy));
Shiny.setInputValue(id + "_change", {
index: dataItem.index,
category: dataItem.categoryX,
value: dataItem.values.valueY.value
});
});
function handleDrag(event) {
var dataItem = event.target.dataItem;
// convert coordinate to value
var value = valueAxis.yToValue(event.target.pixelY);
// set new value
dataItem.valueY = value;
// make column hover
dataItem.column.isHover = true;
// hide tooltip not to interrupt
dataItem.column.hideTooltip(0);
// make bullet hovered (as it might hide if mouse moves away)
event.target.isHover = true;
}
// column template
var columnTemplate = series.columns.template;
columnTemplate.column.cornerRadiusTopLeft = 8;
columnTemplate.column.cornerRadiusTopRight = 8;
columnTemplate.fillOpacity = 0.8;
columnTemplate.tooltipText = "drag me";
columnTemplate.tooltipY = 0; // otherwise will point to middle of the column
// hover state
var columnHoverState = columnTemplate.column.states.create("hover");
columnHoverState.properties.fillOpacity = 1;
// you can change any property on hover state and it will be animated
columnHoverState.properties.cornerRadiusTopLeft = 35;
columnHoverState.properties.cornerRadiusTopRight = 35;
// show bullet when hovered
columnTemplate.events.on("over", event => {
var dataItem = event.target.dataItem;
var itemBullet = dataItem.bullets.getKey(bullet.uid);
itemBullet.isHover = true;
});
// hide bullet when mouse is out
columnTemplate.events.on("out", event => {
var dataItem = event.target.dataItem;
var itemBullet = dataItem.bullets.getKey(bullet.uid);
itemBullet.isHover = false;
});
// start dragging bullet even if we hit on column not just a bullet, this will make it more friendly for touch devices
columnTemplate.events.on("down", event => {
var dataItem = event.target.dataItem;
var itemBullet = dataItem.bullets.getKey(bullet.uid);
itemBullet.dragStart(event.pointer);
});
// when columns position changes, adjust minX/maxX of bullets so that we could only dragg vertically
columnTemplate.events.on("positionchanged", event => {
var dataItem = event.target.dataItem;
var itemBullet = dataItem.bullets.getKey(bullet.uid);
var column = dataItem.column;
itemBullet.minX = column.pixelX + column.pixelWidth / 2;
itemBullet.maxX = itemBullet.minX;
itemBullet.minY = 0;
itemBullet.maxY = chart.seriesContainer.pixelHeight;
});
// as by default columns of the same series are of the same color, we add adapter which takes colors from chart.colors color set
columnTemplate.adapter.add("fill", (fill, target) => {
return barColor; //chart.colors.getIndex(target.dataItem.index).saturate(0.3);
});
bullet.adapter.add("fill", (fill, target) => {
return chart.colors.getIndex(target.dataItem.index).saturate(0.3);
});
}
});
Shiny.inputBindings.register(barchartBinding);
Update
And below is a Shiny implementation of the amcharts4 grouped bar chart.
library(shiny)
library(jsonlite)
registerInputHandler("dataframe", function(data, ...) {
fromJSON(toJSON(data, auto_unbox = TRUE))
}, force = TRUE)
groupedBarChartInput <- function(inputId, width = "100%", height = "400px",
data, categoryField, valueFields,
minValue, maxValue,
ndecimals = 0,
colors = NULL,
categoryLabel = categoryField,
valueLabels = valueFields,
categoryAxisTitle = categoryLabel,
valueAxisTitle = NULL,
categoryAxisTitleFontSize = 22,
valueAxisTitleFontSize = 22,
categoryAxisTitleColor = "indigo",
valueAxisTitleColor = "indigo",
draggable = rep(FALSE, length(valueFields))){
tags$div(id = inputId, class = "amGroupedBarChart",
style = sprintf("width: %s; height: %s;", width, height),
`data-data` = as.character(toJSON(data)),
`data-categoryfield` = categoryField,
`data-valuefields` = as.character(toJSON(valueFields)),
`data-min` = minValue,
`data-max` = maxValue,
`data-ndecimals` = ndecimals,
`data-colors` = ifelse(is.null(colors), "auto", as.character(toJSON(colors))),
`data-valuenames` = as.character(toJSON(valueLabels)),
`data-categoryname` = categoryLabel,
`data-categoryaxistitle` = categoryAxisTitle,
`data-valueaxistitle` = valueAxisTitle,
`data-draggable` = as.character(toJSON(draggable)),
`data-categoryaxistitlefontsize` = categoryAxisTitleFontSize,
`data-valueaxistitlefontsize` = valueAxisTitleFontSize,
`data-categoryaxistitlecolor` = categoryAxisTitleColor,
`data-valueaxistitlecolor` = valueAxisTitleColor)
}
set.seed(666)
dat <- data.frame(
year = rpois(5, 2010),
income = rpois(5, 25),
expenses = rpois(5, 20)
)
ui <- fluidPage(
tags$head(
tags$script(src = "http://www.amcharts.com/lib/4/core.js"),
tags$script(src = "http://www.amcharts.com/lib/4/charts.js"),
tags$script(src = "http://www.amcharts.com/lib/4/themes/animated.js"),
tags$script(src = "groupedBarChartBinding.js")
),
fluidRow(
column(8,
groupedBarChartInput("mybarchart", data = dat[order(dat$year),],
categoryField = "year",
valueFields = c("income", "expenses"),
categoryLabel = "Year",
valueLabels = c("Income", "Expenses"),
valueAxisTitle = "Income and expenses",
minValue = 0, maxValue = 35,
draggable = c(FALSE, TRUE),
colors = c("darkmagenta","darkred"))),
column(4,
tags$label("Data:"),
verbatimTextOutput("data"),
br(),
tags$label("Change:"),
verbatimTextOutput("change"))
)
)
server <- function(input, output){
output[["data"]] <- renderPrint({
input[["mybarchart"]]
})
output[["change"]] <- renderPrint({ input[["mybarchart_change"]] })
}
shinyApp(ui, server)
The file groupedBarChartBinding.js, to put in the www subfolder:
var groupedBarChartBinding = new Shiny.InputBinding();
$.extend(groupedBarChartBinding, {
find: function(scope) {
return $(scope).find(".amGroupedBarChart");
},
getValue: function(el) {
return $(el).data("data");
},
getType: function(el) {
return "dataframe";
},
subscribe: function(el, callback) {
$(el).on("change.groupedBarChartBinding", function(e) {
callback();
});
},
unsubscribe: function(el) {
$(el).off(".groupedBarChartBinding");
},
initialize: function(el) {
var id = el.getAttribute("id");
var $el = $(el);
var data = $el.data("data");
var dataCopy = $el.data("data");
var categoryField = $el.data("categoryfield");
var valueFields = $el.data("valuefields");
var minValue = $el.data("min");
var maxValue = $el.data("max");
var colors = $el.data("colors");
var valueNames = $el.data("valuenames");
var categoryName = $el.data("categoryname");
var categoryAxisTitle = $el.data("categoryaxistitle");
var valueAxisTitle = $el.data("valueaxistitle");
var draggable = $el.data("draggable");
var ndecimals = $el.data("ndecimals");
var numberFormat = "#.";
for (var i = 0; i < ndecimals; i++) {
numberFormat = numberFormat + "#";
}
var categoryAxisTitleFontSize = $el.data("categoryaxistitlefontsize") + "px";
var valueAxisTitleFontSize = $el.data("valueaxistitlefontsize") + "px";
var categoryAxisTitleColor = $el.data("categoryaxistitlecolor");
var valueAxisTitleColor = $el.data("valueaxistitlecolor");
am4core.useTheme(am4themes_animated);
var chart = am4core.create(id, am4charts.XYChart);
chart.hiddenState.properties.opacity = 0; // this makes initial fade in effect
chart.data = data;
chart.padding(40, 40, 40, 40);
chart.maskBullets = false; // allow bullets to go out of plot area
// Create axes
var categoryAxis = chart.yAxes.push(new am4charts.CategoryAxis());
categoryAxis.dataFields.category = categoryField;
categoryAxis.numberFormatter.numberFormat = numberFormat;
categoryAxis.renderer.inversed = true;
categoryAxis.renderer.grid.template.location = 0;
categoryAxis.renderer.cellStartLocation = 0.1;
categoryAxis.renderer.cellEndLocation = 0.9;
categoryAxis.title.text = categoryAxisTitle;
categoryAxis.title.fontWeight = "bold";
categoryAxis.title.fontSize = categoryAxisTitleFontSize;
categoryAxis.title.setFill(categoryAxisTitleColor);
var valueAxis = chart.xAxes.push(new am4charts.ValueAxis());
valueAxis.renderer.opposite = true;
valueAxis.strictMinMax = true;
valueAxis.min = minValue;
valueAxis.max = maxValue;
if (valueAxisTitle !== null) {
valueAxis.title.text = valueAxisTitle;
valueAxis.title.fontWeight = "bold";
valueAxis.title.fontSize = valueAxisTitleFontSize;
valueAxis.title.setFill(valueAxisTitleColor);
}
function handleDrag(event) {
var dataItem = event.target.dataItem;
// convert coordinate to value
var value = valueAxis.xToValue(event.target.pixelX);
// set new value
dataItem.valueX = value;
// make column hover
dataItem.column.isHover = true;
// hide tooltip not to interrupt
dataItem.column.hideTooltip(0);
// make bullet hovered (as it might hide if mouse moves away)
event.target.isHover = true;
}
// Create series
function createSeries(field, name, barColor, drag) {
var series = chart.series.push(new am4charts.ColumnSeries());
series.dataFields.valueX = field;
series.dataFields.categoryY = categoryField;
series.name = name;
series.sequencedInterpolation = true;
var valueLabel = series.bullets.push(new am4charts.LabelBullet());
valueLabel.label.text = "{valueX}";
valueLabel.label.horizontalCenter = "left";
valueLabel.label.dx = 10;
valueLabel.label.hideOversized = false;
valueLabel.label.truncate = false;
var categoryLabel = series.bullets.push(new am4charts.LabelBullet());
categoryLabel.label.text = "{name}";
categoryLabel.label.horizontalCenter = "right";
categoryLabel.label.dx = -10;
categoryLabel.label.fill = am4core.color("#fff");
categoryLabel.label.hideOversized = false;
categoryLabel.label.truncate = false;
// column template
var columnTemplate = series.columns.template;
console.log(columnTemplate);
// columnTemplate.tooltipText = "{name}: [bold]{valueX}[/]";
columnTemplate.tooltipHTML =
"<div style='font-size:9px'>" + "{name}" + ": " + "<b>{valueX}</b>" + "</div>";
columnTemplate.height = am4core.percent(100);
columnTemplate.column.cornerRadiusBottomRight = 8;
columnTemplate.column.cornerRadiusTopRight = 8;
columnTemplate.fillOpacity = 1;
columnTemplate.tooltipX = 0; // otherwise will point to middle of the column
// hover state
var columnHoverState = columnTemplate.column.states.create("hover");
columnHoverState.properties.fillOpacity = 1;
// you can change any property on hover state and it will be animated
columnHoverState.properties.cornerRadiusBottomRight = 35;
columnHoverState.properties.cornerRadiusTopRight = 35;
// color
if (barColor !== false) {
columnTemplate.adapter.add("fill", (fill, target) => {
return barColor;
});
}
if (drag) {
// series bullet
var bullet = series.bullets.create();
bullet.stroke = am4core.color("#ffffff");
bullet.strokeWidth = 1;
bullet.opacity = 0; // initially invisible
bullet.defaultState.properties.opacity = 0;
// resize cursor when over
bullet.cursorOverStyle = am4core.MouseCursorStyle.horizontalResize;
bullet.draggable = true;
// create hover state
var hoverState = bullet.states.create("hover");
hoverState.properties.opacity = 1; // visible when hovered
// add circle sprite to bullet
var circle = bullet.createChild(am4core.Circle);
circle.radius = 5;
// dragging
// while dragging
bullet.events.on("drag", event => {
handleDrag(event);
});
bullet.events.on("dragstop", event => {
handleDrag(event);
var dataItem = event.target.dataItem;
dataItem.column.isHover = false;
event.target.isHover = false;
dataCopy[dataItem.index][field] = dataItem.values.valueX.value;
Shiny.setInputValue(id + ":dataframe", dataCopy);
Shiny.setInputValue(id + "_change", {
index: dataItem.index,
field: field,
category: dataItem.categoryY,
value: dataItem.values.valueX.value
});
});
// bullet color
if (barColor !== false) {
bullet.adapter.add("fill", (fill, target) => {
return barColor;
});
}
// show bullet when hovered
columnTemplate.events.on("over", event => {
var dataItem = event.target.dataItem;
var itemBullet = dataItem.bullets.getKey(bullet.uid);
itemBullet.isHover = true;
});
// hide bullet when mouse is out
columnTemplate.events.on("out", event => {
var dataItem = event.target.dataItem;
var itemBullet = dataItem.bullets.getKey(bullet.uid);
itemBullet.isHover = false;
});
// start dragging bullet even if we hit on column not just a bullet, this will make it more friendly for touch devices
columnTemplate.events.on("down", event => {
var dataItem = event.target.dataItem;
var itemBullet = dataItem.bullets.getKey(bullet.uid);
itemBullet.dragStart(event.pointer);
});
// when columns position changes, adjust minY/maxY of bullets so that we could only dragg horizontally
columnTemplate.events.on("positionchanged", event => {
var dataItem = event.target.dataItem;
var itemBullet = dataItem.bullets.getKey(bullet.uid);
var column = dataItem.column;
itemBullet.minY = column.pixelY + column.pixelHeight / 2;
itemBullet.maxY = itemBullet.minY;
itemBullet.minX = 0;
itemBullet.maxX = chart.seriesContainer.pixelWidth;
});
}
}
for (var i = 0; i < valueFields.length; i++) {
var color = colors === "auto" ? null : colors[i];
createSeries(valueFields[i], valueNames[i], color, draggable[i]);
}
}
});
Shiny.inputBindings.register(groupedBarChartBinding);
Update 2
I have done a package now : shinyAmBarCharts. I have added a button (optional) allowing to update the data to another dataset. This fulfills the OP's desideratum:
the graph engages the user to make a guess and then shows the real
data
library(shiny)
library(shinyAmBarCharts)
# create a dataset
set.seed(666)
df0 <- data.frame(
species = rep(c("sorgho","poacee","banana"), each = 3),
condition = rep(c("normal", "stress", "Nitrogen"), 3),
value = rpois(9, 10)
)
df1 <- df0; df1[["value"]] <- 10
dat <- tidyr::spread(df0, condition, value) # true data
dat2 <- tidyr::spread(df1, condition, value) # data template
# grouped bar chart
ui <- fluidPage(
br(),
fluidRow(
column(9,
amBarChart(
"mygroupedbarchart", data = dat2, data2 = dat, height = "400px",
category = "species", value = c("normal", "stress", "Nitrogen"),
valueNames = c("Normal", "Stress", "Nitrogen"),
minValue = 0, maxValue = 20,
draggable = c(TRUE, TRUE, TRUE),
theme = "dark", backgroundColor = "#30303d",
columnStyle = list(fill = c("darkmagenta", "darkred", "gold"),
stroke = "#cccccc",
cornerRadius = 4),
chartTitle = list(text = "Grouped bar chart",
fontSize = 23,
color = "firebrick"),
xAxis = list(title = list(text = "Species",
fontSize = 21,
color = "silver"),
labels = list(color = "whitesmoke",
fontSize = 17)),
yAxis = list(title = list(text = "Value",
fontSize = 21,
color = "silver"),
labels = list(color = "whitesmoke",
fontSize = 14)),
columnWidth = 90,
button = list(text = "Show true data"),
caption = list(text = "[font-style:italic]shinyAmBarCharts[/]",
color = "yellow"),
gridLines = list(color = "whitesmoke",
opacity = 0.4,
width = 1),
tooltip = list(text = "[bold;font-style:italic]{name}: {valueY}[/]",
labelColor = "#101010",
backgroundColor = "cyan",
backgroundOpacity = 0.7)
)
),
column(3,
tags$label("Data:"),
verbatimTextOutput("data"),
br(),
tags$label("Change:"),
verbatimTextOutput("change"))
)
)
server <- function(input, output){
output[["data"]] <- renderPrint({
input[["mygroupedbarchart"]]
})
output[["change"]] <- renderPrint({ input[["mygroupedbarchart_change"]] })
}
shinyApp(ui, server)

Change cell background of rHandsontable with afterChange event on client side

I'd like to change the background color of a handsontable cell after it's been edited by the user on the client side. The handsontable is defined through a Shiny application; so this is really a question about how to define event hooks in rHandsontable in the Shiny application. The general use case that I'm trying to accomplish is: users edit cell data; the background color change to indicate that it's been changed and is pending saving to a database; the change is passed back to Shiny's observeEvent(); the change is sent to an external database and saved; the the rHandsontable is redrawn on the output with default background coloring that removes the color set be the change. The result is the flicker indicates that data has been saved. And if there's a database connection error or other issue, the color will persist, indicating the data is unsaved. I've been able to accomplish a working example, pasted below.
Specific question: the hook is currently implemented using hot_col(1,renderer=change_hook) however, this isn't about rendering the cell, just a way that allows adding the hook. I assume hot_table() is the correct function, but can it be used to register events? More generally, is there a more built-in way of accomplishing this?
change_hook <- "
function(instance, td, row, col, prop, value, cellProperties) {
Handsontable.hooks.add('afterChange', function(changes,source) {
if (source === 'edit' || source === 'undo' || source === 'autofill' || source === 'paste') {
row = changes[0][0];
col = changes[0][1];
oldval = changes[0][2];
newval = changes[0][3];
if (oldval !== newval) {
cell = this.getCell(row,col);
cell.style.background = 'pink';
}
}
},instance);
Handsontable.renderers.TextRenderer.apply(this, arguments);
}"
ui <- div(width=300,rHandsontableOutput(outputId="hTable"))
server <- function(input, output, session) {
df<-data.frame(col1=c("Hands","on","Table"),col2=c(100,200,300),stringsAsFactors = F)
hTable <- reactiveVal(df)
observeEvent(input$hTable, {
withProgress(message = "Saving changes to database...", value=0.5, {
Sys.sleep(1)
incProgress(1, detail = "done")
input_hTable <- hot_to_r(input$hTable)
hTable(input_hTable)
})
})
output$hTable <- renderRHandsontable({
rhandsontable(hTable(),stretchH="all",height=300) %>%
hot_col(1,renderer=change_hook)
})
}
shinyApp(ui, server)
After searching for a while, I have used the info from these pages (handsontable, htmlwidgets) to change the background color of an edited cell.
In the afterChange function, list of all changed cells will be kept. In the afterRender function the background color of those cells will be changed to yellow. In the afterLoadData function, the background color of changed cells will be reset to white and it will be emptied.
library(shiny)
library(rhandsontable)
change_hook <- "function(el,x) {
var hot = this.hot;
var cellChanges = [];
var changefn = function(changes,source) {
if (source === 'edit' || source === 'undo' || source === 'autofill' || source === 'paste') {
row = changes[0][0];
col = changes[0][1];
oldval = changes[0][2];
newval = changes[0][3];
if (oldval !== newval) {
var cell = hot.getCell(row, col);
cell.style.background = 'pink';
cellChanges.push({'rowid':row, 'colid':col});
}
}
}
var renderfn = function(isForced) {
for(i = 0; i < cellChanges.length; i++)
{
var rowIndex = cellChanges[i]['rowid'];
var columnIndex = cellChanges[i]['colid'];
var cell = hot.getCell(rowIndex, columnIndex);
cell.style.background = 'yellow';
}
}
var loadfn = function(initialLoad) {
for(i = 0; i < cellChanges.length; i++)
{
var rowIndex = cellChanges[i]['rowid'];
var columnIndex = cellChanges[i]['colid'];
var cell = hot.getCell(rowIndex, columnIndex);
cell.style.background = 'white';
}
cellChanges = []
}
hot.addHook('afterChange', changefn);
hot.addHook('afterRender', renderfn);
hot.addHook('afterLoadData', loadfn);
} "
ui <- div(actionButton(inputId = "reset_button",label = "Reset")
,rHandsontableOutput(outputId="hTable"))
server <- function(input, output, session) {
df<-data.frame(col1=c("Hands","on","Table"),col2=c(100,200,300),stringsAsFactors = F)
reset <- reactiveVal(0)
hTable <- reactiveVal(df)
output$hTable <- renderRHandsontable({
r = reset()
rht = rhandsontable(hTable(),reset=r,stretchH="all",height=300)%>%
hot_col('col1',readOnly=T)
reset(0)
htmlwidgets::onRender(rht,change_hook)
})
observeEvent(input$reset_button,
{
reset(1)
})
}
shinyApp(ui, server)
The code below changes the background color of a rhandsontable cell after it's been edited by a user.
library(shiny)
library(rhandsontable)
ui <- fluidPage(
titlePanel ('Give it a try and make changes!'),
mainPanel(rHandsontableOutput('table'))
)
server <- function(input, output, session) {
df <- data.frame(SYMBOLS = c('AAPL', 'ALRM', 'AMZN', 'BABA', 'CRM', 'CSCO',
'FB'),
NAMES = c('APPLE', 'ALARM.com', 'AMAZON', 'ALIBABA',
'SALESFORCE', 'CISCO', 'FACEBOOK'),
NOTE = c('sale', '', 'buy', '', '', '', 'watch'))
output$table <- renderRHandsontable(
rhandsontable(df))
rv <- reactiveValues(row = c(), col = c())
observeEvent(input$table$changes$changes, {
rv$row <- c(rv$row, input$table$changes$changes[[1]][[1]])
rv$col <- c(rv$col, input$table$changes$changes[[1]][[2]])
output$table <- renderRHandsontable({
rhandsontable(hot_to_r(input$table), row_highlight = rv$row,
col_highlight = rv$col) %>%
hot_cols(
renderer = "
function(instance, td, row, col, prop, value, cellProperties) {
Handsontable.renderers.TextRenderer.apply(this, arguments);
if (instance.params) {
hrows = instance.params.row_highlight;
hrows = hrows instanceof Array ? hrows : [hrows];
hcols = instance.params.col_highlight;
hcols = hcols instanceof Array ? hcols : [hcols];
}
for (let i = 0; i < hrows.length; i++) {
if (instance.params && hrows[i] == row && hcols[i] == col) {
td.style.background = 'pink';
}}
}"
)
})
})
}
shinyApp(ui, server)
Each time a cell is changed,
The row index of this cell (input$table$changes$changes[[1]][[1]]) and its column index (input$table$changes$changes[[1]][[2]]) are appended to the reactive variable rv$row and rv$col, respectively,
The rHandsontable is rendered again using the reactive variable (rv) that includes the indices of all the cells that have been changed so far, and finally,
A for loop in the javascript renderer goes through all the indices in rv one pair at a time against all cols and rows of the table. If there is a match in both row and col indices the background color of this cell is changed to pink.

Shiny: How to change the shape and/or size of the clicked point?

I would like to change the shape and size of the clicked point in the below plot. How to achieve it? For this toy plot, I have reduced the number of points from original 100k to 2k. So, the expected solution should be highly scalable and do not deviate from the original plot i.e., all the colors before and after the update of the click point should be the same.
library(shiny)
library(plotly)
df <- data.frame(X=runif(2000,0,2), Y=runif(2000,0,20),
Type=c(rep(c('Type1','Type2'),600),
rep(c('Type3','Type4'),400)),
Val=sample(LETTERS,2000,replace=TRUE))
# table(df$Type, df$Val)
ui <- fluidPage(
title = 'Select experiment',
sidebarLayout(
sidebarPanel(
checkboxGroupInput("SelType", "Select Types to plot:",
choices = unique(df$Type),
selected = NA)
),
mainPanel(
plotlyOutput("plot", width = "400px"),
verbatimTextOutput("click")
)
)
)
server <- function(input, output, session) {
output$plot <- renderPlotly({
if(length(input$SelType) != 0){
df <- subset(df, Type %in% input$SelType)
p <- ggplot(df, aes(X, Y, col = as.factor(Val))) +
geom_point()
}else{
p <- ggplot(df, aes(X, Y, col = as.factor(Val))) +
geom_point()
}
ggplotly(p) %>% layout(height = 800, width = 800)
})
output$click <- renderPrint({
d <- event_data("plotly_click")
if (is.null(d)) "Click events appear here (double-click to clear)"
else cat("Selected point associated with value: ", d$Val)
})
}
shinyApp(ui, server)
A related question has been asked here, but that approach of highlighting the point with a color does not work(when the number of levels of a variable is high, it is difficult to hard code a color which might be already present in the plot).
Plotly's restyle function won't help us here but we can still use the onclick event together with a little bit of JavaScript. The code has acceptable performance for 10,000 points.
We can get the point which was clicked on in JavaScript using:
var point = document.getElementsByClassName('scatterlayer')[0].getElementsByClassName('scatter')[data.points[0].curveNumber].getElementsByClassName('point')[data.points[0].pointNumber];
(scatterlayer is the layer where all the scatterplot elements are located,
scatter[n] is the n-th scatter plot and point[p] is the p-th point in it)
Now we just make this point a lot bigger (or whatever other shape/transformation you want):
point.setAttribute('d', 'M10,0A10,10 0 1,1 0,-10A10,10 0 0,1 10,0Z');
In order to get the possibility to revert everything, we store the unaltered info about the point together with the rest of the Plotly information:
var plotly_div = document.getElementsByClassName('plotly')[0];
plotly_div.backup = {curveNumber: data.points[0].curveNumber,
pointNumber: data.points[0].pointNumber,
d: point.attributes['d'].value
}
and later we can restore the point:
var old_point = document.getElementsByClassName('scatterlayer')[0].getElementsByClassName('scatter')[plotly_div.backup.curveNumber].getElementsByClassName('point')[plotly_div.backup.pointNumber]
old_point.setAttribute('d', plotly_div.backup.d);
Now we can add all the code to the plotly widget.
javascript <- "
function(el, x){
el.on('plotly_click', function(data) {
var point = document.getElementsByClassName('scatterlayer')[0].getElementsByClassName('scatter')[data.points[0].curveNumber].getElementsByClassName('point')[data.points[0].pointNumber];
var plotly_div = document.getElementsByClassName('plotly')[0];
if (plotly_div.backup !== undefined) {
var old_point = document.getElementsByClassName('scatterlayer')[0].getElementsByClassName('scatter')[plotly_div.backup.curveNumber].getElementsByClassName('point')[plotly_div.backup.pointNumber]
if (old_point !== undefined) {
old_point.setAttribute('d', plotly_div.backup.d);
}
}
plotly_div.backup = {curveNumber: data.points[0].curveNumber,
pointNumber: data.points[0].pointNumber,
d: point.attributes['d'].value,
style: point.attributes['style'].value
}
point.setAttribute('d', 'M10,0A10,10 0 1,1 0,-10A10,10 0 0,1 10,0Z');
});
}"
[...]
ggplotly(p) %>% onRender(javascript)
Alternatively you could make a new SVG element based on the location of the clicked point but in the color and shape you would like.
You can try it here without R/Shiny.
//create some random data
var data = [];
for (var i = 0; i < 10; i += 1) {
data.push({x: [],
y: [],
mode: 'markers',
type: 'scatter'});
for (var p = 0; p < 200; p += 1) {
data[i].x.push(Math.random());
data[i].y.push(Math.random());
}
}
//create the plot
var myDiv = document.getElementById('myDiv');
Plotly.newPlot(myDiv, data, layout = { hovermode:'closest'});
//add the same click event as the snippet above
myDiv.on('plotly_click', function(data) {
//let's check if some traces are hidden
var traces = document.getElementsByClassName('legend')[0].getElementsByClassName('traces');
var realCurveNumber = data.points[0].curveNumber;
for (var i = 0; i < data.points[0].curveNumber; i += 1) {
if (traces[i].style['opacity'] < 1) {
realCurveNumber -= 1
}
}
data.points[0].curveNumber = realCurveNumber;
var point = document.getElementsByClassName('scatterlayer')[0].getElementsByClassName('scatter')[data.points[0].curveNumber].getElementsByClassName('point')[data.points[0].pointNumber];
var plotly_div = document.getElementsByClassName('plotly')[0];
if (plotly_div.backup !== undefined) {
var old_point = document.getElementsByClassName('scatterlayer')[0].getElementsByClassName('scatter')[plotly_div.backup.curveNumber].getElementsByClassName('point')[plotly_div.backup.pointNumber]
if (old_point !== undefined) {
old_point.setAttribute('d', plotly_div.backup.d);
}
}
plotly_div.backup = {curveNumber: data.points[0].curveNumber,
pointNumber: data.points[0].pointNumber,
d: point.attributes['d'].value,
style: point.attributes['style'].value
}
point.setAttribute('d', 'M10,0A10,10 0 1,1 0,-10A10,10 0 0,1 10,0Z');
});
<script src="https://cdn.plot.ly/plotly-latest.min.js"></script>
<div id="myDiv">

Using global data in High Charts point click custom function in R Shiny

I am trying to show a different table or plot in a different div when a bar on a a bar plot is clicked. I have come this far.
server.R
library(shiny)
shinyServer(function(input,output,session) {
custom_data = # a data frame in R
barclick_func <- "#! function() {
var cats = ['100','200','3000','4000'];
var datum = [20,40,30,10];
}
$('#container_subcat').highcharts({
chart: {
type: 'column',
},
xAxis: { categories:cats },
series: [{data :datum}]
});
} !#"
output$my_plot <- renderChart2({
a <- hPlot(x="id",y="variable",data=custom_data,type="column")
a$tooltip( animation = 'true', formatter = "#! function() {return '<b>' + 'Frequency of tag_id ' + this.x + '</b>' + ' is ' + this.y;} !#")
a$plotOptions(series = list(color = '#388E8E'),column = list(dataLabels = list(enabled = T, rotation =-90, align = 'right', color = '#FFFFFF', x = 4, y = 10),
cursor = 'pointer', point = list(events = list(click = barclick_func))))
return(a)
})
})
ui.R
library(shiny)
require(rCharts)
shinyUI(fluidPage(
tags$head(
tags$link(rel = "stylesheet", type = "text/css", href = "custom.css"),
tags$script(src="http://code.jquery.com/jquery-git2.min.js"),
),
titlePanel("Test"),
fluidRow(
showOutput("my_plot","highcharts")
),
div(id="container_subcat",style="min-width: 310-px; height: 400px; margin: 0 auto; margin-top:100px;")
)
))
In the above server.R script, in barclick_func() function, the data(variables cats and datum) is hardcoded. The above app works as expected when a bar is clicked, another plot pops up properly with the data.
But, if I want to use another data, that is if I have another data frame in R and want to use that data frame in barclick_func(), the console is throwing an error that the variable is not recognized and if I look at the type of that variable, it shows as 'undefined'. Can anyone suggest how to send data to the javascript function in this particular case. Ideally, my desired code is this.
server.R
library(shiny)
shinyServer(function(input,output,session) {
custom_data = # a data frame in R
custom_data2 = # another data frame in R for which I wanna shoe a plot when the bar is clicked.
barclick_func <- "#! function() {
var cats = #subsetting custom_data2 ;
var datum = #subsetting custom_data2 ;
}
$('#container_subcat').highcharts({
chart: {
type: 'column',
},
xAxis: { categories:cats },
series: [{data :datum}]
});
} !#"
output$my_plot <- renderChart2({
a <- hPlot(x="id",y="variable",data=custom_data,type="column")
a$tooltip( animation = 'true', formatter = "#! function() {return '<b>' + 'Frequency of tag_id ' + this.x + '</b>' + ' is ' + this.y;} !#")
a$plotOptions(series = list(color = '#388E8E'),column = list(dataLabels = list(enabled = T, rotation =-90, align = 'right', color = '#FFFFFF', x = 4, y = 10),
cursor = 'pointer', point = list(events = list(click = barclick_func))))
return(a)
})
})
You could try using paste to add the data to your barclick_func.
For example:
custom_data2 = data.frame(cats=c(100,200,3000,400),datum=c(20,40,30,10))
barclick_func <- paste("#! function() {
var cats = ",paste('[',paste(custom_data2$cats,collapse=','),']',sep=''),"
var datum = ",paste('[',paste(custom_data2$datum,collapse=','),']',sep=''),";
}
$('#container_subcat').highcharts({
chart: {
type: 'column',
},
xAxis: { categories:cats },
series: [{data :datum}]
});
} !#")
Should give the same barclick_func as in your hardcoded version.

Resources