melt.R 3.53 KB
Newer Older
Virgile Baudrot's avatar
Virgile Baudrot 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
#' @title Convert list.column data.frame into scalar.column data.frame
#'
#' @description Convert data.frame with 2 column.list into data.frame with only column.scalar
#'
#' @name fd_melt
#'
#' @param x A data.frame
#' @param key1 character string. The name of the column to select
#' @param key2 icharacter string. The name of the column to select
#' @param id name of the replicate for the id. As to be of the same length as the number of row of the x object
#'
#' @export
#'
fd_melt_DOUBLE <- function(x, key1, key2, id = NULL){
  lgth_key1 = sapply(x[[key1]], length)
  lgth_key2 = sapply(x[[key2]], length)
  if(any(lgth_key1 != lgth_key2)){ stop("length of element from 'key1' and 'key2' differ.")}
  if(is.null(id)) {
    id = 1:length(lgth_key1)
  } else{
    id = x[[id]]
  }
  df = data.frame(
    id = do.call("c", lapply(1:length(id), function(i) rep(id[i], lgth_key1[[i]])))
  )
  df[[key1]] = do.call("c", x[[key1]])
  df[[key2]] = do.call("c", x[[key2]])
  return(df)
}

#' @name fd_melt
#'
#'
#' @export
#'
fd_melt_SINGLE <- function(x, key1, id = NULL){
  lgth_key1 = sapply(x[[key1]], length)
  if(is.null(id)) {
    id = 1:length(lgth_key1)
  } else{
    id = x[[id]]
  }
  df = data.frame(
    id = do.call("c", lapply(1:length(id), function(i) rep(id[i], lgth_key1[[i]])))
  )
  df[[key1]] = do.call("c", x[[key1]])
  return(df)
}

#' @name fd_melt
#'
#' @param keep vector of column name to keep
#'
#' @export
#'
56
fd_melt_12 <- function(x, key1, key2 = NULL, id = NULL, keep = NULL){
Virgile Baudrot's avatar
Virgile Baudrot committed
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72

  if(is.null(key2)){
    DF = fd_melt_SINGLE(x, key1, id)
  } else{
    DF = fd_melt_DOUBLE(x, key1, key2, id)
  }

  # --- keep
  if(!is.null(keep)) {
    for(i in 1:length(keep)){
      DF[[keep[[i]]]] = fd_melt_STICK(x, key1, keep[[i]])
    }
  }
  return(DF)
}

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

#' @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)
}

Virgile Baudrot's avatar
Virgile Baudrot committed
112
113
114
115
116
#' @name fd_melt
#'
#' @export
#'
fd_melt_STICK = function(x, key1, keep){
117
118
119
120
121
122
123
124
  if(is.factor(x[[keep]])){
    vec = factor(do.call("c", lapply(1:nrow(x),
                                     function(i){ as.character(rep(x[[keep]][i], length(x[[key1]][[i]])))})),
                 levels = levels(x[[keep]]))
  } else{
    vec = do.call("c", lapply(1:nrow(x),
                              function(i){ rep(x[[keep]][i], length(x[[key1]][[i]]))}))
  }
Virgile Baudrot's avatar
Virgile Baudrot committed
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
  return(vec)
}

#' @title Combine list of data.frame by Rows
#'
#' @return Return a data.frame
#'
#' @param ls A list of data.frame
#' @param id id to provide to each data.frame. Must be the length of the list
#'
#' @export
#'
fd_rbindLStoDF <- function(ls, id = NULL){
  df <- do.call("rbind", ls)
  nrow_df <- sapply(ls, nrow)
  if(is.null(id)) { id = 1:length(nrow_df) }
  df[["id"]] = do.call("c", lapply(1:length(nrow_df), function(i) rep(id[i], nrow_df[[i]])))
  return(df)
}