Skip to content

Commit 83f38fd

Browse files
hsonnehsonne
committed
Add tests, do not use accessor, add "dbg" args
1 parent 162185b commit 83f38fd

19 files changed

+247
-86
lines changed

‎R/extractObservationData.R

+2-1
Original file line numberDiff line numberDiff line change
@@ -20,7 +20,8 @@ extractObservationData <- function(
2020
text = text,
2121
headerInfo = getHeaderInfo(text),
2222
header.info = header.info,
23-
file = file
23+
file = file,
24+
dbg = dbg
2425
)))
2526
}
2627
)

‎R/extractObservationData_1.R

+5-41
Original file line numberDiff line numberDiff line change
@@ -5,14 +5,11 @@ extractObservationData_1 <- function(
55
{
66
#kwb.utils::assignPackageObjects("kwb.en13508.2")
77

8-
# Create accessor function to header info fields
9-
fromHeader <- kwb.utils::createAccessor(header.info)
10-
118
# Get information on the row numbers where the different blocks start
129
indices <- getBlockIndices(text, dbg = dbg)
1310

1411
# Column separator
15-
sep <- fromHeader("separator")
12+
sep <- kwb.utils::selectElements(header.info, "separator")
1613

1714
# Try to get the C-Block captions (if they are unique, otherwise rais error!)
1815
captions <- tryToGetUniqueCaptions(text[indices$C], sep)
@@ -27,10 +24,11 @@ extractObservationData_1 <- function(
2724
observations <- readObservationsFromCsvText(
2825
text = c(tableHeader, tableBody),
2926
sep = sep,
30-
dec = fromHeader("decimal"),
31-
quote = fromHeader("quote"),
27+
dec = kwb.utils::selectElements(header.info, "decimal"),
28+
quote = kwb.utils::selectElements(header.info, "quote"),
3229
colClasses = colClasses,
33-
header = TRUE
30+
header = TRUE,
31+
dbg = dbg
3432
)
3533

3634
indices$B01 <- indices$B[grep("^#B01=", text[indices$B])]
@@ -123,37 +121,3 @@ getColClasses <- function(codes, captions)
123121

124122
colClasses
125123
}
126-
127-
# getColClasses2 ---------------------------------------------------------------
128-
getColClasses2 <- function(codes, as.text)
129-
{
130-
colClasses <- sapply(codes, get_elements, "class")
131-
132-
if (as.text) {
133-
colClasses[] <- "character"
134-
}
135-
136-
colClasses
137-
}
138-
139-
# convertTypes -----------------------------------------------------------------
140-
convertTypes <- function(data, codes)
141-
{
142-
target_classes <- sapply(
143-
get_elements(codes, names(data)), get_elements, "class"
144-
)
145-
146-
given_classes <- sapply(data, "class")
147-
148-
columns_convert <- names(which(given_classes != target_classes))
149-
150-
for (column in columns_convert) {
151-
target_class <- target_classes[column]
152-
data[[column]] <- kwb.utils::catAndRun(
153-
sprintf("Converting column '%s' to %s", column, target_class),
154-
do.call(paste0("as.", target_class), list(data[[column]]))
155-
)
156-
}
157-
158-
data
159-
}

‎R/extractObservationData_2.R

+17-2
Original file line numberDiff line numberDiff line change
@@ -11,14 +11,16 @@
1111
#' type. The default is \code{FALSE}, i.e. columns that are expected to
1212
#' contain numeric values are converted to numeric, respecting the decimal
1313
#' separator that is given in \code{header.info}
14+
#' @param dbg whether or not to show debug messages
1415
#' @return data frame with columns \code{A}, \code{B}, \code{C}, ... as defined
1516
#' in EN13508.2 and a column \code{inspno} referring to the inspection number.
1617
extractObservationData_2 <- function(
1718
text,
1819
headerInfo,
1920
header.info,
2021
file = "",
21-
as.text = FALSE
22+
as.text = FALSE,
23+
dbg = TRUE
2224
)
2325
{
2426
# Create accessor function to headerInfo
@@ -49,7 +51,8 @@ extractObservationData_2 <- function(
4951
dec = get_elements(header.info, "decimal"),
5052
quote = get_elements(header.info, "quote"),
5153
colClasses = colClasses,
52-
header = TRUE
54+
header = TRUE,
55+
dbg = dbg
5356
)
5457

5558
result[["inspno"]] <- rep(fetch("inspno")[rowsWithKey], blockLengths)
@@ -64,6 +67,18 @@ extractObservationData_2 <- function(
6467
kwb.utils::moveColumnsToFront(inspectionData, "inspno")
6568
}
6669

70+
# getColClasses2 ---------------------------------------------------------------
71+
getColClasses2 <- function(codes, as.text)
72+
{
73+
classes <- sapply(codes, get_elements, "class")
74+
75+
if (as.text) {
76+
classes[] <- "character"
77+
}
78+
79+
classes
80+
}
81+
6782
# extractObservationBlocks -----------------------------------------------------
6883

6984
#' Extract Lines Between #C-Header and #Z End Tag

‎R/readEuCodedFile.R

+10-7
Original file line numberDiff line numberDiff line change
@@ -54,8 +54,6 @@ readEuCodedFile <- function(
5454

5555
name.convention <- match.arg(name.convention, c("norm", "camel", "snake"))
5656

57-
run <- function(...) kwb.utils::catAndRun(dbg = dbg, ...)
58-
5957
# If not explicitly given, use the encoding as given in the #A1 header
6058
if (is.null(file.encoding)) {
6159
file.encoding <- readFileEncodingFromHeader(input.file)
@@ -75,7 +73,8 @@ readEuCodedFile <- function(
7573
stopOnInvalidEncoding(file.encoding)
7674
}
7775

78-
eu_lines <- run(
76+
eu_lines <- kwb.utils::catAndRun(
77+
dbg = dbg,
7978
sprintf("Reading %s assuming %s encoding", input.file, file.encoding),
8079
kwb.utils::readLinesWithEncoding(
8180
file = input.file,
@@ -85,17 +84,20 @@ readEuCodedFile <- function(
8584
)
8685
)
8786

88-
eu_lines <- run(
87+
eu_lines <- kwb.utils::catAndRun(
88+
dbg = dbg,
8989
"Removing empty lines (if any)",
9090
removeEmptyLines(eu_lines, dbg = dbg)
9191
)
9292

93-
header.info <- run(
93+
header.info <- kwb.utils::catAndRun(
94+
dbg = dbg,
9495
"Extracting file header",
9596
getFileHeaderFromEuLines(eu_lines, warn)
9697
)
9798

98-
inspections <- run(
99+
inspections <- kwb.utils::catAndRun(
100+
dbg = dbg,
99101
"Extracting inspection records",
100102
extractInspectionData(
101103
text = eu_lines,
@@ -110,7 +112,8 @@ readEuCodedFile <- function(
110112
#dot.args <- list() # for debugging!
111113
#dot.args <- list(as.text = TRUE)
112114

113-
observations <- run(
115+
observations <- kwb.utils::catAndRun(
116+
dbg = dbg,
114117
"Extracting observation records",
115118
do.call(extractObservationData, c(dot.args, list(
116119
text = eu_lines,

‎R/readObservationsFromCsvText.R

+51-20
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,7 @@
11
# readObservationsFromCsvText --------------------------------------------------
2-
readObservationsFromCsvText <- function(text, sep, dec, quote, colClasses, ...)
2+
readObservationsFromCsvText <- function(
3+
text, sep, dec, quote, colClasses, dbg = TRUE, ...
4+
)
35
{
46
# If colClasses is specified, reduce it to the columns that actually occur
57
if (!identical(colClasses, NA)) {
@@ -19,35 +21,64 @@ readObservationsFromCsvText <- function(text, sep, dec, quote, colClasses, ...)
1921
dot.args <- list(...)
2022
#dot.args <- list(header = TRUE) # for debugging!
2123

22-
result <- try(kwb.utils::callWith(
23-
utils::read.table,
24+
common_args <- c(dot.args, list(
2425
text = text,
2526
sep = sep,
2627
dec = dec,
2728
quote = quote,
2829
comment.char = "",
2930
blank.lines.skip = FALSE,
30-
stringsAsFactors = FALSE,
31-
colClasses = colClasses,
32-
dot.args
31+
stringsAsFactors = FALSE
3332
))
3433

35-
if (!kwb.utils::isTryError(result)) {
36-
return(result)
34+
tryCatch(
35+
expr = do.call(
36+
utils::read.table, c(common_args, list(colClasses = colClasses))
37+
),
38+
silent = TRUE,
39+
error = {
40+
data <- do.call(utils::read.table, c(common_args, list(colClasses = NA)))
41+
convertTypes(data, classes = sapply(
42+
X = get_elements(inspectionDataFieldCodes(), names(data)),
43+
FUN = get_elements,
44+
elements = "class"
45+
))
46+
},
47+
dbg = dbg
48+
)
49+
}
50+
51+
# convertTypes -----------------------------------------------------------------
52+
convertTypes <- function(data, classes, dbg = TRUE)
53+
{
54+
verbose_converter <- function(FUN, what) {
55+
function(x) {
56+
suppressWarnings(y <- FUN(x))
57+
failed <- !is.na(x) & is.na(y)
58+
if (any(failed)) {
59+
message(sprintf(
60+
"Could not convert the following values to %s: %s",
61+
what, kwb.utils::stringList(unique(x[failed]))
62+
))
63+
}
64+
y
65+
}
3766
}
3867

39-
result <- kwb.utils::callWith(
40-
utils::read.table,
41-
text = text,
42-
sep = sep,
43-
dec = dec,
44-
quote = quote,
45-
comment.char = "",
46-
blank.lines.skip = FALSE,
47-
stringsAsFactors = FALSE,
48-
colClasses = NA,
49-
dot.args
68+
converters <- list(
69+
character = as.character,
70+
numeric = verbose_converter(as.numeric, "numeric"),
71+
integer = verbose_converter(as.integer, "integer")
5072
)
5173

52-
convertTypes(result, codes = inspectionDataFieldCodes())
74+
for (column in names(which(sapply(data, "class") != classes))) {
75+
class <- classes[column]
76+
data[[column]] <- kwb.utils::catAndRun(
77+
messageText = sprintf("Converting column '%s' to %s", column, class),
78+
expr = (get_elements(converters, class))(data[[column]]),
79+
dbg = dbg
80+
)
81+
}
82+
83+
data
5384
}

‎man/extractObservationData_2.Rd

+4-1
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

‎tests/testthat/test-function-addInspectionNumbers.R

+4
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
test_that("addInspectionNumbers() works", {
2+
f <- kwb.en13508.2:::addInspectionNumbers
3+
expect_error(f())
4+
})

‎tests/testthat/test-function-convertTypes.R

+14
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,14 @@
1+
test_that("convertTypes() works", {
2+
3+
f <- kwb.en13508.2:::convertTypes
4+
5+
expect_error(f())
6+
7+
expect_message(result <- f(
8+
data.frame(a = c(1, 1.9), b = c("x", "1.0")),
9+
classes = c(a = "integer", b = "numeric"),
10+
dbg = FALSE
11+
))
12+
13+
expect_identical(result, data.frame(a = c(1L, 1L), b = c(NA, 1.0)))
14+
})

‎tests/testthat/test-function-createHashFromColumns.R

+4
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
test_that("createHashFromColumns() works", {
2+
f <- kwb.en13508.2:::createHashFromColumns
3+
expect_error(f())
4+
})

‎tests/testthat/test-function-getBlockIndices.R

+17
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,17 @@
1+
#
2+
# This file was generated by kwb.test::create_test_files(),
3+
# launched by hsonne on 2024-11-01 18:19:55.697403.
4+
# Please modify the dummy functions so that real cases are
5+
# tested. Then, delete this comment.
6+
#
7+
8+
test_that("getBlockIndices() works", {
9+
10+
f <- kwb.en13508.2:::getBlockIndices
11+
12+
expect_error(
13+
f()
14+
# Argument "text" fehlt (ohne Standardwert)
15+
)
16+
17+
})

‎tests/testthat/test-function-getColClasses.R

+17
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,17 @@
1+
#
2+
# This file was generated by kwb.test::create_test_files(),
3+
# launched by hsonne on 2024-11-01 18:19:55.697403.
4+
# Please modify the dummy functions so that real cases are
5+
# tested. Then, delete this comment.
6+
#
7+
8+
test_that("getColClasses() works", {
9+
10+
f <- kwb.en13508.2:::getColClasses
11+
12+
expect_error(
13+
f()
14+
# Argument "captions" fehlt (ohne Standardwert)
15+
)
16+
17+
})

‎tests/testthat/test-function-getColClasses2.R

+17
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,17 @@
1+
#
2+
# This file was generated by kwb.test::create_test_files(),
3+
# launched by hsonne on 2024-11-01 18:19:55.721139.
4+
# Please modify the dummy functions so that real cases are
5+
# tested. Then, delete this comment.
6+
#
7+
8+
test_that("getColClasses2() works", {
9+
10+
f <- kwb.en13508.2:::getColClasses2
11+
12+
expect_error(
13+
f()
14+
# Argument "codes" fehlt (ohne Standardwert)
15+
)
16+
17+
})

‎tests/testthat/test-function-getExampleData.R

+1
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
#library(testthat)
12
test_that("getExampleData() works", {
23

34
f <- kwb.en13508.2:::getExampleData

‎tests/testthat/test-function-readAndMergeEuCodedFiles.R

+2-2
Original file line numberDiff line numberDiff line change
@@ -8,8 +8,8 @@ test_that("readAndMergeEuCodedFiles() works", {
88
file <- kwb.en13508.2:::getExampleFile()
99
files <- c(file, file)
1010

11-
result_camel <- f(files, name.convention = "camel")
12-
result_snake <- f(files, name.convention = "snake")
11+
result_camel <- f(files, name.convention = "camel", dbg = FALSE)
12+
result_snake <- f(files, name.convention = "snake", dbg = FALSE)
1313

1414
check_top_level <- function(x) {
1515
expect_identical(names(x), c("header.info", "inspections", "observations"))

0 commit comments

Comments
 (0)