(v3.0.1.9037) improve cli messages

R/aa_helper_functions.R

@@ -383,27 +383,6 @@ pkg_is_available <- function(pkg, also_load = FALSE, min_version = NULL) {
   isTRUE(out)
 }
 
-highlight_code <- function(code) {
-  if (pkg_is_available("cli", min_version = "3.0.0")) {
-    cli::code_highlight(code)
-  } else {
-    code
-  }
-}
-
-# Format a cli-markup string for output, with a plain-text fallback when cli is
-# unavailable. Unlike message_() / warning_() / stop_(), this function returns
-# the formatted string rather than emitting it, so it can be passed to any
-# output function (e.g. packageStartupMessage()).
-format_inline_ <- function(...) {
-  msg <- paste0(c(...), collapse = "")
-  if (pkg_is_available("cli", min_version = "3.0.0")) {
-    cli::format_inline(msg)
-  } else {
-    cli_to_plain(msg, envir = parent.frame())
-  }
-}
-
 import_fn <- function(name, pkg, error_on_fail = TRUE) {
   if (isTRUE(error_on_fail)) {
     stop_ifnot_installed(pkg)
@@ -429,6 +408,27 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) {
   )
 }
 
+highlight_code <- function(code) {
+  if (pkg_is_available("cli", min_version = "3.0.0")) {
+    cli::code_highlight(code)
+  } else {
+    code
+  }
+}
+
+# Format a cli-markup string for output, with a plain-text fallback when cli is
+# unavailable. Unlike message_() / warning_() / stop_(), this function returns
+# the formatted string rather than emitting it, so it can be passed to any
+# output function (e.g. packageStartupMessage()).
+format_inline_ <- function(...) {
+  msg <- paste0(c(...), collapse = "")
+  if (pkg_is_available("cli", min_version = "3.0.0")) {
+    cli::format_inline(msg)
+  } else {
+    cli_to_plain(msg, envir = parent.frame())
+  }
+}
+
 # Convert cli glue markup to plain text for the non-cli fallback path.
 # Called by message_(), warning_(), and stop_() when cli is not available.
 cli_to_plain <- function(msg, envir = parent.frame()) {
@@ -552,11 +552,39 @@ word_wrap <- function(...,
   gsub("(\n| )+$", "", wrapped)
 }
 
+simplify_help_markup <- function(msg) {
+  # {.help [{.fun fn}](pkg::fn)} -> {.code ?fn()}
+  # {.help [display](topic)}     -> {.code ?display}
+  msg <- gsub(
+    "\\{\\.help \\[\\{\\.fun ([^}]+)\\}\\]\\([^)]+\\)\\}",
+    "{.code ?\\1()}",
+    msg,
+    perl = TRUE
+  )
+  msg <- gsub(
+    "\\{\\.help \\[([^]]+)\\]\\([^)]+\\)\\}",
+    "{.code ?\\1}",
+    msg,
+    perl = TRUE
+  )
+  # {.topic [display](topic)} -> display (plain text)
+  msg <- gsub(
+    "\\{\\.topic \\[([^]]+)\\]\\([^)]+\\)\\}",
+    "\\1",
+    msg,
+    perl = TRUE
+  )
+  msg
+}
+
 message_ <- function(...,
                      appendLF = TRUE,
                      as_note = TRUE) {
   if (pkg_is_available("cli", min_version = "3.0.0")) {
     msg <- paste0(c(...), collapse = "")
+    if (!cli::ansi_has_hyperlink_support()) {
+      msg <- simplify_help_markup(msg)
+    }
     if (isTRUE(as_note)) {
       cli::cli_inform(c("i" = msg), .envir = parent.frame())
     } else {
@@ -573,6 +601,9 @@ warning_ <- function(...,
                      call = FALSE) {
   if (pkg_is_available("cli", min_version = "3.0.0")) {
     msg <- paste0(c(...), collapse = "")
+    if (!cli::ansi_has_hyperlink_support()) {
+      msg <- simplify_help_markup(msg)
+    }
     cli::cli_warn(msg, .envir = parent.frame())
   } else {
     plain_msg <- cli_to_plain(paste0(c(...), collapse = ""), envir = parent.frame())
@@ -585,6 +616,9 @@ warning_ <- function(...,
 # - wraps text to never break lines within words (plain-text fallback)
 stop_ <- function(..., call = TRUE) {
   msg <- paste0(c(...), collapse = "")
+  if (!cli::ansi_has_hyperlink_support()) {
+    msg <- simplify_help_markup(msg)
+  }
   if (pkg_is_available("cli", min_version = "3.0.0")) {
     if (isTRUE(call)) {
       call_obj <- sys.call(-1)

R/ab.R

@@ -574,7 +574,7 @@ print.ab <- function(x, ...) {
       ), as_note = TRUE))
     }
   }
-  cat("Class 'ab'\n")
+  cat(format_inline_("Class {.cls ab}\n"))
   print(as.character(x), quote = FALSE)
 }
 

R/amr_selectors.R

@@ -804,7 +804,7 @@ amr_select_exec <- function(function_name,
                 language = NULL,
                 tolower = TRUE
               ),
-              " (`", abx[abx %in% untreatable], "`)"
+              " ({.field ", abx[abx %in% untreatable], "})"
             ),
             quotes = FALSE,
             sort = TRUE,
@@ -837,10 +837,10 @@ amr_select_exec <- function(function_name,
 #' @export
 #' @noRd
 print.amr_selector <- function(x, ...) {
-  warning_("It should never be needed to print an antimicrobial selector class. Are you using {.pkg data.table}? Then add the argument {.code with = FALSE}, see our examples at {.help [{.fun amr_selector}](AMR::amr_selector)}.",
+  warning_("It should never be needed to print an antimicrobial selector class. Are you using {.pkg data.table}? Then add the argument {.arg with = FALSE}, see our examples at {.help [{.fun amr_selector}](AMR::amr_selector)}.",
     immediate = TRUE
   )
-  cat("Class 'amr_selector'\n")
+  cat(format_inline_("Class {.cls amr_selector}\n"))
   print(as.character(x), quote = FALSE)
 }
 
@@ -937,7 +937,7 @@ any.amr_selector_any_all <- function(..., na.rm = FALSE) {
     if (length(e1) > 1) {
       message_(
         "Assuming a filter on ", type, " ", length(e1), " ", gsub("[\\(\\)]", "", fn_name),
-        ". Wrap around `all()` or `any()` to prevent this note."
+        ". Wrap around {.fun all} or {.fun any} to prevent this note."
       )
     }
   }
@@ -962,7 +962,7 @@ any.amr_selector_any_all <- function(..., na.rm = FALSE) {
     if (length(e1) > 1) {
       message_(
         "Assuming a filter on ", type, " ", length(e1), " ", gsub("[\\(\\)]", "", fn_name),
-        ". Wrap around `all()` or `any()` to prevent this note."
+        ". Wrap around {.fun all} or {.fun any} to prevent this note."
       )
     }
   }
@@ -1071,12 +1071,12 @@ message_agent_names <- function(function_name, agents, ab_group = NULL, examples
         message_("No antimicrobial drugs of class '", ab_group, "' found", examples, ".")
       }
     } else {
-      agents_formatted <- paste0("'", font_bold(agents, collapse = NULL), "'")
+      agents_formatted <- paste0("{.field ", font_bold(agents, collapse = NULL), "}")
       agents_names <- ab_name(names(agents), tolower = TRUE, language = NULL)
       need_name <- generalise_antibiotic_name(agents) != generalise_antibiotic_name(agents_names)
       agents_formatted[need_name] <- paste0(agents_formatted[need_name], " (", agents_names[need_name], ")")
       message_(
-        "For `", function_name, "(",
+        "For {.help [", function_name, "(",
         ifelse(function_name == "amr_class",
           paste0("\"", amr_class_args, "\""),
           ifelse(!is.null(call),
@@ -1084,7 +1084,7 @@ message_agent_names <- function(function_name, agents, ab_group = NULL, examples
             ""
           )
         ),
-        ")` using ",
+        ")](AMR::", function_name, ")} using ",
         ifelse(length(agents) == 1, "column ", "columns "),
         vector_and(agents_formatted, quotes = FALSE, sort = FALSE)
       )

R/atc_online.R

@@ -180,7 +180,7 @@ atc_online_property <- function(atc_code,
       colnames(out) <- gsub("^atc.*", "atc", tolower(colnames(out)))
 
       if (length(out) == 0) {
-        message_("in {.help [{.fun atc_online_property}](AMR::atc_online_property)}: no properties found for ATC ", atc_code[i], ". Please check {.href ", atc_url, " this WHOCC webpage}.")
+        message_("{.help [{.fun atc_online_property}](AMR::atc_online_property)}: no properties found for ATC ", atc_code[i], ". Please check {.href ", atc_url, " this WHOCC webpage}.")
         returnvalue[i] <- NA
         next
       }

R/av.R

@@ -526,7 +526,7 @@ type_sum.av <- function(x, ...) {
 #' @export
 #' @noRd
 print.av <- function(x, ...) {
-  cat("Class 'av'\n")
+  cat(format_inline_("Class {.cls av}\n"))
   print(as.character(x), quote = FALSE)
 }
 

R/custom_mdro_guideline.R

@@ -260,7 +260,7 @@ run_custom_mdro_guideline <- function(df, guideline, info) {
     )
     if (identical(qry, "error")) {
       warning_("in {.help [{.fun custom_mdro_guideline}](AMR::custom_mdro_guideline)}: rule ", i,
-        " (`", as.character(guideline[[i]]$query), "`) was ignored because of this error message: ",
+        " ({.code ", as.character(guideline[[i]]$query), "}) was ignored because of this error message: ",
         AMR_env$err_msg,
         call = FALSE
       )

R/disk.R

@@ -170,7 +170,7 @@ pillar_shaft.disk <- function(x, ...) {
 #' @export
 #' @noRd
 print.disk <- function(x, ...) {
-  cat("Class 'disk'\n")
+  cat(format_inline_("Class {.cls disk}\n"))
   print(as.integer(x), quote = FALSE)
 }
 

R/interpretive_rules.R

@@ -510,8 +510,8 @@ interpretive_rules <- function(x,
 
         ## Set base to R where base + enzyme inhibitor is R ----
         rule_current <- paste0(
-          ab_enzyme$base_name[i], " (`", col_base, "`) = R if ",
-          tolower(ab_enzyme$enzyme_name[i]), " (`", col_enzyme, "`) = R"
+          ab_enzyme$base_name[i], " ({.field ", col_base, "}) = R if ",
+          tolower(ab_enzyme$enzyme_name[i]), " ({.field ", col_enzyme, "}) = R"
         )
         if (isTRUE(info)) {
           cat(word_wrap(rule_current,
@@ -551,8 +551,8 @@ interpretive_rules <- function(x,
 
         ## Set base + enzyme inhibitor to S where base is S ----
         rule_current <- paste0(
-          ab_enzyme$enzyme_name[i], " (`", col_enzyme, "`) = S if ",
-          tolower(ab_enzyme$base_name[i]), " (`", col_base, "`) = S"
+          ab_enzyme$enzyme_name[i], " ({.field ", col_enzyme, "}) = S if ",
+          tolower(ab_enzyme$base_name[i]), " ({.field ", col_base, "}) = S"
         )
 
         if (isTRUE(info)) {

R/mic.R

@@ -72,7 +72,7 @@ COMMON_MIC_VALUES <- c(
 #' ```
 #' x <- random_mic(10)
 #' x
-#' #> Class 'mic'
+#' #> Class <mic>
 #' #>  [1] 16     1      8      8      64     >=128  0.0625 32     32     16
 #'
 #' is.factor(x)
@@ -89,7 +89,7 @@ COMMON_MIC_VALUES <- c(
 #'
 #' ```
 #' x[x > 4]
-#' #> Class 'mic'
+#' #> Class <mic>
 #' #> [1] 16    8     8     64    >=128 32    32    16
 #'
 #' df <- data.frame(x, hospital = "A")
@@ -475,7 +475,7 @@ type_sum.mic <- function(x, ...) {
 #' @export
 #' @noRd
 print.mic <- function(x, ...) {
-  cat("Class 'mic'")
+  cat(format_inline_("Class {.cls mic}"))
   if (!identical(levels(x), VALID_MIC_LEVELS)) {
     cat(font_red(" with an outdated or altered structure - convert with `as.mic()` to update"))
   }

R/mo.R

@@ -783,7 +783,7 @@ get_skimmers.mo <- function(column) {
 #' @noRd
 print.mo <- function(x, print.shortnames = FALSE, ...) {
   add_MO_lookup_to_AMR_env()
-  cat("Class 'mo'\n")
+  cat(format_inline_("Class {.cls mo}\n"))
   x_names <- names(x)
   if (is.null(x_names) & print.shortnames == TRUE) {
     x_names <- tryCatch(mo_shortname(x, ...), error = function(e) NULL)

R/mo_source.R

@@ -75,7 +75,7 @@
 #'
 #' ```
 #' as.mo("lab_mo_ecoli")
-#' #> Class 'mo'
+#' #> Class <mo>
 #' #> [1] B_ESCHR_COLI
 #'
 #' mo_genus("lab_mo_kpneumoniae")
@@ -85,7 +85,7 @@
 #' as.mo(c("Escherichia coli", "E. coli", "lab_mo_ecoli"))
 #' #> NOTE: Translation to one microorganism was guessed with uncertainty.
 #' #>       Use mo_uncertainties() to review it.
-#' #> Class 'mo'
+#' #> Class <mo>
 #' #> [1] B_ESCHR_COLI B_ESCHR_COLI B_ESCHR_COLI
 #' ```
 #'
@@ -108,7 +108,7 @@
 #' #> NOTE: Updated mo_source file '/Users/me/mo_source.rds' (0.3 kB) from
 #' #>       '/Users/me/Documents/ourcodes.xlsx' (9 kB), columns
 #' #>        "Organisation XYZ" and "mo"
-#' #> Class 'mo'
+#' #> Class <mo>
 #' #> [1] B_ESCHR_COLI
 #'
 #' mo_genus("lab_Staph_aureus")

R/plotting.R

@@ -412,7 +412,7 @@ create_scale_sir <- function(aesthetics, colours_SIR, language, eucast_I, ...) {
 
   scale$labels <- function(x) {
     stop_ifnot(all(x %in% c(levels(NA_sir_), "SI", "IR", NA)),
-      "Apply `scale_", aesthetics[1], "_sir()` to a variable of class 'sir', see {.help [{.fun as.sir}](AMR::as.sir)}.",
+      "Apply `scale_", aesthetics[1], "_sir()` to a variable of class {.cls sir}, see {.help [{.fun as.sir}](AMR::as.sir)}.",
       call = FALSE
     )
     x <- as.character(x)

R/proportion.R

@@ -346,7 +346,7 @@ sir_confidence_interval <- function(...,
   if (n < minimum) {
     warning_("Introducing NA: ",
       ifelse(n == 0, "no", paste("only", n)),
-      " results available for `sir_confidence_interval()` (`minimum` = ", minimum, ").",
+      " results available for {.help [{.fun sir_confidence_interval}](AMR::sir_confidence_interval)} (whilst {.arg minimum = ", minimum, "}).",
       call = FALSE
     )
     if (is.character(out)) {

R/sir.R

@@ -601,7 +601,7 @@ as.sir.default <- function(x,
           ifelse(length(out7) > 0, paste0("7 as \"", out7, "\""), NA_character_),
           ifelse(length(out8) > 0, paste0("8 as \"", out8, "\""), NA_character_)
         )
-        message_("in {.help [{.fun as.sir}](AMR::as.sir)}: Interpreting input value ", vector_and(out[!is.na(out)], quotes = FALSE, sort = FALSE))
+        message_("{.help [{.fun as.sir}](AMR::as.sir)}: Interpreting input value ", vector_and(out[!is.na(out)], quotes = FALSE, sort = FALSE))
       }
 
       if (na_before != na_after) {
@@ -1351,7 +1351,7 @@ as_sir_method <- function(method_short,
   }
   if (isTRUE(add_intrinsic_resistance) && guideline_coerced %unlike% "EUCAST") {
     if (isTRUE(info) && message_not_thrown_before("as.sir", "intrinsic")) {
-      message_("in {.help [{.fun as.sir}](AMR::as.sir)}: using {.arg add_intrinsic_resistance} is only useful when using EUCAST guidelines, since the rules for intrinsic resistance are based on EUCAST.")
+      message_("{.help [{.fun as.sir}](AMR::as.sir)}: using {.arg add_intrinsic_resistance} is only useful when using EUCAST guidelines, since the rules for intrinsic resistance are based on EUCAST.")
     }
   }
 
@@ -2087,7 +2087,7 @@ get_skimmers.sir <- function(column) {
 #' @noRd
 print.sir <- function(x, ...) {
   x_name <- deparse(substitute(x))
-  cat("Class 'sir'\n")
+  cat(format_inline_("Class {.cls sir}\n"))
   # TODO for #170
   # if (!is.null(attributes(x)$guideline) && !all(is.na(attributes(x)$guideline))) {
   #   cat(font_blue(word_wrap("These values were interpreted using ",

R/sir_calc.R

@@ -204,7 +204,7 @@ sir_calc <- function(...,
       ifelse(denominator == 0, "no", paste("only", denominator)),
       " results available",
       data_vars,
-      " (`minimum` = ", minimum, ").",
+      " (whilst {.arg minimum = ", minimum, "}).",
       call = FALSE
     )
     fraction <- NA_real_