-
Notifications
You must be signed in to change notification settings - Fork 3
/
gather.R
86 lines (71 loc) · 2.37 KB
/
gather.R
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
#' @title base gather
#' @description base gather mimics basic functionality of tidyr::gather
#' @param data data.frame
#' @param key character, name of new key column, Default: 'key'
#' @param value character, name of new value column, Default: 'value'
#' @param columns column names or indicies or regex of them to gather,
#' Default: NULL
#' @param regex boolean, indicates of columns is to be treated as a
#' regular expression, Default: FALSE
#' @param \dots parameters to pass to grep
#' @param na.rm boolean, apply na.omit to value column, Default: FALSE
#' @param convert boolean, apply type.convert to key column, Default: FALSE
#' @return data.frame
#' @examples
#'
#' mini_iris <- iris[c(1, 51, 101), ]
#'
#' # gather Sepal.Length, Sepal.Width, Petal.Length, Petal.Width
#'
#' b_gather(mini_iris, key = 'flower_att', value = 'measurement',
#' columns = c('Sepal.Length', 'Sepal.Width', 'Petal.Length', 'Petal.Width'))
#'
#' b_gather(mini_iris, key = 'flower_att', value = 'measurement',
#' columns = 1:4)
#'
#' b_gather(mini_iris, key = 'flower_att', value = 'measurement',
#' columns = -5)
#'
#' b_gather(mini_iris, key = 'flower_att', value = 'measurement',
#' columns = '^(Sepal|Petal)',regex = TRUE)
#'
#' @seealso
#' \code{\link[utils]{type.convert}}
#' @rdname b_gather
#' @author Jonathan Sidi
#' @export
#' @importFrom utils type.convert
#' @importFrom stats na.omit
b_gather <- function(data,
key = 'key',
value = 'value',
columns = NULL,
regex = FALSE,
...,
na.rm = FALSE,
convert = FALSE) {
class_in <- class(data)
cols_idx <- find_idx(data, columns, regex = regex, ...)
y <- data[-cols_idx]
if(regex)
columns <- names(data)[cols_idx]
x <- c(data[columns])
l <- lapply(names(x),function(nm,y){
data.frame(y,NAME__ = nm,VALUE__ = x[[nm]],stringsAsFactors = FALSE)
},y=y)
ret <- do.call('rbind',l)
if(na.rm)
ret <- na.omit(ret)
if(convert){
class_key <- all(grepl(pattern = '^[1-9]\\d*(\\.\\d+)?$',ret$NAME__))
if(class_key){
ret$NAME__ <- utils::type.convert(ret$NAME__,as.is = TRUE)
}else{
ret$NAME__ <- utils::type.convert(as.character(ret$NAME__),as.is = TRUE)
}
}
names(ret)[names(ret)=='NAME__'] <- key
names(ret)[names(ret)=='VALUE__'] <- value
class(ret) <- class_in
ret
}