show source code for function in R

Question

I can use lm or class::knn to view the source code, but I failed to show the code for princomp. Was this function written in R or some other bytecode used. I also could not find the source code using advises from How do I show the source code of an S4 function in a package?. Thanks for any help.

> princomp

function (x, ...) 

UseMethod("princomp")

<bytecode: 0x9490010>

<environment: namespace:stats>

Answer 1

You can use the following method:

princomp # this is what you did without having a good enough answer

methods(princomp) # Next step, ask for the method: 'princomp.default'

getAnywhere('princomp.default') # this will show you the code

The code you are looking for is:

function (x, cor = FALSE, scores = TRUE, covmat = NULL, subset = rep(TRUE, 

    nrow(as.matrix(x))), ...) 

{

    cl <- match.call()

    cl[[1L]] <- as.name("princomp")

    if (!missing(x) && !missing(covmat)) 

        warning("both 'x' and 'covmat' were supplied: 'x' will be ignored")

    z <- if (!missing(x)) 

        as.matrix(x)[subset, , drop = FALSE]

    if (is.list(covmat)) {

        if (any(is.na(match(c("cov", "n.obs"), names(covmat))))) 

            stop("'covmat' is not a valid covariance list")

        cv <- covmat$cov

        n.obs <- covmat$n.obs

        cen <- covmat$center

    }

    else if (is.matrix(covmat)) {

        cv <- covmat

        n.obs <- NA

        cen <- NULL

    }

    else if (is.null(covmat)) {

        dn <- dim(z)

        if (dn[1L] < dn[2L]) 

            stop("'princomp' can only be used with more units than variables")

        covmat <- cov.wt(z)

        n.obs <- covmat$n.obs

        cv <- covmat$cov * (1 - 1/n.obs)

        cen <- covmat$center

    }

    else stop("'covmat' is of unknown type")

    if (!is.numeric(cv)) 

        stop("PCA applies only to numerical variables")

    if (cor) {

        sds <- sqrt(diag(cv))

        if (any(sds == 0)) 

            stop("cannot use cor=TRUE with a constant variable")

        cv <- cv/(sds %o% sds)

    }

    edc <- eigen(cv, symmetric = TRUE)

    ev <- edc$values

    if (any(neg <- ev < 0)) {

        if (any(ev[neg] < -9 * .Machine$double.eps * ev[1L])) 

            stop("covariance matrix is not non-negative definite")

        else ev[neg] <- 0

    }

    cn <- paste("Comp.", 1L:ncol(cv), sep = "")

    names(ev) <- cn

    dimnames(edc$vectors) <- if (missing(x)) 

        list(dimnames(cv)[[2L]], cn)

    else list(dimnames(x)[[2L]], cn)

    sdev <- sqrt(ev)

    sc <- if (cor) 

        sds

    else rep(1, ncol(cv))

    names(sc) <- colnames(cv)

    scr <- if (scores && !missing(x) && !is.null(cen)) 

        scale(z, center = cen, scale = sc) %*% edc$vectors

    if (is.null(cen)) 

        cen <- rep(NA_real_, nrow(cv))

    edc <- list(sdev = sdev, loadings = structure(edc$vectors, 

       class = "loadings"), center = cen, scale = sc, n.obs = n.obs, 

        scores = scr, call = cl)

    class(edc) <- "princomp"

    edc

}

<environment: namespace:stats>

Hope this answer helps you!