Render box and contents dynamically from dataframe in shiny - r

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)
})
}

Related

Perform operations on data that has been split into tabls e.g sum of a column in r

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)

How to replace an observeEvent with a more comprehensive reactive function in R Shiny?

The code at the bottom of this post works as intended, using observeEvent(input$choices...) in the server section. The use of input$choices is a simplification for sake of example ease. In the fuller code this excerpt derives from, the equivalent of "choices" is molded by many different inputs (call it a "floating reactive"), and unless I misunderstand observeEvent(), it won't be feasible to use observeEvent() in the fuller code because I would have to list the myriad inputs that can alter it. So, is there a way to genericize this code where it instantly captures any change to "choices" (again, "choices" is a simplified analogy for my more complex floating reactive) and outputs it to the 2nd row of the table, including added rows?
Also in the below image, I show how "choices" is a always parachuted into the 2nd position of the dataframe in all circumstances (maybe there's a simpler way to do this too):
Code:
library(rhandsontable)
library(shiny)
mydata <- data.frame('Series 1' = c(1,1,0,1), check.names = FALSE)
rownames(mydata) <- c('Term A','Floating reactive','Term C','Term D')
ui <- fluidPage(br(),
useShinyjs(),
uiOutput("choices"),br(),
rHandsontableOutput('hottable'),br(),
fluidRow(
column(1,actionButton("addSeries", "Add",width = '70px')),
column(3,hidden(uiOutput("delSeries2")))
)
)
server <- function(input, output) {
uiTable <- reactiveVal(mydata)
observeEvent(input$hottable, {uiTable(hot_to_r(input$hottable))})
output$hottable <- renderRHandsontable({
rhandsontable(uiTable(),rowHeaderWidth = 100, useTypes = TRUE)
})
observeEvent(input$choices,{
tmpTable <- uiTable()
tmpTable[2,]<- as.numeric(input$choices)
uiTable(tmpTable)
})
output$choices <-
renderUI({
selectInput(
"choices",
label = "User selects value to reflect in row 2 of table below:",
choices = c(1,2,3)
)
})
observeEvent(input$addSeries, {
newCol <- data.frame(c(1,1,0,1))
newCol[2,] <- as.numeric(input$choices)
names(newCol) <- paste("Series", ncol(hot_to_r(input$hottable)) + 1)
uiTable(cbind(uiTable(), newCol))
})
output$delSeries2 <-
renderUI(
selectInput(
"delSeries3",
label = NULL,
choices = colnames(hot_to_r(input$hottable))
)
)
}
shinyApp(ui,server)
Not sure if I get the point here, but you might want to use observe instead of observeEvent to avoid managing the reactive dependencies (eventExpr) yourself:
library(rhandsontable)
library(shiny)
library(shinyjs)
mydata <- data.frame('Series 1' = c(1,1,0,1), check.names = FALSE)
rownames(mydata) <- c('Term A','Floating reactive','Term C','Term D')
ui <- fluidPage(br(),
useShinyjs(),
uiOutput("choices"),br(),
rHandsontableOutput('hottable'),br(),
fluidRow(
column(1,actionButton("addSeries", "Add",width = '70px')),
column(3,hidden(uiOutput("delSeries2")))
)
)
server <- function(input, output) {
uiTable <- reactiveVal(mydata)
observeEvent(input$hottable, {uiTable(hot_to_r(input$hottable))})
output$hottable <- renderRHandsontable({
rhandsontable(uiTable(),rowHeaderWidth = 100, useTypes = TRUE)
})
observe({
req(input$choices)
tmpTable <- uiTable()
tmpTable[2,] <- as.numeric(input$choices)
uiTable(tmpTable)
})
output$choices <-
renderUI({
selectInput(
"choices",
label = "User selects value to reflect in row 2 of table below:",
choices = c(1,2,3)
)
})
observeEvent(input$addSeries, {
newCol <- data.frame(c(1,1,0,1))
newCol[2,] <- as.numeric(input$choices)
names(newCol) <- paste("Series", ncol(hot_to_r(input$hottable)) + 1)
uiTable(cbind(uiTable(), newCol))
})
output$delSeries2 <-
renderUI(
selectInput(
"delSeries3",
label = NULL,
choices = colnames(hot_to_r(input$hottable))
)
)
}
shinyApp(ui,server)

CSS in Shiny: coloring dynamic tabs

Learning CSS, is it possible to assign colors to tabs depending on their title?
Example: creating tabs from vector element names and assigning the element value as color.
vec = c("Tab_1" = "#4185FB", "Tab_2" = "#FFC60A", "Tab_3" = "#EB002A")
vec
Tab_1 Tab_2 Tab_3
"#4185FB" "#FFC60A" "#EB002A"
Shiny app:
library(shiny)
vec = c("Tab_1" = "#4185FB", "Tab_2" = "#FFC60A", "Tab_3" = "#EB002A")
ui <- fluidPage(
do.call(tabsetPanel,
c(lapply(names(vec),
function(x){
tab_color = unname(vec[names(vec) == x])
tabPanel(tags$head(tags$style(HTML(glue("'
.nav-tabs>li.active>a, .nav-tabs>li.active>a:focus, .nav-tabs>li.active>a:hover{{
color: {tab_color};
}}'")))),
title = x
)
}
))
)
)
server <- function(input, output, session) {}
shinyApp(ui, server)
This way the colors remain the same.
Here is a way:
library(shiny)
vec = c("Tab_1" = "#4185FB", "Tab_2" = "#FFC60A", "Tab_3" = "#EB002A")
CSS <- paste0(mapply(
function(x,y){
sprintf("
.nav-tabs>li.active>a[data-value='%s'],
.nav-tabs>li.active>a[data-value='%s']:focus,
.nav-tabs>li.active>a[data-value='%s']:hover {
color: %s;
}", x, x, x, y)
},
names(vec), vec
), collapse = "\n")
ui <- fluidPage(
tags$head(tags$style(HTML(CSS))),
do.call(tabsetPanel,
c(lapply(names(vec),
function(x){
tabPanel(
title = x
)
}
))
)
)
server <- function(input, output, session) {}
shinyApp(ui, server)

Make a Shiny module reactive when creating the module via a function

I'm trying to generalise Shiny modules so different functions can be passed through, but the expected behaviour of reactivity is not working - could someone point me in the right direction? I have a reprex below that illustrates my problem.
I expect that the dynamic selection of view_id to change values in the renderShiny() function. It works on app load but changing selections do not flow through.
Is it something to do with the environment the module function is created within?
library(shiny)
create_shiny_module_funcs <- function(data_f,
model_f,
outputShiny,
renderShiny){
server_func <- function(input, output, session, view_id, ...){
gadata <- shiny::reactive({
# BUG: this view_id is not reactive but I want it to be
data_f(view_id(), ...)
})
model_output <- shiny::reactive({
shiny::validate(shiny::need(gadata(),
message = "Waiting for data"))
model_f(gadata(), ...)
})
output$ui_out <- renderShiny({
shiny::validate(shiny::need(model_output(),
message = "Waiting for model output"))
message("Rendering model output")
model_output()
}, ...)
return(model_output)
}
ui_func <- function(id, ...){
ns <- shiny::NS(id)
outputShiny(outputId = ns("ui_out"), ...)
}
list(
shiny_module = list(
server = server_func,
ui = ui_func
)
)
}
# create the shiny module
ff <- create_shiny_module_funcs(
data_f = function(view_id) mtcars[, view_id],
model_f = function(x) mean(x),
outputShiny = shiny::textOutput,
renderShiny = function(x) shiny::renderText(paste("Mean is: ", x))
)
## ui.R
ui <- fluidPage(title = "module bug Shiny Demo",
h1("Debugging"),
selectInput("select", label = "Select", choices = c("mpg","cyl","disp")),
textOutput("view_id"),
ff$shiny_module$ui("demo1"),
br()
)
## server.R
server <- function(input, output, session){
view_id <- reactive({
req(input$select)
input$select
})
callModule(ff$shiny_module$server, "demo1", view_id = view_id)
output$view_id <- renderText(paste("Selected: ", input$select))
}
# run the app
shinyApp(ui, server)
The problem was the renderShiny function needs to wrap another function that creates the actual output, so its actually two separate capabilities confused by me as one: renderShiny should take the output of another function that actually creates the thing to render. The below then works:
library(shiny)
module_factory <- function(data_f = function(x) mtcars[, x],
model_f = function(x) mean(x),
output_shiny = shiny::plotOutput,
render_shiny = shiny::renderPlot,
render_shiny_input = function(x) plot(x),
...){
ui <- function(id, ...){
ns <- NS(id)
output_shiny(ns("ui_out"), ...)
}
server <- function(input, output, session, view_id){
gadata <- shiny::reactive({
data_f(view_id(), ...)
})
model <- shiny::reactive({
shiny::validate(shiny::need(gadata(),
message = "Waiting for data"))
model_f(gadata(), ...)
})
output$ui_out <- render_shiny({
shiny::validate(shiny::need(model(),
message = "Waiting for model output"))
render_shiny_input(gadata())
})
return(model)
}
list(
module = list(
ui = ui,
server = server
)
)
}
made_module <- module_factory()
## ui.R
ui <- fluidPage(title = "module bug Shiny Demo",
h1("Debugging"),
selectInput("select", label = "Select", choices = c("mpg","cyl","disp")),
textOutput("view_id"),
made_module$module$ui("factory1"),
br()
)
## server.R
server <- function(input, output, session){
callModule(made_module$module$server, "factory1", view_id = reactive(input$select))
output$view_id <- renderText(paste("Selected: ", input$select))
}
# run the app
shinyApp(ui, server)
I think you want something like this.
library(shiny)
library(plyr)
library(dplyr)
library(DT)
library(data.table)
ui <- pageWithSidebar(
headerPanel = headerPanel('data'),
sidebarPanel = sidebarPanel(fileInput(
'mtcars', h4('Uplaodmtcardata in csv format')
),
uiOutput('tabnamesui')),
mainPanel(uiOutput("tabsets"))
)
server <- function(input, output, session) {
mtcarsFile <- reactive({
input$mtcars
})
xxmtcars <-
reactive({
read.table(
file = mtcarsFile()$datapath,
sep = ',',
header = T,
stringsAsFactors = T
)
})
tabsnames <- reactive({
names(xxmtcars())
})
output$tabnamesui <- renderUI({
req(mtcarsFile())
selectInput(
'tabnamesui',
h5('Tab names'),
choices = as.list(tabsnames()),
multiple = T
# selected = SalesGlobalDataFilter1Val()
)
})
tabnamesinput <- reactive({
input$tabnamesui
})
output$tabsets <- renderUI({
req(mtcarsFile())
tabs <-
reactive({
lapply(tabnamesinput(), function(x)
tabPanel(title = basename(x)
,fluidRow(splitLayout(cellWidths = c("50%", "50%"),
plotOutput(paste0('plot1',x)),
plotOutput(paste0('plot2',x)
))),fluidRow(splitLayout(cellWidths =
c("50%", "50%"),
plotOutput(paste0('plot3',x)),
plotOutput(paste0('plot4',x)
))),
dataTableOutput(paste0('table',x))))
})
do.call(tabsetPanel, c(tabs()))
})
# Save your sub data here
subsetdata<-reactive({
list_of_subdata<-lapply(tabnamesinput(), function(x) {
as.data.table((select(xxmtcars(),x)))
})
names(list_of_subdata)<-tabnamesinput()
return(list_of_subdata)
})
observe(
lapply(tabnamesinput(), function(x) {
output[[paste0('table',x)]] <-
renderDataTable({
subsetdata()[[x]]
})}))
observe(
lapply(tabnamesinput(), function(x) {
for(i in paste0("plot",1:4)){
output[[paste0(i,x)]] <-
renderPlot({subsetdata()[[x]]%>%plot()#CODE REPEATED
})
}
})
)
}
runApp(list(ui = ui, server = server))
Data Source:
https://gist.githubusercontent.com/seankross/a412dfbd88b3db70b74b/raw/5f23f993cd87c283ce766e7ac6b329ee7cc2e1d1/mtcars.csv

Shiny R renderPrint in loop usinf RenderUI only update the output

I am trying to dynamically render multiple text output from multiple text input. I tried to use this very helpfull example and this one too.
This conversation is also helpfull.
But when I try to adapt this examples on the following script, I have a problem of output update. Apparently, only the last element was read and updated. It's probably a reactivity problem but it seems to be difficult to associate reactive{()} and renderUI{()}functions.
rm(list = ls())
library(shiny)
creatDataElem <- function(ne, input) {
x1 <- lapply(1:ne, function(i) {
textInput(paste0("elemName", i),
label = h4(strong("Name of dataset element")),
value = "")
})
return(x1)
}
ui = (fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput("elemNb",
"Number of elements", value = 1, min = 1,
max = 3)
,
conditionalPanel(
condition = "input.elemNb == 1",
creatDataElem(1)
),
conditionalPanel(
condition = "input.elemNb == 2",
creatDataElem(2)
),
conditionalPanel(
condition = "input.elemNb == 3",
creatDataElem(3)
)
),
mainPanel(
uiOutput("nameElem")
)
)
)
)
server = function(input, output, session) {
max_elem <- 3
# Name
output$nameElem <-renderUI({
nameElem_output_list <- lapply(1:input$elemNb, function(i) {
elemName <- paste0("elemName", i)
tags$div(class = "group-output",
verbatimTextOutput(elemName)
)
})
do.call(tagList, nameElem_output_list)
})
for (i in 1:max_elem) {
local({
force(i)
my_i <- i
elemName <- paste0("elemName", my_i)
output[[elemName]] <- renderPrint(input[[elemName]])
})
}
}
runApp(list(ui = ui, server = server))
The idea with a reactive({}) function is to add an independant object (a function in this case) like:
nameElem <- reactive({
if (input$goElem == 0) {
return()
} else {
isolate({
if (is.null(input$elemName)) {
return()
} else if (test(input$elemName)) {
return("TEST RESULT")
} else {
return(input$elemName)
}
})
}
})
and to use renderUI on this object (with an ActionButton).
So, if someone knows why the output does not return the good object...
I think one of your problems is that your creatDataElem function is such that when it is called with argument ne=3, the first and second textInput elements are created again (and their value "lost").
Anyway, I think one solution would be to create those textInput elements as an "uiOutput".
You'll find a possible solution below which (I think) does what you want.
Lise
rm(list = ls())
library(shiny)
ui = (fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput("elemNb",
"Number of elements", value = 1, min = 1,
max = 3),
uiOutput("myUI")
),
mainPanel(
uiOutput("nameElem")
)
)
)
)
server = function(input, output, session) {
output$myUI=renderUI({
w=""
for (i in 1:input$elemNb){
w=paste0(w,
textInput(paste0("elemName",i),label='Name of dataset element'))
}
HTML(w)
})
output$nameElem <-renderUI({
elems=c("<div>")
for(i in 1:input$elemNb){
elems=paste(elems,"</div><div>",input[[paste0("elemName",i)]])
}
elems=paste0(elems,"</div>")
HTML(elems)
})
}
runApp(list(ui = ui, server = server))
Found a solution:
library(readr)
library(dplyr)
library(shiny)
df <- data.frame(symbol = 1:10)
uiOutput("myUI")
createUI <- function(dfID, symbol) {
div(class="flex-box",paste0(symbol, " - 10"))
}
output$myUI <- renderUI({
w <- lapply(seq_len(nrow(df)), function(i) {
createUI(i, df[i,"symbol"])
})
do.call(fluidPage,w)
})

Resources