Укрепить партийные правила

На графике дерева ниже на пути к узлу 6 (узлу, на правила которого вы ссылаетесь в своем вопросе) мы сначала сохраняем только точки с Petal.Width > 0,6. Но даже тогда узел 6 включает не все оставшиеся точки с Sepal.Length ‹= 5,5, а только те, у которых также Petal.Width ‹= 1,3. Другими словами, между двумя разбиениями Sepal.Length есть промежуточное разделение Petal.Width, поэтому первое разделение Sepal.Length не является избыточным.

m1 = ctree(Petal.Length~.,data=iris)
plot(m1)

Там может быть более эффективный способ, но эти функции могут дать вам то, что вы хотите:

consolidate_rules <- function(tree){
  split.vars <- colnames(tree$node$info$criterion)
  split <- partykit:::.list.rules.party(tree)
  new.split <- c()

  for(i.split in seq_along(split)) {
   for (i.split.var in split.vars) {
    x0 <- split[i.split]
    x1 <- strsplit(x0, " & ")
    x2 <- grep(i.split.var, x1[[1]], value = TRUE)
    x3l <- strsplit(grep("<=", x2, value = TRUE), " <= ") # lower than
    x3g <- strsplit(grep(">", x2, value = TRUE), " > ")  # greater
    x3e <- strsplit(grep(" %in% ", x2, value = TRUE), "%in%")  # elements
    x4 <- c()

    if (length(x3e) != 0) {
      b <- sapply(x3e, "[[", 2)
      b1 <- gsub('"', '', b)
      b2 <- gsub("[c( )]", "", b1)
      b3 <- gsub("(NA,)|(,NA)", "", b2)
      b4 <- unique(strsplit(paste0(b3, collapse = ","), ",")[[1]])
      x4 <- paste0(i.split.var, ' %in% c("',
                   paste0(b4, collapse = '", "'),'")')
    }

    if (length(x3l) != 0) {
      x4 <- paste0(i.split.var, " <= ",
                   min(as.numeric(sapply(x3l, "[[", 2))))
    }
    if (length(x3g) != 0) {
      x4 <- paste0(x4, ifelse(length(x4) > 0 ," & ",""),
                   i.split.var, " > ",
                   max(as.numeric(sapply(x3g, "[[", 2))))
    }

    tmp <- paste0(if(!is.null(new.split[i.split]) &&
                  !is.na(new.split[i.split]) &
                  length(x4) >0) {" & "}, x4)

    new.split[i.split] <- 
      paste0(if(!is.null(new.split[i.split]) &&
            !is.na(new.split[i.split])) {new.split[i.split]},
             tmp)

    rm(x0, x1, x2, x3l, x3g, x3e, x4)
   }
 }
 names(new.split) <- names(split)
 return(new.split)
}

Вы можете вызвать функцию с помощью:

ct <- ctree(Petal.Length~.,data=iris)
consolidate_rules(ct)

Для узла 6 результат выглядит так:

6 
                           "Sepal.Length <= 5.5 & Petal.Width <= 1.3 & Petal.Width > 0.6"

Поскольку результатом является «просто» строка с правилами, я не знаю, можно ли использовать ее так же, как объект .list.rules.party. Но я надеюсь, что это может помочь вам.

Более простая версия:

"Petal.Width > 0.6 & Sepal.Length <= 6.2 & Petal.Width <= 1.3 & Sepal.Length <= 5.5" %>%
    str_split(' & ') %>% unlist() %>% str_split(' ') %>%
    lapply(function(x) data.frame(var = x[1], cond = x[2], value = tail(x, -2) %>% paste(collapse = ' '))) %>% bind_rows() %>%
    group_by(var, cond) %>%
    filter(
        if (str_detect(unique(cond), '<')) 1:n() == which.min(as.numeric(value))
        else if (str_detect(unique(cond), '>')) 1:n() == which.max(as.numeric(value))
        else 1:n() == which.min(str_count(value, ','))
    ) %>%
    apply(1, paste, collapse = ' ') %>% paste(collapse = ' & ')

[1] "Petal.Width > 0.6 & Petal.Width <= 1.3 & Sepal.Length <= 5.5"

Он работает путем разделения правила с использованием & в качестве маркера, а затем снова разбивает каждый элемент (например, Petal.Width > 0.6) на три его компонента (например, переменную Petal.Width, условие > и значение 0.6). Я превращаю все в фрейм данных, группирую по переменной и условию, а затем выбираю правильный элемент в соответствии с условием. Наконец я сворачиваю сначала по ряду, а потом снова в одну строку.

Я придумал это сегодня, поэтому я еще не проверял его полностью, но он должен работать. Для этого требуются пакеты dplyr и stringr. Обратите внимание, что этот код работает по одному правилу, но вы можете использовать его с векторами строк с sapply().