Is this possible when a user input something on textInput to against a regular expression and give a warning.
Such that the textInput area expects: [1-5]GH[0-9]
But when the input is: 5UK8
The warning should be: Check your input
I think this can be done using JS inside UI, but is there any Shiny trick? Or if you can help with a java script.
ui <- fluidPage(
textInput("id", "Enter your ID",),
verbatimTextOutput("value")
)
server <- function(input, output) {
output$value <- renderText({ input$id })
}
shinyApp(ui, server)
Maybe with shinyFeedback ?
library(shiny)
library(shinyFeedback)
ui <- fluidPage(
useShinyFeedback(),
textInput("id", "Enter your ID",),
verbatimTextOutput("value")
)
server <- function(input, output) {
observeEvent(input$id, {
feedbackWarning(
"id",
condition = !grepl("[1-5]GH[0-9]", input$id)
)
})
output$value <- renderText({ input$id })
}
shinyApp(ui, server)
Related
I'm having issues using shinyjs::toggle.
I have a box displaying selected inputs which I want to show when the user has selected an input and hide when they haven't selected an input.
shinyUI <- function(id) {
checkBoxGroupInput(inputId = "foo", ......),
div(id=ns("selected_box"),
box(
width = 24,
title = "Selected Foo",
textOutput(ns('selected_foo'))))
}
From my understanding, this server code:
shinyjs::toggle(id='selected_box', isTruthy(input$foo)})
Should have an identical effect as this code:
if(isTruthy(input$foo)) {
shinyjs::show(id='selected_box', anim = TRUE)
}
else {
shinyjs::hide(id='selected_box', anim = TRUE)
}
})
However when I use shinyjs::toggle the selected_box div shows/hides every time the input$foo changes, instead of only when input$foo is empty.
You may want to try conditionalPanel instead
library(shiny)
ui <- fluidPage(
checkboxGroupInput('foo', "foo", c('a', 'b', 'c')),
conditionalPanel(
'typeof input.foo !== "undefined" && input.foo.length > 0',
textOutput('text')
)
)
server <- function(input, output, session) {
output$text <- renderText({"abc"})
}
shinyApp(ui, server)
Alternatively, if you want to use shinyjs, here is the working code
library(shiny)
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
checkboxGroupInput('foo', "foo", c('a', 'b', 'c')),
textOutput('text')
)
server <- function(input, output, session) {
observeEvent(input$foo, {
print(is.null(input$foo))
toggle(id='text', condition = !is.null(input$foo))
}, ignoreNULL = FALSE)
output$text <- renderText({"abc"})
}
shinyApp(ui, server)
The problem you have is you need to specify condition = xx argument, the second positional argument is anim not condition, can't be lazy here. Had this same mistake before xD.
I am building and app, that includes geolocation captures using the geoloc package
This is an example app:
library(shiny)
library(leaflet)
library(geoloc)
ui <- fluidPage(
h2("Where Am I?"),
tags$p("Click the button to get your location"),
geoloc::button_geoloc("myBtn", "Get my Location"),
tags$br(),
textOutput("coords"),
textOutput("col"),
leafletOutput("lf")
)
server <- function(input, output) {
output$coords <- renderText(paste(input$myBtn_lat, input$myBtn_lon, sep = ", "))
Lats <- reactiveValues(Lat = NULL)
observeEvent(input$myBtn_lat, {
Lats$Lat <- append(Lats$Lat, input$myBtn_lat)
})
output$col <- renderText({
Lats$Lat
})
output$lf <- renderLeaflet({
req(input$myBtn_lon)
req(input$myBtn_lat)
leaflet() %>%
addTiles() %>%
setView(as.numeric(input$myBtn_lon), as.numeric(input$myBtn_lat), zoom = 17) %>%
addMarkers(as.numeric(input$myBtn_lon), as.numeric(input$myBtn_lat), label = "You're here!")
})
}
shinyApp(ui, server)
I have two questions for this:
How to get a vector of latitudes and longitudes with the button
I need this because usually, we like to take 4 or 5 times the location and then use the median.
This has been addressed in this question, however, there are some kinks I can't figure out since the button is a custom one, and the inputs are not input$myBtn, but input$myBtn_lat and input$myBtn_lon, I find it hard to compute. This is what I am trying to do with the observe events
How to transform this into shiny modules
This will go to a larger shiny app, so I would love to generate modules for this, but again, the facto that the input in ui is "myBtn", but then in the server I have 2 inputs (MyBtn_lon and MyBtn_lat), make it very hard to figure out
Any help is welcome
How about the following code with Shiny modules? I tested and it worked.
library(shiny)
library(leaflet)
library(geoloc)
mapUI <- function(id, label = "Location in map"){
ns <- NS(id)
tagList(
geoloc::button_geoloc(ns("myBtn"), "Get my Location"),
tags$br(),
textOutput(ns("coords")),
textOutput(ns("col")),
textOutput(ns("md")), # for median latitude
leafletOutput(ns("lf"))
)
}
mapServer <- function(id){
moduleServer(
id,
function(input, output, session){
output$coords <- renderText(paste(input$myBtn_lat, input$myBtn_lon, sep = ", "))
Lats <- reactiveValues(Lat = NULL)
observeEvent(input$myBtn, {
Lats$Lat <- c(Lats$Lat, input$myBtn_lat)
})
output$col <- renderText({
Lats$Lat
})
# add median latitude
output$md <- renderText({
req(input$myBtn_lat)
if(length(Lats$Lat) %% 5 == 0){
paste0("Median latitute is: ", median(Lats$Lat))
}
})
output$lf <- renderLeaflet({
req(input$myBtn_lon)
req(input$myBtn_lat)
leaflet() %>%
addTiles() %>%
setView(as.numeric(input$myBtn_lon), as.numeric(input$myBtn_lat), zoom = 17) %>%
addMarkers(as.numeric(input$myBtn_lon), as.numeric(input$myBtn_lat), label = "You're here!")
})
}
)
}
ui <- fluidPage(
h2("Where Am I?"),
tags$p("Click the button to get your location"),
mapUI("map1")
)
server <- function(input, output, session) {
mapServer("map1")
}
shinyApp(ui, server)
You should click "myBtn", not "myBtn_lat". So try change observeEvent(input$myBtn_lat to observeEvent(input$myBtn.
In addition, what is the purpose to take 4 or 5 times the location? The coordinates do not change or change very little every time you click the button.
does anyone know how I can, inside a shiny application, get the cursor position inside a textAreaInput ?
library(shiny)
ui <- fluidPage(
textAreaInput("hop"
,label="textarea",value = "Supercalifragilisticexpialidocious"),
verbatimTextOutput("out")
)
server <- function(input, output, session) {
output$out <- renderText({
"here I would like to get the cursor position (an interger?) \n inside que textArea"
})
}
shinyApp(ui, server)
I think I have to use javascript, but I don't know where to start.
Regards
this is a solution I found :
library(shiny)
ui <- fluidPage(tags$head(tags$script(
'Shiny.addCustomMessageHandler("prout",
function(NULL) {
var ctl = document.getElementById("hop");
var startPos = ctl.selectionStart;
var endPos = ctl.selectionEnd;
alert(startPos + ", " + endPos);
});'
)),
textAreaInput("hop"
,label="textarea",value = "Supercalifragilisticexpialidocious"),
verbatimTextOutput("out"),
actionButton("hop","hop")
)
server <- function(input, output, session) {
output$out <- renderText({
"here I would like to get the cursor position (an interger?) \n inside que textArea"
})
observeEvent(input$hop,{
message("hop")
session$sendCustomMessage(type="prout",message=list(NULL))
})
}
shinyApp(ui, server)
I've been trying to add a row (basically a row of check boxes) on my data table, so that users will be able to decide which column they like to keep/delete. And here is what my Shiny App looks like so far. Anyone who knows any hints please help!
Any help would be appreciated!
ui <- dashboardPage(dashboardHeader(disable = T),
dashboardSidebar(disable = T),
dashboardBody(uiOutput("MainBody")))
server <- shinyServer(function(input, output){
vals <- reactiveValues()
vals$data <- data.table(vals$Data<-data.table(
Brands=paste0("Brand",1:10),
Forecasted_Growth=sample(1:20,10),
Last_Year_Purchase=round(rnorm(10,1000,1000)^2),
Contact=paste0("Brand",1:10,"#email.com")
))
output$MainBody <- renderUI({
fluidPage(
box(width = 12,
h3(strong("Template"), align = "center"),
hr(),
column(6, offset = 6,
actionButton(inputId = "Del_Col", label = "Delete Select Column"))),
column(12, dataTableOutput("MainTable")),
tags$script()
)
})
I agree with Pork Chop that you should rethink your layout. I couldn't get my head around it so I reworked it into a minimal fluidpage.
The code below should get you close. It renders buttons (you could make these checkboxes though) directly into the table using a helper function described here. The code below uses these buttons to subset and update the dataframe which I term reactiveTable. Here's the functionality:
Good luck!
library(data.table)
library(DT)
## Nice helper function to make the buttons from:
## https://github.com/rstudio/DT/issues/178
shinyInput <- function(FUN, len, id, ...) {
inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))
}
inputs
}
## Basic UI with a reset button
ui <- fluidPage(
mainPanel(
h1('Table Subsetter'),
actionButton('reset', 'Reset!'),
DT::dataTableOutput('mytable')
)
)
server <- function(input, output){
#This is the table you provided in your question
tableA <- data.table(
Brands=paste0("Brand",1:10),
Forecasted_Growth=sample(1:20,10),
Last_Year_Purchase=round(rnorm(10,1000,1000)^2),
Contact=paste0("Brand",1:10,"#email.com")
)
#make a reactive value for the table and columns to delete
reactiveTable <- reactiveValues(tab=tableA)
columnToDelete <- reactiveValues(col=NULL)
#Logic to make the buttons, reruns everytime the table is updated
tableOut <- reactive({
buttons <- shinyInput(actionButton, length(reactiveTable$tab[1,]), 'button_', label = "Delete!", onclick = 'Shiny.onInputChange(\"select_button\", this.id)' )
buttons <- t(as.data.frame(buttons, stringsAsFactors = FALSE))
colnames(buttons) = colnames(reactiveTable$tab)
rbind(buttons, reactiveTable$tab)
})
#reset button replaces the table
observeEvent(input$reset, {
reactiveTable$tab <- tableA
})
#listener to for the delete button
observeEvent(input$select_button, {
columnToDelete$col <-as.numeric(strsplit(input$select_button, "_")[[1]][2])
reactiveTable$tab <- subset( reactiveTable$tab, select = -columnToDelete$col )
})
#output the table with DT. use escape=F so it renders the html
output$mytable <- DT::renderDataTable({
tableOut()
},server = FALSE, escape = FALSE, selection = 'none')
}
shinyApp(ui = ui, server = server)
I am testing the script from here http://shiny.rstudio.com/articles/action-buttons.html (see the section "Pattern 1 - Command").
If to press the button "Click me" on the site so everything is Ok - we can see the popup menu.
But if to copy the example script into new .R file and run it - no popup message appeared, no warning or errror message is generated (my brouser is Google Chrome). So I am stalled with it.
The example script:
library(shiny)
ui <- fluidPage(
tags$head(tags$script(src = "message-handler.js")),
actionButton("do", "Click Me")
)
server <- function(input, output, session) {
observeEvent(input$do, {
session$sendCustomMessage(type = 'testmessage',
message = 'Thank you for clicking')
})
}
shinyApp(ui, server)
This should work, I gave two examples of pop-up alerts
1) With standard js alert
rm(list = ls())
library(shiny)
ui <- fluidPage(
tags$head(tags$script(HTML('Shiny.addCustomMessageHandler("jsCode",function(message) {eval(message.value);});'))),
actionButton("do", "Click Me")
)
server <- function(input, output, session) {
observeEvent(input$do, {
js_string <- 'alert("Thank you for clicking");'
session$sendCustomMessage(type='jsCode', list(value = js_string))
})
}
shinyApp(ui, server)
2) Using shinyBS package and modal pop-up
rm(list = ls())
library(shiny)
library(shinyBS)
ui <- fluidPage(
tags$script(HTML('Shiny.addCustomMessageHandler("jsCode",function(message) {eval(message.value);});')),
bsModal("ThankYou", "Message", "",tags$p(tags$h1("Thank you for clicking", style = "color:red", align = "center")), size = "small"),
actionButton("do", "Click Me")
)
server <- function(input, output, session) {
observeEvent(input$do, {
activate_modal <- "$('#ThankYou').modal('show')"
session$sendCustomMessage(type='jsCode', list(value = activate_modal))
})
}
shinyApp(ui, server)