├── .gitignore ├── LICENSE ├── README.md ├── project.clj └── src └── matlib ├── control.clj ├── core.clj ├── de.clj ├── ident.clj ├── linalg.clj ├── optim.clj ├── state_space.clj └── stats.clj /.gitignore: -------------------------------------------------------------------------------- 1 | /target 2 | /classes 3 | /checkouts 4 | profiles.clj 5 | pom.xml 6 | pom.xml.asc 7 | *.jar 8 | *.class 9 | /.lein-* 10 | /.nrepl-port 11 | .hgignore 12 | .hg/ 13 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Eclipse Public License - v 2.0 2 | 3 | THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE 4 | PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION 5 | OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. 6 | 7 | 1. DEFINITIONS 8 | 9 | "Contribution" means: 10 | 11 | a) in the case of the initial Contributor, the initial content 12 | Distributed under this Agreement, and 13 | 14 | b) in the case of each subsequent Contributor: 15 | i) changes to the Program, and 16 | ii) additions to the Program; 17 | where such changes and/or additions to the Program originate from 18 | and are Distributed by that particular Contributor. A Contribution 19 | "originates" from a Contributor if it was added to the Program by 20 | such Contributor itself or anyone acting on such Contributor's behalf. 21 | Contributions do not include changes or additions to the Program that 22 | are not Modified Works. 23 | 24 | "Contributor" means any person or entity that Distributes the Program. 25 | 26 | "Licensed Patents" mean patent claims licensable by a Contributor which 27 | are necessarily infringed by the use or sale of its Contribution alone 28 | or when combined with the Program. 29 | 30 | "Program" means the Contributions Distributed in accordance with this 31 | Agreement. 32 | 33 | "Recipient" means anyone who receives the Program under this Agreement 34 | or any Secondary License (as applicable), including Contributors. 35 | 36 | "Derivative Works" shall mean any work, whether in Source Code or other 37 | form, that is based on (or derived from) the Program and for which the 38 | editorial revisions, annotations, elaborations, or other modifications 39 | represent, as a whole, an original work of authorship. 40 | 41 | "Modified Works" shall mean any work in Source Code or other form that 42 | results from an addition to, deletion from, or modification of the 43 | contents of the Program, including, for purposes of clarity any new file 44 | in Source Code form that contains any contents of the Program. Modified 45 | Works shall not include works that contain only declarations, 46 | interfaces, types, classes, structures, or files of the Program solely 47 | in each case in order to link to, bind by name, or subclass the Program 48 | or Modified Works thereof. 49 | 50 | "Distribute" means the acts of a) distributing or b) making available 51 | in any manner that enables the transfer of a copy. 52 | 53 | "Source Code" means the form of a Program preferred for making 54 | modifications, including but not limited to software source code, 55 | documentation source, and configuration files. 56 | 57 | "Secondary License" means either the GNU General Public License, 58 | Version 2.0, or any later versions of that license, including any 59 | exceptions or additional permissions as identified by the initial 60 | Contributor. 61 | 62 | 2. GRANT OF RIGHTS 63 | 64 | a) Subject to the terms of this Agreement, each Contributor hereby 65 | grants Recipient a non-exclusive, worldwide, royalty-free copyright 66 | license to reproduce, prepare Derivative Works of, publicly display, 67 | publicly perform, Distribute and sublicense the Contribution of such 68 | Contributor, if any, and such Derivative Works. 69 | 70 | b) Subject to the terms of this Agreement, each Contributor hereby 71 | grants Recipient a non-exclusive, worldwide, royalty-free patent 72 | license under Licensed Patents to make, use, sell, offer to sell, 73 | import and otherwise transfer the Contribution of such Contributor, 74 | if any, in Source Code or other form. This patent license shall 75 | apply to the combination of the Contribution and the Program if, at 76 | the time the Contribution is added by the Contributor, such addition 77 | of the Contribution causes such combination to be covered by the 78 | Licensed Patents. The patent license shall not apply to any other 79 | combinations which include the Contribution. No hardware per se is 80 | licensed hereunder. 81 | 82 | c) Recipient understands that although each Contributor grants the 83 | licenses to its Contributions set forth herein, no assurances are 84 | provided by any Contributor that the Program does not infringe the 85 | patent or other intellectual property rights of any other entity. 86 | Each Contributor disclaims any liability to Recipient for claims 87 | brought by any other entity based on infringement of intellectual 88 | property rights or otherwise. As a condition to exercising the 89 | rights and licenses granted hereunder, each Recipient hereby 90 | assumes sole responsibility to secure any other intellectual 91 | property rights needed, if any. For example, if a third party 92 | patent license is required to allow Recipient to Distribute the 93 | Program, it is Recipient's responsibility to acquire that license 94 | before distributing the Program. 95 | 96 | d) Each Contributor represents that to its knowledge it has 97 | sufficient copyright rights in its Contribution, if any, to grant 98 | the copyright license set forth in this Agreement. 99 | 100 | e) Notwithstanding the terms of any Secondary License, no 101 | Contributor makes additional grants to any Recipient (other than 102 | those set forth in this Agreement) as a result of such Recipient's 103 | receipt of the Program under the terms of a Secondary License 104 | (if permitted under the terms of Section 3). 105 | 106 | 3. REQUIREMENTS 107 | 108 | 3.1 If a Contributor Distributes the Program in any form, then: 109 | 110 | a) the Program must also be made available as Source Code, in 111 | accordance with section 3.2, and the Contributor must accompany 112 | the Program with a statement that the Source Code for the Program 113 | is available under this Agreement, and informs Recipients how to 114 | obtain it in a reasonable manner on or through a medium customarily 115 | used for software exchange; and 116 | 117 | b) the Contributor may Distribute the Program under a license 118 | different than this Agreement, provided that such license: 119 | i) effectively disclaims on behalf of all other Contributors all 120 | warranties and conditions, express and implied, including 121 | warranties or conditions of title and non-infringement, and 122 | implied warranties or conditions of merchantability and fitness 123 | for a particular purpose; 124 | 125 | ii) effectively excludes on behalf of all other Contributors all 126 | liability for damages, including direct, indirect, special, 127 | incidental and consequential damages, such as lost profits; 128 | 129 | iii) does not attempt to limit or alter the recipients' rights 130 | in the Source Code under section 3.2; and 131 | 132 | iv) requires any subsequent distribution of the Program by any 133 | party to be under a license that satisfies the requirements 134 | of this section 3. 135 | 136 | 3.2 When the Program is Distributed as Source Code: 137 | 138 | a) it must be made available under this Agreement, or if the 139 | Program (i) is combined with other material in a separate file or 140 | files made available under a Secondary License, and (ii) the initial 141 | Contributor attached to the Source Code the notice described in 142 | Exhibit A of this Agreement, then the Program may be made available 143 | under the terms of such Secondary Licenses, and 144 | 145 | b) a copy of this Agreement must be included with each copy of 146 | the Program. 147 | 148 | 3.3 Contributors may not remove or alter any copyright, patent, 149 | trademark, attribution notices, disclaimers of warranty, or limitations 150 | of liability ("notices") contained within the Program from any copy of 151 | the Program which they Distribute, provided that Contributors may add 152 | their own appropriate notices. 153 | 154 | 4. COMMERCIAL DISTRIBUTION 155 | 156 | Commercial distributors of software may accept certain responsibilities 157 | with respect to end users, business partners and the like. While this 158 | license is intended to facilitate the commercial use of the Program, 159 | the Contributor who includes the Program in a commercial product 160 | offering should do so in a manner which does not create potential 161 | liability for other Contributors. Therefore, if a Contributor includes 162 | the Program in a commercial product offering, such Contributor 163 | ("Commercial Contributor") hereby agrees to defend and indemnify every 164 | other Contributor ("Indemnified Contributor") against any losses, 165 | damages and costs (collectively "Losses") arising from claims, lawsuits 166 | and other legal actions brought by a third party against the Indemnified 167 | Contributor to the extent caused by the acts or omissions of such 168 | Commercial Contributor in connection with its distribution of the Program 169 | in a commercial product offering. The obligations in this section do not 170 | apply to any claims or Losses relating to any actual or alleged 171 | intellectual property infringement. In order to qualify, an Indemnified 172 | Contributor must: a) promptly notify the Commercial Contributor in 173 | writing of such claim, and b) allow the Commercial Contributor to control, 174 | and cooperate with the Commercial Contributor in, the defense and any 175 | related settlement negotiations. The Indemnified Contributor may 176 | participate in any such claim at its own expense. 177 | 178 | For example, a Contributor might include the Program in a commercial 179 | product offering, Product X. That Contributor is then a Commercial 180 | Contributor. If that Commercial Contributor then makes performance 181 | claims, or offers warranties related to Product X, those performance 182 | claims and warranties are such Commercial Contributor's responsibility 183 | alone. Under this section, the Commercial Contributor would have to 184 | defend claims against the other Contributors related to those performance 185 | claims and warranties, and if a court requires any other Contributor to 186 | pay any damages as a result, the Commercial Contributor must pay 187 | those damages. 188 | 189 | 5. NO WARRANTY 190 | 191 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, AND TO THE EXTENT 192 | PERMITTED BY APPLICABLE LAW, THE PROGRAM IS PROVIDED ON AN "AS IS" 193 | BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER EXPRESS OR 194 | IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR CONDITIONS OF 195 | TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR 196 | PURPOSE. Each Recipient is solely responsible for determining the 197 | appropriateness of using and distributing the Program and assumes all 198 | risks associated with its exercise of rights under this Agreement, 199 | including but not limited to the risks and costs of program errors, 200 | compliance with applicable laws, damage to or loss of data, programs 201 | or equipment, and unavailability or interruption of operations. 202 | 203 | 6. DISCLAIMER OF LIABILITY 204 | 205 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, AND TO THE EXTENT 206 | PERMITTED BY APPLICABLE LAW, NEITHER RECIPIENT NOR ANY CONTRIBUTORS 207 | SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 208 | EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION LOST 209 | PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 210 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 211 | ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE 212 | EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE 213 | POSSIBILITY OF SUCH DAMAGES. 214 | 215 | 7. GENERAL 216 | 217 | If any provision of this Agreement is invalid or unenforceable under 218 | applicable law, it shall not affect the validity or enforceability of 219 | the remainder of the terms of this Agreement, and without further 220 | action by the parties hereto, such provision shall be reformed to the 221 | minimum extent necessary to make such provision valid and enforceable. 222 | 223 | If Recipient institutes patent litigation against any entity 224 | (including a cross-claim or counterclaim in a lawsuit) alleging that the 225 | Program itself (excluding combinations of the Program with other software 226 | or hardware) infringes such Recipient's patent(s), then such Recipient's 227 | rights granted under Section 2(b) shall terminate as of the date such 228 | litigation is filed. 229 | 230 | All Recipient's rights under this Agreement shall terminate if it 231 | fails to comply with any of the material terms or conditions of this 232 | Agreement and does not cure such failure in a reasonable period of 233 | time after becoming aware of such noncompliance. If all Recipient's 234 | rights under this Agreement terminate, Recipient agrees to cease use 235 | and distribution of the Program as soon as reasonably practicable. 236 | However, Recipient's obligations under this Agreement and any licenses 237 | granted by Recipient relating to the Program shall continue and survive. 238 | 239 | Everyone is permitted to copy and distribute copies of this Agreement, 240 | but in order to avoid inconsistency the Agreement is copyrighted and 241 | may only be modified in the following manner. The Agreement Steward 242 | reserves the right to publish new versions (including revisions) of 243 | this Agreement from time to time. No one other than the Agreement 244 | Steward has the right to modify this Agreement. The Eclipse Foundation 245 | is the initial Agreement Steward. The Eclipse Foundation may assign the 246 | responsibility to serve as the Agreement Steward to a suitable separate 247 | entity. Each new version of the Agreement will be given a distinguishing 248 | version number. The Program (including Contributions) may always be 249 | Distributed subject to the version of the Agreement under which it was 250 | received. In addition, after a new version of the Agreement is published, 251 | Contributor may elect to Distribute the Program (including its 252 | Contributions) under the new version. 253 | 254 | Except as expressly stated in Sections 2(a) and 2(b) above, Recipient 255 | receives no rights or licenses to the intellectual property of any 256 | Contributor under this Agreement, whether expressly, by implication, 257 | estoppel or otherwise. All rights in the Program not expressly granted 258 | under this Agreement are reserved. Nothing in this Agreement is intended 259 | to be enforceable by any entity that is not a Contributor or Recipient. 260 | No third-party beneficiary rights are created under this Agreement. 261 | 262 | Exhibit A - Form of Secondary Licenses Notice 263 | 264 | "This Source Code may also be made available under the following 265 | Secondary Licenses when the conditions for such availability set forth 266 | in the Eclipse Public License, v. 2.0 are satisfied: GNU General Public 267 | License as published by the Free Software Foundation, either version 2 268 | of the License, or (at your option) any later version, with the GNU 269 | Classpath Exception which is available at 270 | https://www.gnu.org/software/classpath/license.html." 271 | 272 | Simply including a copy of this Agreement, including this Exhibit A 273 | is not sufficient to license the Source Code under Secondary Licenses. 274 | 275 | If it is not possible or desirable to put the notice in a particular 276 | file, then You may include the notice in a location (such as a LICENSE 277 | file in a relevant directory) where a recipient would be likely to 278 | look for such a notice. 279 | 280 | You may add additional accurate notices of copyright ownership. 281 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![PRsWelcome](https://img.shields.io/badge/PRs-welcome-brightgreen.svg?style=flat-square)](http://makeapullrequest.com) 2 | [![Clojars Project](https://img.shields.io/clojars/v/matlib.svg)](https://clojars.org/matlib) 3 | 4 | # matlib 5 | 6 | Matlib is a Clojure library of optimisation and control theory tools and 7 | convenience functions based on Neanderthal. 8 | 9 | ## Motivation 10 | 11 | Clojure's REPL-driven workflow is well suited to exploring and manipulating data. 12 | Like MATLAB, this approach should work well for matrix-based numerical computation. 13 | 14 | Neanderthal fills a need for a performant matrix library in Clojure, but it is 15 | essentially a thin wrapper around LAPACK functions. This library aims to 16 | furnish Clojure with some higher-level functions and applications, including 17 | system identification, control theory and optimisation tools, without replicating 18 | things already available in Neanderthal. 19 | 20 | Why not core.matrix? It is of course subjective. The philosophy of core.matrix 21 | and Neanderthal is different and they serve different needs. I preferred being 22 | close to LAPACK -- the cockroach of numerical computing -- and Neanderthal's 23 | syntax made more sense to me. 24 | 25 | 26 | ## Finished features 27 | 28 | - Various linear algebra functions like pseudo-inverse, kernel, subspace projections etc. 29 | - (optimisation) L-BFGS, gradient descent and differential evolution 30 | - (system identification) N4SID first, second (biased), and robust algorithms (untested) 31 | - Basis state-space representation, discrete-time integration 32 | - Gramians, Lyapunov equations 33 | - Some convenience functions 34 | 35 | 36 | ## Installing 37 | 38 | TBD 39 | 40 | 41 | ## Contributing 42 | 43 | Pull requests and bug reports are welcome. 44 | 45 | The code is written in a style that stays close to the mathematics in the 46 | referenced papers where possible. This leads to extensive use of `let`. 47 | The following areas need work: 48 | 49 | ### Unfinished 50 | 51 | - There are currently **no tests** 52 | - Integration of continuous-time of state-space models 53 | - Kroneker product 54 | - MOESP B, D, covariances 55 | - Other system ID algorithms 56 | - Riccati equation solver (but see [this issue](https://github.com/uncomplicate/neanderthal/issues/93)) 57 | - Complex matrices (lacking in Neanderthal) 58 | 59 | Matlib uses only Neanderthal's native type. It shouldn't be *that* hard to use 60 | Neanderthal's GPU types, but I have not attempted it. 61 | 62 | 63 | ## License 64 | 65 | Copyright © 2020 A S Sharma 66 | 67 | This program and the accompanying materials are made available under the 68 | terms of the Eclipse Public License 2.0 which is available at 69 | http://www.eclipse.org/legal/epl-2.0. 70 | 71 | This Source Code may also be made available under the following Secondary 72 | Licenses when the conditions for such availability set forth in the Eclipse 73 | Public License, v. 2.0 are satisfied: GNU General Public License as published by 74 | the Free Software Foundation, either version 2 of the License, or (at your 75 | option) any later version, with the GNU Classpath Exception which is available 76 | at https://www.gnu.org/software/classpath/license.html. 77 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2020 A S Sharma. All rights reserved. 2 | ;; 3 | ;; The use and distribution terms for this software are covered by the 4 | ;; Eclipse Public License 2.0 or later which can be found in the file LICENSE 5 | ;; at the root of this distribution. 6 | ;; By using this software in any fashion, you are agreeing to be bound by 7 | ;; the terms of this license. 8 | ;; You must not remove this notice, or any other, from this software. 9 | 10 | (defproject matlib "0.1.11" 11 | :description "A Clojure library of optimisation and control theory tools and convenience functions based on Neanderthal." 12 | :license {:name "EPL-2.0 OR GPL-2.0-or-later WITH Classpath-exception-2.0" 13 | :url "https://www.eclipse.org/legal/epl-2.0/"} 14 | :scm {:name "git" 15 | :url "https://github.com/atisharma/matlib"} 16 | :url "https://agalmic.ltd" 17 | ; jvm-opts required by Neanderthal on JDK > 8. 18 | :jvm-opts ^:replace ["--add-opens=java.base/jdk.internal.ref=ALL-UNNAMED"] 19 | :dependencies [[org.clojure/clojure "1.10.1"] 20 | [uncomplicate/neanderthal "0.36.0"] 21 | ;[org.bytedeco/mkl-platform-redist "2020.1-1.5.3"] 22 | ; No need to specify slf4j-api, as it’s required by logback. 23 | ; These loggers are here mainly to keep Neanderthal quiet. 24 | [org.clojure/tools.logging "1.1.0"] 25 | [ch.qos.logback/logback-classic "1.2.3"]] 26 | ; lein with-env-vars repl 27 | ; Is this working? Specified in $PATH in .bashrc. 28 | :env-vars {:LD_LIBRARY_PATH "/opt/intel/mkl/lib:/opt/intel/lib:/opt/intel/mkl/lib/intel64:/opt/intel/mkl/lib/intel64_lin"} 29 | :repositories [["local" "~/.m2/repository" 30 | :creds :gpg]] 31 | :signing {:gpg-key "ati@agalmic.ltd"} 32 | :codox {:metadata {:doc/format :markdown}} 33 | :repl-options {:init-ns matlib.core} 34 | :profiles {:repl {:dependencies [[agalmic/plot "0.1.5"]]}}) 35 | -------------------------------------------------------------------------------- /src/matlib/control.clj: -------------------------------------------------------------------------------- 1 | (ns matlib.control 2 | "Matrix equations relating to control theory." 3 | (:require 4 | [matlib.core :refer :all] 5 | [matlib.linalg :refer :all] 6 | [matlib.optim :refer [l-bfgs]] 7 | [uncomplicate.commons.core :refer [release with-release let-release]] 8 | [uncomplicate.neanderthal.real :refer [entry entry!]] 9 | [uncomplicate.neanderthal.native :refer :all :exclude [sv]] 10 | [uncomplicate.neanderthal.linalg :refer :all] 11 | [uncomplicate.neanderthal.core :refer :all :exclude [entry entry!]] 12 | [uncomplicate.neanderthal.vect-math :as vect-math] 13 | [uncomplicate.neanderthal.random :as random])) 14 | 15 | (defn obsv 16 | "Extended observability matrix up to order `i`. If `i` is not specified, up to 17 | order `n` (the usual controllability matrix)." 18 | ([A C] 19 | (obsv A C (mrows A))) 20 | ([A C i] 21 | (let [n (mrows A) 22 | m (mrows C) 23 | Gamma_i (dge (* m i) n) 24 | Apow (dge-eye n)] 25 | (doseq [block-row (range i)] 26 | (copy! (mm C Apow) (submatrix Gamma_i (* block-row m) 0 m n)) 27 | (copy! (mm Apow A) Apow)) ; Apow = A^k, k=0...(i-1) 28 | Gamma_i))) 29 | 30 | (defn ctrb 31 | "Extended controllability matrix up to order `i`. If `i` is not specified, up to 32 | order `n` (the usual controllability matrix)." 33 | ([A B] 34 | (ctrb A B (mrows A))) 35 | ([A B i] 36 | (let [n (mrows A) 37 | m (ncols B) 38 | Ctrb (dge n (* m i)) 39 | Apow (dge-eye n)] 40 | (doseq [block-col (range i)] 41 | (copy! (mm B Apow) (submatrix Ctrb 0 (* block-col n) n m)) 42 | (copy! (mm Apow A) Apow)) ; Apow = A^k, k=0...(i-1) 43 | Ctrb))) 44 | 45 | (defn sylv 46 | "Find a solution to the Sylvester equation 47 | `AX + XB = C`." 48 | ([x A B C] 49 | (let [X (view-ge x (ncols A) (mrows B))] 50 | (nrm2 (axpy -1 C (mm A X) (mm X B))))) 51 | ([A B C] 52 | (let [x0 (view-vctr (dge (ncols A) (mrows B))) 53 | x (:sol (l-bfgs #(sylv % A B C) x0)) 54 | X (view-ge x (ncols A) (mrows B))] 55 | X))) 56 | 57 | (defn dlyap 58 | "Solution `X` to the discrete-time Lyapunov equation 59 | `AXA' - X + Q = 0`. 60 | Should be solved by Schur method, but uses L-BFGS for now." 61 | ([x A Q] 62 | (let [X (view-ge x (mrows Q) (ncols Q))] 63 | (nrm2 (axpy -1 X (mm A X (trans A)) Q)))) 64 | ([A Q] 65 | (let [x0 (view-vctr Q) 66 | x (:sol (l-bfgs #(dlyap % A Q) x0)) 67 | X (view-ge x (mrows Q) (ncols Q))] 68 | (axpy 0.5 X 0.5 (trans X))))) 69 | 70 | (defn clyap 71 | "Solution `X` to the continuous-time Lyapunov equation 72 | `AX + XA' + Q = 0`. 73 | Should be solved by Bartels-Stewart method, but uses L-BFGS for now." 74 | ([x A Q] 75 | (let [X (view-ge x (mrows Q) (ncols Q))] 76 | (nrm2 (xpy (mm A X) (mm X (trans A)) Q)))) 77 | ([A Q] 78 | (let [x0 (view-vctr Q) 79 | x (:sol (l-bfgs #(clyap % A Q) x0)) 80 | X (view-ge x (mrows Q) (ncols Q))] 81 | (axpy 0.5 X 0.5 (trans X))))) 82 | 83 | (defn dcgram 84 | "Discrete-time controllability Gramian." 85 | [A C] 86 | (dlyap A (mm (trans C) C))) 87 | 88 | (defn dogram 89 | "Discrete-time observability Gramian." 90 | [A B] 91 | (scal! -1 (dlyap A (scal! -1 (mm B (trans B)))))) 92 | 93 | (defn ccgram 94 | "Solution `Wc` to the continuous-time Lyapunov equation 95 | `A Wc + Wc A' + B B' = 0`." 96 | ([A B] 97 | (clyap A (mm B (trans B))))) 98 | 99 | (defn cogram 100 | "Solution `Wo` to the continuous-time Lyapunov equation 101 | `A' Wo + Wo A + C' C = 0`." 102 | ([A C] 103 | (clyap (trans A) (scal -1 (mm (trans C) C))))) 104 | 105 | (defn dare 106 | "Solution to the discrete-time algebraic Riccati equation, 107 | `P = A' P A - (A' P B) (R + B' P B)^-1 (B' P A) + Q`. 108 | Also returns the stabilising controller 109 | `K = (R + B' P B)^-1 B' P A` 110 | and the closed-loop state transfer matrix `A-BK`. 111 | The solutions is found via the eigenvalue decomposition of the symplectic matrix 112 | `[A + B R^-1 B' (A^-1)' Q | -B R^-1 B' (A^-1)' ] = Z 113 | [ -(A^-1)' Q | (A^-1)' ]` 114 | TODO: extend to generalised DARE. 115 | TODO: anti-stabilising solution. 116 | " 117 | ([A B Q R] 118 | (let [n (mrows A) 119 | Ainv' (trans (minv A)) 120 | B' (trans B) 121 | Rinv (minv R) 122 | Z11 (xpy A (mm B Rinv B' Ainv' Q)) 123 | Z12 (scal -1 (mm B Rinv B' Ainv')) 124 | Z21 (scal -1 (mm Ainv' Q)) 125 | Z22 Ainv' 126 | Z (vcat (hcat Z11 Z12) (hcat Z21 Z22)) ; symplectic matrix 127 | U (dge (mrows Z) (ncols Z)) ; Schur vectors 128 | eigs (dge (mrows Z) 2) 129 | T (copy Z) ; real Schur form of Z 130 | _ (es! T eigs U) ; overwrite U, eigs, T 131 | ; the stable subspace of the Schur form 132 | U-stab (apply hcat (for [c (range (mrows eigs)) :when (< (entry (vect-math/abs eigs) c 0) 1.0)] (col-vector (col T c))))] 133 | ; split U into stable and anti-stable subspaces 134 | ;U1 (submatrix U-stab n n) 135 | ;U2 (submatrix U-stab 0 n n n) 136 | ;P (mm U2 (minv U1))] 137 | ;K (mm (minv (xpy R (mm B' P B))) B' P A)] 138 | {;:U1 U1 139 | ;:U2 U2 140 | :U-stable U-stab 141 | :U U 142 | :T T 143 | ;:K K 144 | ;:P P 145 | ;:e (trans (col eigs 0)) 146 | ;:A_CL (axpy -1 (mm B K) A) 147 | :residual :not-calculated}))) 148 | 149 | (defn care 150 | "Solution to the continuous-time algebraic Riccati equation." 151 | [A B Q] 152 | :not-implemented) 153 | -------------------------------------------------------------------------------- /src/matlib/core.clj: -------------------------------------------------------------------------------- 1 | (ns matlib.core 2 | "Basic matrix constructions, operations and patterns." 3 | (:require 4 | [uncomplicate.neanderthal.real :refer [entry entry!]] 5 | [uncomplicate.neanderthal.native :refer :all :exclude [sv]] 6 | [uncomplicate.neanderthal.core :refer :all :exclude [entry entry!]])) 7 | 8 | (defn machine-epsilon 9 | "Approximate machine epsilon." 10 | ; Machine precision is about 1.11e-16 on 64bit dp according to LAPACK user guide 11 | ([] 12 | (machine-epsilon 1e-5)) 13 | ([e] 14 | (if (= (+ 1.0 e) 1.0) 15 | e 16 | (recur (* 0.99 e))))) 17 | 18 | (def eps (machine-epsilon 1.0)) 19 | 20 | (def sq-eps (Math/sqrt eps)) 21 | 22 | (defn nan? 23 | "True iff `##NaN`." 24 | [^double x] 25 | (and (number? x) (Double/isNaN x))) 26 | 27 | (defn numeric? 28 | "True if not `##NaN` and is a number. True for `##Inf`." 29 | [x] 30 | (and (number? x) (Double/isFinite x) (not (Double/isNaN x)))) 31 | 32 | (defn ones 33 | "Matrix (vector) of ones with same dimension as `M`." 34 | ([M] 35 | (if (vctr? M) 36 | (vctr native-double (repeat (dim M) 1)) 37 | (dge (mrows M) (ncols M) (repeat (double 1))))) 38 | ([m n] 39 | (dge m n (repeat (double 1))))) 40 | 41 | (defn eye 42 | "Identity matrix (diagonal type)." 43 | [n] 44 | (dgd n (repeat 1))) 45 | 46 | (defn dge-eye 47 | "Full dge identity matrix." 48 | [n] 49 | (transfer! (dgd n (repeat 1)) (dge n n))) 50 | 51 | (defn sign 52 | "Sign of each element in a matrix or vector." 53 | [M] 54 | (alter! (copy M) (fn ^double [^double x] (double (Math/signum x))))) 55 | 56 | (defn negatives 57 | "Elements are `1` where matrix/vector `M` has negative elements." 58 | [M] 59 | (alter! (copy M) (fn ^double [^double x] (if (> 0.0 x) 1.0 0.0)))) 60 | 61 | (defn positives 62 | "Elements are `1` where `M` has positive elements." 63 | [M] 64 | (alter! (copy M) (fn ^double [^long i ^long j ^double x] (if (< 0 x) 1.0 0.0)))) 65 | 66 | (defn replace-nan! 67 | "Replace `##NaN` in-place (with default 0)." 68 | ([M x] 69 | (let [d (double x)] 70 | (alter! M (fn ^double [^double y] (if (nan? y) d y))))) 71 | ([M] 72 | (replace-nan! M 0))) 73 | 74 | (defn replace-non-numeric! 75 | "Replace `##NaN` and `+-##Inf` in-place (with default 0)." 76 | ([M x] 77 | (let [d (double x)] 78 | (alter! M (fn ^double [^double y] (if (numeric? y) y d))))) 79 | ([M] 80 | (replace-nan! M 0))) 81 | 82 | (defn get-zoh 83 | "Return the first non-`##NaN` numeric value found by decrementing column `j`. 84 | If one is not found, return 0." 85 | [M i j] 86 | (if (< j 0) 87 | 0 88 | (let [x (entry M i j)] 89 | (if (Double/isNaN x) 90 | (get-zoh M i (dec j)) 91 | x)))) 92 | 93 | (defn zoh! 94 | "Set elements to the first non-`##NaN` numeric value found by decrementing column `j`. 95 | If one is not found, use 0." 96 | ;TODO: performance here needs improvement 97 | ([M r c] 98 | (entry! M r c (get-zoh M r c))) 99 | ([M r] 100 | (for [c (range (ncols M))] 101 | (last 102 | (zoh! M r c)))) 103 | ([M] 104 | (last 105 | (for [r (range (mrows M)) 106 | c (range (ncols M))] 107 | (zoh! M r c))))) 108 | 109 | (defn hcat 110 | "Concatenate A and B (and D...) to a new matrix [A B]." 111 | ([A B] 112 | (let [C (dge (mrows A) (+ (ncols A) (ncols B)))] 113 | (copy! A (submatrix C (mrows A) (ncols A))) 114 | (copy! B (submatrix C 0 (ncols A) (mrows B) (ncols B))) 115 | C)) 116 | ([A B & D] 117 | (reduce hcat (hcat A B) D))) 118 | 119 | (defn vcat 120 | "Concatenate A and B (and D...) to a new matrix [A' B']'." 121 | ([A B] 122 | (let [C (dge (+ (mrows A) (mrows B)) (ncols A))] 123 | (copy! A (submatrix C (mrows A) (ncols A))) 124 | (copy! B (submatrix C (mrows A) 0 (mrows B) (ncols B))) 125 | C)) 126 | ([A B & D] 127 | (reduce vcat (vcat A B) D))) 128 | 129 | (defn col-vector 130 | "Copy as a column vector." 131 | [v] 132 | (dge (dim v) 1 v)) 133 | 134 | (defn row-vector 135 | "Copy as a row vector." 136 | [v] 137 | (dge 1 (dim v) v)) 138 | 139 | (defn last-cols 140 | "Last `n` (1) columns of matrix `M`." 141 | ([M n] 142 | (submatrix M 0 (- (ncols M) n) (mrows M) n)) 143 | ([M] 144 | (last-cols M 1))) 145 | 146 | (defn last-rows 147 | "Last `n` rows of matrix `M`." 148 | ([M n] 149 | (submatrix M (- (mrows M) n) 0 n (ncols M))) 150 | ([M] 151 | (last-rows M 1))) 152 | 153 | (defn take-cols 154 | "Take `q` columns starting from `p` or first `n` columns of matrix `M`." 155 | ([M p q] 156 | (submatrix M 0 p (mrows M) q)) 157 | ([M n] 158 | (take-cols M 0 n))) 159 | 160 | (defn take-rows 161 | "Take `q` rows starting from `p` or first `n` rows of matrix `M`." 162 | ([M p q] 163 | (submatrix M p 0 q (ncols M))) 164 | ([M n] 165 | (take-rows M 0 n))) 166 | 167 | (defn drop-cols 168 | "All columns but the first (1 or `n`)." 169 | ([M] 170 | (drop-cols M 1)) 171 | ([M n] 172 | (submatrix M 0 n (mrows M) (- (ncols M) n)))) 173 | 174 | (defn drop-rows 175 | "All rows but the first (1 or `n`)." 176 | ([M] 177 | (drop-rows M 1)) 178 | ([M n] 179 | (submatrix M n 0 (- (mrows M) n) (ncols M)))) 180 | 181 | (defn drop-last-cols 182 | "All columns but the last (1 or `n`)." 183 | ([M] 184 | (drop-last-cols M 1)) 185 | ([M n] 186 | (submatrix M 0 0 (mrows M) (- (ncols M) n)))) 187 | 188 | (defn drop-last-rows 189 | "All rows but the last (1 or `n`)." 190 | ([M] 191 | (drop-last-rows M 1)) 192 | ([M n] 193 | (submatrix M 0 0 (- (mrows M) n) (ncols M)))) 194 | 195 | (defn col-diff 196 | "Elements are the diff of M from its previous column, with a fake column of 197 | zeros implied on the left." 198 | [M] 199 | (axpy -1.0 (hcat (dge (mrows M) 1) (take-cols M (- (ncols M) 1))) M)) 200 | 201 | (defn shift-update 202 | "Add a new column `m` to the end of a matrix `M` and discard the first column. 203 | Done in-place." 204 | [M m] 205 | (let [rows (mrows M) 206 | cols (ncols M) 207 | M-back (submatrix M 0 1 rows (- cols 1)) 208 | M-front (submatrix M rows (- cols 1)) 209 | m-col (dge rows 1 m)] 210 | (copy! M-back M-front) 211 | ((copy! m (submatrix M 0 (- cols 1) rows 1))) 212 | M)) 213 | 214 | -------------------------------------------------------------------------------- /src/matlib/de.clj: -------------------------------------------------------------------------------- 1 | (ns matlib.de 2 | "Differential evolution heuristic gradient-free optimisation. 3 | See, for example, https://en.wikipedia.org/wiki/Differential_evolution ." 4 | (:require 5 | [matlib.core :as ml-core] 6 | [matlib.linalg :as ml-linalg] 7 | [uncomplicate.neanderthal.real :refer [entry entry!]] 8 | [uncomplicate.neanderthal.native :as native] 9 | [uncomplicate.neanderthal.linalg :as n-linalg] 10 | [uncomplicate.neanderthal.core :as n-core] 11 | [uncomplicate.neanderthal.vect-math :as vect-math] 12 | [uncomplicate.neanderthal.random :as random])) 13 | 14 | (defn perturb 15 | "Perturb a state vector `x`." 16 | [x] 17 | (let [x0 (native/dv x)] 18 | (while (= 0.0 (reduce * x0)) (n-core/axpy! (random/rand-normal! (native/dv x)) x0)) 19 | (vect-math/mul x0 (random/rand-normal! (native/dv x))))) 20 | 21 | (defn population 22 | "Initialise a population based on an example `x`. 23 | `x` cannot have zero entries. 24 | `NP` must be at least 5." 25 | ([x] 26 | (let [d (n-core/dim x) 27 | NP (cond (< d 10) (* 5 d) 28 | (> d 100) (int (/ d 2)) 29 | :else 50)] 30 | (population x NP))) 31 | ([x NP] 32 | (for [n (range NP)] (perturb x)))) 33 | 34 | (defn update-individual 35 | "Returns updated `x`." 36 | [x a b c CR F] 37 | (let [R (rand-int (n-core/dim x)) 38 | y (n-core/copy x)] 39 | (doseq 40 | [i (range (n-core/dim x))] 41 | (if (or (< (rand) CR) (= i R)) 42 | (entry! y i (+ (entry a i) (* F (- (entry b i) (entry c i))))))) 43 | y)) 44 | 45 | (defn solve 46 | "Find the minimum of `f` given a population (vec) of `x`s. 47 | Constraints should be handled in `f`. 48 | If evaluations of `f` are expensive, consider memoizing `f` with lru." 49 | ([f xs CR F maxiter scores n output] 50 | (let [x (first xs) 51 | ys (shuffle (rest xs)) 52 | a (first ys) 53 | b (nth ys 2) 54 | c (nth ys 3)] 55 | ;(print n scores "\r") 56 | (if (and (> (- (reduce max scores) (reduce min scores)) ml-core/sq-eps) (< n maxiter)) 57 | ; rotate xs with new one at end 58 | (let [y (update-individual x a b c CR F) 59 | fx (f x) 60 | fy-test (f y) 61 | fy (if (Double/isNaN fy-test) ##Inf fy-test) 62 | new-xs (conj (vec (rest xs)) (if (> fy fx) x y)) 63 | new-scores (conj (vec (rest scores)) (min fx fy))] 64 | (when output 65 | (printf "\tn:%5d\t\tf(x):%12.5f\n" n (min fx fy)) 66 | (flush)) 67 | (recur f new-xs CR F maxiter new-scores (inc n) output)) 68 | {:sol x 69 | :f (f x) 70 | :iterations n 71 | :maxiter maxiter 72 | :CR CR 73 | :F F 74 | :NP (count xs) 75 | :success (< n maxiter)})))) 76 | 77 | -------------------------------------------------------------------------------- /src/matlib/ident.clj: -------------------------------------------------------------------------------- 1 | (ns matlib.ident 2 | "Identify a state-space model given input and output snapshot matrices, 3 | using deterministic-stochastic subspace methods (both MOESP and N4SID). 4 | 5 | You are recommended to use the `robust` algorithm. 6 | 7 | Notation and assumptions mostly follow [vOdM-96]. 8 | 9 | Notation: 10 | 11 | `xₖ₊₁ = A xₖ + B uₖ + wₖ` 12 | ` yₖ = C xₖ + D uₖ + vₖ` 13 | 14 | `uₖ ∈ ℝᵐ,` 15 | `yₖ ∈ ℝˡ,` 16 | `xₖ ∈ ℝⁿ,` 17 | and `wₖ, vₖ` are unobserved, Gaussian distributed, zero-mean, non-zero white noise. 18 | 19 | They have covariances 20 | `E ( wₖ wₗ' ) = Q δₖₗ>= 0` 21 | `E ( wₖ vₗ' ) = S δₖₗ>= 0` 22 | `E ( vₖ wₗ' ) = S' δₖₗ>= 0` 23 | `E ( vₖ vₗ' ) = R δₖₗ>= 0` 24 | 25 | Snapshot matrices `U` and `Y` of `uₖ` and `yₖ` are taken with `k=0...(t-1)`. 26 | 27 | The following algorithms are available. 28 | 29 | `n4sid`: N4SID algorithm 1 (unbiased, using SVD rather than RQ decomposition), 30 | `n4sid-biased`: N4SID algorithm 2 (biased), 31 | `robust`: Mixed 'robust' algorithm 3 (Fig 4.8 [vOdM-96]), 32 | `robust-rq`: Mixed 'robust' algorithm 3 (Fig 4.8 [vOdM-96]) using RQ decomposition **(not finished)**, 33 | `moesp`: MOESP using LQ decomposition **(not finished)**. 34 | 35 | This implementation of the algorithms that find `B` and `D` through optimisation 36 | use the (fast) biased algorithm as a first guess for `B` and `D`. 37 | 38 | References: 39 | 40 | [V-94] 41 | 'Identification of the deterministic part of MIMO state space models given in 42 | innovations form from input-output data' 43 | M Verhaegen, 44 | Automatica, Vol. 30, No. 1, pp. 61-74 (1994) 45 | 46 | [vOdM-94] 47 | 'N4SID: Subspace Algorithms for the Identification of Combined 48 | Deterministic-Stochastic Systems' 49 | P van Overschee & B de Moor 50 | Automatica Vol. 30 No. 1 pp. 75-93 (1993) 51 | 52 | [vOdM-95] 53 | 'A Unifying Theorem for Three Subspace System Identification Algorithms' 54 | P van Overschee & B de Moor 55 | Automatica, Vol. 31, No. 12, pp. 1853-1861 (1995) 56 | 57 | [vOdM-96] 58 | 'Subspace Identification for Linear Systems 59 | Theory — Implementation — Applications' 60 | P van Overschee, B de Moor 61 | Edition 1, Springer US, (1996) 62 | ISBN 978-1-4613-8061-0 63 | 64 | [SSvH-04] 65 | 'High-Performance Numerical Algorithms and Software for Subspace-Based Linear 66 | Multivariable System Identification' 67 | V Sima, DM Sima and S van Huffel 68 | J. Comp. Appl. Math., Vol. 170, pp. 371-397 (2004) 69 | 70 | [DSC-06] 71 | 'A New Insight to the Matrices Extraction in a MOESP Type Subspace 72 | Identification Algorithm' 73 | CJM Delgado, P Lopes dos Santos and J L Martins de Carvalho 74 | Int. J. Systems Science, Vol. 37, No. 8, pp. 565-574 (2006) 75 | 76 | " 77 | (:require 78 | [matlib.core :refer :all] 79 | [matlib.linalg :refer :all] 80 | [matlib.state-space] 81 | [matlib.control :refer [obsv]] 82 | [matlib.optim :refer [l-bfgs gradient-descent]] 83 | [uncomplicate.neanderthal.real :refer [entry entry!]] 84 | [uncomplicate.neanderthal.native :refer :all :exclude [sv]] 85 | [uncomplicate.neanderthal.linalg :refer :all] 86 | [uncomplicate.neanderthal.core :refer :all :exclude [entry entry!]] 87 | [uncomplicate.neanderthal.vect-math :as vect-math] 88 | [uncomplicate.neanderthal.random :as random])) 89 | 90 | ;;; TODO: follow through algebra for W2 according to [vOdM-96] 91 | ;;; TODO: find BDQRS in MOESP 92 | 93 | (defn block-hankel 94 | "Construct a block-Hankel matrix `U_a,b` from snapshot matrix `U`. 95 | Notation follows [SSvH-04] which corresponds to [vOdM-*] 96 | as `U_a,b,c` <-> `U_a|b` (the `c` being implicit in the latter). 97 | ; 98 | Arguments: 99 | ; 100 | `a, b, c` determine size of output 101 | `U` `m x j` snapshot matrix `U = [u_0 ... u_j-1]`. 102 | Row `q` of `U` contains the history of the `q`th input, and each 103 | column of `U` is a snapshot of inputs at sample time `k`. 104 | ; 105 | Returns: 106 | ; 107 | `U_a,b,c` block-Hankel matrix of size `(1+b-a)m x (1+c-a)`, where 108 | `U_a,b,c = [ u_a u_a+1 u_a+2 ... u_c ] 109 | [ u_a+1 u_a+2 u_a+3 ... u_c+1 ] 110 | [ ... ... ] 111 | [ u_b ... u_c+b-a ]` 112 | " 113 | ([U a b c] 114 | (let [m (mrows U) 115 | bhm-rows (* m (- b a -1)) 116 | bhm-cols (- c a -1) 117 | bhm (dge bhm-rows bhm-cols)] 118 | (doseq [k0 (range a (+ b 1))] 119 | (copy! 120 | (submatrix U 0 k0 m bhm-cols) 121 | (submatrix bhm (* (- k0 a) m) 0 m bhm-cols))) 122 | bhm))) 123 | 124 | (defn block-hankel-matrices 125 | "Construct a block-Hankel matrices from input, output snapshot matrices 126 | `U` and `Y`, 127 | `U ∈ ℝ^(m x t)`, `Y ∈ ℝ^(l x t)`. 128 | 129 | `W_p := [ U_0|i-1 ]` is past inputs and outputs, 130 | ` [ Y_0|i-1 ]` 131 | 132 | `Y_f := Y_i|2i-1` is future outputs, 133 | 134 | `U_f := U_i|2i-1` is future inputs. 135 | 136 | `W_p+`, `U_f-` and `Y_f-` are defined similarly but with the boundary between 137 | past and future shifted one down (later). 138 | 139 | Notation follows [vOdM-95/96]" 140 | ([ss i] 141 | (block-hankel-matrices (:U ss) (:Y ss) i)) 142 | ([U Y i] 143 | (let [t (ncols U) 144 | N (- t i i) 145 | i2 (* i 2)] 146 | {:N N 147 | :W_p (vcat (block-hankel U 0 (- i 1) N) 148 | (block-hankel Y 0 (- i 1) N)) 149 | :W_p+ (vcat (block-hankel U 0 i N) 150 | (block-hankel Y 0 i N)) 151 | :Y_f (block-hankel Y i (- i2 1) (+ N i)) 152 | :Y_f- (block-hankel Y (+ i 1) (- i2 1) (+ N i 1)) 153 | :U_f (block-hankel U i (- i2 1) (+ N i)) 154 | :U_f- (block-hankel U (+ i 1) (- i2 1) (+ N i 1))}))) 155 | 156 | (defn- W_2 157 | "Weighting matrix `W_2` is based on the method being used. 158 | `W_1` is not calculated because it's only used in CVA, which is not 159 | implemented here. 160 | `method` should be one of :MOESP or :N4SID. 161 | Follows notation in [vOdM-96]" 162 | ([W_p Y_f U_f method] 163 | (let [M (rsp-perp W_p U_f)] 164 | (case method 165 | :MOESP (mm (pinv M) M) ; = Π_U_f-perp 166 | :N4SID nil 167 | :CVA :not-implemented)))) 168 | 169 | (defn model-spectrum 170 | "Return the singular values of `(Y_f /_U_f W_p) Π_U_f-perp`. 171 | The user should determine model order `n` from the largest logarithmic gap in 172 | the spectrum. See (4.24-4.25) or Fig 4.8 of [vOdM-96]." 173 | ([ss i] 174 | (model-spectrum (:U ss) (:Y ss) i)) 175 | ([U Y i] 176 | (let [{N :N W_p :W_p Y_f :Y_f U_f :U_f} (block-hankel-matrices U Y i) 177 | W (W_2 W_p Y_f U_f :MOESP) 178 | O (mm (rsp-perp Y_f U_f) W)] ; weighted oblique projection 179 | (scal! (/ 1.0 N) (dia (:sigma (svd (mm O W)))))))) 180 | 181 | (defn- intermediates 182 | "Intermediate calculations for all methods. 183 | `W2` should be `nil` if not used." 184 | ([W_p Y_f U_f W2 l n] 185 | (let [O_i (oblique-rsp Y_f U_f W_p) ; eq (4.24) 186 | {S1 :sigma U1 :u V1' :vt 187 | S2 :sigma_perp U2 :u_perp V2' :vt_perp} (if W2 188 | (rsvd (mm O_i W2) :rank n) 189 | (rsvd O_i :rank n)) 190 | Gamma_i (mm U1 (vect-math/sqrt S1)) 191 | Gamma_up (submatrix Gamma_i l 0 (- (mrows Gamma_i) l) n) 192 | Gamma_down (submatrix Gamma_i (- (mrows Gamma_i) l) n) 193 | Z_i (rsp Y_f (vcat W_p U_f)) ; eq (4.18) 194 | X_i (mm (vect-math/sqrt S1) V1')] 195 | {:O_i O_i 196 | :Gamma_i Gamma_i 197 | :Gamma_up Gamma_up 198 | :Gamma_down Gamma_down 199 | :order n 200 | :X_i X_i 201 | :Z_i Z_i 202 | :S1 S1 :U1 U1 :V1' V1'}))) 203 | 204 | (defn- Hd_i 205 | "Block Toeplitz matrix of system matrices. 206 | See (5) [DSC-06]." 207 | ([B D Gamma_i l m i] 208 | (let [li (* l i) 209 | mi (* m i) 210 | H (dge li mi) 211 | Gamma_down (submatrix Gamma_i (- li l) (ncols Gamma_i)) 212 | DGamma_iB (vcat D (mm Gamma_down B))] 213 | (doseq [stripe (range (- i 1))] 214 | (let [block-col (take-rows DGamma_iB (- (mrows DGamma_iB) (* l stripe)))] 215 | (copy! block-col (submatrix H (* stripe l) (* stripe m) (mrows block-col) (ncols block-col))))) 216 | H))) 217 | 218 | (defn- BD-cost 219 | "Convex target function that is minimised over `B` and `D` arguments. 220 | Compare (4.51), (4.52) and (4.55) of [vOdM-96]. 221 | Includes a small L2 regularisation penalty on `|B D|`." 222 | [bd A C K Gamma_i Gamma_i_pinv Gamma_i-1_pinv l m n i] 223 | (let [BD-matrix (view-ge bd (+ l n) m) 224 | B (submatrix BD-matrix n m) 225 | D (submatrix BD-matrix n 0 l m) 226 | H (Hd_i B D Gamma_i l m i) 227 | H- (Hd_i B D Gamma_i l m (- i 1)) 228 | Z (dge l (- (ncols H) m)) 229 | Ku (axpy -1 (mm A Gamma_i_pinv H) (hcat B (mm Gamma_i-1_pinv H-))) 230 | Kl (axpy -1 (mm C Gamma_i_pinv H) (hcat D Z))] 231 | (+ (* (nrm2 bd) 1e-4) (nrm2 (axpy -1 K (vcat Ku Kl)))))) 232 | 233 | (defn- find-BD 234 | "Find `B` and `D` by convex optimisation method of [vOdM-96]. 235 | Compare (4.51), (4.52) and (4.55) of the same source." 236 | ([A C K i m] 237 | (let [l (mrows C) 238 | n (mrows A) 239 | bd (dge (+ l n) m)] 240 | (find-BD A C K i m bd false))) 241 | ([A C K i m BD0 output] 242 | (let [l (mrows C) 243 | n (mrows A) 244 | Gamma_i (obsv A C i) 245 | Gamma_i_pinv (pinv Gamma_i) 246 | Gamma_i-1_pinv (pinv (obsv A C (- i 1))) 247 | bd (view-vctr BD0) 248 | opt-result (l-bfgs #(BD-cost % A C K Gamma_i Gamma_i_pinv Gamma_i-1_pinv l m n i) bd :output output :m 50) 249 | sol (:sol opt-result) 250 | BD-matrix (view-ge sol (+ l n) m) 251 | B (submatrix BD-matrix n m) 252 | D (submatrix BD-matrix n 0 l m)] 253 | (merge opt-result {:B B :D D})))) 254 | 255 | (defn- residual-covariance 256 | "Prediction residuals in (4.51), (4.52) and (4.55) of [vOdM-96]. 257 | These are used to estimate the covariance matrices. 258 | Quantities are be reconstructed from calculated system matrices where possible." 259 | [A B C D i U_f Z_i Z_i+1 Y_i|i] 260 | (let [l (mrows C) 261 | m (ncols B) 262 | n (mrows A) 263 | Gamma_i (obsv A C i) 264 | Gamma_i_pinv (pinv Gamma_i) 265 | Gamma_i-1 (obsv A C (- i 1)) 266 | Gamma_i-1_pinv (pinv Gamma_i-1) 267 | H (Hd_i B D Gamma_i l m i) 268 | H- (Hd_i B D Gamma_i l m (- i 1)) 269 | Z (dge l (- (ncols H) m)) 270 | Ku (axpy -1 (mm A Gamma_i_pinv H) (hcat B (mm Gamma_i-1_pinv H-))) 271 | Kl (axpy -1 (mm C Gamma_i_pinv H) (hcat D Z)) 272 | K (vcat Ku Kl) 273 | J1 (vcat (mm (pinv Gamma_i-1) Z_i+1) Y_i|i) 274 | J2 (mm (vcat A C) (pinv Gamma_i) Z_i) 275 | residual (axpy 1 (mm K U_f) 1 J2 -1 J1) 276 | samples (ncols residual) 277 | covariance (scal! (/ 1.0 samples) (mm residual (trans residual))) 278 | {v :sigma Eu :u} (svd covariance true true)] 279 | {:Q (submatrix covariance 0 0 n n) 280 | :S (submatrix covariance 0 n n l) 281 | :R (submatrix covariance n n l l) 282 | :E (mm Eu (vect-math/sqrt! v)) 283 | :samples samples})) 284 | 285 | (defn n4sid-biased 286 | "Algorithm 2 (Figure 4.7) of [vOdM-96]. 287 | This algorithm gives asymptotically biased solutions." 288 | ([ss i n] 289 | (n4sid-biased (:U ss) (:Y ss) i n)) 290 | ([U Y i n] 291 | (let [l (mrows Y) 292 | m (mrows U) 293 | ; block Hankel matrices, time-shifted and not 294 | {:keys [N W_p Y_f U_f W_p+ Y_f- U_f-]} (block-hankel-matrices U Y i) 295 | W2 nil 296 | ;W2 (W_2 W_p Y_f U_f :MOESP) ; untested, check algebra 297 | {Gamma_i :Gamma_i, Gamma_down :Gamma_down, Gamma_up :Gamma_up, 298 | O_i :O_i, Z_i :Z_i} (intermediates W_p Y_f U_f W2 l n) 299 | {O_i+1 :O_i, Z_i+1 :Z_i} (intermediates W_p+ Y_f- U_f- W2 l n) 300 | Gamma_i-1 Gamma_down 301 | X_i+1 (mm (pinv Gamma_i-1) O_i+1) 302 | X_i (mm (pinv Gamma_i) O_i) 303 | U_i|i (block-hankel U i i (- (ncols X_i) i)) 304 | Y_i|i (block-hankel Y i i (- (ncols X_i) i)) 305 | ; solve LSQ for A, B, C, D 306 | Jl (vcat X_i+1 Y_i|i) 307 | Jr (vcat X_i U_i|i) 308 | ABCD (mm Jl (pinv Jr)) 309 | ; determine covariance matrices 310 | samples (ncols X_i) 311 | residual (axpy -1 (mm ABCD Jr) Jl) 312 | covariance (scal! (/ 1.0 samples) (mm residual (trans residual))) 313 | {v :sigma Eu :u} (svd covariance true true)] 314 | {:A (submatrix ABCD 0 0 n n) 315 | :B (submatrix ABCD 0 n n m) 316 | :C (submatrix ABCD n 0 l n) 317 | :D (submatrix ABCD n n l m) 318 | :Q (submatrix covariance 0 0 n n) 319 | :S (submatrix covariance 0 n n l) 320 | :R (submatrix covariance n n l l) 321 | :E (mm Eu (vect-math/sqrt! v)) 322 | :order n 323 | :samples samples 324 | :i i 325 | :scheme :discrete-time 326 | :method :n4sid-biased}))) 327 | 328 | (defn n4sid 329 | "Algorithm 1 (Figure 4.6) of [vOdM-96]." 330 | ([ss i n] 331 | (n4sid (:U ss) (:Y ss) i n)) 332 | ([U Y i n & options] 333 | (let [l (mrows Y) 334 | m (mrows U) 335 | {:keys [output] :or {output false}} options 336 | {:keys [N W_p Y_f U_f W_p+ Y_f- U_f-]} (block-hankel-matrices U Y i) 337 | ;W2 (W_2 W_p Y_f U_f :MOESP) ; untested, check algebra 338 | W2 nil 339 | {Gamma_i :Gamma_i, Gamma_down :Gamma_down, Gamma_up :Gamma_up, 340 | O_i :O_i, Z_i :Z_i} (intermediates W_p Y_f U_f W2 l n) 341 | {O_i+1 :O_i, Z_i+1 :Z_i} (intermediates W_p+ Y_f- U_f- W2 l n) 342 | Gamma_i-1 Gamma_down 343 | Jlu (mm (pinv Gamma_i-1) Z_i+1) 344 | Jru (mm (pinv Gamma_i) Z_i) 345 | Y_i|i (block-hankel Y i i (- (ncols Jlu) i)) 346 | U_i|i (block-hankel U i i (- (ncols Jru) i)) 347 | ; solve linear eqns for A, C, K 348 | ACK (mm (vcat Jlu Y_i|i) (pinv (vcat Jru U_f))) 349 | A (submatrix ACK 0 0 n n) 350 | C (submatrix ACK n 0 l n) 351 | K (submatrix ACK 0 n (+ n l) (- (ncols ACK) n)) 352 | first-pass (n4sid-biased U Y i n) 353 | BD-soln (find-BD A C K i m (vcat (mm (pinv C) (:C first-pass) (:B first-pass)) (:D first-pass)) output) 354 | B (:B BD-soln) 355 | D (:D BD-soln) 356 | QSR (residual-covariance A B C D i U_f Z_i Z_i+1 Y_i|i)] 357 | (merge QSR {:A A 358 | :C C 359 | :B B 360 | :D D 361 | :BD-converged (:success BD-soln) 362 | :i i 363 | :order n 364 | :scheme :discrete-time 365 | :method :n4sid})))) 366 | 367 | (defn robust 368 | "Explicit calculation, per Figure 4.8 of [vOdM-96]. 369 | This is the so-called 'robust' algorithm. 370 | The expressions in [DSC-08] are also used. 371 | `i` is the model delay order and `n` is the model order." 372 | ([ss i n] 373 | (robust (:U ss) (:Y ss) i n)) 374 | ([U Y i n & options] 375 | (let [l (mrows Y) 376 | m (mrows U) 377 | t (ncols U) 378 | {:keys [output] :or {output false}} options 379 | ; block Hankel matrices, time-shifted and not: 380 | {:keys [N W_p Y_f U_f W_p+ Y_f- U_f-]} (block-hankel-matrices U Y i) 381 | ; intermediate calculations 382 | Pi (W_2 W_p Y_f U_f :MOESP) 383 | {O_i :O_i, Gamma_i :Gamma_i, Gamma_i-1 :Gamma_down, 384 | Z_i :Z_i 385 | S1 :S1, U1 :U1, V1' :V1'} (intermediates W_p Y_f U_f Pi l n) 386 | Z_i+1 (rsp Y_f- (vcat W_p+ U_f-)) 387 | Jlu (mm (pinv Gamma_i-1) Z_i+1) 388 | Jru (mm (pinv Gamma_i) Z_i) 389 | Y_i|i (block-hankel Y i i (- (ncols Jlu) i)) 390 | U_i|i (block-hankel U i i (- (ncols Jru) i)) 391 | ; solve linear eqns for A, C, K 392 | ACK (mm (vcat Jlu Y_i|i) (pinv (vcat Jru U_f))) 393 | A (submatrix ACK 0 0 n n) 394 | C (submatrix ACK n 0 l n) 395 | K (submatrix ACK 0 n (+ n l) (- (ncols ACK) n)) 396 | first-pass (n4sid-biased U Y i n) 397 | BD-soln (find-BD A C K i m (vcat (mm (pinv C) (:C first-pass) (:B first-pass)) (:D first-pass)) output) 398 | B (:B BD-soln) 399 | D (:D BD-soln) 400 | QSR (residual-covariance A B C D i U_f Z_i Z_i+1 Y_i|i)] 401 | (merge QSR {:A A 402 | :C C 403 | :B B 404 | :D D 405 | :BD-converged (:success BD-soln) 406 | :spectrum (seq (dia S1)) 407 | :order n 408 | :i i 409 | :scheme :discrete-time 410 | :method :robust})))) 411 | 412 | (defn- hankel-rq 413 | "(Lower) RQ factorisation of block-Hankel matrices, given snapshot matrices 414 | `U` and `Y`." 415 | ([ss i] 416 | (hankel-rq (:U ss) (:Y ss) i)) 417 | ([U Y i] 418 | (let [p (- (* 2 i) 1) 419 | t (ncols U) 420 | N (- t i i) 421 | H (scal! (/ 1.0 (Math/sqrt N)) (vcat (block-hankel U 0 p N) (block-hankel Y 0 p N))) 422 | ; default no pivoting 423 | qr (qrf (trans H)) 424 | Q (trans (org qr)) 425 | R (trans (view-tr (:or qr) {:uplo :upper}))] 426 | {:R R :Q Q}))) 427 | 428 | (defn- partition-R 429 | "Given the lower-triangular `L` of the LQ-factorisation of `H`, 430 | Follows Chapter 6 / p.164 [vOdM-96]." 431 | ([ss i] 432 | (let [L (:R (hankel-rq ss i)) 433 | l (ncols (:B ss)) 434 | m (mrows (:C ss))] 435 | (partition-R L l m))) 436 | ([L l m] 437 | (let [R (view-ge L) 438 | ; infer i from size of R, R is 2i(m+l) x 2i(m+l) 439 | i (/ (mrows R) (* 2 (+ m l))) 440 | ; block row/column sizes 441 | x1 (* m i) 442 | x2 m 443 | x3 (- (* m i) m) 444 | x4 (* l i) 445 | x5 l 446 | x6 (- (* l i) l) 447 | ; block row/column starting indices 448 | ix1 0, 449 | ix2 (+ ix1 x1), 450 | ix3 (+ ix2 x2), 451 | ix4 (+ ix3 x3), 452 | ix5 (+ ix4 x4), 453 | ix6 (+ ix5 x5) 454 | ; spans 455 | x1-2 (+ x1 x2) 456 | x1-3 (+ x1 x2 x3) 457 | x1-4 (+ x1 x2 x3 x4) 458 | x1-5 (+ x1 x2 x3 x4 x5) 459 | x1-6 (+ x1 x2 x3 x4 x5 x6) 460 | x2-3 (+ x2 x3) 461 | x5-6 (+ x5 x6)] 462 | ; first block column 463 | {:i i 464 | :l l 465 | :m m 466 | :R11 (submatrix R ix1 ix1 x1 x1) 467 | :R21 (submatrix R ix2 ix1 x2 x1) 468 | :R31 (submatrix R ix3 ix1 x3 x1) 469 | :R41 (submatrix R ix4 ix1 x4 x1) 470 | :R51 (submatrix R ix5 ix1 x5 x1) 471 | :R61 (submatrix R ix6 ix1 x6 x1) 472 | ; second block column 473 | :R22 (submatrix R ix2 ix2 x2 x2) 474 | :R32 (submatrix R ix3 ix2 x3 x2) 475 | :R42 (submatrix R ix4 ix2 x4 x2) 476 | :R52 (submatrix R ix5 ix2 x5 x2) 477 | :R62 (submatrix R ix6 ix2 x6 x2) 478 | ; third block column 479 | :R33 (submatrix R ix3 ix3 x3 x3) 480 | :R43 (submatrix R ix4 ix3 x4 x3) 481 | :R53 (submatrix R ix5 ix3 x5 x3) 482 | :R63 (submatrix R ix6 ix3 x6 x3) 483 | ; fourth block column 484 | :R44 (submatrix R ix4 ix4 x4 x4) 485 | :R54 (submatrix R ix5 ix4 x5 x4) 486 | :R64 (submatrix R ix6 ix4 x6 x4) 487 | ; fifth block column 488 | :R55 (submatrix R ix5 ix5 x5 x5) 489 | :R65 (submatrix R ix6 ix5 x6 x5) 490 | ; sixth block column 491 | :R66 (submatrix R ix6 ix6 x6 x6) 492 | ; useful partitions 493 | :R5515 (submatrix R ix5 ix1 x5 x1-5) 494 | :R1515 (submatrix R ix1 ix1 x1-5 x1-5) 495 | :R5614 (submatrix R ix5 ix1 x5-6 x1-4) 496 | :R1414 (submatrix R ix1 ix1 x1-4 x1-4) 497 | :R6614 (submatrix R ix6 ix1 x6 x1-4) 498 | :R5514 (submatrix R ix5 ix1 x5 x1-4) 499 | :R2314 (submatrix R ix2 ix1 x2-3 x1-4) 500 | :R2313 (submatrix R ix2 ix1 x2-3 x1-3) 501 | :R1113 (submatrix R ix1 ix1 x1 x1-3) 502 | :R4413 (submatrix R ix4 ix1 x4 x1-3) 503 | :R6615 (submatrix R ix6 ix1 x6 x1-5) 504 | :R5615 (submatrix R ix5 ix1 x5-6 x1-5) 505 | :R2315 (submatrix R ix2 ix1 x2-3 x1-5)}))) 506 | 507 | (defn robust-rq 508 | "Robust identification algorithm of Chapter 6 of [vOdM-96], using the 509 | QR decomposition. See Figure 6.1." 510 | ; TODO: validate R decomposition. Gamma -> AC is correct, but the method overall 511 | ; gives wrong results. 512 | ([ss i n] (robust-rq (partition-R ss i) n)) 513 | ([Rd n] 514 | (let [l (:l Rd), m (:m Rd), i (:i Rd) 515 | li (* l i), mi (* m i), mi2 (* m i 2) 516 | R44 (:R44 Rd) 517 | R1113 (:R1113 Rd) 518 | R1414 (:R1414 Rd) 519 | R2313 (:R2313 Rd) 520 | R2315 (:R2315 Rd) 521 | R4413 (:R4413 Rd) 522 | R5614 (:R5614 Rd) 523 | R5515 (:R5515 Rd) 524 | R5615 (:R5615 Rd) 525 | R6615 (:R6615 Rd) 526 | R2313' (trans R2313) 527 | I2mi (dge-eye mi2) 528 | ; step 1 529 | Ls (mm R5614 (pinv R1414)) 530 | L_Up (submatrix Ls li mi) 531 | L_Uf (submatrix Ls 0 mi li mi) 532 | L_Yp (submatrix Ls 0 mi2 li li) 533 | ; step 2 (step 3 is to determine n, which is given 534 | ;Pi (axpy -1 (mm R2313' (pinv (mm R2313 R2313')) R2313) I2mi) 535 | Pi (axpy -1 (mm (pinv R2313) R2313) I2mi) 536 | F (hcat 537 | (axpy (mm L_Up R1113 Pi) (mm L_Yp R4413 Pi)) 538 | (mm L_Yp R44)) 539 | {S1 :sigma U1 :u V1' :vt} (rsvd F :rank n) 540 | ; step 4 541 | Gamma_i (mm U1 (vect-math/sqrt S1)) 542 | Gamma_up (submatrix Gamma_i l 0 (- (mrows Gamma_i) l) n) 543 | Gamma_down (submatrix Gamma_i (- (mrows Gamma_i) l) n) 544 | Gamma_i-1 Gamma_down 545 | Tl (vcat (mm (pinv Gamma_i-1) R6615) 546 | R5515) 547 | Tr (vcat (mm (pinv Gamma_i) R5615) 548 | R2315) 549 | S (mm Tl (pinv Tr)) 550 | A (submatrix S 0 0 n n) 551 | C (submatrix S n 0 m n)] 552 | {:A A 553 | :C C 554 | :scheme :discrete-time 555 | :A-old (mm (pinv Gamma_down) Gamma_up) 556 | :C-old (submatrix Gamma_i m n)}))) 557 | 558 | (defn moesp 559 | "Explicit calculation, per (6-8) of [vOdM-95], 560 | following notation of [SSvH-04]." 561 | ([ss i n] 562 | (moesp (:U ss) (:Y ss) i n)) 563 | ([U Y i n] 564 | (let [l (mrows Y) 565 | m (mrows U) 566 | t (ncols U) 567 | {:keys [N W_p Y_f U_f W_p+ Y_f- U_f-]} (block-hankel-matrices U Y i) 568 | H (scal! (/ 1.0 (Math/sqrt N)) (vcat U_f W_p Y_f)) 569 | x1 (mrows U_f) 570 | x2 (mrows W_p) 571 | x3 (mrows Y_f) 572 | ; default no pivoting 573 | qr (qrf (trans H)) 574 | ;Q (trans (org qr)) 575 | L (view-ge (trans (view-ge (view-tr (:or qr) {:uplo :upper})))) 576 | L11 (submatrix L 0 0 x1 x1) 577 | L21 (submatrix L x1 0 x2 x1) 578 | L31 (submatrix L (+ x1 x2) 0 x3 x1) 579 | L22 (submatrix L x1 x1 x2 x2) 580 | L32 (submatrix L (+ x1 x2) x1 x3 x2) 581 | L33 (submatrix L (+ x1 x2) (+ x1 x2) x3 x3) 582 | {sigma_1 :sigma U_1 :u V_1' :vt} (rsvd L32 :rank n) 583 | Gamma_i (mm U_1 (vect-math/sqrt sigma_1)) 584 | Gamma_up (submatrix Gamma_i l 0 (- (mrows Gamma_i) l) n) 585 | Gamma_down (submatrix Gamma_i (- (mrows Gamma_i) l) n) 586 | A (mm (pinv Gamma_down) Gamma_up) 587 | C (submatrix Gamma_i l n)] 588 | {:A A 589 | :C C 590 | :order n 591 | :i i 592 | :scheme :discrete-time 593 | :method :MOESP}))) 594 | -------------------------------------------------------------------------------- /src/matlib/linalg.clj: -------------------------------------------------------------------------------- 1 | (ns matlib.linalg 2 | "Linear algebra operations on matrices. 3 | 4 | Useful references: 5 | 6 | [S-06] 7 | 'Linear Algebra and Its Applications (4th Ed.)' 8 | G Strang 9 | Wellesley-Cambridge Press (2016) 10 | ISBN 10: 0980232775 11 | ISBN 13: 9780980232776 12 | 13 | [TB-97] 14 | 'Numerical Linear Algebra' 15 | Lloyd N. Trefethen, David Bau III 16 | SIAM: Society for Industrial and Applied Mathematics (1997) 17 | ISBN 10: 0898713617 18 | ISBN 13: 9780898713619 19 | 20 | " 21 | (:require 22 | [matlib.core :refer :all] 23 | [uncomplicate.neanderthal.real :refer [entry entry!]] 24 | [uncomplicate.neanderthal.native :refer :all :exclude [sv]] 25 | [uncomplicate.neanderthal.linalg :refer :all] 26 | [uncomplicate.neanderthal.core :refer :all :exclude [entry entry!]] 27 | [uncomplicate.neanderthal.vect-math :as vect-math] 28 | [uncomplicate.neanderthal.random :as random])) 29 | 30 | (defn minv 31 | "Matrix inverse of `M` based on LU decomposition." 32 | [M] 33 | (tri! (trf M))) 34 | 35 | (defn rsvd 36 | "The reduced SVD of `M`, 37 | `M = [ U₁ | U₂ ] [ Σ₁ | 0 ] [ V₁' ]` 38 | ` [ 0 | Σ₂ ] [ V₂' ]` 39 | where the leading subspace is given with `u, vt, sigma` and similarly with 40 | subscript `2` as `u_perp` etc." 41 | ([M & options] 42 | (let [{:keys [tol rank] :or {tol sq-eps, rank nil}} options 43 | {:keys [u vt sigma]} (svd M true true) 44 | r (if rank 45 | rank 46 | (count (take-while #(> % tol) (lazy-seq (dia sigma))))) 47 | p (- (min (mrows M) (ncols M)) r) 48 | sigma_r (transfer! 49 | (subvector (view-vctr sigma) 0 r) 50 | (dgd r)) 51 | sigma_perp (transfer! 52 | (subvector (view-vctr sigma) r p) 53 | (dgd p)) 54 | vt_r (submatrix vt r (ncols vt)) 55 | u_r (submatrix u (mrows u) r) 56 | vt_perp (submatrix vt r 0 (- (mrows vt) r) (ncols vt)) 57 | u_perp (submatrix u 0 r (mrows u) (- (ncols u) r))] 58 | {:master true 59 | :sigma sigma_r 60 | :u u_r 61 | :vt vt_r 62 | :u_perp u_perp 63 | :vt_perp vt_perp 64 | :sigma_perp sigma_perp}))) 65 | 66 | (defn pinv 67 | "`M⁺`, the Moore-Penrose pseudoinverse of real matrix `M`, such that 68 | `M M⁺ M = M`, 69 | `M⁺ M M⁺ = M⁺` 70 | and `M M⁺` and `M⁺ M` are symmetric. 71 | The subspace associated with singular values less than or equal 72 | to `:tol` (or, improperly, after rank `:rank`) will be projected away." 73 | ([M & options] 74 | (let [{:keys [tol rank] :or {tol sq-eps, rank nil}} options 75 | {:keys [u vt sigma]} (rsvd M :tol tol :rank rank) 76 | inv-sigma (vect-math/inv sigma)] 77 | (mm (trans vt) inv-sigma (trans u))))) 78 | 79 | (defn rank 80 | "Estimate rank of a matrix based on the ratio of singular values." 81 | ([M & options] 82 | (let [{:keys [tol rank] :or {tol sq-eps, rank nil}} options 83 | sigma (seq (dia (:sigma (svd M)))) 84 | s1 (first sigma)] 85 | (count (filter #(> % tol) sigma))))) 86 | 87 | (defn cokern 88 | "(Left) null-space or kernel `X` of a matrix `M`, such that `x'M=0`, where 89 | `x` is any linear combination of columns of `X`." 90 | ([M & options] 91 | (let [{:keys [tol] :or {tol sq-eps}} options 92 | m (mrows M) 93 | n (ncols M) 94 | d (max m n) 95 | Z (dge m (- d n)) 96 | {:keys [u sigma]} (svd (hcat M Z) true false) 97 | r (count (filter #(> % tol) (dia sigma))) 98 | u (submatrix u 0 r (mrows u) (- (ncols u) r))] 99 | u))) 100 | 101 | (defn kern 102 | "(Right) null-space or kernel `X` of a matrix `M`, such that `Mx=0`, where 103 | `x` is any linear combination of columns of `X`." 104 | ([M & options] 105 | (let [{:keys [tol] :or {tol sq-eps}} options 106 | m (mrows M) 107 | n (ncols M) 108 | d (max m n) 109 | Z (dge (- d m) n) 110 | {:keys [vt sigma]} (svd (vcat M Z) false true) 111 | r (count (filter #(> % tol) (dia sigma))) 112 | vt_perp (submatrix vt r 0 (- (mrows vt) r) (ncols vt))] 113 | (trans vt_perp)))) 114 | 115 | (defn span 116 | "Span (range) `R` of matrix `M`, such that for `r=Mx` and any vector `x`, 117 | `r` is a linear combination of columns of `R`." 118 | ([M & options] 119 | (let [{:keys [tol rank] :or {tol sq-eps, rank nil}} options] 120 | (:u (rsvd M :tol tol :rank rank))))) 121 | 122 | (defn rsp 123 | "Projection of row-space of `E` onto row space of `F`, `E/F = EF⁺F`." 124 | [E F] 125 | (mm E (pinv F) F)) 126 | 127 | (defn rsp-perp 128 | "Orthogonal complement of the row-space projection of `E` onto `F`, 129 | `E/F^⟂ = E-E/F`." 130 | [E F] 131 | (axpy 1 E -1 (rsp E F))) 132 | 133 | (defn oblique-rsp 134 | "Oblique projection of row space of `E` onto row space of `F` along row space 135 | of `G`, `E/_GF = (E/G^⟂)(F/G^⟂)⁺F`." 136 | [E G F] 137 | (mm (rsp-perp E G) (pinv (rsp-perp F G)) F)) 138 | 139 | (defn hada 140 | "Hadamard (element-wise) product of matrices." 141 | ([A] 142 | A) 143 | ([A B] 144 | (dge (mrows A) (ncols B) (vect-math/mul (view-vctr A) (view-vctr B)))) 145 | ([A B & rst] 146 | (reduce hada (hada A B) rst))) 147 | 148 | (defn kron 149 | "Kroneker product of matrices." 150 | [A B] 151 | :not-implemented) 152 | 153 | (defn hess 154 | "Hessenberg form of matrix `M`" 155 | [M] 156 | :not-implemented) 157 | 158 | (defn trace 159 | "Trace of `M`." 160 | [M] 161 | (sum (dia M))) 162 | 163 | (defn schur-ordered 164 | "Sorted Schur decomposition." 165 | [M] 166 | :not-implemented) 167 | -------------------------------------------------------------------------------- /src/matlib/optim.clj: -------------------------------------------------------------------------------- 1 | (ns matlib.optim 2 | "Various optimisation algorithms. 3 | L-BFGS and gradient descent are implemented. 4 | The gradient is estimated by central finite difference. 5 | Differential evolution (gradient-free heuristic optimisation) is implemented. 6 | 7 | [NW-06] 8 | 'Numerical Optimization (second Ed.)' 9 | J Nocedal, S Wright 10 | Springer-Verlag New York (2006) 11 | ISBN: 978-0-387-40065-5 12 | DOI: 10.1007/978-0-387-40065-5 13 | ISBN: 978-0-387-30303-1, 978-1-4939-3711-0 14 | 15 | [L-BFGS] 16 | 'On the limited memory BFGS method for large scale optimization methods' 17 | DC Liu and J Nocedal 18 | Mathematical Programming Vol. 45, pp. 503-528 (1989) 19 | 20 | " 21 | (:require 22 | [matlib.core :refer :all] 23 | [matlib.linalg :refer :all] 24 | [matlib.de] 25 | [uncomplicate.neanderthal.real :refer [entry entry!]] 26 | [uncomplicate.neanderthal.native :refer :all :exclude [sv]] 27 | [uncomplicate.neanderthal.linalg :refer :all] 28 | [uncomplicate.neanderthal.core :refer :all :exclude [entry entry!]] 29 | [uncomplicate.neanderthal.vect-math :as vect-math] 30 | [uncomplicate.neanderthal.random :as random] 31 | [clojure.core.memoize :as core-memo])) 32 | 33 | (def ^:private ip (/ (- (Math/sqrt 5.0) 1.0) 2.0)) 34 | (def ^:private ip2 (/ (- 3.0 (Math/sqrt 5.0)) 2.0)) 35 | 36 | (defn- tolerance 37 | "Default tolerance for iterative functions, `sqrt eps * |x|₂`." 38 | [x] 39 | (cond (vctr? x) (* sq-eps (max 1.0 (nrm2 x))) 40 | (matrix? x) (* sq-eps (max 1.0 (nrm2 x))) 41 | :else (* sq-eps (max 1.0 (Math/abs x))))) 42 | 43 | (defn vctr-grad 44 | "Gradient of `f` at `x`, approximated by central finite-difference, 45 | where `x` is a Neanderthal vctr. 46 | `f: ℝⁿ -> ℝ`." 47 | ([f x] 48 | (vctr-grad f x (tolerance x))) 49 | ([f x h] 50 | (let [df_dx (dv (repeat (dim x) 0))] 51 | (doseq [i (range (dim x))] 52 | (let [dx (dv (repeat (dim x) 0))] 53 | (entry! dx i h) ; perturb in one direction 54 | (let [x+ (axpy 1.0 dx x) 55 | x- (axpy -1.0 dx x) 56 | df_dx_i (/ (- (f x+) (f x-)) (+ h h))] 57 | (entry! df_dx i df_dx_i)))) 58 | df_dx))) 59 | 60 | (defn scalar-grad 61 | "Approximate gradient of a function `phi` by central finite-difference, where 62 | `phi: ℝ -> ℝ`." 63 | ([phi ^double x] 64 | (scalar-grad phi x (tolerance x))) 65 | ([phi ^double x ^double h] 66 | (let [x+ (+ x h) 67 | x- (- x h)] 68 | (/ (- (phi x+) (phi x-)) (* 2 h))))) 69 | 70 | (defn grad 71 | "Approximate vector or scalar gradient of function `f` using central 72 | finite-difference." 73 | [f x] 74 | (if (vctr? x) 75 | (vctr-grad f x) 76 | (scalar-grad f x))) 77 | 78 | (defn golden-section 79 | "Return double `x` that minimises differentiable `phi(x)` using golden mean search. 80 | If bounds `x-` and `x+` are not given, they are assumed to be +-1e20." 81 | ([phi] 82 | (golden-section phi -1e20 1e20)) 83 | ([phi x- x+ & args] 84 | (let [a (min x- x+) 85 | b (max x- x+) 86 | {:keys [h c d fc fd k] :or {h (- b a) 87 | c (+ a (* ip2 h)) 88 | d (+ a (* ip h)) 89 | fc (phi c) 90 | fd (phi d) 91 | k 0}} args] 92 | (cond (<= h (tolerance x+)) {:sol (/ (+ a b) 2.0) :iterations k} 93 | (< fc fd) (recur phi a d {:h (* h ip) :d c :fd fc :k (inc k)}) 94 | (>= fc fd) (recur phi c b {:h (* h ip) :c d :fc fd :k (inc k)}))))) 95 | 96 | (defn- zoom 97 | "Algorithm 3.6 of [NW-06] using bisection. 98 | `phi` phi: ℝ -> ℝ, usually `phi(a) = f(x + ap)` 99 | `a-` lower bound on `a` 100 | `a+` upper bound on `a` 101 | `0 < c1 < c2 < 1`." 102 | [phi a- a+ phi0 phi'0 c1 c2 i] 103 | (let [maxiter 20 104 | a (/ (+ a+ a-) 2.0) 105 | phia (phi a) 106 | phi'a (scalar-grad phi a)] 107 | (cond (> i maxiter) {:sol a :success false} 108 | (> phia (+ phi0 (* c1 a phi'0))) (recur phi a- a phi0 phi'0 c1 c2 (inc i)) 109 | (>= phia (phi a-)) (recur phi a- a phi0 phi'0 c1 c2 (inc i)) 110 | (<= (Math/abs phi'a) (* -1 c2 phi'0)) {:sol a :success true} 111 | (>= (* phi'a (- a+ a-)) 0.0) (recur phi a a- phi0 phi'0 c1 c2 (inc i)) 112 | :else (recur phi a a+ phi0 phi'0 c1 c2 (inc i))))) 113 | 114 | (defn wolfe 115 | "Perform a line search to find a step length `a` satisfying the strong Wolfe 116 | conditions. 117 | `phi` function of scalar a 118 | `a` starting value. 119 | See p.60 [NW-06]." 120 | ([phi & options] 121 | (let [{:keys [a a- amax maxiter k phi0 phi'0 c1 c2] 122 | :or {a 1.0 123 | a- 0.0 124 | amax 2.0 125 | maxiter 20 126 | k 0 127 | phi0 (phi 0) 128 | phi'0 (scalar-grad phi 0) 129 | c1 1e-4 130 | c2 0.9}} options 131 | phi_a (phi a) 132 | phi'a (scalar-grad phi a) 133 | phi_a- (phi a-)] 134 | (cond (> k maxiter) {:sol a :success false} 135 | (> phi_a (+ phi0 (* c1 a phi'0))) (zoom phi a- a phi0 phi'0 c1 c2 0) 136 | (and (> phi_a phi_a-) (> k 1)) (zoom phi a- a phi0 phi'0 c1 c2 0) 137 | (<= (Math/abs phi'a) (* -1 c2 phi'0)) {:sol a :success true} 138 | (>= phi'a 0.0) (zoom phi a a- phi0 phi'0 c1 c2 0) 139 | :else (recur phi {:a (/ (+ a amax) 2.0) 140 | :a- a 141 | :amax amax 142 | :maxiter maxiter 143 | :k (inc k) 144 | :phi0 phi0 145 | :phi'0 phi'0 146 | :c1 c1 147 | :c2 c2}))))) 148 | 149 | (defn backtrack 150 | "Perform a backtracking line search to find a step length `a` satisfying the 151 | Armijo-Goldstein conditions. 152 | `phi` function of scalar a 153 | `a` starting value. 154 | See p.60 [NW-06]." 155 | ([phi & options] 156 | (let [{:keys [a maxiter k tau c phi0 t] 157 | :or {a 10.0 158 | maxiter 1000 159 | k 0 160 | tau 0.5 161 | c 0.5 162 | phi0 (phi 0.0) 163 | t (* -1 c (scalar-grad phi 0))}} options 164 | armijo (>= (- phi0 (phi a)) (* a t))] 165 | (cond armijo {:sol a :success true :iterations k} 166 | (> k maxiter) {:sol a :success false :iterations k} 167 | :else (recur phi {:a (* tau a) 168 | :maxiter maxiter 169 | :k (inc k) 170 | :tau tau 171 | :c c 172 | :phi0 phi0 173 | :t t}))))) 174 | 175 | (defn gradient-descent 176 | "Gradient descent with line search. 177 | `f` function to be solved, `f: ℝⁿ -> ℝ`. 178 | `x` initial solution guess 179 | options (default): 180 | `:tol` solution converges when `(nrm1 (grad f x)) < tol)`, (`sqrt eps * |x₀|²`) 181 | `:maxiter` maximum iterations (1000) 182 | `:output` print progress every iteration (`false`) 183 | `:lsmethod` line-search method for step length, one of `:wolfe`, `:gs`, `:backtrack` (`wolfe`) 184 | " 185 | ([f x & options] 186 | (let [{:keys [tol maxiter output k lsmethod] 187 | :or {tol (tolerance x) 188 | maxiter 1000 189 | output false 190 | k 0 191 | lsmethod :wolfe}} options 192 | linesearch (get {:wolfe wolfe :gs golden-section :backtrack backtrack} lsmethod wolfe) 193 | g (vctr-grad f x) 194 | q (scal -1 g) 195 | a (:sol (wolfe #(f (axpy % q x)))) 196 | x+ (axpy a q x) 197 | success (< (nrm1 g) tol)] 198 | (when output 199 | (when (= k 0) (print "gradient-descent" options "\n")) 200 | (printf "k: %05d\ta: %8.5f\t|grad| %10.3f\t|dx|: %10.3f\t|f(x+)|: %14.8f\n" 201 | k a (nrmi g) (nrm2 (axpy -1 x x+)) (f x+)) 202 | (flush)) 203 | (cond success (merge options {:sol x+ :f (f x+) :grad g :iterations k :success true :lsmethod lsmethod}) 204 | (> k maxiter) (merge options {:sol x+ :f (f x+) :grad g :iterations k :success false :lsmethod lsmethod}) 205 | :else (recur f x+ {:tol tol :maxiter maxiter :output output :k (inc k) :lsmethod lsmethod}))))) 206 | 207 | (defn- alg-7-4 208 | "Two-loop recursion in L-BFGS to calculate descent direction as the 209 | product of Hessian with the gradient. 210 | `S` is a matrix whose columns are `sᵢ` 211 | `Y` is a matrix whose columns are `yᵢ` 212 | `q` is the supplied gradient of `f` at `xₖ`. 213 | See Algorithm 7.4 of [NW-06]." 214 | [S Y q k] 215 | ; i = k-1, ..., k-m 216 | (let [c (ncols S) 217 | m (min c k) 218 | is (range (- c m) c) ; k-m, ..., k-1 219 | irhos (dv (repeat c 0.0)) 220 | as (dv (repeat c 0.0)) 221 | sl (col S (- c 1)) 222 | yl (col Y (- c 1)) 223 | yl2 (dot yl yl) 224 | gamma (/ (dot yl sl) yl2) 225 | r (dv (repeat (dim q) 0.0))] 226 | ; i = k-1, ... k-m 227 | (doseq [i (reverse is)] 228 | (let [s (col S i) 229 | y (col Y i) 230 | irho (dot y s) 231 | a (/ (dot s q) irho)] 232 | ; update as, 1/rhos, q in-place 233 | (entry! irhos i irho) 234 | (entry! as i a) 235 | (axpy! (- a) y q))) 236 | (copy! (scal gamma q) r) ; r0 = H^0_k, H^0_k = gamma I 237 | ; i = k-m, ..., k-1 238 | (doseq [i is] 239 | (let [irho (entry irhos i) 240 | a (entry as i) 241 | s (col S i) 242 | y (col Y i) 243 | b (/ (dot y r) irho)] 244 | (axpy! (- a b) s r))) 245 | (scal! 1 r))) 246 | 247 | (defn- alg-7-5 248 | "Internal L-BFGS solver. See Algorithm 7.5 of [NW-06]. 249 | Falls back to gradient descent if step results in an increase in f(x) as can 250 | occur in poorly conditioned problems." 251 | ([f x S Y X k linesearch tol maxiter history output] 252 | (let [q (vctr-grad f x) 253 | ; search direction, start off downhill 254 | p (if (= 0 k) (scal -1 q) (alg-7-4 S Y q k)) 255 | a (:sol (linesearch #(f (axpy % p x)))) 256 | x+ (axpy a p x) 257 | f_x+ (f x+) 258 | s (axpy -1 x x+) 259 | y (axpy -1 (grad f x+) (grad f x)) 260 | success (< (nrmi q) tol)] 261 | (when output 262 | (printf "k: %5d\ta: %8.5f\t|q| %10.3f\tp.s: %10.3f\t|f(x+)|: %14.8f\n" 263 | k a (nrmi q) (dot p s) (f x+)) 264 | (flush)) 265 | (shift-update S (col-vector s)) 266 | (shift-update Y (col-vector y)) 267 | (when history 268 | (shift-update X (col-vector x))) 269 | (cond success (merge {:sol x+ :f f_x+ :iterations k :tol tol :maxiter maxiter :output output :success true} (if history {:X X :S S :Y Y} {})) 270 | (> k maxiter) (merge {:sol x+ :f f_x+ :iterations k :tol tol :maxiter maxiter :output output :success false} (if history {:X X :S S :Y Y} {})) 271 | (> f_x+ (f x)) (recur f (:sol (gradient-descent f x :tol tol :maxiter 20 :output output)) S Y X (inc k) linesearch tol maxiter history output) 272 | :else (recur f x+ S Y X (inc k) linesearch tol maxiter history output))))) 273 | 274 | (defn l-bfgs 275 | "L-BFGS, using finite-difference gradient approximation. 276 | `f` function to be solved, `f: ℝⁿ -> ℝ`. 277 | `x` initial solution guess (as a vector) 278 | options (default): 279 | `:m` number of last iterations to store for approximate Hessian (20) 280 | `:tol` solution converges when `(nrm1 (grad f x)) < tol)`, (`sqrt eps * |x₀|²`) 281 | `:maxiter` maximum iterations ( 1000) 282 | `:history` return search history (`false`) 283 | `:output` print progress every iteration (`false`) 284 | `:lsmethod` line-search method for step length, one of `:wolfe`, `:gs`, `:backtrack` (`wolfe`) 285 | " 286 | ([f x & options] 287 | (let [{:keys [tol maxiter output m history lsmethod] 288 | :or {tol (tolerance x) 289 | maxiter 1000 290 | output false 291 | m 20 292 | history false 293 | lsmethod :wolfe}} options 294 | linesearch (get {:wolfe wolfe :gs golden-section :backtrack backtrack} lsmethod wolfe) 295 | S (dge (dim x) m) 296 | Y (dge (dim x) m) 297 | X (dge (dim x) maxiter)] 298 | (when output 299 | (print "l-bfgs" options "\n") 300 | (print "\t\ta: steplength\ts: step\tq: df/dx\tp: search dirn\n")) 301 | (merge (alg-7-5 f (copy x) S Y X 0 linesearch tol maxiter history output) {:lsmethod lsmethod})))) 302 | 303 | (defn de 304 | "Differential evolution (a heuristic gradient-free optimisation). 305 | Find the minimum of `f: ℝⁿ -> ℝ` given a population of `x`s. 306 | `f` function to be solved, `f: ℝⁿ -> ℝ`. 307 | `x` initial solution guess (as a vector) from which the population is generated. 308 | options (default): 309 | `:CR` combination rate (0.9) 310 | `:F` differential weight (0.8) 311 | `:maxiter` maximum iterations (10000) 312 | `:memo` memoize calls to `f` (`false`) 313 | `:output` print progress every iteration (`false`) 314 | note: 315 | `f` is memoized with a lru cache. 316 | Constraints should be handled in `f`. 317 | " 318 | ([f x & params] 319 | (let [xs (if (:NP params) (matlib.de/population x (:NP params)) (matlib.de/population x)) 320 | {:keys [memo output CR F maxiter scores n] 321 | :or {output false 322 | memo false 323 | CR 0.9 324 | F 0.8 325 | maxiter 10000 326 | scores (map f xs) 327 | n 0}} params 328 | objective-fn (if memo (core-memo/lru f {} :lru/threshold (* 2 (count xs))) f)] 329 | (when output 330 | (print "de" params "\n") 331 | (print "\tn:\t\tf(x)\n")) 332 | (merge {:memo memo} (matlib.de/solve objective-fn xs CR F maxiter scores n output))))) 333 | 334 | (defn- booth 335 | "Booth function f: ℝ² -> ℝ, minimum at f(1, 3) = 0." 336 | [v] 337 | (let [x (entry v 0) 338 | y (entry v 1)] 339 | (+ (Math/pow (+ x y y -7) 2) 340 | (Math/pow (+ x x y -5) 2)))) 341 | 342 | (defn- beale 343 | "Beale function f: ℝ² -> ℝ, minimum at f(3, 0.5) = 0." 344 | [v] 345 | (let [x (entry v 0) 346 | y (entry v 1) 347 | mx (- x)] 348 | (+ (Math/pow (+ 1.5 (* x y) mx) 2) 349 | (Math/pow (+ 2.25 (* x y y) mx) 2) 350 | (Math/pow (+ 2.625 (* x y y y) mx) 2)))) 351 | 352 | (defn- rosenbrock 353 | "Rosenbrock function f: ℝ² -> ℝ. 354 | Since there is a large flat valley, requires a low tolerance." 355 | ([v] 356 | (rosenbrock v 1 100)) 357 | ([v a b] 358 | (let [x (entry v 0) 359 | y (entry v 1)] 360 | (+ (Math/pow (- a x) 2) 361 | (* b (Math/pow (- y (* x x)) 2)))))) 362 | 363 | (defn- lyap 364 | "Example matrix continuous time Lyapunov equation." 365 | ([x] 366 | (lyap x (dge 2 2 [1 3 2 1]) (dge 2 2 [5 34 34 5]))) 367 | ([x A Q] 368 | (let [n (Math/sqrt (dim x)) 369 | X (view-ge x n n)] 370 | (nrm2 (xpy (mm A X) (mm X A) Q))))) 371 | -------------------------------------------------------------------------------- /src/matlib/state_space.clj: -------------------------------------------------------------------------------- 1 | (ns matlib.state-space 2 | "Basic Linear Time-Invariant (LTI) state space system operations and patterns. 3 | 4 | A discrete-time state-space system is expressed as a set of matrices 5 | `A`, `B`, `C`, `D` which can be integrated as: 6 | `x(k+1) = A x(k) + B u(k) + w(k)` 7 | ` y(k) = C x(k) + D u(k) + v(k)`, 8 | with integer `k` and 9 | `u(k) ∈ ℝ^m,` 10 | `y(k) ∈ ℝ^l,` 11 | `x(k) ∈ ℝ^n`. 12 | 13 | The noise terms `w(k)` and `v(k)` are unobserved, Gaussian distributed, 14 | zero-mean, non-zero white noise, with covariances 15 | `ℰ ( w_k w_l' ) = Q δ_kl >= 0` 16 | `ℰ ( w_k v_l' ) = S δ_kl >= 0` 17 | `ℰ ( v_k w_l' ) = S' δ_kl >= 0` 18 | `ℰ ( v_k v_l' ) = R δ_kl >= 0` 19 | 20 | A continuous-time state-space system is a set of matrices `A`, `B`, `C`, `D` 21 | which can be integrated as: 22 | 23 | `dx(t)/dt = A x(t) + B u(t) + w(t)` 24 | `y(t) = C x(t) + D u(t) + v(t)`, 25 | with `t ∈ ℝ` and 26 | `u(t) ∈ ℝ^m,` 27 | `y(t) ∈ ℝ^l,` 28 | `x(t) ∈ ℝ^n`. 29 | 30 | Internally, discrete-time state-space systems are stored as maps, 31 | `{:A A :B B :C C :D D}`, 32 | optionally with 33 | `{:x x(k), :u u(k), :y y(k), :x+ x(k+1)}` 34 | and optionally with `{:E E}`. 35 | If `E` is supplied, `w(k)` and `v(k)` are generated with covariance matrix 36 | `[ Q S ] = EE'` 37 | `[ S' R ]` 38 | so that 39 | `( w(k) ) = E n(k)` 40 | `( v(k) )` 41 | with `n(k)` serially uncorrelated and drawn from `N(0,1)`. 42 | 43 | The snapshot matrix of inputs `{u(k)}` is stored under `:U`. 44 | Once the system is integrated using `make-snapshots`, snapshot matrix `Y` 45 | will be added to the map. 46 | " 47 | (:require 48 | [matlib.core :refer :all] 49 | [matlib.linalg :refer :all] 50 | [uncomplicate.neanderthal.real :refer [entry entry!]] 51 | [uncomplicate.neanderthal.native :refer :all :exclude [sv]] 52 | [uncomplicate.neanderthal.linalg :refer :all] 53 | [uncomplicate.neanderthal.core :refer :all :exclude [entry entry!]] 54 | [uncomplicate.neanderthal.vect-math :refer :all] 55 | [uncomplicate.neanderthal.random :as random])) 56 | 57 | (defn step-discrete-time 58 | "Integrate a discrete-time system one step, by calculating 59 | `x+ = Ax + Bu + w` 60 | ` y = Cx + Du + v` 61 | `x` is the state vector (a column vector). 62 | Argument `u` is u(k)." 63 | ([ss u] 64 | (let [x (get ss :x+ (:x ss)) 65 | y (axpy 66 | 1 (mm (:C ss) x) 67 | 1 (mm (:D ss) (col-vector u))) 68 | x+ (axpy 69 | 1 (mm (:A ss) x) 70 | 1 (mm (:B ss) (col-vector u)))] 71 | (merge ss 72 | {:k (inc (get ss :k -1)) 73 | :x x 74 | :x+ x+ 75 | :y y 76 | :u (col-vector u)} 77 | (if (:E ss) 78 | (let [n (mm (:E ss) (random/rand-normal! (dge (ncols (:E ss)) 1))) 79 | w (submatrix n (dim x) 1) 80 | v (submatrix n (dim x) 0 (dim y) 1)] 81 | {:x+ (axpy x+ w) 82 | :y (axpy y v) 83 | :v v 84 | :w w}) 85 | {}))))) 86 | 87 | (defn make-snapshots 88 | "Generate snapshot matrices of states `X`, outputs `Y` and noise `e` from a 89 | snapshot matrix of inputs, `U`, and a model, `ss`. 90 | `:k` of `ss` corresponds to the column of `U` and `Y`." 91 | ([ss] 92 | (cond 93 | (not (:U ss)) :input-snapshots-missing 94 | (not (:Y ss)) (recur (merge ss {:Y (dge (mrows (:C ss)) (ncols (:U ss)))})) 95 | (not (:X ss)) (recur (merge ss {:X (dge (mrows (:A ss)) (ncols (:U ss)))})) 96 | (not (:W ss)) (recur (merge ss {:W (dge (mrows (:A ss)) (ncols (:U ss)))})) 97 | (not (:V ss)) (recur (merge ss {:V (dge (mrows (:C ss)) (ncols (:U ss)))})) 98 | (not (:k ss)) (recur (step-discrete-time ss (col (:U ss) 0))) 99 | (< (:k ss) (ncols (:U ss))) (let [ss+ (step-discrete-time ss (col (:U ss) (:k ss)))] 100 | ; side effects on X, Y 101 | (copy! (:x ss) (submatrix (:X ss) 0 (:k ss) (mrows (:A ss)) 1)) 102 | (copy! (:w ss) (submatrix (:W ss) 0 (:k ss) (mrows (:A ss)) 1)) 103 | (copy! (:y ss) (submatrix (:Y ss) 0 (:k ss) (mrows (:C ss)) 1)) 104 | (copy! (:v ss) (submatrix (:V ss) 0 (:k ss) (mrows (:C ss)) 1)) 105 | (recur ss+)) 106 | :else ss))) 107 | 108 | (defn tf 109 | "Transfer function (input-output) of system, 110 | `G(z) = D + C (zI - A)^-1 B`, or 111 | `G(s) = D + C (sI - A)^-1 B`." 112 | ([ss] 113 | (fn [z] (tf ss z))) 114 | ([ss z] 115 | (let [A (:A ss) 116 | B (:B ss) 117 | C (:C ss) 118 | D (:D ss) 119 | n (ncols A) 120 | I (transfer! (eye n) (dge n n))] 121 | (axpy 1 (mm C (minv (axpby! z I -1 (copy A))) B) D)))) 122 | 123 | (defn sigmas 124 | "Singular values of the transfer function over a range of `z` (or `s`)." 125 | [ss zs] 126 | (apply hcat (map #(col-vector (:sigma (svd (tf ss %)))) zs))) 127 | 128 | ;;; below is for testing 129 | 130 | (def i 8000) 131 | 132 | (def ss-model {:scheme :discrete-time 133 | :A (dge 2 2 [0.9 0.2 0 -0.995]) 134 | ;:B (dge 3 2 [1 0 1, 0 1 1]) 135 | :B (dge 2 2 [1 2, 0 1]) 136 | :C (dge 1 2 [1 1, 0 1]) 137 | :D (dge 1 2 [0 0, 0 0]) 138 | :E (scal! 0.005 (dge 3 2 (range))) 139 | :x (dge 2 1 [0 0]) 140 | ; need a better input: 141 | ; - persistently exciting 142 | ; - different frequencies 143 | :U (dge 2 i)}) 144 | 145 | ; first input signal 146 | (axpy! (sin (scal! 0.050 (dge 1 i (range)))) (submatrix (:U ss-model) 0 0 1 i)) 147 | (axpy! (sin (scal! 0.055 (dge 1 i (range)))) (submatrix (:U ss-model) 0 0 1 i)) 148 | (axpy! (sin (scal! 0.150 (dge 1 i (range)))) (submatrix (:U ss-model) 0 0 1 i)) 149 | (axpy! (sin (scal! 1.150 (dge 1 i (range)))) (submatrix (:U ss-model) 0 0 1 i)) 150 | (axpy! (sin (scal! 0.002 (dge 1 i (range)))) (submatrix (:U ss-model) 0 0 1 i)) 151 | 152 | ; second input signal 153 | (axpy! (sin (scal! 0.500 (dge 1 i (range)))) (submatrix (:U ss-model) 1 0 1 i)) 154 | (axpy! (sin (scal! 0.530 (dge 1 i (range)))) (submatrix (:U ss-model) 1 0 1 i)) 155 | (axpy! (sin (scal! 1.503 (dge 1 i (range)))) (submatrix (:U ss-model) 1 0 1 i)) 156 | (axpy! (sin (scal! 4.503 (dge 1 i (range)))) (submatrix (:U ss-model) 1 0 1 i)) 157 | (axpy! (sin (scal! 0.007 (dge 1 i (range)))) (submatrix (:U ss-model) 1 0 1 i)) 158 | 159 | ; arbitrarily step some input 160 | (scal! 5.0 (submatrix (:U ss-model) 0 200 2 1000)) 161 | 162 | ; input noise 163 | (axpy! (random/rand-normal! 0 0.1 (dge (mrows (:U ss-model)) (ncols (:U ss-model)))) (:U ss-model)) 164 | -------------------------------------------------------------------------------- /src/matlib/stats.clj: -------------------------------------------------------------------------------- 1 | (ns matlib.stats 2 | "Basic statistical matrix operations." 3 | (:require 4 | [matlib.core :refer :all] 5 | [matlib.linalg :refer :all] 6 | [uncomplicate.neanderthal.real :refer [entry entry!]] 7 | [uncomplicate.neanderthal.native :refer :all :exclude [sv]] 8 | [uncomplicate.neanderthal.linalg :refer :all] 9 | [uncomplicate.neanderthal.core :refer :all :exclude [entry entry!]] 10 | [uncomplicate.neanderthal.vect-math :refer :all] 11 | [uncomplicate.neanderthal.random :refer :all])) 12 | 13 | (defn row-mean 14 | "Mean across rows." 15 | ([M] 16 | (scal! (/ 1.0 (mrows M)) (dv (map sum (cols M)))))) 17 | 18 | (defn col-mean 19 | "Mean across columns." 20 | ([M] 21 | (scal! (/ 1.0 (ncols M)) (dv (map sum (rows M)))))) 22 | 23 | (defn subtract-col-mean 24 | "Subtract the mean over columns from each row." 25 | [M] 26 | (let [ave (col-vector (col-mean M)) 27 | m-ones (dge 1 (ncols M) (repeat (double -1))) 28 | result (mm ave m-ones)] 29 | (axpy! M result))) 30 | 31 | (defn scale-col-mean 32 | "Divide each row by its mean." 33 | [M] 34 | (let [ave (col-mean M) 35 | ave-inv (div! (ones ave) ave) 36 | d-ave-inv (transfer! ave-inv (dgd (dim ave)))] 37 | (mm d-ave-inv M))) 38 | 39 | (defn covar 40 | "Covariance matrix from a matrix of observations `M`. 41 | Columns of `M` correspond to each sample." 42 | [M] 43 | (let [R (subtract-col-mean M)] 44 | (scal! (/ 1.0 (ncols R)) (mm R (trans R))))) 45 | 46 | (defn sd 47 | "Unscaled sqrt of the diagonal of the covariance matrix." 48 | [M] 49 | (sqrt! (copy (dia (covar M))))) 50 | 51 | (defn snr 52 | "Unscaled mean / std dev." 53 | [M] 54 | (div (col-mean M) (sd M))) 55 | 56 | (defn fuzz 57 | "Add normally distributed random numbers to `M`. The distribution has mean of 58 | `mu` (default 0) and standard deviation `sigma`." 59 | ([M mu sigma] 60 | (axpy! M (rand-normal! mu sigma (copy M)))) 61 | ([M sigma] 62 | (fuzz M 0 sigma))) 63 | --------------------------------------------------------------------------------