Defines functions validate.Score.Arguments .additionalScore.validate is.valid.call checkContiguous checkPanelling .getResponse .validRHSFormula

#This file contains the code to validate the riskscore imputation arguments and
#the formula arguments and various subfunctions

#check the formula is valid (specifically there is no left hand side, should not be tt or cluster
#and if arm is not NULL then the 'arm' is the first term on the right hand side and there are no
#interactions between arm and other covariates)
.validRHSFormula <- function(formula,arm=NULL){
  if(inherits(formula,"formula")!=TRUE) stop("Invalid formula is not of type formula")
    stop("formula cannot have any variables on the left hand side.")
  if(length(untangle.specials(tms,"tt")$vars)>0 ||
    stop("Cannot use tt or cluster in formula for gamma/score imputation")
  if(is.null(arm)) return(NULL)
  #validate the right hand side of the formula
  k <- attr(terms(formula),"term.labels")
    stop("Empty formula!")
  first_term <- k[[1]]
    stop("The first term of the formula must be the treatment group")
    covariates <- tail(k,-1)
    ans <- unlist(lapply(covariates,function(x){
      first_term %in% unlist(strsplit(x,split=c(":")))
      stop(error=paste("Model formula cannot include interactions between",arm, "and covariates.",
                       "The", arm, "must be the first model variable"))

#from http://stackoverflow.com/questions/13217322/how-to-reliably-get-dependent-variable-name-from-formula-object
.getResponse <- function(formula) {
  tt <- terms(formula)
  vars <- as.character(attr(tt, "variables"))[-1] ## [1] is the list call
  response <- attr(tt, "response") # index of response var

#check that the columns [time.start,time.end] for a single
#subject are ordered correctly, the initial time.start = 0, 
#time.end > time.start and there are no gaps (i.e. [0,1], [2,10])
#@param data a data frame with the time dep. covariates for a
#single subject
checkPanelling <- function(data){
  if(data$time.start[1] != 0){
    stop("The time.start for the first row for subject",data$Id[1],"must be 0")
  if(nrow(data)>1 && !all.equal(data$time.start[2:nrow(data)],data$time.end[1:(nrow(data)-1)])){
    stop("There cannot be gaps in the [time.start,time.end) intervals, check subject",data$Id[1])      
  if(any(data$time.end <= data$time.start)){
    stop("The time.end cannot be <= time.start, check subject",data$Id[1])

# Check duplicated elements of a vector are contiguous
# for example c(1,1,1,2,2,4,4,5,5) is contiguous
# but c(1,1,2,2,1,4,5,4,5) is not
# @param vec a vector of values
checkContiguous <- function(vec){
  if(length(vec)<2) return(TRUE)
  known.vals <- vec[1]
  for(i in 2:length(vec)){
    if(vec[i] != vec[i-1]){
      if(!vec[i] %in% known.vals){
        known.vals <- c(known.vals,vec[i])
        stop(paste("The order of the data frame is incorrect. All rows with the same",
                   "Subject ID must be contiguous"))

is.valid.call <- function(Call){
  indx <- match(c("subset", "na.action"), names(Call),nomatch=0L)
    stop("Cannot use na.action or subset argument with this imputation ",
         "function (na.fail is used when fitting the Cox models)")

.additionalScore.validate <- function(data,col.control,Call){
  if(any(c("impute.time","impute.event") %in% colnames(data))){
    stop("Cannot use a data frame with columns impute.time or impute.event")
  #validate col.control (note this is needed here in case people do not use col.headings function) 
  #validate col.control with data
    if(!is.null(x) && !x %in% colnames(data))stop("Invalid column name '",x,"'not found in data frame")})
    stop("Empty data frame!")
    stop("time on study must be numeric")
    stop("DCO time must be numeric")
  #check time is positive
  if(any(data[,col.control$time]<= 0)){
    stop("Time on study must be positive")
  #DCO.time is <= time
  if(any(data[,col.control$DCO.time] < data[,col.control$time])){
    stop("DCO.time must be >= time for all subjects ")
  #unique IDs
    stop("Subject Ids must be unique")
  if(any(!data[,col.control$has.event] %in% c(0,1))){
    stop("Event indicator column can only contain 0s and 1s")
    stop("To impute column can only contain TRUE and FALSE")

validate.Score.Arguments <- function(data,col.control,NN.control,time.dep,Call,m){
  #validation routines additional

  #check m
  if(!.internal.is.finite.number(m) ||!.internal.is.wholenumber(m) || m < 5){
    stop("m must be at least 5")
  #check have event.model
  indx <- match(c("event.model"), names(Call),nomatch=0L)
    stop("Missing event.model argument")
  #event.model and censor.model are validated later
  #validate NN.control  (note this is needed here in case people do not use NN.options function)

  #check arm is two level factor
  if(!is.factor(data[,col.control$arm])|| length(levels(data[,col.control$arm]))!=2){
    stop("Treatment group must be a two level factor variable")
  #censor.type validation
  if("using_has.event_col" %in% colnames(data)){
    stop("Cannot use a data frame with column name using_has.event_col")
    if(any(!data[,col.control$censor.type] %in% 0:2)){
      stop("Censor type must be 0, 1 or 2")
      stop("Censor type for subjects who have event must=0")
      stop("Censor type for subjects who do not have event cannot be=0")
    #timedep class
    if(!"ScoreTD" %in% class(time.dep)){
      stop("time.dep must be of type ScoreTD")  
    ans <- intersect(colnames(time.dep),colnames(data))
    if(length(ans)>1 || (length(ans)==1 && ans[1] != "Id") ){
      stop("Cannot have columns with the same name in data and time.dep data frames")


Try the InformativeCensoring package in your browser

Any scripts or data that you put into this service are public.

InformativeCensoring documentation built on June 7, 2023, 6:09 p.m.