Solved linting issues

.github/workflows/lint.yaml

@@ -0,0 +1,78 @@
+# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples
+# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
+on:
+  push:
+    branches: [main, master]
+  pull_request:
+    branches: [main, master]
+
+name: lint
+
+jobs:
+  lint:
+    runs-on: ubuntu-latest
+    env:
+      GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+    steps:
+      - uses: actions/checkout@v3
+
+      - uses: r-lib/actions/setup-r@v2
+        with:
+          use-public-rspm: true
+
+      - uses: r-lib/actions/setup-r-dependencies@v2
+        with:
+          extra-packages: any::lintr, local::.
+          needs: lint
+
+      - name: Lint
+        run: |
+          library(lintr)
+          critical_rules <- c(
+            absolute_path_linter(), any_duplicated_linter(),
+            any_is_na_linter(), assignment_linter(), backport_linter(),
+            brace_linter(), class_equals_linter(), commas_linter(),
+            commented_code_linter(), condition_message_linter(),
+            conjunct_test_linter(), consecutive_assertion_linter(),
+            duplicate_argument_linter(), empty_assignment_linter(),
+            equals_na_linter(), expect_comparison_linter(),
+            expect_identical_linter(), expect_not_linter(),
+            expect_null_linter(), expect_s3_class_linter(),
+            expect_s4_class_linter(), expect_true_false_linter(),
+            expect_type_linter(), fixed_regex_linter(),
+            for_loop_index_linter(), function_left_parentheses_linter(),
+            function_return_linter(), if_not_else_linter(),
+            ifelse_censor_linter(), implicit_assignment_linter(),
+            indentation_linter(), infix_spaces_linter(),
+            inner_combine_linter(), is_numeric_linter(),
+            keyword_quote_linter(), length_levels_linter(),
+            length_test_linter(), lengths_linter(),
+            library_call_linter(), literal_coercion_linter(),
+            missing_argument_linter(), missing_package_linter(),
+            namespace_linter(), nested_ifelse_linter(),
+            nonportable_path_linter(), numeric_leading_zero_linter(),
+            object_length_linter(), object_usage_linter(),
+            outer_negation_linter(), package_hooks_linter(),
+            paren_body_linter(), paste_linter(), pipe_call_linter(),
+            pipe_consistency_linter(), pipe_continuation_linter(),
+            quotes_linter(), redundant_equals_linter(),
+            redundant_ifelse_linter(), regex_subset_linter(),
+            repeat_linter(), routine_registration_linter(),
+            scalar_in_linter(), semicolon_linter(), sort_linter(),
+            spaces_inside_linter(), spaces_left_parentheses_linter(),
+            sprintf_linter(), string_boundary_linter(),
+            strings_as_factors_linter(), system_file_linter(),
+            T_and_F_symbol_linter(), undesirable_function_linter(),
+            undesirable_operator_linter(),
+            unnecessary_concatenation_linter(), unnecessary_lambda_linter(),
+            unnecessary_nested_if_linter(),
+            unnecessary_placeholder_linter(), unreachable_code_linter(),
+            unused_import_linter(), vector_logic_linter(),
+            whitespace_linter(), yoda_test_linter()
+          )
+
+          lint_package(linters = critical_rules, show_progress = FALSE)
+
+        shell: Rscript {0}
+        env:
+          LINTR_ERROR_ON_LINT: true

DESCRIPTION

@@ -46,7 +46,8 @@ Imports:
 LinkingTo: Rcpp, RcppArmadillo
 Suggests:
     testthat (>= 3.0.0),
-    pracma
+    pracma,
+    lintr
 License: GPL-3
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)

R/MADMMplasso.R

@@ -50,7 +50,7 @@
 
 #' @example inst/examples/MADMMplasso_example.R
 #' @export
-MADMMplasso <- function(X, Z, y, alpha, my_lambda = NULL, lambda_min = .001, max_it = 50000, e.abs = 1E-3, e.rel = 1E-3, maxgrid, nlambda, rho = 5, my_print = F, alph = 1.8, tree, parallel = T, pal = 0, gg = NULL, tol = 1E-4, cl = 4, legacy = FALSE) {
+MADMMplasso <- function(X, Z, y, alpha, my_lambda = NULL, lambda_min = 0.001, max_it = 50000, e.abs = 1E-3, e.rel = 1E-3, maxgrid, nlambda, rho = 5, my_print = FALSE, alph = 1.8, tree, parallel = TRUE, pal = 0, gg = NULL, tol = 1E-4, cl = 4, legacy = FALSE) {
   N <- nrow(X)
 
   p <- ncol(X)
@@ -93,7 +93,6 @@ MADMMplasso <- function(X, Z, y, alpha, my_lambda = NULL, lambda_min = .001, max
   rat <- lambda_min
 
   if (is.null(my_lambda)) {
-    lamda_new <- matrix(0, dim(y)[2])
     r <- y
 
     lammax <- lapply(
@@ -126,13 +125,9 @@ MADMMplasso <- function(X, Z, y, alpha, my_lambda = NULL, lambda_min = .001, max
   }
 
   lam_list <- list()
-  beta_0_list <- list()
-  theta_0_list <- list()
-  beta_list <- list()
-  theta_list <- list()
-  obj <- c()
-  n_main_terms <- c()
-  non_zero_theta <- c()
+  obj <- NULL
+  n_main_terms <- NULL
+  non_zero_theta <- NULL
   my_obj <- list()
 
   my_W_hat <- generate_my_w(X = X, Z = Z)
@@ -152,7 +147,7 @@ MADMMplasso <- function(X, Z, y, alpha, my_lambda = NULL, lambda_min = .001, max
   I <- matrix(0, nrow = nrow(C) * dim(y)[2], ncol = dim(y)[2])
 
   II <- input[multiple_of_D]
-  diag(I[c(1:dim(y)[2]), ]) <- C[1, ] * (CW[1])
+  diag(I[1:dim(y)[2], ]) <- C[1, ] * (CW[1])
 
   c_count <- 2
   for (e in II[-length(II)]) {
@@ -161,10 +156,10 @@ MADMMplasso <- function(X, Z, y, alpha, my_lambda = NULL, lambda_min = .001, max
   }
   new_I <- diag(t(I) %*% I)
   new_G <- matrix(0, (p + p * K))
-  new_G[c(1:p)] <- 1
-  new_G[-c(1:p)] <- 2
-  new_G[c(1:p)] <- rho * (1 + new_G[c(1:p)])
-  new_G[-c(1:p)] <- rho * (1 + new_G[-c(1:p)])
+  new_G[1:p] <- 1
+  new_G[-1:-p] <- 2
+  new_G[1:p] <- rho * (1 + new_G[1:p])
+  new_G[-1:-p] <- rho * (1 + new_G[-1:-p])
 
   invmat <- list() # denominator of the beta estimates
   for (rr in 1:D) {
@@ -211,42 +206,37 @@ MADMMplasso <- function(X, Z, y, alpha, my_lambda = NULL, lambda_min = .001, max
       admm_MADMMplasso(
         beta0, theta0, beta, beta_hat, theta, rho1, X, Z, max_it, my_W_hat, XtY,
         y, N, e.abs, e.rel, alpha, lam[i, ], alph, svd.w, tree, my_print,
-        invmat, gg[i, ],legacy
+        invmat, gg[i, ], legacy
       )
     }
     parallel::stopCluster(cl)
-  } else if (parallel == F & pal == 0) {
+  } else if (parallel && pal == 0) {
     my_values <- lapply(
       seq_len(nlambda),
       function(g) {
         admm_MADMMplasso(
           beta0, theta0, beta, beta_hat, theta, rho1, X, Z, max_it, my_W_hat,
           XtY, y, N, e.abs, e.rel, alpha, lam[g, ], alph, svd.w, tree, my_print,
-          invmat, gg[g, ],legacy
+          invmat, gg[g, ], legacy
         )
       }
     )
   }
 
-  repeat_loop <- 0
   hh <- 1
   while (hh <= nlambda) {
-    res_dual <- 0 # dual residual
-    res_pri <- 0 # primal residual
-
     lambda <- lam[hh, ]
 
     start_time <- Sys.time()
     if (pal == 1) {
       my_values <- admm_MADMMplasso(
         beta0, theta0, beta, beta_hat, theta, rho1, X, Z, max_it, my_W_hat, XtY,
         y, N, e.abs, e.rel, alpha, lambda, alph, svd.w, tree, my_print, invmat,
-        gg[hh, ],legacy
+        gg[hh, ], legacy
       )
 
       beta <- my_values$beta
       theta <- my_values$theta
-      converge <- my_values$converge
       my_obj[[hh]] <- list(my_values$obj)
       beta0 <- my_values$beta0
       theta0 <- my_values$theta0 ### iteration
@@ -255,19 +245,17 @@ MADMMplasso <- function(X, Z, y, alpha, my_lambda = NULL, lambda_min = .001, max
     }
     cost_time <- Sys.time() - start_time
     print(cost_time)
-    if (parallel == T & pal == 0) {
+    if (parallel && pal == 0) {
       beta <- my_values[hh, ]$beta
       theta <- my_values[hh, ]$theta
-      converge <- my_values[hh, ]$converge
       my_obj[[hh]] <- list(my_values[hh, ]$obj)
       beta0 <- my_values[hh, ]$beta0
       theta0 <- my_values[hh, ]$theta0 ### iteration
       beta_hat <- my_values[hh, ]$beta_hat
       y_hat <- my_values[hh, ]$y_hat
-    } else if (parallel == F & pal == 0) {
+    } else if (parallel && pal == 0) {
       beta <- my_values[[hh]]$beta
       theta <- my_values[[hh]]$theta
-      converge <- my_values[[hh]]$converge
       my_obj[[hh]] <- list(my_values[[hh]]$obj)
       beta0 <- my_values[[hh]]$beta0
       theta0 <- my_values[[hh]]$theta0 ### iteration

R/admm_MADMMplasso.R

@@ -48,7 +48,7 @@
 
 
 #' @export
-admm_MADMMplasso <- function(beta0, theta0, beta, beta_hat, theta, rho1, X, Z, max_it, W_hat, XtY, y, N, e.abs, e.rel, alpha, lambda, alph, svd.w, tree, my_print = T, invmat, gg = 0.2, legacy = FALSE) {
+admm_MADMMplasso <- function(beta0, theta0, beta, beta_hat, theta, rho1, X, Z, max_it, W_hat, XtY, y, N, e.abs, e.rel, alpha, lambda, alph, svd.w, tree, my_print = TRUE, invmat, gg = 0.2, legacy = FALSE) {
   if (!legacy) {
     out <- admm_MADMMplasso_cpp(
       beta0, theta0, beta, beta_hat, theta, rho1, X, Z, max_it, W_hat, XtY, y,
@@ -88,7 +88,7 @@ admm_MADMMplasso <- function(beta0, theta0, beta, beta_hat, theta, rho1, X, Z, m
 
   I <- matrix(0, nrow = nrow(C) * dim(y)[2], ncol = dim(y)[2])
   II <- input[multiple_of_D]
-  diag(I[c(1:dim(y)[2]), ]) <- C[1, ] * (CW[1])
+  diag(I[1:dim(y)[2], ]) <- C[1, ] * (CW[1])
 
   c_count <- 2
   for (e in II[-length(II)]) {
@@ -122,7 +122,7 @@ admm_MADMMplasso <- function(beta0, theta0, beta, beta_hat, theta, rho1, X, Z, m
   EE_old <- EE
   res_pri <- 0
   res_dual <- 0
-  obj <- c()
+  obj <- NULL
 
   SVD_D <- Diagonal(x = svd.w$d)
   R_svd <- (svd.w$u %*% SVD_D) / N
@@ -139,21 +139,19 @@ admm_MADMMplasso <- function(beta0, theta0, beta, beta_hat, theta, rho1, X, Z, m
 
     XtY <- crossprod((W_hat), (new_y))
 
-    main_beta <- array(0, c(p, K + 1, D))
-
     res_val <- rho * (t(I) %*% (E) - (t(I) %*% (H)))
 
     v.diff1 <- matrix(0, D)
     q.diff1 <- matrix(0, D)
     ee.diff1 <- matrix(0, D)
 
     new_G <- matrix(0, (p + p * K))
-    new_G[c(1:p)] <- 1
-    new_G[-c(1:p)] <- 2
-    new_G[c(1:p)] <- rho * (1 + new_G[c(1:p)])
-    new_G[-c(1:p)] <- rho * (1 + new_G[-c(1:p)])
+    new_G[1:p] <- 1
+    new_G[-1:-p] <- 2
+    new_G[1:p] <- rho * (1 + new_G[1:p])
+    new_G[-1:-p] <- rho * (1 + new_G[-1:-p])
 
-    invmat <- lapply(seq_len(D), function(j) {(new_G + rho * (new_I[j] + 1))})
+    invmat <- lapply(seq_len(D), function(j) return(new_G + rho * (new_I[j] + 1)))
 
     for (jj in 1:D) {
       group <- (rho) * (t(G) %*% t(V[, , jj]) - t(G) %*% t(O[, , jj]))
@@ -189,7 +187,7 @@ admm_MADMMplasso <- function(beta0, theta0, beta, beta_hat, theta, rho1, X, Z, m
       Q[, -1, jj] <- sign(new.mat) * pmax(abs(new.mat) - ((alpha * lambda[jj]) / (rho)), 0)
       b_hat <- alph * beta_hat1 + (1 - alph) * EE[, , jj]
       new.mat <- b_hat + HH[, , jj]
-      row.norm1 <- sqrt(apply(new.mat^2, 1, sum, na.rm = T))
+      row.norm1 <- sqrt(apply(new.mat^2, 1, sum, na.rm = TRUE))
       coef.term1 <- pmax(1 - (gg[2]) / rho / (row.norm1), 0)
       ee1 <- scale(t(as.matrix(new.mat)), center = FALSE, scale = 1 / coef.term1)
       EE[, , jj] <- t(ee1)
@@ -200,10 +198,10 @@ admm_MADMMplasso <- function(beta0, theta0, beta, beta_hat, theta, rho1, X, Z, m
 
       # Now we have the main part.
       new.mat <- Big_beta1 + O[, , jj]
-      new.mat1 <- new.mat[, c(1:(K + 1))]
-      new.mat2 <- new.mat[, -c(1:(K + 1))]
-      row.norm1 <- sqrt(apply(new.mat1^2, 1, sum, na.rm = T))
-      row.norm2 <- sqrt(apply(new.mat2^2, 1, sum, na.rm = T))
+      new.mat1 <- new.mat[, 1:(K + 1)]
+      new.mat2 <- new.mat[, -1:-(K + 1)]
+      row.norm1 <- sqrt(apply(new.mat1^2, 1, sum, na.rm = TRUE))
+      row.norm2 <- sqrt(apply(new.mat2^2, 1, sum, na.rm = TRUE))
 
       coef.term1 <- pmax(1 - ((1 - alpha) * lambda[jj]) / (rho) / (row.norm1), 0)
       coef.term2 <- pmax(1 - ((1 - alpha) * lambda[jj]) / (rho) / (row.norm2), 0)
@@ -230,11 +228,11 @@ admm_MADMMplasso <- function(beta0, theta0, beta, beta_hat, theta, rho1, X, Z, m
     beta.group <- (array(NA, c(p + p * K, dim(y)[2], dim(C)[1])))
     N_E <- list()
     II <- input[multiple_of_D]
-    new.mat_group[, , 1] <- t((new.mat[c(1:dim(y)[2]), ]))
-    beta.group[, , 1] <- t((Big_beta_respone[c(1:dim(y)[2]), ]))
+    new.mat_group[, , 1] <- t((new.mat[1:dim(y)[2], ]))
+    beta.group[, , 1] <- t((Big_beta_respone[1:dim(y)[2], ]))
 
     beta_transform <- matrix(0, p, (K + 1) * dim(y)[2])
-    beta_transform[, c(1:(1 + K))] <- matrix(new.mat_group[, 1, 1], ncol = (K + 1), nrow = p)
+    beta_transform[, 1:(1 + K)] <- matrix(new.mat_group[, 1, 1], ncol = (K + 1), nrow = p)
     input2 <- 1:(dim(y)[2] * (1 + K))
     multiple_of_K <- (input2 %% (K + 1)) == 0
     II2 <- input2[multiple_of_K]
@@ -245,14 +243,14 @@ admm_MADMMplasso <- function(beta0, theta0, beta, beta_hat, theta, rho1, X, Z, m
       e2 <- II2[c_count2]
     }
 
-    norm_res <- ((apply(beta_transform, c(1), twonorm)))
+    norm_res <- ((apply(beta_transform, 1, twonorm)))
     coef.term1 <- pmax(1 - (gg[1]) / rho / (norm_res), 0)
 
     N_E1 <- scale(t(beta_transform), center = FALSE, scale = 1 / coef.term1)
 
     N_E1 <- t(N_E1)
     beta_transform1 <- matrix(0, p + p * K, dim(y)[2])
-    beta_transform1[, 1] <- as.vector(N_E1[, c(1:(K + 1))])
+    beta_transform1[, 1] <- as.vector(N_E1[, 1:(K + 1)])
 
     input3 <- 1:(dim(y)[2] * (1 + K))
     multiple_of_K <- (input3 %% (K + 1)) == 0
@@ -272,7 +270,7 @@ admm_MADMMplasso <- function(beta0, theta0, beta, beta_hat, theta, rho1, X, Z, m
       beta.group[, , c_count] <- t(Big_beta_respone[c((e + 1):(c_count * dim(y)[2])), ])
 
       beta_transform <- matrix(0, p, (K + 1) * dim(y)[2])
-      beta_transform[, c(1:(1 + K))] <- matrix(new.mat_group[, 1, c_count], ncol = (K + 1), nrow = p)
+      beta_transform[, 1:(1 + K)] <- matrix(new.mat_group[, 1, c_count], ncol = (K + 1), nrow = p)
       input2 <- 1:(dim(y)[2] * (1 + K))
       multiple_of_K <- (input2 %% (K + 1)) == 0
       II2 <- input2[multiple_of_K]
@@ -283,14 +281,14 @@ admm_MADMMplasso <- function(beta0, theta0, beta, beta_hat, theta, rho1, X, Z, m
         e2 <- II2[c_count2]
       }
 
-      norm_res <- ((apply(beta_transform, c(1), twonorm)))
+      norm_res <- ((apply(beta_transform, 1, twonorm)))
       coef.term1 <- pmax(1 - (gg[1]) / rho / (norm_res), 0)
 
       N_E1 <- scale(t(beta_transform), center = FALSE, scale = 1 / coef.term1)
 
       N_E1 <- t(N_E1)
       beta_transform1 <- matrix(0, p + p * K, dim(y)[2])
-      beta_transform1[, 1] <- as.vector(N_E1[, c(1:(K + 1))])
+      beta_transform1[, 1] <- as.vector(N_E1[, 1:(K + 1)])
 
       input3 <- 1:(dim(y)[2] * (1 + K))
       multiple_of_K <- (input3 %% (K + 1)) == 0
@@ -307,9 +305,7 @@ admm_MADMMplasso <- function(beta0, theta0, beta, beta_hat, theta, rho1, X, Z, m
       e <- II[c_count]
     }
 
-    N_beta.group <- apply(beta.group, 3, twonorm)
-
-    E[c(1:dim(C)[2]), ] <- N_E[[1]]
+    E[1:dim(C)[2], ] <- N_E[[1]]
 
     c_count <- 2
     e <- II[-length(II)][1]
@@ -354,18 +350,18 @@ admm_MADMMplasso <- function(beta0, theta0, beta, beta_hat, theta, rho1, X, Z, m
       rho <- rho / 2
     }
 
-    if (my_print == T) {
+    if (my_print) {
       print(c(res_dual, e.dual, res_pri, e.primal))
     }
     if (res_pri <= e.primal && res_dual <= e.dual) {
       # Remove excess beta and nll
 
       # Update convergence message
       message("Convergence reached after ", i, " iterations")
-      converge <- T
+      converge <- TRUE
       break
     }
-    converge <- F
+    converge <- FALSE
   } ### iteration
 
   res_val <- t(I) %*% (E)
@@ -379,8 +375,8 @@ admm_MADMMplasso <- function(beta0, theta0, beta, beta_hat, theta, rho1, X, Z, m
     new_group[, -1] <- group2
     new_g_theta <- as.vector(new_group)
 
-    finB1 <- as.vector(beta_hat[c(1:p), jj]) * (new_g_theta[c(1:p)] != 0) * (as.vector((Q[, 1, jj])) != 0)
-    finB2 <- as.vector(beta_hat[-c(1:p), jj]) * (new_g_theta[-c(1:p)] != 0) * (as.vector((Q[, -1, jj])) != 0)
+    finB1 <- as.vector(beta_hat[1:p, jj]) * (new_g_theta[1:p] != 0) * (as.vector((Q[, 1, jj])) != 0)
+    finB2 <- as.vector(beta_hat[-1:-p, jj]) * (new_g_theta[-1:-p] != 0) * (as.vector((Q[, -1, jj])) != 0)
 
     beta_hat1 <- matrix(c(finB1, finB2), ncol = (K + 1), nrow = p)
     beta[, jj] <- beta_hat1[, 1]