add upload option

DESCRIPTION

@@ -31,8 +31,10 @@ Imports:
     glue,
     httr2,
     jsonlite,
+    openxlsx,
     r2d3,
     R6,
+    readxl,
     shiny,
     stringr,
     testthat,

R/cdmConstructor.R

@@ -111,6 +111,56 @@ cdmConstructor <- R6::R6Class(
     load = function(jsonData) {
       private$.data <- jsonData
     },
+    # Add data from an xlsx test set. Each worksheet should represent one CDM
+    # table. The app loads the CDM tables it supports and ignores other sheets.
+    loadXlsxTestSet = function(path) {
+      checkmate::assertFileExists(path)
+      if (!requireNamespace("readxl", quietly = TRUE)) {
+        stop("The readxl package is required to upload xlsx test data.")
+      }
+
+      sheets <- readxl::excel_sheets(path)
+      supported_tables <- c("person", self$tables)
+      supported_sheets <- intersect(sheets, supported_tables)
+
+      if (!"person" %in% sheets) {
+        stop("Invalid xlsx file: the workbook must contain a 'person' sheet.")
+      }
+      if (!"person" %in% supported_sheets) {
+        stop("Invalid xlsx file: the workbook must contain a supported 'person' sheet.")
+      }
+
+      loaded_tables <- character(0)
+      imported_tables <- list()
+
+      for (tableName in supported_sheets) {
+        table_data <- readxl::read_excel(
+          path,
+          sheet = tableName,
+          .name_repair = "minimal"
+          ) |>
+          data.table::as.data.table()
+
+        table_data <- private$.validateImportedTable(
+          tableName = tableName,
+          table_data = table_data
+          )
+
+        imported_tables[[tableName]] <- table_data
+        loaded_tables <- c(loaded_tables, tableName)
+      }
+
+      self$reset()
+      for (tableName in names(imported_tables)) {
+        self[[tableName]]$load(imported_tables[[tableName]])
+      }
+
+      ignored_tables <- setdiff(sheets, supported_tables)
+      invisible(list(
+        loaded = loaded_tables,
+        ignored = ignored_tables
+        ))
+    },
     delete = function(event_id) {
       name_id <- paste(
         private$.tableName,
@@ -263,6 +313,36 @@ cdmConstructor <- R6::R6Class(
         return(cdm_data_json)
 
         },
+    # Export data to xlsx
+    writeCdmDataXlsx = function(path) {
+      if (!requireNamespace("openxlsx", quietly = TRUE)) {
+        stop("The openxlsx package is required to download xlsx test data.")
+      }
+
+      cdm_data <- list(
+        person = self$person$data()
+        )
+      cdm_data <- c(
+        cdm_data,
+        stats::setNames(
+          lapply(self$tables, function(table_name) self[[table_name]]$data()),
+          self$tables
+          )
+        )
+
+      workbook <- openxlsx::createWorkbook()
+      for (table_name in names(cdm_data)) {
+        openxlsx::addWorksheet(workbook, table_name)
+        openxlsx::writeData(
+          workbook,
+          sheet = table_name,
+          x = as.data.frame(cdm_data[[table_name]]),
+          colNames = TRUE
+          )
+      }
+      openxlsx::saveWorkbook(workbook, path, overwrite = TRUE)
+      invisible(path)
+      },
     # Export data to json
     getCdmDataTimeline = function() {
       if (self$person$data() |> length() > 0) {
@@ -346,6 +426,92 @@ cdmConstructor <- R6::R6Class(
       }
     ),
   private = list(
+    .fillMissingEndDates = function(tableName, table_data) {
+      if (tableName == "condition_occurrence") {
+        start_col <- "condition_start_date"
+        end_col <- "condition_end_date"
+      } else if (tableName == "drug_exposure") {
+        start_col <- "drug_exposure_start_date"
+        end_col <- "drug_exposure_end_date"
+      } else if (tableName == "procedure_occurrence") {
+        start_col <- "procedure_date"
+        end_col <- "procedure_end_date"
+      } else {
+        return(table_data)
+      }
+
+      if (!start_col %in% names(table_data)) {
+        return(table_data)
+      }
+
+      if (!end_col %in% names(table_data)) {
+        table_data[, (end_col) := get(start_col)]
+        return(table_data)
+      }
+
+      missing_end_date <- is.na(table_data[[end_col]])
+      if (any(missing_end_date)) {
+        table_data[
+          missing_end_date,
+          (end_col) := table_data[[start_col]][missing_end_date]
+          ]
+      }
+
+      table_data
+    },
+    .convertDateColumns = function(table_data) {
+      date_cols <- names(table_data)[grepl("_date$", names(table_data))]
+      if (length(date_cols) == 0) {
+        return(table_data)
+      }
+
+      for (date_col in date_cols) {
+        value <- table_data[[date_col]]
+        if (inherits(value, "Date")) {
+          converted_value <- value
+        } else if (inherits(value, "POSIXt")) {
+          converted_value <- as.Date(value)
+        } else if (is.numeric(value)) {
+          converted_value <- as.Date(value, origin = "1899-12-30")
+        } else {
+          converted_value <- suppressWarnings(as.Date(value))
+        }
+        data.table::set(
+          table_data,
+          j = date_col,
+          value = converted_value
+          )
+      }
+
+      table_data
+    },
+    .validateImportedTable = function(tableName, table_data) {
+      table_data <- data.table::as.data.table(table_data)
+      expected_columns <- names(columnNames(tableName))
+      unknown_columns <- setdiff(names(table_data), expected_columns)
+
+      if (length(unknown_columns) > 0) {
+        stop(glue::glue(
+          "Invalid xlsx file: sheet '{tableName}' contains unsupported columns: {glue::glue_collapse(unknown_columns, sep = ', ')}."
+          ))
+      }
+      if (tableName == "person" && !"person_id" %in% names(table_data)) {
+        stop("Invalid xlsx file: sheet 'person' must contain a 'person_id' column.")
+      }
+      if (
+        tableName == "person" &&
+        (nrow(table_data) == 0 || all(is.na(table_data$person_id)))
+      ) {
+        stop("Invalid xlsx file: sheet 'person' must contain at least one person.")
+      }
+
+      table_data <- private$.convertDateColumns(table_data)
+      table_data <- private$.fillMissingEndDates(tableName, table_data)
+      data.table::rbindlist(
+        list(columnNames(tableName), table_data),
+        fill = TRUE
+        )
+    },
     .getData = function() {
       return(private$.data)
       },

R/patientsDesigner.R

@@ -43,6 +43,14 @@ patientDesigner <- function(path = NULL) {
             class = "text-reset text-decoration-none"
           )
           ),
+        fileInput(
+          "upload_xlsx",
+          "Upload xlsx test data",
+          accept = c(
+            ".xlsx",
+            "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet"
+            )
+          ),
         br(),
         br(),
         h6(strong("Test Sets")),
@@ -64,7 +72,12 @@ patientDesigner <- function(path = NULL) {
           ),
         downloadButton(
           "downloadTestSet",
-          "Download Test Set",
+          "Download Test Set as JSON",
+          icon = icon("download")
+          ),
+        downloadButton(
+          "downloadTestSetXlsx",
+          "Download Test Set as XLSX",
           icon = icon("download")
           ),
         position = c("left"),
@@ -191,6 +204,41 @@ patientDesigner <- function(path = NULL) {
       data_version(data_version() + 1)
     })
 
+    observeEvent(input$upload_xlsx, {
+      req(input$upload_xlsx)
+      result <- tryCatch(
+        cdm$loadXlsxTestSet(input$upload_xlsx$datapath),
+        error = function(e) e
+        )
+
+      if (inherits(result, "error")) {
+        showNotification(
+          conditionMessage(result),
+          type = "error",
+          duration = 8
+          )
+        return(invisible(NULL))
+      }
+
+      data_version(data_version() + 1)
+
+      if (length(result$ignored) > 0) {
+        showNotification(
+          glue::glue(
+            "Loaded xlsx test data. Ignored unsupported sheets: {glue::glue_collapse(result$ignored, sep = ', ')}."
+            ),
+          type = "warning",
+          duration = 8
+          )
+      } else {
+        showNotification(
+          "Loaded xlsx test data.",
+          type = "message",
+          duration = 5
+          )
+      }
+    })
+
     ##### Update saved file in sidebar
     current_files <- reactive({
       file_refresh_trigger()
@@ -571,6 +619,15 @@ patientDesigner <- function(path = NULL) {
       }
     )
 
+    output$downloadTestSetXlsx <- downloadHandler(
+      filename = function() {
+        paste("patientDesigner", ".xlsx", sep = "")
+      },
+      content = function(file) {
+        cdm$writeCdmDataXlsx(file)
+      }
+    )
+
     ##### D3 TIMELINE
     output$d3 <- renderD3({
       r2d3(