xgboost-haskell (empty) → 0.1.0.0
raw patch · 11 files changed
+1134/−0 lines, 11 filesdep +basedep +foundationdep +xgboost-haskellsetup-changed
Dependencies added: base, foundation, xgboost-haskell
Files
- LICENSE +20/−0
- README.md +4/−0
- Setup.hs +2/−0
- app/Main.hs +28/−0
- examples/agaricus.hs +33/−0
- src/ML/DMLC/XGBoost.hs +155/−0
- src/ML/DMLC/XGBoost/Exception.hs +16/−0
- src/ML/DMLC/XGBoost/FFI.hs +552/−0
- src/ML/DMLC/XGBoost/Foreign.hs +96/−0
- src/ML/DMLC/XGBoost/Rabit/FFI.hs +174/−0
- xgboost-haskell.cabal +54/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2017 HE, Tao (sighingnow@gmail.com)++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,4 @@+# xgboost-haskell++XGBoost for Haskell, based on the [foundation](https://github.com/haskell-foundation/foundation) package.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE ExtendedDefaultRules #-}++module Main where++import Foundation++import ML.DMLC.XGBoost++-- | Make float as the default type for floating literals.+default (Float)++main :: IO ()+main = do+ putStrLn $ "hello " <> "xgboost"++ dm <- xgbFromMat ([1.0, 2.0, 3.0, 4.0] :: UArray Float) 2 2 2.0++ xgbSetFloatInfo dm LabelInfo ([5.0, 6.0] :: UArray Float)+ info <- xgbGetFloatInfo dm LabelInfo+ print info++ xgbGetFloatInfo dm LabelInfo >>= print++ dmatrixFree dm++print :: Show a => a -> IO ()+print = putStrLn . show
+ examples/agaricus.hs view
@@ -0,0 +1,33 @@+{-# OPTIONS_GHC -Wno-type-defaults #-}+{-# LANGUAGE ImplicitParams #-}++module Main where++import Foundation++import ML.DMLC.XGBoost++main :: IO ()+main = do+ putStrLn $ "xgboost example: agaricus"++ let ?params = [ Param "max_depth" 10+ , Param "eta" 1+ , Param "slient" 1+ , Param "objective" BinaryLogistic ]+ ?debug = True++ dtrain <- xgbFromFile "examples/data/agaricus.txt.train" ?debug+ dtest <- xgbFromFile "examples/data/agaricus.txt.test" ?debug++ booster <- xgbTrain dtrain 10+ result <- xgbPredict booster dtest [] 0++ labels <- xgbGetLabel dtest++ putStrLn . show $ compareLabels labels result++ -- putStrLn . show $ valueToLabel' result++ dmatrixFree dtrain+ dmatrixFree dtest
+ src/ML/DMLC/XGBoost.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE RecordWildCards #-}++module ML.DMLC.XGBoost+ ( module ML.DMLC.XGBoost+ , module ML.DMLC.XGBoost.FFI+ ) where++import Foundation+import Foundation.Collection+import Foundation.Numerical++import qualified Prelude (fromIntegral, Show(..))+import Control.Exception (assert)+import Control.Monad (when, foldM_)++import ML.DMLC.XGBoost.FFI+import ML.DMLC.XGBoost.Rabit.FFI++{------------------------------------------------------------------------------+-- Utility functions.+------------------------------------------------------------------------------}++integerToFloat :: Int -> Float+integerToFloat = Prelude.fromIntegral++-- | Cast floating point output to integer label.+valueToLabel :: (IntegralRounding a) => a -> Int32+valueToLabel = roundNearest++{-# SPECIALIZE valueToLabel :: Float -> Int32 #-}++{-# INLINE valueToLabel #-}++compareLabels+ :: UArray Float -- ^ Wanted+ -> UArray Float -- ^ Actual output+ -> Float -- ^ Successfully rate+compareLabels wanted actual = integerToFloat sameLength / integerToFloat nLength+ where+ sameLabel a b = valueToLabel a == valueToLabel b+ accLabels (a, b) n = if sameLabel a b+ then n + 1+ else n+ nLength = let (CountOf k) = min (length wanted) (length actual) in k+ sameLength = foldr' accLabels 0 $ (zipWith (,) wanted actual :: [(Float, Float)])++compareLabels'+ :: UArray Float -- ^ Wanted+ -> UArray Float -- ^ Actual output+ -> (Float -> Float -> Bool) -- ^ decide whether two given labels are equal+ -> Float -- ^ Successfully rate+compareLabels' wanted actual sameLabel = integerToFloat sameLength / integerToFloat nLength+ where+ accLabels (a, b) n = if sameLabel a b+ then n + 1+ else n+ nLength = let (CountOf k) = min (length wanted) (length actual) in k+ sameLength = foldr' accLabels 0 $ (zipWith (,) wanted actual :: [(Float, Float)])+++{------------------------------------------------------------------------------+-- DMatrix related APIs.+------------------------------------------------------------------------------}++++{------------------------------------------------------------------------------+-- Booster related APIs.+------------------------------------------------------------------------------}++-- | Parameter passed to booster.+data BoosterParam = forall a. Show a => Param { paramName :: String+ , paramValue :: a+ }++-- | Predefined objective functions.+--+-- Ref: https://github.com/dmlc/xgboost/blob/master/src/objective/regression_obj.cc+data ObjectiveFunction = RegLinear | RegLogistic | BinaryLogistic | BinaryLogitraw | CountPoisson | RegGamma | RegTweedie deriving Eq++instance Show ObjectiveFunction where+ show RegLinear = "reg:linear"+ show RegLogistic = "reg:logistic"+ show BinaryLogistic = "binary:logistic"+ show BinaryLogitraw = "binary:logitraw"+ show CountPoisson = "count:poisson"+ show RegGamma = "reg:gamma"+ show RegTweedie = "reg:tweedie"++setBoosterParam+ :: Booster+ -> BoosterParam+ -> IO ()+setBoosterParam booster Param{..} = setParam booster paramName (show paramValue)++newBooster :: (?params :: [BoosterParam]) => [DMatrix] -> IO Booster+newBooster dmats = do+ booster <- xgbBooster dmats+ setParam booster "seed" "0"+ forM_ ?params $ \param ->+ setBoosterParam booster param+ return booster++{------------------------------------------------------------------------------+-- Model train and predict APIs.+------------------------------------------------------------------------------}++xgbTrain+ :: (?params :: [BoosterParam], ?debug :: Bool)+ => DMatrix -- ^ Data to be trained+ -> Int32 -- ^ Number of boosting iterations+ -> IO Booster+xgbTrain dtrain rounds = do+ let nboost = 0++ booster <- newBooster [dtrain]+ version <- loadRabitCheckpoint booster++ when ?debug $ do+ wdsize <- rabitGetWordSize+ assert (wdsize /= 1 || version == 0) $ return ()++ let startIter = version `div` 2++ let go (_nboost, _version) i = do+ _version' <- if _version `mod` 2 == 0+ then do+ updateOneIter booster i dtrain+ saveRabitCheckpoint booster+ return (_version + 1)+ else return _version++ when ?debug $ do+ wdsize <- rabitGetWordSize+ ver <- rabitVersionNumber+ assert (wdsize == 1 || _version' == ver) $ return ()++ saveRabitCheckpoint booster++ return (_nboost + 1, _version' + 1)++ foldM_ go (nboost + startIter, version) [startIter, rounds]++ return booster++xgbPredict+ :: (?debug :: Bool)+ => Booster+ -> DMatrix+ -> [PredictMask]+ -> Int32 -- ^ Limit number of trees in the prediction; defaults to 0 (use all trees).+ -> IO (UArray Float)+xgbPredict booster dtest masks nlimit = boosterPredict booster dtest masks nlimit
+ src/ML/DMLC/XGBoost/Exception.hs view
@@ -0,0 +1,16 @@+module ML.DMLC.XGBoost.Exception+ ( XGBoostException (..)+ , throw+ ) where++import Foundation+import Foundation.Monad (throw)++import qualified Prelude++data XGBoostException = XGBError Int32 String deriving Typeable++instance Exception XGBoostException++instance Prelude.Show XGBoostException where+ show (XGBError err message) = "XGBError: return " <> Prelude.show err <> "\n" <> (toList message)
+ src/ML/DMLC/XGBoost/FFI.hs view
@@ -0,0 +1,552 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UnboxedTuples #-}++module ML.DMLC.XGBoost.FFI where++import Foundation+import Foundation.Array.Internal+import Foundation.Class.Storable+import Foundation.Foreign+import Foundation.Primitive++import qualified Prelude (Show(..))+import Data.Bits ((.|.))+import qualified Foreign.Storable+import Foreign.Marshal.Alloc (alloca)+import GHC.Exts++import ML.DMLC.XGBoost.Exception+import ML.DMLC.XGBoost.Foreign++newtype DMatrix = DMatrix (Ptr ())+ deriving (Eq, Storable, Foreign.Storable.Storable)++{-- Instances to make `DMatirx` (`Ptr ()`) as foundation's PrimType, GeneralizedNewtypeDeriving doesn't work here. --}++instance PrimType DMatrix where+ primSizeInBytes _ = size (Proxy :: Proxy (Ptr ()))+ {-# INLINE primSizeInBytes #-}++ primShiftToBytes _ = let (CountOf k) = size (Proxy :: Proxy (Ptr ())) in if k == 4 then 3 else 5 -- TODO may be wrong+ {-# INLINE primShiftToBytes #-}++ primBaUIndex ba (Offset (I# n)) = DMatrix (Ptr (indexAddrArray# ba n))+ {-# INLINE primBaUIndex #-}++ primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r1 #) = readAddrArray# mba n s1+ in (# s2, DMatrix (Ptr r1) #)+ {-# INLINE primMbaURead #-}++ primMbaUWrite mba (Offset (I# n)) (DMatrix (Ptr w)) = primitive $ \s1 -> (# writeAddrArray# mba n w s1, () #)+ {-# INLINE primMbaUWrite #-}++ primAddrIndex addr (Offset (I# n)) = DMatrix (Ptr (indexAddrOffAddr# addr n))+ {-# INLINE primAddrIndex #-}++ primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r1 #) = readAddrOffAddr# addr n s1+ in (# s2, DMatrix (Ptr r1) #)+ {-# INLINE primAddrRead #-}++ primAddrWrite addr (Offset (I# n)) (DMatrix (Ptr w)) = primitive $ \s1 -> (# writeAddrOffAddr# addr n w s1, () #)+ {-# INLINE primAddrWrite #-}++type DMatrixArray = Ptr DMatrix++newtype Booster = Booster (Ptr ())+ deriving (Storable, Foreign.Storable.Storable)++newtype DataIter = DataIter (Ptr ())+ deriving (Storable, Foreign.Storable.Storable)++newtype DataHolder = DataHolder (Ptr ())+ deriving (Storable, Foreign.Storable.Storable)++newtype XGBoostBatchCSR = XGBoostBatchCSR (Ptr ())+ deriving (Storable, Foreign.Storable.Storable)++type XGBCallbackSetData = Ptr ()+-- TODO+-- type XGBCallbackSetData =+-- FunPtr (DataHolder+-- -> XGBoostBatchCSR+-- -> IO Int)++type XGBCallbackDataIterNext = Ptr ()+-- TODO+-- type XGBCallbackDataIterNext =+-- FunPtr (DataIter+-- -> XGBCallbackSetData+-- -> DataHolderHandle+-- -> IO Int)++{-- Foreign Imports ----------------------------------------------------------}++foreign import ccall unsafe "XGBGetLastError" c_xgbGetLastError+ :: IO StringPtr++foreign import ccall unsafe "XGDMatrixCreateFromFile" c_xgDMatrixCreateFromFile+ :: StringPtr+ -> Int32+ -> Ptr DMatrix+ -> IO Int32++foreign import ccall unsafe "XGDMatrixCreateFromDataIter" c_xgDMatrixCreateFromDataIter+ :: DataIter+ -> XGBCallbackDataIterNext+ -> StringPtr+ -> Ptr DMatrix+ -> IO Int32++foreign import ccall unsafe "XGDMatrixCreateFromMat" c_xgDMatrixCreateFromMat+ :: FloatArray+ -> Word64+ -> Word64+ -> CFloat+ -> Ptr DMatrix+ -> IO Int32++foreign import ccall unsafe "XGDMatrixFree" c_xgDMatrixFree+ :: DMatrix+ -> IO Int32++foreign import ccall unsafe "XGDMatrixSaveBinary" c_xgDMatrixSaveBinary+ :: DMatrix+ -> StringPtr+ -> Int32+ -> IO Int32++foreign import ccall unsafe "XGDMatrixSetFloatInfo" c_xgDMatrixSetFloatInfo+ :: DMatrix+ -> StringPtr+ -> FloatArray+ -> Word64+ -> IO Int32++foreign import ccall unsafe "XGDMatrixSetUIntInfo" c_xgDMatrixSetUIntInfo+ :: DMatrix+ -> StringPtr+ -> UIntArray+ -> Word64+ -> IO Int32++foreign import ccall unsafe "XGDMatrixGetFloatInfo" c_xgDMatrixGetFloatInfo+ :: DMatrix+ -> StringPtr+ -> Ptr Word64+ -> Ptr FloatArray+ -> IO Int32++foreign import ccall unsafe "XGDMatrixGetUIntInfo" c_xgDMatrixGetUIntInfo+ :: DMatrix+ -> StringPtr+ -> Ptr Word64+ -> Ptr UIntArray+ -> IO Int32++foreign import ccall unsafe "XGDMatrixNumRow" c_xgDMatrixNumRow+ :: DMatrix+ -> Ptr Word64+ -> IO Int32++foreign import ccall unsafe "XGDMatrixNumCol" c_xgDMatrixNumCol+ :: DMatrix+ -> Ptr Word64+ -> IO Int32++foreign import ccall unsafe "XGBoosterCreate" c_xgBoosterCreate+ :: DMatrixArray+ -> Word64+ -> Ptr Booster+ -> IO Int32++foreign import ccall unsafe "XGBoosterFree" c_xgBoosterFree+ :: Booster+ -> IO Int32++foreign import ccall unsafe "XGBoosterSetParam" c_xgBoosterSetParam+ :: Booster+ -> StringPtr+ -> StringPtr+ -> IO Int32++foreign import ccall unsafe "XGBoosterUpdateOneIter" c_xgBoosterUpdateOneIter+ :: Booster+ -> Int32+ -> DMatrix+ -> IO Int32++foreign import ccall unsafe "XGBoosterBoostOneIter" c_xgBoosterBoostOneIter+ :: Booster+ -> DMatrix+ -> FloatArray+ -> FloatArray+ -> Word64+ -> IO Int32++foreign import ccall unsafe "XGBoosterEvalOneIter" c_xgBoosterEvalOneIter+ :: Booster+ -> Int32+ -> DMatrixArray+ -> StringArray+ -> Word64+ -> Ptr StringPtr+ -> IO Int32++foreign import ccall unsafe "XGBoosterPredict" c_xgBoosterPredict+ :: Booster+ -> DMatrix+ -> Int32+ -> Int32+ -> Ptr Word64+ -> Ptr FloatArray+ -> IO Int32++foreign import ccall unsafe "XGBoosterLoadModel" c_xgBoosterLoadModel+ :: Booster+ -> StringPtr+ -> IO Int32++foreign import ccall unsafe "XGBoosterSaveModel" c_xgBoosterSaveModel+ :: Booster+ -> StringPtr+ -> IO Int32++foreign import ccall unsafe "XGBoosterLoadModelFromBuffer" c_xgBoosterLoadModelFromBuffer+ :: Booster+ -> ByteArray+ -> Word64+ -> IO Int32++foreign import ccall unsafe "XGBoosterGetModelRaw" c_xgBoosterGetModelRaw+ :: Booster+ -> Ptr Word64+ -> Ptr ByteArray+ -> IO Int32++foreign import ccall unsafe "XGBoosterDumpModel" c_xgBoosterDumpModel+ :: Booster+ -> StringArray+ -> Int32+ -> Ptr Word64+ -> Ptr StringArray+ -> IO Int32++foreign import ccall unsafe "XGBoosterGetAttr" c_xgBoosterGetAttr+ :: Booster+ -> StringPtr+ -> Ptr StringPtr -- TODO+ -> Ptr Int32+ -> IO Int32++foreign import ccall unsafe "XGBoosterSetAttr" c_xgBoosterSetAttr+ :: Booster+ -> StringPtr+ -> StringPtr+ -> IO Int32++foreign import ccall unsafe "XGBoosterGetAttrNames" c_xgBoosterGetAttrNames+ :: Booster+ -> Ptr Word64+ -> Ptr StringArray+ -> IO Int32++foreign import ccall unsafe "XGBoosterLoadRabitCheckpoint" c_xgBoosterLoadRabitCheckpoint+ :: Booster+ -> Ptr Int32+ -> IO Int32++foreign import ccall unsafe "XGBoosterSaveRabitCheckpoint" c_xgBoosterSaveRabitCheckpoint+ :: Booster+ -> IO Int32++{-- Tag Types ----------------------------------------------------------------}++-- | In XGBoost, the float info is correctly restricted to DMatrix's meta information, namely label and weight.+--+-- Ref: /https://github.com/dmlc/xgboost/issues/1026#issuecomment-199873890/.+data FloatInfoField = LabelInfo | WeightInfo | BaseMarginInfo deriving Eq++instance Prelude.Show FloatInfoField where+ show LabelInfo = "label"+ show WeightInfo = "weight"+ show BaseMarginInfo = "base_margin"++-- | In XGBoost, the only uint field valid is "root_index".+--+-- Ref: /https://github.com/dmlc/xgboost/issues/1787#issuecomment-261653748/.+data UIntInfoField = RootIndexInfo deriving Eq++instance Prelude.Show UIntInfoField where+ show RootIndexInfo = "root_index"++-- | See https://github.com/dmlc/xgboost/blob/master/include/xgboost/c_api.h#L399+data PredictMask = Normal | Margin | LeafIndex | FeatureContrib++instance Enum PredictMask where+ toEnum 0 = Normal+ toEnum 1 = Margin+ toEnum 2 = LeafIndex+ toEnum 4 = FeatureContrib+ toEnum _ = error "No such PredictMask"+ fromEnum Normal = 0+ fromEnum Margin = 1+ fromEnum LeafIndex = 2+ fromEnum FeatureContrib = 4++{-- Error Handling -----------------------------------------------------------}++guard_ffi :: IO Int32 -> IO ()+guard_ffi action = action >>= \r ->+ if r == 0+ then return ()+ else xgbGetLastError >>= throw . XGBError r++xgbGetLastError :: IO String+xgbGetLastError = c_xgbGetLastError >>= getString++{-- DMatrix FFI Bindings -----------------------------------------------------}++xgbFromFile+ :: String -- ^ file name+ -> Bool -- ^ print messages during loading+ -> IO DMatrix+xgbFromFile filename slient = alloca $ \pm ->+ withString filename $ \ps -> do+ guard_ffi $ c_xgDMatrixCreateFromFile ps (boolToInt32 slient) pm+ peek pm++xgbFromDataIter+ :: DataIter+ -> XGBCallbackDataIterNext+ -> String+ -> IO DMatrix+xgbFromDataIter iter callback cacheinfo = alloca $ \pm ->+ withString cacheinfo $ \pc -> do+ guard_ffi $ c_xgDMatrixCreateFromDataIter iter callback pc pm+ peek pm++xgbFromMat+ :: UArray Float -- ^ mat+ -> Int -- ^ rows+ -> Int -- ^ columns+ -> Float -- ^ missing value+ -> IO DMatrix+xgbFromMat arr r c missing = alloca $ \pm ->+ withPtr arr $ \parr -> do+ guard_ffi $ c_xgDMatrixCreateFromMat parr (fromIntegral r) (fromIntegral c) (CFloat missing) pm+ peek pm++dmatrixFree :: DMatrix -> IO ()+dmatrixFree = guard_ffi . c_xgDMatrixFree++xgbSetFloatInfo+ :: DMatrix+ -> FloatInfoField -- ^ label field+ -> UArray Float -- ^ info vector+ -> IO ()+xgbSetFloatInfo dm field value = do+ let (CountOf len) = length value+ withString (show field) $ \ps ->+ withPtr value $ \pv ->+ guard_ffi $ c_xgDMatrixSetFloatInfo dm ps pv (fromIntegral len)++xgbGetFloatInfo+ :: DMatrix+ -> FloatInfoField -- ^ label field+ -> IO (UArray Float) -- ^ info vector+xgbGetFloatInfo dm field =+ alloca $ \plen ->+ alloca $ \parr ->+ withString (show field) $ \ps -> do+ guard_ffi $ c_xgDMatrixGetFloatInfo dm ps plen parr+ len <- peek plen+ arr <- peek parr+ peekArray (CountOf (fromIntegral len)) arr++xgbGetLabel :: DMatrix -> IO (UArray Float)+xgbGetLabel mat = xgbGetFloatInfo mat LabelInfo++xgbGetWeight :: DMatrix -> IO (UArray Float)+xgbGetWeight mat = xgbGetFloatInfo mat WeightInfo++xgbGetBaseMargin :: DMatrix -> IO (UArray Float)+xgbGetBaseMargin mat = xgbGetFloatInfo mat BaseMarginInfo++xgbSetLabel :: DMatrix -> UArray Float -> IO ()+xgbSetLabel mat = xgbSetFloatInfo mat LabelInfo++xgbSetWeight :: DMatrix -> UArray Float -> IO ()+xgbSetWeight mat = xgbSetFloatInfo mat WeightInfo++xgbSetBaseMargin :: DMatrix -> UArray Float -> IO ()+xgbSetBaseMargin mat = xgbSetFloatInfo mat BaseMarginInfo++xgbSetUIntInfo+ :: DMatrix+ -> UIntInfoField -- ^ label field+ -> UArray Word32 -- ^ info vector+ -> IO ()+xgbSetUIntInfo dm field value = do+ let (CountOf len) = length value+ withString (show field) $ \ps ->+ withPtr value $ \pv ->+ guard_ffi $ c_xgDMatrixSetUIntInfo dm ps pv (fromIntegral len)++xgbGetUIntInfo+ :: DMatrix+ -> UIntInfoField -- ^ label field+ -> IO (UArray Word32) -- ^ info vector+xgbGetUIntInfo dm field =+ alloca $ \plen ->+ alloca $ \parr ->+ withString (show field) $ \ps -> do+ guard_ffi $ c_xgDMatrixGetUIntInfo dm ps plen parr+ len <- peek plen+ arr <- peek parr+ peekArray (CountOf (fromIntegral len)) arr++xgbMatRow :: DMatrix -> IO Integer+xgbMatRow dm = alloca $ \pnum -> do+ guard_ffi $ c_xgDMatrixNumRow dm pnum+ fromIntegral <$> peek pnum++xgbMatCol :: DMatrix -> IO Integer+xgbMatCol dm = alloca $ \pnum -> do+ guard_ffi $ c_xgDMatrixNumCol dm pnum+ fromIntegral <$> peek pnum++{-- Booster FFI Bindings -----------------------------------------------------}++xgbBooster+ :: [DMatrix]+ -> IO Booster+xgbBooster dms = alloca $ \pb -> do+ let dms' = fromList dms+ (CountOf len) = length dms'+ withPtr dms' $ \pdm -> do+ guard_ffi $ c_xgBoosterCreate pdm (fromIntegral len) pb+ peek pb++boosterFree :: Booster -> IO ()+boosterFree = guard_ffi . c_xgBoosterFree++setParam+ :: Booster+ -> String -- ^ Name of parameter.+ -> String -- ^ Value of parameter.+ -> IO ()+setParam booster name value =+ withString name $ \pname ->+ withString value $ \pvalue ->+ guard_ffi $ c_xgBoosterSetParam booster pname pvalue++updateOneIter+ :: Booster+ -> Int32 -- ^ Current iteration rounds+ -> DMatrix -- ^ Training data+ -> IO ()+updateOneIter booster iter dtrain = guard_ffi $ c_xgBoosterUpdateOneIter booster iter dtrain++boostOneIter+ :: Booster+ -> DMatrix -- ^ Training data+ -> UArray Float -- ^ Gradient statistics+ -> UArray Float -- ^ Second order gradient statistics, should have the same length with gradient statistics array (but not checked)+ -> IO ()+boostOneIter booster dtrain grad hess = do+ let (CountOf nlen) = length grad+ withPtr grad $ \pgrad ->+ withPtr hess $ \phess ->+ guard_ffi $ c_xgBoosterBoostOneIter booster dtrain pgrad phess (fromIntegral nlen)++evalOneIter+ :: Booster+ -> Int32 -- ^ Current iteration rounds+ -> [DMatrix] -- ^ Pointers to data to be evaluated+ -> [String] -- ^ Names of each data, should have the same length with data array (but not checked)+ -> IO String -- ^ The string containing evaluation statistics+evalOneIter booster iter dms names = do+ let dms' = fromList dms+ (CountOf nlen) = length dms'+ alloca $ \pstat ->+ withPtr dms' $ \pdms ->+ withStringArray names $ \pnames -> do+ guard_ffi $ c_xgBoosterEvalOneIter booster iter pdms pnames (fromIntegral nlen) pstat+ peek pstat >>= getString++boosterPredict+ :: Booster+ -> DMatrix+ -> [PredictMask]+ -> Int32+ -> IO (UArray Float)+boosterPredict booster dmat masks ntree = do+ let mask = fromIntegral $ foldl' (.|.) (fromEnum Normal) (fromEnum <$> masks)+ alloca $ \plen ->+ alloca $ \parr -> do+ guard_ffi $ c_xgBoosterPredict booster dmat mask ntree plen parr+ len <- peek plen+ arr <- peek parr+ peekArray (CountOf (fromIntegral len)) arr++loadModel+ :: Booster+ -> String -- ^ File name+ -> IO ()+loadModel booster fname =+ withString fname $ \pfname ->+ guard_ffi $ c_xgBoosterLoadModel booster pfname++saveModel+ :: Booster+ -> String -- ^ File name+ -> IO ()+saveModel booster fname =+ withString fname $ \pfname ->+ guard_ffi $ c_xgBoosterSaveModel booster pfname++loadModelFromBuffer+ :: Booster+ -> ByteArray -- ^ Pointer to buffer+ -> Int32+ -> IO ()+loadModelFromBuffer booster buffer nlen = guard_ffi $ c_xgBoosterLoadModelFromBuffer booster buffer (fromIntegral nlen)++getBoosterAttr :: Booster -> String -> IO String+getBoosterAttr booster name =+ alloca $ \pout ->+ alloca $ \psucc ->+ withString name $ \pname -> do+ guard_ffi $ c_xgBoosterGetAttr booster pname pout psucc+ succ' <- peek psucc+ if int32ToBool succ'+ then peek pout >>= getString+ else return ""++setBoosterAttr :: Booster -> String -> String -> IO ()+setBoosterAttr booster name value =+ withString name $ \pname ->+ withString value $ \pvalue ->+ guard_ffi $ c_xgBoosterSetAttr booster pname pvalue++getAttrNames :: Booster -> IO [String]+getAttrNames booster =+ alloca $ \plen ->+ alloca $ \pout -> do+ guard_ffi $ c_xgBoosterGetAttrNames booster plen pout+ nlen <- peek plen+ peek pout >>= getStringArray' (CountOf (fromIntegral nlen))++loadRabitCheckpoint :: Booster -> IO Int32 -- ^ Return output version of the model+loadRabitCheckpoint booster =+ alloca $ \pversion -> do+ guard_ffi $ c_xgBoosterLoadRabitCheckpoint booster pversion+ peek pversion++saveRabitCheckpoint :: Booster -> IO ()+saveRabitCheckpoint booster = guard_ffi $ c_xgBoosterSaveRabitCheckpoint booster
+ src/ML/DMLC/XGBoost/Foreign.hs view
@@ -0,0 +1,96 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UnboxedTuples #-}++module ML.DMLC.XGBoost.Foreign where++import Foundation+import Foundation.Array.Internal+import Foundation.Class.Storable+import Foundation.Collection+import Foundation.Primitive hiding (toBytes)+import Foundation.String++import Foreign.Ptr (nullPtr)+import GHC.Exts++{-- Orphan instance to make `Ptr a` as foundation's PrimType --}++instance PrimType (Ptr a) where+ primSizeInBytes _ = size (Proxy :: Proxy (Ptr a))+ {-# INLINE primSizeInBytes #-}++ primShiftToBytes _ = let (CountOf k) = size (Proxy :: Proxy (Ptr a)) in if k == 4 then 3 else 5 -- TODO may be wrong+ {-# INLINE primShiftToBytes #-}++ primBaUIndex ba (Offset (I# n)) = Ptr (indexAddrArray# ba n)+ {-# INLINE primBaUIndex #-}++ primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r1 #) = readAddrArray# mba n s1+ in (# s2, Ptr r1 #)+ {-# INLINE primMbaURead #-}++ primMbaUWrite mba (Offset (I# n)) (Ptr w) = primitive $ \s1 -> (# writeAddrArray# mba n w s1, () #)+ {-# INLINE primMbaUWrite #-}++ primAddrIndex addr (Offset (I# n)) = Ptr (indexAddrOffAddr# addr n)+ {-# INLINE primAddrIndex #-}++ primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r1 #) = readAddrOffAddr# addr n s1+ in (# s2, Ptr r1 #)+ {-# INLINE primAddrRead #-}++ primAddrWrite addr (Offset (I# n)) (Ptr w) = primitive $ \s1 -> (# writeAddrOffAddr# addr n w s1, () #)+ {-# INLINE primAddrWrite #-}++{-- Types --------------------------------------------------------------------}++type StringPtr = Ptr Word8+type StringArray = Ptr StringPtr+type FloatArray = Ptr Float+type UIntArray = Ptr Word32+type ByteArray = Ptr Word8++{-- Utilities ----------------------------------------------------------------}++boolToInt32 :: Bool -> Int32+boolToInt32 b = if b then 1 else 0++int32ToBool :: Int32 -> Bool+int32ToBool i = if i == 0 then False else True++getString :: StringPtr -> IO String+getString ptr+ | ptr == nullPtr = return ""+ | otherwise = fromBytesUnsafe <$> peekArrayEndedBy 0 ptr++getString' :: CountOf Word8 -> StringPtr -> IO String+getString' nlen ptr+ | ptr == nullPtr = return ""+ | otherwise = fromBytesUnsafe <$> peekArray nlen ptr++withString :: String -> (StringPtr -> IO a) -> IO a+withString s = withPtr (toBytes UTF8 (s <> "\0"))++getStringArray :: StringArray -> IO [String]+getStringArray ptr+ | ptr == nullPtr = return []+ | otherwise = do ptrs <- peekArrayEndedBy nullPtr ptr :: IO (Array StringPtr)+ mapM getString . toList $ ptrs++getStringArray' :: CountOf StringPtr -> StringArray -> IO [String]+getStringArray' nlen ptr+ | ptr == nullPtr = return []+ | otherwise = do ptrs <- peekArray nlen ptr :: IO (Array StringPtr)+ mapM getString . toList $ ptrs++withStringArray :: [String] -> (StringArray -> IO a) -> IO a+withStringArray [] f = f nullPtr+withStringArray ss f = do+ ptrs <- mapM (\s -> withString s return) ss+ withPtr (fromList ptrs) f
+ src/ML/DMLC/XGBoost/Rabit/FFI.hs view
@@ -0,0 +1,174 @@+module ML.DMLC.XGBoost.Rabit.FFI where++import Foundation+import Foundation.Array.Internal+import Foundation.Class.Storable+import Foundation.Collection+import Foundation.Foreign++import Foreign.Ptr (nullPtr)+import Foreign.Marshal.Alloc (alloca)+import qualified Foreign.Storable (peek)++import ML.DMLC.XGBoost.Foreign++foreign import ccall unsafe "RabitInit" c_rabitInit+ :: Int32+ -> StringArray+ -> IO ()++foreign import ccall unsafe "RabitFinalize" c_rabitFinalize+ :: IO ()++foreign import ccall unsafe "RabitGetRank" c_rabitGetRank+ :: IO Int32++foreign import ccall unsafe "RabitGetWorldSize" c_rabitGetWorldSize+ :: IO Int32++foreign import ccall unsafe "RabitIsDistributed" c_rabitIsDistributed+ :: IO Int32++foreign import ccall unsafe "RabitTrackerPrint" c_rabitTrackerPrint+ :: StringPtr+ -> IO ()++foreign import ccall unsafe "RabitGetProcessorName" c_rabitGetProcessorName+ :: StringPtr+ -> Ptr CULong+ -> CULong+ -> IO ()++foreign import ccall unsafe "RabitBroadcast" c_rabitBroadcast+ :: Ptr a+ -> CULong+ -> Int32+ -> IO ()++foreign import ccall unsafe "RabitAllreduce" c_rabitAllreduce+ :: Ptr a+ -> CSize+ -> Int32+ -> Int32+ -> Ptr ()+ -> Ptr ()+ -> IO ()++foreign import ccall unsafe "RabitLoadCheckPoint" c_rabitLoadCheckPoint+ :: Ptr StringPtr+ -> Ptr CULong+ -> Ptr StringPtr+ -> Ptr CULong+ -> IO Int32++foreign import ccall unsafe "RabitCheckPoint" c_rabitCheckPoint+ :: StringPtr+ -> CULong+ -> StringPtr+ -> CULong+ -> IO ()++foreign import ccall unsafe "RabitVersionNumber" c_rabitVersionNumber+ :: IO Int32++foreign import ccall unsafe "RabitLinkTag" c_rabitLinkTag+ :: IO Int32++rabitInit :: [String] -> IO ()+rabitInit args = do+ let (CountOf nlen) = length args+ argv = fromIntegral nlen+ withStringArray args $ \pargs ->+ c_rabitInit argv pargs++rabitFinalize :: IO ()+rabitFinalize = c_rabitFinalize++rabitGetRank :: IO Int32+rabitGetRank = c_rabitGetRank++rabitGetWordSize :: IO Int32+rabitGetWordSize = c_rabitGetWorldSize++rabitIsDistributed :: IO Bool+rabitIsDistributed = int32ToBool <$> c_rabitIsDistributed++rabitTrackerPrint :: String -> IO ()+rabitTrackerPrint msg = withString msg $ \pmsg -> c_rabitTrackerPrint pmsg++rabitGetProcessorName :: IO String+rabitGetProcessorName = do+ let nlimit = 64+ buf <- mutNew (CountOf nlimit)+ alloca $ \plen ->+ withMutablePtr buf $ \pbuf -> do+ c_rabitGetProcessorName pbuf plen (fromIntegral nlimit)+ nlen <- Foreign.Storable.peek plen+ getString' (CountOf (fromIntegral nlen)) pbuf++rabitBoradcast+ :: Ptr a -- ^ the pointer to send or recive buffer.+ -> Int32 -- ^ the size of data+ -> Int32 -- ^ the root of process+ -> IO ()+rabitBoradcast pdata nlen root = c_rabitBroadcast pdata (fromIntegral nlen) root++-- | Ref: https://github.com/dmlc/rabit/blob/master/include/rabit/internal/engine.h#L172+data AllreduceOpType = KMax | KMin | KSum | KBitwiseOR deriving Eq++instance Enum AllreduceOpType where+ toEnum 0 = KMax+ toEnum 1 = KMin+ toEnum 2 = KSum+ toEnum 3 = KBitwiseOR+ toEnum _ = error "No such AllreduceOpType"+ fromEnum KMax = 0+ fromEnum KMin = 2+ fromEnum KSum = 3+ fromEnum KBitwiseOR = 4++-- | Ref: https://github.com/dmlc/rabit/blob/master/include/rabit/internal/engine.h#L179+data AllreduceDataType = KChar | KUChar | KInt | KUInt | KLong | KULong | KFloat | KDouble | KLongLong | KULongLong deriving Eq++instance Enum AllreduceDataType where+ toEnum 0 = KChar+ toEnum 1 = KUChar+ toEnum 2 = KInt+ toEnum 3 = KUInt+ toEnum 4 = KLong+ toEnum 5 = KULong+ toEnum 6 = KFloat+ toEnum 7 = KDouble+ toEnum 8 = KLongLong+ toEnum 9 = KULongLong+ toEnum _ = error "No such AllreduceDataType"+ fromEnum KChar = 0+ fromEnum KUChar = 1+ fromEnum KInt = 2+ fromEnum KUInt = 3+ fromEnum KLong = 4+ fromEnum KULong = 5+ fromEnum KFloat = 6+ fromEnum KDouble = 7+ fromEnum KLongLong = 8+ fromEnum KULongLong = 9++rabitAllreduce+ :: Ptr a -- ^ buffer for both sending and recving data+ -> Int32 -- ^ number of elements to be reduced+ -> AllreduceDataType+ -> AllreduceOpType+ -> IO ()+rabitAllreduce pdata count dtype optype =+ c_rabitAllreduce pdata+ (fromIntegral count)+ (fromIntegral . fromEnum $ dtype)+ (fromIntegral . fromEnum $ optype)+ nullPtr+ nullPtr++rabitVersionNumber :: IO Int32+rabitVersionNumber = c_rabitVersionNumber++rabitLinkTag :: IO Int32+rabitLinkTag = c_rabitLinkTag
+ xgboost-haskell.cabal view
@@ -0,0 +1,54 @@+name: xgboost-haskell+version: 0.1.0.0+synopsis: XGBoost library for Haskell.+description: XGBoost library for Haskell via FFI binding, on top of foundation.+homepage: https://github.com/sighingnow/xgboost-haskell#readme+author: Tao He+maintainer: sighingnow@gmail.com+license: MIT+license-file: LICENSE+copyright: Copyright: (c) 2017 Tao He+category: Development+build-type: Simple+cabal-version: >=1.10+extra-source-files: README.md++Library+ hs-source-dirs: src+ exposed-modules:+ ML.DMLC.XGBoost+ ML.DMLC.XGBoost.Exception+ ML.DMLC.XGBoost.FFI+ ML.DMLC.XGBoost.Rabit.FFI+ other-modules:+ ML.DMLC.XGBoost.Foreign+ default-language: Haskell2010+ default-extensions: NoImplicitPrelude+ , OverloadedStrings+ build-depends: base >= 4.7 && < 5+ , foundation++executable xgboost-app+ hs-source-dirs: app+ main-is: Main.hs+ default-language: Haskell2010+ default-extensions: NoImplicitPrelude+ , OverloadedStrings+ build-depends: base >= 4.7 && < 5+ , foundation+ , xgboost-haskell+ buildable: False+ extra-libraries: xgboost+ extra-lib-dirs: ./++executable xgb-agaricus+ hs-source-dirs: examples+ main-is: agaricus.hs+ default-language: Haskell2010+ default-extensions: NoImplicitPrelude+ , OverloadedStrings+ build-depends: base >= 4.7 && < 5+ , foundation+ , xgboost-haskell+ extra-libraries: xgboost+ extra-lib-dirs: ./