R/bu2mm.R

In axzinker/blenderFace: Collection of functions to process blender measured facial movement data

#' Scale Blender data (Blender Units) into millimeter
#' 
#' The function rescales specific columns of a data frame according to a scale 
#' factor. For example, the scale factor can be the diameter of a glue dot 
#' measured in Blender. The columns are rescaled accordingly to represent 
#' millimeter instead of Blender Units as measurement unit. For a detailed 
#' description of the rescaling procedure refere to the vignette.
#' 
#' @param data Data frame containig the columns which should be rescaled.
#'   Remaining colums will be returned untouched. The data frame may contain 
#'   many subjects, e.g., as generated by the function 
#'   \code{\link{concatBlenderFiles}}.
#' @param colNames Character vector with names of the columns of the data 
#'   data-frame for which the data should be rescaled.
#' @param colNameSubj Character vector with a single value containig the name 
#'   of the subject column of the data data-frame.
#' @param scaleFactor This factor could be either given as a column name for a 
#'   numeric column attached to the data dataframe, or as separate numeric vector.
#'   The column or vector should contain the values of an object with known 
#'   size (e.g., a glue dot diameter) measured in blender for each subject in 
#'   the data data-frame. The scaleFactor vector must contain a scale value for 
#'   each subject in the data data-frame. The sorting of subjects in data 
#'   data-frame and the sorting of the scaleFactor vector must be the same.
#' @param rwMeasure Optional. Size of an object measured in the desired outcome
#'   measurement (e.g., in millimeter). This value is used to rescale the data
#'   columns. The default value for this parameter is the diameter of a glue dot
#'   (8 millimeter).
#' @param verbose Logical value. If TRUE, the function provides verbose console output.
#'   
#' @import utils
#' 
#' @return Data frame with columns rescaled to millimeter.
#'   
#' @author Axel Zinkernagel \email{zinkernagel@uni-wuppertal.de}
#'   
#' @examples
#' # Load the file "Blender_Scalingdata.csv"
#' scaledata <- read.csv(system.file("extdata", "Blender_Scalingdata.csv", 
#'                       package = "blenderFace"), header = TRUE, sep =",")
#' # Be sure to have the data sorted by subjects
#' scaledata <- scaledata[with(scaledata, order(scaledata$subject)), ]
#'
#' # Determin the dataframe columns which should be scaled:
#' names(rawdata)
#' # -> Frame, Stimulustype and subject should not be scaled -> removed for variable colNames
#'colNames <- c("A7_x",  "A7_y",  "A7_z",  "A8_x",  "A8_y",  "A8_z",  
#'              "BL2_x", "BL2_y", "BL2_z", "BL4_x", "BL4_y", "BL4_z", 
#'              "BL5_x", "BL5_y", "BL5_z", "BL7_x", "BL7_y", "BL7_z",       
#'              "BR2_x", "BR2_y", "BR2_z", "BR4_x", "BR4_y", "BR4_z", 
#'              "BR5_x", "BR5_y", "BR5_z", "BR7_x", "BR7_y", "BR7_z", 
#'              "CL4_x", "CL4_y", "CL4_z", "CL7_x", "CL7_y", "CL7_z",       
#'              "CR4_x", "CR4_y", "CR4_z", "CR7_x", "CR7_y", "CR7_z", 
#'              "DL2_x", "DL2_y", "DL2_z", "DR2_x", "DR2_y", "DR2_z")
#'
#' # To not overwrite existing data, use a new data frame 
#' # (dataSmm means data scaled in millimeter)
#' dataSmm <- bu2mm(data = rawdata, colNames = colNames, colNameSubj = "subject", 
#'                  scaleFactor = scaledata$GlueDotDiameter, rwMeasure = 8, 
#'                  verbose = TRUE)
#' @export

bu2mm <- function(data, colNames, colNameSubj, scaleFactor, rwMeasure = 8, verbose = FALSE) {
  # Error handling
  if (!(is.data.frame(data))) {
    stop("Argument data does not contain a data frame!")
  }
  
  if (!(is.character(colNames))) {
    stop("Argument colNames is missing or not of type character!")
  }
  
  if (!(is.character(colNameSubj))) {
    stop("Argument colNameSubj is missing or not of type character!")
  }
  
  if (any(is.na(match(colNames,colnames(data))))) {
    stop(paste("Invalid column(s): ",colNames[which(is.na(match(colNames,colnames(data))))]))
  }
  
  if (is.character(scaleFactor))   # is it a valid column name in the data dataframe?
    stopifnot(scaleFactor %in% colnames(data))
  else                             # test, if data frame subjects and scaleFactor subjects have the same length
    if (!(is.numeric(scaleFactor)) | !(length(scaleFactor) >= 2))
      stop("Argument scaleFactor is neither a column name nor of type numeric, or contains only one value!")
  else
    if (length(unique(data[[colNameSubj]])) != length(scaleFactor)) 
      stop(paste("Number of subjects in data data-frame (", length(unique(data[[colNameSubj]])), ") is not equal to length of scaleFactor (", 
                 length(scaleFactor), ")!", sep = ""))
  
  
  if (!(is.numeric(rwMeasure)) | (length(rwMeasure) != 1)) {
    stop("Argument rwMeasure is not of type numeric or contains more than one value!")
  }
  
  if (!(is.logical(verbose))) {
    stop("Argument verbose is not of type logical!")
  }
  
  # Helper functions
  fcat <- function(...,newline=TRUE) {if (newline) cat(...,"\n") else cat(...); flush.console() }  # immediate console output
  
  # Principle of rescaling: Perform scaling via rule of proportion (BU = blender units).
  # ((Diameter in BU)/(Diameter in mm)) = Factor to divide BU by, to obtain mm
  # For example, a glue dot has a diameter of 8 mm and is measured in Blender with a diameter of 1 BU:
  # ((1 BU)/(8 mm)) = 0.125
  # ((2 BU)/ 0.125) = 16 mm
  
  if (is.character(scaleFactor))
    data[,colNames] = data[,colNames] * rwMeasure/data[,scaleFactor]
  else {
    subjects <- unique(data[[colNameSubj]])   # Determine number of subjects in data
    for (i in 1:length(subjects)) {           # *** RA: tapply?
      isF <- scaleFactor[i]/rwMeasure         # Determine individual scaleFactor; very important to have the same subject sorting of data dataframe and scaleFactor vector!
      if (verbose) fcat(paste("Perform scaling to millimeters for Subject ", i, " of ", length(subjects), ". Individual scale factor is ",round(isF,6),".", sep = ""))
      data[data$subject == subjects[i], colNames] <- data[data$subject == subjects[i], colNames] / isF  # Rescale data per subject
    }  # end for
  }  # end else
  
  invisible(data)
}