冲积地块边距

Posted 2023-03-06

【中文标题】冲积地块边距

【英文标题】：Margin for alluvial plot

【发布时间】：2020-01-23 21:15:51

【问题描述】：

我用这个例子

library(alluvial)
tit <- as.data.frame(Titanic)

# only two variables: class and survival status
tit2d <- aggregate( Freq ~ Class + Survived, data=tit, sum)

alluvial( tit2d[,1:2], freq=tit2d$Freq, xw=0.0, alpha=0.8,
          gap.width=0.1, col= "steelblue", border="white",
          layer = tit2d$Survived != "Yes" , cex.axis =8)

注意我使用cex.axis =8 我得到了

轴标签超出范围 我尝试使用par(mar=c(10, 10, 10, 10)) 但没有结果 感谢您的任何想法

【参考方案1】：

alluvial函数的源码有bug

函数设置par(mar=c(2,1,1,1)) 硬编码，因此在外部使用par() 没有任何效果。

您可以在本地将函数的源代码更改为 2 个选项之一：

添加参数mar_并通过边距，并设置在正确的位置par(mar=mar_)。 只需将行本地覆盖到所需的边距

我发现第一个选项更有吸引力，因为您可以从函数外部设置值并更轻松地进行优化。

源代码：

function (..., freq, col = "gray", border = 0, layer, hide = FALSE, 
    alpha = 0.5, gap.width = 0.05, xw = 0.1, cw = 0.1, blocks = TRUE, 
    ordering = NULL, axis_labels = NULL, cex = par("cex"), cex.axis = par("cex.axis")) 

    p <- data.frame(..., freq = freq, col, alpha, border, hide, 
        stringsAsFactors = FALSE)
    np <- ncol(p) - 5
    if (!is.null(ordering)) 
        stopifnot(is.list(ordering))
        if (length(ordering) != np) 
            stop("'ordering' argument should have ", np, " components, has ", 
                length(ordering))
    
    n <- nrow(p)
    if (missing(layer)) 
        layer <- 1:n
    
    p$layer <- layer
    d <- p[, 1:np, drop = FALSE]
    p <- p[, -c(1:np), drop = FALSE]
    p$freq <- with(p, freq/sum(freq))
    col <- col2rgb(p$col, alpha = TRUE)
    if (!identical(alpha, FALSE)) 
        col["alpha", ] <- p$alpha * 256
    
    p$col <- apply(col, 2, function(x) do.call(rgb, c(as.list(x), 
        maxColorValue = 256)))
    isch <- sapply(d, is.character)
    d[isch] <- lapply(d[isch], as.factor)
    if (length(blocks) == 1) 
        blocks <- if (!is.na(as.logical(blocks))) 
            rep(blocks, np)
        
        else if (blocks == "bookends") 
            c(TRUE, rep(FALSE, np - 2), TRUE)
        
    
    if (is.null(axis_labels)) 
        axis_labels <- names(d)
    
    else 
        if (length(axis_labels) != ncol(d)) 
            stop("`axis_labels` should have length ", names(d), 
                ", has ", length(axis_labels))
    
    getp <- function(i, d, f, w = gap.width) 
        a <- c(i, (1:ncol(d))[-i])
        if (is.null(ordering[[i]])) 
            o <- do.call(order, d[a])
        
        else 
            d2 <- d
            d2[1] <- ordering[[i]]
            o <- do.call(order, d2[a])
        
        x <- c(0, cumsum(f[o])) * (1 - w)
        x <- cbind(x[-length(x)], x[-1])
        gap <- cumsum(c(0L, diff(as.numeric(d[o, i])) != 0))
        mx <- max(gap)
        if (mx == 0) 
            mx <- 1
        gap <- gap/mx * w
        (x + gap)[order(o), ]
    
    dd <- lapply(seq_along(d), getp, d = d, f = p$freq)
    rval <- list(endpoints = dd)
===============================================
===============Need to edit====================
    op <- par(mar = c(2, 1, 1, 1))
===============================================
    plot(NULL, type = "n", xlim = c(1 - cw, np + cw), ylim = c(0, 
        1), xaxt = "n", yaxt = "n", xaxs = "i", yaxs = "i", xlab = "", 
        ylab = "", frame = FALSE)
    ind <- which(!p$hide)[rev(order(p[!p$hide, ]$layer))]
    for (i in ind) 
        for (j in 1:(np - 1)) 
            xspline(c(j, j, j + xw, j + 1 - xw, j + 1, j + 1, 
                j + 1 - xw, j + xw, j) + rep(c(cw, -cw, cw), 
                c(3, 4, 2)), c(dd[[j]][i, c(1, 2, 2)], rev(dd[[j + 
                1]][i, c(1, 1, 2, 2)]), dd[[j]][i, c(1, 1)]), 
                shape = c(0, 0, 1, 1, 0, 0, 1, 1, 0, 0), open = FALSE, 
                col = p$col[i], border = p$border[i])
        
    
    for (j in seq_along(dd)) 
        ax <- lapply(split(dd[[j]], d[, j]), range)
        if (blocks[j]) 
            for (k in seq_along(ax)) 
                rect(j - cw, ax[[k]][1], j + cw, ax[[k]][2])
            
        
        else 
            for (i in ind) 
                x <- j + c(-1, 1) * cw
                y <- t(dd[[j]][c(i, i), ])
                w <- xw * (x[2] - x[1])
                xspline(x = c(x[1], x[1], x[1] + w, x[2] - w, 
                  x[2], x[2], x[2] - w, x[1] + w, x[1]), y = c(y[c(1, 
                  2, 2), 1], y[c(2, 2, 1, 1), 2], y[c(1, 1), 
                  1]), shape = c(0, 0, 1, 1, 0, 0, 1, 1, 0, 0), 
                  open = FALSE, col = p$col[i], border = p$border[i])
            
        
        for (k in seq_along(ax)) 
            text(j, mean(ax[[k]]), labels = names(ax)[k], cex = cex)
        
    
    axis(1, at = rep(c(-cw, cw), ncol(d)) + rep(seq_along(d), 
        each = 2), line = 0.5, col = "white", col.ticks = "black", 
        labels = FALSE)
    axis(1, at = seq_along(d), tick = FALSE, labels = axis_labels, 
        cex.axis = cex.axis)
    par(op)
    invisible(rval)

我将问题发生的地方标记为：

============================================== ====

==============需要编辑======================

op

============================================== ====

将线路改为par(mar=c(5, 5, 3, 10))后得到：

【讨论】：

很棒的决定！