← Back to branch summary

~ubuntu-branches/ubuntu/wily/r-bioc-genomicranges/wily-proposed

« back to all changes in this revision

Viewing changes to R/seqlevels-utils.R

  • Committer: Package Import Robot
  • Author(s): Andreas Tille
  • Date: 2013-11-26 19:52:13 UTC
  • mfrom: (1.1.1)
  • Revision ID: package-import@ubuntu.com-20131126195213-1zwbthnie0a7fdns
Tags: 1.14.3-1
http://bugs.debian.org/730574
* New upstream version
  Closes: #730574
* Build-Depends: r-bioc-xvector

Show diffs side-by-side

added added

removed removed

Lines of Context:
R/seqlevels-utils.R
1
 
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 
1
### =========================================================================
2
2
### Utility functions for subsetting and renaming seqlevels 
3
 
###
4
 
 
5
 
## keepSeqlevels :
6
 
 
7
 
setGeneric("keepSeqlevels", signature = c("x", "value"),
8
 
           function(x, value, ...)
9
 
           standardGeneric("keepSeqlevels")
10
 
)
11
 
 
12
 
setMethod("keepSeqlevels",  c("GenomicRanges", "GenomicRanges"),
13
 
            function(x, value, ...)
14
 
{
15
 
    value <- seqlevels(value)
16
 
    callGeneric(x, value, ...)
17
 
})
18
 
 
19
 
setMethod("keepSeqlevels",  c("GenomicRanges", "GRangesList"),
20
 
            function(x, value, ...)
21
 
{
22
 
    value <- seqlevels(value)
23
 
    callGeneric(x, value, ...)
24
 
})
25
 
 
26
 
setMethod("keepSeqlevels",  c("GenomicRanges", "GappedAlignments"),
27
 
            function(x, value, ...)
28
 
{
29
 
    value <- seqlevels(value)
30
 
    callGeneric(x, value, ...)
31
 
})
32
 
 
33
 
setMethod("keepSeqlevels",  c("GRangesList", "GenomicRanges"),
34
 
            function(x, value, ...)
35
 
{
36
 
    value <- seqlevels(value)
37
 
    callGeneric(x, value, ...)
38
 
})
39
 
 
40
 
setMethod("keepSeqlevels",  c("GRangesList", "GRangesList"),
41
 
            function(x, value, ...)
42
 
{
43
 
    value <- seqlevels(value)
44
 
    callGeneric(x, value, ...)
45
 
})
46
 
 
47
 
setMethod("keepSeqlevels",  c("GRangesList", "GappedAlignments"),
48
 
            function(x, value, ...)
49
 
{
50
 
    value <- seqlevels(value)
51
 
    callGeneric(x, value, ...)
52
 
})
53
 
 
54
 
setMethod("keepSeqlevels",  c("GenomicRanges", "character"),
55
 
            function(x, value, ...)
56
 
{
57
 
    if (!identical(character(0), seqlevels(x)) &&
58
 
        !identical(character(0), value)) {
59
 
        str <- !value %in% seqlevels(x)
60
 
        if (any(str))
61
 
            warning("seqlevels ", paste(value[str], collapse=", "),
62
 
                    " not found in 'x'")
63
 
        if (all(str)) {
64
 
            x
65
 
        } else {
66
 
            suppressWarnings(seqlevels(x, force=TRUE) <- value[str == FALSE])
67
 
            x
68
 
        }
69
 
    } else {
70
 
        x
71
 
    }
72
 
})
73
 
 
74
 
setMethod("keepSeqlevels",  c("GRangesList", "character"),
75
 
            function(x, value, ...)
76
 
{
77
 
    if (!identical(character(0), seqlevels(x)) &&
78
 
        !identical(character(0), value)) {
79
 
        str <- !value %in% seqlevels(x)
80
 
        if (any(str))
81
 
            warning("seqlevels ", paste(value[str], collapse=", "),
82
 
                    " not found in 'x'")
83
 
        if (all(str)) {
84
 
            x
85
 
        } else {
86
 
            grlSeqnames <- unlist(seqnames(x), use.names=FALSE)
87
 
            idx <- rep(runValue(grlSeqnames) %in% value, runLength(grlSeqnames))
88
 
            grReduced <- deconstructGRLintoGR(x)[idx]
89
 
            grlReduced <- reconstructGRLfromGR(grReduced, x)
90
 
 
91
 
            seqlevels(grlReduced) <- seqlevels(x)[seqlevels(x) %in% value]
92
 
            grlReduced[elementLengths(grlReduced) != 0] 
93
 
        }
94
 
    } else {
95
 
        x
96
 
    }
97
 
})
98
 
 
99
 
setMethod("keepSeqlevels",  c("GappedAlignments", "GenomicRanges"),
100
 
            function(x, value, ...)
101
 
{
102
 
    value <- seqlevels(value)
103
 
    callGeneric(x, value, ...)
104
 
})
105
 
 
106
 
setMethod("keepSeqlevels",  c("GappedAlignments", "GRangesList"),
107
 
            function(x, value, ...)
108
 
{
109
 
    value <- seqlevels(value)
110
 
    callGeneric(x, value, ...)
111
 
})
112
 
 
113
 
setMethod("keepSeqlevels",  c("GappedAlignments", "GappedAlignments"),
114
 
            function(x, value, ...)
115
 
{
116
 
    value <- seqlevels(value)
117
 
    callGeneric(x, value, ...)
118
 
})
119
 
 
120
 
setMethod("keepSeqlevels",  c("GappedAlignments", "character"),
121
 
            function(x, value, ...)
122
 
{
123
 
    if (!identical(character(0), seqlevels(x)) &&
124
 
        !identical(character(0), value)) {
125
 
        str <- !value %in% seqlevels(x)
126
 
        if (any(str))
127
 
            warning("seqlevels ", paste(value[str], collapse=", "), 
128
 
                    " not found in 'x'")
129
 
        if (all(str)) {
130
 
            x
131
 
        } else {
132
 
            suppressWarnings(seqlevels(x, force=TRUE) <- value[str == FALSE])
133
 
            x
 
3
### -------------------------------------------------------------------------
 
4
 
 
5
keepSeqlevels <- function(x, value, ...)
 
6
{
 
7
    value <- unname(value)
 
8
    if (any(nomatch <- !value %in% seqlevels(x)))
 
9
        warning("invalid seqlevels '", 
 
10
                paste(value[nomatch], collapse=","), "' were ignored")
 
11
    seqlevels(x, force=TRUE) <- value[!nomatch]
 
12
    x
 
13
}
 
14
 
 
15
dropSeqlevels <- function(x, value, ...)
 
16
{
 
17
    value <- unname(value)
 
18
    if (any(nomatch <- !value %in% seqlevels(x)))
 
19
        warning("invalid seqlevels '", 
 
20
                paste(value[nomatch], collapse=","), "' were ignored")
 
21
    seqlevels(x, force=TRUE) <- seqlevels(x)[!seqlevels(x) %in% value]
 
22
    x
 
23
}
 
24
 
 
25
renameSeqlevels <- function(x, value, ...)
 
26
{
 
27
    nms <- names(value)
 
28
    ## unnamed
 
29
    if (is.null(nms)) {
 
30
        if (length(value) != length(seqlevels(x)))
 
31
            stop("unnamed 'value' must be the same length as seqlevels(x)")
 
32
        names(value) <- seqlevels(x)
 
33
    ## named
 
34
    } else {
 
35
        if (any(nomatch <- !nms %in% seqlevels(x)))
 
36
            warning("invalid seqlevels '", 
 
37
                    paste(nms[nomatch], collapse=","), "' were ignored")
 
38
        if (length(value) != length(seqlevels(x))) {
 
39
            level <- seqlevels(x)
 
40
            level[level %in% nms] <- value
 
41
            value <- level
134
42
        } 
135
 
    } else { 
136
 
        x
137
 
    }
138
 
})
139
 
 
140
 
 
141
 
## renameSeqlevels : 
142
 
 
143
 
.renameSeqlevels <- function(x, value, ...)
144
 
{
145
 
    if (identical(character(0), seqlevels(x)))
146
 
        return(x)
147
 
    if (is.null(old <- names(value)))
148
 
        stop("'value' must be a named character vector")
149
 
    new <- unlist(value, use.names=FALSE)
150
 
 
151
 
    str <- !old %in% seqlevels(x)
152
 
    if (any(str)) {
153
 
        warning("seqlevels ", paste(old[str], collapse=", "), 
154
 
                " not found in 'x'")
155
 
    }
156
 
    ord <- match(old[str == FALSE], seqlevels(x))
157
 
    seqlevels(x)[ord] <- new[str == FALSE]
 
43
    } 
 
44
    seqlevels(x) <- value  
158
45
    x 
159
46
}
160
47
 
161
 
setGeneric("renameSeqlevels", signature = c("x", "value"),
162
 
    function(x, value, ...)
163
 
    standardGeneric("renameSeqlevels")
164
 
)
165
 
 
166
 
setMethod("renameSeqlevels",  c(x="GappedAlignments", value="character"),
167
 
    function(x, value, ...) .renameSeqlevels(x, value, ...)
168
 
)
169
 
 
170
 
setMethod("renameSeqlevels",  c("GRangesList", "character"),
171
 
    function(x, value, ...) .renameSeqlevels(x, value, ...)
172
 
)
173
 
 
174
 
setMethod("renameSeqlevels",  c("GenomicRanges", "character"),
175
 
    function(x, value, ...) .renameSeqlevels(x, value, ...)
176
 
)
 
48
## Currently applies to TranscriptDb only.
 
49
restoreSeqlevels <- function(x, ...)
 
50
{
 
51
    seqlevels0(x) 
 
52
    x
 
53
}
177
54