I'm writing a small Application to upload multiple dataframes and visualizing them in different tabs. In order to visualize the .csv files given by the user, I'm using one DataTableOutput per Tab as you will see in the code.
The problem that I have not been able to solve is: When I click the 'Refresh tables' button, I should get the a different DataTable render on each tab, but instead I get the last uploaded data in all tabs.
Attached I sent a dummy version of the app. It lacks lots of verifications and messages that I have in the original app, but depics the problem that I talk about.
Thank you very much for your help.
library(shiny)
library(DT)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
numericInput(inputId = 'numsel',
label = 'Total tabs',
value = 0,
min=0
),
uiOutput( outputId = 'TextInputs' ),
actionButton(inputId = 'RenderTabsButton',
label = 'Render Tabs'
),
actionButton(inputId = 'RefreshTablesButton',
label = 'Refresh Tables'
)
),
mainPanel(
h3('Make sure selector is at least 2'),
tabsetPanel( id= 'myTabsetpanel')
)
)
)
server <- function(input, output) {
observeEvent( input$numsel, {
numsel <- isolate(input$numsel)
text_inputs <- NULL
if(numsel>0){
text_inputs <- lapply(1:numsel, function(x){
textInput(inputId = paste( 'TextInput_', x, sep = '' ),
label = 'Tab Name'
)
})
output$TextInputs <- renderUI(text_inputs)
}
} )
observeEvent( input$RenderTabsButton, {
numsel <- isolate(input$numsel)
myTabs <- list()
for( index in 1: numsel){
myTabs[[index]] <- tabPanel(
title = input[[ paste( 'TextInput_', index, sep = '' ) ]],
fileInput(inputId = paste('FileInput_', index , sep = ''), label = '.csv file'),
dataTableOutput( outputId = paste('DataTableOutput_', index , sep = ''))
)
appendTab( inputId = 'myTabsetpanel' , tab = myTabs[[index]] ,select = TRUE )
}
} )
observeEvent( input$RefreshTablesButton, {
numsel <- isolate(input$numsel)
myData <-list()
for( index in 1: numsel){
datapath <- input[[ paste('FileInput_', index , sep = '') ]]$datapath
myData[[index]] <- read.csv(datapath)
output[[ paste('DataTableOutput_', index , sep = '') ]] <- renderDataTable( myData[[index]] )
}
} )
}
shinyApp(ui = ui, server = server)
Related
I have an app set up as this is. As the user selects multiple items from the Animals dropdown, the printout of what they have selected gets longer and pushes the elements under it down
I would like for the elements under it to be justified to the bottom of the page so that they don't move as more animals are selected
library(tidyverse)
library(ggplot2)
library(dplyr)
library(shiny)
# Define UI for app
ui <-
fillPage(
column(2,
fluidRow(
# Input 1: animal
selectInput(
inputId = 'FilterFieldSelection',
label = 'Animal Of Choice',
choices = c('Dog','Cat','Inu','Neko','Giraffe','Kirin','Mouse','Nezumi'),
selected = 'Dog',
multiple = TRUE
),
# Output 1: Active Filters
htmlOutput('ActiveFiltersText')
),
fluidRow(
h4("Counts"),
# Input 2: color
selectInput(
inputId = 'ColorChoice',
label = 'Color Of Choice',
choices = c('red','blue','green'),
selected = 'red'
),
# Output 2: Filtered Well Count
htmlOutput('WellCountFilteredText'),
)
),
column(10,
plotOutput('myplot')
)
)
# Define Server
server <- function(input, output, session) {
# Text Outputs ----
## Text Output Of Active Filters ----
output$ActiveFiltersText <- renderUI({
full_text <- ""
full_text <- paste0(full_text, '<b>','There Is A','</b>:<br/>',
paste(input$FilterFieldSelection,collapse="<br/>"),'<br/>'
)
full_text <- HTML(full_text)
})
## Text Output Of Filtered Well Count ----
output$WellCountFilteredText <- renderUI({
HTML(paste0('<b>','Filtered','</b>:<br/>',150000))
})
## Plot
output$myplot <- renderPlot({
m <- matrix(rnorm(50), ncol = 5)
colnames(m) <- c("a", "b", "c", "d", "e")
as_tibble(m) %>%
ggplot(aes(x=a, y=b) ) +
geom_point(color=input$ColorChoice)
})
}
# Run App
shinyApp(ui = ui, server = server)
I have tried putting the elements to not move in another fluidRow, but that didn't change anything. They're still fully top-justified
You can put the elements in a div with CSS style properties position: fixed; bottom: 0;.
ui <- fluidPage(
fluidRow(
column(
2,
selectInput(
inputId = 'FilterFieldSelection',
label = 'Animal Of Choice',
choices = c('Dog','Cat','Inu','Neko','Giraffe','Kirin','Mouse','Nezumi'),
selected = 'Dog',
multiple = TRUE
),
tags$div(
style = "position: fixed; bottom: 0;",
# Output 1: Active Filters
htmlOutput('ActiveFiltersText'),
tags$hr(),
h4("Counts"),
# Input 2: color
selectInput(
inputId = 'ColorChoice',
label = 'Color Of Choice',
choices = c('red','blue','green'),
selected = 'red'
),
# Output 2: Filtered Well Count
htmlOutput('WellCountFilteredText'),
)
),
column(
10,
plotOutput("myplot")
)
)
)
I have an app where the user will generate a bunch of selectizeInputs along with 3 numericInputs for every selectizeInput. The problem I am having is that the selectizeInput does not align well with the numericInputs and once you have about 10 rows, the alignment is completely gone.
I have thought of two ways of solving this problem:
create one renderUI function and include fluidRows in a loop but some searching has led me to believe that isnt possible.
Height adjust the selectizeInput with using tags$style(type = "text/css", ".form-control.shiny-bound-input, .selectize-input {height: 46px;}"), but I dont want to adjust the selectizeInput height universally as the app has selectizeInputs elsewhere.
I can't really hardcode the input name with tags$style(type = "text/css", "#some_id.form-control.shiny-bound-input {height: 46px;}") since the names are dynamically generated by the user.
Will one of these two options work? If not is there a third option?
I have made a demo version of the problem below.
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(width = 3, br(),br(),br(),br(),br(),br(),br(), h6("something else is here")),
mainPanel(
tabsetPanel(
tabPanel("Problem tab",
br(),
numericInput("inputs_num","Enter Number of Channels to Calibrate", min = 1, value = 10),
hr(),
br(),
fluidRow(
column(width= 3,uiOutput("colname")),
column(width =3, uiOutput("initial_numeric")),
column(width =3, uiOutput("min_numeric")),
column(width =3, uiOutput("max_numeric"))
),
hr()
)
)
)
)
)
server <- function(input, output, server){
output$colname <- renderUI({
req(input$inputs_num)
columns <- colnames(mtcars)
tags <- tagList()
for(i in 1:input$inputs_num){
tags[[i]] = selectizeInput(paste0("colname_",i), paste0("Column ",i), choices = columns, selected = NULL,
options = list(
placeholder = "Enter Column Name",
onInitialize = I('function() { this.setValue(""); }')
))
}
tags
})
output$initial_numeric <- renderUI({
req(input$inputs_num)
tags <- tagList()
for (i in 1:input$inputs_num){
tags[[i]] <- numericInput(paste0("initial_",i), paste("Initial",i), min = 0,value = 1)
}
tags
})
output$min_numeric <- renderUI({
req(input$inputs_num)
tags <- tagList()
for (i in 1:input$inputs_num){
tags[[i]] <- numericInput(paste0("min_",i), paste("Min",i), min = 0,value = 1)
}
tags
})
output$max_numeric <- renderUI({
req(input$inputs_num)
tags <- tagList()
for (i in 1:input$inputs_num){
tags[[i]] <- numericInput(paste0("max_",i), paste("Max",i), min = 0,value = 1)
}
tags
})
}
shinyApp(ui, server)
In Safari everything was aligned fine, and only in Firefox it became visible. I tried wrapping everything in one loop and it seems to work fine, even in Firefox.
So the approach below should correspond to solution 1. Since solution 2 (changing the css of the input universally) is not an option, another approach would be to define custom inputs by wrapping the original inputs in a tag and adding an additional class which can then be targeted in css. But I think that this not necessary, since the approach below works.
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(width = 3, br(),br(),br(),br(),br(),br(),br(), h6("something else is here")),
mainPanel(
tabsetPanel(
tabPanel("Problem tab",
br(),
numericInput("inputs_num","Enter Number of Channels to Calibrate", min = 1, value = 10),
hr(),
br(),
uiOutput("all"),
hr()
)
)
)
)
)
server <- function(input, output, server){
output$all <- renderUI({
req(input$inputs_num)
columns <- colnames(mtcars)
tags <- tagList()
for(i in 1:input$inputs_num){
tags[[i]] <- fluidRow(
column(width= 3,
selectizeInput(paste0("colname_",i), paste0("Column ",i), choices = columns, selected = NULL,
options = list(
placeholder = "Enter Column Name",
onInitialize = I('function() { this.setValue(""); }')
))),
column(width= 3,
numericInput(paste0("initial_",i), paste("Initial",i), min = 0,value = 1)),
column(width= 3,
numericInput(paste0("min_",i), paste("Min",i), min = 0,value = 1)),
column(width= 3,
numericInput(paste0("max_",i), paste("Max",i), min = 0,value = 1))
)
}
tags
})
}
shinyApp(ui, server)
I can't display the Sankey Graph on a shiny application through the data uploaded as a CSV using sankeyNetwork() from networkd3. Well, what I wanted to do is to enter a table as a squared matrix with all nodes and it's cases contain the weights! Simply I couldn't be able to generate Sankey graph this way described in the first part here : enter link description here
The goal is to facilitate to users of the app the add of data, though they won't be obliged to enter it as "source", "target" and " weight" it only generates a link if the weight between the two nodes associated with the matrix case regroups a weight other than zero! the Link I gave presents the command of adjacency matrix which works great on console but couldn't turn it into a shiny app
server.R
library(shiny)
require(networkD3)
require(igraph)
shinyServer(function(input, output) {
data <- reactive({
file1 <- input$myData
if (is.null(file1)) {
return()
}
read.csv(file = file1$datapath,
sep = input$sep,
header = FALSE)
})
label <- reactive({
file1 <- input$myLabels
if (is.null(file1)) {
return()
}
read.csv(file = file1$datapath,
sep = input$sep,
header = FALSE)
})
matrix <- function(data) {
m = as.matrix(data)
n = nrow(m) - 1
colnames(m) <- c(0:n)
return(m)
}
Nodes <- function(label) {
p = as.data.frame(label$Label)
colnames(p) <- as.factor(colnames(p))
return(p)
}
Links1 <- function(matrix) {
p = graph_from_adjacency_matrix(matrix,
mode = "directed",
weighted = T,
diag = T)
L = get.data.frame(p)
return(L)
}
Links1$from <- function(Links1) {
p = Links1$from
return(p)
}
Links1$to <- function(Links1) {
j = Links1$to
return(j)
}
Links1$weight <- function(Links1) {
o = Links1$weight
return(o)
}
output$plot <- renderSankeyNetwork({
sankeyNetwork(
Links = Links1,
Nodes = Nodes,
Source = ' Links1$from',
Target = 'Links1$to',
Value = 'Links1$weight',
NodeID = "label$Label",
fontSize = 30,
nodeWidth = 30
)
})
output$filedf <- renderTable({
if (is.null(data())) {
return ()
}
input$file
})
output$sum <- renderTable({
if (is.null(data())) {
return ()
}
summary(data())
})
output$table <- renderTable({
if (is.null(data())) {
return ()
}
data()
})
output$tb <- renderUI({
if (is.null(data()))
h5("Powered by",
tags$img(
src = 'RStudio-Ball.png',
heigth = 200,
width = 200
))
else
tabsetPanel(
tabPanel("About file", tableOutput("filedf")),
tabPanel("Data",
tableOutput("table")),
tabPanel("Summary", tableOutput("sum"))
)
})
})
ui.R
require(networkD3)
library(shiny)
require(igraph)
shinyUI(fluidPage(
titlePanel("File Input"),
sidebarLayout(
sidebarPanel(
fileInput("myData", "Upload your data"),
fileInput("myLabels", "Upload its label as ID/Label/Nodes"),
helpText("Default max. file size is 5MB"),
radioButtons(
inputId = 'sep',
label = 'Separator',
choices = c(
Comma = ',',
Semicolon = ';',
Tab = '\t',
Space = ''
),
selected = ';'
)
),
mainPanel(sankeyNetworkOutput("plot"), uiOutput("tb"))
)
))
Not sure what you're trying to do with all of those improperly and ultimately unused functions that you declare, but maybe this minimized example will help you get started...
(all in one R file, doesn't matter what you name the file)
library(shiny)
ui <- fluidPage(titlePanel("File Input"),
sidebarLayout(
sidebarPanel(
fileInput("myData", "Upload your data"),
fileInput("myLabels", "Upload its label as ID/Label/Nodes"),
helpText("Default max. file size is 5MB"),
radioButtons(
inputId = 'sep',
label = 'Separator',
choices = c(
Comma = ',',
Semicolon = ';',
Tab = '\t',
Space = ' '
),
selected = ';'
)
),
mainPanel(sankeyNetworkOutput("plot"), uiOutput("tb"))
))
server <- function(input, output) {
data <- reactive({
file1 <- input$myData
if (is.null(file1)) {
return(NULL)
}
read.csv(file = file1$datapath,
sep = input$sep,
header = TRUE)
})
label <- reactive({
file1 <- input$myLabels
if (is.null(file1)) {
return(NULL)
}
read.csv(file = file1$datapath,
sep = input$sep,
header = TRUE)
})
output$plot <- renderSankeyNetwork({
print(names(data()))
sankeyNetwork(
Links = data(),
Nodes = label(),
Source = 'source',
Target = 'target',
Value = 'value',
NodeID = "name",
fontSize = 30,
nodeWidth = 30
)
})
}
shinyApp(ui = ui, server = server)
and using the following CSV files as examples...
myData.csv
source;target;value
0;1;124.729
1;2;0.597
1;3;26.862
1;4;280.322
1;5;81.144
6;2;35
7;4;35
8;9;11.606
10;9;63.965
9;4;75.571
11;12;10.639
11;13;22.505
11;14;46.184
15;16;104.453
15;14;113.726
15;17;27.14
15;12;342.165
15;18;37.797
15;19;4.412
15;13;40.858
15;3;56.691
15;20;7.863
15;21;90.008
15;22;93.494
23;24;40.719
25;24;82.233
5;13;0.129
5;3;1.401
5;26;151.891
5;19;2.096
5;12;48.58
27;15;7.013
17;28;20.897
17;3;6.242
28;18;20.897
29;15;6.995
2;12;121.066
2;30;128.69
2;18;135.835
2;31;14.458
2;32;206.267
2;19;3.64
2;33;33.218
2;20;4.413
34;1;4.375
24;5;122.952
35;26;839.978
36;37;504.287
38;37;107.703
37;2;611.99
39;4;56.587
39;1;77.81
40;14;193.026
40;13;70.672
41;15;59.901
42;14;19.263
43;42;19.263
43;41;59.901
4;19;0.882
4;26;400.12
4;12;46.477
26;15;525.531
26;3;787.129
26;11;79.329
44;15;9.452
45;1;182.01
46;15;19.013
47;15;289.366
myLabels.csv
name
Agricultural 'waste'
Bio-conversion
Liquid
Losses
Solid
Gas
Biofuel imports
Biomass imports
Coal imports
Coal
Coal reserves
District heating
Industry
Heating and cooling - commercial
Heating and cooling - homes
Electricity grid
Over generation / exports
H2 conversion
Road transport
Agriculture
Rail transport
Lighting & appliances - commercial
Lighting & appliances - homes
Gas imports
Ngas
Gas reserves
Thermal generation
Geothermal
H2
Hydro
International shipping
Domestic aviation
International aviation
National navigation
Marine algae
Nuclear
Oil imports
Oil
Oil reserves
Other waste
Pumped heat
Solar PV
Solar Thermal
Solar
Tidal
UK land based bioenergy
Wave
Wind
Reproducible example:
require(shiny)
runApp(list(ui = pageWithSidebar(
headerPanel("Example"),
sidebarPanel(
sliderInput("index",
label = "Select a number",
min = 1,
max = 4,
step = 1,
value = 2)),
mainPanel(
htmlOutput("text")
)),
server = function(input, output) {
output$text <- renderUI({
HTML(paste(c("banana","raccoon","duck","grapefruit")))
})
}
))
I would like to have the word corresponding to index ("raccoon" in the default) displayed in bold and the other words in normal font.
If I do:
HTML(
<b>paste(c("banana","raccoon","duck","grapefruit")[input$index])<\b>,
paste(c("banana","raccoon","duck","grapefruit")[setdiff(1:4,input$index)])
)
I receive an error (< is not recognized)...
One more try, is this helpful?
require(shiny)
fruits <- c("banana","raccoon","duck","grapefruit")
runApp(list(ui = pageWithSidebar(
headerPanel("Example"),
sidebarPanel(
sliderInput("index",
label = "Select a number",
min = 1,
max = 4,
step = 1,
value = 2)),
mainPanel(
htmlOutput("text")
)),
server = function(input, output) {
output$text <- renderUI({
fruits[input$index] <- paste("<b>",fruits[input$index],"</b>")
HTML(paste(fruits))
})
}
))
This might help you:
shinyApp(
ui <- basicPage(
uiOutput(outputId = "text")
),
server <- function(input,output){
output$text <- renderText({
HTML(paste0("<b>","bold","</b>", " not bold"))
})
})
Is that what you were looking for?
If you're not set on using the HTML function, I believe you should be able to use strong(paste(character_vector[index])) instead.
Just use renderPrint instead of renderText
renderPrint({
HTML(paste0("El valor 1 es:", input$val1,"\n","el valor 2 es:",input$val2))
})
I want to select from a list read in from a Mysql query. I am getting an error in the code. I must be doing something just completely wrong, but not sure what.
I would like to select from a list of skus read in from a sql query. I get an error in the ui portion.
I am not even sure if this is possible, but to list out all skus would be extremely timely.
I am getting the following errors:
Error in tag("div", list(...)) :
argument "sidebarPanel" is missing, with no default
shinyApp(ui = ui, server = server)
Error in force(ui) : object 'ui' not found
library('RMySQL')
library('plyr')
library('shiny')
library('scales')
library(shinyapps)
library(ggplot2)
con <- dbConnect(MySQL(), user="user", password="password",dbname="DB", host="host");
rank<-dbGetQuery(con,"select sku from DB")
#build a shiny app to select which sku to pick
server <- function(input, output) {
output$distPlot <- renderPlot({
hist(rnorm(input$obs), col = 'darkgray', border = 'white')
})
}
ui <- pageWithSidebar(
## Application title
sidebarPanel(
sliderInput("obs", "Number of observations:", min = 10, max = 500, value = 100),
selectInput(
'e0', '0. An ordinary select input', choices = unique(rank$sku),
selectize = FALSE
),
mainPanel(plotOutput("distPlot"))
)
)
shinyApp(ui = ui, server = server)
You have both a missing bracket near your selectize = FALSE and (as #DavidRobinson has suggested) you need a headerPanel.
CODE FIX
library(shiny)
library(ggplot2)
# con <- dbConnect(MySQL(), user="user", password="password",dbname="DB", host="host");
# rank<-dbGetQuery(con,"select sku from DB")
# for test hard coding the rank as I dont have your data
# test rank
rank$sku <- c(1,2,3)
#build a shiny app to select which sku to pick
server <- function(input, output) {
output$distPlot <- renderPlot({
hist(rnorm(input$obs), col = 'darkgray', border = 'white')
})
}
ui <- pageWithSidebar(
## Application title
# missing headerPanel
headerPanel(title = "Hello"),
# missing bracket after selectize
sidebarPanel(
sliderInput("obs", "Number of observations:", min = 10, max = 500, value = 100),
selectInput(
'e0', '0. An ordinary select input', choices = unique(rank$sku),
selectize = FALSE)
),
mainPanel(plotOutput("distPlot"))
)
shinyApp(ui = ui, server = server)
RESULT
ANOTHER SHINY PAGE UI OPTION
You can can also use a tabbed page structure, replacing ui above with this code (note it does not require headerPanel like above):
# navbar tabbed page example - without headerPanel
ui2 <- navbarPage(title = "Hello Another Style",
tabPanel("Chart Panel",
sidebarLayout(
sidebarPanel(
sliderInput("obs", "Number of observations:",
min = 10, max = 500, value = 100),
selectInput(
'e0', '0. An ordinary select input',
choices = unique(rank$sku),
selectize = FALSE)
),
mainPanel(
plotOutput("distPlot")
)
)
),
tabPanel("Instructions",
mainPanel(
p("Notes here for example...")
)
)
)
SECOND RESULT
And then on second panel...
DEBUGGING ADVICE
These Shiny pages can have lots of brackets, so pace over your code selecting brackets in turn carefully in your editor like RStudio to make sure your brackets match okay.
All the best!