The idea
I have a box() in a shiny app. The box() includes a title argument (which in turn includes an icon) and a selectInput()element. On hoover over the icon I wanted to have a tooltip (using tipify()) or a popover (using popify()) which title or content argument (or both) would be generated depending on selectInput() input.
The problem
Neither tipify() nor popify() correcctly implement textOutput() as their title or content argument. They need a character string so I tried to use a reactiveValues() element as a function argument but it also failed.
The question
Can tooltip or popover content be made dynamic by just using r? How could this be done?
I suspect it can be done with JavaScript but I have little knowledge of it.
The code
Attempt 1 - failed - displays code not actual text
library("shiny")
library("shinydashboard")
library("shinyBS")
ui <- fluidPage(
box(
title = span("My box",
tipify(el = icon(name = "info-circle", lib = "font-awesome"), title = textOutput("TIP"))),
selectInput(
inputId = "SELECT",
label = NULL,
choices = c("Option1" = "Option1",
"Option2" = "Option2"
),
multiple = FALSE
)
)
)
server <- function(input, output, session){
output$TIP <- renderText({"Helo world!"})
}
shinyApp(ui, server)
Attempt 2 - failed - cannot create UI as TIP (reactiveValues()) is not yet defined
library("shiny")
library("shinydashboard")
library("shinyBS")
ui <- fluidPage(
box(
title = span("My box",
tipify(el = icon(name = "info-circle", lib = "font-awesome"), title = TIP$a)),
selectInput(
inputId = "SELECT",
label = NULL,
choices = c("Option1" = "Option1",
"Option2" = "Option2"
),
multiple = FALSE
)
)
)
server <- function(input, output, session){
TIP <- reactiveValues(a = "Hello world!")
}
shinyApp(ui, server)
Here is a similar question but it does not solve the problem described here.
What could be done is creating the title entirely in the server side. This way you have no problem making it dynamic. This could give you this kind of app:
library("shiny")
library("shinydashboard")
library("shinyBS")
ui <- fluidPage(
box(
title = uiOutput("title"),
selectInput(
inputId = "SELECT",
label = NULL,
choices = c("Option1" = "Option1",
"Option2" = "Option2"
),
multiple = FALSE
)
)
)
server <- function(input, output, session){
TIP <- reactiveValues()
observe({
TIP$a <- ifelse(input$SELECT =="Option1","Hello World","Hello Mars")
})
output$title <- renderUI({span("My box",
tipify(el = icon(name = "info-circle", lib = "font-awesome"), title = TIP$a))})
}
shinyApp(ui, server)
Hope it helps.
Related
I am using the fullPage package to create a Shiny App and I am facing the following issue : I would like to update from the server side the labels of the menu that are first defined in the pagePiling function of the ui part.
I have seen in the HTML code that the field that I should update is the one here below, but I don't know how to change it/access it in the server part of my app.
<ul id="tocMenu">
<li data-menuanchor="test_page">
temp_title
</li>
</ul>
I have the impression that this sould be achievable with javascript, but I don't know a lot about js ; among others, I have tried so far the following stuff :
library(fullPage)
library(shiny)
library(shinyjs)
library(shinyWidgets)
shinyApp(
ui = pagePiling(
shinyjs::useShinyjs(),
center = TRUE,
sections.color = c(
"#CFE2F3"
),
menu = c(
"temp_title" = "test_page"
),
pageSection(
menu="test_page",
pickerInput("title", multiple = F, selected=NULL,
choices = c("Title 1", "Title 2")),
)
),
server = function(input, output) {
observeEvent(input$title, {
# runjs("$('#fullpage').fullpage({
# anchors: ['test'],
# menu: '#tocMenu'});")
runjs(paste0('document.getElementById("test_page").innerHTML = "', input$title, '";'))
} )
}
)
If anyone could help, I would be very grateful !
Thanks
The problem is that you use getElementById() but the menu title doesn't have an id, it has an href tag:
Therefore, you should use querySelectorAll() instead and specify the characteristics of the element you want to select (here, it's an element a that has href="#test_page"). Finally, this function returns a list of elements (this list only contains 1 element here), so you need to use [0] to select it.
Here's your example fixed:
library(fullPage)
library(shiny)
library(shinyjs)
library(shinyWidgets)
shinyApp(
ui = pagePiling(
shinyjs::useShinyjs(),
center = TRUE,
sections.color = c(
"#CFE2F3"
),
menu = c(
"temp_title" = "test_page"
),
pageSection(
menu="test_page",
pickerInput("title", multiple = F, selected=NULL,
choices = c("Title 1", "Title 2")),
)
),
server = function(input, output) {
observeEvent(input$title, {
# runjs("$('#fullpage').fullpage({
# anchors: ['test'],
# menu: '#tocMenu'});")
runjs(paste0('document.querySelectorAll("a[href=\'#test_page\']")[0].innerHTML = "', input$title, '";'))
} )
}
)
I know there is this server side method called renderUI, but it makes updating the UI extremely slow in some cases, so I am now relying on the JavaScript.
My problem is a follows. I would like to update the title attribute of material_card from shinymaterial package. I would like to see the title to change, every time I select an alternative from a separate dropdown menu.
So far my list of UI components contain tags$script() object, which is supposed to observe the changes in the selectInput (goes with id "dropdown").
My code looks as follows:
library(shinymaterial)
library(shiny)
ui <- material_page(
titlePanel("Soon to be working JavaScript example!"),
sidebarLayout(
sidebarPanel(
selectInput(
"dropdown",
"Dropdown menu",
c('Hat','Shoes','Jacket')),
tags$script('
$(document).on("shiny:inputchanged", function(event) {
if (event.name === "dropdown") {
if(input.dropdown === "Jacket") {
//Even this alert is not working, possibly because input.name is not recognized. :(
alert("You chose Jacket, now the material card title will be changed to: Jacket selected");
//What am I supposed to put here to update the material_card title?
} else {
//...and here as well...
}
});'
),
material_card(
depth=5,
title = 'This value needs to be changed according what was chosen in the dropdown menu!')
),
mainPanel(
h5('Nothing here!')
)
)
)
server <- function(input, output) {
#The server is empty, as it should. :)
}
shinyApp(ui = ui, server = server)
I managed to get the alert working without the if(input.dropdown === "Jacket") validation, but this validation is not working: Most likely input.dropdown is not even recognized, although it works nicely with conditional panel.
Furthermore, I am even more lost with the logic: How should I actually use JavaScript to update the material_card title, after the change in selectInput (dropdown) value has been observed?
library(shinymaterial)
library(shiny)
ui <- material_page(
titlePanel("Soon to be working JavaScript example!"),
sidebarLayout(
sidebarPanel(
selectInput(
"dropdown",
"Dropdown menu",
c('Hat','Shoes','Jacket')),
tags$script(HTML('
$(document).on("shiny:inputchanged", function(event) {
if (event.name === "dropdown") {
if(event.value === "Jacket") {
alert("You chose Jacket, now the material card title will be changed to: Jacket selected");
$("#mycard>span.card-title").html("Here is the new card title");
} else {
//...and here as well...
}
}
});')
),
material_card(
depth=5,
title = 'This value needs to be changed according what was chosen in the dropdown menu!',
id = "mycard"
)
),
mainPanel(
h5('Nothing here!')
)
)
)
shinyApp(ui, server = function(input,output){})
A shiny UI-only solution:
library(shinymaterial)
library(shiny)
dropdownChoices <- c('Hat','Shoes','Jacket')
ui <- material_page(
titlePanel("Soon to be working JavaScript example!"),
sidebarLayout(
sidebarPanel(
selectInput(
"dropdown",
"Dropdown menu",
dropdownChoices),
material_card(
depth = 5,
title = lapply(dropdownChoices, function(i){
conditionalPanel(sprintf('input.dropdown == "%s"', i), i)
})
)),
mainPanel(
h5('Nothing here!')
)
)
)
server <- function(input, output) {}
shinyApp(ui = ui, server = server)
I've searched stackoverflow and the complete web, but I can't find to seem a good answer to this, seemingly simple, problem.
The situation is as follows:
I have a Shiny application, connected with a database
I have several user inputs (Pickerinputs), where a user can select multiple arguments
The user inputs are all dependent on each other
The problem that arises is the following:
If a user ticks multiple car brands (for example, Renault, Peugeot and BMW) then the pickerinput that is linked to this selection (specific car models for these brands) gets updated three times. With many pickerinputs that are linked to each other, this creates messy UX.
Solution needed
I think the solution is simple: the pickerinput only needs to send the selected values after the input has been closed; it does not need to send values (and trigger updates) after every pick a user makes. The AirdatePickerInput from Shinywidgets has this specific feature (update_on=c('change', 'close'). What I need is that my pickerInput gets updated only on 'close'. So that the resulting values are send only once back to the server.
Example:
UI
ui <- fluidPage(
# Title panel
fluidRow(
column(2,
wellPanel(
h3("Filters"),
uiOutput("picker_a"),
uiOutput("picker_b"),
)
),
)
)
Server
server <- function(input, output, session) {
# Start values for each filter
all_values_for_a <- tbl(conn, "table") %>%
distinct(a) %>%
collect()
all_values_for_b <- tbl(conn, "table") %>%
distinct(b) %>%
collect()
output$picker_a <- renderUI({
pickerInput(
inputId = "picker_a",
label = "a:",
choices = all_values_for_a,
selected = all_values_for_a,
multiple = TRUE,
options = list("live-search" = TRUE, "actions-box" = TRUE))
})
output$picker_b <- renderUI({
pickerInput(
inputId = "picker_b",
label = "b:",
choices = all_values_for_b,
selected = all_values_for_b,
multiple = TRUE,
options = list("live-search" = TRUE, "actions-box" = TRUE))
})
#I want this code to be executed ONLY when
#picker_a is closed, not everytime when the user
#picks an item in picker_a
observeEvent(
input$picker_a,
{
all_values_for_b <- tbl(conn, "table") %>%
filter(a %in% !!input$picker_a) %>%
distinct(b) %>%
collect()
updatePickerInput(session, "picker_b", choices = all_values_for_b, selected = all_values_for_b)
})
)
)
}
You can probably use an actionButton to delay the execution of the update once all values have been picked by the user.
Or use a debounce function, see this other post.
EDIT
The update_on = c("change", "close") feature was asked for the pickerInput widget to the shinyWidgets developer (Victor Perrier) on GitHub.
Victor's answer was:
there's no similar argument for pickerInput, but there's a special input to know if menu is open or not. So you can use an intermediate reactiveValue to achieve same result.
and he provided the following code:
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
fluidRow(
column(
width = 4,
pickerInput(
inputId = "ID",
label = "Select:",
choices = month.name,
multiple = TRUE
)
),
column(
width = 4,
"Immediate:",
verbatimTextOutput("value1"),
"Updated after close:",
verbatimTextOutput("value2")
),
column(
width = 4,
"Is picker open ?",
verbatimTextOutput("state")
)
)
)
server <- function(input, output) {
output$value1 <- renderPrint(input$ID)
output$value2 <- renderPrint(rv$ID_delayed)
output$state <- renderPrint(input$ID_open)
rv <- reactiveValues()
observeEvent(input$ID_open, {
if (!isTRUE(input$ID_open)) {
rv$ID_delayed <- input$ID
}
})
}
shinyApp(ui, server)
In your case you could try:
observeEvent(
input$picker_a_open,
{
if (!isTRUE(input$picker_a_open)) {
all_values_for_b <- tbl(conn, "table") %>%
filter(a %in% !!input$picker_a) %>%
distinct(b) %>%
collect()
updatePickerInput(session, "picker_b", choices = all_values_for_b, selected = all_values_for_b)
}
})
I've been trying to add a row (basically a row of check boxes) on my data table, so that users will be able to decide which column they like to keep/delete. And here is what my Shiny App looks like so far. Anyone who knows any hints please help!
Any help would be appreciated!
ui <- dashboardPage(dashboardHeader(disable = T),
dashboardSidebar(disable = T),
dashboardBody(uiOutput("MainBody")))
server <- shinyServer(function(input, output){
vals <- reactiveValues()
vals$data <- data.table(vals$Data<-data.table(
Brands=paste0("Brand",1:10),
Forecasted_Growth=sample(1:20,10),
Last_Year_Purchase=round(rnorm(10,1000,1000)^2),
Contact=paste0("Brand",1:10,"#email.com")
))
output$MainBody <- renderUI({
fluidPage(
box(width = 12,
h3(strong("Template"), align = "center"),
hr(),
column(6, offset = 6,
actionButton(inputId = "Del_Col", label = "Delete Select Column"))),
column(12, dataTableOutput("MainTable")),
tags$script()
)
})
I agree with Pork Chop that you should rethink your layout. I couldn't get my head around it so I reworked it into a minimal fluidpage.
The code below should get you close. It renders buttons (you could make these checkboxes though) directly into the table using a helper function described here. The code below uses these buttons to subset and update the dataframe which I term reactiveTable. Here's the functionality:
Good luck!
library(data.table)
library(DT)
## Nice helper function to make the buttons from:
## https://github.com/rstudio/DT/issues/178
shinyInput <- function(FUN, len, id, ...) {
inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))
}
inputs
}
## Basic UI with a reset button
ui <- fluidPage(
mainPanel(
h1('Table Subsetter'),
actionButton('reset', 'Reset!'),
DT::dataTableOutput('mytable')
)
)
server <- function(input, output){
#This is the table you provided in your question
tableA <- data.table(
Brands=paste0("Brand",1:10),
Forecasted_Growth=sample(1:20,10),
Last_Year_Purchase=round(rnorm(10,1000,1000)^2),
Contact=paste0("Brand",1:10,"#email.com")
)
#make a reactive value for the table and columns to delete
reactiveTable <- reactiveValues(tab=tableA)
columnToDelete <- reactiveValues(col=NULL)
#Logic to make the buttons, reruns everytime the table is updated
tableOut <- reactive({
buttons <- shinyInput(actionButton, length(reactiveTable$tab[1,]), 'button_', label = "Delete!", onclick = 'Shiny.onInputChange(\"select_button\", this.id)' )
buttons <- t(as.data.frame(buttons, stringsAsFactors = FALSE))
colnames(buttons) = colnames(reactiveTable$tab)
rbind(buttons, reactiveTable$tab)
})
#reset button replaces the table
observeEvent(input$reset, {
reactiveTable$tab <- tableA
})
#listener to for the delete button
observeEvent(input$select_button, {
columnToDelete$col <-as.numeric(strsplit(input$select_button, "_")[[1]][2])
reactiveTable$tab <- subset( reactiveTable$tab, select = -columnToDelete$col )
})
#output the table with DT. use escape=F so it renders the html
output$mytable <- DT::renderDataTable({
tableOut()
},server = FALSE, escape = FALSE, selection = 'none')
}
shinyApp(ui = ui, server = server)
I'm trying to display the value variables of nodes and links in a networkD3 forceNetwork diagram as tooltips. To do this, I am using Shiny with htmlwidgets and the external JS library Tippy.
Here is what I have so far:
library(shiny)
library(htmlwidgets)
library(networkD3)
fn <- forceNetwork(
Links = MisLinks, Nodes = MisNodes,
Source = "source", Target = "target",
Value = "value", NodeID = "name",
Group = "group", opacity = input$opacity)
tippyJS <- 'tippy(".node")'
server <- function(input, output) {
# Load data
data(MisLinks)
data(MisNodes)
# Append value variables to links and nodes in fn network
fn$x$links$value <- "links tooltips"
fn$x$nodes$value <- "nodes tooltips"
output$net <- renderForceNetwork(onRender(fn,
'
function(el, x) {
d3.selectAll(".node, .link").append("svg:title")
.text(function(d) { return d.value; });
}
'
)
)
}
ui <- fluidPage(
tags$head(tags$script(src="https://unpkg.com/tippy.js#2.0.2/dist/tippy.all.min.js")),
tags$script(tippyJS),
titlePanel("ForceNetD3"),
mainPanel(
forceNetworkOutput(outputId = "net")
)
)
shinyApp(ui = ui, server = server)
Tippy is supposed to take the title attribute of the .node class and convert it to a nicer-looking tooltip. I've added title tags to all of my nodes and links, loaded the Tippy library in the head tag of the underlying HTML page, and then called the Tippy function on all objects of the .node class in a separate script tag. Tippy doesn't seem to pick up on it: I continue to get default browser tooltips instead of Tippy tooltips.
There are multiple reasons why your example code doesn't work (some of which are completely unrelated to the topic of adding Tippy.js), but here's a working, modified version of your example...
library(shiny)
library(htmlwidgets)
library(networkD3)
# Load data
data(MisLinks)
data(MisNodes)
server <- function(input, output) {
output$net <- renderForceNetwork({
fn <- forceNetwork(
Links = MisLinks, Nodes = MisNodes,
Source = "source", Target = "target",
Value = "value", NodeID = "name",
Group = "group", opacity = 1)
# Append value variables to links and nodes in fn network
fn$x$links$value <- "links tooltips"
fn$x$nodes$value <- "nodes tooltips"
onRender(fn, 'function(el, x) {
d3.selectAll(".node circle, .link")
.attr("title", function(d) { return d.value; });
tippy("[title]");
}'
)
})
}
ui <- fluidPage(
tags$head(
tags$script(src = "https://unpkg.com/tippy.js#2.0.2/dist/tippy.all.min.js")
),
titlePanel("ForceNetD3"),
mainPanel(forceNetworkOutput("net"))
)
shinyApp(ui = ui, server = server)