Skip to content

R
Radiant
Commit 1017104c authored by wuzekai's avatar wuzekai
Browse files
Options

将导入xlsx改为导入全部sheet

parent 0dec47dc
Hide whitespace changes
Inline Side-by-side
Showing with 2291 additions and 2251 deletions
radiant.data/R/transform.R
View file @ 1017104c
#' Center #' Center
#' @param x Input variable #' @param x Input variable
#' @param na.rm If TRUE missing values are removed before calculation #' @param na.rm If TRUE missing values are removed before calculation
#' @return If x is a numeric variable return x - mean(x) #' @return If x is a numeric variable return x - mean(x)
#' @export #' @export
center <- function(x, na.rm = TRUE) { center <- function(x, na.rm = TRUE) {
if (is.numeric(x)) { if (is.numeric(x)) {
x - mean(x, na.rm = na.rm) x - mean(x, na.rm = na.rm)
} else { } else {
x x
} }
} }
#' Standardize #' Standardize
#' @param x Input variable #' @param x Input variable
#' @param na.rm If TRUE missing values are removed before calculation #' @param na.rm If TRUE missing values are removed before calculation
#' @return If x is a numeric variable return (x - mean(x)) / sd(x) #' @return If x is a numeric variable return (x - mean(x)) / sd(x)
#' @export #' @export
standardize <- function(x, na.rm = TRUE) { standardize <- function(x, na.rm = TRUE) {
if (is.numeric(x)) { if (is.numeric(x)) {
x_sd <- sd(x, na.rm = na.rm) x_sd <- sd(x, na.rm = na.rm)
x <- x - mean(x, na.rm = na.rm) x <- x - mean(x, na.rm = na.rm)
if (isTRUE(x_sd > 0)) { if (isTRUE(x_sd > 0)) {
x / x_sd x / x_sd
} else { } else {
x x
} }
} else { } else {
x x
} }
} }
#' Calculate square of a variable #' Calculate square of a variable
#' @param x Input variable #' @param x Input variable
#' @return x^2 #' @return x^2
#' @export #' @export
square <- function(x) x^2 square <- function(x) x^2
#' Calculate inverse of a variable #' Calculate inverse of a variable
#' @param x Input variable #' @param x Input variable
#' @return 1/x #' @return 1/x
#' @export #' @export
inverse <- function(x) { inverse <- function(x) {
if (is.numeric(x)) 1 / x else x if (is.numeric(x)) 1 / x else x
} }
#' Normalize a variable x by a variable y #' Normalize a variable x by a variable y
#' @param x Input variable #' @param x Input variable
#' @param y Normalizing variable #' @param y Normalizing variable
#' @return x/y #' @return x/y
#' @export #' @export
normalize <- function(x, y) { normalize <- function(x, y) {
if (is.numeric(x) && is.numeric(y)) x / y else x if (is.numeric(x) && is.numeric(y)) x / y else x
} }
#' Convert input in month-day-year format to date #' Convert input in month-day-year format to date
#' @details Use as.character if x is a factor #' @details Use as.character if x is a factor
#' @param x Input variable #' @param x Input variable
#' @return Date variable of class Date #' @return Date variable of class Date
#' @examples #' @examples
#' as_mdy("2-1-2014") #' as_mdy("2-1-2014")
#' \dontrun{ #' \dontrun{
#' as_mdy("2-1-2014") %>% month(label = TRUE) #' as_mdy("2-1-2014") %>% month(label = TRUE)
#' as_mdy("2-1-2014") %>% week() #' as_mdy("2-1-2014") %>% week()
#' as_mdy("2-1-2014") %>% wday(label = TRUE) #' as_mdy("2-1-2014") %>% wday(label = TRUE)
#' } #' }
#' @export #' @export
as_mdy <- function(x) { as_mdy <- function(x) {
if (is.factor(x)) x <- as.character(x) if (is.factor(x)) x <- as.character(x)
sshhr(mdy(x)) %>% as.Date() sshhr(mdy(x)) %>% as.Date()
} }
#' Convert input in day-month-year format to date #' Convert input in day-month-year format to date
#' @param x Input variable #' @param x Input variable
#' @return Date variable of class Date #' @return Date variable of class Date
#' @examples #' @examples
#' as_dmy("1-2-2014") #' as_dmy("1-2-2014")
#' #'
#' @export #' @export
as_dmy <- function(x) { as_dmy <- function(x) {
if (is.factor(x)) x <- as.character(x) if (is.factor(x)) x <- as.character(x)
sshhr(dmy(x)) %>% as.Date() sshhr(dmy(x)) %>% as.Date()
} }
#' Convert input in year-month-day format to date #' Convert input in year-month-day format to date
#' @param x Input variable #' @param x Input variable
#' @return Date variable of class Date #' @return Date variable of class Date
#' @examples #' @examples
#' as_ymd("2013-1-1") #' as_ymd("2013-1-1")
#' #'
#' @export #' @export
as_ymd <- function(x) { as_ymd <- function(x) {
if (is.factor(x)) x <- as.character(x) if (is.factor(x)) x <- as.character(x)
sshhr(ymd(x)) %>% as.Date() sshhr(ymd(x)) %>% as.Date()
} }
# http://www.noamross.net/blog/2014/2/10/using-times-and-dates-in-r---presentation-code.html # http://www.noamross.net/blog/2014/2/10/using-times-and-dates-in-r---presentation-code.html
#' Convert input in year-month-day-hour-minute-second format to date-time #' Convert input in year-month-day-hour-minute-second format to date-time
#' @param x Input variable #' @param x Input variable
#' @return Date-time variable of class Date #' @return Date-time variable of class Date
#' @examples #' @examples
#' as_ymd_hms("2014-1-1 12:15:01") #' as_ymd_hms("2014-1-1 12:15:01")
#' \dontrun{ #' \dontrun{
#' as_ymd_hms("2014-1-1 12:15:01") %>% as.Date() #' as_ymd_hms("2014-1-1 12:15:01") %>% as.Date()
#' as_ymd_hms("2014-1-1 12:15:01") %>% month() #' as_ymd_hms("2014-1-1 12:15:01") %>% month()
#' as_ymd_hms("2014-1-1 12:15:01") %>% hour() #' as_ymd_hms("2014-1-1 12:15:01") %>% hour()
#' } #' }
#' @export #' @export
as_ymd_hms <- function(x) { as_ymd_hms <- function(x) {
if (is.factor(x)) x <- as.character(x) if (is.factor(x)) x <- as.character(x)
sshhr(ymd_hms(x)) sshhr(ymd_hms(x))
} }
#' Convert input in year-month-day-hour-minute format to date-time #' Convert input in year-month-day-hour-minute format to date-time
#' @param x Input variable #' @param x Input variable
#' @return Date-time variable of class Date #' @return Date-time variable of class Date
#' @examples #' @examples
#' as_ymd_hm("2014-1-1 12:15") #' as_ymd_hm("2014-1-1 12:15")
#' @export #' @export
as_ymd_hm <- function(x) { as_ymd_hm <- function(x) {
if (is.factor(x)) x <- as.character(x) if (is.factor(x)) x <- as.character(x)
sshhr(parse_date_time(x, "%Y%m%d %H%M")) sshhr(parse_date_time(x, "%Y%m%d %H%M"))
} }
#' Convert input in month-day-year-hour-minute-second format to date-time #' Convert input in month-day-year-hour-minute-second format to date-time
#' @param x Input variable #' @param x Input variable
#' @return Date-time variable of class Date #' @return Date-time variable of class Date
#' @examples #' @examples
#' as_mdy_hms("1-1-2014 12:15:01") #' as_mdy_hms("1-1-2014 12:15:01")
#' @export #' @export
as_mdy_hms <- function(x) { as_mdy_hms <- function(x) {
if (is.factor(x)) x <- as.character(x) if (is.factor(x)) x <- as.character(x)
sshhr(parse_date_time(x, "%m%d%Y %H%M%S")) sshhr(parse_date_time(x, "%m%d%Y %H%M%S"))
} }
#' Convert input in month-day-year-hour-minute format to date-time #' Convert input in month-day-year-hour-minute format to date-time
#' @param x Input variable #' @param x Input variable
#' @return Date-time variable of class Date #' @return Date-time variable of class Date
#' @examples #' @examples
#' as_mdy_hm("1-1-2014 12:15") #' as_mdy_hm("1-1-2014 12:15")
#' @export #' @export
as_mdy_hm <- function(x) { as_mdy_hm <- function(x) {
if (is.factor(x)) x <- as.character(x) if (is.factor(x)) x <- as.character(x)
sshhr(parse_date_time(x, "%m%d%Y %H%M")) sshhr(parse_date_time(x, "%m%d%Y %H%M"))
} }
#' Convert input in day-month-year-hour-minute-second format to date-time #' Convert input in day-month-year-hour-minute-second format to date-time
#' @param x Input variable #' @param x Input variable
#' @return Date-time variable of class Date #' @return Date-time variable of class Date
#' @examples #' @examples
#' as_mdy_hms("1-1-2014 12:15:01") #' as_mdy_hms("1-1-2014 12:15:01")
#' @export #' @export
as_dmy_hms <- function(x) { as_dmy_hms <- function(x) {
if (is.factor(x)) x <- as.character(x) if (is.factor(x)) x <- as.character(x)
sshhr(parse_date_time(x, "%d%m%Y %H%M%S")) sshhr(parse_date_time(x, "%d%m%Y %H%M%S"))
} }
#' Convert input in day-month-year-hour-minute format to date-time #' Convert input in day-month-year-hour-minute format to date-time
#' @param x Input variable #' @param x Input variable
#' @return Date-time variable of class Date #' @return Date-time variable of class Date
#' @examples #' @examples
#' as_mdy_hm("1-1-2014 12:15") #' as_mdy_hm("1-1-2014 12:15")
#' @export #' @export
as_dmy_hm <- function(x) { as_dmy_hm <- function(x) {
if (is.factor(x)) x <- as.character(x) if (is.factor(x)) x <- as.character(x)
sshhr(parse_date_time(x, "%d%m%Y %H%M")) sshhr(parse_date_time(x, "%d%m%Y %H%M"))
} }
#' Convert input in hour-minute-second format to time #' Convert input in hour-minute-second format to time
#' @param x Input variable #' @param x Input variable
#' @return Time variable of class Period #' @return Time variable of class Period
#' @examples #' @examples
#' as_hms("12:45:00") #' as_hms("12:45:00")
#' \dontrun{ #' \dontrun{
#' as_hms("12:45:00") %>% hour() #' as_hms("12:45:00") %>% hour()
#' as_hms("12:45:00") %>% second() #' as_hms("12:45:00") %>% second()
#' } #' }
#' @export #' @export
as_hms <- function(x) { as_hms <- function(x) {
if (is.factor(x)) x <- as.character(x) if (is.factor(x)) x <- as.character(x)
sshhr(hms(x)) sshhr(hms(x))
} }
#' Convert input in hour-minute format to time #' Convert input in hour-minute format to time
#' @param x Input variable #' @param x Input variable
#' @return Time variable of class Period #' @return Time variable of class Period
#' @examples #' @examples
#' as_hm("12:45") #' as_hm("12:45")
#' \dontrun{ #' \dontrun{
#' as_hm("12:45") %>% minute() #' as_hm("12:45") %>% minute()
#' } #' }
#' @export #' @export
as_hm <- function(x) { as_hm <- function(x) {
if (is.factor(x)) x <- as.character(x) if (is.factor(x)) x <- as.character(x)
sshhr(hm(x)) sshhr(hm(x))
} }
#' Convert variable to integer avoiding potential issues with factors #' Convert variable to integer avoiding potential issues with factors
#' @param x Input variable #' @param x Input variable
#' @return Integer #' @return Integer
#' @examples #' @examples
#' as_integer(rnorm(10)) #' as_integer(rnorm(10))
#' as_integer(letters) #' as_integer(letters)
#' as_integer(as.factor(5:10)) #' as_integer(as.factor(5:10))
#' as.integer(as.factor(5:10)) #' as.integer(as.factor(5:10))
#' as_integer(c("a", "b")) #' as_integer(c("a", "b"))
#' as_integer(c("0", "1")) #' as_integer(c("0", "1"))
#' as_integer(as.factor(c("0", "1"))) #' as_integer(as.factor(c("0", "1")))
#' #'
#' @export #' @export
as_integer <- function(x) { as_integer <- function(x) {
if (is.factor(x)) { if (is.factor(x)) {
int <- sshhr(levels(x) %>% .[x] %>% as.integer()) int <- sshhr(levels(x) %>% .[x] %>% as.integer())
if (length(na.omit(int)) == 0) as.integer(x) else int if (length(na.omit(int)) == 0) as.integer(x) else int
} else if (is.character(x)) { } else if (is.character(x)) {
int <- sshhr(as.integer(x)) int <- sshhr(as.integer(x))
if (length(na.omit(int)) == 0) as_integer(as.factor(x)) else int if (length(na.omit(int)) == 0) as_integer(as.factor(x)) else int
} else { } else {
as.integer(x) as.integer(x)
} }
} }
#' Convert variable to numeric avoiding potential issues with factors #' Convert variable to numeric avoiding potential issues with factors
#' @param x Input variable #' @param x Input variable
#' @return Numeric #' @return Numeric
#' @examples #' @examples
#' as_numeric(rnorm(10)) #' as_numeric(rnorm(10))
#' as_numeric(letters) #' as_numeric(letters)
#' as_numeric(as.factor(5:10)) #' as_numeric(as.factor(5:10))
#' as.numeric(as.factor(5:10)) #' as.numeric(as.factor(5:10))
#' as_numeric(c("a", "b")) #' as_numeric(c("a", "b"))
#' as_numeric(c("3", "4")) #' as_numeric(c("3", "4"))
#' as_numeric(as.factor(c("3", "4"))) #' as_numeric(as.factor(c("3", "4")))
#' #'
#' @export #' @export
as_numeric <- function(x) { as_numeric <- function(x) {
if (is.factor(x)) { if (is.factor(x)) {
num <- sshhr(levels(x) %>% .[x] %>% as.numeric()) num <- sshhr(levels(x) %>% .[x] %>% as.numeric())
if (length(na.omit(num)) == 0) as.numeric(x) else num if (length(na.omit(num)) == 0) as.numeric(x) else num
} else if (is.character(x)) { } else if (is.character(x)) {
num <- sshhr(as.numeric(x)) num <- sshhr(as.numeric(x))
if (length(na.omit(num)) == 0) as_numeric(as.factor(x)) else num if (length(na.omit(num)) == 0) as_numeric(as.factor(x)) else num
} else { } else {
as.numeric(x) as.numeric(x)
} }
} }
#' Wrapper for factor with ordered = FALSE #' Wrapper for factor with ordered = FALSE
#' @param x Input vector #' @param x Input vector
#' @param ordered Order factor levels (TRUE, FALSE) #' @param ordered Order factor levels (TRUE, FALSE)
#' @export #' @export
as_factor <- function(x, ordered = FALSE) factor(x, ordered = ordered) as_factor <- function(x, ordered = FALSE) factor(x, ordered = ordered)
#' Wrapper for as.character #' Wrapper for as.character
#' @param x Input vector #' @param x Input vector
#' @export #' @export
as_character <- function(x) as.character(x) as_character <- function(x) as.character(x)
#' Wrapper for lubridate's as.duration function. Result converted to numeric #' Wrapper for lubridate's as.duration function. Result converted to numeric
#' @param x Time difference #' @param x Time difference
#' @export #' @export
as_duration <- function(x) as.numeric(lubridate::as.duration(x)) as_duration <- function(x) as.numeric(lubridate::as.duration(x))
#' Distance in kilometers or miles between two locations based on lat-long #' Distance in kilometers or miles between two locations based on lat-long
#' Function based on \url{http://www.movable-type.co.uk/scripts/latlong.html}. Uses the haversine formula #' Function based on \url{http://www.movable-type.co.uk/scripts/latlong.html}. Uses the haversine formula
#' @param long1 Longitude of location 1 #' @param long1 Longitude of location 1
#' @param lat1 Latitude of location 1 #' @param lat1 Latitude of location 1
#' @param long2 Longitude of location 2 #' @param long2 Longitude of location 2
#' @param lat2 Latitude of location 2 #' @param lat2 Latitude of location 2
#' @param unit Measure kilometers ("km", default) or miles ("miles") #' @param unit Measure kilometers ("km", default) or miles ("miles")
#' @param R Radius of the earth #' @param R Radius of the earth
#' @return Distance between two points #' @return Distance between two points
#' @examples #' @examples
#' as_distance(32.8245525, -117.0951632, 40.7033127, -73.979681, unit = "km") #' as_distance(32.8245525, -117.0951632, 40.7033127, -73.979681, unit = "km")
#' as_distance(32.8245525, -117.0951632, 40.7033127, -73.979681, unit = "miles") #' as_distance(32.8245525, -117.0951632, 40.7033127, -73.979681, unit = "miles")
#' #'
#' @export #' @export
as_distance <- function(lat1, long1, lat2, long2, as_distance <- function(lat1, long1, lat2, long2,
unit = "km", R = c("km" = 6371, "miles" = 3959)[[unit]]) { unit = "km", R = c("km" = 6371, "miles" = 3959)[[unit]]) {
rad <- pi / 180 rad <- pi / 180
d1 <- lat1 * rad d1 <- lat1 * rad
d2 <- lat2 * rad d2 <- lat2 * rad
dlat <- (lat2 - lat1) * rad dlat <- (lat2 - lat1) * rad
dlong <- (long2 - long1) * rad dlong <- (long2 - long1) * rad
a <- sin(dlat / 2)^2 + cos(d1) * cos(d2) * sin(dlong / 2)^2 a <- sin(dlat / 2)^2 + cos(d1) * cos(d2) * sin(dlong / 2)^2
c <- 2 * atan2(sqrt(a), sqrt(1 - a)) c <- 2 * atan2(sqrt(a), sqrt(1 - a))
R * c R * c
} }
#' Generate a variable used to selected a training sample #' Generate a variable used to selected a training sample
#' @param n Number (or fraction) of observations to label as training #' @param n Number (or fraction) of observations to label as training
#' @param nr Number of rows in the dataset #' @param nr Number of rows in the dataset
#' @param blocks A vector to use for blocking or a data.frame from which to construct a blocking vector #' @param blocks A vector to use for blocking or a data.frame from which to construct a blocking vector
#' @param seed Random seed #' @param seed Random seed
#' #'
#' @return 0/1 variables for filtering #' @return 0/1 variables for filtering
#' #'
#' @importFrom randomizr complete_ra block_ra #' @importFrom randomizr complete_ra block_ra
#' #'
#' @examples #' @examples
#' make_train(.5, 10) #' make_train(.5, 10)
#' make_train(.5, 10) %>% table() #' make_train(.5, 10) %>% table()
#' make_train(100, 1000) %>% table() #' make_train(100, 1000) %>% table()
#' make_train(.15, blocks = mtcars$vs) %>% table() / nrow(mtcars) #' make_train(.15, blocks = mtcars$vs) %>% table() / nrow(mtcars)
#' make_train(.10, blocks = iris$Species) %>% table() / nrow(iris) #' make_train(.10, blocks = iris$Species) %>% table() / nrow(iris)
#' make_train(.5, blocks = iris[, c("Petal.Width", "Species")]) %>% table() #' make_train(.5, blocks = iris[, c("Petal.Width", "Species")]) %>% table()
#' #'
#' @export #' @export
make_train <- function(n = .7, nr = NULL, blocks = NULL, seed = 1234) { make_train <- function(n = .7, nr = NULL, blocks = NULL, seed = 1234) {
seed <- gsub("[^0-9]", "", seed) seed <- gsub("[^0-9]", "", seed)
if (!is.empty(seed)) set.seed(seed) if (!is.empty(seed)) set.seed(seed)
if (is.empty(nr) && is.empty(blocks)) { if (is.empty(nr) && is.empty(blocks)) {
stop("Please provided the number of rows in the data (nr) or a vector with blocking information (blocks)") stop("Please provided the number of rows in the data (nr) or a vector with blocking information (blocks)")
} else if (is.data.frame(blocks)) { } else if (is.data.frame(blocks)) {
blocks <- do.call(paste, c(blocks, sep = "-")) blocks <- do.call(paste, c(blocks, sep = "-"))
nr <- length(blocks) nr <- length(blocks)
} else if (is.vector(blocks)) { } else if (is.vector(blocks)) {
nr <- length(blocks) nr <- length(blocks)
} }
if (n > 1) n <- n / nr if (n > 1) n <- n / nr
if (length(blocks) > 0) { if (length(blocks) > 0) {
randomizr::block_ra(blocks, prob = n) randomizr::block_ra(blocks, prob = n)
} else { } else {
randomizr::complete_ra(N = nr, prob = n) randomizr::complete_ra(N = nr, prob = n)
} }
} }
#' Add transformed variables to a data frame with the option to include a custom variable name extension #' Add transformed variables to a data frame with the option to include a custom variable name extension
#' #'
#' @details Wrapper for dplyr::mutate_at that allows custom variable name extensions #' @details Wrapper for dplyr::mutate_at that allows custom variable name extensions
#' #'
#' @param .tbl Data frame to add transformed variables to #' @param .tbl Data frame to add transformed variables to
#' @param .funs Function(s) to apply (e.g., log) #' @param .funs Function(s) to apply (e.g., log)
#' @param ... Variables to transform #' @param ... Variables to transform
#' @param .ext Extension to add for each variable #' @param .ext Extension to add for each variable
#' @param .vars A list of columns generated by dplyr::vars(), or a character vector of column names, or a numeric vector of column positions. #' @param .vars A list of columns generated by dplyr::vars(), or a character vector of column names, or a numeric vector of column positions.
#' #'
#' @examples #' @examples
#' mutate_ext(mtcars, .funs = log, mpg, cyl, .ext = "_ln") #' mutate_ext(mtcars, .funs = log, mpg, cyl, .ext = "_ln")
#' mutate_ext(mtcars, .funs = log, .ext = "_ln") #' mutate_ext(mtcars, .funs = log, .ext = "_ln")
#' mutate_ext(mtcars, .funs = log) #' mutate_ext(mtcars, .funs = log)
#' mutate_ext(mtcars, .funs = log, .ext = "_ln", .vars = vars(mpg, cyl)) #' mutate_ext(mtcars, .funs = log, .ext = "_ln", .vars = vars(mpg, cyl))
#' #'
#' @export #' @export
mutate_ext <- function(.tbl, .funs, ..., .ext = "", .vars = c()) { mutate_ext <- function(.tbl, .funs, ..., .ext = "", .vars = c()) {
if (length(.vars) == 0) { if (length(.vars) == 0) {
## from https://stackoverflow.com/a/35317870/1974918 ## from https://stackoverflow.com/a/35317870/1974918
.vars <- sapply(substitute(list(...))[-1], deparse) .vars <- sapply(substitute(list(...))[-1], deparse)
if (length(.vars) == 0) { if (length(.vars) == 0) {
.vars <- colnames(.tbl) .vars <- colnames(.tbl)
} }
} }
if (is.empty(.ext)) { if (is.empty(.ext)) {
dplyr::mutate_at(.tbl, .vars = .vars, .funs = .funs) %>% dplyr::mutate_at(.tbl, .vars = .vars, .funs = .funs) %>%
set_rownames(rownames(.tbl)) set_rownames(rownames(.tbl))
} else { } else {
new <- gsub("^~", "", .vars) %>% paste0(., .ext) new <- gsub("^~", "", .vars) %>% paste0(., .ext)
.tbl[, new] <- transmute_at(.tbl, .vars = .vars, .funs = .funs) %>% .tbl[, new] <- transmute_at(.tbl, .vars = .vars, .funs = .funs) %>%
set_colnames(new) set_colnames(new)
.tbl .tbl
} }
} }
#' Split a numeric variable into a number of bins and return a vector of bin numbers #' Split a numeric variable into a number of bins and return a vector of bin numbers
#' #'
#' @param x Numeric variable #' @param x Numeric variable
#' @param n number of bins to create #' @param n number of bins to create
#' @param rev Reverse the order of the bin numbers #' @param rev Reverse the order of the bin numbers
#' @param type An integer between 1 and 9 to select one of the quantile algorithms described in the help for the stats::quantile function #' @param type An integer between 1 and 9 to select one of the quantile algorithms described in the help for the stats::quantile function
#' #'
#' @seealso See \link[stats]{quantile} for a description of the different algorithm types #' @seealso See \link[stats]{quantile} for a description of the different algorithm types
#' #'
#' @examples #' @examples
#' xtile(1:10, 5) #' xtile(1:10, 5)
#' xtile(1:10, 5, rev = TRUE) #' xtile(1:10, 5, rev = TRUE)
#' xtile(c(rep(1, 6), 7:10), 5) #' xtile(c(rep(1, 6), 7:10), 5)
#' #'
#' @export #' @export
xtile <- function(x, n = 5, rev = FALSE, type = 7) { xtile <- function(x, n = 5, rev = FALSE, type = 7) {
if (!is.numeric(x)) { if (!is.numeric(x)) {
stop(paste0("The variable to bin must be of type {numeric} but is of type {", class(x)[1], "}"), call. = FALSE) stop(paste0("The variable to bin must be of type {numeric} but is of type {", class(x)[1], "}"), call. = FALSE)
} else if (n < 1) { } else if (n < 1) {
stop(paste0("The number of bins must be > 1 but is ", n), call. = FALSE) stop(paste0("The number of bins must be > 1 but is ", n), call. = FALSE)
} else if (length(x) < n) { } else if (length(x) < n) {
stop(paste("The number of bins to create is larger than\nthe number of data points. Perhaps you grouped the data before\ncalling the xtile function and the number of observations per\ngroup is too small"), call. = FALSE) stop(paste("The number of bins to create is larger than\nthe number of data points. Perhaps you grouped the data before\ncalling the xtile function and the number of observations per\ngroup is too small"), call. = FALSE)
} else if (type < 1 || type > 9) { } else if (type < 1 || type > 9) {
stop(paste("The value for type is", type, "but must be between 1 and 9"), call. = FALSE) stop(paste("The value for type is", type, "but must be between 1 and 9"), call. = FALSE)
} }
breaks <- quantile(x, prob = seq(0, 1, length = n + 1), na.rm = TRUE, type = type) breaks <- quantile(x, prob = seq(0, 1, length = n + 1), na.rm = TRUE, type = type)
if (length(breaks) < 2) stop(paste("Insufficient variation in x to construct", n, "breaks"), call. = FALSE) if (length(breaks) < 2) stop(paste("Insufficient variation in x to construct", n, "breaks"), call. = FALSE)
bins <- .bincode(x, breaks, include.lowest = TRUE) bins <- .bincode(x, breaks, include.lowest = TRUE)
if (rev) as.integer((n + 1) - bins) else bins if (rev) as.integer((n + 1) - bins) else bins
} }
#' Show all rows with duplicated values (not just the first or last) #' Show all rows with duplicated values (not just the first or last)
#' #'
#' @details If an entire row is duplicated use "duplicated" to show only one of the duplicated rows. When using a subset of variables to establish uniqueness it may be of interest to show all rows that have (some) duplicate elements #' @details If an entire row is duplicated use "duplicated" to show only one of the duplicated rows. When using a subset of variables to establish uniqueness it may be of interest to show all rows that have (some) duplicate elements
#' #'
#' @param .tbl Data frame to add transformed variables to #' @param .tbl Data frame to add transformed variables to
#' @param ... Variables used to evaluate row uniqueness #' @param ... Variables used to evaluate row uniqueness
#' #'
#' @examples #' @examples
#' bind_rows(mtcars, mtcars[c(1, 5, 7), ]) %>% #' bind_rows(mtcars, mtcars[c(1, 5, 7), ]) %>%
#' show_duplicated(mpg, cyl) #' show_duplicated(mpg, cyl)
#' bind_rows(mtcars, mtcars[c(1, 5, 7), ]) %>% #' bind_rows(mtcars, mtcars[c(1, 5, 7), ]) %>%
#' show_duplicated() #' show_duplicated()
#' #'
#' @export #' @export
show_duplicated <- function(.tbl, ...) { show_duplicated <- function(.tbl, ...) {
.vars <- sapply(substitute(list(...))[-1], deparse) .vars <- sapply(substitute(list(...))[-1], deparse)
if (length(.vars) == 0 || length(unique(.vars)) == ncol(.tbl)) { if (length(.vars) == 0 || length(unique(.vars)) == ncol(.tbl)) {
filter(.tbl, duplicated(.tbl)) filter(.tbl, duplicated(.tbl))
} else { } else {
.tbl %>% .tbl %>%
group_by_at(.vars = .vars) %>% group_by_at(.vars = .vars) %>%
filter(n() > 1) %>% filter(n() > 1) %>%
mutate(nr_dup = 1:n()) %>% mutate(nr_dup = 1:n()) %>%
arrange_at(.vars = .vars) %>% arrange_at(.vars = .vars) %>%
ungroup() ungroup()
} }
} }
#' Weighted standard deviation #' Weighted standard deviation
#' #'
#' @details Calculate weighted standard deviation #' @details Calculate weighted standard deviation
#' #'
#' @param x Numeric vector #' @param x Numeric vector
#' @param wt Numeric vector of weights #' @param wt Numeric vector of weights
#' @param na.rm Remove missing values (default is TRUE) #' @param na.rm Remove missing values (default is TRUE)
#' #'
#' @export #' @export
weighted.sd <- function(x, wt, na.rm = TRUE) { weighted.sd <- function(x, wt, na.rm = TRUE) {
if (na.rm) { if (na.rm) {
ind <- is.na(x) | is.na(wt) ind <- is.na(x) | is.na(wt)
x <- x[!ind] x <- x[!ind]
wt <- wt[!ind] wt <- wt[!ind]
} }
wt <- wt / sum(wt) wt <- wt / sum(wt)
wm <- weighted.mean(x, wt) wm <- weighted.mean(x, wt)
sqrt(sum(wt * (x - wm)^2)) sqrt(sum(wt * (x - wm)^2))
} }
#' Create data.frame summary #' Create data.frame summary
#' #'
#' @details Used in Radiant's Data > Transform tab #' @details Used in Radiant's Data > Transform tab
#' #'
#' @param dataset Data.frame #' @param dataset Data.frame
#' @param dc Class for each variable #' @param dc Class for each variable
#' @param dec Number of decimals to show #' @param dec Number of decimals to show
#' #'
#' @export #' @export
get_summary <- function(dataset, dc = get_class(dataset), dec = 3) { get_summary <- function(dataset, dc = get_class(dataset), dec = 3) {
isFct <- "factor" == dc isFct <- "factor" == dc
isNum <- dc %in% c("numeric", "integer", "Duration") isNum <- dc %in% c("numeric", "integer", "Duration")
isDate <- "date" == dc isDate <- "date" == dc
isChar <- "character" == dc isChar <- "character" == dc
isLogic <- "logical" == dc isLogic <- "logical" == dc
isPeriod <- "period" == dc isPeriod <- "period" == dc
isTs <- "ts" == dc isTs <- "ts" == dc
if (sum(isNum) > 0) { if (sum(isNum) > 0) {
cn <- names(dc)[isNum] cn <- names(dc)[isNum]
cat("Summarize numeric variables:\n") cat("Summarize numeric variables:\n")
select(dataset, which(isNum)) %>% select(dataset, which(isNum)) %>%
gather("variable", "values", !!cn, factor_key = TRUE) %>% gather("variable", "values", !!cn, factor_key = TRUE) %>%
group_by_at(.vars = "variable") %>% group_by_at(.vars = "variable") %>%
summarise_all( summarise_all(
list( list(
n_obs = n_obs, n_obs = n_obs,
n_missing = n_missing, n_missing = n_missing,
n_distinct = n_distinct, n_distinct = n_distinct,
mean = mean, mean = mean,
median = median, median = median,
min = min, min = min,
max = max, max = max,
p25 = p25, p25 = p25,
p75 = p75, p75 = p75,
sd = sd, sd = sd,
se = se se = se
), ),
na.rm = TRUE na.rm = TRUE
) %>% ) %>%
data.frame(check.names = FALSE, stringsAsFactors = FALSE) %>% data.frame(check.names = FALSE, stringsAsFactors = FALSE) %>%
format_df(dec = dec, mark = ",") %>% format_df(dec = dec, mark = ",") %>%
set_colnames(c("", colnames(.)[-1])) %>% set_colnames(c("", colnames(.)[-1])) %>%
print(row.names = FALSE) print(row.names = FALSE)
cat("\n") cat("\n")
} }
if (sum(isTs) > 0) { if (sum(isTs) > 0) {
cn <- names(dc)[isTs] cn <- names(dc)[isTs]
cat("Summarize time-series variables:\n") cat("Summarize time-series variables:\n")
lapply( lapply(
select(dataset, which(isTs)), select(dataset, which(isTs)),
function(x) { function(x) {
as.data.frame(x) %>% as.data.frame(x) %>%
summarise_all( summarise_all(
list( list(
n_obs = n_obs, n_obs = n_obs,
n_missing = n_missing, n_missing = n_missing,
n_distinct = n_distinct, n_distinct = n_distinct,
mean = mean, mean = mean,
median = median, median = median,
min = min, min = min,
max = max, max = max,
start = ~ attr(., "tsp")[1] %>% round(dec), start = ~ attr(., "tsp")[1] %>% round(dec),
end = ~ attr(., "tsp")[2] %>% round(dec), end = ~ attr(., "tsp")[2] %>% round(dec),
frequency = ~ attr(., "tsp")[3] %>% as.integer() frequency = ~ attr(., "tsp")[3] %>% as.integer()
), ),
na.rm = TRUE na.rm = TRUE
) )
} }
) %>% ) %>%
bind_rows() %>% bind_rows() %>%
data.frame(check.names = FALSE, stringsAsFactors = FALSE) %>% data.frame(check.names = FALSE, stringsAsFactors = FALSE) %>%
data.frame(.vars = cn, .) %>% data.frame(.vars = cn, .) %>%
format_df(dec = 3, mark = ",") %>% format_df(dec = 3, mark = ",") %>%
set_colnames(c("", colnames(.)[-1])) %>% set_colnames(c("", colnames(.)[-1])) %>%
print(row.names = FALSE) print(row.names = FALSE)
cat("\n") cat("\n")
} }
if (sum(isFct) > 0) { if (sum(isFct) > 0) {
cat("Summarize factors:\n") cat("Summarize factors:\n")
select(dataset, which(isFct)) %>% select(dataset, which(isFct)) %>%
summary(maxsum = 20) %>% summary(maxsum = 20) %>%
print() print()
cat("\n") cat("\n")
} }
if (sum(isDate) > 0) { if (sum(isDate) > 0) {
cat("Earliest dates:\n") cat("Earliest dates:\n")
select(dataset, which(isDate)) %>% select(dataset, which(isDate)) %>%
summarise_all(min) %>% summarise_all(min) %>%
as.data.frame(stringsAsFactors = FALSE) %>% as.data.frame(stringsAsFactors = FALSE) %>%
print(row.names = FALSE) print(row.names = FALSE)
cat("\nFinal dates:\n") cat("\nFinal dates:\n")
select(dataset, which(isDate)) %>% select(dataset, which(isDate)) %>%
summarise_all(max) %>% summarise_all(max) %>%
as.data.frame(stringsAsFactors = FALSE) %>% as.data.frame(stringsAsFactors = FALSE) %>%
print(row.names = FALSE) print(row.names = FALSE)
cat("\n") cat("\n")
} }
if (sum(isPeriod) > 0) { if (sum(isPeriod) > 0) {
max_time <- function(x) sort(x) %>% tail(1) max_time <- function(x) sort(x) %>% tail(1)
min_time <- function(x) sort(x) %>% head(1) min_time <- function(x) sort(x) %>% head(1)
cat("Earliest time:\n") cat("Earliest time:\n")
select(dataset, which(isPeriod)) %>% select(dataset, which(isPeriod)) %>%
summarise_all(min_time) %>% summarise_all(min_time) %>%
as.data.frame(stringsAsFactors = FALSE) %>% as.data.frame(stringsAsFactors = FALSE) %>%
print(row.names = FALSE) print(row.names = FALSE)
cat("\nFinal time:\n") cat("\nFinal time:\n")
select(dataset, which(isPeriod)) %>% select(dataset, which(isPeriod)) %>%
summarise_all(max_time) %>% summarise_all(max_time) %>%
as.data.frame(stringsAsFactors = FALSE) %>% as.data.frame(stringsAsFactors = FALSE) %>%
print(row.names = FALSE) print(row.names = FALSE)
cat("\n") cat("\n")
} }
if (sum(isChar) > 0) { if (sum(isChar) > 0) {
## finding unique elements can be slow for large files ## finding unique elements can be slow for large files
if (nrow(dataset) < 10^5) { if (nrow(dataset) < 10^5) {
cat("Summarize character variables (< 20 unique values shown):\n") cat("Summarize character variables (< 20 unique values shown):\n")
select(dataset, which(isChar)) %>% select(dataset, which(isChar)) %>%
lapply(unique) %>% lapply(unique) %>%
(function(x) { (function(x) {
for (i in names(x)) { for (i in names(x)) {
cat(i, paste0("(n_distinct ", length(x[[i]]), "): "), x[[i]][1:min(20, length(x[[i]]))], "\n") cat(i, paste0("(n_distinct ", length(x[[i]]), "): "), x[[i]][1:min(20, length(x[[i]]))], "\n")
} }
}) })
} else { } else {
cat("Summarize character variables (< 20 values shown):\n") cat("Summarize character variables (< 20 values shown):\n")
select(dataset, which(isChar)) %>% select(dataset, which(isChar)) %>%
(function(x) { (function(x) {
for (i in names(x)) { for (i in names(x)) {
cat(i, ":", x[[i]][1:min(20, length(x[[i]]))], "\n") cat(i, ":", x[[i]][1:min(20, length(x[[i]]))], "\n")
} }
}) })
} }
cat("\n") cat("\n")
} }
if (sum(isLogic) > 0) { if (sum(isLogic) > 0) {
cat("Summarize logical variables:\n") cat("Summarize logical variables:\n")
select(dataset, which(isLogic)) %>% select(dataset, which(isLogic)) %>%
summarise_all(list(x = ~ sum(., na.rm = TRUE), y = ~ mean(., na.rm = TRUE), z = ~ n_missing(.))) %>% summarise_all(list(x = ~ sum(., na.rm = TRUE), y = ~ mean(., na.rm = TRUE), z = ~ n_missing(.))) %>%
round(dec) %>% round(dec) %>%
matrix(ncol = 3) %>% matrix(ncol = 3) %>%
as.data.frame(stringsAsFactors = FALSE) %>% as.data.frame(stringsAsFactors = FALSE) %>%
set_colnames(c("# TRUE", "% TRUE", "n_missing")) %>% set_colnames(c("# TRUE", "% TRUE", "n_missing")) %>%
set_rownames(names(dataset)[isLogic]) %>% set_rownames(names(dataset)[isLogic]) %>%
format(big.mark = ",", scientific = FALSE) %>% format(big.mark = ",", scientific = FALSE) %>%
print() print()
cat("\n") cat("\n")
} }
} }
#' Create data.frame from a table #' Create data.frame from a table
#' #'
#' @param dataset Data.frame #' @param dataset Data.frame
#' @param freq Column name with frequency information #' @param freq Column name with frequency information
#' #'
#' @examples #' @examples
#' data.frame(price = c("$200", "$300"), sale = c(10, 2)) %>% table2data() #' data.frame(price = c("$200", "$300"), sale = c(10, 2)) %>% table2data()
#' #'
#' @export #' @export
table2data <- function(dataset, freq = tail(colnames(dataset), 1)) { table2data <- function(dataset, freq = tail(colnames(dataset), 1)) {
if (!is.numeric(dataset[[freq]])) stop("The frequency variable must be numeric", call = FALSE) if (!is.numeric(dataset[[freq]])) stop("The frequency variable must be numeric", call = FALSE)
blowup <- function(i) { blowup <- function(i) {
if (!is.na(dataset[[freq]][i])) dataset[rep(i, each = dataset[[freq]][i]), ] if (!is.na(dataset[[freq]][i])) dataset[rep(i, each = dataset[[freq]][i]), ]
} }
lapply(seq_len(nrow(dataset)), blowup) %>% lapply(seq_len(nrow(dataset)), blowup) %>%
bind_rows() %>% bind_rows() %>%
select_at(.vars = base::setdiff(colnames(dataset), freq)) %>% select_at(.vars = base::setdiff(colnames(dataset), freq)) %>%
mutate_all(as.factor) mutate_all(as.factor)
} }
#' Generate list of levels and unique values #' Generate list of levels and unique values
#' #'
#' @param dataset A data.frame #' @param dataset A data.frame
#' @param ... Unquoted variable names to evaluate #' @param ... Unquoted variable names to evaluate
#' #'
#' @examples #' @examples
#' data.frame(a = c(rep("a", 5), rep("b", 5)), b = c(rep(1, 5), 6:10)) %>% level_list() #' data.frame(a = c(rep("a", 5), rep("b", 5)), b = c(rep(1, 5), 6:10)) %>% level_list()
#' level_list(mtcars, mpg, cyl) #' level_list(mtcars, mpg, cyl)
#' #'
#' @export #' @export
level_list <- function(dataset, ...) { level_list <- function(dataset, ...) {
fl <- function(x) { fl <- function(x) {
if ("factor" %in% class(x)) { if ("factor" %in% class(x)) {
levels(x) levels(x)
} else { } else {
unique(x) unique(x)
} }
} }
.vars <- sapply(substitute(list(...))[-1], deparse) .vars <- sapply(substitute(list(...))[-1], deparse)
if (length(.vars) > 0) { if (length(.vars) > 0) {
lapply(select_at(dataset, .vars = .vars), fl) lapply(select_at(dataset, .vars = .vars), fl)
} else { } else {
lapply(dataset, fl) lapply(dataset, fl)
} }
} }
#' Add ordered argument to lubridate::month #' Add ordered argument to lubridate::month
#' @param x Input date vector #' @param x Input date vector
#' @param label Month as label (TRUE, FALSE) #' @param label Month as label (TRUE, FALSE)
#' @param abbr Abbreviate label (TRUE, FALSE) #' @param abbr Abbreviate label (TRUE, FALSE)
#' @param ordered Order factor (TRUE, FALSE) #' @param ordered Order factor (TRUE, FALSE)
#' #'
#' @importFrom lubridate month #' @importFrom lubridate month
#' #'
#' @seealso See the \code{\link[lubridate]{month}} function in the lubridate package for additional details #' @seealso See the \code{\link[lubridate]{month}} function in the lubridate package for additional details
#' #'
#' @export #' @export
month <- function(x, label = FALSE, abbr = TRUE, ordered = FALSE) { month <- function(x, label = FALSE, abbr = TRUE, ordered = FALSE) {
x <- lubridate::month(x, label = label, abbr = abbr) x <- lubridate::month(x, label = label, abbr = abbr)
if (!ordered && label) { if (!ordered && label) {
factor(x, ordered = FALSE) factor(x, ordered = FALSE)
} else { } else {
x x
} }
} }
#' Add ordered argument to lubridate::wday #' Add ordered argument to lubridate::wday
#' @param x Input date vector #' @param x Input date vector
#' @param label Weekday as label (TRUE, FALSE) #' @param label Weekday as label (TRUE, FALSE)
#' @param abbr Abbreviate label (TRUE, FALSE) #' @param abbr Abbreviate label (TRUE, FALSE)
#' @param ordered Order factor (TRUE, FALSE) #' @param ordered Order factor (TRUE, FALSE)
#' #'
#' @importFrom lubridate wday #' @importFrom lubridate wday
#' #'
#' @seealso See the \code{\link[lubridate:day]{lubridate::wday()}} function in the lubridate package for additional details #' @seealso See the \code{\link[lubridate:day]{lubridate::wday()}} function in the lubridate package for additional details
#' #'
#' @export #' @export
wday <- function(x, label = FALSE, abbr = TRUE, ordered = FALSE) { wday <- function(x, label = FALSE, abbr = TRUE, ordered = FALSE) {
x <- lubridate::wday(x, label = label, abbr = abbr) x <- lubridate::wday(x, label = label, abbr = abbr)
if (!ordered && label) { if (!ordered && label) {
factor(x, ordered = FALSE) factor(x, ordered = FALSE)
} else { } else {
x x
} }
} }
#' Remove/reorder levels #' Remove/reorder levels
#' @details Keep only a specific set of levels in a factor. By removing levels the base for comparison in, e.g., regression analysis, becomes the first level. To relabel the base use, for example, repl = 'other' #' @details Keep only a specific set of levels in a factor. By removing levels the base for comparison in, e.g., regression analysis, becomes the first level. To relabel the base use, for example, repl = 'other'
#' @param x Character or Factor #' @param x Character or Factor
#' @param levs Set of levels to use #' @param levs Set of levels to use
#' @param repl String (or NA) used to replace missing levels #' @param repl String (or NA) used to replace missing levels
#' #'
#' @examples #' @examples
#' refactor(diamonds$cut, c("Premium", "Ideal")) %>% head() #' refactor(diamonds$cut, c("Premium", "Ideal")) %>% head()
#' refactor(diamonds$cut, c("Premium", "Ideal"), "Other") %>% head() #' refactor(diamonds$cut, c("Premium", "Ideal"), "Other") %>% head()
#' #'
#' @export #' @export
refactor <- function(x, levs = levels(x), repl = NA) { refactor <- function(x, levs = levels(x), repl = NA) {
if (is.factor(x)) { if (is.factor(x)) {
lv <- levels(x) lv <- levels(x)
} else { } else {
lv <- unique(x) lv <- unique(x)
if (length(levs) == 0) levs <- lv if (length(levs) == 0) levs <- lv
} }
if (length(levs) > 0 && length(lv) > length(levs)) { if (length(levs) > 0 && length(lv) > length(levs)) {
if (!is.empty(repl)) levs <- unique(c(repl, levs)) if (!is.empty(repl)) levs <- unique(c(repl, levs))
x <- as_character(x) %>% ifelse(. %in% base::setdiff(lv, levs), repl, .) x <- as_character(x) %>% ifelse(. %in% base::setdiff(lv, levs), repl, .)
} }
factor(x, levels = levs) factor(x, levels = levs)
} }
#' Convert a string of numbers into a vector #' Convert a string of numbers into a vector
#' #'
#' @param x A string of numbers that may include fractions #' @param x A string of numbers that may include fractions
#' #'
#' @importFrom MASS fractions #' @importFrom MASS fractions
#' #'
#' @examples #' @examples
#' make_vec("1 2 4") #' make_vec("1 2 4")
#' make_vec("1/2 2/3 4/5") #' make_vec("1/2 2/3 4/5")
#' make_vec(0.1) #' make_vec(0.1)
#' @export #' @export
make_vec <- function(x) { make_vec <- function(x) {
if (is.empty(x)) { if (is.empty(x)) {
return(NULL) return(NULL)
} else if (!is.character(x)) { } else if (!is.character(x)) {
return(x) return(x)
} }
any_frac <- FALSE any_frac <- FALSE
check_frac <- function(x) { check_frac <- function(x) {
if (length(x) == 2) { if (length(x) == 2) {
any_frac <<- TRUE any_frac <<- TRUE
as.numeric(x[1]) / as.numeric(x[2]) as.numeric(x[1]) / as.numeric(x[2])
} else { } else {
as.numeric(x) as.numeric(x)
} }
} }
x <- strsplit(x, "(\\s*,\\s*|\\s*;\\s*|\\s+)") %>% x <- strsplit(x, "(\\s*,\\s*|\\s*;\\s*|\\s+)") %>%
unlist() %>% unlist() %>%
strsplit("\\s*/\\s*") %>% strsplit("\\s*/\\s*") %>%
sapply(check_frac) sapply(check_frac)
if (any_frac) { if (any_frac) {
MASS::fractions(x) MASS::fractions(x)
} else { } else {
x x
} }
} }
############################### ###############################
## function below not exported ## function below not exported
############################### ###############################
.recode. <- function(x, cmd) car::Recode(x, cmd) .recode. <- function(x, cmd) car::Recode(x, cmd)
\ No newline at end of file
radiant.data/inst/app/server.R
View file @ 1017104c
shinyServer(function(input, output, session) { shinyServer(function(input, output, session) {
enc <- getOption("radiant.encoding", "UTF-8") enc <- getOption("radiant.encoding", "UTF-8")
## source shared functions ## source shared functions
source("init.R", encoding = enc, local = TRUE) source("init.R", encoding = enc, local = TRUE)
source("radiant.R", encoding = enc, local = TRUE) source("radiant.R", encoding = enc, local = TRUE)
## packages to use for example data ## packages to use for example data
options(radiant.example.data = "radiant.data") options(radiant.example.data = "radiant.data")
## source data & analysis tools ## source data & analysis tools
for (file in list.files(c("tools/app", "tools/data"), pattern = "\\.(r|R)$", full.names = TRUE)) { for (file in list.files(c("tools/app", "tools/data"), pattern = "\\.(r|R)$", full.names = TRUE)) {
source(file, encoding = enc, local = TRUE) source(file, encoding = enc, local = TRUE)
} }
# ============================================================
# [新增功能] 企业级集成：Token鉴权 + 环境变量 + 自动加载
# ============================================================
observe({
# 1. 解析 URL 参数
query <- parseQueryString(session$clientData$url_search)
dataset_id <- query[['datasetId']]
token <- query[['token']]
# 2. 仅当 ID 和 Token 均存在时执行
if (!is.null(dataset_id) && !is.null(token)) {
# 定义 Radiant 内部使用的数据集名称 (例如: data_10086)
# 如果 URL 传了 name 参数就用 name，否则用 id 拼接
ds_name <- if (!is.null(query[['name']])) query[['name']] else paste0("data_", dataset_id)
# 3. 检查数据是否已存在 (防止重复加载)
if (is.null(r_data[[ds_name]])) {
withProgress(message = '正在从业务系统同步数据...', value = 0.2, {
# 4. 获取环境变量中的 API 基地址
api_base <- Sys.getenv("HOST_API_BASE","http://127.0.0.1:11999")
# 5. 拼接完整 API 路径
target_url <- paste0(api_base, "/disease-data/data/export/apply/apply/case?applyId=", dataset_id)
# 6. 创建临时文件 (明确 .xlsx 后缀)
tmp_file <- tempfile(fileext = ".xlsx")
tryCatch({
incProgress(0.3, detail = "正在鉴权并下载...")
# 7. 发起带 Token 的 HTTP 请求
response <- httr::POST(
url = target_url,
# 添加 Bearer Token (或根据你的接口要求修改 Header)
httr::add_headers(Authorization = paste("Bearer", token)),
# 将结果写入磁盘
httr::write_disk(tmp_file, overwrite = TRUE)
)
# 检查 HTTP 状态码
if (httr::status_code(response) != 200) {
stop(paste("下载失败，请手动导入，HTTP状态码:", httr::status_code(response)))
}
incProgress(0.7, detail = "解析并导入 Radiant...")
# 8. 复用 Radiant 核心加载函数 (manage_ui.R 中定义)
# 这会自动完成读取、转因子、生成R代码、注册到下拉框等所有动作
load_user_data(
fname = paste0(ds_name, ".xlsx"), # 虚拟文件名
uFile = tmp_file, # 实际文件路径
ext = "xlsx",
xlsx_sheet = 1,
xlsx_header = TRUE,
man_str_as_factor = TRUE
)
# 9. 界面联动：选中数据并跳转到视图
updateSelectInput(session, "dataset", selected = ds_name)
updateTabsetPanel(session, "nav_radiant", selected = "Data")
updateTabsetPanel(session, "tabs_data", selected = "View") # 或者 "Visualize"
showNotification(paste("数据集", ds_name, "加载成功！"), type = "message")
}, error = function(e) {
showNotification(paste("数据同步失败，请手动导入数据:", e$message), type = "error", duration = 10)
#调试打印 print(e)
})
})
}
}
})
# ============================================================
# dataviewer_proxy <- DT::dataTableProxy("dataviewer", session) # dataviewer_proxy <- DT::dataTableProxy("dataviewer", session)
# observe(session$setCurrentTheme( # observe(session$setCurrentTheme(
# if (isTRUE(input$dark_mode)) { # if (isTRUE(input$dark_mode)) {
# bslib::bs_theme(version = 4, bg = "black", fg = "white") # bslib::bs_theme(version = 4, bg = "black", fg = "white")
...@@ -22,7 +101,7 @@ shinyServer(function(input, output, session) { ...@@ -22,7 +101,7 @@ shinyServer(function(input, output, session) {
# bslib::bs_theme(version = 4) # bslib::bs_theme(version = 4)
# } # }
# )) # ))
## save state on refresh or browser close ## save state on refresh or browser close
saveStateOnRefresh(session) saveStateOnRefresh(session)
}) })
radiant.data/inst/app/tools/data/manage_ui.R
View file @ 1017104c
...@@ -50,8 +50,7 @@ output$ui_fileUpload <- renderUI({ ...@@ -50,8 +50,7 @@ output$ui_fileUpload <- renderUI({
) )
} else if (input$dataType == "xlsx") { } else if (input$dataType == "xlsx") {
tagList( tagList(
make_uploadfile(accept = c(".xlsx", ".xls")), make_uploadfile(accept = c(".xlsx", ".xls"))
make_description_uploadfile(accept = c(".md", ".txt"))
) )
} else if (input$dataType == "url_rds") { } else if (input$dataType == "url_rds") {
with(tags, table( with(tags, table(
...@@ -229,11 +228,6 @@ output$ui_Manage <- renderUI({ ...@@ -229,11 +228,6 @@ output$ui_Manage <- renderUI({
), ),
conditionalPanel( conditionalPanel(
"input.dataType == 'xlsx'", "input.dataType == 'xlsx'",
numericInput(
"xlsx_sheet",
label = i18n$t("Sheet index (1-based):"),
value = 1, min = 1, step = 1
),
checkboxInput( checkboxInput(
"xlsx_header", "xlsx_header",
label = i18n$t("First row as header"), label = i18n$t("First row as header"),
...@@ -514,19 +508,42 @@ observeEvent(input$uploadfile, { ...@@ -514,19 +508,42 @@ observeEvent(input$uploadfile, {
withProgress(message = "Loading ...", value = 1, { withProgress(message = "Loading ...", value = 1, {
for (i in 1:nrow(inFile)) { for (i in 1:nrow(inFile)) {
# 区分文件类型，传递对应参数
if (input$dataType == "xlsx") { if (input$dataType == "xlsx") {
# 调用load_user_data，传递xlsx专属参数 uFile <- as.character(inFile[i, "datapath"])
load_user_data( # 获取xlsx文件中所有sheet名称
fname = as.character(inFile[i, "name"]), sheets <- try(readxl::excel_sheets(uFile), silent = TRUE)
uFile = as.character(inFile[i, "datapath"]), if (inherits(sheets, "try-error")) {
ext = "xlsx", # 明确指定ext为xlsx showNotification(i18n$t("Failed to read the sheet list from the xlsx file. Please check if the file is corrupted or properly formatted "), type = "error")
xlsx_sheet = input$xlsx_sheet, # 从UI获取工作表索引 next # 跳过当前文件
xlsx_header = input$xlsx_header, # 从UI获取表头设置 }
man_str_as_factor = TRUE # xlsx也支持“字符串转因子”
) # 循环读取每个sheet，先带后缀加载，再重命名
} else if (input$dataType %in% c("csv", "url_csv")) { for (sheet in sheets) {
# 原有CSV参数传递 # 1. 临时文件名（带.xlsx后缀，满足函数校验）
temp_fname <- paste0(sheet, ".xlsx")
# 2. 加载数据
load_user_data(
fname = temp_fname, # 临时文件名：sheet名.xlsx
uFile = uFile,
ext = "xlsx",
xlsx_sheet = sheet, # 按sheet名称读取
xlsx_header = input$xlsx_header,
man_str_as_factor = TRUE
)
# 3. 重命名数据集：从“sheet名.xlsx”改为“sheet名”
# 检查是否已存在同名数据集（避免覆盖）
if (!is.null(r_data[[sheet]])) {
sheet_new <- paste0(sheet, "_", length(grep(paste0("^", sheet), names(r_data))) + 1)
sheet <- sheet_new
}
# 执行重命名
r_data[[sheet]] <- r_data[[temp_fname]]
# 删除临时数据集
rm(list = temp_fname, envir = r_data)
}
}
else if (input$dataType %in% c("csv", "url_csv")) {
load_user_data( load_user_data(
fname = as.character(inFile[i, "name"]), fname = as.character(inFile[i, "name"]),
uFile = as.character(inFile[i, "datapath"]), uFile = as.character(inFile[i, "datapath"]),
......
radiant.data/inst/app/tools/data/transform_ui.R
View file @ 1017104c
This source diff could not be displayed because it is too large. You can view the blob instead.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment