gheatmap 函数（ggtree 包）返回“错误：必须从色调调色板中请求至少一种颜色。”绘制热图对象时

Question

我正在尝试使用 ggtree 函数 gheatmap 将热图添加到系统发育树上。尽管创建 gheatmap 对象的行中没有出现明显错误，但在尝试绘制对象时，它会返回“错误：必须从色调调色板中请求至少一种颜色。”。当我使用 gheatmap 的参数的所有默认值（包括颜色选择）、更简单的树和与树的尖端相对应的一些随机值时，仍然会出现此错误。我也尝试过更改一些颜色，但仍然无法解决错误，因为我仍然不确定是哪个参数导致了问题。

我希望这是一个可重现的例子：

library(ggtree)
test.tree <- read.tree(text = "(((A,C), (B,D)), E);")
test.data <- data.frame('taxon' = c('A','B','C','D','E'), 'height' = c(0.7, 0.2, 1.3, 0.55, 0.88))
test.tree.plot <- ggtree(test.tree)

test.plot <- gheatmap(
  test.tree.plot,
  test.data,
  offset = 0,
  width = 1,
  low = "green",
  high = "red",
  color = "white",
  colnames = TRUE,
  colnames_position = "bottom",
  colnames_angle = 0,
  colnames_level = NULL,
  colnames_offset_x = 0,
  colnames_offset_y = 0,
  font.size = 4,
  family = "",
  hjust = 0.5,
  legend_title = "value"
)

plot(test.plot)

Answer 1

欢迎来到！

快速搜索此错误表明仅包含NA 的变量被映射到美学（在本例中为geom_tile() 的fill）。您的数据没有任何NA，因此它可能在gheatmap 函数内部发生。

仔细观察，https://github.com/YuLab-SMU/ggtree/blob/232394961afb6ce62c8dd90a5b1ee8e5f557185a/R/gheatmap.R#L81 这一行上的gheatmap 函数预计数据框将具有rownames。除非，在您的情况下，数据没有行名，这些行名在使用gather 向下旋转几步之后会产生所有NAs。

我更新了函数以采用另一个参数 id_col，它设置用于行名的列。

使用新功能，代码将是：

library(ggtree)
library(magrittr)
library(dplyr)
library(tidyr)
library(ggplot2)
source("ggheatmap.R") # loading the new function (if in a separate file)

test.tree <- read.tree(text = "(((A,C), (B,D)), E);")
test.data <- data.frame('taxon' = c('A','B','C','D','E'), 
                        'height' = c(0.7, 0.2, 1.3, 0.55, 0.88)
                        )
test.tree.plot <- ggtree(test.tree)

test.plot <- ggheat(
  test.tree.plot,
  test.data,
  id_col = "taxon", # here is where you set the column with species names
                    # this becomes rownames internaly 
                    # and is matched to the tip names
  offset = -3,
  width = 1,
  low = "green",
  high = "red",
  color = "white",
  colnames = TRUE,
  colnames_position = "bottom",
  colnames_angle = 0,
  colnames_level = NULL,
  colnames_offset_x = 0,
  colnames_offset_y = 0,
  font.size = 4,
  family = "",
  hjust = 0.5,
  legend_title = "value"
)

plot(test.plot)

这段代码制作了这张图片：

更新的功能在这里：

ggheat <-
  function (p,
            data,
            id_col,
            offset = 0,
            width = 1,
            low = "green",
            high = "red",
            color = "white",
            colnames = TRUE,
            colnames_position = "bottom",
            colnames_angle = 0,
            colnames_level = NULL,
            colnames_offset_x = 0,
            colnames_offset_y = 0,
            font.size = 4,
            family = "",
            hjust = 0.5,
            legend_title = "value")
  {
    colnames_position %<>% match.arg(c("bottom", "top"))
    variable <- value <- lab <- y <- NULL
    width <-
      width * (p$data$x %>% range(na.rm = TRUE) %>% diff) / ncol(data)
    isTip <- x <- y <- variable <- value <- from <- to <- NULL
    df <- p$data
    nodeCo <-
      intersect(
        df %>% filter(is.na(x)) %>% select(.data$parent,
                                           .data$node) %>% unlist(),
        df %>% filter(!is.na(x)) %>%
          select(.data$parent, .data$node) %>% unlist()
      )
    labCo <-
      df %>% filter(.data$node %in% nodeCo) %>% select(.data$label) %>%
      unlist()
    selCo <- intersect(labCo, rownames(data))
    isSel <- df$label %in% selCo
    df <- df[df$isTip | isSel,]
    start <- max(df$x, na.rm = TRUE) + offset
    dd <- as.data.frame(data)
    i <- order(df$y)
    i <- i[!is.na(df$y[i])]
    lab <- df$label[i]
    
    # drop any rownames, then add them based on the user set id column
    # so the matching downstream can work
    dd <- dd %>% tibble::remove_rownames() %>% tibble::column_to_rownames(id_col)
    
    
    dd <- dd[match(lab, rownames(dd)), , drop = FALSE]
    dd$y <- sort(df$y)
    dd$lab <- lab
    dd <- gather(dd, variable, value,-c(lab, y))
    i <- which(dd$value == "")
    if (length(i) > 0) {
      dd$value[i] <- NA
    }
    if (is.null(colnames_level)) {
      dd$variable <- factor(dd$variable, levels = colnames(data))
    }
    else {
      dd$variable <- factor(dd$variable, levels = colnames_level)
    }
    V2 <- start + as.numeric(dd$variable) * width
    mapping <- data.frame(from = dd$variable, to = V2)
    mapping <- unique(mapping)
    dd$x <- V2
    dd$width <- width
    dd[[".panel"]] <- factor("Tree")
    if (is.null(color)) {
      p2 <- p + geom_tile(
        data = dd,
        aes(x, y, fill = value),
        width = width,
        inherit.aes = FALSE
      )
    }
    else {
      p2 <- p + geom_tile(
        data = dd,
        aes(x, y, fill = value),
        width = width,
        color = color,
        inherit.aes = FALSE
      )
    }
    if (is(dd$value, "numeric")) {
      p2 <- p2 + scale_fill_gradient(
        low = low,
        high = high,
        na.value = NA,
        name = legend_title
      )
    }
    else {
      p2 <- p2 + scale_fill_discrete(na.value = NA, name = legend_title)
    }
    if (colnames) {
      if (colnames_position == "bottom") {
        y <- 0
      }
      else {
        y <- max(p$data$y) + 1
      }
      mapping$y <- y
      mapping[[".panel"]] <- factor("Tree")
      p2 <- p2 + geom_text(
        data = mapping,
        aes(x = to, y = y,
            label = from),
        size = font.size,
        family = family,
        inherit.aes = FALSE,
        angle = colnames_angle,
        nudge_x = colnames_offset_x,
        nudge_y = colnames_offset_y,
        hjust = hjust
      )
    }
    p2 <- p2 + theme(legend.position = "right")
    if (!colnames) {
      p2 <- p2 + scale_y_continuous(expand = c(0, 0))
    }
    attr(p2, "mapping") <- mapping
    return(p2)
  }