R/esr_user_metadata.R

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

source("R/global.R")
#' Using the file path returned from the upload function, reads the file, checks
#' the data and returns it. The identifier used must be in the first column, the
#' data in the first column must be unique. This function also exports the data
#' in a `reactiveValue` `user_data` set in `global.R`
#'
#'  @param file_path the file path of the temporary file uploaded by the user
#'
#'  @return the uploaded data as a dataframe
#'
#'  @export
get_user_data <- function(file_path){
  ret <- reactive({
    p <- file_path()
    if (is.null(p)) {
      user_data(NULL)
      return(NULL)
    }
    df <- read_excel(p)
    if (length(levels(as.factor(df[[names(df)[1]]]))) < nrow(df)) {
      user_data(NULL)
      return("ERROR")
    }
    user_data(df)
    return(df)
  })
  return(ret)
}

#' The user metadata module. Allows the user to upload its own metadata (not
#' saved in the database, only kept in the session)
#'
#' @param input,output,session boiler plate of R shiny modules
#' @param redcap_metadata the metadata as saved in the database. To be join to
#' the user data
#'
#' @export
user_metadata_module <- function(input, output, session, redcap_metadata) {

  ns <- session$ns
  user_data(NULL)

  file_path <- reactive({
    return(input$file1$datapath)
  })

  output$file_name <- renderText({
    # browser()
    if(is.null(user_data()) || nrow(user_data()) == 0){
      "No extra information loaded."
    }else{
      paste0("Extra information loaded for ", nrow(user_data()), " records loaded")

    }
  })

  ret <- get_user_data(file_path)

  output$error <- renderUI({
    df <- ret()
    if(is.character(df) && df == "ERROR"){
      return(
        h4(
          "Error, the first column must contain unique values",
          class = "error"
        )
      )
    }
  })

  loaded_user_data <- merge_user_data_with_metadata(ret, redcap_metadata)


  output$user_metadata_dt <- renderDataTable({
    loaded_user_data() %>% datatable()
  })
}

#' User metadata module UI
#'
#' @param id the namespace of the module
#'
#' @export
user_metadata_ui <- function(id){
  ns <- NS(id)
  tagList(
    div(
      div(
        uiOutput(ns("error"))
      ),
      class = "row"
    ),
    div(
      dataTableOutput(ns("user_metadata_dt")),
      class = "row"
    ),
    div(
      fileInput(
        ns("file1"),
        "Choose Excel File",
        multiple = FALSE,
        accept = c(
          "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet"
        )
      ),
      class = "row"
    ),
    div(
      verbatimTextOutput(ns("file_name")),
      class="row"
    )
  )
}

#' Merges the metadata with the user data
#'
#' @param user_metadata the user metadata
#' @param redcap_metadata the metadata saved in the database
#'
#' @return the merged data as a dataframe
#'
#' @noRd
merge_user_data_with_metadata <- function(user_metadata, redcap_metadata){
  ret <- reactive({
    # browser()
    df <- user_metadata()
    if(is.null(df)){return(df)}
    if(is.character(df) && df == "ERROR"){return(NULL)}
    # df <- merge(redcap_metadata(), df,
    #             by.x=main_record_idt_col, by.y=names(df)[1], all.x = F)
    df2 <- redcap_metadata()
    df2 <- df2[df2[[main_record_idt_col]] %in% df[[names(df)[1]]],]
    return(df2)
  })
  return(ret)
}