Перезаписать уровни столбцов факторов в одном кадре данных, используя другой

Question

У меня есть 2 кадра данных с несколькими факторами столбцов. Один - это базовый кадр данных, а другой - окончательный кадр данных. Я хочу обновить уровни базового фрейма данных, используя последний фрейм данных.

Рассмотрим этот пример:

base <- data.frame(product=c("Business Call", "Business Transactional", 
                             "Monthly Non-Compounding and Standard Non-Compounding",
                             "OCR based Call", "Offsale Call", "Offsale Savings",
                             "Offsale Transactional", "Out of Scope","Personal Call"))
base$product <- as.factor(base$product)

final <- data.frame(product=c("Business Call", "Business Transactional", 
                              "Monthly Standard Non-Compounding", "OCR based Call", 
                              "Offsale Call", "Offsale Savings","Offsale Transactional", 
                              "Out of Scope","Personal Call", "You Money")) 
final$product <- as.factor(final$product)

Что бы я хотел, чтобы конечная база данных имела те же уровни, что и база, и удаляла уровни, которые вообще не существуют, такие как «Ваши деньги». Принимая во внимание, что "Ежемесячный стандартный несмешивающийся" будет нечетким соответствием

Например:

levels(base$var1) <- "a" "b" "c"
levels(final$var1) <- "Aa" "Bb" "Cc"

Есть ли способ перезаписать уровни в базовых данных, используя окончательные данные, используя некое нечеткое совпадение?

Как будто я хочу, чтобы конечные уровни для обоих данных были одинаковыми. т.е.

levels(base$var1) <- "Aa" "Bb" "Cc"
levels(final$var1) <- "Aa" "Bb" "Cc"

Answer 1

Мы могли бы построить наш собственный fuzzyMatcher.

Во-первых, нам понадобится векторизованная agrep функция,

agrepv <- function(x, y) all(as.logical(sapply(x, agrep, y)))

на котором мы строим fuzzyMatcher.

fuzzyMatcher <-  function(from, to) { 
  mc <- mapply(function(y) 
    which(mapply(function(x) agrepv(y, x), Map(levels, to))), 
    Map(levels, from))
  return(Map(function(x, y) `levels<-`(x, y), base, 
             Map(levels, from)[mc]))
}

final метки, примененные к base меткам ( примечание, , что я сместил столбцы, чтобы сделать его немного более сложным):

base[] <- fuzzyMatcher(final1, base1)
#    X1 X2
# 1  Aa Xx
# 2  Aa Xx
# 3  Aa Yy
# 4  Aa Yy
# 5  Bb Yy
# 6  Bb Zz
# 7  Bb Zz
# 8  Aa Xx
# 9  Cc Xx
# 10 Cc Zz

Обновление

Основываясь на новых предоставленных данных выше, имеет смысл использовать еще один векторизованный agrepv2(), который при использовании с outer() позволяет нам применять agrep ко всем комбинациям уровней обоих векторов. В дальнейшем colSums, равные нулю, дают нам несовпадающие уровни, а which.max сопоставляющие уровни целевого фрейма данных final. Мы можем использовать эти два результирующих вектора, с одной стороны, для удаления неиспользуемых строк final, с другой стороны, для поднабора желаемых уровней фрейма данных base, чтобы перестроить столбец коэффициентов.

# add to mimic other columns in data frame
base$x <- seq(nrow(base))
final$x <- seq(nrow(final))

# some abbrevations for convenience
p1 <- levels(base$product)
p2 <- levels(final$product)

# agrep
AGREPV2 <- Vectorize(function(x, y, ...) agrep(p2[x], p1[y]))  # new vectorized agrep 
out <- t(outer(seq(p2), seq(p1), agrepv2, max.distance=0.9))  # apply `agrepv2`
del.col <- grep(0, colSums(apply(out, 2, lengths))) # find negative matches
lvl <- unlist(apply(out, 2, which.max))  # find positive matches
lvl <- as.character(p2[lvl])  # get the labels

# delete "non-existing" rows and re-generate factor with new labels
transform(final[-del.col, ], product=factor(product, labels=lvl))
#                  product x
# 1          Business Call 1
# 2 Business Transactional 2
# 4         OCR based Call 4
# 5           Offsale Call 5
# 6        Offsale Savings 6
# 7  Offsale Transactional 7
# 8           Out of Scope 8
# 9          Personal Call 9

Данные

base1 <- structure(list(X1 = structure(c(1L, 1L, 1L, 1L, 2L, 2L, 2L, 1L, 
3L, 3L), .Label = c("a", "b", "c"), class = "factor"), X2 = structure(c(1L, 
1L, 2L, 2L, 2L, 3L, 3L, 1L, 1L, 3L), .Label = c("x", "y", "z"
), class = "factor")), row.names = c(NA, -10L), class = "data.frame")

final1 <- structure(list(X1 = structure(c(1L, 3L, 1L, 1L, 2L, 3L, 2L, 1L, 
2L, 2L, 3L, 3L, 2L, 2L, 2L), .Label = c("Xx", "Yy", "Zz"), class = "factor"), 
    X2 = structure(c(2L, 1L, 1L, 2L, 2L, 3L, 3L, 1L, 1L, 2L, 
    2L, 2L, 2L, 2L, 3L), .Label = c("Aa", "Bb", "Cc"), class = "factor")), row.names = c(NA, 
-15L), class = "data.frame")