关于R语言 reshape里的melt源代码

是 否 +2 论坛币

k人 参与回答

经管之家送您一份

应届毕业生专属福利!

求职就业群

赵安豆老师微信：zhaoandou666

经管之家联合CDA

送您一个全额奖学金名额~ !

立即领取

感谢您参与论坛问题回答

经管之家送您两个论坛币！

+2 论坛币

我想问一下，melt的源代码怎么获得啊？
我自己写了一个类似实现的方法，但是同样的数据量，自己的代码跑了2小时，melt嗖的一下。。。心里太不平衡了，想学习一下～～～
求好心人帮助！！！

扫码加我 拉你入群

请注明：姓名-公司-职位

以便审核进群资格，未注明则拒绝

分享0 收藏1 回帖

关键词：reshape Shape R语言 ELT APE 源代码 好心人 平衡

1. # Melt
   
2. # Melt an object into a form suitable for easy casting.
   
3. #
   
4. # This the generic melt function. See the following functions
   
5. # for specific details for different data structures:
   
6. #
   
7. # \itemize{
   
8. #   \item \code{\link{melt.data.frame}} for data.frames
   
9. #   \item \code{\link{melt.array}} for arrays, matrices and tables
   
10. #   \item \code{\link{melt.list}} for lists
    
11. # }
    
12. #
    
13. # @keyword manip
    
14. # @arguments Data set to melt
    
15. # @arguments Other arguments passed to the specific melt method
    
16. melt <- function(data, ...) UseMethod("melt", data)
    
17. 
    
18. # Default melt function
    
19. # For vectors, make a column of a data frame
    
20. #
    
21. # @keyword internal
    
22. melt.default <- function(data, ...) {
    
23.   data.frame(value=data)
    
24. }
    
25. 
    
26. # Melt a list
    
27. # Melting a list recursively melts each component of the list and joins the results together
    
28. #
    
29. # @keyword internal
    
30. #X a <- as.list(1:4)
    
31. #X melt(a)
    
32. #X names(a) <- letters[1:4]
    
33. #X melt(a)
    
34. #X attr(a, "varname") <- "ID"
    
35. #X melt(a)
    
36. #X a <- list(matrix(1:4, ncol=2), matrix(1:6, ncol=2))
    
37. #X melt(a)
    
38. #X a <- list(matrix(1:4, ncol=2), array(1:27, c(3,3,3)))
    
39. #X melt(a)
    
40. #X melt(list(1:5, matrix(1:4, ncol=2)))
    
41. #X melt(list(list(1:3), 1, list(as.list(3:4), as.list(1:2))))
    
42. melt.list <- function(data, ..., level=1) {
    
43.   var <- nulldefault(attr(data, "varname"), paste("L", level, sep=""))
    
44.   names <- nulldefault(names(data), 1:length(data))
    
45.   parts <- lapply(data, melt, level=level+1, ...)
    
46. 
    
47.   namedparts <- mapply(function(x, name) {
    
48.    x[[var]] <- name
    
49.    x
    
50.   }, parts, names, SIMPLIFY=FALSE)
    
51.   do.call(rbind.fill, namedparts)
    
52. }
    
53. 
    
54. # Melt a data frame
    
55. # Melt a data frame into form suitable for easy casting.
    
56. #
    
57. # You need to tell melt which of your variables are id variables, and which
    
58. # are measured variables. If you only supply one of \code{id.vars} and
    
59. # \code{measure.vars}, melt will assume the remainder of the variables in the
    
60. # data set belong to the other. If you supply neither, melt will assume
    
61. # factor and character variables are id variables, and all others are
    
62. # measured.
    
63. #
    
64. # @arguments Data set to melt
    
65. # @arguments Id variables. If blank, will use all non measure.vars variables.  Can be integer (variable position) or string (variable name)
    
66. # @arguments Measured variables. If blank, will use all non id.vars variables. Can be integer (variable position) or string (variable name)
    
67. # @arguments Name of the variable that will store the names of the original variables
    
68. # @arguments Should NA values be removed from the data set?
    
69. # @arguments Old argument name, now deprecated
    
70. # @value molten data
    
71. # @keyword manip
    
72. # @seealso \url{http://had.co.nz/reshape/}
    
73. #X head(melt(tips))
    
74. #X names(airquality) <- tolower(names(airquality))
    
75. #X melt(airquality, id=c("month", "day"))
    
76. #X names(ChickWeight) <- tolower(names(ChickWeight))
    
77. #X melt(ChickWeight, id=2:4)
    
78. melt.data.frame <- function(data, id.vars, measure.vars, variable_name = "variable", na.rm = !preserve.na, preserve.na = TRUE, ...) {
    
79.   if (!missing(preserve.na))
    
80.     message("Use of preserve.na is now deprecated, please use na.rm instead")
    
81. 
    
82.   var <- melt_check(data, id.vars, measure.vars)
    
83. 
    
84.   if (length(var$measure) == 0) {
    
85.     return(data[, var$id, drop=FALSE])
    
86.   }
    
87. 
    
88.   ids <- data[,var$id, drop=FALSE]
    
89.   df <- do.call("rbind", lapply(var$measure, function(x) {
    
90.     data.frame(ids, x, data[, x])
    
91.   }))
    
92.   names(df) <- c(names(ids), variable_name, "value")
    
93. 
    
94.   df[[variable_name]] <- factor(df[[variable_name]], unique(df[[variable_name]]))
    
95. 
    
96.   if (na.rm) {
    
97.     df <- df[!is.na(df$value), , drop=FALSE]
    
98.   }
    
99.   rownames(df) <- NULL
    
100.   df
     
101. }
     
102. 
     
103. # Melt an array
     
104. # This function melts a high-dimensional array into a form that you can use \code{\link{cast}} with.
     
105. #
     
106. # This code is conceptually similar to \code{\link{as.data.frame.table}}
     
107. #
     
108. # @arguments array to melt
     
109. # @arguments variable names to use in molten data.frame
     
110. # @keyword manip
     
111. # @alias melt.matrix
     
112. # @alias melt.table
     
113. #X a <- array(1:24, c(2,3,4))
     
114. #X melt(a)
     
115. #X melt(a, varnames=c("X","Y","Z"))
     
116. #X dimnames(a) <- lapply(dim(a), function(x) LETTERS[1:x])
     
117. #X melt(a)
     
118. #X melt(a, varnames=c("X","Y","Z"))
     
119. #X dimnames(a)[1] <- list(NULL)
     
120. #X melt(a)
     
121. melt.array <- function(data, varnames = names(dimnames(data)), ...) {
     
122.   values <- as.vector(data)
     
123. 
     
124.   dn <- dimnames(data)
     
125.   if (is.null(dn)) dn <- vector("list", length(dim(data)))
     
126. 
     
127.   dn_missing <- sapply(dn, is.null)
     
128.   dn[dn_missing] <- lapply(dim(data), function(x) 1:x)[dn_missing]
     
129. 
     
130.   char <- sapply(dn, is.character)
     
131.   dn[char] <- lapply(dn[char], type.convert)
     
132.   indices <- do.call(expand.grid, dn)
     
133. 
     
134.   names(indices) <- varnames
     
135. 
     
136.   data.frame(indices, value=values)
     
137. }
     
138. 
     
139. melt.table <- melt.array
     
140. melt.matrix <- melt.array
     
141. 
     
142. # Melt cast data.frames
     
143. # Melt the results of a cast
     
144. #
     
145. # This can be useful when performning complex aggregations - melting
     
146. # the result of a cast will do it's best to figure out the correct variables
     
147. # to use as id and measured.
     
148. #
     
149. # @keyword internal
     
150. melt.cast_df <- function(data, drop.margins=TRUE, ...) {
     
151.   molten <- melt.data.frame(as.data.frame(data), id.vars=attr(data, "idvars"))
     
152. 
     
153.   cols <- rcolnames(data)
     
154.   rownames(cols) <- make.names(rownames(cols))
     
155. 
     
156.   molten <- cbind(molten[names(molten) != "variable"], cols[molten$variable, , drop=FALSE])
     
157. 
     
158.   if (drop.margins) {
     
159.       margins <- !complete.cases(molten[,names(molten) != "value", drop=FALSE])
     
160.     molten <- molten[!margins, ]
     
161.   }
     
162. 
     
163.   molten
     
164. 
     
165. }
     
166. 
     
167. # Melt cast matrices
     
168. # Melt the results of a cast
     
169. #
     
170. # Converts to a data frame and then uses \code{\link{melt.cast_df}}
     
171. #
     
172. # @keyword internal
     
173. melt.cast_matrix <- function(data, ...) {
     
174.   melt(as.data.frame(data))
     
175. }
     
176. 
     
177. # Melt check.
     
178. # Check that input variables to melt are appropriate.
     
179. #
     
180. # If id.vars or measure.vars are missing, \code{melt_check} will do its
     
181. # best to impute them.If you only
     
182. # supply one of id.vars and measure.vars, melt will assume the remainder of
     
183. # the variables in the data set belong to the other. If you supply neither,
     
184. # melt will assume character and factor variables are id variables,
     
185. # and all other are measured.
     
186. #
     
187. # @keyword internal
     
188. # @arguments data frame
     
189. # @arguments Vector of identifying variable names or indexes
     
190. # @arguments Vector of Measured variable names or indexes
     
191. # @value id list id variable names
     
192. # @value measure list of measured variable names
     
193. melt_check <- function(data, id.vars, measure.vars) {
     
194.   varnames <- names(data)
     
195.   if (!missing(id.vars) && is.numeric(id.vars)) id.vars <- varnames[id.vars]
     
196.   if (!missing(measure.vars) && is.numeric(measure.vars)) measure.vars <- varnames[measure.vars]
     
197. 
     
198.   if (!missing(id.vars)) {
     
199.     unknown <- setdiff(id.vars, varnames)
     
200.     if (length(unknown) > 0) {
     
201.       stop("id variables not found in data: ", paste(unknown, collapse=", "),
     
202.         call. = FALSE)
     
203.     }
     
204.   }
     
205. 
     
206.   if (!missing(measure.vars)) {
     
207.     unknown <- setdiff(measure.vars, varnames)
     
208.     if (length(unknown) > 0) {
     
209.       stop("measure variables not found in data: ", paste(unknown, collapse=", "),
     
210.         call. = FALSE)
     
211.     }
     
212.   }
     
213. 
     
214.   if (missing(id.vars) && missing(measure.vars)) {
     
215.     categorical <- sapply(data, function(x) class(x)[1]) %in% c("factor", "ordered", "character")
     
216.     id.vars <- varnames[categorical]
     
217.     measure.vars <- varnames[!categorical]
     
218.     message("Using ", paste(id.vars, collapse=", "), " as id variables")
     
219.   }
     
220. 
     
221.   if (missing(id.vars)) id.vars <- varnames[!(varnames %in% c(measure.vars))]
     
222.   if (missing(measure.vars)) measure.vars <- varnames[!(varnames %in% c(id.vars))]
     
223. 
     
224.   list(id = id.vars, measure = measure.vars)
     
225. }

复制代码

去页面下载：https://cran.r-project.org/web/packages/reshape/
reshape包代码。然后解压，在R文件夹里找到melt.r文件，打开就是原代码了。

jiangbeilu 发表于 2016-1-23 14:16
去页面下载：https://cran.r-project.org/web/packages/reshape/
reshape包代码。然后解压，在R文件 ...

非常感谢啊！！！

ryoeng 发表于 2016-1-23 14:31
也是另一个选择哦！

另外还想问一下，为啥，melt的效率能那么高呢？？