Skip to content

GitLab

Switch branch/tag
Find file Normal viewHistoryPermalink
lgb.prepare_rules2.R 7.13 KB
Newer Older
Laurae's avatar
[R-package] Add lgb.convert from smart matrix building (#561)  
Laurae committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199 
#' Data preparator for LightGBM datasets with rules (numeric)
#'
#' Attempts to prepare a clean dataset to prepare to put in a lgb.Dataset. Factors and characters are converted to numeric. In addition, keeps rules created so you can convert other datasets using this converter. This is useful if you have a specific need for numeric dataset instead of integer dataset. There are programs which do not support integer-only input. Consider this is a fallback solution if you cannot use integers.
#' 
#' @param data A data.frame or data.table to prepare.
#' @param rules A set of rules from the data preparator, if already used.
#' 
#' @return A list with the cleaned dataset (\code{data}) and the rules (\code{rules}). The data must be converted to a matrix format (\code{as.matrix}) for input in lgb.Dataset.
#' 
#' @examples
#' \dontrun{
#'   library(lightgbm)
#'   data(iris)
#'   
#'   str(iris)
#'   # 'data.frame':	150 obs. of  5 variables:
#'   # $ Sepal.Length: num  5.1 4.9 4.7 4.6 5 5.4 4.6 5 4.4 4.9 ...
#'   # $ Sepal.Width : num  3.5 3 3.2 3.1 3.6 3.9 3.4 3.4 2.9 3.1 ...
#'   # $ Petal.Length: num  1.4 1.4 1.3 1.5 1.4 1.7 1.4 1.5 1.4 1.5 ...
#'   # $ Petal.Width : num  0.2 0.2 0.2 0.2 0.2 0.4 0.3 0.2 0.2 0.1 ...
#'   # $ Species     : Factor w/ 3 levels "setosa","versicolor",..: 1 1 1 1 ...
#'   
#'   new_iris <- lgb.prepare_rules2(data = iris) # Autoconverter
#'   str(new_iris$data)
#'   # 'data.frame':	150 obs. of  5 variables:
#'   # $ Sepal.Length: num  5.1 4.9 4.7 4.6 5 5.4 4.6 5 4.4 4.9 ...
#'   # $ Sepal.Width : num  3.5 3 3.2 3.1 3.6 3.9 3.4 3.4 2.9 3.1 ...
#'   # $ Petal.Length: num  1.4 1.4 1.3 1.5 1.4 1.7 1.4 1.5 1.4 1.5 ...
#'   # $ Petal.Width : num  0.2 0.2 0.2 0.2 0.2 0.4 0.3 0.2 0.2 0.1 ...
#'   # $ Species     : num  1 1 1 1 1 1 1 1 1 1 ...
#'   
#'   data(iris) # Erase iris dataset
#'   iris$Species[1] <- "NEW FACTOR" # Introduce junk factor (NA)
#'   # Warning message:
#'   In `[<-.factor`(`*tmp*`, 1, value = c(NA, 1L, 1L, 1L, 1L, 1L, 1L,  :
#'     invalid factor level, NA generated
#'   
#'   # Use conversion using known rules
#'   # Unknown factors become 0, excellent for sparse datasets
#'   newer_iris <- lgb.prepare_rules2(data = iris, rules = new_iris$rules)
#'   
#'   # Unknown factor is now zero, perfect for sparse datasets
#'   newer_iris$data[1, ] # Species became 0 as it is an unknown factor
#'   #   Sepal.Length Sepal.Width Petal.Length Petal.Width Species
#'   # 1          5.1         3.5          1.4         0.2       0
#'   
#'   newer_iris$data[1, 5] <- 1 # Put back real initial value
#'   
#'   # Is the newly created dataset equal? YES!
#'   all.equal(new_iris$data, newer_iris$data)
#'   # [1] TRUE
#'   
#'   # Can we test our own rules?
#'   data(iris) # Erase iris dataset
#'   
#'   # We remapped values differently
#'   personal_rules <- list(Species = c("setosa" = 3,
#'                                      "versicolor" = 2,
#'                                      "virginica" = 1))
#'   newest_iris <- lgb.prepare_rules2(data = iris, rules = personal_rules)
#'   str(newest_iris$data) # SUCCESS!
#'   # 'data.frame':	150 obs. of  5 variables:
#'   # $ Sepal.Length: num  5.1 4.9 4.7 4.6 5 5.4 4.6 5 4.4 4.9 ...
#'   # $ Sepal.Width : num  3.5 3 3.2 3.1 3.6 3.9 3.4 3.4 2.9 3.1 ...
#'   # $ Petal.Length: num  1.4 1.4 1.3 1.5 1.4 1.7 1.4 1.5 1.4 1.5 ...
#'   # $ Petal.Width : num  0.2 0.2 0.2 0.2 0.2 0.4 0.3 0.2 0.2 0.1 ...
#'   # $ Species     : num  3 3 3 3 3 3 3 3 3 3 ...
#'   
#' }
#' 
#' @export
lgb.prepare_rules2 <- function(data, rules = NULL) {
  
  # data.table not behaving like data.frame
  if ("data.table" %in% class(data)) {
    
    # Must use existing rules
    if (!is.null(rules)) {
      
      # Loop through rules
      for (i in names(rules)) {
        
        set(data, j = i, value = unname(rules[[i]][data[[i]]]))
        data[[i]][is.na(data[[i]])] <- 0 # Overwrite NAs by 0s
        
      }
      
    } else {
      
      # Get data classes
      list_classes <- sapply(data, class)
      
      # Map characters/factors
      is_fix <- which(list_classes %in% c("character", "factor"))
      ruleset <- list()
      
      # Need to create rules?
      if (length(is_fix) > 0) {
        
        # Go through all characters/factors
        for (i in is_fix) {
          
          # Store column elsewhere
          mini_data <- data[[i]]
          
          # Get unique values
          if (class(mini_data) == "factor") {
            mini_unique <- levels(mini_data) # Factor
            mini_numeric <- numeric(length(mini_unique))
            mini_numeric[1:length(mini_unique)] <- 1:length(mini_unique) # Respect ordinal if needed
          } else {
            mini_unique <- as.factor(unique(mini_data)) # Character
            mini_numeric <- as.numeric(mini_unique) # No respect of ordinality
          }
          
          # Create ruleset
          indexed <- colnames(data)[i] # Index value
          ruleset[[indexed]] <- mini_numeric # Numeric content
          names(ruleset[[indexed]]) <- mini_unique # Character equivalent
          
          # Apply to real data column
          set(data, j = i, value = unname(ruleset[[indexed]][mini_data]))
          
        }
        
      }
      
    }
    
  } else {
    
    # Must use existing rules
    if (!is.null(rules)) {
      
      # Loop through rules
      for (i in names(rules)) {
        
        data[[i]] <- unname(rules[[i]][data[[i]]])
        data[[i]][is.na(data[[i]])] <- 0 # Overwrite NAs by 0s
        
      }
      
    } else {
      
      # Default routine (data.frame)
      if ("data.frame" %in% class(data)) {
        
        # Get data classes
        list_classes <- sapply(data, class)
        
        # Map characters/factors
        is_fix <- which(list_classes %in% c("character", "factor"))
        ruleset <- list()
        
        # Need to create rules?
        if (length(is_fix) > 0) {
          
          # Go through all characters/factors
          for (i in is_fix) {
            
            # Store column elsewhere
            mini_data <- data[[i]]
            
            # Get unique values
            if (class(mini_data) == "factor") {
              mini_unique <- levels(mini_data) # Factor
              mini_numeric <- numeric(length(mini_unique))
              mini_numeric[1:length(mini_unique)] <- 1:length(mini_unique) # Respect ordinal if needed
            } else {
              mini_unique <- as.factor(unique(mini_data)) # Character
              mini_numeric <- as.numeric(mini_unique) # No respect of ordinality
            }
            
            # Create ruleset
            indexed <- colnames(data)[i] # Index value
            ruleset[[indexed]] <- mini_numeric # Numeric content
            names(ruleset[[indexed]]) <- mini_unique # Character equivalent
            
            # Apply to real data column
            data[[i]] <- unname(ruleset[[indexed]][mini_data])
            
          }
          
        }
        
      } else {
        
        # What do you think you are doing here? Throw error.
        stop("lgb.prepare: you provided ", paste(class(data), collapse = " & "), " but data should have class data.frame")
        
      }
      
    }
    
  }
  
  return(list(data = data, rules = ruleset))
  
}