R/ge_effects.R

In TiagoOlivoto/WAASB: Multi Environment Trials Analysis

#' Genotype-environment effects
#' @description
#' `r badge('stable')`
#'
#' This is a helper function that computes the genotype-environment effects,
#' i.e., the residual effect of the additive model
#'
#'
#' @param .data The dataset containing the columns related to Environments,
#'   Genotypes, replication/block and response variable(s).
#' @param env The name of the column that contains the levels of the
#'   environments. The analysis of variance is computed for each level of this
#'   factor.
#' @param gen The name of the column that contains the levels of the genotypes.
#' @param resp The response variable(s). To analyze multiple variables in a
#'   single procedure a vector of variables may be used. For example `resp
#'   = c(var1, var2, var3)`.
#' @param type The type of effect to compute. Defaults to `"ge"`, i.e.,
#'   genotype-environment. To compute genotype plus genotype-environment effects
#'   use `type = "gge"`.
#' @param verbose Logical argument. If `verbose = FALSE` the code will run
#'   silently.
#' @return A list where each element is the result for one variable that
#'   contains a two-way table with genotypes in rows and environments in
#'   columns.
#' @author Tiago Olivoto \email{tiagoolivoto@@gmail.com}
#' @export
#' @examples
#' \donttest{
#' library(metan)
#' ge_eff <- ge_effects(data_ge, ENV, GEN, GY)
#' gge_eff <- ge_effects(data_ge, ENV, GEN, GY, type = "gge")
#' plot(ge_eff)
#' }
#'
ge_effects <- function(.data,
                       env,
                       gen,
                       resp,
                       type = "ge",
                       verbose = TRUE) {
  if(!type  %in% c("ge", "gge")){
    stop("Invalid value for the argument 'type': It must be either 'ge' or 'gge'", call. = FALSE)
  }
  factors  <-
    .data %>%
    select({{env}}, {{gen}}) %>%
    mutate(across(everything(), as.factor))
  vars <- .data %>% select({{resp}}, -names(factors))
  vars %<>% select_numeric_cols()
  factors %<>% set_names("ENV", "GEN")
  listres <- list()
  nvar <- ncol(vars)
  for (var in 1:nvar) {
    data <- factors %>%
      mutate(Y = vars[[var]])
    if(has_na(data)){
      data <- remove_rows_na(data)
      has_text_in_num(data)
    }
    data <- mean_by(data, ENV, GEN, na.rm = TRUE)
    if(type == "ge"){
      effects <- data %>%
        mutate(ge = residuals(lm(Y ~ ENV + GEN, data = data))) %>%
        make_mat(GEN, ENV, ge) %>%
        rownames_to_column("GEN") %>%
        as_tibble()
    } else{
      effects <- data %>%
        mutate(gge = residuals(lm(Y ~ ENV, data = data))) %>%
        make_mat(GEN, ENV, gge)    %>%
        rownames_to_column("GEN") %>%
        as_tibble()
    }
      listres[[paste(names(vars[var]))]] <- effects
  }
  return(structure(listres, class = "ge_effects"))
}







#' Plot an object of class ge_effects
#'
#' Plot the regression model generated by the function `ge_effects`.
#'
#'
#' @param x An object of class `ge_effects`
#' @param var The variable to plot. Defaults to `var = 1` the first
#'   variable of `x`.
#' @param plot_theme The graphical theme of the plot. Default is
#'   `plot_theme = theme_metan()`. For more details, see
#'   [ggplot2::theme()].
#' @param x.lab The label of x-axis. Each plot has a default value. New
#'   arguments can be inserted as `x.lab = "my label"`.
#' @param y.lab The label of y-axis. Each plot has a default value. New
#'   arguments can be inserted as `y.lab = "my label"`.
#' @param leg.position The position of the legend.
#' @param size.text The size of the text in the axes text and labels. Default
#'   is `12`.
#' @param ... Current not used.
#' @author Tiago Olivoto \email{tiagoolivoto@@gmail.com}
#' @seealso [ge_plot()]
#' @method plot ge_effects
#' @return An object of class `gg, ggplot`.
#' @export
#' @examples
#' \donttest{
#' library(metan)
#' ge_eff <- ge_effects(data_ge2, ENV, GEN, PH)
#' plot(ge_eff)
#' }
#'
plot.ge_effects <- function(x, var = 1, plot_theme = theme_metan(), x.lab = NULL, y.lab = NULL,
                            leg.position = "right", size.text = 12, ...){
  data <- x[[var]] %>%
    column_to_rownames("GEN") %>%
    make_long()
  names <- names(data)
  if (is.null(y.lab) == FALSE) {
    y.lab <- y.lab
  } else {
    y.lab <- names[1]
  }
  if (is.null(x.lab) == FALSE) {
    x.lab <- x.lab
  } else {
    x.lab <- names[2]
  }
  p <-
    ggplot(data, aes_string(names[2], names[1], fill= names[3])) +
    geom_tile()+
    scale_y_discrete(expand = expansion(mult = c(0,0)))+
    scale_x_discrete(expand = expansion(mult = c(0,0)))+
    scale_fill_gradient2()+
    guides(fill = guide_colourbar(label = TRUE,
                                  draw.ulim = TRUE,
                                  draw.llim = TRUE,
                                  frame.colour = "black",
                                  ticks = TRUE,
                                  nbin = 10,
                                  label.position = "right",
                                  barwidth = 1.3,
                                  barheight = 10,
                                  direction = 'vertical'))+
    labs(x = x.lab, y = y.lab)+
    plot_theme %+replace%
    theme(legend.position = leg.position,
          axis.title = element_text(size = size.text),
          axis.text = element_text(size = size.text),
          legend.text = element_text(size = size.text),
          legend.title = element_blank())
  return(p)

}