在 r 的列中對齊數據框的字符串

Question

我有一個大數據框，我希望字符串在基於后綴（子字符串）的列中對齊，源數據框如下所示：

notst 代表要忽略的其他變量前綴

#            col1       col2       col3 
#        notst-s1   notst-s2   notst-x3
#        notst-s1   notst-x3   notst-a5   
#        notst-s2   notst-a5
#        notst-x3   notst-a5

結果，應該是：

#            col1       col2       col3       col4 
#        notst-s1   notst-s2   notst-x3
#        notst-s1              notst-x3   notst-a5   
#                   notst-s2              notst-a5
#                              notst-x3   notst-a5

編輯：

考慮整個后綴（在“-”之后）。 它沒有數字。 在某些情況下，整個字符串 ("xxxx-spst") 應該匹配 (*)，因為字符串的 xxxx 部分有多個版本。

對於：

df <- read.table(text="
           col1         col2        col3 
         st1-ab     stb-spst    sta-spst
       stc-spst     sta-spst      st4-ab   
       stb-spst       st7-ab
         st9-ba     stb-spst",header=TRUE,fill=TRUE,stringsAsFactors=FALSE)

可能的結果可能是：（列名和順序無關緊要）

#           col1         col2        col3       col4    
#         st1-ab     stb-spst    sta-spst      
#         st4-ab     stc-spst    sta-spst         
#         st7-ab     stb-spst       
#                    stb-spst                 st9-ba     

(*) 請注意，在第 2 行 col2 中，“stc-spst”似乎放錯了位置，但這不是問題，因為該行中不存在值 stb-spst，因此對於這種特殊情況，只有后綴（“spst ") 很重要。 換句話說，當整個字符串（前綴-后綴）與其他（在其他行）匹配時，它們應該在同一列中，如果不是，當后綴與（其他行的）后綴匹配時，它們應該在同一列列。 生成的數據幀應具有與原始數據幀相同的行數和盡可能少的列數。

編輯。 答案應該是通用的，適用於：

df2 <- read.table(text="
col1         col2        col3       col4 
st1-ab       stb-spst    sta-spst   std-spst
stc-spst     sta-spst    st4-ab     st2-ab
stb-spst     st7-ab      sa-ac
st9-ba       stb-spst",header=TRUE,fill=TRUE,stringsAsFactors=FALSE)

例如，也。 可能的結果：

#           col1         col2        col3       col4    col5      col6     col7
#         st1-ab     stb-spst    sta-spst    std-spst  
#         st4-ab     stc-spst    sta-spst               st2-ab  
#         st7-ab     stb-spst                                     sa-ac  
#                    stb-spst                                           st9-ba  

例3

df3 <- read.table(text="
col1         col2        col3       col4 
st1-ab       stb-spst    sta-spst   std-spst
stb-spst     sta-ab    
sta-spst     st7-ab      sa-ac
sta-spst     stb-spst",header=TRUE,fill=TRUE,stringsAsFactors=FALSE)

期望的輸出

  col1   col2     col3     col4     col5  
1       st1-ab    sta-spst stb-spst std-spst
2       sta-ab             stb-spst         
3 sa-ac st7-ab    sta-spst                  
4                 sta-spst stb-spst  

編輯示例 4. 為了使任務更容易，您可以在函數中明確定義每行可能有多個可能前綴的后綴。 在這個例子中（“spst”）。 因此，任何后綴與“spst”不同的字符串應該每行只有一個可能的前綴，並且可以並且必須折疊到生成的 df 中的一列中，作為所需輸出中的 col2。 這不是我最初想要的，因為我會得到比預期更多的列。 理想情況下，包含 spst 和不同前綴的字符串應該出現在盡可能少的列中。 見 (* 以上)。

df4 <- read.table(text="
col1         col2        col3       col4 
st1-ab       stb-spst    sta-spst   std-spst
stb-spst     st1-ab    
sta-spst     st7-ab      sa-ac
sta-spst     stb-spst    st7-ab",header=TRUE,fill=TRUE,stringsAsFactors=FALSE)

期望的輸出

row_id  col1  col2          col3     col4     col5
1             st1-ab        sta-spst stb-spst std-spst
2             st1-ab                 stb-spst         
3       sa-ac st7-ab        sta-spst                  
4             st7-ab        sta-spst stb-spst  

Answer 1

我們可以通過首先melt數據集，從元素中提取數字索引，基於該索引創建行/列索引並將元素分配給基於索引的最大值創建的matrix來完成此操作。

library(reshape2)
d1 <- na.omit(transform(melt(as.matrix(df1)), v1 = as.numeric(sub("\\D+", "", value))))
m1 <- matrix("", nrow = max(d1$Var1), ncol = max(d1$v1))
m1[as.matrix(d1[c("Var1", "v1")])]  <- as.character(d1$value) 
d2 <- as.data.frame(m1[,!!colSums(m1!="")])
colnames(d2) <- paste0("col", seq_along(d2))
d2
#     col1     col2     col3     col4
#1 notst-s1 notst-s2 notst-x3         
#2 notst-s1          notst-x3 notst-a5
#3          notst-s2          notst-a5
#4                   notst-x3 notst-a5

Answer 2

矩陣索引可能使這成為可能：

sel <- dat!=""
unq <- unique(dat[sel])
mat <- matrix(NA, nrow=nrow(dat), ncol=length(unq))

mat[cbind(row(dat)[sel],  match(dat[sel], unq) )] <- dat[sel]

#     [,1]       [,2]       [,3]       [,4]      
#[1,] "notst-s1" "notst-s2" "notst-x3" NA        
#[2,] "notst-s1" NA         "notst-x3" "notst-a5"
#[3,] NA         "notst-s2" NA         "notst-a5"
#[4,] NA         NA         "notst-x3" "notst-a5"

其中dat導入為：

dat <- read.table(text="
    col1       col2       col3 
notst-s1   notst-s2   notst-x3
notst-s1   notst-x3   notst-a5   
notst-s2   notst-a5
notst-x3   notst-a5",header=TRUE,fill=TRUE,stringsAsFactors=FALSE)

Answer 3

用四個示例進行了測試，但此版本沒有考慮您在示例 4 中作為變通方法添加的信息。

主要的補充是隨機邏輯（可能很慢）以從右到左壓縮結果數據幀。 有可能不再需要assigned_by_suffix和assigned_by_single_suffix ，但我沒有驗證。

輸出在代碼的末尾

# examples
df1 <- read.table(text="
col1         col2        col3 
st1-ab     stb-spst    sta-spst
stc-spst     sta-spst      st4-ab   
stb-spst       st7-ab
st9-ba     stb-spst",header=TRUE,fill=TRUE,stringsAsFactors=FALSE)

df2 <- read.table(text="
col1         col2        col3       col4 
st1-ab       stb-spst    sta-spst   std-spst
stc-spst     sta-spst    st4-ab     st2-ab
stb-spst     st7-ab      sa-ac
st9-ba       stb-spst",header=TRUE,fill=TRUE,stringsAsFactors=FALSE)

df3 <- read.table(text="
col1         col2        col3       col4 
st1-ab       stb-spst    sta-spst   std-spst
stb-spst     sta-ab    
sta-spst     st7-ab      sa-ac
sta-spst     stb-spst",header=TRUE,fill=TRUE,stringsAsFactors=FALSE)

df4 <- read.table(text="
col1         col2        col3       col4 
st1-ab       stb-spst    sta-spst   std-spst
stb-spst     st1-ab    
sta-spst     st7-ab      sa-ac
sta-spst     stb-spst    st7-ab",header=TRUE,fill=TRUE,stringsAsFactors=FALSE)

library(reshape2)
library(tidyr)
library(dplyr)
library(stringr)
library(assertthat)

suffix <- function(s) {str_extract(s, "[^\\-]+$")}

# make a tall dataframe with melt, and get the suffix
dfm <- df4 %>% 
  mutate(row_id = seq_along(col1)) %>%
  melt(id.vars="row_id") %>%
  select(-2) %>%
  filter(value != "") %>%
  mutate(suffix = suffix(value)) %>%
  arrange(value)
assert_that(!any(duplicated(dfm[c("row_id", "value")])))

# initialize 
combined <- data.frame()
remaining <- dfm

# get the groups with more than 1 value
matched_values  <- dfm %>%
  group_by(value, suffix) %>%
  summarize(n=n()) %>%
  filter(n>1) %>%
  rename(group_id = value) %>%
  ungroup()

# .. and assign the group ids that match
assigned_by_value <- remaining %>% 
  inner_join(matched_values %>% select(group_id), by = c("value" = "group_id")) %>%
  mutate(group_id = value) %>%
  select(row_id, value, suffix, group_id)
combined <- combined %>% bind_rows(assigned_by_value)
remaining <- dfm %>% anti_join(combined, by=c("row_id", "value"))
# find the remaining suffixes 
matched_suffixes <- remaining  %>%
  group_by(suffix) %>%
  summarize(n=n()) %>%
  filter(n>1) %>%
  select(-n) %>%
  ungroup()

# ... and assign those that match
assigned_by_suffix <- remaining %>%
  inner_join(matched_suffixes, by="suffix") %>%
  mutate(group_id = suffix)
combined <- bind_rows(combined, assigned_by_suffix)
remaining <- remaining %>% anti_join(combined, by=c("row_id", "value"))


# All that remain are singles assign matches by suffix, choosing the match with fewest
assigned_by_single_suffix <- remaining %>%
  inner_join(matched_values, by = "suffix") %>%
  top_n(1, n) %>%
  head(1) %>%
  select(-n)
combined <- bind_rows(combined, assigned_by_single_suffix)
remaining <- remaining %>% anti_join(combined, by=c("row_id", "value"))

# get the remaining unmatched
unmatched <- remaining%>%
  mutate(group_id = value)
combined <- bind_rows(combined, unmatched)
remaining <- remaining %>% anti_join(combined, by=c("row_id", "value"))
assert_that(nrow(remaining) == 0)

# any overloads (duplicates) need to bump to their own column
dups <- duplicated(combined[,c("row_id", "group_id")])
combined$group_id[dups] <- combined$value[dups]

assert_that(nrow(combined) == nrow(dfm))

# spread the result

result <- spread(combined %>% select(-suffix), group_id, value, fill ="")

# Shuffle any matching suffix from right to left, so l long as there
# is corresponding space an that the whole column can move
# i is source (startign from right) - j is target (starting from right) 
#
drop_cols = c()
suffixes <- suffix(names(result))
for (i in (ncol(result)):3) {
  for(j in (i-1):2) {
    if (suffixes[i] == suffixes[j]) {
      non_empty <- which(result[,i] != "") # list of source to move
      can_fill  <- which(result[,j] == "") # list of targets can be filled
      can_move   <- all(non_empty %in% can_fill) # is to move a subset of can_fill? 

      # if there's space, shuffle the column down
      if (can_move ) {
        # shuffle down
        result[,j] <- if_else(result[,j] != "", result[,j], result[,i]) 
        drop_cols <- c(drop_cols, i)
        result[,i] <- NA
        break
      }
    }                   
  }
}

if (!is.null(drop_cols)) {
  result <- result[,-drop_cols]
}
result

# Example 1
#   row_id     ab st9-ba sta-spst stb-spst
# 1      1 st1-ab        sta-spst stb-spst
# 2      2 st4-ab        sta-spst stc-spst
# 3      3 st7-ab                 stb-spst
# 4      4        st9-ba          stb-spst

# Example 2
#  row_id     ab sa-ac     spst st2-ab st9-ba sta-spst stb-spst
# 1      1 st1-ab       std-spst               sta-spst stb-spst
# 2      2 st4-ab       stc-spst st2-ab        sta-spst         
# 3      3 st7-ab sa-ac                                 stb-spst
# 4      4                              st9-ba          stb-spst 

# Example 3
#   row_id     ab sa-ac sta-spst stb-spst std-spst
# 1      1 st1-ab       sta-spst stb-spst std-spst
# 2      2 sta-ab                stb-spst         
# 3      3 st7-ab sa-ac sta-spst                  
# 4      4              sta-spst stb-spst   

# Example 4
#   row_id sa-ac st1-ab sta-spst stb-spst std-spst
# 1      1       st1-ab sta-spst stb-spst std-spst
# 2      2       st1-ab          stb-spst         
# 3      3 sa-ac st7-ab sta-spst                  
# 4      4       st7-ab sta-spst stb-spst         
>