Merge pull request #30 from biometryhub/dev

V1.1.0 release
biometryhub · Apr 14, 2022 · 755a939 · 755a939
2 parents 199ddf5 + 7be3e96
commit 755a939
Show file tree

Hide file tree

Showing 40 changed files with 3,594 additions and 1,983 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,8 +1,7 @@
 Type: Package
 Package: biometryassist
 Title: Functions to Assist Design and Analysis of Agronomic Experiments
-Version: 1.0.0
-Date: 2022-01-25
+Version: 1.1.0
 Authors@R: 
     c(person(given = "Sharon",
              family = "Nielsen",
@@ -35,7 +34,6 @@ Imports:
     agricolae,
     cowplot,
     curl,
-    ellipsis,
     farver,
     ggplot2,
     interp,
@@ -49,6 +47,7 @@ Imports:
 Suggests: 
     covr,
     crayon,
+    getPass,
     mockery,
     testthat,
     vdiffr

diff --git a/NAMESPACE b/NAMESPACE
@@ -16,7 +16,6 @@ export(variogram)
 importFrom(cowplot,add_sub)
 importFrom(cowplot,plot_grid)
 importFrom(curl,curl_fetch_disk)
-importFrom(ellipsis,check_dots_used)
 importFrom(farver,decode_colour)
 importFrom(ggplot2,aes)
 importFrom(ggplot2,aes_)
@@ -49,13 +48,15 @@ importFrom(interp,interp)
 importFrom(lattice,wireframe)
 importFrom(multcompView,multcompLetters)
 importFrom(predictmeans,predictmeans)
+importFrom(rlang,check_dots_used)
 importFrom(rlang,is_installed)
 importFrom(rlang,is_interactive)
 importFrom(scales,brewer_pal)
 importFrom(scales,reverse_trans)
 importFrom(scales,viridis_pal)
 importFrom(stats,as.formula)
 importFrom(stats,fitted)
+importFrom(stats,model.frame)
 importFrom(stats,pchisq)
 importFrom(stats,predict)
 importFrom(stats,qnorm)
@@ -66,7 +67,6 @@ importFrom(stats,residuals)
 importFrom(stats,sd)
 importFrom(stats,shapiro.test)
 importFrom(stats,update)
-importFrom(stringi,stri_order)
 importFrom(stringi,stri_sort)
 importFrom(utils,available.packages)
 importFrom(utils,download.file)

diff --git a/NEWS.md b/NEWS.md
@@ -1,3 +1,22 @@
+# biometryassist 1.1.0
+
+## Major changes
+
+- `multiple_comparisons()` no longer requires calls to `predict.asreml()` to be passed into the function, as the predicted values are now calculated internally. Additional arguments can be passed to `predict.asreml()` via the `...` argument. (#27)
+
+## Minor changes
+
+- The `order` argument of `multiple_comparisons()` has been deprecated in favour of a new argument `descending`. This takes logical (`TRUE` or `FALSE`) values only, so `default` is no longer possible as it was producing incorrect results. (#8)
+- `resplt()` has been deprecated in favour of `resplot()` and will be removed in a future version (#20).
+- Warnings about lack of convergence are no longer output in `logl_test()`. (#17)
+
+## Bug fixes
+
+- Aliased levels are printed properly in `multiple_comparisons()` now. (#14)
+- R.param and G.param are removed from the `asreml()` call on `resplot()` if not explicitly provided. (#21)
+- Fixed a bug where `install_asreml()` would not work on macOS Monterey. (#16)
+
+
 # biometryassist 1.0.0
 
 ## Minor changes

diff --git a/R/autoplot.R b/R/autoplot.R
@@ -11,7 +11,7 @@ ggplot2::autoplot
 #' @param size Increase or decrease the text size within the plot for treatment labels. Numeric with default value of 4.
 #' @param margin Logical (default `FALSE`). A value of `FALSE` will expand the plot to the edges of the plotting area i.e. remove white space between plot and axes.
 #' @param palette A string specifying the colour scheme to use for plotting. Default is equivalent to "Spectral". Colour blind friendly palettes can also be provided via options `"colour blind"` (or `"color blind"`, both equivalent to `"viridis"`), `"magma"`, `"inferno"`, `"plasma"` or `"cividis"`. Other palettes from [scales::brewer_pal()] are also possible.
-#' @param ... Other arguments to be passed through.
+#' @inheritParams rlang::args_dots_used
 #'
 #' @name autoplot
 #'

diff --git a/R/biometryassist-deprecated.R b/R/biometryassist-deprecated.R
@@ -8,3 +8,4 @@
 #' @keywords internal
 #' @return No return value.
 NULL
+
diff --git a/R/des_info.R b/R/des_info.R
@@ -27,7 +27,7 @@
 #' @importFrom graphics plot
 #' @importFrom ggplot2 ggsave
 #' @importFrom utils write.csv
-#' @importFrom ellipsis check_dots_used
+#' @importFrom rlang check_dots_used
 #'
 #' @return A list containing a data frame with the complete design, a ggplot object with plot layout, the seed (if `return.seed = TRUE`), and the `satab` object, allowing repeat output of the `satab` table via `cat(output$satab)`.
 #'
@@ -101,7 +101,7 @@ des_info <- function(design.obj,
                      ...) {
 
     # Error checking of inputs
-    ellipsis::check_dots_used()
+    rlang::check_dots_used()
 
     # Check brows and bcols supplied if necessary
     if(design.obj$parameters$design == "rcbd" & anyNA(c(brows, bcols))) {
@@ -205,7 +205,7 @@ des_info <- function(design.obj,
         fac.sep <- rep(fac.sep, times = 2)
     }
 
-    # if (return.seed) {
+    # if(return.seed) {
     #     des.seed <- design.obj$parameters$seed
     # }
     # else {
@@ -217,7 +217,7 @@ des_info <- function(design.obj,
            design <- design.obj$parameters$design
     )
 
-    if (design == "crd") {
+    if(design == "crd") {
         plan <- expand.grid(row = 1:nrows, col = 1:ncols)
         des <- cbind(plan, design.obj$book)
 
@@ -231,7 +231,7 @@ des_info <- function(design.obj,
         ntrt <- nlevels(as.factor(des$treatments))
     }
 
-    if (design == "rcbd") {
+    if(design == "rcbd") {
         # names(design.obj$book)[names(design.obj$book)=="trt"] <- "treatments"
         # names(design.obj$book)[ncol(design.obj$book)] <- "treatments"
         ntrt <- nlevels(as.factor(design.obj$book[,ncol(design.obj$book)]))
@@ -241,20 +241,20 @@ des_info <- function(design.obj,
         rr <- nrows / brows
         cc <- ncols / bcols
         # Blocking across rows: brows == ntrt in a single column
-        if (brows == ntrt) {
+        if(brows == ntrt) {
             des <- design.obj$book
             plan <- expand.grid(row = 1:nrows, col = 1:ncols) # 2
         }
 
         # Blocking incomplete rows all columns
-        if (rr > 1 & cc == 1) {
+        if(rr > 1 & cc == 1) {
             des <- design.obj$book
             plan <- expand.grid(col = 1:ncols, row = 1:nrows) # 1
         }
 
 
         # Blocking incomplete rows and incomplete columns
-        if (rr > 1 & cc > 1) {
+        if(rr > 1 & cc > 1) {
             des <- design.obj$book
 
             # set up empty columns in the plan data.frame
@@ -280,14 +280,14 @@ des_info <- function(design.obj,
 
 
         # Blocking across columns: bcols == ntrt in a single row
-        if (bcols == ntrt) {
+        if(bcols == ntrt) {
             des <- design.obj$book
             plan <- expand.grid(col = 1:ncols, row = 1:nrows)
         } # 4
 
 
         # Blocking incomplete columns all rows
-        if (cc > 1 & rr == 1) {
+        if(cc > 1 & rr == 1) {
             des <- design.obj$book
 
             # set up empty columns in the plan data.frame
@@ -312,7 +312,7 @@ des_info <- function(design.obj,
         names(des)[ncol(des)] <- "treatments"
     }
 
-    if (design == "lsd") {
+    if(design == "lsd") {
         des <- design.obj$book
         des$row <- as.numeric(des$row)
         des$col <- as.numeric(des$col)
@@ -321,7 +321,7 @@ des_info <- function(design.obj,
         ntrt <- nlevels(as.factor(des$treatments))
     }
 
-    if (design == "factorial_crd") {
+    if(design == "factorial_crd") {
         treatments <- NULL
         plan <- expand.grid(row = 1:nrows, col = 1:ncols)
         des <- cbind(plan, design.obj$book, row.names = NULL)
@@ -340,7 +340,7 @@ des_info <- function(design.obj,
         ntrt <- nlevels(des$treatments)
     }
 
-    if (design == "factorial_rcbd") {
+    if(design == "factorial_rcbd") {
         treatments <- NULL
 
         for (i in 3:ncol(design.obj$book)) {
@@ -354,20 +354,20 @@ des_info <- function(design.obj,
         rr <- nrows / brows
         cc <- ncols / bcols
         # Blocking across rows: brows == ntrt in a single column
-        if (brows == ntrt) {
+        if(brows == ntrt) {
             des <- design.obj$book
             plan <- expand.grid(row = 1:nrows, col = 1:ncols) # 2
         }
 
         # Blocking incomplete rows all columns
-        if (rr > 1 & cc == 1) {
+        if(rr > 1 & cc == 1) {
             des <- design.obj$book
             plan <- expand.grid(col = 1:ncols, row = 1:nrows) # 1
         }
 
 
         # Blocking incomplete rows and incomplete columns
-        if (rr > 1 & cc > 1) {
+        if(rr > 1 & cc > 1) {
             des <- design.obj$book
 
             # set up empty columns in the plan data.frame
@@ -393,14 +393,14 @@ des_info <- function(design.obj,
 
 
         # Blocking across columns: bcols == ntrt in a single row
-        if (bcols == ntrt) {
+        if(bcols == ntrt) {
             des <- design.obj$book
             plan <- expand.grid(col = 1:ncols, row = 1:nrows)
         } # 4
 
 
         # Blocking incomplete columns all rows
-        if (cc > 1 & rr == 1) {
+        if(cc > 1 & rr == 1) {
             des <- design.obj$book
 
             # set up empty columns in the plan data.frame
@@ -431,7 +431,7 @@ des_info <- function(design.obj,
         des <- cbind(plan, des)
     }
 
-    if (design == "factorial_lsd") {
+    if(design == "factorial_lsd") {
         treatments <- NULL
         des <- design.obj$book
 
@@ -451,7 +451,7 @@ des_info <- function(design.obj,
         des$col <- as.numeric(des$col)
     }
 
-    if (design == "split") {
+    if(design == "split") {
         des <- design.obj$book
         spfacs <- c("plots", "splots", "block")
 
@@ -469,17 +469,17 @@ des_info <- function(design.obj,
         rr <- nrows / brows
         cc <- ncols / bcols
         # Blocking across rows: brows == ntrt in a single column
-        if (brows == ntrt) {
+        if(brows == ntrt) {
             plan <- expand.grid(row = 1:nrows, col = 1:ncols) # 2
         }
 
         # Blocking incomplete rows all columns
-        if (rr > 1 & cc == 1) {
+        if(rr > 1 & cc == 1) {
             plan <- expand.grid(col = 1:ncols, row = 1:nrows) # 1
         }
 
         # Blocking incomplete rows and incomplete columns
-        if (rr > 1 & cc > 1) {
+        if(rr > 1 & cc > 1) {
 
             # set up empty columns in the plan data.frame
             plan <- expand.grid(row = 1:nrows, col = 1:ncols)
@@ -504,13 +504,13 @@ des_info <- function(design.obj,
 
 
         # Blocking across columns: bcols == ntrt in a single row
-        if (bcols == ntrt) {
+        if(bcols == ntrt) {
             plan <- expand.grid(col = 1:ncols, row = 1:nrows)
         } # 4
 
 
         # Blocking incomplete columns all rows
-        if (cc > 1 & rr == 1) {
+        if(cc > 1 & rr == 1) {
 
             # set up empty columns in the plan data.frame
             plan <- expand.grid(row = 1:nrows, col = 1:ncols)
@@ -543,7 +543,7 @@ des_info <- function(design.obj,
     class(des) <- c("design", class(des))
 
     if(plot) {
-        info$plot.des = autoplot(des, rotation = rotation, size = size, margin = margin)
+        info$plot.des <- autoplot(des, rotation = rotation, size = size, margin = margin)
     }
     info$satab <- satab(design.obj)
 
@@ -578,7 +578,7 @@ des_info <- function(design.obj,
         write.csv(info$design, file = paste0(savename, ".csv"), row.names = FALSE)
     }
 
-    if (return.seed) {
+    if(return.seed) {
         info$seed <- design.obj$parameters$seed
     }
 

diff --git a/R/design.R b/R/design.R
@@ -33,7 +33,7 @@
 #'
 #' @export
 #'
-#' @return A list containing a data frame with the complete design, a ggplot object with plot layout, the seed (if `return.seed = TRUE`), and the `satab` object, allowing repeat output of the `satab` table via `cat(output$satab)`.
+#' @return A list containing a data frame with the complete design (`$design`), a ggplot object with plot layout (`$plot.des`), the seed (`$seed`, if `return.seed = TRUE`), and the `satab` object (`$satab`), allowing repeat output of the `satab` table via `cat(output$satab)`.
 #'
 #' @examples
 #' # Completely Randomised Design

diff --git a/R/install_asreml.R b/R/install_asreml.R
@@ -34,6 +34,35 @@ install_asreml <- function(library = .libPaths()[1], quiet = FALSE, force = FALS
         invisible(TRUE)
     }
     else {
+      # macOS Monterey needs a folder created
+      if(Sys.info()["sysname"] == "Darwin" && Sys.info()["release"] >= 21 && !dir.exists("/Library/Application Support/Reprise/")) {
+
+            result <- tryCatch(
+                expr = {
+                    dir.create("/Library/Application Support/Reprise/", recursive = T)
+                },
+                error = function(cond) {
+                    return(FALSE)
+                },
+                warning = function(cond) {
+                    return(FALSE)
+                }
+            )
+
+            if(isFALSE(result) && rlang::is_installed("getPass")) {
+                message("The ASReml-R package uses Reprise license management and will require administrator privilege to create the folder '/Library/Application Support/Reprise' before it can be loaded.")
+                input <- readline("Would you like to create this folder now (Yes/No)? You will be prompted for your password if yes. ")
+
+                if(toupper(input) == "YES") {
+                    system("sudo -S mkdir '/Library/Application Support/Reprise' && sudo -S chmod 777 '/Library/Application Support/Reprise'",
+                           input = getPass::getPass("Please enter your user account password: "))
+                }
+                else {
+                    stop("ASReml-R cannot be installed until the folder '/Library/Application Support/Reprise' is created with appropriate permissions.")
+                }
+            }
+        }
+
         if(!quiet) {
             message("\nDownloading and installing ASReml-R. This may take some time, depending on internet speed...\n")
         }
@@ -88,7 +117,7 @@ install_asreml <- function(library = .libPaths()[1], quiet = FALSE, force = FALS
         pkgs <- rownames(installed.packages(lib.loc = library))
         deps <- setdiff(c("data.table", "ggplot2", "jsonlite"), pkgs)
 
-        if(rlang::is_installed("data.table") && packageVersion("data.table") < "1.9.6") {
+        if(!rlang::is_installed("data.table", version = "1.9.6")) {
             deps <- c(deps, "data.table")
         }