Permalink
Browse files

Initial Commit

  • Loading branch information...
0 parents commit f655193ddd43a10def1dec2817bcab2ccc388125 Ville Tirronen committed Jun 29, 2011
Showing with 272 additions and 0 deletions.
  1. +171 −0 AI/SVM/Simple.hs
  2. +34 −0 Examples/SmokeTest.hs
  3. +26 −0 LICENSE
  4. +7 −0 README
  5. +2 −0 Setup.hs
  6. +32 −0 svm-simple.cabal
@@ -0,0 +1,171 @@
+{-# LANGUAGE ForeignFunctionInterface, BangPatterns, ScopedTypeVariables, TupleSections,
+ RecordWildCards #-}
+module SVMSimple (loadSVM, saveSVM
+ ,trainSVM, predict
+ , SVM
+ , SVMType(..), Kernel(..)) where
+
+import qualified Data.Vector.Storable as V
+import Data.Vector.Storable ((!))
+import Bindings.SVM
+import Foreign.C.Types
+import Foreign.C.String
+import Foreign.Ptr
+import Foreign.ForeignPtr
+import qualified Foreign.Concurrent as C
+import Foreign.Marshal.Utils
+import Control.Applicative
+import System.IO.Unsafe
+import Foreign.Storable
+import Control.Monad
+
+
+{-# SPECIALIZE convertDense :: V.Vector Double -> V.Vector C'svm_node #-}
+{-# SPECIALIZE convertDense :: V.Vector Float -> V.Vector C'svm_node #-}
+convertDense :: (V.Storable a, Real a) => V.Vector a -> V.Vector C'svm_node
+convertDense v = V.generate (dim+1) readVal
+ where
+ dim = V.length v
+ readVal !n | n >= dim = C'svm_node (-1) 0
+ readVal !n = C'svm_node (fromIntegral n) (realToFrac $ v ! n)
+
+
+withProblem :: [(Double, V.Vector Double)] -> (Ptr C'svm_problem -> IO b) -> IO b
+withProblem v op = -- Well. This turned out super ugly. Also, this is a veritable
+ -- bug magnet.
+ V.unsafeWith xs $ \ptr_xs ->
+ V.unsafeWith y $ \ptr_y ->
+ let optrs = offsetPtrs ptr_xs
+ in V.unsafeWith optrs $ \ptr_offsets ->
+ with (C'svm_problem (fromIntegral dim) ptr_y ptr_offsets) op
+ where
+ dim = length v
+ lengths = map (V.length . snd) v
+ offsetPtrs addr = V.fromList . take dim $
+ [addr `plusPtr` (idx * sizeOf (xs ! 0))
+ | idx <- scanl (+) 0 lengths]
+ y = V.fromList . map (realToFrac . fst) $ v
+ xs = V.concat . map (extractSvmNode.snd) $ v
+ extractSvmNode x = convertDense $ V.generate (V.length x) (x !)
+
+-- | A Support Vector Machine
+newtype SVM = SVM (ForeignPtr C'svm_model)
+
+
+modelFinalizer :: Ptr C'svm_model -> IO ()
+modelFinalizer modelPtr = with modelPtr c'svm_free_and_destroy_model
+
+-- | load an svm from a file.
+loadSVM :: FilePath -> IO SVM
+loadSVM fp = do
+ ptr <- withCString fp c'svm_load_model
+ let fin = modelFinalizer ptr
+ SVM <$> C.newForeignPtr ptr fin
+
+-- | Save an svm to a file.
+saveSVM :: FilePath -> SVM -> IO ()
+saveSVM fp (SVM fptr) =
+ withForeignPtr fptr $ \model_ptr ->
+ withCString fp $ \cstr ->
+ c'svm_save_model cstr model_ptr
+
+
+-- | Predict the class of a vector with an SVM.
+predict :: SVM -> V.Vector Double -> Double
+predict (SVM fptr) vec = unsafePerformIO $
+ withForeignPtr fptr $ \modelPtr ->
+ let nodes = convertDense vec
+ in realToFrac <$> V.unsafeWith nodes (c'svm_predict modelPtr)
+
+defaultParamers = C'svm_parameter {
+ c'svm_parameter'svm_type = c'C_SVC
+ , c'svm_parameter'kernel_type = c'LINEAR
+ , c'svm_parameter'degree = 3
+ , c'svm_parameter'gamma = 0.01
+ , c'svm_parameter'coef0 = 0
+ , c'svm_parameter'cache_size = 100
+ , c'svm_parameter'eps = 0.001
+ , c'svm_parameter'C = 1
+ , c'svm_parameter'nr_weight = 0
+ , c'svm_parameter'weight_label = nullPtr
+ , c'svm_parameter'weight = nullPtr
+ , c'svm_parameter'nu = 0.5
+ , c'svm_parameter'p = 0.1
+ , c'svm_parameter'shrinking = 1
+ , c'svm_parameter'probability = 0
+ }
+
+-- | SVM variants
+data SVMType =
+ -- | C svm (the default tool for classification tasks)
+ C_SVC {cost :: Double}
+ -- | Nu svm
+ | NU_SVC {cost :: Double, nu :: Double}
+ -- | One class svm
+ | ONE_CLASS {nu :: Double}
+ -- | Epsilon support vector regressor
+ | EPSILON_SVR {cost :: Double, epsilon :: Double}
+ -- | Nu support vector regressor
+ | NU_SVR {cost :: Double, nu :: Double}
+
+-- | SVM kernel type
+data Kernel = Linear
+ | Polynomial {gamma :: Double, coef0 :: Double, degree :: Int}
+ | RBF {gamma :: Double}
+ | Sigmoid {gamma :: Double, coef0 :: Double}
+ deriving (Show)
+
+rf = realToFrac
+setKernelParameters Linear p = p
+setKernelParameters (Polynomial {..}) p = p{c'svm_parameter'gamma=rf gamma
+ ,c'svm_parameter'coef0=rf coef0
+ ,c'svm_parameter'degree=fromIntegral degree}
+setKernelParameters (RBF {..}) p = p{c'svm_parameter'gamma=rf gamma }
+setKernelParameters (Sigmoid {..}) p = p{c'svm_parameter'gamma=rf gamma
+ ,c'svm_parameter'coef0=rf coef0 }
+
+setTypeParameters (C_SVC cost) p = p{c'svm_parameter'C=rf cost}
+
+setTypeParameters (NU_SVC{..}) p = p{c'svm_parameter'C=rf cost
+ ,c'svm_parameter'nu=rf nu}
+setTypeParameters (ONE_CLASS{..}) p = p{c'svm_parameter'nu=rf nu}
+
+setTypeParameters (EPSILON_SVR{..}) p = p{c'svm_parameter'C=rf cost
+ ,c'svm_parameter'p=rf epsilon}
+
+setTypeParameters (NU_SVR {..}) p = p{c'svm_parameter'C=rf cost
+ ,c'svm_parameter'nu=rf nu}
+
+
+withParameters svm kernel op = with parameters op
+ where
+ parameters = setTypeParameters svm
+ . setKernelParameters kernel
+ $ defaultParamers
+
+-- Other params that currently cannot be passed:
+-- epsilon -- termination 0.001
+-- cachesize -- in mb 100
+-- shrinking -- bool 1
+-- probability-estimates -- bool 0
+-- weights --
+
+foreign import ccall "wrapper"
+ wrapPrintF :: (CString -> IO ()) -> IO (FunPtr (CString -> IO ()))
+
+-- | Create an SVM from the training data
+trainSVM :: SVMType -> Kernel -> [(Double, V.Vector Double)] -> IO SVM
+trainSVM svm kernel dataSet = do
+ pf <- wrapPrintF (\cstr -> peekCString cstr >>= print . (, ":HS"))
+ -- The above is just a test. Realistically at that point there
+ -- should be an ioref that captures the output which would then
+ -- be returned from this function.
+ c'svm_set_print_string_function pf
+ modelPtr <- withProblem dataSet $ \ptr_problem ->
+ withParameters svm kernel $ \ptr_parameters ->
+ c'svm_train ptr_problem ptr_parameters
+ SVM <$> C.newForeignPtr modelPtr (modelFinalizer modelPtr)
+
+
+
+
@@ -0,0 +1,34 @@
+{-# LANGUAGE ForeignFunctionInterface, BangPatterns, ScopedTypeVariables, TupleSections,
+ RecordWildCards #-}
+module Main where
+
+import SVMSimple
+import qualified Data.Vector.Storable as V
+
+main = do
+ svm <- loadSVM "model"
+ let positiveSample = V.fromList
+ [0.708333, 1, 1, -0.320755, -0.105023, -1
+ , 1, -0.419847, -1, -0.225806, 1, -1]
+ negativeSample = V.fromList
+ [0.583333 ,-1 ,0.333333 ,-0.603774 ,1 ,-1
+ ,1 ,0.358779 ,-1 ,-0.483871 ,-1 ,1]
+
+ let
+ pos = predict svm positiveSample
+ neg = predict svm negativeSample
+ print "Testing a loaded model. Expect (1,-1)."
+ print (pos,neg)
+ print "Training"
+ let trainingData = [(-1, V.fromList [0])
+ ,(-1, V.fromList [20])
+ ,(1, V.fromList [21])
+ ,(1, V.fromList [50])
+ ]
+ svm2 <- trainSVM (C_SVC 1) Linear trainingData
+ print $ predict svm2 $ V.fromList [0]
+ print $ predict svm2 $ V.fromList [19]
+ print $ predict svm2 $ V.fromList [12]
+ print $ predict svm2 $ V.fromList [40]
+
+
26 LICENSE
@@ -0,0 +1,26 @@
+Copyright (c) 2009, Paulo Tanimoto
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+- Redistributions of source code must retain the above copyright notice,
+ this list of conditions and the following disclaimer.
+- Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+- Neither the names of the copyright owners nor the names of the
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
7 README
@@ -0,0 +1,7 @@
+# Simple SVM
+
+Simple SVM is a small project to make good quality haskell bindings for libsvm
+
+## Current Status
+
+Currently this is just a preliminary version, which incidentally, is not at all simple.
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
@@ -0,0 +1,32 @@
+name: svm-simple
+version: 0.0.1
+synopsis: Medium level, simplified, bindings to libsvm
+description:
+ Simplified bindings to libsvm <http://www.csie.ntu.edu.tw/~cjlin/libsvm/>.
+ The aim of this package is to make as easy to use bindings for libsvm as
+ possible. (But we are not yet there)
+ Changes in version 0.0.1
+ .
+ * Initial version
+ .
+license: BSD3
+license-file: LICENSE
+author: Paulo Tanimoto <ptanimoto@gmail.com>
+ Ville Tirronen <aleator@gmail.com>
+maintainer: Paulo Tanimoto <ptanimoto@gmail.com>
+ Ville Tirronen <aleator@gmail.com>
+homepage: http://github.com/aleator/Simple-SVM
+bug-reports: http://github.com/aleator/Simple-SVM/issues
+category: AI, Pattern Classification, Algorithms, Support Vector Machine
+
+build-type: Simple
+cabal-version: >= 1.8
+
+extra-source-files:
+ Examples/SmokeTest.hs
+
+library
+ AI.SVM.Simple
+ build-depends:
+ base >= 4 && < 5,
+ bindings-svm >= 0.2.0 && < 0.3

0 comments on commit f655193

Please sign in to comment.