gsl 1.12.108

data/ext/ndlinear.c

@@ -0,0 +1,321 @@
+#include "rb_gsl.h"
+
+#ifdef HAVE_NDLINEAR_GSL_MULTIFIT_NDLINEAR_H
+#include <gsl/gsl_math.h>
+#include <gsl/gsl_matrix.h>
+#include <gsl/gsl_vector.h>
+#include <gsl/gsl_multifit.h>
+#include <ndlinear/gsl_multifit_ndlinear.h>
+
+static VALUE cWorkspace;
+
+enum Index_Ndlinear {
+  INDEX_NDIM = 0,
+  INDEX_N = 1,
+  INDEX_PROCS = 2,
+  INDEX_PARAMS = 3,
+  INDEX_FUNCS = 4,
+  INDEX_NDIM_I = 5,  
+  
+  NDLINEAR_ARY_SIZE = 6,
+};
+
+static void multifit_ndlinear_mark(gsl_multifit_ndlinear_workspace *w)
+{
+  rb_gc_mark((VALUE) w->params); 
+}
+
+typedef int (*UFUNC)(double, double[], void*);
+typedef struct ufunc_struct
+{
+  UFUNC *fptr;
+} ufunc_struct;
+
+static VALUE cUFunc;
+static ufunc_struct* ufunc_struct_alloc(size_t n_dim) {
+  ufunc_struct *p;
+  p = (ufunc_struct*) malloc(sizeof(ufunc_struct));
+  p->fptr = malloc(sizeof(UFUNC)*n_dim);  
+  return p;
+}
+static void ufunc_struct_free(ufunc_struct *p)
+{
+  free(p->fptr);
+  free(p);
+}
+
+static int func_u(double x, double y[], void *data);
+static VALUE rb_gsl_multifit_ndlinear_alloc(int argc, VALUE *argv, VALUE klass)
+{
+  gsl_multifit_ndlinear_workspace *w;
+  int istart = 0;
+  size_t n_dim = 0, *N, i;
+  struct ufunc_struct *p;
+  VALUE params, wspace, pp;
+  switch (argc) {
+  case 4:
+    istart = 1;
+    CHECK_FIXNUM(argv[0]);
+    n_dim = FIX2INT(argv[0]);
+    /* no break */
+  case 3:  
+    if (TYPE(argv[istart]) != T_ARRAY) {
+      rb_raise(rb_eTypeError, "Wrong argument type %s (Array expected)",
+        rb_class2name(CLASS_OF(argv[istart])));
+    }
+    if (TYPE(argv[istart+1]) != T_ARRAY) {
+      rb_raise(rb_eTypeError, "Wrong argument type %s (Array expected)",
+        rb_class2name(CLASS_OF(argv[istart+1])));
+    }
+    //    n_dim = RARRAY(argv[istart])->len;
+    n_dim = RARRAY_LEN(argv[istart]);
+    N = (size_t*) malloc(sizeof(size_t)*n_dim);
+    break;
+  default:
+    rb_raise(rb_eArgError, "Wrong number of arguments (%d for 3 or 4)", argc);
+  }
+  for (i = 0; i < n_dim; i++) {
+    N[i] = FIX2INT(rb_ary_entry(argv[istart], i));
+  }
+
+  params = rb_ary_new2(NDLINEAR_ARY_SIZE);
+  rb_ary_store(params, INDEX_NDIM, INT2FIX((int) n_dim));
+  rb_ary_store(params, INDEX_N, argv[istart]);   /* N */
+  rb_ary_store(params, INDEX_PROCS, argv[istart+1]); /* procs */
+  rb_ary_store(params, INDEX_PARAMS, argv[istart+2]); /* params */  
+  rb_ary_store(params, INDEX_NDIM_I, INT2FIX(0)); /* for the first parameter */    
+  
+  p = ufunc_struct_alloc(n_dim);
+  for (i = 0; i < n_dim; i++) p->fptr[i] = func_u;
+  pp = Data_Wrap_Struct(cUFunc, 0, ufunc_struct_free, p);  
+  rb_ary_store(params, INDEX_FUNCS, pp);  
+
+  w = gsl_multifit_ndlinear_alloc(n_dim, N, p->fptr, (void*) params);
+    
+  free((size_t*) N);
+
+  wspace = Data_Wrap_Struct(cWorkspace, multifit_ndlinear_mark, gsl_multifit_ndlinear_free, w);
+
+  return wspace;
+}
+
+static int func_u(double x, double y[], void *data)
+{
+  VALUE ary, vN, procs, proc, vy, params;
+  gsl_vector_view ytmp;
+  size_t i, n_dim;
+  int rslt;
+  ary = (VALUE) data;
+  n_dim = FIX2INT(rb_ary_entry(ary, INDEX_NDIM));
+  vN = rb_ary_entry(ary, INDEX_N);
+  procs = rb_ary_entry(ary, INDEX_PROCS);
+  params = rb_ary_entry(ary, INDEX_PARAMS);
+  i = FIX2INT(rb_ary_entry(ary, INDEX_NDIM_I));
+  proc = rb_ary_entry(procs, i);
+  
+  ytmp.vector.data = (double*) y;
+  ytmp.vector.stride = 1;
+  ytmp.vector.size = FIX2INT(rb_ary_entry(vN, i));
+  vy = Data_Wrap_Struct(cgsl_vector_view, 0, NULL, &ytmp);
+
+  rslt = rb_funcall((VALUE) proc, RBGSL_ID_call, 3, rb_float_new(x), vy, params);
+
+  /* for the next parameter */
+  i += 1;
+  if (i == n_dim) i = 0;
+  rb_ary_store(ary, INDEX_NDIM_I, INT2FIX(i));
+  
+  return GSL_SUCCESS;
+}
+
+static VALUE rb_gsl_multifit_ndlinear_design(int argc, VALUE *argv, VALUE obj)
+{
+  gsl_multifit_ndlinear_workspace *w;
+  gsl_matrix *vars = NULL, *X = NULL;
+  int argc2, flag = 0, ret;
+  switch (TYPE(obj)) {
+  case T_MODULE:
+  case T_CLASS:
+  case T_OBJECT:
+    if (!rb_obj_is_kind_of(argv[argc-1], cWorkspace)) {
+      rb_raise(rb_eTypeError, "Wrong argument type %s (GSL::MultiFit::Ndlinear::Workspace expected)",
+        rb_class2name(CLASS_OF(argv[argc-1])));
+    }
+    Data_Get_Struct(argv[argc-1], gsl_multifit_ndlinear_workspace, w);
+    argc2 = argc-1;
+    break;
+  default:
+    Data_Get_Struct(obj, gsl_multifit_ndlinear_workspace, w);
+    argc2 = argc;
+  }
+  switch (argc2) {
+  case 1:
+      CHECK_MATRIX(argv[0]);
+      Data_Get_Struct(argv[0], gsl_matrix, vars);
+      X = gsl_matrix_alloc(vars->size1, w->n_coeffs);
+      flag = 1;
+      break;
+  case 2:
+      CHECK_MATRIX(argv[0]);
+      CHECK_MATRIX(argv[1]);
+      Data_Get_Struct(argv[0], gsl_matrix, vars);
+      Data_Get_Struct(argv[1], gsl_matrix, X);            
+      break;
+  default:
+      rb_raise(rb_eArgError, "Wrong number of arguments.");
+  }
+  ret = gsl_multifit_ndlinear_design(vars, X, w);
+  
+  if (flag == 1) {
+    return Data_Wrap_Struct(cgsl_matrix, 0, gsl_matrix_free, X);
+  } else {
+    return INT2FIX(ret);
+  }
+}
+
+static VALUE rb_gsl_multifit_ndlinear_est(int argc, VALUE *argv, VALUE obj)
+{
+  gsl_multifit_ndlinear_workspace *w;
+  gsl_vector *x = NULL, *c = NULL;
+  gsl_matrix *cov = NULL;
+  double y, yerr;
+  int argc2;
+  switch (TYPE(obj)) {
+  case T_MODULE:
+  case T_CLASS:
+  case T_OBJECT:
+    if (!rb_obj_is_kind_of(argv[argc-1], cWorkspace)) {
+      rb_raise(rb_eTypeError, "Wrong argument type %s (GSL::MultiFit::Ndlinear::Workspace expected)",
+        rb_class2name(CLASS_OF(argv[argc-1])));
+    }
+    Data_Get_Struct(argv[argc-1], gsl_multifit_ndlinear_workspace, w);    
+    argc2 = argc-1;
+    break;
+  default:
+    Data_Get_Struct(obj, gsl_multifit_ndlinear_workspace, w);
+    argc2 = argc;  
+  }
+  switch (argc2) {
+  case 3:
+    CHECK_VECTOR(argv[0]);
+    CHECK_VECTOR(argv[1]);
+    CHECK_MATRIX(argv[2]);
+    Data_Get_Struct(argv[0], gsl_vector, x);
+    Data_Get_Struct(argv[1], gsl_vector, c);
+    Data_Get_Struct(argv[2], gsl_matrix, cov);   
+    break;
+  default:
+    rb_raise(rb_eArgError, "Wrong number of arguments.");  
+  }
+  gsl_multifit_ndlinear_est(x, c, cov, &y, &yerr, w);
+  return rb_ary_new3(2, rb_float_new(y), rb_float_new(yerr));
+}
+
+static VALUE rb_gsl_multifit_ndlinear_calc(int argc, VALUE *argv, VALUE obj)
+{
+  gsl_multifit_ndlinear_workspace *w;
+  gsl_vector *x = NULL, *c = NULL;
+  double val;
+  int argc2;
+  switch (TYPE(obj)) {
+  case T_MODULE:
+  case T_CLASS:
+  case T_OBJECT:
+    if (!rb_obj_is_kind_of(argv[argc-1], cWorkspace)) {
+      rb_raise(rb_eTypeError, 
+	       "Wrong argument type %s (GSL::MultiFit::Ndlinear::Workspace expected)",
+        rb_class2name(CLASS_OF(argv[argc-1])));
+    }
+    Data_Get_Struct(argv[argc-1], gsl_multifit_ndlinear_workspace, w);    
+    argc2 = argc-1;
+    break;
+  default:
+    Data_Get_Struct(obj, gsl_multifit_ndlinear_workspace, w);
+    argc2 = argc;  
+  }
+  switch (argc2) {
+  case 2:
+    CHECK_VECTOR(argv[0]);
+    CHECK_VECTOR(argv[1]);
+    Data_Get_Struct(argv[0], gsl_vector, x);
+    Data_Get_Struct(argv[1], gsl_vector, c);
+    break;
+  default:
+    rb_raise(rb_eArgError, "Wrong number of arguments.");  
+  }
+  val = gsl_multifit_ndlinear_calc(x, c, w);
+  return rb_float_new(val);
+}
+
+static VALUE rb_gsl_multifit_ndlinear_n_coeffs(VALUE obj)
+{
+  gsl_multifit_ndlinear_workspace *w;
+  Data_Get_Struct(obj, gsl_multifit_ndlinear_workspace, w);
+  return INT2FIX(w->n_coeffs);
+}
+
+static VALUE rb_gsl_multifit_ndlinear_n_dim(VALUE obj)
+{
+  gsl_multifit_ndlinear_workspace *w;
+  Data_Get_Struct(obj, gsl_multifit_ndlinear_workspace, w);
+  return INT2FIX(w->n_dim);
+}
+
+static VALUE rb_gsl_multifit_ndlinear_N(VALUE obj)
+{
+  gsl_multifit_ndlinear_workspace *w;
+  VALUE ary;
+  Data_Get_Struct(obj, gsl_multifit_ndlinear_workspace, w);
+  ary = (VALUE) w->params;
+  return rb_ary_entry(ary, INDEX_N);
+}
+/*
+static VALUE rb_gsl_multifit_linear_Rsq(VALUE module, VALUE vy, VALUE vchisq)
+{
+  gsl_vector *y;
+  double chisq, Rsq;
+  CHECK_VECTOR(vy);
+  Data_Get_Struct(vy, gsl_vector, y);
+  chisq = NUM2DBL(vchisq);
+  gsl_multifit_linear_Rsq(y, chisq, &Rsq);
+  return rb_float_new(Rsq);
+}
+*/
+void Init_ndlinear(VALUE module)
+{
+  VALUE mNdlinear;
+  mNdlinear = rb_define_module_under(module, "Ndlinear");
+  cUFunc = rb_define_class_under(mNdlinear, "UFunc", rb_cObject);
+  cWorkspace = rb_define_class_under(mNdlinear, "Workspace", cGSL_Object);
+  
+  rb_define_singleton_method(mNdlinear, "alloc", 
+                            rb_gsl_multifit_ndlinear_alloc, -1);
+  rb_define_singleton_method(cWorkspace, "alloc", 
+                            rb_gsl_multifit_ndlinear_alloc, -1);    
+                            
+  rb_define_singleton_method(mNdlinear, "design", 
+                            rb_gsl_multifit_ndlinear_design, -1);
+  rb_define_singleton_method(cWorkspace, "design", 
+                            rb_gsl_multifit_ndlinear_design, -1);
+  rb_define_method(cWorkspace, "design",rb_gsl_multifit_ndlinear_est, -1);
+  rb_define_singleton_method(mNdlinear, "est", 
+                            rb_gsl_multifit_ndlinear_est, -1);
+  rb_define_singleton_method(cWorkspace, "est", 
+                            rb_gsl_multifit_ndlinear_est, -1);
+  rb_define_method(cWorkspace, "est",rb_gsl_multifit_ndlinear_est, -1);  
+  
+  rb_define_singleton_method(mNdlinear, "calc", 
+                            rb_gsl_multifit_ndlinear_calc, -1);
+  rb_define_singleton_method(cWorkspace, "calc", 
+                            rb_gsl_multifit_ndlinear_calc, -1);
+  rb_define_method(cWorkspace, "calc",rb_gsl_multifit_ndlinear_calc, -1);  
+
+  rb_define_method(cWorkspace, "n_coeffs",rb_gsl_multifit_ndlinear_n_coeffs, 0);    
+  rb_define_method(cWorkspace, "n_dim",rb_gsl_multifit_ndlinear_n_dim, 0);      
+  rb_define_method(cWorkspace, "N",rb_gsl_multifit_ndlinear_N, 0);
+  
+  //  rb_define_module_function(module, "linear_Rsq", rb_gsl_multifit_linear_Rsq, 2);
+}
+
+#endif
+

data/ext/nmf.c

@@ -0,0 +1,167 @@
+/**
+ * NMF: Non-Negative Matrix Factorization
+ *
+ * Written by Roman Shterenzon
+ * (Slightly modified by Y.Tsunesada: just added "const" qualifiers etc.)
+ */
+
+#include <math.h>
+#include <time.h>
+#include <gsl/gsl_matrix.h>
+#include <gsl/gsl_blas.h> /* for multiplication */
+
+#define THRESH 0.000001
+#define MAXITER 1000
+
+#undef DEBUG
+
+#define mm(a, b) gsl_matrix_mult(a, b)
+gsl_matrix * gsl_matrix_mult(const gsl_matrix *a, const gsl_matrix *b)
+{
+  gsl_matrix *c;
+  c = gsl_matrix_alloc(a->size1, b->size2);
+
+  gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, a, b, 0.0, c);
+  return c;
+}
+
+// pretty print
+void pp(const gsl_matrix *m)
+{
+  int r, c;
+
+  for(r=0; r<m->size1; r++) {
+    for(c=0; c<m->size2; c++) {
+      printf(" %.2f", gsl_matrix_get(m, r, c));
+    }
+    printf("\n");
+  }
+}
+
+/* Returns a distance cost */
+double difcost(const gsl_matrix *a, const gsl_matrix *b)
+{
+  int i, j;
+  double dif=0, d;
+
+  for (i=0; i < a->size1; i++)
+  {
+    for (j=0; j < a->size2; j++)
+    {
+      d = gsl_matrix_get(a, i, j) - gsl_matrix_get(b, i, j);
+      dif += d*d;
+    }
+  }
+  return dif;
+}
+
+static void initmatrix(gsl_matrix *m, double min, double max)
+{
+  int i,j;
+  double val;
+
+  srand(time(NULL));
+
+  for(i=0; i < m->size1; i++)
+  {
+    for(j=0; j < m->size2; j++)
+    {
+      val = min + (int) (max * (rand() / (RAND_MAX + min)));
+      gsl_matrix_set(m, i, j, val);
+    }
+  }
+}
+
+static double update(gsl_matrix *v, gsl_matrix *w, gsl_matrix *h)
+{
+  double dist = 0;
+  gsl_matrix *wt=NULL, *ht=NULL, *wh=NULL;
+  gsl_matrix *w_h=NULL, *wt_w=NULL;
+  gsl_matrix *wt_v = NULL;
+  gsl_matrix *v_ht=NULL, *wt_w_h=NULL, *w_h_ht=NULL;
+
+  wt = gsl_matrix_alloc(w->size2, w->size1);
+  gsl_matrix_transpose_memcpy(wt, w);
+  ht = gsl_matrix_alloc(h->size2, h->size1);
+  gsl_matrix_transpose_memcpy(ht, h);
+
+  // wt * v
+  wt_v = mm(wt, v);
+
+  // wt * w * h
+  wt_w = mm(wt, w);
+  wt_w_h = mm(wt_w, h);
+  gsl_matrix_free(wt_w);
+
+  // h = h.mul_elements(wt * v).div_elements(wt * w * h)
+  gsl_matrix_mul_elements(h, wt_v);
+  gsl_matrix_div_elements(h, wt_w_h);
+  gsl_matrix_free(wt_v);
+  gsl_matrix_free(wt_w_h);
+
+  // v * ht
+  v_ht = mm(v, ht);
+
+  // w * h * ht
+  w_h = mm(w, h);
+  w_h_ht = mm(w_h, ht);
+  gsl_matrix_free(w_h);
+
+  // w = w.mul_elements(v * ht).div_elements(w * h * ht)
+  gsl_matrix_mul_elements(w, v_ht);
+  gsl_matrix_div_elements(w, w_h_ht);
+  gsl_matrix_free(v_ht);
+  gsl_matrix_free(w_h_ht);
+
+  gsl_matrix_free(wt);
+  gsl_matrix_free(ht);
+
+  wh = mm(w, h);
+  dist = difcost(v, wh);
+  gsl_matrix_free(wh);
+
+  // w and h were modified in place
+  return dist;
+}
+
+/* The main thing - compute the nmf */
+int gsl_matrix_nmf(gsl_matrix *v, int cols, gsl_matrix **w, gsl_matrix **h)
+{
+  double dist = 1;
+  int iter = 1;
+  double min, max;
+
+#ifdef DEBUG
+  printf("\nCols: %d\nv:\n", cols);
+  pp(v);
+#endif
+
+  gsl_matrix_minmax(v, &min, &max);
+
+#ifdef DEBUG
+  printf("Min: %f, Max: %f\n", min, max);
+#endif
+  *w = gsl_matrix_alloc(v->size1, cols);
+  initmatrix(*w, min, max/2); // the multiplicative rules tend to increase w
+
+  *h = gsl_matrix_alloc(cols, v->size2);
+  initmatrix(*h, min, max);
+
+  while(dist >= THRESH && iter < MAXITER)
+  {
+    dist = update(v, *w, *h);
+#ifdef DEBUG
+    printf("Iteration: %d, distance: %f\n", iter, dist);
+    printf("\nw:\n");
+    pp(*w);
+    printf("\nh:\n");
+    pp(*h);
+    printf("\n");
+#endif
+    iter++;
+  }
+#ifdef DEBUG
+  printf("Ended\n");
+#endif
+  return GSL_SUCCESS;
+}