修改chart.Correlation函数,使pch根据它在factor列中的值着色

时间:2018-04-15 17:46:14

标签: r performanceanalytics

您可以帮忙修改此功能,以便lower.panel绘图圆圈着色,颜色取决于因子列的具体值吗?我有类似“Iris”data.frame的数据,因此,因子列可能是“物种”。我强调了我试图塑造'bg'功能的部分,适用于'对'。

以下是我要调整的代码:

#### chart.Correlation

function (R,histogram = TRUE, method = c("pearson", "kendall", 
    "spearman"), ...) 
{

    x = checkData(R, method = "matrix")
    if (missing(method)) 
        method = method[1]
    panel.cor <- function(x, y, digits = 2, prefix = "", use = "pairwise.complete.obs", 
        method = "pearson", cex.cor, ...) {
        usr <- par("usr")
        on.exit(par(usr))
        par(usr = c(0, 1, 0, 1))
        r <- cor(x, y, use = use, method = method)
        txt <- format(c(r, 0.123456789), digits = digits)[1]
        txt <- paste(prefix, txt, sep = "")
        if (missing(cex.cor)) 
            cex <- 0.8/strwidth(txt)
        test <- cor.test(as.numeric(x), as.numeric(y), method = method)
        Signif <- symnum(test$p.value, corr = FALSE, na = FALSE, 
            cutpoints = c(0, 0.001, 0.01, 0.05, 0.1, 1), symbols = c("***", 
                "**", "*", ".", " "))
        text(0.5, 0.5, txt, cex = cex * (abs(r) + 0.3)/1.3)
        text(0.8, 0.8, Signif, cex = cex, col = 2)
    }
    f <- function(t) {
        dnorm(t, mean = mean(x), sd = sd.xts(x))
    }
    dotargs <- list(...)
    dotargs$method <- NULL
    rm(method)   
    hist.panel = function(x, ... = NULL) {
        par(new = TRUE)
        hist(x, col = "white", probability = TRUE, axes = FALSE, 
            main = "", breaks = "FD")
        lines(density(x, na.rm = TRUE), col = "red", lwd = 1)
        rug(x)
    }
    if (histogram) 
        pairs(x, gap = 0,lower.panel = panel.smooth, upper.panel = panel.cor, 
            diag.panel = hist.panel)
    else pairs(x, gap = 0, lower.panel = panel.smooth, upper.panel = panel.cor)
}

1 个答案:

答案 0 :(得分:1)

omg我自己做了.. 所以,这是编辑过的代码:

function (R,L,histogram = TRUE, method = c("pearson", "kendall", 
"spearman"), ...) 
{
l = checkData(L, method = "zoo")
x = checkData(R, method = "matrix")
if (missing(method)) 
    method = method[1]
panel.cor <- function(x, y, digits = 2, prefix = "", use = "pairwise.complete.obs", 
    method = "pearson", cex.cor, ...) {
    usr <- par("usr")
    on.exit(par(usr))
    par(usr = c(0, 1, 0, 1))
    r <- cor(x, y, use = use, method = method)
    txt <- format(c(r, 0.123456789), digits = digits)[1]
    txt <- paste(prefix, txt, sep = "")
    if (missing(cex.cor)) 
        cex <- 0.8/strwidth(txt)
    test <- cor.test(as.numeric(x), as.numeric(y), method = method)
    Signif <- symnum(test$p.value, corr = FALSE, na = FALSE, 
        cutpoints = c(0, 0.001, 0.01, 0.05, 0.1, 1), symbols = c("***", 
            "**", "*", ".", " "))
    text(0.5, 0.5, txt, cex = cex * (abs(r) + 0.3)/1.6)
    text(0.8, 0.8, Signif, cex = 2, col = 2)
}
f <- function(t) {
    dnorm(t, mean = mean(x), sd = sd.xts(x))
}
dotargs <- list(...)
dotargs$method <- NULL
rm(method)   
hist.panel = function(x, ... = NULL) {
    par(new = TRUE)
    hist(x, col = "white", probability = TRUE, axes = FALSE, 
        main = "", breaks = "FD")
    lines(density(x, na.rm = TRUE), col = "red", lwd = 1)
    rug(x)
}
if (histogram) 
    pairs(x, bg = c("red","green")[l],gap = 0, pch = 21,lower.panel = panel.smooth, upper.panel = panel.cor, 
        diag.panel = hist.panel)
else pairs(x, gap = 0, lower.panel = panel.smooth, upper.panel = panel.cor)

}