R/score.R

In ornelles/virustiter: Virus Titer and Related Functions for Fluorescent Micrographs

#' Score Cells as Positive/Negative
#'
#' Assign \code{logical} variable \code{positive} as \code{TRUE} or
#' \code{FALSE} in a data.frame of fluorescent intensity values based
#' on the cutoff values in the argument \code{bgnd}.
#'
#' @param df A data.frame generated by \code{\link{parseImages}} or
#'   and an appropriate grouping variable.
#' @param bgnd A numeric vector of length one or a named numeric vector for
#'   each level of the grouping variable, typically \code{well, row, column, or file}.
#'   If missing, the function \code{\link{getBgnd}} will be called with parameters
#'   provided in \code{...} to determine the background.
#' @param param A character string identifying the variable to be scored.
#' @param ... Additional arguments for \code{\link{getBgnd}} such as \code{by}.
#'
#' @details
#'
#' A variable named \code{positive} will be added to the data.frame if 
#' necessary and assigned \code{TRUE} or \code{FALSE} if the value 
#' named in \code{"param"} is greater than the appropriate value in
#' \code{bgnd}. If \code{bgnd == NULL}, \code{\link{getBgnd}} will be called
#' with any additional arguments in \code{...} to determine the background.
#'
#' @examples
#' # Small set of data by stack
#'   f <- system.file("extdata", "by_stack", package = "virustiter")
#'   i <- getImages(f, pattern = "file005")
#'   v <- parseImages(i)
#'
#' # Score with grouping value of "file"
#'   v <- score(v, by = "file")
#'   xtabs(~ positive, v)
#'   plot(log(mfi) ~ area, v, col = c(1,2)[positive + 1])
#'
#' @import
#' EBImage
#'
#' @export
#'
score <- function(df, bgnd = NULL, param = "mfi", ...)
{
  if (missing(df)) {
    usage <- c("score examples:",
      '  score(df, bgnd)        ## bgnd holds selected background values',
      '  score(df, 123)         ## single value used as background')
    cat(usage, sep = "\n")
    return(invisible(NULL))
  }
  stopifnot(param %in% names(df))
  if (is.null(bgnd)) {
    message("Calculating default background values")
    bgnd <- getBgnd(df, param = param, ...)
  }

  if (length(bgnd) == 1)     # single values
    df$positive <- df[[param]] > bgnd
	else {	# search for names of bgnd among characters and factors in df
		sel <- sapply(df, is.factor) | sapply(df, is.character)
		choices <- lapply(df[sel], unique)
		sel <- sapply(choices, function(v) all(names(bgnd) %in% v))
		if (sum(sel) > 1)
			stop("found ", sum(sel), " possible factors matching 'bgnd' in 'df'")
		else if (sum(sel) == 0)
			stop("'bgnd' must be a single value or a named vector matching
				a variable in 'df'")
		else {
			g <- names(which(sel))
#			df$positive <- df[[param]] > bgnd[df[[g]]]
			df$positive <- df[[param]] > bgnd[as.character(df[[g]])]
		}
	}
  return(df)
}