Commit 7fba49f8 authored by houyun's avatar houyun
Browse files

marker for heatmap

parent bb238a64

NAMESPACE

+20 −0
Original line number Diff line number Diff line
@@ -34,17 +34,21 @@ S3method(ggplot_add,geom_diag_label) 
S3method(ggplot_add,geom_panel_grid)

S3method(ggplot_add,magic_text)

S3method(ggplot_add,secondary_axis)

S3method(length,marker)

S3method(makeContent,markerGrob)

S3method(print,calc_relimp)

S3method(print,correlate)

S3method(print,grouped_correlate)

S3method(print,grouped_matrix_data)

S3method(print,hyplot)

S3method(print,marker)

S3method(print,matrix_data)

S3method(print,random_forest)

S3method(qcorrplot,cor_md_tbl)

S3method(qcorrplot,data.frame)

S3method(qcorrplot,default)

S3method(qcorrplot,matrix)

S3method(rep_len,marker)

export("%>%")

export("col_names<-")

export("row_names<-")
@@ -54,6 +58,7 @@ export(GeomDoughnut) 
export(GeomHalfcircle)

export(GeomMark)

export(GeomSquare)

export(Geomshaping)

export(aes)

export(anno_link)

export(as.igraph)
@@ -69,6 +74,7 @@ export(colour_pal) 
export(contain_with)

export(correlate)

export(dist_func)

export(draw_key_marker)

export(dudi_pca)

export(extract_diag)

export(extract_lower)
@@ -86,6 +92,7 @@ export(geom_magic_text) 
export(geom_mark)

export(geom_node_doughnut)

export(geom_panel_grid)

export(geom_shaping)

export(geom_square)

export(get_order)

export(grid.doughnut)
@@ -98,6 +105,7 @@ export(layout_tbl_graph_circular) 
export(layout_with_circular)

export(make_cluster)

export(mantel_test)

export(marker)

export(matrix_data)

export(mono_mds)

export(ncols)
@@ -113,6 +121,11 @@ export(regex_select) 
export(reorder_cols)

export(reorder_rows)

export(row_names)

export(scale_marker_binned)

export(scale_marker_continuous)

export(scale_marker_discrete)

export(scale_marker_identity)

export(scale_marker_manual)

export(secondary_x_axis)

export(secondary_y_axis)

export(set_corrplot_style)
@@ -125,15 +138,19 @@ importFrom(dplyr,bind_cols) 
importFrom(dplyr,bind_rows)

importFrom(dplyr,mutate)

importFrom(geomtextpath,GeomTextpath)

importFrom(ggplot2,Geom)

importFrom(ggplot2,GeomCurve)

importFrom(ggplot2,GeomPoint)

importFrom(ggplot2,GeomPolygon)

importFrom(ggplot2,GeomRect)

importFrom(ggplot2,GeomText)

importFrom(ggplot2,ScaleContinuousIdentity)

importFrom(ggplot2,aes)

importFrom(ggplot2,aes_)

importFrom(ggplot2,aes_string)

importFrom(ggplot2,binned_scale)

importFrom(ggplot2,coord_fixed)

importFrom(ggplot2,discrete_scale)

importFrom(ggplot2,draw_key_path)

importFrom(ggplot2,draw_key_polygon)

importFrom(ggplot2,draw_key_text)
@@ -155,10 +172,13 @@ importFrom(ggplot2,scale_y_discrete) 
importFrom(ggplot2,theme)

importFrom(ggplot2,waiver)

importFrom(grid,gTree)

importFrom(grid,get.gpar)

importFrom(grid,gpar)

importFrom(grid,grid.draw)

importFrom(grid,grobTree)

importFrom(grid,is.grob)

importFrom(grid,is.unit)

importFrom(grid,makeContent)

importFrom(grid,polygonGrob)

importFrom(grid,unit)

importFrom(grid,viewport)

R/geom-sharping.R

0 → 100644
+162 −0
Original line number Diff line number Diff line 
#' @title Key glyphs for marker

#' @description Designed to customize marker legends.

#' @param data a data frame.

#' @param params a list of additional parameters.

#' @param size width/height of key in mm.

#' @return a grid grob object.

#' @author Hou Yun

#' @rdname draw_key_marker

#' @export

draw_key_marker <- function(data, params, size) {

  marker <- marker(grob = data$marker %||% "square",

                   width = data$width %||% 1,

                   height = data$height %||% 1,

                   width_unit = params$width_unit,

                   height_unit = params$height_unit,

                   r = data$r %||% 0,

                   n = data$n %||% 5,

                   ratio = data$ratio %||% 0.618)

  markerGrob(marker = marker,

             x = 0.5,

             y = 0.5,

             angle = 0,

             hjust = 0.5,

             vjust = 0.5,

             default.units = "npc",

             gp = gpar(col  = data$colour %||% "grey20",

                       fill = scales::alpha(data$fill %||% "white", data$alpha),

                       lty  = data$linetype %||% 1,

                       size = (data$size %||% 0.5) * ggplot2::.pt

             ))

}



#' @title Shaping Layer

#' @description It can be used to draw custom marker on ggplot.

#' @inheritParams ggplot2::layer

#' @inheritParams ggplot2::geom_polygon

#' @param width_unit,height_unit units of width or height.

#' @section Aesthetics:

#' \code{geom_shaping()} understands the following aesthetics (required aesthetics are in bold):

#'     \itemize{

#'       \item \strong{\code{x}}

#'       \item \strong{\code{y}}

#'       \item \code{marker}

#'       \item \code{width}

#'       \item \code{height}

#'       \item \code{angle}

#'       \item \code{hjust}

#'       \item \code{vjust}

#'       \item \code{n}

#'       \item \code{r}

#'       \item \code{ratio}

#'       \item \code{colour}

#'       \item \code{fill}

#'       \item \code{alpha}

#'       \item \code{size}

#'       \item \code{linetype}

#'   }

#' @rdname geom_shaping

#' @author Hou Yun

#' @importFrom ggplot2 Geom

#' @export

#' @examples

#' qcorrplot(mtcars) + geom_shaping(marker = marker("heart"))

geom_shaping <- function(mapping = NULL,

                         data = NULL,

                         stat = "identity",

                         position = "identity",

                         ...,

                         width_unit = "native",

                         height_unit = width_unit,

                         na.rm = FALSE,

                         show.legend = NA,

                         inherit.aes = TRUE) {

  params <- rename(list(width_unit = width_unit,

                        height_unit = height_unit,

                        na.rm = na.rm,

                        ...), "shaping" = "marker")



  layer(

    data = data,

    mapping = mapping,

    stat = stat,

    geom = Geomshaping,

    position = position,

    show.legend = show.legend,

    inherit.aes = inherit.aes,

    params = params

  )

}



#' @rdname geom_shaping

#' @format NULL

#' @usage NULL

#' @export

Geomshaping <- ggproto(

  "Geomshaping", Geom,

  default_aes = aes(marker = "square", colour = "grey35", fill = NA, size = 0.25,

                    linetype = 1, alpha = NA, width = 1, height = 1, n = 5, r = 0,

                    angle = 0, hjust = 0.5, vjust = 0.5, ratio = 0.618),

  required_aes = c("x", "y"),



  draw_panel = function(self, data, panel_params, coord, shaping = NULL,

                        width_unit = NULL, height_unit = NULL) {

    if (empty(data)) {

      return(nullGrob())

    }



    ## handle native unit

    if (width_unit == "native") {

      data$width <- data$width / diff(panel_params$x.range)

    }

    if (height_unit == "native") {

      data$height <- data$height / diff(panel_params$y.range)

    }



    data <- coord$transform(data, panel_params)

    if (!tibble::is_tibble(data)) {

      data <- as_tibble(data)

    }

    n <- nrow(data)

    if (!is.null(shaping)) {

      if (!inherits(shaping, "marker")) {

        stop("shaping should be a marker object.", call. = FALSE)

      }

      shaping <- rep_len(shaping, n)



      shaping$width_unit <- width_unit %||% shaping$width_unit

      shaping$height_unit <- height_unit %||% width_unit %||% shaping$height_unit



      shaping$width <- ifelse(shaping$width_unit == "native",

                              shaping$width / diff(panel_params$x.range),

                              shaping$width)

      shaping$height <- ifelse(shaping$height_unit == "native",

                               shaping$height / diff(panel_params$y.range),

                               shaping$height)



    } else {

      shaping <- marker(grob = data$marker,

                        width = data$width,

                        height = data$height,

                        width_unit = width_unit %||% "native",

                        height_unit = height_unit %||% "native",

                        r = data$r,

                        n = data$n,

                        ratio = data$ratio)

    }

    markerGrob(marker = shaping,

               x = data$x,

               y = data$y,

               angle = data$angle,

               hjust = data$hjust,

               vjust = data$vjust,

               default.units = "native",

               gp = gpar(col  = scales::alpha(data$colour, data$alpha),

                         fill = scales::alpha(data$fill, data$alpha),

                         lty  = data$linetype,

                         size = data$size * ggplot2::.pt

               ))

  },



  draw_key = draw_key_marker

)

R/marker.R

0 → 100644
+328 −0
Original line number Diff line number Diff line 
#' @title Custom marker for heatmap plot

#' @description This set of functions makes it easy to define shapes, and it

#' similar to points.

#' @param grob grob object, list or character.

#' \itemize{

#'      \item{\strong{grob}: a \code{grob}, \code{gList}, \code{gTree} object.}

#'      \item{\strong{list}: a list of x and y.}

#'      \item{\strong{character}: one of "square", "circle", "star", "heart",

#'      "ellipse", "cross", "triangle", "triangle2".}

#' }

#' @param width,height width or height of marker.

#' @param width_unit,height_unit units of width or height.

#' @param r only be used for ellipse marker.

#' @param n,ratio only be used for star marker.

#' @return a marker object.

#' @author Hou Yun

#' @rdname marker

#' @importFrom grid is.grob gpar get.gpar polygonGrob

#' @export

#' @examples

#' marker()

#' marker(c("square", "circle"))

marker <- function(grob = "square",

                   width = 1,

                   height = 1,

                   width_unit = "cm",

                   height_unit = width_unit,

                   r = 0,

                   n = 5,

                   ratio = 0.618) {

  if (is.list(grob)) {

    grob <- tryCatch(suppressWarnings(list(customGrob(grob))),

                     error = function(e) grob)

  }

  if (is.grob(grob)) {

    grob <- list(grob)

    label <- "custom"

  }

  if (is.atomic(grob)) {

    if (!all(grob %in% all_type)) {

      stop("Invalid marker.", call. = FALSE)

    }

    label <- grob

    grob <- as.list(grob)

  }



  if (!is.list(grob)) {

    stop("Invalid marker.", call. = FALSE)

  }



  ll <- max(length(grob), length(width), length(height))

  grob_is_na <- vapply(grob, function(.grob) {

    if (is.atomic(.grob) && is.na(.grob)) TRUE else FALSE

  }, logical(1))

  grob <- rep_len(grob, ll)

  label <- rep_len(grob, ll)

  width <- rep_len(width, ll)

  height <- rep_len(height, ll)

  width_unit <- rep_len(width_unit, ll)

  height_unit <- rep_len(height_unit, ll)

  r <- rep_len(r, ll)

  n <- rep_len(n, ll)

  ratio <- rep_len(ratio, ll)



  width[grob_is_na] <- 0

  height[grob_is_na] <- 0



  is_custom <- vapply(grob, function(.grob) {

    is.grob(.grob) || is.list(.grob)

  }, logical(1))

  label <- ifelse(is_custom, "custom", grob)



  grob <- lapply(seq_len(ll), function(.id) {

    if (is.grob(grob[[.id]])) {

      grob[[.id]]

    } else if (is.list(grob[[.id]])) {

      customGrob(grob[[.id]])

    } else {

      marker2grob(grob[[.id]], r = r[.id], n = n[.id], ratio = ratio[.id])

    }

  })



  structure(list(grob = grob,

                 label = label,

                 width = width,

                 height = height,

                 width_unit = width_unit,

                 height_unit = height_unit),

            class = "marker")

}



#' @method print marker

#' @export

print.marker <- function(x, ...) {

  n <- length(x)

  label <- ifelse(is.na(x$label), "empty", x$label)

  x <- paste0(label, "(", x$width, x$width_unit, ", ",

              x$height, x$height_unit, ")")

  print(x, ...)

}



#' @method length marker

#' @export

length.marker <- function(x, ...) {

  length(x$grob)

}



#' @method rep_len marker

#' @export

rep_len.marker <- function(x, length.out) {

  grob <- rep_len(x$grob, length.out)

  grob <- rename_grob(grob)

  structure(list(grob = grob,

                 label = rep_len(x$label, length.out),

                 width = rep_len(x$width, length.out),

                 height = rep_len(x$height, length.out),

                 width_unit = rep_len(x$width_unit, length.out),

                 height_unit = rep_len(x$height_unit, length.out)),

            class = "marker")

}



#' @noRd

markerGrob <- function(marker,

                       x = 0.5,

                       y = 0.5,

                       angle = 0,

                       hjust = 0.5,

                       vjust = 0.5,

                       default.units = "npc",

                       gp = gpar(),

                       name = NULL,

                       vp = NULL) {

  if (!inherits(marker, "marker")) {

    stop("Invalid marker.", call. = FALSE)

  }

  n <- max(length(marker), length(x), length(y), length(angle), length(hjust),

           length(vjust))



  marker <- rep_len(marker, n)

  x <- rep_len(x, n)

  y <- rep_len(y, n)

  angle <- rep_len(angle, n)

  hjust <- rep_len(hjust, n)

  vjust <- rep_len(vjust, n)



  grid::gTree(marker = marker,

              x = x,

              y = y,

              angle = angle,

              hjust = hjust,

              vjust = vjust,

              default.units = default.units,

              gp = gp,

              name = name,

              vp = vp,

              cl = "markerGrob")

}



#' @title Dynamic resize the marker

#' @description This function takes care of updating the marker size based on

#' device size.

#' @param x a marker grob object.

#' @importFrom grid makeContent

#' @author Hou Yun

#' @rdname makeContent

#' @export

makeContent.markerGrob <- function(x) {

  n <- length(x$marker)

  marker <- x$marker

  width <- grid::unit(x$marker$width, x$marker$width_unit)

  height <- grid::unit(x$marker$height, x$marker$height_unit)

  width <- grid::convertWidth(width, "cm")

  height <- grid::convertHeight(height, "cm")



  gp <- split_gpar(x$gp, n)



  grobs <- lapply(seq_len(n), function(.n) {

    vp <- grid::viewport(x = x$x[.n],

                         y = x$y[.n],

                         width = width[.n],

                         height = height[.n],

                         angle = x$angle[.n],

                         just = c(x$hjust[.n], x$vjust[.n]),

                         default.units = x$default.units)



    modify_grob(marker$grob[[.n]], vp = vp, gp = gp[[.n]])

  })



  grid::setChildren(x, do.call(grid::gList, grobs))

}



#' @noRd

marker2grob <- function(x, r = 0, n = 100, ratio = 0.618) {

  if (is.na(x)) {

    grid::nullGrob()

  } else {

    switch (x,

            square = polygonGrob(x = c(0, 1, 1, 0, 0),

                                 y = c(0, 0, 1, 1, 0)),

            circle = grid::circleGrob(),

            star = starGrob(n = n,

                            ratio = ratio),

            heart = heartGrob(nstep = 100),

            ellipse = ellipseGrob(r = r, nstep = 100),

            cross = crossGrob(),

            triangle = triangleGrob(1),

            triangle2 = triangleGrob(2)

    )

  }

}





#' @noRd

split_gpar <- function(gp = gpar(), n = 1) {

  gp2 <- grid::get.gpar(c("col", "fill", "alpha", "lty", "lwd"))

  col <- rep_len(gp$col %||% gp2$col, n)

  fill <- rep_len(gp$fill %||% gp2$fill, n)

  alpha <- rep_len(gp$alpha %||% gp2$alpha, n)

  lty <- rep_len(gp$lty %||% gp2$lty, n)

  lwd <- rep_len(gp$lwd %||% gp2$lwd, n)

  lapply(seq_len(n), function(.n) {

    gpar(col = col[.n],

         fill = fill[.n],

         alpha = alpha[.n],

         lty = lty[.n],

         lwd = lwd[.n])

  })

}



#' @noRd

modify_gpar <- function(gp1, gp2) {

  gp <- utils::modifyList(gp1, gp2)

  class(gp) <- "gpar"

  gp

}



#' @noRd

modify_grob <- function(grob, vp = NULL, gp = gpar()) {

  grob$vp <- vp

  grob$gp <- modify_gpar(gp, grob$gp)

  grob

}



#' @noRd

ellipseGrob <- function(r = 0, nstep = 100) {

  tt <- seq(0, 2 * pi, length = nstep)

  x = 0.5 * cos(tt + acos(r) / 2) + 0.5

  y = 0.5 * cos(tt - acos(r) / 2) + 0.5

  polygonGrob(x = x, y = y)

}



#' @noRd

crossGrob <- function() {

  r <- sqrt(2) * 0.618 / 2

  x <- c(0.5 - r, 0.5 + r, 0.5 - r, 0.5 + r)

  y <- c(0.5 - r, 0.5 + r, 0.5 + r, 0.5 - r)

  id <- rep(c(1, 2), each = 2)

  grid::pathGrob(x = x, y = y, id = id)

}



#' @noRd

heartGrob <- function(nstep = 300) {

  tt <- seq(0, 2 * pi, length.out = nstep)

  x <- 16 * (sin(tt))^3

  y <- 13 * cos(tt) - 5 * cos(2 * tt) - 2 * cos(3 * tt) - cos(4 * tt)

  rng <- max(diff(range(x)), diff(range(y)))

  x <- x / rng + 0.5

  y <- y / rng - range(y)[1] / rng



  polygonGrob(x = x, y = y)

}



#' @noRd

starGrob <- function(n = 5, ratio = 0.618) {

  p <- 0:n / n

  if (n %% 2 == 0) p <- p + p[2] / 2

  pos <- p * 2 * pi

  x_tmp <- 0.5 * sin(pos)

  y_tmp <- 0.5 * cos(pos)

  angle <- pi / n

  x <- numeric(2 * n + 2)

  y <- numeric(2 * n + 2)

  x[seq(2, 2 * n + 2, by = 2)] <- 0.5 + x_tmp

  y[seq(2, 2 * n + 2, by = 2)] <- 0.5 + y_tmp

  x[seq(1, 2 * n + 2, by = 2)] <- 0.5 + ratio * (x_tmp * cos(angle) - y_tmp * sin(angle))

  y[seq(1, 2 * n + 2, by = 2)] <- 0.5 + ratio * (x_tmp * sin(angle) + y_tmp * cos(angle))

  polygonGrob(x = x, y = y)

}



#' @noRd

triangleGrob <- function(type = 1) {

  if (type == 1) {

    gap <- (1 - sqrt(3) / 2) / 2

    polygonGrob(x = c(0, 1, 0.5, 0),

                y = c(gap, gap, 1 - gap, gap))

  } else {

    polygonGrob(x = c(0, 1, 1, 0),

                y = c(0, 0, 1, 0))

  }

}



#' @noRd

customGrob <- function(x) {

  if (!is.grob(x)) {

    x <- polygonGrob(x = x$x %||% x[[1]],

                     y = x$y %||% x[[2]])

  }

  x

}



#' @noRd

rename_grob <- function (grobs, prefix = "MARKER", suffix = "GRID")

{

  n <- length(grobs)

  index <- paste(ceiling(abs(stats::rnorm(n)) * 1000),

                 ceiling(abs(stats::rnorm(n)) * 1000),

                 ceiling(abs(stats::rnorm(n)) * 1000), sep = ".")

  ll <- paste(prefix, suffix, index, sep = ".")



  for (i in seq_len(n)) {

    grobs[[i]]$name <- ll[i]

  }

  grobs

}



#' @noRd

all_type <- c("square", "circle", "star", "heart", "ellipse", "cross",

              "triangle", "triangle2")

R/scale-marker.R

0 → 100644
+63 −0
Original line number Diff line number Diff line 
#' @title Discrete and continuous marker scales

#' @description marker scales provide discrete and continuous marker scales.

#' @return a Scale object.

#' @family scale_marker_*

#' @name scale_marker

#' @rdname scale_marker_discrete

NULL



#' @rdname scale_marker_discrete

#' @inheritParams ggplot2::scale_shape_discrete

#' @importFrom ggplot2 discrete_scale

#' @export

scale_marker_discrete <- function(...) {

  discrete_scale("marker", "marker_d", marker_pal(), ...)

}



#' @rdname scale_marker_discrete

#' @inheritParams ggplot2::scale_shape_continuous

#' @export

scale_marker_continuous <- function (...)

{

  stop("A continuous variable can not be mapped to marker.", call. = FALSE)

}



#' @rdname scale_marker_discrete

#' @inheritParams ggplot2::scale_shape_identity

#' @importFrom ggplot2 ScaleContinuousIdentity

#' @export

scale_marker_identity <- function(..., guide = "none") {

  discrete_scale("marker", "identity", scales::identity_pal(),

                 ..., guide = guide, super = ScaleContinuousIdentity)

}



#' @rdname scale_marker_discrete

#' @inheritParams ggplot2::scale_shape_manual

#' @export

scale_marker_manual <- function(..., values, breaks = waiver(), na.value = NA) {

  manual_scale <- utils::getFromNamespace("manual_scale", "ggplot2")

  manual_scale("marker", values, breaks, ..., na.value = na.value)

}



#' @rdname scale_marker_discrete

#' @inheritParams ggplot2::scale_shape_binned

#' @importFrom ggplot2 binned_scale

#' @export

scale_marker_binned <- function(...) {

  binned_pal <- utils::getFromNamespace("binned_pal", "ggplot2")

  binned_scale("marker", "marker_b", binned_pal(marker_pal()), ...)

}



#' @noRd

marker_pal <- function ()

{

  function(n) {

    if (n > 8) {

      warning("The marker palette can deal with a maximum of 8 discrete.",

              call. = FALSE)

    }

    all_type[seq_len(n)]

  }

}

R/utils.R

+12 −12
Original line number Diff line number Diff line
@@ -15,18 +15,18 @@ aes_modify <- function (aes1, aes2) 
  aes

}



#' @noRd

set_attrs <- function(x, ...) {

  attrs <- list(...)

  if(length(attrs) == 0L) {

    return(x)

  }

  nm <- names(attrs)

  for(i in nm) {

    attr(x, i) <- attrs[[i]]

  }

  x

}

#' #' @noRd

#' set_attrs <- function(x, ...) {

#'   attrs <- list(...)

#'   if(length(attrs) == 0L) {

#'     return(x)

#'   }

#'   nm <- names(attrs)

#'   for(i in nm) {

#'     attr(x, i) <- attrs[[i]]

#'   }

#'   x

#' }



#' @noRd

new_data_frame <- getFromNamespace("new_data_frame", "ggplot2")

CRA Git | Maintained and supported by SUSTech CRA and CCSE