R/utils_matrix_plot.R

In distantia: Advanced Toolset for Efficient Time Series Dissimilarity Analysis

#' Plot Distance or Cost Matrix and Least Cost Path
#'
#' @description
#' This function is a simplified version of [fields::imagePlot()], by [Douglas Nychka](https://dnychka.github.io/). The original version is recommended in case more customization than the provided here is needed.
#'
#'
#' @param m (required, numeric matrix) distance or cost matrix generated by [psi_distance_matrix()] or [psi_cost_matrix()], but any numeric matrix will work. Default: NULL
#' @param matrix_color (optional, character vector) vector of colors. Uses the palette "Zissou 1" by default. Default: NULL
#' @param title (optional, character string) plot title. By default, names of the sequences used to compute the matrix `m`. Default: NULL
#' @param subtitle (optional, character string) plot subtitle. Default: NULL
#' @param xlab (optional, character string) title of the x axis (matrix columns). By default, the name of one of the sequences used to compute the matrix `m`. Default: NULL
#' @param ylab (optional, character string) title of the y axis (matrix rows). By default, the name of one of the sequences used to compute the matrix `m`. Default: NULL
#' @param text_cex (optional, numeric) multiplicator of the text size for the plot labels and titles. Default: 1
#' @param path (optional, data frame) least cost path generated with [psi_cost_path()]. This data frame must have the attribute `type == "cost_path`, and must have been computed from the same sequences used to compute the matrix `m`. Default: NULL.
#' @inheritParams distantia_dtw_plot
#' @param guide (optional, logical) if TRUE, a color guide for the matrix `m` is added by [utils_matrix_guide()].
#' @param subpanel (optional, logical) internal argument used when generating the multi-panel plot produced by [distantia_dtw_plot()].
#'
#' @return plot
#' @examples
#' #prepare time series list
#' tsl <- tsl_simulate(
#'   n = 2,
#'   independent = TRUE
#' )
#'
#' #distance matrix between time series
#' dm <- psi_distance_matrix(
#'   x = tsl[[1]],
#'   y = tsl[[2]]
#' )
#'
#' #cost matrix
#' cm <- psi_cost_matrix(
#'   dist_matrix = dm
#'   )
#'
#' #least cost path
#' cp <- psi_cost_path(
#'   dist_matrix = dm,
#'   cost_matrix = cm
#' )
#'
#' #plot cost matrix and least cost path
#' if(interactive()){
#'   utils_matrix_plot(
#'     m = cm,
#'     path = cp,
#'     guide = TRUE
#'   )
#' }
#' @export
#' @autoglobal
#' @family internal_plotting
utils_matrix_plot <- function(
    m = NULL,
    matrix_color = NULL,
    title = NULL,
    subtitle = NULL,
    xlab = NULL,
    ylab = NULL,
    text_cex = 1,
    path = NULL,
    path_width = 1,
    path_color = "black",
    diagonal_width = 1,
    diagonal_color = "white",
    guide = TRUE,
    subpanel = FALSE
){

  #First to upper
  firstup <- function(x) {
    substr(x, 1, 1) <- toupper(substr(x, 1, 1))
    x
  }

  # Preserve user's config
  if(subpanel == FALSE){
    old.par <- graphics::par(no.readonly = TRUE)
    on.exit(graphics::par(old.par))
  }

  #check m
  m <- utils_check_args_matrix(m = m)

  #specific behaviours by matrix type
  m_type <- attributes(m)$type

  #generic matrix
  if(is.null(m_type)){

    m_type <- "generic"
    attr(x = m, which = "x_name") <- "x"
    attr(x = m, which = "y_name") <- "y"
    attr(x = m, which = "x_time") <- seq_len(ncol(m))
    attr(x = m, which = "y_time") <- seq_len(nrow(m))
    guide_title <- "Legend"

  } else {

    if(m_type == "distance"){
      guide_title <- paste0(
        attributes(m)$distance,
        "\ndistance"
      )
    }

    if(m_type == "cost"){
      guide_title <- paste0(
        attributes(m)$distance,
        "\ncumulative\ncost"
      )
    }

  }

  x_name <- attributes(m)$x_name
  y_name <- attributes(m)$y_name


  if(is.null(title)){
    title <- paste0(
      attributes(m)$y_name,
      " vs. ",
      attributes(m)$x_name
    )
  }

  if(is.null(xlab)){
    xlab <- x_name
  }

  if(is.null(ylab)){
    ylab <- y_name
  }

  #get axes time
  axis_x_labels <- attributes(m)$x_time
  axis_y_labels <- attributes(m)$y_time

  #to pretty
  axis_x_labels_pretty <- pretty(x = axis_x_labels)
  axis_y_labels_pretty <- pretty(x = axis_y_labels)

  #axis positions closest to pretty version
  axis_x_at <- lapply(
    X = axis_x_labels_pretty,
    FUN = function(x){
      which.min(abs(as.numeric(x - axis_x_labels)))
    }
  ) |>
    unlist()

  axis_y_at <- lapply(
    X = axis_y_labels_pretty,
    FUN = function(x){
      which.min(abs(as.numeric(x - axis_y_labels)))
    }
  ) |>
    unlist()

  axis_x_labels <- attributes(axis_x_labels_pretty)$labels
  axis_y_labels <- attributes(axis_y_labels_pretty)$labels

  #psi matrix
  if(m_type == "distantia_matrix"){

    if(is.null(title)){
      title <- "Dissimilarity Matrix"
    }

    guide_title <- "Psi \ndistance"

    if(is.null(xlab)){
      xlab <- ""
    }

    if(is.null(ylab)){
      ylab <- ""
    }

    axis_x_at <- seq_len(ncol(m))
    axis_y_at <- seq_len(nrow(m))

    axis_x_labels <- axis_y_labels <- dimnames(m)[[2]]

  }

  guide_title <- firstup(x = guide_title)

  #axis title
  #leave more space if axis needs dates
  if(
    class(attributes(m)$x_time) %in% c("Date", "POSIXct") &&
    subpanel == FALSE
  ){

    axis_title_distance <- 2.5
    axis_labels_cex <- 0.6 * text_cex

  } else {

    axis_title_distance <- 2.2
    axis_labels_cex <- 0.8 * text_cex

  }

  #title cex
  axis_title_cex <- 0.9 * text_cex

  #plotting areas
  plt_all <- graphics::par()$plt
  plt_m <- plt_all

  if(guide == TRUE){

    plt_m <- c(
      plt_m[1],
      plt_m[2] - 0.1,
      plt_m[3],
      plt_m[4]
    )

    plt_guide <- c(
      plt_m[2] + 0.02,
      plt_all[2] - 0.05,
      plt_m[3],
      plt_m[4]
    )

  }

  #title
  main_title_distance <- ifelse(
    test = is.null(subtitle),
    yes = 1.2,
    no = 2
  )
  main_title_cex <- 1.2 * text_cex

  #subtitle
  subtitle_distance <- 0.5
  subtitle_cex <- 1 * text_cex

  if(is.null(matrix_color)){
    matrix_color = color_continuous(
      n = 100
    )
  }

  breaks <- utils_color_breaks(
    m = m,
    n = length(matrix_color)
  )

  graphics::par(
    plt = plt_m
  )

  #plot matrix
  graphics::image(
    x = seq_len(ncol(m)),
    y = seq_len(nrow(m)),
    z = t(m),
    breaks = breaks,
    col = matrix_color,
    xlab = "",
    ylab = "",
    axes = FALSE,
    useRaster = FALSE,
    add = FALSE
  )

  if(subpanel == FALSE){

    graphics::title(
      xlab = xlab,
      line = axis_title_distance,
      cex.lab = axis_title_cex
    )

    graphics::title(
      ylab = ylab,
      line = axis_title_distance,
      cex.lab = axis_title_cex
    )


    graphics::axis(
      side = 1,
      at = axis_x_at,
      labels = axis_x_labels,
      cex.axis = axis_labels_cex,
      las = 2
    )

    graphics::axis(
      side = 2,
      at = axis_y_at,
      labels = axis_y_labels,
      cex.axis = axis_labels_cex,
      las = 2
    )

  }

  graphics::title(
    main = title,
    cex.main = main_title_cex,
    line = main_title_distance
  )

  # matrix subtitle ----
  if(!is.null(subtitle)){

    graphics::mtext(
      side = 3,
      line = subtitle_distance,
      at = NA,
      adj = NA,
      padj = NA,
      outer = FALSE,
      cex = subtitle_cex,
      subtitle
    )

  }

  #plot diagonal
  graphics::lines(
    x = c(0, ncol(m) + 0.5),
    y = c(0, nrow(m) + 0.5),
    lwd = diagonal_width,
    col = diagonal_color
  )

  # least cost path ----
  if(!is.null(path)){

    path <- utils_check_args_path(
      path = path
    )

    if(is.null(attributes(path)$x_name)){
      attr(x = path, which = "x_name") <- "x"
    }

    if(is.null(attributes(path)$y_name)){
      attr(x = path, which = "y_name") <- "y"
    }

    if(
      attributes(path)$y_name != y_name ||
      attributes(path)$x_name != x_name
    ){
      stop("distantia::utils_matrix_plot(): time series names in arguments 'm' and 'path' do not match.", call. = FALSE)
    }

    #rename path columns
    colnames(path)[colnames(path) == "y"] <- y_name
    colnames(path)[colnames(path) == "x"] <- x_name

    #Sakoe-Chiba band
    if("bandwidth" %in% colnames(path)){

      bandwidth <- path$bandwidth[1]

      graphics::lines(
        x = c(ncol(m) * bandwidth, ncol(m)),
        y = c(0, nrow(m) - (nrow(m) * bandwidth)),
        lwd = diagonal_width,
        lty = "dotted",
        col = diagonal_color
      )

      graphics::lines(
        x = c(0, ncol(m) - (ncol(m) * bandwidth)),
        y = c(nrow(m) * bandwidth, nrow(m)),
        lwd = diagonal_width,
        lty = "dotted",
        col = diagonal_color
      )

    }

    #plot cost path
    graphics::lines(
      x = path[[attributes(m)$x_name]],
      y = path[[attributes(m)$y_name]],
      lwd = path_width,
      col = path_color
    )

  }

  #guide
  if(guide == TRUE){

    graphics::par(
      plt = plt_guide,
      new = TRUE
    )

    utils_matrix_guide(
      m = m,
      matrix_color = matrix_color,
      breaks = breaks,
      title = guide_title,
      text_cex = text_cex
    )

  }

  invisible()

}