/** One- or two-dimensional signal correlation, with arbitrary step and phase.
* @source RS\_sig\_conv.c
* @author Copyright (c), 1988, 2006 Insightful Corp. All rights reserved.
* @usage #.Call( "RS_signal_correlate", in.sig, kernel, row.step, col.step, row.overlap, col.overlap, boundary
* @return An RS ... containing ...
* @param in.sig Pointer to an RS object containing ... in.sig
* @param kernel Pointer to an RS object containing ... kernel
* @param row.step Pointer to an RS object containing ... row.step
* @param col.step Pointer to an RS object containing ... col.step
* @param row.overlap Pointer to an RS object containing ... row.overlap
* @param col.overlap Pointer to an RS object containing ... col.overlap
* @param boundary Pointer to an RS object containing ... boundary
* @see siguniv_convolve
* @see _mutil_boundary_type
* @see Matrix Data Types
* @see Interrupt Handling
*/
EXTERN_R SEXP RS_signal_correlate(
SEXP pr_series,
SEXP pr_kernel,
SEXP pr_boundary)
{
SEXP pr_ret_result;
mutil_boundary_type boundary;
mutil_data_type type;
mutil_errcode err;
univ_mat series;
univ_mat kernel;
univ_mat result;
void *VPNULL = NULL;
memlist list;
sint32 n_series;
sint32 n_kernel;
sint32 n_out;
/* Avoid lint warning */
(void) whatssi;
/* initialize memory list */
MEMLIST_INIT( list );
/* Conversion of input data ... */
/* ... pr_series to series */
READ_MATRIX_REGISTER( pr_series, &series );
/* ... pr_kernel to kernel */
READ_MATRIX_REGISTER( pr_kernel, &kernel );
/* ... pr_boundary to boundary */
err = mutil_boundary_type_from_R( pr_boundary, &boundary );
CHECK_CONVERSION( mutil_boundary_type, pr_boundary, &boundary );
/* initialize parameters */
n_series = MATUNIV_NELEM( &series );
n_kernel = MATUNIV_NELEM( &kernel );
n_out = n_series + n_kernel - 1;
/* force the input vectors to be single-rows */
series.mat.dblmat.ncol = n_series;
series.mat.dblmat.nrow = 1;
kernel.mat.dblmat.ncol = n_kernel;
kernel.mat.dblmat.nrow = 1;
/* allocate space for the result */
err = matuniv_malloc_register( &result, 1, n_out, MUTIL_DOUBLE, &list );
if ( err ){
MUTIL_FREE_WARN( memlist, &list );
PROBLEM "Problem allocating and registering memory" ERROR;
}
/* Call the function */
err = siguniv_convolve( &series, &kernel, 1, 1, 1, 1, boundary, VPNULL, &result );
if ( err ){
MUTIL_FREE_WARN( memlist, &list );
PROBLEM "Problem calling siguniv_convolve() function" ERROR;
}
/* create the output RS object */
err = matuniv_to_R( &result, (mutil_R_class_type) MUTIL_R_MATRIX, &pr_ret_result );
MUTIL_FREE_WARN( memlist, &list );
if ( err ) {
PROBLEM "Unable to convert output data to RS format" ERROR;
}
return pr_ret_result;
}
/** The gain functions for Daubechies wavelet and scaling filters.
* @source RS\_wav\_filt.c
* @author Copyright (c), 1988, 2006 Insightful Corp. All rights reserved.
* @usage #itCall( "RS_wavelets_filters_daubechies_gain", filter.type, filter.length, num.levels, num.fft, normalize))#
* @return An R ... containing ...
* @param filter.type Pointer to an R object containing ... filter.type
* @param filter.length Pointer to an R object containing ... filter.length
* @param num.levels Pointer to an R object containing ... num.levels
* @param num.fft Pointer to an R object containing ... num.fft
* @param normalize Pointer to an R object containing ... normalize
* @see _wav_filter_type
* @see wavuniv_filters_daubechies
* @see wavuniv_filters_zero_phase
*/
EXTERN_R SEXP RS_wavelets_filters_daubechies_gain(
SEXP pr_filter_type,
SEXP pr_filter_length,
SEXP pr_num_levels,
SEXP pr_num_fft,
SEXP pr_normalize )
{
SEXP pr_ret_gain_frequency;
SEXP pr_ret_gain_scaling;
SEXP pr_ret_gain_wavelet;
SEXP pr_ret_obj;
boolean normalize;
mutil_errcode err;
sint32 filter_length;
sint32 num_fft;
sint32 num_levels;
univ_mat gain_frequency;
univ_mat gain_scaling;
univ_mat gain_wavelet;
void *VPNULL = NULL;
wav_filter_type filter_type;
memlist list;
/* Avoid lint warning */
(void) whatssi;
/* initialize memory list */
MEMLIST_INIT( list );
/* Conversion of input data ... */
/* ... pr_filter_type to filter_type */
WAV_FILTER_TYPE_FROM_R( pr_filter_type, &filter_type );
/* ... pr_filter_length to filter_length */
SINT32_FROM_R( pr_filter_length, &filter_length );
/* ... pr_num_levels to num_levels */
SINT32_FROM_R( pr_num_levels, &num_levels );
/* ... pr_num_fft to num_fft */
SINT32_FROM_R( pr_num_fft, &num_fft );
/* ... pr_normalize to normalize */
BOOLEAN_FROM_R( pr_normalize, &normalize );
/* Call the function */
err = wavuniv_filters_daubechies_gain(
filter_type,
filter_length,
num_levels,
num_fft,
normalize,
VPNULL,
&gain_frequency,
&gain_wavelet,
&gain_scaling );
MEMLIST_FREE_ON_ERROR_SPLUS( err, &list, "Problem calling wavuniv_filters_daubechies_gain() function" );
err = memlist_member_register( &list, &gain_frequency, MEMTYPE_MATUNIV);
MEMLIST_FREE_ON_ERROR_REGISTER( err, &list );
err = memlist_member_register( &list, &gain_wavelet, MEMTYPE_MATUNIV);
MEMLIST_FREE_ON_ERROR_REGISTER( err, &list );
err = memlist_member_register( &list, &gain_scaling, MEMTYPE_MATUNIV);
MEMLIST_FREE_ON_ERROR_REGISTER( err, &list );
/* create the output R object */
err = matuniv_to_R( &gain_frequency, (mutil_R_class_type) MUTIL_R_MATRIX, &pr_ret_gain_frequency );
MEMLIST_FREE_ON_ERROR_SPLUS( err, &list, "Unable to convert output data to R format" );
err = matuniv_to_R( &gain_wavelet, (mutil_R_class_type) MUTIL_R_MATRIX, &pr_ret_gain_wavelet );
MEMLIST_FREE_ON_ERROR_SPLUS( err, &list, "Unable to convert output data to R format" );
err = matuniv_to_R( &gain_scaling, (mutil_R_class_type) MUTIL_R_MATRIX, &pr_ret_gain_scaling );
MEMLIST_FREE_ON_ERROR_SPLUS( err, &list, "Unable to convert output data to R format" );
PROTECT( pr_ret_obj = allocVector( VECSXP, 3 ) );
SET_VECTOR_ELT( pr_ret_obj, 0, pr_ret_gain_frequency );
SET_VECTOR_ELT( pr_ret_obj, 1, pr_ret_gain_wavelet );
SET_VECTOR_ELT( pr_ret_obj, 2, pr_ret_gain_scaling );
UNPROTECT(1);
/* free registered local memory */
MUTIL_FREE_WARN( memlist, &list );
return pr_ret_obj;
}
/** Creates frequency domain filters for the continuous wavelet transform.
* @source RS\_wav\_filt.c
* @author Copyright (c), 1988, 2006 Insightful Corp. All rights reserved.
* @usage #itCall( "RS_wavelets_filters_continuous", filter.type, filter.arg, frequency, transform.type, normalize))#
* @return An R ... containing ...
* @param filter.type Pointer to an R object containing ... filter.type
* @param filter.arg Pointer to an R object containing ... filter.arg
* @param frequency Pointer to an R object containing ... frequency
* @see _wav_filter_type
* @see wavuniv_transform_continuous_wavelet
*/
EXTERN_R SEXP RS_wavelets_filters_continuous(
SEXP pr_filter_type,
SEXP pr_filter_arg,
SEXP pr_frequency )
{
SEXP pr_ret_result;
double filter_arg;
mutil_data_type type;
mutil_errcode err;
univ_mat frequency;
univ_mat result;
void *VPNULL = NULL;
wav_filter_type filter_type;
/* Avoid lint warning */
(void) whatssi;
/* Conversion of input data ... */
/* ... pr_filter_type to filter_type */
err = wav_filter_type_from_R( pr_filter_type, &filter_type );
if ( err ){
PROBLEM "Unable to convert wav_filter_type type argument pr_filter_type to filter_type" ERROR;
}
/* ... pr_filter_arg to filter_arg */
err = double_from_R( pr_filter_arg, &filter_arg );
if ( err ){
PROBLEM "Unable to convert double type argument pr_filter_arg to filter_arg" ERROR;
}
/* ... pr_frequency to frequency */
err = mutil_R_type( pr_frequency, &type );
if ( err ){
PROBLEM "Unable to read pr_frequency type" ERROR;
}
err = matuniv_from_R( pr_frequency, type, &frequency );
if ( err ){
PROBLEM "Unable to read pr_frequency" ERROR;
}
err = matuniv_malloc( &result,
MATUNIV_NROW( &frequency ),
MATUNIV_NCOL( &frequency ),
MUTIL_DCOMPLEX );
if ( err ) {
MUTIL_FREE_WARN( matuniv, &frequency );
PROBLEM "Unable to allocate memory for frequency response matrix" ERROR;
}
/* Call the function */
err = wavuniv_filters_continuous(
filter_type,
filter_arg,
&frequency,
VPNULL,
&result );
MUTIL_FREE_WARN( matuniv, &frequency );
if ( err ){
PROBLEM "Problem calling wavuniv_filters_continuous() function" ERROR;
}
/* create the output R object */
err = matuniv_to_R( &result, (mutil_R_class_type) MUTIL_R_MATRIX, &pr_ret_result );
MUTIL_FREE_WARN( matuniv, &result );
if ( err ) {
PROBLEM "Unable to convert output data to R format" ERROR;
}
return pr_ret_result;
}
/** Discrete wavelet packet transform subset inverse.
* @source RS\_wav\_dwtc.c
* @author Copyright (c), 1988, 2006 Insightful Corp. All rights reserved.
* @usage #itCall( "RS_wavelets_transform_packet_inverse", dwpt.basis, extra, transform.indices, filters))#
* @return An R ... containing ...
* @param dwpt.basis Pointer to an R object containing ... dwpt.basis
* @param extra Pointer to an R object containing ... extra
* @param atoms Any extra DWPT atoms.
* @param levelmap The level map for extra DWPT atoms.
* @param transform.indices Pointer to an R object containing ... transform.indices
* @param filters Pointer to an R object containing ... filters
* @see wavuniv_transform_packet
* @see wavuniv_transform_packet_convert_indices
*/
EXTERN_R SEXP RS_wavelets_transform_packet_inverse(
SEXP pr_dwpt_basis,
SEXP pr_nextra,
SEXP pr_atoms,
SEXP pr_levelmap,
SEXP pr_transform_indices,
SEXP pr_filters )
{
SEXP pr_ret_result;
mat_set dwpt_basis;
mat_set filters;
mutil_data_type type;
mutil_errcode err;
univ_mat result;
univ_mat transform_indices;
void *VPNULL = NULL;
wav_dwpt_extra extra;
univ_mat um_atoms;
univ_mat um_levelmap;
boolean any_extra;
/* Avoid lint warning */
(void) whatssi;
/* Conversion of input data ... */
/* ... pr_extra to extra */
err = sint32_from_R( pr_nextra, &(extra.nelem) );
if ( err ) {
PROBLEM "Unable to convert pr_nextra to sint32 value" ERROR;
}
any_extra = (boolean) ( extra.nelem > 0 );
if ( any_extra ){
err = matuniv_from_R( pr_atoms, MUTIL_DOUBLE, &um_atoms );
if ( err ){
PROBLEM "Unable to read pr_atoms" ERROR;
}
err = matuniv_from_R( pr_levelmap, MUTIL_SINT32, &um_levelmap );
if ( err ){
PROBLEM "Unable to read pr_levelmap" ERROR;
}
extra.nelem = MATUNIV_NELEM( &um_atoms );
extra.atoms = um_atoms.mat.dblmat;
extra.levelmap = um_levelmap.mat.s32mat;
}
/* ... pr_dwpt_basis to dwpt_basis */
err = matset_from_R( pr_dwpt_basis, MUTIL_DOUBLE, &dwpt_basis );
if ( err ){
PROBLEM "Unable to read pr_dwpt_basis" ERROR;
}
/* ... pr_transform_indices to transform_indices */
err = mutil_R_type( pr_transform_indices, &type );
if ( err ){
PROBLEM "Unable to read pr_transform_indices type" ERROR;
}
err = matuniv_from_R( pr_transform_indices, type, &transform_indices );
if ( err ){
PROBLEM "Unable to read pr_transform_indices" ERROR;
}
/* ... pr_filters to filters */
err = matset_from_R( pr_filters, MUTIL_DOUBLE, &filters );
if ( err ){
PROBLEM "Unable to read pr_filters" ERROR;
}
/* Call the function */
err = wavuniv_transform_packet_inverse(
&dwpt_basis,
&extra,
&transform_indices,
&filters,
VPNULL,
&result );
if ( err ){
PROBLEM "Problem calling wavuniv_transform_packet_inverse() function" ERROR;
}
if ( any_extra ){
MUTIL_FREE_WARN( matuniv, &um_atoms );
MUTIL_FREE_WARN( matuniv, &um_levelmap );
}
/* create the output R object */
err = matuniv_to_R( &result, (mutil_R_class_type) MUTIL_R_MATRIX, &pr_ret_result );
MUTIL_FREE_WARN( matuniv, &result );
if ( err ) {
PROBLEM "Unable to convert output data to R format" ERROR;
}
return pr_ret_result;
}
/** Extracts a discrete wavelet packet transform subset.
* @source RS\_wav\_dwtc.c
* @author Copyright (c), 1988, 2006 Insightful Corp. All rights reserved.
* @usage #itCall( "RS_wavelets_transform_packet_basis", dwpt, transform.indices, n.level))#
* @return An R ... containing ...
* @param dwpt Pointer to an R object containing ... dwpt
* @param transform.indices Pointer to an R object containing ... transform.indices
* @see wavuniv_transform_packet_convert_indices
* @see wavuniv_transform_packet
* @see wavuniv_transform_maximum_overlap_packet
* @see _wav_dwpt_extra
* @see wavuniv_transform_packet_inverse
*/
EXTERN_R SEXP RS_wavelets_transform_packet_basis(
SEXP pr_dwpt,
SEXP pr_transform_indices )
{
SEXP pr_ret_obj;
SEXP tmpobj;
mat_set dwpt;
mat_set result;
mutil_data_type type;
mutil_errcode err;
univ_mat transform_indices;
void *VPNULL = NULL;
wav_dwpt_extra extra;
univ_mat extra_atoms;
univ_mat extra_levelmap;
sint32 i;
memlist list;
/* Avoid lint warning */
(void) whatssi;
/* initialize memory list */
MEMLIST_INIT( list );
/* Conversion of input data ... */
/* ... pr_dwpt to dwpt */
READ_MATSET_REGISTER( pr_dwpt, MUTIL_DOUBLE, &dwpt );
/* ... pr_transform_indices to transform_indices */
READ_MATRIX_REGISTER( pr_transform_indices, &transform_indices );
/* Call the function */
err = wavuniv_transform_packet_basis(
&dwpt,
&transform_indices,
VPNULL,
&result,
&extra );
MUTIL_FREE_WARN( memlist, &list );
if ( err ){
PROBLEM "Problem calling wavuniv_transform_packet_basis() function" ERROR;
}
/* in the case where there are extra dwpt atoms that need to
be stored, there will be memory allocated for the
'extra' structure above. the easiest way to get this
back to R is to pack everything into a list */
if ( extra.nelem > 0 ){
/* wrap universal matrix headers around extra matrices */
err = matuniv_wrap_matrix( &extra_atoms, &(extra.atoms), MUTIL_DOUBLE);
if ( err ){
MUTIL_ERROR( "Unable to wrap universal matrix around extra atoms matrix" );
PROBLEM "Problem creating R list" ERROR;
}
err = matuniv_wrap_matrix( &extra_levelmap, &(extra.levelmap), MUTIL_SINT32 );
if ( err ){
MUTIL_ERROR( "Unable to wrap universal matrix around extra levelmap matrix" );
PROBLEM "Problem creating R list" ERROR;
}
/* create an R list object */
PROTECT( pr_ret_obj = allocVector( VECSXP, result.nelem + 2 ) );
/* create R matrix objects and pack the extra crystals into the list */
for( i = 0; i < result.nelem; i++ ) {
err = matuniv_to_R( &(result.mats[i]), (mutil_R_class_type) MUTIL_R_MATRIX, &tmpobj );
if( err ){
PROBLEM "Problem adding DWPT crystal to R list" ERROR;
}
/*LINTED: cast OK, checked range */
SET_VECTOR_ELT( pr_ret_obj, (int) i, tmpobj);
}
/* pack the extra atoms crystal into the R list */
err = matuniv_to_R( &extra_atoms, (mutil_R_class_type) MUTIL_R_MATRIX, &tmpobj );
if( err ){
PROBLEM "Problem adding extra DWPT crystal to R list" ERROR;
}
/*LINTED: cast OK, checked range */
SET_VECTOR_ELT( pr_ret_obj, (int) i++, tmpobj );
/* finally, pack the levelmap vector into the list */
err = matuniv_to_R( &extra_levelmap, (mutil_R_class_type) MUTIL_R_MATRIX, &tmpobj );
if( err ){
PROBLEM "Problem adding extra DWPT levelmap crystal to R list" ERROR;
}
/*LINTED: cast OK, checked range */
SET_VECTOR_ELT( pr_ret_obj, (int) i, tmpobj );
/* free the memory */
MUTIL_FREE_WARN( matuniv, &extra_levelmap );
MUTIL_FREE_WARN( matuniv, &extra_atoms );
MUTIL_FREEALL_MATSET_WARN( &result );
UNPROTECT(1);
}
else{
err = matset_to_R_list( &result, &pr_ret_obj );
MUTIL_FREEALL_MATSET_WARN( &result );
if ( err ) {
PROBLEM "Unable to convert output data to Splus format" ERROR;
}
}
return pr_ret_obj;
}
/** Conversion and validation of wavelet packet indices.
* @source RS\_wav\_dwtc.c
* @author Copyright (c), 1988, 2006 Insightful Corp. All rights reserved.
* @usage #itCall( "RS_wavelets_transform_packet_convert_indices", transform.indices, filters, n.level))#
* @return An R ... containing ...
* @param transform.indices Pointer to an R object containing ... transform.indices
* @see wavuniv_transform_packet
* @see wavuniv_transform_maximum_overlap_packet
*/
EXTERN_R SEXP RS_wavelets_transform_packet_convert_indices(
SEXP pr_transform_indices )
{
SEXP pr_ret_flat;
SEXP pr_ret_level;
SEXP pr_ret_obj;
SEXP pr_ret_osc;
mutil_data_type type;
mutil_errcode err;
univ_mat flat;
univ_mat level;
univ_mat osc;
univ_mat transform_indices;
void *VPNULL = NULL;
memlist list;
/* Avoid lint warning */
(void) whatssi;
/* initialize memory list */
MEMLIST_INIT( list );
/* Conversion of input data ... */
/* ... pr_transform_indices to transform_indices */
READ_MATRIX_REGISTER( pr_transform_indices, &transform_indices );
/* Call the function */
err = wavuniv_transform_packet_convert_indices(
&transform_indices,
VPNULL,
&flat,
&level,
&osc );
MEMLIST_FREE_ON_ERROR_SPLUS( err, &list, "Problem calling wavuniv_transform_packet_convert_indices() function" );
err = memlist_member_register( &list, &flat, MEMTYPE_MATUNIV);
MEMLIST_FREE_ON_ERROR_REGISTER( err, &list );
err = memlist_member_register( &list, &level, MEMTYPE_MATUNIV);
MEMLIST_FREE_ON_ERROR_REGISTER( err, &list );
err = memlist_member_register( &list, &osc, MEMTYPE_MATUNIV);
MEMLIST_FREE_ON_ERROR_REGISTER( err, &list );
/* create the output R object */
err = matuniv_to_R( &flat, (mutil_R_class_type) MUTIL_R_MATRIX, &pr_ret_flat );
MEMLIST_FREE_ON_ERROR_SPLUS( err, &list, "Unable to convert output data to R format" );
err = matuniv_to_R( &level, (mutil_R_class_type) MUTIL_R_MATRIX, &pr_ret_level );
MEMLIST_FREE_ON_ERROR_SPLUS( err, &list, "Unable to convert output data to R format" );
err = matuniv_to_R( &osc, (mutil_R_class_type) MUTIL_R_MATRIX, &pr_ret_osc );
MEMLIST_FREE_ON_ERROR_SPLUS( err, &list, "Unable to convert output data to R format" );
PROTECT( pr_ret_obj = allocVector( VECSXP, 3 ) );
SET_VECTOR_ELT( pr_ret_obj, 0, pr_ret_flat );
SET_VECTOR_ELT( pr_ret_obj, 1, pr_ret_level );
SET_VECTOR_ELT( pr_ret_obj, 2, pr_ret_osc );
UNPROTECT(1);
/* free registered local memory */
MUTIL_FREE_WARN( memlist, &list );
return pr_ret_obj;
}
/** The modulus maxima of a continuous wavelet transform.
* @source RRS\_wav\_wtmm.c
* @author Copyright (c), 1988, 2006 Insightful Corp. All rights reserved.
* @usage #.Call( "RS_wavelets_transform_continuous_wavelet_modulus_maxima", cwt, tolerance))#
* @return An R ... containing ...
* @param cwt Pointer to an R object containing ... cwt
* @param tolerance Pointer to an R object containing ... tolerance
* @see wavuniv_transform_continuous_wavelet
* @see wavuniv_transform_continuous_wavelet_modulus_maxima_tree
*/
EXTERN_R SEXP RS_wavelets_transform_continuous_wavelet_modulus_maxima(
SEXP pr_cwt,
SEXP pr_tolerance,
SEXP pr_peak_type )
{
SEXP pr_ret_iscale;
SEXP pr_ret_itime;
SEXP pr_ret_obj;
mutil_data_type type;
mutil_errcode err;
univ_mat iscale;
univ_mat itime;
univ_mat cwt;
univ_mat tolerance;
void *VPNULL = NULL;
memlist list;
wav_transform_peak peak_type;
/* Avoid lint warning */
(void) whatssi;
/* initialize memory list */
MEMLIST_INIT( list );
/* Conversion of input data ... */
/* ... pr_cwt to cwt */
READ_MATRIX_REGISTER( pr_cwt, &cwt );
/* ... pr_tolerance to tolerance */
READ_MATRIX_REGISTER( pr_tolerance, &tolerance );
/* ... pr_peak_type to peak_type */
WAV_TRANSFORM_PEAK_FROM_R( pr_peak_type, &peak_type );
/* Call the function */
err = wavuniv_transform_continuous_wavelet_modulus_maxima(
&cwt,
&tolerance,
peak_type,
VPNULL,
&(itime.mat.s32mat),
&(iscale.mat.s32mat) );
MUTIL_FREE_WARN( matuniv, &cwt );
MUTIL_FREE_WARN( matuniv, &tolerance );
if ( err ){
PROBLEM "Problem calling wavuniv_transform_continuous_wavelet_modulus_maxima() function" ERROR;
}
/* free registered local memory */
MUTIL_FREE_WARN( memlist, &list );
/* wrap the sint32 output matrices into a universal matrix */
err = matuniv_wrap_matrix( &itime, &(itime.mat.s32mat), MUTIL_SINT32 );
if (err){
MUTIL_FREE_WARN( matuniv, &itime );
PROBLEM "Problem wrapping WTMM time index matrix into a universal matrix" ERROR;
}
err = matuniv_wrap_matrix( &iscale, &(iscale.mat.s32mat), MUTIL_SINT32 );
if (err){
MUTIL_FREE_WARN( matuniv, &iscale );
PROBLEM "Problem wrapping WTMM scale index matrix into a universal matrix" ERROR;
}
/* create the output R object */
err = matuniv_to_R( &itime, (mutil_R_class_type) MUTIL_R_MATRIX, &pr_ret_itime );
MUTIL_FREE_WARN( matuniv, &itime );
if ( err ) {
PROBLEM "Unable to convert output data to Splus format" ERROR;
}
err = matuniv_to_R( &iscale, (mutil_R_class_type) MUTIL_R_MATRIX, &pr_ret_iscale );
MUTIL_FREE_WARN( matuniv, &iscale );
if ( err ) {
PROBLEM "Unable to convert output data to Splus format" ERROR;
}
PROTECT( pr_ret_obj = allocVector( VECSXP, 2 ) );
SET_VECTOR_ELT( pr_ret_obj, 0, pr_ret_itime );
SET_VECTOR_ELT( pr_ret_obj, 1, pr_ret_iscale );
UNPROTECT(1);
return pr_ret_obj;
}
/** Find the nearest neighbors of a multidimensional embedding of data in the phase space.
* @source RS\_fra\_neig.c
* @author Copyright (c), 1988, 2006 Insightful Corp. All rights reserved.
* @usage #.Call( "RS_fractal_neighbor_find", embedding, n.neighbor, distance.max, distance.metric, pdmatrix, sort.distances, orbital.lag))#
* @return An R ... containing ...
* @param embedding Pointer to an R object containing ... embedding
* @param n.neighbor Pointer to an R object containing ... n.neighbor
* @param distance.max Pointer to an R object containing ... distance.max
* @param distance.metric Pointer to an R object containing ... distance.metric
* @param pdmatrix Pointer to an R object containing ... pdmatrix
* @param sort.distances Pointer to an R object containing ... sort.distances
* @param orbital.lag Pointer to an R object containing ... orbital.lag
* @see _fra_distance_metric
* @see frauniv_embed_neighbors
*/
EXTERN_R SEXP RS_fractal_neighbor_find(
SEXP pr_embedding,
SEXP pr_n_neighbor,
SEXP pr_distance_max,
SEXP pr_distance_metric,
SEXP pr_sort_distances,
SEXP pr_orbital_lag )
{
SEXP pr_ret_neighbor_distances;
SEXP pr_ret_neighbor_indices;
SEXP pr_ret_obj;
SEXP pr_ret_original_indices;
boolean sort_distances;
double distance_max;
fra_distance_metric distance_metric;
mutil_data_type type;
mutil_errcode err;
sint32 n_neighbor;
sint32 orbital_lag;
univ_mat embedding;
univ_mat neighbor_distances;
univ_mat neighbor_indices;
univ_mat original_indices;
void *VPNULL = NULL;
memlist list;
/* Avoid lint warning */
(void) whatssi;
/* initialize memory list */
MEMLIST_INIT( list );
/* Conversion of input data ... */
/* ... pr_time_series to time_series */
READ_MATRIX_REGISTER( pr_embedding, &embedding );
/* ... pr_n_neighbor to n_neighbor */
SINT32_FROM_R( pr_n_neighbor, &n_neighbor );
/* ... pr_distance_max to distance_max */
DOUBLE_FROM_R( pr_distance_max, &distance_max );
/* ... pr_distance_metric to distance_metric */
DISTANCE_METRIC_FROM_R( pr_distance_metric, &distance_metric );
/* ... pr_sort_distances to sort_distances */
BOOLEAN_FROM_R( pr_sort_distances, &sort_distances );
/* ... pr_orbital_lag to orbital_lag */
SINT32_FROM_R( pr_orbital_lag, &orbital_lag );
/* Call the function */
err = frauniv_neighbor_find(
&embedding,
n_neighbor,
distance_max,
distance_metric,
(univ_mat*) NULL,
sort_distances,
orbital_lag,
VPNULL,
&original_indices,
&neighbor_indices,
&neighbor_distances );
MEMLIST_FREE_ON_ERROR_SPLUS( err, &list, "Problem calling frauniv_neighbor_find() function" );
err = memlist_member_register( &list, &original_indices, MEMTYPE_MATUNIV);
MEMLIST_FREE_ON_ERROR_REGISTER( err, &list );
err = memlist_member_register( &list, &neighbor_indices, MEMTYPE_MATUNIV);
MEMLIST_FREE_ON_ERROR_REGISTER( err, &list );
err = memlist_member_register( &list, &neighbor_distances, MEMTYPE_MATUNIV);
MEMLIST_FREE_ON_ERROR_REGISTER( err, &list );
/* create the output R object */
err = matuniv_to_R( &original_indices, (mutil_R_class_type) MUTIL_R_MATRIX, &pr_ret_original_indices );
MEMLIST_FREE_ON_ERROR_SPLUS( err, &list, "Unable to convert output data to R format" );
err = matuniv_to_R( &neighbor_indices, (mutil_R_class_type) MUTIL_R_MATRIX, &pr_ret_neighbor_indices );
MEMLIST_FREE_ON_ERROR_SPLUS( err, &list, "Unable to convert output data to R format" );
err = matuniv_to_R( &neighbor_distances, (mutil_R_class_type) MUTIL_R_MATRIX, &pr_ret_neighbor_distances );
MEMLIST_FREE_ON_ERROR_SPLUS( err, &list, "Unable to convert output data to R format" );
PROTECT( pr_ret_obj = allocVector( VECSXP, 3 ) );
SET_VECTOR_ELT( pr_ret_obj, 0, pr_ret_original_indices );
SET_VECTOR_ELT( pr_ret_obj, 1, pr_ret_neighbor_indices );
SET_VECTOR_ELT( pr_ret_obj, 2, pr_ret_neighbor_distances );
UNPROTECT(1);
/* free registered local memory */
MUTIL_FREE_WARN( memlist, &list );
return pr_ret_obj;
}
