From e64e726c7e34de82027413c9cdf79bfc5ed6cc6c Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Fri, 29 Oct 2021 12:41:59 +0000 Subject: [PATCH 1/4] navbar (user) widget as a module --- DESCRIPTION | 1 + NAMESPACE | 3 + R/AppNavbarUserWidget.R | 7 +- R/navbarWidget.R | 119 +++++++++++++++++++++++++++++ man/appNavbarUserWidget.Rd | 6 +- man/navbarWidget.Rd | 67 ++++++++++++++++ tests/testthat/test-navbarWidget.R | 39 ++++++++++ 7 files changed, 239 insertions(+), 3 deletions(-) create mode 100644 R/navbarWidget.R create mode 100644 man/navbarWidget.Rd create mode 100644 tests/testthat/test-navbarWidget.R diff --git a/DESCRIPTION b/DESCRIPTION index 53f080cc..38367b90 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -49,6 +49,7 @@ Imports: rpivotTable, sendmailR, shiny, + shinyalert, sship, utils, withr, diff --git a/NAMESPACE b/NAMESPACE index 07037e68..ad08c1c9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -67,6 +67,9 @@ export(makeUserSubscriptionTab) export(makeUserSubscriptionTabV2) export(makeUserSubscriptionTab_v2) export(mst) +export(navbarWidgetApp) +export(navbarWidgetInput) +export(navbarWidgetServer) export(noOptOutOk) export(orgList2df) export(pushGist) diff --git a/R/AppNavbarUserWidget.R b/R/AppNavbarUserWidget.R index 923d9d66..a0b2cbca 100644 --- a/R/AppNavbarUserWidget.R +++ b/R/AppNavbarUserWidget.R @@ -36,6 +36,8 @@ #' @param organization String providing the organization of the user #' @param addUserInfo Logical defining wether a user data pop-up is to be part #' of the widget (TRUE) or not (FALSE, default) +#' @param namespace Character string providing the namespace to use, if any. +#' Defaults is \code{NULL} in which case no namespace will be applied. #' #' @return Ready made html script #' @export @@ -44,10 +46,11 @@ #' appNavbarUserWidget() appNavbarUserWidget <- function(user = "Undefined person", organization = "Undefined organization", - addUserInfo = FALSE) { + addUserInfo = FALSE, + namespace = NULL) { if (addUserInfo) { userInfo <- shiny::tags$a( - id = "userInfo", + id = shiny::NS(namespace, "userInfo"), href = "#", class = "action-button", "Om:" diff --git a/R/navbarWidget.R b/R/navbarWidget.R new file mode 100644 index 00000000..c1a608f6 --- /dev/null +++ b/R/navbarWidget.R @@ -0,0 +1,119 @@ +#' Shiny modules providing GUI and server logic for user info widget +#' +#' Shiny modules for making a user information widget in registry shiny apps at +#' Rapporteket. One benefit using these modules will be reduced complexity and +#' number of code lines for each registry. +#' +#' These modules take use of the shiny session object to obtain data for the +#' widget. Hence, a Rapporteket like context will be needed for these modules to +#' function properly. +#' +#' @param id Character string providing module namespace +#' @param addUserInfo Logical defing if an "about" hyperlink is to be added +#' @param orgName Character string naming the organization +#' @param caller Character string naming the environment this function was +#' called from. Default value is \code{environmentName(rlang::caller_env())}. +#' The value is used to display the current version of the R package +#' representing the registry at Rapporteket. If this module is called from +#' exported functions in the registry R package use the default value. If the +#' module is called from outside the registry environment \code{caller} must be +#' set to the actual name of the R package. +#' +#' @return Shiny objects, mostly. Helper functions may return other stuff too. +#' @name navbarWidget +#' @aliases navbarWidgetInput navbarWidgetServer navbarWidgetApp +#' @examples +#' ## client user interface function +#' ui <- shiny::tagList( +#' shiny::navbarPage( +#' "Testpage", +#' shiny::tabPanel( +#' "Testpanel", +#' shiny::mainPanel( +#' navbarWidgetInput("testWidget") +#' ) +#' ) +#' ) +#' ) +#' +#' ## server function +#' server <- function(input, output, session) { +#' navbarWidgetServer("testWidget", orgName = "Test org", caller = "Rpkg") +#' } +#' +#' ## run the app in an interactive session and a Rapporteket like environment +#' if (interactive() && isRapContext()) { +#' shiny::shinyApp(ui, server) +#' } +NULL + + +#' @rdname navbarWidget +#' @export +navbarWidgetInput <- function(id, addUserInfo = TRUE) { + + shiny::addResourcePath("rap", system.file("www", package = "rapbase")) + + shiny::tagList( + shinyalert::useShinyalert(), + rapbase::appNavbarUserWidget( + user = shiny::uiOutput(shiny::NS(id, "name")), + organization = shiny::uiOutput(shiny::NS(id, "affiliation")), + addUserInfo = addUserInfo, + namespace = id + ), + shiny::tags$head( + shiny::tags$link(rel = "shortcut icon", href = "rap/favicon.ico") + ) + ) +} + +#' @rdname navbarWidget +#' @export +navbarWidgetServer <- function(id, orgName, + caller = environmentName(rlang::caller_env())) { + + shiny::moduleServer(id, function(input, output, session) { + + output$name <- shiny::renderText(rapbase::getUserFullName(session)) + output$affiliation <- shiny::renderText( + paste(orgName, rapbase::getUserRole(session), sep = ", ") + ) + + # User info in widget + userInfo <- rapbase::howWeDealWithPersonalData(session, callerPkg = caller) + shiny::observeEvent(input$userInfo, { + shinyalert::shinyalert( + "Dette vet Rapporteket om deg:", + userInfo, + type = "", imageUrl = "rap/logo.svg", + closeOnEsc = TRUE, + closeOnClickOutside = TRUE, + html = TRUE, + confirmButtonText = rapbase::noOptOutOk() + ) + }) + }) +} + +#' @rdname navbarWidget +#' @export +navbarWidgetApp <- function(orgName = "Org Name") { + + ui <- shiny::tagList( + shiny::navbarPage( + "Testpage", + shiny::tabPanel( + "Testpanel", + shiny::mainPanel( + navbarWidgetInput("testWidget") + ) + ) + ) + ) + server <- function(input, output, session) { + navbarWidgetServer("testWidget", orgName = orgName) + } + + shiny::shinyApp(ui, server) +} diff --git a/man/appNavbarUserWidget.Rd b/man/appNavbarUserWidget.Rd index c29ff153..9d68e335 100644 --- a/man/appNavbarUserWidget.Rd +++ b/man/appNavbarUserWidget.Rd @@ -7,7 +7,8 @@ appNavbarUserWidget( user = "Undefined person", organization = "Undefined organization", - addUserInfo = FALSE + addUserInfo = FALSE, + namespace = NULL ) } \arguments{ @@ -17,6 +18,9 @@ appNavbarUserWidget( \item{addUserInfo}{Logical defining wether a user data pop-up is to be part of the widget (TRUE) or not (FALSE, default)} + +\item{namespace}{Character string providing the namespace to use, if any. +Defaults is \code{NULL} in which case no namespace will be applied.} } \value{ Ready made html script diff --git a/man/navbarWidget.Rd b/man/navbarWidget.Rd new file mode 100644 index 00000000..4105f280 --- /dev/null +++ b/man/navbarWidget.Rd @@ -0,0 +1,67 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/navbarWidget.R +\name{navbarWidget} +\alias{navbarWidget} +\alias{navbarWidgetInput} +\alias{navbarWidgetServer} +\alias{navbarWidgetApp} +\title{Shiny modules providing GUI and server logic for user info widget} +\usage{ +navbarWidgetInput(id, addUserInfo = TRUE) + +navbarWidgetServer(id, orgName, caller = environmentName(rlang::caller_env())) + +navbarWidgetApp(orgName = "Org Name") +} +\arguments{ +\item{id}{Character string providing module namespace} + +\item{addUserInfo}{Logical defing if an "about" hyperlink is to be added} + +\item{orgName}{Character string naming the organization} + +\item{caller}{Character string naming the environment this function was +called from. Default value is \code{environmentName(rlang::caller_env())}. +The value is used to display the current version of the R package +representing the registry at Rapporteket. If this module is called from +exported functions in the registry R package use the default value. If the +module is called from outside the registry environment \code{caller} must be +set to the actual name of the R package.} +} +\value{ +Shiny objects, mostly. Helper functions may return other stuff too. +} +\description{ +Shiny modules for making a user information widget in registry shiny apps at +Rapporteket. One benefit using these modules will be reduced complexity and +number of code lines for each registry. +} +\details{ +These modules take use of the shiny session object to obtain data for the +widget. Hence, a Rapporteket like context will be needed for these modules to +function properly. +} +\examples{ +## client user interface function +ui <- shiny::tagList( + shiny::navbarPage( + "Testpage", + shiny::tabPanel( + "Testpanel", + shiny::mainPanel( + navbarWidgetInput("testWidget") + ) + ) + ) +) + +## server function +server <- function(input, output, session) { + navbarWidgetServer("testWidget", orgName = "Test org", caller = "Rpkg") +} + +## run the app in an interactive session and a Rapporteket like environment +if (interactive() && isRapContext()) { + shiny::shinyApp(ui, server) +} +} diff --git a/tests/testthat/test-navbarWidget.R b/tests/testthat/test-navbarWidget.R new file mode 100644 index 00000000..dc3cb342 --- /dev/null +++ b/tests/testthat/test-navbarWidget.R @@ -0,0 +1,39 @@ +## store current instance and set temporary config +currentConfigPath <- Sys.getenv("R_RAP_CONFIG_PATH") +currentInstance <- Sys.getenv("R_RAP_INSTANCE") + +# make pristine and dedicated config to avoid interference with other tests +Sys.setenv(R_RAP_INSTANCE = "DEV") +Sys.setenv(R_RAP_CONFIG_PATH = file.path(tempdir(), "navbarWidgetTesting")) +dir.create(Sys.getenv("R_RAP_CONFIG_PATH")) +file.copy(system.file(c("rapbaseConfig.yml", "dbConfig.yml", "autoReport.yml"), + package = "rapbase"), + Sys.getenv("R_RAP_CONFIG_PATH")) + +registryName <- "rapbase" + +test_that("navbar widget input returns a shiny tag list", { + expect_true("shiny.tag.list" %in% class(navbarWidgetInput("id"))) +}) + + +test_that("module navbar widget server returns output", { + shiny::testServer(navbarWidgetServer, args = list( + orgName = registryName, + caller ="rapbase" + ), { + expect_equal(output$name, "Tore Tester") + expect_equal(class(output$affiliation), "character") + session$setInputs(userInfo = 1) + }) +}) + + +test_that("test app returns an app object", { + expect_equal(class(navbarWidgetApp()), "shiny.appobj") +}) + + +# Restore instance +Sys.setenv(R_RAP_INSTANCE = currentInstance) +Sys.setenv(R_RAP_CONFIG_PATH = currentConfigPath) \ No newline at end of file From 9ffb2f3c0eb93839624ea9f26265036d261d0fe0 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Fri, 29 Oct 2021 12:48:01 +0000 Subject: [PATCH 2/4] consolidate function/files --- R/AppNavbarUserWidget.R | 75 ------------------------------------- R/navbarWidget.R | 77 ++++++++++++++++++++++++++++++++++++++ man/appNavbarUserWidget.Rd | 2 +- 3 files changed, 78 insertions(+), 76 deletions(-) delete mode 100644 R/AppNavbarUserWidget.R diff --git a/R/AppNavbarUserWidget.R b/R/AppNavbarUserWidget.R deleted file mode 100644 index a0b2cbca..00000000 --- a/R/AppNavbarUserWidget.R +++ /dev/null @@ -1,75 +0,0 @@ -#' Create widget for registry apps at Rapporteket -#' -#' Provides a widget-like information and utility block to be applied to all -#' registry apps at Rapporteket. Contains the user name, organization and -#' logout/exit as hyperlinked text. -#' -#' Normally, user information will be be provided through the session parameter -#' and hence this will have to be provided from the server. The "rendering" of -#' this info must hence be done within a layout element at the client such as -#' a \code{tabPanel}. Selecting any one of them should be fine... At the -#' client, both \code{uiOutput} and \code{textOutput} will be fine "rendering -#' the information provided by the server. -#' -#' Example of use in shiny (pseudo code): -#' \preformatted{ -#' server <- function(input, output, session) { -#' ... -#' output$appUserName <- renderText(getUserName(session)) -#' output$appUserOrg <- renderText(getUserReshId(session)) -#' ... -#' } -#' -#' ui <- tagList( -#' navbarPage( -#' ..., -#' tabPanel(..., -#' appNavbarUserWidget(user = uiOutput(appUserName), -#' organization = textOutput(appUserOrg)) -#' ), -#' ... -#' ) -#' ) -#' } -#' -#' @param user String providing the name of the user -#' @param organization String providing the organization of the user -#' @param addUserInfo Logical defining wether a user data pop-up is to be part -#' of the widget (TRUE) or not (FALSE, default) -#' @param namespace Character string providing the namespace to use, if any. -#' Defaults is \code{NULL} in which case no namespace will be applied. -#' -#' @return Ready made html script -#' @export -#' -#' @examples -#' appNavbarUserWidget() -appNavbarUserWidget <- function(user = "Undefined person", - organization = "Undefined organization", - addUserInfo = FALSE, - namespace = NULL) { - if (addUserInfo) { - userInfo <- shiny::tags$a( - id = shiny::NS(namespace, "userInfo"), - href = "#", - class = "action-button", - "Om:" - ) - } else { - userInfo <- character() - } - - txtWidget <- - paste0( - "var header = $('.navbar> .container-fluid');\n", - "header.append('
", - userInfo, - user, - organization, - "
');\n", - "console.log(header)" - ) - - shiny::tags$script(shiny::HTML(txtWidget)) -} diff --git a/R/navbarWidget.R b/R/navbarWidget.R index c1a608f6..b161e9b7 100644 --- a/R/navbarWidget.R +++ b/R/navbarWidget.R @@ -117,3 +117,80 @@ navbarWidgetApp <- function(orgName = "Org Name") { shiny::shinyApp(ui, server) } + + +#' Create widget for registry apps at Rapporteket +#' +#' Provides a widget-like information and utility block to be applied to all +#' registry apps at Rapporteket. Contains the user name, organization and +#' logout/exit as hyperlinked text. +#' +#' Normally, user information will be be provided through the session parameter +#' and hence this will have to be provided from the server. The "rendering" of +#' this info must hence be done within a layout element at the client such as +#' a \code{tabPanel}. Selecting any one of them should be fine... At the +#' client, both \code{uiOutput} and \code{textOutput} will be fine "rendering +#' the information provided by the server. +#' +#' Example of use in shiny (pseudo code): +#' \preformatted{ +#' server <- function(input, output, session) { +#' ... +#' output$appUserName <- renderText(getUserName(session)) +#' output$appUserOrg <- renderText(getUserReshId(session)) +#' ... +#' } +#' +#' ui <- tagList( +#' navbarPage( +#' ..., +#' tabPanel(..., +#' appNavbarUserWidget(user = uiOutput(appUserName), +#' organization = textOutput(appUserOrg)) +#' ), +#' ... +#' ) +#' ) +#' } +#' +#' @param user String providing the name of the user +#' @param organization String providing the organization of the user +#' @param addUserInfo Logical defining wether a user data pop-up is to be part +#' of the widget (TRUE) or not (FALSE, default) +#' @param namespace Character string providing the namespace to use, if any. +#' Defaults is \code{NULL} in which case no namespace will be applied. +#' +#' @return Ready made html script +#' @export +#' +#' @examples +#' appNavbarUserWidget() +appNavbarUserWidget <- function(user = "Undefined person", + organization = "Undefined organization", + addUserInfo = FALSE, + namespace = NULL) { + if (addUserInfo) { + userInfo <- shiny::tags$a( + id = shiny::NS(namespace, "userInfo"), + href = "#", + class = "action-button", + "Om:" + ) + } else { + userInfo <- character() + } + + txtWidget <- + paste0( + "var header = $('.navbar> .container-fluid');\n", + "header.append('
", + userInfo, + user, + organization, + "
');\n", + "console.log(header)" + ) + + shiny::tags$script(shiny::HTML(txtWidget)) +} diff --git a/man/appNavbarUserWidget.Rd b/man/appNavbarUserWidget.Rd index 9d68e335..e75f8c53 100644 --- a/man/appNavbarUserWidget.Rd +++ b/man/appNavbarUserWidget.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AppNavbarUserWidget.R +% Please edit documentation in R/navbarWidget.R \name{appNavbarUserWidget} \alias{appNavbarUserWidget} \title{Create widget for registry apps at Rapporteket} From f1db0c9f4583da5aee9b8ff1b99e23675bb1eaea Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Fri, 29 Oct 2021 12:50:10 +0000 Subject: [PATCH 3/4] upping --- DESCRIPTION | 2 +- NEWS.md | 4 ++++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 38367b90..c91b97ed 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: rapbase Type: Package Title: Base Functions and Resources for Rapporteket -Version: 1.19.4 +Version: 1.20.0 Authors@R: c( person(given = "Are", family = "Edvardsen", diff --git a/NEWS.md b/NEWS.md index 5d29bc7d..7d6c6172 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,7 @@ +# rapbase 1.20.0 + +* Navbar user information widget provided as a shiny module + # rapbase 1.19.4 * Export available to team members only From 24a7ddb3552910c3df11bc71351a219ad4482802 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Fri, 29 Oct 2021 13:16:32 +0000 Subject: [PATCH 4/4] explicit site docs --- _pkgdown.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/_pkgdown.yml b/_pkgdown.yml index 202a7ef0..1b324c7e 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -83,6 +83,7 @@ reference: Helper functions to be used by shiny apps contents: - runShinyApp + - navbarWidget - appNavbarUserWidget - exportGuide - statsGuide