R/util.R

In randomizeR: Randomization for Clinical Trials

###############################################
# --------------------------------------------#
# util - utility functions                    #
# --------------------------------------------#
###############################################

# --------------------------------------------
# Full reference set function
# --------------------------------------------

# Function returning the full reference set given a design
#
# This function can only be applied to designs with total sample size smaller than 20.
# For \code{N=18} this matrix has more than 1 million entries and occupies 4 Mb
# of memory.
# 
# @param obj object of class ebcPar
#
# @return A matrix containing all \code{2^N} randomization sequences in the
# rows, where \code{N=N(obj)} is the total sample size.
compltSet <- function(obj) {
  if (N(obj) > 24) stop("Full reference set only computeable up to N=24. Use the parameter r in genSeq to simulate several sequences.")
  stopifnot(K(obj) == 2, identical(ratio(obj),  c(1, 1)))
  # For K > 2 this must be modified!
  unname(as.matrix(expand.grid(rep(list(0:1), N(obj)))))
}




# --------------------------------------------
# Realized block constellation
# --------------------------------------------
# 
# Generate realized block sequence for a random block design
# 
# This function can only be applied to designs with total sample size smaller than 20.
# For \code{N=18} this matrix has more than 1 million entries and occupies 4 Mb
# of memory.
# 
# @inheritParams overview
#
# @return A vector with the exact succession of the block sizes used for the design.
# E.g. c(4,6) refers to a trial with two blocks, the first of size 4, the second
# of size 6.
genBlockConst <- function(N, rb, filledBlock = FALSE) {
  # generating a vector for the used block lengths
  if (!filledBlock) {
    if (length(rb) == 1) bc <- rep(rb, ceiling(N/rb))
    else {
      bc <- numeric(0)
      repeat {
        bc <- c(bc, sample(rb, 1))
        if (sum(bc) >= N) break
      }
    }
  } else {
    if (length(rb) == 1 && ceiling(N/rb) == N/rb ) {
      return(bc <- rep(rb, ceiling(N/rb)))
    } 
    
    if (length(rb) == 1 && ceiling(N/rb) != N/rb ) {
      stop("No block constellation possible with filled blocks.")
    }
    
    bc <- numeric(0)
    repeat {
      if (length(rb) == 0) stop("No block constellation possible with filled blocks.")
      # possible block lengths
      pbl <- rb[rb <= (N - sum(bc))]
      if (length(pbl) == 0) {
        # not fitting block lengths
        nfb <- which(rb >= bc[length(bc)])
        bc <- bc[-length(bc)]
        rb <- rb[-nfb]
        next
      }
      if(length(pbl) == 1) {
        bc <- c(bc, pbl)
      } else {
        bc <- c(bc, sample(pbl, 1))
      }
      if (sum(bc) >= N) break
    }
  }  
  bc
}


# --------------------------------------------
# Last random assignment for TBD
# --------------------------------------------
# Calcultes the last random allocation of a randomization sequence generated by
# TBD.
# 
# @inheritParams overview
#
# @return The last random allocation of a randomization sequence generated by
# TBD.
lastRandom <- function(x) {
    min((1:length(x))[cumsum(x) == length(x)/2],
        (1:length(x))[cumsum(1-x) == length(x)/2])
}