lgb.prepare_rules.R 6.51 KB
Newer Older
James Lamb's avatar
James Lamb committed
1
2
3
#' 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.
4
#'
James Lamb's avatar
James Lamb committed
5
6
#' @param data A data.frame or data.table to prepare.
#' @param rules A set of rules from the data preparator, if already used.
7
#'
James Lamb's avatar
James Lamb committed
8
#' @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.
9
#'
James Lamb's avatar
James Lamb committed
10
11
12
#' @examples
#' library(lightgbm)
#' data(iris)
13
#'
James Lamb's avatar
James Lamb committed
14
15
16
17
18
19
20
#' 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 ...
21
#'
James Lamb's avatar
James Lamb committed
22
23
24
25
26
27
28
29
#' new_iris <- lgb.prepare_rules(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 ...
30
#'
James Lamb's avatar
James Lamb committed
31
32
33
34
35
#' 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
36
#'
James Lamb's avatar
James Lamb committed
37
38
39
#' # Use conversion using known rules
#' # Unknown factors become 0, excellent for sparse datasets
#' newer_iris <- lgb.prepare_rules(data = iris, rules = new_iris$rules)
40
#'
James Lamb's avatar
James Lamb committed
41
42
43
44
#' # 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
45
#'
James Lamb's avatar
James Lamb committed
46
#' newer_iris$data[1, 5] <- 1 # Put back real initial value
47
#'
James Lamb's avatar
James Lamb committed
48
49
50
#' # Is the newly created dataset equal? YES!
#' all.equal(new_iris$data, newer_iris$data)
#' # [1] TRUE
51
#'
James Lamb's avatar
James Lamb committed
52
53
#' # Can we test our own rules?
#' data(iris) # Erase iris dataset
54
#'
James Lamb's avatar
James Lamb committed
55
56
57
58
59
60
61
62
63
64
65
66
#' # We remapped values differently
#' personal_rules <- list(Species = c("setosa" = 3,
#'                                    "versicolor" = 2,
#'                                    "virginica" = 1))
#' newest_iris <- lgb.prepare_rules(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 ...
67
#'
James Lamb's avatar
James Lamb committed
68
69
70
#' @importFrom data.table set
#' @export
lgb.prepare_rules <- function(data, rules = NULL) {
71

James Lamb's avatar
James Lamb committed
72
73
  # data.table not behaving like data.frame
  if (inherits(data, "data.table")) {
74

James Lamb's avatar
James Lamb committed
75
76
    # Must use existing rules
    if (!is.null(rules)) {
77

James Lamb's avatar
James Lamb committed
78
79
      # Loop through rules
      for (i in names(rules)) {
80

James Lamb's avatar
James Lamb committed
81
82
        data.table::set(data, j = i, value = unname(rules[[i]][data[[i]]]))
        data[[i]][is.na(data[[i]])] <- 0 # Overwrite NAs by 0s
83

James Lamb's avatar
James Lamb committed
84
      }
85

James Lamb's avatar
James Lamb committed
86
    } else {
87

James Lamb's avatar
James Lamb committed
88
89
      # Get data classes
      list_classes <- vapply(data, class, character(1))
90

James Lamb's avatar
James Lamb committed
91
92
93
      # Map characters/factors
      is_fix <- which(list_classes %in% c("character", "factor"))
      rules <- list()
94

James Lamb's avatar
James Lamb committed
95
96
      # Need to create rules?
      if (length(is_fix) > 0) {
97

James Lamb's avatar
James Lamb committed
98
99
        # Go through all characters/factors
        for (i in is_fix) {
100

James Lamb's avatar
James Lamb committed
101
102
          # Store column elsewhere
          mini_data <- data[[i]]
103

James Lamb's avatar
James Lamb committed
104
105
106
107
108
109
110
111
112
          # Get unique values
          if (is.factor(mini_data)) {
            mini_unique <- levels(mini_data) # Factor
            mini_numeric <- numeric(length(mini_unique))
            mini_numeric[seq_along(mini_unique)] <- seq_along(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
          }
113

James Lamb's avatar
James Lamb committed
114
115
116
117
          # Create rules
          indexed <- colnames(data)[i] # Index value
          rules[[indexed]] <- mini_numeric # Numeric content
          names(rules[[indexed]]) <- mini_unique # Character equivalent
118

James Lamb's avatar
James Lamb committed
119
120
          # Apply to real data column
          data.table::set(data, j = i, value = unname(rules[[indexed]][mini_data]))
121

James Lamb's avatar
James Lamb committed
122
        }
123

James Lamb's avatar
James Lamb committed
124
      }
125

James Lamb's avatar
James Lamb committed
126
    }
127

James Lamb's avatar
James Lamb committed
128
  } else {
129

James Lamb's avatar
James Lamb committed
130
131
    # Must use existing rules
    if (!is.null(rules)) {
132

James Lamb's avatar
James Lamb committed
133
134
      # Loop through rules
      for (i in names(rules)) {
135

James Lamb's avatar
James Lamb committed
136
137
        data[[i]] <- unname(rules[[i]][data[[i]]])
        data[[i]][is.na(data[[i]])] <- 0 # Overwrite NAs by 0s
138

James Lamb's avatar
James Lamb committed
139
      }
140

James Lamb's avatar
James Lamb committed
141
    } else {
142

James Lamb's avatar
James Lamb committed
143
144
      # Default routine (data.frame)
      if (inherits(data, "data.frame")) {
145

James Lamb's avatar
James Lamb committed
146
147
        # Get data classes
        list_classes <- vapply(data, class, character(1))
148

James Lamb's avatar
James Lamb committed
149
150
151
        # Map characters/factors
        is_fix <- which(list_classes %in% c("character", "factor"))
        rules <- list()
152

James Lamb's avatar
James Lamb committed
153
154
        # Need to create rules?
        if (length(is_fix) > 0) {
155

James Lamb's avatar
James Lamb committed
156
157
          # Go through all characters/factors
          for (i in is_fix) {
158

James Lamb's avatar
James Lamb committed
159
160
            # Store column elsewhere
            mini_data <- data[[i]]
161

James Lamb's avatar
James Lamb committed
162
163
164
165
166
167
168
169
170
            # Get unique values
            if (is.factor(mini_data)) {
              mini_unique <- levels(mini_data) # Factor
              mini_numeric <- numeric(length(mini_unique))
              mini_numeric[seq_along(mini_unique)] <- seq_along(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
            }
171

James Lamb's avatar
James Lamb committed
172
173
174
175
            # Create rules
            indexed <- colnames(data)[i] # Index value
            rules[[indexed]] <- mini_numeric # Numeric content
            names(rules[[indexed]]) <- mini_unique # Character equivalent
176

James Lamb's avatar
James Lamb committed
177
178
            # Apply to real data column
            data[[i]] <- unname(rules[[indexed]][mini_data])
179

James Lamb's avatar
James Lamb committed
180
          }
181

James Lamb's avatar
James Lamb committed
182
        }
183

James Lamb's avatar
James Lamb committed
184
      } else {
185

James Lamb's avatar
James Lamb committed
186
187
        # 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")
188

James Lamb's avatar
James Lamb committed
189
      }
190

James Lamb's avatar
James Lamb committed
191
    }
192

James Lamb's avatar
James Lamb committed
193
  }
194

James Lamb's avatar
James Lamb committed
195
  return(list(data = data, rules = rules))
196

James Lamb's avatar
James Lamb committed
197
}