Is there any way to click an element in a dataTableOutput and then jump to a different tabPanel?
I know using escape = FALSE could add url to the table element. But how to add "jumping to a different tab" to a dataTableOutput element? And passing values?
Please take a look at my reproducible example. Thanks.
library(shiny)
server <- function(input, output) {
X = data.frame(
ID = c(
"<a href = 'http://www.google.com'> google </a>",
"Click here then Jump to tab2 and pass x=2 and y=2 to tab2",
"Click here then Jump to tab2 and pass x=3 and y=4 to tab2"
),
x = c(1, 2, 3),
y = c(10, 2, 4)
)
output$datatable = renderDataTable({X}, escape = FALSE,
options = list(
paging = FALSE,
searching = FALSE,
filtering = FALSE,
ordering = FALSE
))
output$text = renderText(paste("X = ", "Y = "))
}
ui <- fluidPage(tabsetPanel(
tabPanel("tab1", dataTableOutput("datatable")),
tabPanel("tab2", textOutput("text"))
))
shinyApp(ui = ui, server = server)
Luckily, there is no need for JS, or jQuery, since all those things can be done on Shinyserver side.
Okay, where do we start... DT has an inbuild callback feature to acess which rows/columns/cells were clicked by the user. See example here. Then there is no reason to "send" this information to tab2, but we can just do with this information what we wanted to. Like setting the text in tab2 appropriately. In order to change tabs, shiny has the updateTabsetPanel function that lets you change tabs without any hyperlinks.
Kind of a changelog:
insertet the observeEvent for functionality.
added selected and server attribute to get a single row callback
added Id to tabsetPanel to enable communication.
got rid of the google link and escape.
Code:
library(shiny)
library(DT)
server <- function(input, output, session) {
X = data.frame(
ID = c("Click here then Jump to tab2 and pass x=1 and y=10 to tab2",
"Click here then Jump to tab2 and pass x=2 and y=2 to tab2",
"Click here then Jump to tab2 and pass x=3 and y=4 to tab2"),
x = c(1,2,3),
y = c(10,2,4)
)
output$datatable = renderDataTable({X}, selection = "single", server = FALSE,
options = list(paging=FALSE,
searching=FALSE,
filtering=FALSE,
ordering=FALSE)
)
observeEvent(input$datatable_rows_selected, {
row <- input$datatable_rows_selected
output$text <- renderText({paste("X =", X[row, "x"], "Y =", X[row, "y"])})
updateTabsetPanel(session, "mainPanel", selected = "tab2")
})
}
ui <- fluidPage(
tabsetPanel(id = "mainPanel",
tabPanel("tab1",dataTableOutput("datatable")),
tabPanel("tab2",textOutput("text"))
)
)
shinyApp(ui = ui, server = server)
Related
I am building a R Shiny App with the package fullPage ; I would like to have in the header (=appearing on all pages) a pickerInput that allows the user to select the language.
Could anyone help to achieve this ?
What I was able to do, is only to have this element on the 1st page, but I would like to have it on all pages, ideally in the header, at the same level as the ''menu'' (next to ''First'' and ''Second'' in the minimal example here below).
library(shiny)
library(fullPage)
ui <- fullPage(
menu=c("First"="first",
"Second" ="second"),
fullSection(
menu = "first",
center = TRUE,
pickerInput(
inputId = "lang_select",
label = "Language",
choices = c("ENG", "FR"),
options = list(
style = "btn-primary")
),
h1("Callbacks")
),
fullSection(
menu = "second",
center = TRUE,
h3("Slice"),
verbatimTextOutput("slide")
)
)
server <- function(input, output){
}
shinyApp(ui, server)
In running the below code, each click of the actionButton() is correctly counted and output to the UI (using reactive value y). I'm trying to do the same with selectInput() (counting each time a selection is made)(using reactive value x), but it doesn't completely correctly count because when first invoking the App, selecting the default choice of "Cyl" is not included in the count (I'd like it to), and clicking the same choice more than once isn't included in the count (I'd like all clicks counted). One workaround is to include "multiple = TRUE" in the selectInput(), but I'd like to see if there's a JS solution instead so I don't have to change the UI the way including "multiple = TRUE" does.
As an aside, using "multiple = TRUE" also corrects the weird subtraction of 1 from (x) in output$clickSelInput...; hopefully a JS solution does the same.
Code:
library(shiny)
ui = fluidPage(hr(),
selectInput("selInput",label=NULL,c("Cyl"="cyl","Trans"="am","Gears"="gear"),selected=NULL),
actionButton("addBtn","Add"), hr(),
textOutput("clickSelInput"),
textOutput("clickAddBtn"),
tableOutput("data")
)
server = function(input, output) {
x = reactiveVal(0)
y = reactiveVal(0)
output$data <- renderTable({mtcars[1:10, c("mpg", input$selInput), drop = FALSE]})
observeEvent(input$selInput,{x(x()+1)})
observeEvent(input$addBtn,{y(y()+1)})
output$clickSelInput <- renderText({paste('Select Input clicks =',x()-1)})
output$clickAddBtn <- renderText({paste('Add Button clicks =',y())})
}
shinyApp(ui, server)
Here is a working solution, taking SamR's suggestion into account and using that example by analogy. I had to make other changes to make it work. I commented changes below from OP.
library(shiny)
library(shinyjs) # added
ui = fluidPage(hr(),
useShinyjs(), # added, this line is easy to forget to add
uiOutput("selInput"), # added, pulls renderUI output from server into UI
actionButton("addBtn","Add"), hr(),
textOutput("clickSelInput"),
textOutput("clickAddBtn"),
tableOutput("data")
)
server = function(input, output) {
x = reactiveVal(0)
y = reactiveVal(0)
output$data <- renderTable({mtcars[1:10, c("mpg", input$selInput), drop = FALSE]})
observeEvent(input$addBtn,{y(y()+1)})
# moved select input into renderUI so it can interact with JS in the observe further down:
output$selInput <- renderUI(
selectInput("selInput",label=NULL,c("Cyl"="cyl","Trans"="am","Gears"="gear"),selected=NULL)
)
output$clickSelInput <- renderText({paste('Select Input clicks =',input$rnd)}) # changed
output$clickAddBtn <- renderText({paste('Add Button clicks =',y())})
# added js:
observe({
if(is.null(input$rnd)){
runjs("
var click = 0;
Shiny.onInputChange('rnd', click)
var selInput = document.getElementById('selInput')
selInput.onclick = function() {click += 1; Shiny.onInputChange('rnd', click)};
")
}
})
}
shinyApp(ui, server)
I have a problem with this application, containing a javascript file for the user-interface part, which enables more tabs. However, the server part doesn't work when we have included the javascript file. I have a simple reactivity regarding the mtcars dataset here to showcase the problem. when I disable the "includeScript("script.js")", by merely put the # in front of it, the app works, so the problem is connected to this part. So my question would be, How can I fix this issue and also keep the javascript part in the shiny app.
Grateful for all your help.
Edit:
Now I have replaced includeScript("script.js") with tags$head(tags$script(src="./script.js")), and it appears to work, but with an extremely slow reactivity, I have to wait almost 1-2 min before seeing something. Any suggestion, or do you also experience this ?
library(shiny)
library(shinythemes)
library(shinymanager)
library(dplyr)
script.js
$(document).ready(function(){
$('.dropdown').on('click', function(e){
$(this).toggleClass('open');
e.stopPropagation();
e.preventDefault();
});
$('[data-toggle=tab]').on('click', function(e){
let dv = ($(this).attr('data-value'));
//Set active element in tabcontents
$('.tab-pane').removeClass('active');
$('.tab-pane[data-value="' + dv + '"]').addClass('active');
//Set active element in navbar
$('a[data-toggle=tab]').parent().removeClass('active');
$('a[data-value="' + dv + '"]').parent().addClass("active");
//Close the dropdowns
$('.dropdown').removeClass('open');
e.stopPropagation();
e.preventDefault();
});
});
Credentials
credentials <- data.frame(
user = c("Jhon", "Erik"), # mandatory
password = c("1", "1"), # mandatory
start = c("2022-02-14"), # optinal (all others)
expire = c(NA, "2022-12-31"),
admin = c(TRUE, TRUE),
comment = "Model Performance application",
stringsAsFactors = FALSE
)
Ui
ui <- fluidPage(
includeScript("script.js"),
navbarPage("Shiny",
collapsible = TRUE,
theme = shinytheme('yeti'),
tabPanel("Information" ,icon = icon("info"),
tags$h2("Information about the current user"),
verbatimTextOutput("auth_output")
),
tabPanel("Simulation 1",
tags$h2("Simulation"),
tags$hr(),
selectInput("vars", "Variables", names(mtcars), multiple = T),
tableOutput("data")
),
tabPanel("Upload",icon = icon("upload"),
tags$h2("Upload datasets"),
tags$hr(),
),
tabPanel("Simulation 2",
tags$h2("Simulation"),
tags$hr()
),
navbarMenu("Statistical outputs",
tabPanel("One"
),
tabPanel("Two"
),
tabPanel("Three"
),
tabPanel("Four"
),
tabPanel("Report"
),
navbarMenu("More",
tabPanel("Statistical", icon = icon("info")
),
tabPanel("Info",
icon = icon("info-circle")
),
tabPanel("Subpart 4", "Subpart 4"),
tabPanel("Subpart 5", "Subpart 5")
)
)
)
)
Wrap your UI with secure_app
ui <- secure_app(ui)
Server
server <- function(input, output, session) {
# call the server part
# check_credentials returns a function to authenticate users
res_auth <- secure_server(
check_credentials = check_credentials(credentials)
)
output$auth_output <- renderPrint({
reactiveValuesToList(res_auth)
})
output$data <-renderTable({
req(input$vars)
mtcars %>% select(all_of(input$vars))
})
}
shiny::shinyApp(ui, server)
Update:
Most important in addition to 1. and 2. from the first answer. The app works as desired only if split in ui and server part!
It seems that the server part is not working but after clicking on Statistical outputs the table appears!
First answer:
Put your script.js into a www folder. This should be in the same folder where your app is.
Change includeScript("script.js"), in ui part with tags$head(tags$script(src="script.js")),
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.
Using a ShinyR and data table we can create an interactive plot. When a user select a row in the data table it displayed with specific color and shape in the graph. When we un-select the row, point gain normal conditions.
Example modified from (Shiny apps).
Additionally, we can identify particular points (we are interested in) on the graph (Using nearPoints)
I would like a user to be able un-select the row by clicking on particular point on the graph. Once user clicked the point on the graph it will gain normal appearance.
However, I can’t find function to make it work.
There is a proxy and selectRows function in new DT library (the DT-package)(but for Mac it is unavailable). Example
Another option would be to write and option javascript code in callback, however my knowledge is limited in that area.
Will be thankful for any comments and suggestions.
UI
library(shiny)
library(DT)
fluidPage(
title = 'Select Table Rows',
fluidRow(
column(6, DT::dataTableOutput('x1')),
column(6, plotOutput('x2', height = 500,click = "plot_click"),
verbatimTextOutput("info"))
)
)
Server
shinyServer(function(input, output, session) {
output$x1 = DT::renderDataTable(cars, server = FALSE)
# highlight selected rows in the scatterplot
output$x2 = renderPlot({
s = input$x1_rows_selected
par(mar = c(4, 4, 1, .1))
plot(cars)
if (length(s)) points(cars[s, , drop = FALSE], pch = 19, cex = 2)
})
output$info <- renderPrint({
paste("Selected point row.name - ", row.names(nearPoints(cars, input$plot_click, xvar = "speed", yvar = "dist")), sep="")
})
})
With a new version of DT it works perfect with proxy
proxy = dataTableProxy('x1')
observeEvent(input$plot_click, {
removeRow <- as.numeric(row.names(nearPoints(cars, input$plot_click, xvar = "speed", yvar = "dist")))
selectRows(proxy, input$x1_rows_selected[!input$x1_rows_selected %in% removeRow])
})