conditional plot shinydashboard - conditional-statements

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.

Related

How to move the image as transparent after erasing background to other screen?

I'm developing a photo editing app, in that I have a feature to add the image to other image as transparent after editing in the app. So I can able to erase the background of the image. But I don't know how to move the background erased image to other screen , like how we do for the normal image. Now if I move the transparent part appeared as grey part. you can see that image. Help me to solve this. Thank you.
[
Canvas(
modifier = drawModifier
.onGloballyPositioned {
capturingViewBounds.value = it.boundsInWindow()
}
) {
val canvasWidth = size.width.roundToInt()
val canvasHeight = size.height.roundToInt()
val width = this.size.width
val height = this.size.height
val checkerWidth = 10.dp.toPx()
val checkerHeight = 10.dp.toPx()
val horizontalSteps = (width / checkerWidth).toInt()
val verticalSteps = (height / checkerHeight).toInt()
for (y in 0..verticalSteps) {
for (x in 0..horizontalSteps) {
val isGrayTile = ((x + y) % 2 == 1)
drawRect(
color = if (isGrayTile) Color.LightGray else Color.White,
topLeft = Offset(x * checkerWidth, y * checkerHeight),
size = Size(checkerWidth, checkerHeight)
)
}
}
val space = 20.dp.roundToPx()
with(drawContext.canvas.nativeCanvas) {
val checkPoint = saveLayer(null, null)
drawImage(
image = dstBitmap,
dstOffset = IntOffset(space / 2, space / 2),
dstSize = IntSize(canvasWidth - space, canvasHeight - space)
)
clipBounds
drawPath(
color = Color.Transparent,
path = erasePath,
style = Stroke(
width = 30f,
cap = StrokeCap.Round,
join = StrokeJoin.Round
),
blendMode = BlendMode.Clear
)
restoreToCount(checkPoint)
}
}

Shiny app with dynamic bs_accordion_sidebar() using insertUI

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)

How can I build a table result with "eventReactive" in shiny

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)

updateSelectInput does not hold in shiny module

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
})
}
)

Background Color of grid.arrange in gridExtra

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
}