Unable to create header messages server-side (renderUI) - bug?

[smartinsightsfromdata]

First of all congratulations for yet another great piece of software.

I tried to follow the instructions here.

Unfortunately, while I get the envelope icon on the navbar, I do not get the actual messages.

This is the code:

library(shiny)
# options(shiny.trace = T) 
msg <- data.frame(from = c("Admininstrator","New User","Support"),
                  message = c("Sales are steady this month.","How do I register?","The new server is ready."),
                  stringsAsFactors = F)
ui <- dashboardPage(
  dashboardHeader(title = "Basic dashboard",uiOutput("messageMenu")
#                   dropdownMenu(type = "messages",
#                                messageItem(
#                                  from = "Sales Dept",
#                                  message = "Sales are steady this month."
#                                ),
#                                messageItem(
#                                  from = "New User",
#                                  message = "How do I register?",
#                                  icon = icon("question"),
#                                  time = "13:45"
#                                ),
#                                messageItem(
#                                  from = "Support",
#                                  message = "The new server is ready.",
#                                  icon = icon("life-ring"),
#                                  time = "2014-12-01"
#                                )
#                   )
                  ),
  dashboardSidebar(),
  dashboardBody(
    # Boxes need to be put in a row (or column)
    fluidRow(
      box(plotOutput("plot1", height = 250)),

      box(
        title = "Controls",
        sliderInput("slider", "Number of observations:", 1, 100, 50)
      )
    )
  )
)

server <- function(input, output) {
  set.seed(122)
  histdata <- rnorm(500)

  output$plot1 <- renderPlot({
    data <- histdata[seq_len(input$slider)]
    hist(data)
  })
  #####
  output$messageMenu <- renderUI({
    # Code to generate each of the messageItems here, in a list. This assumes
    # that messageData is a data frame with two columns, 'from' and 'message'.
    msgs <- apply(msg, 1, function(row) {
      messageItem(from = row[["from"]], message = row[["message"]])
    })


#    msgs <- list(messageItem(from = "User", message = "this is the message",
#                             icon = shiny::icon("user"), time = NULL) )
#    print(msgs)
    # This is equivalent to calling:
    #   dropdownMenu(type="messages", msgs[[1]], msgs[[2]], ...)
    dropdownMenu(type = "messages", .list = msgs)

  })
}

shinyApp(ui, server)

I've tried different things, but nothing managed to work on the server side.

Maybe there is something missing either in the web doc or in the code?

[wch]

Hm, the source of the problem is that uiOutput returns a container div or span, which gets in between the ul and li in the DOM hierarchy.

I think the way to fix this will be to add a new function like menuOutput, and the corresponding Javascript bindings.

[smartinsightsfromdata]

I just wish to stress how impressed by this product. Do you think this template would be ok for the "complex" shiny app (>1,000 lines of code!) I'm developing?

[wch]

Glad you like it! Much of the credit belongs to the creator of the AdminLTE theme.

I don't see any reason why it wouldn't be good for a large app.

[happyshows]

Hey Winston,

While you're building future features, please consider to incorporate some UI modules in packages like shinyBS. For example, collapse panel, toggle button, and most importantly, toggle modal.

Appreciate the good work!

[jxiaowei]

wch, when do you think your change in Shiny can be merged to master? In urgent need for the feature. Thank you.

[schmidb]

hi, I have the same problems. I can not create header messages via server. Is there a fix available?

[wch]

@schmidb Hopefully we'll be merge in the fix in the main Shiny development branch in the next couple of days. Then you'll be able to install the dev version of Shiny with devtools::install_github('rstudio/shiny') and have the fix.

If you need the fix now, you can install the branch, with devtools::install_github('wch/shiny@html-replace').

[schmidb]

Hi, I updated to your branch. Now I am getting the following error and the dashboard is not starting:

Error in .getReactiveEnvironment()$currentContext() :
Operation not allowed without an active reactive context. (You tried to do something that can only be done from inside a reactive expression or observer.)
Warning: Unhandled error in observer: Operation not allowed without an active reactive context. (You tried to do something that can only be done from inside a reactive expression or observer.)
observe({
session$sendCustomMessage("ggvis_vega_spec", list(plotId = id,
spec = r_spec()))
})
Warning: Unhandled error in observer: Operation not allowed without an active reactive context. (You tried to do something that can only be done from inside a reactive expression or observer.)
observe({
for (obs in data_observers) obs$suspend()
data_table <- c(attr(r_spec(), "data_table", TRUE), attr(r_spec(),
"scale_data_table", TRUE))
data_observers <<- lapply(names(data_table), function(data_name) {
force(data_name)
obs <- shiny::observe(suspended = TRUE, {
data_reactive <- data_table[[data_name]]
session$sendCustomMessage("ggvis_data", list(plotId = id,
name = data_name, value = as.vega(data_reactive(),
data_name)))
})
sync_with_hidden_state(obs, id, session)
obs
})
data_observers[[length(data_observers) + 1]] <<- shiny::observe(suspended = TRUE,
{
for (name in names(data_table)) {
data_table[name]
}
[... truncated]

any ideas what is wrong?

[wch]

@schimdb Did you restart with a clean R session after installing?

[schmidb]

:-) clean R session removes the error. I now do in server.R

  output$dropdownMenu <- renderUI({
    streamdata <- connectToStream()
    messageData <- data.frame(text=c("test","fsfdfs"), icon=c("truck","truck"), 
                              status=c("success", "success"))
    msgs <- apply(messageData, 1, function(row) {
      notificationItem(text = row[["text"]], status = row[["status"]])
    })

    dropdownMenu(type = "notifications", .list = msgs)
  })

and in ui.R

  dashboardHeader(
    title = "IoT Sensor Demo",
    uiOutput("dropdownMenu", replace = TRUE)
    ),

and I get the error: Error in FUN(X[[1L]], ...) : Expected tag to be of type li
and app is not starting. Any ideas?

[wch]

@schmidb I just pushed a fix to shinydashboard that should fix that issue.

[schmidb]

great, works. Only one small issue: If I move with the mouse over the icon in the header the number (in my case a 2) jumps a little bit to the top. Probably a css issue?

[wch]

For better or worse, the moving number is part of the design from AdminLTE.

[schmidb]

thanks for feedback and fast bug-fix

[hrbrmstr]

I updated shinydashboard and shiny (the alt branch from above) and restarted R/RStudio before posting. How does one get more than one dynamic menu? And, even with a single dynamic menu, the CSS seems off (placement of icon). Test bed code:

  library(shiny)
  library(shinydashboard)

  # start of minimal test app -----------------------------------------------

  msgItem <- messageItem("Support Team", "This is the content of a message.",
                         time = "5 mins")
  nfyItem <- notificationItem(icon = icon("users"),
                             status = "info", "5 new members joined today")

  server <- function(input, output) {

    # for methods 2 & 2a
    output$messagesMenu <- renderUI({
      dropdownMenu(type = "messages", msgItem)
    })

    output$notificationsMenu <- renderUI({
      dropdownMenu(type = "notifications", nfyItem)
    })

  }

  sidebar <- dashboardSidebar()
  body <- dashboardBody()

  # method 1: static, but CSS works -----------------------------------------

  header <- dashboardHeader(dropdownMenu(type = "messages", msgItem),
                            dropdownMenu(type = "notification", nfyItem),
                            title="CYBER Dashboard")
  ui <- dashboardPage(header, sidebar, body, skin="black")
  shinyApp(ui, server)


  # method 2 - based on example - only one menu shows up & CSS is off -------

  header <- dashboardHeader(uiOutput("messagesMenu"),
                            uiOutput("notificationeMenu"),
                            title="CYBER Dashboard")
  ui <- dashboardPage(header, sidebar, body, skin="black")
  shinyApp(ui, server)


  # method 2a - using .list still doesn’t get 2 menus -----------------------

  header <- dashboardHeader(.list=list(uiOutput("messagesMenu"),
                                       uiOutput("notificationeMenu")),
                            title="CYBER Dashboard")
  ui <- dashboardPage(header, sidebar, body, skin="black")
  shinyApp(ui, server)

[wch]

Hi all, we decided to take a different route to fix this issue. This should work with the CRAN version of Shiny, 0.11.

Now there are two functions, dropdownMenuOutput and renderDropdownMenu. Here's an example (this is in the help for renderDropdownMenu):

library(shiny)
library(shinydashboard)

# Example message data in a data frame
messageData <- data.frame(
  from = c("Admininstrator", "New User", "Support"),
  message = c(
    "Sales are steady this month.",
    "How do I register?",
    "The new server is ready."
  ),
  stringsAsFactors = FALSE
)

ui <- dashboardPage(
  dashboardHeader(
    title = "Dynamic menus",
    dropdownMenuOutput("messageMenu")
  ),
  dashboardSidebar(),
  dashboardBody(
    fluidRow(
      box(
        title = "Controls",
        sliderInput("slider", "Number of observations:", 1, 100, 50)
      )
    )
  )
)

server <- function(input, output) {
  output$messageMenu <- renderUI({
    # Code to generate each of the messageItems here, in a list. messageData
    # is a data frame with two columns, 'from' and 'message'.
    # Also add on slider value to the message content, so that messages update.
    msgs <- apply(messageData, 1, function(row) {
      messageItem(
        from = row[["from"]],
        message = paste(row[["message"]], input$slider)
      )
    })

    dropdownMenu(type = "messages", .list = msgs)
  })
}

shinyApp(ui, server)

I'll also update the shinydashboard web site to reflect this.

@hrbrmstr I think the bug in your example is that you misspelled it as notificationeMenu. A modified version of your app, using the new system, looks like this:

  library(shiny)
  library(shinydashboard)

  # start of minimal test app -----------------------------------------------

  msgItem <- messageItem("Support Team", "This is the content of a message.",
                         time = "5 mins")
  nfyItem <- notificationItem(icon = icon("users"),
                             status = "info", "5 new members joined today")

  server <- function(input, output) {

    # for methods 2 & 2a
    output$messagesMenu <- renderDropdownMenu({
      dropdownMenu(type = "messages", msgItem)
    })

    output$notificationsMenu <- renderDropdownMenu({
      dropdownMenu(type = "notifications", nfyItem)
    })

  }

  sidebar <- dashboardSidebar()
  body <- dashboardBody()

  # method 1: static, but CSS works -----------------------------------------

  header <- dashboardHeader(dropdownMenu(type = "messages", msgItem),
                            dropdownMenu(type = "notification", nfyItem),
                            title="CYBER Dashboard")
  ui <- dashboardPage(header, sidebar, body, skin="black")
  shinyApp(ui, server)


  # method 2 - based on example - only one menu shows up & CSS is off -------

  header <- dashboardHeader(dropdownMenuOutput("messagesMenu"),
                            dropdownMenuOutput("notificationsMenu"),
                            title="CYBER Dashboard")
  ui <- dashboardPage(header, sidebar, body, skin="black")
  shinyApp(ui, server)


  # method 2a - using .list still doesn’t get 2 menus -----------------------

  header <- dashboardHeader(.list=list(dropdownMenuOutput("messagesMenu"),
                                       dropdownMenuOutput("notificationsMenu")),
                            title="CYBER Dashboard")
  ui <- dashboardPage(header, sidebar, body, skin="black")
  shinyApp(ui, server)

[afflorezr]

Hi Winston, I have this Observe inside of ShinyDashBoard app, it look like to:

observe({
if (input$SaveElicita == 0)
return()
isolate({
##Validamos que no haya valores en blanco##
if(!is.na(sum(ValLevel())) && !is.na(input$Nhipote))
{
code
if(sum(ValLevel())==input$Nhipote && !(input$Nhipote%in%(ValidaN.Hipo$SumVal)))
{
Code
}
else{ session$sendCustomMessage(type = 'testmessage', message ="La suma de los valores de cada nivel no es igual al N hipotetico o el N hipotetico ya fue elicitado")}
}
else{ session$sendCustomMessage(type = 'testmessage', message ="No se pueden guardar campos en blanco")}
})

But sendCustomMessage don´t work (not create header messages via server), so I try to install "devtools::install_github('wch/shiny@html-replace')" and follow the steps mentioned above by schmidb but when I try to do it show to me this error:

devtools::install_github('wch/shiny@html-replace')
Downloading github repo wch/shiny@html-replace
Error in download(dest, src, auth) : client error: (404) Not Found

Have any idea why it's happening?

thanks for your help.

[wch]

You don't need the html-replace branch anymore; you can just run devtools::install_github('rstudio/shiny').

[afflorezr]

HI Winston, I ran devtools::install_github('rstudio/shiny'), then I restart Rstudio, but the same problem still happening. I think that it is happening buecause Im using "gridster" function from "shinyGridster" package, something like this:

library(shiny)
library(shinydashboard)
library(ShinyDash)
library(rCharts)
library(shinyGridster)
shinyUI(bootstrapPage(
            dashboardPage(
                            dashboardHeader(title = "Expert's Judgment"),
                            dashboardSidebar( 
                                            sidebarUserPanel(subtitle ="Andrés",name="Hi!",image="foo.png"),
                                            sidebarMenu(                                      
                                                        menuItem("Introduction", tabName = "intro", icon = icon("file-text-o")),
                                                        )
                                            ),
                            dashboardBody(
                                        gridster(width = 270, height = 250,marginx = 3,marginy = 3,
                                                    gridsterItem(col = 4, row = 1, sizex = 2, sizey = 1,
                                                                        conditionalPanel(condition = "output.id > 0",
                                                                                           div(   div(style="float:left",tableOutput("ActualizaN")),
                                                                                           div(style="float:right; margin-top: -10px; margin-right: 60px;",
                                                                                           uiOutput("NHipoActualiza"),actionButton("ActualizaElicita", "Update",icon=icon("table"))))
                                                                                        ),
                                                                        conditionalPanel(condition = "output.id == 0",
                                                                                            "¡There are not values!"
                                                                                        )                                                                                   
                                                                )
                                                )           
                                     )
                         )
        ))

shinyServer(function(input, output, session){

# 1. Save the values inside of a input##

observe({
  output$ActualizaN<-renderTable({
    db <- dbConnect(SQLite(), dbname="database.sqlite")
    CateQuery<-paste0("SELECT N FROM variable WHERE id = ",input$variableFR)
    NomQuery<-paste0("SELECT nombre FROM nivel WHERE idVar = ",input$variableFR)
    QC<-dbGetQuery(db, CateQuery)
    NQ<-dbGetQuery(db, NomQuery)
    AA<- numeric(QC$N)        
    for(i in 1:QC$N){
      AA[i] <- c((paste0("<input class='span9' id='A",i,
                         "' class='shiny-bound-input' type='number' value='' name='Cat",1,"'>")))
    }

    data.frame(Name=NQ$nombre,Value=AA)                                                                         
  }, sanitize.text.function = function(x) x)
})


### 2. Are extracted the values from the inputs and those are saved inside of a variable##                              
Valupdate<-reactive({
  if (input$ActualizaElicita == 0)
    return() 
  isolate({
    db <- dbConnect(SQLite(), dbname="database.sqlite")
    CateQuery<-paste0("SELECT N FROM variable WHERE id = ",input$variableFR)
    QC<-dbGetQuery(db, CateQuery)                       
    ValL<-(unlist(reactiveValuesToList(input)[paste0("A",1:QC$N)]))
    return(ValL)                
  })
  input$ActualizaElicita
})
# 3. The ruleta table is updated#                   
observe({
  if (input$ActualizaElicita == 0)
    return()                                
  isolate({
    if(!is.na(sum(Valupdate()))){
      if(sum(Valupdate())==input$ActilizaN_Hipo)
      {
        db <- dbConnect(SQLite(), dbname="database.sqlite")
        N.Id<-dbGetQuery(db,paste0("SELECT Num_N FROM (SELECT SUM(ValNivel) as Ns , Num_N FROM ruleta WHERE IdVariable=",input$variableUpdate,
                                   " AND IdExperto=",input$expertUpdate," AND IdElicita=",input$elicitaUpdate," GROUP BY Num_N) WHERE Ns=",input$ActilizaN_Hipo) )
        Nivel<-dbGetQuery(db,paste0("SELECT idNivel FROM ruleta WHERE IdVariable=",input$variableUpdate," AND IdExperto=",input$expertUpdate,
                                    " AND IdElicita=",input$elicitaUpdate," AND Num_N=",N.Id$Num_N ))
        ##The values are updated##
        for(j in 1:length(Nivel$idNivel))
        {                  
          dbGetQuery(db,paste0("UPDATE ruleta SET ValNivel=",Valupdate()[j], " WHERE IdVariable=",input$variableUpdate,
                               " AND IdExperto=",input$expertUpdate," AND idNivel=",Nivel$idNivel[j]," AND Num_N=",N.Id$Num_N,
                               " AND IdElicita=",input$elicitaUpdate))
        }
        for(i in 1:length(Nivel$idNivel))
        {updateNumericInput(session,paste0("A",i), "", value="",min =1, max = 100000000)}
      }
      else{ session$sendCustomMessage(type = 'testmessage', message ="La suma de los valores de cada nivel debe  ser igual al N hipotetico")}
    }
    else{ session$sendCustomMessage(type = 'testmessage', message ="No se pueden actualizar campos en blanco")}
  })

})

})  

Apparently session$sendCustomMessage does not work when it is within of a gridsterItem

Any idea why ?

[wch]

Oh sorry, I don't think that shinydashboard will work reliably with shinygridster. shinygridster was an early experiment with using a grid layout with shiny, but we're not supporting it now.

[afflorezr]

OK Wiston, I changed the code and removed the gridsterItem function, but even so don't get to make that it work, the new code look like this:

library(shiny)
library(shinydashboard)
library(ShinyDash)
library(rCharts)
library(shinyGridster)
#### -------UI.R------- 
shinyUI(bootstrapPage(
            dashboardPage(
                            dashboardHeader(title = "Expert's Judgment"),
                            dashboardSidebar( 
                                            sidebarUserPanel(subtitle ="Andrés",name="Hi!",image="foo.png"),
                                            sidebarMenu(                                      
                                                        menuItem("Introduction", tabName = "intro", icon = icon("file-text-o")),
                                                        )),
                            dashboardBody(
                                            tabItems(
                                                     tabItem(tabName = "Tab1",
                                                              fluidRow(
                                                                        column(4,offset = 1,
                                                                                tags$section(class="content",
                                                                                  div(class="form-box",
                                                                                  div(class="header", 'Register a new '),
                                                                                  tags$form( method="post",
                                                                                  div(class="body bg-gray",
                                                                                             div(class="form-group",
                                                                                             numericInput("CodElicita", "Elicitation ID:", value="",min =1, max = 100000000)),
                                                                                             div(class="form-group",
                                                                                             textInput("NomElicita", "Elictation Name:"))                                                    
                                                                                     ),
                                                                                    div(class="footer",
                                                                                    actionButton("ElicitaButton", "Send",icon=icon("table")))))    
                                                                                ))
                                                                     )
                                                             )
                                                    )           
                                     )
                         )
        ))

#### -------Server.R-------     

shinyServer(function(input, output, session){
observe({
    if (input$ElicitaButton == 0)
      return()      
    db <- dbConnect(SQLite(), dbname="database.sqlite")
    isolate({
      if(!is.na(input$NomElicita) && !is.na(input$CodElicita)){
        tab1<-paste("INSERT INTO elicitacion VALUES (",input$CodElicita,",","'",input$NomElicita,"'",")",sep="")
        dbSendQuery(conn = db, tab1)
        x<-data.frame(
          Name = c(input$NomElicita,"Decimal"),
          Value = as.character(c(tab1,input$CodElicita)), 
          stringsAsFactors=FALSE
        )
        dat1<-dbGetQuery(db, "SELECT id FROM elicitacion")                                      
        updateNumericInput(session,"CodElicita", "Codigo Elicitacion:", value="",min =1, max = 100000000)
        updateTextInput(session,"NomElicita", "Nombre Elicitacion:",value="")
        updateSelectInput(session, "elicita", label ="Seleccione el codigo de la Elicitacion", choices =(dat1$id),selected =dat1$id[1])
        return(x)
      }
      else{ session$sendCustomMessage(type = 'testmessage', message ="No se pueden guardar campos en blanco")} 
    })
   input$ElicitaButton                           
  })
})      

updateNumericInput is working but session$sendCustomMessage not

[wch]

Oh, I think you're missing the javascript code to receive the message.

For this example: http://shiny.rstudio.com/gallery/server-to-client-custom-messages.html

You need to see the full source code, including the contents of the www directory: https://github.com/rstudio/shiny-examples/tree/master/061-server-to-client-custom-messages

[afflorezr]

Thanks you so much, it now is working,