Skip to content

Commit bf5d156

Browse files
davidruegamerdavidruegamer
authored
Merge pull request #43 from m-muecke/inherits
refactor: use `inherits()` for checking S3 class
2 parents 44b0ad9 + a480818 commit bf5d156

File tree

8 files changed

+52
-52
lines changed

8 files changed

+52
-52
lines changed

‎R/FDboost.R‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -474,12 +474,12 @@ FDboost <- function(formula, ### response ~ xvars
474474
if(inherits(try(id), "try-error")) stop("id must either be NULL or a formula object.")
475475
if(missing(timeformula) || inherits(try(timeformula), "try-error"))
476476
stop("timeformula must either be NULL or a formula object.")
477-
stopifnot(class(formula) == "formula")
478-
if(!is.null(timeformula)) stopifnot(class(timeformula) == "formula")
477+
stopifnot(inherits(formula, "formula"))
478+
if(!is.null(timeformula)) stopifnot(inherits(timeformula, "formula"))
479479

480480
## insert the id variable into the formula, to treat it like the other variables
481481
if(!is.null(id)){
482-
stopifnot(class(id) == "formula")
482+
stopifnot(inherits(id, "formula"))
483483
##tf <- terms.formula(formula, specials = c("c"))
484484
##trmstrings <- attr(tf, "term.labels")
485485
##equalBrackets <- NULL

‎R/FDboostLSS.R‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -209,7 +209,7 @@ cvrisk.FDboostLSS <- function(object, folds = cvLong(id = object[[1]]$id,
209209
## set up grid according to defaults of cvrisk.nc_mboostLSS and cvrisk.mboostLSS
210210
if(is.null(grid)){
211211

212-
if(any(class(object) == "nc_mboostLSS")){
212+
if(inherits(object, "nc_mboostLSS")){
213213
grid <- 1:sum(mstop(object))
214214
}else{
215215
grid <- make.grid(mstop(object))

‎R/bootstrapCIs.R‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -186,7 +186,7 @@ bootstrapCI <- function(object, which = NULL,
186186
type_inner <- match.arg(type_inner)
187187

188188
########## check for scalar response #########
189-
scalarResp <- "FDboostScalar" %in% class(object)
189+
scalarResp <- inherits(object, "FDboostScalar")
190190

191191
########## define outer resampling function if NULL #########
192192
if(is.null(resampling_fun_outer)){
@@ -498,7 +498,7 @@ plot.bootstrapCI <- function(x, which = NULL, pers = TRUE,
498498
ylim = NULL, ...)
499499
{
500500

501-
stopifnot(class(x) == "bootstrapCI")
501+
stopifnot(inherits(x, "bootstrapCI"))
502502

503503
boot_offset <- 0
504504

@@ -598,7 +598,7 @@ plot.bootstrapCI <- function(x, which = NULL, pers = TRUE,
598598
print.bootstrapCI <- function(x, ...)
599599
{
600600

601-
stopifnot(class(x)=="bootstrapCI")
601+
stopifnot(inherits(x, "bootstrapCI"))
602602

603603
cat("\n")
604604

‎R/constrainedX.R‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -211,7 +211,7 @@
211211
## use whole matrices of marginal effects for constraints as Almond suggested
212212
C <- t(X) %*% cbind(rep(1, nrow(X)), X1, X2)
213213
qr_C <- qr(C) ## , tol = 1e-10 ## time?
214-
if( any(class(qr_C) == "sparseQR") ){
214+
if( inherits(qr_C, "sparseQR") ){
215215
rank_C <- qr_C@Dim[2]
216216
}else{
217217
rank_C <- qr_C$rank

‎R/crossvalidation.R‎

Lines changed: 22 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -172,7 +172,7 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ
172172
stop("The folds-matrix must have one row per observed trajectory.")
173173
}
174174

175-
if(any(class(object) == "FDboostLong")){ # irregular response
175+
if(inherits(object, "FDboostLong")){ # irregular response
176176
nObs <- length(unique(object$id)) # number of curves
177177
Gy <- NULL # number of time-points per curve
178178
}else{ # regular response / scalar response
@@ -201,7 +201,7 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ
201201
}else{
202202

203203
if(numInt == "Riemann"){ # use the integration scheme specified in applyFolds
204-
if(!any(class(object) == "FDboostLong")){
204+
if(!inherits(object, "FDboostLong")){
205205
integration_weights <- as.vector(integrationWeights(X1 = matrix(object$response,
206206
ncol = object$ydim[2]), object$yind))
207207
}else{
@@ -216,7 +216,7 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ
216216

217217
### get yind in long format
218218
yindLong <- object$yind
219-
if(!any(class(object) == "FDboostLong")){
219+
if(!inherits(object, "FDboostLong")){
220220
yindLong <- rep(object$yind, each = nObs)
221221
}
222222
### compute ("length of each trajectory")^-1 in the response
@@ -255,7 +255,7 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ
255255
}
256256
}
257257

258-
if(!any(class(object) == "FDboostLong") && !any(class(object) == "FDboostScalar")){
258+
if(!inherits(object, "FDboostLong") && !inherits(object, "FDboostScalar")){
259259
dathelp[[object$yname]] <- matrix(object$response, ncol=object$ydim[2])
260260
dathelp$integration_weights <- matrix(integration_weights, ncol=object$ydim[2])
261261
dathelp$object_id <- object$id
@@ -279,13 +279,13 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ
279279
names_variables <- names_variables[names_variables != nameyind]
280280
names_variables <- names_variables[names_variables != "ONEx"]
281281
names_variables <- names_variables[names_variables != "ONEtime"]
282-
if(!any(class(object) == "FDboostLong")) names_variables <- c(object$yname, "integration_weights", names_variables)
282+
if(!inherits(object, "FDboostLong")) names_variables <- c(object$yname, "integration_weights", names_variables)
283283

284-
length_variables <- if("FDboostScalar" %in% class(object))
284+
length_variables <- if(inherits(object, "FDboostScalar"))
285285
lapply(dathelp[names_variables], length) else
286286
lapply(dathelp[names_variables], NROW)
287287
names_variables_long <- names_variables[ length_variables == length(object$id) ]
288-
nothmatrix <- ! sapply(dathelp[names_variables_long], function(x) any(class(x) == "hmatrix" ))
288+
nothmatrix <- ! sapply(dathelp[names_variables_long], is.hmatrix)
289289
names_variables_long <- names_variables_long[ nothmatrix ]
290290
if(identical(names_variables_long, character(0))) names_variables_long <- NULL
291291

@@ -330,7 +330,7 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ
330330
fitfct <- function(weights, oobweights){
331331

332332
## get data according to weights
333-
if(any(class(object) == "FDboostLong")){
333+
if(inherits(object, "FDboostLong")){
334334
dat_weights <- reweightData(data = dathelp, vars = names_variables,
335335
longvars = c(object$yname, nameyind, "integration_weights", names_variables_long),
336336
weights = weights, idvars = c(attr(object$id, "nameid"), index_names),
@@ -403,7 +403,7 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ
403403
}
404404

405405
## get data according to oobweights
406-
if(any(class(object) == "FDboostLong")){
406+
if(inherits(object, "FDboostLong")){
407407
dathelp$lengthTi1 <- c(lengthTi1)
408408
dat_oobweights <- reweightData(data = dathelp, vars = c(names_variables, "lengthTi1"),
409409
longvars = c(object$yname, nameyind,
@@ -449,7 +449,7 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ
449449
invokeRestart( "muffleWarning" )
450450
}
451451

452-
if(any(class(object) == "FDboostLong")){
452+
if(inherits(object, "FDboostLong")){
453453

454454
if(numInt == "equal"){
455455
oobwstand <- dat_oobweights$integration_weights * (1/sum(dat_oobweights$integration_weights))
@@ -715,7 +715,7 @@ validateFDboost <- function(object, response = NULL,
715715
stop("The folds-matrix must have one row per observed trajectory.")
716716
}
717717

718-
if(any(class(object) == "FDboostLong")){ # irregular response
718+
if(inherits(object, "FDboostLong")){ # irregular response
719719
nObs <- length(unique(object$id)) # number of curves
720720
Gy <- NULL # number of time-points per curve
721721
}else{ # regular response / scalar response
@@ -739,7 +739,7 @@ validateFDboost <- function(object, response = NULL,
739739
# intWeights <- model.weights(object)
740740
# weights are rescaled in mboost, see mboost:::rescale_weights
741741
if(!is.null(object$callEval$numInt) && object$callEval$numInt == "Riemann"){
742-
if(!any(class(object) == "FDboostLong")){
742+
if(!inherits(object, "FDboostLong")){
743743
intWeights <- as.vector(integrationWeights(X1 = matrix(object$response,
744744
ncol = object$ydim[2]), object$yind))
745745
}else{
@@ -761,7 +761,7 @@ validateFDboost <- function(object, response = NULL,
761761

762762
### get yind in long format
763763
yindLong <- object$yind
764-
if(!any(class(object) == "FDboostLong")){
764+
if(!inherits(object, "FDboostLong")){
765765
yindLong <- rep(object$yind, each = nObs)
766766
}
767767
### compute ("length of each trajectory")^-1 in the response
@@ -783,7 +783,7 @@ validateFDboost <- function(object, response = NULL,
783783
nameyind <- attr(object$yind, "nameyind")
784784
dathelp[[nameyind]] <- object$yind
785785

786-
if(!any(class(object) == "FDboostLong") && !any(class(object) == "FDboostScalar")){
786+
if(!inherits(object, "FDboostLong") && !inherits(object, "FDboostScalar")){
787787
dathelp[[object$yname]] <- matrix(object$response, ncol = Gy)
788788
}else{
789789
dathelp[[object$yname]] <- object$response
@@ -801,7 +801,7 @@ validateFDboost <- function(object, response = NULL,
801801
# call$control <- boost_control(risk="oobag")
802802
# call$oobweights <- oobweights[id]
803803
if(refitSmoothOffset == FALSE && is.null(call$offset) ){
804-
if(!any(class(object) == "FDboostLong")){
804+
if(!inherits(object, "FDboostLong")){
805805
call$offset <- matrix(object$offset, ncol = Gy)[1, ]
806806
}else{
807807
call$offset <- object$offset
@@ -908,7 +908,7 @@ validateFDboost <- function(object, response = NULL,
908908
# str(modRisk, max.level=5)
909909

910910
# check whether model fit worked in all iterations
911-
modFitted <- sapply(modRisk, function(x) class(x) == "list")
911+
modFitted <- sapply(modRisk, is.list)
912912
if(any(!modFitted)){
913913

914914
# stop() or warning()?
@@ -962,7 +962,7 @@ validateFDboost <- function(object, response = NULL,
962962
oobpreds0 <- lapply(modRisk, function(x) x$predGrid)
963963
oobpreds <- matrix(nrow = nrow(oobpreds0[[1]]), ncol = ncol(oobpreds0[[1]]))
964964

965-
if(any(class(object) == "FDboostLong")){
965+
if(inherits(object, "FDboostLong")){
966966
for(i in seq_along(oobpreds0)){ # i runs over observed trajectories, i.e. over id
967967
oobpreds[id == i, ] <- oobpreds0[[i]][id == i, ]
968968
}
@@ -1068,7 +1068,7 @@ validateFDboost <- function(object, response = NULL,
10681068
# offset is vector of length yind or numeric of length 1 for constant offset
10691069
ret <- modRisk[[g]]$mod[optimalMstop]$predictOffset(object$yind)
10701070
# regular data or scalar response
1071-
if(!any(class(object) == "FDboostLong")){
1071+
if(!inherits(object, "FDboostLong")){
10721072
if( length(ret) == 1 ) ret <- rep(ret, modRisk[[1]]$mod$ydim[2])
10731073
# irregular data
10741074
}else{
@@ -1077,13 +1077,13 @@ validateFDboost <- function(object, response = NULL,
10771077
}else{ # other effects
10781078
ret <- predict(modRisk[[g]]$mod[optimalMstop], which = l-1) # model g
10791079
if(!(l-1) %in% selected(modRisk[[g]]$mod[optimalMstop]) ){ # effect was never chosen
1080-
if(!any(class(object) == "FDboostLong")){
1080+
if(!inherits(object, "FDboostLong")){
10811081
ret <- matrix(0, ncol=modRisk[[1]]$mod$ydim[2], nrow=modRisk[[1]]$mod$ydim[1])
10821082
}else{
10831083
ret <- matrix(0, nrow = length(object$id), ncol=1)
10841084
}
10851085
}
1086-
if(!any(class(object) == "FDboostLong")){
1086+
if(!inherits(object, "FDboostLong")){
10871087
ret <- ret[g,] # save g-th row = preds for g-th observations
10881088
}else{
10891089
ret <- ret[object$id == g] # save preds of g-th observations
@@ -1112,7 +1112,7 @@ validateFDboost <- function(object, response = NULL,
11121112
oobrisk0 = oobrisk0,
11131113
oobmse0 = oobmse0,
11141114
oobmrd0 = oobmrd0,
1115-
format = if(any(class(object) == "FDboostLong")) "FDboostLong" else "FDboost",
1115+
format = if(inherits(object, "FDboostLong")) "FDboostLong" else "FDboost",
11161116
fun_ret = if(is.null(fun)) NULL else lapply(modRisk, function(x) x$fun_ret) )
11171117

11181118
rm(modRisk)
@@ -1354,7 +1354,7 @@ plotPredCoef <- function(x, which = NULL, pers = TRUE,
13541354
probs = c(0.25, 0.5, 0.75), # quantiles of variables to use for plotting
13551355
ylim = NULL, ...){
13561356

1357-
stopifnot(any(class(x) == "validateFDboost"))
1357+
stopifnot(inherits(x, "validateFDboost"))
13581358

13591359
if(is.null(which)) which <- seq_along(x$coefCV)
13601360

‎R/methods.R‎

Lines changed: 7 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -104,12 +104,12 @@ print.FDboost <- function(x, ...) {
104104
# predict function: wrapper for predict.mboost()
105105
predict.FDboost <- function(object, newdata = NULL, which = NULL, toFDboost = TRUE, ...){
106106

107-
stopifnot(any(class(object) == "FDboost"))
107+
stopifnot(inherits(object, "FDboost"))
108108
# print("Prediction FDboost")
109109
dots <- list(...)
110110

111111
# toFDboost is only meaningful for array-data
112-
if(any(class(object) == "FDboostScalar") || any(class(object) == "FDboostLong")) toFDboost <- FALSE
112+
if(inherits(object, c("FDboostScalar", "FDboostLong"))) toFDboost <- FALSE
113113

114114
if(!is.null(dots$aggregate) && dots$aggregate[1] != "sum"){
115115
if(length(which) > 1 ) stop("For aggregate != 'sum', only one effect, or which=NULL are possible.")
@@ -438,7 +438,7 @@ fitted.FDboost <- function(object, toFDboost = TRUE, ...) {
438438

439439
if (length(args) == 0) {
440440
## give back matrix for regular response and toFDboost == TRUE
441-
if(toFDboost && !any(class(object) == "FDboostScalar") && !any(class(object) == "FDboostLong") ){
441+
if(toFDboost && !inherits(object, "FDboostScalar") && !inherits(object, "FDboostLong") ){
442442
ret <- matrix(object$fitted(), nrow = object$ydim[1])
443443
}else{ # give back a long vector
444444
ret <- object$fitted()
@@ -478,7 +478,7 @@ fitted.FDboost <- function(object, toFDboost = TRUE, ...) {
478478
### residuals (the current negative gradient)
479479
residuals.FDboost <- function(object, ...){
480480

481-
if(!any(class(object)=="FDboostLong")){
481+
if(!inherits(object, "FDboostLong")){
482482
resid <- matrix(object$resid())
483483
ydim <- ifelse(is.null(object$ydim[1]), NROW(resid), object$ydim[1])
484484
resid <- matrix(resid, nrow = ydim)
@@ -1050,8 +1050,8 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL,
10501050
if(!is.matrix(predHelp)){
10511051
X <- predHelp
10521052
}else{
1053-
X <- if(any(trm$get_names() %in% "ONEtime") ||
1054-
any(class(object)=="FDboostScalar")){ # effect constant in t
1053+
X <- if(any(trm$get_names() %in% c("ONEtime")) ||
1054+
inherits(object, "FDboostScalar")){ # effect constant in t
10551055
predHelp[,1]
10561056
}else{
10571057
predHelp[1,] # smooth intercept/ concurrent effect
@@ -1622,7 +1622,7 @@ plot.FDboost <- function(x, raw = FALSE, rug = TRUE, which = NULL,
16221622
if(grepl("bhist", trm$main)){
16231623
rug(x$yind, ticksize = 0.02)
16241624
}else{
1625-
ifelse(grepl("by", trm$main) | ( !any(class(x)=="FDboostLong") && grepl("%X", trm$main) ) ,
1625+
ifelse(grepl("by", trm$main) | ( !inherits(x, "FDboostLong") && grepl("%X", trm$main) ) ,
16261626
rug(bl_data[[i]][[3]], ticksize = 0.02),
16271627
rug(bl_data[[i]][[2]], ticksize = 0.02))
16281628
}

‎R/stabsel.R‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -148,7 +148,7 @@ stabsel.FDboost <- function(x, refitSmoothOffset = TRUE,
148148
}
149149

150150
## for scalar response and/or scalar offset, use the more efficient cvrisk()
151-
if( any(class(x) == "FDboostScalar" ) ) refitSmoothOffset <- FALSE
151+
if( inherits(x, "FDboostScalar" ) ) refitSmoothOffset <- FALSE
152152
if( !is.null(x$call$offset) && x$call$offset == "scalar" ) refitSmoothOffset <- FALSE
153153

154154
if(refitSmoothOffset){

0 commit comments

Comments
 (0)