R/gvmap.R
In jinyancool/gvmap: An Improved Function to Plot Heatmap of Genomic Data
#'
#' gvmap package
#'
#' @param legend_data data frame. The basic legend data of the plot. It will contain all the
#' sample information. Attention: the row name of the legend data must be the sample name, or
#' this funciton will NOT run.
#' @param heatmap_data list, the heatmap data of the sample. The list name of heatmap data must
#' like this form: heatmap_1, heatmap_2 ... And each heatmap subset must be a martrix, with sample
#' name being the col name and gene set being the row name.
#' @param config_file character, the path of your config file. see \link[gvmap]{gvmap-config}
#' @param output_svg_name character, the output svg file name
#' @param convert_pdf bool, whether to convert svg file into pdf. Attention: If your svg file is
#' over 10M, it's better not convert it into pdf. This bug is still being repaired.
#' @param output_group_info bool, output group information of each heatmap and legend
#' @param convert_jpg bool, whether to convert svg file into png.
#' @param plot_width number, the canvas width of your figure. Default: 1200
#' @param plot_height number, the canvas height of your figure. Default: 1600
#' @param stroke_width number, the stroke width of your legend figure. Default: 1
#' @param dend_stroke_width number, the dendrogram stroke width. Default: 2
#' @param group_span number, the distance between two groups, such as heatmap_1 and legend_1. Default: 10
#' @param sample_span number, the distance between sample. Default: 0
#' @param heatmap_row_span number, the distance between two specific colnames on heatmap. Default: 0
#' @param frame bool, if TRUE, the legend data has black outline. Otherwise there is no outline. Default: TRUE
#' @param frame_stroke_width number, the stroke width of the legend frame
#' @param sample_font_size number, the sample font size
#' @param legend_font_size number, the legend font size
#' @param font_family character, the font family of the plot. Default: "Arial"
#'
#' @seealso
#' \link{heatmap}, \link[gplots]{heatmap.2}
#'
#' @export
#'
#' @examples
#' browseVignettes("gvmap")
#'
gvmap <- function(legend_data,
heatmap_data,
config_file,
# output svg name
output_svg_name,
convert_pdf = FALSE,
convert_jpg = FALSE,
# output group info
output_group_info = FALSE,
# plot for canvas data
plot_width = 1200,
plot_height = 1600,
stroke_width = 1,
dend_stroke_width = 2,
group_span = 10,
sample_span = 0,
heatmap_row_span = 0,
frame = TRUE,
frame_stroke_width = 2,
sample_font_size = NULL,
legend_font_size = NULL,
font_family = "Arial") {
## =======================
## Input data
## =======================
# read config file and generate config parmeters
if (missing(config_file)) {
stop("[ERROR] Config file is required!")
}
config_data <- gvmapConfig(config_file)
message("[INFO] Read config data completed")
# read legend data
if (missing(legend_data)) {
message("[WARNING] Legend data is missing")
if (config_data$map_config$legend_num > 0) {
message("[WARNING] The legend_num (legend number) in config file is over zero, please check your data!")
}
legend_data_plot <- FALSE
} else {
if (config_data$map_config$legend_num == 0) {
message("[INFO] The legend_num (legend number) in config file is zero, the legend will not plot.")
legend_data_plot <- FALSE
} else {
legend_data_plot <- TRUE
}
legend_data <- readLegendFile(legend_data)
}
message("[INFO] Read legend data completed")
# read heatmap data
if (missing(heatmap_data)) {
message("[WARNING] heatmap data is missing.")
if (config_data$map_config$heatmap_num > 0) {
message("[WARNING] The heatmap_num (heatmap number) in config file is over zero, please check your data!")
}
heatmap_data_plot <- FALSE
} else {
if (config_data$map_config$heatmap_num == 0) {
message("[INFO] The heatmap_num (heatmap number) in config file is zero, the heatmap will not plot.")
heatmap_data_plot <- FALSE
} else {
heatmap_data_plot <- TRUE
}
heatmap_data <- readHeatmapFile(heatmap_data)
}
message("[INFO] Read heatmap data completed")
if (!heatmap_data_plot & !legend_data_plot) {
stop("[ERROR] None heatmap or legend, please check your data!")
}
if (missing(output_svg_name)) {
stop("[ERROR] The output svg name is required!")
}
## =======================
## Generating plot parameter
## =======================
plot_config <- list(
plot_width = plot_width,
plot_height = plot_height*0.9,
plot_out_height = plot_height,
stroke_width = stroke_width,
dend_stroke_width = dend_stroke_width,
group_span = group_span,
sample_span = sample_span,
heatmap_row_span = heatmap_row_span,
frame = frame,
frame_stroke_width = frame_stroke_width,
sample_font_size = sample_font_size,
legend_font_size = legend_font_size,
font_family = font_family
)
if (heatmap_data_plot) {
sample_num <- dim(heatmap_data[[1]])[2]
sample <- colnames(heatmap_data[[1]])
} else {
sample_num <- dim(legend_data)[1]
sample <- rownames(legend_data)
}
plot_config <- c(plot_config, sample_num = sample_num,
list(sample = sample),
list(sample_order = sample))
# heatamap plot parameter
if (heatmap_data_plot) {
for (i in 1:config_data$map_config$heatmap_num) {
plot_config <- getHeatmapParam(heatmap_data, config_data, plot_config, i)
}
}
if (legend_data_plot) {
plot_config <- getLegendParam(legend_data, config_data, plot_config)
}
message("[INFO] Generating plot paramters completed")
## =======================
## Data processsing
## =======================
# heatmap_1 is the leading controller of all plots
if (heatmap_data_plot) {
Rowv <- config_data$map_config$heatmap_1$Rowv
if (isTRUE(Rowv)) {
Rowv <- rowMeans(heatmap_data[[1]], na.rm = config_data$map_config$heatmap_1$na.rm)
}
if (is.numeric(Rowv)) {
Rowv <- reorderfun(as.dendrogram(
config_data$map_config$heatmap_1$hclustfun( config_data$map_config$heatmap_1$distfun(heatmap_data[[1]]) )
), Rowv)
}
if (is.dendrogram(Rowv)) {
Rowv <- rev(Rowv)
rowInd <- order.dendrogram(Rowv)
if(plot_config$heatmap_1$nr != length(rowInd))
stop("[ERROR] Row dendrogram in heatmap_1 is the wrong size")
} else {
if (!is.null(Rowv) && !is.na(Rowv) && !identical(Rowv, FALSE)) {
warning("[WARNING] Invalid value for Rowv in heatmap_1, ignoring")
}
Rowv <- NULL
rowInd <- 1:plot_config$heatmap_1$nr
}
Colv <- config_data$map_config$heatmap_1$Colv
if (isTRUE(Colv)) {
Colv <- colMeans(heatmap_data[[1]], na.rm = config_data$map_config$heatmap_1$na.rm)
}
if (is.numeric(Colv)) {
Colv <- reorderfun(as.dendrogram(config_data$map_config$heatmap_1$hclustfun(
config_data$map_config$heatmap_1$distfun(t(heatmap_data[[1]])))
), Colv)
}
if (is.dendrogram(Colv)) {
sampleInd <- order.dendrogram(Colv)
if (plot_config$heatmap_1$nc != length(sampleInd))
stop("[ERROR] Col dendrogram is the wrong size in heatmap_1")
} else {
if (!is.null(Colv) && !is.na(Colv) && !identical(Colv, FALSE)) {
warning("[WARNING] Invalid value for Colv in heatmap_1, ignoring")
}
Colv <- FALSE
sampleInd <- 1:plot_config$heatmap_1$nc
}
if(is.dendrogram(Rowv) & (config_data$map_config$heatmap_1$kmer_row > 1)) {
color_theme <- config_data$map_config$heatmap_1$kmer_row_color
if (!is.null(color_theme)) {
col_idx <- which(names(config_data$color_config) == color_theme)
color_theme <- config_data$color_config[[col_idx]]
#color_theme <- color_theme[1:config_data$map_config$heatmap_1$kmer_row]
} else {
color_theme <- config_data$color_config$black_col
}
Rowv <- dendextend::color_branches(Rowv,
k = config_data$map_config$heatmap_1$kmer_row,
col = color_theme,
groupLabels=TRUE)
}
if(is.dendrogram(Colv) & config_data$map_config$heatmap_1$kmer_col > 1) {
color_theme <- config_data$map_config$heatmap_1$kmer_col_color
if (!is.null(color_theme)) {
col_idx <- which(names(config_data$color_config) == color_theme)
color_theme <- config_data$color_config[[col_idx]]
#color_theme <- color_theme[1:config_data$map_config$heatmap_1$kmer_col]
} else {
color_theme <- config_data$color_config$black_col
}
Colv <- dendextend::color_branches(Colv,
k = config_data$map_config$heatmap_1$kmer_col,
col = color_theme,
groupLabels=TRUE)
}
config_data$map_config$heatmap_1$Rowv = Rowv
config_data$map_config$heatmap_1$rowInd = rowInd
config_data$map_config$heatmap_1$Colv = Colv
config_data$map_config$sampleInd = sampleInd
# reorder heatmap_1
heatmap_sub_data <- heatmap_data[[1]]
if (!config_data$map_config$heatmap_1$raw_data) {
heatmap_sub_data <- heatmapRowZdata(heatmap_sub_data)
}
# reorder heatmap mat
heatmap_sub_data <- heatmap_sub_data[rowInd, sampleInd]
heatmap_data[[1]] <- heatmap_sub_data
plot_config$sample_order <- plot_config$sample[sampleInd]
# reorder other heatmap data
if (config_data$map_config$heatmap_num > 1) {
for (i in 2:config_data$map_config$heatmap_num) {
heatmap_sub_name <- paste0("heatmap_", i)
heatmap_sub_info <- config_data$map_config[[which(names(config_data$map_config) == heatmap_sub_name)]]
heatmap_sub_data <- heatmap_data[[which(names(heatmap_data) == heatmap_sub_name)]]
heatmap_sub_plot <- plot_config[[which(names(plot_config) == heatmap_sub_name)]]
col_idx <- match(plot_config$sample_order, colnames(heatmap_sub_data))
if (anyNA(col_idx)) {
message("[WARNING] The sample value of ", heatmap_sub_name," data doesd't match heatmap_1")
}
heatmap_sub_data <- heatmap_sub_data[, col_idx]
colnames(heatmap_sub_data) <- plot_config$sample_order
Rowv <- heatmap_sub_info$Rowv
if (isTRUE(Rowv)) {
Rowv <- rowMeans(heatmap_sub_data, na.rm = heatmap_sub_info$na.rm)
}
if (is.numeric(Rowv)) {
Rowv <- reorderfun(as.dendrogram(
heatmap_sub_info$hclustfun( heatmap_sub_info$distfun(heatmap_sub_data) )
), Rowv)
}
if (is.dendrogram(Rowv)) {
Rowv <- rev(Rowv)
rowInd <- order.dendrogram(Rowv)
if(heatmap_sub_plot$nr != length(rowInd))
stop("[ERROR] Row dendrogram in ", heatmap_sub_name , " is the wrong size")
} else {
if (!is.null(Rowv) && !is.na(Rowv) && !identical(Rowv, FALSE)) {
warning("[WARNING] Invalid value for Rowv in ", heatmap_sub_name , ", ignoring")
}
Rowv <- FALSE
rowInd <- 1:heatmap_sub_plot$nr
}
if (!heatmap_sub_info$raw_data) {
heatmap_sub_data <- heatmapRowZdata(heatmap_sub_data)
}
if(is.dendrogram(Rowv) & (heatmap_sub_info$kmer_row > 1)) {
color_theme <- heatmap_sub_info$kmer_row_color
if (is.null(color_theme)) {
col_idx <- which(names(config_data$color_config) == color_theme)
color_theme <- config_data$color_config[[col_idx]]
# color_theme <- color_theme[1:heatmap_sub_info$kmer_row]
} else {
color_theme <- config_data$color_config$black_col
}
Rowv <- dendextend::color_branches(Rowv,
k = heatmap_sub_info$kmer_row,
col = color_theme,
groupLabels=TRUE)
}
# reorder heatmap mat
heatmap_sub_data <- heatmap_sub_data[rowInd, ]
heatmap_data[[which(names(heatmap_data) == heatmap_sub_name)]] <- heatmap_sub_data
config_data$map_config[[which(names(config_data$map_config) == heatmap_sub_name)]]$Rowv <- Rowv
config_data$map_config[[which(names(config_data$map_config) == heatmap_sub_name)]]$rowInd <- rowInd
config_data$map_config[[which(names(config_data$map_config) == heatmap_sub_name)]]$Colv <- FALSE
}
}
}
message("[INFO] Preprocessing heatmap data")
if (legend_data_plot) {
leg_sample <- rownames(legend_data)
leg_idx <- match(plot_config$sample_order, leg_sample)
if (anyNA(leg_idx)) {
message("[WARNING] The rownames value of legend data doesd't match heatmap")
}
legend_data <- legend_data[leg_idx, ]
rownames(legend_data) <- plot_config$sample_order
}
message("[INFO] Preprocessing legend data")
# calculate SVG location
plot_config <- checkPlotConfig(plot_config, config_data)
group_info <- list()
# transform position of dend
if (heatmap_data_plot) {
for (i in 1:config_data$map_config$heatmap_num) {
heatmap_sub_name <- paste0("heatmap_", i)
heatmap_sub_info <- config_data$map_config[[which(names(config_data$map_config) == heatmap_sub_name)]]
heatmap_sub_data <- heatmap_data[[which(names(heatmap_data) == heatmap_sub_name)]]
heatmap_sub_plot <- plot_config[[which(names(plot_config) == heatmap_sub_name)]]
col_attr <- dendAttribute(dend = heatmap_sub_info$Colv)
row_attr <- dendAttribute(dend = heatmap_sub_info$Rowv)
col_attr <- dendGap(dend_attr = col_attr, gap = plot_config$sample_span,
w = (heatmap_sub_plot$col_dend_w - heatmap_sub_plot$rect_w), h = heatmap_sub_plot$col_dend_h,
name = config_data$map_config$split_sample)
row_attr <- dendGap(dend_attr = row_attr, gap = plot_config$heatmap_row_span,
w = (heatmap_sub_plot$row_dend_w - heatmap_sub_plot$rect_h), h = heatmap_sub_plot$row_dend_h,
name = heatmap_sub_info$split_row_name)
config_data$map_config[[which(names(config_data$map_config) == heatmap_sub_name)]] <- c(
config_data$map_config[[which(names(config_data$map_config) == heatmap_sub_name)]],
list(col_attr = col_attr, row_attr = row_attr)
)
if (i == 1) {
config_data$map_config$heatmap_kmer_gap = col_attr
}
# add group kmer tag
group_sub_row <- data.frame(row_name = row_attr$node_label,
gap = row_attr$node_group,
tag = "g0")
iii <- 0
gtag <- rep("g0", length(group_sub_row[, 1]))
for (ii in 1:length(group_sub_row[, 1])) {
if (isTRUE(group_sub_row$gap[ii])) {
iii <- iii + 1
gtag[ii] <- paste0("g", iii)
} else {
gtag[ii] <- paste0("g", iii)
}
}
group_sub_row$tag <- gtag
group_sub_row <- group_sub_row[!is.na(group_sub_row$row_name), ]
group_sub_row <- list(group_sub_row)
names(group_sub_row) <- heatmap_sub_name
group_info <- c(group_info, group_sub_row)
}
} else {
config_data$map_config$heatmap_kmer_gap = NULL
}
if (is.null(config_data$map_config$heatmap_kmer_gap) | length(config_data$map_config$heatmap_kmer_gap$node_x) <= 1) {
gap = rep(0, length(plot_config$sample_order))
for (i in 2:(length(plot_config$sample_order))) {
if (plot_config$sample_order[i] %in% config_data$map_config$split_sample) {
gap[i] = gap[i-1] + plot_config$sample_span
} else {
gap[i] = gap[i-1] + 0
}
}
config_data$map_config$legend_kmer_gap = gap
}
## =======================
## Generating SVG element
## =======================
message("[INFO] Start to generating SVG element")
def_content <- ""
if (heatmap_data_plot) {
for (i in 1:config_data$map_config$heatmap_num) {
heatmap_sub_name <- paste0("heatmap_", i)
heatmap_sub_info <- config_data$map_config[[which(names(config_data$map_config) == heatmap_sub_name)]]
heatmap_sub_data <- heatmap_data[[which(names(heatmap_data) == heatmap_sub_name)]]
heatmap_sub_plot <- plot_config[[which(names(plot_config) == heatmap_sub_name)]]
if (is.dendrogram(heatmap_sub_info$Colv)) {
col_dend_svg <- dendSVG(dend_attr = heatmap_sub_info$col_attr, id = paste0(heatmap_sub_name, "_dend_col"),
plot_config = plot_config)
} else {
col_dend_svg <- group.svg(id = paste0(heatmap_sub_name, "_dend_col"), group.content = "")
}
if (is.dendrogram(heatmap_sub_info$Rowv)) {
row_dend_svg <- dendSVG(dend_attr = heatmap_sub_info$row_attr, id = paste0(heatmap_sub_name, "_dend_row"),
plot_config = plot_config)
} else {
row_dend_svg <- group.svg(id = paste0(heatmap_sub_name, "_dend_row"), group.content = "")
}
exp_mat_svg <- heatmapSVG(heatmap_sub_data = heatmap_sub_data,
heatmap_sub_info = heatmap_sub_info,
heatmap_sub_plot = heatmap_sub_plot,
config_data = config_data,
id = paste0(heatmap_sub_name, "_exp_mat"))
grad_svg <- heatmapGradSVG(heatmap_sub_data = heatmap_sub_data,
heatmap_sub_info = heatmap_sub_info,
heatmap_sub_plot = heatmap_sub_plot,
config_data = config_data,
id = paste0(heatmap_sub_name, "_grad"))
def_content = paste(def_content, col_dend_svg, row_dend_svg, exp_mat_svg, grad_svg, sep = '\n')
}
}
if (legend_data_plot) {
for (i in 1:config_data$map_config$legend_num) {
legend_sub_name <- paste0("legend_", i)
legend_sub_info <- config_data$map_config[[which(names(config_data$map_config) == legend_sub_name)]]
legend_sub_plot <- plot_config[[which(names(plot_config) == "legend")]]
legend_group_svg <- legendGroupSVG(config_data = config_data,
plot_config = plot_config,
legend_data = legend_data,
legend_sub_info = legend_sub_info,
legend_sub_plot = legend_sub_plot,
gap_info = config_data$map_config$heatmap_kmer_gap,
id = legend_sub_name)
legend_group_svg <- paste(legend_group_svg, collapse = "\n")
def_content <- paste(def_content, legend_group_svg, sep = "\n")
}
}
# add sample information
if (!is.null(config_data$map_config$heatmap_kmer_gap)) {
if (length(config_data$map_config$heatmap_kmer_gap$node_label) > 1) {
group_sub_col <- data.frame(col_name = config_data$map_config$heatmap_kmer_gap$node_label,
gap = config_data$map_config$heatmap_kmer_gap$node_group,
tag = "g0")
} else {
group_sub_col <- data.frame(col_name = plot_config$sample_order,
gap = FALSE,
tag = "g0")
}
iii <- 0
gtag <- rep("g0", length(group_sub_col[, 1]))
for (ii in 1:length(group_sub_col[, 1])) {
if (group_sub_col$gap[ii]) {
iii <- iii + 1
gtag[ii] <- paste0("g", iii)
} else {
gtag[ii] <- paste0("g", iii)
}
}
group_sub_col$tag <- gtag
group_sub_col <- group_sub_col[!is.na(group_sub_col$col_name), ]
group_sub_col <- list(group_sub_col)
names(group_sub_col) <- "sample_list"
group_info <- c(group_info, group_sub_col)
}
# add sample svg
sample_svg <- sampleSVG(plot_config = plot_config,
config_data = config_data,
gap_info = config_data$map_config$heatmap_kmer_gap,
id = "sample_list")
def_content <- paste(def_content, sample_svg, sep = "\n")
def_content <- defs.svg(defs.content = def_content)
## =======================
## Generating SVG Location
## =======================
message("[INFO] Start to generating SVG element location")
use_content <- ""
kk <- 0
for (i in 1:length(config_data$map_config$map_order)) {
order_name <- config_data$map_config$map_order[i]
if (grepl("^heatmap_", order_name)) {
heatmap_sub_info <- config_data$map_config[[which(names(config_data$map_config) == order_name)]]
heatmap_sub_plot <- plot_config[[which(names(plot_config) == heatmap_sub_name)]]
if (order_name == "heatmap_1") {
if (heatmap_sub_info$dendrogram == "both" | heatmap_sub_info$dendrogram == "col") {
col_dend_use <- use.svg(id = paste0(order_name, "_dend_col"),
x = heatmap_sub_plot$w*0.2 + 0.5*heatmap_sub_plot$rect_w,
y = 0)
use_content <- paste(use_content, col_dend_use, sep = "\n")
}
}
if (heatmap_sub_info$dendrogram == "both" | heatmap_sub_info$dendrogram == "row") {
row_dend_use <- use.svg(id = paste0(order_name, "_dend_row"),
x = 0 , y = 0, scale = c(-1, 1),
translate = c(plot_config$group_baseline[i] + heatmap_sub_plot$rect_h*0.5, 0),
rotate = c(90, 0, 0))
use_content <- paste(use_content, row_dend_use, sep = "\n")
}
exp_mat_use <- use.svg(id = paste0(order_name, "_exp_mat"),
x = heatmap_sub_plot$w * 0.2,
y = plot_config$group_baseline[i])
grad_use <- use.svg(id = paste0(order_name, "_grad"),
x = 0,
y = abs(plot_config$group_baseline[i] - heatmap_sub_plot$rect_h*5))
use_content <- paste(use_content, exp_mat_use, grad_use, sep = "\n")
}
if (grepl("^legend_", order_name)) {
legend_sub_plot <- plot_config[[which(names(plot_config) == "legend")]]
legend_sub_info <- config_data$map_config[[which(names(config_data$map_config) == order_name)]]
legend_mat_use <- use.svg(id = paste0(order_name, "_mat"),
x = plot_config$plot_width * 0.2,
y = plot_config$group_baseline[i])
legend_out_use <- use.svg(id = paste0(order_name, "_outline"),
x = plot_config$plot_width * 0.2,
y = plot_config$group_baseline[i])
legend_app_use <- use.svg(id = paste0(order_name, "_leg_text"),
x = plot_config$plot_width * 0.02,
y = plot_config$group_baseline[length(plot_config$group_baseline)] + kk + plot_config$sample_font_size*10)
legend_control <- max(8, legend_sub_plot$row_fz)
legend_control <- min(14, legend_control)
kk <- kk + (legend_control+4) * length(legend_sub_info)
use_content <- paste(use_content, legend_mat_use, legend_out_use, legend_app_use, sep = "\n")
}
}
# use sample svg
sample_use <- use.svg(id = "sample_list",
x = plot_config$plot_width * 0.2,
y = plot_config$group_baseline[length(plot_config$group_baseline)])
use_content <- paste(use_content, sample_use, sep = "\n")
use_content <- group.svg(group.content = use_content, transform.sheet = "translate(20,20)", id = "use",
font.family = plot_config$font_family)
## =======================
## Output the result
## =======================
message("[INFO] Output SVG")
pack_content <- paste(def_content, use_content, sep = "\n")
pack.svg(pack.content = pack_content, output.svg.name = output_svg_name,
width = plot_config$plot_width, height = plot_config$plot_out_height)
output_svg_name <- normalizePath(output_svg_name)
if (output_group_info & length(group_info) > 0) {
output_group_info_name <- gsub(".svg$", ".group.info.xlsx", output_svg_name)
write.xlsx(group_info, output_group_info_name, colWidths = c(NA, "auto", "auto"))
}
# convert
if (convert_pdf) {
if (file.size(output_svg_name) > 10000000) {
cmd = sprintf("inkscape --without-gui --export-pdf=\"%s\" %s &", gsub(".svg$", ".pdf", output_svg_name), output_svg_name)
system(cmd)
} else {
rsvg_pdf(svg = output_svg_name, file = gsub(".svg$", ".pdf", output_svg_name))
}
}
if (convert_jpg) {
cmd <- sprintf("convert -density 300 %s %s", output_svg_name, gsub(".svg$", ".jpg", output_svg_name))
system(cmd)
}
}
jinyancool/gvmap documentation built on June 14, 2019, 12:04 a.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.
#'
#' gvmap package
#'
#' @param legend_data data frame. The basic legend data of the plot. It will contain all the
#' sample information. Attention: the row name of the legend data must be the sample name, or
#' this funciton will NOT run.
#' @param heatmap_data list, the heatmap data of the sample. The list name of heatmap data must
#' like this form: heatmap_1, heatmap_2 ... And each heatmap subset must be a martrix, with sample
#' name being the col name and gene set being the row name.
#' @param config_file character, the path of your config file. see \link[gvmap]{gvmap-config}
#' @param output_svg_name character, the output svg file name
#' @param convert_pdf bool, whether to convert svg file into pdf. Attention: If your svg file is
#' over 10M, it's better not convert it into pdf. This bug is still being repaired.
#' @param output_group_info bool, output group information of each heatmap and legend
#' @param convert_jpg bool, whether to convert svg file into png.
#' @param plot_width number, the canvas width of your figure. Default: 1200
#' @param plot_height number, the canvas height of your figure. Default: 1600
#' @param stroke_width number, the stroke width of your legend figure. Default: 1
#' @param dend_stroke_width number, the dendrogram stroke width. Default: 2
#' @param group_span number, the distance between two groups, such as heatmap_1 and legend_1. Default: 10
#' @param sample_span number, the distance between sample. Default: 0
#' @param heatmap_row_span number, the distance between two specific colnames on heatmap. Default: 0
#' @param frame bool, if TRUE, the legend data has black outline. Otherwise there is no outline. Default: TRUE
#' @param frame_stroke_width number, the stroke width of the legend frame
#' @param sample_font_size number, the sample font size
#' @param legend_font_size number, the legend font size
#' @param font_family character, the font family of the plot. Default: "Arial"
#'
#' @seealso
#' \link{heatmap}, \link[gplots]{heatmap.2}
#'
#' @export
#'
#' @examples
#' browseVignettes("gvmap")
#'
gvmap <- function(legend_data,
heatmap_data,
config_file,
# output svg name
output_svg_name,
convert_pdf = FALSE,
convert_jpg = FALSE,
# output group info
output_group_info = FALSE,
# plot for canvas data
plot_width = 1200,
plot_height = 1600,
stroke_width = 1,
dend_stroke_width = 2,
group_span = 10,
sample_span = 0,
heatmap_row_span = 0,
frame = TRUE,
frame_stroke_width = 2,
sample_font_size = NULL,
legend_font_size = NULL,
font_family = "Arial") {
## =======================
## Input data
## =======================
# read config file and generate config parmeters
if (missing(config_file)) {
stop("[ERROR] Config file is required!")
}
config_data <- gvmapConfig(config_file)
message("[INFO] Read config data completed")
# read legend data
if (missing(legend_data)) {
message("[WARNING] Legend data is missing")
if (config_data$map_config$legend_num > 0) {
message("[WARNING] The legend_num (legend number) in config file is over zero, please check your data!")
}
legend_data_plot <- FALSE
} else {
if (config_data$map_config$legend_num == 0) {
message("[INFO] The legend_num (legend number) in config file is zero, the legend will not plot.")
legend_data_plot <- FALSE
} else {
legend_data_plot <- TRUE
}
legend_data <- readLegendFile(legend_data)
}
message("[INFO] Read legend data completed")
# read heatmap data
if (missing(heatmap_data)) {
message("[WARNING] heatmap data is missing.")
if (config_data$map_config$heatmap_num > 0) {
message("[WARNING] The heatmap_num (heatmap number) in config file is over zero, please check your data!")
}
heatmap_data_plot <- FALSE
} else {
if (config_data$map_config$heatmap_num == 0) {
message("[INFO] The heatmap_num (heatmap number) in config file is zero, the heatmap will not plot.")
heatmap_data_plot <- FALSE
} else {
heatmap_data_plot <- TRUE
}
heatmap_data <- readHeatmapFile(heatmap_data)
}
message("[INFO] Read heatmap data completed")
if (!heatmap_data_plot & !legend_data_plot) {
stop("[ERROR] None heatmap or legend, please check your data!")
}
if (missing(output_svg_name)) {
stop("[ERROR] The output svg name is required!")
}
## =======================
## Generating plot parameter
## =======================
plot_config <- list(
plot_width = plot_width,
plot_height = plot_height*0.9,
plot_out_height = plot_height,
stroke_width = stroke_width,
dend_stroke_width = dend_stroke_width,
group_span = group_span,
sample_span = sample_span,
heatmap_row_span = heatmap_row_span,
frame = frame,
frame_stroke_width = frame_stroke_width,
sample_font_size = sample_font_size,
legend_font_size = legend_font_size,
font_family = font_family
)
if (heatmap_data_plot) {
sample_num <- dim(heatmap_data[[1]])[2]
sample <- colnames(heatmap_data[[1]])
} else {
sample_num <- dim(legend_data)[1]
sample <- rownames(legend_data)
}
plot_config <- c(plot_config, sample_num = sample_num,
list(sample = sample),
list(sample_order = sample))
# heatamap plot parameter
if (heatmap_data_plot) {
for (i in 1:config_data$map_config$heatmap_num) {
plot_config <- getHeatmapParam(heatmap_data, config_data, plot_config, i)
}
}
if (legend_data_plot) {
plot_config <- getLegendParam(legend_data, config_data, plot_config)
}
message("[INFO] Generating plot paramters completed")
## =======================
## Data processsing
## =======================
# heatmap_1 is the leading controller of all plots
if (heatmap_data_plot) {
Rowv <- config_data$map_config$heatmap_1$Rowv
if (isTRUE(Rowv)) {
Rowv <- rowMeans(heatmap_data[[1]], na.rm = config_data$map_config$heatmap_1$na.rm)
}
if (is.numeric(Rowv)) {
Rowv <- reorderfun(as.dendrogram(
config_data$map_config$heatmap_1$hclustfun( config_data$map_config$heatmap_1$distfun(heatmap_data[[1]]) )
), Rowv)
}
if (is.dendrogram(Rowv)) {
Rowv <- rev(Rowv)
rowInd <- order.dendrogram(Rowv)
if(plot_config$heatmap_1$nr != length(rowInd))
stop("[ERROR] Row dendrogram in heatmap_1 is the wrong size")
} else {
if (!is.null(Rowv) && !is.na(Rowv) && !identical(Rowv, FALSE)) {
warning("[WARNING] Invalid value for Rowv in heatmap_1, ignoring")
}
Rowv <- NULL
rowInd <- 1:plot_config$heatmap_1$nr
}
Colv <- config_data$map_config$heatmap_1$Colv
if (isTRUE(Colv)) {
Colv <- colMeans(heatmap_data[[1]], na.rm = config_data$map_config$heatmap_1$na.rm)
}
if (is.numeric(Colv)) {
Colv <- reorderfun(as.dendrogram(config_data$map_config$heatmap_1$hclustfun(
config_data$map_config$heatmap_1$distfun(t(heatmap_data[[1]])))
), Colv)
}
if (is.dendrogram(Colv)) {
sampleInd <- order.dendrogram(Colv)
if (plot_config$heatmap_1$nc != length(sampleInd))
stop("[ERROR] Col dendrogram is the wrong size in heatmap_1")
} else {
if (!is.null(Colv) && !is.na(Colv) && !identical(Colv, FALSE)) {
warning("[WARNING] Invalid value for Colv in heatmap_1, ignoring")
}
Colv <- FALSE
sampleInd <- 1:plot_config$heatmap_1$nc
}
if(is.dendrogram(Rowv) & (config_data$map_config$heatmap_1$kmer_row > 1)) {
color_theme <- config_data$map_config$heatmap_1$kmer_row_color
if (!is.null(color_theme)) {
col_idx <- which(names(config_data$color_config) == color_theme)
color_theme <- config_data$color_config[[col_idx]]
#color_theme <- color_theme[1:config_data$map_config$heatmap_1$kmer_row]
} else {
color_theme <- config_data$color_config$black_col
}
Rowv <- dendextend::color_branches(Rowv,
k = config_data$map_config$heatmap_1$kmer_row,
col = color_theme,
groupLabels=TRUE)
}
if(is.dendrogram(Colv) & config_data$map_config$heatmap_1$kmer_col > 1) {
color_theme <- config_data$map_config$heatmap_1$kmer_col_color
if (!is.null(color_theme)) {
col_idx <- which(names(config_data$color_config) == color_theme)
color_theme <- config_data$color_config[[col_idx]]
#color_theme <- color_theme[1:config_data$map_config$heatmap_1$kmer_col]
} else {
color_theme <- config_data$color_config$black_col
}
Colv <- dendextend::color_branches(Colv,
k = config_data$map_config$heatmap_1$kmer_col,
col = color_theme,
groupLabels=TRUE)
}
config_data$map_config$heatmap_1$Rowv = Rowv
config_data$map_config$heatmap_1$rowInd = rowInd
config_data$map_config$heatmap_1$Colv = Colv
config_data$map_config$sampleInd = sampleInd
# reorder heatmap_1
heatmap_sub_data <- heatmap_data[[1]]
if (!config_data$map_config$heatmap_1$raw_data) {
heatmap_sub_data <- heatmapRowZdata(heatmap_sub_data)
}
# reorder heatmap mat
heatmap_sub_data <- heatmap_sub_data[rowInd, sampleInd]
heatmap_data[[1]] <- heatmap_sub_data
plot_config$sample_order <- plot_config$sample[sampleInd]
# reorder other heatmap data
if (config_data$map_config$heatmap_num > 1) {
for (i in 2:config_data$map_config$heatmap_num) {
heatmap_sub_name <- paste0("heatmap_", i)
heatmap_sub_info <- config_data$map_config[[which(names(config_data$map_config) == heatmap_sub_name)]]
heatmap_sub_data <- heatmap_data[[which(names(heatmap_data) == heatmap_sub_name)]]
heatmap_sub_plot <- plot_config[[which(names(plot_config) == heatmap_sub_name)]]
col_idx <- match(plot_config$sample_order, colnames(heatmap_sub_data))
if (anyNA(col_idx)) {
message("[WARNING] The sample value of ", heatmap_sub_name," data doesd't match heatmap_1")
}
heatmap_sub_data <- heatmap_sub_data[, col_idx]
colnames(heatmap_sub_data) <- plot_config$sample_order
Rowv <- heatmap_sub_info$Rowv
if (isTRUE(Rowv)) {
Rowv <- rowMeans(heatmap_sub_data, na.rm = heatmap_sub_info$na.rm)
}
if (is.numeric(Rowv)) {
Rowv <- reorderfun(as.dendrogram(
heatmap_sub_info$hclustfun( heatmap_sub_info$distfun(heatmap_sub_data) )
), Rowv)
}
if (is.dendrogram(Rowv)) {
Rowv <- rev(Rowv)
rowInd <- order.dendrogram(Rowv)
if(heatmap_sub_plot$nr != length(rowInd))
stop("[ERROR] Row dendrogram in ", heatmap_sub_name , " is the wrong size")
} else {
if (!is.null(Rowv) && !is.na(Rowv) && !identical(Rowv, FALSE)) {
warning("[WARNING] Invalid value for Rowv in ", heatmap_sub_name , ", ignoring")
}
Rowv <- FALSE
rowInd <- 1:heatmap_sub_plot$nr
}
if (!heatmap_sub_info$raw_data) {
heatmap_sub_data <- heatmapRowZdata(heatmap_sub_data)
}
if(is.dendrogram(Rowv) & (heatmap_sub_info$kmer_row > 1)) {
color_theme <- heatmap_sub_info$kmer_row_color
if (is.null(color_theme)) {
col_idx <- which(names(config_data$color_config) == color_theme)
color_theme <- config_data$color_config[[col_idx]]
# color_theme <- color_theme[1:heatmap_sub_info$kmer_row]
} else {
color_theme <- config_data$color_config$black_col
}
Rowv <- dendextend::color_branches(Rowv,
k = heatmap_sub_info$kmer_row,
col = color_theme,
groupLabels=TRUE)
}
# reorder heatmap mat
heatmap_sub_data <- heatmap_sub_data[rowInd, ]
heatmap_data[[which(names(heatmap_data) == heatmap_sub_name)]] <- heatmap_sub_data
config_data$map_config[[which(names(config_data$map_config) == heatmap_sub_name)]]$Rowv <- Rowv
config_data$map_config[[which(names(config_data$map_config) == heatmap_sub_name)]]$rowInd <- rowInd
config_data$map_config[[which(names(config_data$map_config) == heatmap_sub_name)]]$Colv <- FALSE
}
}
}
message("[INFO] Preprocessing heatmap data")
if (legend_data_plot) {
leg_sample <- rownames(legend_data)
leg_idx <- match(plot_config$sample_order, leg_sample)
if (anyNA(leg_idx)) {
message("[WARNING] The rownames value of legend data doesd't match heatmap")
}
legend_data <- legend_data[leg_idx, ]
rownames(legend_data) <- plot_config$sample_order
}
message("[INFO] Preprocessing legend data")
# calculate SVG location
plot_config <- checkPlotConfig(plot_config, config_data)
group_info <- list()
# transform position of dend
if (heatmap_data_plot) {
for (i in 1:config_data$map_config$heatmap_num) {
heatmap_sub_name <- paste0("heatmap_", i)
heatmap_sub_info <- config_data$map_config[[which(names(config_data$map_config) == heatmap_sub_name)]]
heatmap_sub_data <- heatmap_data[[which(names(heatmap_data) == heatmap_sub_name)]]
heatmap_sub_plot <- plot_config[[which(names(plot_config) == heatmap_sub_name)]]
col_attr <- dendAttribute(dend = heatmap_sub_info$Colv)
row_attr <- dendAttribute(dend = heatmap_sub_info$Rowv)
col_attr <- dendGap(dend_attr = col_attr, gap = plot_config$sample_span,
w = (heatmap_sub_plot$col_dend_w - heatmap_sub_plot$rect_w), h = heatmap_sub_plot$col_dend_h,
name = config_data$map_config$split_sample)
row_attr <- dendGap(dend_attr = row_attr, gap = plot_config$heatmap_row_span,
w = (heatmap_sub_plot$row_dend_w - heatmap_sub_plot$rect_h), h = heatmap_sub_plot$row_dend_h,
name = heatmap_sub_info$split_row_name)
config_data$map_config[[which(names(config_data$map_config) == heatmap_sub_name)]] <- c(
config_data$map_config[[which(names(config_data$map_config) == heatmap_sub_name)]],
list(col_attr = col_attr, row_attr = row_attr)
)
if (i == 1) {
config_data$map_config$heatmap_kmer_gap = col_attr
}
# add group kmer tag
group_sub_row <- data.frame(row_name = row_attr$node_label,
gap = row_attr$node_group,
tag = "g0")
iii <- 0
gtag <- rep("g0", length(group_sub_row[, 1]))
for (ii in 1:length(group_sub_row[, 1])) {
if (isTRUE(group_sub_row$gap[ii])) {
iii <- iii + 1
gtag[ii] <- paste0("g", iii)
} else {
gtag[ii] <- paste0("g", iii)
}
}
group_sub_row$tag <- gtag
group_sub_row <- group_sub_row[!is.na(group_sub_row$row_name), ]
group_sub_row <- list(group_sub_row)
names(group_sub_row) <- heatmap_sub_name
group_info <- c(group_info, group_sub_row)
}
} else {
config_data$map_config$heatmap_kmer_gap = NULL
}
if (is.null(config_data$map_config$heatmap_kmer_gap) | length(config_data$map_config$heatmap_kmer_gap$node_x) <= 1) {
gap = rep(0, length(plot_config$sample_order))
for (i in 2:(length(plot_config$sample_order))) {
if (plot_config$sample_order[i] %in% config_data$map_config$split_sample) {
gap[i] = gap[i-1] + plot_config$sample_span
} else {
gap[i] = gap[i-1] + 0
}
}
config_data$map_config$legend_kmer_gap = gap
}
## =======================
## Generating SVG element
## =======================
message("[INFO] Start to generating SVG element")
def_content <- ""
if (heatmap_data_plot) {
for (i in 1:config_data$map_config$heatmap_num) {
heatmap_sub_name <- paste0("heatmap_", i)
heatmap_sub_info <- config_data$map_config[[which(names(config_data$map_config) == heatmap_sub_name)]]
heatmap_sub_data <- heatmap_data[[which(names(heatmap_data) == heatmap_sub_name)]]
heatmap_sub_plot <- plot_config[[which(names(plot_config) == heatmap_sub_name)]]
if (is.dendrogram(heatmap_sub_info$Colv)) {
col_dend_svg <- dendSVG(dend_attr = heatmap_sub_info$col_attr, id = paste0(heatmap_sub_name, "_dend_col"),
plot_config = plot_config)
} else {
col_dend_svg <- group.svg(id = paste0(heatmap_sub_name, "_dend_col"), group.content = "")
}
if (is.dendrogram(heatmap_sub_info$Rowv)) {
row_dend_svg <- dendSVG(dend_attr = heatmap_sub_info$row_attr, id = paste0(heatmap_sub_name, "_dend_row"),
plot_config = plot_config)
} else {
row_dend_svg <- group.svg(id = paste0(heatmap_sub_name, "_dend_row"), group.content = "")
}
exp_mat_svg <- heatmapSVG(heatmap_sub_data = heatmap_sub_data,
heatmap_sub_info = heatmap_sub_info,
heatmap_sub_plot = heatmap_sub_plot,
config_data = config_data,
id = paste0(heatmap_sub_name, "_exp_mat"))
grad_svg <- heatmapGradSVG(heatmap_sub_data = heatmap_sub_data,
heatmap_sub_info = heatmap_sub_info,
heatmap_sub_plot = heatmap_sub_plot,
config_data = config_data,
id = paste0(heatmap_sub_name, "_grad"))
def_content = paste(def_content, col_dend_svg, row_dend_svg, exp_mat_svg, grad_svg, sep = '\n')
}
}
if (legend_data_plot) {
for (i in 1:config_data$map_config$legend_num) {
legend_sub_name <- paste0("legend_", i)
legend_sub_info <- config_data$map_config[[which(names(config_data$map_config) == legend_sub_name)]]
legend_sub_plot <- plot_config[[which(names(plot_config) == "legend")]]
legend_group_svg <- legendGroupSVG(config_data = config_data,
plot_config = plot_config,
legend_data = legend_data,
legend_sub_info = legend_sub_info,
legend_sub_plot = legend_sub_plot,
gap_info = config_data$map_config$heatmap_kmer_gap,
id = legend_sub_name)
legend_group_svg <- paste(legend_group_svg, collapse = "\n")
def_content <- paste(def_content, legend_group_svg, sep = "\n")
}
}
# add sample information
if (!is.null(config_data$map_config$heatmap_kmer_gap)) {
if (length(config_data$map_config$heatmap_kmer_gap$node_label) > 1) {
group_sub_col <- data.frame(col_name = config_data$map_config$heatmap_kmer_gap$node_label,
gap = config_data$map_config$heatmap_kmer_gap$node_group,
tag = "g0")
} else {
group_sub_col <- data.frame(col_name = plot_config$sample_order,
gap = FALSE,
tag = "g0")
}
iii <- 0
gtag <- rep("g0", length(group_sub_col[, 1]))
for (ii in 1:length(group_sub_col[, 1])) {
if (group_sub_col$gap[ii]) {
iii <- iii + 1
gtag[ii] <- paste0("g", iii)
} else {
gtag[ii] <- paste0("g", iii)
}
}
group_sub_col$tag <- gtag
group_sub_col <- group_sub_col[!is.na(group_sub_col$col_name), ]
group_sub_col <- list(group_sub_col)
names(group_sub_col) <- "sample_list"
group_info <- c(group_info, group_sub_col)
}
# add sample svg
sample_svg <- sampleSVG(plot_config = plot_config,
config_data = config_data,
gap_info = config_data$map_config$heatmap_kmer_gap,
id = "sample_list")
def_content <- paste(def_content, sample_svg, sep = "\n")
def_content <- defs.svg(defs.content = def_content)
## =======================
## Generating SVG Location
## =======================
message("[INFO] Start to generating SVG element location")
use_content <- ""
kk <- 0
for (i in 1:length(config_data$map_config$map_order)) {
order_name <- config_data$map_config$map_order[i]
if (grepl("^heatmap_", order_name)) {
heatmap_sub_info <- config_data$map_config[[which(names(config_data$map_config) == order_name)]]
heatmap_sub_plot <- plot_config[[which(names(plot_config) == heatmap_sub_name)]]
if (order_name == "heatmap_1") {
if (heatmap_sub_info$dendrogram == "both" | heatmap_sub_info$dendrogram == "col") {
col_dend_use <- use.svg(id = paste0(order_name, "_dend_col"),
x = heatmap_sub_plot$w*0.2 + 0.5*heatmap_sub_plot$rect_w,
y = 0)
use_content <- paste(use_content, col_dend_use, sep = "\n")
}
}
if (heatmap_sub_info$dendrogram == "both" | heatmap_sub_info$dendrogram == "row") {
row_dend_use <- use.svg(id = paste0(order_name, "_dend_row"),
x = 0 , y = 0, scale = c(-1, 1),
translate = c(plot_config$group_baseline[i] + heatmap_sub_plot$rect_h*0.5, 0),
rotate = c(90, 0, 0))
use_content <- paste(use_content, row_dend_use, sep = "\n")
}
exp_mat_use <- use.svg(id = paste0(order_name, "_exp_mat"),
x = heatmap_sub_plot$w * 0.2,
y = plot_config$group_baseline[i])
grad_use <- use.svg(id = paste0(order_name, "_grad"),
x = 0,
y = abs(plot_config$group_baseline[i] - heatmap_sub_plot$rect_h*5))
use_content <- paste(use_content, exp_mat_use, grad_use, sep = "\n")
}
if (grepl("^legend_", order_name)) {
legend_sub_plot <- plot_config[[which(names(plot_config) == "legend")]]
legend_sub_info <- config_data$map_config[[which(names(config_data$map_config) == order_name)]]
legend_mat_use <- use.svg(id = paste0(order_name, "_mat"),
x = plot_config$plot_width * 0.2,
y = plot_config$group_baseline[i])
legend_out_use <- use.svg(id = paste0(order_name, "_outline"),
x = plot_config$plot_width * 0.2,
y = plot_config$group_baseline[i])
legend_app_use <- use.svg(id = paste0(order_name, "_leg_text"),
x = plot_config$plot_width * 0.02,
y = plot_config$group_baseline[length(plot_config$group_baseline)] + kk + plot_config$sample_font_size*10)
legend_control <- max(8, legend_sub_plot$row_fz)
legend_control <- min(14, legend_control)
kk <- kk + (legend_control+4) * length(legend_sub_info)
use_content <- paste(use_content, legend_mat_use, legend_out_use, legend_app_use, sep = "\n")
}
}
# use sample svg
sample_use <- use.svg(id = "sample_list",
x = plot_config$plot_width * 0.2,
y = plot_config$group_baseline[length(plot_config$group_baseline)])
use_content <- paste(use_content, sample_use, sep = "\n")
use_content <- group.svg(group.content = use_content, transform.sheet = "translate(20,20)", id = "use",
font.family = plot_config$font_family)
## =======================
## Output the result
## =======================
message("[INFO] Output SVG")
pack_content <- paste(def_content, use_content, sep = "\n")
pack.svg(pack.content = pack_content, output.svg.name = output_svg_name,
width = plot_config$plot_width, height = plot_config$plot_out_height)
output_svg_name <- normalizePath(output_svg_name)
if (output_group_info & length(group_info) > 0) {
output_group_info_name <- gsub(".svg$", ".group.info.xlsx", output_svg_name)
write.xlsx(group_info, output_group_info_name, colWidths = c(NA, "auto", "auto"))
}
# convert
if (convert_pdf) {
if (file.size(output_svg_name) > 10000000) {
cmd = sprintf("inkscape --without-gui --export-pdf=\"%s\" %s &", gsub(".svg$", ".pdf", output_svg_name), output_svg_name)
system(cmd)
} else {
rsvg_pdf(svg = output_svg_name, file = gsub(".svg$", ".pdf", output_svg_name))
}
}
if (convert_jpg) {
cmd <- sprintf("convert -density 300 %s %s", output_svg_name, gsub(".svg$", ".jpg", output_svg_name))
system(cmd)
}
}
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.