R/scale-fill.R

In houyunhuang/ggtriangle: Fast processing of matrix heatmap

#' Triangle colour scales
#'
#' This set of scales defines new fill scales for triangel geoms equivalent to the
#' ones already defined by ggplot2.
#'
#' @return A ggproto object inheriting from `Scale`
#' @inheritParams ggplot2::scale_fill_gradient
#' @param low,high Colours for low and high ends of the gradient.
#' @rdname scale_fill_upper
#'
#' @importFrom scales seq_gradient_pal
#' @importFrom ggplot2 continuous_scale
#' @export
scale_fill_upper_gradient <- function(..., low = "#132B43", high = "#56B1F7",
                                     space = "Lab", na.value = "grey50", guide = "colourbar2") {
  continuous_scale("fill.upper", "gradient", seq_gradient_pal(low, high, space),
                   na.value = na.value, guide = guide, ...
  )
}
#' @rdname scale_fill_upper
#'
#' @inheritParams ggplot2::scale_fill_gradient2
#'
#' @importFrom scales div_gradient_pal muted
#' @importFrom ggplot2 continuous_scale
#' @export
scale_fill_upper_gradient2 <- function(..., low = muted("red"), mid = "white", high = muted("blue"),
                                      midpoint = 0, space = "Lab", guide = "colourbar2", na.value = "grey50") {
  continuous_scale("fill.upper", "gradient2",
                   div_gradient_pal(low, mid, high, space),
                   na.value = na.value, ..., guide = guide,
                   rescaler = mid_rescaler(mid = midpoint)
  )
}
#' @rdname scale_fill_upper
#'
#' @inheritParams ggplot2::scale_fill_gradientn
#' @param colours,colors Vector of colours to use for n-colour gradient.
#'
#' @importFrom scales gradient_n_pal
#' @importFrom ggplot2 continuous_scale
#' @export
scale_fill_upper_gradientn <- function(..., colours, values = NULL, guide = "colourbar2",
                                       space = "Lab", na.value = "grey50", colors) {
  colours <- if (missing(colours)) colors else colours

  continuous_scale("fill.upper", "gradientn",
                   gradient_n_pal(colours, values, space),
                   na.value = na.value, guide = guide, ...
  )
}

#' @rdname scale_fill_upper
#'
#' @inheritParams ggplot2::scale_fill_identity
#'
#' @importFrom scales identity_pal
#' @importFrom ggplot2 discrete_scale ScaleDiscreteIdentity
#' @export
scale_fill_upper_identity <- function(...) {
  sc <- discrete_scale("fill.upper", "identity", identity_pal(), ...,
                       super = ScaleDiscreteIdentity
  )
  sc
}
#' @rdname scale_fill_upper
#'
#' @inheritParams ggplot2::scale_fill_manual
#' @export
scale_fill_upper_manual <- function(..., values, aesthetics = "fill.upper") {
  manual_scale(aesthetics, values, ...)
}

#' @rdname scale_fill_upper
#'
#' @inheritParams ggplot2::scale_fill_gradient
#'
#' @importFrom scales seq_gradient_pal
#' @importFrom ggplot2 continuous_scale
#' @export
scale_fill_lower_gradient <- function(..., low = "#132B43", high = "#56B1F7",
                                      space = "Lab", guide = "colourbar2", na.value = "grey50") {
  continuous_scale("fill.lower", "gradient", seq_gradient_pal(low, high, space),
                   na.value = na.value, guide = guide, ...
  )
}
#' @rdname scale_fill_upper
#'
#' @inheritParams ggplot2::scale_fill_gradient2
#'
#' @importFrom scales div_gradient_pal muted
#' @importFrom ggplot2 continuous_scale
#' @export
scale_fill_lower_gradient2 <- function(..., low = muted("red"), mid = "white", high = muted("blue"),
                                       midpoint = 0, space = "Lab", guide = "colourbar2", na.value = "grey50") {
  continuous_scale("fill.lower", "gradient2",
                   div_gradient_pal(low, mid, high, space),
                   na.value = na.value, guide = guide, ...,
                   rescaler = mid_rescaler(mid = midpoint)
  )
}
#' @rdname scale_fill_upper
#'
#' @inheritParams ggplot2::scale_fill_gradientn
#'
#' @importFrom scales gradient_n_pal
#' @importFrom ggplot2 continuous_scale
#' @export
scale_fill_lower_gradientn <- function(..., colours, values = NULL, space = "Lab",
                                       guide = "colourbar2", na.value = "grey50", colors) {
  colours <- if (missing(colours)) colors else colours

  continuous_scale("fill.lower", "gradientn",
                   gradient_n_pal(colours, values, space),
                   na.value = na.value, guide = guide, ...
  )
}

#' @rdname scale_fill_upper
#'
#' @inheritParams ggplot2::scale_fill_identity
#'
#' @importFrom scales identity_pal
#' @importFrom ggplot2 discrete_scale ScaleDiscreteIdentity
#' @export
scale_fill_lower_identity <- function(...) {
  sc <- discrete_scale("fill.lower", "identity", identity_pal(), ...,
                       super = ScaleDiscreteIdentity
  )
  sc
}

#' @rdname scale_fill_upper
#'
#' @inheritParams ggplot2::scale_fill_manual
#' @export
scale_fill_lower_manual <- function(..., values, aesthetics = "fill.upper") {
  manual_scale(aesthetics, values, ...)
}

#' Triangle colour scales
#'
#' This set of scales defines new colour scales for triangel geoms equivalent to the
#' ones already defined by ggplot2.
#'
#' @return A ggproto object inheriting from `Scale`
#' @inheritParams ggplot2::scale_colour_gradient
#' @param low,high Colours for low and high ends of the gradient.
#' @rdname scale_colour_upper
#'
#' @importFrom scales seq_gradient_pal
#' @importFrom ggplot2 continuous_scale
#' @export
scale_colour_upper_gradient <- function(..., low = "#132B43", high = "#56B1F7",
                                      space = "Lab", na.value = "grey50", guide = "colourbar2") {
  continuous_scale("colour.upper", "gradient", seq_gradient_pal(low, high, space),
                   na.value = na.value, guide = guide, ...
  )
}
#' @rdname scale_colour_upper
#'
#' @inheritParams ggplot2::scale_colour_gradient2
#'
#' @importFrom scales div_gradient_pal muted
#' @importFrom ggplot2 continuous_scale
#' @export
scale_colour_upper_gradient2 <- function(..., low = muted("red"), mid = "white", high = muted("blue"),
                                       midpoint = 0, space = "Lab", guide = "colourbar2", na.value = "grey50") {
  continuous_scale("colour.upper", "gradient2",
                   div_gradient_pal(low, mid, high, space),
                   na.value = na.value, ..., guide = guide,
                   rescaler = mid_rescaler(mid = midpoint)
  )
}
#' @rdname scale_colour_upper
#'
#' @inheritParams ggplot2::scale_colour_gradientn
#' @param colours,colors Vector of colours to use for n-colour gradient.
#'
#' @importFrom scales gradient_n_pal
#' @importFrom ggplot2 continuous_scale
#' @export
scale_colour_upper_gradientn <- function(..., colours, values = NULL, guide = "colourbar2",
                                       space = "Lab", na.value = "grey50", colors) {
  colours <- if (missing(colours)) colors else colours

  continuous_scale("colour.upper", "gradientn",
                   gradient_n_pal(colours, values, space),
                   na.value = na.value, guide = guide, ...
  )
}

#' @rdname scale_colour_upper
#'
#' @inheritParams ggplot2::scale_colour_identity
#'
#' @importFrom scales identity_pal
#' @importFrom ggplot2 discrete_scale ScaleDiscreteIdentity
#' @export
scale_colour_upper_identity <- function(...) {
  sc <- discrete_scale("colour.upper", "identity", identity_pal(), ...,
                       super = ScaleDiscreteIdentity
  )
  sc
}
#' @rdname scale_colour_upper
#'
#' @inheritParams ggplot2::scale_colour_manual
#' @export
scale_colour_upper_manual <- function(..., values, aesthetics = "colour.upper") {
  manual_scale(aesthetics, values, ...)
}

#' @rdname scale_colour_upper
#'
#' @inheritParams ggplot2::scale_colour_gradient
#'
#' @importFrom scales seq_gradient_pal
#' @importFrom ggplot2 continuous_scale
#' @export
scale_colour_lower_gradient <- function(..., low = "#132B43", high = "#56B1F7",
                                      space = "Lab", guide = "colourbar2", na.value = "grey50") {
  continuous_scale("colour.lower", "gradient", seq_gradient_pal(low, high, space),
                   na.value = na.value, guide = guide, ...
  )
}
#' @rdname scale_colour_upper
#'
#' @inheritParams ggplot2::scale_colour_gradient2
#'
#' @importFrom scales div_gradient_pal muted
#' @importFrom ggplot2 continuous_scale
#' @export
scale_colour_lower_gradient2 <- function(..., low = muted("red"), mid = "white", high = muted("blue"),
                                       midpoint = 0, space = "Lab", guide = "colourbar2", na.value = "grey50") {
  continuous_scale("colour.lower", "gradient2",
                   div_gradient_pal(low, mid, high, space),
                   na.value = na.value, guide = guide, ...,
                   rescaler = mid_rescaler(mid = midpoint)
  )
}
#' @rdname scale_colour_upper
#'
#' @inheritParams ggplot2::scale_colour_gradientn
#'
#' @importFrom scales gradient_n_pal
#' @importFrom ggplot2 continuous_scale
#' @export
scale_colour_lower_gradientn <- function(..., colours, values = NULL, space = "Lab",
                                       guide = "colourbar2", na.value = "grey50", colors) {
  colours <- if (missing(colours)) colors else colours

  continuous_scale("colour.lower", "gradientn",
                   gradient_n_pal(colours, values, space),
                   na.value = na.value, guide = guide, ...
  )
}

#' @rdname scale_colour_upper
#'
#' @inheritParams ggplot2::scale_colour_identity
#'
#' @importFrom scales identity_pal
#' @importFrom ggplot2 discrete_scale ScaleDiscreteIdentity
#' @export
scale_colour_lower_identity <- function(...) {
  sc <- discrete_scale("colour.lower", "identity", identity_pal(), ...,
                       super = ScaleDiscreteIdentity
  )
  sc
}

#' @rdname scale_colour_upper
#'
#' @inheritParams ggplot2::scale_colour_manual
#' @export
scale_colour_lower_manual <- function(..., values, aesthetics = "colour.upper") {
  manual_scale(aesthetics, values, ...)
}

#' @noRd
#' @importFrom ggplot2 discrete_scale
manual_scale <- function (aesthetic, values = NULL, ...)
{
  if (missing(values)) {
    values <- NULL
  }
  else {
    force(values)
  }
  pal <- function(n) {
    if (n > length(values)) {
      stop("Insufficient values in manual scale. ", n,
           " needed but only ", length(values), " provided.",
           call. = FALSE)
    }
    values
  }
  ggplot2::discrete_scale(aesthetic, "manual", pal, ...)
}