Skip to content

Commit a075b38

Browse files
stemangiolastemangiola
committed
add unnest_SE
1 parent c798f5b commit a075b38

File tree

3 files changed

+234
-86
lines changed

3 files changed

+234
-86
lines changed

‎NAMESPACE‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -67,6 +67,7 @@ export(tbl_format_header)
6767
export(tidy)
6868
export(unite)
6969
export(unnest)
70+
export(unnest_summarized_experiment)
7071
importFrom(S4Vectors,"metadata<-")
7172
importFrom(S4Vectors,DataFrame)
7273
importFrom(S4Vectors,SimpleList)

‎R/tidyr_methods.R‎

Lines changed: 154 additions & 86 deletions
Original file line numberDiff line numberDiff line change
@@ -60,101 +60,169 @@ NULL
6060
unnest.tidySummarizedExperiment_nested <-
6161
function(data, cols, ..., keep_empty=FALSE, ptype=NULL, names_sep=NULL, names_repair="check_unique", .drop, .id, .sep, .preserve) {
6262

63-
64-
# Need this otherwise crashes map
65-
.data_ <- data
66-
6763
cols <- enquo(cols)
6864

69-
# If the column is not SE do normal stuff
70-
if(
71-
data %>%
72-
pull(!!cols) %>%
73-
.[[1]] %>%
74-
class() %>%
75-
as.character() %in%
76-
c("SummarizedExperiment", "RangedSummarizedExperiment") %>%
77-
all() %>%
78-
not()
65+
unnest_summarized_experiment(data, !!cols, ..., keep_empty=keep_empty, ptype=ptype,
66+
names_sep=names_sep, names_repair=names_repair)
67+
68+
69+
}
70+
71+
72+
#' unnest_summarized_experiment
73+
#'
74+
#' @importFrom tidyr unnest
75+
#' @importFrom purrr when
76+
#' @importFrom rlang quo_name
77+
#' @importFrom purrr imap
78+
#'
79+
#' @param data A tbl. (See tidyr)
80+
#' @param cols <[`tidy-select`][tidyr_tidy_select]> Columns to unnest.
81+
#' If you `unnest()` multiple columns, parallel entries must be of
82+
#' compatible sizes, i.e. they're either equal or length 1 (following the
83+
#' standard tidyverse recycling rules).
84+
#' @param ... <[`tidy-select`][tidyr_tidy_select]> Columns to nest, specified
85+
#' using name-variable pairs of the form `new_col=c(col1, col2, col3)`.
86+
#' The right hand side can be any valid tidy select expression.
87+
#'
88+
#' \Sexpr[results=rd, stage=render]{lifecycle::badge("deprecated")}:
89+
#' previously you could write `df %>% nest(x, y, z)` and `df %>%
90+
#' unnest(x, y, z)`. Convert to `df %>% nest(data=c(x, y, z))`.
91+
#' and `df %>% unnest(c(x, y, z))`.
92+
#'
93+
#' If you previously created new variable in `unnest()` you'll now need to
94+
#' do it explicitly with `mutate()`. Convert `df %>% unnest(y=fun(x, y, z))`
95+
#' to `df %>% mutate(y=fun(x, y, z)) %>% unnest(y)`.
96+
#' @param names_sep If `NULL`, the default, the names will be left
97+
#' as is. In `nest()`, inner names will come from the former outer names;
98+
#' in `unnest()`, the new outer names will come from the inner names.
99+
#'
100+
#' If a string, the inner and outer names will be used together. In `nest()`,
101+
#' the names of the new outer columns will be formed by pasting together the
102+
#' outer and the inner column names, separated by `names_sep`. In `unnest()`,
103+
#' the new inner names will have the outer names (+ `names_sep`) automatically
104+
#' stripped. This makes `names_sep` roughly symmetric between nesting and unnesting.
105+
#' @param keep_empty See tidyr::unnest
106+
#' @param names_repair See tidyr::unnest
107+
#' @param ptype See tidyr::unnest
108+
#' @param .drop See tidyr::unnest
109+
#' @param .id tidyr::unnest
110+
#' @param .sep tidyr::unnest
111+
#' @param .preserve See tidyr::unnest
112+
#'
113+
#' @return A tidySingleCellExperiment objector a tibble depending on input
114+
#'
115+
#' @examples
116+
#'
117+
#' library(dplyr)
118+
#' pbmc_small %>%
119+
#'
120+
#' nest(data=-groups) %>%
121+
#' unnest_summarized_experiment(data)
122+
#'
123+
#' @rdname unnest-methods
124+
#' @name unnest_summarized_experiment
125+
#'
126+
#'
127+
#'
128+
#' @export
129+
unnest_summarized_experiment <- function(data, cols, ..., keep_empty=FALSE, ptype=NULL,
130+
names_sep=NULL, names_repair="check_unique", .drop, .id, .sep, .preserve) {
131+
# Need this otherwise crashes map
132+
.data_ <- data
133+
134+
cols <- enquo(cols)
135+
136+
# If the column is not SE do normal stuff
137+
if(
138+
data %>%
139+
pull(!!cols) %>%
140+
.[[1]] %>%
141+
class() %>%
142+
as.character() %in%
143+
c("SummarizedExperiment", "RangedSummarizedExperiment") %>%
144+
all() %>%
145+
not()
146+
)
147+
return(
148+
data %>%
149+
drop_class("tidySummarizedExperiment_nested") %>%
150+
tidyr::unnest(!!cols, ..., keep_empty=keep_empty, ptype=ptype, names_sep=names_sep, names_repair=names_repair) %>%
151+
add_class("tidySummarizedExperiment_nested")
79152
)
80-
return(
81-
data %>%
82-
drop_class("tidySummarizedExperiment_nested") %>%
83-
tidyr::unnest(!!cols, ..., keep_empty=keep_empty, ptype=ptype, names_sep=names_sep, names_repair=names_repair) %>%
84-
add_class("tidySummarizedExperiment_nested")
85-
)
153+
154+
# If both nested by transcript and sample
155+
if( s_(se)$name %in% colnames(data) & f_(se)$name %in% colnames(data) ){
156+
stop("tidySummarizedExperiment says: for the moment nesting both by sample- and feature-wise information is not possible. Please ask this feature to github/stemangiola/tidySummarizedExperiment")
157+
}
158+
159+
# If both nested not by transcript nor sample
160+
if(! s_(se)$name %in% colnames(data) & !f_(se)$name %in% colnames(data) ){
86161

87-
# If both nested by transcript and sample
88-
if( s_(se)$name %in% colnames(data) & f_(se)$name %in% colnames(data) ){
89-
stop("tidySummarizedExperiment says: for the moment nesting both by sample- and feature-wise information is not possible. Please ask this feature to github/stemangiola/tidySummarizedExperiment")
90-
}
162+
se = pull(data, !!cols) %>% .[[1]]
91163

92-
# If both nested not by transcript nor sample
93-
if(! s_(se)$name %in% colnames(data) & !f_(se)$name %in% colnames(data) ){
94-
95-
se = pull(data, !!cols) %>% .[[1]]
96-
97-
# Mark if columns belong to feature or sample
98-
my_unnested_tibble =
99-
mutate(data, !!cols := map(!!cols, ~ as_tibble(.x))) %>%
100-
select(-suppressWarnings( one_of(s_(se)$name, f_(se)$name))) %>%
101-
unnest(!!cols)
102-
103-
# Get which column is relative to feature or sample
104-
sample_columns = my_unnested_tibble %>% get_subset_columns(!!s_(se)$symbol)
105-
transcript_columns = my_unnested_tibble %>% get_subset_columns(!!f_(se)$symbol)
106-
107-
source_column =
108-
c(
109-
rep(s_(se)$name, length(sample_columns)) %>% setNames(sample_columns),
110-
rep(f_(se)$name, length(transcript_columns)) %>% setNames(transcript_columns)
111-
)
112-
113-
# Do my trick to unnest
114-
return(
115-
mutate(data, !!cols := imap(
116-
!!cols, ~ .x %>%
117-
bind_cols_internal(
118-
119-
# Attach back the columns used for nesting
120-
.data_ %>%
121-
select(-!!cols, -suppressWarnings( one_of(s_(se)$name, f_(se)$name))) %>%
122-
slice(rep(.y, ncol(.x) * nrow(.x))),
123-
124-
# Column sample-wise or feature-wise
125-
column_belonging =
126-
source_column[
127-
.data_ %>%
128-
select(-!!cols, -suppressWarnings( one_of(s_(se)$name, f_(se)$name))) %>%
129-
colnames()
130-
]
131-
)
132-
)) %>%
133-
pull(!!cols) %>%
134-
reduce(bind_rows)
164+
# Mark if columns belong to feature or sample
165+
my_unnested_tibble =
166+
mutate(data, !!cols := map(!!cols, ~ as_tibble(.x))) %>%
167+
select(-suppressWarnings( one_of(s_(se)$name, f_(se)$name))) %>%
168+
unnest(!!cols)
169+
170+
# Get which column is relative to feature or sample
171+
sample_columns = my_unnested_tibble %>% get_subset_columns(!!s_(se)$symbol)
172+
transcript_columns = my_unnested_tibble %>% get_subset_columns(!!f_(se)$symbol)
173+
174+
source_column =
175+
c(
176+
rep(s_(se)$name, length(sample_columns)) %>% setNames(sample_columns),
177+
rep(f_(se)$name, length(transcript_columns)) %>% setNames(transcript_columns)
135178
)
136-
137-
}
138179

139-
# If column is SE nd only feature
140-
if(f_(se)$name %in% colnames(data)){
141-
142-
se = do.call(SummarizedExperiment::rbind, pull(data, !!cols))
143-
rowData(se) = cbind( rowData(se), data %>% select(-!!cols, -!!f_(se)$symbol))
144-
145-
return(se)
146-
}
180+
# Do my trick to unnest
181+
return(
182+
mutate(data, !!cols := imap(
183+
!!cols, ~ .x %>%
184+
bind_cols_internal(
185+
186+
# Attach back the columns used for nesting
187+
.data_ %>%
188+
select(-!!cols, -suppressWarnings( one_of(s_(se)$name, f_(se)$name))) %>%
189+
slice(rep(.y, ncol(.x) * nrow(.x))),
190+
191+
# Column sample-wise or feature-wise
192+
column_belonging =
193+
source_column[
194+
.data_ %>%
195+
select(-!!cols, -suppressWarnings( one_of(s_(se)$name, f_(se)$name))) %>%
196+
colnames()
197+
]
198+
)
199+
)) %>%
200+
pull(!!cols) %>%
201+
reduce(bind_rows)
202+
)
147203

148-
# If column is SE nd only sample
149-
if(s_(se)$name %in% colnames(data)){
150-
151-
se = do.call(SummarizedExperiment::cbind, pull(data, !!cols))
152-
colData(se) = cbind( colData(se), data %>% select(-!!cols, -!!s_(se)$symbol))
153-
154-
return(se)
155-
156-
}
157204
}
205+
206+
# If column is SE nd only feature
207+
if(f_(se)$name %in% colnames(data)){
208+
209+
se = do.call(SummarizedExperiment::rbind, pull(data, !!cols))
210+
rowData(se) = cbind( rowData(se), data %>% select(-!!cols, -!!f_(se)$symbol))
211+
212+
return(se)
213+
}
214+
215+
# If column is SE nd only sample
216+
if(s_(se)$name %in% colnames(data)){
217+
218+
se = do.call(SummarizedExperiment::cbind, pull(data, !!cols))
219+
colData(se) = cbind( colData(se), data %>% select(-!!cols, -!!s_(se)$symbol))
220+
221+
return(se)
222+
223+
}
224+
}
225+
158226

159227
#' nest
160228
#'

‎man/unnest-methods.Rd‎

Lines changed: 79 additions & 0 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

0 commit comments

Comments
 (0)