#' Sort selected lines
#'
#' Call this function as an RStudio addin to sort selected lines in the active document.
#'
#' @export
sortLinesA <- function() {
context <- rstudioapi::getActiveDocumentContext()
selection <- rstudioapi::primary_selection(context)
sel_text <- mixedsort(strsplit(selection$text, "\r?\n", perl = TRUE)[[1]],
decreasing = FALSE,
na.last = TRUE,
blank.last = FALSE,
numeric.type = "decimal",
roman.case = "upper")
rstudioapi::insertText(location = selection$range, text = paste(sel_text, collapse = "\n"))
}
#' @export
sortLinesD <- function() {
context <- rstudioapi::getActiveDocumentContext()
selection <- rstudioapi::primary_selection(context)
sel_text <- mixedsort(strsplit(selection$text, "\r?\n", perl = TRUE)[[1]],
decreasing = TRUE,
na.last = TRUE,
blank.last = FALSE,
numeric.type = "decimal",
roman.case = "upper")
rstudioapi::insertText(location = selection$range, text = paste(sel_text, collapse = "\n"))
}
mixedsort <- function(x,
decreasing=FALSE,
na.last=TRUE,
blank.last=FALSE,
numeric.type=c("decimal", "roman"),
roman.case=c("upper","lower","both")) {
ord <- mixedorder(x,
decreasing=decreasing,
na.last=na.last,
blank.last=blank.last,
numeric.type=numeric.type,
roman.case=roman.case)
return(x[ord])
}
# - Split each each character string into an vector of strings and
# numbers
# - Separately rank numbers and strings
# - Combine orders so that strings follow numbers
mixedorder <- function(x,
decreasing=FALSE,
na.last=TRUE,
blank.last=FALSE,
numeric.type=c("decimal", "roman"),
roman.case=c("upper","lower","both")) {
numeric.type <- match.arg(numeric.type)
roman.case <- match.arg(roman.case)
if (length(x) < 1)
return(NULL)
else if(length(x) == 1)
return(1)
if (!is.character(x))
return(order(x, decreasing=decreasing, na.last=na.last))
delim="\\$\\@\\$"
if (numeric.type=="decimal") {
regex <- "((?:(?i)(?:[-+]?)(?:(?=[.]?[0123456789])(?:[0123456789]*)(?:(?:[.])(?:[0123456789]{0,}))?)(?:(?:[eE])(?:(?:[-+]?)(?:[0123456789]+))|)))" # uses PERL syntax
numeric <- function(x) as.numeric(x)
} else if (numeric.type=="roman") {
regex <- switch(roman.case,
"both" = "([IVXCLDMivxcldm]+)",
"upper" = "([IVXCLDM]+)",
"lower" = "([ivxcldm]+)")
numeric <- function(x) roman2int(x)
} else
stop("Unknown value for numeric.type: ", numeric.type)
nonnumeric <- function(x) {
ifelse(is.na(numeric(x)), toupper(x), NA)
}
x <- as.character(x)
which.nas <- which(is.na(x))
which.blanks <- which(x=="")
# Convert each character string into an vector containing single
# character and numeric values.
# find and mark numbers in the form of +1.23e+45.67
delimited <- gsub(regex,
paste(delim, "\\1", delim, sep=""),
x,
perl=TRUE)
# separate out numbers
step1 <- strsplit(delimited, delim)
# remove empty elements
step1 <- lapply(step1, function(x) x[x>""])
# create numeric version of data
suppressWarnings(step1.numeric <- lapply(step1, numeric))
# create non-numeric version of data
suppressWarnings(step1.character <- lapply( step1, nonnumeric))
# now transpose so that 1st vector contains 1st element from each
# original string
maxelem <- max(sapply(step1, length))
step1.numeric.t <- lapply(1:maxelem, function(i) sapply(step1.numeric, function(x)x[i]))
step1.character.t <- lapply(1:maxelem, function(i) sapply(step1.character, function(x)x[i]))
# now order them
rank.numeric <- sapply(step1.numeric.t, rank)
rank.character <- sapply(step1.character.t, function(x) as.numeric(factor(x)))
# and merge
rank.numeric[!is.na(rank.character)] <- 0 # mask off string values
rank.character <- t(
t(rank.character) + apply(matrix(rank.numeric),2,max,na.rm=TRUE)
)
rank.overall <- ifelse(is.na(rank.character),rank.numeric,rank.character)
order.frame <- as.data.frame(rank.overall)
if(length(which.nas) > 0)
if(is.na(na.last))
order.frame[which.nas,] <- NA
else if(na.last)
order.frame[which.nas,] <- Inf
else
order.frame[which.nas,] <- -Inf
if(length(which.blanks) > 0)
if(is.na(blank.last))
order.frame[which.blanks,] <- NA
else if(blank.last)
order.frame[which.blanks,] <- 1e99
else
order.frame[which.blanks,] <- -1e99
order.frame <- as.list(order.frame)
order.frame$decreasing <- decreasing
order.frame$na.last <- NA
retval <- do.call("order", order.frame)
return(retval)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.