update melt function key is LIST

R/melt.R

@@ -53,7 +53,7 @@ fd_melt_SINGLE <- function(x, key1, id = NULL){
 #'
 #' @export
 #'
-fd_melt <- function(x, key1, key2 = NULL, id = NULL, keep = NULL){
+fd_melt_12 <- function(x, key1, key2 = NULL, id = NULL, keep = NULL){
 
   if(is.null(key2)){
     DF = fd_melt_SINGLE(x, key1, id)
@@ -70,6 +70,45 @@ fd_melt <- function(x, key1, key2 = NULL, id = NULL, keep = NULL){
   return(DF)
 }
 
+
+#' @name fd_melt
+#'
+#' @param key a list or vector of column name to keep
+#'
+#' @export
+#'
+fd_melt <- function(x, key, id = NULL, keep = NULL){
+  lgth_key = lapply(1:length(key),
+                    function(i){
+                      sapply(x[[key[[i]]]], length)
+                    })
+  if(length(lgth_key)>1){
+    if(!all(
+      sapply(2:length(lgth_key),
+             function(i) lgth_key[[1]] == lgth_key[[i]])
+    )) { stop("length of element within 'key' differ.")}
+  }
+
+  if(is.null(id)) {
+    id = 1:length(lgth_key[[1]])
+  } else{
+    id = x[[id]]
+  }
+  DF = data.frame(
+    id = do.call("c", lapply(1:length(id), function(i) rep(id[i], lgth_key[[1]][[i]])))
+  )
+  for(i in 1:length(key)){
+    DF[[key[[i]]]] = do.call("c", x[[key[[i]]]])
+  }
+  # --- keep
+  if(!is.null(keep)) {
+    for(i in 1:length(keep)){
+      DF[[keep[[i]]]] = fd_melt_STICK(x, key[[1]], keep[[i]])
+    }
+  }
+  return(DF)
+}
+
 #' @name fd_melt
 #'
 #' @export