Related
Following R Shiny group buttons with individual hover dropdown selection, need to update the radiogroupbuttons dynamically based on some condition. The number of buttons may change.
I have at least the following queries related to the code below. 1) Does the tag belong in server? 2) how to dynamically multiply selectInput in the server code? 3) How to dynamically multiply the output? I have changed your implementation to fit closer to my application. All dropdowns have the same choices if the button is to be shown a dropdown, this is computed dynamically in dropdownTRUE. If dropdownTRUE==F, I don't need a dropdown.
library(shiny)
library(shinyWidgets)
js <- "
function qTip() {
$('#THE_INPUT_ID .radiobtn').each(function(i, $el){
var value = $(this).find('input[type=radio]').val();
var selector = '#select' + value;
$(this).qtip({
overwrite: true,
content: {
text: $(selector).parent().parent()
},
position: {
my: 'top left',
at: 'bottom right'
},
show: {
ready: false
},
hide: {
event: 'unfocus'
},
style: {
classes: 'qtip-blue qtip-rounded'
},
events: {
blur: function(event, api) {
api.elements.tooltip.hide();
}
}
});
});
}
function qTip_delayed(x){
setTimeout(function(){qTip();}, 500);
}
$(document).on('shiny:connected', function(){
Shiny.addCustomMessageHandler('qTip', qTip_delayed);
});
"
ui <- fluidPage(
tags$head( # does this belong to server?
tags$link(rel = "stylesheet", href = "jquery.qtip.min.css"),
tags$script(src = "jquery.qtip.min.js"),
tags$script(HTML(js))
),
br(),
uiOutput('bttns'),
verbatimTextOutput("selection1")
)
server <- function(input, output, session) {
session$sendCustomMessage("qTip", "")
output$bttns<-renderUI({
bttnchoices=c("A", "B", "C")
lenchoice=length(bttnchoices)
dropdownTRUE=sample(c(T,F),lenchoice,T,rep(.5,2)) ##bttns for which dropdown is to be shown
dropchoices = c("Apple", "Banana")# same choices to be shown for all buttons with dropdownTRUE
radioGroupButtons(
inputId = "THE_INPUT_ID",
individual = TRUE,
label = "Make a choice: ",
choices = bttnchoices
)
div(
style = "display: none;",
shinyInput(lenchoice,selectInput, # struggling with dynamic multiplication of selectInput, lapply?
"select",
label = "Select a fruit",
choices=dropchoices,
selectize = FALSE
))
})
observeEvent(input[["select1"]], {
if(input[["select1"]] == "Banana"){
session$sendCustomMessage("qTip", "")
output$bttns<-renderUI({
bttnchoices=c("D", "A")
lenchoice=length(bttnchoices)
dropdownTRUE=sample(c(T,F),lenchoice,T,rep(.5,2))
dropchoices = c("Peach", "Pear")
radioGroupButtons(
inputId = "THE_INPUT_ID",
individual = TRUE,
label = "Make a choice: ",
choices = bttnchoices
)
div(
style = "display: none;",
shinyInput(lenchoice,selectInput,
"select",
label = "Select a fruit",
choices = dropchoices,
selectize = FALSE
))
})
}
output$selection1<-input$select1 # struggling with dynamic multiplication of outputs, lapply?
})
}
shinyApp(ui, server)
Here is the way. The values of the radio buttons must correspond to the suffixes of the selectInput's ids. Here A, B, C, D are the values and then the ids of the selectInput are selectA, selectB, selectC, selectD. If you want to use other names for the radio buttons, do choices = list("name1" = "A", "name2" = "B", "name3" = "C", "name4" = "D").
library(shiny)
library(shinyWidgets)
js <- "
function qTip() {
$('#THE_INPUT_ID .radiobtn').each(function(i, $el){
var value = $(this).find('input[type=radio]').val();
var selector = '#select' + value;
$(this).qtip({
overwrite: true,
content: {
text: $(selector).parent().parent()
},
position: {
my: 'top left',
at: 'bottom right'
},
show: {
ready: false
},
hide: {
event: 'unfocus'
},
style: {
classes: 'qtip-blue qtip-rounded'
},
events: {
blur: function(event, api) {
api.elements.tooltip.hide();
}
}
});
});
}
function qTip_delayed(x){
setTimeout(function(){qTip();}, 500);
}
$(document).on('shiny:connected', function(){
Shiny.addCustomMessageHandler('qTip', qTip_delayed);
});
"
ui <- fluidPage(
tags$head(
tags$link(rel = "stylesheet", href = "jquery.qtip.min.css"),
tags$script(src = "jquery.qtip.min.js"),
tags$script(HTML(js))
),
br(),
radioGroupButtons(
inputId = "THE_INPUT_ID",
individual = TRUE,
label = "Make a choice: ",
choices = c("A", "B", "C")
),
br(), br(), br(),
verbatimTextOutput("selectionA"),
verbatimTextOutput("selectionB"),
verbatimTextOutput("selectionC"),
verbatimTextOutput("selectionD"),
div(
style = "display: none;",
selectInput(
"selectA",
label = "Select a fruit",
choices = c("Apple", "Banana"),
selectize = FALSE
),
selectInput(
"selectB",
label = "Select a fruit",
choices = c("Lemon", "Orange"),
selectize = FALSE
),
selectInput(
"selectC",
label = "Select a fruit",
choices = c("Strawberry", "Pineapple"),
selectize = FALSE
),
selectInput(
"selectD",
label = "Select a fruit",
choices = c("Pear", "Peach"),
selectize = FALSE
)
)
)
server <- function(input, output, session) {
session$sendCustomMessage("qTip", "")
output[["selectionA"]] <- renderPrint(input[["selectA"]])
output[["selectionB"]] <- renderPrint(input[["selectB"]])
output[["selectionC"]] <- renderPrint(input[["selectC"]])
output[["selectionD"]] <- renderPrint(input[["selectD"]])
observeEvent(input[["selectA"]], {
if(input[["selectA"]] == "Banana"){
updateRadioGroupButtons(session, inputId = "THE_INPUT_ID",
label = "Make NEW choice: ",
choices = c("D","A"))
session$sendCustomMessage("qTip", "")
}
})
}
shinyApp(ui, server)
EDIT
The following way allows to set dropdowns for a chosen list of radio buttons.
library(shiny)
library(shinyWidgets)
js <- "
function qTip(values, ids) {
$('#THE_INPUT_ID .radiobtn').each(function(i, $el){
var value = $(this).find('input[type=radio]').val();
if(values.indexOf(value) > -1){
var selector = '#' + ids[value];
$(this).qtip({
overwrite: true,
content: {
text: $(selector).parent().parent()
},
position: {
my: 'top left',
at: 'bottom right'
},
show: {
ready: false
},
hide: {
event: 'unfocus'
},
style: {
classes: 'qtip-blue qtip-rounded'
},
events: {
blur: function(event, api) {
api.elements.tooltip.hide();
}
}
});
}
});
}
function qTip_delayed(mssg){
$('[data-hasqtip]').qtip('destroy', true);
setTimeout(function(){qTip(mssg.values, mssg.ids);}, 500);
}
$(document).on('shiny:connected', function(){
Shiny.addCustomMessageHandler('qTip', qTip_delayed);
});
"
ui <- fluidPage(
tags$head(
tags$link(rel = "stylesheet", href = "jquery.qtip.min.css"),
tags$script(src = "jquery.qtip.min.js"),
tags$script(HTML(js))
),
br(),
radioGroupButtons(
inputId = "THE_INPUT_ID",
individual = TRUE,
label = "Make a choice: ",
choices = c("A", "B", "C")
),
br(), br(), br(),
uiOutput("selections"),
uiOutput("dropdowns")
)
server <- function(input, output, session) {
dropdowns <- reactiveVal(list( # initial dropdowns
A = c("Apple", "Banana"),
B = c("Lemon", "Orange"),
C = c("Strawberry", "Pineapple")
))
flag <- reactiveVal(FALSE)
prefix <- reactiveVal("")
observeEvent(dropdowns(), {
if(flag()) prefix(paste0("x",prefix()))
flag(TRUE)
}, priority = 2)
observeEvent(input[["selectA"]], {
if(input[["selectA"]] == "Banana"){
updateRadioGroupButtons(session, inputId = "THE_INPUT_ID",
label = "Make NEW choice: ",
choices = c("D","A","B"))
dropdowns( # new dropdowns, only for D and B
list(
D = c("Pear", "Peach"),
B = c("Watermelon", "Mango")
)
)
}
})
observeEvent(dropdowns(), {
req(dropdowns())
session$sendCustomMessage(
"qTip",
list(
values = as.list(names(dropdowns())),
ids = setNames(
as.list(paste0(prefix(), "select", names(dropdowns()))),
names(dropdowns())
)
)
)
})
observeEvent(dropdowns(), {
req(dropdowns())
lapply(names(dropdowns()), function(value){
output[[paste0("selection",value)]] <-
renderPrint(input[[paste0(prefix(), "select", value)]])
})
})
output[["dropdowns"]] <- renderUI({
req(dropdowns())
selectInputs <- lapply(names(dropdowns()), function(value){
div(style = "display: none;",
selectInput(
paste0(prefix(), "select", value),
label = "Select a fruit",
choices = dropdowns()[[value]],
selectize = FALSE
)
)
})
do.call(tagList, selectInputs)
})
output[["selections"]] <- renderUI({
req(dropdowns())
verbOutputs <- lapply(names(dropdowns()), function(value){
verbatimTextOutput(
paste0("selection", value)
)
})
do.call(tagList, verbOutputs)
})
}
shinyApp(ui, server)
Would somebody know the syntax for tracking events with Google Analytics and R Shiny?
I'd like to track which inputs the user is selecting when interacting with my apps. So in this example, I'd like to know when a user uses and makes changes to the 'PointUseInput' checkbox input.
I tried following the advice here, but I'm not super familiar with JavaScript, so I'm not sure how to structure the ga function.
# ################################################################################################
# ################################################################################################
# # Sec 1a. Needed Libaries & Input Files
library(shiny)
library(shinydashboard)
library(leaflet)
library(dplyr)
##The Data
Map_DF <- data.frame("Point_ID" = c("A1", "B1", "C3"),
"Latitude" = c(38.05, 39.08, 40.05),
"Longitude" = c(-107.00, -107.05, -108.00),
"PointUse" = c("farm", "house", "well"))
################################################################################################
################################################################################################
#UI
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
### tags$head(includeHTML(("google-analytics.html"))), #Google Analytics html tag here
checkboxGroupInput(inputId = "PointUseInput", label = "Select Point Use", choices = Map_DF$PointUse, selected = Map_DF$PointUse)
),
dashboardBody(
fluidRow(leafletOutput(outputId = 'mapA'))
)
)
################################################################################################
################################################################################################
server <- function(input, output, session) {
## The Filter
filterdf <- reactive({
Map_DF %>%
filter(PointUse %in% input$PointUseInput)
})
## Base Map Creation
output$mapA <- renderLeaflet({
leaflet() %>%
addProviderTiles(
providers$Esri.DeLorme,
options = providerTileOptions(
updateWhenZooming = FALSE,
updateWhenIdle = TRUE)
) %>%
setView(lng = -107.50, lat = 39.00, zoom = 7)
})
## Update Map with Filter Selection
observe({
leafletProxy("mapA", session) %>%
clearMarkers() %>%
addCircleMarkers(
data = filterdf(),
radius = 10,
color = "red",
lat = ~Latitude,
lng = ~Longitude,
popupOptions(autoPan = FALSE),
popup = ~paste("PointUse: ", filterdf()$PointUse))
})
}
################################################################################################
################################################################################################
shinyApp(ui = ui, server = server)
With the accompanying google-analytics JavaScript Code...
$(document).on('change', 'select', function(e) {
ga('send', 'event', 'category', 'action', 'label', value);
});
Setting the following syntax in the google-analytics JavaScript Code worked for me:
gtag('event', <action>, {
'event_category': <category>,
'event_label': <label>,
'value': <value>
});
So, instead of:
$(document).on('change', 'select', function(e) {
ga('send', 'event', 'category', 'action', 'label', value);
});
Try:
$(document).on('change', 'select', function(e) {
gtag('event', 'action', {
'event_category': 'category',
'event_label': 'label',
'value': <value>
});
});
You could also try:
$('#selectInputId').on('change', function(e) {
gtag('event', 'action', {
'event_category': 'category',
'event_label': 'label',
'value': <value>
});
});
That is the only changed I made when following the same article you linked to.
I'm trying to create dropdown input in shiny which has hierarchical drop-down list in R shiny like below:
hierarchical drop-down list in R shiny
For now I'm able to create an shinytree where we can display the entire list, but I want display the list in dropdown instead of shinytree.
Below is my code:
library(shiny)
library(shinyTree)
# Define UI for application:
ui <- {fluidPage(
sidebarLayout(
sidebarPanel(width = 3,
div(shinyTree("Tree",checkbox = TRUE)),
verbatimTextOutput("selected")
),
mainPanel(width = 9)
)
)}
# Define server logic:
server <- function(input, output, session){
observe({
df <- data.frame(
child= c('a','b','c','d','e','f','g','h'),
parent = c('f','f','f','g','h','i','i','i'))
tree <- FromDataFrameNetwork(df)
filtered_value <- as.list(tree)
filtered_value <- filtered_value[-1]
output$Tree <- renderTree({
filtered_value
})
})
}
# Run the application
shinyApp(ui = ui, server = server)
I'm looking for input in this manner: Custom-Dropdown
I did a Shiny binding for the ComboTree library yesterday. It works but this is not fantastic.
File comboTreeBinding.js to put in the www subfolder:
var comboTreeBinding = new Shiny.InputBinding();
$.extend(comboTreeBinding, {
find: function (scope) {
return $(scope).find(".comboTree");
},
getValue: function (el) {
var value = el.value.split(", ");
var empty = value.length === 1 && value[0] === "";
return empty ? null : value;
},
setValue: function(el, value) {
$(el).setSelection(value);
},
subscribe: function (el, callback) {
$(el).on("change.comboTreeBinding", function (e) {
callback();
});
},
unsubscribe: function (el) {
$(el).off(".comboTreeBinding");
},
initialize: function(el) {
var $el = $(el);
$el.comboTree({
source: $el.data("choices"),
isMultiple: $el.data("multiple"),
cascadeSelect: $el.data("cascaded"),
collapse: true
});
}
});
Shiny.inputBindings.register(comboTreeBinding);
Shiny app (put the files style.css and comboTreePlugin.js in the www subfolder):
library(shiny)
library(jsonlite)
comboTreeInput <- function(inputId, width = "30%", height = "100px",
choices, multiple = TRUE, cascaded = TRUE){
tags$div(style = sprintf("width: %s; height: %s;", width, height),
tags$input(id = inputId, class = "comboTree", type = "text",
placeholder = "Select",
`data-choices` = as.character(toJSON(choices, auto_unbox = TRUE)),
`data-multiple` = ifelse(multiple, "true", "false"),
`data-cascaded` = ifelse(cascaded, "true", "false")
)
)
}
choices <- list(
list(id = 1, title = "item1"),
list(id = 2, title = "item2",
subs = list(
list(id = 21, title = "item2-1"),
list(id = 22, title = "item2-2")
)
),
list(id = 3, title = "item3",
subs = list(
list(id = 31, title = "item3-1", isSelectable = FALSE,
subs = list(
list(id = 311, title = "item3-1-1"),
list(id = 312, title = "item3-1-2")
)
),
list(id = 32, title = "item3-2")
)
)
)
ui <- fluidPage(
tags$head(
tags$link(rel = "stylesheet", href = "style.css"),
tags$script(src = "comboTreePlugin.js"),
tags$script(src = "comboTreeBinding.js")
),
br(),
h3("You selected:"),
verbatimTextOutput("selections"),
br(),
comboTreeInput("mycombotree", choices = choices)
)
server <- function(input, output, session){
output[["selections"]] <- renderPrint({
input[["mycombotree"]]
})
}
shinyApp(ui, server)
Let's assume I want to get the following jstree in shiny (the part with the button is just to illustrate that the shinytree is not present from the beginning):
$(function() {
$('#create').on('click', function() {
$('#mytree').jstree({
'core' : {
'data' : {
"url" : "//www.jstree.com/fiddle/?lazy",
"data" : function (node) {
return { "id" : node.id };
}
}
},
contextmenu : {
items : {
'item1' : {
'label' : 'item1',
'action' : function () { /* action */ }
}
}
},
plugins : ["contextmenu"]
});
})
})
<link href="https://cdnjs.cloudflare.com/ajax/libs/jstree/3.3.8/themes/default/style.min.css" rel="stylesheet"/>
<script src="https://cdnjs.cloudflare.com/ajax/libs/jquery/3.3.1/jquery.min.js"></script>
<script src="https://cdnjs.cloudflare.com/ajax/libs/jstree/3.3.8/jstree.min.js"></script>
<div id="mytree"></div>
<button id = "create">
Create Tree
</button>
The problem is that I cannot provide the contextmenu via shinyTree. So I need to fall back to JavaScript to add this functionality myself. On the console I would do it like follows:
$('#mytree').jstree(true).settings.contextmenu = {
items: {
item1 : {
'label' : 'item1',
'action': function() { /* action */ }
}
}
}
But where and when would I call that in my ShinyApp? My approach with another handler does not work, because I guess that the handler fires before the tree is rendered (a second press to the button does the trick then, showing at least that the JS code works as intended). Playing with the priority did not help either.
Could I use a javascript event handler which I would attach to $(document), which listens to the creation of the tree?
ShinyApp
library(shiny)
library(shinyTree)
library(shinyjs)
js_code <- "$('#mytree').jstree(true).settings.contextmenu = {
items: {
item1 : {
'label' : 'item1',
'action': function() { /* action */ }
}
}
};"
ui <- fluidPage(useShinyjs(),
actionButton("create", "Create Tree"),
shinyTree("mytree", contextmenu = TRUE))
server <- function(input, output, session) {
## does not work as intended
observeEvent(input$create, runjs(js_code), ignoreInit = TRUE, priority = -1)
output$mytree <- renderTree({
req(input$create)
list("Root Node" = list("Child Node 1" = list(
"Child Node 3" = "",
"Child Node 4" = ""),
"Child Node 2" = ""))
})
}
shinyApp(ui, server)
I found the solution. Basically one can use the ready.jstree or loaded.jstree event:
library(shiny)
library(shinyTree)
library(shinyjs)
js_code <- "$('.shiny-tree').on('ready.jstree', function() {
$(this).jstree(true).settings.contextmenu = {
items: {
item1 : {
'label' : 'item1',
'action': function() { /* action */ }
}
}
};
})"
ui <- fluidPage(useShinyjs(),
actionButton("create", "Create Tree"),
shinyTree("mytree", contextmenu = TRUE))
server <- function(input, output, session) {
session$onFlushed(function() runjs(js_code))
output$mytree <- renderTree({
req(input$create)
list("Root Node" = list("Child Node 1" = list(
"Child Node 3" = "",
"Child Node 4" = ""),
"Child Node 2" = ""))
})
}
shinyApp(ui, server)
I am trying to call a JavaScript function from Shiny each time when a tab of the app is clicked. I need to send a tab name to custom js function. As the simplest option I call alert() function from R and transfer to it the name of a tab. For some reason my code doesn't work and a window with a message doesn't appear although I’ve replicated the example.
library(shiny)
library(shinydashboard)
library(shinyjs)
ui = dashboardPage(
dashboardHeader(title = "Shiny"),
dashboardSidebar(
sidebarMenu(id = "tabs",
menuItem("Section_1", tabName = "section_1", icon = icon("align-justify"),
startExpanded = TRUE, selected = TRUE,
menuSubItem("Subsection 1", tabName = "report_1", selected = TRUE),
menuSubItem("Subsection 2", tabName = "report_2")),
menuItem("Section_2", tabName = "section_2", icon = icon("align-justify"))
)
),
dashboardBody(
useShinyjs(),
tags$head(tags$script("Shiny.addCustomMessageHandler('handler1', alert(tab_name))")),
tabItems(
tabItem("report_1", h1(id = "a", "a")),
tabItem("report_2", h1(id = "b", "b")),
tabItem("section_2", h1(id = "c", "c")))
)
)
server <- function(input, output, session) {
observe({
if(input$tabs == "report_1") {
print(input$tabs)
tab_name = as.character(input$tabs)
session$sendCustomMessage(type = "handler1", tab_name)
} else if(input$tabs == "report_2"){
print(input$tabs)
tab_name = as.character(input$tabs)
session$sendCustomMessage(type = "handler1", tab_name)
} else if (input$tabs == "section_2"){
print(input$tabs)
tab_name = as.character(input$tabs)
session$sendCustomMessage(type = "handler1", tab_name)
}
})
}
shinyApp(ui=ui, server=server)
Write a function inside the addCustomMessageHandler like so:
library(shiny)
library(shinydashboard)
library(shinyjs)
ui = dashboardPage(
dashboardHeader(title = "Shiny"),
dashboardSidebar(
sidebarMenu(id = "tabs",
menuItem("Section_1", tabName = "section_1", icon = icon("align-justify"),
startExpanded = TRUE, selected = TRUE,
menuSubItem("Subsection 1", tabName = "report_1", selected = TRUE),
menuSubItem("Subsection 2", tabName = "report_2")),
menuItem("Section_2", tabName = "section_2", icon = icon("align-justify"))
)
),
dashboardBody(
useShinyjs(),
tags$head(tags$script('Shiny.addCustomMessageHandler("handler1", function(message) {
alert(JSON.stringify(message));
})')),
tabItems(
tabItem("report_1", h1(id = "a", "a")),
tabItem("report_2", h1(id = "b", "b")),
tabItem("section_2", h1(id = "c", "c")))
)
)
server <- function(input, output, session) {
observe({
if(input$tabs == "report_1") {
print(input$tabs)
tab_name = as.character(input$tabs)
session$sendCustomMessage(type = "handler1", tab_name)
} else if(input$tabs == "report_2"){
print(input$tabs)
tab_name = as.character(input$tabs)
session$sendCustomMessage(type = "handler1", tab_name)
} else if (input$tabs == "section_2"){
print(input$tabs)
tab_name = as.character(input$tabs)
session$sendCustomMessage(type = "handler1", tab_name)
}
})
}
shinyApp(ui=ui, server=server)