Merge pull request #77 from poissonconsulting/f-styler

DESCRIPTION

@@ -63,4 +63,4 @@ Remotes:
     poissonconsulting/rescale
 Encoding: UTF-8
 LazyData: true
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2

R/IC.R

@@ -39,10 +39,12 @@ IC.mb_analyses <- function(object, ...) {
   if (!length(object)) {
     return(tibble(
       model = character(0), K = integer(0), IC = numeric(0),
-      DeltaIC = numeric(0), ICWt = numeric(0)))
+      DeltaIC = numeric(0), ICWt = numeric(0)
+    ))
   }
-  if (!all(vapply(object, is.mb_analysis, TRUE)))
+  if (!all(vapply(object, is.mb_analysis, TRUE))) {
     err("object must be a list of mb_analysis objects", tidy = FALSE)
+  }
 
   if (is.null(names(object))) names(object) <- 1:length(object)
 
@@ -73,4 +75,3 @@ IC.mb_analyses <- function(object, ...) {
 IC.mb_meta_analyses <- function(object, ...) {
   lapply(object, IC, ...)
 }
-

R/R2.R

@@ -30,7 +30,6 @@ R2.mb_analysis <- function(object, response, marginal = FALSE,
                            parallel = getOption("mb.parallel", FALSE),
                            quiet = getOption("mb.quiet", TRUE),
                            beep = getOption("mb.beep", FALSE), ...) {
-
   chk_string(response)
   chk_flag(marginal)
   chk_flag(beep)
@@ -41,9 +40,11 @@ R2.mb_analysis <- function(object, response, marginal = FALSE,
 
   new_data <- data_set(object, marginalize_random_effects = marginal)
 
-  prediction <- predict(object, new_data = new_data, term = term,
-                                  parallel = parallel, quiet = quiet,
-                                  beep = FALSE)
+  prediction <- predict(object,
+    new_data = new_data, term = term,
+    parallel = parallel, quiet = quiet,
+    beep = FALSE
+  )
 
   1 - stats::var(data[[response]] - prediction$estimate) / stats::var(data[[response]])
 }

R/analyse.R

@@ -25,18 +25,22 @@ analyse1 <- function(model, data, loaded, nchains, niters, nthin, quiet, glance,
 }
 
 analyse_data <- function(data, name = NULL, x, loaded, nchains, niters, nthin,
-                          parallel, quiet, glance, ...) {
+                         parallel, quiet, glance, ...) {
   if (!is.null(name) & glance) cat("Data:", name, "\n")
-  analyse1(x, data, loaded = loaded, nchains = nchains, niters = niters,
-           nthin = nthin, parallel = parallel, quiet = quiet, glance = glance, ...)
+  analyse1(x, data,
+    loaded = loaded, nchains = nchains, niters = niters,
+    nthin = nthin, parallel = parallel, quiet = quiet, glance = glance, ...
+  )
 }
 
 
 analyse_model <- function(x, name = NULL, data, parallel, nchains, niters, nthin, quiet, glance, beep, ...) {
   if (!is.null(name) & glance) cat("Model:", name, "\n")
-  analyse(x, data = data, parallel = parallel,
-          nchains = nchains, niters = niters, nthin = nthin,
-          quiet = quiet, glance = glance, beep = beep, ...)
+  analyse(x,
+    data = data, parallel = parallel,
+    nchains = nchains, niters = niters, nthin = nthin,
+    quiet = quiet, glance = glance, beep = beep, ...
+  )
 }
 
 #' Analyse
@@ -64,9 +68,11 @@ analyse.character <- function(x, data,
                               beep = getOption("mb.beep", TRUE),
                               ...) {
   x <- model(x, select_data = select_data)
-  analyse(x, data = data,
-          parallel = parallel, nchains = nchains, niters = niters, nthin = nthin, quiet = quiet,
-          glance = glance, beep = beep)
+  analyse(x,
+    data = data,
+    parallel = parallel, nchains = nchains, niters = niters, nthin = nthin, quiet = quiet,
+    glance = glance, beep = beep
+  )
 }
 
 #' Analyse
@@ -91,21 +97,22 @@ analyse.mb_model <- function(x, data,
                              glance = getOption("mb.glance", TRUE),
                              beep = getOption("mb.beep", TRUE),
                              ...) {
-
   chk_flag(beep)
   if (beep) on.exit(beepr::beep())
 
   if (is.data.frame(data)) {
     chk_data(data)
   } else if (is.list(data)) {
     lapply(data, chk_data)
-  } else err("data must be a data.frame or a list of data.frames", tidy = FALSE)
+  } else {
+    err("data must be a data.frame or a list of data.frames", tidy = FALSE)
+  }
 
   chk_whole_number(nchains)
   chk_range(nchains, c(2L, 10L))
   chk_whole_number(niters)
   chk_range(niters, c(10L, 100000L))
-  if(!is.null(nthin)) {
+  if (!is.null(nthin)) {
     chk_whole_number(nthin)
     chk_range(nthin, c(1L, 10000L))
   }
@@ -119,19 +126,23 @@ analyse.mb_model <- function(x, data,
   loaded <- load_model(x, quiet)
 
   if (is.data.frame(data)) {
-    return(analyse_data(data = data, x = x, loaded = loaded,
-                         nchains = nchains, niters = niters, nthin = nthin,
-                         parallel = parallel, quiet = quiet, glance = glance))
+    return(analyse_data(
+      data = data, x = x, loaded = loaded,
+      nchains = nchains, niters = niters, nthin = nthin,
+      parallel = parallel, quiet = quiet, glance = glance
+    ))
   }
 
   names <- names(data)
   if (is.null(names)) {
     names(data) <- 1:length(x)
   }
 
-  analyses <- purrr::imap(data, analyse_data, x = x, loaded = loaded,
-              nchains = nchains, niters = niters, nthin = nthin,
-              parallel = parallel, quiet = quiet, glance = glance)
+  analyses <- purrr::imap(data, analyse_data,
+    x = x, loaded = loaded,
+    nchains = nchains, niters = niters, nthin = nthin,
+    parallel = parallel, quiet = quiet, glance = glance
+  )
 
   names(data) <- names
 
@@ -167,9 +178,11 @@ analyse.mb_models <- function(x, data,
   names <- names(x)
   if (is.null(names)) names(x) <- 1:length(x)
 
-  analyses <- purrr::imap(x, analyse_model, data = data,
-                          nchains = nchains, niters = niters, nthin = nthin,
-                          parallel = parallel, quiet = quiet, glance = glance, beep = FALSE, ...)
+  analyses <- purrr::imap(x, analyse_model,
+    data = data,
+    nchains = nchains, niters = niters, nthin = nthin,
+    parallel = parallel, quiet = quiet, glance = glance, beep = FALSE, ...
+  )
 
   if (is.data.frame(data)) {
     analyses <- as_mb_analyses(analyses, names)

R/as.R

@@ -28,8 +28,8 @@ as.analyses <- function(x, ...) {
 #' @export
 as.mcmcr.mb_analysis_coef <- function(x, ...) {
   x <- dplyr::select(x, "term", "estimate")
-  x <- dplyr::mutate_(x, parameter = ~sub("^(\\w+)(.*)", "\\1", term))
-  x <-  plyr::dlply(x,~parameter, lmcmcarray)
+  x <- dplyr::mutate_(x, parameter = ~ sub("^(\\w+)(.*)", "\\1", term))
+  x <- plyr::dlply(x, ~parameter, lmcmcarray)
 
   class(x) <- "mcmcr"
 
@@ -39,7 +39,9 @@ as.mcmcr.mb_analysis_coef <- function(x, ...) {
 
 #' @export
 as.mcmcr.mb_analysis <- function(x, ...) {
-  if (!is.null(x$mcmcr)) return(x$mcmcr)
+  if (!is.null(x$mcmcr)) {
+    return(x$mcmcr)
+  }
 
   # this needs switching off by removing lm and replacing R function based optimizer
   x <- coef(x, "all")
@@ -62,13 +64,14 @@ as.models.list <- function(x, ...) {
   if (!is.list(x)) err("x must be a list", tidy = FALSE)
 
   if (length(x)) {
-    if (!all(purrr::map_lgl(x, is.mb_model)))
+    if (!all(purrr::map_lgl(x, is.mb_model))) {
       err("all elements must inherit from 'mb_model'", tidy = FALSE)
+    }
 
     class <- purrr::map(x, class)
-    if (!identical(length(unique(class)), 1L))
+    if (!identical(length(unique(class)), 1L)) {
       err("all model objects must have the same class", tidy = FALSE)
-
+    }
   }
   class(x) <- "mb_models"
   x
@@ -96,11 +99,13 @@ as.analyses.list <- function(x, ...) {
   if (!is.list(x)) err("x must be a list", tidy = FALSE)
 
   if (length(x)) {
-    if (!all(purrr::map_lgl(x, is.mb_analysis)))
+    if (!all(purrr::map_lgl(x, is.mb_analysis))) {
       err("all objects must inherit from 'mb_analysis'", tidy = FALSE)
+    }
     data <- purrr::map(x, data_set)
-    if (!identical(length(unique(data)), 1L))
+    if (!identical(length(unique(data)), 1L)) {
       err("all analysis objects must have the same data", tidy = FALSE)
+    }
   }
   class(x) <- "mb_analyses"
   x

R/augment.R

@@ -5,21 +5,22 @@ generics::augment
 augment.mb_analysis <- function(x, ...) {
   data <- data_set(x)
 
-  if (is_new_parameter(x, "fit"))
+  if (is_new_parameter(x, "fit")) {
     data$fit <- fitted(x)$estimate
-  if (is_new_parameter(x, "residual"))
+  }
+  if (is_new_parameter(x, "residual")) {
     data$residual <- residuals(x)$estimate
+  }
   if (is_new_parameter(x, "log_lik")) {
     if (is_bayesian(x)) {
       logLik <- logLik_matrix(x)
       if (ncol(logLik) == nrow(data)) {
         data$log_lik <- logColMeansExp(logLik)
         data$vlog_lik <- apply(logLik, 2, var)
       }
-    } else
+    } else {
       data$log_lik <- predict(x, new_data = data_set(x), term = "log_lik")$estimate
+    }
   }
   data
 }
-
-

R/backwards.R

@@ -24,7 +24,6 @@ backwards <- function(model, data, drops = list(), conf_level = getOption("mb.co
 #' @export
 backwards.mb_model <- function(model, data, drops = list(), conf_level = getOption("mb.conf_level", 0.95),
                                beep = getOption("mb.beep", TRUE), ...) {
-
   .NotYetImplemented()
 
   chk_flag(beep)

R/check.R

@@ -1,15 +1,21 @@
 check_drops <- function(drops) {
   if (!is.list(drops)) err("drops must be a list", tidy = FALSE)
-  if (!length(drops)) return(drops)
-  if (!all(vapply(drops, is.character, TRUE)))
+  if (!length(drops)) {
+    return(drops)
+  }
+  if (!all(vapply(drops, is.character, TRUE))) {
     err("drops must be a list of character vectors", tidy = FALSE)
-  if (!all(vapply(drops, length, 1L) > 0))
+  }
+  if (!all(vapply(drops, length, 1L) > 0)) {
     err("drops must be a list of non-zero length character vectors", tidy = FALSE)
-  if (anyDuplicated(drops))
+  }
+  if (anyDuplicated(drops)) {
     err("drops must be a list of unique character vectors", tidy = FALSE)
+  }
 
-  if (any(impossible_drop(drops) %in% possible_drop(drops)))
+  if (any(impossible_drop(drops) %in% possible_drop(drops))) {
     err("drops is inconsistent", tidy = FALSE)
+  }
   drops
 }
 
@@ -56,31 +62,41 @@ check_x_in_y <- function(x, y, x_name = substitute(x), y_name = substitute(y), t
   if (is.name(x_name)) x_name <- deparse(x_name)
   if (is.name(y_name)) y_name <- deparse(y_name)
 
-  if (is.null(y)) return(x)
-  if (!length(x)) return(x)
+  if (is.null(y)) {
+    return(x)
+  }
+  if (!length(x)) {
+    return(x)
+  }
 
-  if (!all(x %in% y))
+  if (!all(x %in% y)) {
     err(type_x, " in ", x_name, " must also be in ", type_y, " of ", y_name, tidy = FALSE)
+  }
   x
 }
 
 check_x_not_in_y <- function(x, y, x_name = substitute(x), y_name = substitute(y), type_x = "values", type_y = "values") {
   if (is.name(x_name)) x_name <- deparse(x_name)
   if (is.name(y_name)) y_name <- deparse(y_name)
 
-  if (is.null(y)) return(x)
-  if (!length(x)) return(x)
+  if (is.null(y)) {
+    return(x)
+  }
+  if (!length(x)) {
+    return(x)
+  }
 
-  if (any(x %in% y))
+  if (any(x %in% y)) {
     err(type_x, " in ", x_name, " must not be in ", type_y, " of ", y_name, tidy = FALSE)
+  }
   x
 }
 
 check_single_arg_fun <- function(fun) {
   fun_name <- deparse(substitute(fun))
 
   if (!is.function(fun)) err(fun_name, " must be a function", tidy = FALSE)
-  if (length(formals(args(fun))) != 1)  err(fun_name, " must take a single argument", tidy = FALSE)
+  if (length(formals(args(fun))) != 1) err(fun_name, " must take a single argument", tidy = FALSE)
   fun
 }
 
@@ -96,8 +112,9 @@ check_uniquely_named_character_vector <- function(x, x_name = substitute(x)) {
 
   if (!is.character(x)) err(x_name, " must be a character vector", tidy = FALSE)
 
-  if (!length(x))
+  if (!length(x)) {
     return(x)
+  }
 
   if (is.null(names(x))) err(x_name, "must be named", tidy = FALSE)
   chk_unique(names(x), x_name = x_name)
@@ -114,7 +131,9 @@ check_uniquely_named_list <- function(x, x_name = substitute(x)) {
   if (is.name(x)) x_name <- deparse(x_name)
 
   if (!is.list(x)) err(x_name, " must be a list", tidy = FALSE)
-  if (!length(x)) return(x)
+  if (!length(x)) {
+    return(x)
+  }
   if (is.null(names(x))) err(x_name, " must be a named list", tidy = FALSE)
   if (anyDuplicated(names(x))) err(x_name, " must be a uniquely named list", tidy = FALSE)
   x
@@ -123,19 +142,25 @@ check_uniquely_named_list <- function(x, x_name = substitute(x)) {
 check_all_elements_class_character <- function(x, x_name = substitute(x)) {
   if (is.name(x)) x_name <- deparse(x_name)
 
-  if (!length(x)) return(x)
+  if (!length(x)) {
+    return(x)
+  }
 
-  if (!all(unlist(lapply(x, class)) == "character"))
+  if (!all(unlist(lapply(x, class)) == "character")) {
     err("elements of ", x_name, "must be character vectors", tidy = FALSE)
+  }
   x
 }
 
 check_all_elements_unique <- function(x, x_name = substitute(x)) {
   if (is.name(x)) x_name <- deparse(x_name)
 
-  if (!length(x)) return(x)
+  if (!length(x)) {
+    return(x)
+  }
 
-  if (any(vapply(x, anyDuplicated, TRUE)))
+  if (any(vapply(x, anyDuplicated, TRUE))) {
     err("elements of ", x_name, "must be unique", tidy = FALSE)
+  }
   x
 }

R/code.R

@@ -12,7 +12,6 @@ code <- function(object, ...) {
 
 #' @export
 code.mb_model <- function(object, ...) {
-
   object$code
 }