1
0
mirror of https://github.com/msberends/AMR.git synced 2024-12-25 18:06:12 +01:00
This commit is contained in:
dr. M.S. (Matthijs) Berends 2024-10-17 15:28:13 +02:00
parent b1399259e7
commit 11b1dc2b02
2 changed files with 51 additions and 9 deletions

View File

@ -59,7 +59,7 @@ jobs:
bash _generate_python_wrapper.sh bash _generate_python_wrapper.sh
- name: Publish to PyPI - name: Publish to PyPI
env: # env:
# TWINE_USERNAME: "__token__" # TWINE_USERNAME: "__token__"
# TWINE_PASSWORD: ${{ secrets.PYPI_API_TOKEN }} # TWINE_PASSWORD: ${{ secrets.PYPI_API_TOKEN }}
run: | run: |

48
R/sir.R
View File

@ -319,10 +319,22 @@ as.sir <- function(x, ...) {
UseMethod("as.sir") UseMethod("as.sir")
} }
as_sir_structure <- function(x) { as_sir_structure <- function(x,
structure(factor(as.character(unlist(unname(x))), guideline = NULL,
mo = NULL,
ab = NULL,
method = NULL,
ref_tbl = NULL,
ref_breakpoints = NULL) {
out <- structure(factor(as.character(unlist(unname(x))),
levels = c("S", "SDD", "I", "R", "NI"), levels = c("S", "SDD", "I", "R", "NI"),
ordered = TRUE), ordered = TRUE),
guideline = guideline,
mo = mo,
ab = ab,
method = method,
ref_tbl = ref_tbl,
ref_breakpoints = ref_breakpoints,
class = c("sir", "ordered", "factor")) class = c("sir", "ordered", "factor"))
} }
@ -1634,7 +1646,17 @@ get_skimmers.sir <- function(column) {
#' @export #' @export
#' @noRd #' @noRd
print.sir <- function(x, ...) { print.sir <- function(x, ...) {
x_name <- deparse(substitute(x))
cat("Class 'sir'\n") cat("Class 'sir'\n")
if (!is.null(attributes(x)$guideline) && !all(is.na(attributes(x)$guideline))) {
cat(font_blue(word_wrap("These values were interpreted using ",
font_bold(vector_and(attributes(x)$guideline, quotes = FALSE)),
" based on ",
vector_and(attributes(x)$method, quotes = FALSE),
" values. ",
"Use `sir_interpretation_history(", x_name, ")` to return a full logbook.")))
cat("\n")
}
print(as.character(x), quote = FALSE) print(as.character(x), quote = FALSE)
} }
@ -1715,7 +1737,27 @@ summary.sir <- function(object, ...) {
#' @export #' @export
#' @noRd #' @noRd
c.sir <- function(...) { c.sir <- function(...) {
as.sir(unlist(lapply(list(...), as.character))) lst <- list(...)
guideline <- vapply(FUN.VALUE = character(1), lst, function(x) attributes(x)$guideline %||% NA_character_)
mo <- vapply(FUN.VALUE = character(1), lst, function(x) attributes(x)$mo %||% NA_character_)
ab <- vapply(FUN.VALUE = character(1), lst, function(x) attributes(x)$ab %||% NA_character_)
method <- vapply(FUN.VALUE = character(1), lst, function(x) attributes(x)$method %||% NA_character_)
ref_tbl <- vapply(FUN.VALUE = character(1), lst, function(x) attributes(x)$ref_tbl %||% NA_character_)
ref_breakpoints <- vapply(FUN.VALUE = character(1), lst, function(x) attributes(x)$ref_breakpoints %||% NA_character_)
out <- as.sir(unlist(lapply(list(...), as.character)))
if (!all(is.na(guideline))) {
attributes(out)$guideline <- guideline
attributes(out)$mo <- mo
attributes(out)$ab <- ab
attributes(out)$method <- method
attributes(out)$ref_tbl <- ref_tbl
attributes(out)$ref_breakpoints <- ref_breakpoints
}
out
} }
#' @method unique sir #' @method unique sir