I'm trying to make my Shiny app to redirect the user to another page. I'm using httr to send GET requests and see if the user is logged in. If he's not, I want to redirect him to another link.
Can I do that using R / Shiny only, or do I need some extra libraries?
sample:
library(httr)
library(shiny)
shinyServer(function(input, output) {
rv <- reactiveValues()
rv$mytoken = session$request$token
observeEvent(input$button1, {
rv$a <- GET("my.url:3405/authtoken",
add_headers(
.headers = c("token" = rv$mytoken)
))
if (rv$a$status_code == 200) {
} else {
# redirect magic
}
})
}
shinyUI(fluidPage(
actionButton(button1, "btn")
))
Here this will navigate you to google if not true
library(shiny)
jscode <- "Shiny.addCustomMessageHandler('mymessage', function(message) {window.location = 'http://www.google.com';});"
ui <- fluidPage(
tags$head(tags$script(jscode)),
checkboxInput("Redirect","Redirect",value = T)
)
server <- function(input, output, session) {
observeEvent(input$Redirect,{
if(!input$Redirect){
session$sendCustomMessage("mymessage", "mymessage")
}
})
}
shinyApp(ui,server)
Just to update. There is also an easier way...
shinyjs::runjs(paste0('window.location.href = "...";'))
Don't forget useShinyjs() in UI.
Related
I have an app where I need to monitor a file for changes. However I am struggling to do this.
Consider the following example:
library(shiny)
A function that returns the modified date of a file:
file_info <- function(){
if(file.exists("example.txt")){
return(as.character(as.Date(file.info("example.txt")[1,4])))
} else {
return("File not present")
}
}
Shiny part:
ui <- shinyUI(fluidPage(
textOutput("file_status"),
actionButton("create_file", "Create file"),
actionButton("delete_file", "Delete file")
))
server <- shinyServer(function(input, output, session) {
file_st <- reactive(file_info()) #what is the correct approach here?
output$file_status <- renderText({
file_st()
})
observeEvent(input$create_file,{
file.create("example.txt")
})
observeEvent(input$delete_file, {
unlink("example.txt")
})
})
I would like the file_status text field to update each time the example.txt file changes - if possible even if this happens outside of the app.
I have tried various combinations of reactive, observe and reactiveValues without finding the adequate combo.
Thank you
I was able to solve this using reactivePoll which is practically tailored for this type of task
server <- shinyServer(function(input, output, session) {
file_st <- reactivePoll(500, session,
checkFunc = function() {
if (file.exists("example.txt"))
file.info("example.txt")$mtime[1]
else
""},
valueFunc = function(){
if(file.exists("example.txt")){
return(as.character(as.Date(file.info("example.txt")[1,4])))
} else {
return("File not present")
}
}
)
output$file_status <- renderText({
file_st()
})
observeEvent(input$create_file,{
file.create("example.txt")
})
observeEvent(input$delete_file, {
unlink("example.txt")
})
})
ui <- shinyUI(fluidPage(
textOutput("file_status"),
actionButton("create_file", "Create file"),
actionButton("delete_file", "Delete file")
))
I have this app:
library(shiny)
ui <- fluidPage(
textInput("query_text","Type something:"),
actionButton(inputId='query_button',
label="Search",
icon = icon("th"),
onclick = paste("location.href='http://www.example.com?lookfor=",
input$query_text, "'", sep=""))
)
server <- function(input, output, session) {
}
shinyApp(ui, server)
I'd like to update the url with the action button, so when the user types something (for example: paper), it updates the url like this:
http://www.example.com/?lookfor=paper
Any ideias how to do it? Maybe wrapping it on a observeEvent?
Based on your replies to my comment, what you're looking for is the updateQueryString function.
library(shiny)
ui <- fluidPage(
textInput("query_text", "Type something:"),
actionButton(inputId = 'query_button', label = "Search")
)
server <- function(input, output, session) {
observeEvent(input$query_button, {
updateQueryString(paste0("?lookfor=", input$query_text))
})
}
shinyApp(ui, server)
Hi I am trying to build a login page that contacts an API service and validates user credentials. If the credentials are correct then a new user interface appears and simply makes a plot. If it is not correct a message at the login screen should say "incorrect login". Currently, when I try to type in either of the fields at the login page (ui1.r) the field refreshes/wipes itself after a second or so, thus preventing me from passing on user input to the API. I have the following files
server.r:
rm(list = ls())
library(shiny)
library(dplyr)
library(shinyjs)
umls <- dbConnect(drv=RSQLite::SQLite(),
dbname="/media/sf_umls-2018AA-full/2018AA-full/2018AA/META/umls_browser.sqlite3")
licenseCode <- "mylicense"
shinyServer(function(input, output) {
source('ui1.R') #login page
output$page <- renderUI({ ui1 })
observe({
z<-system(paste("perl", "/media/sf_umls-2018AA-full/2018AA-full/2018AA/META/umls_auth.pl",
input$user, input$password),intern=TRUE)
if (grepl("false",z[22])) {
renderText("incorrect login")
}
if (grepl("true",z[22]))
{
output$page <- renderUI({ ui2 })
output$table <- renderTable({mtcars()})
}
})
})
ui1.r
ui1 <- shinyUI(fluidPage(
# Application title
titlePanel("UMLS Constraint Browser"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
textInput("user", "User",""),
textInput("password", "Password",""),
actionButton("login", "Login")
),
mainPanel(
tableOutput("table")
)
)
))
What appears to be the problem?
I think the problem comes from the observe function. Each time you write a letter, it sends a request to your credential database. You should try to use
ObserveEvent instead :
shinyServer(function(input, output) {
observeEvent(input$login, {
z<-system(paste("perl", "/media/sf_umls-2018AA-full/2018AA-full/2018AA/META/umls_auth.pl",
input$user, input$password),intern=TRUE)
if (grepl("false",z[22])) {
renderText("incorrect login")
}
if (grepl("true",z[22]))
{
output$page <- renderUI({ ui2 })
output$table <- renderTable({mtcars()})
} })
})
Here, a request is made only when the user clicks on the login button. Tell me if it works for you.
Good morning. I want to check if file is choose or not in fileInput so I had to create reactive function but this not working.
ui.R
fileInput("file_input","Choose your file in csv")
mainPanel("main panel",textOutput("choose"))
server.R
library(shiny)
isFileChoose<-function(){reactive({
if(is.null(input$file_input))
return (FALSE)
else
return (TRUE)
}) }
server <- function(input, output) {
if(isFileChoose()==FALSE)
{
output$choose<-renderText("Not selected file")
}
}
I do not think you can just use a reactive in a function like that, see here. You could do this:
library(shiny)
ui <- fluidPage(
fileInput("file_input","Choose your file in csv"),
textOutput("choose")
)
server <- function(input, output) {
output$choose <- reactive({
if(is.null(input$file_input))
{
"No input given yet."
}
else
{
"Now we can process the data!"
}
})
}
shinyApp(ui = ui, server = server)
Hope this helps!
I don't understand R's message vs cat vs print vs etc. too deeply, but I'm wondering if it's possible to capture messages and show them in a shiny app?
Example: the following app can capture cat statements (and print statements as well) but not message statements
runApp(shinyApp(
ui = fluidPage(
textOutput("test")
),
server = function(input,output, session) {
output$test <- renderPrint({
cat("test cat")
message("test message")
})
}
))
Cross post from the shiny-discuss Google group since I got 0 answers.
Yihui suggested I use withCallingHandlers, and that indeed let me to a solution. I wasn't quite sure how to use that function in a way that would do exactly what I needed because my problem was that I had a function that printed out several messages one at a time and using a naive approach only printed the last message. Here is the my first attempt (which works if you only have one message to show):
foo <- function() {
message("one")
message("two")
}
runApp(shinyApp(
ui = fluidPage(
actionButton("btn","Click me"),
textOutput("text")
),
server = function(input,output, session) {
observeEvent(input$btn, {
withCallingHandlers(
foo(),
message = function(m) output$text <- renderPrint(m$message)
)
})
}
))
Notice how only two\n gets outputted. So my final solution was to use the html function from shinyjs package (disclaimer: I wrote that package), which lets me change or append to the HTML inside an element. It worked perfectly - now both messages got printed out in real-time.
foo <- function() {
message("one")
Sys.sleep(0.5)
message("two")
}
runApp(shinyApp(
ui = fluidPage(
shinyjs::useShinyjs(),
actionButton("btn","Click me"),
textOutput("text")
),
server = function(input,output, session) {
observeEvent(input$btn, {
withCallingHandlers({
shinyjs::html("text", "")
foo()
},
message = function(m) {
shinyjs::html(id = "text", html = m$message, add = TRUE)
})
})
}
))
I know this isn't nearly as elegant, but I worked around a bit similar problem using capture.output; sadly sink doesn't allow simultaneous capture of messages and output though. You don't get them in the original order, but you can extract both streams at least (here turned to HTML):
runApp(shinyApp(
ui = fluidPage(
uiOutput("test")
),
server = function(input,output, session) {
output$test <- renderUI({
HTML(
paste(capture.output(type = "message", expr = {
message(capture.output(type = "output", expr = {
cat("test cat<br>")
message("test message")
cat("test cat2<br>")
message("test message2")
}))
}), collapse="<br>")
)})
})
)
Output:
test message
test message2
test cat
test cat2
Perhaps in the case if user wants to capture both but also separate them, this will provide a handy work-around. (Your shinyjs package seems neat, need to take a look at it!)
This can now be done with the high-level function shinyCatch from the spsComps package.
Basic usage
library(shiny)
library(spsComps)
ui <- fluidPage(
actionButton("msg", "msg"),
actionButton("warn", "warn"),
actionButton("err", "err"),
)
server <- function(input, output, session) {
observeEvent(input$msg, {
shinyCatch({message("a message")}, prefix = '')
})
observeEvent(input$warn, {
shinyCatch({warning("a warning")}, prefix = '')
})
observeEvent(input$err, {
shinyCatch({stop("an error")}, prefix = '')
})
}
shinyApp(ui, server)
Choose blocking level
If exceptions happened, we can choose to continue the code or block downstream code in the reactive context. For example, we want to stop downstream code if an error/warning/message happens:
library(shiny)
library(spsComps)
ui <- fluidPage(
actionButton("err", "code not blocked after error"),
actionButton("err_block", "code blocked after error"),
)
server <- function(input, output, session) {
observeEvent(input$err, {
shinyCatch({stop("an error")}, prefix = '')
print("error does not block ")
})
observeEvent(input$err_block, {
shinyCatch({stop("an error")}, prefix = '', blocking_level = "error")
print("you can't see me if error happens")
})
}
shinyApp(ui, server)
More advanced use
check website and demo
cat and print
There is still no good method to catch real-time info from cat and print. I will come back to update this answer if I found a fix for this.