1
#' Constructor functions for the different ggmix objects
2
#'
3
#' \code{new_fullrank_kinship}, \code{new_fullrank_K}, \code{new_fullrank_UD},
4
#' \code{new_lowrank_kinship}, \code{new_lowrank_K} and \code{new_lowrank_UD}
5
#' create the ggmix objects from the provided data that are necessary to fit the
6
#' penalized linear mixed model according to the user's parameters.
7
#'
8
#' @seealso \code{\link{ggmix}}
9
#' @inheritParams ggmix
10
#' @param n_zero_eigenvalues the number of desired or specified zero eigenvalues.
11
#'   This is only needed when \code{estimation="lowrank"}, and is calculated
12
#'   internally by the \code{\link{ggmix}} function. It is equal to the number
13
#'   of observations minus \code{n_nonzero_eigenvalues}
14
#'
15
#' @return A ggmix object, of the class that corresponds to the estimation
16
#'   method. These objects are lists that contain the data necessary for
17
#'   computation. These functions are not meant to be called directly by the
18
#'   user
19
#' @name ggmix_data_object
20
NULL
21

22
#' @rdname ggmix_data_object
23
new_fullrank_kinship <- function(x, y, kinship) {
24 4
  phi_eigen <- eigen(kinship)
25 4
  U_kinship <- phi_eigen$vectors
26 4
  Lambda <- phi_eigen$values
27 4
  if (any(Lambda < 1e-5)) {
28 4
    Lambda[which(Lambda < 1e-5)] <- 1e-05
29
  }
30

31 4
  x <- cbind("(Intercept)" = 1, x)
32 4
  utx <- crossprod(U_kinship, x)
33 4
  uty <- crossprod(U_kinship, y)
34

35 4
  structure(list(
36 4
    x = utx,
37 4
    y = uty,
38 4
    U = U_kinship,
39 4
    D = Lambda
40
  ),
41 4
  class = c("fullrank")
42
  )
43
}
44

45
#' @rdname ggmix_data_object
46
new_fullrank_K <- function(x, y, K) {
47 4
  svdX <- svd(K)
48 4
  U_K <- svdX$u
49 4
  Lambda <- svdX$d^2
50 4
  if (any(Lambda < 1e-5)) {
51 0
    Lambda[which(Lambda < 1e-5)] <- 1e-05
52
  }
53

54 4
  x <- cbind("(Intercept)" = 1, x)
55 4
  utx <- crossprod(U_K, x)
56 4
  uty <- crossprod(U_K, y)
57

58 4
  structure(list(
59 4
    x = utx,
60 4
    y = uty,
61 4
    U = U_K,
62 4
    D = Lambda
63
  ),
64 4
  class = c("fullrank")
65
  )
66
}
67

68
#' @rdname ggmix_data_object
69
new_fullrank_UD <- function(x, y, U, D) {
70 4
  x <- cbind("(Intercept)" = 1, x)
71 4
  utx <- crossprod(U, x)
72 4
  uty <- crossprod(U, y)
73

74 4
  structure(list(
75 4
    x = utx,
76 4
    y = uty,
77 4
    U = U,
78 4
    D = D
79
  ),
80 4
  class = c("fullrank")
81
  )
82
}
83

84

85
#' @rdname ggmix_data_object
86
new_lowrank_kinship <- function(x, y, kinship,
87
                                n_nonzero_eigenvalues,
88
                                n_zero_eigenvalues) {
89 4
  phi_eigen <- RSpectra::eigs(kinship, k = n_nonzero_eigenvalues)
90 4
  U_kinship <- phi_eigen$vectors
91 4
  Lambda <- phi_eigen$values
92 4
  if (any(Lambda < 1e-5)) {
93 0
    Lambda[which(Lambda < 1e-5)] <- 1e-05
94
  }
95

96
  # for lowrank gglasso, and lasso, we use the original X and Y
97
  # because of the W matrix
98
  # we should calculate the W matrix in the lasso and gglaso methods
99
  # since it depends on sigma and eta
100

101 4
  structure(list(
102 4
    x = x, y = y,
103 4
    U = U_kinship,
104 4
    D = Lambda,
105 4
    n_nonzero_eigenvalues = n_nonzero_eigenvalues,
106 4
    n_zero_eigenvalues = n_zero_eigenvalues
107
  ),
108 4
  class = c("lowrank")
109
  )
110
}
111

112
#' @rdname ggmix_data_object
113
new_lowrank_K <- function(x, y, K,
114
                          n_nonzero_eigenvalues,
115
                          n_zero_eigenvalues) {
116 4
  svdX <- RSpectra::svds(K, k = n_nonzero_eigenvalues)
117 4
  U_K <- svdX$u
118 4
  Lambda <- svdX$d^2
119 4
  if (any(Lambda < 1e-5)) {
120 0
    Lambda[which(Lambda < 1e-5)] <- 1e-05
121
  }
122

123 4
  structure(list(
124 4
    x = x, y = y,
125 4
    U = U_K,
126 4
    D = Lambda,
127 4
    n_nonzero_eigenvalues = n_nonzero_eigenvalues,
128 4
    n_zero_eigenvalues = n_zero_eigenvalues
129
  ),
130 4
  class = c("lowrank")
131
  )
132
}
133

134
#' @rdname ggmix_data_object
135
new_lowrank_UD <- function(x, y, U, D,
136
                           n_nonzero_eigenvalues,
137
                           n_zero_eigenvalues) {
138 4
  structure(list(
139 4
    x = x, y = y,
140 4
    U = U,
141 4
    D = D,
142 4
    n_nonzero_eigenvalues = n_nonzero_eigenvalues,
143 4
    n_zero_eigenvalues = n_zero_eigenvalues
144
  ),
145 4
  class = c("lowrank")
146
  )
147
}

Read our documentation on viewing source code .

Loading