R/jam_sestats_hm.R
In jmw86069/jamses: Jam SummarizedExperiment Stats
#' Heatmap for SummarizedExperiment data
#'
#' Heatmap for SummarizedExperiment data
#'
#' Note: Still a work in progress. This function is the basis
#' for the majority of heatmaps created for Omics data.
#'
#' This function is a bold attempt to simplify the intricate task
#' of creating an expression heatmap, using `ComplexHeatmap::Heatmap()`,
#' given a `SummarizedExperiment` object.
#'
#' It attempts to enable:
#'
#' * selection of `assays(se)` to use in the heatmap
#' * use of `rowData(se)` or `colData(se)` to produce row and
#' column annotations, respectively.
#' * re-use of defined colors for annotations, see `platjam::design2colors()`
#' * define and adjust heatmap color gradient and scale
#' * data centering by row: versus all columns, or specific controls,
#' optionally within independent centering groups
#' * filtering rows to show only the statistical hits
#' * display annotation of statistical hits beside the heatmap
#' * split rows or columns using `rowData(se)` and `colData(se)`, respectively
#' * heatmap title to display key options used, for easy reference
#'
#' ## Additional Features
#'
#' * data centering can be disabled with `centerby_colnames=FALSE`.
#' * alternative hits can be displayed using `alt_sestats`. It does not
#' subset heatmap rows, it inherits rows from `sestats`.
#' * display a subset of columns after row centering, useful to hide
#' the control group for certain figures.
#' * option to display correlation heatmap, using the same data
#' centering, then calculates Pearson correlation across sample columns.
#' * labels and legend grids can be customized to exact sizes
#' with `grid::gpar()` and `grid::unit()` definitions, for manuscript figures.
#' * mark annotations option to label a subset of rows
#' * row subclusters can be visualized using `row_subcluster` to drill down
#' into specific subclusters from hierarchical clustering, k-means clustering,
#' or any `row_split`.
#'
#' ## Data Centering
#'
#' The intent is to display expression values from `assays(se)`,
#' centered across all columns, or with customization defined by
#' `centerby_colnames` and `normgroup_colnames`. The resulting centered
#' data can be subsetted by argument `isamples`, which occurs after
#' centering in order to decouple the centering step from the display
#' of resulting data. To subset samples involved in centering itself,
#' either subset the input `se` data, or supply `controlSamples` to
#' define a subset of samples used as the baseline in centering.
#' See `jamma::centerGeneData()` for more details.
#'
#' Paired data, also called repeated measures data, can be visualized
#' by including the pairing as `centerby_colnames` so that centering
#' is calculated within each pairing subgroup. In this case if also using
#' `controlSamples` to define a "time zero" or "baseline", then all
#' baseline samples will have exactly zero, if there is only one replicate
#' per pairing group at the baseline. In this case, it may be useful
#' to create the full heatmap once to confirm the centering is performing
#' as intended, then create a second heatmap using `isamples` to show only
#' the non-baseline samples - thus removing the large chunk of values with 0.
#'
#' Note: data centering can be disabled with `centerby_colnames=FALSE`.
#'
#' ## Heatmap Title
#'
#' A heatmap title is returned as an attribute `attr(hm, "hm_title")`,
#' which describes:
#'
#' * total rows displayed, with `row_type` indicating the measured entity
#' (gene, probe, DEGs, etc.)
#' * total columns displayed, with `column_type` indicating the sampled entity
#' (samples, total replicates, etc.)
#' * the `assay_name` for the data being displayed
#' * relevant options for data centering, for example
#' `"global-centered"` (by default) or
#' `"Centered within Cell Line, versus Wildtype"`
#'
#' To include the heatmap title:
#'
#' `ComplexHeatmap::draw(hm, column_title=attr(hm, "hm_title))`
#'
#' ## Top and Left Annotations
#'
#' The top heatmap annotations use `colData(se)` with user-supplied
#' `top_colnames` or by auto-detecting those colnames that apply
#' to multiple `colnames(se)`.
#' Colors can be supplied using argument `sample_color_list`, as
#' described below.
#'
#' The an incidence matrix of statistical hits can be displayed
#' on the left of the heatmap, using arguments `sestats` and `alt_sestats`.
#' These arguments can accept either the output of `se_contrast_stats()`,
#' or they can be a `numeric` matrix with values `c(-1, 0, 1)`, indicating
#' statistical hits down, no change, and up, respectively.
#' The contrasts can optionally be subset with `contrast_names`,
#' which corresponds to columns in the matrix if supplied in that format.
#'
#' When `sestats` is supplied, it will subset all heatmap rows to include
#' only rows with at least one non-zero value in the incidence matrix.
#' If argument `rows` is supplied, then all `rownames(se)` matching
#' `rows` are displayed, regardless of statistical hits.
#'
#' For comparison across other `sestats` results, argument `alt_sestats`
#' is treated similar to `sestats` except that the heatmap is not subset
#' based upon these values. That means the heatmap will be subset to
#' match hits defined by `sestats` but not `alt_sestats`.
#' The `alt_sestats` incidence matrix is displayed to the far left
#' of the `sestats` incidence matrix. For clarity, it can be useful to
#' add `alt_sestats_suffix` to add a suffix to each contrast label,
#' for example if `sestats` represents limma hits, use
#' `sestats_suffix=" limma"`, and if `alt_sestats` represents limma-voom
#' hits, use `alt_sestats_suffix=" limmavoom"`.
#'
#' Argument `rowData_colnames` can be supplied, which enables display of
#' `rowData(se)` annotations in the `left_annotation` of the heatmap.
#' Colors can be supplied using argument `sample_color_list`.
#'
#' Argument `sample_color_list` is a `list` named by each annotation column
#' to be displayed as top or left annotation. Each list element is either:
#'
#' * a `character` vector of R colors named by `character` value, or
#' * a `function` defined by `circlize::colorRamp2()` to be applied
#' for `numeric` column values. In this case the `breaks` used to
#' define the color function are used to define the color legend.
#'
#' The function `platjam::design2colors()` can be used to create
#' `sample_color_list` starting with a `data.frame` of annotations,
#' and will soon be moved into this package.
#'
#' A custom `left_annotation` can be supplied, but this method currently
#' prevents the other annotations described above from being displayed.
#' To display automated annotations with `rowData_colnames` and custom
#' row annotations, supply custom annotations with `right_annotation`.
#' Note that annotations must be supplied in exact row order, which
#' is usually easiest when supplying `rows` with specific set of rows.
#'
#' ## Compatible Input Formats
#'
#' Data provided in `se` is expected to be `SummarizedExperiment`, however
#' other Bioconductor data types are accepted that provide
#' accessor functions: `featureData()`, `phenoData()`, and `assayData()`,
#' including for example the `"MethyLumiSet"` class.
#'
#' Note that `matrix` input is currently not supported, however it can
#' be converted to `SummarizedExperiment` like this:
#'
#' ```r
#' se <- SummarizedExperiment::SummarizedExperiment(
#' assays=list(data=matrix),
#' rowData=data.frame(Gene=rownames(matrix)),
#' colData=data.frame(Sample=colnames(matrix)))
#' ```
#'
#' @family jamses heatmaps
#'
#' @param se `SummarizedExperiment` by default, or one of the following:
#' * `SummarizedExperiment` with accessor functions
#' `rowData()`, `colData()`, and `assays()`. It will use
#' `values(rowRanges())` if no slot `rowData` exists.
#' * `SingleCellExperiment` with accessor functions
#' `rowData()`, `colData()`, and `assays()`. It will use
#' `values(rowRanges())` if no slot `rowData` exists.
#' * `Seurat` object, which is coerced to `SingleCellExperiment` and
#' handled accordingly
#' * `ExpressionSet` or compatible object with accessor functions
#' `featureData()`, `phenoData()`, and `assayData()`.
#' @param sestats one of the following types of data:
#' * `list` output from `se_contrast_stats()`, which
#' specifically contains `hit_array` as a 3-dimensional array of hits
#' with dimensions "Cutoffs", "Contrasts", "Signal".
#' * `numeric` matrix intended to represent an incidence matrix,
#' where a value `0` indicates absence, and non-zero indicates presence.
#' This format is useful for supplying any incidence matrix, such as
#' gene-by-pathway (for example Github package "jmw86069/multienrichjam"
#' provides `mem$memIM` with gene-by-pathway matrix),
#' or gene-by-class (see Github package "jmw86069/pajam"
#' for examples using ProteinAtlas protein classification, including
#' membrane-bound, secreted, transcription factors, etc.), or any
#' incidence matrix defined by Github "jmw86069/venndir" function
#' `list2im_value()` or `list2im()` which converts input to a Venn diagram
#' into an incidence matrix.
#' * When `sestats` is supplied, data is converted to incidence matrix,
#' then columns are matched with `contrast_names`. All rows with non-zero
#' entry in those columns are included in the heatmap.
#' When `rows` is also supplied, then the intersection of incidence
#' matrix rows and `rows` is displayed in the heatmap.
#' * Note that `alt_sestats` does not subset rows displayed in the
#' heatmap.
#' @param hm_name `character` string, or `NULL` (default) which uses the
#' `data_type` value. Note that the legend title uses the `data_type`,
#' and is also used for `hm_name` when `hm_name=NULL`.
#' The `hm_name` is most useful to customize because this string is used
#' as the prefix for grid graphical components, for example seen with
#' `ComplexHeatmap::list_components()`. When two heatmaps or a
#' `HeatmapList` is drawn, the names can be used to define specific
#' grid regions of each heatmap. If the heatmaps share the same
#' `hm_name` then the regions will also have identical name and cannot
#' be addressed distinctly.
#' @param hm_title `character` string, or `NULL` (default) which generates
#' a heatmap title using the dimensions, `assay_name`, `data_type`,
#' and a string which describes the data centering.
#' When provided as a `character` string, it is used as-is.
#' (In future this value may accept variable names.)
#' @param rows `character` vector of `rownames(se)` to define a specific
#' set of rows to display. When `sestats` is supplied, then the
#' intersection of `rows` with genes defined by `sestats` is displayed.
#' Note that rows are required to be in `rownames(se)`, all other rows
#' are dropped.
#' @param row_type `character` string used in the title of the heatmap
#' which indicates how many rows are displayed. For example
#' `"1,234 genes detected above background"` or
#' `"1,234 DEGs by limma-voom"`.
#' When `row_type=""` or `row_type=NULL` this information
#' is not included in the heatmap title.
#' @param column_type `character` string used in the title of the heatmap
#' which indicates how many column are displayed. For example
#' `"12 samples"` or `"12 biological replicates"`.
#' When `column_type=""` or `column_type=NULL` this information
#' is not included in the heatmap title.
#' @param data_type `character` string used as title of the heatmap
#' color gradient legend, for example `"expression"` indicates
#' the data contains gene expression measurements. Notes:
#' * The prefix `"centered"` is automatically appended whenever
#' the data is also centered for the heatmap. Set `centerby_colnames=FALSE`
#' to display data that is not centered.
#' * The prefix `"correlation of"` is automatically appended when
#' `correlation=TRUE` which displays correlation of whatever data
#' is included in the heatmap.
#' @param correlation `logical` indicating whether to calculate sample
#' correlation, and plot a sample-by-sample correlation heatmap.
#' This option is included here since many of the same arguments
#' are required for data centering, and sample annotations.
#' Note that `color_max` is forced to a maximum value of `1.0`,
#' representing the maximum correlation value.
#' @param assay_name `character` string indicating the name in
#' `assays(se)` to use for data to be displayed in the heatmap.
#' * When multiple `assay_name` values are supplied, the first
#' assay_name that matches `names(assays(se))` will be used in the
#' heatmap. In this way, multiple `assay_names` can be supplied to
#' define statistical hits in `sestats`, which calls `hit_array_to_list()`
#' to combine hits across `assay_name` entries; but only the first
#' `assay_name` found in `se` is used for the heatmap values.
#' * When there is only one value for `assayNames(se)`, then
#' `assay_name` will default to this value, instead of acting like
#' it couldn't possibly know what was intended. Haha.
#' * Lastly, `assay_name` can be a `numeric` index, helpful in case
#' `assays(se)` contains no names - not recommended but it can happen.
#' @param contrast_names `character` vector of contrasts in
#' `sestats$hit_array` to use for the heatmap. When `contrast_names=NULL`
#' then all contrasts are displayed, which is the default.
#' @param contrast_suffix `character` string with optional suffix to append
#' to the end of each contrast name label for `sestats` hit incidence
#' matrix beside the heatmap. This suffix may be useful when comparing
#' two methods for the same set of contrast names, with `sestats` and
#' `alt_sestats`.
#' @param cutoff_name `character` or `integer` index used to define the
#' specific statistical cutoffs to use from `sestats$hit_array`. This
#' argument is passed to `hit_array_to_list()` as `cutoff_names`.
#' @param alt_sestats,alt_assay_name,alt_contrast_names,alt_contrast_suffix
#' arguments analogous to those described above for `sestats` which
#' are used when `alt_sestats` is supplied.
#' @param isamples `character` vector of `colnames(se)` used to visualize a
#' subset of samples used for the data centering step. Note that
#' data centering uses all columns supplied in `se`, and after centering,
#' the subset of columns defined in `isamples` is displayed in the heatmap.
#' This distinction makes it possible to center data by some control group,
#' then optionally not display the control group data.
#' @param normgroup_colname `character` vector of colnames in `colData(se)`
#' used during data centering. When supplied, samples are centered
#' independently within each normgroup grouping. These values are
#' equivalent to using `centerby_colnames`.
#' @param centerby_colnames either:
#' * `character` vector of colnames in `colData(se)`
#' used during data centering. When supplied, samples are centered
#' independently within each centerby grouping. It is typically used
#' for things like cell lines, to center each cell line by a time
#' point control, or untreated control.
#' * `NULL` to perform centering across all columns in `se`.
#' * `FALSE` to disable centering.
#' @param controlSamples `character` optional vector of samples to use as the
#' reference during data centering. Note that samples are still
#' centered within each normgroup and centerby grouping, and within
#' that grouping samples are centered to the `controlSamples`
#' which are present in that grouping. Any center group for which no
#' samples are defined in `controlSamples` will use all samples in that
#' center group. Typically, `controlSamples` is used to define a
#' specific group as the reference for centering, so changes are displayed
#' relative to that group. Make sure to define `control_name` to include
#' an appropriate label in the heatmap title.
#' @param control_label `character` string used in heatmap title
#' to describe the control used during data centering, relevant when
#' `controlSamples` is also supplied. Recommended format:
#' `"versus Wildtype"` or `"vs. Wildtype"`.
#' The heatmap title will include data centering and `control_label`
#' in this format:
#' `"centered within {centerby_colnames}, {control_label}"`, for example
#' `"centered within Genotype/Time, versus Vehicle"`.
#' @param controlFloor,naControlAction,naControlFloor passed to
#' `jamma::centerGeneData()` to customize data centering.
#' * `controlFloor` imposes an optional noise floor to control group
#' mean/median values, so the summary value during centering is at
#' least `controlFloor`. Useful for defining an effective noise floor
#' for a platform technology.
#' * `naControlAction` defines the action taken only when values for
#' all control samples are `NA`.
#' * `naControlFloor` is a `numeric` value used when
#' `naControlAction="floor"`, which causes the group reference value
#' to use the value provided in `naControlFloor`.
#' @param top_colnames one of the following types:
#' * `character` vector of colnames to use from
#' `colData(se)` as annotations to display in `top_annotation` above
#' the heatmap.
#' * `NULL`, will call `choose_annotation_colnames()` to detect
#' reasonable colnames: columns with more than one unique value;
#' columns with at least one duplicated value.
#' * `FALSE` will hide the `top_colnames`, which also occurs when
#' `colData(se)` is empty.
#' @param top_annotation specific heatmap annotation as defined by
#' `ComplexHeatmap::HeatmapAnnotation()`. When supplied, the `top_colnames`
#' described above is not used.
#' @param top_annotation_name_gp `grid::gpar` object to customize the
#' annotation name displayed beside the top annotation.
#' @param rowData_colnames `character` vector of colnames in `rowData(se)`
#' to use for heatmap annotations displayed on the left side of
#' the heatmap. Specific colors can be included in `sample_color_list`
#' as a named `list` of color vectors or color functions. The names
#' of this list must match colnames to be displayed, otherwise
#' `ComplexHeatmap::Heatmap()` will define its own color function.
#' @param left_annotation specific heatmap annotation as defined by
#' `ComplexHeatmap::rowAnnotation()`. When supplied, the `rowData_colnames`
#' and `sestats` row annotations are not displayed. In order to supply
#' custom row annotations and not lose `left_annotation` defined above,
#' supply the row annotations as `right_annotation`.
#' @param left_annotation_name_gp `grid::gpar` object to customize the
#' annotation name displayed beside the left annotation.
#' @param left_annotation_name_rot `numeric` rotation of left annotation
#' label, in degrees, where `0` indicates normal text, and `90` is
#' rotated vertically.
#' @param right_annotation specific heatmap annotation as defined by
#' `ComplexHeatmap::HeatmapAnnotation()`. This element is created
#' automatically when `mark_rows` is supplied.
#' @param simple_anno_size `grid::unit` size used to define heatmap
#' annotation sizes (height or width of each line) for any simple
#' annotations.
#' @param legend_title_gp `grid::gpar` to customize the legend title
#' fonts, applied to each legend: top annotation, left annotation,
#' main heatmap.
#' @param legend_labels_gp `grid::gpar` to customize the legend label
#' fonts, applied to each legend: top annotation, left annotation,
#' main heatmap.
#' @param legend_grid_cex `numeric` multiplied to adjust the relative
#' size of each legend grid unit, applied to each relevant metric.
#' @param row_names_gp `gpar` to define custom column name settings.
#' When `"fontsize"` is not defined, the automatic font size calculation
#' is added to the `row_names_gp` supplied.
#' @param row_split is used to define heatmap split by row, ultimately
#' passed to `ComplexHeatmap::Heatmap()` argument `row_split`. However,
#' the input type can vary:
#' * `integer` number of row splits based upon row clustering. If
#' `row_split` is greater than the number of rows, it will be set
#' to the number of rows.
#' * `character` value or values in colnames of `rowData(se)` to split
#' using row annotation in `se`.
#' * `data.frame` whose `rownames()` must contain all rows to be
#' displayed in the heatmap. This argument is passed directly to
#' `ComplexHeatmap::Heatmap()` to apply the split appropriately.
#' * `character` or `factor` vector named by `rownames(se)` with another
#' custom row split, passed directly to `ComplexHeatmap::Heatmap()`
#' argument `row_split`, with proper order for rows being displayed
#' @param row_subcluster `integer` or `character` vector representing one
#' or more elements returned by `row_split` to use as a drill-down
#' sub-cluster heatmap. This argument is experimental, and is intended
#' to make it easy to "drill down" into specific row clusters.
#' * The process internally creates a full heatmap using all arguments
#' as defined, then extracts the `jamba::heatmap_row_order()` which
#' contains row split data in a `list` of rownames vectors. The `list`
#' elements that match `row_subcluster` are extracted and used again
#' for a subsequent heatmap, and are displayed in the same order
#' in which they appear in the original full heatmap - which means
#' `cluster_rows=FALSE` is defined at this point. However `row_split`
#' is retained for this subset of rows, to indicate the original
#' row split annotation.
#' * Note that `row_subcluster` must match the `names()` returned
#' by `jamba::heatmap_row_order()` for the full heatmap, or should
#' include a `numeric` index for the `list` element or elements to
#' use.
#' * In principle this process would be run in two stages: First,
#' view a heatmap with `row_split=6`, then re-run the same heatmap
#' with `row_subcluster=4` to see cluster number 4 from the full
#' heatmap.
#' @param row_title_rot `numeric` value indicating text rotation in degrees
#' to use for row titles.
#' @param sample_color_list named `list` of color vectors or color functions,
#' where names correspond to colnames in either `colData(se)` or
#' `rowData(se)`, and which are passed to corresponding left or top
#' annotation functions. When colors are not defined,
#' `ComplexHeatmap::Heatmap()` will define colors using its own internal
#' function.
#' @param legend_at,legend_labels `numeric` and `character`, respectively,
#' to define custom values for the heatmap color gradient legend.
#' * When `legend_at` is supplied, it is used as provided.
#' * When `legend_labels` is supplied, it is used only when its length
#' equals `length(legend_at)`, in which case it is used as provided.
#' * When `centerby_colnames=FALSE` and the matrix data does not contain
#' negative values, `legend_at` uses integers from `0` to `color_max`,
#' to avoid presenting a color legend with unnecessary negative values.
#' However, when `color_max <= 1` it uses `pretty(c(0, color_max))`,
#' removing extraneous values, then ensuring the maximum value is
#' `color_max`. For example when `color_max=0.85`,
#' the `legend_at` is likely to be `c(0, 0.2, 0.4, 0.6, 0.8, 0.85)`.
#' * When `centerby_colnames` is not `FALSE`, and/or data contains
#' negative values, the `legend_at` is symmetric above and below zero.
#' When `color_max <= 1` the label is created using
#' `pretty(c(-color_max, color_max))`, as described above, so `color_max`
#' is used as the minimum and maximum value.
#' When `color_max > 1` the `legend_at` uses integer steps.
#' * When `color_max <= 1` the `legend_labels` are presented as-is with
#' no transformation.
#' * When `color_max > 1` the `legend_labels` are transformed with
#' `exp2signed(x)` which is the inverse of `log2(1 + x)`. This inverse
#' tranform displays normal space values, in the case of centered data,
#' the values represent normal space fold changes.
#' For example the `legend_at=c(-2, -1, 0, 1, 2)` would result in
#' `legend_labels=c("-4", "-2", "1", "2", "4")`.
#' * When `correlation=TRUE` the `legend_labels` by default use `legend_at`,
#' following rules for `color_max <= 1` above.
#' Otherwise, `legend_labels` values inverse transformed from `log2(1 + x)`
#' in order to display normal space fold change values,
#' * To override any of this behavior, supply both `legend_at`
#' and corresponding `legend_labels`.
#' @param subset_legend_colors `logical` indicating whether to subset colors
#' shown in the color key defined by `sample_color_list`, which is useful
#' when the heatmap only represents a subset of categorical color values.
#' * When `subset_legend_colors == TRUE`, the color key will only
#' include colors shown in the `top_annotation`.
#' * When `subset_legend_colors == FALSE` all colors defined in
#' `sample_color_list` will be included for each relevant column.
#' @param row_cex,column_cex `numeric` values used to adjust the row and
#' column name font size, relative to the automatic adjustment that
#' is already done based upon the number of rows and columns being
#' displayed.
#' @param row_anno_fontsize `numeric` base font size for row
#' annotation labels. This value is only used when `left_annotation_name_gp`
#' is not supplied. Note these labels appears underneath row annotations,
#' alongside column labels, and therefore they are also adjusted
#' by multiplying `column_cex` so these labels are adjusted together.
#' @param useMedian `logical` passed to `jamma::centerGeneData()` during
#' data centering.
#' @param show_row_names,show_row_dend `logical` indicating whether to
#' display row names, and row dendrogram, respectively. With more than
#' 2,000 rows this step can become somewhat slow.
#' @param mark_rows `character` vector of values in `rownames(se)` that
#' should be labeled using `ComplexHeatmap::anno_mark()` in call-out
#' style. Usually this argument is used when `show_row_names=FALSE`,
#' hiding the row labels, but is not required. Values in `mark_rows`
#' are intersected with rows displayed in the heatmap, therefore only
#' matching entries will be labeled.
#' @param mark_labels_gp `grid::gpar` to customize the font used by labels
#' when `mark_rows` is supplied.
#' @param column_title `character` optional title to include at the top
#' of the heatmap. It can include a single value, or multiple values
#' representing each `column_split` in the order they appear.
#' * Note: This argument is ignored when `apply_hm_column_title=TRUE`.
#' * When `column_title=character(0)` (default) or `column_title=""`,
#' the `ComplexHeatmap::Heatmap()` uses its usual default behavior,
#' which is to assign `column_title` using `column_split` values
#' when they are being used.
#' @param apply_hm_column_title `logical` (default FALSE) whether to
#' apply the heatmap title to `column_title`. This option makes it
#' convenient to display the title atop the heatmap without additional
#' effort, however it hides any other `column_title` created by
#' using `column_split`.
#' When using both `column_split` and `apply_hm_column_title=TRUE`
#' it may be useful to call `heatmap_column_group_labels()`.
#' @param hm_title_buffer `numeric` number of whitespace lines to add
#' to the heatmap title `(attr(hm, "hm_title")` between the title
#' and the heatmap below it. This whitespace can be useful when also
#' calling `heatmap_column_group_labels()`, to provide enough space
#' to draw the additional annotations.
#' @param show_heatmap_legend,show_left_legend,show_top_legend `logical`
#' indicating whether each legend should be displayed. Sometimes there
#' are too many annotations, and the color legends can overwhelm the
#' figure. Note that `show_left_legend` is applied in a specific order,
#' with these rules:
#' * `show_left_legend` is extended to at least length 2, then values
#' are used in order for: `sestats`, `rowData_colnames`, in order,
#' using whichever is defined.
#' * If `sestats` is defined, the first value in `show_left_legend`
#' is used for this annotation, then the remaining values are used
#' for `rowData_colnames`. Setting the first `show_left_legend` value
#' to `FALSE` will ensure the legend for `sestats` is not displayed.
#' * If `rowData_colnames` is defined, then the remaining values in
#' `show_left_legend` are recycled for all columns in
#' `rowData_colnames`, and applied in order.
#' In this way, individual columns can have the legend displayed or hidden.
#' * If `alt_sestats` is defined, the legend is always hidden, in favor
#' of showing only the legend for `sestats` without duplicating this legend.
#' @param legend_border_color `character` color used as border color tofor
#' be used as a border color for the various legend colors. Note this
#' argument recognizes only the first color provided, and does not
#' recycle different colors across the various legend borders.
#' @param show_top_annotation_name,show_left_annotation_name `logical`
#' indicating whether to display the annotation name beside the top and
#' left annotations, respectively.
#' @param row_label_colname `character` string used as a row label, where
#' this value is a colname in `rowData(se)`. It is useful when rownames
#' are some identifier that is not user-friendly, and where another column
#' in the data may provide a more helpful label, for example `"SYMBOL"`
#' to display gene symbol instead of accession number.
#' @param cluster_columns,cluster_rows `logical` indicating whether
#' to cluster columns by hierarchical clustering; or `function` with
#' a specific function that produces `hclust` or `dendrogram` output,
#' given a `numeric` matrix. Note that `cluster_rows` default will replace
#' `NA` values with zero `0` to avoid errors with missing data, and
#' uses `amap::hcluster()` by default which is a one-step compiled
#' process to perform distance calculation and hierarchical clustering.
#' @param column_names_gp `gpar` to define custom column name settings.
#' When `"fontsize"` is not defined, the automatic font size calculation
#' is added to the `column_names_gp` supplied.
#' @param column_split `character` or `integer` vector used to define
#' heatmap column split.
#' @param column_split_sep `character` string used as delimited when
#' `column_split` defines multiple split levels.
#' @param color_max `numeric` value passed to `colorjam::col_div_xf()`
#' which defines the upper limit of color gradient used in the heatmap.
#' @param color_floor `numeric` value passed to `colorjam::col_div_xf()`
#' argument `floor` which defines the minimum non-zero numeric value
#' for a color to be applied. This option is available to prevent coloring
#' values below the `color_floor` which can be useful in some circumstances.
#' @param lens `numeric` value passed to `colorjam::col_div_xf()` to control
#' the intensity of color gradient applied to the numeric range.
#' @param rename_contrasts,rename_alt_contrasts `logical` (default TRUE)
#' whether to rename long contrast names in `sestats` and `alt_sestats`
#' using `contrast2comp()`.
#' @param use_raster `logical` passed to `ComplexHeatmap::Heatmap()` to
#' determine whether heatmaps should be converted to raster images,
#' which effectively turns each heatmap panel into a single graphical
#' object.
#' Recommend `use_raster=TRUE` and also installing R package `magick`
#' which greatly enhances speed and quality of rasterized heatmap
#' output. When `magick` is not available, it may be best to use
#' `use_raster=FALSE`.
#' When `use_raster=FALSE` each pixel square of a heatmap
#' is its own graphical object. For heatmaps with very large dimensions,
#' having each pixel as an object can make the heatmap extremely large
#' in memory, and sometimes pixels can overlap others because the
#' minimum pixel size of the output graphics device does not
#' reflect the actual size of each pixel.
#' @param verbose `logical` indicating whether to print verbose output.
#' @param debug `logical` indicating debug mode, data is returned in a `list`:
#' * `hm` object `ComplexHeatmap::Heatmap`
#' * `top_annotation` object `ComplexHeatmap::HeatmapAnnotation` for columns
#' * `left_annotation` object `ComplexHeatmap::HeatmapAnnotation` for rows
#' * `hm_title` object `character` string with the heatmap title.
#' @param ... additional arguments are passed to supporting functions.
#'
#' @examples
#' se <- make_se_test(nrow=1000, ngroups=4, nreps=8)
#'
#' # optionally define factor levels to force the order of labels
#' SummarizedExperiment::rowData(se)$Class <- factor(
#' sample(head(LETTERS, 5), size=nrow(se), replace=TRUE))
#'
#' # basic heatmap
#' hm <- heatmap_se(se, rowData_colnames="Class")
#'
#' # draw by printing hm, or call draw() to add useful options
#' ComplexHeatmap::draw(hm,
#' column_title=attr(hm, "hm_title"),
#' merge_legends=TRUE)
#'
#' # define specific colors
#' sample_color_list <- list(
#' group=colorjam::group2colors(
#' unique(SummarizedExperiment::colData(se)$group)),
#' Class=colorjam::group2colors(
#' unique(SummarizedExperiment::rowData(se)$Class)))
#'
#' heatmap_se(se,
#' rowData_colnames="Class",
#' sample_color_list=sample_color_list)
#'
#' # split rows by "Class"
#' heatmap_se(se,
#' rowData_colnames="Class",
#' row_split="Class",
#' sample_color_list=sample_color_list)
#'
#' # let's have some fun now
#' hm2 <- heatmap_se(se,
#' column_split=c("group"),
#' column_title_rot=90,
#' row_split=c("Class"),
#' rowData_colnames=c("Class"),
#' cluster_row_slices=FALSE,
#' sample_color_list=sample_color_list)
#' hm2drawn <- ComplexHeatmap::draw(hm2, merge_legends=TRUE)
#'
#' # as an example, extract the row order
#' # technically you should use hm2drawn, but usually hm2 is enough
#' hro <- jamba::heatmap_row_order(hm2drawn);
#' jamba::sdim(hro)
#' lapply(hro, head, 7)
#' # (the names will differ from values when `row_labels` are customized)
#'
#' # center by WildType samples
#' # - controlSamples
#' # - control_label
#' hm2 <- heatmap_se(se,
#' controlSamples=rownames(subset(
#' SummarizedExperiment::colData(se), group %in% "groupA")),
#' control_label="vs groupA",
#' column_split=c("group"),
#' column_title_rot=90,
#' row_split=c("Class"),
#' rowData_colnames=c("Class"),
#' cluster_row_slices=FALSE,
#' sample_color_list=sample_color_list)
#' hm2drawn <- ComplexHeatmap::draw(hm2,
#' column_title=attr(hm2, "hm_title"),
#' merge_legends=TRUE)
#'
#' # add "callout" labels for a subset of rows
#' mark_rows <- c(sample(jamba::heatmap_row_order(hm2drawn)[[1]], size=5),
#' sample(jamba::heatmap_row_order(hm2drawn)[[1]], size=3));
#'
#' # turn off ComplexHeatmap warning when using RStudio
#' ComplexHeatmap::ht_opt(message=FALSE)
#'
#' hm3 <- heatmap_se(se,
#' mark_rows=mark_rows,
#' controlSamples=rownames(
#' subset(SummarizedExperiment::colData(se), group %in% "groupA")),
#' control_label="vs groupA",
#' column_split=c("group"),
#' column_title_rot=90,
#' row_split=c("Class"),
#' rowData_colnames=c("Class"),
#' cluster_row_slices=FALSE,
#' sample_color_list=sample_color_list)
#' ComplexHeatmap::draw(hm3,
#' column_title=attr(hm3, "hm_title"),
#' merge_legends=TRUE)
#'
#' # sestats can accept list, incidence matrix, hit_array, or sestats
#' # this example defines random set of hits
#' sestats_list <- list(
#' contrast1=setNames(sample(c(1, -1), replace=TRUE, size=50),
#' sample(rownames(se), size=50)),
#' contrast2=setNames(sample(c(1, -1), replace=TRUE, size=50),
#' sample(rownames(se), size=50)))
#' hm4 <- heatmap_se(se,
#' controlSamples=rownames(
#' subset(SummarizedExperiment::colData(se), group %in% "groupA")),
#' control_label="vs groupA",
#' sestats=sestats_list,
#' column_split=c("group"),
#' row_split=c("Class"),
#' rowData_colnames=c("Class"),
#' cluster_row_slices=FALSE,
#' sample_color_list=sample_color_list)
#' ComplexHeatmap::draw(hm4,
#' column_title=attr(hm4, "hm_title"),
#' merge_legends=TRUE)
#'
#' # it doesn't take much effort to run stats really quick
#' sedesign <- groups_to_sedesign(SummarizedExperiment::colData(se)[, "group", drop=FALSE])
#' contrast_names(sedesign) <- jamba::vigrep("-groupA", contrast_names(sedesign))
#' sestats <- se_contrast_stats(se=se,
#' fold_cutoff=4,
#' sedesign=sedesign, assay_name="counts")
#' hm4s <- heatmap_se(se,
#' controlSamples=rownames(
#' subset(SummarizedExperiment::colData(se), group %in% "groupA")),
#' control_label="vs groupA",
#' sestats=sestats,
#' column_split=c("group"),
#' row_split=6,
#' rowData_colnames=c("Class"),
#' cluster_row_slices=FALSE,
#' sample_color_list=sample_color_list)
#' ComplexHeatmap::draw(hm4s,
#' column_title=attr(hm4s, "hm_title"),
#' merge_legends=TRUE)
#'
#' # for fun, "drill down" into cluster 5
#' hm4s_4 <- heatmap_se(se,
#' controlSamples=rownames(
#' subset(SummarizedExperiment::colData(se), group %in% "groupA")),
#' control_label="vs groupA",
#' sestats=sestats,
#' column_split=c("group"),
#' row_split=6,
#' row_subcluster=4,
#' rowData_colnames=c("Class"),
#' cluster_row_slices=FALSE,
#' sample_color_list=sample_color_list)
#' ComplexHeatmap::draw(hm4s_4,
#' column_title=attr(hm4s_4, "hm_title"),
#' merge_legends=TRUE)
#'
#'
#' # sestats can be provided as an incidence matrix
#' if (jamba::check_pkg_installed("venndir")) {
#' # convert sestats to list
#' sestats_hitlist <- hit_array_to_list(sestats)
#' # convert sestats hitlist to incidence matrix
#' # - for fun, use only the first two contrasts
#' sestats_hitim <- venndir::list2im_value(sestats_hitlist[1:2])
#' print(head(sestats_hitim));
#'
#' # convert sestats_list to signed incidence matrix
#' sestats_im <- venndir::list2im_value(sestats_list)
#' print(head(sestats_im, 10));
#' # if the list has items (no direction) use venndir::list2im_opt()
#'
#' hm5 <- heatmap_se(se,
#' controlSamples=rownames(
#' subset(SummarizedExperiment::colData(se), group %in% "groupA")),
#' control_label="vs groupA",
#' sestats=sestats_hitim,
#' column_split=c("group"),
#' rowData_colnames=c("Class"),
#' cluster_row_slices=FALSE,
#' sample_color_list=sample_color_list)
#' ComplexHeatmap::draw(hm5,
#' column_title=attr(hm5, "hm_title"),
#' merge_legends=TRUE)
#' }
#'
#'
#' # customize column label fonts using column_names_gp
#' column_bold <- ifelse(
#' SummarizedExperiment::colData(se)$group %in% "groupA",
#' 2, 1);
#' hm6 <- heatmap_se(se,
#' controlSamples=rownames(
#' subset(SummarizedExperiment::colData(se), group %in% "groupA")),
#' control_label="vs WildType",
#' column_names_gp=grid::gpar(col=sample_color_list$group[
#' as.character(SummarizedExperiment::colData(se)$group)],
#' font=column_bold),
#' column_split=c("group"),
#' row_split=c("Class"),
#' rowData_colnames=c("Class"),
#' cluster_row_slices=FALSE,
#' sample_color_list=sample_color_list)
#' ComplexHeatmap::draw(hm6,
#' column_title=attr(hm6, "hm_title"),
#' merge_legends=TRUE)
#'
#' # correlation=TRUE, any heatmap becomes a sample correlation heatmap
#' hm6corr <- heatmap_se(se,
#' correlation=TRUE,
#' apply_hm_column_title=TRUE,
#' controlSamples=rownames(
#' subset(SummarizedExperiment::colData(se), group %in% "groupA")),
#' control_label="vs groupA",
#' column_names_gp=grid::gpar(col=sample_color_list$group[
#' as.character(SummarizedExperiment::colData(se)$group)],
#' font=rep(c(1, 2, 1), c(3, 5, 24))),
#' column_split=c("Group"),
#' sample_color_list=sample_color_list)
#' ComplexHeatmap::draw(hm6corr,
#' merge_legends=TRUE)
#'
#' ## Final heatmap:
#' # 1. Applies heatmap title automatically.
#' # 2. Hides the top_colnames
#' # 3. Adds fancy grouped labels above the heatmap.
#' #
#' # apply_hm_column_title=TRUE
#' # convenient way to define a title,
#' # but it does not also display column_split labels
#' #
#' # hm_title_buffer=4
#' # convenient way to insert some whitespace lines
#' #
#' # heatmap_column_group_labels()
#' # adds to a drawn heatmap - it must already be drawn
#' #
#' SummarizedExperiment::colData(se)$Genotype <- rep(c("WT", "KO"), each=16);
#' SummarizedExperiment::colData(se)$Treatment <- rep(c("Control", "Dex"), each=8);
#' hm7 <- heatmap_se(se,
#' apply_hm_column_title=TRUE,
#' hm_title_buffer=3,
#' controlSamples=rownames(
#' subset(SummarizedExperiment::colData(se), group %in% "groupA")),
#' control_label="vs groupA",
#' sestats=sestats_list,
#' top_colnames=FALSE,
#' column_split=c("group"),
#' row_split=c("Class"),
#' rowData_colnames=c("Class"),
#' cluster_row_slices=FALSE,
#' sample_color_list=sample_color_list)
#' hm7_drawn <- ComplexHeatmap::draw(hm7,
#' merge_legends=TRUE)
#'
#' # now add fancy labels
#' heatmap_column_group_labels(
#' hm_group_list=c("Treatment", "Genotype"),
#' se=se,
#' hm_drawn=hm7_drawn)
#' # Note: this step does not work consistently inside RStudio plot pane,
#' # in that case call dev.new() then run the step above to create hm7_drawn,
#' # then repeat the step below
#' #
#' # adjust the height of labels with argument y_offset_lines
#' # with positive values (upward), or negative values (downward).
#'
#' @export
heatmap_se <- function
(se,
sestats=NULL,
hm_name=NULL,
hm_title=NULL,
rows=NULL,
row_type="rows",
column_type="samples",
data_type="expression",
correlation=FALSE,
assay_name=NULL,
contrast_names=NULL,
contrast_suffix="",
cutoff_name=NULL,
alt_sestats=NULL,
alt_assay_name=assay_name,
alt_contrast_names=NULL,
alt_contrast_suffix="",
alt_cutoff_name=NULL,
isamples=colnames(se),
normgroup_colname=NULL,
centerby_colnames=NULL,
controlSamples=NULL,
control_label="",
controlFloor=NA,
naControlAction=c("na",
"row",
"floor",
"min"),
naControlFloor=0,
top_colnames=NULL,
top_annotation=NULL,
top_annotation_name_gp=grid::gpar(),
rowData_colnames=NULL,
left_annotation=NULL,
left_annotation_name_gp=grid::gpar(),
left_annotation_name_rot=90,
right_annotation=NULL,
simple_anno_size=grid::unit(8, "mm"),
legend_title_gp=grid::gpar(fontsize=10),
legend_labels_gp=grid::gpar(fontsize=10),
legend_grid_cex=1,
row_names_gp=NULL,
row_split=NULL,
row_subcluster=NULL,
row_title_rot=0,
sample_color_list=NULL,
legend_at=NULL,
legend_labels=NULL,
subset_legend_colors=TRUE,
row_cex=0.8,
column_cex=1,
row_anno_fontsize=11,
useMedian=FALSE,
show_row_names=NULL,
show_row_dend=length(rows) < 2000,
mark_rows=NULL,
mark_labels_gp=grid::gpar(),
column_title=character(0),
apply_hm_column_title=FALSE,
hm_title_buffer=0,
show_heatmap_legend=TRUE,
show_top_legend=TRUE,
show_left_legend=TRUE,
legend_border_color="black",
show_top_annotation_name=TRUE,
show_left_annotation_name=TRUE,
row_label_colname=NULL,
cluster_columns=FALSE,
cluster_column_slices=FALSE,
cluster_rows=function(x, ...){
amap::hcluster(jamba::rmNA(naValue=0, x),
...,
method="euclidean",
link="ward")},
cluster_row_slices=FALSE,
column_names_gp=NULL,
column_split=NULL,
column_split_sep=",",
color_max=3,
color_floor=0,
lens=2,
rename_contrasts=TRUE,
rename_alt_contrasts=TRUE,
use_raster=TRUE,
verbose=FALSE,
debug=FALSE,
...)
{
#
if (!jamba::check_pkg_installed("ComplexHeatmap")) {
stop("This function requires Bioconductor package ComplexHeatmap.");
}
if (!jamba::check_pkg_installed("venndir")) {
stop("This function requires Github package venndir from 'jmw86069/venndir'");
}
# if (!suppressPackageStartupMessages(require(SummarizedExperiment))) {
# stop("This function requires Bioconductor package SummarizedExperiment.");
# }
if (length(correlation) == 0) {
correlation <- FALSE;
}
if (length(legend_border_color) == 0) {
legend_border_color <- "transparent";
} else {
legend_border_color <- head(legend_border_color, 1)
}
# accept matrix input by converting to simple SummarizedExperiment
if (inherits(se, "data.frame")) {
se_sclass <- jamba::sclass(se);
se_numcols <- colnames(se)[
which(se_sclass %in% c("numeric", "integer"))];
if (length(se_numcols) == 0) {
stop("data.frame input contained no numeric columns.")
}
if (length(rownames(se)) == 0) {
# use first non-numeric column
if (!any(se_sclass %in% c("character", "factor"))) {
rownames(se) <- paste0("row",
jamba::padInteger(seq_len(nrow(se))));
} else {
se_namecol <- head(names(
which(se_sclass %in% c("numeric", "integer"))), 1);
rownames(se) <- jamba::makeNames(se[[se_namecol]])
}
} else if (any(duplicated(rownames(se)))) {
rownames(se) <- jamba::makeNames(rownames(se),
renameFirst=FALSE)
}
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"Converting data.frame input to matrix.");
}
se <- as.matrix(se[, se_numcols, drop=FALSE]);
}
if (inherits(se, "matrix")) {
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"Converting matrix input to SummarizedExperiment.");
}
se <- SummarizedExperiment::SummarizedExperiment(
assays=list(data=se),
rowData=data.frame(rows=rownames(se),
row.names=rownames(se)),
colData=data.frame(rows=colnames(se),
row.names=colnames(se)))
if (length(assay_name) > 0) {
names(SummarizedExperiment::assays(se))[1] <- assay_name;
} else {
assay_name <- head(SummarizedExperiment::assayNames(se), 1);
}
}
# row_subcluster
if (length(row_subcluster) > 0) {
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"Preparing sub-cluster heatmap.");
}
hm_total <- heatmap_se(
se=se,
sestats=sestats,
hm_name=hm_name,
rows=rows,
row_type=row_type,
column_type=column_type,
data_type=data_type,
correlation=correlation,
assay_name=assay_name,
contrast_names=contrast_names,
contrast_suffix=contrast_suffix,
cutoff_name=cutoff_name,
alt_sestats=alt_sestats,
alt_assay_name=alt_assay_name,
alt_contrast_names=alt_contrast_names,
alt_contrast_suffix=alt_contrast_suffix,
alt_cutoff_name=alt_cutoff_name,
isamples=isamples,
normgroup_colname=normgroup_colname,
centerby_colnames=centerby_colnames,
controlSamples=controlSamples,
control_label=control_label,
top_colnames=top_colnames,
top_annotation=top_annotation,
top_annotation_name_gp=top_annotation_name_gp,
rowData_colnames=rowData_colnames,
left_annotation=left_annotation,
left_annotation_name_gp=left_annotation_name_gp,
left_annotation_name_rot=left_annotation_name_rot,
right_annotation=right_annotation,
simple_anno_size=simple_anno_size,
legend_title_gp=legend_title_gp,
legend_labels_gp=legend_labels_gp,
legend_grid_cex=legend_grid_cex,
row_split=row_split,
row_subcluster=NULL,
row_title_rot=row_title_rot,
sample_color_list=sample_color_list,
legend_at=legend_at,
legend_labels=legend_labels,
subset_legend_colors=subset_legend_colors,
row_cex=row_cex,
column_cex=column_cex,
row_anno_fontsize=row_anno_fontsize,
useMedian=useMedian,
show_row_names=show_row_names,
show_row_dend=show_row_dend,
mark_rows=mark_rows,
mark_labels_gp=mark_labels_gp,
show_heatmap_legend=show_heatmap_legend,
show_top_legend=show_top_legend,
show_left_legend=show_left_legend,
show_top_annotation_name=show_top_annotation_name,
show_left_annotation_name=show_left_annotation_name,
row_label_colname=row_label_colname,
cluster_columns=cluster_columns,
cluster_rows=cluster_rows,
column_split=column_split,
column_split_sep=column_split_sep,
color_max=color_max,
color_floor=color_floor,
lens=lens,
rename_contrasts=rename_contrasts,
rename_alt_contrasts=rename_alt_contrasts,
verbose=verbose,
debug=debug,
...)
row_order <- jamba::heatmap_row_order(hm_total);
if (length(names(row_order)) == 0) {
names(row_order) <- as.character(seq_along(row_order))
}
if (is.numeric(row_subcluster)) {
row_order_use <- row_order[seq_along(row_order) %in% row_subcluster];
} else {
row_order_use <- row_order[names(row_order) %in% as.character(row_subcluster)];
}
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"row_subcluster: ", row_subcluster);
jamba::printDebug("heatmap_se(): ",
"selected: '",
sep="', '",
names(row_order_use),
"'")
}
# set new argument values for the drill-down heatmap
rows <- unlist(unname(row_order_use));
cluster_rows <- FALSE;
row_split <- jamba::nameVector(rep(names(row_order_use),
lengths(row_order_use)),
rows);
# subset the se data?
se <- se[rows,];
if (debug) {
return(invisible(row_order));
}
}
# sestats - define rows to use
gene_hitlist <- NULL;
alt_gene_hitlist <- NULL;
gene_hits_im <- NULL;
gene_hits <- NULL;
alt_gene_hits_im <- NULL;
# rows as user-defined vector
rows <- intersect(rows, rownames(se));
if (length(sestats) > 0) {
# generate an appropriate incidence matrix
gene_hits_im <- process_sestats_to_hitim(sestats,
cutoff_names=cutoff_name,
contrast_names=contrast_names,
assay_names=assay_name,
contrast_suffix=contrast_suffix,
rename_contrasts=rename_contrasts,
rows=rows,
verbose=verbose,
...);
gene_hits <- rownames(gene_hits_im);
if (length(rows) == 0) {
rows <- gene_hits;
}
}
if (length(gene_hits) == 0) {
if (length(rows) == 0) {
rows <- rownames(se);
}
gene_hits <- rows;
} else if (length(rows) == 0) {
rows <- gene_hits
}
# confirm all rows exist in rownames(se)
if (!all(gene_hits %in% rownames(se))) {
gene_hits <- intersect(gene_hits, rownames(se));
rows <- gene_hits;
gene_hits_im <- gene_hits_im[gene_hits, , drop=FALSE];
}
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"nrows in heatmap: ",
jamba::formatInt(length(rows)));
}
# alt_sestats only for rows and gene_hits defined from sestats
if (length(sestats) > 0 && length(alt_sestats) > 0) {
# generate an appropriate incidence matrix
alt_gene_hits_im <- process_sestats_to_hitim(alt_sestats,
cutoff_names=alt_cutoff_name,
contrast_names=alt_contrast_names,
assay_names=alt_assay_name,
contrast_suffix=alt_contrast_suffix,
rename_contrasts=rename_contrasts,
rows=rows,
verbose=verbose,
...);
}
# validate sample_color_list
# remove NA
# convert color name to hex
if (length(sample_color_list) > 0) {
sample_color_list <- lapply(sample_color_list, function(i){
if (is.function(i)) {
i
} else {
i <- i[!is.na(i) & !is.na(names(i))];
i_is_hex <- grepl("^#", i);
if (any(!i_is_hex)) {
i[!i_is_hex] <- jamba::rgb2col(alpha=FALSE,
col2rgb(i[!i_is_hex]))
}
i;
}
})
}
# pull colData and rowData as data.frame
# to be tolerant of other data types
# Note: This process does not subset by `rows` or `isamples` yet
## Experimental: handle Seurat objects
if ("Seurat" %in% class(se)) {
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"Converted Seurat input to SingleCellExperiment");
}
se <- Seurat::as.SingleCellExperiment(se,
# assay=assay_name,
...);
}
# confirm rownames and colnames exist
if (length(rownames(se)) == 0) {
rownames(se) <- paste0("row",
jamba::padInteger(seq_len(nrow(se))));
}
if (length(colnames(se)) == 0) {
colnames(se) <- paste0("column",
jamba::padInteger(seq_len(ncol(se))));
}
# 0.0.69.900 - call se_to_rowcoldata() and remove logic from here
rowcolData_list <- se_to_rowcoldata(se,
verbose=verbose,
...);
rowData_se <- rowcolData_list$rowData_se;
colData_se <- rowcolData_list$colData_se;
# normgroup for column split
normgroup_colname <- intersect(normgroup_colname,
colnames(colData_se));
if (length(column_split) == 0) {
if (length(normgroup_colname) > 0 &&
nrow(unique(colData_se[isamples, normgroup_colname, drop=FALSE])) > 1) {
column_split <- jamba::pasteByRow(
colData_se[isamples, normgroup_colname, drop=FALSE],
sep=column_split_sep);
names(column_split) <- isamples;
} else {
column_split <- NULL;
}
} else {
if (any(c("factor", "character") %in% class(column_split))) {
if (!any(duplicated(column_split)) &&
all(column_split %in% colnames(colData_se))) {
column_split <- jamba::pasteByRowOrdered(
data.frame(check.names=FALSE,
colData_se[isamples, column_split, drop=FALSE]),
keepOrder=TRUE,
sep=column_split_sep);
names(column_split) <- isamples;
} else if (all(names(column_split) %in% isamples)) {
column_split <- column_split[isamples];
} else if (length(column_split) == length(isamples)) {
# leave as-is but add isamples as names
names(column_split) <- isamples;
} else {
column_split <- NULL;
}
} else if (length(column_split) == 1 && is.numeric(column_split)) {
# leave as-is
} else {
column_split <- NULL;
}
}
# column font size
column_fontsize <- jamba::noiseFloor(
column_cex * 60/(length(isamples))^(1/2),
ceiling=20,
minimum=2);
# row font size
if (correlation) {
row_fontsize <- jamba::noiseFloor(
row_cex * (60*(14 / 10))/(length(isamples))^(1/2),
minimum=1,
ceiling=20);
} else {
row_fontsize <- jamba::noiseFloor(
row_cex * (60*(14 / 10))/(length(gene_hits))^(1/2),
minimum=1,
ceiling=20);
}
# choose interesting top_annotation colnames when none are supplied
if (length(top_colnames) == 0) {
top_colnames <- choose_annotation_colnames(colData_se,
...);
if (length(top_colnames) > 0 && verbose) {
jamba::printDebug("heatmap_se(): ",
"derived top_colnames: ",
top_colnames);
}
}
top_colnames <- intersect(top_colnames,
colnames(colData_se));
if (length(top_annotation) == 0 &&
length(top_colnames) > 0 &&
!any(top_colnames %in% FALSE)) {
# subset color key by data shown in the heatmap
top_color_list <- NULL;
# subset any factor columns to limit colors shown in the legend
top_df <- data.frame(check.names=FALSE,
colData_se[isamples, top_colnames, drop=FALSE]);
for (top_colname in top_colnames) {
if (is.factor(top_df[[top_colname]])) {
top_df[[top_colname]] <- factor(top_df[[top_colname]]);
}
}
if (any(top_colnames %in% names(sample_color_list))) {
if (subset_legend_colors) {
top_color_list <- lapply(jamba::nameVector(top_colnames), function(top_colname){
sample_colors <- sample_color_list[[top_colname]];
if (!is.function(sample_colors)) {
if (is.factor(top_df[isamples, top_colname])) {
uniq_values <- levels(top_df[isamples, top_colname]);
} else {
uniq_values <- jamba::mixedSort(unique(
as.character(
top_df[isamples, top_colname])));
}
sample_colors <- sample_colors[uniq_values];
if (length(sample_colors) == 0) {
sample_colors <- rep(NA, length.out=length(uniq_values));
}
names(sample_colors) <- uniq_values;
if (any(is.na(sample_colors))) {
# fallback plan for missing values is to assign
# generic rainbow categorical colors
sample_colors[is.na(sample_colors)] <- colorjam::rainbowJam(
n=sum(is.na(sample_colors)),
...);
}
}
sample_colors;
})
} else {
top_color_list <- sample_color_list[intersect(top_colnames, names(sample_color_list))];
}
}
top_param_list <- c(
lapply(jamba::nameVector(top_colnames), function(iname){
if (iname %in% names(top_color_list)) {
if (is.function(top_color_list[[iname]])) {
if ("breaks" %in% names(attributes(top_color_list[[iname]]))) {
list(border=legend_border_color,
title_gp=legend_title_gp,
labels_gp=legend_labels_gp,
grid_height=grid::unit(4 * legend_grid_cex, "mm"),
grid_width=grid::unit(4 * legend_grid_cex, "mm"),
color_bar="discrete",
at=attr(top_color_list[[iname]], "breaks"))
} else {
list(border=legend_border_color,
title_gp=legend_title_gp,
labels_gp=legend_labels_gp,
grid_height=grid::unit(4 * legend_grid_cex, "mm"),
grid_width=grid::unit(4 * legend_grid_cex, "mm"),
color_bar="discrete")
}
} else {
if (subset_legend_colors) {
list(border=legend_border_color,
title_gp=legend_title_gp,
labels_gp=legend_labels_gp,
grid_height=grid::unit(4 * legend_grid_cex, "mm"),
grid_width=grid::unit(4 * legend_grid_cex, "mm"),
color_bar="discrete",
at=jamba::rmNA(names(top_color_list[[iname]])))
} else {
list(border=legend_border_color,
grid_height=grid::unit(4 * legend_grid_cex, "mm"),
grid_width=grid::unit(4 * legend_grid_cex, "mm"),
title_gp=legend_title_gp,
labels_gp=legend_labels_gp)
}
}
} else {
list(border=legend_border_color,
grid_height=grid::unit(4 * legend_grid_cex, "mm"),
grid_width=grid::unit(4 * legend_grid_cex, "mm"),
title_gp=legend_title_gp,
labels_gp=legend_labels_gp)
}
}));
top_annotation <- ComplexHeatmap::HeatmapAnnotation(
border=TRUE,
df=top_df,
annotation_name_gp=top_annotation_name_gp,
annotation_legend_param=top_param_list,
simple_anno_size=simple_anno_size,
show_legend=show_top_legend,
show_annotation_name=show_top_annotation_name,
col=top_color_list);
}
# left_annotation
if (length(left_annotation) == 0 && !correlation) {
row_anno_fontsize <- jamba::noiseFloor(
column_cex * row_anno_fontsize,
ceiling=24,
minimum=2);
left_anno_list <- list();
left_color_list <- list();
left_param_list <- list();
if (length(show_left_legend) == 0) {
show_left_legend <- TRUE;
}
if (length(show_left_legend) < 2) {
show_left_legend <- rep(show_left_legend,
length.out=2);
}
show_left_legend_v <- logical(0);
# sestats annotations
if (length(sestats) > 0) {
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"Preparing sestats incidence matrix left_annotation.");
}
show_left_legend_v <- show_left_legend[1];
show_left_legend <- tail(show_left_legend, -1);
left_anno_list <- c(list(
hits=gene_hits_im[gene_hits, , drop=FALSE]),
left_anno_list);
left_color_list <- c(list(
hits=colorjam::col_div_xf(1.5)),
left_color_list);
left_param_list <- c(list(
hits=list(
at=c(-1, 0, 1),
color_bar="discrete",
title_gp=legend_title_gp,
labels_gp=legend_labels_gp,
grid_height=grid::unit(4 * legend_grid_cex, "mm"),
grid_width=grid::unit(4 * legend_grid_cex, "mm"),
border=legend_border_color,
labels=c("down", "no change", "up"))),
left_param_list);
}
# alt_sestats annotations
if (length(alt_sestats) > 0) {
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"Preparing alt_sestats incidence matrix left_annotation.");
}
show_left_legend_v <- c(FALSE,
show_left_legend_v);
left_anno_list <- c(list(
hits_alt=alt_gene_hits_im[gene_hits, , drop=FALSE]),
left_anno_list);
left_color_list <- c(list(
hits_alt=colorjam::col_div_xf(1.5)),
left_color_list);
left_param_list <- c(list(
hits_alt=list(
at=c(-1, 0, 1),
color_bar="discrete",
title_gp=legend_title_gp,
labels_gp=legend_labels_gp,
grid_height=grid::unit(4 * legend_grid_cex, "mm"),
grid_width=grid::unit(4 * legend_grid_cex, "mm"),
border=legend_border_color,
labels=c("down", "no change", "up"))),
left_param_list);
}
# rowData annotations
if (length(rowData_colnames) > 0) {
rowData_colnames <- intersect(rowData_colnames,
colnames(rowData_se));
}
if (length(rowData_colnames) > 0) {
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"preparing left_annotation for rowData_colnames: ",
rowData_colnames);
}
show_left_legend_v <- c(show_left_legend_v,
rep(show_left_legend, length.out=length(rowData_colnames)))
# subset any factor columns to limit colors shown in the legend
left_df <- data.frame(check.names=FALSE,
rowData_se[gene_hits, rowData_colnames, drop=FALSE]);
for (rowData_colname in rowData_colnames) {
if (is.factor(left_df[[rowData_colname]])) {
left_df[[rowData_colname]] <- factor(left_df[[rowData_colname]]);
}
}
# put it together
left_anno_list <- c(list(
df=left_df),
left_anno_list);
use_color_list_names <- intersect(rowData_colnames,
names(sample_color_list));
leftanno_color_list <- NULL;
if (length(use_color_list_names) > 0) {
if (subset_legend_colors) {
leftanno_color_list <- lapply(jamba::nameVector(use_color_list_names), function(use_color_list_name){
sample_colors <- sample_color_list[[use_color_list_name]];
if (!is.function(sample_colors)) {
if (is.factor(left_df[gene_hits, use_color_list_name])) {
# for factors we honor the order of factor levels
uniq_values <- levels(left_df[gene_hits, use_color_list_name]);
} else {
# note we add mixedSort() so they are alphanumerical
uniq_values <- jamba::mixedSort(unique(
as.character(
left_df[gene_hits, use_color_list_name])));
}
sample_colors <- sample_colors[uniq_values];
names(sample_colors) <- uniq_values;
if (any(is.na(sample_colors))) {
# fallback plan for missing values is to assign
# generic rainbow categorical colors
sample_colors[is.na(sample_colors)] <- colorjam::rainbowJam(
n=sum(is.na(sample_colors)),
...);
}
}
sample_colors;
})
} else {
leftanno_color_list <- sample_color_list[use_color_list_names];
}
left_color_list <- c(
jamba::rmNULL(
leftanno_color_list),
left_color_list);
if (debug) {
jamba::printDebug("heatmap_se(): ",
"left_color_list:");
print(left_color_list[!jamba::sclass(left_color_list) %in% "function"]);
}
}
left_param_list <- c(
lapply(jamba::nameVector(rowData_colnames), function(iname){
if (iname %in% names(left_color_list)) {
if (is.function(left_color_list[[iname]])) {
if ("breaks" %in% names(attributes(left_color_list[[iname]]))) {
list(border=legend_border_color,
color_bar="discrete",
title_gp=legend_title_gp,
labels_gp=legend_labels_gp,
grid_height=grid::unit(4 * legend_grid_cex, "mm"),
grid_width=grid::unit(4 * legend_grid_cex, "mm"),
at=attr(left_color_list[[iname]], "breaks"))
} else {
list(border=legend_border_color,
title_gp=legend_title_gp,
labels_gp=legend_labels_gp,
grid_height=grid::unit(4 * legend_grid_cex, "mm"),
grid_width=grid::unit(4 * legend_grid_cex, "mm"),
color_bar="discrete")
}
} else {
if (subset_legend_colors) {
list(border=legend_border_color,
title_gp=legend_title_gp,
labels_gp=legend_labels_gp,
grid_height=grid::unit(4 * legend_grid_cex, "mm"),
grid_width=grid::unit(4 * legend_grid_cex, "mm"),
color_bar="discrete",
at=jamba::rmNA(names(left_color_list[[iname]])))
} else {
list(border=legend_border_color,
grid_height=grid::unit(4 * legend_grid_cex, "mm"),
grid_width=grid::unit(4 * legend_grid_cex, "mm"),
title_gp=legend_title_gp,
labels_gp=legend_labels_gp)
}
}
} else {
list(border=legend_border_color,
grid_height=grid::unit(4 * legend_grid_cex, "mm"),
grid_width=grid::unit(4 * legend_grid_cex, "mm"),
title_gp=legend_title_gp,
labels_gp=legend_labels_gp)
}
}),
left_param_list);
}
# put it all together
if (length(left_anno_list) > 0) {
if (length(left_annotation_name_gp) == 0) {
left_annotation_name_gp <- grid::gpar(fontsize=row_anno_fontsize);
}
left_alist <- alist(
simple_anno_size=simple_anno_size,
col=left_color_list,
gap=ComplexHeatmap::ht_opt("ROW_ANNO_PADDING"),
annotation_legend_param=left_param_list,
show_legend=show_left_legend_v,
show_annotation_name=show_left_annotation_name,
annotation_name_rot=left_annotation_name_rot,
annotation_name_gp=left_annotation_name_gp,
border=TRUE
);
if (debug > 1) {
jamba::printDebug("heatmap_se(): ",
"left_alist:");
print(jamba::sdim(left_alist));
print(left_alist);
jamba::printDebug("heatmap_se(): ",
"left_anno_list:");
print(jamba::sdim(left_anno_list));
print(left_anno_list);
}
left_arglist <- c(
left_alist,
left_anno_list);
left_annotation <- do.call(ComplexHeatmap::rowAnnotation,
left_arglist);
if (debug > 1) {
print(jamba::sdim(left_annotation@anno_list))
for (i in left_annotation@anno_list){
print(i@show_legend)
}
}
}
}
# optional row_split
if (length(row_split) > 0) {
if (TRUE %in% correlation) {
# correlation uses colData for split
if (any(c("factor", "character") %in% class(row_split))) {
if (!any(duplicated(row_split)) &&
all(row_split %in% colnames(colData_se))) {
row_split <- data.frame(check.names=FALSE,
colData_se[isamples, row_split, drop=FALSE]);
} else if (all(names(row_split) %in% isamples)) {
row_split <- row_split[isamples];
} else if (length(row_split) == length(isamples)) {
names(row_split) <- isamples;
} else {
row_split <- NULL;
}
} else if (length(row_split) == 1 && is.numeric(row_split)) {
# leave as-is
} else {
row_split <- NULL;
}
} else {
# non-correlation uses rowData for split
if (length(row_split) == 1 && is.numeric(row_split)) {
# leave as-is, this splits to the number of clusters requested
if (row_split > length(gene_hits)) {
row_split <- length(gene_hits);
}
} else {
# 0.0.61.900 - anything except single numeric value
# is handled here
# } else if (any(c("factor", "character") %in% class(row_split))) {
if (inherits(row_split, "data.frame")) {
# data.frame is acceptable input
# but rownames must represent every gene_hits value
row_split_match <- match(gene_hits, rownames(row_split));
if (all(is.na(row_split_match))) {
stop("rownames(row_split) does not match any heatmap rows.");
}
row_split <- row_split[row_split_match, , drop=FALSE];
rownames(row_split) <- row_split_match;
} else if (!any(duplicated(row_split)) &&
all(row_split %in% colnames(rowData_se))) {
# no duplicated values, and all values match colnames(rowData)
row_split_cols <- intersect(row_split, colnames(rowData_se))
row_split <- data.frame(check.names=FALSE,
rowData_se[gene_hits, row_split_cols, drop=FALSE]);
} else if (all(gene_hits %in% names(row_split))) {
# 0.0.61.900 - reverse order: gene_hits in names(row_split)
row_split <- data.frame(row_split=row_split[gene_hits]);
rownames(row_split) <- gene_hits;
} else {
row_split <- NULL;
}
}
}
} else if (TRUE %in% correlation) {
row_split <- column_split;
}
if (verbose && length(row_split) > 0) {
jamba::printDebug("heatmap_se(): ",
"row_split:", head(row_split, 20));
}
assay_name <- head(intersect(assay_name,
names(SummarizedExperiment::assays(se))), 1);
if (length(assay_name) == 0) {
if (length(SummarizedExperiment::assays(se)) == 1) {
assay_name <- head(names(SummarizedExperiment::assays(se)), 1);
if (length(assay_name) == 0) {
assay_name <- 1;
}
} else {
stop("assay_name must be supplied when there are multiple assays(se)")
}
}
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"using assay_name '", assay_name, "'");
}
norm_label <- paste0(assay_name, " ", data_type);
if (ncol(se) == 1 && !FALSE %in% centerby_colnames) {
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"Defining centerby_colnames=FALSE since there is only one column.");
}
centerby_colnames <- FALSE;
}
if (any(centerby_colnames %in% FALSE)) {
centerby_colnames <- NULL;
centerGroups <- FALSE;
centerby_label <- "";
} else {
centerby_colnames <- intersect(centerby_colnames,
colnames(colData_se));
if (length(centerby_colnames) > 0) {
centerby_label <- paste0("centered within ",
jamba::cPaste(centerby_colnames,
sep="/"));
centerGroups <- jamba::pasteByRow(
colData_se[,centerby_colnames]);
} else {
centerGroups <- NULL;
centerby_label <- "global-centered";
}
if (length(control_label) > 0 && any(nchar(control_label)) > 0) {
centerby_label <- paste0(centerby_label,
", ",
control_label);
}
}
# row_labels
if (correlation) {
# for correlation, samples are shown on rows
# so it must use colData_se
if (length(row_label_colname) == 0 ||
!all(row_label_colname %in% colnames(colData_se))) {
row_labels <- isamples;
} else if (length(row_label_colname) > 1) {
row_labels <- jamba::pasteByRow(
colData_se[isamples, row_label_colname, drop=FALSE],
sep=",");
} else {
row_labels <- colData_se[isamples, , drop=FALSE][[row_label_colname]];
}
} else {
# for expression data, rowData_se must be used
if (length(row_label_colname) == 0) {
row_labels <- gene_hits;
} else if (length(row_label_colname) > 1) {
row_labels <- jamba::pasteByRow(
rowData_se[gene_hits, row_label_colname, drop=FALSE],
sep=",");
} else {
row_labels <- rowData_se[gene_hits, , drop=FALSE][[row_label_colname]];
}
}
if (length(show_row_names) == 0) {
show_row_names <- (length(gene_hits) <= 500);
}
# pull assay data separately so we can tolerate other object types
# Note columns are not subset here so they can be used during centering.
# After centering, isamples is used to subset columns as needed.
if (any(grepl("SummarizedExperiment|SingleCellExperiment",
ignore.case=TRUE, class(se)))) {
se_matrix <- SummarizedExperiment::assays(se[gene_hits, ])[[assay_name]];
} else {
se_matrix <- Biobase::assayData(se[gene_hits, ])[[assay_name]];
}
# heatmap legend labels
# TODO: handle non-zero color_floor
if (length(legend_at) == 0) {
if (correlation) {
if (abs(color_max) > 1) {
color_max <- 1;
}
legend_at <- seq(-ceiling(color_max),
to=ceiling(color_max),
by=0.25);
if (length(legend_labels) == 0) {
legend_labels <- legend_at;
}
} else {
if (FALSE %in% centerby_colnames && min(se_matrix, na.rm=TRUE) >= 0) {
if (color_max <= 1) {
legend_pretty <- pretty(c(0, color_max), n=4)
legend_at <- unique(c(
legend_pretty[legend_pretty <= color_max],
color_max))
if (length(legend_labels) == 0) {
legend_labels <- legend_at;
}
} else {
legend_at <- seq(from=0,
to=ceiling(color_max));
}
} else {
if (color_max <= 1) {
legend_pretty <- pretty(c(-color_max, color_max), n=6)
legend_at <- unique(c(
-color_max,
legend_pretty[legend_pretty <= color_max & legend_pretty >= -color_max],
color_max))
if (length(legend_labels) == 0) {
legend_labels <- legend_at;
}
} else {
legend_at <- seq(-ceiling(color_max),
to=ceiling(color_max));
}
}
}
}
if (length(legend_labels) != length(legend_at)) {
if (correlation) {
legend_labels <- legend_at;
} else {
legend_labels <- round(jamba::exp2signed(legend_at+0.000001, offset=0))
if (any(duplicated(legend_labels))) {
legend_labels <- round(10 * jamba::exp2signed(legend_at+0.000001, offset=0)) / 10;
}
}
}
# cluster_columns
if (!is.function(cluster_columns) && cluster_columns %in% TRUE) {
cluster_columns <- function(x, ...) {
amap::hcluster(jamba::rmNA(naValue=0, x),
...,
method="euclidean",
link="ward")}
}
# define heatmap matrix
# After centering, columns are subset using isamples.
if (length(centerGroups) > 0 && any(centerGroups %in% FALSE)) {
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"Not centering data.");
}
se_matrix <- se_matrix[, isamples, drop=FALSE];
legend_title <- data_type;
if (length(hm_name) == 0) {
hm_name <- legend_title;
}
} else {
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"Centering data.");
}
se_matrix <- jamma::centerGeneData(
useMedian=useMedian,
centerGroups=centerGroups,
x=se_matrix,
controlSamples=controlSamples,
controlFloor=controlFloor,
naControlAction=naControlAction,
naControlFloor=naControlFloor,
...)[, isamples, drop=FALSE];
legend_title <- paste0("centered\n", data_type);
}
if (correlation) {
# call correlation function cor()
se_matrix <- jamba::call_fn_ellipsis(cor,
x=se_matrix,
use="pairwise.complete.obs",
...);
cluster_rows <- cluster_columns;
if (length(centerGroups) > 0 && any(centerGroups %in% FALSE)) {
legend_title <- paste0("correlation of\n", data_type);
} else {
legend_title <- paste0("correlation of\ncentered\n", data_type);
}
}
if (length(hm_name) == 0) {
hm_name <- legend_title;
}
# optional mark_rows
mark_rows <- intersect(mark_rows, gene_hits);
if (length(mark_rows) > 0) {
mark_at <- match(mark_rows, rownames(se_matrix));
right_annotation_mark <- ComplexHeatmap::rowAnnotation(
foo=ComplexHeatmap::anno_mark(
at=mark_at,
labels=row_labels[mark_at],
labels_gp=mark_labels_gp))
if (length(right_annotation) == 0) {
right_annotation <- right_annotation_mark;
} else {
right_annotation <- right_annotation + right_annotation_mark;
}
}
# pre-calculate row clusters
# This step is required to enable row_split as integer number of clusters,
# which is not accepted when supplying a function.
# This step does not work with character or data.frame row_split
if (length(row_split) == 1 &&
is.numeric(row_split)) {
if (is.function(cluster_rows)) {
if (verbose) {
jamba::printDebug("heatmap_se(): ",
paste0("row_split requires for cluster_rows()",
" to be applied to generate a dendrogram."));
}
cluster_rows <- cluster_rows(se_matrix);
} else if (FALSE %in% cluster_rows || length(cluster_rows) == 0) {
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"row_split ignored because cluster_rows=FALSE.");
}
row_split <- NULL;
}
}
if (length(column_split) == 1 &&
is.numeric(column_split)) {
# is.function(cluster_columns)) {
# cluster_columns <- cluster_columns(se_matrix);
if (is.function(cluster_columns)) {
if (verbose) {
jamba::printDebug("heatmap_se(): ",
paste0("column_split requires for cluster_columns()",
" to be applied to generate a dendrogram."));
}
cluster_columns <- cluster_columns(se_matrix);
} else if (FALSE %in% cluster_columns || length(cluster_columns) == 0) {
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"column_split ignored because cluster_columns=FALSE.");
}
column_split <- NULL;
}
}
# optional customization of row and column names gp
if (length(row_names_gp) == 0) {
row_names_gp <- grid::gpar(fontsize=row_fontsize)
} else {
# if fontsize is not defined we add it here,
# otherwise use row_names_gp as supplied
if (!"fontsize" %in% names(row_names_gp)) {
row_names_gp <- do.call(grid::gpar,
c(row_names_gp,
alist(fontsize=row_fontsize)))
}
}
if (length(column_names_gp) == 0) {
column_names_gp <- grid::gpar(fontsize=column_fontsize)
} else {
# if fontsize is not defined we add it here,
# otherwise use column_names_gp as supplied
if (!"fontsize" %in% names(column_names_gp)) {
column_names_gp <- do.call(grid::gpar,
c(column_names_gp,
alist(fontsize=column_fontsize)))
}
}
# define heatmap title using relevant arguments
row_label <- NULL;
if (length(row_type) > 0 && nchar(head(row_type, 1)) > 0) {
row_label <- paste0(
jamba::formatInt(length(gene_hits)),
" ",
head(row_type, 1))
}
column_label <- NULL;
if (length(column_type) > 0 && nchar(head(column_type, 1)) > 0) {
column_label <- paste0(
jamba::formatInt(ncol(se_matrix)),
" ",
head(column_type, 1))
}
dim_label <- paste(c(row_label, column_label), collapse=", ")
if (any(nchar(dim_label) > 0)) {
dim_label <- paste0(dim_label, "\n")
}
if (length(hm_title) == 0) {
hm_title <- paste0(
dim_label,
norm_label,
ifelse(any(nchar(centerby_label) > 0),
paste0(",\n", centerby_label),
""))
}
# optionally add whitespace buffer after the title
if (length(hm_title_buffer) == 1 && hm_title_buffer > 0) {
hm_title_buffer <- ceiling(hm_title_buffer);
hm_title <- paste0(hm_title,
paste0(rep("\n", hm_title_buffer),
collapse=""))
}
# optionally apply heatmap title to column_title
if (TRUE %in% apply_hm_column_title) {
column_title <- hm_title;
hm_title <- "";
}
# define heatmap
if (verbose && length(row_split) > 0) {
jamba::printDebug("heatmap_se(): ",
"row_split (pre-heatmap):");print(head(row_split, 20));
}
hm_hits <- jamba::call_fn_ellipsis(ComplexHeatmap::Heatmap,
matrix=se_matrix,
use_raster=use_raster,
top_annotation=top_annotation,
left_annotation=left_annotation,
right_annotation=right_annotation,
heatmap_legend_param=list(
border=legend_border_color,
color_bar="discrete",
at=legend_at,
labels=legend_labels,
grid_height=grid::unit(4 * legend_grid_cex, "mm"),
grid_width=grid::unit(4 * legend_grid_cex, "mm"),
title=legend_title,
title_gp=legend_title_gp,
labels_gp=legend_labels_gp
),
clustering_method_rows="ward.D",
column_split=column_split,
column_title=column_title,
row_split=row_split,
row_title_rot=row_title_rot,
cluster_column_slices=cluster_column_slices,
cluster_row_slices=cluster_row_slices,
border=TRUE,
name=hm_name,
show_row_names=show_row_names,
show_row_dend=show_row_dend,
show_heatmap_legend=show_heatmap_legend,
row_labels=row_labels,
row_names_gp=row_names_gp,
column_names_gp=column_names_gp,
col=colorjam::col_div_xf(color_max,
lens=lens,
floor=color_floor,
...),
cluster_columns=cluster_columns,
cluster_rows=cluster_rows,
...)
# optionally apply heatmap title to column_title
attr(hm_hits, "hm_title") <- hm_title;
if (length(column_title) > 0) {
attr(hm_hits, "column_title") <- column_title;
}
if (debug) {
ret_list <- list(
hm=hm_hits,
top_annotation=top_annotation,
left_annotation=left_annotation,
hm_title=hm_title
);
ret_list$gene_hits_im <- gene_hits_im;
ret_list$alt_gene_hits_im <- alt_gene_hits_im;
ret_list$gene_hitlist <- gene_hitlist;
ret_list$alt_gene_hitlist <- alt_gene_hitlist;
return(ret_list)
}
hm_hits
}
jmw86069/jamses documentation built on Nov. 4, 2024, 9:25 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
#' Heatmap for SummarizedExperiment data
#'
#' Heatmap for SummarizedExperiment data
#'
#' Note: Still a work in progress. This function is the basis
#' for the majority of heatmaps created for Omics data.
#'
#' This function is a bold attempt to simplify the intricate task
#' of creating an expression heatmap, using `ComplexHeatmap::Heatmap()`,
#' given a `SummarizedExperiment` object.
#'
#' It attempts to enable:
#'
#' * selection of `assays(se)` to use in the heatmap
#' * use of `rowData(se)` or `colData(se)` to produce row and
#' column annotations, respectively.
#' * re-use of defined colors for annotations, see `platjam::design2colors()`
#' * define and adjust heatmap color gradient and scale
#' * data centering by row: versus all columns, or specific controls,
#' optionally within independent centering groups
#' * filtering rows to show only the statistical hits
#' * display annotation of statistical hits beside the heatmap
#' * split rows or columns using `rowData(se)` and `colData(se)`, respectively
#' * heatmap title to display key options used, for easy reference
#'
#' ## Additional Features
#'
#' * data centering can be disabled with `centerby_colnames=FALSE`.
#' * alternative hits can be displayed using `alt_sestats`. It does not
#' subset heatmap rows, it inherits rows from `sestats`.
#' * display a subset of columns after row centering, useful to hide
#' the control group for certain figures.
#' * option to display correlation heatmap, using the same data
#' centering, then calculates Pearson correlation across sample columns.
#' * labels and legend grids can be customized to exact sizes
#' with `grid::gpar()` and `grid::unit()` definitions, for manuscript figures.
#' * mark annotations option to label a subset of rows
#' * row subclusters can be visualized using `row_subcluster` to drill down
#' into specific subclusters from hierarchical clustering, k-means clustering,
#' or any `row_split`.
#'
#' ## Data Centering
#'
#' The intent is to display expression values from `assays(se)`,
#' centered across all columns, or with customization defined by
#' `centerby_colnames` and `normgroup_colnames`. The resulting centered
#' data can be subsetted by argument `isamples`, which occurs after
#' centering in order to decouple the centering step from the display
#' of resulting data. To subset samples involved in centering itself,
#' either subset the input `se` data, or supply `controlSamples` to
#' define a subset of samples used as the baseline in centering.
#' See `jamma::centerGeneData()` for more details.
#'
#' Paired data, also called repeated measures data, can be visualized
#' by including the pairing as `centerby_colnames` so that centering
#' is calculated within each pairing subgroup. In this case if also using
#' `controlSamples` to define a "time zero" or "baseline", then all
#' baseline samples will have exactly zero, if there is only one replicate
#' per pairing group at the baseline. In this case, it may be useful
#' to create the full heatmap once to confirm the centering is performing
#' as intended, then create a second heatmap using `isamples` to show only
#' the non-baseline samples - thus removing the large chunk of values with 0.
#'
#' Note: data centering can be disabled with `centerby_colnames=FALSE`.
#'
#' ## Heatmap Title
#'
#' A heatmap title is returned as an attribute `attr(hm, "hm_title")`,
#' which describes:
#'
#' * total rows displayed, with `row_type` indicating the measured entity
#' (gene, probe, DEGs, etc.)
#' * total columns displayed, with `column_type` indicating the sampled entity
#' (samples, total replicates, etc.)
#' * the `assay_name` for the data being displayed
#' * relevant options for data centering, for example
#' `"global-centered"` (by default) or
#' `"Centered within Cell Line, versus Wildtype"`
#'
#' To include the heatmap title:
#'
#' `ComplexHeatmap::draw(hm, column_title=attr(hm, "hm_title))`
#'
#' ## Top and Left Annotations
#'
#' The top heatmap annotations use `colData(se)` with user-supplied
#' `top_colnames` or by auto-detecting those colnames that apply
#' to multiple `colnames(se)`.
#' Colors can be supplied using argument `sample_color_list`, as
#' described below.
#'
#' The an incidence matrix of statistical hits can be displayed
#' on the left of the heatmap, using arguments `sestats` and `alt_sestats`.
#' These arguments can accept either the output of `se_contrast_stats()`,
#' or they can be a `numeric` matrix with values `c(-1, 0, 1)`, indicating
#' statistical hits down, no change, and up, respectively.
#' The contrasts can optionally be subset with `contrast_names`,
#' which corresponds to columns in the matrix if supplied in that format.
#'
#' When `sestats` is supplied, it will subset all heatmap rows to include
#' only rows with at least one non-zero value in the incidence matrix.
#' If argument `rows` is supplied, then all `rownames(se)` matching
#' `rows` are displayed, regardless of statistical hits.
#'
#' For comparison across other `sestats` results, argument `alt_sestats`
#' is treated similar to `sestats` except that the heatmap is not subset
#' based upon these values. That means the heatmap will be subset to
#' match hits defined by `sestats` but not `alt_sestats`.
#' The `alt_sestats` incidence matrix is displayed to the far left
#' of the `sestats` incidence matrix. For clarity, it can be useful to
#' add `alt_sestats_suffix` to add a suffix to each contrast label,
#' for example if `sestats` represents limma hits, use
#' `sestats_suffix=" limma"`, and if `alt_sestats` represents limma-voom
#' hits, use `alt_sestats_suffix=" limmavoom"`.
#'
#' Argument `rowData_colnames` can be supplied, which enables display of
#' `rowData(se)` annotations in the `left_annotation` of the heatmap.
#' Colors can be supplied using argument `sample_color_list`.
#'
#' Argument `sample_color_list` is a `list` named by each annotation column
#' to be displayed as top or left annotation. Each list element is either:
#'
#' * a `character` vector of R colors named by `character` value, or
#' * a `function` defined by `circlize::colorRamp2()` to be applied
#' for `numeric` column values. In this case the `breaks` used to
#' define the color function are used to define the color legend.
#'
#' The function `platjam::design2colors()` can be used to create
#' `sample_color_list` starting with a `data.frame` of annotations,
#' and will soon be moved into this package.
#'
#' A custom `left_annotation` can be supplied, but this method currently
#' prevents the other annotations described above from being displayed.
#' To display automated annotations with `rowData_colnames` and custom
#' row annotations, supply custom annotations with `right_annotation`.
#' Note that annotations must be supplied in exact row order, which
#' is usually easiest when supplying `rows` with specific set of rows.
#'
#' ## Compatible Input Formats
#'
#' Data provided in `se` is expected to be `SummarizedExperiment`, however
#' other Bioconductor data types are accepted that provide
#' accessor functions: `featureData()`, `phenoData()`, and `assayData()`,
#' including for example the `"MethyLumiSet"` class.
#'
#' Note that `matrix` input is currently not supported, however it can
#' be converted to `SummarizedExperiment` like this:
#'
#' ```r
#' se <- SummarizedExperiment::SummarizedExperiment(
#' assays=list(data=matrix),
#' rowData=data.frame(Gene=rownames(matrix)),
#' colData=data.frame(Sample=colnames(matrix)))
#' ```
#'
#' @family jamses heatmaps
#'
#' @param se `SummarizedExperiment` by default, or one of the following:
#' * `SummarizedExperiment` with accessor functions
#' `rowData()`, `colData()`, and `assays()`. It will use
#' `values(rowRanges())` if no slot `rowData` exists.
#' * `SingleCellExperiment` with accessor functions
#' `rowData()`, `colData()`, and `assays()`. It will use
#' `values(rowRanges())` if no slot `rowData` exists.
#' * `Seurat` object, which is coerced to `SingleCellExperiment` and
#' handled accordingly
#' * `ExpressionSet` or compatible object with accessor functions
#' `featureData()`, `phenoData()`, and `assayData()`.
#' @param sestats one of the following types of data:
#' * `list` output from `se_contrast_stats()`, which
#' specifically contains `hit_array` as a 3-dimensional array of hits
#' with dimensions "Cutoffs", "Contrasts", "Signal".
#' * `numeric` matrix intended to represent an incidence matrix,
#' where a value `0` indicates absence, and non-zero indicates presence.
#' This format is useful for supplying any incidence matrix, such as
#' gene-by-pathway (for example Github package "jmw86069/multienrichjam"
#' provides `mem$memIM` with gene-by-pathway matrix),
#' or gene-by-class (see Github package "jmw86069/pajam"
#' for examples using ProteinAtlas protein classification, including
#' membrane-bound, secreted, transcription factors, etc.), or any
#' incidence matrix defined by Github "jmw86069/venndir" function
#' `list2im_value()` or `list2im()` which converts input to a Venn diagram
#' into an incidence matrix.
#' * When `sestats` is supplied, data is converted to incidence matrix,
#' then columns are matched with `contrast_names`. All rows with non-zero
#' entry in those columns are included in the heatmap.
#' When `rows` is also supplied, then the intersection of incidence
#' matrix rows and `rows` is displayed in the heatmap.
#' * Note that `alt_sestats` does not subset rows displayed in the
#' heatmap.
#' @param hm_name `character` string, or `NULL` (default) which uses the
#' `data_type` value. Note that the legend title uses the `data_type`,
#' and is also used for `hm_name` when `hm_name=NULL`.
#' The `hm_name` is most useful to customize because this string is used
#' as the prefix for grid graphical components, for example seen with
#' `ComplexHeatmap::list_components()`. When two heatmaps or a
#' `HeatmapList` is drawn, the names can be used to define specific
#' grid regions of each heatmap. If the heatmaps share the same
#' `hm_name` then the regions will also have identical name and cannot
#' be addressed distinctly.
#' @param hm_title `character` string, or `NULL` (default) which generates
#' a heatmap title using the dimensions, `assay_name`, `data_type`,
#' and a string which describes the data centering.
#' When provided as a `character` string, it is used as-is.
#' (In future this value may accept variable names.)
#' @param rows `character` vector of `rownames(se)` to define a specific
#' set of rows to display. When `sestats` is supplied, then the
#' intersection of `rows` with genes defined by `sestats` is displayed.
#' Note that rows are required to be in `rownames(se)`, all other rows
#' are dropped.
#' @param row_type `character` string used in the title of the heatmap
#' which indicates how many rows are displayed. For example
#' `"1,234 genes detected above background"` or
#' `"1,234 DEGs by limma-voom"`.
#' When `row_type=""` or `row_type=NULL` this information
#' is not included in the heatmap title.
#' @param column_type `character` string used in the title of the heatmap
#' which indicates how many column are displayed. For example
#' `"12 samples"` or `"12 biological replicates"`.
#' When `column_type=""` or `column_type=NULL` this information
#' is not included in the heatmap title.
#' @param data_type `character` string used as title of the heatmap
#' color gradient legend, for example `"expression"` indicates
#' the data contains gene expression measurements. Notes:
#' * The prefix `"centered"` is automatically appended whenever
#' the data is also centered for the heatmap. Set `centerby_colnames=FALSE`
#' to display data that is not centered.
#' * The prefix `"correlation of"` is automatically appended when
#' `correlation=TRUE` which displays correlation of whatever data
#' is included in the heatmap.
#' @param correlation `logical` indicating whether to calculate sample
#' correlation, and plot a sample-by-sample correlation heatmap.
#' This option is included here since many of the same arguments
#' are required for data centering, and sample annotations.
#' Note that `color_max` is forced to a maximum value of `1.0`,
#' representing the maximum correlation value.
#' @param assay_name `character` string indicating the name in
#' `assays(se)` to use for data to be displayed in the heatmap.
#' * When multiple `assay_name` values are supplied, the first
#' assay_name that matches `names(assays(se))` will be used in the
#' heatmap. In this way, multiple `assay_names` can be supplied to
#' define statistical hits in `sestats`, which calls `hit_array_to_list()`
#' to combine hits across `assay_name` entries; but only the first
#' `assay_name` found in `se` is used for the heatmap values.
#' * When there is only one value for `assayNames(se)`, then
#' `assay_name` will default to this value, instead of acting like
#' it couldn't possibly know what was intended. Haha.
#' * Lastly, `assay_name` can be a `numeric` index, helpful in case
#' `assays(se)` contains no names - not recommended but it can happen.
#' @param contrast_names `character` vector of contrasts in
#' `sestats$hit_array` to use for the heatmap. When `contrast_names=NULL`
#' then all contrasts are displayed, which is the default.
#' @param contrast_suffix `character` string with optional suffix to append
#' to the end of each contrast name label for `sestats` hit incidence
#' matrix beside the heatmap. This suffix may be useful when comparing
#' two methods for the same set of contrast names, with `sestats` and
#' `alt_sestats`.
#' @param cutoff_name `character` or `integer` index used to define the
#' specific statistical cutoffs to use from `sestats$hit_array`. This
#' argument is passed to `hit_array_to_list()` as `cutoff_names`.
#' @param alt_sestats,alt_assay_name,alt_contrast_names,alt_contrast_suffix
#' arguments analogous to those described above for `sestats` which
#' are used when `alt_sestats` is supplied.
#' @param isamples `character` vector of `colnames(se)` used to visualize a
#' subset of samples used for the data centering step. Note that
#' data centering uses all columns supplied in `se`, and after centering,
#' the subset of columns defined in `isamples` is displayed in the heatmap.
#' This distinction makes it possible to center data by some control group,
#' then optionally not display the control group data.
#' @param normgroup_colname `character` vector of colnames in `colData(se)`
#' used during data centering. When supplied, samples are centered
#' independently within each normgroup grouping. These values are
#' equivalent to using `centerby_colnames`.
#' @param centerby_colnames either:
#' * `character` vector of colnames in `colData(se)`
#' used during data centering. When supplied, samples are centered
#' independently within each centerby grouping. It is typically used
#' for things like cell lines, to center each cell line by a time
#' point control, or untreated control.
#' * `NULL` to perform centering across all columns in `se`.
#' * `FALSE` to disable centering.
#' @param controlSamples `character` optional vector of samples to use as the
#' reference during data centering. Note that samples are still
#' centered within each normgroup and centerby grouping, and within
#' that grouping samples are centered to the `controlSamples`
#' which are present in that grouping. Any center group for which no
#' samples are defined in `controlSamples` will use all samples in that
#' center group. Typically, `controlSamples` is used to define a
#' specific group as the reference for centering, so changes are displayed
#' relative to that group. Make sure to define `control_name` to include
#' an appropriate label in the heatmap title.
#' @param control_label `character` string used in heatmap title
#' to describe the control used during data centering, relevant when
#' `controlSamples` is also supplied. Recommended format:
#' `"versus Wildtype"` or `"vs. Wildtype"`.
#' The heatmap title will include data centering and `control_label`
#' in this format:
#' `"centered within {centerby_colnames}, {control_label}"`, for example
#' `"centered within Genotype/Time, versus Vehicle"`.
#' @param controlFloor,naControlAction,naControlFloor passed to
#' `jamma::centerGeneData()` to customize data centering.
#' * `controlFloor` imposes an optional noise floor to control group
#' mean/median values, so the summary value during centering is at
#' least `controlFloor`. Useful for defining an effective noise floor
#' for a platform technology.
#' * `naControlAction` defines the action taken only when values for
#' all control samples are `NA`.
#' * `naControlFloor` is a `numeric` value used when
#' `naControlAction="floor"`, which causes the group reference value
#' to use the value provided in `naControlFloor`.
#' @param top_colnames one of the following types:
#' * `character` vector of colnames to use from
#' `colData(se)` as annotations to display in `top_annotation` above
#' the heatmap.
#' * `NULL`, will call `choose_annotation_colnames()` to detect
#' reasonable colnames: columns with more than one unique value;
#' columns with at least one duplicated value.
#' * `FALSE` will hide the `top_colnames`, which also occurs when
#' `colData(se)` is empty.
#' @param top_annotation specific heatmap annotation as defined by
#' `ComplexHeatmap::HeatmapAnnotation()`. When supplied, the `top_colnames`
#' described above is not used.
#' @param top_annotation_name_gp `grid::gpar` object to customize the
#' annotation name displayed beside the top annotation.
#' @param rowData_colnames `character` vector of colnames in `rowData(se)`
#' to use for heatmap annotations displayed on the left side of
#' the heatmap. Specific colors can be included in `sample_color_list`
#' as a named `list` of color vectors or color functions. The names
#' of this list must match colnames to be displayed, otherwise
#' `ComplexHeatmap::Heatmap()` will define its own color function.
#' @param left_annotation specific heatmap annotation as defined by
#' `ComplexHeatmap::rowAnnotation()`. When supplied, the `rowData_colnames`
#' and `sestats` row annotations are not displayed. In order to supply
#' custom row annotations and not lose `left_annotation` defined above,
#' supply the row annotations as `right_annotation`.
#' @param left_annotation_name_gp `grid::gpar` object to customize the
#' annotation name displayed beside the left annotation.
#' @param left_annotation_name_rot `numeric` rotation of left annotation
#' label, in degrees, where `0` indicates normal text, and `90` is
#' rotated vertically.
#' @param right_annotation specific heatmap annotation as defined by
#' `ComplexHeatmap::HeatmapAnnotation()`. This element is created
#' automatically when `mark_rows` is supplied.
#' @param simple_anno_size `grid::unit` size used to define heatmap
#' annotation sizes (height or width of each line) for any simple
#' annotations.
#' @param legend_title_gp `grid::gpar` to customize the legend title
#' fonts, applied to each legend: top annotation, left annotation,
#' main heatmap.
#' @param legend_labels_gp `grid::gpar` to customize the legend label
#' fonts, applied to each legend: top annotation, left annotation,
#' main heatmap.
#' @param legend_grid_cex `numeric` multiplied to adjust the relative
#' size of each legend grid unit, applied to each relevant metric.
#' @param row_names_gp `gpar` to define custom column name settings.
#' When `"fontsize"` is not defined, the automatic font size calculation
#' is added to the `row_names_gp` supplied.
#' @param row_split is used to define heatmap split by row, ultimately
#' passed to `ComplexHeatmap::Heatmap()` argument `row_split`. However,
#' the input type can vary:
#' * `integer` number of row splits based upon row clustering. If
#' `row_split` is greater than the number of rows, it will be set
#' to the number of rows.
#' * `character` value or values in colnames of `rowData(se)` to split
#' using row annotation in `se`.
#' * `data.frame` whose `rownames()` must contain all rows to be
#' displayed in the heatmap. This argument is passed directly to
#' `ComplexHeatmap::Heatmap()` to apply the split appropriately.
#' * `character` or `factor` vector named by `rownames(se)` with another
#' custom row split, passed directly to `ComplexHeatmap::Heatmap()`
#' argument `row_split`, with proper order for rows being displayed
#' @param row_subcluster `integer` or `character` vector representing one
#' or more elements returned by `row_split` to use as a drill-down
#' sub-cluster heatmap. This argument is experimental, and is intended
#' to make it easy to "drill down" into specific row clusters.
#' * The process internally creates a full heatmap using all arguments
#' as defined, then extracts the `jamba::heatmap_row_order()` which
#' contains row split data in a `list` of rownames vectors. The `list`
#' elements that match `row_subcluster` are extracted and used again
#' for a subsequent heatmap, and are displayed in the same order
#' in which they appear in the original full heatmap - which means
#' `cluster_rows=FALSE` is defined at this point. However `row_split`
#' is retained for this subset of rows, to indicate the original
#' row split annotation.
#' * Note that `row_subcluster` must match the `names()` returned
#' by `jamba::heatmap_row_order()` for the full heatmap, or should
#' include a `numeric` index for the `list` element or elements to
#' use.
#' * In principle this process would be run in two stages: First,
#' view a heatmap with `row_split=6`, then re-run the same heatmap
#' with `row_subcluster=4` to see cluster number 4 from the full
#' heatmap.
#' @param row_title_rot `numeric` value indicating text rotation in degrees
#' to use for row titles.
#' @param sample_color_list named `list` of color vectors or color functions,
#' where names correspond to colnames in either `colData(se)` or
#' `rowData(se)`, and which are passed to corresponding left or top
#' annotation functions. When colors are not defined,
#' `ComplexHeatmap::Heatmap()` will define colors using its own internal
#' function.
#' @param legend_at,legend_labels `numeric` and `character`, respectively,
#' to define custom values for the heatmap color gradient legend.
#' * When `legend_at` is supplied, it is used as provided.
#' * When `legend_labels` is supplied, it is used only when its length
#' equals `length(legend_at)`, in which case it is used as provided.
#' * When `centerby_colnames=FALSE` and the matrix data does not contain
#' negative values, `legend_at` uses integers from `0` to `color_max`,
#' to avoid presenting a color legend with unnecessary negative values.
#' However, when `color_max <= 1` it uses `pretty(c(0, color_max))`,
#' removing extraneous values, then ensuring the maximum value is
#' `color_max`. For example when `color_max=0.85`,
#' the `legend_at` is likely to be `c(0, 0.2, 0.4, 0.6, 0.8, 0.85)`.
#' * When `centerby_colnames` is not `FALSE`, and/or data contains
#' negative values, the `legend_at` is symmetric above and below zero.
#' When `color_max <= 1` the label is created using
#' `pretty(c(-color_max, color_max))`, as described above, so `color_max`
#' is used as the minimum and maximum value.
#' When `color_max > 1` the `legend_at` uses integer steps.
#' * When `color_max <= 1` the `legend_labels` are presented as-is with
#' no transformation.
#' * When `color_max > 1` the `legend_labels` are transformed with
#' `exp2signed(x)` which is the inverse of `log2(1 + x)`. This inverse
#' tranform displays normal space values, in the case of centered data,
#' the values represent normal space fold changes.
#' For example the `legend_at=c(-2, -1, 0, 1, 2)` would result in
#' `legend_labels=c("-4", "-2", "1", "2", "4")`.
#' * When `correlation=TRUE` the `legend_labels` by default use `legend_at`,
#' following rules for `color_max <= 1` above.
#' Otherwise, `legend_labels` values inverse transformed from `log2(1 + x)`
#' in order to display normal space fold change values,
#' * To override any of this behavior, supply both `legend_at`
#' and corresponding `legend_labels`.
#' @param subset_legend_colors `logical` indicating whether to subset colors
#' shown in the color key defined by `sample_color_list`, which is useful
#' when the heatmap only represents a subset of categorical color values.
#' * When `subset_legend_colors == TRUE`, the color key will only
#' include colors shown in the `top_annotation`.
#' * When `subset_legend_colors == FALSE` all colors defined in
#' `sample_color_list` will be included for each relevant column.
#' @param row_cex,column_cex `numeric` values used to adjust the row and
#' column name font size, relative to the automatic adjustment that
#' is already done based upon the number of rows and columns being
#' displayed.
#' @param row_anno_fontsize `numeric` base font size for row
#' annotation labels. This value is only used when `left_annotation_name_gp`
#' is not supplied. Note these labels appears underneath row annotations,
#' alongside column labels, and therefore they are also adjusted
#' by multiplying `column_cex` so these labels are adjusted together.
#' @param useMedian `logical` passed to `jamma::centerGeneData()` during
#' data centering.
#' @param show_row_names,show_row_dend `logical` indicating whether to
#' display row names, and row dendrogram, respectively. With more than
#' 2,000 rows this step can become somewhat slow.
#' @param mark_rows `character` vector of values in `rownames(se)` that
#' should be labeled using `ComplexHeatmap::anno_mark()` in call-out
#' style. Usually this argument is used when `show_row_names=FALSE`,
#' hiding the row labels, but is not required. Values in `mark_rows`
#' are intersected with rows displayed in the heatmap, therefore only
#' matching entries will be labeled.
#' @param mark_labels_gp `grid::gpar` to customize the font used by labels
#' when `mark_rows` is supplied.
#' @param column_title `character` optional title to include at the top
#' of the heatmap. It can include a single value, or multiple values
#' representing each `column_split` in the order they appear.
#' * Note: This argument is ignored when `apply_hm_column_title=TRUE`.
#' * When `column_title=character(0)` (default) or `column_title=""`,
#' the `ComplexHeatmap::Heatmap()` uses its usual default behavior,
#' which is to assign `column_title` using `column_split` values
#' when they are being used.
#' @param apply_hm_column_title `logical` (default FALSE) whether to
#' apply the heatmap title to `column_title`. This option makes it
#' convenient to display the title atop the heatmap without additional
#' effort, however it hides any other `column_title` created by
#' using `column_split`.
#' When using both `column_split` and `apply_hm_column_title=TRUE`
#' it may be useful to call `heatmap_column_group_labels()`.
#' @param hm_title_buffer `numeric` number of whitespace lines to add
#' to the heatmap title `(attr(hm, "hm_title")` between the title
#' and the heatmap below it. This whitespace can be useful when also
#' calling `heatmap_column_group_labels()`, to provide enough space
#' to draw the additional annotations.
#' @param show_heatmap_legend,show_left_legend,show_top_legend `logical`
#' indicating whether each legend should be displayed. Sometimes there
#' are too many annotations, and the color legends can overwhelm the
#' figure. Note that `show_left_legend` is applied in a specific order,
#' with these rules:
#' * `show_left_legend` is extended to at least length 2, then values
#' are used in order for: `sestats`, `rowData_colnames`, in order,
#' using whichever is defined.
#' * If `sestats` is defined, the first value in `show_left_legend`
#' is used for this annotation, then the remaining values are used
#' for `rowData_colnames`. Setting the first `show_left_legend` value
#' to `FALSE` will ensure the legend for `sestats` is not displayed.
#' * If `rowData_colnames` is defined, then the remaining values in
#' `show_left_legend` are recycled for all columns in
#' `rowData_colnames`, and applied in order.
#' In this way, individual columns can have the legend displayed or hidden.
#' * If `alt_sestats` is defined, the legend is always hidden, in favor
#' of showing only the legend for `sestats` without duplicating this legend.
#' @param legend_border_color `character` color used as border color tofor
#' be used as a border color for the various legend colors. Note this
#' argument recognizes only the first color provided, and does not
#' recycle different colors across the various legend borders.
#' @param show_top_annotation_name,show_left_annotation_name `logical`
#' indicating whether to display the annotation name beside the top and
#' left annotations, respectively.
#' @param row_label_colname `character` string used as a row label, where
#' this value is a colname in `rowData(se)`. It is useful when rownames
#' are some identifier that is not user-friendly, and where another column
#' in the data may provide a more helpful label, for example `"SYMBOL"`
#' to display gene symbol instead of accession number.
#' @param cluster_columns,cluster_rows `logical` indicating whether
#' to cluster columns by hierarchical clustering; or `function` with
#' a specific function that produces `hclust` or `dendrogram` output,
#' given a `numeric` matrix. Note that `cluster_rows` default will replace
#' `NA` values with zero `0` to avoid errors with missing data, and
#' uses `amap::hcluster()` by default which is a one-step compiled
#' process to perform distance calculation and hierarchical clustering.
#' @param column_names_gp `gpar` to define custom column name settings.
#' When `"fontsize"` is not defined, the automatic font size calculation
#' is added to the `column_names_gp` supplied.
#' @param column_split `character` or `integer` vector used to define
#' heatmap column split.
#' @param column_split_sep `character` string used as delimited when
#' `column_split` defines multiple split levels.
#' @param color_max `numeric` value passed to `colorjam::col_div_xf()`
#' which defines the upper limit of color gradient used in the heatmap.
#' @param color_floor `numeric` value passed to `colorjam::col_div_xf()`
#' argument `floor` which defines the minimum non-zero numeric value
#' for a color to be applied. This option is available to prevent coloring
#' values below the `color_floor` which can be useful in some circumstances.
#' @param lens `numeric` value passed to `colorjam::col_div_xf()` to control
#' the intensity of color gradient applied to the numeric range.
#' @param rename_contrasts,rename_alt_contrasts `logical` (default TRUE)
#' whether to rename long contrast names in `sestats` and `alt_sestats`
#' using `contrast2comp()`.
#' @param use_raster `logical` passed to `ComplexHeatmap::Heatmap()` to
#' determine whether heatmaps should be converted to raster images,
#' which effectively turns each heatmap panel into a single graphical
#' object.
#' Recommend `use_raster=TRUE` and also installing R package `magick`
#' which greatly enhances speed and quality of rasterized heatmap
#' output. When `magick` is not available, it may be best to use
#' `use_raster=FALSE`.
#' When `use_raster=FALSE` each pixel square of a heatmap
#' is its own graphical object. For heatmaps with very large dimensions,
#' having each pixel as an object can make the heatmap extremely large
#' in memory, and sometimes pixels can overlap others because the
#' minimum pixel size of the output graphics device does not
#' reflect the actual size of each pixel.
#' @param verbose `logical` indicating whether to print verbose output.
#' @param debug `logical` indicating debug mode, data is returned in a `list`:
#' * `hm` object `ComplexHeatmap::Heatmap`
#' * `top_annotation` object `ComplexHeatmap::HeatmapAnnotation` for columns
#' * `left_annotation` object `ComplexHeatmap::HeatmapAnnotation` for rows
#' * `hm_title` object `character` string with the heatmap title.
#' @param ... additional arguments are passed to supporting functions.
#'
#' @examples
#' se <- make_se_test(nrow=1000, ngroups=4, nreps=8)
#'
#' # optionally define factor levels to force the order of labels
#' SummarizedExperiment::rowData(se)$Class <- factor(
#' sample(head(LETTERS, 5), size=nrow(se), replace=TRUE))
#'
#' # basic heatmap
#' hm <- heatmap_se(se, rowData_colnames="Class")
#'
#' # draw by printing hm, or call draw() to add useful options
#' ComplexHeatmap::draw(hm,
#' column_title=attr(hm, "hm_title"),
#' merge_legends=TRUE)
#'
#' # define specific colors
#' sample_color_list <- list(
#' group=colorjam::group2colors(
#' unique(SummarizedExperiment::colData(se)$group)),
#' Class=colorjam::group2colors(
#' unique(SummarizedExperiment::rowData(se)$Class)))
#'
#' heatmap_se(se,
#' rowData_colnames="Class",
#' sample_color_list=sample_color_list)
#'
#' # split rows by "Class"
#' heatmap_se(se,
#' rowData_colnames="Class",
#' row_split="Class",
#' sample_color_list=sample_color_list)
#'
#' # let's have some fun now
#' hm2 <- heatmap_se(se,
#' column_split=c("group"),
#' column_title_rot=90,
#' row_split=c("Class"),
#' rowData_colnames=c("Class"),
#' cluster_row_slices=FALSE,
#' sample_color_list=sample_color_list)
#' hm2drawn <- ComplexHeatmap::draw(hm2, merge_legends=TRUE)
#'
#' # as an example, extract the row order
#' # technically you should use hm2drawn, but usually hm2 is enough
#' hro <- jamba::heatmap_row_order(hm2drawn);
#' jamba::sdim(hro)
#' lapply(hro, head, 7)
#' # (the names will differ from values when `row_labels` are customized)
#'
#' # center by WildType samples
#' # - controlSamples
#' # - control_label
#' hm2 <- heatmap_se(se,
#' controlSamples=rownames(subset(
#' SummarizedExperiment::colData(se), group %in% "groupA")),
#' control_label="vs groupA",
#' column_split=c("group"),
#' column_title_rot=90,
#' row_split=c("Class"),
#' rowData_colnames=c("Class"),
#' cluster_row_slices=FALSE,
#' sample_color_list=sample_color_list)
#' hm2drawn <- ComplexHeatmap::draw(hm2,
#' column_title=attr(hm2, "hm_title"),
#' merge_legends=TRUE)
#'
#' # add "callout" labels for a subset of rows
#' mark_rows <- c(sample(jamba::heatmap_row_order(hm2drawn)[[1]], size=5),
#' sample(jamba::heatmap_row_order(hm2drawn)[[1]], size=3));
#'
#' # turn off ComplexHeatmap warning when using RStudio
#' ComplexHeatmap::ht_opt(message=FALSE)
#'
#' hm3 <- heatmap_se(se,
#' mark_rows=mark_rows,
#' controlSamples=rownames(
#' subset(SummarizedExperiment::colData(se), group %in% "groupA")),
#' control_label="vs groupA",
#' column_split=c("group"),
#' column_title_rot=90,
#' row_split=c("Class"),
#' rowData_colnames=c("Class"),
#' cluster_row_slices=FALSE,
#' sample_color_list=sample_color_list)
#' ComplexHeatmap::draw(hm3,
#' column_title=attr(hm3, "hm_title"),
#' merge_legends=TRUE)
#'
#' # sestats can accept list, incidence matrix, hit_array, or sestats
#' # this example defines random set of hits
#' sestats_list <- list(
#' contrast1=setNames(sample(c(1, -1), replace=TRUE, size=50),
#' sample(rownames(se), size=50)),
#' contrast2=setNames(sample(c(1, -1), replace=TRUE, size=50),
#' sample(rownames(se), size=50)))
#' hm4 <- heatmap_se(se,
#' controlSamples=rownames(
#' subset(SummarizedExperiment::colData(se), group %in% "groupA")),
#' control_label="vs groupA",
#' sestats=sestats_list,
#' column_split=c("group"),
#' row_split=c("Class"),
#' rowData_colnames=c("Class"),
#' cluster_row_slices=FALSE,
#' sample_color_list=sample_color_list)
#' ComplexHeatmap::draw(hm4,
#' column_title=attr(hm4, "hm_title"),
#' merge_legends=TRUE)
#'
#' # it doesn't take much effort to run stats really quick
#' sedesign <- groups_to_sedesign(SummarizedExperiment::colData(se)[, "group", drop=FALSE])
#' contrast_names(sedesign) <- jamba::vigrep("-groupA", contrast_names(sedesign))
#' sestats <- se_contrast_stats(se=se,
#' fold_cutoff=4,
#' sedesign=sedesign, assay_name="counts")
#' hm4s <- heatmap_se(se,
#' controlSamples=rownames(
#' subset(SummarizedExperiment::colData(se), group %in% "groupA")),
#' control_label="vs groupA",
#' sestats=sestats,
#' column_split=c("group"),
#' row_split=6,
#' rowData_colnames=c("Class"),
#' cluster_row_slices=FALSE,
#' sample_color_list=sample_color_list)
#' ComplexHeatmap::draw(hm4s,
#' column_title=attr(hm4s, "hm_title"),
#' merge_legends=TRUE)
#'
#' # for fun, "drill down" into cluster 5
#' hm4s_4 <- heatmap_se(se,
#' controlSamples=rownames(
#' subset(SummarizedExperiment::colData(se), group %in% "groupA")),
#' control_label="vs groupA",
#' sestats=sestats,
#' column_split=c("group"),
#' row_split=6,
#' row_subcluster=4,
#' rowData_colnames=c("Class"),
#' cluster_row_slices=FALSE,
#' sample_color_list=sample_color_list)
#' ComplexHeatmap::draw(hm4s_4,
#' column_title=attr(hm4s_4, "hm_title"),
#' merge_legends=TRUE)
#'
#'
#' # sestats can be provided as an incidence matrix
#' if (jamba::check_pkg_installed("venndir")) {
#' # convert sestats to list
#' sestats_hitlist <- hit_array_to_list(sestats)
#' # convert sestats hitlist to incidence matrix
#' # - for fun, use only the first two contrasts
#' sestats_hitim <- venndir::list2im_value(sestats_hitlist[1:2])
#' print(head(sestats_hitim));
#'
#' # convert sestats_list to signed incidence matrix
#' sestats_im <- venndir::list2im_value(sestats_list)
#' print(head(sestats_im, 10));
#' # if the list has items (no direction) use venndir::list2im_opt()
#'
#' hm5 <- heatmap_se(se,
#' controlSamples=rownames(
#' subset(SummarizedExperiment::colData(se), group %in% "groupA")),
#' control_label="vs groupA",
#' sestats=sestats_hitim,
#' column_split=c("group"),
#' rowData_colnames=c("Class"),
#' cluster_row_slices=FALSE,
#' sample_color_list=sample_color_list)
#' ComplexHeatmap::draw(hm5,
#' column_title=attr(hm5, "hm_title"),
#' merge_legends=TRUE)
#' }
#'
#'
#' # customize column label fonts using column_names_gp
#' column_bold <- ifelse(
#' SummarizedExperiment::colData(se)$group %in% "groupA",
#' 2, 1);
#' hm6 <- heatmap_se(se,
#' controlSamples=rownames(
#' subset(SummarizedExperiment::colData(se), group %in% "groupA")),
#' control_label="vs WildType",
#' column_names_gp=grid::gpar(col=sample_color_list$group[
#' as.character(SummarizedExperiment::colData(se)$group)],
#' font=column_bold),
#' column_split=c("group"),
#' row_split=c("Class"),
#' rowData_colnames=c("Class"),
#' cluster_row_slices=FALSE,
#' sample_color_list=sample_color_list)
#' ComplexHeatmap::draw(hm6,
#' column_title=attr(hm6, "hm_title"),
#' merge_legends=TRUE)
#'
#' # correlation=TRUE, any heatmap becomes a sample correlation heatmap
#' hm6corr <- heatmap_se(se,
#' correlation=TRUE,
#' apply_hm_column_title=TRUE,
#' controlSamples=rownames(
#' subset(SummarizedExperiment::colData(se), group %in% "groupA")),
#' control_label="vs groupA",
#' column_names_gp=grid::gpar(col=sample_color_list$group[
#' as.character(SummarizedExperiment::colData(se)$group)],
#' font=rep(c(1, 2, 1), c(3, 5, 24))),
#' column_split=c("Group"),
#' sample_color_list=sample_color_list)
#' ComplexHeatmap::draw(hm6corr,
#' merge_legends=TRUE)
#'
#' ## Final heatmap:
#' # 1. Applies heatmap title automatically.
#' # 2. Hides the top_colnames
#' # 3. Adds fancy grouped labels above the heatmap.
#' #
#' # apply_hm_column_title=TRUE
#' # convenient way to define a title,
#' # but it does not also display column_split labels
#' #
#' # hm_title_buffer=4
#' # convenient way to insert some whitespace lines
#' #
#' # heatmap_column_group_labels()
#' # adds to a drawn heatmap - it must already be drawn
#' #
#' SummarizedExperiment::colData(se)$Genotype <- rep(c("WT", "KO"), each=16);
#' SummarizedExperiment::colData(se)$Treatment <- rep(c("Control", "Dex"), each=8);
#' hm7 <- heatmap_se(se,
#' apply_hm_column_title=TRUE,
#' hm_title_buffer=3,
#' controlSamples=rownames(
#' subset(SummarizedExperiment::colData(se), group %in% "groupA")),
#' control_label="vs groupA",
#' sestats=sestats_list,
#' top_colnames=FALSE,
#' column_split=c("group"),
#' row_split=c("Class"),
#' rowData_colnames=c("Class"),
#' cluster_row_slices=FALSE,
#' sample_color_list=sample_color_list)
#' hm7_drawn <- ComplexHeatmap::draw(hm7,
#' merge_legends=TRUE)
#'
#' # now add fancy labels
#' heatmap_column_group_labels(
#' hm_group_list=c("Treatment", "Genotype"),
#' se=se,
#' hm_drawn=hm7_drawn)
#' # Note: this step does not work consistently inside RStudio plot pane,
#' # in that case call dev.new() then run the step above to create hm7_drawn,
#' # then repeat the step below
#' #
#' # adjust the height of labels with argument y_offset_lines
#' # with positive values (upward), or negative values (downward).
#'
#' @export
heatmap_se <- function
(se,
sestats=NULL,
hm_name=NULL,
hm_title=NULL,
rows=NULL,
row_type="rows",
column_type="samples",
data_type="expression",
correlation=FALSE,
assay_name=NULL,
contrast_names=NULL,
contrast_suffix="",
cutoff_name=NULL,
alt_sestats=NULL,
alt_assay_name=assay_name,
alt_contrast_names=NULL,
alt_contrast_suffix="",
alt_cutoff_name=NULL,
isamples=colnames(se),
normgroup_colname=NULL,
centerby_colnames=NULL,
controlSamples=NULL,
control_label="",
controlFloor=NA,
naControlAction=c("na",
"row",
"floor",
"min"),
naControlFloor=0,
top_colnames=NULL,
top_annotation=NULL,
top_annotation_name_gp=grid::gpar(),
rowData_colnames=NULL,
left_annotation=NULL,
left_annotation_name_gp=grid::gpar(),
left_annotation_name_rot=90,
right_annotation=NULL,
simple_anno_size=grid::unit(8, "mm"),
legend_title_gp=grid::gpar(fontsize=10),
legend_labels_gp=grid::gpar(fontsize=10),
legend_grid_cex=1,
row_names_gp=NULL,
row_split=NULL,
row_subcluster=NULL,
row_title_rot=0,
sample_color_list=NULL,
legend_at=NULL,
legend_labels=NULL,
subset_legend_colors=TRUE,
row_cex=0.8,
column_cex=1,
row_anno_fontsize=11,
useMedian=FALSE,
show_row_names=NULL,
show_row_dend=length(rows) < 2000,
mark_rows=NULL,
mark_labels_gp=grid::gpar(),
column_title=character(0),
apply_hm_column_title=FALSE,
hm_title_buffer=0,
show_heatmap_legend=TRUE,
show_top_legend=TRUE,
show_left_legend=TRUE,
legend_border_color="black",
show_top_annotation_name=TRUE,
show_left_annotation_name=TRUE,
row_label_colname=NULL,
cluster_columns=FALSE,
cluster_column_slices=FALSE,
cluster_rows=function(x, ...){
amap::hcluster(jamba::rmNA(naValue=0, x),
...,
method="euclidean",
link="ward")},
cluster_row_slices=FALSE,
column_names_gp=NULL,
column_split=NULL,
column_split_sep=",",
color_max=3,
color_floor=0,
lens=2,
rename_contrasts=TRUE,
rename_alt_contrasts=TRUE,
use_raster=TRUE,
verbose=FALSE,
debug=FALSE,
...)
{
#
if (!jamba::check_pkg_installed("ComplexHeatmap")) {
stop("This function requires Bioconductor package ComplexHeatmap.");
}
if (!jamba::check_pkg_installed("venndir")) {
stop("This function requires Github package venndir from 'jmw86069/venndir'");
}
# if (!suppressPackageStartupMessages(require(SummarizedExperiment))) {
# stop("This function requires Bioconductor package SummarizedExperiment.");
# }
if (length(correlation) == 0) {
correlation <- FALSE;
}
if (length(legend_border_color) == 0) {
legend_border_color <- "transparent";
} else {
legend_border_color <- head(legend_border_color, 1)
}
# accept matrix input by converting to simple SummarizedExperiment
if (inherits(se, "data.frame")) {
se_sclass <- jamba::sclass(se);
se_numcols <- colnames(se)[
which(se_sclass %in% c("numeric", "integer"))];
if (length(se_numcols) == 0) {
stop("data.frame input contained no numeric columns.")
}
if (length(rownames(se)) == 0) {
# use first non-numeric column
if (!any(se_sclass %in% c("character", "factor"))) {
rownames(se) <- paste0("row",
jamba::padInteger(seq_len(nrow(se))));
} else {
se_namecol <- head(names(
which(se_sclass %in% c("numeric", "integer"))), 1);
rownames(se) <- jamba::makeNames(se[[se_namecol]])
}
} else if (any(duplicated(rownames(se)))) {
rownames(se) <- jamba::makeNames(rownames(se),
renameFirst=FALSE)
}
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"Converting data.frame input to matrix.");
}
se <- as.matrix(se[, se_numcols, drop=FALSE]);
}
if (inherits(se, "matrix")) {
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"Converting matrix input to SummarizedExperiment.");
}
se <- SummarizedExperiment::SummarizedExperiment(
assays=list(data=se),
rowData=data.frame(rows=rownames(se),
row.names=rownames(se)),
colData=data.frame(rows=colnames(se),
row.names=colnames(se)))
if (length(assay_name) > 0) {
names(SummarizedExperiment::assays(se))[1] <- assay_name;
} else {
assay_name <- head(SummarizedExperiment::assayNames(se), 1);
}
}
# row_subcluster
if (length(row_subcluster) > 0) {
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"Preparing sub-cluster heatmap.");
}
hm_total <- heatmap_se(
se=se,
sestats=sestats,
hm_name=hm_name,
rows=rows,
row_type=row_type,
column_type=column_type,
data_type=data_type,
correlation=correlation,
assay_name=assay_name,
contrast_names=contrast_names,
contrast_suffix=contrast_suffix,
cutoff_name=cutoff_name,
alt_sestats=alt_sestats,
alt_assay_name=alt_assay_name,
alt_contrast_names=alt_contrast_names,
alt_contrast_suffix=alt_contrast_suffix,
alt_cutoff_name=alt_cutoff_name,
isamples=isamples,
normgroup_colname=normgroup_colname,
centerby_colnames=centerby_colnames,
controlSamples=controlSamples,
control_label=control_label,
top_colnames=top_colnames,
top_annotation=top_annotation,
top_annotation_name_gp=top_annotation_name_gp,
rowData_colnames=rowData_colnames,
left_annotation=left_annotation,
left_annotation_name_gp=left_annotation_name_gp,
left_annotation_name_rot=left_annotation_name_rot,
right_annotation=right_annotation,
simple_anno_size=simple_anno_size,
legend_title_gp=legend_title_gp,
legend_labels_gp=legend_labels_gp,
legend_grid_cex=legend_grid_cex,
row_split=row_split,
row_subcluster=NULL,
row_title_rot=row_title_rot,
sample_color_list=sample_color_list,
legend_at=legend_at,
legend_labels=legend_labels,
subset_legend_colors=subset_legend_colors,
row_cex=row_cex,
column_cex=column_cex,
row_anno_fontsize=row_anno_fontsize,
useMedian=useMedian,
show_row_names=show_row_names,
show_row_dend=show_row_dend,
mark_rows=mark_rows,
mark_labels_gp=mark_labels_gp,
show_heatmap_legend=show_heatmap_legend,
show_top_legend=show_top_legend,
show_left_legend=show_left_legend,
show_top_annotation_name=show_top_annotation_name,
show_left_annotation_name=show_left_annotation_name,
row_label_colname=row_label_colname,
cluster_columns=cluster_columns,
cluster_rows=cluster_rows,
column_split=column_split,
column_split_sep=column_split_sep,
color_max=color_max,
color_floor=color_floor,
lens=lens,
rename_contrasts=rename_contrasts,
rename_alt_contrasts=rename_alt_contrasts,
verbose=verbose,
debug=debug,
...)
row_order <- jamba::heatmap_row_order(hm_total);
if (length(names(row_order)) == 0) {
names(row_order) <- as.character(seq_along(row_order))
}
if (is.numeric(row_subcluster)) {
row_order_use <- row_order[seq_along(row_order) %in% row_subcluster];
} else {
row_order_use <- row_order[names(row_order) %in% as.character(row_subcluster)];
}
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"row_subcluster: ", row_subcluster);
jamba::printDebug("heatmap_se(): ",
"selected: '",
sep="', '",
names(row_order_use),
"'")
}
# set new argument values for the drill-down heatmap
rows <- unlist(unname(row_order_use));
cluster_rows <- FALSE;
row_split <- jamba::nameVector(rep(names(row_order_use),
lengths(row_order_use)),
rows);
# subset the se data?
se <- se[rows,];
if (debug) {
return(invisible(row_order));
}
}
# sestats - define rows to use
gene_hitlist <- NULL;
alt_gene_hitlist <- NULL;
gene_hits_im <- NULL;
gene_hits <- NULL;
alt_gene_hits_im <- NULL;
# rows as user-defined vector
rows <- intersect(rows, rownames(se));
if (length(sestats) > 0) {
# generate an appropriate incidence matrix
gene_hits_im <- process_sestats_to_hitim(sestats,
cutoff_names=cutoff_name,
contrast_names=contrast_names,
assay_names=assay_name,
contrast_suffix=contrast_suffix,
rename_contrasts=rename_contrasts,
rows=rows,
verbose=verbose,
...);
gene_hits <- rownames(gene_hits_im);
if (length(rows) == 0) {
rows <- gene_hits;
}
}
if (length(gene_hits) == 0) {
if (length(rows) == 0) {
rows <- rownames(se);
}
gene_hits <- rows;
} else if (length(rows) == 0) {
rows <- gene_hits
}
# confirm all rows exist in rownames(se)
if (!all(gene_hits %in% rownames(se))) {
gene_hits <- intersect(gene_hits, rownames(se));
rows <- gene_hits;
gene_hits_im <- gene_hits_im[gene_hits, , drop=FALSE];
}
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"nrows in heatmap: ",
jamba::formatInt(length(rows)));
}
# alt_sestats only for rows and gene_hits defined from sestats
if (length(sestats) > 0 && length(alt_sestats) > 0) {
# generate an appropriate incidence matrix
alt_gene_hits_im <- process_sestats_to_hitim(alt_sestats,
cutoff_names=alt_cutoff_name,
contrast_names=alt_contrast_names,
assay_names=alt_assay_name,
contrast_suffix=alt_contrast_suffix,
rename_contrasts=rename_contrasts,
rows=rows,
verbose=verbose,
...);
}
# validate sample_color_list
# remove NA
# convert color name to hex
if (length(sample_color_list) > 0) {
sample_color_list <- lapply(sample_color_list, function(i){
if (is.function(i)) {
i
} else {
i <- i[!is.na(i) & !is.na(names(i))];
i_is_hex <- grepl("^#", i);
if (any(!i_is_hex)) {
i[!i_is_hex] <- jamba::rgb2col(alpha=FALSE,
col2rgb(i[!i_is_hex]))
}
i;
}
})
}
# pull colData and rowData as data.frame
# to be tolerant of other data types
# Note: This process does not subset by `rows` or `isamples` yet
## Experimental: handle Seurat objects
if ("Seurat" %in% class(se)) {
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"Converted Seurat input to SingleCellExperiment");
}
se <- Seurat::as.SingleCellExperiment(se,
# assay=assay_name,
...);
}
# confirm rownames and colnames exist
if (length(rownames(se)) == 0) {
rownames(se) <- paste0("row",
jamba::padInteger(seq_len(nrow(se))));
}
if (length(colnames(se)) == 0) {
colnames(se) <- paste0("column",
jamba::padInteger(seq_len(ncol(se))));
}
# 0.0.69.900 - call se_to_rowcoldata() and remove logic from here
rowcolData_list <- se_to_rowcoldata(se,
verbose=verbose,
...);
rowData_se <- rowcolData_list$rowData_se;
colData_se <- rowcolData_list$colData_se;
# normgroup for column split
normgroup_colname <- intersect(normgroup_colname,
colnames(colData_se));
if (length(column_split) == 0) {
if (length(normgroup_colname) > 0 &&
nrow(unique(colData_se[isamples, normgroup_colname, drop=FALSE])) > 1) {
column_split <- jamba::pasteByRow(
colData_se[isamples, normgroup_colname, drop=FALSE],
sep=column_split_sep);
names(column_split) <- isamples;
} else {
column_split <- NULL;
}
} else {
if (any(c("factor", "character") %in% class(column_split))) {
if (!any(duplicated(column_split)) &&
all(column_split %in% colnames(colData_se))) {
column_split <- jamba::pasteByRowOrdered(
data.frame(check.names=FALSE,
colData_se[isamples, column_split, drop=FALSE]),
keepOrder=TRUE,
sep=column_split_sep);
names(column_split) <- isamples;
} else if (all(names(column_split) %in% isamples)) {
column_split <- column_split[isamples];
} else if (length(column_split) == length(isamples)) {
# leave as-is but add isamples as names
names(column_split) <- isamples;
} else {
column_split <- NULL;
}
} else if (length(column_split) == 1 && is.numeric(column_split)) {
# leave as-is
} else {
column_split <- NULL;
}
}
# column font size
column_fontsize <- jamba::noiseFloor(
column_cex * 60/(length(isamples))^(1/2),
ceiling=20,
minimum=2);
# row font size
if (correlation) {
row_fontsize <- jamba::noiseFloor(
row_cex * (60*(14 / 10))/(length(isamples))^(1/2),
minimum=1,
ceiling=20);
} else {
row_fontsize <- jamba::noiseFloor(
row_cex * (60*(14 / 10))/(length(gene_hits))^(1/2),
minimum=1,
ceiling=20);
}
# choose interesting top_annotation colnames when none are supplied
if (length(top_colnames) == 0) {
top_colnames <- choose_annotation_colnames(colData_se,
...);
if (length(top_colnames) > 0 && verbose) {
jamba::printDebug("heatmap_se(): ",
"derived top_colnames: ",
top_colnames);
}
}
top_colnames <- intersect(top_colnames,
colnames(colData_se));
if (length(top_annotation) == 0 &&
length(top_colnames) > 0 &&
!any(top_colnames %in% FALSE)) {
# subset color key by data shown in the heatmap
top_color_list <- NULL;
# subset any factor columns to limit colors shown in the legend
top_df <- data.frame(check.names=FALSE,
colData_se[isamples, top_colnames, drop=FALSE]);
for (top_colname in top_colnames) {
if (is.factor(top_df[[top_colname]])) {
top_df[[top_colname]] <- factor(top_df[[top_colname]]);
}
}
if (any(top_colnames %in% names(sample_color_list))) {
if (subset_legend_colors) {
top_color_list <- lapply(jamba::nameVector(top_colnames), function(top_colname){
sample_colors <- sample_color_list[[top_colname]];
if (!is.function(sample_colors)) {
if (is.factor(top_df[isamples, top_colname])) {
uniq_values <- levels(top_df[isamples, top_colname]);
} else {
uniq_values <- jamba::mixedSort(unique(
as.character(
top_df[isamples, top_colname])));
}
sample_colors <- sample_colors[uniq_values];
if (length(sample_colors) == 0) {
sample_colors <- rep(NA, length.out=length(uniq_values));
}
names(sample_colors) <- uniq_values;
if (any(is.na(sample_colors))) {
# fallback plan for missing values is to assign
# generic rainbow categorical colors
sample_colors[is.na(sample_colors)] <- colorjam::rainbowJam(
n=sum(is.na(sample_colors)),
...);
}
}
sample_colors;
})
} else {
top_color_list <- sample_color_list[intersect(top_colnames, names(sample_color_list))];
}
}
top_param_list <- c(
lapply(jamba::nameVector(top_colnames), function(iname){
if (iname %in% names(top_color_list)) {
if (is.function(top_color_list[[iname]])) {
if ("breaks" %in% names(attributes(top_color_list[[iname]]))) {
list(border=legend_border_color,
title_gp=legend_title_gp,
labels_gp=legend_labels_gp,
grid_height=grid::unit(4 * legend_grid_cex, "mm"),
grid_width=grid::unit(4 * legend_grid_cex, "mm"),
color_bar="discrete",
at=attr(top_color_list[[iname]], "breaks"))
} else {
list(border=legend_border_color,
title_gp=legend_title_gp,
labels_gp=legend_labels_gp,
grid_height=grid::unit(4 * legend_grid_cex, "mm"),
grid_width=grid::unit(4 * legend_grid_cex, "mm"),
color_bar="discrete")
}
} else {
if (subset_legend_colors) {
list(border=legend_border_color,
title_gp=legend_title_gp,
labels_gp=legend_labels_gp,
grid_height=grid::unit(4 * legend_grid_cex, "mm"),
grid_width=grid::unit(4 * legend_grid_cex, "mm"),
color_bar="discrete",
at=jamba::rmNA(names(top_color_list[[iname]])))
} else {
list(border=legend_border_color,
grid_height=grid::unit(4 * legend_grid_cex, "mm"),
grid_width=grid::unit(4 * legend_grid_cex, "mm"),
title_gp=legend_title_gp,
labels_gp=legend_labels_gp)
}
}
} else {
list(border=legend_border_color,
grid_height=grid::unit(4 * legend_grid_cex, "mm"),
grid_width=grid::unit(4 * legend_grid_cex, "mm"),
title_gp=legend_title_gp,
labels_gp=legend_labels_gp)
}
}));
top_annotation <- ComplexHeatmap::HeatmapAnnotation(
border=TRUE,
df=top_df,
annotation_name_gp=top_annotation_name_gp,
annotation_legend_param=top_param_list,
simple_anno_size=simple_anno_size,
show_legend=show_top_legend,
show_annotation_name=show_top_annotation_name,
col=top_color_list);
}
# left_annotation
if (length(left_annotation) == 0 && !correlation) {
row_anno_fontsize <- jamba::noiseFloor(
column_cex * row_anno_fontsize,
ceiling=24,
minimum=2);
left_anno_list <- list();
left_color_list <- list();
left_param_list <- list();
if (length(show_left_legend) == 0) {
show_left_legend <- TRUE;
}
if (length(show_left_legend) < 2) {
show_left_legend <- rep(show_left_legend,
length.out=2);
}
show_left_legend_v <- logical(0);
# sestats annotations
if (length(sestats) > 0) {
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"Preparing sestats incidence matrix left_annotation.");
}
show_left_legend_v <- show_left_legend[1];
show_left_legend <- tail(show_left_legend, -1);
left_anno_list <- c(list(
hits=gene_hits_im[gene_hits, , drop=FALSE]),
left_anno_list);
left_color_list <- c(list(
hits=colorjam::col_div_xf(1.5)),
left_color_list);
left_param_list <- c(list(
hits=list(
at=c(-1, 0, 1),
color_bar="discrete",
title_gp=legend_title_gp,
labels_gp=legend_labels_gp,
grid_height=grid::unit(4 * legend_grid_cex, "mm"),
grid_width=grid::unit(4 * legend_grid_cex, "mm"),
border=legend_border_color,
labels=c("down", "no change", "up"))),
left_param_list);
}
# alt_sestats annotations
if (length(alt_sestats) > 0) {
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"Preparing alt_sestats incidence matrix left_annotation.");
}
show_left_legend_v <- c(FALSE,
show_left_legend_v);
left_anno_list <- c(list(
hits_alt=alt_gene_hits_im[gene_hits, , drop=FALSE]),
left_anno_list);
left_color_list <- c(list(
hits_alt=colorjam::col_div_xf(1.5)),
left_color_list);
left_param_list <- c(list(
hits_alt=list(
at=c(-1, 0, 1),
color_bar="discrete",
title_gp=legend_title_gp,
labels_gp=legend_labels_gp,
grid_height=grid::unit(4 * legend_grid_cex, "mm"),
grid_width=grid::unit(4 * legend_grid_cex, "mm"),
border=legend_border_color,
labels=c("down", "no change", "up"))),
left_param_list);
}
# rowData annotations
if (length(rowData_colnames) > 0) {
rowData_colnames <- intersect(rowData_colnames,
colnames(rowData_se));
}
if (length(rowData_colnames) > 0) {
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"preparing left_annotation for rowData_colnames: ",
rowData_colnames);
}
show_left_legend_v <- c(show_left_legend_v,
rep(show_left_legend, length.out=length(rowData_colnames)))
# subset any factor columns to limit colors shown in the legend
left_df <- data.frame(check.names=FALSE,
rowData_se[gene_hits, rowData_colnames, drop=FALSE]);
for (rowData_colname in rowData_colnames) {
if (is.factor(left_df[[rowData_colname]])) {
left_df[[rowData_colname]] <- factor(left_df[[rowData_colname]]);
}
}
# put it together
left_anno_list <- c(list(
df=left_df),
left_anno_list);
use_color_list_names <- intersect(rowData_colnames,
names(sample_color_list));
leftanno_color_list <- NULL;
if (length(use_color_list_names) > 0) {
if (subset_legend_colors) {
leftanno_color_list <- lapply(jamba::nameVector(use_color_list_names), function(use_color_list_name){
sample_colors <- sample_color_list[[use_color_list_name]];
if (!is.function(sample_colors)) {
if (is.factor(left_df[gene_hits, use_color_list_name])) {
# for factors we honor the order of factor levels
uniq_values <- levels(left_df[gene_hits, use_color_list_name]);
} else {
# note we add mixedSort() so they are alphanumerical
uniq_values <- jamba::mixedSort(unique(
as.character(
left_df[gene_hits, use_color_list_name])));
}
sample_colors <- sample_colors[uniq_values];
names(sample_colors) <- uniq_values;
if (any(is.na(sample_colors))) {
# fallback plan for missing values is to assign
# generic rainbow categorical colors
sample_colors[is.na(sample_colors)] <- colorjam::rainbowJam(
n=sum(is.na(sample_colors)),
...);
}
}
sample_colors;
})
} else {
leftanno_color_list <- sample_color_list[use_color_list_names];
}
left_color_list <- c(
jamba::rmNULL(
leftanno_color_list),
left_color_list);
if (debug) {
jamba::printDebug("heatmap_se(): ",
"left_color_list:");
print(left_color_list[!jamba::sclass(left_color_list) %in% "function"]);
}
}
left_param_list <- c(
lapply(jamba::nameVector(rowData_colnames), function(iname){
if (iname %in% names(left_color_list)) {
if (is.function(left_color_list[[iname]])) {
if ("breaks" %in% names(attributes(left_color_list[[iname]]))) {
list(border=legend_border_color,
color_bar="discrete",
title_gp=legend_title_gp,
labels_gp=legend_labels_gp,
grid_height=grid::unit(4 * legend_grid_cex, "mm"),
grid_width=grid::unit(4 * legend_grid_cex, "mm"),
at=attr(left_color_list[[iname]], "breaks"))
} else {
list(border=legend_border_color,
title_gp=legend_title_gp,
labels_gp=legend_labels_gp,
grid_height=grid::unit(4 * legend_grid_cex, "mm"),
grid_width=grid::unit(4 * legend_grid_cex, "mm"),
color_bar="discrete")
}
} else {
if (subset_legend_colors) {
list(border=legend_border_color,
title_gp=legend_title_gp,
labels_gp=legend_labels_gp,
grid_height=grid::unit(4 * legend_grid_cex, "mm"),
grid_width=grid::unit(4 * legend_grid_cex, "mm"),
color_bar="discrete",
at=jamba::rmNA(names(left_color_list[[iname]])))
} else {
list(border=legend_border_color,
grid_height=grid::unit(4 * legend_grid_cex, "mm"),
grid_width=grid::unit(4 * legend_grid_cex, "mm"),
title_gp=legend_title_gp,
labels_gp=legend_labels_gp)
}
}
} else {
list(border=legend_border_color,
grid_height=grid::unit(4 * legend_grid_cex, "mm"),
grid_width=grid::unit(4 * legend_grid_cex, "mm"),
title_gp=legend_title_gp,
labels_gp=legend_labels_gp)
}
}),
left_param_list);
}
# put it all together
if (length(left_anno_list) > 0) {
if (length(left_annotation_name_gp) == 0) {
left_annotation_name_gp <- grid::gpar(fontsize=row_anno_fontsize);
}
left_alist <- alist(
simple_anno_size=simple_anno_size,
col=left_color_list,
gap=ComplexHeatmap::ht_opt("ROW_ANNO_PADDING"),
annotation_legend_param=left_param_list,
show_legend=show_left_legend_v,
show_annotation_name=show_left_annotation_name,
annotation_name_rot=left_annotation_name_rot,
annotation_name_gp=left_annotation_name_gp,
border=TRUE
);
if (debug > 1) {
jamba::printDebug("heatmap_se(): ",
"left_alist:");
print(jamba::sdim(left_alist));
print(left_alist);
jamba::printDebug("heatmap_se(): ",
"left_anno_list:");
print(jamba::sdim(left_anno_list));
print(left_anno_list);
}
left_arglist <- c(
left_alist,
left_anno_list);
left_annotation <- do.call(ComplexHeatmap::rowAnnotation,
left_arglist);
if (debug > 1) {
print(jamba::sdim(left_annotation@anno_list))
for (i in left_annotation@anno_list){
print(i@show_legend)
}
}
}
}
# optional row_split
if (length(row_split) > 0) {
if (TRUE %in% correlation) {
# correlation uses colData for split
if (any(c("factor", "character") %in% class(row_split))) {
if (!any(duplicated(row_split)) &&
all(row_split %in% colnames(colData_se))) {
row_split <- data.frame(check.names=FALSE,
colData_se[isamples, row_split, drop=FALSE]);
} else if (all(names(row_split) %in% isamples)) {
row_split <- row_split[isamples];
} else if (length(row_split) == length(isamples)) {
names(row_split) <- isamples;
} else {
row_split <- NULL;
}
} else if (length(row_split) == 1 && is.numeric(row_split)) {
# leave as-is
} else {
row_split <- NULL;
}
} else {
# non-correlation uses rowData for split
if (length(row_split) == 1 && is.numeric(row_split)) {
# leave as-is, this splits to the number of clusters requested
if (row_split > length(gene_hits)) {
row_split <- length(gene_hits);
}
} else {
# 0.0.61.900 - anything except single numeric value
# is handled here
# } else if (any(c("factor", "character") %in% class(row_split))) {
if (inherits(row_split, "data.frame")) {
# data.frame is acceptable input
# but rownames must represent every gene_hits value
row_split_match <- match(gene_hits, rownames(row_split));
if (all(is.na(row_split_match))) {
stop("rownames(row_split) does not match any heatmap rows.");
}
row_split <- row_split[row_split_match, , drop=FALSE];
rownames(row_split) <- row_split_match;
} else if (!any(duplicated(row_split)) &&
all(row_split %in% colnames(rowData_se))) {
# no duplicated values, and all values match colnames(rowData)
row_split_cols <- intersect(row_split, colnames(rowData_se))
row_split <- data.frame(check.names=FALSE,
rowData_se[gene_hits, row_split_cols, drop=FALSE]);
} else if (all(gene_hits %in% names(row_split))) {
# 0.0.61.900 - reverse order: gene_hits in names(row_split)
row_split <- data.frame(row_split=row_split[gene_hits]);
rownames(row_split) <- gene_hits;
} else {
row_split <- NULL;
}
}
}
} else if (TRUE %in% correlation) {
row_split <- column_split;
}
if (verbose && length(row_split) > 0) {
jamba::printDebug("heatmap_se(): ",
"row_split:", head(row_split, 20));
}
assay_name <- head(intersect(assay_name,
names(SummarizedExperiment::assays(se))), 1);
if (length(assay_name) == 0) {
if (length(SummarizedExperiment::assays(se)) == 1) {
assay_name <- head(names(SummarizedExperiment::assays(se)), 1);
if (length(assay_name) == 0) {
assay_name <- 1;
}
} else {
stop("assay_name must be supplied when there are multiple assays(se)")
}
}
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"using assay_name '", assay_name, "'");
}
norm_label <- paste0(assay_name, " ", data_type);
if (ncol(se) == 1 && !FALSE %in% centerby_colnames) {
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"Defining centerby_colnames=FALSE since there is only one column.");
}
centerby_colnames <- FALSE;
}
if (any(centerby_colnames %in% FALSE)) {
centerby_colnames <- NULL;
centerGroups <- FALSE;
centerby_label <- "";
} else {
centerby_colnames <- intersect(centerby_colnames,
colnames(colData_se));
if (length(centerby_colnames) > 0) {
centerby_label <- paste0("centered within ",
jamba::cPaste(centerby_colnames,
sep="/"));
centerGroups <- jamba::pasteByRow(
colData_se[,centerby_colnames]);
} else {
centerGroups <- NULL;
centerby_label <- "global-centered";
}
if (length(control_label) > 0 && any(nchar(control_label)) > 0) {
centerby_label <- paste0(centerby_label,
", ",
control_label);
}
}
# row_labels
if (correlation) {
# for correlation, samples are shown on rows
# so it must use colData_se
if (length(row_label_colname) == 0 ||
!all(row_label_colname %in% colnames(colData_se))) {
row_labels <- isamples;
} else if (length(row_label_colname) > 1) {
row_labels <- jamba::pasteByRow(
colData_se[isamples, row_label_colname, drop=FALSE],
sep=",");
} else {
row_labels <- colData_se[isamples, , drop=FALSE][[row_label_colname]];
}
} else {
# for expression data, rowData_se must be used
if (length(row_label_colname) == 0) {
row_labels <- gene_hits;
} else if (length(row_label_colname) > 1) {
row_labels <- jamba::pasteByRow(
rowData_se[gene_hits, row_label_colname, drop=FALSE],
sep=",");
} else {
row_labels <- rowData_se[gene_hits, , drop=FALSE][[row_label_colname]];
}
}
if (length(show_row_names) == 0) {
show_row_names <- (length(gene_hits) <= 500);
}
# pull assay data separately so we can tolerate other object types
# Note columns are not subset here so they can be used during centering.
# After centering, isamples is used to subset columns as needed.
if (any(grepl("SummarizedExperiment|SingleCellExperiment",
ignore.case=TRUE, class(se)))) {
se_matrix <- SummarizedExperiment::assays(se[gene_hits, ])[[assay_name]];
} else {
se_matrix <- Biobase::assayData(se[gene_hits, ])[[assay_name]];
}
# heatmap legend labels
# TODO: handle non-zero color_floor
if (length(legend_at) == 0) {
if (correlation) {
if (abs(color_max) > 1) {
color_max <- 1;
}
legend_at <- seq(-ceiling(color_max),
to=ceiling(color_max),
by=0.25);
if (length(legend_labels) == 0) {
legend_labels <- legend_at;
}
} else {
if (FALSE %in% centerby_colnames && min(se_matrix, na.rm=TRUE) >= 0) {
if (color_max <= 1) {
legend_pretty <- pretty(c(0, color_max), n=4)
legend_at <- unique(c(
legend_pretty[legend_pretty <= color_max],
color_max))
if (length(legend_labels) == 0) {
legend_labels <- legend_at;
}
} else {
legend_at <- seq(from=0,
to=ceiling(color_max));
}
} else {
if (color_max <= 1) {
legend_pretty <- pretty(c(-color_max, color_max), n=6)
legend_at <- unique(c(
-color_max,
legend_pretty[legend_pretty <= color_max & legend_pretty >= -color_max],
color_max))
if (length(legend_labels) == 0) {
legend_labels <- legend_at;
}
} else {
legend_at <- seq(-ceiling(color_max),
to=ceiling(color_max));
}
}
}
}
if (length(legend_labels) != length(legend_at)) {
if (correlation) {
legend_labels <- legend_at;
} else {
legend_labels <- round(jamba::exp2signed(legend_at+0.000001, offset=0))
if (any(duplicated(legend_labels))) {
legend_labels <- round(10 * jamba::exp2signed(legend_at+0.000001, offset=0)) / 10;
}
}
}
# cluster_columns
if (!is.function(cluster_columns) && cluster_columns %in% TRUE) {
cluster_columns <- function(x, ...) {
amap::hcluster(jamba::rmNA(naValue=0, x),
...,
method="euclidean",
link="ward")}
}
# define heatmap matrix
# After centering, columns are subset using isamples.
if (length(centerGroups) > 0 && any(centerGroups %in% FALSE)) {
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"Not centering data.");
}
se_matrix <- se_matrix[, isamples, drop=FALSE];
legend_title <- data_type;
if (length(hm_name) == 0) {
hm_name <- legend_title;
}
} else {
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"Centering data.");
}
se_matrix <- jamma::centerGeneData(
useMedian=useMedian,
centerGroups=centerGroups,
x=se_matrix,
controlSamples=controlSamples,
controlFloor=controlFloor,
naControlAction=naControlAction,
naControlFloor=naControlFloor,
...)[, isamples, drop=FALSE];
legend_title <- paste0("centered\n", data_type);
}
if (correlation) {
# call correlation function cor()
se_matrix <- jamba::call_fn_ellipsis(cor,
x=se_matrix,
use="pairwise.complete.obs",
...);
cluster_rows <- cluster_columns;
if (length(centerGroups) > 0 && any(centerGroups %in% FALSE)) {
legend_title <- paste0("correlation of\n", data_type);
} else {
legend_title <- paste0("correlation of\ncentered\n", data_type);
}
}
if (length(hm_name) == 0) {
hm_name <- legend_title;
}
# optional mark_rows
mark_rows <- intersect(mark_rows, gene_hits);
if (length(mark_rows) > 0) {
mark_at <- match(mark_rows, rownames(se_matrix));
right_annotation_mark <- ComplexHeatmap::rowAnnotation(
foo=ComplexHeatmap::anno_mark(
at=mark_at,
labels=row_labels[mark_at],
labels_gp=mark_labels_gp))
if (length(right_annotation) == 0) {
right_annotation <- right_annotation_mark;
} else {
right_annotation <- right_annotation + right_annotation_mark;
}
}
# pre-calculate row clusters
# This step is required to enable row_split as integer number of clusters,
# which is not accepted when supplying a function.
# This step does not work with character or data.frame row_split
if (length(row_split) == 1 &&
is.numeric(row_split)) {
if (is.function(cluster_rows)) {
if (verbose) {
jamba::printDebug("heatmap_se(): ",
paste0("row_split requires for cluster_rows()",
" to be applied to generate a dendrogram."));
}
cluster_rows <- cluster_rows(se_matrix);
} else if (FALSE %in% cluster_rows || length(cluster_rows) == 0) {
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"row_split ignored because cluster_rows=FALSE.");
}
row_split <- NULL;
}
}
if (length(column_split) == 1 &&
is.numeric(column_split)) {
# is.function(cluster_columns)) {
# cluster_columns <- cluster_columns(se_matrix);
if (is.function(cluster_columns)) {
if (verbose) {
jamba::printDebug("heatmap_se(): ",
paste0("column_split requires for cluster_columns()",
" to be applied to generate a dendrogram."));
}
cluster_columns <- cluster_columns(se_matrix);
} else if (FALSE %in% cluster_columns || length(cluster_columns) == 0) {
if (verbose) {
jamba::printDebug("heatmap_se(): ",
"column_split ignored because cluster_columns=FALSE.");
}
column_split <- NULL;
}
}
# optional customization of row and column names gp
if (length(row_names_gp) == 0) {
row_names_gp <- grid::gpar(fontsize=row_fontsize)
} else {
# if fontsize is not defined we add it here,
# otherwise use row_names_gp as supplied
if (!"fontsize" %in% names(row_names_gp)) {
row_names_gp <- do.call(grid::gpar,
c(row_names_gp,
alist(fontsize=row_fontsize)))
}
}
if (length(column_names_gp) == 0) {
column_names_gp <- grid::gpar(fontsize=column_fontsize)
} else {
# if fontsize is not defined we add it here,
# otherwise use column_names_gp as supplied
if (!"fontsize" %in% names(column_names_gp)) {
column_names_gp <- do.call(grid::gpar,
c(column_names_gp,
alist(fontsize=column_fontsize)))
}
}
# define heatmap title using relevant arguments
row_label <- NULL;
if (length(row_type) > 0 && nchar(head(row_type, 1)) > 0) {
row_label <- paste0(
jamba::formatInt(length(gene_hits)),
" ",
head(row_type, 1))
}
column_label <- NULL;
if (length(column_type) > 0 && nchar(head(column_type, 1)) > 0) {
column_label <- paste0(
jamba::formatInt(ncol(se_matrix)),
" ",
head(column_type, 1))
}
dim_label <- paste(c(row_label, column_label), collapse=", ")
if (any(nchar(dim_label) > 0)) {
dim_label <- paste0(dim_label, "\n")
}
if (length(hm_title) == 0) {
hm_title <- paste0(
dim_label,
norm_label,
ifelse(any(nchar(centerby_label) > 0),
paste0(",\n", centerby_label),
""))
}
# optionally add whitespace buffer after the title
if (length(hm_title_buffer) == 1 && hm_title_buffer > 0) {
hm_title_buffer <- ceiling(hm_title_buffer);
hm_title <- paste0(hm_title,
paste0(rep("\n", hm_title_buffer),
collapse=""))
}
# optionally apply heatmap title to column_title
if (TRUE %in% apply_hm_column_title) {
column_title <- hm_title;
hm_title <- "";
}
# define heatmap
if (verbose && length(row_split) > 0) {
jamba::printDebug("heatmap_se(): ",
"row_split (pre-heatmap):");print(head(row_split, 20));
}
hm_hits <- jamba::call_fn_ellipsis(ComplexHeatmap::Heatmap,
matrix=se_matrix,
use_raster=use_raster,
top_annotation=top_annotation,
left_annotation=left_annotation,
right_annotation=right_annotation,
heatmap_legend_param=list(
border=legend_border_color,
color_bar="discrete",
at=legend_at,
labels=legend_labels,
grid_height=grid::unit(4 * legend_grid_cex, "mm"),
grid_width=grid::unit(4 * legend_grid_cex, "mm"),
title=legend_title,
title_gp=legend_title_gp,
labels_gp=legend_labels_gp
),
clustering_method_rows="ward.D",
column_split=column_split,
column_title=column_title,
row_split=row_split,
row_title_rot=row_title_rot,
cluster_column_slices=cluster_column_slices,
cluster_row_slices=cluster_row_slices,
border=TRUE,
name=hm_name,
show_row_names=show_row_names,
show_row_dend=show_row_dend,
show_heatmap_legend=show_heatmap_legend,
row_labels=row_labels,
row_names_gp=row_names_gp,
column_names_gp=column_names_gp,
col=colorjam::col_div_xf(color_max,
lens=lens,
floor=color_floor,
...),
cluster_columns=cluster_columns,
cluster_rows=cluster_rows,
...)
# optionally apply heatmap title to column_title
attr(hm_hits, "hm_title") <- hm_title;
if (length(column_title) > 0) {
attr(hm_hits, "column_title") <- column_title;
}
if (debug) {
ret_list <- list(
hm=hm_hits,
top_annotation=top_annotation,
left_annotation=left_annotation,
hm_title=hm_title
);
ret_list$gene_hits_im <- gene_hits_im;
ret_list$alt_gene_hits_im <- alt_gene_hits_im;
ret_list$gene_hitlist <- gene_hitlist;
ret_list$alt_gene_hitlist <- alt_gene_hitlist;
return(ret_list)
}
hm_hits
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.