/** 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;
}
/** 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;
}
