查看R源代码的六种方法
查看R源代码的六种方法
不最醉不龟归 发表于5个月前
查看R源代码的六种方法
  • 发表于 5个月前
  • 阅读 6
  • 收藏 0
  • 点赞 0
  • 评论 0

腾讯云实验室 1小时搭建人工智能应用,让技术更容易入门 免费体验 >>>   

> methods(length)
[1] length.pdf_doc* length.POSIXlt 
see '?methods' for accessing help and source code
> length.POSIXlt
function (x) 
length(x[[1L]])
<bytecode: 0x00000000111d75b0>
<environment: namespace:base>
 

-------------------------------------------------------------------------

 

 

方法一:直接写函数名称,如在R中查看回归分析代码:

  1. lm

复制代码


直接可以查看到

  1. function (formula, data, subset, weights, na.action, method = "qr", 
  2.     model = TRUE, x = FALSE, y = FALSE, qr = TRUE, singular.ok = TRUE, 
  3.     contrasts = NULL, offset, ...) 
  4. {
  5.     ret.x <- x
  6.     ret.y <- y
  7.     cl <- match.call()
  8.     mf <- match.call(expand.dots = FALSE)
  9.     m <- match(c("formula", "data", "subset", "weights", "na.action", 
  10.         "offset"), names(mf), 0L)
  11.     mf <- mf[c(1L, m)]
  12.     mf$drop.unused.levels <- TRUE
  13.     mf[[1L]] <- quote(stats::model.frame)
  14.     mf <- eval(mf, parent.frame())
  15.     if (method == "model.frame") 
  16.         return(mf)
  17.     else if (method != "qr") 
  18.         warning(gettextf("method = '%s' is not supported. Using 'qr'", 
  19.             method), domain = NA)
  20.     mt <- attr(mf, "terms")
  21.     y <- model.response(mf, "numeric")
  22.     w <- as.vector(model.weights(mf))
  23.     if (!is.null(w) && !is.numeric(w)) 
  24.         stop("'weights' must be a numeric vector")
  25.     offset <- as.vector(model.offset(mf))
  26.     if (!is.null(offset)) {
  27.         if (length(offset) != NROW(y)) 
  28.             stop(gettextf("number of offsets is %d, should equal %d (number of observations)", 
  29.                 length(offset), NROW(y)), domain = NA)
  30.     }
  31.     if (is.empty.model(mt)) {
  32.         x <- NULL
  33.         z <- list(coefficients = if (is.matrix(y)) matrix(, 0, 
  34.             3) else numeric(), residuals = y, fitted.values = 0 * 
  35.             y, weights = w, rank = 0L, df.residual = if (!is.null(w)) sum(w != 
  36.             0) else if (is.matrix(y)) nrow(y) else length(y))
  37.         if (!is.null(offset)) {
  38.             z$fitted.values <- offset
  39.             z$residuals <- y - offset
  40.         }
  41.     }
  42.     else {
  43.         x <- model.matrix(mt, mf, contrasts)
  44.         z <- if (is.null(w)) 
  45.             lm.fit(x, y, offset = offset, singular.ok = singular.ok, 
  46.                 ...)
  47.         else lm.wfit(x, y, w, offset = offset, singular.ok = singular.ok, 
  48.             ...)
  49.     }
  50.     class(z) <- c(if (is.matrix(y)) "mlm", "lm")
  51.     z$na.action <- attr(mf, "na.action")
  52.     z$offset <- offset
  53.     z$contrasts <- attr(x, "contrasts")
  54.     z$xlevels <- .getXlevels(mt, mf)
  55.     z$call <- cl
  56.     z$terms <- mt
  57.     if (model) 
  58.         z$model <- mf
  59.     if (ret.x) 
  60.         z$x <- x
  61.     if (ret.y) 
  62.         z$y <- y
  63.     if (!qr) 
  64.         z$qr <- NULL
  65.     z
  66. }
  67.  

复制代码

优点:直接简单。
缺点:并非所有的函数都能通过此方法得到。
原因:R是面向对象设计的程序语言。

方法二:与方法一类似,用函数page(),不过,结果在另一个窗口显示。


方法三:与方法二类似,用函数edit()。

方法四:对于计算方法不同的函数,要用methods()来定义具体的查看对象,如查看函数mean代码,用方法一只能查到

  1. function (x, ...) 
  2. UseMethod("mean")

复制代码

无法得到具体的代码。此时要有methods()来查找mean具体的对象

  1. methods(mean)

复制代码



此时,结果是

[1] mean.Date     mean.default  mean.difftime mean.POSIXct  mean.POSIXlt 

要查看具体名称,如mean.default的代码,直接用代码

  1. mean.default

复制代码


可以看到mean.default的源代码

  1. function (x, trim = 0, na.rm = FALSE, ...) 
  2. {
  3.     if (!is.numeric(x) && !is.complex(x) && !is.logical(x)) {
  4.         warning("argument is not numeric or logical: returning NA")
  5.         return(NA_real_)
  6.     }
  7.     if (na.rm) 
  8.         x <- x[!is.na(x)]
  9.     if (!is.numeric(trim) || length(trim) != 1L) 
  10.         stop("'trim' must be numeric of length one")
  11.     n <- length(x)
  12.     if (trim > 0 && n) {
  13.         if (is.complex(x)) 
  14.             stop("trimmed means are not defined for complex data")
  15.         if (anyNA(x)) 
  16.             return(NA_real_)
  17.         if (trim >= 0.5) 
  18.             return(stats::median(x, na.rm = FALSE))
  19.         lo <- floor(n * trim) + 1
  20.         hi <- n + 1 - lo
  21.         x <- sort.int(x, partial = unique(c(lo, hi)))[lo:hi]
  22.     }
  23.     .Internal(mean(x))
  24. }

复制代码


注意:1. 对于程序包里的函数,需要先调用函数所在的包。
           2.对于methods()得出的类函数中带星号标注的源代码是看不到的。
           3.对于非类函数,不能用此方法。

方法五:对于方法四中methods()得出的类函数中带星号标注的源代码,用函数getAnywhere(),如查找predict函数的源代码。

  1. methods(predict)  

复制代码

结果显示:
[1] predict.ar*                predict.Arima*             predict.arima0*            predict.glm                predict.HoltWinters*       predict.lm                
[7] predict.loess*             predict.mlm*               predict.nls*               predict.poly*              predict.ppr*               predict.prcomp*           
[13] predict.princomp*          predict.smooth.spline*     predict.smooth.spline.fit* predict.StructTS*         


若用命令predict.Arima查看predict.Arima源代码。结果显示:

错误: 找不到对象'predict.Arima'

此时,用

  1. getAnywhere(predict.Arima)

复制代码


这样就可以查看到predict.Arima的源代码。

  1. function (object, n.ahead = 1L, newxreg = NULL, se.fit = TRUE, 
  2.     ...) 
  3. {
  4.     myNCOL <- function(x) if (is.null(x)) 
  5.         0
  6.     else NCOL(x)
  7.     rsd <- object$residuals
  8.     xr <- object$call$xreg
  9.     xreg <- if (!is.null(xr)) 
  10.         eval.parent(xr)
  11.     else NULL
  12.     ncxreg <- myNCOL(xreg)
  13.     if (myNCOL(newxreg) != ncxreg) 
  14.         stop("'xreg' and 'newxreg' have different numbers of columns")
  15.     class(xreg) <- NULL
  16.     xtsp <- tsp(rsd)
  17.     n <- length(rsd)
  18.     arma <- object$arma
  19.     coefs <- object$coef
  20.     narma <- sum(arma[1L:4L])
  21.     if (length(coefs) > narma) {
  22.         if (names(coefs)[narma + 1L] == "intercept") {
  23.             xreg <- cbind(intercept = rep(1, n), xreg)
  24.             newxreg <- cbind(intercept = rep(1, n.ahead), newxreg)
  25.             ncxreg <- ncxreg + 1L
  26.         }
  27.         xm <- if (narma == 0) 
  28.             drop(as.matrix(newxreg) %*% coefs)
  29.         else drop(as.matrix(newxreg) %*% coefs[-(1L:narma)])
  30.     }
  31.     else xm <- 0
  32.     if (arma[2L] > 0L) {
  33.         ma <- coefs[arma[1L] + 1L:arma[2L]]
  34.         if (any(Mod(polyroot(c(1, ma))) < 1)) 
  35.             warning("MA part of model is not invertible")
  36.     }
  37.     if (arma[4L] > 0L) {
  38.         ma <- coefs[sum(arma[1L:3L]) + 1L:arma[4L]]
  39.         if (any(Mod(polyroot(c(1, ma))) < 1)) 
  40.             warning("seasonal MA part of model is not invertible")
  41.     }
  42.     z <- KalmanForecast(n.ahead, object$model)
  43.     pred <- ts(z[[1L]] + xm, start = xtsp[2L] + deltat(rsd), 
  44.         frequency = xtsp[3L])
  45.     if (se.fit) {
  46.         se <- ts(sqrt(z[[2L]] * object$sigma2), start = xtsp[2L] + 
  47.             deltat(rsd), frequency = xtsp[3L])
  48.         return(list(pred = pred, se = se))
  49.     }
  50.     else return(pred)
  51. }
  52.  

复制代码

方法六:直接上CRAN 下载源代码包

流程如下:

1)       登入R主页 http://www.r-project.org/ ,点击 Download 下的CRAN;

2)       选择一个镜像;

3)       里面的Source Code for all Platforms下有各种源码了,对于程序包,点packages;

4)       点选择项Table of available packages, sorted by name;

5)       找到你你想要的包,点击看Package source这一项,用tar.gz封装的,下载解压后就能看见源代码了。


 

很多函数的核心是用C或FORTRAN等写的,利用.C(),.FORTRAN()等函数调用。这种做法是出于计算效率的考虑。

最后,如果真的想阅读组成R系统本身的源代码,在各个CRAN中均有下载。都是精心挑选过的算法,是学习的好材料。同时,你可以看到R系统内部是如何构成的,对于高效使用R有至关重要的作用。


欢迎大家多多和我交流,共同进步。

共有 人打赏支持
粉丝 9
博文 233
码字总数 102776
×
不最醉不龟归
如果觉得我的文章对您有用,请随意打赏。您的支持将鼓励我继续创作!
* 金额(元)
¥1 ¥5 ¥10 ¥20 其他金额
打赏人
留言
* 支付类型
微信扫码支付
打赏金额:
已支付成功
打赏金额: