9292# ' @rdname nfindr
9393# ' @export
9494# ' @include unmixR-package.R
95+ nfindr <- function (
96+ x ,
97+ p ,
98+ init = c(" projections" " random" " coordinates_sequence" " coordinates_random"
99+ iter = c(" points" " endmembers" " both"
100+ estimator = c(" Cramer" " volume" " height" " cofactor" " LDU"
101+ iter_max = 10 ,
102+ n_init = 1 ,
103+ ...
104+ ) {
95105
96- nfindr <- function (x , ... ) {
97- UseMethod(" nfindr"
106+ m <- nrow(x )
107+ n <- ncol(x )
108+
109+ # check for p being with the valid range, >= 2
110+ if (! is.numeric(p ) || p < 2 ) {
111+ stop(" p must be a positive integer >= 2"
112+ }
113+
114+ # # Normalize string arguments -----
115+ iter <- tolower(match.arg(iter ))
116+ estimator <- tolower(match.arg(estimator ))
117+ if (is.character(init )) {
118+ init <- tolower(match.arg(init ))
119+ }
120+
121+ # Check dimensions and number of endmembers ------
122+ if (n != p - 1 ) {
123+ warning(
124+ " Applying N-FINDR without dimension reduction might be inefficient. "
125+ " Consider reducing the dimensionality of the data first, e.g. with PCA."
126+ )
127+ if (estimator != " height"
128+ warning(" Note, `estimator` parameter is forced to 'height'."
129+ }
130+ estimator = " height"
131+ }
132+
133+ # # Parse init --------
134+ # Convert init into list where each element of the list is a set of initial indices
135+ if (is.numeric(init ) && (length(init ) == p )) {
136+ # Single numeric vector of indices
137+ init <- list (init )
138+ if ( (.options(" debuglevel" > 0L ) && (n_init != 1L ) ) {
139+ warning(" `n_init` is ignored since specific initial endmember indices were provided."
140+ }
141+ } else if (is.list(init )) {
142+ # List of numeric vectors (multiple initializations)
143+ if ( (.options(" debuglevel" > 0L ) && (n_init != length(init )) ) {
144+ warning(" `n_init` is ignored since specific initial endmember indices were provided."
145+ }
146+ } else if (is.function(init )) {
147+ # Call the function n_init times
148+ init <- lapply(1 : n_init , function (i ) {
149+ result <- init(x , p )
150+ # Handle both direct indices and list with indices element
151+ if (is.list(result ) && (" indices" %in% names(result )) ) {
152+ result $ indices
153+ } else {
154+ result
155+ }
156+ })
157+ } else if (init == " random"
158+ init <- lapply(1 : n_init , function (i ) sample(m , p ))
159+ } else if (init == " projections"
160+ init <- lapply(1 : n_init , function (i ) random_projections(x , p )$ indices )
161+ } else if (init == " coordinates_sequence"
162+ init <- lapply(1 : n_init , function (i ) extreme_coordinates(x , p , random = FALSE )$ indices )
163+ } else if (init == " coordinates_random"
164+ init <- lapply(1 : n_init , function (i ) extreme_coordinates(x , p , random = TRUE )$ indices )
165+ } else {
166+ stop(" Unexpected `init` value. Must be a string, numeric vector, list of numeric vectors, or function."
167+ }
168+
169+ stopifnot(
170+ is.list(init ) && all(sapply(init , is.numeric )) && all(sapply(init , length ) == p )
171+ )
172+
173+ # # Check number of outer-most iterations --------
174+ # for "both" type iteration increase the number of iteration
175+ # to approximately similar amount that "points" estimator would have
176+ if (iter == " both"
177+ iter_max <- iter_max * p
178+ }
179+
180+ # # Check the selected nfindr method --------
181+ nfindr_func <- get0(
182+ paste(" .nfindr" estimator , iter , sep = " _"
183+ mode = " function"
184+ )
185+ if (is.null(nfindr_func )) {
186+ stop(" Invalid options iter and/or estimator parameters"
187+ }
188+
189+ # transform the input into a matrix
190+ data <- as.matrix(x )
191+
192+ # # Do N-FINDR -----
193+ results_list <- lapply(
194+ init ,
195+ function (indices ) {
196+ nfindr_func(data , indices , iter_max = iter_max )
197+ }
198+ )
199+
200+ # Combine the results
201+ result <- list ()
202+
203+ # Remove duplicate results to avoid unnecessary volume calculations
204+ # sort the indices to normalize the order between runs
205+ unique_indices <- unique(t(
206+ sapply(results_list , function (r ) sort(r $ indices ))
207+ ))
208+
209+ if (nrow(unique_indices ) == 1 ){
210+ # if there is only one unique result, return it
211+ result $ indices <- unique_indices [1 ,]
212+ } else {
213+ # if there are multiple unique results, select the one with the largest volume
214+ volumes <- apply(unique_indices , 1 , function (indices ) simplex_volume(data , indices , factorial = FALSE ))
215+ result $ indices <- unique_indices [which.max(volumes ),]
216+ }
217+
218+ # Add counts for debugging
219+ if (.options(" debuglevel" > 0L ) {
220+ result [[" iterations_count" <- sapply(results_list , function (r ) r $ iterations_count )
221+ result [[" replacements_count" <- sapply(results_list , function (r ) r $ replacements_count )
222+ }
223+
224+ # Add replacements for debugging
225+ if (.options(" debuglevel" > 1L ) {
226+ result [[" replacements" <- lapply(results_list , function (r ) r $ replacements )
227+ }
228+
229+ class(result ) <- " nfindr"
230+
231+ return (result )
98232}
99233
100234
@@ -119,7 +253,7 @@ nfindr <- function (x, ...) {
119253 indices <- 1 : 3
120254 best_indices <- 4 : 6
121255 p <- length(indices )
122- estimators <- eval(formals(nfindr.default )$ estimator )
256+ estimators <- eval(formals(nfindr )$ estimator )
123257 estimators <- estimators [order(tolower(estimators ))]
124258 expect_equal(estimators , c(" cofactor" " Cramer" " height" " LDU" " volume"
125259 # # Test exceptions ----
@@ -436,9 +570,6 @@ nfindr <- function (x, ...) {
436570 })
437571
438572
439- # # Test the formula interface ----
440- # -> nfindr.formula has its own test
441-
442573 # # Test other (hyperSpec) objects ----
443574 test_that (" hyperSpec object"
444575 pca <- prcomp(laser $ spc )
0 commit comments