R/zzz.R

In esviz: Plotting Functions for Climate Science and Services

.KnownLonNames <- function() {
  known_lon_names <- c('lon', 'longitude', 'x', 'i', 'nav_lon')
}

.KnownLatNames <- function() {
  known_lat_names <- c('lat', 'latitude', 'y', 'j', 'nav_lat')
}

.IsColor <- function(x) {
  res <- try(col2rgb(x), silent = TRUE)
  return(!"try-error" %in% class(res))
}

.FilterUserGraphicArgs <- function(excludedArgs, ...) {
  # This function filter the extra graphical parameters passed by the user in
  # a plot function, excluding the ones that the plot function uses by default.
  # Each plot function has a different set of arguments that are not allowed to
  # be modified.
  args <- list(...)
  userArgs <- list()
  for (name in names(args)) {
      if ((name != "") & !is.element(name, excludedArgs)) {
          # If the argument has a name and it is not in the list of excluded
          # arguments, then it is added to the list that will be used
          userArgs[[name]] <- args[[name]]
      } else {
        warning(paste0("the argument '", name, "' can not be 
        modified and the new value will be ignored"))
      }
  }
  userArgs
}

.SelectDevice <- function(fileout, width, height, units, res) {
  # This function is used in the plot functions to check the extension of the 
  # files where the graphics will be stored and select the right R device to 
  # save them.
  # If the vector of filenames ('fileout') has files with different 
  # extensions, then it will only accept the first one, changing all the rest 
  # of the filenames to use that extension.

  # We extract the extension of the filenames: '.png', '.pdf', ...
  ext <- regmatches(fileout, regexpr("\\.[a-zA-Z0-9]*$", fileout))

  if (length(ext) != 0) {
    # If there is an extension specified, select the correct device
    ## units of width and height set to accept inches
    if (ext[1] == ".png") {
      saveToFile <- function(fileout) {
        png(filename = fileout, width = width, height = height, res = res, units = units)
      }
    } else if (ext[1] == ".jpeg") {
      saveToFile <- function(fileout) {
        jpeg(filename = fileout, width = width, height = height, res = res, units = units)
      }
    } else if (ext[1] %in% c(".eps", ".ps")) {
      saveToFile <- function(fileout) {
        postscript(file = fileout, width = width, height = height)
      }
    } else if (ext[1] == ".pdf") {
      saveToFile <- function(fileout) {
        pdf(file = fileout, width = width, height = height)
      }
    } else if (ext[1] == ".svg") {
      saveToFile <- function(fileout) {
        svg(filename = fileout, width = width, height = height)
      }
    } else if (ext[1] == ".bmp") {
      saveToFile <- function(fileout) {
        bmp(filename = fileout, width = width, height = height, res = res, units = units)
      }
    } else if (ext[1] == ".tiff") {
      saveToFile <- function(fileout) {
        tiff(filename = fileout, width = width, height = height, res = res, units = units)
      }
    } else {
      warning("file extension not supported, it will be used '.eps' by default.")
      ## In case there is only one filename
      fileout[1] <- sub("\\.[a-zA-Z0-9]*$", ".eps", fileout[1])
      ext[1] <- ".eps"
      saveToFile <- function(fileout) {
        postscript(file = fileout, width = width, height = height)
      }
    }
    # Change filenames when necessary
    if (any(ext != ext[1])) {
      warning(paste0("some extensions of the filenames provided in 'fileout' are not ", ext[1],". The extensions are being converted to ", ext[1], "."))
      fileout <- sub("\\.[a-zA-Z0-9]*$", ext[1], fileout)
    }
  } else {
    # Default filenames when there is no specification
    warning("there are no extensions specified in the filenames, default to '.eps'")
    fileout <- paste0(fileout, ".eps")
    saveToFile <- postscript
  }

  # return the correct function with the graphical device, and the correct 
  # filenames
  list(fun = saveToFile, files = fileout)
}

#Draws Color Bars for Categories
#A wrapper of ColorBar to generate multiple color bars for different 
#categories, and each category has different color set.
#Draws Color Bars for Categories
#A wrapper of ColorBarContinuous to generate multiple color bars for different 
#categories, and each category has different color set.
#'@import utils
GradientCatsColorBar <- function(nmap, brks = NULL, cols = NULL, vertical = TRUE, subsampleg = NULL,
                                 bar_limits, var_limits = NULL,
                                 triangle_ends = NULL, col_inf = NULL, col_sup = NULL, plot = TRUE,
                                 draw_separators = FALSE,
                                 bar_titles = NULL, title_scale = 1, bar_label_scale = 1, bar_extra_margin = rep(0, 4),
                                 ...) {

  # bar_limits: a vector of 2 or a list 
  if (!is.list(bar_limits)) {
    if (!is.numeric(bar_limits) || length(bar_limits) != 2) {
      stop("Parameter 'bar_limits' must be a numeric vector of length 2 or a list containing that.")
    }
    # turn into list
    bar_limits <- rep(list(bar_limits), nmap)
  } else {
    if (any(!sapply(bar_limits, is.numeric)) || any(sapply(bar_limits, length) != 2)) {
      stop("Parameter 'bar_limits' must be a numeric vector of length 2 or a list containing that.")
    }
    if (length(bar_limits) != nmap) {
      stop("Parameter 'bar_limits' must have the length of 'nmap'.")
    }
  }
  # Check brks
  if (!is.list(brks)) {
    if (is.null(brks)) {
      brks <- 5
    } else if (!is.numeric(brks)) {
      stop("Parameter 'brks' must be a numeric vector.")
    }
    # Turn it into list
    brks <- rep(list(brks), nmap)
  } else {
    if (length(brks) != nmap) {
      stop("Parameter 'brks' must have the length of 'nmap'.")
    }
  }
  for (i_map in 1:nmap) {
    if (length(brks[[i_map]]) == 1) {
      brks[[i_map]] <- seq(from = bar_limits[[i_map]][1], to = bar_limits[[i_map]][2], length.out = brks[[i_map]])
    }
  }

  # Check cols
  col_sets <- list(c("#A1D99B", "#74C476", "#41AB5D", "#238B45"),
                   c("#6BAED6FF", "#4292C6FF", "#2171B5FF", "#08519CFF"),
                   c("#FFEDA0FF", "#FED976FF", "#FEB24CFF", "#FD8D3CFF"),
                   c("#FC4E2AFF", "#E31A1CFF", "#BD0026FF", "#800026FF"),
                   c("#FCC5C0", "#FA9FB5", "#F768A1", "#DD3497"))
  if (is.null(cols)) {
    if (length(col_sets) >= nmap) {
      chosen_sets <- 1:nmap
      chosen_sets <- chosen_sets + floor((length(col_sets) - length(chosen_sets)) / 2)
    } else {
      chosen_sets <- array(1:length(col_sets), nmap)
    }
    cols <- col_sets[chosen_sets]

    # Set triangle_ends, col_sup, col_inf
    #NOTE: The "col" input of ColorBar() later is not NULL (since we determine it here)
    #      so ColorBar() cannot decide these parameters for us.
    #NOTE: Here, col_inf and col_sup are prior to triangle_ends, which is consistent with ColorBar().
    #TODO: Make triangle_ends a list
    if (is.null(triangle_ends)) {
      if (!is.null(var_limits)) {
        triangle_ends <- c(FALSE, FALSE)
        #TODO: bar_limits is a list
        if (bar_limits[1] >= var_limits[1] | !is.null(col_inf)) {
          triangle_ends[1] <- TRUE
          if (is.null(col_inf)) {
            col_inf <-  lapply(cols, head, 1)
            cols <-  lapply(cols, '[', -1)
          }
        }
        if (bar_limits[2] < var_limits[2] | !is.null(col_sup)) {
          triangle_ends[2] <- TRUE
          if (is.null(col_sup)) {
            col_sup <- lapply(cols, tail, 1)
            cols <- lapply(cols, '[', -length(cols[[1]]))
          }
        }
      } else {
        triangle_ends <- c(!is.null(col_inf), !is.null(col_sup))
      }
    } else {  # triangle_ends has values
      if (triangle_ends[1] & is.null(col_inf)) {
        col_inf <-  lapply(cols, head, 1)
        cols <-  lapply(cols, '[', -1)
      }
      if (triangle_ends[2] & is.null(col_sup)) {
        col_sup <- lapply(cols, tail, 1)
        cols <- lapply(cols, '[', -length(cols[[1]]))
      }
    }

  } else {
    if (!is.list(cols)) {
      stop("Parameter 'cols' must be a list of character vectors.")
    }
    if (!all(sapply(cols, is.character))) {
      stop("Parameter 'cols' must be a list of character vectors.")
    }
    if (length(cols) != nmap) {
     stop("Parameter 'cols' must be a list of the same length as 'nmap'.")
    }
  }
  for (i_map in 1:length(cols)) {
    if (length(cols[[i_map]]) != (length(brks[[i_map]]) - 1)) {
      cols[[i_map]] <- grDevices::colorRampPalette(cols[[i_map]])(length(brks[[i_map]]) - 1)
    }
  }

  # Check bar_titles
  if (is.null(bar_titles)) {
    if (nmap == 3) {
      bar_titles <- c("Below normal (%)", "Normal (%)", "Above normal (%)")
    } else if (nmap == 5) {
      bar_titles <- c("Low (%)", "Below normal (%)",
                         "Normal (%)", "Above normal (%)", "High (%)")
    } else {
      bar_titles <- paste0("Cat. ", 1:nmap, " (%)")
    }
  }

  if (plot) {
    for (k in 1:nmap) {
      ColorBarContinuous(brks = brks[[k]], cols = cols[[k]], vertical = FALSE, subsampleg = subsampleg,
                         bar_limits = bar_limits[[k]], #var_limits = var_limits,
                         triangle_ends = triangle_ends, col_inf = col_inf[[k]], col_sup = col_sup[[k]],  plot = TRUE,
                         draw_separators = draw_separators,
                         title = bar_titles[[k]], title_scale = title_scale,
                         bar_label_scale = bar_label_scale, bar_extra_margin = bar_extra_margin)
    }
  } else {
    return(list(brks = brks, cols = cols, col_inf = col_inf, col_sup = col_sup))
  }

}

# Decide var_limits for ColorBarContinuous()
.create_var_limits <- function(data, brks, bar_limits, drawleg) {
  if (!all(is.na(data))) {
    var_limits <- c(min(data[!is.infinite(data)], na.rm = TRUE),
                    max(data[!is.infinite(data)], na.rm = TRUE))
  } else {
    warning("All the data are NAs. The map will be filled with colNA.")
    if (!is.null(brks) && length(brks) > 1) {
      #NOTE: var_limits be like this to avoid warnings from ColorBar
      var_limits <- c(min(brks, na.rm = TRUE) + diff(brks)[1], 
                      max(brks, na.rm = TRUE))
    } else if (!is.null(bar_limits)) {
      var_limits <- c(bar_limits[1] + 0.01, bar_limits[2])
    } else {
      var_limits <- c(-0.5, 0.5) # random range since colorbar is not going to be plotted
      if (!isFALSE(drawleg)) {
        drawleg <- FALSE
        warning("All data are NAs. Color bar won't be drawn. If you want to have ",
                 "color bar still, define parameter 'brks' or 'bar_limits'.")
      }
    }
  }
  return(list(var_limits = var_limits, drawleg = drawleg))
}

utils::globalVariables(c("geometry", "value", "int", "new_scale", "obs.color", 
                         "density", "integrate", "approxfun"))