procs-example1.R
In procs: Recreates Some 'SAS®' Procedures in 'R'

## ----setup, include = FALSE---------------------------------------------------
knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>"
)


## ----eval=FALSE, echo=TRUE----------------------------------------------------
#  library(sassy)
#  library(procs)
#  
#  # Prepare Log -------------------------------------------------------------
#  
#  
#  options("logr.autolog" = TRUE,
#          "logr.on" = TRUE,
#          "logr.notes" = FALSE,
#          "procs.print" = FALSE)
#  
#  # Get temp directory
#  tmp <- tempdir()
#  
#  # Open log
#  lf <- log_open(file.path(tmp, "example1.log"))
#  
#  
#  
#  # Prepare formats ---------------------------------------------------------
#  
#  sep("Prepare formats")
#  
#  put("Age categories")
#  agecat <- value(condition(x >= 18 & x <= 29, "18 to 29"),
#                  condition(x >=30 & x <= 39, "30 to 39"),
#                  condition(x >=40 & x <=49, "40 to 49"),
#                  condition(x >= 50, ">= 50"),
#                  condition(TRUE, "Out of range"))
#  
#  put("Sex decodes")
#  fmt_sex <- value(condition(is.na(x), "Missing"),
#                   condition(x == "M", "Male"),
#                   condition(x == "F", "Female"),
#                   condition(TRUE, "Other"))
#  
#  put("Race decodes")
#  fmt_race <- value(condition(is.na(x), "Missing"),
#                    condition(x == "WHITE", "White"),
#                    condition(x == "BLACK", "Black or African American"),
#                    condition(TRUE, "Other"))
#  
#  
#  put("Compile format catalog")
#  fc <- fcat(MEAN = "%.1f", STD = "(%.2f)",
#             Q1 = "%.1f", Q3 = "%.1f",
#             MIN = "%d", MAX = "%d",
#             CNT = "%2d", PCT = "(%5.1f%%)",
#             AGECAT = agecat,
#             SEX = fmt_sex,
#             RACE = fmt_race,
#             AOV.F = "%5.3f",
#             AOV.P = "(%5.3f)",
#             CHISQ = "%5.3f",
#             CHISQ.P = "(%5.3f)")
#  
#  
#  # Load and Prepare Data ---------------------------------------------------
#  
#  sep("Prepare Data")
#  
#  
#  put("Create sample ADSL data.")
#  adsl <- read.table(header = TRUE, text = '
#    SUBJID  ARM    SEX  RACE    AGE
#    "001"   "ARM A" "F"  "WHITE" 19
#    "002"   "ARM B" "F"  "WHITE" 21
#    "003"   "ARM C" "F"  "WHITE" 23
#    "004"   "ARM D" "F"  "BLACK" 28
#    "005"   "ARM A" "M"  "WHITE" 37
#    "006"   "ARM B" "M"  "WHITE" 34
#    "007"   "ARM C" "M"  "WHITE" 36
#    "008"   "ARM D" "M"  "WHITE" 30
#    "009"   "ARM A" "F"  "WHITE" 39
#    "010"   "ARM B" "F"  "WHITE" 31
#    "011"   "ARM C" "F"  "BLACK" 33
#    "012"   "ARM D" "F"  "WHITE" 38
#    "013"   "ARM A" "M"  "BLACK" 37
#    "014"   "ARM B" "M"  "WHITE" 34
#    "015"   "ARM C" "M"  "WHITE" 36
#    "016"   "ARM A" "M"  "WHITE" 40')
#  
#  put("Categorize AGE")
#  adsl$AGECAT <- fapply(adsl$AGE, agecat)
#  
#  put("Log starting dataset")
#  put(adsl)
#  
#  
#  put("Get ARM population counts")
#  proc_freq(adsl, tables = ARM,
#            output = long,
#            options = v(nopercent, nonobs)) -> arm_pop
#  
#  # Age Summary Block -------------------------------------------------------
#  
#  sep("Create summary statistics for age")
#  
#  put("Call means procedure to get summary statistics for age")
#  proc_means(adsl, var = AGE,
#             stats = v(n, mean, std, median, q1, q3, min, max),
#             by = ARM,
#             options = v(notype, nofreq)) -> age_stats
#  
#  put("Combine stats")
#  datastep(age_stats,
#           format = fc,
#           drop = find.names(age_stats, start = 4),
#           {
#             `Mean (SD)` <- fapply2(MEAN, STD)
#             Median <- MEDIAN
#             `Q1 - Q3` <- fapply2(Q1, Q3, sep = " - ")
#             `Min - Max` <- fapply2(MIN, MAX, sep = " - ")
#  
#  
#           }) -> age_comb
#  
#  put("Transpose ARMs into columns")
#  proc_transpose(age_comb,
#                 var = names(age_comb),
#                 copy = VAR, id = BY,
#                 name = LABEL) -> age_trans
#  
#  put("Calculate aov")
#  age_aov <- aov(AGE ~ ARM, data = adsl) |>
#    summary()
#  
#  put("Get aov into proper data frame")
#  
#  age_aov <- age_aov[[1]][1, c("F value", "Pr(>F)")]
#  names(age_aov) <- c("AOV.F", "AOV.P")
#  age_aov <- as.data.frame(age_aov) |> put()
#  
#  put("Combine aov statistics")
#  datastep(age_aov,
#           keep = PVALUE,
#           format = fc,
#           {
#             PVALUE <- fapply2(AOV.F, AOV.P)
#  
#           }) -> age_aov_comb
#  
#  put("Append aov")
#  datastep(age_trans, merge = age_aov_comb, {}) -> age_block
#  
#  # Sex Block ---------------------------------------------------------------
#  
#  sep("Create frequency counts for SEX")
#  
#  put("Get sex frequency counts")
#  proc_freq(adsl, tables = SEX,
#            by = ARM,
#            options = nonobs) -> sex_freq
#  
#  
#  put("Combine counts and percents.")
#  datastep(sex_freq,
#           format = fc,
#           rename = list(CAT = "LABEL"),
#           drop = v(CNT, PCT),
#           {
#  
#             CNTPCT <- fapply2(CNT, PCT)
#  
#           }) -> sex_comb
#  
#  put("Transpose ARMs into columns")
#  proc_transpose(sex_comb, id = BY,
#                 var = CNTPCT,
#                 copy = VAR, by = LABEL) -> sex_trans
#  
#  put("Clean up")
#  datastep(sex_trans, drop = NAME,
#           {
#  
#             LABEL <- fapply(LABEL, fc$SEX)
#             LABEL <- factor(LABEL, levels = levels(fc$SEX))
#  
#           }) -> sex_cnts
#  
#  put("Sort by label")
#  proc_sort(sex_cnts, by = LABEL) -> sex_cnts
#  
#  put("Get sex chisq")
#  proc_freq(adsl, tables = v(SEX * ARM),
#            options = v(chisq, notable)) -> sex_chisq
#  
#  put("Combine chisq statistics")
#  datastep(sex_chisq,
#           format = fc,
#           keep = PVALUE,
#           {
#  
#             PVALUE = fapply2(CHISQ, CHISQ.P)
#           }) -> sex_chisq_comb
#  
#  put("Append chisq")
#  datastep(sex_cnts,
#           merge = sex_chisq_comb,
#           {}) -> sex_block
#  
#  
#  # Race block --------------------------------------------------------------
#  
#  
#  sep("Create frequency counts for RACE")
#  
#  put("Get race frequency counts")
#  proc_freq(adsl, tables = RACE,
#            by = ARM,
#            options = nonobs) -> race_freq
#  
#  
#  put("Combine counts and percents.")
#  datastep(race_freq,
#           format = fc,
#           rename = list(CAT = "LABEL"),
#           drop = v(CNT, PCT),
#           {
#  
#             CNTPCT <- fapply2(CNT, PCT)
#  
#           }) -> race_comb
#  
#  put("Transpose ARMs into columns")
#  proc_transpose(race_comb, id = BY, var = CNTPCT,
#                 copy = VAR, by = LABEL) -> race_trans
#  
#  put("Clean up")
#  
#  datastep(race_trans, drop = NAME,
#           where = expression(del == FALSE),
#           {
#             LABEL <- fapply(LABEL, fc$RACE)
#             LABEL <- factor(LABEL, levels = levels(fc$RACE))
#  
#           }) -> race_cnts
#  
#  put("Sort by label")
#  proc_sort(race_cnts, by = LABEL) -> race_cnts
#  
#  put("Get race chisq")
#  proc_freq(adsl, tables = RACE * ARM,
#            options = v(chisq, notable)) -> race_chisq
#  
#  put("Combine chisq statistics")
#  datastep(race_chisq,
#           format = fc,
#           keep = c("PVALUE"),
#           {
#  
#             PVALUE = fapply2(CHISQ, CHISQ.P)
#           }) -> race_chisq_comb
#  
#  put("Append chisq")
#  datastep(race_cnts, merge = race_chisq_comb, {}) -> race_block
#  
#  
#  # Age Group Block ----------------------------------------------------------
#  
#  sep("Create frequency counts for Age Group")
#  
#  
#  put("Get age group frequency counts")
#  proc_freq(adsl,
#            table = AGECAT,
#            by = ARM,
#            options = nonobs) -> ageg_freq
#  
#  put("Combine counts and percents and assign age group factor for sorting")
#  datastep(ageg_freq,
#           format = fc,
#           keep = v(VAR, LABEL, BY, CNTPCT),
#           {
#             CNTPCT <- fapply2(CNT, PCT)
#             LABEL <- factor(CAT, levels = levels(fc$AGECAT))
#           }) -> ageg_comb
#  
#  
#  put("Sort by age group factor")
#  proc_sort(ageg_comb, by = v(BY, LABEL)) -> ageg_sort
#  
#  put("Tranpose age group block")
#  proc_transpose(ageg_sort,
#                 var = CNTPCT,
#                 copy = VAR,
#                 id = BY,
#                 by = LABEL) -> ageg_trans
#  
#  put("Some clean up")
#  datastep(ageg_trans,
#           drop = NAME,
#           {}) -> ageg_cnts
#  
#  put("Get ageg chisq")
#  proc_freq(adsl, tables = AGECAT * ARM,
#            options = v(chisq, notable)) -> ageg_chisq
#  
#  put("Combine chisq statistics")
#  datastep(ageg_chisq,
#           format = fc,
#           keep = c("PVALUE"),
#           {
#             PVALUE = fapply2(CHISQ, CHISQ.P)
#           }) -> ageg_chisq_comb
#  
#  put("Append chisq")
#  datastep(ageg_cnts, merge = ageg_chisq_comb,
#           {}) -> ageg_block
#  
#  
#  put("Combine blocks into final data frame")
#  datastep(age_block,
#           set = list(ageg_block, sex_block, race_block),
#           {}) -> final
#  
#  # Report ------------------------------------------------------------------
#  
#  
#  sep("Create and print report")
#  
#  var_fmt <- c("AGE" = "Age", "AGECAT" = "Age Group", "SEX" = "Sex", "RACE" = "Race")
#  
#  plbl <- "Tests of Association{supsc('1')}\n Value (P-Value)"
#  
#  # Create Table
#  tbl <- create_table(final, first_row_blank = TRUE) |>
#    column_defaults(from = `ARM A`, to = `ARM D`, align = "center", width = 1.1) |>
#    stub(vars = c("VAR", "LABEL"), "Variable", width = 2.5) |>
#    define(VAR, blank_after = TRUE, dedupe = TRUE, label = "Variable",
#           format = var_fmt,label_row = TRUE) |>
#    define(LABEL, indent = .25, label = "Demographic Category") |>
#    define(`ARM A`,  label = "Placebo", n = arm_pop["ARM A"]) |>
#    define(`ARM B`,  label = "Drug 50mg", n = arm_pop["ARM B"]) |>
#    define(`ARM C`,  label = "Drug 100mg", n = arm_pop["ARM C"]) |>
#    define(`ARM D`,  label = "Competitor", n = arm_pop["ARM D"]) |>
#    define(PVALUE, label = plbl, width = 2, dedupe = TRUE, align = "center") |>
#    titles("Table 1.0", "Analysis of Demographic Characteristics",
#           "Safety Population", bold = TRUE) |>
#    footnotes("Program: DM_Table.R",
#              "NOTE: Denominator based on number of non-missing responses.",
#              "{supsc('1')}Pearson's Chi-Square tests will be used for "
#              %p% "Categorical variables and ANOVA tests for continuous variables.")
#  
#  rpt <- create_report(file.path(tmp, "ProcsDemoDM.rtf"),
#                       output_type = "RTF",
#                       font = "Times") |>
#    page_header("Sponsor: Company", "Study: ABC") |>
#    set_margins(top = 1, bottom = 1) |>
#    add_content(tbl) |>
#    page_footer("Date Produced: {Sys.Date()}", right = "Page [pg] of [tpg]")
#  
#  put("Write out the report")
#  res <- write_report(rpt)
#  
#  # Clean Up ----------------------------------------------------------------
#  sep("Clean Up")
#  
#  put("Close log")
#  log_close()
#  
#  
#  # Uncomment to view report
#  # file.show(res$modified_path)
#  
#  # Uncomment to view log
#  # file.show(lf)
#