I want to do operations on data that has been split into tables. The operations should actually affect all tables eg sum of a column
Here is the code I used to split the data frame.
library(shiny)
ui <- fluidPage(
uiOutput("mytabs")
)
server <- function(input, output) {
df1 <- reactive (split(iris, iris$Species))
output$mytabs <- renderUI({
thetabs <- lapply(paste0('table_', names(df1())),
function(x) {
tabPanel(x,
tableOutput(x))
})
do.call(tabsetPanel, thetabs)
})
observe({
lapply(names(df1()), function(x) {
output[[paste0("table_", x)]] <- renderTable({ df1()[x] })
})
})
}
shinyApp(ui = ui, server = server)
We can add a bslib::value_box in the same tabPanel that the tableOutput goes.
Here's an example, notice the use of map2 instead of lapply, this is to loop through the character with the name of the tables and the tables themselves.
thetabs <- purrr::map2(
paste0("table_", names(df1())),
df1(),
function(x, y) {
tabPanel(
title = x,
value_box(
title = glue::glue("Sum of {x}"),
value = sum(y[['Sepal.Length']]),
showcase = bs_icon("plus")
),
tableOutput(x)
)
}
)
App:
library(shiny)
library(bslib)
library(bsicons)
ui <- fluidPage(
uiOutput("mytabs")
)
server <- function(input, output) {
df1 <- reactive(split(iris, iris$Species))
output$mytabs <- renderUI({
thetabs <- purrr::map2(
paste0("table_", names(df1())),
df1(),
function(x, y) {
tabPanel(
title = x,
value_box(
title = glue::glue("Sum of {x}"),
value = sum(y[['Sepal.Length']]),
showcase = bs_icon("plus")
),
tableOutput(x)
)
}
)
do.call(tabsetPanel, thetabs)
})
observe({
lapply(names(df1()), function(x) {
output[[paste0("table_", x)]] <- renderTable({
df1()[x]
})
})
})
}
shinyApp(ui = ui, server = server)
I am facing an issue in updating the data selected using SelectInput and modules in Shiny. In a few words, when I select the data to be loaded into the selectInput panel, it updates it on the first selection, but if I then want to go from dataset 1 to dataset 2, the data does not update.
Below you cand find the code to reproduce the specific problem.
# Libraries
pacman::p_load(shiny, shinydashboard,
tidyverse, data.table, DT, stringr,
ggplot2, plotly,
survival, survminer, GGally, scales,
shinycssloaders)
version <- 0.1
# GENERAL PARAMETERS
box.height <<- 700
select.box.height <<- 150
selectAB.box.height <<- 250
select.box.width <<- 12
# Data
men1_1.norm <<- as.numeric(rnorm(50))
men1_1.pois <<- as.numeric(rpois(50, lambda = 1))
men1_2.norm <<- as.numeric(rnorm(50, mean = 1))
men1_2.pois <<- as.numeric(rpois(50, lambda = 2))
# ui modules
LoadDataUI <- function(id,
label = "Select the data:",
sel = "Data 1",
choic = c('Data 1','Data 2')){
ns <- NS(id)
selectInput(ns("data.sel"),
label = label,
choices = choic,
selected = sel)
}
PlotUI <- function(id){
ns <- NS(id)
plotOutput(ns("plot"))
}
# ui
ui <- dashboardPage(
dashboardHeader(title = paste('My Dashboard',version,sep='')),
dashboardSidebar(
sidebarMenu(
id = "sbMenu",
#Tabs for different data displays
menuItem("1st Menu", tabName = "men1", icon = icon('microscope'))
)
),
dashboardBody(
tabItems(
tabItem(tabName = 'men1',
h2(strong('tab 1')),
fluidRow(
### !!!! TO REMOVE ERROR MESSAGES !!!!
# tags$style(type="text/css",
# ".shiny-output-error { visibility: hidden; }",
# ".shiny-output-error:before { visibility: hidden; }"
#,
box(title='Select data to load:', height= select.box.height, width = select.box.width,
LoadDataUI("data1")
),
box(title='Normal', height=box.height,
PlotUI("hist_norm1")
),
box(title='Poisson', height=box.height,
PlotUI("hist_pois1")
)
)
)
)
)
)
# server modules
Panel <- function(id){
moduleServer(
id,
function(input, output, session) {
return(
list(
data = reactive({input$data.sel})
)
)
}
)
}
LoadDataServer <- function(id, menu, data_selected
){
moduleServer(
id,
function(input, output, session){
dt <- reactive(data_selected)
data <- reactiveValues(norm = NULL,
pois = NULL)
data$norm <- reactive({get(paste0(menu(),"_", dt(), ".norm"), envir = .GlobalEnv)})
data$pois <- reactive({get(paste0(menu(),"_", dt(), ".pois"), envir = .GlobalEnv)})
return(
data
)
}
)
}
PlotServer <- function(id,data = NULL){
moduleServer(
id,
function(input, output, session) {
x <- reactive(as.numeric(data))
output$plot <- renderPlot({
hist(x(), col = 'darkgray', border = 'white')
})
# output$plot <- renderPlot({
# if(is.null(data)){return(NULL)}else{
# hist(data, col = 'darkgray', border = 'white')}
# })
}
)
}
# server
server <- function(input, output, session){
data1 <- Panel("data1")
observeEvent(data1$data(), {
updateSelectInput(session, 'data.sel', selected = input$data.sel)
})
pnl1 <- reactive(
switch(data1$data(),
"Data 1" = "1",
"Data 2" = "2")
)
d1 <- LoadDataServer("data1", menu = reactive({input$sbMenu}), data_selected = pnl1())
# Plot
# menu1
output$plot <- PlotServer("hist_norm1", data = d1$norm())
output$plot <- PlotServer("hist_pois1", data = d1$pois())
}
shinyApp(ui, server)
Thanks!
Try this
version <- 0.1
# GENERAL PARAMETERS
box.height <<- 500
select.box.height <<- 150
selectAB.box.height <<- 250
select.box.width <<- 12
# Data
men1_1.norm <<- as.numeric(rnorm(50))
men1_1.pois <<- as.numeric(rpois(50, lambda = 1))
men1_2.norm <<- as.numeric(rnorm(150, mean = 1))
men1_2.pois <<- as.numeric(rpois(150, lambda = 2))
# ui modules
LoadDataUI <- function(id,
label = "Select the data:",
sel = "Data 1",
choic = c('Data 1','Data 2')){
ns <- NS(id)
selectInput(ns("data.sel"),
label = label,
choices = choic,
selected = sel)
}
PlotUI <- function(id){
ns <- NS(id)
tagList(
plotOutput(ns("plot"))
)
}
# ui
ui <- dashboardPage(
dashboardHeader(title = paste('My Dashboard',version,sep='')),
dashboardSidebar(
sidebarMenu(
id = "sbMenu",
#Tabs for different data displays
menuItem("1st Menu", tabName = "men1", icon = icon('microscope'))
)
),
dashboardBody(
tabItems(
tabItem(tabName = 'men1',
h2(strong('tab 1')),
fluidRow(
### !!!! TO REMOVE ERROR MESSAGES !!!!
# tags$style(type="text/css",
# ".shiny-output-error { visibility: hidden; }",
# ".shiny-output-error:before { visibility: hidden; }"
#,
box(title='Select data to load:', height= select.box.height, width = select.box.width,
LoadDataUI("data1")
),
box(title='Normal', height=box.height,
PlotUI("hist_norm1")
),
box(title='Poisson', height=box.height,
PlotUI("hist_pois1")
)
)
)
)
)
)
# server modules
Panel <- function(id){
moduleServer(
id,
function(input, output, session) {
return(
list(
data = reactive({input$data.sel})
)
)
}
)
}
LoadDataServer <- function(id, menu, data_selected
){
moduleServer(
id,
function(input, output, session){
dt <- reactive(
switch(data_selected(),
"Data 1" = "1",
"Data 2" = "2")
)
observe({print(dt())})
data <- reactiveValues(norm = NULL,
pois = NULL)
data$norm <- reactive({get(paste0(menu(),"_", dt(), ".norm"), envir = .GlobalEnv)})
data$pois <- reactive({get(paste0(menu(),"_", dt(), ".pois"), envir = .GlobalEnv)})
return(
data
)
}
)
}
PlotServer <- function(id,data){
moduleServer(
id,
function(input, output, session) {
#x <- reactive(as.numeric(data))
output$plot <- renderPlot({
x <- as.numeric(data())
hist(x, col = 'darkgray', border = 'white')
})
# output$plot <- renderPlot({
# if(is.null(data)){return(NULL)}else{
# hist(data, col = 'darkgray', border = 'white')}
# })
}
)
}
# server
server <- function(input, output, session){
data1 <- Panel("data1")
# observeEvent(data1$data(), {
# updateSelectInput(session, 'data.sel', selected = input$data.sel)
# })
# pnl1 <- reactive(
# switch(data1$data(),
# "Data 1" = "1",
# "Data 2" = "2")
# )
d1 <- LoadDataServer("data1", menu = reactive({input$sbMenu}), data_selected = data1$data )
# Plot
# menu1
PlotServer("hist_norm1", data = reactive(d1$norm()) )
PlotServer("hist_pois1", data = reactive(d1$pois()) )
}
shinyApp(ui, server)
The problem arises because the data you pass to the PlotServer is not reactive. I've made the additional changes:
stored the data in the beginning in a list to avoid using get; it's easier and safer to directly work with a data object
removed the data_selected argument from the LoadDataServer as this information is determined by the input$data.sel variable, however this is only accessible from within the module and not the the main app server. For the initialisation, you need this information only in the UI part of the module (which you already have implemented). This allows me to remove observeEvent code in your main app server as this is handled by the module.
# Libraries
# pacman::p_load(shiny, shinydashboard,
# tidyverse, data.table, DT, stringr,
# ggplot2, plotly,
# survival, survminer, GGally, scales,
# shinycssloaders)
library(shiny)
library(shinydashboard)
library(ggplot2)
version <- 0.1
# GENERAL PARAMETERS
box.height <<- 700
select.box.height <<- 150
selectAB.box.height <<- 250
select.box.width <<- 12
# Data
data_object <- list(
men1_1 = list(
norm = as.numeric(rnorm(50)),
pois = as.numeric(rpois(50, lambda = 1))
),
men1_2 = list(
norm = as.numeric(rnorm(50, mean = 1)),
pois = as.numeric(rpois(50, lambda = 2))
)
)
# ui modules
LoadDataUI <- function(id,
label = "Select the data:",
sel = "Data 1",
choic = c('Data 1' = "1",'Data 2' = "2")){
ns <- NS(id)
selectInput(ns("data.sel"),
label = label,
choices = choic,
selected = sel)
}
PlotUI <- function(id){
ns <- NS(id)
plotOutput(ns("plot"))
}
# ui
ui <- dashboardPage(
dashboardHeader(title = paste('My Dashboard',version,sep='')),
dashboardSidebar(
sidebarMenu(
id = "sbMenu",
#Tabs for different data displays
menuItem("1st Menu", tabName = "men1", icon = icon('microscope'))
)
),
dashboardBody(
tabItems(
tabItem(tabName = 'men1',
h2(strong('tab 1')),
fluidRow(
### !!!! TO REMOVE ERROR MESSAGES !!!!
# tags$style(type="text/css",
# ".shiny-output-error { visibility: hidden; }",
# ".shiny-output-error:before { visibility: hidden; }"
#,
box(title='Select data to load:', height= select.box.height, width = select.box.width,
LoadDataUI("data1")
),
box(title='Normal', height=box.height,
PlotUI("hist_norm1")
),
box(title='Poisson', height=box.height,
PlotUI("hist_pois1")
)
)
)
)
)
)
# server modules
Panel <- function(id){
moduleServer(
id,
function(input, output, session) {
return(
list(
data = reactive({input$data.sel})
)
)
}
)
}
LoadDataServer <- function(id, menu
){
moduleServer(
id,
function(input, output, session){
data <- reactiveValues(norm = NULL,
pois = NULL)
observeEvent(input$data.sel, {
data$norm <- data_object[[paste0(menu(), "_", input$data.sel)]][["norm"]]
data$pois <- data_object[[paste0(menu(), "_", input$data.sel)]][["pois"]]
})
return(
data
)
}
)
}
PlotServer <- function(id,data = NULL){
moduleServer(
id,
function(input, output, session) {
output$plot <- renderPlot({
hist(data(), col = 'darkgray', border = 'white')
})
}
)
}
# server
server <- function(input, output, session){
d1 <- LoadDataServer("data1", menu = reactive({input$sbMenu}))
# Plot
# menu1
output$plot <- PlotServer("hist_norm1", data = reactive({d1$norm}))
output$plot <- PlotServer("hist_pois1", data = reactive({d1$pois}))
}
shinyApp(ui, server)
If you pass the complete d1 object to the PlotServer, you could remove the reactive({}) you currently need to pass the norm or pois data.
I recommend to read into how to pass data between modules and module capsulation, you can start with mastering shiny or my introduction to modules.
I am working in a shiny app to compare multiple items according to an input defined by the user. The code works fine but I have an issue. I do not know what function I should apply in order to display the results of some computing as tables in the right side of the app. The code of the app is next:
library(shiny)
library(shinydashboard)
#Function
compute <- function(firstitem,seconditem)
{
Sum <- firstitem+seconditem
Difference <- firstitem+seconditem
Product <- firstitem*seconditem
Ratio <- firstitem/seconditem
Res <- data.frame(C1=Sum,C2=Difference,C3=Product,C4=Ratio)
return(Res)
}
#App
ui = shinyUI(fluidPage(
titlePanel("Compare"),
sidebarLayout(
sidebarPanel(
numericInput("numitems", label = "Number of items to compare?",
min = 1, max = 5, value = 1),
uiOutput("period_cutpoints"),
uiOutput("period_cutpoints2"),
actionButton("submit", "Submit")
),
mainPanel(
textOutput("numitems"),
textOutput("cutpoints")
)
)
))
server = shinyServer(function(input, output, session) {
output$period_cutpoints<-renderUI({
req(input$numitems)
lapply(1:(input$numitems), function(i) {
numericInput(inputId=paste0("firstitem",i),
label=paste0("Enter the value of first item ", i, ":"),value = 0)
})
})
output$period_cutpoints2<-renderUI({
req(input$numitems)
lapply(1:(input$numitems), function(i) {
numericInput(inputId=paste0("seconditem",i),
label=paste0("Enter the value of second item ", i, ":"),value = 0)
})
})
seldates <- reactiveValues(x=NULL)
observeEvent(input$submit, {
seldates$x <- list()
lapply(1:(input$numitems), function(i) {
seldates$x[[i]] <- compute(firstitem = input[[paste0("firstitem", i)]],seconditem = input[[paste0("seconditem", i)]])
})
})
output$cutpoints <- renderText({as.character(seldates$x)})
})
shinyApp(ui = ui, server = server)
It is working but my issue is that I do not know how to set the content of seldates, which are dataframes, as tables that should appear one after another. This task is done with output$cutpoints but I can not get them as Tables:
Does anybody know how can I fix this issue? Many thanks!
Try this
library(shiny)
library(shinydashboard)
library(DT)
#Function
compute <- function(firstitem,seconditem)
{
Sum <- firstitem+seconditem
Difference <- firstitem+seconditem
Product <- firstitem*seconditem
Ratio <- firstitem/seconditem
Res <- data.frame(C1=Sum,C2=Difference,C3=Product,C4=Ratio)
return(Res)
}
#App
ui = shinyUI(fluidPage(
titlePanel("Compare"),
sidebarLayout(
sidebarPanel(
numericInput("numitems", label = "Number of items to compare?",
min = 1, max = 5, value = 1),
uiOutput("period_cutpoints"),
uiOutput("period_cutpoints2"),
actionButton("submit", "Submit")
),
mainPanel(
textOutput("numitems"),
textOutput("cutpoints"),
uiOutput("t1")
)
)
))
server = shinyServer(function(input, output, session) {
output$period_cutpoints<-renderUI({
req(input$numitems)
lapply(1:(input$numitems), function(i) {
numericInput(inputId=paste0("firstitem",i),
label=paste0("Enter the value of first item ", i, ":"),value = i)
})
})
output$period_cutpoints2<-renderUI({
req(input$numitems)
lapply(1:(input$numitems), function(i) {
numericInput(inputId=paste0("seconditem",i),
label=paste0("Enter the value of second item ", i, ":"),value = i+i)
})
})
seldates <- reactiveValues(x=NULL)
observeEvent(input$submit, {
seldates$x <- list()
lapply(1:(input$numitems), function(i) {
seldates$x[[i]] <- compute(firstitem = input[[paste0("firstitem", i)]],seconditem = input[[paste0("seconditem", i)]])
})
})
output$cutpoints <- renderText({as.character(seldates$x)})
observeEvent(input$submit, {
lapply(1:(input$numitems), function(i) {
output[[paste0("table",i)]] <- renderDT(seldates$x[[i]])
})
output$t1 <- renderUI({
tagList(
lapply(1:(input$numitems), function(i) {
DTOutput(paste0("table",i))
})
)
})
})
})
shinyApp(ui = ui , server = server)
I am working on a dashboard and I want to use a data frame to generate the boxes and descriptions. I can use lapply to make the boxes, but I can't figure out how to pull the description from the data frame. So far I have (without the descriptions):
library(shiny)
library(shinydashboard)
dataset <- data.frame("title" = c("A","B","C"), "description" = c("Info about box A", "Info about box B","Info about box C"), "data" = c(1:3))
ui <- fluidPage(
titlePanel("Dynamic Boxes"),
fluidRow(
uiOutput("boxes")
)
)
dataset <- data.frame("title" = c("A","B","C"), "description" = c("Stuff about box A", "Stuff about box B","Stuff about box C"), "data" = c(1:3))
server <- function(input, output) {
output$boxes <- renderUI({
lapply(dataset[,'title'], function(a) {
box(title = a, p("say stuff here"))
})
})
}
I can't figure out the correct logic to pull in the descriptions.
I've tried mapply:
server <- function(input, output) {
output$boxes <- renderUI({
mapply(function(x,y) {
box(title = x, p(y)
)
}, x = dataset[,'title'], y = dataset[,'description']
)
})
}
but I don't know what I'm doing. Can you help?
Edit:
I can get the dashboard to work using the dummy data above using mapply with SIMPLIFY=FALSE and with lapply
server <- function(input, output) {
output$boxes <- renderUI({
lapply(dataset[,'title'], function(a) {
box(title = a, p(dataset[dataset$title==a,2]))
})
})
}
But I have been unable to get it to work with real data, and am having trouble replicating the issue with the "dummy" data.
My real data lies on a server in a database.
This should work
server <- function(input, output) {
output$boxes <- renderUI({
lapply(dataset[,'title'], function(a) {
box(title = a, p(dataset[dataset$title==a,2]))
})
})
}
Your approach was correct with mapply you need to include SIMPLIFY = FALSE so that it returns a list.
server <- function(input, output) {
output$boxes <- renderUI({
mapply(function(x,y) {
box(title = x, p(y)
)
}, x = dataset[,'title'], y = dataset[,'description'], SIMPLIFY = FALSE
)
})
}
Or use Map which always returns a list.
server <- function(input, output) {
output$boxes <- renderUI({
Map(function(x,y) box(title = x, p(y)), dataset$title, dataset$description)
})
}
I am developing the Shiny app and I am unable to sum the values entered in dynamically created textInput.
The RCode used is as follows:
ui <- fluidPage(
fluidRow(
column(3, offset = 3,wellPanel(textOutput("text2"))),
column(3,wellPanel(textOutput("text3"))),
column(3,wellPanel(textOutput("text4")))
)
)
server <- function(input, output, session){
observeEvent(input$view, {
output$inputGroup = renderUI({
#code for generating textBoxes and corresponding Id's dynamically
input_list <- lapply(1:(nrow(df())*3), function(i) {
inputName <- paste("id", i, sep = "")
textInputRow<-function (inputId,value)
{
textAreaInput(inputName,"", width = "200px", height = "43px", resize = "horizontal")
}
column(4,
textInputRow(inputName, "")
)
})
do.call(tagList, input_list)
})
})
#code for adding the values and displaying the sum
output$text2 <- renderText({
tot = nrow(df())*3
sum1 = 0
for(lim in 1:tot){
if(lim %% 3 == 1){
inp = paste("id",lim)
sum1 = sum1 + input[[inp]]
}
}
})
}
shinyApp(ui = ui, server = server)
The output is :
Can anyone help me with this code?
While your question is modified, Here's a reproducible code for summing values entered in the textbox:
## Only run examples in interactive R sessions
if (interactive()) {
ui <- fluidPage(
textInput("input1", "Input1", 1),
textInput("input2", "Input2", 2),
tags$h3('Result:'),
verbatimTextOutput("value")
)
server <- function(input, output) {
output$value <- renderText({ as.numeric(input$input1) + as.numeric(input$input2)})
}
shinyApp(ui, server)
}