R中因子类别的多标签格式化函数

Question

问题

在某些健康数据集中，一列可以对个别病例感兴趣的各种疾病表现进行分类。在一些总结中，将这些表现的各种组合制成表格是有益的，包括计算给定案例是否“大于”或“小于”选择的关键表现。

在SAS中，可以为一列分配multilabel format，这样可以在procedure steps期间同时汇总各种重叠的类别。我一直在努力在 R 中找到一个令人满意的解决方案，从 SAS 中复制此功能。我知道dplyr 或base 函数链接在一起的组合可以制成表格并附加不同的组合，从而有效地创建一个数据集，该数据集复制代表所有overlapping levels 所需的行。

目标

创建一个函数，允许轻松创建考虑到目标类别的各种重叠级别的数据集。这将允许将下面提供的示例数据转换为附加正确行的新数据集，并且可以在组内提供检查，以查看某个分组是否与所有需要的级别匹配以被视为新分组的一部分。

library(tibble)

# Example data (Repeat groups)
exampleData <- tibble(group = c(1, 1, 1, 2, 3, 3),
                   condition = factor(c('A', 'B', 'C', 'A', 'B', 'Q'), ordered = F))

# Initial output
# A tibble: 6 x 2
  group condition
  <dbl> <fct>    
1     1 A        
2     1 B        
3     1 C        
4     2 A        
5     3 B        
6     3 Q  


# Function to add new level combinations, based upon the levels within each group.
create_multilevelFactor(exampleData , target_col = 'condition', group_col = 'group', new_levels = list('AB' = c('A', 'B'), 'QB' = c('Q', 'B')))

# Desired output
# A tibble: 8 x 3
  group condition track_col
  <dbl> <chr>         <dbl>
1     1 A                 1
2     1 B                 1
3     1 C                 1
4     2 A                 1
5     3 B                 1
6     3 Q                 1
7     1 AB                2
8     3 QB                3

您会注意到原始因子水平保持不变，如果组合存在，则命名列表中包含正确水平的组将形成一个新行。在更现实的例子中，AB 的分组可以被视为具有“至少 A 或 B 疾病表现”的组 1。

挑战

我怀疑其他人可能对此功能有类似的需求，并且像我一样，要么不知道更简单的方法，要么没有遇到易于使用的现有解决方案。在我对这个问题的思考过程中，我创建了一个函数（主要尝试使用base R），尽管不太优雅，但它创建了上述所需的输出。

我希望其他人可以提供更理想的解决方案，使用替代方法或增加功能的健壮性和更广泛的适用性。

Answer 1

以下函数为问题提供了一个可行的但不优雅的解决方案。我倾向于过度考虑流程，这可能反映在此处的答案中。

此函数将接收初始数据集，并根据是否提供分组函数，创建一个新数据集，其中包含聚合因子级别的各种组合的附加行（如果这些级别存在于分组中）。可以以列表的形式提供各种新级别，并且附加的列可以很容易地查看除了原始行之外还添加了哪些新级别。

#-----------------------------------------------------------#
# Create function for multilevel labelling of factor groups #
#-----------------------------------------------------------#
# target_col is a character string for the column of interest to be adjusted
# group_col is a character string for the column to check levels that exist within groupings
# new_levels is a list that uses name and value pairs to determine how new levels should be aggregated
# collapse will ensure that only unique combinations of the new level is appended
# track will add a flag to ensure one can easily see the new combinations that were appended
create_multilevelFactor <- function(data, target_col, new_levels , group_col, collapse = T, track = T) {
  #
  #  Do some basic checks on inputs
  #

  # Check if new_levels is provided as a list
  if(!is.list(new_levels)) stop('The provided set of levels is not in a list format, please provide as a list') 

  # Check if target_col is a factor
  if(!is.factor(data[[target_col]])) stop('The target column for multiple levels is not a factor, convert to a factor before proceeding.')

  # Check if levels are in list
  for(i in 1:length(new_levels)) {
    if(length(setdiff(levels(factor(new_levels[[i]])),
                      levels(factor(data[[target_col]])))) > 0) { # If levels in provided list contain a level not in the column, then throw error
      stop('Levels in list do not match the levels in the target column')
    }
  }

  # State if grouping col was provided and its purpose
  if(!missing(group_col)) { message(paste0('The following column is used as a grouping variable for summarizing multilevel factoring: ',
                                         group_col, '. If you do not want labels determined by those within groupings, leave argument blank.'))
    }

  #
  # Main 
  #

  # Set new column for tracking if desired
  if(track == T) {track_col <- rep(NA,nrow(data)); data$track_col <- 1;  trackColIndex <- 1;}

  OutData <- as.data.frame(NULL) # Empy data frame to fill and append later

  # Loop for all new levels of interest to add
  for(i in 1:length(new_levels)){

    tempData <- data # Look at fresh data every pass

    levelIndex <- which(levels(tempData[[target_col]]) %in% new_levels [[i]]) # Index of matches

    # If grouping provided, do necessary splits and rbinds
    if(!missing(group_col)) {
      tempData <- split(tempData, tempData[[group_col]]) # Split if there are groupings

      tempData <- lapply(tempData, function(x) {
        if(!(length(setdiff(levels(factor(new_levels [[i]])), levels(factor(x[[target_col]])))) > 0)) { # If the grouping does not have all the levels for the new grouping, then do nothing
          levels(x[[target_col]])[levelIndex] <- names(new_levels )[i]
          x
          }
        })

      tempData <- do.call(rbind, tempData)  # If didnt match necessary group conditions, will bring back empty
      rownames(tempData) <- NULL # Correct row names for tibble

    } else { # If not grouping
      levels(tempData[[target_col]])[levelIndex] <- names(new_levels )[i]

      }

    tempData <- tempData[tempData[[target_col]] %in% names(new_levels )[i],] # Only keep new factor levels (could be empty if no group matches)

    if(collapse == T) tempData <- unique(tempData[(tempData[[target_col]] %in% names(new_levels )[i]),]) # Collapse to unique combinations if desired

    if(track == T){track_col <- rep(NA, nrow(tempData));  tempData$track_col <- trackColIndex+1;  trackColIndex <- trackColIndex+1;} # Add track column to the new rows

    OutData <- suppressWarnings(dplyr::bind_rows(OutData, tempData)) # Append all the new rows
    }

  # Append new rows to the original rows
  OutData <- suppressWarnings(dplyr::bind_rows(data, OutData)) #

  return(OutData)

}

使用最初提供的示例数据，可以产生以下输出：

#Original data
library(tibble)

# Example data (Repeat groups)
exampleData <- tibble(group = c(1, 1, 1, 2, 3, 3),
                   condition = factor(c('A', 'B', 'C', 'A', 'B', 'Q'), ordered = F))

# Original data
# A tibble: 6 x 2
  group condition
  <dbl> <fct>    
1     1 A        
2     1 B        
3     1 C        
4     2 A        
5     3 B        
6     3 Q 

##################

newData <- create_multilevelFactor(exampleData,
                        target_col = 'condition',
                        group_col = 'group',
                        new_levels = list('AB' = c('A', 'B'), 'QB' = c('Q', 'B')),
                        collapse = T, track = T)

newData 
# Data with grouping argument
# A tibble: 8 x 3
  group condition track_col
  <dbl> <chr>         <dbl>
1     1 A                 1
2     1 B                 1
3     1 C                 1
4     2 A                 1
5     3 B                 1
6     3 Q                 1
7     1 AB                2
8     3 QB                3

addmargins(table(newData$group,newData$condition))
      A AB B C Q QB Sum
  1   1  1 1 1 0  0   4
  2   1  0 0 0 0  0   1
  3   0  0 1 0 1  1   3
  Sum 2  1 2 1 1  1   8

newData <- create_multilevelFactor(exampleData,
                        target_col = 'condition',
                        new_levels = list('AB' = c('A', 'B'), 'QB' = c('Q', 'B')),
                        collapse = T, track = T)

newData 
# Without grouping argument
# A tibble: 11 x 3
   group condition track_col
   <dbl> <chr>         <dbl>
 1     1 A                 1
 2     1 B                 1
 3     1 C                 1
 4     2 A                 1
 5     3 B                 1
 6     3 Q                 1
 7     1 AB                2
 8     2 AB                2
 9     3 AB                2
10     1 QB                3
11     3 QB                3

newData <- create_multilevelFactor(exampleData,
                        target_col = 'condition',
                        new_levels = list('AB' = c('A', 'B'), 'QB' = c('Q', 'B')),
                        collapse = F, track = T)

newData 
# Without collapse and grouping argument
# A tibble: 13 x 3
   group condition track_col
   <dbl> <chr>         <dbl>
 1     1 A                 1
 2     1 B                 1
 3     1 C                 1
 4     2 A                 1
 5     3 B                 1
 6     3 Q                 1
 7     1 AB                2
 8     1 AB                2
 9     2 AB                2
10     3 AB                2
11     1 QB                3
12     3 QB                3
13     3 QB                3