Prep sample order input

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: BoutrosLab.plotting.general
-Version: 7.1.1
+Version: 7.1.2
 Type: Package
 Title: Functions to Create Publication-Quality Plots
-Date: 2024-01-08
+Date: 2024-04-02
 Authors@R: c(person("Paul Boutros", role = c("aut", "cre"), email = "[email protected]"),
              person("Christine P'ng", role = "ctb"),
              person("Jeff Green", role = "ctb"),

NEWS

@@ -1,3 +1,9 @@
+BoutrosLab.plotting.general 7.1.2 2024-04-02
+
+UPDATE
+* Improved "sample.order" argument checking
+
+--------------------------------------------------------------------------
 BoutrosLab.plotting.general 7.1.1 2024-01-08
 
 UPDATE

R/create.barplot.R

@@ -617,9 +617,9 @@ create.barplot <- function(
 		}
 
 	# reorder the bars in decreasing or increasing order if specified
-	if (is.null(sample.order) || is.na(sample.order)) { sample.order <- 'none'; }
+	sample.order <- prep.sample.order(sample.order);
 
-	if (sample.order[1] != 'none') {
+	if (length(sample.order) != 1 || sample.order != sample.order.default()) {
 		for (i in 1:length(trellis.object$panel.args)) {
 
 			# will need two separate ways for horizontal and non - horizontal
@@ -636,16 +636,11 @@ create.barplot <- function(
 					}
 
 				if (length(sample.order) == 1) {
-					if(! sample.order %in% c('decreasing', 'increasing')) {
-						stop('sample.order should be `decreasing` or `increasing`');
-						}
-
 					# This looks backwards but gets reversed later
 					# Might want to revisit if it makes more sense to sort in correct order here
-					sample.order.decreasing <- sample.order != 'decreasing';
 					ordering <- order(
 						trellis.object$panel.args[[1]]$y[c(1:num.bars)],
-						decreasing = sample.order.decreasing
+						decreasing = sample.order != sample.order.decreasing()
 						);
 					}
 
@@ -699,14 +694,9 @@ create.barplot <- function(
 					}
 
 				if (length(sample.order) == 1) {
-					if(! sample.order %in% c('decreasing', 'increasing')) {
-						stop('sample.order should be `decreasing` or `increasing`');
-						}
-
-					sample.order.decreasing <- sample.order != 'decreasing';
 					ordering <- order(
 						trellis.object$panel.args[[1]]$x[c(1:num.bars)],
-						decreasing = sample.order.decreasing
+						decreasing = sample.order != sample.order.decreasing()
 						);
 					}
 

R/create.boxplot.R

@@ -397,8 +397,9 @@ create.boxplot <- function(
 
 		}
 
+    sample.order <- prep.sample.order.setting(sample.order);
 	# reorder by median
-	if (sample.order == 'increasing' | sample.order == 'decreasing') {
+	if (sample.order %in% sample.order.auto.values()) {
 
 		if (is.numeric(trellis.object$panel.args[[1]]$x)) {
 			num.boxes <- levels(trellis.object$panel.args[[1]]$y);
@@ -423,7 +424,9 @@ create.boxplot <- function(
 			ranks <- rank(values.to.sort.by, ties.method = 'random');
 
 			# swap the rankings if decreasing order is specified
-			if (sample.order == 'decreasing') { ranks <- rank(values.to.sort.by * ( -1 ), ties.method = 'random'); }
+			if (sample.order == sample.order.decreasing()) {
+			    ranks <- rank(values.to.sort.by * ( -1 ), ties.method = 'random');
+			    }
 
 			newlocations <- NULL;
 
@@ -476,7 +479,9 @@ create.boxplot <- function(
 
 			ranks <- rank(values.to.sort.by, ties.method = 'random');
 
-			if (sample.order == 'decreasing') { ranks <- rank(values.to.sort.by * (-1), ties.method = 'random'); }
+			if (sample.order == sample.order.decreasing()) {
+			    ranks <- rank(values.to.sort.by * (-1), ties.method = 'random');
+			    }
 
 			newlocations <- NULL;
 

R/prep.inputs.R

@@ -0,0 +1,39 @@
+prep.sample.order <- function(sample.order) {
+    if (length(sample.order) == 1) {
+        return(prep.sample.order.setting(sample.order));
+        }
+
+    contains.na <- any(is.na(sample.order));
+
+    if (is.null(sample.order) || contains.na) {
+        sample.order <- sample.order.default();
+
+        if (contains.na) {
+            warning(paste(
+                'NA values found in "sample.order" (using default "none" setting).'
+                ));
+            }
+        }
+
+    return(sample.order);
+    }
+
+prep.sample.order.setting <- function(sample.order) {
+    if (!(sample.order %in% valid.sample.order.values())) {
+        stop(paste('Invalid "sample.order":', paste0('(', sample.order, ')')))
+        }
+    return(sample.order);
+    }
+
+sample.order.default <- function() 'none';
+sample.order.increasing <- function() 'increasing';
+sample.order.decreasing <- function() 'decreasing';
+sample.order.auto.values <- function() {
+    c(sample.order.increasing(), sample.order.decreasing());
+    }
+valid.sample.order.values <- function() {
+    c(
+        sample.order.default(),
+        sample.order.auto.values()
+        );
+    }

tests/testthat/test-prep.inputs.R

@@ -0,0 +1,66 @@
+test_that(
+    'prep.sample.order replaces NULL with default',
+    {
+        sample.order <- NULL;
+        result <- prep.sample.order(sample.order);
+
+        expect_equal(result, sample.order.default());
+        }
+    );
+
+test_that(
+    'prep.sample.order replaces with default value if NAs are present',
+    {
+        sample.order <- c(NA, 'sample', 'order', NA);
+        result <- prep.sample.order(sample.order);
+
+        expect_equal(result, sample.order.default());
+        }
+    );
+
+test_that(
+    'prep.sample.order warns if NAs are present',
+    {
+        sample.order <- c(NA, 'sample', 'order', NA);
+
+        expect_warning(
+            { prep.sample.order(sample.order); },
+            regexp = 'NA'
+            );
+        }
+    );
+
+test_that(
+    'prep.sample.order errors on invalid string input',
+    {
+        sample.order <- 'invalid sample order setting';
+        expect_error(
+            {
+                prep.sample.order(sample.order);
+                },
+            regexp = sample.order
+            );
+        }
+    );
+
+test_that(
+    'prep.sample.order.setting errors with invalid setting',
+    {
+        sample.order <- 'invalid sample order setting';
+        expect_error(
+            {
+                prep.sample.order.setting(sample.order);
+                },
+            regexp = sample.order
+            );
+        }
+    );
+
+test_that(
+    'prep.sample.order.setting returns valid setting',
+    {
+        sample.order <- sample.order.default();
+        result <- prep.sample.order.setting(sample.order);
+        expect_equal(result, sample.order);
+        }
+    );