R/plot_blup.R

In metan: Multi Environment Trials Analysis

#' Plot the BLUPs for genotypes
#' @description
#' `r badge('stable')`
#'
#' Plot the predicted BLUP of the genotypes.
#'
#'
#' @param x The `waasb object`
#' @param var The variable to plot. Defaults to `var = 1` the first
#'   variable of `x`.
#' @param which Which plot to shown. If `which = "gen"` (default) plots the
#'   BLUPs for genotypes. To create a plot showing the BLUPs for
#'   genotype-environment combinations, use `which = "ge"`.
#' @param ncol,nrow The number of columns and rows, respectively, to be shown in
#'   the plot when `which = "ge"`.
#' @param prob The probability error for constructing confidence interval.
#' @param export Export (or not) the plot. Default is `TRUE`.
#' @param file.type If `export = TRUE`, define the type of file to be
#'   exported. Default is `pdf`, Graphic can also be exported in
#'   `*.tiff` format by declaring `file.type = "tiff"`.
#' @param file.name The name of the file for exportation, default is
#'   `NULL`, i.e. the files are automatically named.
#' @param plot_theme The graphical theme of the plot. Default is
#'   `plot_theme = theme_metan()`. For more details, see
#'   [ggplot2::theme()].
#' @param width The width "inch" of the plot. Default is `6`.
#' @param height The height "inch" of the plot. Default is `6`.
#' @param size.shape The size of the shape (both for genotypes and
#'   environments). Default is `3.5`.
#' @param size.tex.lab The size of the text in axis text and labels.
#' @param err.bar Logical value to indicate if an error bar is shown. Defaults
#'   to `TRUE`.
#' @param size.err.bar The size of the error bar for the plot. Default is
#'   `0.5`.
#' @param height.err.bar The height for error bar. Default is `0.3`.
#' @param x.lim The range of x-axis. Default is `NULL` (maximum and minimum
#'   values of the data set). New arguments can be inserted as `x.lim =
#'   c(x.min, x.max)`.
#' @param x.breaks The breaks to be plotted in the x-axis. Default is
#'   `authomatic breaks`. New arguments can be inserted as `x.breaks =
#'   c(breaks)`
#' @param col.shape A vector of length 2 that contains the color of shapes for
#'   genotypes above and below of the mean, respectively. Default is
#'   `c("blue", "red")`.
#' @param x.lab The label of the x-axis in the plot. Default is `NULL`,
#'   i.e., the name of the selected variable.
#' @param y.lab The label of the y-axis in the plot. Default is
#'   `"Genotypes"`.
#' @param n.dodge The number of rows that should be used to render the Y labels.
#'   This is useful for displaying labels that would otherwise overlap.
#' @param check.overlap Silently remove overlapping labels, (recursively)
#'   prioritizing the first, last, and middle labels.
#' @param panel.spacing Defines the spacing between panels when `which =
#'   "ge"`.
#' @param resolution The resolution of the plot. Parameter valid if
#'   `file.type = "tiff"` is used. Default is `300` (300 dpi)
#' @param ... Currently not used.
#' @return An object of class `gg, ggplot`.
#' @author Tiago Olivoto \email{tiagoolivoto@@gmail.com}
#' @seealso [plot_scores()], [plot_waasby()]
#' @export
#' @examples
#'\donttest{
#' library(metan)
#' BLUP <- waasb(data_ge2,
#'               resp = PH,
#'               gen = GEN,
#'               env = ENV,
#'               rep = REP)
#' plot_blup(BLUP)
#' plot_blup(BLUP, which = "ge")
#'
#'}
#'
#'
plot_blup <- function(x,
                      var = 1,
                      which = "gen",
                      ncol = NULL,
                      nrow = NULL,
                      prob = 0.05,
                      export = FALSE,
                      file.type = "pdf",
                      file.name = NULL,
                      plot_theme = theme_metan(),
                      width = 6,
                      height = 6,
                      err.bar = TRUE,
                      size.err.bar = 0.5,
                      size.shape = 3.5,
                      size.tex.lab = 12,
                      height.err.bar = 0.3,
                      x.lim = NULL,
                      x.breaks = waiver(),
                      col.shape = c("blue", "red"),
                      y.lab = "Genotypes",
                      x.lab = NULL,
                      n.dodge = 1,
                      check.overlap = FALSE,
                      panel.spacing = 0.15,
                      resolution = 300, ...) {
    x.lab <- ifelse(missing(x.lab), names(x[var]), x.lab)
    if(!which %in% c("gen", "ge")){
        stop("Argument 'which' must be one of 'gen' or 'ge'.", call. = FALSE)
    }
    x <- x[[var]]
    if(!class(x)  %in% c("waasb", "gamem")){
        stop("The object 'x' must be of class 'waasb' or 'gamem'.")
    }
    if(inherits(x, "gamem")){
        PROB <- ((1 - (1 - prob))/2) + (1 - prob)
        t <- qt(PROB, nlevels(x$residuals$REP))
        GV <- as.numeric(x$ESTIMATES[1, 2])
        AccuGen <- as.numeric(x$ESTIMATES[8, 2])
        Limits <- t * sqrt(((1 - AccuGen) * GV))
        blup <- x$BLUPgen %>%
            mutate(LL = Predicted - Limits,
                   UL = Predicted + Limits,
                   Mean = ifelse(Predicted < mean(Predicted), "below", "above")) %>%
            arrange(Predicted)
    }
    if(inherits(x, "waasb")){
        PROB <- ((1 - (1 - prob))/2) + (1 - prob)
        t <- qt(PROB, nlevels(x$residuals$REP))
        GV <- as.numeric(x$random[which(x$random$Group == "GEN"), 2])
        AccuGen <- as.numeric(x$ESTIMATES[which(x$ESTIMATES$Parameters == "Accuracy"), 2])
        Limits <- t * sqrt(((1 - AccuGen) * GV))
        if(which == "gen"){
        blup <-
            x$BLUPgen %>%
            mutate(LL = Predicted - Limits,
                   UL = Predicted + Limits,
                   Mean = ifelse(Predicted < mean(Predicted), "below", "above")) %>%
            arrange(Predicted)
        } else{
            blup <-
                x$BLUPint %>%
                mean_by(ENV, GEN) %>%
                mutate(LL = Predicted - Limits,
                       UL = Predicted + Limits,
                       Mean = ifelse(Predicted < mean(Predicted), "below", "above"))
        }
    }
    p1 <-
        ggplot(blup, aes(x = Predicted, y = reorder(GEN, Predicted))) +
        geom_vline(xintercept = mean(blup$Predicted), linetype = 2) +
        scale_fill_manual(name = "Average", values = col.shape, labels = c("Above", "Below")) +
        labs(x = x.lab, y = y.lab) +
        scale_x_continuous(limits = x.lim, breaks = x.breaks) +
        scale_y_discrete(guide = guide_axis(n.dodge = n.dodge, check.overlap = check.overlap)) +
        plot_theme %+replace% theme(axis.text = element_text(size = size.tex.lab,colour = "black"),
                               axis.title = element_text(size = size.tex.lab, colour = "black"))
    if(err.bar == TRUE){
        p1 <- p1 +
            geom_errorbarh(aes(xmin = LL, xmax = UL), size = size.err.bar, height = height.err.bar) +
            geom_point(stat = "identity", aes(fill = Mean), shape = 21, size = size.shape)
    }
    if(which == "ge"){
    p1 <- p1 +
        facet_wrap(~ENV, ncol = ncol, nrow = nrow) +
        theme(panel.spacing = unit(panel.spacing, "cm"),
              legend.position = "bottom")
    }

    if (export == FALSE) {
        return(p1)
    } else if (file.type == "pdf") {
        if (is.null(file.name)) {
            pdf("BLUPs genotypes.pdf", width = width, height = height)
        } else pdf(paste0(file.name, ".pdf"), width = width, height = height)
        plot(p1)
        dev.off()
    }
    if (file.type == "tiff") {
        if (is.null(file.name)) {
            tiff(filename = "BLUPs genotypes.tiff", width = width, height = height,
                 units = "in", compression = "lzw", res = resolution)
        } else tiff(filename = paste0(file.name, ".tiff"), width = width, height = height,
                    units = "in", compression = "lzw", res = resolution)
        plot(p1)
        dev.off()
    }
}