R/validation_functions.R

In gsearly: Creates Group Sequential Trial Designs when Early Outcomes are Available

#-------------------------------------------------------------------------------
# Validation functions for gsearly
#-------------------------------------------------------------------------------
# 1st July 2026
#-------------------------------------------------------------------------------

#-------------------------------------------------------------------------------
# 38.  .valCorrmod
#-------------------------------------------------------------------------------
.valCorrmod <- function(rmodel, cmodel, sd, rho, s) {

  ## Validate function inputs
  notNumeric <- function(x) {
    return(!is(c(x), "numeric") || length(x) > 1)
  }
  isInteger <- function(x) {
    all(is.numeric(x)) && all(round(x, 0) == x)
  }
  notInteger <- function(x) {
    return(!isInteger(x) || length(x) > 1)
  }
  notGtrange <- function(x, a, b) {
    return(a > x || x > b)
  }
  notGterange <- function(x, a, b) {
    return(a >= x || x >= b)
  }
  isLogical <- function(x) {
    all(is.logical(x))
  }
  notLogical <- function(x) {
    return(!isLogical(x) || length(x) > 1)
  }

  ## cmodel
  if (rmodel == "none") {
    if (is.matrix(cmodel) == TRUE) {
      if (!isSymmetric(cmodel)) {
        stop("cmodel: matrix not symmetric")
      }
      if (any(eigen(cmodel)$values < 0)) {
        stop("cmodel: matrix not positive semi-definite")
      }
      if (any(diag(cmodel) != 1) | any(as.numeric(cmodel) > 1) |
        any(as.numeric(cmodel) < 0)) {
        stop("cmodel: not a valid correlation matrix; 0 < cmodel[i,j] < 1")
      }
      ## If cmodel is matrix must be s x s
      if (dim(cmodel)[1] != s | dim(cmodel)[2] != s) {
        stop("cmodel: set to s x s matrix")
      }
    } else {
      corrmods <- c("exponential", "uniform")
      icorrmod <- as.integer(match(cmodel, corrmods, -1))
      if (icorrmod < 1) {
        stop("cmodel: set to be exponential or uniform")
      }
    }
  } else {
    corrmods <- c("exponential", "uniform")
    icorrmod <- as.integer(match(cmodel, corrmods, -1))
    if (any(icorrmod < 1)) {
      stop("cmodel: set to be exponential or uniform")
    }
  }

  ## sd
  if (length(sd) == 1) {
    ix <- notNumeric(sd)
    if (ix == FALSE) {
      ix <- notGterange(sd, a = 0, b = Inf)
    }
    if (ix == TRUE) {
      stop("sd: set to numeric, sd > 0")
    }
  } else {
    sd <- subset(sd, complete.cases(sd))
    ix <- length(sd) != s
    if (ix == FALSE) {
      ix <- sapply(sd, notNumeric)
    }
    if (all(ix == FALSE)) {
      ix <- sapply(sd, notGterange, a = 0, b = Inf)
    }
    if (any(ix == TRUE)) {
      stop("sd: set to numeric vector length s, sd's > 0")
    }
  }

  ## rho
  ix <- notNumeric(rho)
  if (ix == FALSE) {
    ix <- notGtrange(rho, a = 0, b = 1)
    if(rho==1){ix <- TRUE}
  }
  if (ix == TRUE) {
    stop("rho: set to range 0 <= rho < 1")
  }
}
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------

#-------------------------------------------------------------------------------
# 39.  .valFptn
#-------------------------------------------------------------------------------
.valFptn <- function(fp, tn, nlooks) {

  ## Validate function inputs
  notNumeric <- function(x) {
    return(!is(c(x), "numeric") || length(x) > 1)
  }
  isInteger <- function(x) {
    all(is.numeric(x)) && all(round(x, 0) == x)
  }
  notInteger <- function(x) {
    return(!isInteger(x) || length(x) > 1)
  }
  notGtrange <- function(x, a, b) {
    return(a > x || x > b)
  }
  notGterange <- function(x, a, b) {
    return(a >= x || x >= b)
  }
  isLogical <- function(x) {
    all(is.logical(x))
  }
  notLogical <- function(x) {
    return(!isLogical(x) || length(x) > 1)
  }
  valCprobs <- function(x) {
    i_x <- sapply(x, notNumeric)
    if (all(i_x == FALSE)) {
      i_x <- (any(diff(c(x)) < 0) || any(diff(c(x)) >= 1)) || sum(x) ==
        0
    }
    if (any(i_x) == TRUE) {
      stop("bounds: set to cumulative probability vector, in interval c(0,1)")
    }
  }

  ## fp and tn
  valCprobs(fp)
  valCprobs(tn)

  ## Vector fp and tn must be of length nlooks
  if (length(fp) != nlooks) {
    stop("fp: set to vector of length tinterims + 1")
  }
  if (length(tn) != nlooks) {
    stop("tn: set to vector of length tinterims + 1")
  }
  dfp <- as.numeric(diff(c(0, fp)))
  dtn <- as.numeric(diff(c(0, tn)))

  ## Final efficacy and futility spend must be > 0
  if (dfp[nlooks] <= 0) {
    stop("fp: Final efficacy spend must be > 0")
  }
  if (dtn[nlooks] <= 0) {
    stop("tn: Final futility spend must be > 0")
  }
}
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------

#-------------------------------------------------------------------------------
# 40.  .valMeanmod
#-------------------------------------------------------------------------------
.valMeanmod <- function(x, s) {
  ix <- !is.matrix(x)
  if (ix == FALSE) {
    ix <- !is.numeric(x)
  }
  if (ix == FALSE) {
    ix <- any(is.na(as.numeric(x)))
  }
  if (ix == FALSE) {
    ix <- dim(x)[1] != 2 | dim(x)[2] != s
  }
  if (ix == TRUE) {
    stop("mean: matrix of numbers, dimensions 2 x s, with no NAs")
  }
}
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------

#-------------------------------------------------------------------------------
# 41.  .valRecruitmod
#-------------------------------------------------------------------------------
.valRecruitmod <- function(rmodel, trecruit, s, tfu, theta, tinterims, ninterims = NULL,
  n, tref, vphi, roundup, pow, m, sopt) {
  
  ## Validate function inputs
  notNumeric <- function(x) {
    return(!is(c(x), "numeric") || length(x) > 1)
  }
  isInteger <- function(x) {
    all(is.numeric(x)) && all(round(x, 0) == x)
  }
  notInteger <- function(x) {
    return(!isInteger(x) || length(x) > 1)
  }
  notGtrange <- function(x, a, b) {
    return(a > x || x > b)
  }
  notGterange <- function(x, a, b) {
    return(a >= x || x >= b)
  }
  isLogical <- function(x) {
    all(is.logical(x))
  }
  notLogical <- function(x) {
    return(!isLogical(x) || length(x) > 1)
  }

  ## trecruit
  ix <- notInteger(trecruit)
  if (ix == FALSE) {
    ix <- notGtrange(trecruit, a = 1, b = Inf)
  }
  if (ix == TRUE) {
    stop("trecruit: set to integer, trecruit > 1")
  }

  ## s
  ix <- notInteger(s)
  if (ix == FALSE) {
    ix <- notGtrange(s, a = 2, b = 10)
  }
  if (ix == TRUE) {
    stop("s: set to integer in range 2 <= s <= 10")
  }

  ## tfu
  ix <- sapply(tfu, notInteger)
  if (all(ix == FALSE)) {
    ix <- diff(c(0, tfu)) <= 0
  }
  if (any(ix) == TRUE) {
    stop("tfu: set to ordered integers, with tfu[1] >= 1")
  }

  ## theta
  i_x <- notNumeric(theta)
  if (i_x == FALSE) {
    i_x <- notGterange(theta, a = -Inf, b = Inf)
  }
  if (i_x == TRUE) {
    stop("theta: set to numeric")
  }

  ## tinterims
  ix <- sapply(tinterims, notNumeric)
  if (all(ix == FALSE)) {
    ix <- any(diff(c(0, tinterims)) <= 0) || length(tinterims) < 1
  }
  if (any(ix) == TRUE) {
    stop("tinterims: set to vector of ordered times >= 1")
  }

  ## sopt
  ix <- is.list(sopt)
  if (ix == TRUE) {
    ix <- length(sopt) == 2
  }
  if (ix == TRUE) {
    ix <- setequal(names(sopt), c("r", "bisect"))
  }
  # r
  if (ix == TRUE) {
    ix <- length(sopt$r) != 1 || notGterange(sopt$r, a = 1, b = 80)
  }
  if (ix == TRUE) {
    stop("bisect r: set to range 1 < r < 80")
  }
  # bisect
  ix <- is.list(sopt$bisect)
  if (ix == TRUE) {
    ix <- length(sopt$bisect) == 4
  }
  if (ix == TRUE) {
    ix <- setequal(names(sopt$bisect), c("min", "max", "niter", "tol"))
  }
  # min and max
  ix <- isInteger(sopt$bisect$min) && isInteger(sopt$bisect$max)
  if (ix == TRUE) {
    ix <- sopt$bisect$min >= 2 && sopt$bisect$max > sopt$bisect$min
  }
  if (ix == FALSE) {
    stop("bisect min and max: must be integers >=2 such that max>min")
  }
  # niter
  ix <- isInteger(sopt$bisect$niter)
  if (ix == FALSE) {
    stop("bisect niter: must be integer")
  }
  # tol
  ix <- notNumeric(sopt$bisect$tol)
  if (ix == FALSE) {
    ix <- notGterange(sopt$bisect$tol, a = 0, b = 0.1)
  }
  if (ix == TRUE) {
    stop("tol: set to range 0 < tol < 0.1")
  }

  ## ninterims
  if (rmodel == "none") {
    ## Function to validate ninterims
    valNinterims <- function(x, s, tinterims, fn = FALSE) {
      ix <- is.matrix(x)
      if (ix == TRUE) {
        ix <- all(x > 1)
      }
      if (ix == TRUE) {
        r <- dim(x)[1]
        c <- dim(x)[2]
        ix <- c == (s + 1) && r == length(tinterims)
      }
      if (ix == TRUE) {
        check_rdecrease <- function(r, idat) {
          return(any(diff(c(idat[r, ], 0)) >= 0))
        }
        check_cincrease <- function(c, idat) {
          return(any(diff(c(0, idat[, c])) <= 0))
        }
        ir <- sapply(1:r, check_rdecrease, idat = x)
        ic <- sapply(1:c, check_cincrease, idat = x)
        ix <- all(ir == FALSE) && all(ic == FALSE)
      }
      if (fn == FALSE) {
        if (ix == FALSE) {
          stop("ninterims: set to matrix of required structure (see help)")
        }
      } else if (fn == TRUE) {
        if (ix == FALSE) {
          stop("ninterims: set function to give required structure (see help)")
        }
      }
    }
    if (is.function(ninterims) == TRUE) {
      test_min <- ninterims(as.numeric(sopt$bisect$min))
      test_max <- ninterims(as.numeric(sopt$bisect$max))
      valNinterims(test_min, s = s, tinterims = tinterims, fn = TRUE)
      valNinterims(test_max, s = s, tinterims = tinterims, fn = TRUE)
    } else {
      valNinterims(ninterims, s = s, tinterims = tinterims, fn = FALSE)
    }
  }

  ## n
  if (!is.null(n)) {
    ix <- notInteger(n)
    if (ix == FALSE) {
      ix <- notGtrange(n, a = 2, b = Inf)
    }
    if (ix == TRUE) {
      stop("n: set to integer, n > 0")
    }
  }

  ## tref
  ix <- all(is.element(tref, 1:s)) && length(tref) == 2
  if (ix == TRUE) {
    ix <- tref[2] > tref[1]
  }
  if (ix == FALSE) {
    stop("tref: invalid tfu reference category")
  }

  ## vphi
  ix <- notNumeric(vphi)
  if (ix == FALSE) {
    ix <- notGterange(vphi, a = 0, b = 1)
  }
  if (ix == TRUE) {
    stop("vphi: set to range 0 < vphi < 1")
  }

  ## roundup
  ix <- length(roundup) !=1 || notLogical(roundup)
  if (ix == TRUE) {
    stop("roundup: Logical of length 1")
  }

  ## pow
  ix <- notNumeric(pow)
  if (ix == FALSE) {
    ix <- notGterange(pow, a = 0, b = 1)
  }
  if (ix == TRUE) {
    stop("pow: set to range 0 < pow < 1")
  }

  ## m
  if (rmodel != "none") {
    ix <- notNumeric(m)
    if (ix == FALSE) {
      ix <- notGtrange(m, a = 1, b = Inf)
    }
    if (ix == TRUE) {
      stop("m: set to range 1 <= m < Inf")
    }
  }

  ## Vector tfu must be of length s
  if (length(tfu) != s) {
    stop("tfu: set to vector of length s")
  }
  ## Need feasible window of opportunity
  if (trecruit <= tfu[s]) {
    stop("Infeasible window of opportunity: trecruit <= tfu[s]")
  }
  ## Times of interims must fall in window of opportunity
  #i_interim <- any(tinterims <= tfu[s]) || any(tinterims >= trecruit)
  #if (i_interim == TRUE) {
  #  stop("tinterims: infeasible tinterims, need tfu[s] < tinterims < trecruit")
  #}

  ## Times of interims generally fall in window of opportunity
  ## And must be before end of FU (trecruit + tfu[s])
  lengthtrial <- trecruit + tfu[s]
  i_interim <- any(tinterims <= tfu[s]) || any(tinterims >= lengthtrial)
  if (i_interim == TRUE) {
    stop("tinterims: infeasible tinterims, need tfu[s] < tinterims < trecruit + tfu[s]")
  }
  if(any(tinterims >= trecruit)){
    warning("Interim time-point(s) outside window of opportunity", call. = FALSE)
  }
}
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------

#-------------------------------------------------------------------------------
# 42.  .valRmodel
#-------------------------------------------------------------------------------
.valRmodel <- function(x) {
  ## Recruitment model must be set to one of the below options
  recruit_mods <- c("fix", "dlin", "ilin", "dquad", "iquad", "dilin",
    "idlin", "diquad", "idquad", "filin", "fdlin", "ilinf", "dlinf")
  irecruit_mod <- as.integer(match(x, recruit_mods, -1))
  stopmess <- paste("rmodel: set to be ", paste(recruit_mods, collapse = ", "),
    sep = "")
  if (irecruit_mod < 1) {
    stop(stopmess)
  }
}
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------

#-------------------------------------------------------------------------------
# 43.  .valTinterims
#-------------------------------------------------------------------------------
.valTinterims <- function(x) {
  notNumeric <- function(x) {
    return(!is(c(x), "numeric") || length(x) > 1)
  }
  ix <- sapply(x, notNumeric)
  if (all(ix == FALSE)) {
    ix <- any(diff(c(0, x)) <= 0) || length(x) < 1
  }
  if (any(ix) == TRUE) {
    stop("interims: set to vector of ordered times >=1")
  }
}
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------

#-------------------------------------------------------------------------------
# 50.  .valContrat
#-------------------------------------------------------------------------------
.valContrat <- function(x) {
  notNumeric <- function(x) {
    return(!is(c(x), "numeric") || length(x) > 1)
  }
  isInteger <- function(x) {
    all(is.numeric(x)) && all(round(x, 0) == x)
  }
  notInteger <- function(x) {
    return(!isInteger(x) || length(x) > 1)
  }
  ix <- sapply(x, notNumeric)
  if (all(ix == FALSE) && length(x)==2) {
    x<- abs(x)
    ix <- (notInteger(x[1]) || notInteger(x[2])) || x[1] >= x[2]
    if(x[1] == 0){ix <- TRUE}
  }
  if (any(ix) == TRUE || length(x)!=2) {
    stop("contrat: invalid control to (control + treatment) ratio vector")
  }
}
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------



#-------------------------------------------------------------------------------
# End
# --------------------------------------------------------------------------
#-------------------------------------------------------------------------------