diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +# xgboost-haskell + +XGBoost for Haskell, based on the [foundation](https://github.com/haskell-foundation/foundation) package. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/examples/agaricus.hs b/examples/agaricus.hs new file mode 100644 --- /dev/null +++ b/examples/agaricus.hs @@ -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 diff --git a/src/ML/DMLC/XGBoost.hs b/src/ML/DMLC/XGBoost.hs new file mode 100644 --- /dev/null +++ b/src/ML/DMLC/XGBoost.hs @@ -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 diff --git a/src/ML/DMLC/XGBoost/Exception.hs b/src/ML/DMLC/XGBoost/Exception.hs new file mode 100644 --- /dev/null +++ b/src/ML/DMLC/XGBoost/Exception.hs @@ -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) diff --git a/src/ML/DMLC/XGBoost/FFI.hs b/src/ML/DMLC/XGBoost/FFI.hs new file mode 100644 --- /dev/null +++ b/src/ML/DMLC/XGBoost/FFI.hs @@ -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 diff --git a/src/ML/DMLC/XGBoost/Foreign.hs b/src/ML/DMLC/XGBoost/Foreign.hs new file mode 100644 --- /dev/null +++ b/src/ML/DMLC/XGBoost/Foreign.hs @@ -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 diff --git a/src/ML/DMLC/XGBoost/Rabit/FFI.hs b/src/ML/DMLC/XGBoost/Rabit/FFI.hs new file mode 100644 --- /dev/null +++ b/src/ML/DMLC/XGBoost/Rabit/FFI.hs @@ -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 diff --git a/xgboost-haskell.cabal b/xgboost-haskell.cabal new file mode 100644 --- /dev/null +++ b/xgboost-haskell.cabal @@ -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: ./