← Back to branch summary

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

« back to all changes in this revision

Viewing changes to R/strand-utils.R

  • Committer: Package Import Robot
  • Author(s): Andreas Tille
  • Date: 2014-06-13 15:04:19 UTC
  • mfrom: (1.1.2)
  • Revision ID: package-import@ubuntu.com-20140613150419-v49mxnlg42rnuks5
Tags: 1.16.3-1
* New upstream version
* New (Build-)Depends: r-bioc-genomeinfodb
* cme fix dpkg-control
* add autopkgtest

Show diffs side-by-side

added added

removed removed

Lines of Context:
R/strand-utils.R
1
 
### Strand utilities.
 
1
### =========================================================================
 
2
### Strand utilities
 
3
### -------------------------------------------------------------------------
 
4
 
 
5
 
 
6
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 
7
### Some "strand" and "strand<-" methods
 
8
###
2
9
 
3
10
setMethod("strand", "missing", function(x) factor(levels=c("+","-","*")))
 
11
setMethod("strand", "NULL", function(x) strand())
4
12
 
5
13
setMethod("strand", "character",
6
 
    function(x) {
 
14
    function(x)
 
15
    {
7
16
        lvls <- levels(strand())
8
 
        if (!all(is.na(x) | (x %in% lvls)))
 
17
        if (!all(x %in% lvls))
9
18
            stop("strand values must be in '", paste(lvls, collapse="' '"), "'")
10
19
        factor(x, levels=lvls)
11
 
    })
 
20
    }
 
21
)
12
22
 
13
23
setMethod("strand", "factor",
14
 
    function(x) {
 
24
    function(x)
 
25
    {
 
26
        if (any(is.na(x)))
 
27
            stop("NA not a valid strand value, use \"*\" instead")
15
28
        lvls <- levels(strand())
16
 
        if (length(setdiff(levels(x), lvls)))
17
 
            stop("strand values must be in '", paste(lvls, collapse="' '"), "'")
 
29
        x_levels <- levels(x)
 
30
        if (identical(x_levels, lvls))
 
31
            return(x)
 
32
        invalid_levels <- setdiff(x_levels, lvls)
 
33
        if (length(invalid_levels) != 0L)
 
34
            stop("invalid strand levels in 'x': ",
 
35
                 paste(invalid_levels, collapse=", "))
18
36
        factor(x, levels=lvls)
19
 
    })
 
37
    }
 
38
)
20
39
 
21
40
setMethod("strand", "integer",
22
 
    function(x) {
 
41
    function(x)
 
42
    {
23
43
        lvls <- c(1L, -1L, NA)
24
 
        if (length(setdiff(x, lvls)))
 
44
        if (!all(x %in% lvls))
25
45
            stop("strand values must be in '", paste(lvls, collapse="' '"), "'")
26
 
        ans <- strand()
27
 
        length(ans) <- length(x)
 
46
        ans <- rep.int(strand("*"), length(x))
28
47
        ans[x ==  1L] <- "+"
29
48
        ans[x == -1L] <- "-"
30
49
        ans
31
 
    })
 
50
    }
 
51
)
32
52
 
33
53
setMethod("strand", "logical",
34
 
    function(x) {
35
 
        ans <- strand()
36
 
        length(ans) <- length(x)
 
54
    function(x)
 
55
    {
 
56
        ans <- rep.int(strand("*"), length(x))
37
57
        ans[!x] <- "+"
38
58
        ans[ x] <- "-"
39
59
        ans
40
 
    })
 
60
    }
 
61
)
41
62
 
42
63
setMethod("strand", "Rle",
43
 
    function(x) {
 
64
    function(x)
 
65
    {
44
66
        x_runValue <- runValue(x)
45
 
        if (!is.logical(x_runValue))
46
 
            stop("only 'logical'-Rle's are supported by \"strand\" method",
47
 
                 "for Rle objects at the moment, sorry")
 
67
        if (!(is.character(x_runValue) ||
 
68
              is.factor(x_runValue) ||
 
69
              is.integer(x_runValue) ||
 
70
              is.logical(x_runValue)))
 
71
            stop("\"strand\" method for Rle objects only works on a ",
 
72
                 "character-, factor-, integer-, or logical-Rle object")
48
73
        runValue(x) <- strand(x_runValue)
49
74
        x
50
 
    })
 
75
    }
 
76
)
51
77
 
52
78
setMethod("strand", "DataTable",
53
 
    function(x) {
 
79
    function(x)
 
80
    {
54
81
        ans <- x[["strand"]]
55
 
        if (is.null(ans))
56
 
            ans <- strand(rep(NA_character_, nrow(x)))
57
 
        else if (is.character(ans))
 
82
        if (is.null(ans)) {
 
83
            ans <- rep.int(strand("*"), nrow(x))
 
84
        } else {
58
85
            ans <- strand(ans)
59
 
        else if (is(ans, "Rle"))
60
 
            ans <- as.factor(ans)
 
86
        }
61
87
        ans
62
 
    })
 
88
    }
 
89
)
63
90
 
64
91
setReplaceMethod("strand", "DataTable", function(x, value) {
65
92
  x$strand <- normargGenomicRangesStrand(value, nrow(x))
66
93
  x
67
94
})
68
95
 
 
96
 
 
97
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 
98
### compatibleStrand() generic and methods
 
99
###
 
100
 
69
101
setGeneric("compatibleStrand", signature=c("x","y"),  # not exported
70
102
    function(x, y) standardGeneric("compatibleStrand")
71
103
)
123
155
        ans
124
156
    }
125
157
)
 
158