Create svd_wrapper and copy ginv to avoid LAPACK errors

DESCRIPTION

@@ -34,7 +34,6 @@ Imports:
     ggrepel,
     graphics,
     gridExtra,
-    MASS,
     matrixStats,
     methods,
     parallel,
@@ -45,6 +44,7 @@ Suggests:
     devtools,
     FactoMineR,
     knitr,
+    MASS,
     pander,
     rmarkdown,
     rticles,

NAMESPACE

@@ -41,7 +41,6 @@ export(rgcca_predict)
 export(rgcca_stability)
 export(rgcca_transform)
 importFrom(Deriv,Deriv)
-importFrom(MASS,ginv)
 importFrom(caret,confusionMatrix)
 importFrom(caret,multiClassSummary)
 importFrom(caret,postResample)

R/block_init.R

@@ -1,5 +1,3 @@
-#' @importFrom MASS ginv
-
 block_init <- function(x, init = "svd") {
   UseMethod("block_init")
 }

R/ginv.R

@@ -0,0 +1,20 @@
+# Copy of the ginv function from the MASS package.
+# We replace calls to svd by our wrapper to avoid LAPACK errors.
+ginv <- function (X, tol = sqrt(.Machine$double.eps))
+{
+  if (length(dim(X)) > 2L || !(is.numeric(X) || is.complex(X)))
+    stop("'X' must be a numeric or complex matrix")
+  if (!is.matrix(X))
+    X <- as.matrix(X)
+  Xsvd <- svd_wrapper(X)
+  if (is.complex(X))
+    Xsvd$u <- Conj(Xsvd$u)
+  Positive <- Xsvd$d > max(tol * Xsvd$d[1L], 0)
+  if (all(Positive))
+    Xsvd$v %*% (1/Xsvd$d * t(Xsvd$u))
+  else if (!any(Positive))
+    array(0, dim(X)[2L:1L])
+  else Xsvd$v[, Positive, drop = FALSE] %*% (
+    (1/Xsvd$d[Positive]) * t(Xsvd$u[, Positive, drop = FALSE])
+  )
+}

R/initsvd.R

@@ -21,10 +21,10 @@ initsvd <- function(X, dual = TRUE) {
 
   if (dual) {
     ifelse(n >= p,
-      return(svd(X, nu = 0, nv = 1)$v),
-      return(svd(X, nu = 1, nv = 0)$u)
+      return(svd_wrapper(X, nu = 0, nv = 1)$v),
+      return(svd_wrapper(X, nu = 1, nv = 0)$u)
     )
   } else {
-    return(svd(X, nu = 0, nv = 1)$v)
+    return(svd_wrapper(X, nu = 0, nv = 1)$v)
   }
 }

R/svd_wrapper.R

@@ -0,0 +1,25 @@
+# workaround by Art Owen to avoid LAPACK errors
+# See https://stat.ethz.ch/pipermail/r-help/2007-October/143508.html
+svd_wrapper <- function(x, nu = min(n, p), nv = min(n, p), ...) {
+  success <- FALSE
+  n <- NROW(x)
+  p <- NCOL(x)
+  try({
+    svd_x <- base::svd(x, nu, nv, ...)
+    success <- TRUE
+  }, silent = TRUE)
+  if( success ) {
+    return(svd_x)
+  }
+  try( {
+    svd_tx <- base::svd(t(x), nv, nu, ...)
+    success <- TRUE
+  }, silent = TRUE )
+  if( !success ) {
+    stop("Error: svd(x) and svd(t(x)) both failed to converge.")
+  }
+  temp <- svd_tx$u
+  svd_tx$u <- svd_tx$v
+  svd_tx$v <- temp
+  return(svd_tx)
+}

codemeta.json

@@ -112,6 +112,11 @@
       },
       "sameAs": "https://CRAN.R-project.org/package=knitr"
     },
+    {
+      "@type": "SoftwareApplication",
+      "identifier": "MASS",
+      "name": "MASS"
+    },
     {
       "@type": "SoftwareApplication",
       "identifier": "pander",
@@ -247,18 +252,6 @@
       "sameAs": "https://CRAN.R-project.org/package=gridExtra"
     },
     "8": {
-      "@type": "SoftwareApplication",
-      "identifier": "MASS",
-      "name": "MASS",
-      "provider": {
-        "@id": "https://cran.r-project.org",
-        "@type": "Organization",
-        "name": "Comprehensive R Archive Network (CRAN)",
-        "url": "https://cran.r-project.org"
-      },
-      "sameAs": "https://CRAN.R-project.org/package=MASS"
-    },
-    "9": {
       "@type": "SoftwareApplication",
       "identifier": "matrixStats",
       "name": "matrixStats",