Loading source codes for functions 1: cut & paste

Loading Source Code By Hand

Every command in R is written in computer code the delivers commands to the computer. Some of this code is R code and if we want to see it we can. Much of it is written in another programming language (eg C++) that we can’t view or otherwise hidden from view

There are times when it might be necessary to load the code for a function by hand into R. This usually happens when someone has written a custom function and posted the code to a website or published it in a paper.

Some of our computers in the lab are having trouble downloading packages from the internet b/c of the network. The package Hmisc has a function errbar that I would like to use. This code is pasted below. We can copy and paste this code into the R console and it should then allow us to use the errbar function.

Source code for Hmisc::errbar

• Copy all of this code, paste it into the consol, and press enter.
• If you then type just “errbar” the code should be spit back at you if its been loaded.
• Since we don’t have the full Hmisc package loaded, ?errbar WILL NOT bring up the help fille.

# Source code for Hmisc:errbar
# Package authored by Frank E Harrell Jr.
# https://cran.r-project.org/web/packages/Hmisc/index.html

errbar <- function (x, y, yplus, yminus, cap = 0.015, main = NULL, sub = NULL, 
          xlab = as.character(substitute(x)), ylab = if (is.factor(x) || 
                                                         is.character(x)) "" else as.character(substitute(y)), 
          add = FALSE, lty = 1, type = "p", ylim = NULL, lwd = 1, pch = 16, 
          errbar.col = par("fg"), Type = rep(1, length(y)), ...) 
{
  if (is.null(ylim)) 
    ylim <- range(y[Type == 1], yplus[Type == 1], yminus[Type == 
                                                           1], na.rm = TRUE)
  if (is.factor(x) || is.character(x)) {
    x <- as.character(x)
    n <- length(x)
    t1 <- Type == 1
    t2 <- Type == 2
    n1 <- sum(t1)
    n2 <- sum(t2)
    omai <- par("mai")
    mai <- omai
    mai[2] <- max(strwidth(x, "inches")) + 0.25
    par(mai = mai)
    on.exit(par(mai = omai))
    plot(NA, NA, xlab = ylab, ylab = "", xlim = ylim, ylim = c(1, 
                                                               n + 1), axes = FALSE, ...)
    axis(1)
    w <- if (any(t2)) 
      n1 + (1:n2) + 1
    else numeric(0)
    axis(2, at = c(seq.int(length.out = n1), w), labels = c(x[t1], 
                                                            x[t2]), las = 1, adj = 1)
    points(y[t1], seq.int(length.out = n1), pch = pch, type = type, 
           ...)
    segments(yplus[t1], seq.int(length.out = n1), yminus[t1], 
             seq.int(length.out = n1), lwd = lwd, lty = lty, col = errbar.col)
    if (any(Type == 2)) {
      abline(h = n1 + 1, lty = 2, ...)
      offset <- mean(y[t1]) - mean(y[t2])
      if (min(yminus[t2]) < 0 & max(yplus[t2]) > 0) 
        lines(c(0, 0) + offset, c(n1 + 1, par("usr")[4]), 
              lty = 2, ...)
      points(y[t2] + offset, w, pch = pch, type = type, 
             ...)
      segments(yminus[t2] + offset, w, yplus[t2] + offset, 
               w, lwd = lwd, lty = lty, col = errbar.col)
      at <- pretty(range(y[t2], yplus[t2], yminus[t2]))
      axis(side = 3, at = at + offset, labels = format(round(at, 
                                                             6)))
    }
    return(invisible())
  }
  if (add) 
    points(x, y, pch = pch, type = type, ...)
  else plot(x, y, ylim = ylim, xlab = xlab, ylab = ylab, pch = pch, 
            type = type, ...)
  xcoord <- par()$usr[1:2]
  smidge <- cap * (xcoord[2] - xcoord[1])/2
  segments(x, yminus, x, yplus, lty = lty, lwd = lwd, col = errbar.col)
  if (par()$xlog) {
    xstart <- x * 10^(-smidge)
    xend <- x * 10^(smidge)
  }
  else {
    xstart <- x - smidge
    xend <- x + smidge
  }
  segments(xstart, yminus, xend, yminus, lwd = lwd, lty = lty, 
           col = errbar.col)
  segments(xstart, yplus, xend, yplus, lwd = lwd, lty = lty, 
           col = errbar.col)
  return(invisible())
}

Testing the function

You can test the function with this code

Load some test data into a format errbar() can take

x.test <- c(1,5,10)
y.test <- c(2,2,2)
y.plus <- y.test+2
y.minus <- y.test-2

Then run the errbar() command

errbar(x = x.test,
       y = y.test, 
       yplus = y.plus, 
       yminus = y.minus)