Develop Reference

R Shiny communicate column sizes between R and Javascript with colResize

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)

Vectors of latitude and longitude in geolocation app in shiny

I am building and app, that includes geolocation captures using the geoloc package
This is an example app:
library(shiny)
library(leaflet)
library(geoloc)
ui <- fluidPage(
h2("Where Am I?"),
tags$p("Click the button to get your location"),
geoloc::button_geoloc("myBtn", "Get my Location"),
tags$br(),
textOutput("coords"),
textOutput("col"),
leafletOutput("lf")
)
server <- function(input, output) {
output$coords <- renderText(paste(input$myBtn_lat, input$myBtn_lon, sep = ", "))
Lats <- reactiveValues(Lat = NULL)
observeEvent(input$myBtn_lat, {
Lats$Lat <- append(Lats$Lat, input$myBtn_lat)
})
output$col <- renderText({
Lats$Lat
})
output$lf <- renderLeaflet({
req(input$myBtn_lon)
req(input$myBtn_lat)
leaflet() %>%
addTiles() %>%
setView(as.numeric(input$myBtn_lon), as.numeric(input$myBtn_lat), zoom = 17) %>%
addMarkers(as.numeric(input$myBtn_lon), as.numeric(input$myBtn_lat), label = "You're here!")
})
}
shinyApp(ui, server)
I have two questions for this:
How to get a vector of latitudes and longitudes with the button
I need this because usually, we like to take 4 or 5 times the location and then use the median.
This has been addressed in this question, however, there are some kinks I can't figure out since the button is a custom one, and the inputs are not input$myBtn, but input$myBtn_lat and input$myBtn_lon, I find it hard to compute. This is what I am trying to do with the observe events
How to transform this into shiny modules
This will go to a larger shiny app, so I would love to generate modules for this, but again, the facto that the input in ui is "myBtn", but then in the server I have 2 inputs (MyBtn_lon and MyBtn_lat), make it very hard to figure out
Any help is welcome

How about the following code with Shiny modules? I tested and it worked.
library(shiny)
library(leaflet)
library(geoloc)
mapUI <- function(id, label = "Location in map"){
ns <- NS(id)
tagList(
geoloc::button_geoloc(ns("myBtn"), "Get my Location"),
tags$br(),
textOutput(ns("coords")),
textOutput(ns("col")),
textOutput(ns("md")), # for median latitude
leafletOutput(ns("lf"))
)
}
mapServer <- function(id){
moduleServer(
id,
function(input, output, session){
output$coords <- renderText(paste(input$myBtn_lat, input$myBtn_lon, sep = ", "))
Lats <- reactiveValues(Lat = NULL)
observeEvent(input$myBtn, {
Lats$Lat <- c(Lats$Lat, input$myBtn_lat)
})
output$col <- renderText({
Lats$Lat
})
# add median latitude
output$md <- renderText({
req(input$myBtn_lat)
if(length(Lats$Lat) %% 5 == 0){
paste0("Median latitute is: ", median(Lats$Lat))
}
})
output$lf <- renderLeaflet({
req(input$myBtn_lon)
req(input$myBtn_lat)
leaflet() %>%
addTiles() %>%
setView(as.numeric(input$myBtn_lon), as.numeric(input$myBtn_lat), zoom = 17) %>%
addMarkers(as.numeric(input$myBtn_lon), as.numeric(input$myBtn_lat), label = "You're here!")
})
}
)
}
ui <- fluidPage(
h2("Where Am I?"),
tags$p("Click the button to get your location"),
mapUI("map1")
)
server <- function(input, output, session) {
mapServer("map1")
}
shinyApp(ui, server)

You should click "myBtn", not "myBtn_lat". So try change observeEvent(input$myBtn_lat to observeEvent(input$myBtn.
In addition, what is the purpose to take 4 or 5 times the location? The coordinates do not change or change very little every time you click the button.

Trigger a reaction after change of textOutput() in shiny

I am trying to use JohnCoene/marker package to highlight sections of text in a shiny app. My intend is to first generate the text using some server logic and display it with textOutput. However, I am struggeling with how to trigger the marker after the text appeared on the website. Putting it in the same observeEvent() does not work.
Here is my reprex
# remotes::install_github("johncoene/marker")
library(shiny)
library(marker)
ui <- fluidPage(
use_marker(),
actionButton("click", "click"),
textOutput("text_to_mark")
)
server <- function(input, output) {
observeEvent(input$click,
{
output$text <- renderText("My house is yellow")
})
# observeEvent() below does not work. This is just for illustration
observeEvent(input$text_to_mark,
{
marker <- marker$new("#text_to_mark.shiny-text-output.shiny-bound-output")
marker$
unmark()$ # unmark all before we mark
mark("My house")
})
}
# Run the application
shinyApp(ui = ui, server = server)
Created on 2019-10-10 by the reprex package (v0.3.0)
For illustration: I can get the marker to work, by adding a second button as in the code below, but I am look for a solution where it gets triggered when the text appears.
# remotes::install_github("johncoene/marker")
library(shiny)
library(marker)
ui <- fluidPage(
use_marker(),
actionButton("click", "click"),
textOutput("text_to_mark"),
actionButton("mark", "Mark!")
)
server <- function(input, output) {
observeEvent(input$click,
{
output$text_to_mark <- renderText("My house is yellow")
})
observeEvent(input$mark,
{
marker <- marker$new("#text_to_mark.shiny-text-output.shiny-bound-output")
marker$
unmark()$ # unmark all before we mark
mark("My house")
})
}
# Run the application
shinyApp(ui = ui, server = server)
Created on 2019-10-10 by the reprex package (v0.3.0)

You could listen on DOM changes with javascript: Is there a JavaScript / jQuery DOM change listener?.
When a change happens you can check if your target element has text:
hasText = document.getElementById("text_to_mark").innerHTML != ""
Note that i assume that your element has the id "text_to_mark".
The result you can "send to R" with
Shiny.onInputChange("hasText", hasText);
On the R side you will know if the element has text via listening on input$hasText.
So you can add:
observeEvent(input$hasText,{
...
})
The javascript you can add to your app with tags$script(jsCode) or use shinyjs.
A reproducible example:
library(shiny)
library(marker)
jsCode <- '
MutationObserver = window.MutationObserver || window.WebKitMutationObserver;
var observer = new MutationObserver(function(mutations, observer) {
console.log(mutations, observer);
hasText = document.getElementById("text_to_mark").innerHTML != ""
Shiny.onInputChange("hasText", hasText);
});
observer.observe(document, {
subtree: true,
attributes: true
});
'
ui <- fluidPage(
use_marker(),
tags$script(jsCode),
actionButton("click", "click"),
textOutput("text_to_mark"),
actionButton("mark", "Mark!")
)
server <- function(input, output) {
observeEvent(input$click, {
output$text_to_mark <- renderText("My house is yellow")
})
observeEvent(input$hasText,{
marker <- marker$new("#text_to_mark.shiny-text-output.shiny-bound-output")
marker$
unmark()$ # unmark all before we mark
mark("My house")
})
}
# Run the application
shinyApp(ui = ui, server = server)
Note that this only works on the first appearance of the text. If you also want to listen for changes of the text, one could send the text to R instead and check on the R side if the text was updated. Not sure if it is needed here.

Listening on DOM changes is one option, but your approach already shows that there is a pure shiny (non-custom-JS) solution, it only takes one click more, so the question is how to do it with only one click. I suggest using invalidateLater and wrap it in an if statement to prevent it from running over and over again like seen here.
The trick is to run your marker calls in an observe statement. Include the invalidateLater here and wrap it in an if condition with a counter which counts how many times the statement has been executed. Play around with the number of milliseconds and counts, in my case it works fine with if(isolate(val$cnt) < 1) and invalidateLater(1000). Don't forget to wrap your counter in an isolate otherwise it will get stuck in a loop.
Note also that input$click not only writes the text into a reactiveValue but also resets the counter val$cnt to 0 so that you can use the invalidateLater again on a new text. The same procedure will help you if you want to update your text using an observeEvent or the like. Just make sure to also reset the counter to 0 and the highlighting works on your new text part.
# remotes::install_github("johncoene/marker")
library(shiny)
library(marker)
ui <- fluidPage(
use_marker(),
actionButton("click", "click"),
textOutput("text_to_mark")
)
server <- function(input, output) {
val <- reactiveValues(cnt = 0,
text = NULL)
observeEvent(input$click, {
val$text <- "My house is yellow"
val$cnt <- 0
})
observe({
if(isolate(val$cnt) < 1) {
invalidateLater(1000)
}
marker <- marker$new("#text_to_mark.shiny-text-output.shiny-bound-output")
marker$
unmark()$ # unmark all before we mark
mark("My house")
val$cnt = isolate(val$cnt) + 1
})
output$text_to_mark <-renderText({
val$text
})
}
# Run the application
shinyApp(ui = ui, server = server)

Making columns to be dynamic by adding checkboxe in Shiny

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)

Using external tooltip JS library with networkD3 and Shiny

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)