Movatterモバイル変換

[0]ホーム
URL:

Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly

 Sign up
Appearance settings

Commit5f6cbba

Browse files
Merge pull request#94 from R-Computing-Lab/dev_main
Dev main
2 parents12322e8 +22f4946 commit5f6cbba

File tree

36 files changed

+638
-442
lines changed

36 files changed

+638
-442
lines changed

‎CRAN-SUBMISSION‎

Lines changed: 0 additions & 3 deletions
This file was deleted.

‎DESCRIPTION‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
Package: BGmisc
22
Title: An R Package for Extended Behavior Genetics Analysis
3-
Version: 1.5.0
3+
Version: 1.5.0.9000
44
Authors@R: c(
55
person("S. Mason", "Garrison", , "garrissm@wfu.edu", role = c("aut", "cre"),
66
comment = c(ORCID = "0000-0002-4804-6003")),

‎NEWS.md‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,7 @@
1+
#BGmisc (development version)
2+
* partially refactored summarizePedigree to be more modular
3+
* added compression control to ped2com
4+
15
#BGmisc 1.5.0
26
##CRAN submission
37
* Removed ASOIAF dataset from BGmisc, now in ggpedigree

‎R/buildComponent.R‎

Lines changed: 45 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@
2020
#' @param adjacency_method character. The method to use for computing the adjacency matrix. Options are "loop", "indexed", direct or beta
2121
#' @param isChild_method character. The method to use for computing the isChild matrix. Options are "classic" or "partialparent"
2222
#' @param adjBeta_method numeric The method to use for computing the building the adjacency_method matrix when using the "beta" build
23+
#' @param compress logical. If TRUE, use compression when saving the checkpoint files. Defaults to TRUE.
2324
#' @param ... additional arguments to be passed to \code{\link{ped2com}}
2425
#' @details The algorithms and methodologies used in this function are further discussed and exemplified in the vignette titled "examplePedigreeFunctions". For more advanced scenarios and detailed explanations, consult this vignette.
2526
#' @export
@@ -42,6 +43,7 @@ ped2com <- function(ped, component,
4243
update_rate=100,
4344
save_path="checkpoint/",
4445
adjBeta_method=NULL,
46+
compress=TRUE,
4547
...) {
4648
#------
4749
# Check inputs
@@ -66,7 +68,8 @@ ped2com <- function(ped, component,
6668
gc=gc,
6769
component=component,
6870
adjBeta_method=adjBeta_method,
69-
nr= nrow(ped)
71+
nr= nrow(ped),
72+
compress=compress
7073
)
7174

7275

@@ -186,7 +189,8 @@ ped2com <- function(ped, component,
186189
isChild<- .loadOrComputeIsChild(
187190
ped=ped,
188191
checkpoint_files=checkpoint_files,
189-
config=config
192+
config=config,
193+
compress=config$compress
190194
)
191195
# --- Step 2: Compute Relatedness Matrix ---
192196

@@ -228,11 +232,11 @@ ped2com <- function(ped, component,
228232
}
229233
# Save progress every save_rate iterations
230234
if (config$saveable==TRUE&& (count%%save_rate_gen==0)) {
231-
saveRDS(r,file=checkpoint_files$r_checkpoint)
232-
saveRDS(gen,file=checkpoint_files$gen_checkpoint)
233-
saveRDS(newIsPar,file=checkpoint_files$newIsPar_checkpoint)
234-
saveRDS(mtSum,file=checkpoint_files$mtSum_checkpoint)
235-
saveRDS(count,file=checkpoint_files$count_checkpoint)
235+
saveRDS(r,file=checkpoint_files$r_checkpoint,compress=config$compress)
236+
saveRDS(gen,file=checkpoint_files$gen_checkpoint,compress=config$compress)
237+
saveRDS(newIsPar,file=checkpoint_files$newIsPar_checkpoint,compress=config$compress)
238+
saveRDS(mtSum,file=checkpoint_files$mtSum_checkpoint,compress=config$compress)
239+
saveRDS(count,file=checkpoint_files$count_checkpoint,compress=config$compress)
236240
}
237241
if (config$gc==TRUE&&config$nr>1000000) {
238242
gc()
@@ -245,7 +249,7 @@ ped2com <- function(ped, component,
245249
gc()
246250
}
247251
if (config$saveable==TRUE) {
248-
saveRDS(r,file=checkpoint_files$ram_checkpoint)
252+
saveRDS(r,file=checkpoint_files$ram_checkpoint,compress=config$compress)
249253
}
250254

251255
if (config$component=="generation") {# no need to do the rest
@@ -261,22 +265,26 @@ ped2com <- function(ped, component,
261265
r=r,
262266
isChild=isChild,
263267
checkpoint_files=checkpoint_files,
264-
config=config
268+
config=config,
269+
compress=config$compress
265270
)
266271

267272
# --- Step 4: T crossproduct ---
268273

269274
if (config$resume==TRUE&& file.exists(checkpoint_files$tcrossprod_checkpoint)&&
270275
config$component!="generation") {
271-
if (config$verbose==TRUE)cat("Resuming: Loading tcrossprod...\n")
276+
if (config$verbose==TRUE)message("Resuming: Loading tcrossprod...\n")
272277
r<- readRDS(checkpoint_files$tcrossprod_checkpoint)
273278
}else {
274279
r<- .computeTranspose(
275280
r2=r2,transpose_method=transpose_method,
276281
verbose=config$verbose
277282
)
278283
if (config$saveable==TRUE) {
279-
saveRDS(r,file=checkpoint_files$tcrossprod_checkpoint)
284+
saveRDS(r,
285+
file=checkpoint_files$tcrossprod_checkpoint,
286+
compress=config$compress
287+
)
280288
}
281289
}
282290

@@ -293,7 +301,7 @@ ped2com <- function(ped, component,
293301
diag(r)<-1
294302
}
295303
if (config$saveable==TRUE) {
296-
saveRDS(r,file=checkpoint_files$final_matrix)
304+
saveRDS(r,file=checkpoint_files$final_matrix,compress=config$compress)
297305
}
298306
return(r)
299307
}
@@ -314,6 +322,7 @@ ped2add <- function(ped, max_gen = 25, sparse = TRUE, verbose = FALSE,
314322
save_rate_gen=save_rate,
315323
save_rate_parlist=100000*save_rate,
316324
save_path="checkpoint/",
325+
compress=TRUE,
317326
...) {
318327
ped2com(
319328
ped=ped,
@@ -331,6 +340,7 @@ ped2add <- function(ped, max_gen = 25, sparse = TRUE, verbose = FALSE,
331340
save_rate_gen=save_rate_gen,
332341
save_rate_parlist=save_rate_parlist,
333342
save_path=save_path,
343+
compress=compress,
334344
...
335345
)
336346
}
@@ -354,6 +364,7 @@ ped2mit <- ped2mt <- function(ped, max_gen = 25,
354364
save_rate_gen=save_rate,
355365
save_rate_parlist=100000*save_rate,
356366
save_path="checkpoint/",
367+
compress=TRUE,
357368
...) {
358369
ped2com(
359370
ped=ped,
@@ -371,6 +382,7 @@ ped2mit <- ped2mt <- function(ped, max_gen = 25,
371382
save_rate_gen=save_rate_gen,
372383
save_rate_parlist=save_rate_parlist,
373384
save_path=save_path,
385+
compress=compress,
374386
...
375387
)
376388
}
@@ -391,6 +403,7 @@ ped2cn <- function(ped, max_gen = 25, sparse = TRUE, verbose = FALSE,
391403
save_rate_gen=save_rate,
392404
save_rate_parlist=1000*save_rate,
393405
save_path="checkpoint/",
406+
compress=TRUE,
394407
...) {
395408
ped2com(
396409
ped=ped,
@@ -408,6 +421,7 @@ ped2cn <- function(ped, max_gen = 25, sparse = TRUE, verbose = FALSE,
408421
save_rate_gen=save_rate_gen,
409422
save_rate_parlist=save_rate_parlist,
410423
save_path=save_path,
424+
compress=compress,
411425
...
412426
)
413427
}
@@ -534,18 +548,20 @@ initializeCheckpoint <- function(config = list(
534548
#' @param config A list containing configuration parameters such as `resume`, `verbose`, and `saveable`.
535549
#' @param message_resume Optional message to display when resuming from a checkpoint.
536550
#' @param message_compute Optional message to display when computing the checkpoint.
551+
#' @param compress a logical specifying whether saving to a named file is to use "gzip" compression, or one of "gzip", "bzip2", "xz" or "zstd" to indicate the type of compression to be used. Ignored if file is a connection.
537552
#' @return The loaded or computed checkpoint.
538553
#' @keywords internal
539554
loadOrComputeCheckpoint<-function(file,compute_fn,
540555
config,message_resume=NULL,
541-
message_compute=NULL) {
556+
message_compute=NULL,
557+
compress=TRUE) {
542558
if (config$resume==TRUE&& file.exists(file)) {
543559
if (config$verbose==TRUE&&!is.null(message_resume)) cat(message_resume)
544560
return(readRDS(file))
545561
}else {
546562
if (config$verbose==TRUE&&!is.null(message_compute)) cat(message_compute)
547563
result<- compute_fn()
548-
if (config$saveable==TRUE) saveRDS(result,file=file)
564+
if (config$saveable==TRUE) saveRDS(result,file=file,compress=compress)
549565
return(result)
550566
}
551567
}
@@ -561,7 +577,8 @@ loadOrComputeCheckpoint <- function(file, compute_fn,
561577
#'
562578
#' @keywords internal
563579
#' @importFrom Matrix sparseMatrix
564-
.loadOrComputeIsPar<-function(iss,jss,parVal,ped,checkpoint_files,config) {
580+
.loadOrComputeIsPar<-function(iss,jss,parVal,ped,checkpoint_files,config,
581+
compress=TRUE) {
565582
isPar<- loadOrComputeCheckpoint(
566583
file=checkpoint_files$isPar,
567584
compute_fn=function() {
@@ -573,7 +590,8 @@ loadOrComputeCheckpoint <- function(file, compute_fn,
573590
},
574591
config=config,
575592
message_resume="Resuming: Loading adjacency matrix...\n",
576-
message_compute="Initializing adjacency matrix...\n"
593+
message_compute="Initializing adjacency matrix...\n",
594+
compress=compress
577595
)
578596

579597
return(isPar)
@@ -586,13 +604,14 @@ loadOrComputeCheckpoint <- function(file, compute_fn,
586604
#'
587605
#' @keywords internal
588606

589-
.loadOrComputeIsChild<-function(ped,checkpoint_files,config) {
607+
.loadOrComputeIsChild<-function(ped,checkpoint_files,config,compress=TRUE) {
590608
isChild<- loadOrComputeCheckpoint(
591609
file=checkpoint_files$isChild,
592610
compute_fn=function() isChild(isChild_method=config$isChild_method,ped=ped),
593611
config=config,
594612
message_resume="Resuming: Loading isChild matrix...\n",
595-
message_compute="Computing isChild matrix...\n"
613+
message_compute="Computing isChild matrix...\n",
614+
compress=compress
596615
)
597616

598617
return(isChild)
@@ -608,15 +627,17 @@ loadOrComputeCheckpoint <- function(file, compute_fn,
608627

609628

610629
.loadOrComputeInverseDiagonal<-function(r,isChild,
611-
checkpoint_files,config) {
630+
checkpoint_files,config,
631+
compress=TRUE) {
612632
r2<- loadOrComputeCheckpoint(
613633
file=checkpoint_files$r2_checkpoint,
614634
compute_fn=function() {
615635
r%*%Matrix::Diagonal(x= sqrt(isChild),n=config$nr)
616636
},
617637
config=config,
618638
message_resume="Resuming: Loading I-A inverse...\n",
619-
message_compute="Doing I-A inverse times diagonal multiplication\n"
639+
message_compute="Doing I-A inverse times diagonal multiplication\n",
640+
compress=compress
620641
)
621642
if (config$gc==TRUE) {
622643
rm(r,isChild)
@@ -642,7 +663,8 @@ loadOrComputeCheckpoint <- function(file, compute_fn,
642663

643664
.loadOrComputeParList<-function(checkpoint_files,config,
644665
ped=NULL,
645-
parList=NULL,lens=NULL) {
666+
parList=NULL,lens=NULL,
667+
compress=TRUE) {
646668
if (config$resume==TRUE&&
647669
file.exists(checkpoint_files$parList)&&
648670
file.exists(checkpoint_files$lens)) {
@@ -700,8 +722,8 @@ loadOrComputeCheckpoint <- function(file, compute_fn,
700722
message("Constructed sparse matrix\n")
701723
}
702724
if (config$saveable==TRUE) {
703-
saveRDS(list_of_adjacencies$jss,file=checkpoint_files$jss)
704-
saveRDS(list_of_adjacencies$iss,file=checkpoint_files$iss)
725+
saveRDS(list_of_adjacencies$jss,file=checkpoint_files$jss,compress=compress)
726+
saveRDS(list_of_adjacencies$iss,file=checkpoint_files$iss,compress=compress)
705727
}
706728
}
707729
return(list_of_adjacencies)

‎R/constructAdjacency.R‎

Lines changed: 17 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -5,7 +5,7 @@
55
.adjLoop<-function(ped,component,saveable,resume,
66
save_path,verbose,lastComputed,
77
checkpoint_files,update_rate,
8-
parList,lens,save_rate_parlist,config,
8+
parList,lens,save_rate_parlist,config,compress=config$compress,
99
...) {
1010
# Loop through each individual in the pedigree
1111
# Build the adjacency matrix for parent-child relationships
@@ -51,8 +51,8 @@
5151
}
5252
# Checkpointing every save_rate iterations
5353
if (saveable&& (i%%save_rate_parlist==0)) {
54-
saveRDS(parList,file=checkpoint_files$parList)
55-
saveRDS(lens,file=checkpoint_files$lens)
54+
saveRDS(parList,file=checkpoint_files$parList,compress=compress)
55+
saveRDS(lens,file=checkpoint_files$lens,compress=compress)
5656
if (verbose==TRUE) cat("Checkpointed parlist saved at iteration",i,"\n")
5757
}
5858
}
@@ -69,7 +69,7 @@
6969
.adjIndexed<-function(ped,component,saveable,resume,
7070
save_path,verbose,lastComputed,
7171
checkpoint_files,update_rate,
72-
parList,lens,save_rate_parlist,config) {
72+
parList,lens,save_rate_parlist,config,compress=config$compress) {
7373
# Loop through each individual in the pedigree
7474
# Build the adjacency matrix for parent-child relationships
7575
# Is person in column j the parent of the person in row i? .5 for yes, 0 for no.
@@ -113,8 +113,8 @@
113113

114114
# Checkpointing every save_rate iterations
115115
if (saveable==TRUE&& (i%%save_rate_parlist==0)) {
116-
saveRDS(parList,file=checkpoint_files$parList)
117-
saveRDS(lens,file=checkpoint_files$lens)
116+
saveRDS(parList,file=checkpoint_files$parList,compress=compress)
117+
saveRDS(lens,file=checkpoint_files$lens,compress=compress)
118118
if (verbose==TRUE) cat("Checkpointed parlist saved at iteration",i,"\n")
119119
}
120120
}
@@ -135,7 +135,7 @@
135135
.adjDirect<-function(ped,component,saveable,resume,
136136
save_path,verbose,lastComputed,
137137
checkpoint_files,update_rate,
138-
parList,lens,save_rate_parlist,config,
138+
parList,lens,save_rate_parlist,config,compress=config$compress,
139139
...) {
140140
# Loop through each individual in the pedigree
141141
# Build the adjacency matrix for parent-child relationships
@@ -225,6 +225,7 @@
225225
update_rate=NULL,
226226
checkpoint_files=NULL,
227227
config,
228+
compress=config$compress,
228229
...) {# 1) Pairwise compare mother IDs
229230
if (adjBeta_method==1) {
230231
# gets slow when data are bigger. much slower than indexed
@@ -406,7 +407,8 @@
406407
lastComputed=lastComputed,config=config,
407408
checkpoint_files=checkpoint_files,
408409
update_rate=update_rate,parList=parList,
409-
lens=lens,save_rate_parlist=save_rate_parlist
410+
lens=lens,save_rate_parlist=save_rate_parlist,
411+
compress=compress
410412
)
411413
}
412414
return(list_of_adjacency)
@@ -435,6 +437,7 @@ computeParentAdjacency <- function(ped, component,
435437
parList,lens,save_rate_parlist,
436438
adjBeta_method=NULL,
437439
config,
440+
compress=config$compress,
438441
...) {
439442
if (!adjacency_method%in% c("loop","indexed","direct","beta")) {
440443
stop("Invalid method specified. Choose from 'loop', 'direct', 'indexed', or 'beta'.")
@@ -460,6 +463,7 @@ computeParentAdjacency <- function(ped, component,
460463
lens=lens,
461464
save_rate_parlist=save_rate_parlist,
462465
config=config,
466+
compress=compress,
463467
...
464468
)
465469
},
@@ -479,6 +483,7 @@ computeParentAdjacency <- function(ped, component,
479483
lens=lens,
480484
save_rate_parlist=save_rate_parlist,
481485
config=config,
486+
compress=compress,
482487
...
483488
)
484489
},
@@ -498,6 +503,7 @@ computeParentAdjacency <- function(ped, component,
498503
lens=lens,
499504
save_rate_parlist=save_rate_parlist,
500505
config=config,
506+
compress=compress,
501507
...
502508
)
503509
},
@@ -517,14 +523,15 @@ computeParentAdjacency <- function(ped, component,
517523
lens=lens,
518524
save_rate_parlist=save_rate_parlist,
519525
config=config,
526+
compress=compress,
520527
...
521528
)
522529
}
523530
)
524531
}
525532
if (saveable==TRUE) {
526-
saveRDS(parList,file=checkpoint_files$parList)
527-
saveRDS(lens,file=checkpoint_files$lens)
533+
saveRDS(parList,file=checkpoint_files$parList,compress=compress)
534+
saveRDS(lens,file=checkpoint_files$lens,compress=compress)
528535
if (verbose==TRUE) {
529536
cat("Final checkpoint saved for adjacency matrix.\n")
530537
}

0 commit comments

Comments
 (0)
[8]ページ先頭
©2009-2025 Movatter.jp