improve plots (#127)

R/matching.R

@@ -277,8 +277,7 @@ plot_weights_base <- function(weighted_data,
   }
 
   # plot
-  original_par <- par(no.readonly = TRUE)
-  par(mgp = c(2.3, 0.5, 0), cex.axis = 0.9, cex.lab = 0.95, bty = "n")
+  original_par <- par(mgp = c(2.3, 0.5, 0), cex.axis = 0.9, cex.lab = 0.95, bty = "n")
   on.exit(par(original_par))
   hist(wt, border = "white", col = bin_col, main = main_title, breaks = 20, yaxt = "n", xlab = "")
   axis(2, las = 1)

R/plot_km.R

@@ -48,9 +48,6 @@ kmplot <- function(weights_object,
   trt_var_ipd <- toupper(trt_var_ipd)
   trt_var_agd <- toupper(trt_var_agd)
 
-  original_par <- par(no.readonly = TRUE)
-  on.exit(par(original_par))
-
   # pre check
   if (!"maicplus_estimate_weights" %in% class(weights_object)) {
     stop("weights_object should be an object returned by estimate_weights")
@@ -242,6 +239,7 @@ kmplot <- function(weights_object,
       )
     }
   }
+  invisible(NULL)
 }
 
 
@@ -279,8 +277,8 @@ kmplot <- function(weights_object,
 
 basic_kmplot <- function(kmdat,
                          endpoint_name = "Time to Event Endpoint",
-                         time_scale,
-                         time_grid,
+                         time_scale = NULL,
+                         time_grid = NULL,
                          show_risk_set = TRUE,
                          main_title = "Kaplan-Meier Curves",
                          subplot_heights = NULL,
@@ -289,9 +287,8 @@ basic_kmplot <- function(kmdat,
                          use_line_types = NULL,
                          use_pch_cex = 0.65,
                          use_pch_alpha = 100) {
-  original_par <- par(no.readonly = TRUE)
+  original_par <- par("bty", "tcl", "mgp", "cex.lab", "cex.axis", "cex.main", "mar")
   on.exit(par(original_par))
-
   # precheck
   if (!length(subplot_heights) %in% c(0, (1 + show_risk_set))) {
     stop("length of subplot_heights should be ", (1 + show_risk_set))
@@ -300,16 +297,18 @@ basic_kmplot <- function(kmdat,
     stop("kmdat$treatment needs to be a factor, its levels will be used in legend and title, first level is comparator")
   }
   if (nlevels(kmdat$treatment) > 4) stop("kmdat$treatment cannot have more than 4 levels")
-  if (is.null(time_grid) && show_risk_set) stop("please provide a numeric vector as time_grid to show risk set table")
 
   # set up x axis (time)
   if (is.null(time_grid)) {
     max_t <- max(kmdat$time)
     t_range <- c(0, get_time_as(max_t, time_scale) * 1.07)
+    time_grid <- pretty(t_range)
   } else {
     t_range <- c(0, max(time_grid))
   }
 
+
+
   # plat layout in par
   if (!suppress_plot_layout) {
     nr_subplot <- (1 + show_risk_set)
@@ -434,6 +433,7 @@ basic_kmplot <- function(kmdat,
       legend = levels(kmdat$treatment)
     )
   }
+  invisible(NULL)
 }
 
 
@@ -520,8 +520,7 @@ ph_diagplot <- function(weights_object,
   zphobj_adj <- survival::cox.zph(coxobj_adj2, transform = zph_transform, global = FALSE)
 
   # making the plot
-  original_par <- par(no.readonly = TRUE)
-  par(mfrow = c(3, 2), cex.lab = 0.85, cex.axis = 0.8, cex.main = 0.9)
+  original_par <- par(mfrow = c(3, 2), cex.lab = 0.85, cex.axis = 0.8, cex.main = 0.9)
   on.exit(par(original_par))
   # log-cum-hazard plot
   ph_diagplot_lch(kmobj,
@@ -640,7 +639,7 @@ ph_diagplot_lch <- function(km_fit,
   t_range <- range(all.times)
   y_range <- range(log(do.call(rbind, clldat)$cumhaz))
 
-  original_par <- par(no.readonly = TRUE)
+  original_par <- par("mar", "bty", "tcl", "mgp")
   par(mar = c(4, 4, 4, 1), bty = "n", tcl = -0.15, mgp = c(1.5, 0.3, 0))
   on.exit(par(original_par))
   plot(0, 0,
@@ -717,8 +716,7 @@ ph_diagplot_schoenfeld <- function(coxobj,
   use_yrange <- range(schresid, uppband, lowband)
 
   # making the plot
-  original_par <- par(no.readonly = TRUE)
-  par(bty = "n", mar = c(4, 4, 4, 1), tcl = -0.15, mgp = c(1.5, 0.3, 0))
+  original_par <- par(bty = "n", mar = c(4, 4, 4, 1), tcl = -0.15, mgp = c(1.5, 0.3, 0))
   on.exit(par(original_par))
   plot(schresid ~ plot_x,
     type = "n",

R/time-helper.R

@@ -3,6 +3,7 @@ settings_env <- new.env()
 
 #' Get and Set Time Conversion Factors
 #'
+#' @param default The default time scale, commonly whichever has factor = 1
 #' @param days Factor to divide data time units to get time in days
 #' @param weeks Factor to divide data time units to get time in weeks
 #' @param months Factor to divide data time units to get time in months
@@ -13,13 +14,33 @@ settings_env <- new.env()
 #' @rdname time_conversion
 #'
 #' @examples
-#' # Native time format is years
-#' set_time_conversion(days = 1 / 365.25, weeks = 1 / 52.17857, months = 1 / 12, years = 1)
+#' # The default time scale is days:
+#' set_time_conversion(default = "days", days = 1, weeks = 7, months = 365.25 / 12, years = 365.25)
 #'
-#' # Native time format is days
-#' set_time_conversion(days = 1, weeks = 7, months = 365.25 / 12, years = 365.25)
-set_time_conversion <- function(days = 1, weeks = 7, months = 365.25 / 12, years = 365.25) {
-  settings_env$time_conversion <- c(days = days, weeks = weeks, months = months, years = years)
+#'
+#' # Set the default time scale to years
+#' set_time_conversion(
+#'   default = "years",
+#'   days = 1 / 365.25,
+#'   weeks = 1 / 52.17857,
+#'   months = 1 / 12,
+#'   years = 1
+#' )
+#'
+set_time_conversion <- function(default = "days", days = 1, weeks = 7, months = 365.25 / 12, years = 365.25) {
+  if (!default %in% c("days", "weeks", "months", "years")) {
+    stop("default must be one of \"days\", \"weeks\", \"months\", \"years\")")
+  }
+  factors <- c(days = days, weeks = weeks, months = months, years = years)
+  check_factors <- vapply(factors, function(x) isFALSE(!is.finite(x) || x == 0), logical(1L))
+  if (!all(check_factors)) {
+    stop(
+      "Conversion factors must be finite non-zero numerical values: ",
+      paste0(names(factors)[!check_factors], " = ", factors[!check_factors], collapse = ", ")
+    )
+  }
+  settings_env$time_conversion <- factors
+  settings_env$default_time_scale <- default
 }
 
 
@@ -44,12 +65,13 @@ get_time_conversion <- function(factor = c("days", "weeks", "months", "years"))
 #' Convert Time Values Using Scaling Factors
 #'
 #' @param times Numeric time values
-#' @param as A time scale to convert to
+#' @param as A time scale to convert to. One of "days", "weeks", "months", "years"
 #'
 #' @return Returns a numeric vector calculated from `times / get_time_conversion(factor = as)`
 
-get_time_as <- function(times, as = c("days", "weeks", "months", "years")) {
+get_time_as <- function(times, as = NULL) {
+  if (is.null(as)) as <- settings_env$default_time_scale
   if (!is.numeric(times)) stop("times arguments must be numeric")
-  as <- match.arg(as)
+  as <- match.arg(as, c("days", "weeks", "months", "years"))
   times / get_time_conversion(as)
 }