Unable to render Gauge from Flexdashboard library in Shiny app - r

I am trying to create a Shiny app which
a) prompts user to upload a file which contains numeric data,
b) reads the file and assigns the data points to different variables,
c) calculates new variables from the captured variables
d) display a 'Gauge' using the calculated variables
The code successfully executes but the Gauge chart is not rendered properly. There is no error or warning message either. Instead, I am getting the following message:
"Input to asJSON(keep_vec_names=TRUE) is a named vector. In a future version of jsonlite, this option will not be supported, and named vectors will be translated into arrays instead of objects. If you want JSON object output, please use a named list instead. See ?toJSON."
And instead of the gauge output I am getting that tiny spec in the middle, as seen in the attached image.
The entire code is fairly long, hence providing just the relevant snippets of code.
Would really appreciate if you can help fix this.
library(shiny)
library(flexdashboard)
ui <- fluidPage(
tabPanel("Sensitivity Analysis",
sidebarLayout(
sidebarPanel(
uiOutput("Sensitivity_Analysis")
),
mainPanel(
gaugeOutput("sensitivity", width = "600px", height = "600px")
)
)
),
server <- function (input, output)
{
output$input_financials=renderUI({
fluidRow(fileInput("file1", "Choose CSV File",multiple = FALSE,accept = c("text/csv","text/comma-separated-values,text/plain",".csv")),
actionButton("process","Process"))})
data_input=reactiveValues()
observeEvent(input$process,{
file_input <- input$file1
if (is.null(file_input)) {
return(NULL)}
## File is read and all the inputs are assigned to variables
....
## Output for Gauge begins
output$sensitivity <- flexdashboard::renderGauge({
gauge_limit <- data_input$wc_value
data_input$cash_rel_dpo <- ## Formula for cash_del_dpo
data_input$cash_rel_dro <- ## Formula for cash_del_dro
data_input$cash_rel_dio <- ## Formula for cash_del_dio
data_input$wc_predicted_value <- (data_input$wc_predicted_value - data_input$cash_rel_dpo - data_input$cash_rel_dro - data_input$cash_rel_dio)
gauge(data_input$wc_predicted_value, min = 0, max = gauge_limit,
gaugeSectors(success = c(0, 10000),
warning = c(10001, 50000),
danger = c(50001, 1000000000))
)
})
shinyApp(ui = ui, server = server)
Screenshot of the output generated upon executing the code

There's a similar gauge in package billboarder, try this example:
library(shiny)
library(billboarder)
ui <- fluidPage(
tabPanel(
title = "Sensitivity Analysis",
sidebarLayout(
sidebarPanel(
fileInput("file1", "Choose CSV File",
multiple = FALSE,
accept = c("text/csv","text/comma-separated-values,text/plain",".csv")),
actionButton(inputId = "process", label = "Process (click here to refresh the gauge)")
),
mainPanel(
billboarderOutput("sensitivity", width = "400px", height = "400px")
)
)
)
)
server <- function (input, output) {
data_input <- reactiveValues(x = 0)
observeEvent(input$process, {
data_input$x <- sample.int(1e5, size = 1)
}, ignoreInit = TRUE)
## Output for Gauge begins
output$sensitivity <- renderBillboarder({
billboarder() %>%
bb_gaugechart(
value = data_input$x,
name = "Predicted value",
steps = c(1e4, 5e4, 1e5),
steps_color = rev(c("#FF0000","#F6C600", "#60B044"))
) %>%
bb_gauge(
min = 0, max = 1e5,
units = "",
label = list(
format = htmlwidgets::JS("function(value, ratio) {return d3.format(',')(value);}") # format value with thousand separator
),
width = 80
)
})
}
shinyApp(ui = ui, server = server)

Related

R/Shiny: Subscript out of bounds error despite working in R

I've seen many people with issues like mine, but no answers have been helpful for my case.
I am using seurat for single cell data analysis and I'm trying to build a very simple web page for other individuals to query their gene expression.
I get a "subscript out of bounds" error while trying to run my Shiny app immediately on launch, despite it working in R.
In the console, it's immediately displaying -- Warning: Error in [[: subscript out of bounds. What am I doing wrong here?
library(shiny)
library(Seurat)
WholeEye <- readRDS("WholeEye.rds")
MG <- readRDS("MG.rds")
CMZ <- readRDS("CMZ.rds")
RPE <- readRDS("CMZ.rds")
ui <- fluidPage(
headerPanel('McFarlane scRNAseq'),
sidebarPanel(
textInput(inputId = 'celltype', label = "Choose a cell type. Eg. WholeEye, MG, RPE, CMZ", value = "MG", width = NULL, placeholder = NULL),
textInput(inputId = 'gene', label = "Choose a gene", value = "", width = NULL, placeholder = NULL)
),
mainPanel(
plotOutput(outputId = "FeaturePlot" )
)
)
server <- function(input, output) {
output$FeaturePlot <- renderPlot({
FeaturePlot(object = input$celltype, reduction = "umap", label = TRUE, min.cutoff = 0, features = input$gene)
})
}
shinyApp(ui = ui, server = server)
Try
output$FeaturePlot <- renderPlot({
req(input$celltype,input$gene)
FeaturePlot(object = get(input$celltype), reduction = "umap", label = TRUE, min.cutoff = 0, features = get(input$gene))
})

Shiny SelectInputs to Dataframe

I'm trying to learn R and am running into issues using the Shiny dashboard GUI. I'm trying to turn these SelectInputs
tabItem(tabName = "data",
fluidRow(
selectInput("Telecommuting", "Telecommute (Yes=1, No=0)", c("1","0")),
selectInput("logo", "Has Logo(Yes=1, No=0)", c("1","0")),
selectInput("questions", "Has Questions(Yes=1, No=0)", c("1","0")),
into dataframe inputs that I call at the top of my dashboard script
dfTemp<- read.csv('words.csv', header=T)
The CSV is just a one row csv with all values initialized to 0. I want to take the SelectInputs by the user and place them into the dataframe according to the input.
storeCommute<- renderText(input$Telecommuting)
dfTemp$telecommuting<- storeCommute
However when I try to set the dfTemp$telecommuting to the storeCommute input, I get an error:
Error in xj[i] : object of type 'closure' is not subsettable
I have searched for hours and there is no info on how to get this done. Any help would be awesome, thanks!
What you describe is doable yet quite complicated due to the nature of selectInput. Below is an example which I think would very close to what you write and the example include various usage of different input ui, reactive values, and event handling in Shiny.
library(shiny)
library(dplyr)
# ui part
ui <- fluidPage(
# Application title
titlePanel("Trial Input added rows to a dataframe"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
fluidRow(
# a text input for input random word
textInput(inputId = "word",
label = 'Word', width = "300px")
),
fluidRow(
# a checkbox for Yes/No values - telecommute
checkboxInput(inputId = "telecommute",
label = 'Telecommuting',
value = FALSE)
),
fluidRow(
# a checkbox for Yes/No values - logo
checkboxInput(inputId = "logo",
label = 'Has Logo',
value = FALSE)
),
fluidRow(
# a checkbox for Yes/No values - questions
checkboxInput(inputId = "questions",
label = 'Has Questions',
value = FALSE)
),
fluidRow(
# Action button that added rows to the reactive value df on click
actionButton(inputId = "add_rows", label = "Add rows")
)
),
# Show a plot of the generated distribution
mainPanel(
fluidRow(
# data.frame output - will change follow each "add_rows" click
tableOutput(outputId = "data_table")
),
fluidRow(
# Action button that save the current data to words.csv
actionButton(inputId = "save_csv", label = "Save to csv")
)
)
)
)
# server part
server <- function(input, output) {
# reactive values that store df_temp for later processing & visualization
values <- reactiveValues(
df_temp =
{
# for the first time running if no words.csv available
# an empty tibble is created.
data <- tibble(word = character(0),
telecommute = logical(0),
logo = logical(0),
questions = logical(0))
if (file.exists("./words.csv")) {
# if words.csv exist load the data from csv file
data <- read.csv("./words.csv", stringsAsFactors = FALSE)
}
data
}
)
# server code handling logic added row to values$df_temp
observeEvent(input$add_rows, {
values$df_temp <- bind_rows(values$df_temp,
tibble(word = input$word,
telecommute = input$telecommute,
logo = input$logo,
questions = input$questions))
})
# render the values$df_temp to a table output to UI
output$data_table <- renderTable(values$df_temp)
# server code handling logic to save values$df_temp when click "Save to csv"
observeEvent(input$save_csv, {
write.csv(values$df_temp, "./words.csv", row.names = FALSE)
})
}
# Run the application
shinyApp(ui = ui, server = server)

How to save the inputs, inside Data Frame which is inside the list?

I tried to keep reprex as simple as possible.
I want to save with the ADD button currently chosen inputs, inside Data Frame (selected by index passed by userId input), which is inside the list, and later on use this Data Frame to render a table (in the final app make a plot).
Here I figured out, how to save values inside the data frame. (not data frame inside a list)
How to save input to data frame, and use it later in Shiny?
Now Add button returns this:
Warning: Error in choosen_user: unused argument (rbind(choosen_user(), new_day_rate())) <- this is propably because I used reactive() not reactiveVal(), but with reactiveVal() there is this error:
Warning: Error in .getReactiveEnvironment()$currentContext: Operation not allowed without an active reactive context.
You tried to do something that can only be done from inside a reactive consumer.
library(shiny)
# Saved_users_list normally came from external file
saved_users_list <- list(data.frame(date = c(as.Date("2022-04-18"),
as.Date("2022-04-19")),
rate = c(8,1),
day_comment = c("Found a gf",
"Broke my arm")),
data.frame(date = c(as.Date("2022-04-18"),
as.Date("2022-04-19")),
rate = c(10,1),
day_comment = c("Found a job",
"They fired me")))
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("userId", "userId", choices = c(1:2)),
sliderInput("day_rate", "Rate your day", min = 0, max = 10, value = 5, step = 0.5),
dateInput("date", "Pick a date"),
textAreaInput("comment", "Comment", placeholder = "Add a description (OPTIONAL)"),
actionButton("add", "Add"),
actionButton("test", "Test values") # Button to test inputs values
),
mainPanel(
tableOutput("test_table")
)
)
)
server <- function(input, output, session) {
users_list <- reactiveVal(saved_users_list)
selected_user <- reactive(as.numeric(input$userId))
output$test_table <- renderTable({
users_list()[selected_user()]
})
new_day_rate <- reactive(list(data.frame(date = input$date,
rate = input$day_rate,
day_comment = input$comment)))
choosen_user <- reactive(users_list()[[selected_user()]])
# Button to add values to the data frame inside users_list
observeEvent(input$add, {
# users_list()[[selected_user()]] <- rbind(users_list()[[selected_user()]], as.data.frame(new_day_rate())) # Error in <-: invalid (NULL) left side of assignment
choosen_user(rbind(choosen_user(), new_day_rate())) # Here I tried to implement a solution from linked question
})
# Button to test inputs values
observeEvent(input$test, {
message("userId: ", input$userId, " ", class(input$userId))
message("selected_user(): ", selected_user())
message("new_day_rate(): ", new_day_rate())
message("str(new_day_rate()): ", str(new_day_rate()))
message("users_list()[[selected_user()]]: ",users_list()[[selected_user()]])
})
}
shinyApp(ui, server)
I think you're after reactiveValues? Something like:
library(shiny)
# Saved_users_list normally came from external file
saved_users_list <- list(
data.frame(
date = c(as.Date("2022-04-18"), as.Date("2022-04-19")),
rate = c(8,1),
day_comment = c("Found a gf", "Broke my arm")
),
data.frame(
date = c(as.Date("2022-04-18"), as.Date("2022-04-19")),
rate = c(10,1),
day_comment = c("Found a job", "They fired me")
)
)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("userId", "userId", choices = c(1:2)),
sliderInput("day_rate", "Rate your day", min = 0, max = 10, value = 5, step = 0.5),
dateInput("date", "Pick a date"),
textAreaInput("comment", "Comment", placeholder = "Add a description (OPTIONAL)"),
actionButton("add", "Add"),
actionButton("test", "Test values") # Button to test inputs values
),
mainPanel(
tableOutput("test_table")
)
)
)
server <- function(input, output, session) {
cache <- reactiveValues(saved_users = saved_users_list)
selected_user <- reactive(as.numeric(input$userId))
output$test_table <- renderTable({
cache$saved_users[selected_user()]
})
new_day_rate <- reactive(
data.frame(
date = as.Date(input$date),
rate = input$day_rate,
day_comment = input$comment
)
)
observeEvent(input$add, {
cache$saved_users[[selected_user()]] <- rbind(
cache$saved_users[[selected_user()]], new_day_rate()
)
})
observeEvent(input$test, {
message("userId: ", input$userId, " ", class(input$userId))
message("selected_user(): ", selected_user())
message("new_day_rate(): ", new_day_rate())
message("str(new_day_rate()): ", str(new_day_rate()))
message("users_list()[[selected_user()]]: ", cache$saved_users[[selected_user()]])
})
}
shinyApp(ui, server)

Shiny Dashboard formatting issue

library(needs)
needs(
shiny,
ggplot2,
tidyverse,
shinydashboard,
DT
)
source("~/functions.R",local = T)
# Define UI for application that draws a histogram
header = dashboardHeader(
# tags$li(class = "dropdown",
# tags$style(".main-header {max-height: 80px}"),
# tags$style(".main-header .logo {height: 80px}")),
#title = tags$img(src='logo.png',height='100',width='200')
)
sidebar = dashboardSidebar(
menuItem("Full data",tabName="Data",icon=icon("table"),startExpanded = F,
fileInput("file","Upload CSV files",multiple=TRUE,accept=("text/comma"))),
menuItem(text = 'Simulate',tabName = 'simulate',icon=icon('chart-line'),
helpText('Simulation Parameters'),
radioButtons('type',"Please choose the type of analysis:",choices = list("Gender" = 1,"US Minority Status" = 2),selected = 1),
sliderInput("numSims","Number of simulations:",min = 1, max = 10000,step = 1000,value = 10000),
sliderInput("numYears","Number of years to simulate:",min = 1,max = 5,value = 3,step = 1),
numericInput('turnover','Total Turnover', value = 10),
sliderInput('promoRate','Set Promo rate', value = 25, min = 1, max = 100, step = 5),
sliderInput('growthRate','Set growth rate',value = 0,min=0,max=100,step = 1),
helpText('0% Growth Rate assumes a flat, constant headcount'),
actionButton('go',label = "Update"),width = 4)
)
body <- dashboardBody(
tabItems(
tabItem(
tabName = 'data',
fluidRow(wellPanel(
fileInput(
inputId = 'file',
label = "File Upload:",
accept = c("csv", ".csv")))),
wellPanel(DT::dataTableOutput('table'))),
tabItem(
tabName = 'simulate',
fluidRow(
wellPanel(
DT:::dataTableOutput('simDataTable')
))
)
))
ui = shinydashboard::dashboardPage(header,sidebar,body,skin='red')
server = server <- function(input, output) {
options(shiny.maxRequestSize = 30 * 1024 ^ 2)
dataset <- reactive({
req(input$file)
read.csv(input$file$datapath)
})
output$table = renderDataTable(dataset(), filter = 'top',options = list(scrollX = TRUE))
simulate = eventReactive(input$go,{
req(input$numSims,input$type)
x = dataset()
temp = dataSim(x,type=input$type,
numSims = input$numSims)
})
simulateAvg = reactive({
x = simulate()
y = x %>% group_by(Role) %>% summarise(mean(freq))
})
output$simDataTable = renderDataTable(simulateAvg())
}
shinyApp(ui,server)
I'm having some trouble with two issues.
1.) The formatting of the shiny dashboard is odd. The text on the side bar seems very compacted and not what other shiny dashboards look like. I'm not sure what the issue is.
2.) After upload, a table is suppose to appear on the dashboard body but it doesn't
3.) Once a table appears and I head to the simulate tab, will the dashboard body change accordingly and display the simulateAvgData set that I populated?
The dataSim function is from the source file on top. I don't receive any errors when I run anything so looking for guidance and inputs to whether or not this shiny dashboard work as intended. I'm newer to the dashboard packages from shiny.
You have a couple of issues here. You do not need a fileInput statement inside dashboardBody. Next, within dashboardSidebar, you can define fileInput at the top level of menuItem (option 1 in the code below), or a sub-level of the first menuItem (option 2 below). In either case, you need to have a menuItem with a tabName where you want to display the file that was read in. Once you read the input file, you need to select the appropriate tab to see the displayed data. Try this code
header <- dashboardHeader()
### option 1: fileInput at the first menuItem level
# sidebar <- dashboardSidebar(width=320,
# menuItem("Full data",tabName="Data",icon=icon("table"),startExpanded = F),
# fileInput("file","Upload CSV files",multiple=FALSE,accept=c("csv", ".csv"))
# )
### option 2 - fileInput as a subitem
sidebar <- dashboardSidebar(width=320,
menuItem("Full data",tabName="noData",icon=icon("table"),startExpanded = F, ## data not displayed for this tabName
menuItem("Full_data",tabName="Data", icon=icon("table")),
fileInput("file","Upload CSV files",multiple=FALSE,accept=c("csv", ".csv")))
)
body <- dashboardBody(
tabItems(
tabItem(
tabName = 'Data',
fluidRow(DTOutput('table')))
))
ui <- shinydashboard::dashboardPage(header,sidebar,body,skin='red')
server <- function(input, output, session) {
data1 <- reactive({
req(input$file)
data <- read.csv(input$file$datapath,sep = ",", header = TRUE)
})
output$table <- renderDT(data1())
}
shinyApp(ui,server)

Passing user input in Shiny to a URL query string

I have a question that I'm having trouble getting to work. I have a Shiny app that I want to accept two user input, send it back from ui.R to server.R, and insert that as a variable into a URL query string to download the file from a database. At first, we hardcoded the values to test the algorithm but we eventually want to make it user defined. I thought that saving as a variable and replacing it in the query string would work, but it didn't... I tried to concatenate pieces of the URL and I'm getting an error "Warning: Error in cat: argument 1 (type 'closure') cannot be handled by 'cat'". I tried to search online but couldn't find a good solution to my problem. Here is my code so far... As you see in the code, what I want to get is at least form the url and showing it as text on the ui just to see that it is being dynamic. Then when I know I can insert the user input, then I can continue on with storing the downloaded file.
#ui.R
library(shiny)
library(leaflet)
library(foreach)
library(ape)
library(data.table)
library(DT)
# Choices for the genetic distance model
geneticDistanceModel <- c(
"raw" = "raw",
"JC69" = "JC69",
"K80" = "K80",
"F81" = "F81",
"K81" = "K81",
"F84" = "F84",
"BH87" = "BH87",
"T92" = "T92",
"TN93" = "TN93",
"GG95" = "GG95",
"logdet" = "logdet",
"paralin" = "paralin"
)
shinyUI(navbarPage("TeMPuЯa", id="nav", position = c("fixed-top"),
# needed to keep fixed-top navbar from obscuring content
header = tags$style(type = "text/css", "body {padding-top: 70px;}"),
collapsible = "true",
tabPanel("Tool",
h1("Instructions"),
p("Placeholder"),
sidebarLayout(
sidebarPanel(
textInput("taxonomy", label = h4("Enter taxonomy group:"), value = "Porifera"),
textInput("geography", label = h4("Enter geographical location:"), value = "all"),
sliderInput("latitude", label = h4("Latitude difference"), min = 10, max = 30, value = 20),
sliderInput("genetic", label = h4("Genetic similarity threshold"), min = 10, max = 20, value = 15),
sliderInput("outgroups", label = h4("Select a distance from the outgroup"), min = 1, max = 2, value = 1.3, step = 0.1),
selectInput("distanceModels", label = h4("Select a genetic distance model"), geneticDistanceModel, selected = "K80"),
submitButton("Submit"),
br(),
downloadButton("download", label = "Download CSV")
),
mainPanel(
leafletOutput("worldmap"),
br(),
div(style='height:300px; width:850px; overflow:scroll',
DT::dataTableOutput("url", width = 850)),
textOutput("text")
)
)
),
tabPanel("Genetic Distance Models Info",
h1("Genetic distance models:"),
a("Link to more explanation for the distance models used in R", href = "http://svitsrv25.epfl.ch/R-doc/library/ape/html/dist.dna.html"),
br(),
p(strong("raw:") ,"This is simply the proportion or the number of sites that differ between each pair of sequences. This may be useful to draw 'saturation plots'."),
p(strong("JC69:") ,"This model was developed by Jukes and Cantor (1969)."),
p(strong("K80:") ,"The distance derived by Kimura (1980), sometimes referred to as 'Kimura's 2-parameters distance'."),
p(strong("F81:") ,"Felsenstein (1981) generalized the Jukes-Cantor model."),
p(strong("K81:") ,"This model is called the Kimura's 'three substitution types model' (3ST), and is sometimes referred to as 'Kimura's 3-parameters distance'."),
p(strong("F84:") ,"This model generalized K80, and was first introduced by Felsenstein in 1984."),
p(strong("BH87:") ,"Barry and Hartigan (1987)."),
p(strong("T92:") ,"Tamura (1992) generalized the Kimura model."),
p(strong("TN93:") ,"Tamura and Nei (1993) model."),
p(strong("GG95:") ,"Galtier and Gouy (1995) model."),
p(strong("logdet:") ,"The Log-Det distance, developed by Lockhart et al. (1994), is related to BH87. However, this distance is symmetric."),
p(strong("paralin:") ,"Lake (1994) developed the paralinear distance which can be viewed as another variant of the Barry-Hartigan distance.")
)
))
# server.R
library(shiny)
library(leaflet)
library(foreach)
library(ape)
library(data.table)
library(DT)
source("tsvtoDataFrame.R")
shinyServer(function(input, output, session) {
# Create the map
output$worldmap <- renderLeaflet({
leaflet() %>%
addTiles() %>% # Add default OpenStreetMap map tiles
setView(lng = -93.85, lat = 37.45, zoom = 4)
})
textInput <- reactive({
var1 <- "http://www.boldsystems.org/index.php/API_Public/combined?taxon="
var2 <- "&geo="
var3 <- "&format=tsv"
paste(c(var1), c(input$taxonomy), c(var2), c(input$geography), c(var3))
})
output$text <- renderText({
textInput
})
output$url <- DT::renderDataTable(
dfMatchOverallBest,
options = list(scrollX = TRUE)
)
})
textInput is a reactive, so you should use
output$text <- renderText({
textInput()
})
Also you should probably use paste0 instead of paste to get your URL, and the c() command is not necessary.

Resources