Added dp parameter to getAttenuatedR and added function getCorrectedR…

… (with dp parameter!)

NAMESPACE

@@ -19,6 +19,7 @@ export(getCISpearman)
 export(getCIforQuantiles)
 export(getCSC)
 export(getChronbachAlpha)
+export(getCorrectedR)
 export(getICCfromMLM)
 export(getNNA)
 export(getNOK)

R/getAttenuatedR.R

@@ -5,6 +5,7 @@
 #' @param unattR unattenuated R
 #' @param rel1 reliability of first of the variables (order of variables is arbitrary)
 #' @param rel2 reliability of second of the variables (order of variables is arbitrary)
+#' @param dp number of decimal places required for attenuated R
 #'
 #' @return numeric: attenuated correlation
 #'
@@ -35,7 +36,7 @@
 #' @section History/development log:
 #' Started 12.x.24
 #'
-getAttenuatedR <- function(unattR, rel1, rel2) {
+getAttenuatedR <- function(unattR, rel1, rel2, dp = 3) {
   ### sanity checking
   if (!is.numeric(unattR)) {
     stop(paste0("You input ",
@@ -73,8 +74,26 @@ getAttenuatedR <- function(unattR, rel1, rel2) {
   if (length(rel2) > 1) {
     stop("Sorry, you entered more than one value for rel2, this function only handles single values.")
   }
+  if (length(dp) > 1) {
+    stop("Sorry, you entered more than one value for dp, the number of decimal places.  This function only handles single values.")
+  }
+  if (dp < 1){
+    stop(paste0("You entered ",
+                dp,
+                " for dp, the number of decimal places wanted. That must be 1 or higher.  Fix it!!"))
+  }
+  if (dp > 5) {
+    warning(paste0("You entered ",
+                   dp,
+                   " for dp, the number of decimal places wanted.  That is highly unlikely to be meaningful precision."))
+  }
+  if (abs(dp[1]) - round(dp[1]) > .1) {
+    warning(paste0("You entered ",
+                   dp,
+                   " for dp, the number of decimal places wanted.  That's not an integer.  Something wrong there?"))
+  }
 
   ### OK, do it!
-  unattR * sqrt(rel1 * rel2)
+  round(unattR * sqrt(rel1 * rel2), dp)
 }
 

R/getCorrectedR.R

@@ -0,0 +1,118 @@
+#' Function that gives the corrected R for an observed R and two reliability values
+#' @description
+#' This just uses the conventional formula for the attenuation of a (Pearson) correlation by unreliability.
+#'
+#' @param obsR observed R
+#' @param rel1 reliability of first of the variables (order of variables is arbitrary)
+#' @param rel2 reliability of second of the variables (order of variables is arbitrary)
+#' @param dp number of decimal places required for corrected R
+#'
+#' @return numeric: corrected correlation
+#'
+#' @family utility functions
+#'
+#' @section Background:
+#' This is ancient psychometrics but still of some use.  For more information, see:
+#' \href{https://www.psyctc.org/psyctc/glossary2/attenuation-by-unreliability-of-measurement/}{OMbook glossary entry for attenuation}
+#' The formula is simple:
+#' \loadmathjax{}
+#'
+#' \mjdeqn{correctedCorr=observedCorr\frac{\sqrt{rel_{1}*rel_{2}}}}{}
+#'
+#' The short summary is that unreliability in the measurement of both variables involved in a correlation
+#' always reduces the observed correlation between the variables from what it would have been had the
+#' variables been measured with no unreliability (which is essentially impossible for any self-report measures
+#' and pretty much any measures used in our fields.  This uses that relationship to work back to an
+#' assumed "corrected" correlation given an observed correlation and two reliability values.
+#'
+#' For even moderately high observed correlations and low reliabilities the function can easily return
+#' values for the corrected correlation over 1.0.  That's a clear indication that things other than
+#' unreliability and classical test theory are at work.  The function gives a warning in this situation.
+#'
+#'
+#' @export
+#'
+#' @examples
+#' getCorrectedR(.3, .7, .7)
+#' ### should return 0.428571428571429
+#'
+#'
+#'
+#' @author Chris Evans
+#' @section History/development log:
+#' Started 13.x.24
+#'
+getCorrectedR <- function(obsR, rel1, rel2, dp = 3) {
+  ### sanity checking
+  if (!is.numeric(obsR)) {
+    stop(paste0("You input ",
+                obsR,
+                " for obsR, it must be numeric. Fix it!!"
+    ))
+  }
+  if (!is.numeric(rel1)) {
+    stop(paste0("You input ",
+                rel1,
+                " for rel1, it must be numeric. Fix it!!"
+    ))
+  }
+  if (!is.numeric(rel2)) {
+    stop(paste0("You input ",
+                rel2,
+                " for rel2, it must be numeric. Fix it!!"
+    ))
+  }
+  if (!is.numeric(dp)) {
+    stop(paste0("You input ",
+                dp,
+                " for dp, the number of decimal places.  It must be numeric. Fix it!!"
+    ))
+  }
+  if (obsR < -1 | obsR > 1) {
+    stop("obsR must be between -1 and +1.")
+  }
+  if (rel1 < .01 | rel1 >= 1) {
+    stop("For this function rel1 must be between .01 and 1.0.")
+  }
+  if (rel2 < .01 | rel2 >= 1) {
+    stop("For this function rel2 must be between .01 and 1.0.")
+  }
+  if (length(obsR) > 1) {
+    stop("Sorry, you entered more than one value for obsR, this function only handles single values.")
+  }
+  if (length(rel1) > 1) {
+    stop("Sorry, you entered more than one value for rel, this function only handles single values.")
+  }
+  if (length(rel2) > 1) {
+    stop("Sorry, you entered more than one value for rel2, this function only handles single values.")
+  }
+  if (length(dp) > 1) {
+    stop("Sorry, you entered more than one value for dp, the number of decimal places.  This function only handles single values.")
+  }
+  if (dp < 1){
+    stop(paste0("You entered ",
+                dp,
+                " for dp, the number of decimal places wanted. That must be 1 or higher.  Fix it!!"))
+  }
+  if (dp > 5) {
+    warning(paste0("You entered ",
+                   dp,
+                   " for dp, the number of decimal places wanted.  That is highly unlikely to be meaningful precision."))
+  }
+  if (abs(dp[1]) - round(dp[1]) > .1) {
+    warning(paste0("You entered ",
+                   dp,
+                   " for dp, the number of decimal places wanted.  That's not an integer.  Something wrong there?"))
+  }
+
+  ### OK, do it!
+  correctedR <- obsR / sqrt(rel1 * rel2)
+
+  if (correctedR > 1){
+    warning(paste0("The corrected R is ",
+                   correctedR,
+                   " which is over 1.0 and clearly impossible. I think this can happen for many reasons. Beware!"))
+  }
+  round(correctedR, dp)
+}
+

tests/testthat/test-getAttenuatedR.R

@@ -1,23 +1,35 @@
 testthat::test_that("sanity checks work", {
+  ### test unattR
   testthat::expect_error(getAttenuatedR("A", .7, .7))
-  testthat::expect_error(getAttenuatedR(.9, "A", .7))
-  testthat::expect_error(getAttenuatedR(.9, .7, "A"))
   testthat::expect_error(getAttenuatedR(c(.9, .7), "A", .7))
-  testthat::expect_error(getAttenuatedR(.9, c(.7, .8), .7))
-  testthat::expect_error(getAttenuatedR(.9, .7, c(.7, .8)))
   testthat::expect_error(getAttenuatedR(-2, .7, .7))
   testthat::expect_error(getAttenuatedR(1.2, .7, .7))
+
+  ### test rel1
+  testthat::expect_error(getAttenuatedR(.9, "A", .7))
+  testthat::expect_error(getAttenuatedR(.9, c(.7, .8), .7))
   testthat::expect_error(getAttenuatedR(.8, .0001, .7))
-  testthat::expect_error(getAttenuatedR(.8, .7, .0001))
   testthat::expect_error(getAttenuatedR(.8, 1.2, .7))
+  ### test rel2
+  testthat::expect_error(getAttenuatedR(.9, .7, "A"))
+  testthat::expect_error(getAttenuatedR(.9, .7, c(.7, .8)))
+  testthat::expect_error(getAttenuatedR(.8, .7, .0001))
   testthat::expect_error(getAttenuatedR(.8, .7, 1.2))
+  ### test dp
+  testthat::expect_error(getAttenuatedR(.8, .7, 1.2, "A"))
+  testthat::expect_error(getAttenuatedR(.8, .7, 1.2, 1:2))
 })
 
 ## test warnings
+testthat::test_that("Test warning", {
+  testthat::expect_warning(getAttenuatedR(.3, .7, .7, 8))
+})
 
 ### test of outputs
 testthat::test_that("Output correct", {
   set.seed(12345)
   testthat::expect_equal(getAttenuatedR(.9, .7, .7),
                          .63)
+  testthat::expect_equal(getAttenuatedR(.7, .7, .8, 5),
+                         .52383)
 })

tests/testthat/test-getCorrectedR.R

@@ -0,0 +1,36 @@
+testthat::test_that("sanity checks work", {
+  ### test obsR
+  testthat::expect_error(getCorrectedR("A", .7, .7))
+  testthat::expect_error(getCorrectedR(c(.9, .7), .7, .7))
+  testthat::expect_error(getCorrectedR(-2, .7, .7))
+  testthat::expect_error(getCorrectedR(1.2, .7, .7))
+    ### test rel1
+  testthat::expect_error(getCorrectedR(.9, "A", .7))
+  testthat::expect_error(getCorrectedR(.9, c(.7, .8), .7))
+  testthat::expect_error(getCorrectedR(.8, .0001, .7))
+  testthat::expect_error(getCorrectedR(.8, 1.2, .7))
+    ### test rel2
+  testthat::expect_error(getCorrectedR(.9, .7, "A"))
+  testthat::expect_error(getCorrectedR(.9, .7, c(.7, .8)))
+  testthat::expect_error(getCorrectedR(.8, .7, .0001))
+    testthat::expect_error(getCorrectedR(.8, .7, 1.2))
+  ### test dp
+  testthat::expect_error(getCorrectedR(.8, .7, 1.2, "A"))
+  testthat::expect_error(getCorrectedR(.8, .7, 1.2, 1:2))
+})
+
+## test warnings
+testthat::test_that("Test warning", {
+  testthat::expect_warning(getCorrectedR(.9, .7, .7))
+  testthat::expect_warning(getCorrectedR(.3, .7, .7, 8))
+})
+
+
+### test of outputs
+testthat::test_that("Output correct", {
+  set.seed(12345)
+  testthat::expect_equal(getCorrectedR(.3, .7, .7),
+                         0.429)
+  testthat::expect_equal(getCorrectedR(.3, .7, .7, 4),
+                         0.4286)
+})