From 67a9fb490e70059feab924868091090cf05ffd63 Mon Sep 17 00:00:00 2001 From: Maximilian Muecke Date: Sat, 5 Apr 2025 12:17:32 +0200 Subject: [PATCH] refactor: use fixed strings where possible --- R/FDboost.R | 66 +++++++++++++++++----------------- R/crossvalidation.R | 30 ++++++++-------- R/factorize.R | 4 +-- R/methods.R | 86 ++++++++++++++++++++++---------------------- R/utilityFunctions.R | 2 +- 5 files changed, 93 insertions(+), 95 deletions(-) diff --git a/R/FDboost.R b/R/FDboost.R index 3a74d7a..149b7d0 100644 --- a/R/FDboost.R +++ b/R/FDboost.R @@ -465,8 +465,8 @@ FDboost <- function(formula, ### response ~ xvars ## check if number of opening brackets is equal to number of closing brackets equalBrackets <- sapply(seq_along(trmstrings2), function(i) { - lengths(regmatches(trmstrings2[i], gregexpr("\\(", trmstrings2[i]))) == - lengths(regmatches(trmstrings2[i], gregexpr("\\)", trmstrings2[i]))) + lengths(regmatches(trmstrings2[i], gregexpr("(", trmstrings2[i], fixed = TRUE))) == + lengths(regmatches(trmstrings2[i], gregexpr(")", trmstrings2[i], fixed = TRUE))) }) } @@ -486,8 +486,8 @@ FDboost <- function(formula, ### response ~ xvars if(length(trmstrings) > 0){ ## insert index into the other base-learners of the tensor-product as well for(i in seq_along(trmstrings)){ - if(grepl( "%X", trmstrings2[i])){ - temp <- unlist(strsplit(trmstrings2[i], "%X")) + if(grepl( "%X", trmstrings2[i], fixed = TRUE)){ + temp <- unlist(strsplit(trmstrings2[i], "%X", fixed = TRUE)) temp1 <- temp[-length(temp)] ## http://stackoverflow.com/questions/2261079 ## delete all trailing whitespace @@ -497,13 +497,13 @@ FDboost <- function(formula, ### response ~ xvars trmstrings2[i] <- paste0(paste0(temp1, collapse = " %X"), " %X", temp[length(temp)]) } ## do not add index to base-learners bhistx() - if( grepl("bhistx", trmstrings[i]) ) trmstrings2[i] <- trmstrings[i] + if( grepl("bhistx", trmstrings[i], fixed = TRUE) ) trmstrings2[i] <- trmstrings[i] ## do not add an index if an index is already part of the formula if( grepl("index[[:blank:]]*=", trmstrings[i]) ) trmstrings2[i] <- trmstrings[i] ## do not add an index if an index for %A%, %A0%, %O% - if( grepl("%A%", trmstrings[i]) ) trmstrings2[i] <- trmstrings[i] - if( grepl("%A0%", trmstrings[i]) ) trmstrings2[i] <- trmstrings[i] - if( grepl("%O%", trmstrings[i]) ) trmstrings2[i] <- trmstrings[i] + if( grepl("%A%", trmstrings[i], fixed = TRUE) ) trmstrings2[i] <- trmstrings[i] + if( grepl("%A0%", trmstrings[i], fixed = TRUE) ) trmstrings2[i] <- trmstrings[i] + if( grepl("%O%", trmstrings[i], fixed = TRUE) ) trmstrings2[i] <- trmstrings[i] ## do not add an index for base-learner that do not have brackets if( i %in% which(!equalBrackets) ) trmstrings2[i] <- trmstrings[i] } @@ -538,7 +538,7 @@ FDboost <- function(formula, ### response ~ xvars scalarResponse <- TRUE if(is.null(timeformula)) scalarNoFLAM <- TRUE - if(grepl("df", formula[3]) || !grepl("lambda", formula[3]) ){ + if(grepl("df", formula[3], fixed = TRUE) || !grepl("lambda", formula[3], fixed = TRUE) ){ timeformula <- ~bols(ONEtime, intercept = FALSE, df = 1) }else{ timeformula <- ~bols(ONEtime, intercept = FALSE) @@ -671,23 +671,23 @@ FDboost <- function(formula, ### response ~ xvars ## get formula over time tfm <- paste(deparse(timeformula), collapse = "") - tfm <- strsplit(tfm, "~")[[1]] - tfm <- strsplit(tfm[2], "\\+")[[1]] + tfm <- strsplit(tfm, "~", fixed = TRUE)[[1]] + tfm <- strsplit(tfm[2], "+", fixed = TRUE)[[1]] ## get formula in covariates cfm <- paste(deparse(formula), collapse = "") - cfm <- strsplit(cfm, "~")[[1]] + cfm <- strsplit(cfm, "~", fixed = TRUE)[[1]] cfm0 <- cfm #xfm <- strsplit(cfm[2], "\\+")[[1]] xfm <- trmstrings ## check that the timevariable in timeformula and in the bhistx-base-learners have the same name - if(any(grepl("bhistx", trmstrings))){ + if(any(grepl("bhistx", trmstrings, fixed = TRUE))){ for(j in seq_along(trmstrings)){ - if(any(grepl("bhistx", trmstrings[j]))){ - if(grepl("%X", trmstrings[j]) ){ + if(any(grepl("bhistx", trmstrings[j], fixed = TRUE))){ + if(grepl("%X", trmstrings[j], fixed = TRUE) ){ temp <- strsplit(trmstrings[[j]], "%X.*%")[[1]] - temp <- temp[ grepl("bhistx", temp) ] + temp <- temp[ grepl("bhistx", temp, fixed = TRUE) ] ## pryr::standardise_call(quote(bhistx(X1h, df=3))) temp_name <- all.vars(formula(paste("~", temp)))[1] }else{ @@ -707,13 +707,13 @@ FDboost <- function(formula, ### response ~ xvars } } - yfm <- strsplit(cfm[1], "\\+")[[1]] ## name of response + yfm <- strsplit(cfm[1], "+", fixed = TRUE)[[1]] ## name of response ## set up formula for effects constant in time if(length(where.c) > 0){ # set c_df to the df/lambda in timeformula - if( grepl("lambda", tfm) || - ( grepl("bols", tfm) && !grepl("df", tfm)) ){ + if( grepl("lambda", tfm, fixed = TRUE) || + ( grepl("bols", tfm, fixed = TRUE) && !grepl("df", tfm, fixed = TRUE)) ){ c_lambda <- eval(parse(text = paste0(tfm, "$dpp(rep(1.0,", length(time), "))$df()")))["lambda"] cfm <- paste("bols(ONEtime, intercept = FALSE, lambda = ", c_lambda ,")") } else{ @@ -745,20 +745,20 @@ FDboost <- function(formula, ### response ~ xvars } # do not expand an effect bconcurrent() or bhist() with timeformula - if( length(c(grep("bconcurrent", tmp), grep("bhis", tmp)) ) > 0 ) - tmp[c(grep("bconcurrent", tmp), grep("bhist", tmp))] <- xfm[c(grep("bconcurrent", tmp), grep("bhist", tmp))] + if (any(grepl("bconcurrent|bhis", tmp))) + tmp[c(grep("bconcurrent", tmp, fixed = TRUE), grep("bhist", tmp, fixed = TRUE))] <- xfm[c(grep("bconcurrent", tmp, fixed = TRUE), grep("bhist", tmp, fixed = TRUE))] ## do not expand effects in formula including %A% with timeformula - if( length(grep("%A%", xfm)) > 0 ) - tmp[grep("%A%", xfm)] <- xfm[grep("%A%", xfm)] + if( any(grepl("%A%", xfm, fixed = TRUE)) ) + tmp[grep("%A%", xfm, fixed = TRUE)] <- xfm[grep("%A%", xfm, fixed = TRUE)] ## do not expand effects in formula including %A0% with timeformula - if( length(grep("%A0%", xfm)) > 0 ) - tmp[grep("%A0%", xfm)] <- xfm[grep("%A0%", xfm)] + if( any(grepl("%A0%", xfm, fixed = TRUE)) ) + tmp[grep("%A0%", xfm, fixed = TRUE)] <- xfm[grep("%A0%", xfm, fixed = TRUE)] ## do not expand effects in formula including %O% with timeformula - if( length(grep("%O%", xfm)) > 0 ) - tmp[grep("%O%", xfm)] <- xfm[grep("%O%", xfm)] + if( any(grepl("%O%", xfm, fixed = TRUE)) ) + tmp[grep("%O%", xfm, fixed = TRUE)] <- xfm[grep("%O%", xfm, fixed = TRUE)] ## expand with a constant effect in t-direction if(length(where.c) > 0){ @@ -833,11 +833,11 @@ FDboost <- function(formula, ### response ~ xvars ### replace "1" with intercept base learner formula_intercept <- FALSE - if ( any( gsub(" ", "", strsplit(cfm0[2], "\\+")[[1]]) == "1")){ + if ( any( gsub(" ", "", strsplit(cfm0[2], "+", fixed = TRUE)[[1]], fixed = TRUE) == "1")){ formula_intercept <- TRUE ## use df or lambda as in timeformula - if( any(grepl("lambda", deparse(timeformula))) || - any(( grepl("bols", deparse(timeformula)) & !grepl("df", deparse(timeformula)))) ){ + if( any(grepl("lambda", deparse(timeformula), fixed = TRUE)) || + any(( grepl("bols", deparse(timeformula), fixed = TRUE) & !grepl("df", deparse(timeformula), fixed = TRUE))) ){ tmp <- c("bols(ONEx, intercept = FALSE, lambda = 0)", tmp) } else{ tmp <- c("bols(ONEx, intercept = FALSE, df = 1)", tmp) @@ -879,9 +879,9 @@ FDboost <- function(formula, ### response ~ xvars ## get the limits argument current_bl <- attr(terms_fm_bhist, "variables")[[places_bhist[pl] + 1]] # for base-learner with interaction, find bhistx / bhist - if(any(grepl("%X", current_bl))){ + if(any(grepl("%X", current_bl, fixed = TRUE))){ #current_bl <- current_bl[ grepl("bhist", current_bl) ] - arg_limits <- eval(as.call(as.list(current_bl[grepl("bhist", current_bl)])[[1]])$limits) + arg_limits <- eval(as.call(as.list(current_bl[grepl("bhist", current_bl, fixed = TRUE)])[[1]])$limits) }else{ # limits argument of bhist / bhistx arg_limits <- eval(as.call(current_bl)$limits) @@ -1163,7 +1163,7 @@ FDboost <- function(formula, ### response ~ xvars if(check0 && length(ret$baselearner) > 1 && is.null(id) && dim(response)[2] != 1){ # do not check the smooth intercept - if(any( gsub(" ", "", strsplit(cfm[2], "\\+")[[1]]) == "1")){ + if(any( gsub(" ", "", strsplit(cfm[2], "+", fixed = TRUE)[[1]], fixed = TRUE) == "1")){ effectsToCheck <- 2:length(ret$baselearner) }else{ effectsToCheck <- seq_along(ret$baselearner) diff --git a/R/crossvalidation.R b/R/crossvalidation.R index 1fd10dd..55a1636 100644 --- a/R/crossvalidation.R +++ b/R/crossvalidation.R @@ -235,7 +235,7 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ # Function to suppress the warning of missings in the response h <- function(w){ - if( any( grepl( "response contains missing values;", w) ) ) + if( any( grepl( "response contains missing values;", w, fixed = TRUE) ) ) invokeRestart( "muffleWarning" ) } @@ -296,16 +296,16 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ # the probelm with such base-learners is that their data is not contained in object$data # using object$baselearner[[j]]$get_data() is difficult as this can be blow up by index for %X% singleBls <- gsub("\\s", "", unlist(lapply(strsplit( - strsplit(object$formulaFDboost, "~")[[1]][2], # split formula - "\\+")[[1]], # split additive terms + strsplit(object$formulaFDboost, "~", fixed = TRUE)[[1]][2], # split formula + "+", fixed = TRUE)[[1]], # split additive terms function(y) strsplit(y, split = "%.{1,3}%")) # split single baselearners )) singleBls <- singleBls[singleBls != "1"] - if(any(!grepl("\\(", singleBls))) + if(any(!grepl("(", singleBls, fixed = TRUE))) stop(paste0("applyFolds can not deal with the following base-learner(s) without brackets: ", - toString(singleBls[!grepl("\\(", singleBls)]))) + toString(singleBls[!grepl("(", singleBls, fixed = TRUE)]))) ## check if data includes all variables @@ -701,9 +701,9 @@ validateFDboost <- function(object, response = NULL, msg = "'validateFDboost' is deprecated. Use 'applyFolds' and 'bootstrapCI' instead.") names_bl <- names(object$baselearner) - if(any(grepl("brandomc", names_bl))) message("For brandomc, the transformation matrix Z is fixed over all folds.") - if(any(grepl("bolsc", names_bl))) message("For bolsc, the transformation matrix Z is fixed over all folds.") - if(any(grepl("bbsc", names_bl))) message("For bbsc, the transformation matrix Z is fixed over all folds.") + if(any(grepl("brandomc", names_bl, fixed = TRUE))) message("For brandomc, the transformation matrix Z is fixed over all folds.") + if(any(grepl("bolsc", names_bl, fixed = TRUE))) message("For bolsc, the transformation matrix Z is fixed over all folds.") + if(any(grepl("bbsc", names_bl, fixed = TRUE))) message("For bbsc, the transformation matrix Z is fixed over all folds.") type <- attr(folds, "type") if(is.null(type)) type <- "unknown" @@ -755,7 +755,7 @@ validateFDboost <- function(object, response = NULL, # Function to suppress the warning of missings in the response h <- function(w){ - if( any( grepl( "response contains missing values;", w) ) ) + if( any( grepl( "response contains missing values;", w, fixed = TRUE) ) ) invokeRestart( "muffleWarning" ) } @@ -956,7 +956,7 @@ validateFDboost <- function(object, response = NULL, } ## only makes sense for type="curves" with leaving-out one curve per fold!! - if(grepl( "curves", type)){ + if(grepl( "curves", type, fixed = TRUE)){ # predict response for all mstops in grid out of bag # predictions for each response are in a vector! oobpreds0 <- lapply(modRisk, function(x) x$predGrid) @@ -1061,7 +1061,7 @@ validateFDboost <- function(object, response = NULL, ### predictions of terms based on the coefficients for each model # only makes sense for type="curves" with leaving-out one curve per fold!! - if(grepl("curves", type)){ + if(grepl("curves", type, fixed = TRUE)){ for(l in 1:(length(modRisk[[1]]$mod$baselearner)+1)){ predCV[[l]] <- t(sapply(seq_along(modRisk), function(g){ if(l == 1){ # save offset of model @@ -1561,7 +1561,7 @@ plot_bootstrapped_coef <- function(temp, l, quanty <- quantile(temp$y, probs=probs, type=1) # set lower triangular matrix to NA for historic effect - if(grepl("bhist", temp$main)){ + if(grepl("bhist", temp$main, fixed = TRUE)){ for(k in seq_along(temp$value)){ temp$value[[k]][temp$value[[k]]==0] <- NA } @@ -1675,9 +1675,9 @@ cvrisk.FDboost <- function(object, folds = cvLong(id=object$id, weights=model.we if(!length(unique(object$offset)) == 1) message("The smooth offset is fixed over all folds.") names_bl <- names(object$baselearner) - if(any(grepl("brandomc", names_bl))) message("For brandomc, the transformation matrix Z is fixed over all folds.") - if(any(grepl("bolsc", names_bl))) message("For bolsc, the transformation matrix Z is fixed over all folds.") - if(any(grepl("bbsc", names_bl))) message("For bbsc, the transformation matrix Z is fixed over all folds.") + if(any(grepl("brandomc", names_bl, fixed = TRUE))) message("For brandomc, the transformation matrix Z is fixed over all folds.") + if(any(grepl("bolsc", names_bl, fixed = TRUE))) message("For bolsc, the transformation matrix Z is fixed over all folds.") + if(any(grepl("bbsc", names_bl, fixed = TRUE))) message("For bbsc, the transformation matrix Z is fixed over all folds.") class(object) <- "mboost" diff --git a/R/factorize.R b/R/factorize.R index 293264c..e3d344c 100644 --- a/R/factorize.R +++ b/R/factorize.R @@ -266,7 +266,7 @@ factorize.FDboost <- function(x, newdata = NULL, newweights = 1, blwise = TRUE, e[[i]]$ens <- unlist(lapply(cf[[i]], asplit, 2), recursive = FALSE) e[[i]]$ens <- Map( function(x, cls) { bm <- list(model = x) - class(bm) <- gsub("bl", "bm", cls) + class(bm) <- gsub("bl", "bm", cls, fixed = TRUE) bm }, x = e[[i]]$ens[bl_order[[i]]], @@ -356,4 +356,4 @@ plot.FDboost_fac <- function(x, which = NULL, main = NULL, ...) { main <- names(x$baselearner)[w] for(i in seq_along(w)) plot.mboost(x, which = w[i], main = main[i], ...) -} \ No newline at end of file +} diff --git a/R/methods.R b/R/methods.R index 7b5127f..3350dde 100644 --- a/R/methods.R +++ b/R/methods.R @@ -232,9 +232,9 @@ predict.FDboost <- function(object, newdata = NULL, which = NULL, toFDboost = TR indname <- attr(object$baselearner[[i]]$get_data()[[xname]], "indname") # does not work for %X% ## if two ore more base-learners are connected by %X%, find the functional variable ## the loop is necessary if more than one functioal covaraites are used in the same bl - if(grepl("%X", names(object$baselearner)[i])){ - form <- strsplit(object$baselearner[[i]]$get_call(), "%X")[[1]] - findFun <- grepl("bhist", form) | grepl("bconcurrent", form) | grepl("bsignal", form) | grepl("bfpc", form) + if(grepl("%X", names(object$baselearner)[i], fixed = TRUE)){ + form <- strsplit(object$baselearner[[i]]$get_call(), "%X", fixed = TRUE)[[1]] + findFun <- grepl("bhist", form, fixed = TRUE) | grepl("bconcurrent", form, fixed = TRUE) | grepl("bsignal", form, fixed = TRUE) | grepl("bfpc", form, fixed = TRUE) xname <- c() indname <- c() for(j in which(findFun)){ @@ -282,7 +282,7 @@ predict.FDboost <- function(object, newdata = NULL, which = NULL, toFDboost = TR # offset of length>1 is not used in prediction, # important when offset=NULL in FDboost() but not in mboost() muffleWarning1 <- function(w){ - if( any( grepl( "User-specified offset is not a scalar", w) ) ) + if( any( grepl("User-specified offset is not a scalar", w, fixed = TRUE) ) ) invokeRestart( "muffleWarning" ) } @@ -603,7 +603,7 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, numberLevels <- 1 ### generate data in the case of an bhistx()-bl - if(grepl("bhistx", trm$get_call())){ + if(grepl("bhistx", trm$get_call(), fixed = TRUE)){ ng <- n2 # get hmatrix-object position_hmatrix <- which(sapply(trm$model.frame(), is.hmatrix)) @@ -614,10 +614,10 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, tvals <- seq(min(tvals), max(tvals), length = ng) tvals <- rep(tvals, each = ng) - if( grepl("%X", trm$get_call()) ){ + if( grepl("%X", trm$get_call(), fixed = TRUE) ){ split_bl <- strsplit(trm$get_call(), split = "%.{1,3}%")[[1]] ## save the position of bhistx() - position_bhistx <- which(grepl("bhistx", split_bl)) + position_bhistx <- grep("bhistx", split_bl, fixed = TRUE) if(length(split_bl) == 2){ # one %X% if(position_bhistx == 1){ @@ -667,7 +667,7 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, attr(d, "ym") <- seq(min(tvals), max(tvals), length = ng) ## for a tensor product term: add the scalar factors to d - if( grepl("%X", trm$get_call()) ){ + if( grepl("%X", trm$get_call(), fixed = TRUE) ){ if(position_hmatrix == 1){ position_z <- 2 }else{ @@ -827,7 +827,7 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, }else{ ### functional response ## not bhist - if( ! grepl("bhist", trm$get_call()) ){ + if( ! grepl("bhist", trm$get_call(), fixed = TRUE) ){ ## y (time variable, usually second variable) ## important in case of by-variables, then yind is third variable @@ -929,7 +929,7 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, ## add dummy signal to data for bsignal() - if(grepl("bsignal", trm$get_call()) || grepl("bfpc", trm$get_call()) ){ + if (grepl("bsignal|bfpc", trm$get_call())) { position_signal <- which(sapply(trm$model.frame(), function(x) !is.null(attr(x, "signalIndex")) )) @@ -944,7 +944,7 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, ## as they cannot be included into the variable x(s) ## use intFun() to compute the integration weights # ls(environment(trm$dpp)) - if(grepl("bhist", trm$get_call()) ){ + if(grepl("bhist", trm$get_call(), fixed = TRUE) ){ ## temp <- I(diag(ng)/integrationWeightsLeft(diag(ng), d[[varnms[1]]])) ## use intFun() of the bl to compute the integration weights temp <- environment(trm$dpp)$args$intFun(diag(ng), d[[attr(object$yind, "nameyind")]]) @@ -956,7 +956,7 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, } ## add dummy signal to data for bconcurrent() - if(grepl("bconcurrent", trm$get_call())){ + if(grepl("bconcurrent", trm$get_call(), fixed = TRUE)){ d[[ trm$get_names()[1] ]] <- I(matrix(rep(1.0, ng^2), ncol=ng)) } @@ -975,7 +975,7 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, # if %X% was used in combination with factor variables make a list of data-frames - if(!inherits(object, "FDboostLong") && grepl("%X", trm$get_call())){ + if(!inherits(object, "FDboostLong") && grepl("%X", trm$get_call(), fixed = TRUE)){ dlist <- NULL ## if %X% was used in combination with factor variables make a list of data-frames @@ -1068,7 +1068,7 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, ## for bhist(), multiply with standardisation weights if necessary ## you need the args$vecStand from the prediction of X, constructed here - if(grepl("bhist", trm$get_call())){ + if(grepl("bhist", trm$get_call(), fixed = TRUE)){ myargsHist <- myargs ## use the args found in makeDataGrid() ## this should only occur for more than two %X% @@ -1110,13 +1110,13 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, z=attr(d, "zm"), zlab=varnms[3], vecStand=vecStand) ## include the second scalar covariate called z1 into the output - if( grepl("bhistx", trm$get_call()) && length(trm$get_names()) > 2){ + if( grepl("bhistx", trm$get_call(), fixed = TRUE) && length(trm$get_names()) > 2){ extra_output <- list(z1=attr(d, "z1m"), z1lab=varnms[4]) P <- c(P, extra_output) } ## save the arguments of stand and limits as part of returned object - if(grepl("bhist", trm$get_call())){ + if(grepl("bhist", trm$get_call(), fixed = TRUE)){ P$stand <- myargsHist$stand P$limits <- myargsHist$limits } @@ -1151,8 +1151,7 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, trm <- object$baselearner[[i]] trm$dim <- length(trm$get_names()) - if(any(grepl("ONEx", trm$get_names()), - grepl("ONEtime", trm$get_names()))) trm$dim <- trm$dim - 1 + if(any(grepl("ONE(x|time)", trm$get_names()))) trm$dim <- trm$dim - 1 ### give error for bl1 %X% bl2 %X% bl3 #if( grepl("bhistx", trm$get_call()) & trm$dim > 2){ @@ -1160,18 +1159,18 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, #} ## add 1 to dimension of bhist and bhistx, otherwise dim is only 1 - if( grepl("bhist", trm$get_call()) ){ + if( grepl("bhist", trm$get_call(), fixed = TRUE) ){ trm$dim <- trm$dim + 1 } # If a by-variable was specified, reduce number of dimensions # as smooth linear effect in several groups can be plotted in one plot - if( grepl("by =", trm$get_call()) && grepl("bols", trm$get_call()) || - grepl("by =", trm$get_call()) && grepl("bbs", trm$get_call()) ) trm$dim <- trm$dim - 1 + if( grepl("by =", trm$get_call(), fixed = TRUE) && grepl("bols", trm$get_call(), fixed = TRUE) || + grepl("by =", trm$get_call(), fixed = TRUE) && grepl("bbs", trm$get_call(), fixed = TRUE) ) trm$dim <- trm$dim - 1 # what to do with bbs(..., by=factor)? - if(trm$dim > 3 && !grepl("bhistx", trm$get_call()) ){ + if(trm$dim > 3 && !grepl("bhistx", trm$get_call(), fixed = TRUE) ){ warning("Can't deal with smooths with more than 3 dimensions, returning NULL for ", shrtlbls[i], ".") return(NULL) @@ -1180,12 +1179,12 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, d <- makeDataGrid(trm) ### better solution for %X% in base-learner!!! - if(!is.null(object$ydim) && any(grepl("%X", trm$get_call())) - && !any(grepl("bhistx", trm$get_call())) ) trm$dim <- trm$dim - 1 + if(!is.null(object$ydim) && any(grepl("%X", trm$get_call(), fixed = TRUE)) + && !any(grepl("bhistx", trm$get_call(), fixed = TRUE)) ) trm$dim <- trm$dim - 1 ## it is necessary to expand the dataframe! if(!grepl("bhistx(", trm$get_call(), fixed=TRUE) && - inherits(object, "FDboostLong") && !grepl("bconcurrent", trm$get_call())){ + inherits(object, "FDboostLong") && !grepl("bconcurrent", trm$get_call(), fixed = TRUE)){ #print(attr(d, "varnms")) vari <- names(d)[1] if(is.factor(d[[vari]])){ @@ -1194,8 +1193,7 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, each=length(unique(d[[vari]])) ) }else{ # expand signal variable - if( grepl("bhist(", trm$get_call(), fixed = TRUE) || - grepl("bsignal", trm$get_call()) || grepl("bfpc", trm$get_call()) ){ + if (grepl("bhist\\(|bsignal|bfpc", trm$get_call())) { vari <- names(d)[!names(d) %in% attr(d, "varnms")] d[[vari]] <- d[[vari]][ rep(seq_len(NROW(d[[vari]])), times=NROW(d[[vari]])), ] @@ -1211,14 +1209,14 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, ###### just return the data, that is used for the prediction if(returnData){ - if(grepl("bhist", trm$get_call())){ + if(grepl("bhist", trm$get_call(), fixed = TRUE)){ message("If argument stand is specified !=\"no\", the standardization will be part of the predicted coefficient.") } return(d) } if( !is.null(attr(d, "numberLevels")) && attr(d, "numberLevels") > 1){ - if( grepl("bhistx", trm$get_call()) ) trm$dim <- 2 + if( grepl("bhistx", trm$get_call(), fixed = TRUE) ) trm$dim <- 2 ## get smooth coefficient estimates for several factor levels # P <- getP(d[[1]], trm = trm, myargs = attr(d, "myargsHist")) P <- lapply(d, getP, trm = trm, myargs = attr(d, "myargsHist")) @@ -1250,11 +1248,11 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, xpart[i] <- gsub(pattern = "\\\"", replacement = "", x = xpart[i], fixed=TRUE) xpart[i] <- gsub(pattern = "\\", replacement = "", x = xpart[i], fixed=TRUE) nvar <- length(all.vars(formula(paste("Y~", xpart[i])))[-1]) - commaSep <- unlist(strsplit(xpart[i], ",")) + commaSep <- unlist(strsplit(xpart[i], ",", fixed = TRUE)) # shorten the name to first variable and delete x= if present - if(grepl("=", commaSep[1])){ - temp <- unlist(strsplit(commaSep[1], "=")) + if(grepl("=", commaSep[1], fixed = TRUE)){ + temp <- unlist(strsplit(commaSep[1], "=", fixed = TRUE)) temp[1] <- unlist(strsplit(temp[1], "(", fixed=TRUE))[1] if(substr(temp[2], 1, 1)==" ") temp[2] <- substr(temp[2], 2, nchar(temp[2])) if(length(commaSep) == 1){ @@ -1479,7 +1477,7 @@ plot.FDboost <- function(x, raw = FALSE, rug = TRUE, which = NULL, ## trm <- terms[[i]] myplot <- function(trm, range_i = NULL){ - if(grepl("bhist", trm$main)){ + if(grepl("bhist", trm$main, fixed = TRUE)){ # set 0 to NA so that beta only has values in its domain # get the limits-function limits <- trm$limits @@ -1507,14 +1505,14 @@ plot.FDboost <- function(x, raw = FALSE, rug = TRUE, which = NULL, } if(rug && !is.factor(x = trm$x)){ - if(grepl("bconcurrent", trm$main) || grepl("bsignal", trm$main) || grepl("bfpc", trm$main) ){ + if (grepl("bconcurrent|bsignal|bfpc", trm$main)) { rug(attr(bl_data[[i]][[1]], "signalIndex"), ticksize = 0.02) }else rug(bl_data[[i]][[trm$xlab]], ticksize = 0.02) } } # plot with factor variable - if( (!grepl("bhistx", trm$main)) && trm$dim==2 && + if( (!grepl("bhistx", trm$main, fixed = TRUE)) && trm$dim==2 && ((is.factor(trm$x) || is.factor(trm$y)) || is.factor(trm$z)) ){ ## plot for the special case where factor is plotted in several plots @@ -1619,14 +1617,14 @@ plot.FDboost <- function(x, raw = FALSE, rug = TRUE, which = NULL, if(rug){ ##points(expand.grid(bl_data[[i]][[1]], bl_data[[i]][[2]])) - if(grepl("bhist", trm$main)){ + if(grepl("bhist", trm$main, fixed = TRUE)){ rug(x$yind, ticksize = 0.02) }else{ - ifelse(grepl("by", trm$main) | ( !inherits(x, "FDboostLong") && grepl("%X", trm$main) ) , + ifelse(grepl("by", trm$main, fixed = TRUE) | ( !inherits(x, "FDboostLong") && grepl("%X", trm$main, fixed = TRUE) ) , rug(bl_data[[i]][[3]], ticksize = 0.02), rug(bl_data[[i]][[2]], ticksize = 0.02)) } - ifelse(grepl("bsignal", trm$main) | grepl("bfpc", trm$main) | grepl("bhist", trm$main), + ifelse(grepl("bsignal|bfpc|bhist", trm$main), rug(attr(bl_data[[i]][[1]], "signalIndex"), ticksize = 0.02, side=2), rug(bl_data[[i]][[1]], ticksize = 0.02, side=2)) } @@ -1714,7 +1712,7 @@ plot.FDboost <- function(x, raw = FALSE, rug = TRUE, which = NULL, time <- x$yind # include the offset in the plot of the intercept - if( includeOffset && 1 %in% which && grepl("ONEx", shrtlbls[1]) ){ + if( includeOffset && 1 %in% which && grepl("ONEx", shrtlbls[1], fixed = TRUE) ){ terms[[1]] <- terms[[1]] + x$offset shrtlbls[1] <- paste("offset", "+", shrtlbls[1]) } @@ -1880,16 +1878,16 @@ update.FDboost <- function(object, weights = NULL, oobweights = NULL, risk = NUL ### check for brackets singleBls <- gsub("\\s", "", unlist(lapply(strsplit( - strsplit(object$formulaFDboost, "~")[[1]][2], # split formula - "\\+")[[1]], # split additive terms + strsplit(object$formulaFDboost, "~", fixed = TRUE)[[1]][2], # split formula + "+", fixed = TRUE)[[1]], # split additive terms function(y) strsplit(y, split = "%.{1,3}%")) # split single baselearners )) singleBls <- singleBls[singleBls!="1"] - if(any( !grepl("\\(",singleBls) )) + if(any( !grepl("(",singleBls, fixed = TRUE) )) stop(paste0("update can not deal with the following base-learner(s) without brackets: ", - toString(singleBls[!grepl("\\(",singleBls)]), ".\n", + toString(singleBls[!grepl("(", singleBls, fixed = TRUE)]), ".\n", "Please build such base-learners within the FDboost call or ", "update corresponding baselearner(s) manually and supply a new formula to the update function.")) @@ -1931,7 +1929,7 @@ extract.blg <- function(object, what = c("design", "penalty", "index"), asmatrix = FALSE, expand = FALSE, ...){ what <- match.arg(what) - if(grepl("%O%", object$get_call()) || grepl("%Oz%", object$get_call())){ + if (grepl("%O%|%Oz%", object$get_call())) { object <- object$dpp( rep(1, NROW(object$model.frame()[[1]])) ) }else{ object <- object$dpp(rep(1, nrow(object$model.frame()))) diff --git a/R/utilityFunctions.R b/R/utilityFunctions.R index ce5fc39..1d1ed4f 100644 --- a/R/utilityFunctions.R +++ b/R/utilityFunctions.R @@ -351,7 +351,7 @@ getYYhatTime <- function(object, breaks=object$yind){ newdata <- list() for(j in seq_along(object$baselearner)){ datVarj <- object$baselearner[[j]]$get_data() - if(grepl("bconcurrent", names(object$baselearner)[j])){ + if(grepl("bconcurrent", names(object$baselearner)[j], fixed = TRUE)){ datVarj <- t(apply(datVarj[[1]], 1, function(x) approx(object$yind, x, xout=time)$y)) datVarj <- list(datVarj) }