andreas/REDCapCAST
1
0
Fork 0
mirror of https://github.com/agdamsbo/REDCapCAST.git synced 2024-11-22 05:20:23 +01:00
Code Issues Packages Projects Releases Wiki Activity

small adjustments to interpret character vectors of roman numerals as numeric vector

Browse Source
This commit is contained in:
Andreas Gammelgaard Damsbo 2024-11-20 15:23:31 +01:00
parent 18544ddcfe
commit 47fb3fceca
No known key found for this signature in database
1 changed files with 11 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
R/as_factor.R
View File

@ -56,10 +56,13 @@ as_factor.numeric <- function(x, ...) {
#' @export #' @export
as_factor.character <- function(x, ...) { as_factor.character <- function(x, ...) {
labels <- get_attr(x) labels <- get_attr(x)
if (is.roman(x)){
x <- factor(x)
} else {
x <- structure( x <- structure(
forcats::fct_inorder(x), forcats::fct_inorder(x),
label = attr(x, "label", exact = TRUE) label = attr(x, "label", exact = TRUE)
) )}
set_attr(x, labels, overwrite = FALSE) set_attr(x, labels, overwrite = FALSE)
} }
@ -218,15 +221,16 @@ named_levels <- function(data, label = "labels", na.label = NULL, na.value = 99)
out <- stats::setNames(d$value, d$name) out <- stats::setNames(d$value, d$name)
## Sort if levels are numeric ## Sort if levels are numeric
## Else, they appear in order of appearance ## Else, they appear in order of appearance
if (identical( if (possibly_numeric(levels(data))) {
levels(data),
suppressWarnings(as.character(as.numeric(levels(data))))
)) {
out <- out |> sort() out <- out |> sort()
} }
out out
} }
is.roman <- function(data){
identical(data,as.character(utils::as.roman(data)))
}
#' Allows conversion of factor to numeric values preserving original levels #' Allows conversion of factor to numeric values preserving original levels
#' #'
@ -277,13 +281,13 @@ fct2num <- function(data) {
## If no NA on numeric coercion, of original names, then return ## If no NA on numeric coercion, of original names, then return
## original numeric names, else values ## original numeric names, else values
if (possible_numeric(out)) { if (possibly_numeric(out)) {
out <- as.numeric(names(out)) out <- as.numeric(names(out))
} }
unname(out) unname(out)
} }
possible_numeric <- function(data){ possibly_numeric <- function(data){
length(stats::na.omit(suppressWarnings(as.numeric(names(data))))) == length(stats::na.omit(suppressWarnings(as.numeric(names(data))))) ==
length(data) length(data)
} }