13c9d3623d41c85dd73cce33a611d426e332bbfd
[scilab.git] / scilab / modules / elementary_functions / macros / %gsort_multilevel.sci
1 // Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
2 // Copyright (C) 2020 - Samuel GOUGEON
3 //
4 // This file is hereby licensed under the terms of the GNU GPL v2.0,
5 // pursuant to article 5.3.4 of the CeCILL v.2.1.
6 // This file was originally licensed under the terms of the CeCILL v2.1,
7 // and continues to be available under such terms.
8 // For more information, see the COPYING file which you should have
9 // received along with this program.
10
11 function [sorted, K] = %gsort_multilevel(array, sortype, sortdir, criteria)
12     // This internal overload sorts only dense matrices.
13     // For hypermatrices, %hm_gsort() is called upstream
14     //   - to reformat the input as a matrix
15     //   - to call %_gsort() with the equivalent input matrix
16     //   - to reformat the output as expected
17     //   There is nothing specific to complex numbers with hypermatrices
18     // For sparse matrices, %sp_gsort() is called upstream.
19     //
20     // array   : vector or matrix to be sorted.
21     //           Hypermatrices are pre- and post-processed by %hm_gsort()
22     // sortype : "g" "r" "c" "lr" "lc". Default "g"
23     // sortdir: [], or vector of "i" or "d". Default = "d"
24     // criteria: list of Scilab functions or primitives handles, or :.
25     //           When a function fun requires some additional parameters
26     //           a, b, c, ... list(fun, a, b, c,..) must be provided
27     //           instead of only fun.
28
29     sa = size(array)
30
31     // CHECKING INPUT PARAMETERS
32     // -------------------------
33     // array:
34     // This overload is called only when array is defined and are complex numbers
35
36     // sortype:
37     if ~isdef("sortype", "l") || sortype==[] || (type(sortype)==10 && sortype(1)=="")
38         sortype = "g"
39     elseif type(sortype)~=10
40         msg = _("%s: Argument #%d: Text(s) expected.\n")
41         error(msprintf(msg, "gsort", 2))
42     else
43         sortype = convstr(sortype(1))
44         if ~or(sortype==["g" "r" "c" "lr" "lc"])
45             msg = _("%s: Argument #%d: Must be in the set {%s}.\n")
46             error(msprintf(msg, "gsort", 2, "''g'',''r'',''c'',''lc'',''lr''"))
47         end
48     end
49
50     // sortdir:
51     if ~isdef("sortdir", "l") || sortdir==[]
52         sortdir = "d"           // for back-compatibility
53     elseif type(sortdir)~=10
54         msg = _("%s: Argument #%d: Text(s) expected.\n")
55         error(msprintf(msg, "gsort", 3))
56     else
57         sortdir = convstr(sortdir)
58         k = find(sortdir <> "i" & sortdir <> "d")
59         if k <> []
60             msg = _("%s: Argument #%d: Must be in the set {%s}.\n")
61             error(msprintf(msg, "gsort", 3, "''i'',''d''"))
62         end
63     end
64
65     // criteria:
66     if type(criteria) <> 15 then
67         msg = _("%s: Argument #%d: List expected.\n")
68         error(msprintf(msg, "gsort", 4))
69     end
70     if size(criteria) <> size(sortdir,"*") then
71         msg = _("%s: Arguments #%d and #%d: Same numbers of elements expected.\n")
72         error(msprintf(msg, "gsort", 3, 4))
73     end
74     for c = criteria
75         t = type(c)==13 || typeof(c)=="fptr" || ..
76            (typeof(c)=="implicitlist" && (1:1:$)==c)
77         if ~t & type(c)==15
78             if length(c) > 0
79                 t = type(c(1))==13 || typeof(c(1))=="fptr" || ..
80                    (typeof(c(1))=="implicitlist" && (1:1:$)==c(1))
81             end
82         end
83         if ~t
84             msg = _("%s: Argument #%d: List of functions identifiers expected.\n")
85             error(msprintf(msg, "gsort", 4))
86         end
87     end
88
89     // ONLY ONE LEVEL => SIMPLE DIRECT PROCESSING
90     // ------------------------------------------
91     if size(criteria)==1 then
92         fun = criteria(1)
93         if typeof(fun)=="implicitlist" & fun==(1:1:$)
94             [sorted, K] = gsort(array, sortype, sortdir)
95         else
96             v = %gsort_eval(array, fun)
97             [sorted, K] = gsort(v, sortype, sortdir)
98             select sortype
99             case "g"
100                 sorted = matrix(array(K), size(array))
101             case "r"
102                 C = ones(sa(1),1) * (1:sa(2))
103                 sorted = matrix(array(K+(C-1)*sa(1)), sa)
104             case "c"
105                 R = (1:sa(1))' * ones(1,sa(2))
106                 sorted = matrix(array(R+(K-1)*sa(1)), sa)
107             case "lr"
108                 sorted = array(K, :)
109             case "lc"
110                 sorted = array(:, K)
111             end
112         end
113         return
114     end
115
116     // OTHERWISE:
117     // BUILDING THE MATRIX OF SEPARATE RANKS
118     // -------------------------------------
119     nbcrit = length(criteria)
120     a = array(:)
121     kk = []
122     for i = 1:nbcrit
123         fun = criteria(i)
124         v = %gsort_eval(a, fun)
125         [vs, k0] = gsort(v(:), "g", sortdir(i))
126         [?, k2] = gsort(k0,"g","i")
127         // The k(i) of equal elements following the first one must be
128         //  set to the heading index:
129         b = [%T ; vs(2:$) <> vs(1:$-1)];
130         k = cumsum(b);  // Done!
131         kk = [kk k(k2)];
132     end
133
134     // SORTING
135     // -------
136     if sortype=="g" then
137         [?, K] = gsort(kk, "lr", "i");
138         K = matrix(K, sa)
139         sorted = matrix(array(K), sa)
140
141     elseif or(sortype==["c" "r"]) then
142         [?, K] = gsort(kk, "lr", "i");
143         K = matrix(K, sa)
144         z = zeros(sa(1),sa(2))
145         z(K) = 1:prod(sa)
146         [?, K] = gsort(z, sortype, "i")
147         if sortype=="c" then
148             R = (1:sa(1))' * ones(1,sa(2))
149             sorted = matrix(array(R+(K-1)*sa(1)), sa)
150         else // "r"
151             C = ones(sa(1),1) * (1:sa(2))
152             sorted = matrix(array(K+(C-1)*sa(1)), sa)
153         end
154
155     elseif sortype=="lr" then
156         tmp = ones(nbcrit,1)*(1:sa(2))+(0:nbcrit-1)'*ones(1,sa(2))*sa(2)
157         tmp = matrix(kk, sa(1), -1)(:,tmp)
158         [?, K] = gsort(tmp, "lr", "i");
159         sorted = array(K, :)
160
161     else // sortype=="lc"
162         tmp = matrix(kk',nbcrit*sa(1), -1)'
163         [?, K] = gsort(tmp, "lr", "i");
164         K = K'
165         sorted = array(:,K)
166     end
167
168 endfunction
169 // ------------------------------------------------------
170 function v = %gsort_eval(a, fun)
171     if type(fun)==15
172         params = fun
173         params(1) = null()
174         fun = fun(1)
175         if typeof(fun)=="fptr" & fun==atan & type(a)==1 & ~isreal(a)
176             v = fun(imag(a), real(a)) + params(1)
177         else
178             v = fun(a, params(:))
179         end
180     elseif typeof(fun)=="fptr" & fun==atan & type(a)==1 & ~isreal(a)
181         v = atan(imag(a), real(a))
182     elseif typeof(fun)=="implicitlist" & (1:1:$)==fun
183         v = a
184     else
185         v = fun(a)
186     end
187 endfunction