Tufte-like Population Pyramid for R. Still figuring out how to sort out ellipsis args between functions. Example at bottom.

TuftePyramid.R

TuftePyramid <- function(males, females, age, widths, gap = .05, 
        fill.args = list(), border.args = list(), grid.args = list(), 
        age.label.args = list(), x.label.args = list(), 
        grid = TRUE, labels = TRUE, add = FALSE){
    
    Total <- sum(males, females)
    males   <- males / Total
    females <- females / Total

    max.x <- max(abs(pretty(c(males, females), n = 25))) 
    off   <- gap * max.x
    xlim  <- max.x * c(1, -1) * (1 + gap)
    u.age <- age[length(age)] + widths[length(widths)]
    if( !add){
        plot(NULL, type = "n", xlim = xlim, ylim = c(age[1], u.age), 
                axes = FALSE, xaxs = "i", yaxs = "i", xlab = "", ylab = "")
    }
    b.poly.args1 <- c(fill.args, list(
            x = c(off, rep(females, each = 2) + off, off), 
            y =  c(rep(c(age, u.age), each = 2))))
    b.poly.args2 <- c(fill.args, list(
            x = c(-off, rep(-males, each = 2) - off, -off), 
            y =  c(rep(c(age, u.age), each = 2))))
    do.call(polygon, b.poly.args1)
    do.call(polygon, b.poly.args2)
    #polygon(c(off, rep(females, each = 2) + off, off), c(rep(c(age, u.age), each = 2)), ...)
    #polygon(c(-off, rep(-males, each = 2) - off, -off), c(rep(c(age, u.age), each = 2)), ...)
       
    v.ticks     <- pretty(c(-males, females), n = 15)
    if (0 %in% v.ticks){
        v.ticks <- v.ticks[!v.ticks == 0]
    }
    v.labs      <- abs(sort(c(v.ticks * 100,0,0)))
    v.ticks     <- sort(c(v.ticks + ifelse(sign(v.ticks) == 1, off, -off), off, -off))
    if (grid){
        h.grid.args <- c(grid.args, list(h = pretty(c(age, u.age), n = 10)))
        v.grid.args <- c(grid.args, list(v = v.ticks))
        do.call(abline, h.grid.args)
        do.call(abline, v.grid.args)
        #abline(h = pretty(c(age, u.age), n = 10))
        #abline(v = v.ticks)  
    }
    b.poly.args1 <- c(border.args, list(
            x = c(off, rep(females, each = 2) + off, off), 
            y =  c(rep(c(age, u.age), each = 2))))
    b.poly.args2 <- c(border.args, list(
            x = c(-off, rep(-males, each = 2) - off, -off), 
            y =  c(rep(c(age, u.age), each = 2))))
       # polygon(c(off, rep(females, each = 2) + off, off), c(rep(c(age, u.age), each = 2)), 
        #        border = border, lty = lty, lwd = lwd)
        #polygon(c(-off, rep(-males, each = 2) - off, -off), c(rep(c(age, u.age), each = 2)),
        #        border = border, lty = lty, lwd = lwd)
    do.call(polygon, b.poly.args1)
    do.call(polygon, b.poly.args2)
    
    # labels
    a.args <- c(age.label.args, list(x = 0, y = pretty(c(age, u.age), n = 10), 
                    labels = pretty(c(age, u.age), n = 10), xpd = TRUE))
    if ("x" %in% names(x.label.args)){
        x.label.args$x <-  x.label.args$x + ifelse(sign(x.label.args$x) == 1, off, -off)
    }
    x.args <- c(x.label.args, list(x = v.ticks, y = age[1], 
                    pos = 1, labels =  v.labs, xpd = TRUE ))
    a.args <- a.args[!duplicated(names(a.args))]
    x.args <- x.args[!duplicated(names(x.args))]
    do.call(text, a.args)
    do.call(text, x.args)
}
# from HMD SWE, first year available (1751?)- pretty bad heaping, less apparent because original data were likely in 5-year groups
#males <- structure(c(28608.93, 25873.44, 26127.31, 21638.37, 17681.68, 
#                17824.89, 17920.14, 18125.9, 18583.2, 19139.68, 18322.33, 17566.63, 
#                16805.54, 16213.91, 15716.37, 15879.36, 16050.4, 15864.86, 15289.38, 
#                14751.75, 14317.51, 13905.93, 13757.83, 13927.85, 13839.19, 13943.58, 
#                13952.54, 13797.98, 13718.29, 13599.83, 12784.88, 11933.6, 11137.09, 
#                10467.99, 9866.04, 10002.34, 10237.46, 10443.06, 10604.41, 10604.31, 
#                9676.58, 8924.75, 8306.42, 7737.15, 7095.81, 7271.04, 7615.27, 
#                7982.92, 8486.4, 8857.04, 8061.75, 7176.68, 6281.76, 5470.44, 
#                4769.04, 4832.72, 5002.55, 5239.44, 5542.7, 5825.66, 5621.9, 
#                5463.6, 5163.31, 4857.49, 4531.52, 4312.67, 4117.64, 3941.05, 
#                3744.55, 3516.75, 3130.77, 2760.48, 2374.04, 1992.61, 1629.25, 
#                1447.67, 1306.98, 1207.63, 1141.88, 1095.7, 969.37, 842.16, 717.26, 
#                600.12, 494.64, 401.27, 328.92, 273.21, 224.14, 182.97, 145.85, 
#                115.62, 90.41, 70.56, 54.67, 41.91, 31.32, 22.92, 16.89, 12.21, 
#                8.48), .Names = c("0", "1", "2", "3", "4", "5", "6", "7", "8", 
#                "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", 
#                "20", "21", "22", "23", "24", "25", "26", "27", "28", "29", "30", 
#                "31", "32", "33", "34", "35", "36", "37", "38", "39", "40", "41", 
#                "42", "43", "44", "45", "46", "47", "48", "49", "50", "51", "52", 
#                "53", "54", "55", "56", "57", "58", "59", "60", "61", "62", "63", 
#                "64", "65", "66", "67", "68", "69", "70", "71", "72", "73", "74", 
#                "75", "76", "77", "78", "79", "80", "81", "82", "83", "84", "85", 
#                "86", "87", "88", "89", "90", "91", "92", "93", "94", "95", "96", 
#                "97", "98", "99", "100"))
#females <- structure(c(28595.61, 26191.55, 26508.24, 22053.87, 18244.12, 
#18296.82, 18094.76, 18040.69, 18324.15, 18807.98, 18296.14, 17713.5, 
#17039.1, 16449.55, 15939.98, 16570.65, 17010.95, 17118.63, 17282.31, 
#17430.77, 16901.85, 16460.07, 16088.59, 15822.2, 15370.35, 15391.02, 
#15450.72, 15468.8, 15448.83, 15287.97, 14314.7, 13352.42, 12350.63, 
#11436.73, 10627.16, 10810.93, 11164.94, 11538.23, 11989.25, 12265.8, 
#11233.71, 10322.27, 9473.27, 8627.03, 7795.34, 8121.22, 8659.56, 
#9314.69, 10155.2, 10956.27, 9911.9, 8861.08, 7861.81, 6968.06, 
#6123.67, 6343.53, 6672, 7147.67, 7876.66, 8735.82, 8544.61, 8311.95, 
#7760.1, 7074.47, 6286.88, 6048.71, 5876.15, 5771.78, 5664.79, 
#5580.32, 4895.12, 4223.91, 3564.4, 2926.81, 2339.58, 2163.34, 
#2026.73, 1952.99, 1927.69, 1843.71, 1638.03, 1431.32, 1227.15, 
#1029.21, 852.88, 700.88, 569.74, 464.3, 381.26, 316.54, 255.82, 
#201.42, 156.58, 120.1, 91.21, 68.4, 50.32, 36.42, 26.38, 18.22, 
#12.67), .Names = c("0", "1", "2", "3", "4", "5", "6", "7", "8", 
#"9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", 
#"20", "21", "22", "23", "24", "25", "26", "27", "28", "29", "30", 
#"31", "32", "33", "34", "35", "36", "37", "38", "39", "40", "41", 
#"42", "43", "44", "45", "46", "47", "48", "49", "50", "51", "52", 
#"53", "54", "55", "56", "57", "58", "59", "60", "61", "62", "63", 
#"64", "65", "66", "67", "68", "69", "70", "71", "72", "73", "74", 
#"75", "76", "77", "78", "79", "80", "81", "82", "83", "84", "85", 
#"86", "87", "88", "89", "90", "91", "92", "93", "94", "95", "96", 
#"97", "98", "99", "100"))
#age <- 0:100
#widths <- rep(1, length(age))
#TuftePyramid(males, females, age, widths, gap = .05, grid.args = list(col = "white", lwd = .5),
#        fill.args = list(col = gray(.93)), border.args = list(border = gray(.5), lwd = 2),
#       age.label.args = list(x = 0, y = seq(0,100,by = 5), labels = seq(0,100,by = 5), cex = .8),
#       x.label.args = list(cex = .8, x = c(-.02,-.015,-.01,-.005,-1e-10,1e-10,.005,.01,.015,.02),
#               labels = c("2.0%","1.5%","1.0%","0.5%","0%","0%","0.5%","1.0%","1.5%","2.0%")))
#