fix cov2cor(m) where diag(V) is <= 0 or NA

git-svn-id: https://svn.r-project.org/R/trunk@85706 00db46b3-68df-0310-9c12-caf00c1e9a41

doc/NEWS.Rd

@@ -578,6 +578,10 @@
 
       \item \code{cov2cor(<0x0>)} now works, fixing \PR{18423} thanks to
       Mikael Jagan and Elin Warning.
+
+      \item \code{cov2cor(<negative diagonal>)} and similar now give one
+      warning instead of two, with better wording, fixing \PR{18424} thanks
+      to Mikael Jagan.
     }
   }
 }

src/library/stats/R/cor.R

@@ -194,9 +194,12 @@ cov2cor <- function(V)
     p <- (d <- dim(V))[1L]
     if(!is.numeric(V) || length(d) != 2L || p != d[2L])
 	stop("'V' is not a square numeric matrix")
-    Is <- sqrt(1/diag(V)) # diag( 1/sigma_i )
-    if(any(!is.finite(Is)))
-	warning("diag(.) had 0 or NA entries; non-finite result is doubtful")
+    ## Is := diag( 1/sigma_i )
+    pos <- !is.na(Is <- D <- diag(V, names=FALSE)) & D > 0
+    Is[ pos] <- sqrt(1/D[pos])
+    Is[!pos] <- NaN
+    if(any(!pos) || any(!is.finite(Is)))
+	warning("diag(V) had non-positive or NA entries; the non-finite result may be dubious")
     r <- V # keep dimnames
     r[] <- Is * V * rep(Is, each = p)
     ##	== D %*% V %*% D  where D = diag(Is)

tests/reg-tests-1e.R

@@ -1110,6 +1110,17 @@ stopifnot(identical(cov2cor(m00), m00))
 ## gave error in R <= 4.3.2
 
 
+## cov2cor(.) warning(s) with negative/NA diag(.) - PR#18424
+(D_1 <- diag(-1, 3L))
+op <- options(warn=1)
+m <- capture.output(r <- cov2cor(D_1), type = "message")
+matrix(rep_len(c(1, rep(NaN,3)),3*3), 3) -> r0
+stopifnot(all.equal(r, r0, tol = 0, check.attributes = FALSE),# always ok
+          length(m) == 2, grepl("^ *diag.V. ", m[2]))
+options(op) # revert
+## cov2cor() gave 2 warnings on 3 lines, the 2nd one inaccurate in R <= 4.3.2
+
+
 
 ## keep at end
 rbind(last =  proc.time() - .pt,