#' @include desc_statby.R utilities_base.R utilities_color.R
NULL
#' @import ggplot2
#' @importFrom magrittr %>%
#' @importFrom rstatix df_group_by df_nest_by df_select df_arrange
#' @importFrom tibble as_tibble
#' @importFrom dplyr group_by mutate across where group_nest arrange desc reframe slice_head slice_tail
#' @importFrom purrr map2 map
#' @importFrom tidyr unite
#' @importFrom dplyr select distinct
#' @importFrom dplyr summarise
#' @importFrom dplyr everything
#' @importFrom grid drawDetails
#' @importFrom rlang !!
#' @importFrom rlang !!!
#' @importFrom rlang sym syms .data
#' @importFrom rlang %||%


required_package <- function(pkg) {
  if (!requireNamespace(pkg, quietly = TRUE)) {
    stop(
      pkg, " package needed to be installed before using this function. ",
      "Type this in R: install.packages('", pkg, "')"
    )
  }
}

# Resolve line width compatibility between `size` and `linewidth`.
.resolve_linewidth_args <- function(size = NULL, linewidth = NULL, default_linewidth = NULL,
                                    warn_if_size = TRUE, null_size_after = FALSE) {
  if (!is.null(size) && !is.null(linewidth)) {
    stop("Please specify either 'size' or 'linewidth', not both. Use 'linewidth' for ggplot2 3.4.0+ compatibility.")
  }

  if (!is.null(size)) {
    if (isTRUE(warn_if_size)) {
      warning("The 'size' parameter for lines is deprecated in ggplot2 3.4.0+. Please use 'linewidth' instead to avoid this warning in future versions.")
    }
    linewidth <- size
    if (isTRUE(null_size_after)) size <- NULL
  } else if (is.null(linewidth)) {
    linewidth <- default_linewidth
  }

  list(size = size, linewidth = linewidth)
}

# Unnesting, adapt to tidyr 1.0.0
unnest <- function(data, cols = "data", ...) {
  if (is_pkg_version_sup("tidyr", "0.8.3")) {
    results <- tidyr::unnest(data, cols = dplyr::all_of(cols), ...)
  } else {
    results <- tidyr::unnest(data, ...)
  }
  results
}

# Check if an installed package version is superior to a specified version
# Version, pkg: character vector
is_pkg_version_sup <- function(pkg, version) {
  vv <- as.character(utils::packageVersion(pkg))
  cc <- utils::compareVersion(vv, version) > 0
  cc
}

keep_only_tbl_df_classes <- function(x) {
  toremove <- setdiff(class(x), c("tbl_df", "tbl", "data.frame"))
  if (length(toremove) > 0) {
    class(x) <- setdiff(class(x), toremove)
  }
  x
}

# %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Execute a geom_* function from ggplot2
# %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# geomfunc : gem_*() functions
# data data for mapping
# ... argument accepeted by the function
# return a plot if geomfunc != NULL or a list(option, mapping) if geomfunc is NULL
.geom_exec <- function(geomfunc = NULL, data = NULL,
                       position = NULL, ...) {
  geom_exec(geomfunc = geomfunc, data = data, position = position, ...)
}

# %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Official argument from ggplot2
# %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# bar plot arguments
.barplot_params <- function(...) {
  x <- list(...)
  res <- list()
  res$width <- x$width
  res$binwidth <- x$binwidth
  res$na.rm <- ifelse(!is.null(x$na.rm), x$na.rm, FALSE)
  res$show.legend <- ifelse(!is.null(x$show.legend), x$show.legend, NA)
  res$inherit.aes <- ifelse(!is.null(x$inherit.aes), x$inherit.aes, TRUE)
  return(res)
}

# box plot arguments
.boxplot_params <- function(...) {
  x <- list(...)
  res <- list()
  res$outlier.colour <- x$outlier.colour
  res$outlier.shape <- ifelse(!is.null(x$outlier.shape), x$outlier.shape, 19)
  res$outlier.size <- ifelse(!is.null(x$outlier.size), x$outlier.size, 1.5)
  res$outlier.stroke <- ifelse(!is.null(x$outlier.stroke), x$outlier.stroke, 0.5)
  res$notch <- ifelse(!is.null(x$notch), x$notch, FALSE)
  res$notchwidth <- ifelse(!is.null(x$notchwidth), x$notchwidth, 0.5)
  res$varwidth <- ifelse(!is.null(x$varwidth), x$varwidth, FALSE)
  res$na.rm <- ifelse(!is.null(x$na.rm), x$na.rm, FALSE)
  res$show.legend <- ifelse(!is.null(x$show.legend), x$show.legend, NA)
  res$inherit.aes <- ifelse(!is.null(x$inherit.aes), x$inherit.aes, TRUE)
  return(res)
}

.dotplot_params <- function(...) {
  x <- list(...)
  res <- list()
  res$stackratio <- ifelse(!is.null(x$stackratio), x$stackratio, 1)
  res$width <- ifelse(!is.null(x$width), x$width, 0.9)
  return(res)
}

.violin_params <- function(...) {
  x <- list(...)
  res <- list()
  # Use exact ([[) matching, not $, so a facet argument like scales = "free"
  # is not partial-matched to the violin `scale` parameter (which would set an
  # invalid scale and crash geom_violin at draw time, #398).
  res$stat <- ifelse(!is.null(x[["stat"]]), x[["stat"]], "ydensity")
  res$draw_quantiles <- x[["draw_quantiles"]]
  res$scale <- ifelse(!is.null(x[["scale"]]), x[["scale"]], "area")
  res$trim <- ifelse(!is.null(x[["trim"]]), x[["trim"]], TRUE)
  res$adjust <- x[["adjust"]] # Bandwidth adjustment for kernel density (Issue #552)
  return(res)
}

.hist_params <- function(...) {
  x <- list(...)
  res <- list()
  res$binwidth <- x$binwidth
  res$bins <- x$bins
  return(res)
}

.standard_params <- function(...) {
  x <- list(...)
  res <- list()
  res$color <- ifelse(!is.null(x$color), x$color, "black")
  res$color <- ifelse(!is.null(x$colour), x$colour, res$color)
  res$linetype <- ifelse(!is.null(x$linetype), x$linetype, "solid")
  res$size <- ifelse(!is.null(x$size), x$size, 1)
  res$fill <- ifelse(!is.null(x$fill), x$fill, "black")
  res$shape <- ifelse(!is.null(x$shape), x$shape, 19)
  res
}


# %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Graphical parameters
# %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

# Set plot orientation
# %%%%%%%%%%%%%%%%%%%%%%%%%%%%%
.set_orientation <-
  function(p, orientation = c("vertical", "horizontal", "reverse"),
           xlim = NULL, ylim = NULL) {
    ori <- match.arg(orientation)
    if (ori == "horizontal") {
      # Pass the axis limits into coord_flip() (in the original, pre-flip
      # coordinates, so ylim still refers to the value axis). A separate
      # coord_cartesian() would be dropped when coord_flip() replaces it (#646).
      p + coord_flip(xlim = xlim, ylim = ylim)
    } else if (ori == "reverse") {
      p + scale_y_reverse()
    } else {
      p
    }
  }


# Change title and labels
# %%%%%%%%%%%%%%%%%%%%%%%%%%%%%
.labs <- function(p, main = NULL, xlab = NULL, ylab = NULL,
                  font.main = NULL, font.x = NULL, font.y = NULL,
                  submain = NULL, caption = NULL,
                  font.submain = NULL, font.caption = NULL) {
  font.main <- .parse_font(font.main)
  font.x <- .parse_font(font.x)
  font.y <- .parse_font(font.y)
  font.submain <- .parse_font(font.submain)
  font.caption <- .parse_font(font.caption)

  if (is.logical(main)) {
    if (!main) main <- NULL
  }

  if (is.logical(submain)) {
    if (!submain) submain <- NULL
  }

  if (is.logical(caption)) {
    if (!caption) caption <- NULL
  }


  if (!is.null(main)) {
    p <- p + labs(title = main)
  }

  if (!is.null(submain)) {
    p <- p + labs(subtitle = submain)
  }

  if (!is.null(caption)) {
    p <- p + labs(caption = caption)
  }

  if (!is.null(xlab)) {
    if (xlab == FALSE) {
      p <- p + theme(axis.title.x = element_blank())
    } else {
      p <- p + labs(x = xlab)
    }
  }

  if (!is.null(ylab)) {
    if (ylab == FALSE) {
      p <- p + theme(axis.title.y = element_blank())
    } else {
      p <- p + labs(y = ylab)
    }
  }

  if (!is.null(font.main)) {
    p <- .add_text_theme(p, "plot.title", element_text(
      size = font.main$size,
      lineheight = 1.0, face = font.main$face, colour = font.main$color
    ))
  }
  if (!is.null(font.submain)) {
    p <- .add_text_theme(p, "plot.subtitle", element_text(
      size = font.submain$size,
      lineheight = 1.0, face = font.submain$face, colour = font.submain$color
    ))
  }
  if (!is.null(font.caption)) {
    p <- .add_text_theme(p, "plot.caption", element_text(
      size = font.caption$size,
      lineheight = 1.0, face = font.caption$face, colour = font.caption$color
    ))
  }
  if (!is.null(font.x)) {
    p <- .add_text_theme(p, "axis.title.x", element_text(
      size = font.x$size,
      face = font.x$face, colour = font.x$color
    ))
  }
  if (!is.null(font.y)) {
    p <- .add_text_theme(p, "axis.title.y", element_text(
      size = font.y$size,
      face = font.y$face, colour = font.y$color
    ))
  }


  p
}


# Merge a text theme element into a single theme slot, unless the plot already
# carries a markdown element there. ggtext's element_markdown()/element_textbox()
# (used e.g. by survminer on risk-table strata labels) cannot be merged with a
# plain element_text(): ggplot2 errors "Only elements of the same class can be
# merged". For such slots we leave the existing element untouched, so ggpar() no
# longer crashes on ggsurvplot objects. Normal element_text/element_blank/NULL
# slots are handled exactly as before (p + theme(...)), so output is unchanged
# (#382).
.add_text_theme <- function(p, slot, element) {
  existing <- p$theme[[slot]]
  if (inherits(existing, c("element_markdown", "element_textbox"))) {
    return(p)
  }
  p + do.call(ggplot2::theme, stats::setNames(list(element), slot))
}

# ticks
# %%%%%%%%%%%%%%%%%%%%%%%%%%%%%
.set_ticks <-
  function(p, ticks = TRUE, tickslab = TRUE, font.tickslab = NULL,
           xtickslab.rt = NULL, ytickslab.rt = NULL,
           font.xtickslab = font.tickslab, font.ytickslab = font.tickslab) {
    . <- xhjust <- xvjust <- NULL
    if (!is.null(xtickslab.rt)) {
      if (xtickslab.rt > 5) xhjust <- 1
      if (xtickslab.rt == 90) xvjust <- 0.5
    } else {
      xhjust <- NULL
    }

    if (ticks) {
      ticks <-
        element_line(colour = "black")
    } else {
      ticks <- element_blank()
    }

    if (is.null(font.xtickslab)) {
      font.x <- list()
    } else {
      font.x <- .parse_font(font.xtickslab)
    }
    if (is.null(font.ytickslab)) {
      font.y <- list()
    } else {
      font.y <- .parse_font(font.ytickslab)
    }

    p <- p + theme(axis.ticks = ticks)
    if (tickslab) {
      xtickslab <- font.x %>%
        .add_item(hjust = xhjust, vjust = xvjust, angle = xtickslab.rt) %>%
        do.call(element_text, .)
      ytickslab <- font.y %>%
        .add_item(angle = ytickslab.rt) %>%
        do.call(element_text, .)
      # Skip a slot whose existing element is markdown (see .add_text_theme, #382)
      p <- .add_text_theme(p, "axis.text.x", xtickslab)
      p <- .add_text_theme(p, "axis.text.y", ytickslab)
    } else {
      p <- p + theme(axis.text.x = element_blank(), axis.text.y = element_blank())
    }
    p
  }


# Change Axis limits
# %%%%%%%%%%%%%%%%%%%%%%%%%%%%%
.set_axis_limits <- function(xlim = NULL, ylim = NULL) {
  if (!is.null(xlim) | !is.null(ylim)) coord_cartesian(xlim, ylim)
}


# Axis scales
# %%%%%%%%%%%%%%%%%%%%%%%%%%%%%
.set_scale <- function(p, xscale = c("none", "log2", "log10", "sqrt"),
                       yscale = c("none", "log2", "log10", "sqrt"),
                       format.scale = FALSE) {
  xscale <- match.arg(xscale)
  yscale <- match.arg(yscale)
  .x <- ".x"

  if (format.scale) {
    if (!requireNamespace("scales")) stop("The R package 'scales' is required.")

    if (yscale == "log2") {
      p <- p + scale_y_continuous(
        trans = scales::log2_trans(),
        breaks = scales::trans_breaks("log2", function(x) 2^x),
        labels = scales::trans_format("log2", scales::math_format(2^.x))
      )
    } else if (yscale == "log10") {
      p <- p + scale_y_continuous(
        trans = scales::log10_trans(),
        breaks = scales::trans_breaks("log10", function(x) 10^x),
        labels = scales::trans_format("log10", scales::math_format(10^.x))
      )
    }

    if (xscale == "log2") {
      p <- p + scale_x_continuous(
        trans = scales::log2_trans(),
        breaks = scales::trans_breaks("log2", function(x) 2^x),
        labels = scales::trans_format("log2", scales::math_format(2^.x))
      )
    } else if (xscale == "log10") {
      p <- p + scale_x_continuous(
        trans = scales::log10_trans(),
        breaks = scales::trans_breaks("log10", function(x) 10^x),
        labels = scales::trans_format("log10", scales::math_format(10^.x))
      )
    }
  } else {
    if (xscale != "none") p <- p + scale_x_continuous(trans = xscale)
    if (yscale != "none") p <- p + scale_y_continuous(trans = yscale)
  }
  p
}

# Legends
# %%%%%%%%%%%%%%%%%%%%%%%%%%%%%
.set_legend <- function(p, legend = NULL,
                        legend.title = NULL, font.legend = NULL,
                        legend.direction = NULL) {
  if (is.null(legend.title)) legend.title <- waiver()
  font <- .parse_font(font.legend)

  if (!is.null(legend)) p <- p + theme(legend.position = legend)
  # legend.direction was previously ignored for legend = "top"/"bottom" (it only
  # took effect via ggplot2 defaults for "left"/"right"); apply it explicitly (#652).
  if (!is.null(legend.direction)) {
    p <- p + theme(legend.direction = legend.direction)
  }

  # Handle legend.title - skip if empty string (used to hide legend title)
  # Empty string causes "Ignoring unknown labels" warnings in ggplot2
  if (!.is_empty(legend.title) && !(is.character(legend.title) && legend.title == "")) {
    if (.is_list(legend.title)) {
      p <- p + do.call(ggplot2::labs, legend.title)
    } else {
      # Only set legend title for aesthetics actually used in the plot
      # to avoid "Ignoring unknown labels" warnings from ggplot2
      # Check both plot-level and layer-level mappings
      used_aes <- names(p$mapping)
      for (layer in p$layers) {
        used_aes <- c(used_aes, names(layer$mapping))
      }
      used_aes <- unique(used_aes)
      labs_args <- list()
      if ("colour" %in% used_aes || "color" %in% used_aes) labs_args$colour <- legend.title
      if ("fill" %in% used_aes) labs_args$fill <- legend.title
      if ("linetype" %in% used_aes) labs_args$linetype <- legend.title
      if ("shape" %in% used_aes) labs_args$shape <- legend.title
      if ("size" %in% used_aes) labs_args$size <- legend.title
      if ("alpha" %in% used_aes) labs_args$alpha <- legend.title
      if (length(labs_args) > 0) {
        p <- p + do.call(ggplot2::labs, labs_args)
      }
    }
  }

  if (!is.null(font)) {
    p <- .add_text_theme(p, "legend.text", element_text(
      size = font$size,
      face = font$face, colour = font$color
    ))
    p <- .add_text_theme(p, "legend.title", element_text(
      size = font$size,
      face = font$face, colour = font$color
    ))
  }

  p
}


# Set ticks by
# %%%%%%%%%%%%%%%%%%%%%%%%%%%%%
.set_ticksby <- function(p, xticks.by = NULL, yticks.by = NULL) {
  # x and y must be handled independently: an `else if` here dropped xticks.by
  # whenever yticks.by was also supplied (#333).
  if (!is.null(yticks.by)) {
    # Forcing ymin to start at 0 when distribution plot
    gg_mapping <- .get_gg_xy_variables(p)
    is_density_plot <- gg_mapping["y"] %in% c("..count..", "..density..", "..ecdf..")
    ymin <- NULL
    if (is_density_plot) ymin <- 0
    p <- p + scale_y_continuous(breaks = get_breaks(by = yticks.by, from = ymin))
  }
  # Skip xticks.by only when x is discrete: adding scale_x_continuous() to a
  # discrete x (e.g. ggboxplot) errors at draw time, so a discrete x keeps its
  # default axis (as it silently did when xticks.by was combined with yticks.by
  # before this fix). Every non-discrete x (numeric, integer, Date, POSIXct)
  # still receives the continuous scale exactly as before (#333).
  if (!is.null(xticks.by) && !.is_discrete_x(p)) {
    p <- p + scale_x_continuous(breaks = get_breaks(by = xticks.by))
  }
  p
}

# TRUE when the plot's x aesthetic resolves to discrete data (factor, character
# or logical), for which a continuous x scale cannot be applied. Falls back to
# FALSE (treat as continuous, i.e. apply the scale as before) if x cannot be
# evaluated, so behavior for non-discrete x is unchanged from previous versions.
.is_discrete_x <- function(p) {
  x_data <- tryCatch(
    rlang::eval_tidy(p$mapping$x, p$data),
    error = function(e) NULL
  )
  is.factor(x_data) || is.character(x_data) || is.logical(x_data)
}


# %%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Add stat
# %%%%%%%%%%%%%%%%%%%%%%%%%%%%%

.check_add.params <- function(add, add.params, error.plot, data, color, fill, ...) {
  if (color %in% names(data) & is.null(add.params$color)) add.params$color <- color
  if (fill %in% names(data) & is.null(add.params$fill)) add.params$fill <- fill
  if (is.null(add.params$color)) add.params$color <- color
  if (is.null(add.params$fill) & ("crossbar" %in% error.plot | "boxplot" %in% add | "violin" %in% add)) add.params$fill <- fill
  if (is.null(add.params$fill)) add.params$fill <- add.params$color
  # else add.params$fill <- add.params$color
  if (!is.null(list(...)$shape) & is.null(add.params$shape)) add.params$shape <- list(...)$shape
  add.params
}


# Calculate the mean and the SD in each group
#+++++++++++++++++++++++++
# data : a data frame
# varname : the name of the variable to be summariezed
# grps : column names to be used as grouping variables
# .mean_sd <- function(data, varname, grps){
#   summary_func <- function(x, col){
#     c(mean = base::mean(x[[col]], na.rm=TRUE),
#       sd = stats::sd(x[[col]], na.rm=TRUE))
#   }
#   data_sum <- plyr::ddply(data, grps, .fun=summary_func, varname)
#   data_sum$ymin <- data_sum$mean-data_sum$sd
#   data_sum$ymax <- data_sum$mean+data_sum$sd
#   names(data_sum)[ncol(data_sum)-3] <- varname
#   # data_sum <- plyr::rename(data_sum, c("mean" = varname))
#   return(data_sum)
# }


# Summary functions
.summary_functions <- function() {
  c(
    "mean", "mean_se", "mean_se_", "mean_sd", "mean_ci",
    "mean_range", "median", "median_iqr", "median_hilow", "median_hilow_",
    "median_q1q3", "median_mad", "median_range"
  )
}
.errorbar_functions <- function() {
  setdiff(.summary_functions(), c("mean", "median"))
}


# parse font
# %%%%%%%%%%%%%%%%%%%%%%%%%%%%%
.parse_font <- function(font) {
  if (is.null(font)) {
    res <- NULL
  } else if (inherits(font, "list")) {
    res <- font
  } else {
    # matching size and face (supports integer, dot, or comma decimals)
    size_idx <- grep("^[0-9]+([\\.,][0-9]+)?$", font, perl = TRUE)
    face_idx <- grep("plain|bold|italic|bold.italic", font, perl = TRUE)
    if (length(size_idx) == 0) {
      size <- NULL
    } else {
      size_vals <- font[size_idx]
      size_vals <- gsub(",", ".", size_vals, fixed = TRUE)
      size <- as.numeric(size_vals)
    }
    if (length(face_idx) == 0) face <- NULL else face <- font[face_idx]
    color_idx <- setdiff(seq_along(font), c(size_idx, face_idx))
    if (length(color_idx) == 0) color <- NULL else color <- font[color_idx]
    res <- list(size = size, face = face, color = color)
  }
  res
}


# Add annotation to a plot
# label: text to be added to a plot
# size: text size
# coord: x and coordinates
.ggannotate <- function(label, size = 12, coord = c(NULL, NULL)) {
  if (is.null(unique(coord))) {
    grob <- grid::grobTree(grid::textGrob(label,
      x = 0.3, y = 0.80, hjust = 0,
      gp = grid::gpar(col = "black", fontsize = size, fontface = "plain")
    ))
    ggplot2::annotation_custom(grob)
  } else {
    ggplot2::annotate("text",
      x = coord[1], y = coord[2],
      label = label, size = size / 3
    )
  }
}

# :::::::::::::::::::::::::::::::::::::::::
# Check the data provided by user
# :::::::::::::::::::::::::::::::::::::::::
# combine: if TRUE, gather y variables
# return a list(data, x, y)
.check_data <- function(data, x, y, combine = FALSE) {
  if (missing(x) & missing(y)) {
    if (!is.numeric(data)) {
      stop("x and y are missing. In this case data should be a numeric vector.")
    } else {
      data <- data.frame(y = data, x = rep(1, length(data)))
      x <- "x"
      y <- "y"
    }
  } else if (missing(x)) {
    x <- "x"
    if (is.numeric(data)) {
      data <- data.frame(x = data)
    } else {
      data$x <- rep("1", nrow(data))
    }
  }
  # A list of y elements to plot
  else if (length(y) > 1) {
    if (!all(y %in% colnames(data))) {
      not_found <- setdiff(y, colnames(data))
      y <- intersect(y, colnames(data))

      if (.is_empty(y)) {
        stop("Can't find the y elements in the data.")
      } else if (!.is_empty(not_found)) {
        warning(
          "Can't find the following element in the data: ",
          .collapse(not_found)
        )
      }
    }
  }

  if (inherits(data, c("tbl_df", "tbl"))) {
    data <- as.data.frame(data)
  }

  # Combining y variables
  # ......................................................
  if (is.null(y)) y <- ""
  if (combine & length(y) > 1) {
    data <- data %>%
      df_gather(cols = y, names_to = ".y.", values_to = ".value.") %>%
      dplyr::mutate(.y. = factor(.data$.y., levels = unique(.data$.y.)))
    y <- ".value."
  }
  # Combining x variables: Case of density plot or histograms
  # ......................................................
  else if (combine & length(x) > 1 & y[1] %in% c("..density..", "..count..", "..ecdf..", "..qq..")) {
    data <- data %>%
      df_gather(cols = x, names_to = ".y.", values_to = ".value.") %>%
      dplyr::mutate(.y. = factor(.data$.y., levels = unique(.data$.y.)))
    x <- ".value."
  }

  # If not factor, x elements on the plot should
  # appear in the same order as in the data
  if (is.character(data[[x]])) {
    data[[x]] <- factor(data[[x]], levels = unique(data[[x]]))
  }

  y <- unique(y)
  names(y) <- y
  x <- unique(x)
  names(x) <- x

  if (y[1] %in% c("..density..", "..count..", "..ecdf..", "..qq..")) {
    list(x = x, data = data, y = y)
  } # The name of plots are x variables
  else {
    list(y = y, data = data, x = x)
  } # The name of plots will be y variables
}


# Adjust shape when ngroups > 6, to avoid ggplot warnings
.scale_point_shape <- function(p, data, shape) {
  if (shape %in% colnames(data)) {
    grp <- data[[shape]]
    if (!inherits(grp, "factor")) grp <- as.factor(grp)
    ngroups <- length(levels(data[[shape]]))
    if (ngroups > 6) p <- p + scale_shape_manual(values = seq_len(ngroups), labels = levels(data[[shape]]))
  }
  p
}

# Get not numeric columns in a data.frame
.get_not_numeric_vars <- function(data_frame) {
  is_numeric <- sapply(data_frame, is.numeric)
  if (sum(!is_numeric) == 0) {
    res <- NULL
  } else {
    res <- colnames(data_frame[, !is_numeric, drop = FALSE])
  }
  res
}


# Get the current color used in ggplot
.get_ggplot_ncolors <- function(p) {
  g <- ggplot_build(p)
  gdata <- g$data[[1]]
  cols <- fills <- 1
  if ("colour" %in% names(gdata)) cols <- unique(unlist(gdata["colour"]))
  if ("fills" %in% names(gdata)) fills <- unique(unlist(gdata["fill"]))
  max(length(cols), length(fills))
}

# Check if character string is a valid color representation
.is_color <- function(x) {
  sapply(x, function(X) {
    tryCatch(is.matrix(grDevices::col2rgb(X)),
      error = function(e) FALSE
    )
  })
}


# Collapse one or two vectors
# :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
.collapse <- function(x, y = NULL, sep = ".") {
  if (missing(y)) {
    paste(x, collapse = sep)
  } else if (is.null(x) & is.null(y)) {
    return(NULL)
  } else if (is.null(x)) {
    return(as.character(y))
  } else if (is.null(y)) {
    return(as.character(x))
  } else {
    paste0(x, sep, y)
  }
}

# Check if en object is empty
# :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
.is_empty <- function(x) {
  length(x) == 0
}

# Remove NULL items in a vector or list
#
# x a vector or list
.compact <- function(x) {
  Filter(Negate(is.null), x)
}

# Check if is a list
# :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
.is_list <- function(x) {
  inherits(x, "list")
}

# Returns the levels of a factor variable
# :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
.levels <- function(x) {
  if (!is.factor(x)) x <- as.factor(x)
  levels(x)
}

# Remove items from a list
# :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
.remove_item <- function(.list, items) {
  for (item in items) {
    .list[[item]] <- NULL
  }
  .list
}

# Additems in a list
# :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
.add_item <- function(.list, ...) {
  pms <- list(...)
  for (pms.names in names(pms)) {
    .list[[pms.names]] <- pms[[pms.names]]
  }
  .list
}


# Select a colun as vector from tiblle data frame
.select_vec <- function(df, column) {
  dplyr::pull(df, column)
}

# Select the top up or down rows of a data frame sorted by variables
# :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
# - df: data frame
# - x: x axis variables (grouping variables)
# - y: y axis variables (sorting variables)
# - n the number of rows
# - grps: other grouping variables
.top_up <- function(df, x, y, n, grouping.vars = NULL) {
  grouping.vars <- c(x, grouping.vars) %>%
    unique()
  df %>%
    df_arrange(vars = c(grouping.vars, y)) %>%
    df_group_by(vars = grouping.vars) %>%
    slice_tail(n = n)
}


.top_down <- function(df, x, y, n, grouping.vars = NULL) {
  grouping.vars <- c(x, grouping.vars) %>%
    unique()
  df %>%
    df_arrange(vars = c(grouping.vars, y)) %>%
    df_group_by(vars = grouping.vars) %>%
    slice_head(n = n)
}


# ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
# Apply ggpubr functions on a data
# ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
# fun: function, can be ggboxplot, ggdotplot, ggstripchart, ...
.plotter <- function(fun, data, x, y, combine = FALSE, merge = FALSE,
                     color = "black", fill = "white",
                     title = NULL, xlab = NULL, ylab = NULL,
                     legend = NULL, legend.title = NULL,
                     facet.by = NULL,
                     select = NULL, remove = NULL, order = NULL,
                     add = "none", add.params = list(),
                     label = NULL, font.label = list(size = 11, color = "black"),
                     label.select = NULL, repel = FALSE, label.rectangle = FALSE,
                     font.family = "", parse = FALSE,
                     ggtheme = theme_pubr(),
                     fun_name = "", group = 1, # used only by ggline
                     show.legend.text = NA,
                     ...) {
  # Accept the British spelling `colour` as an alias for `color` (#317).
  # Map it to `color` and drop it from the extra args so it is not also passed
  # to the geom (which would raise a "Duplicated aesthetics" warning). `.extra`
  # replaces `...` in the downstream calls below.
  .extra <- list(...)
  if (!is.null(.extra$colour)) {
    color <- .extra$colour
    .extra$colour <- NULL
  }
  if (is.logical(merge)) {
    if (merge) {
      merge <- "asis"
    } else {
      merge <- "none"
    }
  }
  if (combine & merge != "none") {
    stop("You should use either combine = TRUE or merge = TRUE, but not both together.")
  }

  font.label <- .parse_font(font.label)
  if (is.null(label) & fun_name == "barplot") label <- FALSE
  .lab <- label
  if (fun_name != "barplot") .lab <- NULL

  if (!missing(x) & !missing(y)) {
    if (length(y) == 1 & length(x) == 1) {
      combine <- FALSE
      merge <- "none"
    }
  }

  # Check data
  # :::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  # - returns a list of updated main options:
  #       list(y, data,  x)
  opts <- .check_data(data, x, y, combine = combine | merge != "none")
  data <- opts$data
  x <- opts$x
  y <- opts$y


  is_density_plot <- y[1] %in% c("..count..", "..density..", "..ecdf..", "..qq..")

  if (combine) facet.by <- ".y." # Faceting by y variables
  if (merge != "none") {
    if (!is_density_plot) facet.by <- NULL
    if (is.null(legend.title)) legend.title <- "" # remove .y. in the legend
  }


  # Updating parameters after merging
  # :::::::::::::::::::::::::::::::::::::::::::::::::::::::::

  # Special case for density and histograms:
  # x are variables and y is ..count.. or ..density..
  # after merging ggpubr add a new column .y. which hold x variables
  # User might want to color by x variables as follows: color = ".x." and
  # he aren't aware that the column is ".y." --> so we should translate this (see from line 1055)

  user.add.color <- add.params$color
  geom.text.position <- "identity"

  if (merge == "asis") {
    .grouping.var <- ".y." # y variables become grouping variable
  } else if (merge == "flip") {
    .grouping.var <- opts$x # x variable becomes grouping variable
    opts$x <- ".y." # y variables become x tick labels
    if (is.null(xlab)) xlab <- FALSE
  }

  if (merge == "asis" | merge == "flip") {
    if (is_density_plot) {
      color <- ifelse(color == ".x.", ".y.", color)
      fill <- ifelse(fill == ".x.", ".y.", fill)
    }

    if (any(c(color, fill) %in% names(data))) {
      add.params$color <- font.label$color <- ifelse(color %in% names(data), color, fill)
    } else if (!all(c(color, fill) %in% names(data))) {
      color <- add.params$color <- font.label$color <- .grouping.var
      # fill <- "white"
    }
    group <- .grouping.var
    geom.text.position <- position_dodge(0.8)
  }

  if (!combine & merge == "none" & length(opts$y) > 1 & is.null(title)) {
    title <- opts$y
  }

  if (!combine & merge == "none" & is.null(title)) {
    if (length(opts$y) > 1) {
      title <- opts$y
    } else if (length(opts$x) > 1 & is_density_plot) { # case of density plot
      title <- opts$x
    }
  }

  # Item to display
  x <- opts$data[[opts$x]] %>% as.vector()
  if (!is.null(select)) {
    opts$data <- subset(opts$data, x %in% select)
  }
  if (!is.null(remove)) {
    opts$data <- subset(opts$data, !(x %in% remove))
  }
  if (!is.null(order)) opts$data[[opts$x]] <- factor(opts$data[[opts$x]], levels = order)

  # Add additional options, which can be potentially vectorized
  # when multiple plots
  opts <- opts %>%
    c(list(title = title, xlab = xlab, ylab = ylab)) %>%
    .compact()
  data <- opts$data
  opts$data <- list(opts$data)
  if (fun_name %in% c("ggline", "ggdotchart")) opts$group <- group
  # Plotting
  # ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  # Apply function to each y variables
  p <- do.call(purrr::pmap, c(
    list(
      .l = opts, .f = fun,
      color = color, fill = fill, legend = legend,
      legend.title = legend.title, ggtheme = ggtheme, facet.by = facet.by,
      add = add, add.params = add.params,
      # group = group, # for line plot
      user.add.color = user.add.color,
      label = .lab, # used only in ggbarplot
      font.label = font.label, repel = repel, label.rectangle = label.rectangle
    ),
    .extra
  ))
  # Faceting
  if (!is.null(facet.by)) {
    p <- do.call(purrr::map, c(list(.x = p, .f = facet, facet.by = facet.by), .extra))
  }


  # Add labels
  if (!is.null(label) & fun_name != "barplot") {
    if (is.logical(label)) {
      if (label) label <- opts$y
    }

    grouping.vars <- intersect(c(facet.by, color, fill), colnames(data))

    label.opts <- font.label %>%
      .add_item(
        data = data, x = opts$x, y = opts$y,
        label = label, label.select = label.select,
        repel = repel, label.rectangle = label.rectangle,
        family = font.family, parse = parse,
        ggtheme = NULL,
        grouping.vars = grouping.vars, facet.by = facet.by, position = geom.text.position,
        show.legend = show.legend.text
      )
    p <- purrr::map(
      p,
      function(p, label.opts) {
        . <- NULL
        label.opts %>%
          .add_item(ggp = p) %>%
          do.call(ggtext, .)
      },
      label.opts
    )
  }

  # Take into account the legend argument, when the main plot has no legend and ggtext has legend
  p <- purrr::map(p, ggpar, legend = legend, legend.title = legend.title)

  if (.is_list(p) & length(p) == 1) p <- p[[1]]
  p
}


# get the geometry of the first layer
# :::::::::::::::::::::::::::::::::::::::::::::::::::::::::
.geom <- function(p, .layer = 1) {
  . <- NULL
  if (is.null(p) | .is_empty(p$layers)) {
    return("")
  }
  class(p$layers[[.layer]]$geom)[1] %>%
    tolower() %>%
    gsub("geom", "", .)
}


# Get the mapping variables of the first layer
# :::::::::::::::::::::::::::::::::::::::::::::::::
.mapping <- function(p) {
  if (is.null(p)) {
    return(list())
  }

  . <- NULL

  layer0.mapping <- as.character(p$mapping) %>% gsub("~", "", .)
  layer0.mapping.labels <- p$mapping %>% names()
  names(layer0.mapping) <- layer0.mapping.labels

  layer1.mapping <- NULL

  if (!.is_empty(p$layers)) {
    layer1.mapping <- p$layers[[1]]$mapping %>%
      as.character() %>%
      gsub("~", "", .)
    layer1.mapping.labels <- p$layers[[1]]$mapping %>%
      names()
    names(layer1.mapping) <- layer1.mapping.labels
  }

  c(layer0.mapping, layer1.mapping) %>%
    as.list()
}

# Call geom_exec function to update a plot
# :::::::::::::::::::::::::::::::::::::::::::::::::::::::::
.update_plot <- function(opts, p) {
  p + do.call(geom_exec, opts)
}


# Get ggplot2 x and y variable
# ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
.get_gg_xy_variables <- function(p) {
  . <- NULL
  x <- p$mapping["x"] %>%
    as.character() %>%
    gsub("~", "", .)
  y <- p$mapping["y"] %>%
    as.character() %>%
    gsub("~", "", .)
  xy <- c(x, y)
  names(xy) <- c("x", "y")
  return(xy)
}

# Add mean or median line
# used by ggdensity and gghistogram
# :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
# p: main plot
# data: data frame
# x: measure variables
# add: center to add
# grouping.vars: grouping variables
.add_center_line <- function(p, add = c("none", "mean", "median"), grouping.vars = NULL,
                             color = "black", linetype = "dashed", size = NULL, linewidth = NULL) {
  # Handle size vs linewidth parameter compatibility
  # size deprecated in ggplot2 v >= 3.4.0
  if (!is.null(linewidth)) {
    size <- linewidth
  }
  add <- match.arg(add)
  data <- p$data
  # x <- .mapping(p)$x
  .mapping <- .get_gg_xy_variables(p)
  x <- .mapping["x"]

  if (!(add %in% c("mean", "median"))) {
    return(p)
  }
  compute_center <- switch(add,
    mean = mean,
    median = stats::median
  )

  # NO grouping variable
  if (.is_empty(grouping.vars)) {
    m <- ifelse(add == "mean",
      mean(data[[x]], na.rm = TRUE),
      stats::median(data[[x]], na.rm = TRUE)
    )
    # geom_vline takes `linewidth`, not the deprecated `size` (ggplot2 >= 3.4.0).
    # Only pass it when set, so the default width is used otherwise (avoids an
    # "empty aesthetic" warning when no width is supplied).
    width_opt <- if (!is.null(size)) list(linewidth = size) else list()
    p <- p + do.call(
      ggplot2::geom_vline,
      c(
        list(
          xintercept = m, color = color,
          linetype = linetype, inherit.aes = FALSE
        ),
        width_opt
      )
    )
  }
  # Case of grouping variable
  else {
    data_sum <- data %>%
      group_by(!!!syms(grouping.vars)) %>%
      summarise(.center = compute_center(!!sym(x), na.rm = TRUE))
    p <- p + geom_exec(geom_vline,
      data = data_sum,
      xintercept = ".center", color = color,
      linetype = linetype, linewidth = size,
      inherit.aes = FALSE
    )
  }

  p
}


# Check legend argument
.check_legend <- function(legend) {
  allowed.values <- c("top", "bottom", "left", "right", "none")

  if (is.null(legend) | is.numeric(legend)) {
    return(legend)
  } else if (is.logical(legend)) {
    if (legend) {
      legend <- "top"
    } else {
      legend <- "none"
    }
  } else if (is.character(legend)) {
    legend <- legend[1]
    if (!legend %in% allowed.values) {
      stop("Argument legend should be one of ", .collapse(allowed.values, sep = ", "))
    }
  }
  return(legend)
}


# show.n: per-group observation counts on box/violin/strip charts (#598, #627)
# +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
# Dodge width implied by a position (NULL = the layer is not dodged).
.dodge_width_of <- function(position) {
  if (is.null(position)) return(NULL)
  if (is.character(position)) {
    if (position %in% c("dodge", "dodge2")) return(0.8)
    if (position == "jitterdodge") return(0.75)
    return(NULL)
  }
  if (inherits(position, "PositionJitterdodge")) return(position$dodge.width %||% 0.75)
  if (inherits(position, c("PositionDodge2", "PositionDodge"))) return(position$width %||% 0.8)
  NULL
}

# Facet variables actually used by the plot. Reads them from the facet object so
# the internal `.y.` panel of combine = TRUE is handled like any other facet.
.plot_facet_vars <- function(p) {
  f <- p$facet
  if (is.null(f) || inherits(f, "FacetNull")) return(character(0))
  pr <- f$params
  unique(c(names(pr$facets), names(pr$rows), names(pr$cols)))
}

# Add "n = <count>" labels at the top of each panel, one per group. Counts are
# taken from the plot's own data (so select/remove/order and combine's reshaped
# data are respected). When the groups are dodged (a dodging position + a
# colour/fill grouping), the labels dodge to sit above each box; otherwise a
# single count per x tick is shown. Opt-in via show.n = TRUE; default output is
# unchanged.
.add_show_n <- function(p, x, color = NULL, fill = NULL, facet.by = NULL,
                        position = NULL, size = 3.2, vjust = 1.4) {
  d <- p$data
  if (is.null(d) || !(x %in% colnames(d))) return(p)
  group <- intersect(unique(c(color, fill)), colnames(d))
  facet.vars <- intersect(unique(c(.plot_facet_vars(p), facet.by)), colnames(d))
  dodge.w <- .dodge_width_of(position)
  dodged <- length(group) > 0 && !is.null(dodge.w)
  keys <- if (dodged) unique(c(facet.vars, x, group)) else unique(c(facet.vars, x))
  keys <- intersect(keys, colnames(d))
  cnt <- d %>%
    dplyr::group_by(dplyr::across(dplyr::all_of(keys))) %>%
    dplyr::summarise(.n = dplyr::n(), .groups = "drop") %>%
    as.data.frame()
  if (nrow(cnt) == 0) return(p)
  cnt$.n. <- paste0("n = ", cnt$.n)
  # y = Inf pins the label to the top of each panel (facet-robust); the .data
  # pronoun keeps non-syntactic column names (spaces/hyphens) working.
  if (dodged) {
    # dodge by the interaction of all grouping columns, matching the boxes.
    # Use a collision-proof temp column name (never a real data column).
    grp.col <- ".ggpubr_show_n_grp."
    cnt[[grp.col]] <- interaction(cnt[group], drop = TRUE, lex.order = TRUE)
    mapping <- ggplot2::aes(
      x = .data[[x]], y = Inf, label = .data$.n., group = .data[[grp.col]]
    )
    pos <- ggplot2::position_dodge(width = dodge.w)
  } else {
    mapping <- ggplot2::aes(x = .data[[x]], y = Inf, label = .data$.n.)
    pos <- "identity"
  }
  p + ggplot2::geom_text(
    data = cnt, mapping = mapping, position = pos, vjust = vjust,
    size = size, colour = "black", inherit.aes = FALSE, show.legend = FALSE
  )
}
