1

我正在尝试在我的 X 和 Y 变量之间创建一个相关矩阵，并以一个漂亮的图形显示此信息。我目前正在ggpairs()从GGally包中使用，但如果有更好的方法可以做到这一点，那么我很乐意尝试新的东西。该图应：

lm- 拟合X 和 Y 变量之间的线性回归模型（使用）

- 显示带有回归线的散点图

- 显示测定系数 (R2)

-按组映射点/线/R2值的颜色

我已经能够完成大部分工作，但ggpairs只显示相关系数 (r) 而不是决定系数 (R2)。我能够使用这篇文章中的建议，但不幸的是，该解决方案没有按组显示 R2 值。

至今：

library(GGally)
library(ggplot2)

cars <- mtcars
cars$group <- factor(c(rep("A", 16), rep("B", 16))) #adding grouping variable

#function to return R2 (coefficient of determination) and not just r (Coefficient of correlation) in the top portion of the figure
upper_fn <- function(data, mapping, ndp=2, ...){
  
  # Extract the relevant columns as data
  x <- eval_data_col(data, mapping$x)
  y <- eval_data_col(data, mapping$y)
  
  # Calculate the r^2 & format output
  m <- summary(lm(y ~ x))
  lbl <- paste("r^2: ", formatC(m$r.squared, digits=ndp, format="f"))
  
  # Write out label which is centered at x&y position
  ggplot(data=data, mapping=mapping) + 
    annotate("text", x=mean(x, na.rm=TRUE), y=mean(y, na.rm=TRUE), label=lbl, parse=TRUE, ...)+
    theme(panel.grid = element_blank()) 
}


#lower function basically fits a linear model and displays points 
lower_fn <- function(data, mapping, ...){
  p <- ggplot(data = data, mapping = mapping) + 
    geom_point(alpha = 0.7) + 
    geom_smooth(method=lm, fill="blue", se = F, ...)
  p
}

#The actual figure
  ggpairs(cars,
    columns = c(1:11),
    mapping = ggplot2::aes(color = group),
    upper = list(continuous = "cor", size = 15),
    diag = list(continuous = "densityDiag", alpha=0.5),
    lower = list(continuous = lower_fn))
4

1 回答 1

1

基于是否可以拆分相关框以显示pairplot中两种不同处理的相关值？，下面是一些帮助您入门的代码。

这个想法是您需要 1.主题变量split上的数据aes（假设为colour），2. 对每个数据子集运行回归并提取 r^2，3. 快速计算放置 r^ 的位置2 个标签，4. 情节。有些功能还有待完成。

upper_fn <- function(data, mapping, ndp=2, ...){
  
  # Extract the relevant columns as data
  x <- eval_data_col(data, mapping$x)
  y <- eval_data_col(data, mapping$y)
  col <- eval_data_col(data, mapping$colour)

  # if no colour mapping run over full data
  if(is.null(col)) {
        ## add something here
    }

  # if colour aesthetic, split data and run `lm` over each group
  if(!is.null(col)) {
    idx <- split(seq_len(nrow(data)), col)
    r2 <- unlist(lapply(idx, function(i) summary(lm(y[i] ~ x[i]))$r.squared))

    lvs <- if(is.character(col)) sort(unique(col)) else levels(col)
    cuts <- seq(min(y, na.rm=TRUE), max(y, na.rm=TRUE), length=length(idx)+1L)
    pos <- (head(cuts, -1) + tail(cuts, -1))/2 

    p <- ggplot(data=data, mapping=mapping, ...) + 
            geom_blank() + 
            theme_void() + 
            # you could map colours to each level 
            annotate("text", x=mean(x), y=pos, label=paste(lvs, ": ", formatC(r2, digits=ndp, format="f")))
    }
  
  return(p)
}
于 2022-02-15T18:40:57.527 回答