I would like to generate sliders in my server (because the number of sliders I need depend on other inputs). As you will see with the code herebelow and the picture, the sliders that appear do not look good. I presume it has to do with the way I specify them in HTML (maybe something to do with the style/css?).
Here is the code:
ui <- pageWithSidebar(
headerPanel("test"),
sidebarPanel(
helpText('these sliders do not look good:')
),
mainPanel(uiOutput('slider'))
)
server <- function(input,output, session){
output$slider <- renderTable({
inputs <- paste0("<input id='Sl_C", 1:2, "' class='jslider-pointer jslider-pointer-to' type = 'range' value='c(0,20)' min='0' max='100'>")
matrix <- data.frame(inputs)
},sanitize.text.function = function(x) x)
}
runApp(list(ui=ui,server=server))
Any advice/suggestion would be highly appreciated.
All the best
Here is one way to achieve multiple slider inputs.
library(shiny)
multiSliders = function(n, ...){
sliders = lapply(1:n, function(i){
sliderInput(paste0('slider-', i), paste('Slider', i), ...)
})
paste_all = function(...) paste(..., collapse = '\n')
HTML(do.call('paste_all', sliders))
}
runApp(list(
ui = pageWithSidebar(
headerPanel('Multiple Sliders'),
sidebarPanel(
sliderInput('slider-0', 'Slider0', 0, 10, 4),
multiSliders(2, 0, 10, 4)
),
mainPanel()
),
server = function(input, output){
}
))
Related
I am creating a matrix in my server. I would like to then output this matrix on the screen using renderTable(). (I create it in the server because its length (among others) depends on some other inputs in the ui).
As you will see with the code (or the attached picture) here below, the matrix that appears does not look good at all :it's a matrix with grey borders, rounded corners etc.
So the question: is there a way to control the appearance of the matrix ? For example, I may not want borders, I may want the rownames to be in Italics/bold etc...
shiny::runApp(
list(
ui = pageWithSidebar(
headerPanel("TEST"),
sidebarPanel(
helpText('This matrix is pretty ugly:')
),
mainPanel(
uiOutput('matrix')
)
)
,
server = function(input,output){
output$matrix <- renderTable({
matrix <- matrix(rep(1,6),nrow=3)
rownames(matrix) <- c('a','b','c')
matrix
})
}
)
)
Mathjax rendering:
library(xtable)
shiny::runApp(
list(
ui = pageWithSidebar(
headerPanel("TEST"),
sidebarPanel(
helpText('Is this matrix cool ?')
),
mainPanel(
uiOutput('matrix')
)
)
,
server = function(input,output){
output$matrix <- renderUI({
M <- matrix(rep(1,6),nrow=3)
rownames(M) <- c('a','b','c')
M <- print(xtable(M, align=rep("c", ncol(M)+1)),
floating=FALSE, tabular.environment="array", comment=FALSE, print.results=FALSE)
html <- paste0("$$", M, "$$")
list(
tags$script(src = 'https://c328740.ssl.cf1.rackcdn.com/mathjax/2.0-latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML', type = 'text/javascript'),
HTML(html)
)
})
}
)
)
Update July 2015
Something has changed and the MathJax rendering does not work anymore. Maybe this is the link to the MathJax library, I don't know. Anyway, there's a new function in Shiny, withMathJax, which does the job. Replace the server function by the following one:
server = function(input,output){
output$matrix <- renderUI({
M <- matrix(rep(1,6),nrow=3)
rownames(M) <- c('a','b','c')
M <- print(xtable(M, align=rep("c", ncol(M)+1)),
floating=FALSE, tabular.environment="array", comment=FALSE, print.results=FALSE)
html <- paste0("$$", M, "$$")
list(
withMathJax(HTML(html))
)
})
}
You can start fiddling with CSS, but for quick work the googleVis package is nice. Additional options to add decorations can be found in the documentation.
shiny::runApp(
list(
ui = pageWithSidebar(
headerPanel("TEST"),
sidebarPanel(
helpText('This matrix is quite nice:')
),
mainPanel(
uiOutput('matrix')
)
)
,
server = function(input,output){
library(googleVis)
output$matrix <- renderGvis({
df <- as.data.frame(matrix(rnorm(9),nrow=3))
rownames(df) <- c('a','b','c')
gvisTable(df);
})
}
)
)
For rownames in googleVis package use:
shiny::runApp(
list(
ui = pageWithSidebar(
headerPanel("TEST"),
sidebarPanel(
helpText('This matrix is quite nice:')
),
mainPanel(
uiOutput('matrix')
)
)
,
server = function(input,output){
library(googleVis)
output$matrix <- renderGvis({
df <- as.data.frame(matrix(rnorm(9),nrow=3))
df <- cbind(' ' = c('a','b','c'),df)
gvisTable(df);
})
}
)
)
How do I create a scrollable list of tables within a tabPanel?
Based on Outputing N tables in shiny, where N depends on the data, I have tried the following
Server.R
userHist <- list(
data.frame(X=1:10,Y=11:20),
data.frame(X=1:10,Y=11:20))
output$groupHistory <- renderUI({
userHistList <- lapply( seq(userHist), function(i){
hist_i <- userHist[[i]]
TabName <- paste0("User", i)
fluidRow( column(10,
h2(TabName),
hr(),
column(3, renderTable(hist_i, rownames=TRUE) )
) )
} )
userHistList
})
ui.R
tabsetPanel(id="tabsetpanel",
tabPanel(h1("Group History"),
style="overflow-y:scroll;",
uiOutput("groupHistory")
)
)
There is a main firefox scrollbar that shows up when the list gets long, but there is a second scrollbar for the table that does not scroll vertically. Ideally I would also eliminate horizontal scrolling.
You need to call the render first to create the output objects and the compose the UI with those objects:
ui <- fluidPage(
tabsetPanel(
id = "tabsetpanel",
tabPanel(
style = "overflow-y:scroll; max-height: 600px",
h1("Group History"),
numericInput("n_users", "Number of Users", value = 5, min = 1, max = 10),
uiOutput("group_history")
)
)
)
server <- shinyServer(function(input, output) {
df_list <- reactive({
n <- input$n_users
# generate some observations
obs_x <- seq(3)
obs_y <- obs_x + n
# generate the df
df_template <- data.frame(x = obs_x, y = obs_y)
# make a list of df and return
lapply(seq(n), function(n) {
df_template
})
})
# use the constructed renders and compose the ui
output$group_history <- renderUI({
table_output_list <- lapply(seq(input$n_users), function(i) {
table_name <- paste0("table", i)
tab_name <- paste("User", i)
fluidRow(
column(
width = 10,
h2(tab_name),
hr(), column(3, tableOutput(table_name))
)
)
})
# Convert the list to a tagList - this is necessary for the list of items
# to display properly.
do.call(tagList, table_output_list)
})
# Call renderTable for each one. Tables are only actually generated when they
# are visible on the web page.
observe({
data <- df_list()
for (i in seq(input$n_users)) {
# Need local so that each item gets its own number. Without it, the value
# of i in the renderPlot() will be the same across all instances, because
# of when the expression is evaluated.
local({
my_i <- i
tab_name <- paste0("table", my_i)
output[[tab_name]] <- renderTable(data[[my_i]], rownames = TRUE)
})
}
})
})
shinyApp(ui, server)
Based off of Winston Chang's work here
I wrapped the list in fluidPage or wellPanel and everything works as I want.
Server.R
userHist <- list(
data.frame(X=1:10,Y=11:20),
data.frame(X=1:10,Y=11:20))
output$groupHistory <- renderUI({
userHistList <- lapply( seq(userHist), function(i){
hist_i <- userHist[[i]]
TabName <- paste0("User", i)
fluidRow( column(10,
h2(TabName),
hr(),
column(3, renderTable(hist_i, rownames=TRUE) )
) )
} )
table_output_list <- fluidPage(userHistList,
style="overflow-y:scroll; max-height: 90vh")
})
UI.R
tabsetPanel(id="tabsetpanel",
tabPanel(h1("Group History"),
style="overflow: visible",
uiOutput("groupHistory")
)
)
Is there a way to show the value from textInput() elsewhere in the UI without having to go through server.R with something very verbose like the following?
ui.R
library(shiny)
shinyUI(
fluidPage(
textInput('text_in', label = 'Write text here'),
# elsewhere in the UI...
textOutput('text_out')
))
server.R
library(shiny)
shinyServer(function(input, output) {
output$text_out = renderText(input$text_in)
})
It's not too bad for this example, but it becomes very verbose when I need to do it many times. My desire is to collect all the inputs the user enters throughout the app and compile them into a nice table at the end so they can confirm everything is laid out right.
I've seen you can reference input elements without going through the server when using a JavaScript expression in conditionalPanel() but I'm not sure how to implement that outside of this specific instance.
For accessing all inputs, you can use reactiveValuesToList server-side. You can access input values via Javascript Events like below (I have taken the example from #Pork Chop) :
library(shiny)
ui <- basicPage(
fluidRow(
column(
width = 6,
textInput('a', 'Text A',"a1"),
textInput('b', 'Text B',"b1"),
textInput('c', 'Text A',"c1"),
textInput('d', 'Text B',"d1"),
textInput('e', 'Text A',"e1"),
textInput('f', 'Text B',"f1")
),
column(
width = 6,
tags$p("Text A :", tags$span(id = "valueA", "")),
tags$script(
"$(document).on('shiny:inputchanged', function(event) {
if (event.name === 'a') {
$('#valueA').text(event.value);
}
});
"
),
tableOutput('show_inputs')
)
)
)
server <- shinyServer(function(input, output, session){
AllInputs <- reactive({
x <- reactiveValuesToList(input)
data.frame(
names = names(x),
values = unlist(x, use.names = FALSE)
)
})
output$show_inputs <- renderTable({
AllInputs()
})
})
shinyApp(ui = ui, server = server)
Since your overall objective is to collect all the user inputs and then compile them into a table I will show you how to achieve that with example below. As you can see all of the input variables can be accessed by names from server. I kept them in a reactive just in case you need it for further analysis or for some renderUI functionality.
#rm(list=ls())
library(shiny)
ui <- basicPage(
textInput('a', 'Text A',"a1"),
textInput('b', 'Text B',"b1"),
textInput('c', 'Text A',"c1"),
textInput('d', 'Text B',"d1"),
textInput('e', 'Text A',"e1"),
textInput('f', 'Text B',"f1"),
tableOutput('show_inputs')
)
server <- shinyServer(function(input, output, session){
AllInputs <- reactive({
myvalues <- NULL
for(i in 1:length(names(input))){
myvalues <- as.data.frame(rbind(myvalues,(cbind(names(input)[i],input[[names(input)[i]]]))))
}
names(myvalues) <- c("User Input","Last Value")
myvalues
})
output$show_inputs <- renderTable({
AllInputs()
})
})
shinyApp(ui = ui, server = server)
If the Shiny inputs all have different lengths and the above does not work (e.g. if you have combination of radio buttons, checkboxgroup, textInput, etc.) this will work and can produce a table of variable:value that you can parse later:
AllInputs <- reactive({
myvalues <- NULL
newvalues <- NULL
for(i in 1:length(names(input))){
newvalues <- paste(names(input)[i], input[[names(input)[i]]], sep=":")
myvalues <- append(myvalues, newvalues)
}
myvalues
})
output$show_inputs <- renderTable({
AllInputs()
})
Borrowing from both Pork Chop and mysteRious, here's a solution that works for multiple types of text & number inputs in shiny.
library(shiny)
AdvRchp3 <- "While you’ve probably already used many (if not all)
of the different types of vectors, you may not have thought
deeply about how they’re interrelated. In this chapter,
I won’t cover individual vectors types in too much detail,
but I will show you how all the types fit together as a whole.
If you need more details, you can find them in R’s documentation."
ui <- fluidPage(
fluidRow(
h4("Text Inputs"),
textInput("text_input", "Input some Text", value = "some text"),
passwordInput("password_input", "Input a Password", value = "1234"),
textAreaInput("text_area_input", "Input lots of Text", rows = 3, value = AdvRchp3)
),
fluidRow(
h4("Numeric Inputs"),
numericInput("numeric_input", "Number 1", value = 1, min = 0, max = 100),
sliderInput("slider_input_single", "Number 50", value = 50, min = 0, max = 100),
sliderInput("slider_input_ranges", "Range 10 to 20", value = c(10, 20), min = 0, max = 100)
),
fluidRow(
tableOutput("show_inputs")
)
)
server <- function(input, output, session) {
all_inputs <- reactive({
input_df <- NULL
df_row <- NULL
for(i in 1:length(names(input))){
df_row <- as.data.frame(cbind(names(input)[i], input[[names(input)[i]]]))
input_df <- as.data.frame(dplyr::bind_rows(input_df, df_row))
}
names(input_df) <- c("input_id", "input_val")
input_df
})
output$show_inputs <- renderTable({
all_inputs()
})
}
shinyApp(ui, server)
notice: the rbind is now dplyr::bind_rows, but plyr::rbind.fill will also work.
Fowllowing the description of dynamic shiny app at topic [R Shiny Dynamic Input
, i want to get a data into shiny app. I wrote in ui.R
library(fPortfolio)
library(quantmod)
library(shiny)
ui <- shinyUI(fluidPage(
titlePanel("Portfolio optimization"),
sidebarLayout(
sidebarPanel(
numericInput("numInputs", "A number of stocks", 2),
# place to hold dynamic inputs
uiOutput("inputGroup")
),
mainPanel(
tabPanel("Trading Statistics",
fixedRow(
column(8,
fixedRow(column(4,tableOutput("tablePerformance")),
column(4,tableOutput("tableRisk"))),
fixedRow(column(4,tableOutput("tableDaily")),
column(4,tableOutput("tableMonthly"))))
))
)
)
))
and in server.r
library(fPortfolio)
library(quantmod)
library(shiny)
server<-shinyServer(function(input, output){
observeEvent(input$numInputs, {
output$inputGroup = renderUI({
input_list <- lapply(1:input$numInputs, function(i) {
# for each dynamically generated input, give a different name
inputName <- paste("input", i, sep = "")
textInput(inputName, inputName, value = 1)
})
do.call(tagList, input_list)
})
})
data <- read.csv("E:/stock vn data/dulieuvietnam/metastock_all_data.txt", header = TRUE, stringsAsFactors = FALSE)
Tickers <- data[!duplicated(data$X.Ticker.),1]
Tickers <- subset(Tickers,substr(Tickers,1,1)!= "^")
PriceList <- list()
for (i in 1:length(Tickers)){
PriceList[[i]] <- subset(data[,c(2,6)],data$X.Ticker. == Tickers[i])
names(PriceList[[i]]) <- c("Date",Tickers[i])
PriceList[[i]][PriceList[[i]]==0]<-NA
PriceList[[i]] <- na.locf(PriceList[[i]])
}
PriceList[[(length(Tickers)+1)]]<-subset(data[,c(2,6)],data$X.Ticker. == "^VNINDEX")
names(PriceList[[(length(Tickers)+1)]]) <- c("Date","VNINDEX")
PriceList[[(length(Tickers)+1)]][PriceList[[(length(Tickers)+1)]]==0]<-NA
PriceList[[(length(Tickers)+1)]] <- na.locf(PriceList[[(length(Tickers)+1)]])
dataPrice <- PriceList[[1]]
for (k in 2:length(PriceList)){
dataPrice <-merge(dataPrice,PriceList[[k]],all=TRUE)
}
output$tablePerformance<-renderTable({
})
})
.
When i run runApp(), the app only shows input with label "A number of stocks" that has default value is 2. However, interface of app did not show two text input.
Please help me!
I'm creating Shiny app and I want to use checkboxGroupInput in order to print out multiple plots. However, I want to print out plots only for the elements of checkboxGroupInput that were checked. There is a similar example in Shiny gallery to create UI elements in a loop that uses lapply. Here is a simplified version of that example to show what I want to do:
#server.R
library(shiny)
library(ggplot2)
shinyServer(function(input, output, session) {
numberInput <- reactive({
input$checkbox
})
lapply(1:10, function(i) {
output[[paste0('b', i)]] <- renderPlot({
qplot(x = rnorm(100, mean = as.numeric(numberInput()[i]))) +
ggtitle(paste("This plot was plotted with", numberInput()[i], "option"))
})
})
})
#ui.R
library(shiny)
shinyUI(fluidPage(
title = 'lapply example',
sidebarLayout(
sidebarPanel(
checkboxGroupInput("checkbox", "Checkbox",
choices = sample(1:10, 5))
),
mainPanel(
lapply(1:10, function(i) {
plotOutput(paste0('b', i))
})
)
)
))
This works, but obviously when Shiny tries to extract numberInput()[i] where i is bigger than number of currently checked elements, there is nothing to extract and instead of a plot there is an error. Therefore I need to somehow tell lapply to iterate only n number of times where n is length(input$checkbox).
I tried to use length(input$checkbox) directly, tried putting that element in the numberInput() reactive statement and returning it as the list, I tried to use reactiveValues() in a following way:
v <- reactiveValues(n = length(input$checkbox))
lapply(1:isolate(v$n), function(i) {
However, in all of those instances Shiny complains about lack of active reactive context.
So, what am I missing? How can I use length of input in lapply outside of reactive context?
I've generally had more luck using this approach (only because it's easier for me to wrap my head around it), but the idea is to render your plots into a UI on the server and then render the UI in ui.R
#server.R
library(shiny)
library(ggplot2)
server <- shinyServer(function(input, output, session) {
output$checks <- renderText(input$checkbox)
output$plots <- renderUI({
plot_output_list <-
lapply(input$checkbox,
function(i){
plotOutput(paste0("plot", i))
})
do.call(tagList, plot_output_list)
})
observe({
for (i in input$checkbox) {
local({
local_i <- i
output[[paste0("plot", local_i)]] <-
renderPlot({
qplot(x = rnorm(100, mean = as.numeric(local_i))) +
ggtitle(paste("This plot was plotted with", local_i, "option"))
})
})
}
})
})
#ui.R
library(shiny)
ui <- shinyUI(fluidPage(
title = 'lapply example',
sidebarLayout(
sidebarPanel(
checkboxGroupInput("checkbox", "Checkbox",
choices = sample(1:10, 5))
),
mainPanel(
verbatimTextOutput("checks"),
uiOutput('plots')
)
)
))
shinyApp(ui = ui, server = server)