shinyCAPTCHA does not trigger the validation properly - shiny

I would like to integrate captcha verification into my shiny app (like this). But it has an unexpected behavior.
If this line:
recaptchaUI("test", sitekey = "6LeIxAcTAAAAAJcZVRqyHh71UMIEGNQ_MXjiZKhI")
is inside the UI, my app works fine (I mean, the validation is triggered when the checkbox and the button are clicked)
However, if it is inside renderUI, the validation is triggered only by clicking the checkbox (there is no need to click the button)
Here is my minimal working example:
library(shiny)
library(shinyCAPTCHA)
ui <- fluidPage(
# With this line, the captcha works perfectly
recaptchaUI("test", sitekey = "6LeIxAcTAAAAAJcZVRqyHh71UMIEGNQ_MXjiZKhI"),
uiOutput("body")
)
server <- function(input, output, session) {
result <- callModule(recaptcha, "test", secret = "6LeIxAcTAAAAAGG-vFI1TnRWxMZNFuojJ4WifJWe")
output$body <- renderUI({
fluidPage(
# Inside renderUI, it does not work properly.
#recaptchaUI("test", sitekey = "6LeIxAcTAAAAAJcZVRqyHh71UMIEGNQ_MXjiZKhI"),
uiOutput("humansOnly")
)
})
output$humansOnly <- renderUI({
req(result()$success)
tags$h1("For human eyes only!")
})
}
shinyApp(ui, server)
I have an app with several modules, that's why I need to use renderUI. What is the error in my code?
I appreciate any help!

Related

Let parent server of module know that something happened inside the module

I am building an app that presents a data table and which allows you to add data. The adding of data is build by means of a form. This form is written by a module. What I want to happen is that one may fill out the form, press an 'add' button and that the data inside the table is updated.
As an example, could you help me figure out how to complete the following piece of code:
library(shiny)
library(shinydashboard)
moduleInput <- function(id){
ns <- NS(id)
sidebarPanel(
actionButton(ns("action1"), label = "click")
)
}
module <- function(input, output, session){
observeEvent(input$action1, {
# Do stuff here,
# -> let the parent module or server know that something has happened
})
}
ui <- fluidPage(
verbatimTextOutput("module.pressed"),
moduleInput("first")
)
server <- function(input, output, session){
# print the currently open tab
output$module.pressed <- renderPrint({
#-> Write that we have pressed the button of the module
})
callModule(module,"first")
}
shinyApp(ui = ui, server = server)
All I thus want to do is find an easy way to present TRUE in the output field module.pressed when something happend inside the module.
Thanks!
Modules can pass reactive expression(s) to calling apps/modules by returning them in their server function. The documentation provides a few examples on how to set up interactions between modules and calling apps - https://shiny.rstudio.com/articles/modules.html
If a module needs to use a reactive expression, take the reactive expression as a function parameter. If a module wants to return reactive expressions to the calling app, then return a list of reactive expressions from the function.
library(shiny)
moduleInput <- function(id){
ns <- NS(id)
sidebarPanel(
actionButton(ns("action1"), label = "click")
)
}
module <- function(input, output, session){
action1 <- reactive(input$action1)
return(reactive(input$action1))
}
ui <- fluidPage(
verbatimTextOutput("module.pressed"),
moduleInput("first")
)
server <- function(input, output, session){
action1 <- callModule(module,"first")
output$module.pressed <- renderPrint({
print(action1())
})
}
shinyApp(ui = ui, server = server)

bsCollapsePanel within renderUI

I am using bsCollapse panels (from the shinyBS library) heavily in an app that I am working on. I'd like to be able to define a panel on the server-side as shown in the code. The code does not run and returns an error ERROR: argument is of length zero. The problem seems to be that bsCollapse won't accept a renderUI argument and requires bsCollapsePanel call to be in ui.R.
I've tried having bsCollapse() on the server-side, which works but is clunky as the individual panels then don't expand/collapse in the same way. I've also tried including outputOptions(output, "hipanel", suspendWhenHidden = FALSE), the idea being that my "hipanel" would be evaluated earlier, but this didn't work.
I think the key is that renderUI/uiOutput isn't returning the an object that's accepted by bsCollapsePanel (at least not at the right time), but I'm not sure what to do about it.
server.R
shinyServer(function(input, output){
output$hipanel<-renderUI({
bsCollapsePanel("hello",helpText("It's working!"))
})
})
ui.R
shinyUI(fluidPage(
mainPanel(
bsCollapse(
bsCollapsePanel("This panel works",helpText("OK")),
uiOutput("hipanel")
))))
It seems that bsCollapse needs a bsCollapsePanel so just add this in and then you can rnder whatever you want into the content:
library(shiny)
library(shinyBS)
ui <- shinyUI(fluidPage(
mainPanel(
bsCollapse(
bsCollapsePanel("This panel works",helpText("OK")),
bsCollapsePanel("hello",uiOutput("hipanel"))
)
)))
server <- shinyServer(function(input, output,session){
output$hipanel<- renderUI({
helpText("It's working!")
})
})
shinyApp(ui,server)
You can always dynamically create the whole thing
library(shiny)
library(shinyBS)
ui <- shinyUI(fluidPage(
mainPanel(
uiOutput("hipanel")
)))
server <- shinyServer(function(input, output,session){
output$hipanel<- renderUI({
bsCollapse(
bsCollapsePanel("This panel works",helpText("OK")),
bsCollapsePanel("hello",helpText("It's working!"))
)
})
})
shinyApp(ui,server)

shiny app only works on specific browsers / platforms

I have programmed a shiny app in RStudio using R version 3.2.4. The app can be found here: https://koenvandenberge.shinyapps.io/tempConditioning/
Note that there is quite a lot of data to be loaded so it takes a couple of seconds to load.
I have deployed it on my Macbook and it seems as if it only works on Safari and Chromium browsers. It does not seem to work on Chrome or Firefox browsers. With this I mean that the plots which should be generated are not. The drop-down menu is present as it should be, so the app does not crash, but the plots that should be generated by selecting something from the drop-down menu do not.
Is there any way to fix this? You can find the code of my app below:
library(shiny)
library(scales)
load("countMatrix.RData")
countMatrixAllSub = as.data.frame(countMatrix$counts[,-1]) ; rm(countMatrix)
sampleNames = unlist(lapply(strsplit(colnames(countMatrixAllSub),split=".",fixed=TRUE), function(x) x[4]))
sampleNames[28] <- "3c0a"
treat=substr(sampleNames,2,2)
time=substr(sampleNames,3,nchar(sampleNames)-1)
timeC=as.numeric(time)
timeC[timeC==15]=0.25
ui <- shinyUI(fluidPage(
# Application title
titlePanel("Gene expression: conditioning experiment Gust"),
# Sidebar with a
sidebarLayout(
sidebarPanel(
selectInput("gene",
"Pick a gene",
choices = rownames(countMatrixAllSub))
),
# Show a plot of the generated distribution
mainPanel(
plotOutput("genePlot")
)
)
))
# Define server logic required to draw an expression plot
server <- shinyServer(function(input, output) {
output$genePlot <- renderPlot({
par(mar = c(5.1, 4.1, 3, 1))
plot(y=countMatrixAllSub[input$gene,],x=timeC, col=c("black","red")[as.numeric(factor(treat))], pch=19,cex=.6,xaxt="n",xlab="Time", ylab="Expression")
lines(x=unique(timeC[!timeC==0]),y=colMeans(sapply(unique(timeC[!timeC==0]), function(t) as.matrix(countMatrixAllSub[input$gene,treat=="c" & timeC==t]))), col=1)
lines(x=unique(timeC[!timeC==0]),y=colMeans(sapply(unique(timeC[!timeC==0]), function(t) as.matrix(countMatrixAllSub[input$gene,treat=="t" & timeC==t]))), col=2)
axis(1,at=c(0,0.25,1,3,6,9),labels=c("","15m","1h","3h","6h","9h"))
abline(v=c(0,0.25,1,3,6,9),col=alpha("grey",.6))
mtext("Conditioned",side=3, adj=0,col="red")
mtext("Unconditioned",side=3, adj=0.2, col="black")
})
})
# Run the application
shinyApp(ui = ui, server = server)

Disable browsers back button in R shiny App

I am building a shiny app which has a lot of conditional panel. I have a back button in the app itself to navigate between the conditional panel. I would like to disable the web browsers back button as clicking that button goes to previous webpage(away from my app). Is there a way to do this?
You can write some javascript to do this. Here I have two examples, note that I only tested this on Chrome
Example 1 will return a message upon activation of the back button within the browser
rm(list = ls())
library(shiny)
jscode <- 'window.onbeforeunload = function() { return "Please use the button on the webpage"; };'
ui <- basicPage(
mainPanel(tags$head(tags$script(jscode)))
)
server <- function(input, output,session) {}
runApp(list(ui = ui, server = server))
Example 2 will disable navigation altogether. Personally I don't like this method as people might be annoyed that your site doesn't offer standard navigation functionalities
rm(list = ls())
library(shiny)
jscode2 <- "history.pushState(null, null, document.title);
window.addEventListener('popstate', function () {
history.pushState(null, null, document.title);});"
ui <- basicPage(
mainPanel(tags$head(tags$script(jscode2)))
)
server <- function(input, output,session) {}
runApp(list(ui = ui, server = server))

How to programmatically collapse a box in shiny dashboard

I'm trying to collapse a box programmatically when an input changes. It seems that I only need to add the class "collapsed-box" to the box, I tried to use the shinyjs function addClass, but I don't know how to do that becuase a box doesn't have an id. Here as simple basic code that can be used to test possible solutions:
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
box(collapsible = TRUE,p("Test")),
actionButton("bt1", "Collapse")
)
)
server <- function(input, output) {
observeEvent(input$bt1, {
# collapse the box
})
}
shinyApp(ui, server)
I've never tried using boxes before so keep in mind that my answer might be very narrow minded. But I took a quick look and it looks like simply setting the "collapsed-box" class on the box does not actually make the box collapse. So instead my next thought was to actually click the collapse button programatically.
As you said, there isn't an identifier associated with the box, so my solution was to add an id argument to box. I initially expected that to be the id of the box, but instead it looks like that id is given to an element inside the box. No problem - it just means that in order to select the collapse button, we need to take the id, look up the DOM tree to find the box element, and then look back down the DOM tree to find the button.
I hope everything I said makes sense. Even if it doesn't, this code should still work and will hopefully make things a little more clear :)
library(shiny)
library(shinydashboard)
library(shinyjs)
jscode <- "
shinyjs.collapse = function(boxid) {
$('#' + boxid).closest('.box').find('[data-widget=collapse]').click();
}
"
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
useShinyjs(),
extendShinyjs(text = jscode, functions = "collapse"),
actionButton("bt1", "Collapse box1"),
actionButton("bt2", "Collapse box2"),
br(), br(),
box(id = "box1", collapsible = TRUE, p("Box 1")),
box(id = "box2", collapsible = TRUE, p("Box 2"))
)
)
server <- function(input, output) {
observeEvent(input$bt1, {
js$collapse("box1")
})
observeEvent(input$bt2, {
js$collapse("box2")
})
}
shinyApp(ui, server)