Merge pull request #106 from R-Computing-Lab/dev_main

Add customizable sex coding to checkParentIDs

Author: smasongarrison

NEWS.md

@@ -1,9 +1,10 @@
-# BGmisc beta 1.5.2
+# BGmisc 1.5.2
 * More flexible ID generation for simulatePedigree
 * Created ped2gen function to extract generation information from pedigree data.frames
 * Added tests for ped2gen
 * Fixed handling of character ID variables leading to a warning in ped2fam
 * Added famIDs to phantom parents
+* Tweaked how sex coding is handled to allow for unknown sex
 
 # BGmisc 1.5.1
 ## CRAN submission

R/checkParents.R

@@ -12,11 +12,12 @@
 #' @param repairsex A logical flag indicating whether to attempt repairs on sex of the parents
 #' @param addphantoms A logical flag indicating whether to add phantom parents for missing parent IDs.
 #' @param parentswithoutrow A logical flag indicating whether to add parents without a row in the pedigree.
-#' @param  famID Character. Column name for family IDs.
-#' @param  personID Character. Column name for individual IDs.
+#' @param famID Character. Column name for family IDs.
+#' @param personID Character. Column name for individual IDs.
 #' @param momID Character. Column name for maternal IDs.
 #' @param dadID Character. Column name for paternal IDs.
-#'
+#' @param code_male The code value used to represent male sex in the 'sex' column of \code{ped}.
+#' @param code_female The code value used to represent female sex in the 'sex' column of \code{ped}.
 #'
 #' @return Depending on the value of `repair`, either a list containing validation results or a repaired dataframe is returned.
 #' @examples
@@ -32,7 +33,10 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE,
                            famID = "famID",
                            personID = "ID",
                            momID = "momID",
-                           dadID = "dadID") {
+                           dadID = "dadID",
+                           code_male = NULL,
+                           code_female = NULL
+                           ) {
   # Standardize column names in the input dataframe
   ped <- standardizeColnames(ped, verbose = verbose)
 
@@ -87,18 +91,28 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE,
     cat("Step 2: Determining the if moms are the same sex and dads are same sex\n")
   }
   # Determine modal sex values for moms and dads
+
+
+
   mom_results <- checkParentSex(ped, parent_col = "momID", verbose = verbose)
   dad_results <- checkParentSex(ped, parent_col = "dadID", verbose = verbose)
 
   validation_results$mom_sex <- mom_results$unique_sexes
   validation_results$dad_sex <- dad_results$unique_sexes
-  validation_results$female_var <- mom_results$modal_sex
-  validation_results$male_var <- dad_results$modal_sex
+
   validation_results$wrong_sex_moms <- mom_results$inconsistent_parents
   validation_results$wrong_sex_dads <- dad_results$inconsistent_parents
   validation_results$female_moms <- mom_results$all_same_sex
   validation_results$male_dads <- dad_results$all_same_sex
-
+  if (!is.null(code_male) && !is.null(code_female)) {
+    validation_results$male_var <- code_male
+    validation_results$female_var <- code_female
+    validation_results$sex_code_source <- "user_provided_codes"
+  } else {
+    validation_results$female_var <- mom_results$modal_sex
+    validation_results$male_var <- dad_results$modal_sex
+    validation_results$sex_code_source <- "modal_parent_sex"
+  }
   # Are any parents in both momID and dadID?
   momdad <- intersect(ped$dadID, ped$momID)
   if (length(momdad) > 0 && !is.na(momdad)) {

R/checkSex.R

@@ -17,13 +17,14 @@
 #'
 #' @details This function uses the terms 'male' and 'female' in a biological context, referring to chromosomal and other biologically-based characteristics necessary for constructing genetic pedigrees. The biological aspect of sex used in genetic analysis (genotype) is distinct from the broader, richer concept of gender identity (phenotype).
 #'
-#' We recognize the importance of using language and methodologies that affirm and respect the full spectrum of gender identities.  
+#' We recognize the importance of using language and methodologies that affirm and respect the full spectrum of gender identities.
 #' The developers of this package express unequivocal support for folx in the transgender
 #' and LGBTQ+ communities.
 #'
 #' @param ped A dataframe representing the pedigree data with a 'sex' column.
 #' @param code_male The current code used to represent males in the 'sex' column.
 #' @param code_female The current code used to represent females in the 'sex' column. If both are NULL, no recoding is performed.
+#' @param code_unknown The current code used to represent unknown or ambiguous sex in the 'sex' column. Can be NA to indicate that missing values should be treated as unknown. If NULL and both code_male and code_female are provided, values not matching either will be inferred as unknown.
 #' @param verbose A logical flag indicating whether to print progress and validation messages to the console.
 #' @param repair A logical flag indicating whether to attempt repairs on the sex coding.
 #' @param momID The column name for maternal IDs. Default is "momID".
@@ -37,7 +38,10 @@
 #' }
 #' @export
 #'
-checkSex <- function(ped, code_male = NULL, code_female = NULL, verbose = FALSE, repair = FALSE,
+checkSex <- function(ped, code_male = NULL,
+                     code_female = NULL,
+                     code_unknown = NULL,
+                     verbose = FALSE, repair = FALSE,
                      momID = "momID",
                      dadID = "dadID") {
   # Standardize column names in the input dataframe
@@ -61,7 +65,6 @@ checkSex <- function(ped, code_male = NULL, code_female = NULL, verbose = FALSE,
   }
 
 
-
   # Are there multiple sexes/genders in the list of dads and moms?
 
   dad_results <- checkParentSex(ped, parent_col = dadID, verbose = verbose)
@@ -92,7 +95,11 @@ checkSex <- function(ped, code_male = NULL, code_female = NULL, verbose = FALSE,
 
     if (validation_results$sex_length == 2) {
       # Recode all dads to the most frequent male value
-      ped <- recodeSex(ped, code_male = validation_results$most_frequent_sex_dad)
+      ped <- recodeSex(ped,
+        code_male = validation_results$most_frequent_sex_dad,
+        code_female = validation_results$most_frequent_sex_mom,
+        code_unknown = code_unknown
+      )
       # Count and record the change
       num_changes <- sum(original_ped$sex != ped$sex)
       # Record the change and the count
@@ -128,8 +135,16 @@ checkSex <- function(ped, code_male = NULL, code_female = NULL, verbose = FALSE,
 #' @export
 #'
 #' @seealso \code{\link{checkSex}}
-repairSex <- function(ped, verbose = FALSE, code_male = NULL, code_female = NULL) {
-  checkSex(ped = ped, verbose = verbose, repair = TRUE, code_male = code_male, code_female = code_female)
+repairSex <- function(ped, verbose = FALSE,
+                      code_male = NULL,
+                      code_female = NULL,
+                      code_unknown = NULL) {
+  checkSex(
+    ped = ped, verbose = verbose, repair = TRUE,
+    code_male = code_male,
+    code_female = code_female,
+    code_unknown = code_unknown
+  )
 }
 
 #' Recodes Sex Variable in a Pedigree Dataframe
@@ -142,51 +157,76 @@ repairSex <- function(ped, verbose = FALSE, code_male = NULL, code_female = NULL
 #' @param recode_na The value to use for missing values. Default is NA_character_
 #' @param recode_male The value to use for males. Default is "M"
 #' @param recode_female The value to use for females. Default is "F"
+#' @param recode_unknown The value to use for unknown values. Default is "U"
 #' @inherit checkSex details
 #' @return A modified version of the input data.frame \code{ped}, containing an additional or modified 'sex_recode' column where the 'sex' values are recoded according to \code{code_male}. NA values in the 'sex' column are preserved.
 #' @export
 
 recodeSex <- function(
-    ped, verbose = FALSE, code_male = NULL, code_na = NULL, code_female = NULL,
-    recode_male = "M", recode_female = "F", recode_na = NA_character_) {
+  ped, verbose = FALSE, code_male = NULL, code_na = NULL, code_female = NULL,
+  code_unknown = NULL,
+  recode_male = "M",
+  recode_female = "F",
+  recode_unknown = "U",
+  recode_na = NA_character_
+) {
+  if (is.null(code_male) && is.null(code_female)) {
+    if (verbose == TRUE) {
+      warning("Both code male and code female are empty. No recoding was done.")
+    }
+    return(ped)
+  }
+  # First, set any code_na values to NA
   if (!is.null(code_na)) {
     ped$sex[ped$sex == code_na] <- NA
   }
-  # Recode as "F" or "M" based on code_male, preserving NAs
-  if (!is.null(code_male) && !is.null(code_female)) {
-    # Initialize sex_recode as NA, preserving the length of the 'sex' column
-    ped$sex_recode <- recode_na
-    ped$sex_recode[ped$sex == code_female] <- recode_female
-    ped$sex_recode[ped$sex == code_male] <- recode_male
-    # Overwriting temp recode variable
-    ped$sex <- ped$sex_recode
-    ped$sex_recode <- NULL
-  } else if (!is.null(code_male) && is.null(code_female)) {
-    # Initialize sex_recode as NA, preserving the length of the 'sex' column
-    ped$sex_recode <- recode_na
-    ped$sex_recode[ped$sex != code_male & !is.na(ped$sex)] <- recode_female
+
+  # Initialize sex_recode as NA, preserving the length of the 'sex' column
+  ped$sex_recode <- recode_na
+
+
+  if (!is.null(code_male)) {
     ped$sex_recode[ped$sex == code_male] <- recode_male
-    # Overwriting temp recode variable
-    ped$sex <- ped$sex_recode
-    ped$sex_recode <- NULL
-  } else if (is.null(code_male) && !is.null(code_female)) {
-    # Initialize sex_recode as NA, preserving the length of the 'sex' column
-    ped$sex_recode <- recode_na
-    ped$sex_recode[ped$sex != code_female & !is.na(ped$sex)] <- recode_male
+  }
+  if (!is.null(code_female)) {
     ped$sex_recode[ped$sex == code_female] <- recode_female
-    # Overwriting temp recode variable
-    ped$sex <- ped$sex_recode
-    ped$sex_recode <- NULL
-  } else {
-    if (verbose == TRUE) {
-      warning("Both code male and code female are empty. No recoding was done.")
+  }
+
+  # handle unknown codes
+  if (!is.null(code_unknown) && !is.na(code_unknown)) {
+    ped$sex_recode[ped$sex == code_unknown] <- recode_unknown
+  } else if (!is.null(code_unknown) && is.na(code_unknown)) {
+    ped$sex_recode[is.na(ped$sex)] <- recode_unknown
+  } else if (!is.null(code_male) && !is.null(code_female)) {
+    ped$sex_recode[!ped$sex %in% c(code_male, code_female) & !is.na(ped$sex)] <- recode_unknown
+  }
+
+
+  # Handle cases where only one of code
+  # just male
+  if (!is.null(code_male) && is.null(code_female)) {
+    if (!is.null(code_unknown)) {
+      ped$sex_recode[ped$sex != code_male & !is.na(ped$sex) & ped$sex != code_unknown] <- recode_female
+    } else if (is.null(code_unknown)) {
+      ped$sex_recode[ped$sex != code_male & !is.na(ped$sex)] <- recode_female
     }
   }
+  # just female
+  if (is.null(code_male) && !is.null(code_female)) {
+    if (!is.null(code_unknown)) {
+      ped$sex_recode[ped$sex != code_female & !is.na(ped$sex) & ped$sex != code_unknown] <- recode_male
+    } else if (is.null(code_unknown)) {
+      ped$sex_recode[ped$sex != code_female & !is.na(ped$sex)] <- recode_male
+    }
+  }
+
+  # Overwriting temp recode variable
+  ped$sex <- ped$sex_recode
+  ped$sex_recode <- NULL
   return(ped)
 }
 
 
-
 #' Check Parental Role Sex Consistency
 #'
 #' Validates sex coding consistency for a given parental role (momID or dadID).
@@ -225,9 +265,15 @@ checkParentSex <- function(ped, parent_col, sex_col = "sex", verbose = FALSE) {
   # Store the most frequent sex for moms and dads
   modal_sex <- names(sort(table(parent_sexes), decreasing = TRUE))[1]
 
+  if (all(is.na(modal_sex)) && verbose == TRUE) {
+    cat(paste0("All parents in role ", parent_col, " have missing sex values.\n"))
+  }
+
   # Type coercion based on ped$sex type
   if (is.numeric(ped[[sex_col]])) {
     modal_sex <- as.numeric(modal_sex)
+  } else if (is.character(ped[[sex_col]])) {
+    modal_sex <- as.character(modal_sex)
   }
 
   # List ids for dads that are female, moms that are male