[FIXED] How to insert a hover over pop up window in R Shiny table?

Issue

I found an old post, Add bootstrap tooltip to column header in shiny app, that basically and almost gets at what I need but I'm trying to clean it up. My questions are:

(1) how to remove the annoying pop up what appears when first invoking the below Code, as shown in the next image,

(2) will there be a way to adjust the size of, and otherwise format, the text ("HELLO") that appears when hovering over the table column header, and

(3) are there better options now for doing this sort of thing, where you get an editable, formattable pop-window (with user instructions) when you hover over a specific text string in a table?

Code:

library(shiny)

ui <- fluidPage(fluidRow(column(12,dataTableOutput('table'))))
  
server <- function(input, output) {
  output$table <- renderDataTable(
    iris,
    options = 
      list(
      pageLength = 5,
        initComplete = I("function(settings, json) {alert('Done.');
            $('th').each( function(){this.setAttribute('title','HELLO');});  
            $('th').tooltip();
            }")
      )
    )
    
  tags$head(tags$script("
      $('table th').each(function(){ console.log( $(this).text());
            $(this).attr('data-toggle','tooltip')
            $(this).attr('title','example text')
            $(this).tooltip();
        );
      "))
}

shinyApp(ui,server)

Solution

Once you have an id for the header, you can apply the shinyBS::bsPopover function. To have an id, you can use the container argument of DT::datatable.

library(shiny)
library(DT)
library(shinyBS)

sketch = htmltools::withTags(
  table(
    class = "display",
    thead(
      tr(
        th("Sepal length"),
        th("Sepal width"),
        th("Petal length"),
        th("Petal width"),
        th("Species", id = "header-species")
      )
    )
  )
)

ui <- fluidPage(
  br(),
  DTOutput("dtable"),
  bsPopover(
    id      = "header-species",
    title   = "Species",
    content = "This is the species column"
  )
)

server <- function(input, output, session) {
  output[["dtable"]] <- renderDT({
    datatable(iris, rownames = FALSE, container = sketch)    
  })
}

shinyApp(ui, server)

Answered By - Stéphane Laurent

Answer Checked By - Marie Seifert (PHPFixing Admin)

Read More

[FIXED] How to return a reactive dataframe from within a shiny module that depends on a button click?

Issue

Aim: Return a reactive dataframe object from within the module named "modApplyAssumpServer" Problem: I am getting an endless loop. Even if I wrap everything within the observeevent logic within isolate()

I have included another table in the app code below to indicate a simplified version of the logic that works outside of the module framework but that I can't seem to get to work within the module.

library(shiny)
library(dplyr)

df_agg_orig <- data.frame(proj_1 = c(2,3))

modGrowthInput <- function(id) {
  ns <- NS(id)
    tagList(
    numericInput(ns("first"),label = "Assumption",value = 100),
  )
}

 modGrowthServer <- function(id, btnGrowth) {
    moduleServer(id, function(input, output, session) {
      list(
        first = reactive({input$first})
        )
   })
 }

modButtonUI <- function(id,lbl = "Recalculate"){
  ns <- NS(id)
  actionButton(inputId = ns("btn"),label = lbl)#,style = "pill",color = "primary",no_outline = T,size = "xs"
}

modButtonServer <- function(id){
  moduleServer(id, function(input, output, session) {
    reactive({input$btn})
  })
}


modApplyAssumpServer <- function(id,btnGrowth, df_agg,case_vals){
  moduleServer(id, function(input, output, session) {
    stopifnot(is.reactive(btnGrowth))
    stopifnot(is.reactive(df_agg))
        mod_vals <- reactiveVal(df_agg())
         observeEvent(btnGrowth(),{
           isolate({mod_vals(df_agg() %>% mutate(proj_1 = proj_1*input$first))})
           print("Looping problem...")
           })
      mod_vals()
  })
}

#### Test App
GrowthInputApp <- function() {
  
  ui <- fluidPage(
    sidebarPanel(modGrowthInput("tst"),modButtonUI("tstGrowth")),
    mainPanel(fluidRow( splitLayout( DT::DTOutput("no_module"),DT::DTOutput("module_tbl")))))

  server <- function(input, output, session) {
    
    btnGrowth <- modButtonServer("tstGrowth")
    case_vals <- modGrowthServer("tst")
    
    df_agg <- reactiveValues(df_wide = df_agg_orig)
    
    #Outside of module test exhibiting expected/desired behavior (at least if the looping issue would let it do so :)
    observeEvent(btnGrowth(),{
      df_agg$df_wide$proj_1 <- round(df_agg$df_wide*case_vals$first(),2)
       })

    output$no_module <- DT::renderDT({DT::datatable(rownames = F,df_agg$df_wide,caption = "Not Updated Within Module")})
    
    output$module_tbl <- DT::renderDT({DT::datatable(rownames = F,modApplyAssumpServer("tst",btnGrowth = btnGrowth,df_agg = reactive({df_agg_orig})),caption = "Table Returned From Module")}
    )
  
  }
  
  shinyApp(ui, server)  
  
}
runApp(GrowthInputApp())

Solution

Try this

library(shiny)
library(dplyr)

df_agg_orig <- data.frame(proj_1 = c(2,3))

modGrowthInput <- function(id) {
  ns <- NS(id)
  tagList(
    numericInput(ns("first"),label = "Assumption",value = 10),
  )
}

modGrowthServer <- function(id) {
  moduleServer(id, function(input, output, session) {
    list(
      first = reactive({input$first})
    )
  })
}

modButtonUI <- function(id,lbl = "Recalculate"){
  ns <- NS(id)
  actionButton(inputId = ns("btn"),label = lbl)#,style = "pill",color = "primary",no_outline = T,size = "xs"
}

modButtonServer <- function(id){
  moduleServer(id, function(input, output, session) {
    reactive({input$btn})
  })
}


modApplyAssumpServer <- function(id,btnGrowth, df_agg, val){
  moduleServer(id, function(input, output, session) {
    stopifnot(is.reactive(btnGrowth))
    stopifnot(is.reactive(df_agg))
    
    modvals <- eventReactive(btnGrowth(), {
      print("Looping problem...")
      #print(btnGrowth())
      df_agg() %>% mutate(proj_1 = proj_1*val )
    })
    return(modvals())
  })
}

#### Test App
GrowthInputApp <- function() {
  
  ui <- fluidPage(
    sidebarPanel(modGrowthInput("tst"),modButtonUI("tstGrowth")),
    mainPanel(fluidRow( splitLayout( DT::DTOutput("no_module"),DT::DTOutput("module_tbl")))))
  
  server <- function(input, output, session) {
    
    btnGrowth <- modButtonServer("tstGrowth")
    case_vals <- modGrowthServer("tst")
    observe({ print(case_vals$first())})
    df_agg <- reactiveValues(df_wide = df_agg_orig)
    
    #Outside of module test exhibiting expected/desired behavior (at least if the looping issue would let it do so :)
    observeEvent(btnGrowth(),{
      df_agg$df_wide$proj_1 <- round(df_agg$df_wide*case_vals$first(),2)
    })
    
    mydf <- eventReactive(c(btnGrowth(),case_vals$first()), {
      modApplyAssumpServer("tst", btnGrowth, reactive({df_agg$df_wide}), case_vals$first() )
    })
    #observe({print(btnGrowth())})
    output$no_module <- renderDT({DT::datatable(rownames = F,df_agg$df_wide,caption = "Not Updated Within Module")})
    
    output$module_tbl <- renderDT({DT::datatable(rownames = F, mydf() ,caption = "Table Returned From Module")} )
    
    ###  using original data so no change after first click 
    #output$module_tbl <- renderDT({DT::datatable(rownames = F, modApplyAssumpServer("tst", btnGrowth, reactive({df_agg_orig}), case_vals$first() ),caption = "Table Returned From Module")}
    #)
  }
  
  shinyApp(ui, server)  
  
}
runApp(GrowthInputApp())

Answered By - YBS

Answer Checked By - Timothy Miller (PHPFixing Admin)

Read More