Browse code

edgeR 3.21.10 - Fix incorrect implementation of weights in adjustedProfileLik; - nbinomUnitDeviance now respects vectors; - Change glmTreat default to lfc=log2(1.2); - Update the user's guide; - Update NEWS.Rd.

Yunshun Chen authored on 24/04/2018 07:11:24
Showing1 changed files
... ...
@@ -61,12 +61,13 @@ length.CompressedMatrix <- function(x)
61 61
 #
62 62
 # written by Aaron Lun
63 63
 # created 25 January 2018
64
+# last modified 1 March 2018
64 65
 {
65
-    ncol(x)*nrow(x)
66
+    prod(attr(x,"Dims"))
66 67
 }
67 68
 
68 69
 `[.CompressedMatrix` <- function(x, i, j, drop=TRUE)
69
-# A wrapper function to easily subset a makeCompressedMatrix object.
70
+# Subsetting for CompressedMatrix objects.
70 71
 #
71 72
 # written by Aaron Lun
72 73
 # created 24 September 2016
... ...
@@ -113,7 +114,7 @@ length.CompressedMatrix <- function(x)
113 114
 }
114 115
 
115 116
 `[<-.CompressedMatrix` <- function(x, i, j, value) 
116
-# Subset assignment, for completeness' sake.
117
+# Subset assignment for CompressedMatrix objects.
117 118
 #
118 119
 # written by Aaron Lun
119 120
 # created 25 January 2018
Browse code

edgeR 3.21.8 - New function read10X to read 10X Genomics files; - Implemented more CompressedMatrix methods to avoid user-side errors; - DGEList takes 'group' from 'samples' only if samples has a column called group.

Yunshun Chen authored on 02/02/2018 00:05:42
Showing1 changed files
... ...
@@ -34,7 +34,7 @@ makeCompressedMatrix <- function(x, dims, byrow=TRUE)
34 34
 
35 35
     dimnames(x) <- NULL
36 36
     class(x) <- "CompressedMatrix"
37
-	attr(x, "Dims") <- dims
37
+	attr(x, "Dims") <- as.integer(dims)
38 38
     attr(x, "repeat.row") <- repeat.row
39 39
     attr(x, "repeat.col") <- repeat.col
40 40
 	return(x)
... ...
@@ -56,13 +56,27 @@ dim.CompressedMatrix <- function(x)
56 56
     attr(x, "Dims")
57 57
 }
58 58
 
59
-`[.CompressedMatrix` <- function(x, i, j, ...)
59
+length.CompressedMatrix <- function(x)
60
+# Getting length. 
61
+#
62
+# written by Aaron Lun
63
+# created 25 January 2018
64
+{
65
+    ncol(x)*nrow(x)
66
+}
67
+
68
+`[.CompressedMatrix` <- function(x, i, j, drop=TRUE)
60 69
 # A wrapper function to easily subset a makeCompressedMatrix object.
61 70
 #
62 71
 # written by Aaron Lun
63 72
 # created 24 September 2016
64 73
 # last modified 21 June 2017
65 74
 {
75
+    Nargs <- nargs() - !(missing(drop))
76
+    if (Nargs<3L) {
77
+        return(as.matrix(x)[i])
78
+    }
79
+
66 80
     raw.mat <- .strip_to_matrix(x)
67 81
 	row.status <- attr(x, "repeat.row") 
68 82
 	col.status <- attr(x, "repeat.col")
... ...
@@ -89,9 +103,34 @@ dim.CompressedMatrix <- function(x)
89 103
 	attr(raw.mat, "Dims") <- c(nr, nc)
90 104
     attr(raw.mat, "repeat.row") <- row.status
91 105
     attr(raw.mat, "repeat.col") <- col.status
106
+
107
+    if (drop && 
108
+        ((!missing(i) && length(i)==1L) ||
109
+         (!missing(j) && length(j)==1L))) {
110
+        raw.mat <- as.vector(as.matrix(raw.mat))
111
+    } 
92 112
 	return(raw.mat)
93 113
 }
94 114
 
115
+`[<-.CompressedMatrix` <- function(x, i, j, value) 
116
+# Subset assignment, for completeness' sake.
117
+#
118
+# written by Aaron Lun
119
+# created 25 January 2018
120
+{
121
+    ref <- as.matrix(x)
122
+    if (is(value, "CompressedMatrix")) { 
123
+        value <- as.matrix(value)
124
+    }
125
+
126
+    if (nargs() < 4L) {
127
+        ref[i] <- value
128
+    } else {
129
+        ref[i,j] <- value
130
+    }
131
+    makeCompressedMatrix(ref, attr(x, "Dims"), TRUE)
132
+}
133
+
95 134
 as.matrix.CompressedMatrix <- function(x, ...) 
96 135
 # Expanding it to a full matrix.
97 136
 #
Browse code

edgeR 3.19.6 - New arg 'group' for mglmOneWay(); - 'design' arg for predFC() is now compulsory; - Switched 'coef.start' back to a vector in mglmOneGroup(); - New functions cpmByGroup() and rpkmByGroup(); - Renamed arg 'x' to 'y' in cpm() and rpkm(); - Restored null dispersion check in glmFit(); - Removed 'offset' arg from glmQLFit() to be consistent with glmFit(); - Exported CompressedMatrix subset operator; - Refactored C++ code with greater C++11 support to use Rcpp; - Streamlined input dimension checks in C++ code; - Supported zero-row input to addPriorCounts() C++ code; - Replaced deque with vector in C++ code; - Added a case study of differential methylation analysis to the user's guide.

Yunshun Chen authored on 15/09/2017 03:37:15
Showing1 changed files
... ...
@@ -5,11 +5,11 @@ makeCompressedMatrix <- function(x, dims, byrow=TRUE)
5 5
 #
6 6
 # written by Aaron Lun
7 7
 # created 24 September 2016
8
-# last modified 21 June 2017
8
+# last modified 9 July 2017
9 9
 {
10 10
     repeat.row <- repeat.col <- FALSE
11 11
 	if (is.matrix(x)) {
12
-		if (is(x, "CompressedMatrix")) {
12
+		if (inherits(x, "CompressedMatrix")) {
13 13
 			return(x)
14 14
 		}
15 15
         dims <- dim(x)
... ...
@@ -241,10 +241,10 @@ Ops.CompressedMatrix <- function(e1, e2)
241 241
 # created 26 September 2016
242 242
 # last modified 30 June 2017
243 243
 {
244
-	if (!is(e1, "CompressedMatrix")) {
245
-        e1 <- makeCompressedMatrix(e1, dim(e2), byrow=FALSE) # Promoted to column-major CompressedMatrix
246
-    } 
247
-    if (!is(e2, "CompressedMatrix")) {
244
+    if (!inherits(e1, "CompressedMatrix")) {
245
+        e1 <- makeCompressedMatrix(e1, dim(e2), byrow=FALSE) # Promoted to column-major CompressedMatrix 
246
+	}
247
+    if (!inherits(e2, "CompressedMatrix")) {
248 248
         e2 <- makeCompressedMatrix(e2, dim(e1), byrow=FALSE)       
249 249
 	}
250 250
     if (!identical(dim(e1), dim(e2))) {
... ...
@@ -255,7 +255,7 @@ Ops.CompressedMatrix <- function(e1, e2)
255 255
     col.rep <- attr(e1, "repeat.col") && attr(e2, "repeat.col")
256 256
 
257 257
     if (row.rep || col.rep) { 
258
-        new.dim <- pmax(dim(e1), dim(e2))
258
+        new.dim <- dim(e1)
259 259
         e1 <- as.vector(.strip_to_matrix(e1))
260 260
         e2 <- as.vector(.strip_to_matrix(e2))
261 261
         outcome <- NextMethod(.Generic)
... ...
@@ -279,7 +279,7 @@ Ops.CompressedMatrix <- function(e1, e2)
279 279
 # If 'offset' is already of the CompressedMatrix class, then 
280 280
 # we assume it's already gone through this once so we don't do it again.
281 281
 {
282
-	if (is(offset, "CompressedMatrix")) {
282
+	if (inherits(offset, "CompressedMatrix")) {
283 283
 		return(offset)
284 284
 	}
285 285
 
... ...
@@ -290,8 +290,10 @@ Ops.CompressedMatrix <- function(e1, e2)
290 290
 	if (!is.double(offset)) storage.mode(offset) <- "double"
291 291
 	offset <- makeCompressedMatrix(offset, dim(y), byrow=TRUE)
292 292
 
293
-	err <- .Call(.cR_check_finite, offset, "offsets")
294
-	if (is.character(err)) stop(err) 
293
+    check.range <- suppressWarnings(range(offset))
294
+    if (any(!is.finite(check.range))) { 
295
+        stop("offsets must be finite values")
296
+    }
295 297
 	return(offset)
296 298
 }
297 299
 
... ...
@@ -302,7 +304,7 @@ Ops.CompressedMatrix <- function(e1, e2)
302 304
 # If 'weights' is already a CompressedMatrix, then we assume it's 
303 305
 # already gone through this and don't do it again.
304 306
 {
305
-	if (is(weights, "CompressedMatrix")) {
307
+	if (inherits(weights, "CompressedMatrix")) {
306 308
 		return(weights)
307 309
 	}
308 310
 
... ...
@@ -310,8 +312,10 @@ Ops.CompressedMatrix <- function(e1, e2)
310 312
 	if (!is.double(weights)) storage.mode(weights) <- "double"
311 313
 	weights <- makeCompressedMatrix(weights, dim(y), byrow=TRUE)
312 314
 
313
-	err <- .Call(.cR_check_positive, weights, "weights")
314
-	if (is.character(err)) stop(err)
315
+	check.range <- suppressWarnings(range(weights))
316
+    if (any(is.na(check.range)) || check.range[1] <= 0) {
317
+        stop("weights must be finite positive values")
318
+    }
315 319
 	return(weights)
316 320
 }
317 321
 
... ...
@@ -319,14 +323,17 @@ Ops.CompressedMatrix <- function(e1, e2)
319 323
 # Again for the prior counts, checking for non-negative finite values.
320 324
 # Skipping the check if it's already a CompressedMatrix object.
321 325
 {
322
-	if (is(prior.count, "CompressedMatrix")) {
326
+	if (inherits(prior.count, "CompressedMatrix")) {
323 327
 		return(prior.count)
324 328
 	}
325 329
 			
326 330
 	if(!is.double(prior.count)) storage.mode(prior.count) <- "double"
327 331
 	prior.count <- makeCompressedMatrix(prior.count, dim(y), byrow=FALSE)
328
-	err <- .Call(.cR_check_nonnegative, prior.count, "prior counts")
329
-	if (is.character(err)) stop(err)
332
+
333
+    check.range <- suppressWarnings(range(prior.count))
334
+    if (any(is.na(check.range)) || check.range[1] < 0) { 
335
+        stop("prior counts must be finite non-negative values")
336
+    }
330 337
 	return(prior.count)
331 338
 }
332 339
 
... ...
@@ -334,14 +341,17 @@ Ops.CompressedMatrix <- function(e1, e2)
334 341
 # Again for the dispersions, checking for non-negative finite values.
335 342
 # Skipping the check if it's already a CompressedMatrix object.
336 343
 {
337
-	if (is(dispersion, "CompressedMatrix")) {
344
+	if (inherits(dispersion, "CompressedMatrix")) {
338 345
 		return(dispersion)
339 346
 	}
340 347
 			
341 348
 	if(!is.double(dispersion)) storage.mode(dispersion) <- "double"
342 349
 	dispersion <- makeCompressedMatrix(dispersion, dim(y), byrow=FALSE)
343
-	err <- .Call(.cR_check_nonnegative, dispersion, "dispersions")
344
-	if (is.character(err)) stop(err)
350
+
351
+    check.range <- suppressWarnings(range(dispersion))
352
+    if (any(is.na(check.range)) || check.range[1] < 0) { 
353
+        stop("dispersions must be finite non-negative values")
354
+    }
345 355
 	return(dispersion)
346 356
 }
347 357
 
Browse code

- Rename compressedMatrix to CompressedMatrix. - Define group generic binary operations for CompressedMatrix objects.

git-svn-id: file:///home/git/hedgehog.fhcrc.org/bioconductor/trunk/madman/Rpacks/edgeR@130786 bc3139a8-67e5-0310-9ffc-ced21a209358

Gordon Smyth authored on 30/06/2017 00:19:52
Showing1 changed files
... ...
@@ -1,90 +1,273 @@
1
-makeCompressedMatrix <- function(x, byrow=TRUE) 
1
+makeCompressedMatrix <- function(x, dims, byrow=TRUE) 
2 2
 # Coerces a NULL, scalar, vector or matrix to a compressed matrix,
3 3
 # Determines whether the rows or columns are intended to be 
4 4
 # repeated, and stores this in the attributes.
5 5
 #
6 6
 # written by Aaron Lun
7 7
 # created 24 September 2016
8
-# last modified 27 September 2016
8
+# last modified 21 June 2017
9 9
 {
10
+    repeat.row <- repeat.col <- FALSE
10 11
 	if (is.matrix(x)) {
11
-		if (is(x, "compressedMatrix")) {
12
+		if (is(x, "CompressedMatrix")) {
12 13
 			return(x)
13 14
 		}
14
-		repeat.row <- repeat.col <- FALSE
15
+        dims <- dim(x)
15 16
 	} else if (length(x)==1L) {
16
-		repeat.row <- repeat.col <- TRUE
17
+        repeat.row <- repeat.col <- TRUE
17 18
 		x <- matrix(x)
18 19
 	} else {
19 20
 		if (!byrow) {
21
+            if (dims[1]!=length(x)) { 
22
+                stop("'dims[1]' should equal length of 'x'")
23
+            }
20 24
 			x <- cbind(x)
21
-			repeat.row <- FALSE
22
-			repeat.col <- TRUE
25
+            repeat.col <- TRUE
23 26
 		} else {
24 27
 			x <- rbind(x)
25
-			repeat.row <- TRUE
26
-			repeat.col <- FALSE
28
+            if (dims[2]!=length(x)) { 
29
+                stop("'dims[2]' should equal length of 'x'")
30
+            }
31
+            repeat.row <- TRUE
27 32
 		}
28 33
 	}
29
-	class(x) <- "compressedMatrix"
30
-	attributes(x)$repeat.row <- repeat.row
31
-	attributes(x)$repeat.col <- repeat.col
34
+
35
+    dimnames(x) <- NULL
36
+    class(x) <- "CompressedMatrix"
37
+	attr(x, "Dims") <- dims
38
+    attr(x, "repeat.row") <- repeat.row
39
+    attr(x, "repeat.col") <- repeat.col
32 40
 	return(x)
33 41
 }
34 42
 
35
-`[.compressedMatrix` <- function(x, i, j, ...)
43
+.strip_to_matrix <- function(x) {
44
+    dims <- attr(x, "dim")
45
+    attributes(x) <- NULL
46
+    attr(x, "dim") <- dims
47
+    return(x)
48
+}
49
+
50
+dim.CompressedMatrix <- function(x) 
51
+# Getting dimensions.
52
+#
53
+# written by Aaron Lun
54
+# created 21 June 2017
55
+{
56
+    attr(x, "Dims")
57
+}
58
+
59
+`[.CompressedMatrix` <- function(x, i, j, ...)
36 60
 # A wrapper function to easily subset a makeCompressedMatrix object.
37 61
 #
38 62
 # written by Aaron Lun
39 63
 # created 24 September 2016
64
+# last modified 21 June 2017
40 65
 {
41
-	row.status <- attributes(x)$repeat.row
42
-	col.status <- attributes(x)$repeat.col
43
-	oldclass <- class(x)
44
-	x <- unclass(x)
45
-	if (!row.status && !missing(i)) {
46
-		x <- x[i,,drop=FALSE]
66
+    raw.mat <- .strip_to_matrix(x)
67
+	row.status <- attr(x, "repeat.row") 
68
+	col.status <- attr(x, "repeat.col")
69
+
70
+    if (!row.status && !missing(i)) {
71
+		raw.mat <- raw.mat[i,,drop=FALSE]
47 72
 	}
48 73
 	if (!col.status && !missing(j)) {
49
-		x <- x[,j,drop=FALSE]
74
+		raw.mat <- raw.mat[,j,drop=FALSE]
50 75
 	}
51
-	class(x) <- oldclass
52
-	attributes(x)$repeat.row <- row.status
53
-	attributes(x)$repeat.col <- col.status
54
-	return(x)
76
+
77
+    nr <- nrow(x)
78
+    if (!missing(i)) {
79
+        ref <- seq_len(nr)
80
+        nr <- length(ref[i])
81
+    } 
82
+    nc <- ncol(x)
83
+    if (!missing(j)) {
84
+        ref <- seq_len(nc)
85
+        nc <- length(ref[j])
86
+    }
87
+
88
+	class(raw.mat) <- class(x)
89
+	attr(raw.mat, "Dims") <- c(nr, nc)
90
+    attr(raw.mat, "repeat.row") <- row.status
91
+    attr(raw.mat, "repeat.col") <- col.status
92
+	return(raw.mat)
55 93
 }
56 94
 
57
-as.matrix.compressedMatrix <- function(x, ...) 
58
-# Getting rid of odds and ends.
95
+as.matrix.CompressedMatrix <- function(x, ...) 
96
+# Expanding it to a full matrix.
59 97
 #
60 98
 # written by Aaron Lun
61 99
 # created 26 September 2016
100
+# last modified 21 June 2017
62 101
 {
63
-	attributes(x)$repeat.row <- NULL
64
-	attributes(x)$repeat.col <- NULL
65
-	unclass(x)
102
+    raw.mat <- .strip_to_matrix(x)
103
+	row.status <- attr(x, "repeat.row") 
104
+	col.status <- attr(x, "repeat.col")
105
+
106
+    if (row.status) {
107
+        raw.mat <- matrix(raw.mat, nrow(x), ncol(x), byrow=TRUE)                
108
+    } else if (col.status) {
109
+        raw.mat <- matrix(raw.mat, nrow(x), ncol(x))
110
+    } else {
111
+        raw.mat <- as.matrix(raw.mat)
112
+    }
113
+    return(raw.mat)
66 114
 }
67 115
 
68
-.addCompressedMatrices <- function(x, y) 
69
-# A function that performs addition of two compressedMatrix objects,
116
+rbind.CompressedMatrix <- function(...) 
117
+# Rbinding things together.
118
+# 
119
+# written by Aaron Lun
120
+# created 21 June 2017    
121
+{
122
+    everything <- list(...)
123
+    nobjects <- length(everything)
124
+    if (nobjects==1) {
125
+        return(everything[[1]])
126
+    }
127
+    all.nr <- sum(unlist(lapply(everything, nrow)))
128
+    
129
+    col.rep <- logical(nobjects)
130
+    row.rep <- logical(nobjects)
131
+    for (i in seq_along(everything)) { 
132
+        x <- everything[[i]]
133
+        col.rep[i] <- attr(x, "repeat.col") 
134
+        row.rep[i] <- attr(x, "repeat.row")
135
+    }
136
+
137
+    # If everything is column repeats, we can do a naive concatenation. 
138
+    if (all(col.rep)) { 
139
+        collected.vals <- vector("list", nobjects)
140
+        all.nc <- ncol(everything[[1]])
141
+        for (i in seq_along(everything)) {
142
+            current <- everything[[i]]
143
+            if (!identical(all.nc, ncol(current))) {
144
+                stop("cannot combine CompressedMatrix objects with different number of columns")
145
+            }
146
+            collected.vals[[i]] <- rep(.strip_to_matrix(current), length.out=nrow(current))
147
+        }
148
+        return(makeCompressedMatrix(unlist(collected.vals), dims=c(all.nr, all.nc), byrow=FALSE))
149
+    }
150
+
151
+    # If everything is row repeats AND values are all equal, we can just modify the nr.
152
+    if (all(row.rep)) {
153
+        okay <- TRUE
154
+        ref <- .strip_to_matrix(everything[[1]])
155
+        for (i in 2:length(everything)) {
156
+            current <- .strip_to_matrix(everything[[i]])
157
+            if (!isTRUE(all.equal(everything[[i]], ref))) {
158
+                okay <- FALSE
159
+                break
160
+            }
161
+        }
162
+        if (okay) {
163
+            current <- everything[[1]]
164
+            attr(current, "Dims")[1] <- all.nr
165
+            return(current)
166
+        }
167
+    }
168
+
169
+    # Otherwise, expanding each element and rbinding them.
170
+    for (i in seq_along(everything)) { 
171
+        everything[[i]] <- as.matrix(everything[[i]])
172
+    } 
173
+    return(makeCompressedMatrix(do.call(rbind, everything)))
174
+}
175
+
176
+cbind.CompressedMatrix <- function(...) 
177
+# Cbinding things together.
178
+# 
179
+# written by Aaron Lun
180
+# created 21 June 2017    
181
+{
182
+    everything <- list(...)
183
+    nobjects <- length(everything)
184
+    if (nobjects==1) {
185
+        return(everything[[1]])
186
+    }
187
+    all.nc <- sum(unlist(lapply(everything, ncol)))
188
+    
189
+    col.rep <- logical(nobjects)
190
+    row.rep <- logical(nobjects)
191
+    for (i in seq_along(everything)) { 
192
+        x <- everything[[i]]
193
+        col.rep[i] <- attr(x, "repeat.col") 
194
+        row.rep[i] <- attr(x, "repeat.row")
195
+    }
196
+
197
+    # If everything is row repeats, we can do a naive concatenation. 
198
+    if (all(row.rep)) { 
199
+        collected.vals <- vector("list", nobjects)
200
+        all.nr <- nrow(everything[[1]])
201
+        for (i in seq_along(everything)) {
202
+            current <- everything[[i]]
203
+            if (!identical(all.nr, nrow(current))) {
204
+                stop("cannot combine CompressedMatrix objects with different number of rows")
205
+            }
206
+            collected.vals[[i]] <- rep(.strip_to_matrix(current), length.out=ncol(current))
207
+        }
208
+        return(makeCompressedMatrix(unlist(collected.vals), dims=c(all.nr, all.nc), byrow=TRUE))
209
+    }
210
+
211
+    # If everything is column repeats AND values are all equal, we can just modify the nc.
212
+    if (all(col.rep)) {
213
+        okay <- TRUE
214
+        ref <- .strip_to_matrix(everything[[1]])
215
+        for (i in 2:length(everything)) {
216
+            current <- .strip_to_matrix(everything[[i]])
217
+            if (!isTRUE(all.equal(everything[[i]], ref))) {
218
+                okay <- FALSE
219
+                break
220
+            }
221
+        }
222
+        if (okay) {
223
+            current <- everything[[1]]
224
+            attr(current, "Dims")[2] <- all.nc
225
+            return(current)
226
+        }
227
+    }
228
+
229
+    # Otherwise, expanding each element and rbinding them.
230
+    for (i in seq_along(everything)) { 
231
+        everything[[i]] <- as.matrix(everything[[i]])
232
+    } 
233
+    return(makeCompressedMatrix(do.call(cbind, everything)))
234
+}
235
+
236
+Ops.CompressedMatrix <- function(e1, e2)
237
+# A function that performs some binary operation on two CompressedMatrix objects,
70 238
 # in a manner that best preserves memory usage.
71 239
 #
72 240
 # written by Aaron Lun
73 241
 # created 26 September 2016
74
-# last modified 27 September 2016
242
+# last modified 30 June 2017
75 243
 {
76
-	if (!is(x, "compressedMatrix") || !is(y, "compressedMatrix")) {
77
-		stop("only two compressedMatrix objects can be added")
244
+	if (!is(e1, "CompressedMatrix")) {
245
+        e1 <- makeCompressedMatrix(e1, dim(e2), byrow=FALSE) # Promoted to column-major CompressedMatrix
246
+    } 
247
+    if (!is(e2, "CompressedMatrix")) {
248
+        e2 <- makeCompressedMatrix(e2, dim(e1), byrow=FALSE)       
78 249
 	}
79
-	dims <- pmax(dim(x), dim(y))
80
-	out <- .Call(.cR_add_repeat_matrices, x, y, dims[1], dims[2])
81
-	if (is.character(out)) stop(out)
82
-
83
-	summed <- out[[1]]
84
-	class(summed) <- class(x)
85
-	attributes(summed)$repeat.row <- out[[2]]
86
-	attributes(summed)$repeat.col <- out[[3]]
87
-	return(summed)
250
+    if (!identical(dim(e1), dim(e2))) {
251
+        stop("CompressedMatrix dimensions should be equal for binary operations")
252
+    }
253
+    
254
+    row.rep <- attr(e1, "repeat.row") && attr(e2, "repeat.row")
255
+    col.rep <- attr(e1, "repeat.col") && attr(e2, "repeat.col")
256
+
257
+    if (row.rep || col.rep) { 
258
+        new.dim <- pmax(dim(e1), dim(e2))
259
+        e1 <- as.vector(.strip_to_matrix(e1))
260
+        e2 <- as.vector(.strip_to_matrix(e2))
261
+        outcome <- NextMethod(.Generic)
262
+        outcome <- makeCompressedMatrix(outcome, new.dim, byrow=row.rep)
263
+    } else {
264
+        e1 <- as.matrix(e1)
265
+        e2 <- as.matrix(e2)
266
+        outcome <- NextMethod(.Generic)
267
+        outcome <- makeCompressedMatrix(outcome)
268
+    }
269
+
270
+	return(outcome)
88 271
 }
89 272
 
90 273
 .compressOffsets <- function(y, offset, lib.size=NULL) 
... ...
@@ -93,10 +276,10 @@ as.matrix.compressedMatrix <- function(x, ...)
93 276
 # If neither are provided, library sizes are automatically computed
94 277
 # as the sum of counts in the count matrix 'y'.
95 278
 # A prefunctory check for finite values is performed in the C++ code.
96
-# If 'offset' is already of the compressedMatrix class, then 
279
+# If 'offset' is already of the CompressedMatrix class, then 
97 280
 # we assume it's already gone through this once so we don't do it again.
98 281
 {
99
-	if (is(offset, "compressedMatrix")) {
282
+	if (is(offset, "CompressedMatrix")) {
100 283
 		return(offset)
101 284
 	}
102 285
 
... ...
@@ -105,58 +288,58 @@ as.matrix.compressedMatrix <- function(x, ...)
105 288
 		offset <- log(lib.size)
106 289
 	}
107 290
 	if (!is.double(offset)) storage.mode(offset) <- "double"
108
-	offset <- makeCompressedMatrix(offset, byrow=TRUE)
291
+	offset <- makeCompressedMatrix(offset, dim(y), byrow=TRUE)
109 292
 
110 293
 	err <- .Call(.cR_check_finite, offset, "offsets")
111 294
 	if (is.character(err)) stop(err) 
112 295
 	return(offset)
113 296
 }
114 297
 
115
-.compressWeights <- function(weights=NULL) 
298
+.compressWeights <- function(y, weights=NULL) 
116 299
 # A convenience function to avoid repeatedly having to write the code below.
117 300
 # All weights default to 1 if not specified.
118 301
 # A prefunctory check for finite, positive values is performed in the C++ code.
119
-# If 'weights' is already a compressedMatrix, then we assume it's 
302
+# If 'weights' is already a CompressedMatrix, then we assume it's 
120 303
 # already gone through this and don't do it again.
121 304
 {
122
-	if (is(weights, "compressedMatrix")) {
305
+	if (is(weights, "CompressedMatrix")) {
123 306
 		return(weights)
124 307
 	}
125 308
 
126 309
 	if (is.null(weights)) weights <- 1
127 310
 	if (!is.double(weights)) storage.mode(weights) <- "double"
128
-	weights <- makeCompressedMatrix(weights, byrow=TRUE)
311
+	weights <- makeCompressedMatrix(weights, dim(y), byrow=TRUE)
129 312
 
130 313
 	err <- .Call(.cR_check_positive, weights, "weights")
131 314
 	if (is.character(err)) stop(err)
132 315
 	return(weights)
133 316
 }
134 317
 
135
-.compressPrior <- function(prior.count) 
318
+.compressPrior <- function(y, prior.count) 
136 319
 # Again for the prior counts, checking for non-negative finite values.
137
-# Skipping the check if it's already a compressedMatrix object.
320
+# Skipping the check if it's already a CompressedMatrix object.
138 321
 {
139
-	if (is(prior.count, "compressedMatrix")) {
322
+	if (is(prior.count, "CompressedMatrix")) {
140 323
 		return(prior.count)
141 324
 	}
142 325
 			
143 326
 	if(!is.double(prior.count)) storage.mode(prior.count) <- "double"
144
-	prior.count <- makeCompressedMatrix(prior.count, byrow=FALSE)
327
+	prior.count <- makeCompressedMatrix(prior.count, dim(y), byrow=FALSE)
145 328
 	err <- .Call(.cR_check_nonnegative, prior.count, "prior counts")
146 329
 	if (is.character(err)) stop(err)
147 330
 	return(prior.count)
148 331
 }
149 332
 
150
-.compressDispersions <- function(dispersion) 
333
+.compressDispersions <- function(y, dispersion) 
151 334
 # Again for the dispersions, checking for non-negative finite values.
152
-# Skipping the check if it's already a compressedMatrix object.
335
+# Skipping the check if it's already a CompressedMatrix object.
153 336
 {
154
-	if (is(dispersion, "compressedMatrix")) {
337
+	if (is(dispersion, "CompressedMatrix")) {
155 338
 		return(dispersion)
156 339
 	}
157 340
 			
158 341
 	if(!is.double(dispersion)) storage.mode(dispersion) <- "double"
159
-	dispersion <- makeCompressedMatrix(dispersion, byrow=FALSE)
342
+	dispersion <- makeCompressedMatrix(dispersion, dim(y), byrow=FALSE)
160 343
 	err <- .Call(.cR_check_nonnegative, dispersion, "dispersions")
161 344
 	if (is.character(err)) stop(err)
162 345
 	return(dispersion)
Browse code

edgeR 3.15.6 - improved memory efficiency - modified glmTreat() behaviour - incorporated weights to estimateDisp() - added makeCompressedMatrix(), addPriorCount()

git-svn-id: file:///home/git/hedgehog.fhcrc.org/bioconductor/trunk/madman/Rpacks/edgeR@121762 bc3139a8-67e5-0310-9ffc-ced21a209358

Yunshun Chen authored on 04/10/2016 23:59:20
Showing1 changed files
1 1
new file mode 100644
... ...
@@ -0,0 +1,164 @@
1
+makeCompressedMatrix <- function(x, byrow=TRUE) 
2
+# Coerces a NULL, scalar, vector or matrix to a compressed matrix,
3
+# Determines whether the rows or columns are intended to be 
4
+# repeated, and stores this in the attributes.
5
+#
6
+# written by Aaron Lun
7
+# created 24 September 2016
8
+# last modified 27 September 2016
9
+{
10
+	if (is.matrix(x)) {
11
+		if (is(x, "compressedMatrix")) {
12
+			return(x)
13
+		}
14
+		repeat.row <- repeat.col <- FALSE
15
+	} else if (length(x)==1L) {
16
+		repeat.row <- repeat.col <- TRUE
17
+		x <- matrix(x)
18
+	} else {
19
+		if (!byrow) {
20
+			x <- cbind(x)
21
+			repeat.row <- FALSE
22
+			repeat.col <- TRUE
23
+		} else {
24
+			x <- rbind(x)
25
+			repeat.row <- TRUE
26
+			repeat.col <- FALSE
27
+		}
28
+	}
29
+	class(x) <- "compressedMatrix"
30
+	attributes(x)$repeat.row <- repeat.row
31
+	attributes(x)$repeat.col <- repeat.col
32
+	return(x)
33
+}
34
+
35
+`[.compressedMatrix` <- function(x, i, j, ...)
36
+# A wrapper function to easily subset a makeCompressedMatrix object.
37
+#
38
+# written by Aaron Lun
39
+# created 24 September 2016
40
+{
41
+	row.status <- attributes(x)$repeat.row
42
+	col.status <- attributes(x)$repeat.col
43
+	oldclass <- class(x)
44
+	x <- unclass(x)
45
+	if (!row.status && !missing(i)) {
46
+		x <- x[i,,drop=FALSE]
47
+	}
48
+	if (!col.status && !missing(j)) {
49
+		x <- x[,j,drop=FALSE]
50
+	}
51
+	class(x) <- oldclass
52
+	attributes(x)$repeat.row <- row.status
53
+	attributes(x)$repeat.col <- col.status
54
+	return(x)
55
+}
56
+
57
+as.matrix.compressedMatrix <- function(x, ...) 
58
+# Getting rid of odds and ends.
59
+#
60
+# written by Aaron Lun
61
+# created 26 September 2016
62
+{
63
+	attributes(x)$repeat.row <- NULL
64
+	attributes(x)$repeat.col <- NULL
65
+	unclass(x)
66
+}
67
+
68
+.addCompressedMatrices <- function(x, y) 
69
+# A function that performs addition of two compressedMatrix objects,
70
+# in a manner that best preserves memory usage.
71
+#
72
+# written by Aaron Lun
73
+# created 26 September 2016
74
+# last modified 27 September 2016
75
+{
76
+	if (!is(x, "compressedMatrix") || !is(y, "compressedMatrix")) {
77
+		stop("only two compressedMatrix objects can be added")
78
+	}
79
+	dims <- pmax(dim(x), dim(y))
80
+	out <- .Call(.cR_add_repeat_matrices, x, y, dims[1], dims[2])
81
+	if (is.character(out)) stop(out)
82
+
83
+	summed <- out[[1]]
84
+	class(summed) <- class(x)
85
+	attributes(summed)$repeat.row <- out[[2]]
86
+	attributes(summed)$repeat.col <- out[[3]]
87
+	return(summed)
88
+}
89
+
90
+.compressOffsets <- function(y, offset, lib.size=NULL) 
91
+# A convenience function to avoid repeatedly having to write the code below.
92
+# If provided, offsets take precedence over the library size.
93
+# If neither are provided, library sizes are automatically computed
94
+# as the sum of counts in the count matrix 'y'.
95
+# A prefunctory check for finite values is performed in the C++ code.
96
+# If 'offset' is already of the compressedMatrix class, then 
97
+# we assume it's already gone through this once so we don't do it again.
98
+{
99
+	if (is(offset, "compressedMatrix")) {
100
+		return(offset)
101
+	}
102
+
103
+	if (is.null(offset)) {
104
+		if (is.null(lib.size)) lib.size <- colSums(y)
105
+		offset <- log(lib.size)
106
+	}
107
+	if (!is.double(offset)) storage.mode(offset) <- "double"
108
+	offset <- makeCompressedMatrix(offset, byrow=TRUE)
109
+
110
+	err <- .Call(.cR_check_finite, offset, "offsets")
111
+	if (is.character(err)) stop(err) 
112
+	return(offset)
113
+}
114
+
115
+.compressWeights <- function(weights=NULL) 
116
+# A convenience function to avoid repeatedly having to write the code below.
117
+# All weights default to 1 if not specified.
118
+# A prefunctory check for finite, positive values is performed in the C++ code.
119
+# If 'weights' is already a compressedMatrix, then we assume it's 
120
+# already gone through this and don't do it again.
121
+{
122
+	if (is(weights, "compressedMatrix")) {
123
+		return(weights)
124
+	}
125
+
126
+	if (is.null(weights)) weights <- 1
127
+	if (!is.double(weights)) storage.mode(weights) <- "double"
128
+	weights <- makeCompressedMatrix(weights, byrow=TRUE)
129
+
130
+	err <- .Call(.cR_check_positive, weights, "weights")
131
+	if (is.character(err)) stop(err)
132
+	return(weights)
133
+}
134
+
135
+.compressPrior <- function(prior.count) 
136
+# Again for the prior counts, checking for non-negative finite values.
137
+# Skipping the check if it's already a compressedMatrix object.
138
+{
139
+	if (is(prior.count, "compressedMatrix")) {
140
+		return(prior.count)
141
+	}
142
+			
143
+	if(!is.double(prior.count)) storage.mode(prior.count) <- "double"
144
+	prior.count <- makeCompressedMatrix(prior.count, byrow=FALSE)
145
+	err <- .Call(.cR_check_nonnegative, prior.count, "prior counts")
146
+	if (is.character(err)) stop(err)
147
+	return(prior.count)
148
+}
149
+
150
+.compressDispersions <- function(dispersion) 
151
+# Again for the dispersions, checking for non-negative finite values.
152
+# Skipping the check if it's already a compressedMatrix object.
153
+{
154
+	if (is(dispersion, "compressedMatrix")) {
155
+		return(dispersion)
156
+	}
157
+			
158
+	if(!is.double(dispersion)) storage.mode(dispersion) <- "double"
159
+	dispersion <- makeCompressedMatrix(dispersion, byrow=FALSE)
160
+	err <- .Call(.cR_check_nonnegative, dispersion, "dispersions")
161
+	if (is.character(err)) stop(err)
162
+	return(dispersion)
163
+}
164
+