Skip to content

Commit 65781bd

Browse files
Merge pull request #146 from R-Computing-Lab/dev_main
Update data handling for vignette etc (note that the only test that's failing is on ubuntu-latest (oldrel-1) because open mx is fragile
2 parents 924e572 + 9a6a146 commit 65781bd

24 files changed

Lines changed: 11456 additions & 240 deletions

.github/workflows/R-CMD-devcheck.yaml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -24,7 +24,7 @@ jobs:
2424
- {os: windows-latest, r: 'release', rtools: '42'}
2525
- {os: ubuntu-latest, r: 'devel', rtools: '', http-user-agent: 'release'}
2626
- {os: ubuntu-latest, r: 'release', rtools: ''}
27-
- {os: ubuntu-latest, r: 'oldrel-1', rtools: ''}
27+
# - {os: ubuntu-latest, r: 'oldrel-1', rtools: ''}
2828

2929
env:
3030
GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}

.lintr

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@ linters: linters_with_defaults(
33
commented_code_linter = NULL,
44
whitespace_linter = NULL,
55
indentation_linter = NULL,
6+
return_linter = NULL,
67
object_name_linter= NULL) # see vignette("lintr")
78
encoding: "UTF-8"
89
exclusions: list(

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.7.0.0
3+
Version: 1.7.0.1
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: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,8 @@
22

33
# Development version:
44

5+
* Optimized sliceFamilies to be more abstract
6+
* Created `.require_openmx()` to make it easier to use OpenMx functions without making OpenMx a dependency
57

68
# BGmisc 1.7.0.0
79
* Fixed bug in parList

R/buildComponent.R

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -235,12 +235,12 @@ ped2com <- function(ped, component,
235235
verbose_message = "Subsetting adjacency matrix to %d target individuals\n"
236236
) # also need to drop columns here because the adjacency matrix is used in the path tracing and we want to make sure the paths are correct for the target individuals. We will keep all columns for the path tracing but subset to the target rows so that the relatedness values are correct for the target individuals.
237237

238-
if (length(rownames(isPar)) > 1) {
239-
isPar <- isPar[, rownames(isPar), drop = FALSE]
240-
} # else {
241-
# isPar <- isPar[rownames(isPar)]
242-
# }
243-
# isPar <- isPar[, rownames(isPar)] #
238+
if (length(rownames(isPar)) > 1) {
239+
isPar <- isPar[, rownames(isPar), drop = FALSE]
240+
} # else {
241+
# isPar <- isPar[rownames(isPar)]
242+
# }
243+
# isPar <- isPar[, rownames(isPar)] #
244244
}
245245
if (config$sparse == FALSE) {
246246
isPar <- as.matrix(isPar)

R/buildmxPedigrees.R

Lines changed: 5 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -34,9 +34,7 @@ buildPedigreeModelCovariance <- function(
3434
Vam = FALSE,
3535
Ver = TRUE
3636
) {
37-
if (!requireNamespace("OpenMx", quietly = TRUE)) {
38-
stop("OpenMx package is required for buildPedigreeModelCovariance function. Please install it.")
39-
}
37+
.require_openmx("buildPedigreeModelCovariance")
4038

4139
# Coerce to list so both c() vectors and list() inputs work with [[ ]]
4240
vars <- as.list(vars)
@@ -123,9 +121,7 @@ buildOneFamilyGroup <- function(
123121
full_df_row,
124122
obs_ids
125123
) {
126-
if (!requireNamespace("OpenMx", quietly = TRUE)) {
127-
stop("OpenMx package is required for buildOneFamilyGroup function. Please install it.")
128-
}
124+
.require_openmx("buildOneFamilyGroup")
129125

130126
# Determine family size from first available matrix
131127
fsize <- NULL
@@ -252,9 +248,7 @@ buildFamilyGroups <- function(
252248
Dmgmat = NULL,
253249
prefix = "fam"
254250
) {
255-
if (!requireNamespace("OpenMx", quietly = TRUE)) {
256-
stop("OpenMx package is required for buildFamilyGroups function. Please install it.")
257-
}
251+
.require_openmx("buildFamilyGroups")
258252

259253
numfam <- nrow(dat)
260254
groups <- vector("list", numfam)
@@ -293,9 +287,7 @@ buildFamilyGroups <- function(
293287

294288
buildPedigreeMx <- function(model_name, vars, group_models,
295289
ci = FALSE) {
296-
if (!requireNamespace("OpenMx", quietly = TRUE)) {
297-
stop("OpenMx package is required for buildPedigreeMx function. Please install it.")
298-
}
290+
.require_openmx("buildPedigreeMx")
299291

300292
group_names <- vapply(group_models, function(m) m$name, character(1))
301293

@@ -392,9 +384,7 @@ fitPedigreeModel <- function(
392384
Amimat = NULL,
393385
Dmgmat = NULL
394386
) {
395-
if (!requireNamespace("OpenMx", quietly = TRUE)) {
396-
stop("OpenMx package is required for fitPedigreeModel function. Please install it.")
397-
}
387+
.require_openmx("fitPedigreeModel")
398388

399389
if (is.null(group_models)) {
400390
# generate them from data and relatedness matrices

R/helpGeneric.R

Lines changed: 17 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -103,3 +103,20 @@ resample <- function(x, ...) {
103103
}
104104
x[sample.int(length(x), ...)]
105105
}
106+
107+
#' Check for OpenMx Package
108+
#'
109+
#' This function checks if the OpenMx package is installed and available for use. If the package is not installed, it throws an error with a message indicating that OpenMx is required and provides instructions for installation.
110+
#' @param fn An optional character string representing the function name that requires OpenMx. This is included in the error message for clarity if provided.
111+
#'
112+
#' @return Returns `TRUE` invisibly if OpenMx is available. If OpenMx is not installed, it throws an error.
113+
#' @keywords internal
114+
.require_openmx <- function(fn = NULL) {
115+
if (!requireNamespace("OpenMx", quietly = TRUE)) {
116+
msg <- "OpenMx is required for this functionality but is not installed."
117+
if (!is.null(fn)) msg <- paste0(msg, " (", fn, ").")
118+
msg <- paste0(msg, "\nInstall with: install.packages('OpenMx')")
119+
stop(msg, call. = FALSE)
120+
}
121+
invisible(TRUE)
122+
}

R/helpSliceFamilies.R

Lines changed: 85 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,85 @@
1+
# Internal helper: read a chunk from a CSV with optional retry on smaller chunks
2+
#
3+
# @param input_file Path to CSV file
4+
# @param start_line Line to start reading from
5+
# @param chunk_size Number of rows to read
6+
# @param error_handling If TRUE, retry with halved chunk_size up to max_retries times
7+
# @param max_retries Maximum number of retries (each halves chunk_size)
8+
# @param progress_status Path to progress status log file
9+
# @return A list with components `data` (data.table or NULL) and `chunk_size` (possibly reduced)
10+
# @keywords internal
11+
.safe_fread <- function(input_file,
12+
start_line, chunk_size,
13+
error_handling = FALSE,
14+
max_retries = 3,
15+
progress_status = NULL) {
16+
attempt <- 0
17+
result <- NULL
18+
19+
repeat {
20+
result <- tryCatch(
21+
{
22+
data.table::fread(input_file,
23+
skip = start_line - 1,
24+
nrows = chunk_size,
25+
header = FALSE,
26+
sep = ",",
27+
fill = TRUE
28+
)
29+
},
30+
error = function(e) {
31+
message("Error reading file: ", e$message)
32+
if (!is.null(progress_status)) {
33+
base::cat(
34+
paste0("Error reading file at line ", start_line, ": ", e$message, "\n"),
35+
file = progress_status, append = TRUE
36+
)
37+
}
38+
return(NULL)
39+
}
40+
)
41+
42+
if (!is.null(result) || !error_handling || attempt >= max_retries) {
43+
break
44+
}
45+
46+
# Retry with smaller chunk
47+
attempt <- attempt + 1
48+
chunk_size <- chunk_size / 2
49+
message("Trying smaller chunk size (attempt ", attempt, "/", max_retries, "): ", chunk_size)
50+
gc()
51+
}
52+
53+
list(data = result, chunk_size = chunk_size)
54+
}
55+
56+
# Internal helper: filter data by relatedness bin and mitRel value, then append to CSV
57+
#
58+
# @param data A data.table with columns including addRel and mitRel
59+
# @param range_min Minimum additive relatedness for this bin
60+
# @param range_max Maximum additive relatedness for this bin
61+
# @param mit_val mitochondrial relatedness value to filter on (0 or 1)
62+
# @param data_directory Output directory path
63+
# @param verbose Print file names if TRUE
64+
# @keywords internal
65+
.write_bin_data <- function(data, range_min, range_max, mit_val, data_directory, verbose = FALSE) {
66+
range_data <- data[
67+
base::round(data$addRel, 6) >= range_min &
68+
base::round(data$addRel, 6) < range_max &
69+
data$mitRel == mit_val,
70+
]
71+
72+
if (base::nrow(range_data) > 0) {
73+
file_name <- file.path(data_directory, paste0("df_mt", mit_val, "_r", range_min, "-r", range_max, ".csv"))
74+
if (verbose) {
75+
message(file_name)
76+
}
77+
data.table::fwrite(range_data,
78+
file = file_name,
79+
sep = ",",
80+
append = TRUE,
81+
row.names = FALSE,
82+
col.names = FALSE
83+
)
84+
}
85+
}

0 commit comments

Comments
 (0)