Formatting being lost on a shiny app when using column - r

I have a shiny dashboard where i am using a tab Panel and in that panel I'm trying to place two summary tables side by side
The tables seem to lose the background of the tabPanel
Does anyone know why
Reproducible example below
library(shiny)
library(shinydashboard)
library(dplyr)
data(iris)
server <- function(input, output) {
output$top_Length = renderTable({
mydf <- iris %>%
arrange(desc(Sepal.Length)) %>%
slice(1:10)
mydf
})
output$top_width = renderTable({
mydf <- iris %>%
arrange(desc(Sepal.Width)) %>%
slice(1:10)
})
}
header <- dashboardHeader(title = "Flower Power")
sidebar <- dashboardSidebar(disable = TRUE)
body <- dashboardBody(fluidRow(
tabBox(title = "Charting Information",width = 9,
tabPanel("Trending"),
tabPanel("Details",
column(4,
h2('Top Sepal Length'),
tableOutput('top_Length')
),
column(3,
h2('Top Sepal Width'),
tableOutput('top_width')
)
)
)
))
ui <- dashboardPage(
skin = "yellow",
header,
sidebar,
body
)
shinyApp(ui = ui, server = server)

Use fluidRow to prevent overlapping as below:
fluidRow( column(4,
h2('Top Sepal Length'),
tableOutput('top_Length',width="200")
),
column(3,
h2('Top Sepal Width'),
tableOutput('top_width') )
)

Related

Skip decimal numbers from values with "thousands" mark in a DT::datatable()

In the DT::datatable() of my shiny app below I have found how to add "thousands" mark )(.) in my table but I want to get rid of the decimals numbers.
library(shiny)
library(shinydashboard)
library(DT)
## app.R ##
library(shiny)
library(shinydashboard)
library(DT)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
),
dashboardBody(
dataTableOutput("table")
)
)
server <- function(input, output) {
iris<-iris[,1:4]*100000
output$table <- renderDataTable({
datatable(iris) %>%
formatCurrency(columns = c("Sepal.Length","Sepal.Width","Petal.Length","Petal.Width"), currency = "", interval = 3, mark = ".") %>%
formatStyle(
columns = c("Sepal.Length")
) })
}
shinyApp(ui, server)
Just add digits=0 to the formatCurrency().

How to create a checkBoxGroup item under a menuItem or fixed box in shiny dashboard sidebar?

I am creating a shiny dashboard that displays data tables in the body. I am trying to add a sidebar on the side with checkboxgroup that filters the data table. Right now the check boxes show but title and the option names are missing. If I do not use the sidebar and put the checkboxes in the dashboard body it does show. But I am trying to put in sidebar or fixed on the side of the page.
library(shiny)
library(shinydashboard)
library(tidyverse)
df <- mpg
header <- dashboardHeader(
title = "NSCLC Market Share"
)
body <- dashboardBody(
fluidRow(
column(width = 9,
tabBox(width = NULL,
title = "MarketShare",
id = "tabset1", height = "250px",
tabPanel("Incidence",
tableOutput('mpg_tbl'),
br(),
tabPanel("Prevalence", "Tab content 2")
)
)
)
))
sidebar <- dashboardSidebar(box(width = NULL, status = "warning",
checkboxGroupInput('modelFilter', "Select model",
choices =
unique(df$model),
selected = unique(df$model)
)),
br(),
box(width = NULL, status = "warning",
uiOutput("classFilter"),
checkboxGroupInput('classFilter', "Select class",
choices = unique(df$class),
selected = unique(df$class)
))
)
ui <- dashboardPage(
header,
sidebar,
body
)
server = function(input, output) {
filtData <- reactive({
df %>%
filter(model %in% input$modelFilter) %>%
filter(class %in% input$classFilter ) %>%
group_by(manufacturer) %>%
summarise(count = n())
})
output$mpg_tbl <- renderTable(
filtData()
)
}
# Run the application
shinyApp(ui = ui, server = server)
The issue is because of box, if you remove that it works -
library(shiny)
library(shinydashboard)
library(tidyverse)
df <- mpg
header <- dashboardHeader(
title = "NSCLC Market Share"
)
body <- dashboardBody(
fluidRow(
column(width = 9,
tabBox(width = NULL,
title = "MarketShare",
id = "tabset1", height = "250px",
tabPanel("Incidence",
tableOutput('mpg_tbl'),
br(),
tabPanel("Prevalence", "Tab content 2")
)
)
)
))
sidebar <- dashboardSidebar(checkboxGroupInput('modelFilter', "Select model",
choices =
unique(df$model),
selected = unique(df$model)
),
br(),
checkboxGroupInput('classFilter', "Select class",
choices = unique(df$class),
selected = unique(df$class)
)
)
ui <- dashboardPage(
header,
sidebar,
body
)
server = function(input, output) {
filtData <- reactive({
df %>%
filter(model %in% input$modelFilter) %>%
filter(class %in% input$classFilter ) %>%
group_by(manufacturer) %>%
summarise(count = n())
})
output$mpg_tbl <- renderTable(
filtData()
)
}
# Run the application
shinyApp(ui = ui, server = server)

Store and print cell values based on multiple DT row selection in a shiny dashboard

I have a shiny dashboard below in which I want to be able to select multiple rows from the datatable and when the user selects a row and presses the actionbutton the relative mpg cells to be displayed in the box. Now I can store only my first selection.
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu()
),
dashboardBody(
uiOutput("jobs")
)
)
server <- function(input, output, session) {
# helper for debugging
observeEvent(input$action, {
print(mtcars)
})
# graph
# jobs UI
output$jobs <- renderUI({
list(
fluidRow(
uiOutput("job_selected")),
fluidRow(
DTOutput("jobslist")))
})
output$jobslist <- renderDT({
if (!is.null(mtcars)) {
r <- mtcars %>%
select(mpg,cyl,disp,hp,drat,wt)
datatable(r,
# escape = F,
selection = "multiple",
options = list(
columnDefs = list(list(searchable = F, targets = c(2, 5)))),
filter = "top")
}
})
output$job_selected <- renderUI({
req(input$jobslist_rows_selected)
list(
box(width = 6,
mtcars %>%
filter(row_number() %in% input$jobslist_rows_selected) %>%
pull(mpg),
tags$br(),
actionButton("assignCB", "assigned selected to CB")
)
)
})
}
shinyApp(ui, server)
I think you're complicating things a little bit here. You don't need renderUI/uiOutput. I would just define a box, the action button and the datatable outputs; use an eventReactive tied to the button to only get the selected rows (and generate the text from them) when the button is clicked; and renderText tied to the eventReactive variable.
library(shiny)
library(shinydashboard)
library(DT)
library(dplyr)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
box(
title='selected',
width = 6,
solidHeader = TRUE,
status = "primary",
textOutput('selected_rows')),
actionButton("get_selected_rows", 'Get selected rows'),
DTOutput("my_dt"))
)
server <- function(input, output, session) {
# show DT
output$my_dt <- renderDT({
mtcars %>%
select(mpg, cyl, disp, hp, drat, wt) %>%
datatable(
selection = "multiple",
options = list(
columnDefs = list(list(searchable = F, targets = c(2, 5)))),
filter = "top")
})
# store data as text variable
my_selected_rows <- eventReactive(input$get_selected_rows, {
rows_selected <- input$my_dt_rows_selected
selected_values <- mtcars %>%
filter(row_number() %in% rows_selected) %>%
select(mpg)
unlist(selected_values)
})
# render text variable to be used in textOutput
output$selected_rows <- renderText({
my_selected_rows()
})
}
shinyApp(ui, server)

Why renderTable() does not giving any output in shinyApp for selectInput items?

I want to display tabular data while input select entered in shinyUI.
Here is my code:
library(shiny)
library(shinydashboard)
library(dplyr)
ui <- shinyUI(
dashboardPage(
dashboardHeader(),
dashboardSidebar(disable = TRUE),
dashboardBody(
selectInput("filt", "Datafiltered",
choices = unique(comor$DiagnosisProvided),
multiple = TRUE),
tableOutput("tab1")
)
)
)
server <- shinyServer(
function(input, output, session) {
output$tab1 <- renderTable({
apl <- data %>% filter(DiagnosisProvided == input$filt)
})
}
)
shinyApp(ui,server)
I am getting error "Result must have length 707, not 0"
I would like to upload my data. Is there any link to upload my data?
Can anyone help me on renderTable() output ?
as you have not given any data sample to make it reproducible, I tried to built the same as per my understandings with IRIS Data. Hope this can solve your issue.
UI.R
library(shiny)
library(shinydashboard)
library(shinyglide)
dashboardPage(
dashboardHeader(title = "Basic dashboard"),
dashboardSidebar(
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard"))
)
),
dashboardBody(
useShinyalert(),
tabItems(
tabItem(tabName = "dashboard",
fluidRow(
column(3,
uiOutput("filter")
),
column(9,
tableOutput("tab")
)
)
)
)
)
)
Server.R
library(shiny)
library(shinydashboard)
library(dplyr)
shinyServer(function(input,output){
####### Your data ######
data<-iris
output$filter<-renderUI({
selectInput("filter_select","Select Filter",choices = unique(data$Species))
})
output$tab<-renderTable({
if(is.null(input$filter_select))
{
returnValue()
}
else
{
show_data<-data %>% filter(Species == input$filter_select)
show_data
}
})
})
The error is caused by data %>% filter(DiagnosisProvided == input$filt), because input$filt is an empty array. You can reproduce this error by:
iris %>% filter(Sepal.Length == NULL)
.... Result must have length 150, not 0
So check your unique(comor$DiagnosisProvided) it looks like it is empty. And then instead of using the == replace it by %in%:
data %>% filter(DiagnosisProvided %in% input$filt)

R- Shiny - how to change color of legends in pie chart?

I want to change the color of legends in piechart.
Here is the code:
library(ECharts2shiny)
library(shiny)
dat5 <- c(rep("Female", 3376), rep("Male", 2180))
ui <- shinyUI(
dashboardPage(dashboardHeader(title = "PSM"),
dashboardBody(
mainPanel(
tabsetPanel(
tabPanel(
loadEChartsLibrary(), tags$div(id="test5",
style="width:60%;height:300px;"),
deliverChart(div_id = "test5"))
server <- shinyServer(function(input,output){
renderPieChart(div_id = "test5", data = dat5 ) })
Can anybody help me how to change the legends color?
hope it helps:
library(shiny)
library(shinydashboard)
dat5 <- c(rep("Female", 3376), rep("Male", 2180))
app <- shinyApp(
ui <- shinyUI(
dashboardPage(dashboardHeader(title = "PSM"),
dashboardSidebar(),
dashboardBody(
mainPanel(
tabsetPanel(
tabPanel(tags$div(id="test5",
style="width:60%;height:300px;"),
plotOutput("pie_chart"))
))))
),
server <- shinyServer(function(input,output){
output$pie_chart <- renderPlot({
df <- table(dat5)
cols <- rainbow(length(df))
pie(df, col = cols)
})
})
)
runApp(app)

Resources