Merge pull request #114 from statgenlmu/fix_lints

Fix lints

.Rbuildignore

@@ -1,6 +1,7 @@
 ^misc$
 .tar.gz$
 ^.travis*
+^.lintr$
 ^.*\.Rproj$
 ^\.Rproj\.user$
 ^cran-comments\.md$

.lintr

@@ -0,0 +1 @@
+linters: with_defaults(trailing_whitespace_linter = NULL, closed_curly_linter = NULL, commented_code_linter = NULL)

.travis.yml

@@ -5,18 +5,14 @@ warnings_are_errors: true
 
 r_binary_packages:
   - testthat
-  - ff 
-  - bigmemory 
-  - RcppArmadillo
-  - igraph 
-  - stringdist 
-  - shiny
-
-r_github_packages:
-  - jimhester/lintr 
-  - jimhester/covr
+  - covr
+  - RcppArmadillo # for coala
+  - knitr # for lintr
+  - igraph # for lintr
+
+r_packages:
+  - lintr 
 
 after_success:
   - Rscript -e "lintr::lint_package()"
   - Rscript -e "library(covr); coveralls()"
-

DESCRIPTION

@@ -1,5 +1,5 @@
 Package: jaatha
-Version: 3.0.0.9008
+Version: 3.0.0.9009
 Date: 2016-01-25
 License: GPL (>= 3)
 Title: Simulation-Based Maximum Likelihood Parameter Estimation

R/block.R

@@ -1,12 +1,12 @@
 #' @importFrom R6 R6Class
-block_class <- R6Class("Block", 
+block_class <- R6Class("Block",
   private = list(border = NULL),
   public = list(
     initialize = function(border, cut) {
       assert_that(is.matrix(border))
       assert_that(ncol(border) == 2)
       assert_that(nrow(border) >= 1)
-      assert_that(all(border[ , 1] < border[ , 2]))
+      assert_that(all(border[, 1] < border[, 2]))
       if (cut)  {
         border[border < 0] <- 0
         border[border > 1] <- 1
@@ -17,39 +17,39 @@ block_class <- R6Class("Block",
     get_border = function() private$border,
     print = function() print(private$border),
     print_border = function(jaatha) {
-      lower <- denormalize(private$border[ , 1], jaatha)
-      upper <- denormalize(private$border[ , 2], jaatha)
+      lower <- denormalize(private$border[, 1], jaatha)
+      upper <- denormalize(private$border[, 2], jaatha)
       paste0(round(lower, 3), "-", round(upper, 3), collapse = " x ")
     },
     includes = function(point) {
-      all(private$border[ , 1] - 1e-15 <= point & 
-            point <= private$border[ , 2] + 1e-15)
+      all(private$border[, 1] - 1e-15 <= point &
+            point <= private$border[, 2] + 1e-15)
     },
     get_middle = function() {
-      m <- (private$border[ , 2] - private$border[ , 1]) / 2 + 
-        private$border[ , 1]
+      m <- (private$border[, 2] - private$border[, 1]) / 2 +
+        private$border[, 1]
       names(m) <- rownames(private$border)
       m
     },
     get_corners = function() {
       corners <- expand.grid(lapply(1:nrow(private$border), function(i) {
-        private$border[i , , drop = FALSE]
-      }), KEEP.OUT.ATTRS = FALSE)
+        private$border[i, , drop = FALSE] #nolint
+      }), KEEP.OUT.ATTRS = FALSE) #nolint
       colnames(corners) <- rownames(private$border)
       as.matrix(corners)
     },
     sample_pars = function(number, add_corners = FALSE) {
       "Generates random parameter combinations inside the block's range"
       assert_that(is.count(number))
       assert_that(is_single_logical(add_corners))
-      
+
       # Sample random simulation parameters
       par_number <- nrow(self$get_border())
       random_pars <- matrix(runif(par_number * number,
-                                  min = self$get_border()[ , 1],
-                                  max = self$get_border()[ , 2]),
+                                  min = self$get_border()[, 1],
+                                  max = self$get_border()[, 2]),
                             number, par_number, byrow = TRUE)
-      
+
       # Add corners if requested
       if (add_corners) random_pars <- rbind(random_pars, self$get_corners())
       assert_that(all(apply(random_pars, 1, self$includes)))

R/coala_interface.R

@@ -50,7 +50,7 @@ create_jaatha_model.coalmodel <- function(x,
 
   # create parameter ranges
   par_table <- coala::get_parameter_table(x)
-  par_ranges <- as.matrix(par_table[,-1])
+  par_ranges <- as.matrix(par_table[, -1])
   rownames(par_ranges) <- par_table$name
 
   # create summary statisics
@@ -96,7 +96,7 @@ convert_coala_sumstats <- function(coala_model, jsfs_summary = "sums",
     # --- Four Gamete Summary Statistic -----------------------------
     if (inherits(stat, "stat_four_gamete")) {
       return(create_jaatha_stat(name, function(x, opts) {
-        x[[name]][ , c(1, 2, 6), drop = FALSE]
+        x[[name]][, c(1, 2, 6), drop = FALSE]
       }, poisson = FALSE, breaks = four_gamete_breaks))
     }
 
@@ -119,10 +119,10 @@ multi_index_range <- function(d, p) {
   ## A[p[1,1]:p[1:2],p[2,1]:p[2:2],...] consists of the same values as A[v],
   ## even though no necessarily in the same order.
   N <- nrow(p)
-  v <- p[N,1]:p[N,2]
+  v <- p[N, 1]:p[N, 2]
   if (N > 1) {
     for (n in (N - 1):1) {
-      v <- as.vector(outer((v - 1)*d[n], p[n, 1]:p[n, 2], "+"))
+      v <- as.vector(outer( (v - 1) * d[n], p[n, 1]:p[n, 2], "+"))
     }
   }
 
@@ -174,7 +174,7 @@ coarsen_jsfs <- function(ja, part, part_hi = NULL) {
     if (!is.list(part_hi)) part_hi <- rep(list(part_hi), n)
     for (i in 1:n) {
       upper <- sort(d[i] - part_hi[[i]])
-      if (tail(part[[i]],1) >= upper[1]) {
+      if (tail(part[[i]], 1) >= upper[1]) {
         stop(paste("part and part_hi incompatible in dim", i))
       }
       part[[i]] <- c(part[[i]], upper)

R/fit_glm.R

@@ -5,7 +5,7 @@ fit_glm.default <- function(x, sim_data, ...) {
 
 
 #' @export
-fit_glm.jaatha_model <- function(x, sim_data, ...) { 
+fit_glm.jaatha_model <- function(x, sim_data, ...) { #nolint
   "Fits a GLM to the simulation results"
   lapply(x$get_sum_stats(), fit_glm, sim_data, ...)
 }
@@ -21,7 +21,7 @@ fit_glm.jaatha_stat_basic <- function(x, sim_data, ...) {
 
   glms <- lapply(1:ncol(Y), function(i) {
     suppressWarnings(
-      glm.fit(X, Y[ , i], family = poisson("log"), 
+      glm.fit(X, Y[, i], family = poisson("log"), 
               control = list(maxit = 100))[c("coefficients", "converged")]
     )
   })

R/initialization.R

@@ -31,7 +31,7 @@ get_start_pos <- function(model, data, reps, sim, init_method, cores,
   }
 
   assert_that(is.matrix(start_pos))
-  assert_that(all((dim(start_pos) == c(reps, model$get_par_number()))))
+  assert_that(all(dim(start_pos) == c(reps, model$get_par_number())))
   start_pos
 }
 

R/jaatha.R

@@ -84,7 +84,7 @@ jaatha <- function(model, data,
   # Setup
   log <- create_jaatha_log(model, data, repetitions, max_steps, verbose = TRUE)
   if (sim_cache_limit < sim) sim_cache_limit <- 0
-  sim_cache <- create_sim_cache(sim_cache_limit)
+  sim_cache <- create_sim_cache(sim_cache_limit) #nolint
 
 
   # Get start positions
@@ -128,7 +128,7 @@ jaatha <- function(model, data,
   best_values <- log$get_best_estimates(5)
   if (nrow(best_values) == 0) stop("No valid estimates.")
   for (i in 1:nrow(best_values)) {
-    llh <- estimate_llh(model, data, as.numeric(best_values[i, -(1:3)]), 
+    llh <- estimate_llh(model, data, as.numeric(best_values[i, -(1:3)]), #nolint 
                         100, cores, TRUE)
     log$log_estimate("final", i, llh, best_values[i, 3])
   }

R/jaatha_log.R

@@ -23,7 +23,8 @@ jaatha_log_class <- R6Class("jaatha_log",
         colnames(estimates) <- c("rep", "step", "llh", par_names)
         as.data.frame(estimates)
       })
-      private$final_estimates <- private$estimates[[1]][rep(1, 5 * par_number), ]
+      private$final_estimates <- 
+        private$estimates[[1]][rep(1, 5 * par_number), ]
       private$reps <- reps
       private$max_steps <- max_steps
       private$verbose <- verbose
@@ -60,7 +61,7 @@ jaatha_log_class <- R6Class("jaatha_log",
     },
     log_convergence = function(step) {
       if (private$verbose) message(" Convergence detected")
-      private$converged[step] = TRUE
+      private$converged[step] <- TRUE
     },
     log_initialization = function(method) {
       if (!private$verbose) return(invisible(NULL))
@@ -85,7 +86,7 @@ jaatha_log_class <- R6Class("jaatha_log",
     create_results = function() {
       "creates the results list the main function returns"
       best_estimate <- self$get_best_estimates(1, TRUE)
-      param <- as.numeric(best_estimate[1, -(1:3)])
+      param <- as.numeric(best_estimate[1, -(1:3)]) #nolint
       res <- list(estimate = private$par_ranges$denormalize(param),
                   loglikelihood = as.numeric(best_estimate[1, 3]),
                   converged = all(private$converged),

R/jaatha_model.R

@@ -53,7 +53,7 @@ jaatha_model_class <- R6Class("jaatha_model",
         withCallingHandlers({
           sim_result <- private$sim_func(sim_pars)
         }, error = function(e) {
-          error_dump = tempfile("jaatha_frame_dump_", fileext = ".Rda")
+          error_dump <- tempfile("jaatha_frame_dump_", fileext = ".Rda")
           dump.frames("sim_error_dump")
           save("sim_error_dump", file = error_dump)
           stop(paste(e$message, "[Frame dump written to", error_dump, "]"), 
@@ -131,7 +131,9 @@ create_jaatha_model <- function(x, ..., scaling_factor = 1, test = TRUE) {
 }
 
 
-create_jaatha_model.default <- function(x, ..., scaling_factor = 1, test = TRUE) {
+create_jaatha_model.default <- function(x, ..., 
+                                        scaling_factor = 1, 
+                                        test = TRUE) {
   stop("Can create a model from an object of class '", class(x), "'")
 }
 

R/likelihood.R

@@ -22,7 +22,7 @@ approximate_llh <- function(x, data, param, glm_fitted, sim, ...) {
 }
 
 #' @export
-approximate_llh.default <- function(x, data, param, glm_fitted, sim, ...) { 
+approximate_llh.default <- function(x, data, param, glm_fitted, sim, ...) { #nolint 
   stop("Unknown Summary Statistic")
 }
 
@@ -58,8 +58,8 @@ optimize_llh <- function(block, model, data, glms, sim) {
                       function(param) {
                         approximate_llh(model, data, param, glms, sim)
                       },
-                      lower = boundary[ , 1, drop = FALSE], 
-                      upper = boundary[ , 2, drop = FALSE],
+                      lower = boundary[, 1, drop = FALSE], 
+                      upper = boundary[, 2, drop = FALSE],
                       method = "L-BFGS-B", 
                       control = list(fnscale = -1))
 

R/par_ranges.R

@@ -11,29 +11,29 @@ par_ranges_class <- R6Class("par_ranges",
       assert_that(is.matrix(par_range))
       assert_that(ncol(par_range) == 2)
       assert_that(nrow(par_range) >= 1)
-      assert_that(all(par_range[ , 1] < par_range[ , 2]))
+      assert_that(all(par_range[, 1] < par_range[, 2]))
       if (is.null(rownames(par_range))) {
         rownames(par_range) <- paste0("p", 1:nrow(par_range))
       }
       private$range <- par_range
       private$offset <- min(par_range) - 1
       private$log_range <- log(par_range - private$offset)
-      private$log_range_width <- private$log_range[ , 2] - 
-                                   private$log_range[ , 1]
+      private$log_range_width <- private$log_range[, 2] - 
+                                   private$log_range[, 1]
     },
     normalize = function(value) {
       log_value <- log(value - private$offset)
-      (log_value - private$log_range[ , 1]) / private$log_range_width
+      (log_value - private$log_range[, 1]) / private$log_range_width
     },
     denormalize = function(value) {
-      exp(value * private$log_range_width + private$log_range[ , 1]) + 
+      exp(value * private$log_range_width + private$log_range[, 1]) + 
         private$offset
     },
     print = function() {
       print(private$range)
     },
     get_middle = function() {
-      (private$range[ , 2] - private$range[ , 1]) / 2 + private$range[ , 1]
+      (private$range[, 2] - private$range[, 1]) / 2 + private$range[, 1]
     },
     get_par_number = function() nrow(private$range),
     get_par_names = function() rownames(private$range)

R/stat_cube.R

@@ -7,7 +7,7 @@ stat_cube_class <- R6Class("stat_cube", inherit = stat_basic_class,
       "calculate the actual values for break_values"
       break_values <- unique(quantile(values, props, na.rm = TRUE))
       break_values[break_values == 0] <- ifelse(length(break_values) == 1, 
-                                    0.01, min(0.01, min(break_values[-1])/2))
+                                    0.01, min(0.01, min(break_values[-1]) / 2))
       break_values
     },
     generate_cube = function(stat, break_values, cols) {
@@ -17,21 +17,22 @@ stat_cube_class <- R6Class("stat_cube", inherit = stat_basic_class,
       assert_that(all(cols <= ncol(stat)))
 
       # Remove rows that contain NAs or NaNs
-      stat <- stat[apply(stat, 1, function(x) all(is.finite(x))), , 
+      stat <- stat[apply(stat, 1, function(x) all(is.finite(x))), , #nolint
                    drop = FALSE]
 
       # Classify the loci accordingly to their statistics
       locus_class <- matrix(1, nrow(stat), ncol(stat))
       for (i in 1:ncol(stat)) {
         for (brk in break_values[[i]]) {
-          locus_class[,i] <- locus_class[,i] + (stat[,i] > brk)
+          locus_class[, i] <- locus_class[, i] + (stat[, i] > brk)
         }
       }
 
       # Count the classes and return as vector
       dims <- vapply(break_values, length, numeric(1)) + 1
       factors <- cumprod(c(1, dims[-length(dims)]))
-      classes_int <- apply(locus_class, 1, function(x) sum((x - 1)*factors) + 1)
+      classes_int <- apply(locus_class, 1, 
+                           function(x) sum((x - 1) * factors) + 1) #nolint
       tabulate(classes_int, nbins = prod(dims))
     }
   ),

tests/testthat.R

@@ -1,2 +1,2 @@
 library(testthat)
-test_check('jaatha')
+test_check("jaatha")

tests/testthat/test-block.R

@@ -3,12 +3,12 @@ context("Block")
 border <- matrix(c(0.4, 0.2, 0.6, 0.4), 2, 2)
 border_1dim <- matrix(c(0, 1), 1, 2)
 
-test_that("blocks can be initalized", {
+test_that("blocks can be initalized", { #nolint
   block <- create_block(border)
   expect_equivalent(block$get_border(), border)
 
   expect_error(create_block(t(border)))
-  expect_error(create_block(border[ , 2:1]))
+  expect_error(create_block(border[, 2:1]))
 
   expect_error(create_block(matrix(c(-1, .5, .5, 2), 2)))
   block <- create_block(matrix(c(-1, .5, .5, 2), 2), TRUE)

tests/testthat/test-coala-interface.R

@@ -4,7 +4,7 @@ test_that("it creates a jaatha model from a coala one", {
   skip_if_not_installed("coala")
   coala_model <- coala::coal_model(10:15, 100) +
     coala::feat_mutation(coala::par_range("theta", 1, 5)) +
-    coala::feat_migration(coala::par_range('m', 1, 5), symmetric = TRUE) +
+    coala::feat_migration(coala::par_range("m", 1, 5), symmetric = TRUE) +
     coala::sumstat_sfs()
   jaatha_model <- create_jaatha_model(coala_model, test = FALSE)
 
@@ -26,7 +26,7 @@ test_that("conversion of coala sumstats works", {
   skip_if_not_installed("coala")
   model <- coala::coal_model(c(10, 15), 1) +
     coala::feat_mutation(coala::par_range("theta", 1, 5)) +
-    coala::feat_migration(coala::par_range('m', 1, 5), symmetric = TRUE)
+    coala::feat_migration(coala::par_range("m", 1, 5), symmetric = TRUE)
 
   expect_equal(convert_coala_sumstats(model), list())
   model <- model + coala::sumstat_sfs()

tests/testthat/test-fit-glm.R

@@ -37,12 +37,12 @@ test_that("glm fitting throws an error if coefficients are 0", {
 
 test_that("fit_glm works for PoiSmooth", {
   skip("Smoothing not implemented")
-  glms.fitted.smooth <- fit_glm(smooth_jaatha, smooth_sim_data)
-  expect_true(is.list(glms.fitted.smooth))
-  expect_equal(1, length(glms.fitted.smooth))
-  expect_true(is.list(glms.fitted.smooth$csi))
-  expect_equal(1, length(glms.fitted.smooth$csi))
-  expect_true("glm" %in% is(glms.fitted.smooth$csi[[1]]))
+  glms_fitted_smooth <- fit_glm(smooth_jaatha, smooth_sim_data)
+  expect_true(is.list(glms_fitted_smooth))
+  expect_equal(1, length(glms_fitted_smooth))
+  expect_true(is.list(glms_fitted_smooth$csi))
+  expect_equal(1, length(glms_fitted_smooth$csi))
+  expect_true("glm" %in% is(glms_fitted_smooth$csi[[1]]))
 })
 
 

tests/testthat/test-jaatha-function.R

@@ -34,3 +34,4 @@ test_that("it supports a one parameter model", {
   expect_equal(results$args$cores, 1)
   expect_equal(results$args$max_steps, 15)
 })
+