mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2025-09-12 01:49:39 +02:00
814 lines
24 KiB
R
814 lines
24 KiB
R
library(data.table)
|
|
library(rlang)
|
|
|
|
|
|
#' Select, rename and convert variables
|
|
#'
|
|
#' @param id Module id. See [shiny::moduleServer()].
|
|
#' @param title Module's title, if `TRUE` use the default title,
|
|
#' use \code{NULL} for no title or a `shiny.tag` for a custom one.
|
|
#'
|
|
#' @return A [shiny::reactive()] function returning the updated data.
|
|
#' @export
|
|
#'
|
|
#' @name update-variables
|
|
#'
|
|
update_variables_ui <- function(id, title = "") {
|
|
ns <- NS(id)
|
|
if (isTRUE(title)) {
|
|
title <- htmltools::tags$h4(
|
|
i18n("Update & select variables"),
|
|
class = "datamods-title"
|
|
)
|
|
}
|
|
htmltools::tags$div(
|
|
class = "datamods-update",
|
|
shinyWidgets::html_dependency_pretty(),
|
|
title,
|
|
htmltools::tags$div(
|
|
style = "min-height: 25px;",
|
|
htmltools::tags$div(
|
|
shiny::uiOutput(outputId = ns("data_info"), inline = TRUE),
|
|
shiny::tagAppendAttributes(
|
|
shinyWidgets::dropMenu(
|
|
placement = "bottom-end",
|
|
shiny::actionButton(
|
|
inputId = ns("settings"),
|
|
label = phosphoricons::ph("gear"),
|
|
class = "pull-right float-right"
|
|
),
|
|
shinyWidgets::textInputIcon(
|
|
inputId = ns("format"),
|
|
label = i18n("Date format:"),
|
|
value = "%Y-%m-%d",
|
|
icon = list(phosphoricons::ph("clock"))
|
|
),
|
|
shinyWidgets::textInputIcon(
|
|
inputId = ns("origin"),
|
|
label = i18n("Date to use as origin to convert date/datetime:"),
|
|
value = "1970-01-01",
|
|
icon = list(phosphoricons::ph("calendar"))
|
|
),
|
|
shinyWidgets::textInputIcon(
|
|
inputId = ns("dec"),
|
|
label = i18n("Decimal separator:"),
|
|
value = ".",
|
|
icon = list("0.00")
|
|
)
|
|
),
|
|
style = "display: inline;"
|
|
)
|
|
),
|
|
htmltools::tags$br(),
|
|
toastui::datagridOutput(outputId = ns("table"))
|
|
),
|
|
htmltools::tags$br(),
|
|
htmltools::tags$div(
|
|
id = ns("update-placeholder"),
|
|
shinyWidgets::alert(
|
|
id = ns("update-result"),
|
|
status = "info",
|
|
phosphoricons::ph("info"),
|
|
paste(
|
|
"Select variables to keep (if none selected, all are kept), rename",
|
|
"variables and labels, and convert variable type/class in the table",
|
|
"above. Apply changes by clicking the button below."
|
|
)
|
|
)
|
|
),
|
|
shiny::actionButton(
|
|
inputId = ns("validate"),
|
|
label = htmltools::tagList(
|
|
phosphoricons::ph("arrow-circle-right", title = datamods::i18n("Apply changes")),
|
|
datamods::i18n("Apply changes")
|
|
),
|
|
width = "100%"
|
|
)
|
|
)
|
|
}
|
|
|
|
#' @export
|
|
#'
|
|
#' @param id Module's ID
|
|
#' @param data a \code{data.frame} or a \code{reactive} function returning a \code{data.frame}.
|
|
#' @param height Height for the table.
|
|
#' @param return_data_on_init Return initial data when module is called.
|
|
#' @param try_silent logical: should the report of error messages be suppressed?
|
|
#'
|
|
#' @rdname update-variables
|
|
#'
|
|
update_variables_server <- function(id,
|
|
data,
|
|
height = NULL,
|
|
return_data_on_init = FALSE,
|
|
try_silent = FALSE) {
|
|
shiny::moduleServer(
|
|
id = id,
|
|
module = function(input, output, session) {
|
|
ns <- session$ns
|
|
updated_data <- shiny::reactiveValues(x = NULL)
|
|
|
|
data_r <- shiny::reactive({
|
|
if (shiny::is.reactive(data)) {
|
|
data()
|
|
} else {
|
|
data
|
|
}
|
|
})
|
|
|
|
output$data_info <- shiny::renderUI({
|
|
shiny::req(data_r())
|
|
data <- data_r()
|
|
sprintf(i18n("Data has %s observations and %s variables."), nrow(data), ncol(data))
|
|
})
|
|
|
|
variables_r <- shiny::reactive({
|
|
shiny::validate(
|
|
shiny::need(data(), i18n("No data to display."))
|
|
)
|
|
data <- data_r()
|
|
if (isTRUE(return_data_on_init)) {
|
|
updated_data$x <- data
|
|
} else {
|
|
updated_data$x <- NULL
|
|
}
|
|
summary_vars(data)
|
|
})
|
|
|
|
output$table <- toastui::renderDatagrid({
|
|
shiny::req(variables_r())
|
|
|
|
variables <- variables_r()
|
|
|
|
update_variables_datagrid(
|
|
variables,
|
|
height = height,
|
|
selectionId = ns("row_selected"),
|
|
buttonId = "validate"
|
|
)
|
|
})
|
|
|
|
shiny::observeEvent(input$validate,
|
|
{
|
|
updated_data$list_rename <- NULL
|
|
updated_data$list_select <- NULL
|
|
updated_data$list_mutate <- NULL
|
|
updated_data$list_relabel <- NULL
|
|
data <- data_r()
|
|
new_selections <- input$row_selected
|
|
if (length(new_selections) < 1) {
|
|
new_selections <- seq_along(data)
|
|
}
|
|
|
|
data_inputs <- data.table::as.data.table(input$table_data)
|
|
data.table::setorderv(data_inputs, "rowKey")
|
|
|
|
old_names <- data_inputs$name
|
|
new_names <- data_inputs$name_toset
|
|
new_names[new_names == "New name"] <- NA
|
|
new_names[is.na(new_names)] <- old_names[is.na(new_names)]
|
|
new_names[new_names == ""] <- old_names[new_names == ""]
|
|
|
|
old_label <- data_inputs$label
|
|
new_label <- data_inputs$label_toset
|
|
new_label[new_label == "New label"] <- ""
|
|
new_label[is.na(new_label)] <- old_label[is.na(new_label)]
|
|
new_label[new_label == ""] <- old_label[new_label == ""]
|
|
|
|
new_classes <- data_inputs$class_toset
|
|
new_classes[new_classes == "Select"] <- NA
|
|
|
|
data_sv <- variables_r()
|
|
vars_to_change <- get_vars_to_convert(data_sv, setNames(as.list(new_classes), old_names))
|
|
|
|
res_update <- try(
|
|
{
|
|
# convert
|
|
if (nrow(vars_to_change) > 0) {
|
|
data <- convert_to(
|
|
data = data,
|
|
variable = vars_to_change$name,
|
|
new_class = vars_to_change$class_to_set,
|
|
origin = input$origin,
|
|
format = input$format,
|
|
dec = input$dec
|
|
)
|
|
}
|
|
list_mutate <- attr(data, "code_03_convert")
|
|
|
|
# rename
|
|
list_rename <- setNames(
|
|
as.list(old_names),
|
|
unlist(new_names, use.names = FALSE)
|
|
)
|
|
list_rename <- list_rename[names(list_rename) != unlist(list_rename, use.names = FALSE)]
|
|
names(data) <- unlist(new_names, use.names = FALSE)
|
|
|
|
# relabel
|
|
list_relabel <- as.list(new_label)
|
|
data <- purrr::map2(
|
|
data, list_relabel,
|
|
\(.data, .label){
|
|
if (!(is.na(.label) | .label == "")) {
|
|
REDCapCAST::set_attr(.data, .label, attr = "label")
|
|
} else {
|
|
attr(x = .data, which = "label") <- NULL
|
|
.data
|
|
}
|
|
}
|
|
) |> dplyr::bind_cols(.name_repair = "unique_quiet")
|
|
|
|
# select
|
|
list_select <- setdiff(names(data), names(data)[new_selections])
|
|
data <- data[, new_selections, drop = FALSE]
|
|
},
|
|
silent = try_silent
|
|
)
|
|
|
|
if (inherits(res_update, "try-error")) {
|
|
datamods:::insert_error(selector = "update")
|
|
} else {
|
|
datamods:::insert_alert(
|
|
selector = ns("update"),
|
|
status = "success",
|
|
tags$b(phosphoricons::ph("check"), datamods::i18n("Data successfully updated!"))
|
|
)
|
|
updated_data$x <- data
|
|
updated_data$list_rename <- list_rename
|
|
updated_data$list_select <- list_select
|
|
updated_data$list_mutate <- list_mutate
|
|
updated_data$list_relabel <- list_relabel
|
|
}
|
|
},
|
|
ignoreNULL = TRUE,
|
|
ignoreInit = TRUE
|
|
)
|
|
|
|
# shiny::observeEvent(input$close,
|
|
# {
|
|
return(shiny::reactive({
|
|
data <- updated_data$x
|
|
code <- list()
|
|
if (!is.null(data) && shiny::isTruthy(updated_data$list_mutate) && length(updated_data$list_mutate) > 0) {
|
|
code <- c(code, list(rlang::call2("mutate", !!!updated_data$list_mutate)))
|
|
}
|
|
if (!is.null(data) && shiny::isTruthy(updated_data$list_rename) && length(updated_data$list_rename) > 0) {
|
|
code <- c(code, list(rlang::call2("rename", !!!updated_data$list_rename)))
|
|
}
|
|
if (!is.null(data) && shiny::isTruthy(updated_data$list_select) && length(updated_data$list_select) > 0) {
|
|
code <- c(code, list(rlang::expr(select(-any_of(c(!!!updated_data$list_select))))))
|
|
}
|
|
if (!is.null(data) && shiny::isTruthy(updated_data$list_relabel) && length(updated_data$list_relabel) > 0) {
|
|
code <- c(code, list(rlang::call2("purrr::map2(list_relabel,
|
|
function(.data,.label){
|
|
REDCapCAST::set_attr(.data,.label,attr = 'label')
|
|
}) |> dplyr::bind_cols(.name_repair = 'unique_quiet')")))
|
|
}
|
|
if (length(code) > 0) {
|
|
attr(data, "code") <- Reduce(
|
|
f = function(x, y) rlang::expr(!!x %>% !!y),
|
|
x = code
|
|
)
|
|
}
|
|
return(data)
|
|
}))
|
|
# })
|
|
|
|
# shiny::reactive({
|
|
# data <- updated_data$x
|
|
# code <- list()
|
|
# if (!is.null(data) && shiny::isTruthy(updated_data$list_mutate) && length(updated_data$list_mutate) > 0) {
|
|
# code <- c(code, list(rlang::call2("mutate", !!!updated_data$list_mutate)))
|
|
# }
|
|
# if (!is.null(data) && shiny::isTruthy(updated_data$list_rename) && length(updated_data$list_rename) > 0) {
|
|
# code <- c(code, list(rlang::call2("rename", !!!updated_data$list_rename)))
|
|
# }
|
|
# if (!is.null(data) && shiny::isTruthy(updated_data$list_select) && length(updated_data$list_select) > 0) {
|
|
# code <- c(code, list(rlang::expr(select(-any_of(c(!!!updated_data$list_select))))))
|
|
# }
|
|
# if (!is.null(data) && shiny::isTruthy(updated_data$list_relabel) && length(updated_data$list_relabel) > 0) {
|
|
# code <- c(code, list(rlang::call2("purrr::map2(list_relabel,
|
|
# function(.data,.label){
|
|
# REDCapCAST::set_attr(.data,.label,attr = 'label')
|
|
# }) |> dplyr::bind_cols(.name_repair = 'unique_quiet')")))
|
|
# }
|
|
# if (length(code) > 0) {
|
|
# attr(data, "code") <- Reduce(
|
|
# f = function(x, y) rlang::expr(!!x %>% !!y),
|
|
# x = code
|
|
# )
|
|
# }
|
|
# updated_data$return_data <- data
|
|
# })
|
|
|
|
# shiny::observeEvent(input$close,
|
|
# {
|
|
# shiny::req(input$close)
|
|
# return(shiny::reactive({
|
|
# data <- updated_data$return_data
|
|
# return(data)
|
|
# }))
|
|
# })
|
|
|
|
}
|
|
)
|
|
}
|
|
|
|
|
|
modal_update_variables <- function(id,
|
|
title = "Select, rename and reclass variables",
|
|
easyClose = TRUE,
|
|
size = "xl",
|
|
footer = NULL) {
|
|
ns <- NS(id)
|
|
showModal(modalDialog(
|
|
title = tagList(title, datamods:::button_close_modal()),
|
|
update_variables_ui(id),
|
|
# tags$div(
|
|
# style = "display: none;",
|
|
# textInput(inputId = ns("hidden"), label = NULL, value = datamods:::genId())
|
|
# ),
|
|
easyClose = easyClose,
|
|
size = size,
|
|
footer = footer
|
|
))
|
|
}
|
|
|
|
|
|
|
|
# utils -------------------------------------------------------------------
|
|
|
|
|
|
#' Get variables classes from a \code{data.frame}
|
|
#'
|
|
#' @param data a \code{data.frame}
|
|
#'
|
|
#' @return a \code{character} vector as same length as number of variables
|
|
#' @noRd
|
|
#'
|
|
#' @examples
|
|
#'
|
|
#' get_classes(mtcars)
|
|
get_classes <- function(data) {
|
|
classes <- lapply(
|
|
X = data,
|
|
FUN = function(x) {
|
|
paste(class(x), collapse = ", ")
|
|
}
|
|
)
|
|
unlist(classes, use.names = FALSE)
|
|
}
|
|
|
|
|
|
#' Get count of unique values in variables of \code{data.frame}
|
|
#'
|
|
#' @param data a \code{data.frame}
|
|
#'
|
|
#' @return a \code{numeric} vector as same length as number of variables
|
|
#' @noRd
|
|
#'
|
|
#'
|
|
#' @examples
|
|
#' get_n_unique(mtcars)
|
|
get_n_unique <- function(data) {
|
|
u <- lapply(data, FUN = function(x) {
|
|
if (is.atomic(x)) {
|
|
data.table::uniqueN(x)
|
|
} else {
|
|
NA_integer_
|
|
}
|
|
})
|
|
unlist(u, use.names = FALSE)
|
|
}
|
|
|
|
|
|
|
|
#' Add padding 0 to a vector
|
|
#'
|
|
#' @param x a \code{vector}
|
|
#'
|
|
#' @return a \code{character} vector
|
|
#' @noRd
|
|
#'
|
|
#' @examples
|
|
#'
|
|
#' pad0(1:10)
|
|
#' pad0(c(1, 15, 150, NA))
|
|
pad0 <- function(x) {
|
|
NAs <- which(is.na(x))
|
|
x <- formatC(x, width = max(nchar(as.character(x)), na.rm = TRUE), flag = "0")
|
|
x[NAs] <- NA
|
|
x
|
|
}
|
|
|
|
#' Variables summary
|
|
#'
|
|
#' @param data a \code{data.frame}
|
|
#'
|
|
#' @return a \code{data.frame}
|
|
#' @noRd
|
|
#'
|
|
#' @examples
|
|
#'
|
|
#' summary_vars(iris)
|
|
#' summary_vars(mtcars)
|
|
summary_vars <- function(data) {
|
|
data <- as.data.frame(data)
|
|
datsum <- dplyr::tibble(
|
|
name = names(data),
|
|
label = lapply(data, \(.x) REDCapCAST::get_attr(.x, "label")) |> unlist(),
|
|
class = get_classes(data),
|
|
n_missing = unname(colSums(is.na(data))),
|
|
p_complete = 1 - n_missing / nrow(data),
|
|
n_unique = get_n_unique(data)
|
|
)
|
|
|
|
datsum
|
|
}
|
|
|
|
add_var_toset <- function(data, var_name, default = "") {
|
|
datanames <- names(data)
|
|
datanames <- append(
|
|
x = datanames,
|
|
values = paste0(var_name, "_toset"),
|
|
after = which(datanames == var_name)
|
|
)
|
|
data[[paste0(var_name, "_toset")]] <- default
|
|
data[, datanames]
|
|
}
|
|
|
|
#' Modified from the datamods pacakge
|
|
#'
|
|
#' @param data data
|
|
#'
|
|
#' @param height height
|
|
#' @param selectionId selectionId
|
|
#' @param buttonId buttonId
|
|
#'
|
|
#' @examples
|
|
#' mtcars |>
|
|
#' summary_vars() |>
|
|
#' update_variables_datagrid()
|
|
#'
|
|
update_variables_datagrid <- function(data, height = NULL, selectionId = NULL, buttonId = NULL) {
|
|
# browser()
|
|
data <- add_var_toset(data, "name", "New name")
|
|
data <- add_var_toset(data, "class", "Select")
|
|
data <- add_var_toset(data, "label", "New label")
|
|
|
|
gridTheme <- getOption("datagrid.theme")
|
|
if (length(gridTheme) < 1) {
|
|
datamods:::apply_grid_theme()
|
|
}
|
|
on.exit(toastui::reset_grid_theme())
|
|
|
|
col.names <- names(data)
|
|
|
|
std_names <- c(
|
|
"name", "name_toset", "label", "label_toset", "class", "class_toset", "n_missing", "p_complete", "n_unique"
|
|
) |>
|
|
setNames(c(
|
|
"Name", "New name", "Label", "New label", "Class", "New class", "Missing", "Complete", "Unique"
|
|
))
|
|
|
|
headers <- lapply(col.names, \(.x){
|
|
if (.x %in% std_names) {
|
|
names(std_names)[match(.x, std_names)]
|
|
} else {
|
|
.x
|
|
}
|
|
}) |> unlist()
|
|
|
|
grid <- toastui::datagrid(
|
|
data = data,
|
|
theme = "default",
|
|
colwidths = NULL
|
|
)
|
|
grid <- toastui::grid_columns(
|
|
grid = grid,
|
|
columns = col.names,
|
|
header = headers,
|
|
minWidth = 100
|
|
)
|
|
|
|
grid <- toastui::grid_format(
|
|
grid = grid,
|
|
"p_complete",
|
|
formatter = toastui::JS("function(obj) {return (obj.value*100).toFixed(0) + '%';}")
|
|
)
|
|
grid <- toastui::grid_style_column(
|
|
grid = grid,
|
|
column = "name_toset",
|
|
fontStyle = "italic"
|
|
)
|
|
grid <- toastui::grid_style_column(
|
|
grid = grid,
|
|
column = "label_toset",
|
|
fontStyle = "italic"
|
|
)
|
|
grid <- toastui::grid_style_column(
|
|
grid = grid,
|
|
column = "class_toset",
|
|
fontStyle = "italic"
|
|
)
|
|
|
|
grid <- toastui::grid_filters(
|
|
grid = grid,
|
|
column = "name",
|
|
# columns = unname(std_names[std_names!="vals"]),
|
|
showApplyBtn = FALSE,
|
|
showClearBtn = TRUE,
|
|
type = "text"
|
|
)
|
|
|
|
# grid <- toastui::grid_columns(
|
|
# grid = grid,
|
|
# columns = "name_toset",
|
|
# editor = list(type = "text"),
|
|
# validation = toastui::validateOpts()
|
|
# )
|
|
#
|
|
# grid <- toastui::grid_columns(
|
|
# grid = grid,
|
|
# columns = "label_toset",
|
|
# editor = list(type = "text"),
|
|
# validation = toastui::validateOpts()
|
|
# )
|
|
#
|
|
# grid <- toastui::grid_columns(
|
|
# grid = grid,
|
|
# columns = "class_toset",
|
|
# editor = list(
|
|
# type = "radio",
|
|
# options = list(
|
|
# instantApply = TRUE,
|
|
# listItems = lapply(
|
|
# X = c("Select", "character", "factor", "numeric", "integer", "date", "datetime", "hms"),
|
|
# FUN = function(x) {
|
|
# list(text = x, value = x)
|
|
# }
|
|
# )
|
|
# )
|
|
# ),
|
|
# validation = toastui::validateOpts()
|
|
# )
|
|
|
|
grid <- toastui::grid_editor(
|
|
grid = grid,
|
|
column = "name_toset",
|
|
type = "text"
|
|
)
|
|
grid <- toastui::grid_editor(
|
|
grid = grid,
|
|
column = "label_toset",
|
|
type = "text"
|
|
)
|
|
grid <- toastui::grid_editor(
|
|
grid = grid,
|
|
column = "class_toset",
|
|
type = "select",
|
|
choices = c("Select", "character", "factor", "numeric", "integer", "date", "datetime", "hms")
|
|
)
|
|
grid <- toastui::grid_editor_opts(
|
|
grid = grid,
|
|
editingEvent = "click",
|
|
actionButtonId = NULL,
|
|
session = NULL
|
|
)
|
|
grid <- toastui::grid_selection_row(
|
|
grid = grid,
|
|
inputId = selectionId,
|
|
type = "checkbox",
|
|
return = "index"
|
|
)
|
|
|
|
return(grid)
|
|
}
|
|
|
|
|
|
|
|
#' Convert a variable to specific new class
|
|
#'
|
|
#' @param data A \code{data.frame}
|
|
#' @param variable Name of the variable to convert
|
|
#' @param new_class Class to set
|
|
#' @param ... Other arguments passed on to methods.
|
|
#'
|
|
#' @return A \code{data.frame}
|
|
#' @noRd
|
|
#'
|
|
#' @importFrom utils type.convert
|
|
#' @importFrom rlang sym expr
|
|
#'
|
|
#' @examples
|
|
#' dat <- data.frame(
|
|
#' v1 = month.name,
|
|
#' v2 = month.abb,
|
|
#' v3 = 1:12,
|
|
#' v4 = as.numeric(Sys.Date() + 0:11),
|
|
#' v5 = as.character(Sys.Date() + 0:11),
|
|
#' v6 = as.factor(c("a", "a", "b", "a", "b", "a", "a", "b", "a", "b", "b", "a")),
|
|
#' v7 = as.character(11:22),
|
|
#' stringsAsFactors = FALSE
|
|
#' )
|
|
#'
|
|
#' str(dat)
|
|
#'
|
|
#' str(convert_to(dat, "v3", "character"))
|
|
#' str(convert_to(dat, "v6", "character"))
|
|
#' str(convert_to(dat, "v7", "numeric"))
|
|
#' str(convert_to(dat, "v4", "date", origin = "1970-01-01"))
|
|
#' str(convert_to(dat, "v5", "date"))
|
|
#'
|
|
#' str(convert_to(dat, c("v1", "v3"), c("factor", "character")))
|
|
#'
|
|
#' str(convert_to(dat, c("v1", "v3", "v4"), c("factor", "character", "date"), origin = "1970-01-01"))
|
|
#'
|
|
convert_to <- function(data,
|
|
variable,
|
|
new_class = c("character", "factor", "numeric", "integer", "date", "datetime", "hms"),
|
|
...) {
|
|
new_class <- match.arg(new_class, several.ok = TRUE)
|
|
stopifnot(length(new_class) == length(variable))
|
|
args <- list(...)
|
|
args$format <- clean_sep(args$format)
|
|
if (length(variable) > 1) {
|
|
for (i in seq_along(variable)) {
|
|
data <- convert_to(data, variable[i], new_class[i], ...)
|
|
}
|
|
return(data)
|
|
}
|
|
if (identical(new_class, "character")) {
|
|
data[[variable]] <- as.character(x = data[[variable]], ...)
|
|
attr(data, "code_03_convert") <- c(
|
|
attr(data, "code_03_convert"),
|
|
setNames(list(expr(as.character(!!sym(variable)))), variable)
|
|
)
|
|
} else if (identical(new_class, "factor")) {
|
|
data[[variable]] <- as.factor(x = data[[variable]])
|
|
attr(data, "code_03_convert") <- c(
|
|
attr(data, "code_03_convert"),
|
|
setNames(list(expr(as.factor(!!sym(variable)))), variable)
|
|
)
|
|
} else if (identical(new_class, "numeric")) {
|
|
data[[variable]] <- as.numeric(data[[variable]], ...)
|
|
# This is the original, that would convert to character and then to numeric
|
|
# resulting in all NAs, setting as.is = FALSE would result in a numeric
|
|
# vector in order of appearance. Now it is acting like integer conversion
|
|
# data[[variable]] <- as.numeric(type.convert(data[[variable]], as.is = TRUE, ...))
|
|
attr(data, "code_03_convert") <- c(
|
|
attr(data, "code_03_convert"),
|
|
setNames(list(expr(as.numeric(!!sym(variable)))), variable)
|
|
)
|
|
} else if (identical(new_class, "integer")) {
|
|
data[[variable]] <- as.integer(x = data[[variable]], ...)
|
|
attr(data, "code_03_convert") <- c(
|
|
attr(data, "code_03_convert"),
|
|
setNames(list(expr(as.integer(!!sym(variable)))), variable)
|
|
)
|
|
} else if (identical(new_class, "date")) {
|
|
data[[variable]] <- as.Date(x = clean_date(data[[variable]]), ...)
|
|
attr(data, "code_03_convert") <- c(
|
|
attr(data, "code_03_convert"),
|
|
setNames(list(expr(as.Date(clean_date(!!sym(variable)), origin = !!args$origin, format = clean_sep(!!args$format)))), variable)
|
|
)
|
|
} else if (identical(new_class, "datetime")) {
|
|
data[[variable]] <- as.POSIXct(x = data[[variable]], ...)
|
|
attr(data, "code_03_convert") <- c(
|
|
attr(data, "code_03_convert"),
|
|
setNames(list(expr(as.POSIXct(!!sym(variable)))), variable)
|
|
)
|
|
} else if (identical(new_class, "hms")) {
|
|
data[[variable]] <- hms::as_hms(x = data[[variable]])
|
|
attr(data, "code_03_convert") <- c(
|
|
attr(data, "code_03_convert"),
|
|
setNames(list(expr(hms::as_hms(!!sym(variable)))), variable)
|
|
)
|
|
}
|
|
return(data)
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
#' Get variable(s) to convert
|
|
#'
|
|
#' @param vars Output of [summary_vars()]
|
|
#' @param classes_input List of inputs containing new classes
|
|
#'
|
|
#' @return a `data.table`.
|
|
#' @noRd
|
|
#'
|
|
#' @importFrom data.table data.table as.data.table
|
|
#'
|
|
#' @examples
|
|
#' # 2 variables to convert
|
|
#' new_classes <- list(
|
|
#' "Sepal.Length" = "numeric",
|
|
#' "Sepal.Width" = "numeric",
|
|
#' "Petal.Length" = "character",
|
|
#' "Petal.Width" = "numeric",
|
|
#' "Species" = "character"
|
|
#' )
|
|
#' get_vars_to_convert(summary_vars(iris), new_classes)
|
|
#'
|
|
#'
|
|
#' # No changes
|
|
#' new_classes <- list(
|
|
#' "Sepal.Length" = "numeric",
|
|
#' "Sepal.Width" = "numeric",
|
|
#' "Petal.Length" = "numeric",
|
|
#' "Petal.Width" = "numeric",
|
|
#' "Species" = "factor"
|
|
#' )
|
|
#' get_vars_to_convert(summary_vars(iris), new_classes)
|
|
#'
|
|
#' # Not set = NA or ""
|
|
#' new_classes <- list(
|
|
#' "Sepal.Length" = NA,
|
|
#' "Sepal.Width" = NA,
|
|
#' "Petal.Length" = NA,
|
|
#' "Petal.Width" = NA,
|
|
#' "Species" = NA
|
|
#' )
|
|
#' get_vars_to_convert(summary_vars(iris), new_classes)
|
|
#'
|
|
#' # Set for one var
|
|
#' new_classes <- list(
|
|
#' "Sepal.Length" = "",
|
|
#' "Sepal.Width" = "",
|
|
#' "Petal.Length" = "",
|
|
#' "Petal.Width" = "",
|
|
#' "Species" = "character"
|
|
#' )
|
|
#' get_vars_to_convert(summary_vars(iris), new_classes)
|
|
#'
|
|
#' new_classes <- list(
|
|
#' "mpg" = "character",
|
|
#' "cyl" = "numeric",
|
|
#' "disp" = "character",
|
|
#' "hp" = "numeric",
|
|
#' "drat" = "character",
|
|
#' "wt" = "character",
|
|
#' "qsec" = "numeric",
|
|
#' "vs" = "character",
|
|
#' "am" = "numeric",
|
|
#' "gear" = "character",
|
|
#' "carb" = "integer"
|
|
#' )
|
|
#' get_vars_to_convert(summary_vars(mtcars), new_classes)
|
|
get_vars_to_convert <- function(vars, classes_input) {
|
|
vars <- data.table::as.data.table(vars)
|
|
classes_input <- data.table::data.table(
|
|
name = names(classes_input),
|
|
class_to_set = unlist(classes_input, use.names = FALSE),
|
|
stringsAsFactors = FALSE
|
|
)
|
|
classes_input <- classes_input[!is.na(class_to_set) & class_to_set != ""]
|
|
classes_df <- merge(x = vars, y = classes_input, by = "name")
|
|
classes_df <- classes_df[!is.na(class_to_set)]
|
|
classes_df[class != class_to_set]
|
|
}
|
|
|
|
|
|
#' gsub wrapper for piping with default values for separator substituting
|
|
#'
|
|
#' @param data character vector
|
|
#' @param old.sep old separator
|
|
#' @param new.sep new separator
|
|
#'
|
|
#' @returns character vector
|
|
#' @export
|
|
#'
|
|
clean_sep <- function(data, old.sep = "[-.,/]", new.sep = "-") {
|
|
gsub(old.sep, new.sep, data)
|
|
}
|
|
|
|
#' Attempts at applying uniform date format
|
|
#'
|
|
#' @param data character string vector of possible dates
|
|
#'
|
|
#' @returns character string
|
|
#' @export
|
|
#'
|
|
clean_date <- function(data) {
|
|
data |>
|
|
clean_sep() |>
|
|
sapply(\(.x){
|
|
if (is.na(.x)) {
|
|
.x
|
|
} else {
|
|
strsplit(.x, "-") |>
|
|
unlist() |>
|
|
lapply(\(.y){
|
|
if (nchar(.y) == 1) paste0("0", .y) else .y
|
|
}) |>
|
|
paste(collapse = "-")
|
|
}
|
|
}) |>
|
|
unname()
|
|
}
|