mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2026-06-19 04:27:30 +02:00
big steps
This commit is contained in:
parent
52d1791708
commit
ce2558fe90
19 changed files with 3825 additions and 529 deletions
237
R/data-summary.R
Normal file
237
R/data-summary.R
Normal file
|
|
@ -0,0 +1,237 @@
|
|||
data_summary_ui <- function(id) {
|
||||
ns <- NS(id)
|
||||
|
||||
toastui::datagridOutput(outputId = "tbl_summary")
|
||||
}
|
||||
|
||||
|
||||
data_summary_server <- function(id,
|
||||
data) {
|
||||
shiny::moduleServer(
|
||||
id = id,
|
||||
module = function(input, output, session) {
|
||||
ns <- session$ns
|
||||
|
||||
data_r <- shiny::reactive({
|
||||
if (shiny::is.reactive(data)) {
|
||||
data()
|
||||
} else {
|
||||
data
|
||||
}
|
||||
})
|
||||
|
||||
output$tbl_summary <- shiny::reactive({
|
||||
toastui::renderDatagrid(
|
||||
data_r() |>
|
||||
overview_vars() |>
|
||||
create_overview_datagrid() |>
|
||||
add_sparkline(
|
||||
column = "vals"
|
||||
)
|
||||
)
|
||||
})
|
||||
}
|
||||
)
|
||||
}
|
||||
|
||||
#' Add sparkline to datagrid
|
||||
#'
|
||||
#' @param grid grid
|
||||
#' @param column clumn to transform
|
||||
#'
|
||||
#' @returns datagrid
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' grid <- mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' overview_vars() |>
|
||||
#' toastui::datagrid() |>
|
||||
#' add_sparkline()
|
||||
#' grid
|
||||
add_sparkline <- function(grid, column = "vals", color.main = "#2a8484", color.sec = "#84EF84") {
|
||||
out <- toastui::grid_sparkline(
|
||||
grid = grid,
|
||||
column = column,
|
||||
renderer = function(data) {
|
||||
data_cl <- class(data)
|
||||
if (identical(data_cl, "factor")) {
|
||||
type <- "column"
|
||||
s <- summary(data)
|
||||
ds <- data.frame(x = names(s), y = s)
|
||||
horizontal <- FALSE
|
||||
} else if (any(c("numeric", "integer") %in% data_cl)) {
|
||||
if (length(unique(data)) == length(data)) {
|
||||
type <- "line"
|
||||
ds <- data.frame(x = NA, y = NA)
|
||||
horizontal <- FALSE
|
||||
} else {
|
||||
type <- "box"
|
||||
ds <- data.frame(x = 1, y = data)
|
||||
horizontal <- TRUE
|
||||
}
|
||||
} else if (any(c("Date", "POSIXct", "POSIXt", "hms", "difftime") %in% data_cl)) {
|
||||
type <- "line"
|
||||
ds <- data.frame(x = seq_along(data), y = data)
|
||||
horizontal <- FALSE
|
||||
} else {
|
||||
type <- "line"
|
||||
ds <- data.frame(x = NA, y = NA)
|
||||
horizontal <- FALSE
|
||||
}
|
||||
apexcharter::apex(
|
||||
ds,
|
||||
apexcharter::aes(x, y),
|
||||
type = type,
|
||||
auto_update = TRUE
|
||||
) |>
|
||||
apexcharter::ax_chart(sparkline = list(enabled = TRUE)) |>
|
||||
apexcharter::ax_plotOptions(
|
||||
boxPlot = apexcharter::boxplot_opts(color.upper = color.sec, color.lower = color.main),
|
||||
bar = apexcharter::bar_opts(horizontal = horizontal)
|
||||
) |>
|
||||
apexcharter::ax_colors(
|
||||
c(color.main, color.sec)
|
||||
)
|
||||
}
|
||||
)
|
||||
|
||||
toastui::grid_columns(
|
||||
grid = out,
|
||||
columns = column,
|
||||
minWidth = 200
|
||||
)
|
||||
}
|
||||
|
||||
#' Create a data overview data.frame ready for sparklines
|
||||
#'
|
||||
#' @param data data
|
||||
#'
|
||||
#' @returns data.frame
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> overview_vars()
|
||||
overview_vars <- function(data) {
|
||||
data <- as.data.frame(data)
|
||||
|
||||
dplyr::tibble(
|
||||
class = get_classes(data),
|
||||
name = names(data),
|
||||
n_missing = unname(colSums(is.na(data))),
|
||||
p_complete = 1 - n_missing / nrow(data),
|
||||
n_unique = get_n_unique(data),
|
||||
vals = as.list(data)
|
||||
)
|
||||
}
|
||||
|
||||
#' Create a data overview datagrid
|
||||
#'
|
||||
#' @param data data
|
||||
#'
|
||||
#' @returns datagrid
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |>
|
||||
#' overview_vars() |>
|
||||
#' create_overview_datagrid()
|
||||
create_overview_datagrid <- function(data) {
|
||||
# browser()
|
||||
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",
|
||||
"Class" = "class",
|
||||
"Missing" = "n_missing",
|
||||
"Complete" = "p_complete",
|
||||
"Unique" = "n_unique",
|
||||
"Plot" = "vals"
|
||||
)
|
||||
|
||||
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 = "auto"
|
||||
)
|
||||
|
||||
grid <- toastui::grid_columns(
|
||||
grid = grid,
|
||||
columns = col.names,
|
||||
header = headers,
|
||||
resizable = TRUE,
|
||||
width = 80
|
||||
)
|
||||
|
||||
grid <- add_class_icon(
|
||||
grid = grid,
|
||||
column = "class"
|
||||
)
|
||||
|
||||
# grid <- toastui::grid_format(
|
||||
# grid = grid,
|
||||
# "p_complete",
|
||||
# formatter = toastui::JS("function(obj) {return (obj.value*100).toFixed(0) + '%';}")
|
||||
# )
|
||||
|
||||
return(grid)
|
||||
}
|
||||
|
||||
#' Convert class grid column to icon
|
||||
#'
|
||||
#' @param grid grid
|
||||
#' @param column column
|
||||
#'
|
||||
#' @returns datagrid
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
add_class_icon <- function(grid, column = "class") {
|
||||
out <- toastui::grid_format(
|
||||
grid = grid,
|
||||
column = column,
|
||||
formatter = function(value) {
|
||||
lapply(
|
||||
X = value,
|
||||
FUN = function(x) {
|
||||
if (identical(x, "numeric")) {
|
||||
shiny::icon("chart-line")
|
||||
} else if (identical(x, "factor")) {
|
||||
shiny::icon("chart-column")
|
||||
} else if (identical(x, "integer")) {
|
||||
shiny::icon("arrow-down-1-9")
|
||||
} else if (identical(x, "character")) {
|
||||
shiny::icon("arrow-down-a-z")
|
||||
} else if (any(c("Date", "POSIXct", "POSIXt") %in% x)) {
|
||||
shiny::icon("calendar-days")
|
||||
} else if ("hms" %in% x) {
|
||||
shiny::icon("clock")
|
||||
} else {
|
||||
shiny::icon("table")
|
||||
}
|
||||
}
|
||||
)
|
||||
}
|
||||
)
|
||||
|
||||
toastui::grid_columns(
|
||||
grid = out,
|
||||
header = NULL,
|
||||
columns = column,
|
||||
width = 60
|
||||
)
|
||||
}
|
||||
|
|
@ -1,125 +1,125 @@
|
|||
#' #' Shiny UI module to load a data file
|
||||
#' #'
|
||||
#' #' @param id id
|
||||
#' #'
|
||||
#' #' @return shiny UI
|
||||
#' #' @export
|
||||
#' #'
|
||||
#' m_datafileUI <- function(id) {
|
||||
#' ns <- shiny::NS(id)
|
||||
#' shiny::tagList(
|
||||
#' shiny::fileInput(
|
||||
#' inputId = ns("file"),
|
||||
#' label = "Upload a file",
|
||||
#' multiple = FALSE,
|
||||
#' accept = c(
|
||||
#' ".csv",
|
||||
#' ".xlsx",
|
||||
#' ".xls",
|
||||
#' ".dta",
|
||||
#' ".ods",
|
||||
#' ".rds"
|
||||
#' )
|
||||
#' ),
|
||||
#' shiny::h4("Parameter specifications"),
|
||||
#' shiny::helpText(shiny::em("Select the desired variables and press 'Submit'")),
|
||||
#' shiny::uiOutput(ns("include_vars")),
|
||||
#' DT::DTOutput(ns("data_input")),
|
||||
#' shiny::actionButton(ns("submit"), "Submit")
|
||||
#' )
|
||||
#' }
|
||||
#' Shiny UI module to load a data file
|
||||
#'
|
||||
#' m_datafileServer <- function(id, output.format = "df") {
|
||||
#' shiny::moduleServer(id, function(input, output, session, ...) {
|
||||
#' ns <- shiny::NS(id)
|
||||
#' ds <- shiny::reactive({
|
||||
#' REDCapCAST::read_input(input$file$datapath) |> REDCapCAST::parse_data()
|
||||
#' })
|
||||
#' @param id id
|
||||
#'
|
||||
#' output$include_vars <- shiny::renderUI({
|
||||
#' shiny::req(input$file)
|
||||
#' shiny::selectizeInput(
|
||||
#' inputId = ns("include_vars"),
|
||||
#' selected = NULL,
|
||||
#' label = "Covariables to include",
|
||||
#' choices = colnames(ds()),
|
||||
#' multiple = TRUE
|
||||
#' )
|
||||
#' })
|
||||
#' @return shiny UI
|
||||
#' @export
|
||||
#'
|
||||
#' base_vars <- shiny::reactive({
|
||||
#' if (is.null(input$include_vars)) {
|
||||
#' out <- colnames(ds())
|
||||
#' } else {
|
||||
#' out <- input$include_vars
|
||||
#' }
|
||||
#' out
|
||||
#' })
|
||||
#'
|
||||
#' output$data_input <-
|
||||
#' DT::renderDT({
|
||||
#' shiny::req(input$file)
|
||||
#' ds()[base_vars()]
|
||||
#' })
|
||||
#'
|
||||
#' shiny::eventReactive(input$submit, {
|
||||
#' # shiny::req(input$file)
|
||||
#'
|
||||
#' data <- shiny::isolate({
|
||||
#' ds()[base_vars()]
|
||||
#' })
|
||||
#'
|
||||
#' file_export(data,
|
||||
#' output.format = output.format,
|
||||
#' tools::file_path_sans_ext(input$file$name)
|
||||
#' )
|
||||
#' })
|
||||
#' })
|
||||
#' }
|
||||
#'
|
||||
#'
|
||||
#'
|
||||
#'
|
||||
#'
|
||||
#' file_app <- function() {
|
||||
#' ui <- shiny::fluidPage(
|
||||
#' m_datafileUI("data"),
|
||||
#' # DT::DTOutput(outputId = "redcap_prev")
|
||||
#' toastui::datagridOutput2(outputId = "redcap_prev")
|
||||
#' )
|
||||
#' server <- function(input, output, session) {
|
||||
#' m_datafileServer("data", output.format = "list")
|
||||
#' }
|
||||
#' shiny::shinyApp(ui, server)
|
||||
#' }
|
||||
#'
|
||||
#' file_app()
|
||||
#'
|
||||
#' tdm_data_upload <- teal::teal_data_module(
|
||||
#' ui <- function(id) {
|
||||
#' shiny::fluidPage(
|
||||
#' m_datafileUI(id)
|
||||
#' )
|
||||
#' },
|
||||
#' server = function(id) {
|
||||
#' m_datafileServer(id, output.format = "teal")
|
||||
#' }
|
||||
#' )
|
||||
#'
|
||||
#' tdm_data_read <- teal::teal_data_module(
|
||||
#' ui <- function(id) {
|
||||
#' shiny::fluidPage(
|
||||
#' m_redcap_readUI(id = "redcap")
|
||||
#' )
|
||||
#' },
|
||||
#' server = function(id) {
|
||||
#' moduleServer(
|
||||
#' id,
|
||||
#' function(input, output, session) {
|
||||
#' ns <- session$ns
|
||||
#'
|
||||
#' m_redcap_readServer(id = "redcap", output.format = "teal")
|
||||
#' }
|
||||
#' )
|
||||
#' }
|
||||
#' )
|
||||
m_datafileUI <- function(id) {
|
||||
ns <- shiny::NS(id)
|
||||
shiny::tagList(
|
||||
shiny::fileInput(
|
||||
inputId = ns("file"),
|
||||
label = "Upload a file",
|
||||
multiple = FALSE,
|
||||
accept = c(
|
||||
".csv",
|
||||
".xlsx",
|
||||
".xls",
|
||||
".dta",
|
||||
".ods",
|
||||
".rds"
|
||||
)
|
||||
),
|
||||
shiny::h4("Parameter specifications"),
|
||||
shiny::helpText(shiny::em("Select the desired variables and press 'Submit'")),
|
||||
shiny::uiOutput(ns("include_vars")),
|
||||
DT::DTOutput(ns("data_input")),
|
||||
shiny::actionButton(ns("submit"), "Submit")
|
||||
)
|
||||
}
|
||||
|
||||
m_datafileServer <- function(id, output.format = "df") {
|
||||
shiny::moduleServer(id, function(input, output, session, ...) {
|
||||
ns <- shiny::NS(id)
|
||||
ds <- shiny::reactive({
|
||||
REDCapCAST::read_input(input$file$datapath) |> REDCapCAST::parse_data()
|
||||
})
|
||||
|
||||
output$include_vars <- shiny::renderUI({
|
||||
shiny::req(input$file)
|
||||
shiny::selectizeInput(
|
||||
inputId = ns("include_vars"),
|
||||
selected = NULL,
|
||||
label = "Covariables to include",
|
||||
choices = colnames(ds()),
|
||||
multiple = TRUE
|
||||
)
|
||||
})
|
||||
|
||||
base_vars <- shiny::reactive({
|
||||
if (is.null(input$include_vars)) {
|
||||
out <- colnames(ds())
|
||||
} else {
|
||||
out <- input$include_vars
|
||||
}
|
||||
out
|
||||
})
|
||||
|
||||
output$data_input <-
|
||||
DT::renderDT({
|
||||
shiny::req(input$file)
|
||||
ds()[base_vars()]
|
||||
})
|
||||
|
||||
shiny::eventReactive(input$submit, {
|
||||
# shiny::req(input$file)
|
||||
|
||||
data <- shiny::isolate({
|
||||
ds()[base_vars()]
|
||||
})
|
||||
|
||||
file_export(data,
|
||||
output.format = output.format,
|
||||
tools::file_path_sans_ext(input$file$name)
|
||||
)
|
||||
})
|
||||
})
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
file_app <- function() {
|
||||
ui <- shiny::fluidPage(
|
||||
m_datafileUI("data"),
|
||||
# DT::DTOutput(outputId = "redcap_prev")
|
||||
toastui::datagridOutput2(outputId = "redcap_prev")
|
||||
)
|
||||
server <- function(input, output, session) {
|
||||
m_datafileServer("data", output.format = "list")
|
||||
}
|
||||
shiny::shinyApp(ui, server)
|
||||
}
|
||||
|
||||
file_app()
|
||||
|
||||
tdm_data_upload <- teal::teal_data_module(
|
||||
ui <- function(id) {
|
||||
shiny::fluidPage(
|
||||
m_datafileUI(id)
|
||||
)
|
||||
},
|
||||
server = function(id) {
|
||||
m_datafileServer(id, output.format = "teal")
|
||||
}
|
||||
)
|
||||
|
||||
tdm_data_read <- teal::teal_data_module(
|
||||
ui <- function(id) {
|
||||
shiny::fluidPage(
|
||||
m_redcap_readUI(id = "redcap")
|
||||
)
|
||||
},
|
||||
server = function(id) {
|
||||
moduleServer(
|
||||
id,
|
||||
function(input, output, session) {
|
||||
ns <- session$ns
|
||||
|
||||
m_redcap_readServer(id = "redcap", output.format = "teal")
|
||||
}
|
||||
)
|
||||
}
|
||||
)
|
||||
|
|
|
|||
38
R/helpers.R
38
R/helpers.R
|
|
@ -148,7 +148,7 @@ file_export <- function(data, output.format = c("df", "teal", "list"), filename,
|
|||
teal_data(),
|
||||
{
|
||||
assign(name, value |>
|
||||
dplyr::bind_cols() |>
|
||||
dplyr::bind_cols(.name_repair = "unique_quiet") |>
|
||||
default_parsing())
|
||||
},
|
||||
value = data,
|
||||
|
|
@ -185,8 +185,42 @@ file_export <- function(data, output.format = c("df", "teal", "list"), filename,
|
|||
#' default_parsing() |>
|
||||
#' str()
|
||||
default_parsing <- function(data) {
|
||||
data |>
|
||||
name_labels <- lapply(data,\(.x) REDCapCAST::get_attr(.x,attr = "label"))
|
||||
|
||||
out <- data |>
|
||||
REDCapCAST::parse_data() |>
|
||||
REDCapCAST::as_factor() |>
|
||||
REDCapCAST::numchar2fct()
|
||||
|
||||
purrr::map2(out,name_labels,\(.x,.l){
|
||||
if (!(is.na(.l) | .l=="")) {
|
||||
REDCapCAST::set_attr(.x, .l, attr = "label")
|
||||
} else {
|
||||
attr(x = .x, which = "label") <- NULL
|
||||
.x
|
||||
}
|
||||
# REDCapCAST::set_attr(data = .x, label = .l,attr = "label", overwrite = FALSE)
|
||||
}) |> dplyr::bind_cols()
|
||||
}
|
||||
|
||||
#' Remove NA labels
|
||||
#'
|
||||
#' @param data data
|
||||
#'
|
||||
#' @returns data.frame
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' ds <- mtcars |> lapply(\(.x) REDCapCAST::set_attr(.x,label=NA,attr = "label"))
|
||||
#' ds |> remove_na_attr() |> str()
|
||||
remove_na_attr <- function(data,attr="label"){
|
||||
out <- data |> lapply(\(.x){
|
||||
ls <- REDCapCAST::get_attr(data = .x,attr = attr)
|
||||
if (is.na(ls) | ls == ""){
|
||||
attr(x = .x, which = attr) <- NULL
|
||||
}
|
||||
.x
|
||||
})
|
||||
|
||||
dplyr::bind_cols(out)
|
||||
}
|
||||
|
|
|
|||
|
|
@ -10,8 +10,8 @@
|
|||
m_redcap_readUI <- function(id, include_title = TRUE) {
|
||||
ns <- shiny::NS(id)
|
||||
|
||||
server_ui <- shiny::column(
|
||||
width = 6,
|
||||
server_ui <- shiny::tagList(
|
||||
# width = 6,
|
||||
shiny::tags$h4("REDCap server information"),
|
||||
shiny::textInput(
|
||||
inputId = ns("uri"),
|
||||
|
|
@ -27,8 +27,8 @@ m_redcap_readUI <- function(id, include_title = TRUE) {
|
|||
|
||||
|
||||
params_ui <-
|
||||
shiny::column(
|
||||
width = 6,
|
||||
shiny::tagList(
|
||||
# width = 6,
|
||||
shiny::tags$h4("Data import parameters"),
|
||||
shiny::helpText("Options here will show, when API and uri are typed"),
|
||||
shiny::uiOutput(outputId = ns("fields")),
|
||||
|
|
@ -63,9 +63,14 @@ m_redcap_readUI <- function(id, include_title = TRUE) {
|
|||
|
||||
shiny::fluidPage(
|
||||
if (include_title) shiny::tags$h3("Import data from REDCap"),
|
||||
fluidRow(
|
||||
bslib::layout_columns(
|
||||
server_ui,
|
||||
params_ui),
|
||||
params_ui,
|
||||
col_widths = bslib::breakpoints(
|
||||
sm = c(12, 12),
|
||||
md = c(12, 12)
|
||||
)
|
||||
),
|
||||
shiny::column(
|
||||
width = 12,
|
||||
# shiny::actionButton(inputId = ns("import"), label = "Import"),
|
||||
|
|
@ -75,8 +80,8 @@ m_redcap_readUI <- function(id, include_title = TRUE) {
|
|||
icon = shiny::icon("download", lib = "glyphicon"),
|
||||
label_busy = "Just a minute...",
|
||||
icon_busy = fontawesome::fa_i("arrows-rotate",
|
||||
class = "fa-spin",
|
||||
"aria-hidden" = "true"
|
||||
class = "fa-spin",
|
||||
"aria-hidden" = "true"
|
||||
),
|
||||
type = "primary",
|
||||
auto_reset = TRUE
|
||||
|
|
@ -194,7 +199,7 @@ m_redcap_readServer <- function(id, output.format = c("df", "teal", "list")) {
|
|||
# browser()
|
||||
data.df <- dd()[, c(1, 2, 4, 5, 6, 8)]
|
||||
DT::datatable(data.df,
|
||||
caption = "Subset of data dictionary"
|
||||
caption = "Subset of data dictionary"
|
||||
)
|
||||
},
|
||||
server = TRUE
|
||||
|
|
@ -241,8 +246,8 @@ m_redcap_readServer <- function(id, output.format = c("df", "teal", "list")) {
|
|||
REDCapCAST::suffix2label()
|
||||
|
||||
out_object <- file_export(redcap_data,
|
||||
output.format = output.format,
|
||||
filename = name()
|
||||
output.format = output.format,
|
||||
filename = name()
|
||||
)
|
||||
|
||||
if (output.format == "list") {
|
||||
|
|
@ -270,7 +275,6 @@ m_redcap_readServer <- function(id, output.format = c("df", "teal", "list")) {
|
|||
#'
|
||||
#' @rdname redcap_read_shiny_module
|
||||
tdm_redcap_read <- teal::teal_data_module(
|
||||
|
||||
ui <- function(id) {
|
||||
shiny::fluidPage(
|
||||
m_redcap_readUI(id)
|
||||
|
|
@ -305,7 +309,7 @@ redcap_app <- function() {
|
|||
)
|
||||
)
|
||||
server <- function(input, output, session) {
|
||||
data_val <- shiny::reactiveValues(data=NULL)
|
||||
data_val <- shiny::reactiveValues(data = NULL)
|
||||
|
||||
ds <- m_redcap_readServer("data", output.format = "df")
|
||||
# output$redcap_prev <- DT::renderDT(
|
||||
|
|
@ -328,8 +332,9 @@ redcap_app <- function() {
|
|||
})
|
||||
|
||||
filtered_data <- IDEAFilter::IDEAFilter("data_filter",
|
||||
data = ds,
|
||||
verbose = FALSE)
|
||||
data = ds,
|
||||
verbose = FALSE
|
||||
)
|
||||
|
||||
# filtered_data <- shiny::reactive({
|
||||
# IDEAFilter::IDEAFilter("data_filter",
|
||||
|
|
|
|||
|
|
@ -71,7 +71,7 @@ regression_model <- function(data,
|
|||
.x
|
||||
}
|
||||
}) |>
|
||||
dplyr::bind_cols()
|
||||
dplyr::bind_cols(.name_repair = "unique_quiet")
|
||||
|
||||
if (is.null(fun)) auto.mode <- TRUE
|
||||
|
||||
|
|
|
|||
34
R/sparkline_h_minimal.R
Normal file
34
R/sparkline_h_minimal.R
Normal file
|
|
@ -0,0 +1,34 @@
|
|||
# dependencies
|
||||
library(apexcharter)
|
||||
library(toastui)
|
||||
|
||||
spark_data <- mtcars |>
|
||||
(\(.x){
|
||||
dplyr::tibble(
|
||||
name = names(.x),
|
||||
vals = as.list(.x)
|
||||
)
|
||||
})()
|
||||
|
||||
ui <- fluidPage(
|
||||
toastui::datagridOutput("tbl")
|
||||
)
|
||||
|
||||
server <- function(input, output) {
|
||||
output$tbl <- toastui::renderDatagrid(
|
||||
spark_data |>
|
||||
toastui::datagrid() |>
|
||||
toastui::grid_sparkline(
|
||||
column = "vals",
|
||||
renderer = function(data) {
|
||||
apex(data.frame(x = 1, y = data), aes(x, y), type = "box") |>
|
||||
ax_chart(sparkline = list(enabled = TRUE)) |>
|
||||
ax_plotOptions(
|
||||
bar = bar_opts(horizontal=TRUE)
|
||||
)
|
||||
}
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
shinyApp(ui = ui, server = server)
|
||||
707
R/update-variables-ext.R
Normal file
707
R/update-variables-ext.R
Normal file
|
|
@ -0,0 +1,707 @@
|
|||
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
|
||||
#'
|
||||
#' @example examples/variables.R
|
||||
update_variables_ui <- function(id, title = TRUE) {
|
||||
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"),
|
||||
datamods::i18n(paste(
|
||||
"Select, rename and convert variables in table above,",
|
||||
"then apply changes by clicking button below."
|
||||
))
|
||||
)
|
||||
),
|
||||
shiny::actionButton(
|
||||
inputId = ns("validate"),
|
||||
label = htmltools::tagList(
|
||||
phosphoricons::ph("arrow-circle-right", title = 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())
|
||||
# browser()
|
||||
variables <- variables_r()
|
||||
|
||||
# variables <- variables |>
|
||||
# dplyr::mutate(vals=as.list(dplyr::as_tibble(data_r())))
|
||||
|
||||
# variables <- variables |>
|
||||
# dplyr::mutate(n_id=seq_len(nrow(variables)))
|
||||
|
||||
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)
|
||||
}
|
||||
# browser()
|
||||
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
|
||||
|
||||
# browser()
|
||||
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
|
||||
)
|
||||
|
||||
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)
|
||||
}))
|
||||
}
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# 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]
|
||||
}
|
||||
|
||||
#' @importFrom toastui datagrid grid_columns grid_format grid_style_column
|
||||
#' grid_style_column grid_editor grid_editor_opts grid_selection_row
|
||||
#' @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_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 new class", "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(...)
|
||||
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(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 = data[[variable]], ...)
|
||||
attr(data, "code_03_convert") <- c(
|
||||
attr(data, "code_03_convert"),
|
||||
setNames(list(expr(as.Date(!!sym(variable), origin = !!args$origin))), 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]
|
||||
}
|
||||
|
||||
|
||||
Loading…
Add table
Add a link
Reference in a new issue