ctree() - 如何获取每个终端节点的拆分条件列表?

Posted

技术标签:

【中文标题】ctree() - 如何获取每个终端节点的拆分条件列表?【英文标题】:ctree() - How to get the list of splitting conditions for each terminal node? 【发布时间】:2014-02-21 23:19:03 【问题描述】:

我有来自ctree()party 包)的输出,如下所示。如何获取每个终端节点的拆分条件列表,如sns <= 0, dta <= 1; sns <= 0, dta > 1等?

1) sns <= 0; criterion = 1, statistic = 14655.021
  2) dta <= 1; criterion = 1, statistic = 3286.389
   3)*  weights = 153682 
  2) dta > 1
   4)*  weights = 289415 
1) sns > 0
  5) dta <= 2; criterion = 1, statistic = 1882.439
   6)*  weights = 245457 
  5) dta > 2
   7) dta <= 6; criterion = 1, statistic = 1170.813
     8)*  weights = 328582 
   7) dta > 6

谢谢

【问题讨论】:

【参考方案1】:

CtreePathFunc 函数重写为更像 Hadley-verse(我认为更易于理解)的方式。还处理分类变量。

library(magrittr)
readSplitter <- function(nodeSplit)
  splitPoint <- nodeSplit$splitpoint
  if("levels" %>% is_in(splitPoint %>% attributes %>% names))
    splitPoint %>% attr("levels") %>% .[splitPoint]
  else
    splitPoint %>% as.numeric
  


hasWeigths <- function(ct, path, terminalNode, pathNumber)
  ct %>%
    nodes(pathNumber %>% equals(path %>% length) %>% ifelse(terminalNode, path[pathNumber + 1]) ) %>%
    .[[1]] %>% use_series("weights") %>% as.logical %>% which


dataFilter <- function(ct, dts, path, terminalNode, pathNumber)
  whichWeights <- hasWeigths(ct, path, terminalNode, pathNumber)
  nodes(ct, path[pathNumber])[[1]][[5]] %>%
    buildDataFilter(dts, whichWeights)


buildDataFilter <- function(nodeSplit, ...) UseMethod("buildDataFilter")

buildDataFilter.nominalSplit <-
  function(nodeSplit, dts, whichWeights)
    varName <- nodeSplit$variableName
    includedLevels <- dts[ whichWeights
                          ,varName] %>% unique
    paste( varName, "=="
          ,includedLevels %>% paste(collapse = ", ") %>% paste0("", ., ""))
  

buildDataFilter.orderedSplit <-
  function(nodeSplit, dts, whichWeights)
    varName <- nodeSplit$variableName
    splitter <- nodeSplit %>% readSplitter

    dts[ whichWeights
        ,varName] %>%
          is_weakly_less_than(splitter) %>%
          all %>%
          ifelse("<=" ,">") %>%
          paste(varName, ., splitter)


readTerminalNodePaths <- function (ct, dts) 

  nodeWeights <- function(Node) nodes(ct, Node)[[1]]$weights
  sgmnts <- ct %>% where %>% unique
  nodesFirstTreeWeightIsOne <- function(node) nodes(ct, node)[[1]][2][[1]] == 1

  # Take the inner nodes smaller than the selected terminal node
  innerNodes <-
    function(Node) setdiff( 1:(Node - 1)
                           ,sgmnts[sgmnts < Node])
  pathForTerminalNode <- function(terminalNode)
    innerNodes(terminalNode) %>%
      sapply(function(innerNode)
        if(any(nodeWeights(terminalNode) & nodesFirstTreeWeightIsOne(innerNode))) innerNode
       ) %>%
      unlist
  

  # Find the splits criteria
  sgmnts %>% sapply(function(terminalNode) #

    path <- terminalNode %>% pathForTerminalNode

    path %>% length %>% seq %>%
      sapply(function(nodeNumber)
        dataFilter(ct, dts, path, terminalNode, nodeNumber)
       , simplify = FALSE) %>%
      unlist %>% paste(collapse = " & ") %>%
      data.frame(Node = terminalNode, Path = .)

  , simplify = FALSE) %>%
    Reduce(f = rbind)

测试

shiftFirstPart <- function(vctr, divideBy, proportion = .5)
    vctr[vctr %>% length %>% multiply_by(proportion) %>% round %>% seq] %<>% divide_by(divideBy)
  vctr

set.seed(11)
n <- 13000
gdt <- 
  data.frame( is_buyer = runif(n) %>% shiftFirstPart(1.5) %>% round %>% factor(labels = c("no", "yes"))
             ,age = runif(n) %>% shiftFirstPart(1.5) %>%
               cut(breaks = c(0, .3, .6, 1), include_lowest = TRUE, ordered_result = TRUE, labels = c("low", "mid", "high"))
             ,city = runif(n) %>% shiftFirstPart(1.5) %>%
               cut(breaks = c(0, .3, .6, 1), include_lowest = TRUE, labels = c("Chigaco", "Boston", "Memphis"))
             ,point = runif(n) %>% shiftFirstPart(1.2)
             )

gct <- ctree( is_buyer ~ ., data = gdt)
readTerminalNodePaths(gct, gdt)

【讨论】:

这是一个非常酷的功能,我不确定我是否完全理解它是如何工作的,但是有没有一种简单的方法来修改它来获取 all 节点的路径而不是只是终端的? 抱歉这个愚蠢的问题,但是哪个库包含函数'where'? @Manuel Chirouze, party.【参考方案2】:

如果您使用ctree() 的新推荐partykit 实现而不是旧的party 包,那么您可以使用函数.list.rules.party()。这还没有正式导出,但可以用来提取所需的信息。

library("partykit")
airq <- subset(airquality, !is.na(Ozone))
ct <- ctree(Ozone ~ ., data = airq)
partykit:::.list.rules.party(ct)
##                                      3                                      5 
##             "Temp <= 82 & Wind <= 6.9" "Temp <= 82 & Wind > 6.9 & Temp <= 77" 
##                                      6                                      8 
##  "Temp <= 82 & Wind > 6.9 & Temp > 77"             "Temp > 82 & Wind <= 10.3" 
##                                      9 
##              "Temp > 82 & Wind > 10.3" 

【讨论】:

【参考方案3】:

由于我需要这个函数,但对于分类数据,我或多或少地回答了@JoãoDaniel 的问题(我只测试了分类预测变量),下一个函数:

# returns string w/o leading or trailing whitespace
# http://***.com/questions/2261079/how-to-trim-leading-and-trailing-whitespace-in-r
trim <- function (x) gsub("^\\s+|\\s+$", "", x)
getVariable <- function (x) sub("(.*?)[[:space:]].*", "\\1", x)
getSimbolo <- function (x) sub("(.*?)[[:space:]](.*?)[[:space:]].*", "\\2", x)

getReglaFinal = function(elemento)         
    x = as.data.frame(strsplit(as.character(elemento),";"))
    Regla = apply(x,1, trim)
    Regla = data.frame(Regla)
    indice = as.numeric(rownames(Regla))
    variable = apply(Regla,1, getVariable)
    simbolo = apply(Regla,1, getSimbolo)

    ReglaRaw = data.frame(Regla,indice,variable,simbolo)
    cols <- c( 'variable' , 'simbolo' )
    ReglaRaw$tipo_corte <- apply(  ReglaRaw[ , cols ] ,1 , paste , collapse = "" )
    #print(ReglaRaw)
    cortes = unique(ReglaRaw$tipo_corte)
    #print(cortes)
    ReglaFinal = ""
    for(i in 1:length(cortes))
        #print("------------------------------------")
        #print(cortes[i])
        #print("ReglaRaw econtrada")
        #print(ReglaRaw$indice[ReglaRaw$tipo_corte==cortes[i]])
        maximo = max(ReglaRaw$indice[ReglaRaw$tipo_corte==cortes[i]])
        #print(maximo)
        tmp = as.character(ReglaRaw$Regla[ReglaRaw$indice==maximo])
        if(ReglaFinal=="")
            ReglaFinal = tmp
        else
            ReglaFinal = paste(ReglaFinal,tmp,sep="; ",collapse="; ")
        
    
    return(ReglaFinal)
#getReglaFinal

CtreePathFuncAllCat <- function (ct) 

  ResulTable <- data.frame(Node = character(), Path = character())

  for(Node in unique(where(ct)))

    # Taking all possible non-Terminal nodes that are smaller than the selected terminal node
    NonTerminalNodes <- setdiff(1:(Node - 1), unique(where(ct))[unique(where(ct)) < Node])

    # Getting the weigths for that node
    NodeWeights <- nodes(ct, Node)[[1]]$weights

    # Finding the path
    Path <- NULL
    for (i in NonTerminalNodes)
        if(any(NodeWeights & nodes(ct, i)[[1]][2][[1]] == 1)) Path <- append(Path, i)
    

    # Finding the splitting creteria for that path
    Path2 <- SB <- NULL

    variablesNombres <- array()
    variablesPuntos <- list()

    for(i in 1:length(Path))
        n <- nodes(ct, Path[i])[[1]]

        if(i == length(Path)) 
            nextNodeID = Node
         else 
            nextNodeID = Path[i+1]
               

        vec_puntos  = as.vector(n[[5]]$splitpoint)
        vec_nombre  = n[[5]]$variableName
        vec_niveles = attr(n[[5]]$splitpoint,"levels")

        index = 0

        if((length(vec_puntos)!=length(vec_niveles)) && (length(vec_niveles)!=0) )
            index = vec_puntos
            vec_puntos = vector(length=length(vec_niveles))
            vec_puntos[index] = TRUE
        

        if(length(vec_niveles)==0)
            index = vec_puntos
            vec_puntos = n[[5]]$splitpoint
        

        if(index==0)
            if(nextNodeID==n$right$nodeID)
                vec_puntos = !vec_puntos
            else
                vec_puntos = !!vec_puntos
            
            if(i != 1) 
                for(j in 1:(length(Path)-1))
                    if(length(variablesNombres)>=j)
                        if( variablesNombres[j]==vec_nombre)
                            vec_puntos = vec_puntos*variablesPuntos[[j]]
                        
                    
                
                vec_puntos = vec_puntos==1
               
            SB = "="
        else
            if(nextNodeID==n$right$nodeID)
                SB = ">"
            else
                SB = "<="
            

        

        variablesPuntos[[i]] = vec_puntos       
        variablesNombres[i] = vec_nombre

        if(length(vec_niveles)==0)
            descripcion = vec_puntos
        else
            descripcion = paste(vec_niveles[vec_puntos],collapse=", ")
        
        Path2 <- paste(c(Path2, paste(c(variablesNombres[i],SB,"",descripcion, ""),collapse=" ")
                        ),
                       collapse = "; ")
    

    # Output
    ResulTable <- rbind(ResulTable, cbind(Node = Node, Path = Path2))
  

    we = weights(ct)
    c0 = as.matrix(where(ct))
    c3 = sapply(we, function(w) sum(w))
    c3 = as.matrix(unique(cbind(c0,c3)))
    Counts = as.matrix(c3[,2])
    c2 = drop(Predict(ct))
    Means = as.matrix(unique(c2))

    ResulTable = data.frame(ResulTable,Means,Counts)
    ResulTable  = ResulTable[ order(ResulTable$Means) ,]

    ResulTable$TruePath =  apply(as.data.frame(ResulTable$Path),1, getReglaFinal)

    ResulTable2 = ResulTable

    ResulTable2$SQL <- paste("WHEN ",gsub("\\'([-+]?([0-9]*\\.[0-9]+|[0-9]+))\\'", "\\1",gsub("\\, ", "','", gsub(" \\", "')", gsub("\\ ", "('", gsub("\\;", " AND ", ResulTable2$TruePath)))))," THEN ")

    cols <- c( 'SQL' , 'Node' )
    ResulTable2$SQL <- apply(  ResulTable2[ , cols ] ,1 , paste , collapse = "'Nodo " )

    ResulTable2$SQL <- gsub("THEN'", "THEN '", gsub(" '", "'",  paste(ResulTable2$SQL,"'")))

    ResultadoFinal = list()

    ResultadoFinal$PreTable = ResulTable
    ResultadoFinal$Table = ResulTable
    ResultadoFinal$Table$Path = ResultadoFinal$Table$TruePath
    ResultadoFinal$Table$TruePath = NULL
    ResultadoFinal$SQL = paste(" CASE ",paste(ResulTable2$SQL,sep="",collapse=" ")," END ",collapse="")

    return(ResultadoFinal)
#CtreePathFuncAllCat

这是一个测试:

library(party)
#With ordered factors
TreeModel1 = ctree(PB~ME+SYMPT+HIST+BSE+DECT, data = mammoexp)
Result2 <- CtreePathFuncAllCat(TreeModel1)
Result2
##$PreTable
##  Node                                                Path    Means Counts
##3    7    DECT >  Somewhat likely ; SYMPT >  Disagree  6.526316    114
##2    6   DECT >  Somewhat likely ; SYMPT <=  Disagree  7.640000    175
##1    4  DECT <=  Somewhat likely ; DECT >  Not likely  8.161905    105
##4    3 DECT <=  Somewhat likely ; DECT <=  Not likely  9.833333     18
##                                          TruePath
##3   DECT >  Somewhat likely ; SYMPT >  Disagree 
##2  DECT >  Somewhat likely ; SYMPT <=  Disagree 
##1 DECT <=  Somewhat likely ; DECT >  Not likely 
##4                             DECT <=  Not likely 
##
##$Table
##  Node                                               Path    Means Counts
##3    7   DECT >  Somewhat likely ; SYMPT >  Disagree  6.526316    114
##2    6  DECT >  Somewhat likely ; SYMPT <=  Disagree  7.640000    175
##1    4 DECT <=  Somewhat likely ; DECT >  Not likely  8.161905    105
##4    3                             DECT <=  Not likely  9.833333     18
##
##$SQL
##[1] " CASE  WHEN  DECT > ('Somewhat likely') AND  SYMPT > ('Disagree')  THEN 'Nodo 7' WHEN  DECT > ('Somewhat likely') AND  SYMPT <= ('Disagree')  THEN 'Nodo 6' WHEN  DECT <= ('Somewhat likely') AND  DECT > ('Not likely')  THEN 'Nodo 4' WHEN  DECT <= ('Not likely')  THEN 'Nodo 3'  END "


#With unordered factors
TreeModel2 = ctree(count~spray, data = InsectSprays)
plot(TreeModel2, type="simple")
Result2 <- CtreePathFuncAllCat(TreeModel2)
Result2
##$PreTable
##Node                                  Path     Means Counts            TruePath
##2    5 spray =  C, D, E ; spray =  C, E   2.791667     24    spray =  C, E 
##3    4    spray =  C, D, E ; spray =  D   4.916667     12       spray =  D 
##1    2                   spray =  A, B, F  15.500000     36 spray =  A, B, F 
##
##$Table
##Node                Path     Means Counts
##2    5    spray =  C, E   2.791667     24
##3    4       spray =  D   4.916667     12
##1    2 spray =  A, B, F  15.500000     36
##
##$SQL
##[1] " CASE  WHEN  spray = ('C','E')  THEN 'Nodo 5' WHEN  spray = ('D')  THEN 'Nodo 4' WHEN  spray = ('A','B','F')  THEN 'Nodo 2'  END "

#With continuous variables
airq <- subset(airquality, !is.na(Ozone))
TreeModel3 <- ctree(Ozone ~ ., data = airq,  controls = ctree_control(maxsurrogate = 3))
Result2 <- CtreePathFuncAllCat(TreeModel3)
Result2
##$PreTable
##  Node                                           Path    Means Counts
##1    5 Temp <=  82 ; Wind >  6.9 ; Temp <=  77  18.47917     48
##3    6  Temp <=  82 ; Wind >  6.9 ; Temp >  77  31.14286     21
##4    9                 Temp >  82 ; Wind >  10.3  48.71429      7
##2    3                Temp <=  82 ; Wind <=  6.9  55.60000     10
##5    8                Temp >  82 ; Wind <=  10.3  81.63333     30
##                                     TruePath
##1                Temp <=  77 ; Wind >  6.9 
##3 Temp <=  82 ; Wind >  6.9 ; Temp >  77 
##4                Temp >  82 ; Wind >  10.3 
##2               Temp <=  82 ; Wind <=  6.9 
##5               Temp >  82 ; Wind <=  10.3 
##
##$Table
##  Node                                          Path    Means Counts
##1    5                Temp <=  77 ; Wind >  6.9  18.47917     48
##3    6 Temp <=  82 ; Wind >  6.9 ; Temp >  77  31.14286     21
##4    9                Temp >  82 ; Wind >  10.3  48.71429      7
##2    3               Temp <=  82 ; Wind <=  6.9  55.60000     10
##5    8               Temp >  82 ; Wind <=  10.3  81.63333     30
##
##$SQL
##[1] " CASE  WHEN  Temp <= (77) AND  Wind > (6.9)  THEN 'Nodo 5' WHEN  Temp <= (82) AND  Wind > (6.9) AND  Temp > (77)  THEN 'Nodo 6' WHEN  Temp > (82) AND  Wind > (10.3)  THEN 'Nodo 9' WHEN  Temp <= (82) AND  Wind <= (6.9)  THEN 'Nodo 3' WHEN  Temp > (82) AND  Wind <= (10.3)  THEN 'Nodo 8'  END "

更新!现在该函数支持分类变量和数值变量的混合!

【讨论】:

很好用,但是,它似乎只适用于分类变量:当我在 airct 树 CtreePathFuncAllCat(ct) 的结果上尝试这个时,它返回拆分字段,但不返回拆分标准。知道如何获取分类变量和连续变量的路径吗? @clevelandfrowns 我更新了函数,现在可以处理连续和分类数据。【参考方案4】:

这个函数应该可以完成这项工作

 CtreePathFunc <- function (ct, data) 

  ResulTable <- data.frame(Node = character(), Path = character())

  for(Node in unique(where(ct)))
  # Taking all possible non-Terminal nodes that are smaller than the selected terminal node
  NonTerminalNodes <- setdiff(1:(Node - 1), unique(where(ct))[unique(where(ct)) < Node])


  # Getting the weigths for that node
  NodeWeights <- nodes(ct, Node)[[1]]$weights


  # Finding the path
  Path <- NULL
  for (i in NonTerminalNodes)
    if(any(NodeWeights & nodes(ct, i)[[1]][2][[1]] == 1)) Path <- append(Path, i)
  

  # Finding the splitting creteria for that path
  Path2 <- SB <- NULL

  for(i in 1:length(Path))
    if(i == length(Path)) 
      n <- nodes(ct, Node)[[1]]
     else n <- nodes(ct, Path[i + 1])[[1]]

    if(all(data[which(as.logical(n$weights)), as.character(unlist(nodes(ct,Path[i])[[1]][[5]])[length(unlist(nodes(ct,Path[i])[[1]][[5]]))])] <= as.numeric(unlist(nodes(ct,Path[i])[[1]][[5]])[3])))
      SB <- "<="
     else SB <- ">"
    Path2 <- paste(c(Path2, paste(as.character(unlist(nodes(ct,Path[i])[[1]][[5]])[length(unlist(nodes(ct,Path[i])[[1]][[5]]))]),
                                 SB,
                                 as.character(unlist(nodes(ct,Path[i])[[1]][[5]])[3]))),
                   collapse = ", ")
  

  # Output
  ResulTable <- rbind(ResulTable, cbind(Node = Node, Path = Path2))
  
  return(ResulTable)

测试

library(party)
airq <- subset(airquality, !is.na(Ozone))
ct <- ctree(Ozone ~ ., data = airq,  controls = ctree_control(maxsurrogate = 3))
Result <- CtreePathFunc(ct, airq)
Result 

##   Node                               Path
## 1    5 Temp <= 82, Wind > 6.9, Temp <= 77
## 2    3            Temp <= 82, Wind <= 6.9
## 3    6  Temp <= 82, Wind > 6.9, Temp > 77
## 4    9             Temp > 82, Wind > 10.3
## 5    8            Temp > 82, Wind <= 10.3

【讨论】:

耗时较长,但反应非常好。而且您忘记将“airq”矩阵作为变量。 谢谢,@Galled。已编辑。我也忘了library(party)。这是我在 SO 中的第一个答案之一,所以那里有点菜鸟 这个函数是否有任何更新版本也可以处理分类解释变量? @DavidArenburg @JoãoDaniel,我没有写过。也许发布一个新问题,看看是否有人可以详细说明,因为我不确定我是否有时间在新的未来写一个 @JoãoDaniel 我做了一个。

以上是关于ctree() - 如何获取每个终端节点的拆分条件列表?的主要内容,如果未能解决你的问题,请参考以下文章

如何获取所有终端节点 - r 中的权重和响应预测“ctree”

如何打印带有范围的数值变量的 ctree 终端节点

如何为 ctree(打包方)的终端节点添加标签?

ctree 图的终端节点中的缩放图

ctree CART 条件树中的权重与权重 (party::ctree)

ctree 在 R 中的派对包中绘制决策树,终端节点出现一些奇怪的数字 - 问题?