Use Href Infobox as Actionbutton

Use href infobox as actionbutton

I decided to change the method. I have now include an actionbutton (or actionLink) inside the substile element of the value box and create a bsModal element linked to this actionButton.

If you are not familiar with the ShinyBS package it allow to make popover, tooltip etc features without including HTML or java.

I follow the @Mikko Martila advice Shiny: adding addPopover to actionLink and here is a reproductile example to show you my issue :

library("shiny")
library("shinydashboard")
library("shinyBS")

header <- dashboardHeader(title = "reporductible example")

body <- dashboardBody(valueBoxOutput("box_01"),
                      bsModal("modal", "foo", trigger = "", "bar"))
sidebar <- dashboardSidebar()
ui <- dashboardPage(header,sidebar,body,skin="green")
server = function(input, output, session) {
  # ----- First info box synthesis menu
  output$box_01 <- renderValueBox({
    entry_01 <- "BlaBla"
    valueBox(value=entry_01, icon = icon("users",lib="font-awesome"),
                    width=NULL,color = "blue",subtitle = HTML("<b>my substitle</b> <button id=\"button\" type=\"button\" class=\"btn btn-default action-button\">Show modal</button>")
    )
  })

  observeEvent(input$button, {
    toggleModal(session, "modal", "open")
  })
}

runApp(list(ui = ui, server = server))

I use the HTML() option to add my button inside the subtitle of value boxes.

It's not really what i wanted but it do the work.

You can do it with actionLink (it's look better) by using subtitle like this :

subtitle=HTML("<b>my subtitle</b><a id=\"button_box_05\" href=\"#\" class=\"action-button\">
     <i class=\"fa fa-question-circle\"></i>

       </a>")

How to create Infobox as actionbutton in Shinydashboard?

We can use actionLink and wrap it around infoBox. This will generate an input in the example below named input$info_clk which starts at 0 and gos up with each click. To turn this into an control-flow we use the remainder of the devision with 2 in an if statement if(input$info_clk %% 2):

library(shiny)
library(shinydashboard)
library(dplyr)
library(ggplot2)
library(shinyBS)
library(DT)

ui<-dashboardPage(
  dashboardHeader(title="Missing",titleWidth = 230),
  dashboardSidebar(
    fileInput("file1", "Upload CSV File below",
              accept = c(
                "text/csv",
                "text/comma-separated-values,text/plain",
                ".csv")
    )),
  dashboardBody(
    fluidRow(
      
      tags$head(
        tags$style(HTML('.info-box {min-height: 45px;} .info-box-icon {height: 45px; line-height: 45px;} .info-box-content {padding-top: 0px; padding-bottom: 0px;}')
                   )
        ),
      
      actionLink("info_clk",
        infoBox(" ", fill = TRUE, width = 7, value = tags$p("Infobox", style = "font-size: 100%;"))
        ),
      
      # infoBoxOutput("Infobox"),
      
      div(id="popme1", box(plotOutput("Plot1"),collapsible = TRUE,title="Plot 1",solidHeader = TRUE,status = "primary")),
      bsModal("modalExample1", "Plot1", "popme1", size = "large", plotOutput("Plot11")),
      
      div(id="popme2", box(plotOutput("Plot2"),collapsible=TRUE,title="Plot 2",solidHeader = TRUE,status = "primary")),
      bsModal("modalExample2", "Plot2", "popme2", size = "large", plotOutput("Plot22")),
      
      div(id="popme3", fluidRow(column(width=8,box(DTOutput("Missing_datatable"), width = NULL,collapsible = TRUE)) )),
      bsModal("modalExample3", "Data Table", "popme3", size = "large", DTOutput("Missing_datatable2"))
      
    )
  )
)

server<- function(input, output,session) {
  
  output$Plot1 <- output$Plot11 <- renderPlot({
    plot(cars)
  })
  
  output$Plot2 <- output$Plot22 <- renderPlot({
    
    if (input$info_clk %% 2L) {
      plot(mtcars$wt, mtcars$hp)
    } else {
      plot(pressure)
    }
    })
  
    output$Missing_datatable <- renderDT({iris[1:7,]})
  output$Missing_datatable2 <- renderDT({iris[1:7,]})
}

# Run the application 
shinyApp(ui = ui, server = server)

Using actionButton with marker-click and button-click on observeEvent returning no features

You should observe button_click instead of showmodal, actually showmodal is ignored because it is inside the popup. You can not retrieve the "name", "lng", and "lat" from data without having there. Initially data only contains clickedMarker with NULL, later when the user click on the button it will have again just NULL. You can get the value of the layerID parameter using input$map_marker_click$id and then use the id value as an index to access values inside myData. Below is a modification of you code that implements the idea.

library(leaflet)
library(shiny)
library(shinyalert)

myData <- data.frame(
  lat = c(54.406486, 53.406486),
  lng = c(-2.925284, -1.925284),
  id = c(1,2),
  name= c("Location1", "Location2")
)

ui <- fluidPage(
  leafletOutput("map"),
  p(),
  useShinyalert()
)

server <- shinyServer(function(input, output) {
  # produce the basic leaflet map with single marker
  output$map <- renderLeaflet(
    leaflet() %>%
      addProviderTiles("CartoDB.Positron") %>%
      #dont worry about the spacing its just an example
      addMarkers(
        lat = myData$lat, lng = myData$lng, layerId = myData$id, 
        popup= (paste0(
          myData$name, ": ", myData$lat, ", ", myData$lng,
          actionButton("showmodal", "Expand to show more details", 
                       onclick = 'Shiny.onInputChange("button_click",  Math.random())')
        ))
      )#close circle markers  
  )#close render
  # observe the marker click info and print to console when it is changed.
  
  observeEvent( input$button_click,{
    print("observed button_click and get id from map_marker_click$id")
    id <- input$map_marker_click$id
    shinyalert(
      title = "testing",
      text = paste0(myData$name[id], ": ", myData$lat[id], ", ", myData$lng[id])
    )
  })
  
})#close shiny

shinyApp(ui, server)

Use infoBox from shinydashboard into shiny

Hello you also need the AdminLTE.css file (you can find it in the shinydashboard dir) :

### ui
library("shiny")
fluidPage(
  tags$h1("Example of an infoBox with shiny"),
  # Add CSS files
  includeCSS(path = "AdminLTE.css"),
  includeCSS(path = "shinydashboard.css"),
  br(),
  fluidRow(
    infoBox("New Orders", 10 * 2, icon = icon("credit-card"), fill = TRUE),
    infoBoxOutput("progressBox2"),
    infoBoxOutput("approvalBox2")
  ),
  fluidRow(
    # Clicking this will increment the progress amount
    box(width = 4, actionButton("count", "Increment progress"))
  )
)
### server
library("shiny")
function(input, output) {
  output$progressBox2 <- renderInfoBox({
    infoBox(
      "Progress", paste0(25 + input$count, "%"), icon = icon("list"),
      color = "purple", fill = TRUE
    )
  })
  output$approvalBox2 <- renderInfoBox({
    infoBox(
      "Approval", "80%", icon = icon("thumbs-up", lib = "glyphicon"),
      color = "yellow", fill = TRUE
    )
  })
}

This app will work if you copy the files in your app directory, if you don't want to do that you can do :

# Function for adding dependencies
library("htmltools")
addDeps <- function(x) {
  if (getOption("shiny.minified", TRUE)) {
    adminLTE_js <- "app.min.js"
    adminLTE_css <- c("AdminLTE.min.css", "_all-skins.min.css")
  } else {
    adminLTE_js <- "app.js"
    adminLTE_css <- c("AdminLTE.css", "_all-skins.css")
  }

  dashboardDeps <- list(
    htmlDependency("AdminLTE", "2.0.6",
                   c(file = system.file("AdminLTE", package = "shinydashboard")),
                   script = adminLTE_js,
                   stylesheet = adminLTE_css
    ),
    htmlDependency("shinydashboard",
                   as.character(utils::packageVersion("shinydashboard")),
                   c(file = system.file(package = "shinydashboard")),
                   script = "shinydashboard.js",
                   stylesheet = "shinydashboard.css"
    )
  )

  shinydashboard:::appendDependencies(x, dashboardDeps)
}

library("shiny")
# ui 
ui <- fluidPage(
  tags$h1("Example of an infoBox with shiny"),
  br(),
  fluidRow(
    infoBox("New Orders", 10 * 2, icon = icon("credit-card"), fill = TRUE),
    infoBoxOutput("progressBox2"),
    infoBoxOutput("approvalBox2")
  ),
  fluidRow(
    # Clicking this will increment the progress amount
    box(width = 4, actionButton("count", "Increment progress"))
  )
)
# Attach dependencies
ui <- addDeps(
  tags$body(shiny::fluidPage(ui)
  )
)
# server
server <- function(input, output) {
  output$progressBox2 <- renderInfoBox({
    infoBox(
      "Progress", paste0(25 + input$count, "%"), icon = icon("list"),
      color = "purple", fill = TRUE
    )
  })
  output$approvalBox2 <- renderInfoBox({
    infoBox(
      "Approval", "80%", icon = icon("thumbs-up", lib = "glyphicon"),
      color = "yellow", fill = TRUE
    )
  })
}
# app
shinyApp(ui = ui, server = server)

Shiny - dashboardPage - how can I add a button to box header

If you want a button in the right corner of the box header you could modify the original box function or you could use some JavaScript to add the button after the creation of the box.

An even simpler solution is to create a box title with an actionLink or with an actionButton. Bellow is a example for both cases. The first box has an actionLink as title, when the user clicks on it, the content of the box is updated. On the second box the title is created with plain text and with a small actionButton that will also update the box content. For the second box you could add some custom style to create a header of the same size of a normal box.

library(shiny)
library(shinydashboard)

body <- dashboardBody(
  fluidRow(
    box(
      title = actionLink("titleId", "Update", icon = icon("refresh")), 
      width = 4, solidHeader = TRUE, status = "primary",
      uiOutput("boxContentUI")
    ),
    box(
      title = p("Title 1", 
                actionButton("titleBtId", "", icon = icon("refresh"),
                  class = "btn-xs", title = "Update")
      ), 
      width = 4, solidHeader = TRUE, status = "warning",
      uiOutput("boxContentUI2")
    )
  )
)

ui <- dashboardPage(
  dashboardHeader(title = "Row layout"),
  dashboardSidebar(),
  body
)

server = function(input, output, session) { 
  output$boxContentUI <- renderUI({
    input$titleId
    pre(paste(sample(letters,10), collapse = ", "))
  }) 

  output$boxContentUI2 <- renderUI({
    input$titleBtId
    pre(paste(sample(LETTERS,10), collapse = ", "))
  })  
}

shinyApp(ui = ui, server = server)

In flexdashboard, can a valueBox be clicked to update a text box like an actionButton?

I tried different parameters for valueBox without any luck. In the end I managed to solve it by putting actionButtons in the captions of the valueBoxes, and then using custom styles to make them transparent and expand them so they cover the entire valueBox. It looks like this, where clicking each valueBox renders different text under "Text output":

Sample Image

I added color and icons to highlight that the valueBoxes can be styled normally. It only uses the flexdashboard library, and it's completely responsive. Here's the code:

---
title: "valueBox Links"
output: 
  flexdashboard::flex_dashboard:
runtime: shiny
---

```{r setup, include=FALSE}
library(flexdashboard)
```

Tab 1 - Test
======================================================================

Column 
-------------------------------------

#### Three valueBoxes

### valueBox 1
```{r}
valueBox(1, caption = paste("I'm clickable!", actionButton("button1", " ", style = "background-color:rgba(39, 128, 227, 0.0); border-color:rgba(39, 128, 227, 0.0); position: absolute; overflow: hidden; left: 0px; top: 0px; right: 0px; bottom: 0px; width:100%")), icon = "fa-thumbs-up", color = "success")
```

### valueBox 2
```{r}
valueBox(2, caption = paste("I'm clickable too!", actionButton("button2", " ", style = "background-color:rgba(39, 128, 227, 0.0); border-color:rgba(39, 128, 227, 0.0); position: absolute; overflow: hidden; left: 0px; top: 0px; right: 0px; bottom: 0px; width:100%")), icon = "fa-tag", color = "warning")
```

### valueBox 3
```{r}
valueBox(3, caption = paste("ME TOO!", actionButton("button3", " ", style = "background-color:rgba(0, 0, 0, 0.0); border-color:rgba(0, 0, 0, 0.0); position: absolute; overflow: hidden; left: 0px; top: 0px; right: 0px; bottom: 0px; width:100%")), icon = "fa-random", color = "danger")
```

Column
-------------------------------------

### Text output
```{r}
textOutput("textout")

rv <- reactiveValues(data = NULL)

observeEvent(input$button1, {
rv$data <- "There are two types of people in the world: 1) Those who can extrapolate from incomplete data."
})

observeEvent(input$button2, {
rv$data <- "If you live to be one hundred, you’ve got it made. Very few people die past that age."
})

observeEvent(input$button3, {
rv$data <- "A statistician’s wife had twins. He was delighted. He rang the minister who was also delighted. “Bring them to church on Sunday and we’ll baptize them,” said the minister. “No,” replied the statistician. “Baptize one. We’ll keep the other as a control."
})  

output$textout <- renderText({
  rv$data
})
```

Use Href Infobox as Actionbutton