Related
I am using a future promise to call my data more efficiently. However, I'm finding that my filters (called through selecticizeGroupServer) do not work with the future promise.
See attached for a minimal reproducible example. The filters work as expected when I remove the "future_promise" function from the data reactive expression. However, when I use "future_promise," the filter module fails.
Could you please help me figure out what I'm doing wrong?
library(shiny)
library(future)
library(promises)
library(shinyWidgets)
plan(multisession)
ui <- fluidPage(
titlePanel("Example App"),
sidebarLayout(
sidebarPanel(),
mainPanel(
selectizeGroupUI(
id = "filters",
inline = FALSE,
params = list(
`mpg` = list(inputId = "mpg", title = "mpg", placeholder = "All"),
`cyl` = list(inputId = "cyl", title = "cyl", placeholder = "All"),
`disp` = list(inputId = "disp", title = "disp", placeholder = "All")
)
)
)
)
)
server <- function(input, output) {
data <- reactive({
future_promise({
mtcars
})
})
filter_mod <- reactive({})
observe({
filter_mod <<- callModule(
module = selectizeGroupServer,
id = "filters",
inline = FALSE,
data = data,
vars = c("mpg", "cyl", "disp")
)
})
}
# Run the application
shinyApp(ui = ui, server = server)
We can use a initialized reactiveVal instead of reactive to avoid passing a promise to selectizeGroupServer.
Please check the following:
library(shiny)
library(future)
library(promises)
library(shinyWidgets)
plan(multisession)
ui <- fluidPage(
titlePanel("Example App"),
sidebarLayout(
sidebarPanel("The choices will appear after 5 seconds:"),
mainPanel(
selectizeGroupUI(
id = "filters",
inline = FALSE,
params = list(
`mpg` = list(inputId = "mpg", title = "mpg", placeholder = "All"),
`cyl` = list(inputId = "cyl", title = "cyl", placeholder = "All"),
`disp` = list(inputId = "disp", title = "disp", placeholder = "All")
)
)
)
)
)
server <- function(input, output, session) {
data <- reactiveVal(NULL)
future_promise({
Sys.sleep(5) # long running task
mtcars
}) %...>% data() # assign to reactiveVal "data" once the future_promise is resolved
filter_mod <- callModule(
module = selectizeGroupServer,
id = "filters",
inline = FALSE,
data = data,
vars = c("mpg", "cyl", "disp")
)
}
shinyApp(ui = ui, server = server)
Im new to R shiny and have ran into a weird issue. Im using a selectizeGroupUI function to have some filter inputs in the UI. for some reason one of my filter options always lines up oddly. Ive attached the code from my UI below along with a screenshot of the actual output. any help would be greatly appreciated.
ui <- fluidPage(theme = shinytheme("cerulean"),
titlePanel(h1("Powered")),
sidebarLayout(
sidebarPanel(
fluidRow(
checkboxGroupInput(
inputId = "vars",
label = h3("Filters:"),
choices = c("Program", "Site", "Buyer", "Part_Number"),
selected = c("Program", "Site", "Buyer", "Part_Number")
),
panel(
column(
width = 8,
selectizeGroupUI(
id = "my-filters",
params = list(
Program = list(inputId = "Program", label = h5("Program:")),
Buyer = list(inputId = "Buyer", label = h5("Buyer:")),
Site = list(inputId = "Site", label = h5("Site:")),
#Buyer = list(inputId = "Buyer", title = "Buyer:"),
Part_Number = list(inputId = "Part_Number", label = h5("Part Number:"))
), inline = FALSE
))),
status = "primary"),
fluidRow(
selectInput("select1","Part Tracker", choices = unique(mydataTS$Part_Number))
),
fluidRow(
tags$image(src = "B.png",height= "30%" , width= "30%" ,align = "left"),
tags$image(src = "A.png",height= "30%" , width= "30%" ,align = "right")
),
width = 4 ),
)
Also here is the server side
mydataTS1 <-excel_sheets("~/Desktop/Updated-Dashboard-code3:15/Prototype v5/Dashboard-TSData4.xlsx") %>% map_df(~read_xlsx("~/Desktop/Updated-Dashboard-code3:15/Prototype v5/Dashboard-TSData4.xlsx",.))
shinyServer(
function(input, output, session) {
vars_r <- reactive({input$vars})
res_mod <- callModule(module = selectizeGroupServer,id = "my-filters", data = mydataTS1, vars = vars_r, inline = FALSE)
print(res_mod)
output$table <- DT::renderDataTable({
req(res_mod())
res_mod()
})
OUTPUT OF UI
My apologies for the bad first question, I'm new to SO but learning.
Let me know if any other information is required.
I would like to add/remove filters based on column names, i.e., if I select 2 column names, those column names should show numericRangeInput or seletizeInput or any other based on the class. Can it be done with conditionalPanel
Here is what I am trying
library(shiny)
nodes = read.csv("data/nodes.csv", header=T, as.is=T)
ui <- shinyUI(
fluidPage(
actionButton("addNode", "Add Node filter", icon=icon("plus", class=NULL, lib="font-awesome")),
uiOutput("filterPage1")
)
)
server <- function(input, output){
i <- 0
observeEvent(input$addNode, {
i <<- i + 1
output[[paste("filterPage",i,sep="")]] = renderUI({
t4 = class(nodes[,names(nodes)[i]])
print(t4)
list(
fluidPage(
fluidRow(
conditionalPanel(
condition = "t4=='character'",
column(6, selectInput(paste("filteringFactor",i,sep=""), paste0(names(nodes4)[i],':'),
choices=unique(nodes[,names(nodes)[i]]), selected=NULL,
width="100%")),
column(6, actionButton(paste("removeFactor",i,sep=""), "",
icon=icon("times", class = NULL, lib = "font-awesome"),
onclick = paste0("Shiny.onInputChange('remove', ", i, ")"))),
condition = "t4=='numeric'",
column(6, sliderInput(paste("filteringFactor",i,sep=""), paste0(names(nodes4)[i],':'),
choices=unique(nodes4[,names(nodes4)[i]]), selected=NULL,
width="100%")),
column(6, actionButton(paste("removeFactor",i,sep=""), "",
icon=icon("times", class = NULL, lib = "font-awesome"),
onclick = paste0("Shiny.onInputChange('remove', ", i, ")")))
)
)
),
uiOutput(paste("filterPage",i + 1,sep=""))
)
})
})
observeEvent(input$remove, {
i <- input$remove
output[[paste("filterPage",i,sep="")]] <- renderUI({uiOutput(paste("filterPage",i + 1,sep=""))})
})
}
shinyApp(ui, server)
I made an example based on the link I shared to elaborate on my comments (yours isn't reproducible):
library(shiny)
library(shinyWidgets)
library(tools)
library(datasets)
d <- data(package = "datasets")
dataset_is <- sapply(gsub(" .*$", "", d$results[,"Item"]), function(x){is(get(x))[1]})
DFs <- names(dataset_is[dataset_is == "data.frame"])
filterParams <- function(vars){
setNames(lapply(vars, function(x){
list(inputId = x, title = paste0(tools::toTitleCase(x), ":"), placeholder = "...")
}), vars)
}
ui <- fluidPage(
fluidRow(
column(
width = 10, offset = 1,
selectInput("dataset", label = "Select dataset", choices = DFs),
tags$h3("Filter data with selectize group"),
uiOutput("panelProxy"),
DT::dataTableOutput(outputId = "table")
)
)
)
server <- function(input, output, session) {
selected_dataset <- reactive({
DF <- get(input$dataset)
setNames(DF, gsub("\\.", "_", names(DF))) # avoid dots in inputId's (JS special character)
})
vars_r <- reactive({
input$vars
})
res_mod <- callModule(
module = selectizeGroupServer,
id = "my-filters",
data = selected_dataset,
vars = vars_r
)
output$table <- DT::renderDataTable({
req(res_mod())
res_mod()
})
output$panelProxy <- renderUI({
available_vars <- names(selected_dataset())
panel(
checkboxGroupInput(
inputId = "vars",
label = "Variables to use:",
choices = available_vars,
selected = available_vars,
inline = TRUE
),
selectizeGroupUI(
id = "my-filters",
params = filterParams(available_vars)
),
status = "primary"
)
})
}
shinyApp(ui, server)
The process_map() function in the server in the R shiny script creates the diagram image as below. My requirement is that there are two attributes "FUN" and "units" that are part of the performance() function. They have standard four values each that are available in the ui code below under PickerInput ID's Case4 and Case5. Currently, I am hard coding the value to create the map, can you help me to use the id's in the server code and make it dynamic such that when I select the value in the PickerInput, the formula fetches the value directly. Thanks and please help.
library(shiny)
library(shinydashboard)
library(bupaR)
library(processmapR)
library(lubridate)
library(dplyr)
library(edeaR)
library(shinyWidgets)
library(DiagrammeR)
ui <- dashboardPage(
dashboardHeader(title = "Diagram Plot",titleWidth = 290),
dashboardSidebar(width = 0),
dashboardBody(
tabsetPanel(type = "tab",
tabPanel("Overview", value = 1,
box(
column(1,
dropdown(
pickerInput(inputId = "resources",
label = "",
choices = c("Throughput Time"),
choicesOpt = list(icon = c("fa fa-bars",
"fa fa-bars",
"fa fa-safari")),
options = list(`icon-base` = "")),
circle = FALSE, status = "primary", icon = icon("list", lib = "glyphicon"), width = "300px"
),
conditionalPanel(
condition = "input.resources == 'Throughput Time' ",
tags$br(),
tags$br(),
tags$br(),
dropdown(
pickerInput(inputId = "Case4",
label = "Select the Process Time Summary Unit",
choices = c("min","max","mean","median"), options = list(`actions-box` = TRUE),
multiple = F),
circle = FALSE, status = "primary", icon = icon("eye-close", lib = "glyphicon"), width = "300px"
),
tags$br(),
tags$br(),
tags$br(),
dropdown(
pickerInput(inputId = "Case5",
label = "Select the Process Time Unit",
choices = c("mins","hours","days","weeks"), options = list(`actions-box` = TRUE),
multiple = F, selected = "days"),
circle = FALSE, status = "primary", icon = icon("eye-close", lib = "glyphicon"), width = "300px"
))),
title = "Process Map",
status = "primary",height = "575", width = "500",
solidHeader = T,
column(10,grVizOutput("State")),
align = "left")
),
id= "tabselected"
)))
server <- function(input, output) {
output$State <- renderDiagrammeR(
{
if(input$resources == "Throughput Time")
patients %>% process_map(performance(FUN = mean,units = "days"))
else
return()
})}
shinyApp(ui, server)
test this:
output$State <- renderDiagrammeR({
if(input$resources == "Throughput Time")
{
if(input$Case4=="mean"){
patients %>% process_map(performance(FUN = mean,units = input$Case5))}
else if(input$case4=="min"){
patients %>% process_map(performance(FUN = min,units = input$Case5))
}else if(input$case4=="max"){
patients %>% process_map(performance(FUN = max ,units = input$Case5))
}else{
patients %>% process_map(performance(FUN = median ,units = input$Case5))
}
}else
return()
})
or you can use this:
patients %>%
process_map(performance(FUN = eval(parse(text=input$Case4)) ,units = input$Case5))
enjoy;)
here is a sample:
library(shiny)
ui <- fluidPage(
selectInput(inputId = "func", label = "Choose The Function", choices = c("mean", "sum", "median"))
,
textOutput("text")
)
server <- function(input, output, session) {
main_data <- reactive({
data.frame(a= rnorm(100), b=rnorm(100) )
})
output$text <- renderText({
df <- main_data()
apply(df,2, FUN = eval(parse(text=input$func)) )
})
}
shinyApp(ui = ui, server = server)
You could use do.call to call a function from its name, see the example below. You can add arguments by adding them in the list in the do.call function, e.g. list(x,units=input$Case5).
library(shiny)
x=c(1,2,3,4,5,6,7)
ui <- fluidPage(
selectInput('select','Select Function: ', choices=c('mean','max','min','median')),
textOutput('text')
)
server <- function(input,output)
{
output$text <- renderText({
result = do.call(input$select, list(x))
paste0('The ', input$select, ' of [', paste(x,collapse=', '),'] is ', result)
})
}
shinyApp(ui,server)
Hope this helps!
I have solved this programmed but while changing input I am unable to find output change as a table please any one can help me using R shiny code
I have solve the error but it's still showing only
library(shiny)
library(DT)
bcl <- read.csv("R-D.csv", stringsAsFactors = FALSE)
ui <- shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
radioButtons("TYPE.OF.DATA","View data by:", choices = c("NP", "CR", "AN"), inline = TRUE, selected = "NP"),
tags$hr(),
radioButtons(" LINE.OF.BUSINESS ","View data by:" ,choices = c("AF", "HL"), inline = TRUE, selected = "AF"),
tags$hr(),
selectInput("typeInput6", " APPLICATION ",
choices = c("TERADATA"),
selected = "TERADATA"),
tags$hr(),
radioButtons( "DatabaseName","View data by:",choices = c("DW_re", "DW_np", "DW_AN"), inline = TRUE, selected = "DW_re")
),
mainPanel(
DT::dataTableOutput("table")
)
)
))
server <- shinyServer(function(input, output,session) {
observe({
if(input$bcl == "TYPE.OF.DATA"){
choices = c("NP", "CR", "AN")
firstchoice = "NP"
label = "DATA TYPE:"
}else{
choices = c("DW_re", "DW_np", "DW_AN")
firstchoice = "DW_re"
label = "NAME:"
}
updateSelectInput(session, "bcl", label = label, choices = choices, selected = firstchoice)
})
data <- reactive({
data = switch(input$bcl,
"NP" = NP, "CR" = CR, "AN" = AN,
"DW_re" = DW_re, "DW_np" = DW_np, "DW_AN" = DW_AN
)
})
output$table <- DT::renderDataTable({
datatable(data())
})
})
shinyApp(ui=ui,server=server)