tools.R 7.3 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163
  1. # Additional rFerns R code
  2. #
  3. # Copyright 2011-2018 Miron B. Kursa
  4. #
  5. # This file is part of rFerns R package.
  6. #
  7. #rFerns is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version.
  8. #rFerns is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
  9. #You should have received a copy of the GNU General Public License along with rFerns. If not, see http://www.gnu.org/licenses/.
  10. #' Merge two random ferns models
  11. #'
  12. #' This function combines two compatible (same decision, same training data structure and same depth) models into a single ensemble.
  13. #' It can be used to distribute model training, perform it on batches of data, save checkouts or precisely investigate its course.
  14. #' @method merge rFerns
  15. #' @param x Object of a class \code{rFerns}; a first model to be merged.
  16. #' @param y Object of a class \code{rFerns}; a second model to be merged.
  17. #' Can also be \code{NULL}, \code{x} is immediately returned in that case.
  18. #' Has to have be built on the same kind of training data as \code{x}, with the same depth.
  19. #' @param dropModel If \code{TRUE}, model structure will be dropped to save size.
  20. #' This disallows prediction using the merged model, but retains importance and OOB approximations.
  21. #' @param ignoreObjectConsistency If \code{TRUE}, merge will be done even if both models were built on a different sets of objects.
  22. #' This drops OOB approximations.
  23. #' @param trueY Copy of the training decision, used to re-construct OOB error and confusion matrix.
  24. #' Can be omitted, OOB error and confusion matrix will disappear in that case; ignored when \code{ignoreObjectConsistency} is \code{TRUE}.
  25. #' @param ... Ignored, for S3 gerneric/method consistency.
  26. #' @return An object of class \code{rFerns}, which is a list with the following components:
  27. #' \item{model}{The merged model in case both \code{x} and \code{y} had model structures included and \code{dropModel} was \code{FALSE}.
  28. #' Otherwise \code{NULL}.}
  29. #' \item{oobErr}{OOB approximation of accuracy, if can be computed.
  30. #' Namely, when \code{oobScores} could be and \code{trueY} is provided.}
  31. #' \item{importance}{The merged importance scores in case both \code{x} and \code{y} had importance calculated.
  32. #' Shadow importance appears only if both models had it enabled.}
  33. #' \item{oobScores}{OOB scores, if can be computed; namely if both models had it calculated and \code{ignoreObjectConsistency} was not used.}
  34. #' \item{oobPreds}{A vector of OOB predictions of class for each object in training set, if can be computed.}
  35. #' \item{oobConfusionMatrix}{OOB confusion matrix, if can be computed.
  36. #' Namely, when \code{oobScores} could be and \code{trueY} is provided.}
  37. #' \item{timeTaken}{Time used to train the model, calculated as a sum of training times of \code{x} and \code{y}.}
  38. #' \item{parameters}{Numerical vector of three elements: \code{classes}, \code{depth} and \code{ferns}.}
  39. #' \item{classLabels}{Copy of \code{levels(Y)} after purging unused levels.}
  40. #' \item{isStruct}{Copy of the train set structure.}
  41. #' \item{merged}{Set to \code{TRUE} to mark that merging was done.}
  42. #' @note In case of different training object sets were used to build the merged models, merged importance is calculated but mileage may vary; for substantially different sets it may become biased.
  43. #' Your have been warned.
  44. #'
  45. #' Shadow importance is only merged when both models have shadow importance and the same \code{consistentSeed} value; otherwise shadow importance would be biased down.
  46. #'
  47. #' The order of objects in \code{x} and \code{y} is not important; the only exception is merging with \code{NULL}, in which case \code{x} must be an \code{rFerns} object for R to use proper merge method.
  48. #' @examples
  49. #' set.seed(77)
  50. #' #Fetch Iris data
  51. #' data(iris)
  52. #' #Build models
  53. #' rFerns(Species~.,data=iris)->modelA
  54. #' rFerns(Species~.,data=iris)->modelB
  55. #' modelAB<-merge(modelA,modelB)
  56. #' print(modelA)
  57. #' print(modelAB)
  58. #' @export
  59. merge.rFerns<-function(x,y,dropModel=FALSE,ignoreObjectConsistency=FALSE,trueY=NULL,...){
  60. stopifnot(inherits(x,'rFerns')) #Tautology thanks to object dispatch
  61. if(is.null(y)) return(x)
  62. stopifnot(inherits(y,'rFerns'))
  63. stopifnot(identical(x$isStruct,y$isStruct))
  64. if(!ignoreObjectConsistency){
  65. stopifnot(identical(dim(x$oobScores),dim(y$oobScores)))
  66. }else{
  67. x$oobScores<-NULL
  68. y$oobScores<-NULL
  69. trueY<-NULL
  70. }
  71. stopifnot(identical(x$classLabels,y$classLabels))
  72. stopifnot(identical(x$type,y$type))
  73. stopifnot(identical(x$parameters[-3],y$parameters[-3]))
  74. #Initiate core structure
  75. ans<-list(
  76. isStruct=x$isStruct,
  77. type=x$type,
  78. classLabels=x$classLabels,
  79. merged=TRUE)
  80. #Merge model fields
  81. if(is.null(x$model)||is.null(y$model)||dropModel){
  82. ans$model<-NULL
  83. }else{
  84. ans$model<-list(
  85. splitAttIdxs=c(x$model$splitAttIdxs,y$model$splitAttIdxs),
  86. threReal=c(x$model$threReal,y$model$threReal),
  87. threInteger=c(x$model$threInteger,y$model$threInteger),
  88. scores=c(x$model$scores,y$model$scores)
  89. )
  90. }
  91. #OOB scores is summed with #ferns-derived weights, then OOB elements re-generated
  92. #When nrow x!=nrow y, we assume it means different batches were used and oobScores make no sense anymore
  93. if(!is.null(x$oobScores)&&!is.null(y$oobScores)){
  94. ans$oobScores<-x$oobScores+y$oobScores
  95. ans$oobPreds<-factor(x$classLabels)[apply(ans$oobScores,2,
  96. function(x){
  97. which.max(x)->l
  98. if(length(l)!=1) return(NA)
  99. return(l)
  100. }
  101. )]
  102. if(!is.null(trueY)){
  103. #TODO: Multilabel!
  104. stopifnot(is.factor(trueY))
  105. stopifnot(identical(levels(trueY),ans$classLabels))
  106. #OOB error propagation is always squashed into final OOB error
  107. ans$oobErr<-mean(trueY!=ans$oobPreds)
  108. ans$oobConfusionMatrix<-table(Predicted=ans$oobPreds,True=trueY)
  109. }
  110. }
  111. #Importance
  112. if(!is.null(x$importance)&&!is.null(y$importance)){
  113. ans$importance<-x$importance
  114. if(!is.null(ans$importance$Tries)&&!is.null(y$importance$Tries)){
  115. ans$importance$Tries<-x$importance$Tries+y$importance$Tries
  116. }else{
  117. ans$importance$Tries<-NULL
  118. }
  119. if(!is.null(ans$importance$MeanScoreLoss)&&!is.null(y$importance$MeanScoreLoss)){
  120. ans$importance$MeanScoreLoss<-
  121. (with(x$importance,MeanScoreLoss*Tries)+
  122. with(y$importance,MeanScoreLoss*Tries))/ans$importance$Tries
  123. }else{
  124. ans$importance$MeanScoreLoss<-NULL
  125. }
  126. if(identical(x$consistentSeed,y$consistentSeed)&&!is.null(x$consistentSeed)){
  127. ans$consistentSeed<-x$consistentSeed
  128. if(!is.null(ans$importance$Shadow)&&!is.null(y$importance$Shadow)){
  129. ans$importance$Shadow<-
  130. (with(x$importance,Shadow*Tries)+
  131. with(y$importance,Shadow*Tries))/ans$importance$Tries
  132. }else{
  133. ans$importance$Shadow<-NULL
  134. }
  135. }else{
  136. ans$consistentSeed<-NULL #Redundant
  137. ans$importance$Shadow<-NULL
  138. }
  139. if(!is.null(ans$importance$Hits)&&!is.null(y$importance$Hits)&&identical(x$consistentSeed,y$consistentSeed)){
  140. ans$importance$Hits<-x$importance$Hits+y$importance$Hits
  141. }else{
  142. ans$importance$Hits<-NULL
  143. }
  144. }
  145. #Parameters
  146. ans$parameters<-c(
  147. x$parameters["classes"],
  148. x$parameters["depth"],
  149. x$parameters["ferns"]+y$parameters["ferns"])
  150. #Time taken
  151. ans$timeTaken<-x$timeTaken+y$timeTaken
  152. class(ans)<-"rFerns"
  153. ans
  154. }