R/mc6.R

In pmpsa-hpc/GladiaTOX: R Package for Processing High Content Screening data

#####################################################################
## This program is distributed in the hope that it will be useful, ##
## but WITHOUT ANY WARRANTY; without even the implied warranty of  ##
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the    ##
## GNU General Public License for more details.                    ##
#####################################################################

#-------------------------------------------------------------------------------
# mc6: Perform level 6 multiple-concentration processing
#-------------------------------------------------------------------------------

#' @template proclvl
#' @templateVar LVL 6
#' @templateVar type mc
#'
#' @inheritParams mc4
#'
#' @details
#' Level 6 multiple-concentration flagging uses both the plate level
#' concentration-response data and the modeled parameters to flag potential
#' false positives and false negative results.
#'
#' @seealso \code{\link{Method functions}}, \code{\link{MC6_Methods}}
#'
#' @keywords internal
#' 
#' @import data.table

mc6 <- function(ae, wr=FALSE) {

    ## Variable-binding to pass R CMD Check
    mthd_id <- m4id <- m5id <- lval <- rval <- J <- mthd <- bmad <- NULL

    owarn <- getOption("warn")
    options(warn=1)
    on.exit(options(warn=owarn))

    ## Check the ae input
    if (length(ae) > 1) {
        warning("ae must be of length 1. Level 6 ",
                "processing incomplete; no updates",
                "\n  made to the mc6 table for AEIDS ",
                paste(ae, collapse=", "), ".")
        if(wr) return(FALSE) else return(list(FALSE, NULL))
    }

    stime <- Sys.time()

    ## Load the mc6 flags
    ms <- gtoxMthdLoad(lvl=6L, id=ae, type="mc")
    if (nrow(ms) == 0) {
        warning("No level 6 methods assigned to AEID", ae, ".")
        if(wr) return(TRUE) else return(list(TRUE, NULL))
    }
    setkey(ms, mthd_id)

    ## Load level 5 and, if needed, level 3 data
    ft <- gtoxLoadData(lvl=5L, type="mc", fld="aeid", val=ae)
    setkey(ft, m4id)
    if (any(ms$nddr)) {
        dr <- .load6DR(ae)
        setkey(dr, m4id)
        dr <- dr[ft[ , list(m4id, m5id)]]
        dr[ , bmad := unique(ft$bmad)]
    }

    ## Check if any level 5 data was loaded
    if (nrow(ft) == 0) {
        warning("No level 5 data for AEID", ae, ". Level 6 ",
                "processing incomplete;",
                " no updates\n  made to the mc6 table for AEID", ae, ".")
        if(wr) return(FALSE) else return(list(FALSE, NULL))
    }

    ttime <- round(difftime(Sys.time(), stime, units="sec"), 2)
    ttime <- paste(unclass(ttime), units(ttime))

    message("Loaded L5 AEID", ae, " (", nrow(ft),
            " rows; ", ttime,")\n", sep="")

    stime <- Sys.time()

    ## Initialize f, the list of data.tables containing the flag information
    f <- vector(mode="list", length=max(ms$mthd_id))

    ## Generate and evaluate flag expressions
    mthd_funcs <- mc6_mthds()
    exprs <- lapply(ms$mthd_id, function(x) mthd_funcs[[ms[J(x), mthd]]](x))
    fenv <- environment()
    invisible(rapply(exprs, eval, envir=fenv))

    f <- rbindlist(f)

    ttime <- round(difftime(Sys.time(), stime, units="sec"), 2)
    ttime <- paste(unclass(ttime), units(ttime))
    message("Processed L6 AEID", ae, " (", nrow(ft),
            " rows; ", ttime, ")\n", sep="")

    res <- TRUE

    ## Load into mc6 table -- else return results
    if (wr) {

        stime <- Sys.time()

        if (nrow(f) == 0) {
            ttime <- round(difftime(Sys.time(), stime, units="sec"), 2)
            ttime <- paste(unclass(ttime), units(ttime))
            warning("No flags to write for AEID", ae, sep="")
            return(TRUE)
        }

        gtoxWriteData(dat=f, lvl=6L, type="mc")

        ttime <- round(difftime(Sys.time(), stime, units="sec"), 2)
        ttime <- paste(unclass(ttime), units(ttime))
        message("Wrote L6 AEID", ae, " (", nrow(f), " rows; ", ttime,
                ")\n", sep="")
    } else {
        res <- c(list(res), list(f))
    }

    return(res)

}

#-------------------------------------------------------------------------------