R/legacy.R

In smasongarrison/discord: Functions for Discordant Kinship Modeling

#' Legacy Code: Restructure Data
#'
#' This is from
#' \url{https://github.com/R-Computing-Lab/discord/blob/74323b2cdd739355cd4a388251c747f1bcd87eb5/R/discord_data.R}
#' and is legacy code used to restructure wide form, double-entered data, into
#' analyzable data sorted by outcome. This can be used in \code{\link{discord_regression_legacy}}.
#'
#' @param outcome Name of outcome variable
#' @param predictors Names of predictors.
#' @param df dataframe with all variables in it.
#' @param scale If TRUE, rescale all variables at the individual level to have a mean of 0 and a SD of 1.
#' @param id id variable (optional).
#' @param doubleentered  Describes whether data are double entered. Default is FALSE.
#' @param ... Optional pass on additional inputs.
#' @param full If TRUE, returns kin1 and kin2 scores in addition to diff and mean scores. If FALSE, only returns diff and mean scores.
#' @param sep The character in \code{df} that separates root outcome and predictors from mean and diff labels character string to separate the names of the \code{predictors} and \code{outcome}s from kin identifier (1 or 2). Not \code{NA_character_}.
#'
#' @keywords internal
#'
#' @return Returns \code{data.frame} with the following variables:
#' \item{id}{id}
#' \item{outcome_1}{outcome for kin1; kin1 is always greater than kin2, except when tied. Then kin1 is randomly selected from the pair}
#' \item{outcome_2}{outcome for kin2}
#' \item{outcome_diff}{difference between outcome of kin1 and kin2}
#' \item{outcome_mean}{mean outcome for kin1 and kin2}
#' \item{predictor_i_1}{predictor variable i for kin1}
#' \item{predictor_i_2}{predictor variable i for kin2}
#' \item{predictor_i_diff}{difference between predictor i of kin1 and kin2}
#' \item{predictor_i_mean}{mean predictor i for kin1 and kin2}
#'
discord_data_legacy <- function(
    outcome,
    predictors = NULL,
    doubleentered = TRUE,
    sep = "",
    scale = FALSE,
    df = NULL,
    id = NULL,
    full = TRUE,
    ...) {
  arguments <- as.list(match.call())
  y <- ysort <- NULL

  IVlist <- list()
  outcome1 <- subset(df, select = paste0(arguments$outcome, sep, "1"))[, 1]
  outcome2 <- subset(df, select = paste0(arguments$outcome, sep, "2"))[, 1]

  if (!is.null(id)) {
    id <- df[, id]
  } else {
    id <- seq(1, nrow(df))
  }

  # If no predictors selected, grab all variables not listed as outcome, and contain sep 1 or sep 2
  if (is.null(predictors)) {
    predictors <- setdiff(unique(gsub(paste0(sep, "1|", sep, "2"), "", grep(paste0(sep, "1|", sep, "2"), names(df), value = TRUE))), paste0(arguments$outcome))
    # unpaired.predictors=setdiff(grep(paste0(sep,"1|",sep,"2"),names(df),value = TRUE,invert=TRUE),paste0(arguments$id))
  }


  if (!doubleentered) {
    outcome2x <- outcome2
    outcome2 <- c(outcome2[, 1], outcome1[, 1])
    outcome1 <- c(outcome1[, 1], outcome2x[, 1])

    if (scale & is.numeric(outcome1)) {
      outcome1 <- scale(outcome1)
      outcome2 <- scale(outcome2)
    }
    DV <- data.frame(outcome1, outcome2)
    DV$outcome_diff <- DV$outcome1 - DV$outcome2
    DV$outcome_mean <- (DV$outcome1 + DV$outcome2) / 2

    remove(outcome1)
    remove(outcome2x)
    remove(outcome2)

    for (i in 1:length(predictors)) {
      predictor1x <- predictor1 <- subset(df, select = paste0(predictors[i], sep, "1"))[, 1]
      predictor2 <- subset(df, select = paste0(predictors[i], sep, "2"))[, 1]
      predictor1 <- c(predictor1[, 1], predictor2[, 1])
      predictor2 <- c(predictor2[, 1], predictor1x[, 1])
      if (scale & is.numeric(predictor1)) {
        predictor1 <- scale(predictor1)
        predictor2 <- scale(predictor2)
      }
      remove(predictor1x)
      IVi <- data.frame(predictor1, predictor2)
      IVi$predictor_diff <- IVi$predictor1 - IVi$predictor2
      IVi$predictor_mean <- (IVi$predictor1 + IVi$predictor2) / 2
      names(IVi) <- c(paste0(predictors[i], "_1"), paste0(predictors[i], "_2"), paste0(predictors[i], "_diff"), paste0(predictors[i], "_mean"))
      IVlist[[i]] <- IVi

      names(IVlist)[i] <- paste0("")
    }
  } else {
    if (scale & is.numeric(outcome1)) {
      outcome1 <- scale(outcome1)
      outcome2 <- scale(outcome2)
    }
    DV <- data.frame(outcome1, outcome2)

    DV$outcome_diff <- DV$outcome1 - DV$outcome2
    DV$outcome_mean <- (DV$outcome1 + DV$outcome2) / 2

    remove(outcome1)
    remove(outcome2)
    for (i in 1:length(predictors)) {
      predictor1 <- subset(df, select = paste0(predictors[i], sep, "1"))[, 1]
      predictor2 <- subset(df, select = paste0(predictors[i], sep, "2"))[, 1]
      if (scale & is.numeric(predictor1)) {
        predictor1 <- scale(predictor1)
        predictor2 <- scale(predictor2)
      }
      IVi <- data.frame(predictor1, predictor2)
      IVi$predictor_diff <- IVi$predictor1 - IVi$predictor2
      IVi$predictor_mean <- (IVi$predictor1 + IVi$predictor2) / 2
      names(IVi) <- c(paste0(predictors[i], "_1"), paste0(predictors[i], "_2"), paste0(predictors[i], "_diff"), paste0(predictors[i], "_mean"))
      IVlist[[i]] <- IVi
      names(IVlist)[i] <- paste0("")
    }
  }


  DV$id <- id
  DV$ysort <- 0
  DV$ysort[DV$outcome_diff > 0 & !is.na(DV$outcome_diff)] <- 1

  # randomly select for sorting on identical outcomes

  if (length(unique(DV$id[DV$outcome_diff == 0])) > 0) {
    select <- sample(c(0, 1), replace = TRUE, size = length(unique(DV$id[DV$outcome_diff == 0 & !is.na(DV$outcome_diff)])))
    DV$ysort[DV$outcome_diff == 0 & !is.na(DV$outcome_diff)] <- c(select, abs(select - 1))
  }
  DV$id <- NULL
  names(DV) <- c(paste0(arguments$outcome, "_1"), paste0(arguments$outcome, "_2"), paste0(arguments$outcome, "_diff"), paste0(arguments$outcome, "_mean"), "ysort")

  merged.data.frame <- data.frame(id, DV, IVlist)

  id <- ysort <- NULL # appeases R CMD check

  merged.data.frame <- subset(merged.data.frame, ysort == 1)
  merged.data.frame$ysort <- NULL
  merged.data.frame <- merged.data.frame[order(merged.data.frame$id), ]
  if (!full) {
    varskeep <- c("id", paste0(arguments$outcome, "_diff"), paste0(arguments$outcome, "_mean"), paste0(predictors, "_diff"), paste0(predictors, "_mean"))

    merged.data.frame <- merged.data.frame[varskeep]
  }

  return(merged.data.frame)
}



#' Legacy Code: Discord Regression
#'
#' This is from
#' \url{https://github.com/R-Computing-Lab/discord/blob/74323b2cdd739355cd4a388251c747f1bcd87eb5/R/discord_regression.R}
#' and is used to perform the discordant regression on the data output from
#' \code{\link{discord_data_legacy}}.
#'
#' @importFrom stats lm formula
#'
#' @inheritParams discord_data
#' @param more_args Optional string to add additional inputs to formula
#' @param additional_formula Deprecated
#'
#' @keywords internal
#'
#' @return Resulting `lm` object from performing the discordant regression.
#'
discord_regression_legacy <- function(df,
                                      outcome,
                                      predictors,
                                      more_args = NULL,
                                      additional_formula = more_args,
                                      ...) {
  # grab variables
  outcome_diff <- paste0(outcome, "_diff")
  outcome_mean <- paste0(outcome, "_mean")
  predictors_diff <- paste0(predictors, "_diff")
  predictors_mean <- paste0(predictors, "_mean")
  # create string of predictors to go on the right side of the formula
  right_side <- paste(c(outcome_mean, predictors_diff, predictors_mean, more_args), collapse = "+")

  discord_formula <- formula(paste0(outcome_diff, " ~ ", right_side))

  # returns lm with the actual equation, not just printing
  #   "lm(formula = discord_formula, data = df)"
  eval(bquote(lm(.(discord_formula), data = df)))
}