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)
Related
I'm trying to render some UI elements in Shiny on the client side using Javascript. I want the user to click a button which reveals a hidden panel. Once the panel is revealed, it should show a plot. When the button is clicked the panel becomes visible but the plot doesn't render.
I know this behaviour is achievable using server-side functions like observeEvent but the goal here is to leverage the client directly via JS.
Below is a reprex. For ease, I've inlined the JS and CSS.
library(shiny)
# Inline js to toggle display of element when button is clicked
js <- '
$(document).ready(function() {
document.getElementById("reveal").addEventListener("click", event => {
var panel = document.getElementById("init-hidden-panel");
panel.style.display = "block";
});
})
'
ui <- fluidPage(
tags$script(HTML(js)),
actionButton("reveal", "Reveal"),
div(
id = "init-hidden-panel",
plotOutput("plot"),
style = "display: none; background-color: darkgray" # initialize element as hidden
)
)
server <- function(input, output) {
output$plot <- renderPlot({
hist(iris$Sepal.Length)
})
}
# Run the application
shinyApp(ui = ui, server = server)
We can tell that the JS is in fact toggling the display because the gray background appears.
Perhaps you can use this method:
ui <- fluidPage(
actionButton("reveal", "Reveal"),
plotOutput("plot")
)
server <- function(input, output) {
plot_data <- reactiveValues(trigger = 0)
observe({
req(input$reveal)
isolate(plot_data$trigger <- plot_data$trigger + 1)
})
output$plot <- renderPlot({
input$reveal
if (plot_data$trigger %% 2 == 0) {
return(NULL)
} else {
hist(iris$Sepal.Length)
}
})
}
# Run the application
shinyApp(ui = ui, server = server)
I'm using this plugin to enable manual column resizing for the DataTables in R Shiny. Now I would like to save the column width state after the user resized the table. For this I would like to communicate the change into a Shiny input variable. However I am quite new to Javascript and jQuery which means I don't understand the instructions on the Github page. So I would like to ask how to achieve this.
library(shiny)
library(DT)
library(htmltools)
dep <- htmlDependency(
name = "colResize",
version = "1.6.1",
src = normalizePath("colResize"),
script = "jquery.dataTables.colResize.js",
stylesheet = "jquery.dataTables.colResize.css",
all_files = FALSE
)
js <- c(
"function(column, columns){",
" Shiny.setInputValue('colwidth', column);",
"}"
)
dat <- head(iris, 6)
ui <- fluidPage(
br(),
fluidRow(
column(
width = 8,
DTOutput("dtable")
),
column(
width = 4,
verbatimTextOutput("columnWidth")
)
)
)
server <- function(input, output, session){
output[["dtable"]] <- renderDT({
dtable <- datatable(
dat,
options = list(
colResize = list(
onResizeEnd = JS(js)
)
)
)
deps <- dtable[["dependencies"]]
deps <- c(deps, list(dep))
dtable[["dependencies"]] <- deps
dtable
})
output[["columnWidth"]] <- renderPrint({
input[["colwidth"]]
})
}
shinyApp(ui, server)
I'm currently trying to use a googlelayer as a base layer for a leaflet map in shiny R, that's why I've been using shinyJs in order to insert a Js script into my R code in order to insert a map, the thing is that I don't manage to access the map outside of the Javascript code, and if I look up to the Js console, it says that "the map container has already been initialized". I provide you the code of the app as a reproducible science.
###################
#### Library ######
###################
library(leaflet)
library(shiny)
library(shinythemes)
library(shinyjs)
#library(raster)
###################
setwd("D:\\R")
ui <- fluidPage(
tags$head(
tags$link(rel="stylesheet", href="https://unpkg.com/leaflet#1.0.3/dist/leaflet.css"),
tags$script(src="shared/shiny.js"),
tags$script(src="https://maps.googleapis.com/maps/api/js?key=AIzaSyAQvaBc5_RruTllCvOxy3i9YNFYlaDzaJ8"),
tags$script(src="https://unpkg.com/leaflet#1.0.3/dist/leaflet.js"),
tags$script(src='https://unpkg.com/leaflet.gridlayer.googlemutant#latest/Leaflet.GoogleMutant.js')
),
sidebarLayout(
sidebarPanel(
actionButton(inputId = "button",
label = "coucou")
),
mainPanel(
leafletOutput("mymap")
)
#)
),
tags$script(HTML('$(document).on("shiny:connected", function(){
var mymap = L.map("mymap").setView([45.777222,3.087025],4);
var roads = L.gridLayer.googleMutant({type : "satellite"}).addTo(mymap);
var el = document.getElementById(mymap.id);
Shiny.onInputChange("mymap",el);
})'))
)
server <- function(input, output) {
# output$mymap <- renderLeaflet({
# leaflet() %>%
# setView(-1.252441, 47.802332, 4)
# })
# jean <- reactive(input$el)
#print(output$mymap)
observeEvent(input$button, {
output$mymap <- renderLeaflet({
leafletProxy("mymap", data =input$mymap) %>%
addMarkers(45.777222,
3.087025,
"btn")
})
})
observeEvent(input$mymap_click, {
cat("vroum")
})
}
shinyApp(ui = ui, server = server)
You can plot a Google Map directly using my googleway package
library(shiny)
library(googleway)
ui <- fluidPage(
google_mapOutput(outputId = "map", height = 600)
)
server <- function(input, output){
output$map <- renderGoogle_map({
google_map(key = 'your_api_key')
})
observeEvent(input$map_map_click, {
print(input$map_map_click)
})
}
shinyApp(ui, server)
To answer your question, you can access the map using the following code:
var el = document.getElementById("mymap");
var map = $(el).data("leaflet-map"));
But this doesn't get you to add the google layer as you need leaflet version 1.0.3 and the R package uses version 0.7 and you can't just load the version 1.0.3 as you did because it will raise come compatibility issues with the R package.
I'm trying to do the same but I found nothing so far. If you managed to do it, I would be very happy to know how.
I am trying append a reactive text (the color name from selectInput) to the body of a shiny app after tags$h3. I guess this is more a jquery issue, but right now it keeps adding the selected color rather than displaying the string "reactively".
What I would like instead is to have the string inside h3.colorLabel to be replaced.
ui.R
library(shiny)
jsCode <- "shinyjs.pageCol = function(params){
$('body').css('background', params);
/*$('.colorName').after('<h3></h3>').addClass('colorLabel');
$('h3.colorLabel').replaceWith('<h3>'+params+'</h3>').addClass('colorLabel');
*/
$('h3.colorName').after('<h3>'+params+'</h3>').addClass('colorLabel');
};
"
shinyUI( fluidPage(
useShinyjs(),
extendShinyjs(text = jsCode),
selectInput("col", "Colour:",
c("white", "yellow", "red", "blue", "purple")),
tags$h3('Just in case you are color-blind, the background color is:', class='colorName')
))
server.R
library(shiny)
library(shinyjs)
shinyServer(
function(input,output,session) {
observeEvent(input$col, {
js$pageCol(input$col)
})
})
I think this is what you want. It edits the innerhtml of the h3' element with thecolorLabel` class. I also added a corresponding empty initialized element to the ui code so there would be something to edit.
library(shiny)
library(shinyjs)
jsCode <- "shinyjs.pageCol = function(params){
$('body').css('background', params);
$('h3.colorLabel').text(params);
};
"
u <- shinyUI(fluidPage(
useShinyjs(),
extendShinyjs(text = jsCode),
selectInput("col","Colour:",
c("white","yellow","red","blue","purple")),
tags$h3('Just in case you are color-blind, the background color is:',class ='colorName'),
tags$h3('',class = 'colorLabel')
))
s <- shinyServer(
function(input,output,session) {
observeEvent(input$col, {
js$pageCol(input$col)
})
})
shinyApp(ui = u,server = s)
yielding:
And this is what is being edited internally:
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.