Restyled code

cwendorf · Oct 29, 2023 · 80911b8 · 80911b8
1 parent 53de064
commit 80911b8
Show file tree

Hide file tree

Showing 26 changed files with 675 additions and 600 deletions.
diff --git a/R/calm.R b/R/calm.R
@@ -1,16 +1,16 @@
 # Contrast Algorithms for Linear Models
 ## Conversion Functions
 
-calm.encode <- function(L,digits=4) {
+calm.encode <- function(L, digits = 4) {
   X <- t(L) %*% solve(L %*% t(L))
-  rownames(X)=rownames(X,do.NULL=FALSE,prefix="GROUP ")
-  colnames(X)=colnames(X,do.NULL=FALSE,prefix="CODE ")
-  return(round(X,digits))
+  rownames(X) <- rownames(X, do.NULL = FALSE, prefix = "GROUP ")
+  colnames(X) <- colnames(X, do.NULL = FALSE, prefix = "CODE ")
+  return(round(X, digits))
 }
 
-calm.decode <- function(X,digits=4) {
+calm.decode <- function(X, digits = 4) {
   L <- solve(t(X) %*% X) %*% t(X)
-  rownames(L)=rownames(L,do.NULL=FALSE,prefix="HYPOTH ")
-  colnames(L)=colnames(L,do.NULL=FALSE,prefix="GROUP ")   
-  return(round(L,digits))
+  rownames(L) <- rownames(L, do.NULL = FALSE, prefix = "HYPOTH ")
+  colnames(L) <- colnames(L, do.NULL = FALSE, prefix = "GROUP ")
+  return(round(L, digits))
 }
diff --git a/R/control.R b/R/control.R
@@ -8,30 +8,31 @@
 ### codingMatrices Equivalent: control
 ### Original Code: codingMatrices
 
-control.first <- function(n, intercept=FALSE, contrasts = TRUE, sparse = FALSE) {
+control.first <- function(n, intercept = FALSE, contrasts = TRUE, sparse = FALSE) {
   if (is.numeric(n) && length(n) == 1L) {
-    if (n > 1L)
+    if (n > 1L) {
       levels <- .zf(seq_len(n))
-    else stop("not enough degrees of freedom to define contrasts")
-  }
-  else {
+    } else {
+      stop("not enough degrees of freedom to define contrasts")
+    }
+  } else {
     levels <- as.character(n)
     n <- length(n)
   }
   B <- diag(n)
   dimnames(B) <- list(1:n, levels)
-  if(!contrasts) {
-    if(sparse) B <- .asSparse(B)
+  if (!contrasts) {
+    if (sparse) B <- .asSparse(B)
     return(B)
   }
-  if(max(nchar(levels)) > 3) {
+  if (max(nchar(levels)) > 3) {
     levels <- paste0("m", .zf(seq_len(n)))
   }
-  B <- B - 1/n
+  B <- B - 1 / n
   B <- B[, -1, drop = FALSE]
-  colnames(B) <- paste(levels[-1], levels[1], sep="-")
-  if(intercept) (B <- cbind(Int=1,B))
-  if(sparse){
+  colnames(B) <- paste(levels[-1], levels[1], sep = "-")
+  if (intercept) (B <- cbind(Int = 1, B))
+  if (sparse) {
     .asSparse(B)
   } else {
     B
@@ -45,30 +46,31 @@ control.first <- function(n, intercept=FALSE, contrasts = TRUE, sparse = FALSE)
 ### codingMatrices Equivalent: control_last
 ### Original Code: codingMatrices
 
-control.last <- function(n, intercept=FALSE, contrasts = TRUE, sparse = FALSE) {
+control.last <- function(n, intercept = FALSE, contrasts = TRUE, sparse = FALSE) {
   if (is.numeric(n) && length(n) == 1L) {
-    if (n > 1L)
+    if (n > 1L) {
       levels <- .zf(seq_len(n))
-    else stop("not enough degrees of freedom to define contrasts")
-  }
-  else {
+    } else {
+      stop("not enough degrees of freedom to define contrasts")
+    }
+  } else {
     levels <- as.character(n)
     n <- length(n)
   }
   B <- diag(n)
   dimnames(B) <- list(1:n, levels)
-  if(!contrasts) {
-    if(sparse) B <- .asSparse(B)
+  if (!contrasts) {
+    if (sparse) B <- .asSparse(B)
     return(B)
   }
-  if(max(nchar(levels)) > 3) {
+  if (max(nchar(levels)) > 3) {
     levels <- paste0("m", .zf(seq_len(n)))
   }
-  B <- B - 1/n
+  B <- B - 1 / n
   B <- B[, -n, drop = FALSE]
-  colnames(B) <- paste(levels[-n], levels[n], sep="-")
-  if(intercept) (B <- cbind(Int=1,B))
-  if(sparse){
+  colnames(B) <- paste(levels[-n], levels[n], sep = "-")
+  if (intercept) (B <- cbind(Int = 1, B))
+  if (sparse) {
     .asSparse(B)
   } else {
     B

diff --git a/R/deviation.R b/R/deviation.R
@@ -8,26 +8,27 @@
 ### codingMatrices Equivalent: deviation_first
 ### Original Code: codingMatrices
 
-deviation.first <- function(n, intercept=FALSE, contrasts=TRUE, sparse=FALSE) {
+deviation.first <- function(n, intercept = FALSE, contrasts = TRUE, sparse = FALSE) {
   if (is.numeric(n) && length(n) == 1L) {
-    if (n > 1L)
+    if (n > 1L) {
       levels <- .zf(seq_len(n))
-    else stop("not enough degrees of freedom to define contrasts")
-  }
-  else {
+    } else {
+      stop("not enough degrees of freedom to define contrasts")
+    }
+  } else {
     levels <- as.character(n)
     n <- length(n)
   }
-  if(!contrasts) {
+  if (!contrasts) {
     B <- diag(n)
     dimnames(B) <- list(1:n, levels)
-    if(sparse) B <- .asSparse(B)
+    if (sparse) B <- .asSparse(B)
     return(B)
   }
-  B <- rbind(-1, diag(n-1))
+  B <- rbind(-1, diag(n - 1))
   dimnames(B) <- list(1:n, paste0("MD", .zf(2:n)))
-  if(intercept) (B <- cbind(Int=1,B))  
-  if(sparse){
+  if (intercept) (B <- cbind(Int = 1, B))
+  if (sparse) {
     .asSparse(B)
   } else {
     B
@@ -41,20 +42,24 @@ deviation.first <- function(n, intercept=FALSE, contrasts=TRUE, sparse=FALSE) {
 ### codingMatrices Equivalent: deviation
 ### Original Code: R Base
 
-deviation.last <- function (n, intercept=FALSE, contrasts=TRUE, sparse=FALSE) {
-    if (length(n) <= 1L) {
-        if (is.numeric(n) && length(n) == 1L && n > 1L) levels <- seq_len(n)
-        else stop("not enough degrees of freedom to define contrasts")
-    }
-    else levels <- n
-    levels <- as.character(levels)
-    cont <- .Diag(levels, sparse = sparse)
-    if (contrasts) {
-        cont <- cont[, -length(levels), drop = FALSE]
-        cont[length(levels), ] <- -1
-        colnames(cont) <- NULL
-        #dimnames(cont) <- list(1:n, paste0("MD", .zf(1:(n-1))))  
+deviation.last <- function(n, intercept = FALSE, contrasts = TRUE, sparse = FALSE) {
+  if (length(n) <= 1L) {
+    if (is.numeric(n) && length(n) == 1L && n > 1L) {
+      levels <- seq_len(n)
+    } else {
+      stop("not enough degrees of freedom to define contrasts")
     }
-    if(intercept) (cont <- cbind(Int=1,cont))
-    cont
+  } else {
+    levels <- n
+  }
+  levels <- as.character(levels)
+  cont <- .Diag(levels, sparse = sparse)
+  if (contrasts) {
+    cont <- cont[, -length(levels), drop = FALSE]
+    cont[length(levels), ] <- -1
+    colnames(cont) <- NULL
+    # dimnames(cont) <- list(1:n, paste0("MD", .zf(1:(n-1))))
+  }
+  if (intercept) (cont <- cbind(Int = 1, cont))
+  cont
 }
diff --git a/R/difference.R b/R/difference.R
@@ -8,33 +8,36 @@
 ### codingMatrices Equivalent: diff_forward
 ### Original Code: codingMatrices
 
-difference.forward <- function(n, intercept=FALSE,contrasts = TRUE, sparse = FALSE) {
+difference.forward <- function(n, intercept = FALSE, contrasts = TRUE, sparse = FALSE) {
   if (is.numeric(n) && length(n) == 1L) {
-    if (n > 1L)
+    if (n > 1L) {
       levels <- .zf(seq_len(n))
-    else stop("not enough degrees of freedom to define contrasts")
-  }
-  else {
+    } else {
+      stop("not enough degrees of freedom to define contrasts")
+    }
+  } else {
     levels <- as.character(n)
     n <- length(n)
   }
-  if(!contrasts) {
+  if (!contrasts) {
     B <- diag(n)
     dimnames(B) <- list(1:n, levels)
-    if(sparse) B <- .asSparse(B)
+    if (sparse) B <- .asSparse(B)
     return(B)
   }
-  if(max(nchar(levels)) > 3) {
+  if (max(nchar(levels)) > 3) {
     levels <- paste0("m", .zf(seq_len(n)))
   }
   B <- 1 - col(matrix(0, n, n))
   ut <- upper.tri(B)
   B[ut] <- n + B[ut]
-  B <- B[, -1, drop = FALSE]/n
-  dimnames(B) <- list(1:n,
-                      paste(levels[-n], levels[-1], sep = "-"))
-  if(intercept) (B <- cbind(Int=1,B))
-  if(sparse){
+  B <- B[, -1, drop = FALSE] / n
+  dimnames(B) <- list(
+    1:n,
+    paste(levels[-n], levels[-1], sep = "-")
+  )
+  if (intercept) (B <- cbind(Int = 1, B))
+  if (sparse) {
     .asSparse(B)
   } else {
     B
@@ -48,33 +51,36 @@ difference.forward <- function(n, intercept=FALSE,contrasts = TRUE, sparse = FAL
 ### codingMatrices Equivalent: diff
 ### Original Code: codingMatrices
 
-difference.reverse <- function(n, intercept=FALSE, contrasts = TRUE, sparse = FALSE) {
+difference.reverse <- function(n, intercept = FALSE, contrasts = TRUE, sparse = FALSE) {
   if (is.numeric(n) && length(n) == 1L) {
-    if (n > 1L)
+    if (n > 1L) {
       levels <- .zf(seq_len(n))
-    else stop("not enough degrees of freedom to define contrasts")
-  }
-  else {
+    } else {
+      stop("not enough degrees of freedom to define contrasts")
+    }
+  } else {
     levels <- as.character(n)
     n <- length(n)
   }
-  if(!contrasts) {
+  if (!contrasts) {
     B <- diag(n)
     dimnames(B) <- list(1:n, levels)
-    if(sparse) B <- .asSparse(B)
+    if (sparse) B <- .asSparse(B)
     return(B)
   }
-  if(max(nchar(levels)) > 3) {
+  if (max(nchar(levels)) > 3) {
     levels <- paste0("m", .zf(seq_len(n)))
   }
   B <- col(matrix(0, n, n)) - 1
   ut <- upper.tri(B)
   B[ut] <- B[ut] - n
-  B <- B[, -1, drop = FALSE]/n
-  dimnames(B) <- list(1:n,
-                      paste(levels[-1], levels[-n], sep = "-"))
-  if(intercept) (B <- cbind(Int=1,B))  
-  if(sparse){
+  B <- B[, -1, drop = FALSE] / n
+  dimnames(B) <- list(
+    1:n,
+    paste(levels[-1], levels[-n], sep = "-")
+  )
+  if (intercept) (B <- cbind(Int = 1, B))
+  if (sparse) {
     .asSparse(B)
   } else {
     B

diff --git a/R/helmert.R b/R/helmert.R
@@ -8,28 +8,29 @@
 ### codingMatrices Equivalent: helmert_forward
 ### Original Code: codingMatrices
 
-helmert.forward <- function(n, intercept=FALSE, contrasts=TRUE, sparse=FALSE) {
+helmert.forward <- function(n, intercept = FALSE, contrasts = TRUE, sparse = FALSE) {
   if (is.numeric(n) && length(n) == 1L) {
-    if (n > 1L)
+    if (n > 1L) {
       levels <- .zf(seq_len(n))
-    else stop("not enough degrees of freedom to define contrasts")
-  }
-  else {
+    } else {
+      stop("not enough degrees of freedom to define contrasts")
+    }
+  } else {
     levels <- as.character(n)
     n <- length(n)
   }
-  if(!contrasts) {
+  if (!contrasts) {
     B <- diag(n)
     dimnames(B) <- list(1:n, levels)
-    if(sparse) B <- .asSparse(B)
+    if (sparse) B <- .asSparse(B)
     return(B)
   }
   B <- rbind(diag(n:2 - 1), 0)
   B[lower.tri(B)] <- -1
-  B <- B/rep(n:2, each = n)
+  B <- B / rep(n:2, each = n)
   dimnames(B) <- list(1:n, paste0("FH", .zf(2:n - 1)))
-  if(intercept) (B <- cbind(Int=1,B))   
-  if(sparse){
+  if (intercept) (B <- cbind(Int = 1, B))
+  if (sparse) {
     .asSparse(B)
   } else {
     B
@@ -45,27 +46,28 @@ helmert.forward <- function(n, intercept=FALSE, contrasts=TRUE, sparse=FALSE) {
 
 helmert.reverse <- function(n, intercept = FALSE, contrasts = TRUE, sparse = FALSE) {
   if (is.numeric(n) && length(n) == 1L) {
-    if (n > 1L)
+    if (n > 1L) {
       levels <- .zf(seq_len(n))
-    else stop("not enough degrees of freedom to define contrasts")
-  }
-  else {
+    } else {
+      stop("not enough degrees of freedom to define contrasts")
+    }
+  } else {
     levels <- as.character(n)
     n <- length(n)
   }
-  if(!contrasts) {
+  if (!contrasts) {
     B <- diag(n)
     dimnames(B) <- list(1:n, levels)
-    if(sparse) B <- .asSparse(B)
+    if (sparse) B <- .asSparse(B)
     return(B)
   }
   B <- diag(1:n - 1)
   B[upper.tri(B)] <- -1
-  B  <- B/rep(1:n, each = n)
+  B <- B / rep(1:n, each = n)
   B <- B[, -1, drop = FALSE]
   dimnames(B) <- list(1:n, paste0("RH", .zf(2:n)))
-  if(intercept) (B <- cbind(Int=1,B))  
-  if(sparse) {
+  if (intercept) (B <- cbind(Int = 1, B))
+  if (sparse) {
     .asSparse(B)
   } else {
     B