Develop Reference

How to set the focus to the first row first column cell in a rhandsontable in an RShiny app?

I need to set focus on the first-row first-column cell of a rhandsontable in an RShiny app. Looking for a solution similar to the solutions discussed in this forum: Set the focus to a specific datagrid cell, QML: Set focus TextInput in a table cell, how to focus a table cell using javascript?, want to put the focus and edit the first cell of my dynamic table, etc. I need help with the renderer function to accomplish this.
library(shiny)
library(rhandsontable)
DF = data.frame(matrix(data = '', nrow = 5, ncol = 1, dimnames = list(seq(1:5),c("Barcode"))))
ui <- fluidPage(
titlePanel("Scan Sample Barcode"),
mainPanel(
rHandsontableOutput("scanBarcode")
)
)
server <- function(input, output) {
output$scanBarcode <- renderRHandsontable(rhandsontable(DF) %>%
hot_cols(renderer = "function(instance, td, row, col, prop, value, cellProperties)
{Handsontable.TextCell.renderer.apply(this, arguments);
if (col == 0 & row == 0 ) {td.focus();}")
)
}
shinyApp(ui = ui, server = server)

How about his:
library(htmlwidgets)
server <- function(input, output) {
output$scanBarcode <- renderRHandsontable(
rhandsontable(DF) %>%
onRender("function(el, x) {
let hot = this.hot;
hot.selectCell(0, 0);
hot.getActiveEditor().beginEditing();
}")
)
}
You use the handsontable API to select the cell (N.B. indices are zero based in JS) and then invoke the cell editor.
You place this JS code in the onRender function where you have a reference of the handsontable object being created.

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.

Prevent pickerInput from updating every time something is selected (R, Shiny)

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)
}
})

Actionbutton within DataTable doesn't work, Shiny DT

I am trying to create this shiny App with navigation panel. The first tab on navBar will be a summary table, in which I want to make the first column content clickable and navigate to its detail tab content. I already make the text as hyperlink, but I wonder how do I actually make the onClick navigation work.
_______________________Updating the Question______________________
So I made some updates according to suggestions I got. I just use the function actionLink(), combined with an ObserveEvent({updateNavPanel})
It seems the main question is that actionLink inside a DT table won't work, but outside it works fine. Maybe I just missing some callback functions to let it recognize buttons inside DT?
Below are the codes: Summary1 shows the action link that works, Summary2 shows the action link within DT that dones't work.
---
title: "Fruit Dashboard"
output:
flexdashboard::flex_dashboard:
orientation: columns
vertical_layout: fill
runtime: shiny
---
```{r global, include=FALSE, echo=FALSE}
# import libraries
library(DT)
library(shiny)
library(tidyverse)
library(shinythemes)
library(shinydashboard)
```
```{r, echo = FALSE}
shinyApp(
ui <- fluidPage(
titlePanel("Fruit Dashboard"),
theme = shinytheme("united"),
navlistPanel(id='nav', widths = c(2, 10),
tabPanel('Summary1', actionLink('apple', 'go to apple')),
tabPanel('Summary2', dataTableOutput('summary')),
tabPanel("apple", dataTableOutput('apple')),
tabPanel("orange", dataTableOutput('orange')),
tabPanel("watermelon", dataTableOutput('watermelon'))
)
),
server <- function(input, output, session) {
observeEvent(input$apple, {
updateNavlistPanel(session, "nav", 'apple')
})
output$summary <- renderDataTable({
data <- data.frame('Fruit' = c('apple', 'orange', 'watermelon'),
'Count' = c(3,4,5)) %>%
mutate(Fruit = paste0("<a id='", Fruit, "' hrep='#' class='action-button'>", Fruit, "</a>" ))
table <- datatable(data, escape = FALSE , selection = 'none')
table
})
output$apple <- renderDataTable({
data <- data.frame('Total#' = 3, 'Organic#'= 2, 'Conventional#'=1)
table <- datatable(data, escape = FALSE)
table
})
output$orange <- renderDataTable({
data <- data.frame('Total#' = 4, 'Organic#'= 3, 'Conventional#'=1)
table <- datatable(data, escape = FALSE)
table
})
output$watermelon <- renderDataTable({
data <- data.frame('Total#' = 5, 'Organic#'= 2, 'Conventional#'= 3)
table <- datatable(data, escape = FALSE)
table
})
}
)
```

Get inspired by the answer here: R Shiny: Handle Action Buttons in Data Table
I guess the key is to add the on.click parameter when creating actionLinks inside DT, so that click triggers event. And the on.click can also assign unique button id to the actionLink/button. Then in observeEvent, simply put the expression as input$selected_button. See full code below:
---
title: "Fruit Dashboard"
output:
flexdashboard::flex_dashboard:
orientation: columns
vertical_layout: fill
runtime: shiny
---
```{r global, include=FALSE, echo=FALSE}
# import libraries
library(DT)
library(shiny)
library(tidyverse)
library(shinythemes)
library(shinydashboard)
df <- data.frame('Fruit' = c('apple', 'orange', 'watermelon'),
'Count' = c(3,4,5))
shinyInput <- function(FUN, len, id, label, ...) {
inputs <- character(len)
for (i in seq_len(len)) {
label <- df$Fruit[i]
inputs[i] <- as.character(FUN(paste0(id, i),label=label, ...))
}
inputs
}
```
```{r, echo = FALSE}
shinyApp(
ui <- fluidPage(
titlePanel("Fruit Dashboard"),
theme = shinytheme("united"),
navlistPanel(id='nav', widths = c(2, 10),
tabPanel('Summary2', dataTableOutput('summary')),
tabPanel("apple", dataTableOutput('apple')),
tabPanel("orange", dataTableOutput('orange')),
tabPanel("watermelon", dataTableOutput('watermelon'))
)
),
server <- function(input, output, session) {
output$summary <- renderDataTable({
data <- df %>%
mutate(Fruit = shinyInput(actionLink, nrow(df), 'button_', label = Fruit, onclick = 'Shiny.onInputChange(\"select_button\", this.id)' ))
table <- datatable(data, escape = FALSE , selection = 'none')
table
})
observeEvent(input$select_button, {
selectedRow <- as.numeric(strsplit(input$select_button, "_")[[1]][2])
updateNavlistPanel(session, 'nav', df[selectedRow, 1])
})
output$apple <- renderDataTable({
data <- data.frame('Total#' = 3, 'Organic#'= 2, 'Conventional#'=1)
table <- datatable(data, escape = FALSE)
table
})
output$orange <- renderDataTable({
data <- data.frame('Total#' = 4, 'Organic#'= 3, 'Conventional#'=1)
table <- datatable(data, escape = FALSE)
table
})
output$watermelon <- renderDataTable({
data <- data.frame('Total#' = 5, 'Organic#'= 2, 'Conventional#'= 3)
table <- datatable(data, escape = FALSE)
table
})
}
)
```