R/detStructAddVarNames.R

In behaviorchange: Tools for Behavior Change Researchers and Professionals

#' Functions to preprocess determinant structures
#'
#' These functions are used in conjunction with the
#' \code{\link{determinantStructure}} family of funtions to conveniently work
#' with determinant structures.
#'
#' This family of functions will be explained more in detail in a forthcoming
#' paper.
#'
#' @aliases detStructAddVarLabels detStructAddVarNames detStructComputeProducts
#' detStructComputeScales
#' @param determinantStructure The \code{\link{determinantStructure}} object.
#' @param varLabelDf The variable label dataframe as generated by the
#' `processLSvarLabels` in the `userfriendlyscience` package.  It is also possible
#' to specify a 'homemade' dataframe, in which case the column names have to
#' specified (see the next arguments).
#' @param varNameCol The name of the column of the \code{varLabelDf} that
#' contains the variable name. Only needs to be changed from the default value
#' if \code{varLabelDf} is not a dataframe as produced by
#' `processLSvarLabels`.
#' @param leftAnchorCol The name of the column of the \code{varLabelDf} that
#' contains the left anchor. Only needs to be changed from the default value if
#' \code{varLabelDf} is not a dataframe as produced by
#' `processLSvarLabels`.
#' @param rightAnchorCol The name of the column of the \code{varLabelDf} that
#' contains the right anchor. Only needs to be changed from the default value
#' if \code{varLabelDf} is not a dataframe as produced by
#' `processLSvarLabels`.
#' @param subQuestionCol The name of the column of the \code{varLabelDf} that
#' contains the subquestion. Only needs to be changed from the default value if
#' \code{varLabelDf} is not a dataframe as produced by
#' `processLSvarLabels`.
#' @param questionTextCol The name of the column of the \code{varLabelDf} that
#' contains the question text. Only needs to be changed from the default value
#' if \code{varLabelDf} is not a dataframe as produced by
#' `processLSvarLabels`.
#' @param names A character vector with the variable names. These are matched
#' against the regular expressions as specified in the
#' \code{\link{determinantStructure}} object, and any matches will be stored in
#' the \code{\link{determinantStructure}} object.
#' @param data The dataframe containing the data; the variables names specified
#' in \code{names} (when calling \code{detStructAddVarNames}) must be present
#' in this dataframe.
#' @param append Whether to only return the products or scales, or whether to
#' append these to the dataframe and return the entire dataframe.
#' @param separator The separator to use when constructing the scale variables
#' names.
#' @return \code{detStructAddVarLabels} and \code{detStructAddVarNames} just
#' change the \code{\link{determinantStructure}} object;
#' \code{detStructComputeProducts} and \code{detStructComputeScales} return
#' either the dataframe with the new variables appended (if \code{append} =
#' \code{TRUE}) or just a dataframe with the new variables (if \code{append} =
#' \code{FALSE}).
#' @seealso \code{\link{determinantStructure}}, \code{\link{determinantVar}},
#' \code{\link{subdeterminants}}, \code{\link{subdeterminantProducts}},
#' \code{\link{detStructCIBER}}
#' @references (Forthcoming)
#' @keywords utilities
#' @export
#' @name detStructPreprocessing
#' @rdname detStructPreprocessing
#' @examples
#' ### Create some bogus determinant data
#' detStudy <- mtcars[, c(1, 3:7)];
#' names(detStudy) <- c('rUse_behav',
#'                      'rUse_intention',
#'                      'rUse_attitude1',
#'                      'rUse_attitude2',
#'                      'rUse_expAtt1',
#'                      'rUse_expAtt2');
#'
#' ### Specify the determinant structure
#'
#' ### First a subdeterminant
#' expAtt <-
#'   behaviorchange::subdeterminants("Subdeterminants",
#'                                   "expAtt");
#'
#' ### Then two determinants
#' attitude <-
#'   behaviorchange::determinantVar("Determinant",
#'                                  "attitude",
#'                                  expAtt);
#'
#' intention <-
#'   behaviorchange::determinantVar("ProximalDeterminant",
#'                                  "intention",
#'                                  attitude);
#'
#' ### Then the entire determinant strcture
#' detStruct <-
#'   behaviorchange::determinantStructure('Behavior',
#'                                        list('behav',
#'                                        behaviorRegEx = 'rUse'),
#'                                        intention);
#'
#' ### Add the variable names
#' behaviorchange::detStructAddVarNames(detStruct,
#'                                      names(detStudy));
#'
#' ### Add the determinant scale variable to the dataframe
#' detStudyPlus <-
#'   behaviorchange::detStructComputeScales(detStruct,
#'                                          data=detStudy);
#'
#' ### Show its presence
#' names(detStudyPlus);
#' mean(detStudyPlus$rUse_Determinant);
#'
detStructAddVarNames <- function(determinantStructure,
                                 names) {

  ### Get all behaviorRegExes that are set (should only be one)
  behaviorRegEx <- data.tree::Get(nodes=list(determinantStructure),
                                  attribute='behaviorRegEx',
                                  traversal='level',
                                  filterFun=function(x) return(!is.null(data.tree::Get(nodes=list(x),
                                                                                       attribute='behaviorRegEx'))));

  ### Remove any duplicates and select the first one in case there are more
  behaviorRegEx <- unique(behaviorRegEx)[1];

  ### Only retain the names matching that behavior regex
  allNms <- grep(behaviorRegEx, names, value=TRUE);

  ### Walk through the determinant structure and select the
  ### matching variable names, adding the to the structure
  data.tree::Do(nodes=data.tree::Traverse(determinantStructure,
                                          traversal = 'level',
                                          filterFun = function(x) {
                                            return(!is.null(x$selection))}),
                fun=function(currentNode, allNames = allNms) {

    if (is.list(currentNode$selection)) {
      currentNode$varNames <-
        sapply(currentNode$selection,
               function(x) {
                 res <- sapply(x,
                               grep,
                               allNames,
                               value=TRUE,
                               simplify=FALSE);
                 names(res) <- allNames;
                 return(res);
               },
               simplify=FALSE);
      names(currentNode$varNames) <- currentNode$selection;
    } else {
      currentNode$varNames <-
        sapply(currentNode$selection,
               grep, allNames, value=TRUE, simplify=FALSE);
      names(currentNode$varNames) <- currentNode$selection;
    }
  });

}