R/esr_redcap.R

In pydupont/esr.shiny.redcap.modules: ESR shiny reporting apps linked to RedCap

if(file.exists("R/global.R")){source("R/global.R")}
### REDCAP CONNECTION ###
#' Redcap connection shiny module UI displaying:
#' \itemize{
#' \item the password field to input a redcap API token allowing connection to
#' the database.
#' \item an action button to initiate the connection to the database
#' \item a textbox showing the status of the connection
#' }
#'
#' @param id,label standard \code{shiny} boilerplate
#'
#' @export
redcap_conn_ui <- function(id, label = "redcap_conn") {
  ns <- NS(id)
  if(use_user_authentication){
    tagList(
     eruu_ui(ns("user_login"))
    )
  }else{
    tagList(
      passwordInput(ns("token_in"), h2("Access token"), value = "", placeholder = "Enter your access key"),
      actionButton(ns("token_button"), "Connect"),
      verbatimTextOutput(ns("connection_status")) %>% withSpinner(type=spinner_type, size=.25, proxy.height = "20px"),
    )
  }
}

#' Redcap connection shiny module allowing users to connect to a redcap
#' database.
#' The redcap URL needs to be provided in the `global.R` file and has to be
#' called `redcap_url`.
#' The connection is initiated when user clicks on the Connect button and the
#' status is displayed in the Connection status text box
#'
#' @param input,output,session standard \code{shiny} boilerplate
#'
#' @return a `reactiveVal` containing the redcapAPI connection object
#'
#' @export
redcap_conn_module <- function(input, output, session, user_db) {
  if(use_user_authentication){
    callModule(eruu_module, "user_login", user_db)
    current_key <- session$userData$current_key
    conn <- reactive({
      if(!is.null(current_key())){
        return(redcapConnection(url = redcap_url, token = current_key()))
      }else{
        return(NULL)
      }
    })
  }
  else{
    conn <- reactiveVal(NULL)
    observeEvent(input$token_button, {
      if (nchar(input$token_in) == 32) {
        conn(redcapConnection(url = redcap_url, token = input$token_in))
      } else{
        conn(NULL)
      }
    })

    output$connection_status <- renderText({
      if (is.null(conn())) {
        log_debug("redcap_conn_module: not connected")
        is_connected(FALSE)
        return("Not connected yet")
      } else{
        log_debug("redcap_conn_module: connected")
        is_connected(TRUE)
        return("Successfully connected")
      }
    })
    return(conn)
  }

}

## REDCAP DATA ##

#' Redcap data shiny module UI loading the data from the database
#' Displays the number of samples loaded using a given connection object
#'
#' @param input,output,session standard \code{shiny} boilerplate
#'
#' @export
redcap_data_ui <- function(id, label = "redcap_data") {
  ns <- NS(id)
  tagList(
    h2("Samples loaded"),
    verbatimTextOutput(ns("samples_loaded")) %>% withSpinner(type=spinner_type, size=.25, proxy.height = "20px"),
  )
}

#' Redcap data shiny module loading data from a given connection object
#' Loads the data, displays the number of samples loaded and returns the data as
#' a `reactive` value. Remove all columns present in the variable
#' `data_to_ignore` defined in `global.R`
#'
#' @param input,output,session standard \code{shiny} boilerplate
#' @param conn a `redcapAPI` connection object in a `reactiveVal` (as returned
#'   by the module `redcap_conn_module`)
#'
#' @return the data as a data frame in a `reactive` value
#'
#' @export
redcap_load_data_module <- function(input, output, session, conn){
  log_debug("redcap_load_data_module: before reactive")
  data <- reactive({
    log_debug("redcap_load_data_module: in reactive")
    log_debug("redcap_load_data_module: conn read")
    if(is.null(conn())){
      log_debug("redcap_load_data_module: not connected")
      return(NULL)
    } else{
      data <- as.data.frame(exportRecords(conn()))
      data <- data[!names(data) %in% data_to_ignore]
      data <- data %>% mutate(record_id = sprintf("isolate%06d", as.integer(record_id)))
      log_debug(paste0("redcap_load_data_module: data read (", nrow(data), ")"))
      return(data)
    }
  })
  output$samples_loaded <- renderText({
    if(is.null(data())){
      disable_all_tabs(except = c(tab_names$home, tab_names$user_admin))
      return("No data loaded")
    } else{
      enable_all_tabs()
      return(paste0(nrow(data()), " samples loaded"))
    }
  })
  # loaded_data(data)
  return(data)
}