Add a versatile map scale onto the plot (with base graphics).

mapscale.R

mapscale <- 
function(mapunit, unitname = "km", pos = c("bottom", "left", "right", "top"),
         width = 0.15,
         style = c("line", "bar", "double"),
         height = 0, n = 5,
         fine.part = NULL, lab.below = FALSE,
         cex = par("cex.axis") * par("cex"),
         line.lab = 0.8, offx = 0.25, offy = offx,
         tcl = par("tcl"), extreme.ticks = FALSE,
         double.bar = FALSE,
         cex.lab = .66,
         col = par("col"), fill = NA,
         bg = par("bg"),
         lty = par("lty"), lwd = par("lwd"),
         ...
         ) {


    col1 <- cbind(col2rgb(col[1L], alpha = TRUE),
                  col2rgb(bg[1L], alpha = TRUE))
    col2 <- apply(col1, 2L, function(x) paste0("#", paste0(sprintf("%02x", x), collapse = "")))

    if(!missing(style)) {
        style <- match.arg(style)
        switch(style, line = {
            height <- 0
            lab.below <- FALSE
        }, bar = {
            height <- .25
            double.bar <- FALSE
            lab.below <- TRUE
            fill <- col2
            tcl <- c(.25, 0)
            fine.part <- TRUE
        }, double = {
            height <- .35
            double.bar <- TRUE
            lab.below <- TRUE
            fill <- col2
            tcl <- c(0, 0)
            fine.part <- TRUE
        })
    }
    
    I2Ux <- function(x) grconvertX(x, from = "inch", to = "user")
    I2Uy <- function(x) grconvertY(x, from = "inch", to = "user")
    U2Ix <- function(x) grconvertX(x, from = "user", to = "inch")
    U2Iy <- function(x) grconvertY(x, from = "user", to = "inch")
    
    pos <- match.arg(pos, several.ok = TRUE)
    usr <- par("usr")
    dusrx <- usr[2L] - usr[1L]
    
    xa <- pretty(c(0, dusrx/mapunit * width), n = 2, min.n = 1)
   
    if(isTRUE(fine.part)) fine.part <- median(xa)
    if((is.numeric(fine.part) && fine.part < xa[length(xa)])) {
        x <- c(pretty(c(0, fine.part), n = max(n, 1), min.n = 1),
            xa[length(xa)])
        nx <- length(x)
        tckmain <-  c(1L, if(nx > 2 && !isTRUE(extreme.ticks)) nx - 1L, nx)
    } else {
        x <- pretty(c(0, dusrx/mapunit * width), n = max(n, 1), min.n = 1)
        tckmain <- c(1L, length(x))
    }
    N <- length(x)
    tcktype <- rep(2L, N)
    tcktype[tckmain] <- 1L
        
    
    if("right" %in% pos) {
        x2 <- I2Ux(U2Ix(usr[2L]) - offx)
        x1 <- x2 - (x[N] * mapunit)
    } else { # if("left" %in% pos)
        x1 <- I2Ux(U2Ix(usr[1L]) + offx)
        x2 <- x1 + (x[N] * mapunit)
    }
    if("bottom" %in% pos) {
        y1 <- I2Uy(U2Iy(usr[3L]) + offy)
    } else { # if("top" %in% pos)
        y1 <- I2Uy(U2Iy(usr[4L]) - offy)
    }
    x12 <- x1 + x * mapunit
    
    lineheight <- (strheight("X\nX\nX", cex = cex) - strheight("X", cex = cex)) / 2
    
    #lineheight  <- strheight("X", cex = cex)
    
    if(height > 0) {
        h <- lineheight * height
        if(double.bar) {
            rect(x12[-length(x12)], y1, x12[-1L], y1 - (h / 2), col = fill, border = col,
                 lwd = lwd, lty = lty, ...)
            rect(x12[-length(x12)], y1 - (h / 2), x12[-1L], y1 - h, col = rev(fill), border = col,
                 lwd = lwd, lty = lty, ...)

        } else {
            rect(x12[-length(x12)], y1, x12[-1L], y1 - h, col = fill, border = col,
                 lwd = lwd, lty = lty, ...)
        }
        
    } else h <- 0

    tcl <- rep(tcl, length.out = 2L)[tcktype]
    tclen <- lineheight * tcl
    tcy <- ifelse(tcl < 0, y1 - h, y1)
   
    segments(x1, y1, x2, y1, col = col, ...)
    segments(x12, tcy, x12, tcy + tclen, col = col, ...)
    
    lab <- format(x)
    #koBrowseHere()
    
    ylab <- y1 - h + min(c(0, tclen))
    
    if(lab.below) {
        lx <- range(x12)
        text(lx[1] + (diff(lx) /2), ylab, unitname,
             adj = c(0.4, 2.5 + line.lab), lheight = 1, cex = cex.lab, ...)
    } else {
        lab[length(lab)] <- paste(lab[length(lab)], unitname)
    }
    text(x12, ylab, lab, adj = c(0.4, 1 + line.lab), lheight = 1, cex = cex.lab, ...)
}

plot(c(0, 1000), c(0, 10000), type = "n", xlab = NA, ylab = NA, asp = 1)

mapscale(mapunit = 1000,
         pos = c("top", "left"), style = "bar",
         cex.lab = .5, n = 3)
mapscale(mapunit = 1000,
         pos = c("top", "left"), style = "double",
         offy = 1, cex.lab = .5, width = .2)
mapscale(mapunit = 1000,
         pos = c("bottom", "left"), style = "line",
         offy = .4, cex.lab = .5, n = 2)

mapscale(mapunit = 1000, pos = c("top", "right"), double.bar = FALSE,
         height = .5, fill = c("black", "white"),
         offy = .1, offx = .2, cex.lab = .5, n = 3)

mapscale(mapunit = 1000, pos = c("top", "right"), double.bar = TRUE,
         height = .5, fill = c("black", "white"),
         fine.part = TRUE,
         offy = .9, offx = .2, cex.lab = .5, n = 4)

mapscale(mapunit = 1000, pos = c("bottom", "right"), 
         height = 0, fill = c("black", "white"),
         lab.below = TRUE, tcl = .5,
         fine.part = TRUE,
         offy = .4, offx = .2, cex.lab = .5, n = 4)