Develop Reference

R shiny DT hover how to report NULL when mouse is moved off the table

Related to R shiny DT hover shows detailed table
I've been working on an application where I would like to display some text as a user mouses over a table.
I've been working with a modified version of the example from the above link, but there's one hang-up.
Is there a way to have input[["cell"]] revert to NULL in the case where the user moves the mouse outside the table? With the current implementation it reports the last value the mouse touched before departure.
library(shiny)
library(DT)
data(mpg, package = "ggplot2")
callback <- c(
"table.on('mouseover', 'td', function(){",
" var index = table.cell(this).index();",
" Shiny.setInputValue('cell', index, {priority: 'event'});",
"});"
)
ui <- fluidPage(
br(),
DTOutput("tbl"),
htmlOutput("msg")
)
server <- function(input, output, session){
dat <- mpg
output[["tbl"]] <- renderDT({
datatable(
dat,
callback = JS(callback)
)
})
output[["tblfiltered"]] <- renderDT({
datatable(
filteredData(),
fillContainer = TRUE,
options = list(
pageLength = 5
)
)
})
output$msg <- renderText(paste(input[["cell"]], collapse = ","))
}
shinyApp(ui, server)

Thanks to Stéphane Laurent for the help
Amended the callback as follows
callback <- c(
"table.on('mouseover', 'td', function(){",
" var index = table.cell(this).index();",
" Shiny.setInputValue('cell', index, {priority: 'event'});",
"});,
table.on('mouseout', 'td', function(){",
" Shiny.setInputValue('cell', null, {priority: 'event'});",
"});
"
)

In Shiny click event is not working when using modules

why when Im using modules the clickable feature in my highchart treemap is not working.
I tried this without module and worked well.
Probably is something related no namespace, right , but I can not find what it it.
Any help ?
This is my code:
library(shiny)
library(highcharter)
library(gapminder)
library(shinyjs)
source(file = 'module_ex_2.R')
ui <- fluidPage(
mod_ex2_UI('ex1')
)
server <- function(input, output){
mod_ex2_Server('ex1')
}
shinyApp(ui, server)
My module file:
mod_ex2_UI <- function(id) {
ns <- NS(id)
tagList(
highchartOutput(ns("hcontainer")),
htmlOutput(ns("clicked"))
)
}
mod_ex2_Server <- function(id) {
moduleServer(
id,
function(input, output, session) {
click_js <- JS("function(event) {Shiny.onInputChange('treemapclick', event.point.name);}")
output$hcontainer <- renderHighchart({
gapminder::gapminder %>%
dplyr::filter(year == 2007) %>%
highcharter::data_to_hierarchical(group_vars = c(continent, country), size_var = pop) %>%
hchart(type = "treemap") %>%
hc_plotOptions(treemap = list(events = list(click = click_js)))
})
output$clicked <- renderUI({
if(is.null(input$treemapclick)){
reactable::reactable(data =gapminder::gapminder %>%
dplyr::filter(year == 2007) %>%
dplyr::filter(country == 'China'))
}else{
reactable::reactable(data =gapminder::gapminder %>%
dplyr::filter(year == 2007) %>%
dplyr::filter(country == input$treemapclick))
}
})
}
)
}
Thanks any help would be amazing.

You need to append the namespace to your custom event like so:
click_js <- JS(
glue::glue("function(event) {{
Shiny.setInputValue('{NS(id)('treemapclick')}',
event.point.name);
}}"
)
)
N.B. onInputChange is the older name for setInputValue and the latter is more verbose (cf. to this Shiny article)

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.

R Shiny: Check a Regular expression in textInput on UI

Is this possible when a user input something on textInput to against a regular expression and give a warning.
Such that the textInput area expects: [1-5]GH[0-9]
But when the input is: 5UK8
The warning should be: Check your input
I think this can be done using JS inside UI, but is there any Shiny trick? Or if you can help with a java script.
ui <- fluidPage(
textInput("id", "Enter your ID",),
verbatimTextOutput("value")
)
server <- function(input, output) {
output$value <- renderText({ input$id })
}
shinyApp(ui, server)

Maybe with shinyFeedback ?
library(shiny)
library(shinyFeedback)
ui <- fluidPage(
useShinyFeedback(),
textInput("id", "Enter your ID",),
verbatimTextOutput("value")
)
server <- function(input, output) {
observeEvent(input$id, {
feedbackWarning(
"id",
condition = !grepl("[1-5]GH[0-9]", input$id)
)
})
output$value <- renderText({ input$id })
}
shinyApp(ui, server)

sendCustomMessage does not work properly in actionButton (Shiny)

I am testing the script from here http://shiny.rstudio.com/articles/action-buttons.html (see the section "Pattern 1 - Command").
If to press the button "Click me" on the site so everything is Ok - we can see the popup menu.
But if to copy the example script into new .R file and run it - no popup message appeared, no warning or errror message is generated (my brouser is Google Chrome). So I am stalled with it.
The example script:
library(shiny)
ui <- fluidPage(
tags$head(tags$script(src = "message-handler.js")),
actionButton("do", "Click Me")
)
server <- function(input, output, session) {
observeEvent(input$do, {
session$sendCustomMessage(type = 'testmessage',
message = 'Thank you for clicking')
})
}
shinyApp(ui, server)

This should work, I gave two examples of pop-up alerts
1) With standard js alert
rm(list = ls())
library(shiny)
ui <- fluidPage(
tags$head(tags$script(HTML('Shiny.addCustomMessageHandler("jsCode",function(message) {eval(message.value);});'))),
actionButton("do", "Click Me")
)
server <- function(input, output, session) {
observeEvent(input$do, {
js_string <- 'alert("Thank you for clicking");'
session$sendCustomMessage(type='jsCode', list(value = js_string))
})
}
shinyApp(ui, server)
2) Using shinyBS package and modal pop-up
rm(list = ls())
library(shiny)
library(shinyBS)
ui <- fluidPage(
tags$script(HTML('Shiny.addCustomMessageHandler("jsCode",function(message) {eval(message.value);});')),
bsModal("ThankYou", "Message", "",tags$p(tags$h1("Thank you for clicking", style = "color:red", align = "center")), size = "small"),
actionButton("do", "Click Me")
)
server <- function(input, output, session) {
observeEvent(input$do, {
activate_modal <- "$('#ThankYou').modal('show')"
session$sendCustomMessage(type='jsCode', list(value = activate_modal))
})
}
shinyApp(ui, server)