using cli instead of warning_wrap

DESCRIPTION

@@ -38,7 +38,8 @@ Imports:
  treeio (>= 1.8.0),
  utils,
  scales,
- stats
+ stats,
+ cli
 Suggests:
  emojifont,
  ggimage,

NAMESPACE

@@ -167,6 +167,7 @@ importFrom(ape,reorder.phylo)
 importFrom(ape,rtree)
 importFrom(aplot,plot_list)
 importFrom(aplot,xrange)
+importFrom(cli,cli_alert_warning)
 importFrom(dplyr,collapse)
 importFrom(dplyr,filter)
 importFrom(dplyr,full_join)

R/geom_hilight.R

@@ -123,6 +123,7 @@ geom_hilight_rect2 <- function(data=NULL,
 
 #' @importFrom ggplot2 draw_key_polygon Geom ggproto aes GeomPolygon
 #' @importFrom grid rectGrob gpar grobTree
+#' @importFrom cli cli_alert_warning
 GeomHilightRect <- ggproto("GeomHilightRect", Geom,
  default_aes = aes(colour = NA, fill = "steelblue", 
  linewidth = 0.5, linetype = 1, alpha = 0.5,
@@ -146,18 +147,16 @@ GeomHilightRect <- ggproto("GeomHilightRect", Geom,
  flag2 <- data$extendto < data$xmax
  flag <- equals(flag1, flag2)
  if (all(flag1) && any(flag)){
- warning_wrap("extendto ", 
- paste0(data$extendto[flag], collapse="; "), 
- ifelse(length(data$extendto[flag])>1, " are", " is"), 
- " too small for node: ", paste0(data$clade_root_node[flag], collapse="; "),
- ", keep the original xmax value(s): ", paste0(data$xmax[flag], collapse="; "), ".")
+ cli_alert_warning(c("{.code extendto} ", paste0(data$extendto[flag], collapse="; "), 
+ ifelse(length(data$extendto[flag])>1, " are", " is")," too small for node: ", 
+ paste0(data$clade_root_node[flag], collapse="; "),", keep the original xmax value(s): ", 
+ paste0(data$xmax[flag], collapse="; "), "."), wrap = TRUE)
  data$xmax[!flag] <- data$extendto[!flag]
  }else if(!all(flag1) && any(flag)){
- warning_wrap("extendto ", 
- paste0(data$extendto[flag], collapse="; "), 
- ifelse(length(data$extendto[flag])>1, " are", " is"),
- " too big for node: ", paste0(data$clade_root_node[flag], collapse="; "),
- ", keep the original xmax value(s): ", paste0(data$xmax[flag], collapse="; "), ".")
+ cli_alert_warning(c("{.code extendto} ", paste0(data$extendto[flag], collapse="; "), 
+ ifelse(length(data$extendto[flag])>1, " are", " is"), " too big for node: ", 
+ paste0(data$clade_root_node[flag], collapse="; "), ", keep the original xmax value(s): ", 
+ paste0(data$xmax[flag], collapse="; "), "."), wrap = TRUE)
  data$xmax[!flag] <- data$extendto[!flag]
  }else{
  data$xmax <- data$extendto 
@@ -166,10 +165,12 @@ GeomHilightRect <- ggproto("GeomHilightRect", Geom,
  data <- build_align_data(data=data, align=align) 
  if (!coord$is_linear()) {
  if (gradient){
- warning_wrap("The gradient color hight light layer only presents in rectangular, ellipse, roundrect layouts")
+ cli_alert_warning("The gradient color hight light layer only presents in 
+ rectangular, ellipse, roundrect layouts.", wrap = TRUE)
  }
  if (roundrect){
- warning_wrap("The round rectangular hight light layer only presents in rectangular, ellipse, roundrect layouts")
+ cli_alert_warning("The round rectangular hight light layer only presents in 
+ rectangular, ellipse, roundrect layouts.", wrap =TRUE)
  }
  aesthetics <- setdiff(colnames(data), #"x.start", "y.start", "x.stop", "y.stop"), 
  c("xmin", "xmax", "ymin", "ymax", "clade_root_node"))
@@ -212,7 +213,7 @@ GeomHilightRect <- ggproto("GeomHilightRect", Geom,
  hilightGrob <- ifelse(roundrect, grid::roundrectGrob, grid::rectGrob)
  if (gradient){
  if (roundrect){
- warning_wrap("The round rectangular and gradient are not applied simultaneously")
+ cli_alert_warning("The round rectangular and gradient are not applied simultaneously")
  }
  gradient.direction <- match.arg(gradient.direction, c("rt", "tr"))
  rects <- lapply(split(coords, seq_len(nrow(coords))), function(row){
@@ -304,14 +305,19 @@ geom_hilight_encircle2 <- function(data=NULL,
  )
 }
 
+check_linewidth <- getFromNamespace('check_linewidth', 'ggplot2')
+snake_class <- getFromNamespace('snake_class', 'ggplot2')
+snakeize <- getFromNamespace('snakeize', 'ggplot2')
+
 GeomHilightEncircle <- ggproto("GeomHilightEncircle", Geom,
  required_aes = c("x", "y", "clade_root_node"),
  default_aes = aes(colour="black", fill="steelblue", alpha = 0.5,
  expand=0, spread=0.1, linetype=1, linewidth = 0.5,
  s_shape=0.5, s_open=FALSE),
  draw_key = draw_key_polygon,
  rename_size = TRUE,
- draw_panel = function(data, panel_scales, coord){
+ draw_panel = function(self, data, panel_scales, coord){
+ data <- check_linewidth(data, snake_class(self))
  globs <- lapply(split(data, data$clade_root_node), function(i)
  get_glob_encircle(i, panel_scales, coord))
  ggname("geom_hilight_encircle2", do.call("grobTree", globs))
@@ -479,14 +485,7 @@ build_align_data <- function(data, align){
 
 
 #' @importFrom utils getFromNamespace
-#warning_wrap <- getFromNamespace("warning_wrap", "ggplot2")
-warning_wrap <- function(...){
- x = paste0(...)
- x = paste(strwrap(x), collapse = "\n")
- warning(x, call. = FALSE)
-}
 rect_to_poly <- getFromNamespace("rect_to_poly", "ggplot2")
-#new_data_frame <- getFromNamespace("new_data_frame", "ggplot2")
 
 ## ##' layer of hilight clade with rectangle
 ## ##'

R/geom_hilight_encircle.R

@@ -139,7 +139,7 @@ get_glob_encircle <- function(data, panel_scales, coord){
  data.frame(x,y,first_row[!names(first_row) %in% c("x","y")])
  }
 
- coords <- coords[ch,]
+ coords <- coords[ch,,drop=FALSE]
  ## FIXME: using grid:: a lot. importFrom instead?
 
  ## convert from lengths to physical units, for computing *directions*
@@ -195,7 +195,8 @@ get_glob_encircle <- function(data, panel_scales, coord){
  ## browser()
 
  gp <- grid::get.gpar()
- pars1 <- c("colour","linetype","alpha","fill","size")
+ # the 'size' of line in ggplot2 3.4.0 have been replaced with 'linewidth'
+ pars1 <- c("colour","linetype","alpha","fill","linewidth")
  pars2 <- c("col","lty","alpha","fill","lwd")
  gp[pars2] <- first_row[pars1]
  grid::xsplineGrob(

R/geom_tiplab.R

@@ -133,10 +133,11 @@ geom_tiplab_rectangular <- function(mapping=NULL, hjust = 0, align = FALSE,
  params <- list(...)
  if ("nudge_x" %in% names(params)){
  if (offset != 0){
- warning_wrap("Both nudge_x and offset arguments are provided.
+ cli_alert_warning("Both {.code nudge_x} and {.code offset} arguments are provided.
  Because they all adjust the horizontal offset of labels,
- and the 'nudge_x' is consistent with 'ggplot2'. The
- 'offset' will be deprecated here and only the 'nudge_x' will be used.")
+ and the {.code nudge_x} is consistent with {.code ggplot2}. The
+ {.code offset} will be deprecated here and only the {.code nudge_x} will be used.", 
+ wrap = TRUE)
  }
  offset <- params$nudge_x
  params$nudge_x <- NULL

R/geom_tree.R

@@ -39,14 +39,10 @@
 ##' <http://yulab-smu.top/treedata-book/index.html> by Guangchuang Yu.
 geom_tree <- function(mapping=NULL, data=NULL, layout="rectangular", multiPhylo=FALSE, continuous="none", position="identity", ...) {
  if (is.logical(continuous)){
- warning_wrap('The type of "continuous" argument was changed (v>=2.5.2). Now, 
- it should be one of "color" (or "colour"), "size", "all", and "none".')
- ifelse(continuous,
- warning_wrap('It was set to TRUE, it should be replaced with "color" (or "colour"), 
- this meaning the aesthethic of "color" (or "colour") is continuous.'),
- warning_wrap('It was set to FALSE, it should be replaced with "none", 
- this meaning the aesthethic of "color" (or "colour") or "size" will not be continuous.')
- )
+ cli::cli_warn(c("The type of {.code continuous} argument was changed (v>=2.5.2). Now,", 
+ "i" = "Consider using {.code continuous = \"color\"}, {.code continuous = \"colour\"}, ", 
+ "{.code continuous = \"size\"}, {.code continuous = \"all\"} or",
+ " {.code continuous = \"none\"} instead."))
  continuous <- ifelse(continuous, "color", "none")
  }
  continuous <- match.arg(continuous, c("color", "colour", "size", "none", "all"))

R/method-ggplot-add.R

@@ -341,8 +341,9 @@ ggplot_add.cladelab <- function(object, plot, object_name){
  samevars <- Reduce(intersect,list(extract_all_aes_var(object$mapping), colnames(plot$data), colnames(object$data)))
  object$data <- merge(object$data, plot$data, by.x=quo_name(object$mapping$node), by.y="node", all.x=TRUE)
  if (length(samevars) > 0){
- warning_wrap('The "', paste(samevars, collapse=", ") ,'" has(have) been found in tree data. You might need to 
- rename the variable(s) in the data of "geom_cladelab" to avoid this warning!')
+ cli_alert_warning(text=c('The "', paste(samevars, collapse=", ") ,'" has(have) been found in tree data. You might need to 
+ rename the variable(s) in the data of "geom_cladelab" to avoid this warning!'),
+ wrap = TRUE)
  object$mapping <- remapping(mapping=object$mapping, samevars=samevars)
  }
  }
@@ -500,8 +501,10 @@ ggplot_add.hilight <- function(object, plot, object_name){
  samevars <- Reduce(intersect,list(extract_all_aes_var(object$mapping), colnames(plot$data), colnames(object$data)))
  object$data <- merge(object$data, plot$data, by.x=quo_name(object$mapping$node), by.y="node", all.x=TRUE)
  if (length(samevars) > 0){
- warning_wrap('The "', paste(samevars, collapse=", ") ,'" has(have) been found in tree data. You might need to 
- rename the variable(s) in the data of "geom_hilight" to avoid this warning!')
+ cli_alert_warning(text=c('The "', paste(samevars, collapse=", ") ,'" has(have) been found in tree data. You might need to 
+ rename the variable(s) in the data of "geom_hilight" to avoid this warning!'),
+ wrap = TRUE
+ )
  object$mapping <- remapping(mapping=object$mapping, samevars=samevars)
  }
  }

R/tree-utilities.R

@@ -42,7 +42,9 @@ layoutEqualAngle <- function(model, branch.length = "branch.length"){
 
  if (! is.null(tree$edge.length)) {
  if (anyNA(tree$edge.length)) {
- warning("'edge.length' contains NA values...\n## setting 'edge.length' to NULL automatically when plotting the tree...")
+ cli_alert_warning(c("{.code edge.length} contains NA values...",
+ "## setting {.code edge.length} of the tree to NULL ",
+ "automatically when plotting the tree..."), wrap = TRUE)
  tree$edge.length <- NULL
  }
  }
@@ -771,12 +773,10 @@ getXcoord2 <- function(x, root, parent, child, len, start=0, rev=FALSE) {
  ignore_negative_edge <- getOption("ignore.negative.edge", default=FALSE)
 
  if (any(len < 0) && !ignore_negative_edge) {
- warning_wrap("The tree contained negative ", 
- ifelse(sum(len < 0)>1, "edge lengths", "edge length"),
- ". If you want to ignore the ", 
- ifelse(sum(len<0) > 1, "edges", "edge"),
- ", you can set 'options(ignore.negative.edge=TRUE)', then re-run ggtree."
- )
+ cli_alert_warning(c("The tree contained negative ", ifelse(sum(len < 0)>1, "edge lengths", "edge length"), 
+ ". If you want to ignore the ", ifelse(sum(len<0) > 1, "edges", "edge"), ", you can 
+ set {.code options(ignore.negative.edge=TRUE)}, then re-run ggtree."
+ ), wrap = TRUE)
  }
  while(anyNA(x)) {
  idx <- which(parent %in% currentNode)