← Back to branch summary

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

« back to all changes in this revision

Viewing changes to R/makeGRangesFromDataFrame.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/makeGRangesFromDataFrame.R
 
1
### =========================================================================
 
2
### makeGRangesFromDataFrame()
 
3
### -------------------------------------------------------------------------
 
4
 
 
5
 
 
6
### Must return NULL or a Seqinfo object.
 
7
.normarg_seqinfo <- function(seqinfo)
 
8
{
 
9
    if (is.null(seqinfo) || is(seqinfo, "Seqinfo"))
 
10
        return(seqinfo)
 
11
    if (is.character(seqinfo))
 
12
        return(Seqinfo(seqinfo))
 
13
    if (is.numeric(seqinfo)) {
 
14
        seqlevels <- names(seqinfo)
 
15
        if (is.null(seqlevels))
 
16
            stop("when a numeric vector, 'seqinfo' must have names")
 
17
        return(Seqinfo(seqlevels, seqlengths=seqinfo))
 
18
    }
 
19
    stop("'seqinfo' must be NULL, or a Seqinfo object, or a character vector ",
 
20
         "of seqlevels, or a named numeric vector of sequence lengths")
 
21
}
 
22
 
 
23
.get_field_pos <- function(field, df, what, required=TRUE)
 
24
{
 
25
    if (!is.character(field) || any(is.na(field)))
 
26
        stop("'", what, ".field' must be a character vector with no NAs")
 
27
    pos <- match(field, names(df))
 
28
    pos <- pos[which(!is.na(pos))[1L]]
 
29
    if (required && is.na(pos))
 
30
        stop("no field listed in '", what, ".field' is present in 'df'")
 
31
    pos
 
32
}
 
33
 
 
34
### 'df' must be a data.frame or DataFrame object.
 
35
makeGRangesFromDataFrame <- function(df,
 
36
    keep.extra.columns=FALSE,
 
37
    ignore.strand=FALSE,
 
38
    seqinfo=NULL,
 
39
    seqnames.field=c("seqnames", "chr", "chrom"),
 
40
    start.field=c("start", "chromStart"),
 
41
    end.field=c("end", "chromEnd", "stop", "chromStop"),
 
42
    strand.field="strand",
 
43
    starts.in.df.are.0based=FALSE)
 
44
{
 
45
    ## Check args.
 
46
    if (!is.data.frame(df) && !is(df, "DataFrame"))
 
47
        stop("'df' must be a data.frame or DataFrame object")
 
48
    if (!isTRUEorFALSE(keep.extra.columns))
 
49
        stop("'keep.extra.columns' must be TRUE or FALSE")
 
50
    if (!isTRUEorFALSE(ignore.strand))
 
51
        stop("'ignore.strand' must be TRUE or FALSE")
 
52
    ans_seqinfo <- .normarg_seqinfo(seqinfo)
 
53
    seqnames_fpos <- .get_field_pos(seqnames.field, df, "seqnames")
 
54
    start_fpos <- .get_field_pos(start.field, df, "start")
 
55
    end_fpos <- .get_field_pos(end.field, df, "end")
 
56
    strand_fpos <- .get_field_pos(strand.field, df, "strand", required=FALSE)
 
57
    if (!isTRUEorFALSE(starts.in.df.are.0based))
 
58
        stop("'starts.in.df.are.0based' must be TRUE or FALSE")
 
59
 
 
60
    ## Prepare the GRanges components.
 
61
    ans_seqnames <- df[[seqnames_fpos]]
 
62
    ans_start <- df[[start_fpos]]
 
63
    ans_end <- df[[end_fpos]]
 
64
    if (!is.numeric(ans_start) || !is.numeric(ans_end))
 
65
        stop("\"", names(df)[start_fpos], "\" and ",
 
66
             "\"", names(df)[end_fpos], "\" columns must be numeric")
 
67
    if (starts.in.df.are.0based)
 
68
        ans_start <- ans_start + 1L
 
69
    ans_ranges <- IRanges(ans_start, ans_end)
 
70
    if (is.na(strand_fpos) || ignore.strand) {
 
71
        ans_strand <- "*"
 
72
    } else {
 
73
        ans_strand <- df[[strand_fpos]]
 
74
    }
 
75
    if (keep.extra.columns) {
 
76
        drop_idx <- c(seqnames_fpos, start_fpos, end_fpos)
 
77
        if (!is.na(strand_fpos))
 
78
            drop_idx <- c(drop_idx, strand_fpos)
 
79
        ans_mcols <- df[-drop_idx]
 
80
    } else {
 
81
        ans_mcols <- NULL
 
82
    }
 
83
    ans_names <- rownames(df)
 
84
    if (identical(as.character(seq_len(nrow(df))), ans_names))
 
85
        ans_names <- NULL
 
86
 
 
87
    ## Make the GRanges object and return it.
 
88
    ans <- GRanges(seqnames=ans_seqnames, ranges=ans_ranges, strand=ans_strand,
 
89
                   ans_mcols, seqinfo=ans_seqinfo)
 
90
    if (!is.null(ans_names))
 
91
        names(ans) <- ans_names
 
92
    ans
 
93
}
 
94
 
 
95
setAs("data.frame", "GRanges",
 
96
    function(from) makeGRangesFromDataFrame(from, keep.extra.columns=TRUE)
 
97
)
 
98
 
 
99
setAs("DataFrame", "GRanges",
 
100
    function(from) makeGRangesFromDataFrame(from, keep.extra.columns=TRUE)
 
101
)
 
102