Merge pull request #138 from openpharma/ls_create_v0.1.1

Create v0.1.1 release
openpharma · Nov 19, 2024 · 573c633 · 573c633
2 parents f32e09d + 92677b0
commit 573c633
Show file tree

Hide file tree

Showing 25 changed files with 279 additions and 80 deletions.
diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml
@@ -0,0 +1,59 @@
+# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples
+# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
+# usethis::use_github_action("pkgdown")
+
+on:
+  push:
+    branches: [main]
+  pull_request:
+    branches: [main, dev, devex]
+  release:
+    types: [published]
+  workflow_dispatch:
+
+name: pkgdown.yaml
+
+permissions: read-all
+
+jobs:
+  pkgdown:
+    runs-on: ubuntu-latest
+    # Only restrict concurrency for non-PR jobs
+    concurrency:
+      group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }}
+    env:
+      GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+    permissions:
+      contents: write
+    steps:
+      - uses: actions/checkout@v4
+
+      - uses: r-lib/actions/setup-pandoc@v2
+
+      - uses: r-lib/actions/setup-r@v2
+        with:
+          use-public-rspm: true
+          # r-version: 'renv'
+
+      - uses: r-lib/actions/setup-r-dependencies@v2
+        with:
+          extra-packages: any::pkgdown, local::.
+          needs: website
+
+      - uses: r-lib/actions/setup-renv@v2
+
+      - name: Install clinsight
+        shell: bash
+        run: R CMD INSTALL --preclean .
+
+      - name: Build site
+        run: pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE)
+        shell: Rscript {0}
+
+      - name: Deploy to GitHub pages 🚀
+        if: github.event_name != 'pull_request'
+        uses: JamesIves/[email protected]
+        with:
+          clean: false
+          branch: gh-pages
+          folder: docs
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: clinsight
 Title: ClinSight
-Version: 0.1.0
+Version: 0.1.1
 Authors@R: c(
     person("Leonard Daniël", "Samson", , "[email protected]", role = c("cre", "aut"),
            comment = c(ORCID = "0000-0002-6252-7639")),
@@ -46,6 +46,7 @@ Imports:
     tools,
     withr
 Suggests: 
+    base64enc,
     kableExtra,
     knitr,
     pkgload,

diff --git a/NEWS.md b/NEWS.md
@@ -1,3 +1,14 @@
+# clinsight 0.1.1
+
+## Changed 
+
+- Added `pkgdown` GHA workflow to automatically update documentation site with pushes to `main`
+
+## Bug fixes
+
+- Fixed inconsistencies in app messages when saving a review for a form with items with different review states (with some items reviewed previously by a different reviewer, and some items being completely new).
+- Fixed a bug where clinsight deployed with `shinyproxy` would crash when a user with non-ASCII letters in their name would attempt to login. In this new version, when using the `shinyproxy` deployment configuration, the user name is now expected to be base64 encoded, and will now be base64 encoded by `clinsight` by default, so that the app can also handle non-ASCII signs in user names that are stored in HTTP headers. To display the user name correctly, use base64 encoding in the `application.yml` in ShinyProxy settings (for example: `http-headers.X_SP_USERNAME: "#{T(java.util.Base64).getEncoder().encodeToString(oidcUser.getFullName().getBytes())}"`).
+
 # clinsight 0.1.0
 
 ## Changed

diff --git a/R/app_authentication.R b/R/app_authentication.R
@@ -151,7 +151,7 @@ authenticate_server <- function(
     ),
     http_headers = reactiveValues(
       user = session$request$HTTP_X_SP_USERID,
-      name = session$request$HTTP_X_SP_USERNAME,
+      name = decode_base64(session$request$HTTP_X_SP_USERNAME),
       roles = get_valid_roles(session$request$HTTP_X_SP_USERGROUPS, all_roles),
       sites = all_sites
     ),

diff --git a/R/app_server.R b/R/app_server.R
@@ -9,7 +9,7 @@
 #' the `header widgets` ([mod_header_widgets_server()]), and the `query page`
 #' ([mod_queries_server()])
 #'
-#' @param input,output,session Internal parameters for {shiny}.
+#' @param input,output,session Internal parameters for `shiny`.
 #' @seealso [app_ui()], [run_app()]
 #' 
 app_server <- function(

diff --git a/R/fct_app_role_helpers.R b/R/fct_app_role_helpers.R
@@ -27,6 +27,7 @@ get_roles_from_config <- function(
 #' @return A named character vector with the roles applicable for the
 #'   application and available for the current user.
 #' 
+#' @keywords internal
 get_valid_roles <- function(
     roles,
     all_roles = get_roles_from_config()

diff --git a/R/fct_data_helpers.R b/R/fct_data_helpers.R
@@ -92,6 +92,7 @@ get_metadata <- function(
 #'
 #' @return A data frame
 #'
+#' @keywords internal
 rename_raw_data <- function(
     data, 
     column_names = metadata$column_names
@@ -129,6 +130,7 @@ rename_raw_data <- function(
 #' @return A data frame, with derivative time and event variables, needed for
 #'   ClinSight to function properly.
 #'
+#' @keywords internal
 add_timevars_to_data <- function(
     data
 ){
@@ -326,6 +328,7 @@ get_meta_vars <- function(data = appdata, meta = metadata){
 #'
 #' @return A cleaned data frame with form-level data.
 #' 
+#' @keywords internal
 get_form_level_data <- function(
     data,
     all_forms,
@@ -383,7 +386,7 @@ get_form_level_data <- function(
 #' @param value_column A string containing the column name with the item values.
 #' @param id_column The columns identifying a unique participant (subject_id).
 #'
-#' @return as data frame with an additional column named "base_{varname}". 
+#' @return as data frame with an additional column named "base_`varname`". 
 #' @export
 #' @examples
 #'  library(dplyr)

diff --git a/R/fct_utils.R b/R/fct_utils.R
@@ -706,3 +706,41 @@ custom_config_path <- function(
 ){
   Sys.getenv("CONFIG_PATH", app_sys("golem-config.yml")) 
 }
+
+#' Decode a base64 encoded string.
+#'
+#' Used to decode base64-encoded HTTP headers. Encoding these headers
+#' ensures that they can contain complex names with special characters.
+#'
+#' The function will warn if the decoded output string is no valid UTF-8. This
+#' might occur if the input was not base64 encoded.
+#'
+#' @param x A base64 encoded character string.
+#'
+#' @return A decoded character string.
+#' @noRd
+#'
+#' @examples
+#' encoded_username <- base64enc::base64encode(charToRaw("Ťěšťůšěř 的"))
+#' decode_base64(encoded_username)
+#' 
+decode_base64 <- function(
+    x
+){
+  stopifnot("base64enc is not installed" = rlang::is_installed("base64enc"))
+  if(is.null(x)) return(x)
+  stopifnot(is.character(x))
+  decoded <- base64enc::base64decode(x)
+  valid_UTF8 <- base64enc::checkUTF8(decoded, quiet = TRUE)
+
+  if(isFALSE(valid_UTF8)){
+    warning(
+      "decoded string does not contain valid UTF-8. ",
+      "Is the input really base64 encoded?"
+    )
+    # using deparse creates visible quotes around the string but doing so will
+    # prevent the app from breaking due to incorrect UTF-8 encoding:
+    return({deparse1(rawToChar(decoded))})
+  }
+  rawToChar(decoded)
+}
diff --git a/R/mod_query_add.R b/R/mod_query_add.R
@@ -179,6 +179,8 @@ mod_query_add_server <- function(
         db_path, query_id = new_query$query_id, n = new_query$n
       )
       query_in_db <- unique(query_in_db[names(new_query)])
+      query_in_db <- query_in_db[query_in_db$timestamp == new_query$timestamp[1], ]
+
       if(identical(new_query, query_in_db)){
         r$query_data <- dplyr::bind_rows(r$query_data, new_query)
       }

diff --git a/R/mod_review_forms.R b/R/mod_review_forms.R
@@ -253,23 +253,34 @@ mod_review_forms_server <- function(
         tables = "all_review_data" 
       )
 
-      review_row_db <- db_get_review(
+      # Contains multiple rows, one for each item.
+      updated_rows_db <- db_get_review(
         db_path, subject = review_row$subject_id, form = review_row$item_group
-        )
-      review_row_db <- unique(review_row_db[names(review_row)])
+        )[c(names(review_row), "event_name", "item_name", "form_repeat")]
+      # Within a form, only items with a changed review state are updated and 
+      # contain the new (current) time stamp. 
+      updated_rows_db <- updated_rows_db[
+        updated_rows_db$timestamp == review_row$timestamp[1], 
+        ]
+
+      review_row_db <- unique(updated_rows_db[names(review_row)])
       if(identical(review_row_db, review_row)){
         cat("Update review data and status in app\n")
         r$review_data <- r$review_data |> 
-          dplyr::rows_update(review_row, by = c("subject_id", "item_group"))
+          dplyr::rows_update(
+            updated_rows_db, 
+            by = c("subject_id", "item_group", "event_name", "item_name", "form_repeat")
+          )
       }
 
-      review_row_memory <- review_row |> 
-        dplyr::left_join(r$review_data, by = names(review_row)) 
-      review_row_memory <- unique(review_row_memory[names(review_row)])
+      updated_items_memory <- sort(with(r$review_data, item_name[
+        reviewer == review_row$reviewer[1] & timestamp == review_row$timestamp[1]
+      ]))
+      updated_items_db <- sort(updated_rows_db$item_name)
 
       review_save_error(any(
         !identical(review_row_db, review_row),
-        !identical(review_row_memory, review_row_db)
+        !identical(updated_items_db, updated_items_memory)
       ))
 
       if(review_save_error()){

diff --git a/dev/02_dev.R b/dev/02_dev.R
@@ -147,6 +147,12 @@ usethis::use_vignette(name = "data_spec", title = "Input Data Specification")
 # Add action for PR
 #usethis::use_github_action_pr_commands()
 
+# For pkgdown
+# https://gist.github.com/ramnathv/2227408 to create an orphan gh-pages branch
+# and then run this
+usethis::use_github_action("pkgdown")
+
+
 # Circle CI
 #usethis::use_circleci()
 #usethis::use_circleci_badge()

diff --git a/inst/golem-config.yml b/inst/golem-config.yml
@@ -1,6 +1,6 @@
 default:
   golem_name: clinsight
-  golem_version: 0.1.0
+  golem_version: 0.1.1
   app_prod: no
   user_identification: test_user
   study_data: !expr clinsight::clinsightful_data

diff --git a/man/add_timevars_to_data.Rd b/man/add_timevars_to_data.Rd
diff --git a/man/app_server.Rd b/man/app_server.Rd
diff --git a/man/get_base_value.Rd b/man/get_base_value.Rd
diff --git a/man/get_form_level_data.Rd b/man/get_form_level_data.Rd
diff --git a/man/get_valid_roles.Rd b/man/get_valid_roles.Rd
diff --git a/man/rename_raw_data.Rd b/man/rename_raw_data.Rd
diff --git a/tests/testthat/_snaps/mod_review_forms.md b/tests/testthat/_snaps/mod_review_forms.md
@@ -3,36 +3,48 @@
     Code
       print(dplyr::select(r$review_data, -timestamp), width = Inf)
     Output
-      # A tibble: 2 x 11
+      # A tibble: 4 x 11
         subject_id event_name item_group     form_repeat item_name              
         <chr>      <chr>      <chr>                <dbl> <chr>                  
       1 361        Visit 5    Vital signs              4 Systolic blood pressure
-      2 885        Any visit  Adverse events           1 AE Number              
-        event_date edit_date_time      reviewed comment reviewer                     
-        <chr>      <chr>               <chr>    <chr>   <chr>                        
-      1 2023-07-01 2023-08-30 01:01:01 No       ""      ""                           
-      2 2023-08-15 2023-09-30 01:01:01 Yes      ""      "test_name (Medical Monitor)"
-        status
-        <chr> 
-      1 new   
-      2 old   
+      2 361        Visit 6    Vital signs              5 Systolic blood pressure
+      3 885        Any visit  Adverse events           1 Atrial Fibrillation    
+      4 885        Any visit  Adverse events           2 Cystitis               
+        event_date edit_date_time      reviewed comment          
+        <chr>      <chr>               <chr>    <chr>            
+      1 2023-07-01 2023-08-30 01:01:01 Yes      "another comment"
+      2 2023-08-01 2023-08-02 01:01:01 No       ""               
+      3 2023-08-15 2023-09-30 01:01:01 Yes      "test comment"   
+      4 2023-09-01 2023-10-01 01:01:01 Yes      ""               
+        reviewer                      status
+        <chr>                         <chr> 
+      1 "Reviewer 2"                  old   
+      2 ""                            new   
+      3 "Reviewer 1"                  old   
+      4 "test_name (Medical Monitor)" old   
 
 ---
 
     Code
       print(dplyr::select(r$review_data, -timestamp), width = Inf)
     Output
-      # A tibble: 2 x 11
+      # A tibble: 4 x 11
         subject_id event_name item_group     form_repeat item_name              
         <chr>      <chr>      <chr>                <dbl> <chr>                  
       1 361        Visit 5    Vital signs              4 Systolic blood pressure
-      2 885        Any visit  Adverse events           1 AE Number              
-        event_date edit_date_time      reviewed comment      
-        <chr>      <chr>               <chr>    <chr>        
-      1 2023-07-01 2023-08-30 01:01:01 No       ""           
-      2 2023-08-15 2023-09-30 01:01:01 No       "test review"
+      2 361        Visit 6    Vital signs              5 Systolic blood pressure
+      3 885        Any visit  Adverse events           1 Atrial Fibrillation    
+      4 885        Any visit  Adverse events           2 Cystitis               
+        event_date edit_date_time      reviewed comment          
+        <chr>      <chr>               <chr>    <chr>            
+      1 2023-07-01 2023-08-30 01:01:01 Yes      "another comment"
+      2 2023-08-01 2023-08-02 01:01:01 No       ""               
+      3 2023-08-15 2023-09-30 01:01:01 No       "test review"    
+      4 2023-09-01 2023-10-01 01:01:01 No       "test review"    
         reviewer                      status
         <chr>                         <chr> 
-      1 ""                            new   
-      2 "test_name (Medical Monitor)" new   
+      1 "Reviewer 2"                  old   
+      2 ""                            new   
+      3 "test_name (Medical Monitor)" new   
+      4 "test_name (Medical Monitor)" new