I am new to Shiny and have a basic shiny app using mtcars. I have multiple tabs with some input dropdowns and presenting the output as DT tables. This is all working fine, but I would now like to use some formatting like formattable. Some of the formatting I would like to include is basic percentage, decimal. Also, I would like to add some cell based highlighting. I have tried multiple formatting functions without any luck. I have added functions within the server side output, but I can not get the right combination. Below is my Shiny code:
library(shiny)
library(dplyr)
library(DT)
ui <- fluidPage(
titlePanel("mtcars"),
sidebarLayout(
sidebarPanel(
selectInput("cyl",
"cyl:",
c(unique(as.character(mtcars$cyl)))),
selectInput("gear",
"gear:",
c("All",
unique(as.character(mtcars$gear)))), width=2),
mainPanel(
tabsetPanel(
id = 'dataset',
tabPanel("Summary", DT::dataTableOutput("Summary")),
tabPanel("Detail", DT::dataTableOutput("Detail"))))))
server <- function(input, output) {
output$Detail <- renderDataTable(datatable({
data <- mtcars
if (input$cyl != "All") {
data <- data[data$cyl == input$cyl,]
}
if (input$gear != "All") {
data <- data[data$gear == input$gear,]
}
data
}))
output$Summary <- renderDataTable({
mtcars %>%
filter(cyl==input$cyl) %>%
group_by(gear) %>%
summarise(mpg = median(mpg),
count = n()) %>%
ungroup() %>%
arrange(desc(count))
})}
shinyApp(ui = ui, server = server)
I'm not sure what you've tried so far with formattable, but you should be able to use it with DT in your shiny app.
Here is a quick example you can try. This makes the mpg column a percentage. Also, if colors the count column a shade of green.
Other vignettes are available for other options with formattable package.
output$Summary <- renderDataTable({
my_data <- mtcars %>%
filter(cyl==input$cyl) %>%
group_by(gear) %>%
summarise(mpg = median(mpg),
count = n()) %>%
ungroup() %>%
arrange(desc(count))
# Make percent, for example
my_data$mpg <- percent(my_data$mpg)
# Return formattable datatable
return(
as.datatable(
formattable(
my_data,
list(
count = color_tile("transparent", "green")
)
)
)
)
})
To complete Ben's answer, even if you say you want to use formattable, I think there are enough options in DT to customize the tables the way you want.
Here's your example (randomly customized since you didn't specify the formatting of the cells):
library(shiny)
library(dplyr)
library(DT)
ui <- fluidPage(
titlePanel("mtcars"),
sidebarLayout(
sidebarPanel(
selectInput("cyl",
"cyl:",
c(unique(as.character(mtcars$cyl)))),
selectInput("gear",
"gear:",
c("All",
unique(as.character(mtcars$gear)))), width=2),
mainPanel(
tabsetPanel(
id = 'dataset',
tabPanel("Summary", DT::dataTableOutput("Summary")),
tabPanel("Detail", DT::dataTableOutput("Detail"))))))
server <- function(input, output) {
output$Detail <- renderDataTable(datatable({
data <- mtcars
if (input$cyl != "All") {
data <- data[data$cyl == input$cyl,]
}
if (input$gear != "All") {
data <- data[data$gear == input$gear,]
}
data
}))
output$Summary <- renderDataTable({
your_data <- mtcars %>%
filter(cyl==input$cyl) %>%
group_by(gear) %>%
summarise(mpg = median(mpg),
count = n()) %>%
ungroup() %>%
arrange(desc(count))
datatable(your_data) %>%
formatPercentage(columns = c("mpg", "gear")) %>%
formatRound(columns = c("count"), digits = 3) %>%
formatStyle(columns = "mpg",
valueColumns = "gear",
backgroundColor = styleEqual(c(3, 4, 5), c("red", "blue", "green")))
})}
shinyApp(ui = ui, server = server)
See here for more details, and here for several examples of color-styling.
Related
I am creating a shiny App where it will do two things on mtcars dataset
group data based on user selected values and calculate the mean mpg
and then filter based on selected values to display the output
library(shiny)
library(dplyr)
ui <- fluidPage(
titlePanel(" APP"),
sidebarLayout(
sidebarPanel(selectInput("x","Select cylinder",choices = c(mtcars$cyl),multiple = TRUE),
selectInput("y","Select gear",choices = c(mtcars$gear),multiple = TRUE),
submitButton("Submit")),
mainPanel(
tableOutput("m")
)))
server <- function(input,output){
check <- reactive({
if(is.null(input$x) & is.null(input$y)){
mtcars %>% summarise(Average_mpg = mean(mpg))
}else if(!is.null(input$x) & is.null(input$y)){
a <- mtcars %>% group_by(cyl) %>% summarise(Average_mpg = mean(mpg))
a %>% filter(cyl==input$x)
}else if(is.null(input$x) & !is.null(input$y)){
a <- mtcars %>% group_by(gear) %>% summarise(Average_mpg = mean(mpg))
a %>% filter(gear==input$y)
}else{
a <- mtcars %>% group_by(gear,cyl) %>% summarise(Average_mpg = mean(mpg))
a %>% filter(cyl==input$x & gear==input$y)
}
})
output$m <- renderTable(
check()
)
}
shinyApp(ui = ui, server = server)
Currently I have hard coded all possible combination using if else statement and then realized its not efficient way. If the filters/widgets increase then its difficult to manage
for e.g. If I add one more filter here for variable "carb" in mtcars dataset I have to include all possible scenarios what the user will select and hard code it.
My actual app is having 5 -6 more filters.
Is there any way where whatever the user selects the app will group by on the fly and then filter and show results.
This is not a perfect approach as it still involves some copy & paste and duplicated code. But as a first step it gets rid of the if-else to filter your data:
library(shiny)
library(dplyr)
choices_cyl <- unique(mtcars$cyl)
choices_gear <- unique(mtcars$gear)
ui <- fluidPage(
titlePanel(" APP"),
sidebarLayout(
sidebarPanel(
selectInput("x", "Select cylinder", choices = choices_cyl, multiple = TRUE),
selectInput("y", "Select gear", choices = choices_gear, multiple = TRUE),
submitButton("Submit")
),
mainPanel(
tableOutput("m")
)
)
)
server <- function(input, output) {
check <- reactive({
cyls <- input$x
gears <- input$y
grps <- c("cyl", "gear")[c(!is.null(cyls), !is.null(gears))]
if (is.null(cyls)) cyls <- choices_cyl
if (is.null(gears)) gears <- choices_gear
mtcars %>%
filter(cyl %in% cyls, gear %in% gears) %>%
group_by(across(all_of(grps))) %>%
summarise(Average_mpg = mean(mpg))
})
output$m <- renderTable(
check()
)
}
shinyApp(ui = ui, server = server)
I have a simple shiny that presents descriptive statistics using reactive. However, I would like to use ifelse within tidyverse pipe (and not writing tons of codes). However, I´m not being able to do that. I checked previous post but it´s not working as well. I imagine this part is close to what I want:
students_results <- reactive({
ds %>%
if (input$all_quest == TRUE) { do nothing here!! } else {
filter(domain == input$domain) %>%
group_by(input$quest)
}
summarise(mean(test))
This code is 100% working,
library(shiny)
library(tidyverse)
library(DT)
ds <- data.frame(quest = c(2,4,6,8), domain = c("language", "motor"), test = rnorm(120, 10,1))
ui <- fluidPage(
sidebarLayout(
tabPanel("student",
sidebarPanel(
selectInput("domain", "domain", selected = "language", choices = c("language", "motor")),
selectInput("quest", "Questionnaire", selected = "2", choices = unique(ds$quest)),
checkboxInput("all_quest",
label = "Show all questionnaires",
value = FALSE)
)
),
mainPanel(
dataTableOutput("table")
)
)
)
server <- function(input, output) {
students_results <- reactive({
if (input$all_quest == TRUE) {
ds %>%
group_by(quest, domain) %>%
summarise(mean(test))
}
else {
ds %>%
filter(domain == input$domain) %>%
group_by(input$quest) %>%
summarise(mean(test))
}
})
output$table <- renderDataTable({
students_results()
}
)
}
shinyApp(ui = ui, server = server)
Please check the akrun response below. Everything is working.
We may need to use {} to block the code between the %>%
students_results <- reactive({
ds %>%
{
if (input$all_quest == TRUE) {
.
} else {
{.} %>%
filter(domain == input$domain) %>%
group_by(input$quest)
}
}%>%
summarise(mean(test))
})
Another option is purrr::when which can help to build case_when like pipes. Note that I changed the example code slightly to better show how its working.
library(shiny)
library(tidyverse)
library(DT)
ds <- data.frame(quest = c(2,4,6,8), domain = c("language", "motor"), test = rnorm(120, 10,1))
ui <- fluidPage(
sidebarLayout(
tabPanel("student",
sidebarPanel(
selectInput("domain", "domain", selected = "language", choices = c("language", "motor")),
selectInput("quest", "Questionnaire", selected = "2", choices = unique(ds$quest)),
checkboxInput("all_quest",
label = "Show all questionnaires",
value = FALSE)
)
),
mainPanel(
dataTableOutput("table")
)
)
)
server <- function(input, output) {
students_results <- reactive({
ds %>%
when(input$all_quest == TRUE ~ .,
~ filter(., domain == input$domain) %>%
filter(quest == input$quest) %>%
summarise(mean(test))
)
})
output$table <- renderDataTable({
students_results()
}
)
}
shinyApp(ui = ui, server = server)
I am dynamically generating fluidrows for a uiOutput because the user selection will determine how many rows there are. For each row, I have 3 columns - two are text and the third is a plot.
I've got the text working, but I"m struggling to figure out how to get the plot in there.
In the reprex below it's the same plot, but in my actual example I will need to use a table other than the one passed into map(), but filter it based on one of the .x values.
library(tidyverse)
ui <- fluidPage(
uiOutput("row_mt")
)
server <- function(input, output) {
output$row_mt <- renderUI({
mt_list <- mtcars %>%
rownames_to_column(var = "model") %>%
rowwise() %>%
group_split() %>%
map(~{
tagList(fluidRow(
column(4,
.x$model),
column(4,
.x$mpg),
column(4,
mtcars %>%
filter(cyl == .x$cyl) %>%
ggplot(aes(x = mpg, y = cyl)) + geom_point())
),
br()
)
})
tagList(mt_list)
})
}
shinyApp(ui, server)
You should try to create the plot with renderPlot, and then display it in the renderUI with a plotOutput.
Try this
server <- function(input, output) {
output$myplot <- renderPlot({
mtcars %>%
rownames_to_column(var = "model") %>%
rowwise() %>%
group_split() %>%
map(~{
mtcars %>%
filter(cyl == .x$cyl) %>%
ggplot(aes(x = mpg, y = cyl)) + geom_point()
})
})
output$row_mt <- renderUI({
mt_list <- mtcars %>%
rownames_to_column(var = "model") %>%
rowwise() %>%
group_split() %>%
map(~{
tagList(fluidRow(
column(4,
.x$model),
column(4,
.x$mpg),
column(4,
plotOutput("myplot", height=100, width=100))
),
br()
)
})
tagList(mt_list)
})
}
In the example below, I am trying to produce a box and plot for each group within a dataset, using lapply within a renderUI function. However, some of these groups require an additional filter as they have sub-groupings.
This means creating a selectInput inside the box for those groups only and having the corresponding chart reference that selectInput only.
Here's the reproducible example... my problem is in the lapply loop creating a selectInput with the inputID of paste("selector_",i) and then immediately referencing this in the data to be output inside the corresponding box with input$(what goes here?)
library(shiny)
library(shinydashboard)
library(tidyverse)
library(nycflights13)
library(DT)
data <- planes %>%
select(manufacturer, type, model, year, seats) %>%
unique() %>%
filter(!is.na(year)) %>%
mutate(year = as.character(year))
ui <- dashboardPage(
dashboardHeader(title = "Testing"),
dashboardSidebar(),
dashboardBody(
fluidRow(
column(12, selectInput("type","Type", choices = unique(data$type)),
uiOutput("mytabs"))
)
)
)
server <- function(input, output) {
data_filtered <- reactive({
req(input$type)
data %>%
filter(type == input$type)
})
mfrs <- reactive({
data_filtered() %>%
select(manufacturer) %>%
unique() %>%
pull()
})
output$mytabs = renderUI({
fluidRow(
lapply(mfrs(), function(i) {
dt <- data_filtered() %>%
filter(manufacturer == i) %>%
arrange(year) %>%
select(model, year, seats)
models <- dt %>%
filter(!is.na(model)) %>%
select(model) %>%
unique() %>%
pull()
if(length(models) > 1) {
box(id = paste0('card', i), title = paste(i),
selectInput(inputId = paste0("selector_",i), "Question",
choices = models, selected = models[1]),
DT::datatable(dt[dt$qntext == input$the_one_above],
width = "100%", rownames = F,
options = list(
columnDefs = list(list(width = '40px', targets = "_all"))
))
)
} else {
box(id = paste0('card', i), title = paste(i),
DT::datatable(dt,
width = "100%", rownames = F,
options = list(
columnDefs = list(list(width = '40px', targets = "_all"))
))
)
}
})
)
})
}
shinyApp(ui, server)
As I am not sure what qns means, I have assigned qns to be models. Try this code:
data <- planes %>%
select(manufacturer, type, model, year, seats) %>%
unique() %>%
filter(!is.na(year)) %>%
mutate(year = as.character(year))
ui <- dashboardPage(
dashboardHeader(title = "Testing"),
dashboardSidebar(uiOutput("myqns")),
dashboardBody(
fluidRow(
column(12, selectInput("type","Type", choices = unique(data$type)), uiOutput("mytabs"))
)
)
)
server <- function(input, output) {
data_filtered <- reactive({
req(input$type)
data %>%
filter(type == input$type)
})
mfrs <- reactive({
req(data_filtered())
data_filtered() %>%
select(manufacturer) %>%
unique() %>%
pull()
})
output$myqns <- renderUI({
req(mfrs())
lapply(1:length(mfrs()), function(i) {
dt <- data_filtered() %>%
filter(manufacturer == mfrs()[i]) %>%
arrange(year) %>%
select(model, year, seats)
models <- dt %>%
filter(!is.na(model)) %>%
select(model) %>%
unique() %>%
pull()
qns <- models
selectInput(inputId = paste0("selector_",i), paste("Question",i), choices = as.list(qns), selected = 1)
})
})
output$mytabs = renderUI({
req(mfrs())
fluidRow(
lapply(1:length(mfrs()), function(i) {
req(input[[paste0("selector_",i)]])
dt <- data_filtered() %>%
filter(manufacturer == mfrs()[i]) %>%
arrange(year) %>%
select(model, year, seats)
models <- dt %>%
filter(!is.na(model)) %>%
select(model) %>%
unique() %>%
pull()
qns <- models
if(length(models) > 1) {
box(id = paste0('card', i), title = paste(mfrs()[i]),
# selectInput(inputId = paste0("selector_",i), "Question",
# choices = qns, selected = qns[1]),
DT::datatable(dt[dt$model == input[[paste0("selector_",i)]], ],
width = "100%", rownames = F,
options = list(
columnDefs = list(list(width = '40px', targets = "_all"))
))
)
} else {
box(id = paste0('card', i), title = paste(mfrs()[i]),
DT::datatable(dt,
width = "100%", rownames = F,
options = list(
columnDefs = list(list(width = '40px', targets = "_all"))
))
)
}
})
)
})
}
shinyApp(ui, server)
Answered by the awesome Paul Campbell... using modules.
library(shinydashboard)
library(tidyverse)
library(highcharter)
library(nycflights13)
# Modules ===============================================
# UI and server module for box with chart
box_chart_UI <- function(id, title) {
ns <- NS(id)
box(
title = title, height = 550,
highcharter::highchartOutput(ns("chart"))
)
}
box_chart <- function(input, output, session, df) {
output$chart <- renderHighchart({
validate(need(nrow(df) > 0, "No data"))
hchart(df, "column", hcaes(year, seats))
})
}
# UI and server module for box with chart and filter
box_chart_filter_UI <- function(id, title, filters, filter_lab = "Model") {
ns <- NS(id)
box(
title = title, height = 550,
selectInput(inputId = ns("selector"), label = filter_lab, choices = filters),
highchartOutput(ns("chart"))
)
}
box_chart_filter <- function(input, output, session, df) {
output$chart <- renderHighchart({
req(input$selector)
df_chart <- df %>% filter(model == input$selector)
validate(need(nrow(df_chart) > 0, "No data"))
hchart(df_chart, "column", hcaes(year, seats))
})
}
# Main App ===============================================
# load app data
data <- planes %>%
select(manufacturer, type, model, year, seats) %>%
unique() %>%
filter(!is.na(year)) %>%
mutate(year = as.character(year))
ui <- dashboardPage(
dashboardHeader(title = "Testing"),
dashboardSidebar(),
dashboardBody(
fluidRow(
column(
width = 12,
selectInput("type", "Type", choices = unique(data$type))
)
),
uiOutput("mytabs")
)
)
server <- function(input, output, session) {
data_filtered <- reactive({
req(input$type)
data %>% filter(type == input$type)
})
mfrs <- reactive({
data_filtered() %>%
distinct(manufacturer) %>%
pull()
})
# first load all the UI module functions
output$mytabs <- renderUI({
fluidRow(
lapply(1:length(mfrs()), function(i) {
models <- data_filtered() %>%
filter(manufacturer == mfrs()[i], !is.na(model)) %>%
distinct(model) %>%
pull() %>%
sort()
# depending on how many models, load the correct UI module
if (length(models) > 1) {
box_chart_filter_UI(id = i, title = mfrs()[i], filters = models)
} else {
box_chart_UI(id = i, title = mfrs()[i])
}
})
)
})
# now separately load the module server functions
# need to do this inside an observe due to reactive objects
observe({
lapply(1:length(mfrs()), function(i) {
dt <- data_filtered() %>%
filter(manufacturer == mfrs()[i]) %>%
arrange(year) %>%
select(model, year, seats)
models <- dt %>%
filter(!is.na(model)) %>%
distinct(model) %>%
pull() %>%
sort()
# depending on how many models, load the correct server module
if (length(models) > 1) {
callModule(box_chart_filter, id = i, df = dt)
} else {
callModule(box_chart, id = i, df = dt)
}
})
})
}
shinyApp(ui, server)
I am trying to build a shiny app that gives user the flexibility to choose the variables for group by and summarize. Checkbox will have an option for selecting group by variables. Right now I haven't given measure variables as selections, since I struggling with group by. I want the numbers to be aggregated basis the selection.
library(shiny)
library(ggplot2) # for the diamonds dataset
library(shinydashboard)
library(dplyr)
y1<-diamonds
ui <- fluidPage(
checkboxGroupInput("variable", "Variables to show:",
c("cut","color","clarity"),selected = "cut"),
tableOutput("data"),
textOutput("result")
)
server <- function(input, output, session) {
base <- reactive({
groupby <- enquo(input$variable)
print(groupby)
res <-y1%>% group_by(!!!groupby,x) %>%
tally() %>%
ungroup() %>%
summarise(sum = sum(x)) %>%
pull()
res
})
output$result <- renderText({
input$variable
})
output$data<-renderTable({
base()
}
)
}
shinyApp(ui, server)
Thanks,
Hema
I'm not sure that I understood your question exactly, but maybe something like this:
library(shiny)
library(ggplot2) # for the diamonds dataset
library(shinydashboard)
library(dplyr)
y1<-diamonds
ui <- fluidPage(
checkboxGroupInput("variable", "Variables to show:",
c("cut","color","clarity"),selected = "cut"),
tableOutput("data"),
textOutput("result")
)
server <- function(input, output, session) {
base <- reactive({
res <- y1 %>% group_by(eval(parse(text = input$variable)),x) %>%
tally() %>%
#ungroup() %>%
summarise(sum = sum(x)) %>%
pull()
res
})
output$result <- renderText({
input$variable
})
output$data<-renderTable({
base()
})
}
shinyApp(ui, server)
if it's possible to select multiple from the check boxes such that you'd want something like group_by(x,y) this may help you get what you want:
group_by(across(all_of(input$group)))