auth_ui() : add choose_language

NAMESPACE

@@ -79,16 +79,20 @@ importFrom(shiny,reactiveVal)
 importFrom(shiny,reactiveValues)
 importFrom(shiny,reactiveValuesToList)
 importFrom(shiny,removeUI)
+importFrom(shiny,renderUI)
 importFrom(shiny,req)
 importFrom(shiny,selectInput)
 importFrom(shiny,showModal)
 importFrom(shiny,showNotification)
 importFrom(shiny,tabPanel)
 importFrom(shiny,textInput)
+importFrom(shiny,uiOutput)
+importFrom(shiny,updateActionButton)
 importFrom(shiny,updateCheckboxInput)
 importFrom(shiny,updateDateRangeInput)
 importFrom(shiny,updateQueryString)
 importFrom(shiny,updateSelectInput)
+importFrom(shiny,updateTextInput)
 importFrom(stats,setNames)
 importFrom(utils,getFromNamespace)
 importFrom(utils,modifyList)

NEWS.md

@@ -3,6 +3,8 @@
 * Add ``autofocus`` on username input.
 * Fix some (strange) bug with ``input$shinymanager_where``
 * Fix `inputs_list` with some shiny version
+* `auth_ui()` now accept a `choose_language` arguments.
+* Rename `br` language into `pt-BR` (iso code)
 
 # shinymanager 1.0.200
 

R/module-auth.R

@@ -8,6 +8,8 @@
 #' @param tags_top A \code{tags (div, img, ...)} to be displayed on top of the authentication module.
 #' @param tags_bottom A \code{tags (div, img, ...)} to be displayed on bottom of the authentication module.
 #' @param background A optionnal \code{css} for authentication background. See example.
+#' @param choose_language \code{logical/character}. Add language selection on top ? TRUE for all supported languages
+#' or a vector of possibilities like \code{c("fr", "en")}. If enabled, \code{input$shinymanager_language} is created
 #' @param ... : Used for old version compatibility.
 #' 
 #' 
@@ -16,11 +18,12 @@
 #' @name module-authentication
 #'
 #' @importFrom htmltools tagList tags singleton
-#' @importFrom shiny NS fluidRow column textInput passwordInput actionButton
+#' @importFrom shiny NS fluidRow column textInput passwordInput actionButton uiOutput
 #'
 #' @example examples/module-auth.R
 auth_ui <- function(id, status = "primary", tags_top = NULL, 
-                    tags_bottom = NULL, background = NULL, ...) {
+                    tags_bottom = NULL, background = NULL, 
+                    choose_language = NULL, ...) {
 
   ns <- NS(id)
 
@@ -55,10 +58,35 @@ auth_ui <- function(id, status = "primary", tags_top = NULL,
             class = paste0("panel panel-", status),
             tags$div(
               class = "panel-body",
+              if (!is.null(choose_language)){
+                choices = NULL
+                if(is.logical(choose_language) && choose_language){
+                  choices = lan$get_language_registered()
+                } else if(is.character(choose_language)){
+                  choices = unique(c(intersect(choose_language, lan$get_language_registered()), lan$get_language()))
+                }
+
+                if(length(choices) > 1){
+                  selected = ifelse(lan$get_language() %in% choices, 
+                                    lan$get_language(),
+                                    choices[1])
+
+                  tags$div(
+                    style = "text-align: left; font-size: 12px;",
+                    selectInput(
+                      inputId = ns("language"),
+                      label = NULL,
+                      choices = choices,
+                      selected = selected,
+                      width = "20%"
+                    )
+                  )
+                }
+              },
               tags$div(
                 style = "text-align: center;",
                 if (!is.null(tags_top)) tags_top,
-                tags$h3(lan$get("Please authenticate"))
+                uiOutput(ns("auth_title"))
               ),
               tags$br(),
               textInput(
@@ -83,7 +111,8 @@ auth_ui <- function(id, status = "primary", tags_top = NULL,
                 sprintf("bindEnter('%s');", ns(""))
               ),
               tags$div(id = ns("result_auth")),
-              if (!is.null(tags_bottom)) tags$hr(), tags_bottom
+              if (!is.null(tags_bottom)) tags$hr(), tags_bottom,
+              uiOutput(ns("update_shinymanager_language"))
             )
           )
         )
@@ -113,7 +142,7 @@ auth_ui <- function(id, status = "primary", tags_top = NULL,
 #'  }
 #'
 #' @importFrom htmltools tags
-#' @importFrom shiny reactiveValues observeEvent removeUI updateQueryString insertUI icon
+#' @importFrom shiny reactiveValues observeEvent removeUI updateQueryString insertUI icon updateActionButton updateTextInput renderUI
 #' @importFrom stats setNames
 auth_server <- function(input, output, session, check_credentials, use_token = FALSE) {
 
@@ -131,6 +160,26 @@ auth_server <- function(input, output, session, check_credentials, use_token = F
 
   lan <- use_language()
 
+  auth_title <- reactiveVal(lan$get("Please authenticate"))
+  observe({
+    if(!is.null(input$language)){
+      lan$set_language(input$language) 
+      updateTextInput(session, inputId = "user_id", label = lan$get("Username:"))
+      updateTextInput(session, inputId = "user_pwd", label = lan$get("Password:"))
+      updateActionButton(session, inputId = "go_auth", label = lan$get("Login"))
+
+      auth_title(lan$get("Please authenticate"))
+
+      output$update_shinymanager_language <- renderUI({
+        shinymanager_language(lan$get_language())
+      })
+    }
+  })
+
+  output$auth_title <- renderUI({
+    tags$h3(auth_title())
+  })
+
   authentication <- reactiveValues(result = FALSE, user = NULL, user_info = NULL)
 
   observeEvent(input$go_auth, {

R/secure-app.R

@@ -10,7 +10,7 @@
 #' @param theme Alternative Bootstrap stylesheet, default is to use \code{readable},
 #'  you can use themes provided by \code{shinythemes}.
 #'  It will affect the authentication panel and the admin page.
-#' @param language Language to use for labels, supported values are : "en", "fr", "br".
+#' @param language Language to use for labels, supported values are : "en", "fr", "pt-BR".
 #'
 #' @note A special input value will be accessible server-side with \code{input$shinymanager_where}
 #'  to know in which step user is : authentication, application, admin or password.
@@ -26,8 +26,8 @@
 #'
 #' @example examples/secure_app.R
 secure_app <- function(ui, ..., enable_admin = FALSE, head_auth = NULL, theme = NULL, language = "en") {
-  if (!language %in% c("en", "fr", "br")) {
-    warning("Only supported language for the now are: en, fr, br", call. = FALSE)
+  if (!language %in% c("en", "fr", "pt-BR")) {
+    warning("Only supported language for the now are: en, fr, pt-BR", call. = FALSE)
     language <- "en"
   }
   set_language(language)
@@ -53,7 +53,8 @@ secure_app <- function(ui, ..., enable_admin = FALSE, head_auth = NULL, theme =
           theme = theme,
           tags$head(head_auth),
           do.call(pwd_ui, args),
-          shinymanager_where("password")
+          shinymanager_where("password"),
+          shinymanager_language(lan$get_language())
         )
         return(pwd_ui)
       }
@@ -82,7 +83,8 @@ secure_app <- function(ui, ..., enable_admin = FALSE, head_auth = NULL, theme =
             title = tagList(icon("home"), lan$get("Home")),
             value = "home",
             admin_ui("admin"),
-            shinymanager_where("admin")
+            shinymanager_where("admin"),
+            shinymanager_language(lan$get_language())
           ),
           tabPanel(
             title = "Logs",
@@ -123,7 +125,7 @@ secure_app <- function(ui, ..., enable_admin = FALSE, head_auth = NULL, theme =
           ui <- ui(request)
         }
         tagList(
-          ui, menu, shinymanager_where("application"),
+          ui, menu, shinymanager_where("application"), shinymanager_language(lan$get_language()),
           singleton(tags$head(tags$script(src = "shinymanager/timeout.js")))
         )
       }

R/shiny-utils.R

@@ -28,6 +28,14 @@ shinymanager_where <- function(where) {
   )
 }
 
+shinymanager_language <- function(lan) {
+  tags$div(
+    style = "display: none;",
+    selectInput(inputId = "shinymanager_language", label = NULL, 
+                choices = lan, selected = lan, multiple = TRUE)
+  )
+}
+
 
 # Remove the whole query string
 #' @importFrom shiny updateQueryString getDefaultReactiveDomain

examples/demo/server.R

@@ -22,6 +22,7 @@ function(input, output, session) {
 
   observe({
     print(input$shinymanager_where)
+    print(input$shinymanager_language)
   })
 
   output$res_auth <- renderPrint({

examples/demo/ui.R

@@ -23,6 +23,8 @@ ui <- fluidPage(
 # Call UI inside secure_app()
 secure_app(
   ui = ui,
-  enable_admin = TRUE
+  enable_admin = TRUE,
+  language = "fr",
+  choose_language = c("en")
 )
 

examples/module-auth.R

@@ -36,9 +36,11 @@ if (interactive()) {
         )
       ),
       # change auth ui background ?
+      # https://developer.mozilla.org/fr/docs/Web/CSS/background
       background  = "linear-gradient(rgba(0, 0, 255, 0.5),
                        rgba(255, 255, 0, 0.5)),
-                       url('https://www.r-project.org/logo/Rlogo.png');"
+                       url('https://www.r-project.org/logo/Rlogo.png');", 
+      choose_language = TRUE
     ),
 
     # result of authentication

examples/secure_app.R

@@ -16,7 +16,7 @@ if (interactive()) {
   )
 
   # Wrap your UI with secure_app
-  ui <- secure_app(ui)
+  ui <- secure_app(ui, choose_language = TRUE)
 
   # change auth ui background ?
   # ui <- secure_app(ui,
@@ -36,6 +36,11 @@ if (interactive()) {
       reactiveValuesToList(res_auth)
     })
 
+    observe({
+      print(input$shinymanager_where)
+      print(input$shinymanager_language)
+    })
+
     # your classic server logic
 
   }