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);
})
}
)
)
Related
I am developing a shiny app for regression analysis. I get an error when I want to change some variables to factor using the factor() function.
I want the user to select the variables he\she wants to change to factor from a selectInoput() and use a reactive function to feed the results to a new dataframe but the result is very weird! :(
I put a simplified version of what I do here.
Spent a day and could find the solution. Would appreciate your help.
x <- c( 1:5 )
y <- c( 10:14)
df <- data.frame(
x = x,
y = y
)
library(shiny)
ui <- fluidPage(
titlePanel(""),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "str", label = "which variables should be changed to factors",choices = names(df), multiple = T)
),
mainPanel(
verbatimTextOutput("output")
)
)
)
server <- function(input, output) {
df_2 <- reactive({
df[ , input$str ] <- factor(df[ , input$str ])
})
output$output <- renderPrint({
str( df_2() )
})
}
shinyApp(ui = ui, server = server)
Your code only needs minor modification in server.
x <- c( 1:5 )
y <- c( 10:14)
df <- data.frame(
x = x,
y = y
)
library(shiny)
ui <- fluidPage(
titlePanel(""),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "vars", label = "which variables should be changed to factors",choices = names(df), multiple = T)
),
mainPanel(
verbatimTextOutput("output")
)
)
)
server <- function(input, output) {
selected_vars <- reactive(input$vars)
df_2 <- reactive({
df[selected_vars()] <- lapply(df[selected_vars()], as.factor)
return(df)
})
output$output <- renderPrint({
str(df_2())
})
}
shinyApp(ui = ui, server = server)
I am creating a Shiny App where I used machine learning algorithms and these latter used a lot of compute power. I would like to use the function bindCache for extracting the calculated results. However, when my inputs are ordered in a different way but the results stay the same, my algorithms recalculate everything, which I don't want. Here is a simple example to illustrate my problem:
library(shiny)
shinyApp(
ui = fluidPage(
selectInput("x", "x", seq(10), multiple = TRUE)
, br()
, br()
, br()
, br()
, br()
, br()
, br()
, br()
, br()
, br()
, verbatimTextOutput("txt")
),
server = function(input, output){
r <- reactive({
message("Doing expensive computation...")
Sys.sleep(2)
sort(as.numeric(input$x))
}) %>% bindCache(input$x)
output$txt <- renderText(r())
}
)
For example, if I enter 2 and then 5, the input is a c(2,5) and the sum 7. The result is saved if I enter again 2 and then 5. However, if I enter 5 and then 2, the result is recalculated again for the same result. How can I avoid the recalculation if the list of values contains the same values but not ordered?
I believe this works:
bindCache(sum(as.numeric(input$x)))
Two possibilities are using bindCache with a pre-computed key or memoise with pre-computed input. To see them work, for example:
Type "A B C" in the input box then press the button.
Type "C B A" in the input box then press the button.
Using bindCache:
library(shiny)
library(stringr)
shinyApp(
ui = fluidPage(
textInput("text_input", label = "input"),
tableOutput("table_output"),
actionButton("start_button", label = "calculate")
),
server = function(input, output){
sort_input = reactive({
sort(str_split(input$text_input, " ")[[1]])
})
calc_output = reactive({
Sys.sleep(2)
sort_input()
}) %>%
bindCache({sort_input()}) %>%
bindEvent(input$start_button)
observe({
output$table_output = renderTable(as.matrix(system.time(calc_output())), rownames = T)
})
}
)
Using memoise:
library(shiny)
library(stringr)
library(memoise)
sort_func = function(input)
{
return(sort(str_split(input$text_input, " ")[[1]]))
}
output_func = function(input) {
Sys.sleep(2)
}
output_func_memoised = memoise(output_func)
shinyApp(
ui = fluidPage(
textInput("text_input", label = "input"),
tableOutput("table_output"),
actionButton("start_button", label = "calculate")
),
server = function(input, output){
calc_output = reactive({
output_func_memoised(sort_func(input))
}) %>%
bindEvent(input$start_button)
observe({
output$table_output = renderTable(as.matrix(system.time(calc_output())), rownames = T)
})
}
)
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")
)
)
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 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){
}
))