From e882dd3ae5f8d4696ec1a9862762878b8b3132df Mon Sep 17 00:00:00 2001 From: Ger Inberg Date: Fri, 5 Jun 2026 08:44:13 +0200 Subject: [PATCH 1/5] #49 fix updating measurement/procedure --- R/patientsDesigner.R | 18 +++++++++++++++--- R/updateFunctions.R | 18 +++--------------- 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/R/patientsDesigner.R b/R/patientsDesigner.R index 76a31d2..4d42ec7 100644 --- a/R/patientsDesigner.R +++ b/R/patientsDesigner.R @@ -311,9 +311,9 @@ patientDesigner <- function(path = NULL) { cdm$person$data() }) - # After person selection - # Filters and updates observation/drug exposure fields - observeEvent(person_module(), { + # After person selection, refresh event selectors for all + # patient-level event tables. + observeEvent(list(person_module()), { req(person_module()) updateTableIdsNs( @@ -328,6 +328,18 @@ patientDesigner <- function(path = NULL) { input_person_id = person_module, session = session ) + updateTableIdsNs( + cdm = cdm, + type = "measurement", + input_person_id = person_module, + session = session + ) + updateTableIdsNs( + cdm = cdm, + type = "procedure_occurrence", + input_person_id = person_module, + session = session + ) updateTableIdsNs( cdm = cdm, type = "drug_exposure", diff --git a/R/updateFunctions.R b/R/updateFunctions.R index a843617..bb89e4f 100644 --- a/R/updateFunctions.R +++ b/R/updateFunctions.R @@ -163,22 +163,10 @@ updateTableDatesNs <- function(cdm, input, syncing) { - # browser() - if (type == "condition_occurrence") { - type_corrected <- "condition" - } else if (type == "measurement") { - type_corrected <- "measurement" - } else { - type_corrected <- type - } - - # Access names - if (type == "measurement") { - table_start_date <- "measurement_date" + table_start_date <- cdm[[type]]$tableNameDate("start") + table_end_date <- cdm[[type]]$tableNameDate("end") + if (length(table_end_date) == 0) { table_end_date <- NULL - } else { - table_start_date <- glue::glue("{type_corrected}_start_date") - table_end_date <- glue::glue("{type_corrected}_end_date") } table_id <- glue::glue("{type}_id") From b99be045448401eee0a8daeb0182307edca6c0e1 Mon Sep 17 00:00:00 2001 From: Ger Inberg Date: Fri, 5 Jun 2026 08:46:36 +0200 Subject: [PATCH 2/5] revert --- R/patientsDesigner.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/patientsDesigner.R b/R/patientsDesigner.R index 4d42ec7..dd613c0 100644 --- a/R/patientsDesigner.R +++ b/R/patientsDesigner.R @@ -313,7 +313,7 @@ patientDesigner <- function(path = NULL) { # After person selection, refresh event selectors for all # patient-level event tables. - observeEvent(list(person_module()), { + observeEvent(person_module(), { req(person_module()) updateTableIdsNs( From 35ddd17c0f710423fa0adc9221e45c4143d0a568 Mon Sep 17 00:00:00 2001 From: Ger Inberg Date: Fri, 5 Jun 2026 09:23:33 +0200 Subject: [PATCH 3/5] fix test --- R/cdmConstructor.R | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/R/cdmConstructor.R b/R/cdmConstructor.R index 4c30c3d..6545ac6 100644 --- a/R/cdmConstructor.R +++ b/R/cdmConstructor.R @@ -352,12 +352,19 @@ cdmConstructor <- R6::R6Class( names() |> tail(-2) |> head(3) + if (private$.tableName == "observation_period") { values <- list( as.Date("2010-02-28"), as.Date("2015-02-28"), 44191562L ) + } else if (private$.tableName == "measurement") { + # this table has no end date + column_names <- column_names |> head(2) + values <- list( + 44191562L, + as.Date("2010-02-28")) } else { values <- list( 44191562L, From 0887be25430e23fac1603e6e21e99ee4a8c9bd25 Mon Sep 17 00:00:00 2001 From: Ger Inberg Date: Mon, 8 Jun 2026 08:36:32 +0200 Subject: [PATCH 4/5] fix saving procedure dates --- R/cdmTableModules.R | 41 ++++++++++++++------------- tests/testthat/test-cdmTableModules.R | 25 ++++++++++++++++ 2 files changed, 46 insertions(+), 20 deletions(-) diff --git a/R/cdmTableModules.R b/R/cdmTableModules.R index 4501284..137ad51 100644 --- a/R/cdmTableModules.R +++ b/R/cdmTableModules.R @@ -78,28 +78,17 @@ cdmTableServer <- function( session ) { ns <- session$ns - if (id == "condition_occurrence") { - table_id <- "condition" - } else { - table_id <- id - } - table_event_id <- paste( id, "id", sep = "_" ) table_concept_id <- cdm[[id]]$tableNameConceptId() - table_start_date <- paste( - table_id, - "start_date", - sep = "_" - ) - table_end_date <- paste( - table_id, - "end_date", - sep = "_" - ) + table_start_date <- cdm[[id]]$tableNameDate("start") + table_end_date <- cdm[[id]]$tableNameDate("end") + if (length(table_end_date) == 0) { + table_end_date <- NULL + } columnList <- columnNames( name = id, limit = NULL @@ -297,19 +286,31 @@ cdmTableServer <- function( elongation_click <- reactiveVal(NULL) # # # Elongation + tableDateInputs <- reactive({ + values <- list(input[[table_start_date]]) + if (!is.null(table_end_date)) { + values <- c(values, list(input[[table_end_date]])) + } + values + }) + observeEvent( - list(input[[table_start_date]], input[[table_end_date]]), + tableDateInputs(), { - print(syncing) req(!syncing()) + req(input[[table_event_id]]) req(input[[table_start_date]]) - req(input[[table_end_date]]) + end_date <- NULL + if (!is.null(table_end_date)) { + req(input[[table_end_date]]) + end_date <- input[[table_end_date]] + } cdm[[id]]$updateDates( person_id = person_id_selected(), event_id = input[[table_event_id]], start_date = input[[table_start_date]], - end_date = input[[table_end_date]] + end_date = end_date ) elongation_click(Sys.time()) }, diff --git a/tests/testthat/test-cdmTableModules.R b/tests/testthat/test-cdmTableModules.R index e618c31..708efa7 100644 --- a/tests/testthat/test-cdmTableModules.R +++ b/tests/testthat/test-cdmTableModules.R @@ -42,3 +42,28 @@ test_that("cdmTableServer persists manually entered concept ids", { expect_equal(cdm$measurement$data()$measurement_concept_id[[1]], 3018251L) }) + +test_that("cdmTableServer persists manually entered procedure dates", { + cdm <- new_cdm() + cdm$person$add(gender_concept_id = 8532L, year_of_birth = 1970L) + cdm$procedure_occurrence$add(person_id = 1L) + + syncing <- shiny::reactiveVal(FALSE) + + shiny::testServer(cdm_table_server, + args = list( + id = "procedure_occurrence", + cdm = cdm, + person_id_selected = shiny::reactive("1"), + syncing = syncing, + concept_lookup = function(concept_id) "(Procedure)" + ), { + session$setInputs(procedure_occurrence_id = 1L) + session$setInputs(procedure_date = as.Date("2021-04-03")) + session$setInputs(procedure_end_date = as.Date("2021-04-05")) + } + ) + + expect_equal(cdm$procedure_occurrence$data()$procedure_date[[1]], as.Date("2021-04-03")) + expect_equal(cdm$procedure_occurrence$data()$procedure_end_date[[1]], as.Date("2021-04-05")) +}) From 1e8a2eb16cd82e22a451c70343722a8bde6d7010 Mon Sep 17 00:00:00 2001 From: Ger Inberg Date: Mon, 8 Jun 2026 08:58:26 +0200 Subject: [PATCH 5/5] add observation --- R/cdm54data.R | 3 ++- R/cdmConstructor.R | 13 ++++++---- R/cdmTableClass.R | 4 +++- R/patientsDesigner.R | 36 ++++++++++++++++++++++++++-- inst/d3/cdm_timeline.js | 27 ++++++++++++++++----- tests/testthat/test-cdmConstructor.R | 25 ++++++++++++------- 6 files changed, 86 insertions(+), 22 deletions(-) diff --git a/R/cdm54data.R b/R/cdm54data.R index 85025dc..a0b35f1 100644 --- a/R/cdm54data.R +++ b/R/cdm54data.R @@ -66,7 +66,8 @@ columnNames <- function( "condition_occurrence", "drug_exposure", "measurement", - "procedure_occurrence" + "procedure_occurrence", + "observation" ) if (!is.null(name)) { diff --git a/R/cdmConstructor.R b/R/cdmConstructor.R index 6545ac6..345c704 100644 --- a/R/cdmConstructor.R +++ b/R/cdmConstructor.R @@ -8,12 +8,14 @@ cdmConstructor <- R6::R6Class( condition_occurrence = NULL, measurement = NULL, procedure_occurrence = NULL, + observation = NULL, initialize = function(tables = c( "observation_period", "condition_occurrence", "drug_exposure", "measurement", - "procedure_occurrence" + "procedure_occurrence", + "observation" ) ) { self$tables <- tables @@ -170,7 +172,8 @@ cdmConstructor <- R6::R6Class( "condition_occurrence", "drug_exposure", "measurement", - "procedure_occurrence")) { + "procedure_occurrence", + "observation")) { classTable <- class(jsonData[[tableName]]) table_data <- jsonData[[tableName]] |> as.data.table() if (classTable == "data.frame") { @@ -192,6 +195,7 @@ cdmConstructor <- R6::R6Class( self$condition_occurrence$reset() self$measurement$reset() self$procedure_occurrence$reset() + self$observation$reset() }, # Delete person or event @@ -246,7 +250,8 @@ cdmConstructor <- R6::R6Class( drug_exposure = self$drug_exposure$data(), condition_occurrence = self$condition_occurrence$data(), measurement = self$measurement$data(), - procedure_occurrence = self$procedure_occurrence$data() + procedure_occurrence = self$procedure_occurrence$data(), + observation = self$observation$data() ) cdm_data_json <- jsonlite::toJSON( @@ -359,7 +364,7 @@ cdmConstructor <- R6::R6Class( as.Date("2015-02-28"), 44191562L ) - } else if (private$.tableName == "measurement") { + } else if (private$.tableName %in% c("measurement", "observation")) { # this table has no end date column_names <- column_names |> head(2) values <- list( diff --git a/R/cdmTableClass.R b/R/cdmTableClass.R index 317b801..9129ec5 100644 --- a/R/cdmTableClass.R +++ b/R/cdmTableClass.R @@ -95,6 +95,8 @@ cdmTable <- R6::R6Class( ) if (name == "start" & private$.tableName == "measurement") { table_name_id <- "measurement_date" + } else if (name == "start" & private$.tableName == "observation") { + table_name_id <- "observation_date" } else if (name == "start" & private$.tableName == "procedure_occurrence") { table_name_id <- "procedure_date" } else { @@ -111,4 +113,4 @@ cdmTable <- R6::R6Class( return(table_name_id) } ) - ) \ No newline at end of file + ) diff --git a/R/patientsDesigner.R b/R/patientsDesigner.R index dd613c0..1e89e21 100644 --- a/R/patientsDesigner.R +++ b/R/patientsDesigner.R @@ -118,6 +118,11 @@ patientDesigner <- function(path = NULL) { "Procedure Occurrence", cdmTableUI(id = "procedure_occurrence"), value = "procedure_occurrence_module" + ), + tabPanel( + "Observation", + cdmTableUI(id = "observation"), + value = "observation_module" ) ), tabsetPanel( @@ -138,7 +143,8 @@ patientDesigner <- function(path = NULL) { tableOutput("drugExposureTable"), tableOutput("conditionOccurrenceTable"), tableOutput("measurementTable"), - tableOutput("procedureOccurrenceTable") + tableOutput("procedureOccurrenceTable"), + tableOutput("observationTable") ) ), border = FALSE @@ -340,6 +346,12 @@ patientDesigner <- function(path = NULL) { input_person_id = person_module, session = session ) + updateTableIdsNs( + cdm = cdm, + type = "observation", + input_person_id = person_module, + session = session + ) updateTableIdsNs( cdm = cdm, type = "drug_exposure", @@ -438,6 +450,22 @@ patientDesigner <- function(path = NULL) { cdm$procedure_occurrence$data() }) + # OBSERVATION TABLE + observation_module <- cdmTableServer( + id = "observation", + cdm = cdm, + person_id_selected = person_module, + syncing = syncing + ) + + output$observationTable <- renderTable({ + data_version() + observation_module$add_click() + observation_module$delete_click() + observation_module$elongation_click() + cdm$observation$data() + }) + # CDM Data Timeline cdmDataTimeline <- reactive({ pid <- suppressWarnings(as.numeric(person_module())) @@ -463,6 +491,9 @@ patientDesigner <- function(path = NULL) { procedure_occurrence_module$add_click(), procedure_occurrence_module$delete_click(), procedure_occurrence_module$elongation_click(), + observation_module$add_click(), + observation_module$delete_click(), + observation_module$elongation_click(), ignoreInit = FALSE ) @@ -506,7 +537,8 @@ patientDesigner <- function(path = NULL) { person_id <- update_data$person_id event_id <- update_data$event_id type <- update_data$type - end_date <- if (identical(type, "measurement")) NULL else update_data$end_date + has_end_date <- length(cdm[[type]]$tableNameDate("end")) > 0 + end_date <- if (isTRUE(has_end_date)) update_data$end_date else NULL print("END DATA:") update_data$start_date %>% print() end_date %>% print() diff --git a/inst/d3/cdm_timeline.js b/inst/d3/cdm_timeline.js index 65a2e28..40643eb 100644 --- a/inst/d3/cdm_timeline.js +++ b/inst/d3/cdm_timeline.js @@ -14,6 +14,11 @@ const gap = 12 const axisPad = 12 const labelPad = 8 const measurementMarkerWidth = barHeight +const pointEventTypes = new Set(["measurement", "observation"]) + +function isPointEvent(d) { + return pointEventTypes.has(d.type); +} function formatDate(value) { if (value === null || value === undefined || value === "") { @@ -47,7 +52,7 @@ function tooltipText(d) { } function labelX(scale, d) { - if (d.type === "measurement") { + if (isPointEvent(d)) { return scale(new Date(d.start_date)) - measurementMarkerWidth - labelPad; } @@ -79,6 +84,8 @@ function startColor(d, i) { return "#D81B60"; } else if (d.type == "measurement") { return "#E53935"; + } else if (d.type == "observation") { + return "#8E44AD"; } else if (d.type == "procedure_occurrence") { return "#1E88E5"; } @@ -94,6 +101,8 @@ function dragColor(type) { return "#F06292"; } else if (type == "measurement") { return "#FF6F60"; + } else if (type == "observation") { + return "#B47CD9"; } else if (type == "procedure_occurrence") { return "#64B5F6"; } @@ -109,6 +118,8 @@ function endColor(type) { return "#D81B60"; } else if (type == "measurement") { return "#E53935"; + } else if (type == "observation") { + return "#8E44AD"; } else if (type == "procedure_occurrence") { return "#1E88E5"; } @@ -357,7 +368,11 @@ r2d3.onRender(function(data, svg, width, height, options) { const value_start_date = d3.timeFormat("%Y-%m-%d")(new Date(d.start_date)); - d3.select("#measurement-measurement_date input") + const name_start_date = d.type === "observation" + ? "#observation-observation_date input" + : "#measurement-measurement_date input"; + + d3.select(name_start_date) .property("value", value_start_date) .dispatch("change"); @@ -579,7 +594,7 @@ r2d3.onRender(function(data, svg, width, height, options) { let g = svg.append("g") g.selectAll("rect.rectGroup") - .data(data.filter(d => d.type !== "measurement")) + .data(data.filter(d => !isPointEvent(d))) .enter() .append("rect") .attr("class", d => `rectGroup row_${d.categories}`) @@ -596,7 +611,7 @@ r2d3.onRender(function(data, svg, width, height, options) { .attr("transform", `translate(${margin.left},${margin.top + axisPad})`) g.selectAll("polygon.measurementMarker") - .data(data.filter(d => d.type === "measurement")) + .data(data.filter(d => isPointEvent(d))) .enter() .append("polygon") .attr("class", d => `measurementMarker row_${d.categories}`) @@ -630,7 +645,7 @@ r2d3.onRender(function(data, svg, width, height, options) { .attr("transform", `translate(${margin.left},${margin.top + axisPad})`) g.selectAll("circle.circleRightGroup") - .data(data.filter(d => d.type !== "measurement")) + .data(data.filter(d => !isPointEvent(d))) .enter() .append("circle") .attr("class", d => `circleRightGroup row_${d.categories}`) @@ -643,7 +658,7 @@ r2d3.onRender(function(data, svg, width, height, options) { .attr("transform", `translate(${margin.left},${margin.top + axisPad})`) g.selectAll("circle.circleLeftGroup") - .data(data.filter(d => d.type !== "measurement")) + .data(data.filter(d => !isPointEvent(d))) .enter() .append("circle") .attr("class", d => `circleLeftGroup row_${d.categories}`) diff --git a/tests/testthat/test-cdmConstructor.R b/tests/testthat/test-cdmConstructor.R index 028e5ce..c966ea0 100644 --- a/tests/testthat/test-cdmConstructor.R +++ b/tests/testthat/test-cdmConstructor.R @@ -18,7 +18,8 @@ test_that("Initialize correctly tables defined in the parameter", { "drug_exposure", "condition_occurrence", "measurement", - "procedure_occurrence" + "procedure_occurrence", + "observation" ) cdm <- cdmConstructor$new(tables = tables) @@ -47,7 +48,8 @@ test_that("cdmConstructor reset empties core tables", { "condition_occurrence", "drug_exposure", "measurement", - "procedure_occurrence" + "procedure_occurrence", + "observation" ) for (i in seq_along(cdm_tables)) { @@ -122,7 +124,8 @@ test_that("observation/condition/drug/measurement/procedure_occurrence update da "condition_occurrence", "drug_exposure", "measurement", - "procedure_occurrence" + "procedure_occurrence", + "observation" ) # Add 1 person to all data tables @@ -174,7 +177,8 @@ test_that("getCdmData and getCdmDataTimeline return valid structures", { "condition_occurrence", "drug_exposure", "measurement", - "procedure_occurrence" + "procedure_occurrence", + "observation" ) # Add 1 person to all data tables @@ -191,6 +195,7 @@ test_that("getCdmData and getCdmDataTimeline return valid structures", { jsonlite::validate(cdm_json) ) expect_true("measurement" %in% names(jsonlite::fromJSON(cdm_json))) + expect_true("observation" %in% names(jsonlite::fromJSON(cdm_json))) timeline <- cdm$getCdmDataTimeline() expect_s3_class( @@ -213,7 +218,8 @@ test_that("getCdmData and getCdmDataTimeline return valid structures", { "drug_exposure", "condition_occurrence", "measurement", - "procedure_occurrence" + "procedure_occurrence", + "observation" ) ) }) @@ -352,7 +358,8 @@ test_that("Testing methods on LLM testset", { "condition_occurrence", "drug_exposure", "measurement", - "procedure_occurrence" + "procedure_occurrence", + "observation" ) expect_no_error({ @@ -399,7 +406,8 @@ test_that("Testing modified test from LLM can be inserted back to TestGenerator" "condition_occurrence", "drug_exposure", "measurement", - "procedure_occurrence" + "procedure_occurrence", + "observation" ) # Load into memory and modify all fields expect_no_error({ @@ -466,7 +474,8 @@ test_that("Testing methods on LLM testset 'objective_1_patient'", { "condition_occurrence", "drug_exposure", "measurement", - "procedure_occurrence" + "procedure_occurrence", + "observation" ) expect_no_error({