I need to change the value of an input every time that the user changes the page of a dataset pagination.
I've tried to use the observeEvent, but it doesn't work.
UI
fluidRow(
column(10,
""
),
column(2,
textInput("inText", "Input text 2", value = "Default text")
),
column(12,
dataTableOutput('table')
)
)
Server
observeEvent(input$table, {
updateTextInput(session, "inText", value = paste("New text",0))
})
Hope you can help me.
Assuming your table id is table as given in your example, you can use:
input$table_state$start / input$table_state$length + 1.
In the following a complete example:
library(DT)
library(shiny)
app <- shinyApp(
ui = fluidPage(
tags$head(
# hides the default search functionality
tags$style(
HTML(".dataTables_filter, .dataTables_info { display: none; }")
)
),
fluidRow(
column(10,
""
),
column(2,
# adding new page filter
uiOutput("pageFilter")
),
column(12,
dataTableOutput('table')
)
)
),
server = function(input, output) {
output$pageFilter <- renderUI({
val <- input$table_state$start / input$table_state$length + 1
numericInput("page", "Page", val, min = 1)
})
output$table <- DT::renderDataTable({
iris
}, options = list(pageLength = 5, stateSave = TRUE))
# using new page filter
observeEvent(input$page, {
dataTableProxy("table") %>% selectPage(input$page)
})
}
)
runApp(app, launch.browser = TRUE)
Related
Is it possible to update a tag value when dateInput is changed by a user?
Maybe something like force, eventReactive, reactivevalue or stop lazy evaluation?
library(shiny)
library(lubridate)
library(tidyverse)
library(DT)
data <- data.frame(
date=seq.Date(from=dmy("1/1/2022"),to=dmy("31/1/2022"),by="day"),
y=round(rnorm(n=31,mean=0,sd=2),2)
)
date_selected <- ""
# fn_lookup(date_in="")
fn_lookup <- function(date_in){
if(length(date_in)>0){
y=(data %>% filter(date==dmy(date_in)))$y
}else{
y=""
}
return(y)
}
ui <- fluidPage(
fluidRow(
column(12,actionButton(inputId="edit_table",label="edit",icon=icon("edit")))
),
fluidRow(
br(),
br(),
column(12,DT::dataTableOutput('table')))
)
server <- function(input, output) {
output$table <- DT::renderDataTable(data)
observeEvent(input$edit_table,{
date_selected <- eventReactive(input$ad1, { input$ad1 })
showModal(modalDialog(
tagList(
div(style="display:inline-block;",
dateInput(inputId="ad1",label="Date",value="2022-1-15",format="dd/mm/yyyy")
),
div(style="display:inline-block;",
tags$label("value static"),
tags$input(id = "ad2", type = "text", class="form-control",value = fn_lookup("15/1/2022"))
),
div(style="display:inline-block;",
tags$label("value dynamic"),
#dynamically update this tag value when the date input changes
tags$input(id = "ad3", type = "text", class="form-control",value = fn_lookup(input$ad1))
),
div(style="display:inline-block;",
tags$label("value dynamic 2"),
#dynamically update this tag value when the date input changes
# tags$input(id = "ad3", type = "text", class="form-control",value = fn_lookup(date_selected))
)
),
footer = tagList(
modalButton("Cancel"),
actionButton(inputId="check", "Check",icon=icon("check"))
),
easyClose = TRUE
))
})
}
shinyApp(ui, server)
When running the code below, you will notice that I have two options below. If you press the Excel option, a fileInput will appear right below the radioButtons. However, I would like to know if it is possible to separate fileInput from radioButtons. I will insert an image to clarify what I want. See that they are separated.
Executable code below:
library(shiny)
library(dplyr)
library(shinyjs)
library(shinythemes)
library(readxl)
ui <- fluidPage(
shiny::navbarPage(theme = shinytheme("flatly"), collapsible = TRUE,
br(),
tabPanel("PAGE1",
sidebarLayout(
sidebarPanel(
radioButtons("button",
label = h3("Data source"),
choices = list("Excel" = "Excel",
"Database" = "database"),
selected = "File"),
uiOutput('fileInput'),
),
mainPanel(
)))))
server <- function(input, output) {
observe({
if(is.null(input$button)) {
}else if (input$button =="Excel"){
output$fileInput <- renderUI({
fileInput("file",h4("Import file"), multiple = T, accept = ".xlsx")
})
} else if(input$button=="database"){
output$fileInput <- NULL
} else {
output$fileInput <- NULL
}
})
}
shinyApp(ui = ui, server = server)
Example:
I left it in red to specify the space
A possible workaround could be to use fluidRow with two columns to simulating a sidebarPanel with a mainPanel.
Notice that I wrapped the inputs in a div(class = "well well-lg") for the background.
App
library(shiny)
library(dplyr)
library(shinyjs)
library(shinythemes)
library(readxl)
ui <- navbarPage(
theme = shinytheme("flatly"), collapsible = TRUE,
br(),
tabPanel(
"PAGE1",
fluidRow(
column(
width = 6,
fluidRow(div(
class = "well well-lg",
radioButtons("button",
label = h3("Data source"),
choices = list(
"Excel" = "Excel",
"Database" = "database"
),
selected = "File"
)
)),
fluidRow(
uiOutput("fileInput")
)
),
column(
width = 6,
tableOutput("iris")
)
)
)
)
server <- function(input, output) {
output$iris <- renderTable({
iris
})
observe({
if (is.null(input$button)) {
} else if (input$button == "Excel") {
output$fileInput <- renderUI({
div(class = "well well-lg", fileInput("file", h4("Import file"), multiple = T, accept = ".xlsx"))
})
} else if (input$button == "database") {
output$fileInput <- NULL
} else {
output$fileInput <- NULL
}
})
}
shinyApp(ui = ui, server = server)
I wish to have a popout modal within a shiny app that depending on the user's action within the modal,
it would show or hide certain fields.
For example, the Modal includes a button that when pressed, another button would apear\disappear.
sadly, although the observeEvent detects a change in the hide\show button, shinyjs::toggle(), shinyjs::hide()
and shinyjs::show() fail to work
example script:
library(shiny)
ui <- fluidPage(
actionButton("show_modal", "show modal"),
)
server <- function(input, output) {
observeEvent(input$show_modal, {
showModal(
modalDialog(footer = NULL,easyClose = T,
tagList(
fluidRow(
box(status = "primary", width = 6, style = "direction: ltr",
actionButton("toggle_btn", "show or hide second button")
)),
fluidRow(
box(status = "success", width = 6, style = "direction: ltr",
actionButton("box_btn", "Box!")
))
)
))
})
observeEvent(input$toggle_btn, {
shinyjs::toggle("box_btn")
cat("\npresentation button pressed\n")
})
}
shinyApp(ui, server)
You can do it without shinyjs by using conditionalPanel():
library(shiny)
ui <- fluidPage(
actionButton("show_modal", "show modal"),
)
server <- function(input, output) {
rv <- reactiveValues(show_btn = FALSE)
observeEvent(input$toggle_btn, {
rv$show_btn <- !rv$show_btn
})
output$show_btn <- reactive({rv$show_btn})
outputOptions(output, "show_btn", suspendWhenHidden = FALSE)
observeEvent(input$show_modal, {
# add_path_to_existing_offers_DB(user = user)
showModal(
modalDialog(
footer = NULL,
easyClose = T,
tagList(
fluidRow(
actionButton("toggle_btn", "show or hide second button")
),
conditionalPanel(
condition = "output.show_btn == true",
fluidRow(
actionButton("box_btn", "Box!")
)
)
)
)
)
})
}
shinyApp(ui, server)
Turns out as Dean Attali the author of shinyjs pointed out kindly,
that I failed to call useShinyjs() function.
library(shiny)
library(shinyjs)
ui <- fluidPage(
**useShinyjs(),**
actionButton("show_modal", "show modal"),
)
server <- function(input, output) {
observeEvent(input$show_modal, {
showModal(
modalDialog(footer = NULL,easyClose = T,
tagList(
fluidRow(
box(status = "primary", width = 6, style = "direction: ltr",
actionButton("toggle_btn", "show or hide second button")
)),
fluidRow(
box(status = "success", width = 6, style = "direction: ltr",
actionButton("box_btn", "Box!")
))
)
))
})
observeEvent(input$toggle_btn, {
shinyjs::toggle("box_btn")
cat("\npresentation button pressed\n")
})
}
shinyApp(ui, server)
I need my Shiny module to hide/show a div outside of the namespace. I tried passing the div id to the module server function and using shinyjs to show/hide it but that is not working. I'm not getting an error, it just doesn't show/hide the div.
I know the Shiny module documentation says modules cannot access outputs outside the namespace. The docs do, though, give a way for the module to access inputs outside the namespace using reactives.
Does anyone know if there is a way for a Shiny module to access an output outside the namespace?
Here is what I'm trying to do:
### ui.R ###
header <- dashboardHeader(
title = a(href = 'http://google.com')
)
dashboardPage(
skin = 'black',
header,
dashboardSidebar(
sidebarMenu( id='tabs',
menuItem('Edit Existing Client', tabName = 'client-info')
)),
dashboardBody(
useShinyjs(),
fluidRow(
tabItems(
tabItem(tabName = "client-info",
div(selectClientModuleUI("clientinfons")),
div(id='editclientinfo', uiOutput('editclientstuff'))
)
)
)
)
)
### server.R ###
shinyServer(function(session,input, output) {
output$editclientstuff <- renderUI({
div(
fluidRow(
column(6,
textInput('editname', "Display name", value ='Testing name')
),
column(6,
numericInput('editastart','Start', value ='3')
)
)
)
})
callModule(selectClientModule, 'clientinfons', 'editclientinfo')
shinyjs::hide(id='editclientstuff')
})
### in global.R ###
selectClientModuleUI <- function(id){
ns <- NS(id)
clientlist = c(0, 1, 2)
names(clientlist) = c('Choose client', 'Fred', 'Kim')
div(
selectInput(ns('selectclient'), 'Select client to edit', choices = clientlist, selected = NULL, multiple = FALSE)
)
}
selectClientModule <- function(input, output, session, divtoshow = ''){
observeEvent(input$selectclient, {
if (!is.null(input$selectclient) && input$selectclient > 0){
print(paste0("showing ", divtoshow))
shinyjs::show(divtoshow)
}
})
}
That is possible by giving the value as a reactive (not as the value of the reactive) to the module. You can change the reactive Value in the module and return the reactive from the Module to the app (note, return the reactive itself, not its value). The following app switches the 'divtoshow' in the main app from inside the module. If nothing is selected, it's hidden, otherwise it's shown (note, I adjusted you code a little so it's working as a stand-alone app):
library(shinydashboard)
library(shinyjs)
# Module
selectClientModuleUI <- function(id){
ns <- NS(id)
clientlist = c(0, 1, 2)
names(clientlist) = c('Choose client', 'Fred', 'Kim')
div(
selectInput(ns('selectclient'), 'Select client to edit', choices = clientlist, selected = NULL, multiple = FALSE)
)
}
selectClientModule <- function(input, output, session, divtoshow){
observeEvent(input$selectclient, {
if (input$selectclient > 0){
print(paste0("showing editclientinfo"))
divtoshow("editclientinfo") # set the div to show to "editclientinfo", this will be visible outside the module
}else{
divtoshow("") # set the div to show to "", if nothing was chosen
}
})
# return the div to show as reactive to the main app
return(divtoshow)
}
# Main App
ui <- shinyUI(
dashboardPage(
skin = 'black',
dashboardHeader(
title = a(href = 'http://google.com')
),
dashboardSidebar(
sidebarMenu( id='tabs',
menuItem('Edit Existing Client', tabName = 'client-info')
)),
dashboardBody(
useShinyjs(),
fluidRow(
tabItems(
tabItem(tabName = "client-info",
div(selectClientModuleUI("clientinfons")),
div(id='editclientinfo', uiOutput('editclientstuff'))
)
)
)
)
))
server <- shinyServer(function(session,input, output) {
output$editclientstuff <- renderUI({
div(
fluidRow(
column(6,
textInput('editname', "Display name", value ='Testing name')
),
column(6,
numericInput('editastart','Start', value ='3')
)
)
)
})
# store the div to show in a reactive
divtoshow <- reactiveVal('')
# divtoshow can be changed in side this module, so it's a return value
divtoshow <- callModule(selectClientModule, 'clientinfons', divtoshow)
# observe the value of divtoshow and toggle the corresponding div
observeEvent(divtoshow(), {
if(divtoshow() == "editclientinfo"){
shinyjs::show("editclientinfo")
}else{
shinyjs::hide("editclientinfo")
}
})
})
shinyApp(ui, server)
I have a table in Shiny and want to add only one tooltip for the column "Species", i.e. the other columns should not have a tooltip.
I managed to add a tooltip for all of them, but don't know how I can set the content for specific columns.
shinyApp(
ui = fluidPage(
fluidRow(
column(12,
dataTableOutput('table')
)
)
),
server = function(input, output) {
output$table <- renderDataTable(iris, options = list(
pageLength = 5,
initComplete = I("function(settings, json) {
$('th').each( function(){this.setAttribute( 'title', 'TEST' );});
$('th').tooltip();
}")))
}
)
I have modified your code to get the tooltip for only the 4th column name ie "Species".
library(shiny)
shinyApp(
ui = fluidPage(
fluidRow(
column(12,
dataTableOutput('table')
)
)
),
server = function(input, output) {
output$table <- renderDataTable(iris, options = list(
pageLength = 5,
initComplete = I("function(settings, json) {
$('th:eq(4)').each( function(){this.setAttribute( 'title', 'TEST' );});
$('th').tooltip();
}")))
}
)
Hope this helps!