求R语言rms包的calibrate函数源代码

是 否 +2 论坛币

k人 参与回答

经管之家送您一份

应届毕业生专属福利!

求职就业群

赵安豆老师微信：zhaoandou666

经管之家联合CDA

送您一个全额奖学金名额~ !

立即领取

感谢您参与论坛问题回答

经管之家送您两个论坛币！

+2 论坛币

请问谁知道rms包的calibrate函数源代码，我想研究一下，找了好久没找到

扫码加我 拉你入群

请注明：姓名-公司-职位

以便审核进群资格，未注明则拒绝

分享0 收藏0 回帖

关键词：calibrate Rate lib R语言 bra

rms 6.2-0 calibrate的源代码：

1. function (fit, predy, method = c("boot", "crossvalidation",
   
2.     ".632", "randomization"), B = 40, bw = FALSE,
   
3.     rule = c("aic", "p"), type = c("residual",
   
4.         "individual"), sls = 0.05, aics = 0, force = NULL,
   
5.     estimates = TRUE, pr = FALSE, kint, smoother = "lowess",
   
6.     digits = NULL, ...)
   
7. {
   
8.     call <- match.call()
   
9.     method <- match.arg(method)
   
10.     rule <- match.arg(rule)
    
11.     type <- match.arg(type)
    
12.     ns <- num.intercepts(fit)
    
13.     if (missing(kint))
    
14.         kint <- floor((ns + 1)/2)
    
15.     clas <- attr(fit, "class")
    
16.     model <- if (any(clas == "lrm"))
    
17.         "lr"
    
18.     else if (any(clas == "ols"))
    
19.         "ol"
    
20.     else stop("fit must be from lrm or ols")
    
21.     lev.name <- NULL
    
22.     yvar.name <- as.character(formula(fit))[2]
    
23.     y <- fit$y
    
24.     n <- length(y)
    
25.     if (length(y) == 0)
    
26.         stop("fit did not use x=TRUE,y=TRUE")
    
27.     if (model == "lr") {
    
28.         y <- factor(y)
    
29.         lev.name <- levels(y)[kint + 1]
    
30.         fit$y <- as.integer(y) - 1
    
31.     }
    
32.     predicted <- if (model == "lr")
    
33.         plogis(fit$linear.predictors - fit$coefficients[1] +
    
34.             fit$coefficients[kint])
    
35.     else fit$linear.predictors
    
36.     if (missing(predy)) {
    
37.         if (n < 11)
    
38.             stop("must have n > 10 if do not specify predy")
    
39.         p <- sort(predicted)
    
40.         predy <- seq(p[5], p[n - 4], length = 50)
    
41.         p <- NULL
    
42.     }
    
43.     penalty.matrix <- fit$penalty.matrix
    
44.     cal.error <- function(x, y, iter, smoother, predy, kint,
    
45.         model, digits = NULL, ...) {
    
46.         if (model == "lr") {
    
47.             x <- plogis(x)
    
48.             y <- y >= kint
    
49.         }
    
50.         if (length(digits))
    
51.             x <- round(x, digits)
    
52.         smo <- if (is.function(smoother))
    
53.             smoother(x, y)
    
54.         else lowess(x, y, iter = 0)
    
55.         cal <- approx(smo, xout = predy, ties = function(x) x[1])$y
    
56.         if (iter == 0)
    
57.             structure(cal - predy, keepinfo = list(orig.cal = cal))
    
58.         else cal - predy
    
59.     }
    
60.     fitit <- function(x, y, model, penalty.matrix = NULL, xcol = NULL,
    
61.         ...) {
    
62.         if (length(penalty.matrix) && length(xcol)) {
    
63.             if (model == "ol")
    
64.                 xcol <- xcol[-1] - 1
    
65.             penalty.matrix <- penalty.matrix[xcol, xcol, drop = FALSE]
    
66.         }
    
67.         f <- switch(model, lr = lrm.fit(x, y, penalty.matrix = penalty.matrix,
    
68.             tol = 1e-13), ol = if (length(penalty.matrix) ==
    
69.             0) {
    
70.             w <- lm.fit.qr.bare(x, y, intercept = TRUE, xpxi = TRUE)
    
71.             w$var <- w$xpxi * sum(w$residuals^2)/(length(y) -
    
72.                 length(w$coefficients))
    
73.             w
    
74.         } else lm.pfit(x, y, penalty.matrix = penalty.matrix))
    
75.         if (any(is.na(f$coefficients)))
    
76.             f$fail <- TRUE
    
77.         f
    
78.     }
    
79.     z <- predab.resample(fit, method = method, fit = fitit, measure = cal.error,
    
80.         pr = pr, B = B, bw = bw, rule = rule, type = type, sls = sls,
    
81.         aics = aics, force = force, estimates = estimates, non.slopes.in.x = model ==
    
82.             "ol", smoother = smoother, predy = predy, model = model,
    
83.         kint = kint, penalty.matrix = penalty.matrix, ...)
    
84.     orig.cal <- attr(z, "keepinfo")$orig.cal
    
85.     z <- cbind(predy, calibrated.orig = orig.cal, calibrated.corrected = orig.cal -
    
86.         z[, "optimism"], z)
    
87.     structure(z, class = "calibrate.default", call = call,
    
88.         kint = kint, model = model, lev.name = lev.name, yvar.name = yvar.name,
    
89.         n = n, freq = fit$freq, non.slopes = ns, B = B, method = method,
    
90.         predicted = predicted, smoother = smoother)
    
91. }

复制代码

llb_321 发表于 2022-5-30 14:50
rms 6.2-0 calibrate的源代码：

感谢大神

llb_321 发表于 2022-5-30 14:50
rms 6.2-0 calibrate的源代码：

大神方便说一下怎么找到的吗？我把rms包下载下来也没看见这个函数的源代码

liuqiang0704 发表于 2022-5-31 00:32
大神方便说一下怎么找到的吗？我把rms包下载下来也没看见这个函数的源代码

1. library(rms)
   
2. getAnywhere(calibrate.default)

复制代码

llb_321 发表于 2022-5-31 11:19

非常感谢