SDTM DM/SUPPDM Mini DEMO

Install and Load Package

install.packages('pacman')

pacman::p_load(haven, dplyr,tidyr,tibble, purrr,readr, glue, lubridate,stringr, EDCimport, logger, validate)

Upload the following raw datasets/exports needed to program SDTM.DM:

# path <- "C:/Users/Waraba/Desktop/R in CDISC _ Jupyter Lab/rawdata"

# db <- read_all_xpt(path, format_file = NULL)  # XPT
# db <- read_all_sas(path)                    # SAS7BDAT
# db <- read_all_csv(path)                    # CSV
# load_database(db)   # puts each table into your environment

demog        <-   read_xpt("DEMOG.xpt")
ipadmin      <-   read_xpt("IPADMIN.xpt")
eos          <-   read_xpt("EOS.xpt")
enrlment     <-   read_xpt("ENRLMENT.xpt")
rand         <-   read_xpt("RAND.xpt")
box          <-   read_xpt("BOX.xpt")
adverse      <-   read_xpt("ADVERSE.xpt")
conmeds      <-   read_xpt("CONMEDS.xpt")
ecg          <-   read_xpt("ECG.xpt")
eoip         <-   read_xpt("EOIP.xpt")
eq5d3l       <-   read_xpt("EQ5D3L.xpt")
hosp         <-   read_xpt("HOSP.xpt")
lab_chem     <-   read_xpt("LAB_CHEM.xpt")
lab_hema     <-   read_xpt("LAB_HEMA.xpt")
physmeas     <-   read_xpt("PHYSMEAS.xpt")
surg         <-   read_xpt("SURG.xpt")
vitals       <-   read_xpt("VITALS.xpt")

Map: Domain, studyid, subjid, siteid, usubjid, country, ethnic, race using raw.demog

demog

A tibble: 8 × 13

study	pt	sex	ethnic	race	race2	race3	race4	racesp	age_raw	age_rawu	brthdt_raw	country
<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>
STU001	1001	Male	Hispanic or Latino	White					35	Years		USA
STU001	1002	Female	Not Hispanic or Latino	Asian	American Indian or Alaska Native				40	Years		USA
STU001	1003	Male	Hispanic or Latino	Other				BRAZILIAN	40	Years		USA
STU001	1004	Male	Hispanic or Latino	White					38	Years		USA
STU001	1005	Male	Not Hispanic or Latino	American Indian or Alaska Native					64	Years		USA
STU001	1006	Female	Not Hispanic or Latino	Native Hawaiian or Other Pacific Islander					75	Years		USA
STU001	1007	Male	Not Hispanic or Latino	Unknown					32	Years		USA
STU001	1008	Female	Not Hispanic or Latino	Not Reported					83	Years		USA

demo1 <- demog %>%
        rename(race1=race) %>%
        mutate(
        nmiss_count = rowSums(across(c(race1, race2, race3, race4), ~ !is.na(.) & . != "")),   # To count how races were selected
        race = ifelse(nmiss_count > 1, "MULTIPLE", toupper(coalesce(race1, race2, race3, race4))),
        racesp = racesp,
        race1 = ifelse(nmiss_count > 1,toupper(race1),""),
        race2 = ifelse(nmiss_count > 1,toupper(race2),""),
        race3 = ifelse(nmiss_count > 1,toupper(race3),""),
        race4 = ifelse(nmiss_count > 1,toupper(race4),""),   
    
        age = ifelse(!is.na(age_raw), as.integer(age_raw), NA_integer_),
        ageu = toupper(age_rawu),
            
        sex = ifelse(sex == "Female", "F", ifelse(sex == "Male", "M", sex)),
        siteid = substr(pt, 1, 2),
        usubjid = paste(study, pt, sep = "-"),
       
        domain = "DM",
        studyid = study,
        subjid = pt,
        country = country,
        ethnic = toupper(ethnic)
        )
demo1

A tibble: 8 × 22

study	pt	sex	ethnic	race1	race2	race3	race4	racesp	age_raw	⋯	country	nmiss_count	race	age	ageu	siteid	usubjid	domain	studyid	subjid
<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	⋯	<chr>	<dbl>	<chr>	<int>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>
STU001	1001	M	HISPANIC OR LATINO						35	⋯	USA	1	WHITE	35	YEARS	10	STU001-1001	DM	STU001	1001
STU001	1002	F	NOT HISPANIC OR LATINO	ASIAN	AMERICAN INDIAN OR ALASKA NATIVE				40	⋯	USA	2	MULTIPLE	40	YEARS	10	STU001-1002	DM	STU001	1002
STU001	1003	M	HISPANIC OR LATINO					BRAZILIAN	40	⋯	USA	1	OTHER	40	YEARS	10	STU001-1003	DM	STU001	1003
STU001	1004	M	HISPANIC OR LATINO						38	⋯	USA	1	WHITE	38	YEARS	10	STU001-1004	DM	STU001	1004
STU001	1005	M	NOT HISPANIC OR LATINO						64	⋯	USA	1	AMERICAN INDIAN OR ALASKA NATIVE	64	YEARS	10	STU001-1005	DM	STU001	1005
STU001	1006	F	NOT HISPANIC OR LATINO						75	⋯	USA	1	NATIVE HAWAIIAN OR OTHER PACIFIC ISLANDER	75	YEARS	10	STU001-1006	DM	STU001	1006
STU001	1007	M	NOT HISPANIC OR LATINO						32	⋯	USA	1	UNKNOWN	32	YEARS	10	STU001-1007	DM	STU001	1007
STU001	1008	F	NOT HISPANIC OR LATINO						83	⋯	USA	1	NOT REPORTED	83	YEARS	10	STU001-1008	DM	STU001	1008

Derive disposition related variables rficdtc, rfendtc, dthdtc

rficdtc <- enrlment %>%
 mutate(
 rficdtc = ifelse(!is.na(icdt_raw), format(as.Date(icdt_raw, format = "%d/%b/%Y"),"%Y-%m-%d"), NA),
 enrldtc = ifelse(!is.na(enrldt_raw), format(as.Date(enrldt_raw, format = "%d/%b/%Y"),"%Y-%m-%d"), NA),
 randdtc = ifelse(!is.na(randdt_raw), format(as.Date(randdt_raw, format = "%d/%b/%Y"),"%Y-%m-%d"), NA)
 ) %>%
 select(study, pt, rficdtc, enrldtc, randdtc)
 
rfendtc <- eos %>%
 filter(eoscat == "End of Study") %>%
 mutate(rfendtc = ifelse(!is.na(eostdt_raw), format(as.Date(eostdt_raw, format = "%d/%b/%Y"),"%Y-%m-%d"), NA)) %>%
 select(study, pt, rfendtc)
 
dthdtc <- eos %>%
 filter(eoscat == "End of Study" & eoterm == "Death") %>%
 mutate(dthdtc = ifelse(!is.na(eostdt_raw), format(as.Date(eostdt_raw, format = "%d/%b/%Y"),"%Y-%m-%d"), NA), dthfl = "Y") %>%
 select(study, pt, dthdtc, dthfl)

Map Exposure Related Variables: rfxstdtc, rfxendtc

ipadmin

A tibble: 16 × 10

study	pt	folder	ipconc	ipstdt_raw	ipsttm_raw	ipqty_raw	ipqtyu	ipadj	ipboxid
<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>
STU001	1004	WEEK 1	500	05/JAN/2010	8:35	2	mL		13434371
STU001	1004	WEEK 2	500	12/JAN/2010	8:35	2	mL		52970539
STU001	1004	WEEK 3	500	18/JAN/2010	9:30	1	mL	Adverse Event	52120567
STU001	1004	WEEK 4	500	25/JAN/2010	8:45	2	mL		59305202
STU001	1005	WEEK 1	500	05/FEB/2010	8:46	2	mL		13787377
STU001	1005	WEEK 2	500	12/FEB/2010	8:30	2	mL		65580239
STU001	1005	WEEK 3	500	19/FEB/2010	8:15	0	mL	Adverse Event	45377264
STU001	1006	WEEK 1	500	2/MAR/2010	8:30	1.9	mL		39024101
STU001	1006	WEEK 2	500	10/MAR/2010	8:30	2	mL		65845489
STU001	1007	WEEK 1	500	15/APR/2010	8:23	2	mL		66223983
STU001	1007	WEEK 2	500	22/APR/2010	9:00	2	mL		71763169
STU001	1007	WEEK 3	500	29/APR/2010	9:03	2	mL		60038358
STU001	1007	WEEK 4	500	6/MAY/2010	8:12	2	mL		68706162
STU001	1008	WEEK 1	500	27/JUN/2010	8:45	2	mL		68891589
STU001	1008	WEEK 2	500	4/JUL/2010	8:17	2	mL		2311359
STU001	1008	WEEK 3	500	11/JUL/2010	9:20	2	mL		3199027

expodate1 <- ipadmin %>%
    filter(as.integer(ipqty_raw) > 0) %>%

    mutate(
    ipstdtc = as.Date(ipstdt_raw, format = "%d/%b/%Y"),
    ipsttm = format(as.POSIXct(ipsttm_raw, format = "%H:%M", tz = ""),"%H:%M"),
    infudtc = paste(ipstdtc, ipsttm, sep = "T")
 ) %>%

select(study, pt, infudtc, ipboxid)

expodate1

A tibble: 15 × 4

study	pt	infudtc	ipboxid
<chr>	<chr>	<chr>	<chr>
STU001	1004	2010-01-05T08:35	13434371
STU001	1004	2010-01-12T08:35	52970539
STU001	1004	2010-01-18T09:30	52120567
STU001	1004	2010-01-25T08:45	59305202
STU001	1005	2010-02-05T08:46	13787377
STU001	1005	2010-02-12T08:30	65580239
STU001	1006	2010-03-02T08:30	39024101
STU001	1006	2010-03-10T08:30	65845489
STU001	1007	2010-04-15T08:23	66223983
STU001	1007	2010-04-22T09:00	71763169
STU001	1007	2010-04-29T09:03	60038358
STU001	1007	2010-05-06T08:12	68706162
STU001	1008	2010-06-27T08:45	68891589
STU001	1008	2010-07-04T08:17	2311359
STU001	1008	2010-07-11T09:20	3199027

#Earliest treatment date
rfxstdtc <- expodate1 %>%
    arrange(study,pt,infudtc) %>%
    group_by(study, pt) %>%
    slice(1) %>%
    mutate(rfxstdtc = infudtc)
rfxstdtc

A grouped_df: 5 × 5

study	pt	infudtc	ipboxid	rfxstdtc
<chr>	<chr>	<chr>	<chr>	<chr>
STU001	1004	2010-01-05T08:35	13434371	2010-01-05T08:35
STU001	1005	2010-02-05T08:46	13787377	2010-02-05T08:46
STU001	1006	2010-03-02T08:30	39024101	2010-03-02T08:30
STU001	1007	2010-04-15T08:23	66223983	2010-04-15T08:23
STU001	1008	2010-06-27T08:45	68891589	2010-06-27T08:45

#Late treatment date
rfxendtc <- expodate1 %>%
    arrange(study,pt,infudtc) %>%
    group_by(study, pt) %>%
    slice(n()) %>%
    mutate(rfxendtc = infudtc)
rfxendtc

A grouped_df: 5 × 5

study	pt	infudtc	ipboxid	rfxendtc
<chr>	<chr>	<chr>	<chr>	<chr>
STU001	1004	2010-01-25T08:45	59305202	2010-01-25T08:45
STU001	1005	2010-02-12T08:30	65580239	2010-02-12T08:30
STU001	1006	2010-03-10T08:30	65845489	2010-03-10T08:30
STU001	1007	2010-05-06T08:12	68706162	2010-05-06T08:12
STU001	1008	2010-07-11T09:20	3199027	2010-07-11T09:20

Derive Planned and Actual Arm related variables

enrlment

A tibble: 8 × 9

study	pt	folder	icdt_raw	icvers	prtvers	enrldt_raw	randdt_raw	randno
<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>
STU001	1001	SCR	1/JAN/2010	1	1
STU001	1002	SCR	1/JAN/2010	1	1	4/JAN/2010
STU001	1003	SCR	1/JAN/2010	1	1	3/JAN/2010	3/JAN/2010	514876
STU001	1004	SCR	1/JAN/2010	1	1	4/JAN/2010	5/JAN/2010	101415
STU001	1005	SCR	15/JAN/2010	1	1	1/FEB/2010	5/FEB/2010	306185
STU001	1006	SCR	18/FEB/2010	1	1	1/MAR/2010	1/MAR/2010	987435
STU001	1007	SCR	4/APR/2010	2	2	14/APR/2010	14/APR/2010	098745
STU001	1008	SCR	20/JUN/2010	2	3	26/JUN/2010	27/JUN/2010	123098

randno <- enrlment %>%
    filter(!is.na(randno) & randno!="") %>%
    select(study, pt, randno)

randno

A tibble: 6 × 3

study	pt	randno
<chr>	<chr>	<chr>
STU001	1003	514876
STU001	1004	101415
STU001	1005	306185
STU001	1006	987435
STU001	1007	098745
STU001	1008	123098

rand

A tibble: 6 × 4

rand_id	tx_cd	cohort	strata
<chr>	<chr>	<chr>	<chr>
514876	PBO	1	Dummy strata1
101415	ACTIVE	1	Dummy strata1
306185	ACTIVE	1	Dummy strata1
987435	PBO	2	Dummy strata2
098745	PBO	2	Dummy strata2
123098	ACTIVE	2	Dummy strata2

randtrt <- rand %>%
    mutate(
    armcd = tx_cd,
    arm = ifelse(armcd == "ACTIVE", "Active", ifelse(armcd == "PBO", "Placebo", NA_character_))
) %>%
select(armcd, arm, randno=rand_id)
randtrt

A tibble: 6 × 3

armcd	arm	randno
<chr>	<chr>	<chr>
PBO	Placebo	514876
ACTIVE	Active	101415
ACTIVE	Active	306185
PBO	Placebo	987435
PBO	Placebo	098745
ACTIVE	Active	123098

Merge

armdata <- randno %>%
left_join(randtrt, by = "randno")

armdata

A tibble: 6 × 5

study	pt	randno	armcd	arm
<chr>	<chr>	<chr>	<chr>	<chr>
STU001	1003	514876	PBO	Placebo
STU001	1004	101415	ACTIVE	Active
STU001	1005	306185	ACTIVE	Active
STU001	1006	987435	PBO	Placebo
STU001	1007	098745	PBO	Placebo
STU001	1008	123098	ACTIVE	Active

Derive actual ARM related variable

actarmcode <- rfxstdtc
actarmcode

A grouped_df: 5 × 5

study	pt	infudtc	ipboxid	rfxstdtc
<chr>	<chr>	<chr>	<chr>	<chr>
STU001	1004	2010-01-05T08:35	13434371	2010-01-05T08:35
STU001	1005	2010-02-05T08:46	13787377	2010-02-05T08:46
STU001	1006	2010-03-02T08:30	39024101	2010-03-02T08:30
STU001	1007	2010-04-15T08:23	66223983	2010-04-15T08:23
STU001	1008	2010-06-27T08:45	68891589	2010-06-27T08:45

Box data for mapping actual arm

box

A tibble: 16 × 2

kitid	content
<chr>	<chr>
13434371	ACTIVE
52970539	ACTIVE
52120567	ACTIVE
59305202	ACTIVE
13787377	PBO
65580239	ACTIVE
45377264	ACTIVE
39024101	PBO
65845489	PBO
66223983	PBO
71763169	PBO
60038358	PBO
68706162	PBO
68891589	ACTIVE
2311359	ACTIVE
3199027	ACTIVE

boxdata <- box %>%
    mutate(
    ipboxid = kitid,
    actarmcd = case_when(
        content == "ACTIVE" ~ "ACTIVE",
        content == "PBO" ~ "PBO",
        TRUE ~ NA_character_
     ),

    actarm = case_when(
        content == "ACTIVE" ~ "Active",
        content == "PBO" ~ "Placebo",
        TRUE ~ NA_character_)
)
boxdata

A tibble: 16 × 5

kitid	content	ipboxid	actarmcd	actarm
<chr>	<chr>	<chr>	<chr>	<chr>
13434371	ACTIVE	13434371	ACTIVE	Active
52970539	ACTIVE	52970539	ACTIVE	Active
52120567	ACTIVE	52120567	ACTIVE	Active
59305202	ACTIVE	59305202	ACTIVE	Active
13787377	PBO	13787377	PBO	Placebo
65580239	ACTIVE	65580239	ACTIVE	Active
45377264	ACTIVE	45377264	ACTIVE	Active
39024101	PBO	39024101	PBO	Placebo
65845489	PBO	65845489	PBO	Placebo
66223983	PBO	66223983	PBO	Placebo
71763169	PBO	71763169	PBO	Placebo
60038358	PBO	60038358	PBO	Placebo
68706162	PBO	68706162	PBO	Placebo
68891589	ACTIVE	68891589	ACTIVE	Active
2311359	ACTIVE	2311359	ACTIVE	Active
3199027	ACTIVE	3199027	ACTIVE	Active

Merge 'actarmcode' and 'boxdata' data frames by 'ipboxid'

actarmdata <- left_join(
                    actarmcode, boxdata, by = "ipboxid") %>%
              filter(!is.na(actarmcd)) %>%
              select(study, pt, actarmcd, actarm)

actarmdata

A grouped_df: 5 × 4

study	pt	actarmcd	actarm
<chr>	<chr>	<chr>	<chr>
STU001	1004	ACTIVE	Active
STU001	1005	PBO	Placebo
STU001	1006	PBO	Placebo
STU001	1007	PBO	Placebo
STU001	1008	ACTIVE	Active

Reference End of participation
Combine the raw date variables into 'combdate' data frame

hospc <-hosp %>% mutate(
    study = as.character(study))

combdate <- bind_rows(
 adverse %>% select(study, pt, date = aestdt_raw),
 adverse %>% select(study, pt, date = aeendt_raw),
 adverse %>% select(study, pt, date = hadmtdt_raw),
 adverse %>% select(study, pt, date = hdsdt_raw),
 conmeds %>% select(study, pt, date = cmstdt_raw),
 conmeds %>% select(study, pt, date = cmendt_raw),
 ecg %>% select(study, pt, date = egdt_raw),
 enrlment %>% select(study, pt, date = icdt_raw),
 enrlment %>% select(study, pt, date = enrldt_raw),
 enrlment %>% select(study, pt, date = randdt_raw),

 eos %>% select(study, pt, date = eostdt_raw),
 eoip %>% select(study, pt, date = eostdt_raw),
 eq5d3l %>% select(study, pt, date = dt_raw),


 ipadmin %>% select(study, pt, date = ipstdt_raw),
 lab_chem %>% select(study, pt, date = lbdt_raw),
 lab_hema %>% select(study, pt, date = lbdt_raw),
 physmeas %>% select(study, pt, date = pmdt_raw),
 surg %>% select(study, pt, date = surgdt_raw),
 vitals %>% select(study, pt, date = vsdt_raw)
)
combdate

A tibble: 953 × 3

study	pt	date
<chr>	<chr>	<chr>
STU001	1001	01/JAN/2010
STU001	1003	05/JAN/2010
STU001	1004	01/JAN/2010
STU001	1004	03/JAN/2010
STU001	1004	08/JAN/2010
STU001	1004	10/JAN/2010
STU001	1005	18/FEB/2010
STU001	1006	UN/MAR/2010
STU001	1007	9/MAY/2010
STU001	1001	01/JAN/2010
STU001	1003	05/JAN/2010
STU001	1004	01/JAN/2010
STU001	1004	07/JAN/2010
STU001	1004	09/JAN/2010
STU001	1004
STU001	1005	21/FEB/2010
STU001	1006	25/MAR/2010
STU001	1007	12/MAY/2010
STU001	1001
STU001	1003	5/JAN/2010
STU001	1004
STU001	1004
STU001	1004
STU001	1004
STU001	1005	20/FEB/2020
STU001	1006
STU001	1007
STU001	1001
STU001	1003	5/JAN/2010
STU001	1004
⋮	⋮	⋮
STU001	1008	11/Jul/2010
STU001	1008	11/Jul/2010
STU001	1008	11/Jul/2010
STU001	1008	11/Jul/2010
STU001	1008	11/Jul/2010
STU001	1008	11/Jul/2010
STU001	1008	11/Jul/2010
STU001	1008	11/Jul/2010
STU001	1008	11/Jul/2010
STU001	1008	11/Jul/2010
STU001	1008	11/Jul/2010
STU001	1008	11/Jul/2010
STU001	1008	11/Jul/2010
STU001	1008	11/Jul/2010
STU001	1008	11/Jul/2010
STU001	1008	11/Jul/2010
STU001	1004	4/JAN/2010
STU001	1005	5/FEB/2010
STU001	1006	1/MAR/2010
STU001	1007	13/APR/2010
STU001	1005	20/FEB/2010
STU001	1004	02/JAN/2010
STU001	1004	12/JAN/2010
STU001	1005	5/FEB/2010
STU001	1005	12/FEB/2010
STU001	1005	22/FEB/2010
STU001	1006	01/MAR/2010
STU001	1006	11/MAR/2010
STU001	1007	15/APR/2010
STU001	1007	29/APR/2010

Process the date variables to create date in ISO format in 'alldates02' data frame

combdate01 <- combdate %>%
         mutate(
             dayn = suppressWarnings(as.integer(stringr::word(date, 1, sep = "/"))),
             day = if_else(!is.na(dayn), sprintf("%02d", dayn), "-"),
             monthc = toupper(word(date, 2, sep='/')),
             month = case_when(
             monthc == "JAN" ~ "01",
             monthc == "FEB" ~ "02",
             monthc == "MAR" ~ "03",
             monthc == "APR" ~ "04",
             monthc == "MAY" ~ "05",
             monthc == "JUN" ~ "06",
             monthc == "JUL" ~ "07",
             monthc == "AUG" ~ "08",
             monthc == "SEP" ~ "09",
             monthc == "OCT" ~ "10",
             monthc == "NOV" ~ "11",
             monthc == "DEC" ~ "12",
             TRUE ~ "-"
         ),
             
         year = word(date,3,sep='/'),
         year = if_else(toupper(year) == "UNK", "-", year),
             
         datec = str_c(year, month, day, sep = "-"),
         datec = ifelse(str_sub(datec, -5) == "-----", str_sub(datec, end = -6), datec),
         datec = ifelse(str_sub(datec, -4) == "----",  str_sub(datec, end = -5), datec),
         datec = ifelse(str_sub(datec, -2) == "--",    str_sub(datec, end = -3), datec)
)
 
combdate01

A tibble: 953 × 9

study	pt	date	dayn	day	monthc	month	year	datec
<chr>	<chr>	<chr>	<int>	<chr>	<chr>	<chr>	<chr>	<chr>
STU001	1001	01/JAN/2010	1	01	JAN	01	2010	2010-01-01
STU001	1003	05/JAN/2010	5	05	JAN	01	2010	2010-01-05
STU001	1004	01/JAN/2010	1	01	JAN	01	2010	2010-01-01
STU001	1004	03/JAN/2010	3	03	JAN	01	2010	2010-01-03
STU001	1004	08/JAN/2010	8	08	JAN	01	2010	2010-01-08
STU001	1004	10/JAN/2010	10	10	JAN	01	2010	2010-01-10
STU001	1005	18/FEB/2010	18	18	FEB	02	2010	2010-02-18
STU001	1006	UN/MAR/2010	NA	-	MAR	03	2010	2010-03
STU001	1007	9/MAY/2010	9	09	MAY	05	2010	2010-05-09
STU001	1001	01/JAN/2010	1	01	JAN	01	2010	2010-01-01
STU001	1003	05/JAN/2010	5	05	JAN	01	2010	2010-01-05
STU001	1004	01/JAN/2010	1	01	JAN	01	2010	2010-01-01
STU001	1004	07/JAN/2010	7	07	JAN	01	2010	2010-01-07
STU001	1004	09/JAN/2010	9	09	JAN	01	2010	2010-01-09
STU001	1004		NA	-	NA	-	NA	NA
STU001	1005	21/FEB/2010	21	21	FEB	02	2010	2010-02-21
STU001	1006	25/MAR/2010	25	25	MAR	03	2010	2010-03-25
STU001	1007	12/MAY/2010	12	12	MAY	05	2010	2010-05-12
STU001	1001		NA	-	NA	-	NA	NA
STU001	1003	5/JAN/2010	5	05	JAN	01	2010	2010-01-05
STU001	1004		NA	-	NA	-	NA	NA
STU001	1004		NA	-	NA	-	NA	NA
STU001	1004		NA	-	NA	-	NA	NA
STU001	1004		NA	-	NA	-	NA	NA
STU001	1005	20/FEB/2020	20	20	FEB	02	2020	2020-02-20
STU001	1006		NA	-	NA	-	NA	NA
STU001	1007		NA	-	NA	-	NA	NA
STU001	1001		NA	-	NA	-	NA	NA
STU001	1003	5/JAN/2010	5	05	JAN	01	2010	2010-01-05
STU001	1004		NA	-	NA	-	NA	NA
⋮	⋮	⋮	⋮	⋮	⋮	⋮	⋮	⋮
STU001	1008	11/Jul/2010	11	11	JUL	07	2010	2010-07-11
STU001	1008	11/Jul/2010	11	11	JUL	07	2010	2010-07-11
STU001	1008	11/Jul/2010	11	11	JUL	07	2010	2010-07-11
STU001	1008	11/Jul/2010	11	11	JUL	07	2010	2010-07-11
STU001	1008	11/Jul/2010	11	11	JUL	07	2010	2010-07-11
STU001	1008	11/Jul/2010	11	11	JUL	07	2010	2010-07-11
STU001	1008	11/Jul/2010	11	11	JUL	07	2010	2010-07-11
STU001	1008	11/Jul/2010	11	11	JUL	07	2010	2010-07-11
STU001	1008	11/Jul/2010	11	11	JUL	07	2010	2010-07-11
STU001	1008	11/Jul/2010	11	11	JUL	07	2010	2010-07-11
STU001	1008	11/Jul/2010	11	11	JUL	07	2010	2010-07-11
STU001	1008	11/Jul/2010	11	11	JUL	07	2010	2010-07-11
STU001	1008	11/Jul/2010	11	11	JUL	07	2010	2010-07-11
STU001	1008	11/Jul/2010	11	11	JUL	07	2010	2010-07-11
STU001	1008	11/Jul/2010	11	11	JUL	07	2010	2010-07-11
STU001	1008	11/Jul/2010	11	11	JUL	07	2010	2010-07-11
STU001	1004	4/JAN/2010	4	04	JAN	01	2010	2010-01-04
STU001	1005	5/FEB/2010	5	05	FEB	02	2010	2010-02-05
STU001	1006	1/MAR/2010	1	01	MAR	03	2010	2010-03-01
STU001	1007	13/APR/2010	13	13	APR	04	2010	2010-04-13
STU001	1005	20/FEB/2010	20	20	FEB	02	2010	2010-02-20
STU001	1004	02/JAN/2010	2	02	JAN	01	2010	2010-01-02
STU001	1004	12/JAN/2010	12	12	JAN	01	2010	2010-01-12
STU001	1005	5/FEB/2010	5	05	FEB	02	2010	2010-02-05
STU001	1005	12/FEB/2010	12	12	FEB	02	2010	2010-02-12
STU001	1005	22/FEB/2010	22	22	FEB	02	2010	2010-02-22
STU001	1006	01/MAR/2010	1	01	MAR	03	2010	2010-03-01
STU001	1006	11/MAR/2010	11	11	MAR	03	2010	2010-03-11
STU001	1007	15/APR/2010	15	15	APR	04	2010	2010-04-15
STU001	1007	29/APR/2010	29	29	APR	04	2010	2010-04-29

Pick the latest non-missing date for each subject

rfpendtc <- combdate01 %>%
         filter(!is.na(datec) & datec != "") %>%
         arrange(study, pt, datec) %>%
         group_by(study, pt) %>%
         slice(n()) %>%
         ungroup() %>%

         select(study, pt, rfpendtc = datec)
rfpendtc

A tibble: 8 × 3

study	pt	rfpendtc
<chr>	<chr>	<chr>
STU001	1001	2010-01-01
STU001	1002	2010-01-05
STU001	1003	2010-01-05
STU001	1004	2010-02-28
STU001	1005	2020-02-20
STU001	1006	2010-03-25
STU001	1007	2010-06-12
STU001	1008	2010-08-18

Merge all datasets together

demo2 <- demo1 %>%
             left_join(rficdtc, by = c("study", "pt")) %>%
             left_join(dthdtc, by = c("study", "pt")) %>%
             left_join(rfendtc, by = c("study", "pt")) %>%
             left_join(rfxstdtc, by = c("study", "pt")) %>%
             left_join(rfxendtc, by = c("study", "pt")) %>%
             left_join(actarmdata, by = c("study", "pt")) %>%
             left_join(armdata, by = c("study", "pt")) %>%
             left_join(rfpendtc, by = c("study", "pt"))

demo2

A tibble: 8 × 40

study	pt	sex	ethnic	race1	race2	race3	race4	racesp	age_raw	⋯	rfxstdtc	infudtc.y	ipboxid.y	rfxendtc	actarmcd	actarm	randno	armcd	arm	rfpendtc
<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	⋯	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>
STU001	1001	M	HISPANIC OR LATINO						35	⋯	NA	NA	NA	NA	NA	NA	NA	NA	NA	2010-01-01
STU001	1002	F	NOT HISPANIC OR LATINO	ASIAN	AMERICAN INDIAN OR ALASKA NATIVE				40	⋯	NA	NA	NA	NA	NA	NA	NA	NA	NA	2010-01-05
STU001	1003	M	HISPANIC OR LATINO					BRAZILIAN	40	⋯	NA	NA	NA	NA	NA	NA	514876	PBO	Placebo	2010-01-05
STU001	1004	M	HISPANIC OR LATINO						38	⋯	2010-01-05T08:35	2010-01-25T08:45	59305202	2010-01-25T08:45	ACTIVE	Active	101415	ACTIVE	Active	2010-02-28
STU001	1005	M	NOT HISPANIC OR LATINO						64	⋯	2010-02-05T08:46	2010-02-12T08:30	65580239	2010-02-12T08:30	PBO	Placebo	306185	ACTIVE	Active	2020-02-20
STU001	1006	F	NOT HISPANIC OR LATINO						75	⋯	2010-03-02T08:30	2010-03-10T08:30	65845489	2010-03-10T08:30	PBO	Placebo	987435	PBO	Placebo	2010-03-25
STU001	1007	M	NOT HISPANIC OR LATINO						32	⋯	2010-04-15T08:23	2010-05-06T08:12	68706162	2010-05-06T08:12	PBO	Placebo	098745	PBO	Placebo	2010-06-12
STU001	1008	F	NOT HISPANIC OR LATINO						83	⋯	2010-06-27T08:45	2010-07-11T09:20	3199027	2010-07-11T09:20	ACTIVE	Active	123098	ACTIVE	Active	2010-08-18

Derive additional variables that depend on previously derived variables.

demo3 <- demo2 %>%
         mutate(
             rfstdtc = substr(rfxstdtc, 1, 10),
             rfstdtc = ifelse(is.na(rfstdtc) & !is.na(randdtc), randdtc, rfstdtc),
             rfstdtc = ifelse(is.na(rfstdtc) & !is.na(rficdtc), rficdtc, rfstdtc),
 
             armcd = case_when(
                         is.na(enrldtc) ~ "SCRNFAIL",
                         is.na(randdtc) ~ "NOTASSGN",
                         TRUE ~ armcd),
             arm =   case_when(
                         armcd =="SCRNFAIL" ~ "Screen Failure",
                         armcd == "NOTASSGN" ~ "Not Assigned",
                         TRUE ~ arm),
             actarmcd = case_when(
                         is.na(enrldtc) ~ "SCRNFAIL",
                         is.na(randdtc) ~ "NOTASSGN",
                         is.na(rfxstdtc) ~ "NOTTRT",
                         TRUE ~ actarmcd),
 
             actarm = case_when(
                     actarmcd =="SCRNFAIL" ~ "Screen Failure",
                     actarmcd == "NOTASSGN" ~ "Not Assigned",
                     actarmcd == "NOTTRT" ~ "Not Treated",
                     TRUE ~ actarm)) %>%
 rename_all(toupper)

demo3

A tibble: 8 × 41

STUDY	PT	SEX	ETHNIC	RACE1	RACE2	RACE3	RACE4	RACESP	AGE_RAW	⋯	INFUDTC.Y	IPBOXID.Y	RFXENDTC	ACTARMCD	ACTARM	RANDNO	ARMCD	ARM	RFPENDTC	RFSTDTC
<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	⋯	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>
STU001	1001	M	HISPANIC OR LATINO						35	⋯	NA	NA	NA	SCRNFAIL	Screen Failure	NA	SCRNFAIL	Screen Failure	2010-01-01	2010-01-01
STU001	1002	F	NOT HISPANIC OR LATINO	ASIAN	AMERICAN INDIAN OR ALASKA NATIVE				40	⋯	NA	NA	NA	NOTASSGN	Not Assigned	NA	NOTASSGN	Not Assigned	2010-01-05	2010-01-01
STU001	1003	M	HISPANIC OR LATINO					BRAZILIAN	40	⋯	NA	NA	NA	NOTTRT	Not Treated	514876	PBO	Placebo	2010-01-05	2010-01-03
STU001	1004	M	HISPANIC OR LATINO						38	⋯	2010-01-25T08:45	59305202	2010-01-25T08:45	ACTIVE	Active	101415	ACTIVE	Active	2010-02-28	2010-01-05
STU001	1005	M	NOT HISPANIC OR LATINO						64	⋯	2010-02-12T08:30	65580239	2010-02-12T08:30	PBO	Placebo	306185	ACTIVE	Active	2020-02-20	2010-02-05
STU001	1006	F	NOT HISPANIC OR LATINO						75	⋯	2010-03-10T08:30	65845489	2010-03-10T08:30	PBO	Placebo	987435	PBO	Placebo	2010-03-25	2010-03-02
STU001	1007	M	NOT HISPANIC OR LATINO						32	⋯	2010-05-06T08:12	68706162	2010-05-06T08:12	PBO	Placebo	098745	PBO	Placebo	2010-06-12	2010-04-15
STU001	1008	F	NOT HISPANIC OR LATINO						83	⋯	2010-07-11T09:20	3199027	2010-07-11T09:20	ACTIVE	Active	123098	ACTIVE	Active	2010-08-18	2010-06-27

Write attributes and keep only required variables and in the required order

varlist <- c(
 'STUDYID', 'DOMAIN', 'USUBJID', 'SUBJID', 'RFSTDTC', 'RFENDTC', 'RFXSTDTC', 'RFXENDTC',
 'RFICDTC', 'RFPENDTC', 'DTHDTC', 'DTHFL', 'SITEID', 'AGE', 'AGEU', 'SEX', 'RACE', 'ETHNIC',
 'ARMCD', 'ARM', 'ACTARMCD', 'ACTARM', 'COUNTRY', 'RACE1', 'RACE2', 'RACE3', 'RACE4', 'RACESP'
)

dm <- demo3 %>%
 select(all_of(varlist))
 
dm

A tibble: 8 × 28

STUDYID	DOMAIN	USUBJID	SUBJID	RFSTDTC	RFENDTC	RFXSTDTC	RFXENDTC	RFICDTC	RFPENDTC	⋯	ARMCD	ARM	ACTARMCD	ACTARM	COUNTRY	RACE1	RACE2	RACE3	RACE4	RACESP
<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	⋯	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>
STU001	DM	STU001-1001	1001	2010-01-01	NA	NA	NA	2010-01-01	2010-01-01	⋯	SCRNFAIL	Screen Failure	SCRNFAIL	Screen Failure	USA
STU001	DM	STU001-1002	1002	2010-01-01	2010-01-05	NA	NA	2010-01-01	2010-01-05	⋯	NOTASSGN	Not Assigned	NOTASSGN	Not Assigned	USA	ASIAN	AMERICAN INDIAN OR ALASKA NATIVE
STU001	DM	STU001-1003	1003	2010-01-03	2010-01-05	NA	NA	2010-01-01	2010-01-05	⋯	PBO	Placebo	NOTTRT	Not Treated	USA					BRAZILIAN
STU001	DM	STU001-1004	1004	2010-01-05	2010-02-28	2010-01-05T08:35	2010-01-25T08:45	2010-01-01	2010-02-28	⋯	ACTIVE	Active	ACTIVE	Active	USA
STU001	DM	STU001-1005	1005	2010-02-05	NA	2010-02-05T08:46	2010-02-12T08:30	2010-01-15	2020-02-20	⋯	ACTIVE	Active	PBO	Placebo	USA
STU001	DM	STU001-1006	1006	2010-03-02	2010-03-25	2010-03-02T08:30	2010-03-10T08:30	2010-02-18	2010-03-25	⋯	PBO	Placebo	PBO	Placebo	USA
STU001	DM	STU001-1007	1007	2010-04-15	2010-06-12	2010-04-15T08:23	2010-05-06T08:12	2010-04-04	2010-06-12	⋯	PBO	Placebo	PBO	Placebo	USA
STU001	DM	STU001-1008	1008	2010-06-27	2010-08-18	2010-06-27T08:45	2010-07-11T09:20	2010-06-20	2010-08-18	⋯	ACTIVE	Active	ACTIVE	Active	USA

write_xpt(dm, "dm.xpt")

colnames(dm)

1. 'STUDYID'
2. 'DOMAIN'
3. 'USUBJID'
4. 'SUBJID'
5. 'RFSTDTC'
6. 'RFENDTC'
7. 'RFXSTDTC'
8. 'RFXENDTC'
9. 'RFICDTC'
10. 'RFPENDTC'
11. 'DTHDTC'
12. 'DTHFL'
13. 'SITEID'
14. 'AGE'
15. 'AGEU'
16. 'SEX'
17. 'RACE'
18. 'ETHNIC'
19. 'ARMCD'
20. 'ARM'
21. 'ACTARMCD'
22. 'ACTARM'
23. 'COUNTRY'
24. 'RACE1'
25. 'RACE2'
26. 'RACE3'
27. 'RACE4'
28. 'RACESP'

suppdm <- dm %>%
  select(STUDYID, USUBJID, RACE1, RACE2, RACESP) %>%
  pivot_longer(
    cols = c(RACE1, RACE2, RACESP),
    names_to = "QNAM",
    values_to = "QVAL"
  ) %>%

  filter(!is.na(QVAL) & QVAL != "") %>%
  mutate(
    RDOMAIN   = "DM",
    IDVAR     = "",
    IDVARVAL  = "",
    QNAM      = str_to_upper(str_sub(QNAM, 1, 8)),
    QLABEL    = case_when(
      QNAM == "RACE1"   ~ "Race Component 1",
      QNAM == "RACE2"   ~ "Race Component 2",
      QNAM == "RACESP" ~ "Race, Specify",
      TRUE              ~ QNAM
    ),
    QVAL   = as.character(QVAL),
    QORIG  = case_when(
      QNAM %in% c("RACE1","RACE2","RACESP") ~ "CRF",
      TRUE ~ "DERIVED"
    ),
    QEVAL = ""
  ) %>%
  select(STUDYID, RDOMAIN, USUBJID, IDVAR, IDVARVAL, QNAM, QLABEL, QVAL, QORIG, QEVAL) %>%
  arrange(STUDYID, USUBJID, QNAM)

suppdm

A tibble: 3 × 10

STUDYID	RDOMAIN	USUBJID	IDVAR	IDVARVAL	QNAM	QLABEL	QVAL	QORIG	QEVAL
<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>	<chr>
STU001	DM	STU001-1002			RACE1	Race Component 1	ASIAN	CRF
STU001	DM	STU001-1002			RACE2	Race Component 2	AMERICAN INDIAN OR ALASKA NATIVE	CRF
STU001	DM	STU001-1003			RACESP	Race, Specify	BRAZILIAN	CRF

Generated QC logs and check summaries for SDTM DM in R (keys, required variables, CT, ISO8601 dates), producing reviewer-ready PASS/WARN/FAIL
outputs and exportable summaries.

# ---- 1) Configure logging (writes to console + file) ----
log_file <- "qc_run.log"
log_appender(appender_tee(log_file))     # tee: console + file
log_layout(layout_glue_generator("{time} [{level}] {msg}"))

# Helper: standard result row
qc_result <- function(check_id, dataset, severity, status, message, n_issue = NA_integer_) {
  tibble(
    check_id = check_id,
    dataset  = dataset,
    severity = severity,      # INFO/WARN/ERROR
    status   = status,        # PASS/WARN/FAIL
    n_issue  = n_issue,
    message  = message
  )
}

# ---- 2) Example checks (write to log + return summary rows) ----
check_unique <- function(df, keys, dataset = "ADSL", check_id = "UNIQUE_USUBJID") {
  log_info("Running {check_id} on {dataset} (keys: {paste(keys, collapse=', ')})")

  dup <- df %>%
    count(across(all_of(keys))) %>%
    filter(n > 1)

  if (nrow(dup) == 0) {
    log_info("{check_id}: PASS")
    qc_result(check_id, dataset, "INFO", "PASS", "No duplicate keys.")
  } else {
    log_error("{check_id}: FAIL - {nrow(dup)} duplicate key combinations found.")
    qc_result(check_id, dataset, "ERROR", "FAIL",
              glue("{nrow(dup)} duplicate key combinations found."),
              n_issue = nrow(dup))
  }
}

check_missing <- function(df, vars, dataset = "ADSL", check_id = "MISSING_CORE") {
  log_info("Running {check_id} on {dataset} (vars: {paste(vars, collapse=', ')})")

  miss_counts <- sapply(vars, function(v) sum(is.na(df[[v]]) | df[[v]] == ""))
  n_bad_vars  <- sum(miss_counts > 0)

  if (n_bad_vars == 0) {
    log_info("{check_id}: PASS")
    qc_result(check_id, dataset, "INFO", "PASS", "No missing values in required variables.")
  } else {
    bad <- paste(names(miss_counts)[miss_counts > 0], collapse = ", ")
    log_warn("{check_id}: WARN - Missing values found in: {bad}")
    qc_result(check_id, dataset, "WARN", "WARN",
              glue("Missing values found in: {bad}"),
              n_issue = sum(miss_counts))
  }
}

# ---- 3) Run checks & build a reviewer summary ----
run_qc <- function(df, dataset = "ADSL") {
  log_info("===== QC START: {dataset} =====")

  results <- bind_rows(
    check_unique(df, keys = c("USUBJID"), dataset = dataset),
    check_missing(df, vars = c("USUBJID","AGE","SEX"), dataset = dataset)
  )

  # Quick reviewer view: counts by status
  reviewer_summary <- results %>%
    count(status, severity, name = "n_checks") %>%
    arrange(match(status, c("FAIL","WARN","PASS")))

  log_info("===== QC END: {dataset} =====")
  list(results = results, reviewer_summary = reviewer_summary)
}

Basics QC Check: But Use Pinnacle 21

out <- run_qc(dm, "DM")

# ---- 5) Export summaries ----
write_csv(out$results, "qc_check_results.csv")
write_csv(out$reviewer_summary, "qc_reviewer_summary.csv")

out$results
out$reviewer_summary

A tibble: 2 × 6

check_id	dataset	severity	status	n_issue	message
<chr>	<chr>	<chr>	<chr>	<int>	<chr>
UNIQUE_USUBJID	DM	INFO	PASS	NA	No duplicate keys.
MISSING_CORE	DM	INFO	PASS	NA	No missing values in required variables.

A tibble: 1 × 3

status	severity	n_checks
<chr>	<chr>	<int>
PASS	INFO	2