← Back to branch summary

~ubuntu-branches/ubuntu/raring/r-cran-sp/raring

« back to all changes in this revision

Viewing changes to R/over.R

  • Committer: Bazaar Package Importer
  • Author(s): Charles Plessy
  • Date: 2011-05-29 21:21:40 UTC
  • mfrom: (1.1.10 upstream)
  • Revision ID: james.westby@ubuntu.com-20110529212140-ug6xemkw0j0yr5gc
Tags: 1:0.9-81-1
http://bugs.debian.org/628354
* Team upload.
* New upstream release. Closes: #628354 (caused by a typo in the source).
* Using Debhelper 8 (debian/control, debian/compat).
* Removed completely debian/get-orig-source, and version mangling in
  debian/watch. This is not needed since 1:0.9-52-1.
* Build-depend on R versions greater than R 2.10.0 (debian/control).
* Converted debian/copyright to DEP 5 and documented a new file.
* Renamed debian/README.Debian debian/README.test, and install it
  with debian/docs.
* Incremented Standards-Version to reflect conformance with Policy 3.9.2.
  (debian/control, no changes needed).

Show diffs side-by-side

added added

removed removed

Lines of Context:
R/over.R
1
 
.overDF = function(r, data, n, returnList, fn) {
 
1
.overDF = function(r, data, n, returnList, fn, ...) {
2
2
        ret = lapply(1:n, function(x) data[r[[x]],,drop=FALSE])
3
3
        if (!returnList) {
4
4
                if (is.null(fn))
5
 
                        fn = function(x) { x[1,,drop=FALSE] }
6
 
                ret = do.call(rbind, lapply(ret, fn))
 
5
                        fn = function(x, ...) { x[1,,drop=FALSE] }
 
6
                ret = do.call(rbind, lapply(ret, fn, ...))
7
7
                # ret[match(1:n, ix),,drop=FALSE]
8
8
                ret[is.nan(ret)] = NA
 
9
                ret = as.data.frame(ret)
9
10
        } else
10
11
                stopifnot(is.null(fn))
11
12
        ret
12
13
}
13
14
 
 
15
# we need to invert a list of indexes, i.e.
 
16
# list(c(1,4), c(2,4,5))
 
17
# needs to become
 
18
# list(c(1), c(2), integer(0), c(1,2), c(2))
 
19
# the expensive way is to form the full matrix, as in:
 
20
#
14
21
#.invert = function(lst, nr, nc) {
15
22
#       stopifnot(nr == length(lst))
16
23
#       m = matrix(FALSE, nr, nc)
18
25
#               m[i,lst[[i]]] = TRUE
19
26
#       lapply(1:nc, function(x) which(m[,x]))
20
27
#}
 
28
# but the following does this more efficient:
21
29
 
22
30
.invert = function(x, nr, nc) { 
23
31
        stopifnot(nr == length(x)) # obsolete argument!
24
32
        ret = cbind(rep(1:nr, times = sapply(x, length)), unlist(x))
25
33
        ret = split(ret[,1], ret[,2])
 
34
        # initialize return list with empty cells:
26
35
        lst = lapply(1:nc, function(x) integer(0))
27
36
        idx = as.integer(names(ret))
28
37
        lst[idx] = ret
31
40
 
32
41
'%over%' = function(x,y) over(x,y)
33
42
 
 
43
overDFGeneric = function(x, y, returnList = FALSE, fn = NULL, ...) {
 
44
        stopifnot(identical(proj4string(x),proj4string(y)))
 
45
        r = over(x, geometry(y), returnList = TRUE)
 
46
        ret = .overDF(r, y@data, length(x), returnList, fn, ...)
 
47
        if (!returnList)
 
48
                row.names(ret) = row.names(x)
 
49
        ret
 
50
}
 
51
 
34
52
setMethod("over",
35
53
        signature(x = "SpatialPoints", y = "SpatialPoints"), 
36
 
                function(x, y, returnList = FALSE, fn = NULL) {
 
54
                function(x, y, returnList = FALSE, fn = NULL, ...) {
37
55
                        stopifnot(identical(proj4string(x),proj4string(y)))
38
56
                        zd = zerodist2(x, y)
39
57
                        if (returnList) {
40
 
                                ret = lapply(1:length(x), integer(0))
 
58
                                ret = lapply(1:length(x), function(X) integer(0))
41
59
                                s = split(zd[,2],zd[,1])
42
60
                                ix = as.integer(names(s))
43
61
                                ret[ix] = s
49
67
                }
50
68
)
51
69
setMethod("over",
 
70
        signature(x = "SpatialPoints", y = "SpatialPointsDataFrame"), 
 
71
                overDFGeneric)
 
72
setMethod("over",
52
73
        signature(x = "SpatialPoints", y = "SpatialPolygons"), 
53
 
                function(x, y, returnList = FALSE, fn = NULL) {
 
74
                function(x, y, returnList = FALSE, fn = NULL, ...) {
54
75
                        stopifnot(identical(proj4string(x),proj4string(y)))
55
76
                        r = pointsInSpatialPolygons(x, y, returnList)
56
77
                        if (returnList)
60
81
)
61
82
setMethod("over",
62
83
        signature(x = "SpatialPoints", y = "SpatialPolygonsDataFrame"), 
63
 
                function(x, y, returnList = FALSE, fn = NULL) {
 
84
                function(x, y, returnList = FALSE, fn = NULL, ...) {
64
85
                        stopifnot(identical(proj4string(x),proj4string(y)))
65
86
                        r = pointsInSpatialPolygons(x, geometry(y), returnList=TRUE)
66
87
                        r = .invert(r, length(y), length(x))
67
 
                        ret = .overDF(r, y@data, length(x), returnList, fn)
 
88
                        ret = .overDF(r, y@data, length(x), returnList, fn, ...)
68
89
                        #ret = y@data[r,,drop=FALSE]
69
90
                        if (!returnList)
70
91
                                row.names(ret) = row.names(x)
74
95
 
75
96
setMethod("over",
76
97
        signature(x = "SpatialPolygons", y = "SpatialPoints"), 
77
 
                function(x, y, returnList = FALSE, fn = NULL) {
 
98
                function(x, y, returnList = FALSE, fn = NULL, ...) {
78
99
                        stopifnot(identical(proj4string(x),proj4string(y)))
79
100
                        r = pointsInSpatialPolygons(geometry(y), geometry(x), TRUE)
80
101
                        if (!returnList)
85
106
)
86
107
setMethod("over",
87
108
        signature(x = "SpatialPolygons", y = "SpatialPointsDataFrame"), 
88
 
                function(x, y, returnList = FALSE, fn = NULL) {
89
 
                        stopifnot(identical(proj4string(x),proj4string(y)))
90
 
                        # r = over(y, x)
91
 
                        r = over(x, geometry(y), returnList = TRUE)
92
 
                        ret = .overDF(r, y@data, length(x), returnList, fn)
93
 
                        if (!returnList)
94
 
                                row.names(ret) = row.names(x)
95
 
                        ret
96
 
                }
97
 
)
 
109
                overDFGeneric)
98
110
setMethod("over",
99
111
        signature(x = "SpatialPolygons", y = "SpatialGridDataFrame"), 
100
 
                function(x, y, returnList = FALSE, fn = NULL) {
 
112
                function(x, y, returnList = FALSE, fn = NULL, ...) {
101
113
                        stopifnot(identical(proj4string(x),proj4string(y)))
102
114
                        over(x, as(y, "SpatialPixelsDataFrame"), returnList = returnList,
103
 
                                fn = fn)
 
115
                                fn = fn, ...)
104
116
                }
105
117
)
106
118
 
107
119
setMethod("over", signature("SpatialPoints", "SpatialGrid"), 
108
 
        function(x, y, returnList = FALSE, fn = NULL) {
 
120
        function(x, y, returnList = FALSE, fn = NULL, ...) {
109
121
                stopifnot(identical(proj4string(x),proj4string(y)))
 
122
                stopifnot(returnList == FALSE)
110
123
                getGridIndex(coordinates(x), y@grid, all.inside = FALSE)
111
124
        }
112
125
)
113
126
 
114
127
setMethod("over", signature("SpatialPoints", "SpatialGridDataFrame"), 
115
 
        function(x, y, returnList = FALSE, fn = NULL) {
 
128
        function(x, y, returnList = FALSE, fn = NULL, ...) {
116
129
                stopifnot(identical(proj4string(x),proj4string(y)))
117
 
                #idx = over(geometry(y), x)
118
 
                #ret = .overDF(idx, y@data, length(x), returnList, fn)
119
 
                #row.names(ret) = row.names(x)
120
 
                #ret
 
130
                stopifnot(returnList == FALSE)
121
131
                idx = over(x, geometry(y))
122
132
                ret = y@data[idx,,drop=FALSE]
123
133
                row.names(ret) = row.names(x)
126
136
)
127
137
 
128
138
setMethod("over", signature("SpatialPoints", "SpatialPixels"), 
129
 
        function(x, y, returnList = FALSE, fn = NULL) {
 
139
        function(x, y, returnList = FALSE, fn = NULL, ...) {
130
140
                stopifnot(identical(proj4string(x),proj4string(y)))
 
141
                stopifnot(returnList == FALSE)
131
142
                idx = getGridIndex(coordinates(x), y@grid, all.inside = FALSE)
132
143
                idx = match(idx, y@grid.index)
133
144
                idx
135
146
)
136
147
 
137
148
setMethod("over", signature("SpatialPoints", "SpatialPixelsDataFrame"), 
138
 
        function(x, y, returnList = FALSE, fn = NULL) {
 
149
        function(x, y, returnList = FALSE, fn = NULL, ...) {
139
150
                stopifnot(identical(proj4string(x),proj4string(y)))
 
151
                stopifnot(returnList == FALSE)
140
152
                idx = over(x, geometry(y))
141
153
                ret = y@data[idx,,drop=FALSE]
142
154
                row.names(ret) = row.names(x)
143
155
                ret
144
156
        }
145
157
)
 
158
 
 
159
aggregate.Spatial = function(x, by, FUN = mean, ...) {
 
160
        by0 = by
 
161
        if (gridded(by))
 
162
                by = as(by, "SpatialPolygons")
 
163
        df = over(by, x, fn = FUN, ...)
 
164
        addAttrToGeom(by0, df, match.ID = FALSE)
 
165
}