How can I create a "table result" to each relationship I assumed in the selectInput "Col" and "Row"? Dinamicaly, after each press 'ok' botom.
library(shiny)
shinyUI(fluidPage(
h4("Give a valor between 0 to 5, to each col/row relationship"),
uiOutput("colrow"),
hr(),
h5("Result:"),
tableOutput("result")
))
shinyServer(
function(input, output, session) {
cols <<- c("Select"="", "col01" = "c01", "col02" = "c02")
rows <<- c("Select"="", "row01" = "r01", "row02" = "r02")
values <<- c("Select"="", 1:5)
output$colrow <- renderUI({
div(selectInput("ipt_col", label = "Col",
choices = c(cols),
selected = cols[1],
width = "50%"),
selectInput("ipt_row", label = "Row",
choices = c(rows),
selected = rows[1],
width = "50%"),
selectInput("ipt_vlr", label = "Value",
choices = c(values),
selected = ""),
actionButton("bt_ok", "ok")
)
})
colrow_vlr <- eventReactive(input$bt_ok, {
as.data.frame(matrix(input$ipt_vlr, 1,1, dimnames = list(input$ipt_row,input$ipt_col)))
})
output$result <- renderTable({
colrow_vlr()
})
})
I changed your code a little bit and now it works. I added comments at where the changes were made.
library(shiny)
ui <- fluidPage(
h4("Give a valor between 0 to 5, to each col/row relationship"),
uiOutput("colrow"),
hr(),
h5("Result:"),
# using DT which is recommended in shiny
DT::dataTableOutput("result")
)
server <- function(input, output, session) {
# no need to assign in the global env especially 'cols' is reserved
cols <- c("Select"="", "col01" = "c01", "col02" = "c02")
rows <- c("Select"="", "row01" = "r01", "row02" = "r02")
values <- c("Select"="", 1:5)
output$colrow <- renderUI({
div(selectInput("ipt_col", label = "Col",
choices = cols, # no need to wrap with c()
selected = cols[1],
width = "50%"),
selectInput("ipt_row", label = "Row",
choices = rows,
selected = rows[1],
width = "50%"),
selectInput("ipt_vlr", label = "Value",
choices = values,
selected = ""),
actionButton("bt_ok", "ok")
)
})
colrow_vlr <- eventReactive(input$bt_ok, {
as.data.frame(matrix(input$ipt_vlr, 1,1, dimnames = list(input$ipt_row,input$ipt_col)))
})
output$result <- DT::renderDataTable({
colrow_vlr()
})
}
shinyApp(ui = ui, server = server)
Related
I would like to download rhandsontable output object from an R Shiny app into .xlsx and .pdf format. Does anyone have any idea how to do this? For example, I want to download the tables in the results tab in the app below (the codes are copied from my other question earlier):
library(shiny)
library(rhandsontable)
ui <- navbarPage("App",
tabPanel("Input",
numericInput('num_of_table', "Number of sub tabs: ", value = 1, min = 1, max = 10),
uiOutput("input")),
tabPanel("Results",
uiOutput("results"))
)
server <- function(input, output,session) {
### Input ###
input_table <- reactive({
list_of_input_table = list()
for (i in c(1:input$num_of_table)){
mat <- matrix(c(1:25) * i, ncol = 5, nrow = 5)
list_of_input_table[[i]] = as.data.frame(mat)
}
index = c(1:i)
list_of_input_table[index]
})
observeEvent(input$num_of_table, {
lapply(seq_len(input$num_of_table), function(i) {
output[[paste0('input_table_', i)]] <- renderRHandsontable({
rhandsontable(input_table()[[i]])
})
})
})
output$input <- renderUI({
nTabs = input$num_of_table
myTabs1 = lapply(seq_len(nTabs), function(x){
tabPanel(paste("Tab", x),
column(12,
rHandsontableOutput(paste0("input_table_", x))))
})
do.call(tabsetPanel, myTabs1)
})
### Results ###
results_table <- reactive({
list_of_results_table = list()
for (i in c(1:input$num_of_table)){
req(input[[paste0("input_table_", i)]])
list_of_results_table[[i]] <- hot_to_r(input[[paste0("input_table_", i)]])[2:5]/hot_to_r(input[[paste0("input_table_", i)]])[1:4]
}
return(list_of_results_table)
})
observeEvent(input$num_of_table, {
lapply(seq_len(input$num_of_table), function(i) {
output[[paste0('results_table_', i)]] <- renderRHandsontable({
rhandsontable(results_table()[[i]])
})
})
})
output$results <- renderUI({
nTabs = input$num_of_table
myTabs2 = lapply(seq_len(nTabs), function(x){
tabPanel(paste("Tab", x),
column(12,
rHandsontableOutput(paste0("results_table_", x))))
})
do.call(tabsetPanel, myTabs2)
})
}
shinyApp(ui,server)
Appreciate any help! Thanks!
This will download the results but you will need to first click all the tabs in the results to essentially have the results rhandsontables active and then hit the downloadButton which you can also change to a downloadLink().
library(shiny)
library(rhandsontable)
library(writexl)
ui <- navbarPage("App",
tabPanel("Input",
numericInput('num_of_table', "Number of sub tabs: ", value = 1, min = 1, max = 10),
uiOutput("input")
),
tabPanel("Results",
downloadButton("dwnld", "Download Results"),
uiOutput("results"))
)
server <- function(input, output,session) {
### Input ###
input_table <- reactive({
list_of_input_table = list()
for (i in c(1:input$num_of_table)){
mat <- matrix(c(1:25) * i, ncol = 5, nrow = 5)
list_of_input_table[[i]] = as.data.frame(mat)
}
index = c(1:i)
list_of_input_table[index]
})
observeEvent(input$num_of_table, {
lapply(seq_len(input$num_of_table), function(i) {
output[[paste0('input_table_', i)]] <- renderRHandsontable({
rhandsontable(input_table()[[i]])
})
})
})
output$input <- renderUI({
nTabs = input$num_of_table
myTabs1 = lapply(seq_len(nTabs), function(x){
tabPanel(paste("Tab", x),
column(12,
rHandsontableOutput(paste0("input_table_", x))))
})
do.call(tabsetPanel, myTabs1)
})
### Results ###
results_table <- reactive({
list_of_results_table = list()
for (i in c(1:input$num_of_table)){
req(input[[paste0("input_table_", i)]])
list_of_results_table[[i]] <- hot_to_r(input[[paste0("input_table_", i)]])[2:5]/hot_to_r(input[[paste0("input_table_", i)]])[1:4]
}
return(list_of_results_table)
})
observeEvent(input$num_of_table, {
lapply(seq_len(input$num_of_table), function(i) {
output[[paste0('results_table_', i)]] <- renderRHandsontable({
rhandsontable(results_table()[[i]])
})
})
})
output$results <- renderUI({
nTabs = input$num_of_table
myTabs2 = lapply(seq_len(nTabs), function(x){
tabPanel(paste("Tab", x),
column(12,
rHandsontableOutput(paste0("results_table_", x))))
})
do.call(tabsetPanel, myTabs2)
})
output$dwnld <- downloadHandler(
filename = function(){ paste0("results.xlsx")},
content = function(file){
resultslist <- lapply(1:input$num_of_table, function(x) hot_to_r(input[[paste0("results_table_",x)]]))
write_xlsx(resultslist, path = file)
}
)
}
shinyApp(ui,server)
I am trying to build a dynamic Shiny app that insert sliders in a bs_accordion_sidebar.
The "add" button is working well but I can't figure out what I should add in my "delete" button code to update the barplot ?
Also, when clicking on the panel title, I think it should collapse and change his color but nothing happen ?
Thanks for any help !
library(shiny)
library(bsplus)
# global button counter
cpt <- 0
# function to create a new slider input
newinput <- function(ID, tag){
div(id=ID,
bs_append(
tag = tag,
title_side = ID,
content_side = NULL,
content_main = sliderInput( inputId = paste0("slider_",ID),
label = paste0("slider_",ID),
value = 0,
min=0,
max=10)
)
)
}
# UI
ui <- shinyUI(fluidPage(
titlePanel("bs_append and insertUI"),
sidebarPanel(
fluidRow(
actionButton("add", "+"),
mytag <- bs_accordion_sidebar(id = "accordion",
spec_side = c(width = 4, offset = 0),
spec_main = c(width = 8, offset = 0)),
div(id = "placeholder"),
actionButton("delete", "-")
)
),
mainPanel(
plotOutput('show_inputs')
),
use_bs_accordion_sidebar()
))
# SERVER
server <- shinyServer(function(input, output) {
# reactive function to collect all input values
AllInputs <- reactive({
myvalues <- sapply(names(input)[!names(input) %in% c("add", "delete")], function(x) input[[x]])
print(myvalues)
return(myvalues)
})
# simple output barplot
output$show_inputs <- renderPlot({
barplot(AllInputs())
})
# take a dependency on 'add' button
observeEvent(input$add, {
cpt <<- cpt + 1
insertUI(
selector ='#placeholder',
where = "beforeEnd",
ui = newinput(ID = cpt,
tag = mytag)
)
})
# take a dependency on 'delete' button
observeEvent(input$delete, {
removeUI(selector = paste0('#', cpt))
cpt <<- cpt - 1
})
})
shinyApp(ui, server)
I have found the answer here : https://stackoverflow.com/a/51517902/12812645
it was necessary to nullify the input deleted by removeUI
here is the corrected code using shinyjs :
library(shiny)
library(bsplus)
library(shinyjs)
# global button counter
cpt <- 0
# function to create a new slider input
newinput <- function(ID, tag){
div(id=ID,
bs_append(
tag = tag,
title_side = ID,
content_side = NULL,
content_main = sliderInput( inputId = paste0("slider_",ID),
label = paste0("slider_",ID),
value = 0,
min=0,
max=10)
)
)
}
# UI
ui <- shinyUI(fluidPage(
titlePanel("bs_append and insertUI"),
sidebarPanel(
fluidRow(
actionButton("add", "+"),
mytag <- bs_accordion_sidebar(id = "accordion",
spec_side = c(width = 4, offset = 0),
spec_main = c(width = 8, offset = 0)),
div(id = "placeholder"),
actionButton("delete", "-")
)
),
mainPanel(
plotOutput('show_inputs')
),
useShinyjs(debug = TRUE),
use_bs_accordion_sidebar()
))
# SERVER
server <- shinyServer(function(input, output) {
# reactive function to collect all input values
AllInputs <- reactive({
myvalues <- sapply(names(input)[!names(input) %in% c("add", "delete")], function(x) input[[x]])
myvalues <- unlist(myvalues[!unlist(lapply(myvalues, is.null))])
print(myvalues)
return(myvalues)
})
# simple output barplot
output$show_inputs <- renderPlot({
barplot(AllInputs())
})
# take a dependency on 'add' button
observeEvent(input$add, {
cpt <<- cpt + 1
insertUI(
selector ='#placeholder',
where = "beforeEnd",
ui = newinput(ID = cpt,
tag = mytag)
)
})
# take a dependency on 'delete' button
observeEvent(input$delete, {
removeUI(selector = paste0('#', cpt))
runjs(paste0('Shiny.onInputChange("slider_',cpt,'", null)'))
cpt <<- cpt - 1
})
})
shinyApp(ui, server)
I'm testing modulization for an shiny app. One problem in the following code is that, when select a new name under "name to analyze", updated result does not hold. The selection will automatically return to 'name1' within seconds. Much appreciated for any advice to correct it.
Thanks.
library(shiny)
subgroupInput <- function(id){
ns <-NS(id)
tagList(
selectInput(ns("name"),
label = "name to analyze",
choices = NULL,selected=NULL),
radioButtons(ns('radio'), 'cutoffType', choices=c('percentile', 'value'),
selected = NULL, inline = FALSE),
conditionalPanel(
condition = paste0("input['", ns("radio"), "'] == 'percentile'"),
sliderInput(ns("cutoff1"),
label = "Bottom-trim percentile:",
min = 0, max = 100, value = 5),
sliderInput(ns("cutoff2"),
label = "Top-trim percentile:",
min = 0, max = 100, value = 95)
),
conditionalPanel(
condition = paste0("input['", ns("radio"), "'] == 'value'"),
sliderInput(ns("cutoff3"),
label = "Bottom-trim value:",
min = 0, max = 100, value = -1),
sliderInput(ns("cutoff4"),
label = "Top-trim value:",
min = 0, max = 100, value = 1)
)
)
}
subgroup <- function(input, output, session,default_selected=NULL){
ns=session$ns
model <- reactive({
data = data.frame(matrix(rep(rnorm(100*100,sd=3)),ncol=100),stringsAsFactors = F)
colnames(data)=paste0('name',1:100)
namelist = colnames(data)
updateSelectInput(session, "name",choices = namelist, selected = default_selected)
validate(
shiny::need(input$name,"Select name")
)
x = round(data[,input$name])
updateSliderInput(session, "cutoff3", label="Cufoff value", min=min(x),max=max(x))
updateSliderInput(session, "cutoff4", label="Cufoff value", min=min(x),max=max(x))
if(input$radio=="percentile") {
dt = data[,input$name]
qt = quantile(dt,c(input$cutoff1,input$cutoff2)/100)
result <- hist(dt[dt>qt[1] & dt<=qt[2]],main=paste0("Histogram of ",input$name))
}
else if(input$radio=="value"){
dt = data[,input$name]
result <- hist(dt[dt>input$cutoff3 & dt<=input$cutoff4],main=paste0("Histogram of ",input$name))
}
return(list(plot = result, data = data, inname=input$name))
})
return (model)
}
The above are modules. Following code makes call:
shinyApp(
ui = fluidPage(
subgroupInput("test1"),
plotOutput("plot")
),
server = function(input, output, session){
test <- shiny::callModule(subgroup,"test1")
output$plot <- renderPlot({
test()$plot
})
}
)
I would like to know why (in the following code) the graph does not display when I click on the checkbox "graph"? Below is an example of the code. I would also want to know if it is possible to do the same thing using a conditionalPanel instead of renderUI?
library(shinydashboard)
library(shiny)
library(plotly)
library(ggplot2)
# Can set box height from environment var
useboxheight <- Sys.getenv("USE_BOX_HEIGHT")
if (tolower(useboxheight) == "true") {
row1height <- 300
row2height <- 240
row3height <- 110
} else {
row1height <- row2height <- row3height <- NULL
}
body <- dashboardBody(
fluidRow(
box(
title = "Box title",
status = "primary",
plotOutput("plot1", height = 240),
height = row1height
),
uiOutput("ui")
),
# Boxes with solid headers
fluidRow(
box(
title = "Title 1", width = 4, solidHeader = TRUE, status = "primary",
height = row2height,
sliderInput("orders", "Orders", min = 1, max = 500, value = 120),
radioButtons("fill", "Fill", inline = TRUE,
c(None = "none", Blue = "blue", Black = "black", red = "red")
)
),
box(
title = "Title 2",
width = 4, solidHeader = TRUE,
height = row2height
),
box(
title = "Title 3",
width = 4, solidHeader = TRUE, status = "warning",
height = row2height,
selectInput("spread", "Spread",
choices = c("0%" = 0, "20%" = 20, "40%" = 40, "60%" = 60, "80%" = 80, "100%" = 100),
selected = "60"
)
)
),
# Solid backgrounds
fluidRow(
box(
width = 4,
height = row3height,
background = "black",
"A box with a solid black background"
),
box(
title = "Title 5",
width = 4,
height = row3height,
background = "light-blue",
"A box with a solid light-blue background"
),
box(
title = "Title 6",
width = 4,
height = row3height,
background = "maroon",
"A box with a solid maroon background"
)
)
)
ui <- dashboardPage(
dashboardHeader(title = "Row layout"),
dashboardSidebar(checkboxGroupInput(inputId="Graph", label = h4("Graph print"),
choices = list("graph" = "graph"),selected = NULL)),
body
)
server <- function(input, output) {
set.seed(122)
histdata <- rnorm(500)
output$plot1 <- renderPlot({
if (is.null(input$orders) || is.null(input$fill))
return()
data <- histdata[seq(1, input$orders)]
color <- input$fill
if (color == "none")
color <- NULL
hist(data, col = color)
})
output$ui <- renderUI({
check1 <- input$Graph == "graph"
if(length(check1)==0){check1 <- F}
if(check1){
box(
status = "warning",
plotOutput("plot1", height = 240),
height = row1height
)
}
else{return(NULL)}
})
}
shinyApp(ui, server)
Cheers
Dave
I would start my taking a look at what happens underneath the output$plot1 <- renderPlot({ bracket. Be sure that your conditional function is sound.
Same goes for your renderUI code.
So I am trying to draw a few ggplots and their legend using gridExtra. The legend appears in the last cell on a white background - I would like to change the background color there, so that white background disappears. How can I do that?
Here's my code:
library(reshape)
library(ggplot2)
library(plyr)
library(wq)
library(gridExtra)
library(lattice)
library(grid)
testVisualization <- function()
{
set.seed(123)
xx <- sample(seq(from = 20, to = 50, by = 5), size = 50, replace = TRUE)
yy <- sample(seq(from = 1, to = 50), size = 50, replace = TRUE)
zz <- sample(seq(from = 1, to = 10, by = 1), size = 50, replace = TRUE)
dd <- data.frame(xx,yy,zz)
colRainbow <- rainbow(n, s = 1, v = 1, start = 0, end = max(1, n - 1)/n, alpha = 1)
gg <- ggplot() + geom_point(data=dd, aes(x=xx, y=yy, colour=zz))+
theme_custom()
lay2 <- rbind(c(1,1,1,1,1),
c(2,2,3,3,4))
legg1 <- g_legend(gg)
grid.arrange(
gg+guides(fill=FALSE, colour=FALSE, size=FALSE),
gg+guides(fill=FALSE, colour=FALSE, size=FALSE),
gg+guides(fill=FALSE, colour=FALSE, size=FALSE),
legg1,
layout_matrix=lay2)
}
theme_custom <- function()
{
theme(
plot.background = element_rect(fill = "#002B36", colour = "#002B36"),
panel.background = element_rect(fill = "#002B36"),
panel.background = element_rect(fill = "#002B36"),
legend.background = element_rect(fill="#002B36", colour = "#002B36"),
legend.margin = unit(c(-4, -4), "cm"),
legend.key = element_rect(fill="#002B36", colour ="#002B36"),
legend.text =element_text(colour = "#DCD427"),
legend.title=element_text(colour = "#DCD427")
)
}
g_legend<-function(a.gplot){
tmp <- ggplot_gtable(ggplot_build(a.gplot))
leg <- which(sapply(tmp$grobs, function(x) x$name) == "guide-box")
legend <- tmp$grobs[[leg]]
#+ legend.margin = unit(-0.5, "cm")
legend
}
Try this,
g_legend<-function(gg){
tmp <- ggplot_gtable(ggplot_build(gg))
id <- which(sapply(tmp$grobs, function(x) x$name) == "guide-box")
leg <- tmp$grobs[[id]]
bkg <- leg[["grobs"]][[1]][["grobs"]][leg[["grobs"]][[1]][["layout"]][,"name"]=="background"][[1]][["gp"]][["fill"]]
leg <- gtable_add_grob(leg, grobs = rectGrob(gp=gpar(fill=bkg, col="red", lty=2)),
t=1, l=1, b=nrow(leg), r=ncol(leg), z=-1)
# no idea why, but the legend seems to have weird negative sizes
# that make the background overlap with neighbouring elements
# workaround: set those unidentified sizes to 1null
leg$widths[c(1,2,4,5)] <- unit(rep(1,4),"null")
leg$heights[c(1,2,4,5)] <- unit(rep(1,4),"null")
leg
}