R/Inf.D3.OTC1.R

Defines functions Inf.D3.OTC1

# Start  Inf.D3.OTC1() function
###############################################################################
# Brianna Hitt - 05-01-17
# Updated: Brianna Hitt - 06-20-18

# Brianna Hitt - 04.02.2020
# Changed cat() to message()

Inf.D3.OTC1 <- function(p, Se, Sp, group.sz, obj.fn, weights = NULL, alpha = 2,
                        updateProgress = NULL, trace = TRUE,
                        print.time = TRUE, ...) {

  start.time <- proc.time()

  set.of.I <- group.sz

  save.ET <- matrix(data = NA, nrow = length(set.of.I),
                    ncol = 2 * max(set.of.I) + 8)
  save.MAR <- matrix(data = NA, nrow = length(set.of.I),
                     ncol = 2 * max(set.of.I) + 8)
  save.GR1 <- matrix(data = NA, nrow = length(set.of.I),
                     ncol = 2 * max(set.of.I) + 8)
  save.GR2 <- matrix(data = NA, nrow = length(set.of.I),
                     ncol = 2 * max(set.of.I) + 8)
  save.GR3 <- matrix(data = NA, nrow = length(set.of.I),
                     ncol = 2 * max(set.of.I) + 8)
  save.GR4 <- matrix(data = NA, nrow = length(set.of.I),
                     ncol = 2 * max(set.of.I) + 8)
  save.GR5 <- matrix(data = NA, nrow = length(set.of.I),
                     ncol = 2 * max(set.of.I) + 8)
  save.GR6 <- matrix(data = NA, nrow = length(set.of.I),
                     ncol = 2 * max(set.of.I) + 8)

  count <- 1

  for (I in set.of.I) {
    # build a vector of probabilities for a heterogeneous population
    if (length(p) == 1) {
      p.vec <- expectOrderBeta(p = p, alpha = alpha, size = I, ...)
    } else if (length(p) > 1) {
      p.vec <- sort(p)
      alpha <- NA
    }

    # generate a matrix of all possible configurations/sets of pool sizes
    # the parts() function requires loading the partitions library
    # do not include the first column, which would test the initial group twice
    possible.groups <- parts(n = I)[,-1]

    save.it <- matrix(data = NA, nrow = ncol(possible.groups),
                      ncol = 2 * max(set.of.I) + 15)

    counter <- 1
    for (c in 1:ncol(possible.groups)) {
      # extract the configuration, ordering, and group sizes for each column
      config <- c(possible.groups[,c], 1:I)
      order.for.p <- config[(1 + I):(2 * I)]
      gp.sizes <- config[1:I]

      # call hierarchical.desc2() for the configuration
      save.info <- hierarchical.desc2(p = p.vec[order.for.p], se = Se, sp = Sp,
                                      I2 = gp.sizes[gp.sizes != 0],
                                      order.p = FALSE)

      # extract accuracy measures for each individual
      ET <- save.info$ET
      PSe.vec <- save.info$individual.testerror$pse.vec
      PSp.vec <- save.info$individual.testerror$psp.vec
      if ("MAR" %in% obj.fn) {
        MAR <- MAR.func(ET = ET, p.vec = p.vec,
                        PSe.vec = PSe.vec, PSp.vec = PSp.vec)
      } else {MAR <- NA}

      # calculate overall accuracy measures
      group.testerror <- save.info$group.testerror
      names(group.testerror) <- NULL
      PSe <- group.testerror[1]
      PSp <- group.testerror[2]
      PPPV <- group.testerror[3]
      PNPV <- group.testerror[4]

      # for each row in the matrix of weights, calculate the GR function
      if (is.null(dim(weights))) {
        GR1 <- NA
        GR2 <- NA
        GR3 <- NA
        GR4 <- NA
        GR5 <- NA
        GR6 <- NA
      } else {
        GR1 <- GR.func(ET = ET, p.vec = p.vec,
                       PSe.vec = PSe.vec, PSp.vec = PSp.vec,
                       D1 = weights[1,1], D2 = weights[1,2])
        if (dim(weights)[1] >= 2) {
          GR2 <- GR.func(ET = ET, p.vec = p.vec,
                         PSe.vec = PSe.vec, PSp.vec = PSp.vec,
                         D1 = weights[2,1], D2 = weights[2,2])
        } else {GR2 <- NA}
        if (dim(weights)[1] >= 3) {
          GR3 <- GR.func(ET = ET, p.vec = p.vec,
                         PSe.vec = PSe.vec, PSp.vec = PSp.vec,
                         D1 = weights[3,1], D2 = weights[3,2])
        } else {GR3 <- NA}
        if (dim(weights)[1] >= 4) {
          GR4 <- GR.func(ET = ET, p.vec = p.vec,
                         PSe.vec = PSe.vec, PSp.vec = PSp.vec,
                         D1 = weights[4,1], D2 = weights[4,2])
        } else {GR4 <- NA}
        if (dim(weights)[1] >= 5) {
          GR5 <- GR.func(ET = ET, p.vec = p.vec,
                         PSe.vec = PSe.vec, PSp.vec = PSp.vec,
                         D1 = weights[5,1], D2 = weights[5,2])
        } else {GR5 <- NA}
        if (dim(weights)[1] >= 6) {
          GR6 <- GR.func(ET = ET, p.vec = p.vec,
                         PSe.vec = PSe.vec, PSp.vec = PSp.vec,
                         D1 = weights[6,1], D2 = weights[6,2])
        } else {GR6 <- NA}
      }

      save.it[counter,] <- c(p.vec,
                             rep(NA, max(0, max(set.of.I) - length(p.vec))),
                             alpha, I, ET, ET / I, MAR, GR1 / I, GR2 / I,
                             GR3 / I, GR4 / I, GR5 / I, GR6 / I,
                             PSe, PSp, PPPV, PNPV, gp.sizes,
                             rep(0, max(0, max(set.of.I) - length(gp.sizes))))
      counter <- counter + 1

    }

    # save the top configurations for each initial group size
    num.top <- 10
    if (I  ==  set.of.I[1]) {
      if (obj.fn[1] == "ET") {
        top.configs <- as.matrix(save.it[order(save.it[,(max(set.of.I) + 4)]),])[1:min(nrow(save.it), num.top), c(1:(max(set.of.I) + 3),(max(set.of.I) + 4),(max(set.of.I) + 12):ncol(save.it))]
      } else if (obj.fn[1] == "MAR") {
        top.configs <- as.matrix(save.it[order(save.it[,(max(set.of.I) + 5)]),])[1:min(nrow(save.it), num.top), c(1:(max(set.of.I) + 3),(max(set.of.I) + 5),(max(set.of.I) + 12):ncol(save.it))]
      } else if (obj.fn[1] == "GR") {
        top.configs <- as.matrix(save.it[order(save.it[,(max(set.of.I) + 6)]),])[1:min(nrow(save.it), num.top), c(1:(max(set.of.I) + 3),(max(set.of.I) + 6),(max(set.of.I) + 12):ncol(save.it))]
      }
    } else if (I > set.of.I[1]) {
      if (obj.fn[1] == "ET") {
        top.configs <- rbind(top.configs, as.matrix(save.it[order(save.it[,(max(set.of.I) + 4)]),])[1:min(nrow(save.it), num.top), c(1:(max(set.of.I) + 3),(max(set.of.I) + 4),(max(set.of.I) + 12):ncol(save.it))])
      } else if (obj.fn[1] == "MAR") {
        top.configs <- rbind(top.configs, as.matrix(save.it[order(save.it[,(max(set.of.I) + 5)]),])[1:min(nrow(save.it), num.top), c(1:(max(set.of.I) + 3),(max(set.of.I) + 5),(max(set.of.I) + 12):ncol(save.it))])
      } else if (obj.fn[1] == "GR") {
        top.configs <- rbind(top.configs, as.matrix(save.it[order(save.it[,(max(set.of.I) + 6)]),])[1:min(nrow(save.it), num.top), c(1:(max(set.of.I) + 3),(max(set.of.I) + 6),(max(set.of.I) + 12):ncol(save.it))])
      }
    }

    # find the best configuration for each initial group size I, out of all possible configurations
    save.ET[count,] <- save.it[save.it[,(max(set.of.I) + 4)] == min(save.it[,(max(set.of.I) + 4)]), c(1:(max(set.of.I) + 3),(max(set.of.I) + 4),(max(set.of.I) + 12):ncol(save.it))]
    if (!inherits(try(save.MAR[count,] <- save.it[save.it[,(max(set.of.I) + 5)] == min(save.it[,(max(set.of.I) + 5)]), c(1:(max(set.of.I) + 3),(max(set.of.I) + 5),(max(set.of.I) + 12):ncol(save.it))],silent = T), "try-error")) {
      save.MAR[count,] <- save.it[save.it[,(max(set.of.I) + 5)] == min(save.it[,(max(set.of.I) + 5)]), c(1:(max(set.of.I) + 3),(max(set.of.I) + 5),(max(set.of.I) + 12):ncol(save.it))]
    }
    if (!inherits(try(save.GR1[count,] <- save.it[save.it[,(max(set.of.I) + 6)] == min(save.it[,(max(set.of.I) + 6)]), c(1:(max(set.of.I) + 3),(max(set.of.I) + 6),(max(set.of.I) + 12):ncol(save.it))],silent = T), "try-error")) {
      save.GR1[count,] <- save.it[save.it[,(max(set.of.I) + 6)] == min(save.it[,(max(set.of.I) + 6)]), c(1:(max(set.of.I) + 3),(max(set.of.I) + 6),(max(set.of.I) + 12):ncol(save.it))]
    }
    if (!inherits(try(save.GR2[count,] <- save.it[save.it[,(max(set.of.I) + 7)] == min(save.it[,(max(set.of.I) + 7)]), c(1:(max(set.of.I) + 3),(max(set.of.I) + 7),(max(set.of.I) + 12):ncol(save.it))],silent = T), "try-error")) {
      save.GR2[count,] <- save.it[save.it[,(max(set.of.I) + 7)] == min(save.it[,(max(set.of.I) + 7)]), c(1:(max(set.of.I) + 3),(max(set.of.I) + 7),(max(set.of.I) + 12):ncol(save.it))]
    }
    if (!inherits(try(save.GR3[count,] <- save.it[save.it[,(max(set.of.I) + 8)] == min(save.it[,(max(set.of.I) + 8)]), c(1:(max(set.of.I) + 3),(max(set.of.I) + 8),(max(set.of.I) + 12):ncol(save.it))],silent = T), "try-error")) {
      save.GR3[count,] <- save.it[save.it[,(max(set.of.I) + 8)] == min(save.it[,(max(set.of.I) + 8)]), c(1:(max(set.of.I) + 3),(max(set.of.I) + 8),(max(set.of.I) + 12):ncol(save.it))]
    }
    if (!inherits(try(save.GR4[count,] <- save.it[save.it[,(max(set.of.I) + 9)] == min(save.it[,(max(set.of.I) + 9)]), c(1:(max(set.of.I) + 3),(max(set.of.I) + 9),(max(set.of.I) + 12):ncol(save.it))],silent = T), "try-error")) {
      save.GR4[count,] <- save.it[save.it[,(max(set.of.I) + 9)] == min(save.it[,(max(set.of.I) + 9)]), c(1:(max(set.of.I) + 3),(max(set.of.I) + 9),(max(set.of.I) + 12):ncol(save.it))]
    }
    if (!inherits(try( save.GR5[count,] <- save.it[save.it[,(max(set.of.I) + 10)] == min(save.it[,(max(set.of.I) + 10)]), c(1:(max(set.of.I) + 3),(max(set.of.I) + 10),(max(set.of.I) + 12):ncol(save.it))],silent = T), "try-error")) {
      save.GR5[count,] <- save.it[save.it[,(max(set.of.I) + 10)] == min(save.it[,(max(set.of.I) + 10)]), c(1:(max(set.of.I) + 3),(max(set.of.I) + 10),(max(set.of.I) + 12):ncol(save.it))]
    }
    if (!inherits(try(save.GR6[count,] <- save.it[save.it[,(max(set.of.I) + 11)] == min(save.it[,(max(set.of.I) + 11)]), c(1:(max(set.of.I) + 3),(max(set.of.I) + 11),(max(set.of.I) + 12):ncol(save.it))],silent = T), "try-error")) {
      save.GR6[count,] <- save.it[save.it[,(max(set.of.I) + 11)] == min(save.it[,(max(set.of.I) + 11)]), c(1:(max(set.of.I) + 3),(max(set.of.I) + 11),(max(set.of.I) + 12):ncol(save.it))]
    }

    if (is.function(updateProgress)) {
      updateText <- paste0("Initial Pool Size = ", I)
      updateProgress(value = count / (length(set.of.I) + 1),
                     detail = updateText)
    }

    # print the progress, if trace == TRUE
    if (trace) {
      cat("Initial Group Size = ", I, "\n", sep = "")
    }

    count <- count + 1
  }

  # reorder matrix of top configurations by E(T)/I
  top.configs <- top.configs[order(top.configs[,(max(set.of.I) + 4)]),]
  colnames(top.configs) <- c(rep(x = "p", times = max(set.of.I)),
                             "alpha", "I", "ET", "value", "PSe", "PSp",
                             "PPPV", "PNPV", rep(x = "pool.sz",
                                                 times = max(set.of.I)))
  top.configs <- convert.config(algorithm = "ID3", results = top.configs)

  # save the best configuration for each initial group size
  if (length(set.of.I) == 1) {
    configs <- NA
  } else {
    if (obj.fn[1] == "ET") {
      configs <- as.matrix(save.ET)[order(save.ET[,(max(set.of.I) + 4)]),]
    } else if (obj.fn[1] == "MAR") {
      configs <- as.matrix(save.MAR)[order(save.MAR[,(max(set.of.I) + 4)]),]
    } else if (obj.fn[1] == "GR") {
      configs <- as.matrix(save.GR1)[order(save.GR1[,(max(set.of.I) + 4)]),]
    }

    colnames(configs) <- c(rep(x = "p", times = max(set.of.I)),
                           "alpha", "I", "ET", "value", "PSe", "PSp",
                           "PPPV", "PNPV", rep(x = "pool.sz",
                                               times = max(set.of.I)))
    configs <- convert.config(algorithm = "ID3", results = configs)
  }

  # find the optimal testing configuration, over all initial group sizes considered
  result.ET <- save.ET[save.ET[,(max(set.of.I) + 4)] == min(save.ET[,(max(set.of.I) + 4)]),]
  result.MAR <- save.MAR[save.MAR[,(max(set.of.I) + 4)] == min(save.MAR[,(max(set.of.I) + 4)]),]
  result.GR1 <- save.GR1[save.GR1[,(max(set.of.I) + 4)] == min(save.GR1[,(max(set.of.I) + 4)]),]
  result.GR2 <- save.GR2[save.GR2[,(max(set.of.I) + 4)] == min(save.GR2[,(max(set.of.I) + 4)]),]
  result.GR3 <- save.GR3[save.GR3[,(max(set.of.I) + 4)] == min(save.GR3[,(max(set.of.I) + 4)]),]
  result.GR4 <- save.GR4[save.GR4[,(max(set.of.I) + 4)] == min(save.GR4[,(max(set.of.I) + 4)]),]
  result.GR5 <- save.GR5[save.GR5[,(max(set.of.I) + 4)] == min(save.GR5[,(max(set.of.I) + 4)]),]
  result.GR6 <- save.GR6[save.GR6[,(max(set.of.I) + 4)] == min(save.GR6[,(max(set.of.I) + 4)]),]

  p.vec.ET <- (result.ET[1:max(set.of.I)])[!is.na(result.ET[1:max(set.of.I)])]
  if ("MAR" %in% obj.fn) {
    p.vec.MAR <- (result.MAR[1:max(set.of.I)])[!is.na(result.MAR[1:max(set.of.I)])]
  } else {p.vec.MAR <- NA}
  if (is.null(dim(weights))) {
    p.vec.GR1 <- NA
    p.vec.GR2 <- NA
    p.vec.GR3 <- NA
    p.vec.GR4 <- NA
    p.vec.GR5 <- NA
    p.vec.GR6 <- NA
  } else {
    p.vec.GR1 <- (result.GR1[1:max(set.of.I)])[!is.na(result.GR1[1:max(set.of.I)])]
    if (dim(weights)[1] >= 2) {
      p.vec.GR2 <- (result.GR2[1:max(set.of.I)])[!is.na(result.GR2[1:max(set.of.I)])]
    } else {p.vec.GR2 <- NA}
    if (dim(weights)[1] >= 3) {
      p.vec.GR3 <- (result.GR3[1:max(set.of.I)])[!is.na(result.GR3[1:max(set.of.I)])]
    } else {p.vec.GR3 <- NA}
    if (dim(weights)[1] >= 4) {
      p.vec.GR4 <- (result.GR4[1:max(set.of.I)])[!is.na(result.GR4[1:max(set.of.I)])]
    } else {p.vec.GR4 <- NA}
    if (dim(weights)[1] >= 5) {
      p.vec.GR5 <- (result.GR5[1:max(set.of.I)])[!is.na(result.GR5[1:max(set.of.I)])]
    } else {p.vec.GR5 <- NA}
    if (dim(weights)[1] >= 6) {
      p.vec.GR6 <- (result.GR6[1:max(set.of.I)])[!is.na(result.GR6[1:max(set.of.I)])]
    } else {p.vec.GR6 <- NA}
  }

  # put accuracy measures in a matrix for easier display of results
  acc.ET <- matrix(data = result.ET[(max(set.of.I) + 5:8)],
                   nrow = 1, ncol = 4,
                   dimnames = list(NULL, c("PSe", "PSp", "PPPV", "PNPV")))
  acc.MAR <- matrix(data = result.MAR[(max(set.of.I) + 5:8)],
                    nrow = 1, ncol = 4,
                    dimnames = list(NULL, c("PSe", "PSp", "PPPV", "PNPV")))
  acc.GR1 <- matrix(data = result.GR1[(max(set.of.I) + 5:8)],
                    nrow = 1, ncol = 4,
                    dimnames = list(NULL, c("PSe", "PSp", "PPPV", "PNPV")))
  acc.GR2 <- matrix(data = result.GR2[(max(set.of.I) + 5:8)],
                    nrow = 1, ncol = 4,
                    dimnames = list(NULL, c("PSe", "PSp", "PPPV", "PNPV")))
  acc.GR3 <- matrix(data = result.GR3[(max(set.of.I) + 5:8)],
                    nrow = 1, ncol = 4,
                    dimnames = list(NULL, c("PSe", "PSp", "PPPV", "PNPV")))
  acc.GR4 <- matrix(data = result.GR4[(max(set.of.I) + 5:8)],
                    nrow = 1, ncol = 4,
                    dimnames = list(NULL, c("PSe", "PSp", "PPPV", "PNPV")))
  acc.GR5 <- matrix(data = result.GR5[(max(set.of.I) + 5:8)],
                    nrow = 1, ncol = 4,
                    dimnames = list(NULL, c("PSe", "PSp", "PPPV", "PNPV")))
  acc.GR6 <- matrix(data = result.GR6[(max(set.of.I) + 5:8)],
                    nrow = 1, ncol = 4,
                    dimnames = list(NULL, c("PSe", "PSp", "PPPV", "PNPV")))

  # create a list of results for each objective function
  opt.ET <- list("OTC" = list("Stage1" = result.ET[(max(set.of.I) + 2)],
                              "Stage2" = (result.ET[(max(set.of.I) + 9):length(result.ET)])[result.ET[(max(set.of.I) + 9):length(result.ET)] != 0]),
                 "p.vec" = p.vec.ET, "ET" = result.ET[(max(set.of.I) + 3)],
                 "value" = result.ET[(max(set.of.I) + 4)], "Accuracy" = acc.ET)
  opt.MAR <- list("OTC" = list("Stage1" = result.MAR[(max(set.of.I) + 2)],
                               "Stage2" = (result.MAR[(max(set.of.I) + 9):length(result.MAR)])[result.MAR[(max(set.of.I) + 9):length(result.MAR)] != 0]),
                  "p.vec" = p.vec.MAR, "ET" = result.MAR[(max(set.of.I) + 3)],
                  "value" = result.MAR[(max(set.of.I) + 4)], "Accuracy" = acc.MAR)
  opt.GR1 <- list("OTC" = list("Stage1" = result.GR1[(max(set.of.I) + 2)],
                               "Stage2" = (result.GR1[(max(set.of.I) + 9):length(result.GR1)])[result.GR1[(max(set.of.I) + 9):length(result.GR1)] != 0]),
                  "p.vec" = p.vec.GR1, "ET" = result.GR1[(max(set.of.I) + 3)],
                  "value" = result.GR1[(max(set.of.I) + 4)], "Accuracy" = acc.GR1)
  opt.GR2 <- list("OTC" = list("Stage1" = result.GR2[(max(set.of.I) + 2)],
                               "Stage2" = (result.GR2[(max(set.of.I) + 9):length(result.GR2)])[result.GR2[(max(set.of.I) + 9):length(result.GR2)] != 0]),
                  "p.vec" = p.vec.GR2, "ET" = result.GR2[(max(set.of.I) + 3)],
                  "value" = result.GR2[(max(set.of.I) + 4)], "Accuracy" = acc.GR2)
  opt.GR3 <- list("OTC" = list("Stage1" = result.GR3[(max(set.of.I) + 2)],
                               "Stage2" = (result.GR3[(max(set.of.I) + 9):length(result.GR3)])[result.GR3[(max(set.of.I) + 9):length(result.GR3)] != 0]),
                  "p.vec" = p.vec.GR3, "ET" = result.GR3[(max(set.of.I) + 3)],
                  "value" = result.GR3[(max(set.of.I) + 4)], "Accuracy" = acc.GR3)
  opt.GR4 <- list("OTC" = list("Stage1" = result.GR4[(max(set.of.I) + 2)],
                               "Stage2" = (result.GR4[(max(set.of.I) + 9):length(result.GR4)])[result.GR4[(max(set.of.I) + 9):length(result.GR4)] != 0]),
                  "p.vec" = p.vec.GR4,  "ET" = result.GR4[(max(set.of.I) + 3)],
                  "value" = result.GR4[(max(set.of.I) + 4)], "Accuracy" = acc.GR4)
  opt.GR5 <- list("OTC" = list("Stage1" = result.GR5[(max(set.of.I) + 2)],
                               "Stage2" = (result.GR5[(max(set.of.I) + 9):length(result.GR5)])[result.GR5[(max(set.of.I) + 9):length(result.GR5)] != 0]),
                  "p.vec" = p.vec.GR5, "ET" = result.GR5[(max(set.of.I) + 3)],
                  "value" = result.GR5[(max(set.of.I) + 4)], "Accuracy" = acc.GR5)
  opt.GR6 <- list("OTC" = list("Stage1" = result.GR6[(max(set.of.I) + 2)],
                               "Stage2" = (result.GR6[(max(set.of.I) + 9):length(result.GR6)])[result.GR6[(max(set.of.I) + 9):length(result.GR6)] != 0]),
                  "p.vec" = p.vec.GR6, "ET" = result.GR6[(max(set.of.I) + 3)],
                  "value" = result.GR6[(max(set.of.I) + 4)], "Accuracy" = acc.GR6)

  # create input accuracy value matrices for output display
  Se.display <- matrix(data = Se, nrow = 1, ncol = 3,
                       dimnames = list(NULL, "Stage" = 1:3))
  Sp.display <- matrix(data = Sp, nrow = 1, ncol = 3,
                       dimnames = list(NULL, "Stage" = 1:3))

  # create a list of results, including all objective functions
  opt.all <- list("opt.ET" = opt.ET, "opt.MAR" = opt.MAR, "opt.GR1" = opt.GR1,
                  "opt.GR2" = opt.GR2, "opt.GR3" = opt.GR3, "opt.GR4" = opt.GR4,
                  "opt.GR5" = opt.GR5, "opt.GR6" = opt.GR6)
  # remove any objective functions not requested by the user
  opt.req <- Filter(function(x) !is.na(x$ET), opt.all)

  # print the time elapsed, if print.time == TRUE
  if (print.time) {
    time.it(start.time)
  }

  inputs <- list("algorithm" = "Informative three-stage hierarchical testing",
                 "prob" = list(p), "alpha" = alpha,
                 "Se" = Se.display, "Sp" = Sp.display)
  res <- c(inputs, opt.req)
  res[["Configs"]] <- configs
  res[["Top.Configs"]] <- top.configs
  res
}

###############################################################################

Try the binGroup2 package in your browser

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

binGroup2 documentation built on Nov. 14, 2023, 9:06 a.m.