2012-05-28 12 views
13

Puedo usar lm o class::knn para ver el código fuente, pero no pude mostrar el código para princomp. Fue esta función (u otra cosa) escrita en R u otro bytecode utilizado. Tampoco pude encontrar el código fuente usando los avisos de How do I show the source code of an S4 function in a package?. Gracias por cualquier ayuda.muestra el código fuente para la función en R

> princomp 
function (x, ...) 
UseMethod("princomp") 
<bytecode: 0x9490010> 
<environment: namespace:stats> 

Respuesta

34

usted tiene que pedir mediante el correspondiente método utilizado por la función. Prueba esto:

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 

El código que busca es:

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> 

Creo que esto lo que estaba pidiendo.

Cuestiones relacionadas