SEXP L2L1Vit(SEXP obsSeq, SEXP obsWts, SEXP lambda2, SEXP lambda1,
SEXP retPath, SEXP maxSegs, SEXP nSegs, SEXP backPtrs,
SEXP primBds)
{
int max_segs = GetInt(maxSegs, 0, 0);
double * o = REAL(obsSeq);
double * wts = REAL(obsWts);
double lam2 = GetNumeric(lambda2, 0, 0);
double lam1 = GetNumeric(lambda1, 0, 0);
int n_obs = LENGTH(obsSeq);
int n_protect = 0;
double * back_ptrs = REAL(backPtrs);
int msg_buf_len = FL_SEGSZ*2*30;
double * msg_buf = malloc( msg_buf_len*sizeof(double) );
int * n_segs = INTEGER(nSegs);
double obs_min = R_PosInf, obs_max = R_NegInf;
for(int i = 0; i < n_obs; i++){
if(R_FINITE(o[i])){
if(o[i] < obs_min) obs_min = o[i];
else if(o[i] > obs_max) obs_max = o[i];
}
}
SEXP ret_sxp;
PROTECT(ret_sxp = NEW_INTEGER(1)); n_protect++;
double * rp = REAL(retPath);
int r1 = L2L1VitFwd(lam2, o, wts,
&msg_buf, &msg_buf_len, max_segs,
back_ptrs, n_segs, n_obs, max_segs, obs_min, obs_max,
(rp + (n_obs-1)) );
if(r1 != 1){
INTEGER(ret_sxp)[0] = r1;
UNPROTECT(n_protect);
return ret_sxp;
}
double * bd1 = NULL, *bd2 = NULL;
if(primBds != R_NilValue){
bd1 = REAL(primBds);
bd2 = bd1 + 1;
}
L2L1BackTrace(rp[n_obs-1], lam1, rp, n_obs, back_ptrs, bd1, bd2);
free(msg_buf);
INTEGER(ret_sxp)[0] = 1;
if(n_protect > 0) UNPROTECT(n_protect);
return ret_sxp;
}
DVT_STATUS VALUE_TM_CLASS::IsTime (string time, int, LOG_MESSAGE_CLASS * messages)
// DESCRIPTION : Check if time format is valid.
// PRECONDITIONS :
// POSTCONDITIONS :
// EXCEPTIONS :
// NOTES :
//<<===========================================================================
{
int length = time.length();
int hour;
int minute;
int second;
char message[256];
if (length > 6)
{
sprintf (message, "HHMMSS may not exceed 6 characters. Length %d found.",
length);
messages->AddMessage (VAL_RULE_D_TM_9, message);
return (MSG_ERROR);
}
hour = 0;
minute = 0;
second = 0;
switch (length)
{
case 6:
second = GetNumeric (&time[4],2); // Fall through.
case 4:
minute = GetNumeric (&time[2], 2); // Fall through
case 2:
hour = GetNumeric (time, 2);
break;
case 0:
break;
default:
sprintf (message, "invalid time format - expected [HH[MM[SS[.FRAC]]]]");
messages->AddMessage (VAL_RULE_D_TM_2, message);
return (MSG_ERROR);
}
if (IsTimeValid (hour, minute, second) == false)
{
sprintf (message, "invalid time");
messages->AddMessage (VAL_RULE_D_TM_5, message);
return (MSG_ERROR);
}
return (MSG_OK);
}
void SpectDisplay::ReadDialogValues()
//{==================================
{
spectseq->amplitude = formantdlg->t_amplitude->GetValue();
spectseq->duration = GetNumeric(voicedlg->vd_duration);
voicedlg->ReadParams();
}
uint32 SOMFRecordPointer::UnpackLIDATABlock(int8 * destination, uint32 MaxSize) {
// Unpack Data block in LIDATA record recursively and store data at destination
uint32 RepeatCount = GetNumeric(); // Outer repeat count
uint32 BlockCount = GetWord(); // Inner repeat count
uint32 Size = 0; // Size of data expanded so far
uint32 RSize; // Size of recursively expanded data
uint32 SaveIndex; // Save Index for repetition
uint32 i, j; // Loop counters
if (BlockCount == 0) {
// Contains one repeated block
Size = GetByte(); // Size of repeated block
if (RepeatCount * Size > MaxSize) {
// Data outside allowed area
err.submit(2310); // Error message
Index += Size; // Point to after block
return 0; // No data stored
}
// Loop RepeatCount times
for (i = 0; i < RepeatCount; i++) {
// copy data block into destination
memcpy(destination, buffer + FileOffset + Index, Size);
destination += Size;
}
Index += Size; // Point to after block
return RepeatCount * Size; // Size of expanded data
}
// Nested repeat blocks
SaveIndex = Index;
// Loop RepeatCount times
for (i = 0; i < RepeatCount; i++) {
// Go back and repeat unpacking
Index = SaveIndex;
// Loop BlockCount times
for (j = 0; j < BlockCount; j++) {
// Recursion
RSize = UnpackLIDATABlock(destination, MaxSize);
destination += RSize;
MaxSize -= RSize;
Size += RSize;
}
}
return Size;
}
uint32 SOMFRecordPointer::InterpretLIDATABlock() {
// Interpret Data block in LIDATA record recursively
// Prints repeat count and returns total size
uint32 RepeatCount = GetNumeric();
uint32 BlockCount = GetWord();
uint32 Size = 0;
printf("%i * ", RepeatCount);
if (BlockCount == 0) {
Size = GetByte();
Index += Size;
printf("%i", Size);
return RepeatCount * Size;
}
// Nested repeat blocks
printf("(");
for (uint32 i = 0; i < BlockCount; i++) {
// Recursion
Size += InterpretLIDATABlock();
if (i+1 < BlockCount) printf(" + ");
}
printf(")");
return RepeatCount * Size;
}
SEXP L2L1ExpandFit(SEXP betaPath, SEXP betaSegs, SEXP lam1, SEXP lam2Inds, SEXP retFit)
{
double lm1 = GetNumeric(lam1, 0, 0);
double * ret_fit = REAL(retFit);
int n_lam2i = LENGTH(lam2Inds);
int * lam2i = INTEGER(lam2Inds);
for(int i = 0; i < n_lam2i; i++){
SEXP bp_sxp = VECTOR_ELT(betaPath, lam2i[i]);
SEXP bsg_sxp = VECTOR_ELT(betaSegs, lam2i[i]);
int n_seg = LENGTH(bp_sxp);
double * bv = REAL(bp_sxp);
int * sgv = INTEGER(bsg_sxp);
double cur_b = soft_thresh(bv[0], lm1);
int n_fill = 1 + sgv[1] - sgv[0];
for(int j = 0; j < n_fill; j++, ret_fit++){
*ret_fit = cur_b;
}
for(int k = 1, k2 = 2; k < n_seg; k++, k2 += 2){
cur_b = soft_thresh(bv[k], lm1);
n_fill = 1 + sgv[k2 + 1] - sgv[k2];
for(int j = 0; j < n_fill; j++, ret_fit++){
*ret_fit = cur_b;
}
}
}
return R_NilValue;
}
DVT_STATUS VALUE_DT_CLASS::Check (UINT32 flags,
BASE_VALUE_CLASS **,
LOG_MESSAGE_CLASS *messages,
SPECIFIC_CHARACTER_SET_CLASS *)
// DESCRIPTION : Check DT format.
// PRECONDITIONS :
// POSTCONDITIONS :
// EXCEPTIONS :
// NOTES :
//<<===========================================================================
{
DVT_STATUS result = MSG_OK;
int length = valueM.length();
int maxLength;
int index;
int frac_index = 0;
unsigned int offset_index = 0;
string syntax = "";
int second;
int minute;
int hour;
int day;
int month;
int year;
char message[256];
if (length == 0)
return (MSG_OK);
if (flags & ATTR_FLAG_RANGES_ALLOWED)
{
maxLength = DT_QR_LENGTH;
}
else
{
maxLength = DT_LENGTH;
}
if (length > maxLength)
{
sprintf (message, "value length %i exceeds maximum length %i - truncated for value(%s)",
length, maxLength, valueM.c_str());
messages->AddMessage (VAL_RULE_D_DT_1, message);
length = maxLength;
result= MSG_ERROR;
}
if (length > 0)
{
for (index=0 ; index<length ; index++)
{
if ((valueM[index] >= '0') && (valueM[index] <= '9'))
{
syntax += 'n';
}
else
{
switch (valueM[index])
{
case '.':
if (!(flags & ATTR_FLAG_RANGES_ALLOWED))
{
if (frac_index != 0) // twice
{
sprintf (message, "more then one '.' Character found at offset %d",
index);
messages->AddMessage (VAL_RULE_D_DT_2, message);
return MSG_ERROR;
}
}
syntax += '.';
frac_index = index + 1;
break;
case '+': // Fall through
case '-':
if (!(flags & ATTR_FLAG_RANGES_ALLOWED))
{
if (offset_index != 0) // twice
{
sprintf (message, "more then one '+' or '-' Character found at offset %d",
index);
messages->AddMessage (VAL_RULE_D_DT_2, message);
return MSG_ERROR;
}
}
syntax += 'S';
offset_index = index + 1;
break;
case ' ':
if ( ((index + 1) % 2 != 0) ||
((valueM[index+1] != NULLCHAR) &&
((index + 1) < maxLength)
)
)
{
sprintf (message, "unexpected SPACE character at offset %d",
index+1);
messages->AddMessage (VAL_RULE_D_DT_2, message);
return MSG_ERROR;
}
break;
case 0x00:
sprintf (message, "unexpected character [NUL]=0x00 at offset %d",
index+1);
messages->AddMessage (VAL_RULE_D_DT_2, message);
return MSG_ERROR;
case 0x0a: // Fall through
case 0x0d:
sprintf (message, "unexpected character 0x%02X at offset %d",
(int)(valueM[index]), index+1);
messages->AddMessage (VAL_RULE_D_DT_2, message);
return MSG_ERROR;
default:
sprintf (message, "unexpected character %c=0x%02X at offset %d",
valueM[index], valueM[index], index+1);
messages->AddMessage (VAL_RULE_D_DT_2, message);
return MSG_ERROR;
}
}
}
// Deal with offset first. Note that an offset can not be at the
// beginning of a string.
if (offset_index != 0)
{
if (syntax.find("nnnn", offset_index) != offset_index)
{
sprintf (message, "invalid optional offset suffix");
messages->AddMessage (VAL_RULE_D_DT_2, message);
return MSG_ERROR;
}
hour = GetNumeric (&valueM[offset_index], 2);
minute = GetNumeric (&valueM[offset_index + 2], 2);
if (!(IsTimeValid (hour, minute, 0)))
{
sprintf (message, "invalid time value specified in offset suffix");
messages->AddMessage (VAL_RULE_D_DT_2, message);
return MSG_ERROR;
}
// chop offset off syntax string
index = offset_index - 1;
syntax[index] = NULLCHAR;
hour = 0;
minute = 0;
}
// Compensate the index counter used in the for-loop.
index--;
// Deal with frac.
if (!(flags & ATTR_FLAG_RANGES_ALLOWED))
{
if ((syntax.find ("nnnnnnnnnnnnnn.n") == 0) && (index <= 21))
{
if (! IsNumeric (&valueM[frac_index], index-frac_index))
{
sprintf (message, "invalid fractional part specified");
messages->AddMessage (VAL_RULE_D_DT_2, message);
return MSG_ERROR;
}
}
else
{
if (frac_index > 0)
{
sprintf (message,
"fraction '.' Character not expected at offset %d",
frac_index);
messages->AddMessage (VAL_RULE_D_DT_2, message);
return MSG_ERROR;
}
}
}
// Deal with main date/time stem - various formats
index = 0;
while (syntax[index] == 'n')
{
index++;
}
second = 0;
minute = 0;
hour = 0;
day = 1;
month = 1;
year = 1900;
switch (index)
{
case 14:
second = GetNumeric(&valueM[12], 2); // Fall through
case 12:
minute = GetNumeric(&valueM[10], 2); // Fall through
case 10:
hour = GetNumeric(&valueM[8], 2); // Fall through
case 8:
day = GetNumeric(&valueM[6], 2); // Fall through
case 6:
month = GetNumeric(&valueM[4], 2); // Fall through
case 4:
year = GetNumeric(valueM, 4);
break;
default:
sprintf (message, "unexpected components - expected YYYY[MM[DD[HH[MM[SS[.FRAC]]]]]][OFFSET]");
messages->AddMessage (VAL_RULE_D_DT_2, message);
return MSG_ERROR;
}
if (IsDateValid(year, month, day) == false)
{
sprintf (message, "invalid date");
messages->AddMessage (VAL_RULE_D_DT_3, message);
return MSG_ERROR;
}
if (IsTimeValid(hour, minute, second) == false)
{
sprintf (message, "invalid time");
messages->AddMessage (VAL_RULE_D_DT_3, message);
return MSG_ERROR;
}
}
return (result);
}
Token
Scanner::Get(Need need)
{
int type = Token::EOT;
old_index = index;
old_line = line;
eos = str + length;
p = str + index;
if (p >= eos) {
if (need == Demand && reader) {
Load(reader->more());
if (length > 0)
return Get(need);
}
return Token("", type, 0, line, 0);
}
while (isspace(*p) && p < eos) { // skip initial white space
if (*p == '\n') {
line++;
lineStart = p - str;
}
p++;
}
if (p >= eos) {
if (need == Demand && reader) {
Load(reader->more());
if (length > 0)
return Get(need);
}
return Token("", type, 0, line, 0);
}
Token result;
size_t start = p - str;
if (*p == '"' || *p == '\'') { // special case for quoted tokens
if (*p == '"') type = Token::StringLiteral;
else type = Token::CharLiteral;
char match = *p;
while (++p < eos) {
if (*p == match) { // find matching quote
if (*(p-1) != '\\') { // if not escaped
p++; // token includes matching quote
break;
}
}
}
}
// generic delimited comments
else if (*p == Token::comBeg(0) &&
(!Token::comBeg(1) || *(p+1) == Token::comBeg(1))) {
type = Token::Comment;
while (++p < eos) {
if (*p == Token::comEnd(0) &&
(!Token::comEnd(1) || *(p+1) == Token::comEnd(1))) {
p++; if (Token::comEnd(1)) p++;
break;
}
}
}
// alternate form delimited comments
else if (*p == Token::altBeg(0) &&
(!Token::altBeg(1) || *(p+1) == Token::altBeg(1))) {
type = Token::Comment;
while (++p < eos) {
if (*p == Token::altEnd(0) &&
(!Token::altEnd(1) || *(p+1) == Token::altEnd(1))) {
p++; if (Token::altEnd(1)) p++;
break;
}
}
}
else if (*p == '.') type = Token::Dot;
else if (*p == ',') type = Token::Comma;
else if (*p == ';') type = Token::Semicolon;
else if (*p == '(') type = Token::LParen;
else if (*p == ')') type = Token::RParen;
else if (*p == '[') type = Token::LBracket;
else if (*p == ']') type = Token::RBracket;
else if (*p == '{') type = Token::LBrace;
else if (*p == '}') type = Token::RBrace;
// use lexical sub-parser for ints and floats
else if (isdigit(*p))
type = GetNumeric();
else if (IsSymbolic(*p)) {
type = Token::SymbolicIdent;
while (IsSymbolic(*p)) p++;
}
else {
type = Token::AlphaIdent;
while (IsAlpha(*p)) p++;
}
size_t extent = (p - str) - start;
if (extent < 1) extent = 1; // always get at least one character
index = start + extent; // advance the cursor
int col = start - lineStart;
if (line == 0) col++;
char* buf = new(__FILE__, __LINE__) char [extent + 1];
strncpy(buf, str + start, extent);
buf[extent] = '\0';
if (type == Token::Comment && Token::hidecom) {
delete [] buf;
if (Token::comEnd(0) == '\n') {
line++;
lineStart = p - str;
}
return Get(need);
}
if (type == Token::AlphaIdent || // check for keyword
type == Token::SymbolicIdent) {
int val;
if (Token::findKey(Text(buf), val))
result = Token(buf, Token::Keyword, val, line+1, col);
}
if (result.mType != Token::Keyword)
result = Token(buf, type, 0, line+1, col);
if (line+1 > (size_t) best.mLine ||
(line+1 == (size_t) best.mLine && col > best.mColumn))
best = result;
delete [] buf;
return result;
}
SEXP L2L1VitPath(SEXP obsSeq, SEXP lambda2, SEXP lambda1, SEXP retPath, SEXP maxSegs,
SEXP segmentVec, SEXP primBds)
{
int segmented_ret = (segmentVec != R_NilValue) ? 1 : 0;
int max_segs = GetInt(maxSegs, 0, 0);
double * all_obs = REAL(obsSeq);
int n_obs = LENGTH(obsSeq);
int n_protect = 0;
double * back_ptrs = AllocProtectReal(2*n_obs); n_protect++;
int * fused_segs1 = NULL;
int * fused_segs2 = NULL;
double *o2 = NULL, *wts2 = NULL, *o3 = NULL, *wts3 = NULL;
int msg_buf_len = FL_SEGSZ*2*30;
double * msg_buf = malloc( msg_buf_len*sizeof(double) );
SEXP ret_sxp;
PROTECT(ret_sxp = NEW_INTEGER(1)); n_protect++;
double obs_min = R_PosInf, obs_max = R_NegInf;
for(int i = 0; i < n_obs; i++){
if(R_FINITE(all_obs[i])){
if(all_obs[i] < obs_min) obs_min = all_obs[i];
if(all_obs[i] > obs_max) obs_max = all_obs[i];
}
}
double lam1 = GetNumeric(lambda1, 0, 0);
int n_lam2 = LENGTH(lambda2);
int n_o = n_obs;
double * o = all_obs;
double * wts = NULL;
double * prim_bds = (primBds == R_NilValue) ? NULL : REAL(primBds);
for(int lam2i = 0; lam2i < n_lam2; lam2i++){
double lam2 = REAL(lambda2)[lam2i];
double beta_hat = 0.0;
int r1 = L2L1VitFwd(lam2, o, wts,
&msg_buf, &msg_buf_len, max_segs,
back_ptrs, NULL, n_o, max_segs, obs_min, obs_max,
&beta_hat);
if(r1 != 1){
INTEGER(ret_sxp)[0] = r1;
UNPROTECT(n_protect);
return ret_sxp;
}
int * fs = fused_segs1;
int nfsd2 = 0;
if(o2 == NULL || segmented_ret){
//We haven't allocated the buffers for the
//fused observations yet
nfsd2 = L2L1GetNFused(beta_hat, n_o, back_ptrs);
o2 = AllocProtectReal(nfsd2); n_protect++;
wts2 = AllocProtectReal(nfsd2); n_protect++;
fused_segs1 = AllocProtectInt(2*(nfsd2+1)); n_protect++;
fused_segs2 = AllocProtectInt(2*(nfsd2+1)); n_protect++;
}
double * fit_v = NULL;
if(segmented_ret){
SEXP tmp_sxp;
PROTECT(tmp_sxp = NEW_NUMERIC(nfsd2));
SET_VECTOR_ELT(retPath, lam2i, tmp_sxp);
UNPROTECT(1);
fit_v = REAL(VECTOR_ELT(retPath, lam2i));
}else{
fit_v = REAL(retPath) + n_obs * lam2i;
}
int seg_R = (fs) ? fs[0] : (n_obs-1);
int seg_L = (fs) ? fs[1] : (n_obs-1);
int n_fused2 = 0;
fused_segs2[0] = seg_R;
if(fs) fs += 2;
double bd1 = 0.0, bd2 = 0.0;
double beta_hat_shr = beta_hat;
if(segmented_ret){
fit_v[(nfsd2-1) - n_fused2] = beta_hat_shr;
bd1 += fabs(beta_hat_shr);
}else{
for(int k = seg_L; k <= seg_R; k++){
fit_v[k] = beta_hat_shr;
}
bd1 += fabs(beta_hat_shr) * (double)(1+seg_R - seg_L);
}
if( !R_FINITE(o[n_o-1]) ){
o2[n_fused2] = wts2[n_fused2] = 0;
}else if(wts){
o2[n_fused2] = o[n_o-1]*wts[n_o-1];
wts2[n_fused2] = wts[n_o-1];
}else{
o2[n_fused2] = o[n_o-1];
wts2[n_fused2] = 1.0;
}
if(n_o == 1){
n_fused2 = 1;
fused_segs2[0] = n_obs - 1;
fused_segs2[1] = 0;
o2[0] = o[0] * wts[0];
wts2[0] = wts[0];
}
for(int i = n_o-2; i >= 0; i--){
seg_R = (fs) ? fs[0] : i;
seg_L = (fs) ? fs[1] : i;
double * bp = back_ptrs + (2*(i+1));
if(beta_hat > bp[1]){
bd2 += fabs(beta_hat - bp[1]);
beta_hat = bp[1];
beta_hat_shr = beta_hat;
fused_segs2[2*n_fused2 + 1] = seg_R+1;
n_fused2++;
o2[n_fused2] = wts2[n_fused2] = 0.0;
fused_segs2[2*n_fused2] = seg_R;
}else if(beta_hat < bp[0]){
bd2 += fabs(beta_hat - bp[0]);
beta_hat = bp[0];
beta_hat_shr = beta_hat;
fused_segs2[2*n_fused2 + 1] = seg_R+1;
n_fused2++;
o2[n_fused2] = wts2[n_fused2] = 0.0;
fused_segs2[2*n_fused2] = seg_R;
}
if(R_FINITE(o[i])){
if(wts){
o2[n_fused2] += o[i]*wts[i];
wts2[n_fused2] += wts[i];
}else{
o2[n_fused2] += o[i];
wts2[n_fused2] += 1.0;
}
}
if(segmented_ret){
fit_v[(nfsd2-1) - n_fused2] = beta_hat_shr;
}else{
for(int k = seg_L; k <= seg_R; k++){
fit_v[k] = beta_hat_shr;
}
}
bd1 += fabs(beta_hat_shr) * (double)(1+seg_R - seg_L);
if(i == 0){
fused_segs2[2*n_fused2 + 1] = seg_L;
n_fused2++;
}
if(fs) fs += 2;
}
if(prim_bds){
double * bdv = prim_bds + 2*lam2i;
bdv[0] = bd1;
bdv[1] = bd2;
}
// We have stored the fitted parameters. Now we collapse
// observations and fit on the new sequence at the next
// iteration
obs_min = R_PosInf;
obs_max = R_NegInf;
if(o3 == NULL){
o3 = AllocProtectReal(n_fused2); n_protect++;
wts3 = AllocProtectReal(n_fused2); n_protect++;
}
for(int i = 0; i < n_fused2; i++){
if( wts2[n_fused2-1-i] > 0.0 ){
double z = o2[n_fused2-1-i] / wts2[n_fused2-1-i];
if(z < obs_min) obs_min = z;
if(z > obs_max) obs_max = z;
o3[i] = z;
}else{
o3[i] = NA_REAL;
}
wts3[i] = wts2[n_fused2-1-i];
}
if(n_o == 1){
obs_max = obs_min + FL_ENDPT_KNOT_FUDGE;
obs_min -= FL_ENDPT_KNOT_FUDGE;
}
if(segmented_ret){
SEXP tmp_sxp, seg_dim;
PROTECT(tmp_sxp = NEW_INTEGER(2*nfsd2));
PROTECT(seg_dim=NEW_INTEGER(2));
INTEGER(seg_dim)[0] = 2;
INTEGER(seg_dim)[1] = nfsd2;
SET_DIM(tmp_sxp,seg_dim);
SET_VECTOR_ELT(segmentVec, lam2i, tmp_sxp);
UNPROTECT(2);
int * seg_v = INTEGER(VECTOR_ELT(segmentVec, lam2i));
for(int k = 0; k < nfsd2; k++){
seg_v[1+2*k] = fused_segs2[(nfsd2-1-k)*2]+1;
seg_v[2*k] = fused_segs2[1+(nfsd2-1-k)*2]+1;
}
}
o = o3;
wts = wts3;
fs = fused_segs2;
fused_segs2 = fused_segs1;
fused_segs1 = fs;
n_o = n_fused2;
}
free(msg_buf);
if(segmented_ret){
for(int lam2i = 0; lam2i < n_lam2; lam2i++){
double * bv = REAL(VECTOR_ELT(retPath, lam2i));
int m = LENGTH(VECTOR_ELT(retPath, lam2i));
for(int i = 0; i < m; i++){
bv[i] = soft_thresh(bv[i], lam1);
}
}
}else{
double * bv = REAL(retPath);
int m = LENGTH(retPath);
for(int i = 0; i < m; i++){
bv[i] = soft_thresh(bv[i], lam1);
}
}
INTEGER(ret_sxp)[0] = 1;
UNPROTECT(n_protect);
return ret_sxp;
}
