types <- sapply(cal.track.obj, "[[", "type")
val.shape <- map(cal.track.obj, function(x) {
  c(length(x$new.val), class(x$new.val))
 }
)

w.single <- which(sapply(val.shape, function(x) x[1] == 1))

1 Focal Parameters

1.1 All single values

sing.focal <- intersect(which(types == "focal"), w.single)
c.df <- map(cal.track.obj[sing.focal], function(x) do.call(data.frame, x))
all.df <- do.call(bind_rows, c.df) %>% select(-type) %>%
  mutate(difference = new.val - old.val, 
         p.diff = round(100 * difference / new.val, 2))

gt::gt(all.df) %>% 
  gt::tab_header("Single value, focal calibrated parameters") %>%
  gt::cols_label(
    name = "Parameter", old.val = "Old Value", 
    new.val = "New Value", difference = "Absolute Difference",
    p.diff = "Percent Difference"
  ) %>% gt::fmt_number(columns = 2:ncol(all.df), 
                       n_sigfig = 3, drop_trailing_zeros = TRUE)
Single value, focal calibrated parameters
Parameter Old Value New Value Absolute Difference Percent Difference
prep.reinit.wk$snap2 0.00557 0.00151 −0.00406 −270 

sml_temp <- paste0(c("\n\n", rep("#", 2), " %s ", "
", "
 "), collapse = "")

mult.focal <- intersect(which(types == "focal"), 
                        setdiff(seq(cal.track.obj), w.single))

for (mk.idx in seq_along(mult.focal)) {
  p.indx <- mult.focal[mk.idx]
  obj.name <- names(cal.track.obj)[p.indx]
  cat(sprintf(sml_temp, obj.name))
  obj.info <- val.shape[[obj.name]]
  if (any(obj.info[-1] == "data.frame")) {
    sub.calib.obj <- cal.track.obj[[p.indx]]
    old.df <- sub.calib.obj$old.val
    new.df <- sub.calib.obj$new.val
    if (!is.data.frame(old.df)) {
      head(new.df) %>% knitr::kable() %>% print()
    } else{
      matching.vec <- map2(old.df, new.df, function(x, y) {
        all(x == y)
      }) %>% flatten_lgl()
      which.no.match <- which(!matching.vec)
      colnames(old.df)[which.no.match] <- 
        paste0(colnames(old.df)[which.no.match], ".old")
      colnames(new.df)[which.no.match] <- 
        paste0(colnames(new.df)[which.no.match], ".new")
      new.df <- left_join(old.df, new.df, by = colnames(old.df)[matching.vec])
      new.and.old <- grep("\\.old|\\.new", colnames(new.df))
      head(new.df) %>% knitr::kable() %>% 
        # kableExtra::column_spec(new.and.old, background = "#BEBEBE",
        #                         bold = T) %>%
        print()
    }
  }
  cat("\n\n")
}

1.2 prep.newrx.wk.dt

age.grp race region snap5 dur prev inci.unadj inci.adj.old inci.adj.new
1 O King 0 11.41989 0.0003667 0.0000080 0.0000080 0.0000032
1 O King 1 14.02013 0.0046033 0.0000821 0.0000825 0.0000330
1 O King 2 17.21242 0.0336597 0.0004889 0.0005059 0.0002024
1 O King 3 21.13157 0.1354994 0.0016030 0.0018543 0.0007417
1 O King 4 25.94309 0.2964467 0.0028567 0.0040604 0.0016242
1 O King 5 31.85017 0.4035996 0.0031680 0.0053118 0.0021247

2 Set Parameters

2.1 All single values

sing.set <- intersect(which(types == "set"), w.single)
c.df <- map(cal.track.obj[sing.set], function(x) do.call(data.frame, x))
all.df <- do.call(bind_rows, c.df) %>% select(-type) %>%
  mutate(difference = new.val - old.val, 
         p.diff = round(100 * difference / new.val, 2))

gt::gt(all.df) %>% 
  gt::tab_header("Single value, set calibrated parameters") %>%
  gt::cols_label(
    name = "Parameter", old.val = "Old Value", 
    new.val = "New Value", difference = "Absolute Difference",
    p.diff = "Percent Difference"
  ) %>% gt::fmt_number(2:ncol(all.df), drop_trailing_zeros = TRUE,
                       n_sigfig = 4)
Single value, set calibrated parameters
Parameter Old Value New Value Absolute Difference Percent Difference
jnt_prev_targ_yr 2,011 1,990 −21.00 −1.060
UIAI.prob 0.007763 0.004436 −0.003327 −75.00
URAI.prob 0.009044 0.005168 −0.003876 −75.00
pre_targ_mult 1.300 1.300 0 0
rr_tx_init_adap NA 0.1946 NA NA
rr_tx_halt_adap NA 0.2678 NA NA
rr_tx_reinit_adap NA 1.007 NA NA
pdap$pdap.frac 0.06095 0.005000 −0.05595 −1,119

2.2 Other

2.3 adap_apply_param

Old.Values New.Values
NA 0.8324995
NA 0.8324995
NA 0.8324995