int
ftp_get(ftpbuf_t *ftp, FILE *outfp, const char *path, ftptype_t type)
{
databuf_t *data = NULL;
char *ptr;
int lastch;
int rcvd;
if (ftp == NULL)
return 0;
if (!ftp_type(ftp, type))
goto bail;
if ((data = ftp_getdata(ftp)) == NULL)
goto bail;
if (!ftp_putcmd(ftp, "RETR", path))
goto bail;
if (!ftp_getresp(ftp) || (ftp->resp != 150 && ftp->resp != 125))
goto bail;
if ((data = data_accept(data)) == NULL)
goto bail;
lastch = 0;
while ((rcvd = my_recv(data->fd, data->buf, FTP_BUFSIZE))) {
if (rcvd == -1)
goto bail;
if (type == FTPTYPE_ASCII) {
for (ptr = data->buf; rcvd; rcvd--, ptr++) {
if (lastch == '\r' && *ptr != '\n')
putc('\r', outfp);
if (*ptr != '\r')
putc(*ptr, outfp);
lastch = *ptr;
}
}
else {
fwrite(data->buf, rcvd, 1, outfp);
}
}
if (type == FTPTYPE_ASCII && lastch == '\r')
putc('\r', outfp);
data = data_close(data);
if (ferror(outfp))
goto bail;
if (!ftp_getresp(ftp) || (ftp->resp != 226 && ftp->resp != 250))
goto bail;
return 1;
bail:
data_close(data);
return 0;
}
/* {{{ ftp_nb_continue_read
*/
int
ftp_nb_continue_read(ftpbuf_t *ftp)
{
databuf_t *data = NULL;
char *ptr;
int lastch;
size_t rcvd;
ftptype_t type;
data = ftp->data;
/* check if there is already more data */
if (!data_available(ftp, data->fd)) {
return PHP_FTP_MOREDATA;
}
type = ftp->type;
lastch = ftp->lastch;
if ((rcvd = my_recv(ftp, data->fd, data->buf, FTP_BUFSIZE))) {
if (rcvd == -1) {
goto bail;
}
if (type == FTPTYPE_ASCII) {
for (ptr = data->buf; rcvd; rcvd--, ptr++) {
if (lastch == '\r' && *ptr != '\n') {
php_stream_putc(ftp->stream, '\r');
}
if (*ptr != '\r') {
php_stream_putc(ftp->stream, *ptr);
}
lastch = *ptr;
}
} else if (rcvd != php_stream_write(ftp->stream, data->buf, rcvd)) {
goto bail;
}
ftp->lastch = lastch;
return PHP_FTP_MOREDATA;
}
if (type == FTPTYPE_ASCII && lastch == '\r') {
php_stream_putc(ftp->stream, '\r');
}
ftp->data = data = data_close(ftp, data);
if (!ftp_getresp(ftp) || (ftp->resp != 226 && ftp->resp != 250)) {
goto bail;
}
ftp->nb = 0;
return PHP_FTP_FINISHED;
bail:
ftp->nb = 0;
ftp->data = data_close(ftp, data);
return PHP_FTP_FAILED;
}
/* {{{ ftp_nb_continue_write
*/
int
ftp_nb_continue_write(ftpbuf_t *ftp)
{
long size;
char *ptr;
int ch;
/* check if we can write more data */
if (!data_writeable(ftp, ftp->data->fd)) {
return PHP_FTP_MOREDATA;
}
size = 0;
ptr = ftp->data->buf;
while (!php_stream_eof(ftp->stream) && (ch = php_stream_getc(ftp->stream)) != EOF) {
if (ch == '\n' && ftp->type == FTPTYPE_ASCII) {
*ptr++ = '\r';
size++;
}
*ptr++ = ch;
size++;
/* flush if necessary */
if (FTP_BUFSIZE - size < 2) {
if (my_send(ftp, ftp->data->fd, ftp->data->buf, size) != size) {
goto bail;
}
return PHP_FTP_MOREDATA;
}
}
if (size && my_send(ftp, ftp->data->fd, ftp->data->buf, size) != size) {
goto bail;
}
ftp->data = data_close(ftp, ftp->data);
if (!ftp_getresp(ftp) || (ftp->resp != 226 && ftp->resp != 250)) {
goto bail;
}
ftp->nb = 0;
return PHP_FTP_FINISHED;
bail:
ftp->data = data_close(ftp, ftp->data);
ftp->nb = 0;
return PHP_FTP_FAILED;
}
/* {{{ ftp_close
*/
ftpbuf_t*
ftp_close(ftpbuf_t *ftp)
{
if (ftp == NULL) {
return NULL;
}
if (ftp->data) {
data_close(ftp, ftp->data);
}
if (ftp->stream && ftp->closestream) {
TSRMLS_FETCH();
php_stream_close(ftp->stream);
}
if (ftp->fd != -1) {
#if HAVE_OPENSSL_EXT
if (ftp->ssl_active) {
SSL_shutdown(ftp->ssl_handle);
SSL_free(ftp->ssl_handle);
}
#endif
closesocket(ftp->fd);
}
ftp_gc(ftp);
efree(ftp);
return NULL;
}
/* {{{ ftp_close
*/
ftpbuf_t*
ftp_close(ftpbuf_t *ftp)
{
if (ftp == NULL) {
return NULL;
}
if (ftp->data) {
data_close(ftp, ftp->data);
}
if (ftp->stream && ftp->closestream) {
php_stream_close(ftp->stream);
}
if (ftp->fd != -1) {
#ifdef HAVE_FTP_SSL
if (ftp->ssl_active) {
SSL_shutdown(ftp->ssl_handle);
SSL_free(ftp->ssl_handle);
}
#endif
closesocket(ftp->fd);
}
ftp_gc(ftp);
efree(ftp);
return NULL;
}
void muste_nterm(int argc, char *argv[])
{
int i;
/*
if (argc==1)
{
Rprintf("This program can be used as a SURVO 84C module only.");
return;
}
*/
s_init(argv[1]);
i=init_sequence();
if (i<0) { s_end(argv[1]); return; }
i=init_regressors();
if (i<0) return;
i=linear_regression(seq_n,10);
if (i<0) return;
data_close(&data);
edwrite(nterm_output_buffer,nterm_output_line,1);
s_end(argv[1]);
}
void rtmp_server::handle_sock_error(int sock, basic_class *bcptr)
{
delete dynamic_cast<rtmp_viewer *> (bcptr);
// _net_ptr->fd_del_hdl_map_delete(sock);
del_seed(sock);
data_close(sock, "client closed!!");
_pk_mgr_ptr->del_stream(sock,(stream *)bcptr, STRM_TYPE_MEDIA);
}
void muste_linco(char *argv)
{
int i;
// RS 5.5.2014 Variable init
// SURVO_DATA d;
A=NULL;
rlab=NULL;
clab=NULL;
rdim=cdim=lr=lc=type=0;
expr[0]=EOS;
matname[0]=EOS;
pros=0;
var=NULL;
y=NULL;
outvar=NULL;
lag=NULL;
act=0;
// if (argc==1) return;
s_init(argv);
if (g<3)
{
sur_print("\nUsage: LINCO <SURVO_data>,<matrix_of_coefficients>");
WAIT; return;
}
i=data_open2(word[1],&d,1,0,0); if (i<0) return;
/* tilaa uusille muuttujille */
i=spec_init(r1+r-1); if (i<0) return;
pros=0;
act='A'; i=spfind("ACT");
if (i>=0) act=*spb[i];
i=conditions(&d); if (i<0) return; /* permitted only once */
i=matparam(); if (i<0) return;
i=matrix_load(matname,&A,&rdim,&cdim,&rlab,&clab,&lr,&lc,&type,expr);
if (i<0) return;
i=varaa_tilat(); if (i<0) return;
i=find_variables();
if (i<0)
{
if (etu==2)
{
sprintf(tut_info,"___@%d@LINCO@Error in LINCO@",-i);
s_end(argv[1]); return;
}
return;
}
linear_combinations();
data_close(&d);
s_end(argv);
}
/* {{{ ftp_nb_get
*/
int
ftp_nb_get(ftpbuf_t *ftp, php_stream *outstream, const char *path, const size_t path_len, ftptype_t type, zend_long resumepos)
{
databuf_t *data = NULL;
char arg[11];
if (ftp == NULL) {
return PHP_FTP_FAILED;
}
if (!ftp_type(ftp, type)) {
goto bail;
}
if ((data = ftp_getdata(ftp)) == NULL) {
goto bail;
}
if (resumepos>0) {
int arg_len = snprintf(arg, sizeof(arg), ZEND_LONG_FMT, resumepos);
if (arg_len < 0) {
goto bail;
}
if (!ftp_putcmd(ftp, "REST", sizeof("REST")-1, arg, arg_len)) {
goto bail;
}
if (!ftp_getresp(ftp) || (ftp->resp != 350)) {
goto bail;
}
}
if (!ftp_putcmd(ftp, "RETR", sizeof("RETR")-1, path, path_len)) {
goto bail;
}
if (!ftp_getresp(ftp) || (ftp->resp != 150 && ftp->resp != 125)) {
goto bail;
}
if ((data = data_accept(data, ftp)) == NULL) {
goto bail;
}
ftp->data = data;
ftp->stream = outstream;
ftp->lastch = 0;
ftp->nb = 1;
return (ftp_nb_continue_read(ftp));
bail:
ftp->data = data_close(ftp, data);
return PHP_FTP_FAILED;
}
static int xall(void)
{
int i,j,k;
double x,y;
int var1;
int vartotal;
int howmany;
i=data_open(word[1],&d); if (i<0) return -1;
i=mask(&d); if (i<0) return -1;
i=conditions(&d); if (i<0) return -1;
var1=varfind(&d,word[2]); if (var1<0) return -1;
vartotal=atoi(word[3]);
if (g>4) howmany=atoi(word[4]); else howmany=1;
if (howmany<1) return -1;
muste_kv_s_disp("\nConverting \"X ALL\" responses in %d variables...", vartotal);
muste_kv_s_disp("\nMoving values of %d variables at a time...", howmany);
if ((var1+howmany*vartotal) > d.m) {
muste_kv_s_err("Not enough variables after %s!", word[2]);
return -1;
}
for (j=d.l1; j<=d.l2; j++) {
if (unsuitable(&d,j)) continue;
muste_kv_s_disp(" %d",j);
for (i=(var1+howmany*vartotal-howmany); i>=var1; i-=howmany) {
data_load(&d,j,i,&x);
if (x==MISSING8) {
data_save(&d,j,i,MISSING8); /* (data in edit field) */
for (k=1; k<howmany; k++) { /* 31.5.97 */
data_save(&d,j,i+k,MISSING8);
}
continue;
}
if (howmany==1 && ((int)x == i)) continue;
if (((int)x < 1) || ((int)x > vartotal)) continue; /* 20.5.97 */
data_save(&d,j,i,MISSING8);
data_save(&d,j,var1+howmany*(int)x-howmany,x);
for (k=1; k<howmany; k++) { /* 20.5.97 */
data_load(&d,j,i+k,&y);
data_save(&d,j,i+k,MISSING8);
data_save(&d,j,var1+howmany*(int)x-howmany+k,y);
}
}
}
data_close(&d);
return 1;
}
/* {{{ ftp_nb_put
*/
int
ftp_nb_put(ftpbuf_t *ftp, const char *path, php_stream *instream, ftptype_t type, zend_long startpos)
{
databuf_t *data = NULL;
char arg[11];
if (ftp == NULL) {
return 0;
}
if (!ftp_type(ftp, type)) {
goto bail;
}
if ((data = ftp_getdata(ftp)) == NULL) {
goto bail;
}
if (startpos > 0) {
snprintf(arg, sizeof(arg), ZEND_LONG_FMT, startpos);
if (!ftp_putcmd(ftp, "REST", arg)) {
goto bail;
}
if (!ftp_getresp(ftp) || (ftp->resp != 350)) {
goto bail;
}
}
if (!ftp_putcmd(ftp, "STOR", path)) {
goto bail;
}
if (!ftp_getresp(ftp) || (ftp->resp != 150 && ftp->resp != 125)) {
goto bail;
}
if ((data = data_accept(data, ftp)) == NULL) {
goto bail;
}
ftp->data = data;
ftp->stream = instream;
ftp->lastch = 0;
ftp->nb = 1;
return (ftp_nb_continue_write(ftp));
bail:
ftp->data = data_close(ftp, data);
return PHP_FTP_FAILED;
}
WsStream *ws_stream_new_data_input(const unsigned char *data, size_t data_len)
{
WsStreamDataInputCtx *ctx = ws_calloc(1, sizeof(*ctx));
WsStream *stream;
if (ctx == NULL)
return NULL;
ctx->data = data;
ctx->data_len = data_len;
stream = ws_stream_new(ctx, data_input, NULL, data_close);
if (stream == NULL)
/* The stream creation failed. Close the stream context. */
data_close(ctx);
return stream;
}
/* {{{ ftp_close
*/
ftpbuf_t*
ftp_close(ftpbuf_t *ftp)
{
if (ftp == NULL) {
return NULL;
}
if (ftp->data) {
data_close(ftp, ftp->data);
}
if (ftp->fd != -1) {
#if HAVE_OPENSSL_EXT
if (ftp->ssl_active) {
SSL_shutdown(ftp->ssl_handle);
}
#endif
closesocket(ftp->fd);
}
ftp_gc(ftp);
efree(ftp);
return NULL;
}
/* {{{ ftp_get
*/
int
ftp_get(ftpbuf_t *ftp, php_stream *outstream, const char *path, ftptype_t type, zend_long resumepos)
{
databuf_t *data = NULL;
size_t rcvd;
char arg[11];
if (ftp == NULL) {
return 0;
}
if (!ftp_type(ftp, type)) {
goto bail;
}
if ((data = ftp_getdata(ftp)) == NULL) {
goto bail;
}
ftp->data = data;
if (resumepos > 0) {
snprintf(arg, sizeof(arg), ZEND_LONG_FMT, resumepos);
if (!ftp_putcmd(ftp, "REST", arg)) {
goto bail;
}
if (!ftp_getresp(ftp) || (ftp->resp != 350)) {
goto bail;
}
}
if (!ftp_putcmd(ftp, "RETR", path)) {
goto bail;
}
if (!ftp_getresp(ftp) || (ftp->resp != 150 && ftp->resp != 125)) {
goto bail;
}
if ((data = data_accept(data, ftp)) == NULL) {
goto bail;
}
while ((rcvd = my_recv(ftp, data->fd, data->buf, FTP_BUFSIZE))) {
if (rcvd == -1) {
goto bail;
}
if (type == FTPTYPE_ASCII) {
#ifndef PHP_WIN32
char *s;
#endif
char *ptr = data->buf;
char *e = ptr + rcvd;
/* logic depends on the OS EOL
* Win32 -> \r\n
* Everything Else \n
*/
#ifdef PHP_WIN32
php_stream_write(outstream, ptr, (e - ptr));
ptr = e;
#else
while (e > ptr && (s = memchr(ptr, '\r', (e - ptr)))) {
php_stream_write(outstream, ptr, (s - ptr));
if (*(s + 1) == '\n') {
s++;
php_stream_putc(outstream, '\n');
}
ptr = s + 1;
}
#endif
if (ptr < e) {
php_stream_write(outstream, ptr, (e - ptr));
}
} else if (rcvd != php_stream_write(outstream, data->buf, rcvd)) {
goto bail;
}
}
ftp->data = data = data_close(ftp, data);
if (!ftp_getresp(ftp) || (ftp->resp != 226 && ftp->resp != 250)) {
goto bail;
}
return 1;
bail:
ftp->data = data_close(ftp, data);
return 0;
}
int
ftp_put(ftpbuf_t *ftp, const char *path, FILE *infp, ftptype_t type)
{
databuf_t *data = NULL;
int size;
char *ptr;
int ch;
if (ftp == NULL)
return 0;
if (!ftp_type(ftp, type))
goto bail;
if ((data = ftp_getdata(ftp)) == NULL)
goto bail;
if (!ftp_putcmd(ftp, "STOR", path))
goto bail;
if (!ftp_getresp(ftp) || (ftp->resp != 150 && ftp->resp != 125))
goto bail;
if ((data = data_accept(data)) == NULL)
goto bail;
size = 0;
ptr = data->buf;
while ((ch = getc(infp)) != EOF) {
/* flush if necessary */
if (FTP_BUFSIZE - size < 2) {
if (my_send(data->fd, data->buf, size) != size)
goto bail;
ptr = data->buf;
size = 0;
}
if (ch == '\n' && type == FTPTYPE_ASCII) {
*ptr++ = '\r';
size++;
}
*ptr++ = ch;
size++;
}
if (size && my_send(data->fd, data->buf, size) != size)
goto bail;
if (ferror(infp))
goto bail;
data = data_close(data);
if (!ftp_getresp(ftp) || (ftp->resp != 226 && ftp->resp != 250))
goto bail;
return 1;
bail:
data_close(data);
return 0;
}
void muste_rndtest(char *argv)
{
int i;
char xx[LLENGTH],*sana[4];
s_init(argv);
if (g<3)
{
init_remarks();
rem_pr("Usage: RNDTEST <SURVO_data>,<variable>,<output_line>");
rem_pr("This Survo operation makes empirical statistical tests on a series");
rem_pr("numbers supposed to form a random sample from a uniform distribution");
rem_pr("in the interval (0,1).");
rem_pr("Most of these tests are explained in Volume 2 of \"The Art of Programming\"");
rem_pr("by Donald E. Knuth.");
rem_pr("The main application of RNDTEST is testing of various random number");
rem_pr("generators.");
rem_pr("");
rem_pr("A standard set of tests is performed without any extra specification.");
rem_pr("However, If RESULTS=0, no test is performed without explicit specifica-");
rem_pr("tions. To select tests in a more detailed form, following specifications");
rem_pr("can be given.");
rem_pr("");
rem_pr("SUBSAMPLES=<size>,<# of classes>");
rem_pr("The sample is divided systematically in subsamples of given <size>");
rem_pr("and their uniformity is tested by the standard Chi^2-test by divi-");
rem_pr("ding the interval (0,1) in <# of classes>.");
rem_pr("Also tests for mean=0.5 as well for the minimum ans maximum values");
rem_pr("in subsamples are made.");
rem_pr("Default is SUBSAMPLES=0 (i.e. this test is omitted).");
wait_remarks(1);
rem_pr("");
rem_pr("FREQUENCIES=<# of classes>,<lower limit>,<upper limit>");
rem_pr("The uniformity of the total sample is tested by the Chi^2-test.");
rem_pr("Default: FREQUENCIES=10,0,1");
rem_pr("");
rem_pr("MAXLAG=<largest_lag>");
rem_pr("The autocorrelations of the series are computed up to the given");
rem_pr("maximum lag. Default: MAXLAG=10");
rem_pr("");
rem_pr("GAPTEST=<lower_limit>,<upper_limit>,<max.gap>");
rem_pr("The lengths of gaps between occurrences of values in the given range");
rem_pr("are computed.");
rem_pr("Default: GAPTEST=0,0.5,10");
rem_pr("");
rem_pr("PERMTEST=<# of consecutive numbers (3,4,5,6 or 7)>");
rem_pr("Frequencies of different permutations of relative orderings are computed.");
rem_pr("Default: PERMTEST=4");
rem_pr("");
rem_pr("POKER=<# of obs.>,<# of classes>,<lower limit>,<upper_limit>");
rem_pr("Default: POKER=5,5,0,1");
wait_remarks(1);
rem_pr("");
rem_pr("COUPON=<# of classes>,<max_len>,<lower limit>,<upper limit>");
rem_pr("Coupon collector's test");
rem_pr("Default: COUPON=5,20,0,1");
rem_pr("");
rem_pr("Certain run tests are performed in any case.");
wait_remarks(2);
return;
}
p_mean=NULL;
p_min=NULL;
p_max=NULL;
fr_f=NULL;
lagv=NULL;
lagvv=NULL;
first_x=NULL;
gap=NULL;
f_perm=NULL;
f_pok=NULL;
s_pok=NULL;
f1_pok=NULL;
f_coup=NULL;
coup_ind=NULL;
s_coup=NULL;
i=spec_init(r1+r-1); if (i<0) return;
for(i=0; i<MAXRUN; ++i) runs_up[i]=runs_down[i]=0;
n_sub=0;
i=spfind("SUBSAMPLES");
if (i>=0)
{
strcpy(xx,spb[i]); i=split(xx,sana,2);
if (i<1) { sur_print("\nUsage: SUBSAMPLES=<size>,<# of classes>");
WAIT; return;
}
n_sub=atoi(sana[0]); n_subclass=10;
if (i>1) n_subclass=atoi(sana[1]);
}
if (results==0) fr_n=0; else { fr_n=10; fr_a=0.0; fr_d=0.1; }
i=spfind("FREQUENCIES");
if (i>=0)
{
strcpy(xx,spb[i]); i=split(xx,sana,3);
if (i<3) { sur_print("\nUsage: FREQUENCIES=<# of classes>,<lower_limit>,<upper_limit>");
WAIT; return;
}
fr_n=atoi(sana[0]); fr_a=atof(sana[1]);
fr_d=(atof(sana[2])-fr_a)/(double)fr_n;
}
if (results==0) maxlag=0; else maxlag=10;
i=spfind("MAXLAG"); if (i>=0) maxlag=atoi(spb[i]);
if (results==0) maxgap=0; else { maxgap=10; a_gap=0; b_gap=0.5; }
i=spfind("GAPTEST");
if (i>=0)
{
strcpy(xx,spb[i]); i=split(xx,sana,3);
if (i<2) { sur_print("\nUsage: GAPTEST=<lower_limit>,<upper_limit>,<max.gap>");
WAIT; return;
}
a_gap=atof(sana[0]); b_gap=atof(sana[1]);
maxgap=10; if (i>2) maxgap=atoi(sana[2]);
}
if (results==0) permlen=0; else permlen=4;
i=spfind("PERMTEST");
if (i>=0)
{
permlen=atoi(spb[i]);
if (permlen && (permlen<3 || permlen>7) )
{
sur_print("\nOnly values 0 and 3,4,5,6,7 permitted in PERMTEST");
WAIT; return;
}
}
if (results==0) poklen=0; else { poklen=5; n_pok=5; pok_a=0.0; pok_d=0.2; }
i=spfind("POKER");
if (i>=0)
{
strcpy(xx,spb[i]); i=split(xx,sana,4);
if (i<4) { sur_print("\nUsage: POKER=<# of obs.>,<# of classes>,<l.limit>,<u.limit>");
WAIT; return;
}
poklen=atoi(sana[0]);
n_pok=atoi(sana[1]);
pok_a=atof(sana[2]);
pok_d=(atof(sana[3])-pok_a)/(double)n_pok;
}
if (results==0) couplen=0; else { couplen=5; coup_max=20; coup_a=0.0; coup_d=0.2; }
i=spfind("COUPON");
if (i>=0)
{
strcpy(xx,spb[i]); i=split(xx,sana,4);
if (i<4) { sur_print("\nUsage: COUPON=<# of classes>,<max_len>,<l.limit>,<u.limit>");
WAIT; return;
}
couplen=atoi(sana[0]);
coup_max=atoi(sana[1]);
coup_a=atof(sana[2]);
coup_d=(atof(sana[3])-coup_a)/(double)couplen;
}
results_line=0;
if (g>3)
{
results_line=edline2(word[3],1,1);
if (results_line==0) return;
}
i=data_read_open(word[1],&d); if (i<0) return;
var=varfind(&d,word[2]);
if (var<0) return;
i=sp_init(r1+r-1);
if (i<0) { sur_print("\nToo many specifications!"); WAIT; return; }
i=conditions(&d); if (i<0) return;
i=space_allocation(); if (i<0) { sur_print("\nNot enough memory!"); return; }
i=read_data(); if (i<0) return;
rnd_printout();
data_close(&d);
s_end(argv);
}
void muste_xcorr(char *argv)
{
int i;
s_init(argv);
if (g<4)
{
sur_print("\nUsage: XCORR <data>,<xvar>,<yvar>,L");
WAIT;
return;
}
i=sp_init(r1+r-1);
if (i<0) return;
i=data_read_open(word[1],&d);
if (i<0) return;
xvar=varfind(&d,word[2]);
if (xvar<0) return;
yvar=varfind(&d,word[3]);
if (yvar<0) return;
if (xvar==yvar) autocorr=1;
else autocorr=0;
if (g<5) tulosrivi=0;
else
{
tulosrivi=edline2(word[4],1);
if (tulosrivi==0) return;
}
i=conditions(&d);
if (i<0) return;
i=spfind("MAXLAG");
if (i<0) maxlag=12;
else maxlag=atoi(spb[i]);
if (maxlag<1) maxlag=1;
xx=NULL;
yy=NULL;
xy1=NULL;
xy2=NULL;
x2=NULL;
y2=NULL;
xs1=NULL;
xs2=NULL;
ys1=NULL;
ys2=NULL;
i=varaa_tilat_xcorr();
if (i<0) return;
n=0;
for (i=0; i<maxlag; ++i) xx[i]=yy[i]=xy1[i]=xy2[i]=0.0;
for (i=0; i<maxlag; ++i) xs1[i]=xs2[i]=ys1[i]=ys2[i]=0.0;
xsum=ysum=xsum2=ysum2=0.0;
corr=0.0;
i=lue_datat();
data_close(&d);
if (i<0) return;
if ((int)maxlag>n-1) maxlag=n-1;
tulostus();
s_end(argv);
}
void muste_powers(char *argv)
{
int i,k;
int j;
double a,b;
degree=2;
var_type='8';
s_init(argv);
if (g<2)
{
sur_print("\nUsage: POWERS <SURVO_data>");
sur_print("\n POW_VARS=<list_of_variables>");
sur_print("\n DEGREE=<max_power> TYPE=<1|2|4|8>");
WAIT; return;
}
strcpy(aineisto,word[1]);
i=data_open3(aineisto,&d,1,1,1,1);
if (i<0) { s_end(argv[1]); return; }
i=spec_init(r1+r-1); if (i<0) return;
i=conditions(&d); if (i<0) { s_end(argv[1]); return; }
i=list_of_vars(); if (i<0) return;
i=spfind("DEGREE");
if (i>=0) degree=atoi(spb[i]);
if (degree>MAX_POW)
{
sprintf(sbuf,"\nMax. degree is %d.",MAX_POW);
sur_print(sbuf); WAIT; return;
}
i=spfind("TYPE");
if (i>=0) var_type=*spb[i];
i=power_combinations(); if (i<0) return;
for (j=1L; j<=d.n; ++j)
{
for (i=0; i<nvar; ++i)
{
if (unsuitable(&d,j)) continue;
data_load(&d,j,var_ind[i],&a);
// Rprintf("\nvar=%d a=%g|",vara); getch();
val[i][1]=a; b=a;
for (k=2; k<=degree; ++k)
{
b*=a;
val[i][k]=b;
// Rprintf("\nval: %d %d %g %g|",i,k,a,val[i][k]); getch();
}
}
for (k=0; k<ncomb; ++k)
{
a=1.0;
for (i=0; i<nvar; ++i)
if (pow_v[k][i]>0) a*=val[i][pow_v[k][i]];
// Rprintf("\na=%g|",a); getch();
data_save(&d,j,pow_ind[k],a);
}
}
data_close(&d); // 8.8.2011/SM
s_end(argv);
}
void muste_t2test(char *argv)
{
int i,k;
int l,l2;
// if (argc==1) return(1);
s_init(argv);
if (g<3)
{
sur_print("\nUsage: T2TEST <data1>,<data2>,<output_line>");
WAIT; return;
}
tulosrivi=0;
if (g>3)
{
tulosrivi=edline2(word[3],1,1);
if (tulosrivi==0) return;
}
simumax=10000;
i=spec_init(r1+r-1); if (i<0) return;
if ((i=spfind("RESULTS"))>=0) results=atoi(spb[i]);
x=NULL;
v=NULL;
xx=NULL;
ind=NULL;
s=NULL;
s2=NULL;
ss[0]=NULL;
ss2[0]=NULL;
ss[1]=NULL;
ss2[1]=NULL;
ss_inv=NULL;
ss_apu=NULL;
ss_apu2=NULL;
ero=NULL;
i=hae_apu("prind",sbuf); if (i) prind=atoi(sbuf);
if ((i=spfind("PRIND"))>=0) prind=atoi(spb[i]);
if ((i=spfind("SIMUMAX"))>=0) simumax=atol(spb[i]);
method=1;
if ((i=spfind("METHOD"))>=0) method=atoi(spb[i]);
fixed=0;
if ((i=spfind("FIXED"))>=0) fixed=atoi(spb[i]);
orig_samples=1;
spec_rnd();
strcpy(tempname,etmpd); strcat(tempname,"SURVOHOT.TMP");
tempfile=muste_fopen(tempname,"wb");
if (tempfile==NULL)
{
sprintf(sbuf,"\nCannot open temporary file %s!",tempname);
sur_print(sbuf); WAIT; return;
}
strcpy(aineisto[0],word[1]);
i=data_read_open(aineisto[0],&d); if (i<0) return;
i=mask(&d); if (i<0) return;
m=d.m_act;
if (m==0)
{
sur_print("\nNo active variables!");
WAIT; return;
}
x=(double *)muste_malloc(m*sizeof(double));
if (x==NULL) { not_enough_memory(); return; }
v=(int *)muste_malloc(m*sizeof(int));
if (v==NULL) { not_enough_memory(); return; }
for (i=0; i<m; ++i) v[i]=d.v[i];
sur_print("\n");
talleta(1); /* data 1 */
data_close(&d);
strcpy(aineisto[1],word[2]);
i=data_read_open(aineisto[1],&d); if (i<0) return;
i=mask(&d); if (i<0) return;
if (d.m_act!=m) { data_error(); return; }
for (i=0; i<m; ++i)
{
if (v[i]!=d.v[i]) {data_error(); return; }
}
talleta(2); /* data 2 */
data_close(&d);
muste_fclose(tempfile);
n[0]=n[1]+n[2];
tempfile=muste_fopen(tempname,"rb");
xx=(double *)muste_malloc(n[0]*m*sizeof(double));
if (xx==NULL) { not_enough_memory(); return; }
fread(xx,sizeof(double),n[0]*(int)m,tempfile);
muste_fclose(tempfile);
ind=muste_malloc(n[0]);
if (ind==NULL) { not_enough_memory(); return; }
s=muste_malloc(m*sizeof(double));
if (s==NULL) { not_enough_memory(); return; }
s2=muste_malloc(m*m*sizeof(double));
if (s2==NULL) { not_enough_memory(); return; }
for (l=0; l<n[0]; ++l) ind[l]='1';
laske_summat(s,s2);
// Rprintf("s: %g %g\n",s[0],s[1]); getch();
ss[0]=muste_malloc(m*sizeof(double));
if (ss[0]==NULL) { not_enough_memory(); return; }
ss2[0]=muste_malloc(m*m*sizeof(double));
if (ss2[0]==NULL) { not_enough_memory(); return; }
ss[1]=muste_malloc(m*sizeof(double));
if (ss[1]==NULL) { not_enough_memory(); return; }
ss2[1]=muste_malloc(m*m*sizeof(double));
if (ss2[1]==NULL) { not_enough_memory(); return; }
ss_inv=muste_malloc(m*m*sizeof(double));
if (ss_inv==NULL) { not_enough_memory(); return; }
ss_apu=muste_malloc(m*m*sizeof(double));
if (ss_apu==NULL) { not_enough_memory(); return; }
ss_apu2=muste_malloc(m*m*sizeof(double));
if (ss_apu2==NULL) { not_enough_memory(); return; }
ero=muste_malloc(m*sizeof(double));
if (ero==NULL) { not_enough_memory(); return; }
// Todelliset otokset
for (l=0; l<n[0]; ++l) ind[l]='0';
for (l=0; l<n[1]; ++l) ind[l]='1';
t2_0=T2();
p_hot=1.0-muste_cdf_f((double)(n[0]-m-1)/(n[0]-2)/(double)m*t2_0,
(double)m,(double)(n[1]+n[2]-m-1),1e-15);
if (method==2)
{
t2_BF0=T2_BF();
yao_test();
print_t2_yao();
}
// Rprintf("\nt2: %g %g",t2_0,t2_BF0); getch();
else
print_t2_hot();
if (fixed) orig_samples=0;
++scroll_line;
nn1=0L; k=0;
if (simumax) sur_print("\nInterrupt by '.'");
for (nn=1; nn<=simumax; ++nn)
{
// Rprintf("\nnn=%d",nn);
for (l=0; l<n[0]; ++l) ind[l]='0';
for (l=0; l<n[1]; ++l)
{
while (1)
{
l2=n[0]*uniform_dev();
if (ind[l2]=='1') continue;
ind[l2]='1'; break;
}
}
if (method==1)
{
t2_1=T2();
// Rprintf("t2: %g %g\n",t2_1,t2_0); getch();
if (t2_1>t2_0) ++nn1;
}
else
{
t2_1=T2_BF();
// Rprintf("t2: %g %g\n",t2_1,t2_BF0); getch();
if (t2_1>t2_BF0) ++nn1;
}
++k;
// Rprintf("t2=%g\n",t2_1); i=getch(); if (i=='.') break;
/**********************************
if (sur_kbhit())
{
i=sur_getch(); if (i=='.') break;
prind=1-prind;
}
***********************************/
if (k>=1000 && prind)
{
sprintf(sbuf,"\n%d %g ",nn,(double)nn1/(double)nn);
sur_print(sbuf);
k=0;
}
}
// Rprintf("4"); sur_getch();
output_open(eout);
--nn;
if (method==1)
{
eoutput("Hotelling's two-sample test for equality of mean vectors:");
sprintf(sbuf,"T2=%g p=%d n1=%d n2=%d P1=%g",
t2_0,m,n[1],n[2],p_hot);
}
else
{
eoutput("Yao's two-sample test for equality of mean vectors:");
sprintf(sbuf,"T2=%g P1=%g (assuming nonequal cov.matrices)",
t2_BF0,p_yao);
}
eoutput(sbuf);
if (simumax>0L)
{
eoutput("Randomization test:");
p_sim=(double)nn1/(double)nn;
sprintf(sbuf,"N=%d P=%g (s.e. %g) %s",
nn,p_sim,sqrt(p_sim*(1-p_sim)/nn),method_text[method-1]);
eoutput(sbuf);
}
output_close(eout);
s_end(argv);
return;
}
void muste_covtest(char *argv)
{
int i,k,h,kk;
int l,l2,li;
// if (argc==1) return(1);
s_init(argv[1]);
if (g<2)
{
sur_print("\nUsage: COVTEST <output_line>");
sur_print("\n SAMPLES=<data(1),...,<data(m)>");
WAIT; return;
}
tulosrivi=0;
if (g>1)
{
tulosrivi=edline2(word[1],1,1);
if (tulosrivi==0) return;
}
i=spec_init(r1+r-1); if (i<0) return;
if ((i=spfind("RESULTS"))>=0) results=atoi(spb[i]);
i=hae_apu("prind",sbuf); if (i) prind=atoi(sbuf);
if ((i=spfind("PRIND"))>=0) prind=atoi(spb[i]);
simumax=10000;
if ((i=spfind("SIMUMAX"))>=0) simumax=atol(spb[i]);
spec_rnd();
strcpy(tempname,etmpd); strcat(tempname,"SURVOCOV.TMP");
tempfile=fopen(tempname,"wb");
if (tempfile==NULL)
{
sprintf(sbuf,"\nCannot open temporary file %s!",tempname);
sur_print(sbuf); WAIT; return;
}
i=spfind("SAMPLES");
if (i<0)
{
sur_print("SAMPLES=<data(1),...,<data(m)> missing!");
WAIT; return;
}
strcpy(y,spb[i]);
ns=split(y,otos,S_MAX);
if (ns<2)
{
sur_print("At least 2 samples must be given by SAMPLES!");
WAIT; return;
}
x=NULL;
v=NULL;
xx=NULL;
ind=NULL;
nt=0L;
for (k=0; k<ns; ++k)
{
strcpy(aineisto,otos[k]);
i=data_read_open(aineisto,&d); if (i<0) return;
i=mask(&d); if (i<0) return;
if (d.m_act==0)
{
sur_print("\nNo active variables!");
WAIT; return;
}
if (k==0)
{
m=d.m_act;
x=(double *)muste_malloc(m*sizeof(double));
if (x==NULL) { not_enough_memory(); return; }
v=(int *)muste_malloc(m*sizeof(int));
if (v==NULL) { not_enough_memory(); return; }
for (i=0; i<m; ++i) v[i]=d.v[i];
}
if (k!=0)
{
if (d.m_act!=m) { data_error(k); return; }
for (i=0; i<m; ++i)
{
if (v[i]!=d.v[i]) { data_error(k); return; }
}
}
sur_print("\n");
talleta(k); /* data k */
data_close(&d);
}
muste_fclose(tempfile);
tempfile=fopen(tempname,"rb");
xx=(double *)muste_malloc(nt*m*sizeof(double));
if (xx==NULL) { not_enough_memory(); return; }
fread(xx,sizeof(double),nt*(int)m,tempfile);
muste_fclose(tempfile);
ind=muste_malloc(sizeof(short)*nt);
if (ind==NULL) { not_enough_memory(); return; }
for (k=0; k<ns+1; ++k)
{
s[k]=NULL;
s[k]=muste_malloc(m*sizeof(double));
if (s[k]==NULL) { not_enough_memory(); return; }
s2[k]=NULL;
s2[k]=muste_malloc(m*m*sizeof(double));
if (s2[k]==NULL) { not_enough_memory(); return; }
}
l=0;
for (k=0; k<ns; ++k)
for (li=0L; li<n[k]; ++li) ind[l++]=k;
laske_summat();
l=0;
for (k=0; k<ns; ++k)
for (li=0; li<n[k]; ++li)
{
for (h=0; h<m; ++h)
xx[l+h]-=s[k][h]/n[k];
l+=m;
}
t0=testi();
os1=(double)(nt-ns)*m/2*log((double)(nt-ns));
nim2=0.0; a=0.0;
for (k=0; k<ns; ++k)
{
nim2+=(n[k]-1)*muste_log((double)(n[k]-1));
a+=1.0/(n[k]-1);
}
x2=t0/2+os1-(double)m/2*nim2;
a=1-(a-1.0/(nt-ns))*(2*m*m+3*m-1)/6.0/(m+1)/(k-1);
x2*=-2*a;
// Rprintf("x2=%g\n",x2); getch();
df=(double)m/2*(m+1)*(ns-1);
pr_x2=1.0-muste_cdf_chi2(x2,df,1e-7);
/*****************************************************
os1=n*p/2*log(n)
os1=10326.054776478
os2=0.5*(n1*log(det1)+n2*log(det2)+n3*log(det3))
os2=8299.3933358899
nim1=n/2*log(det)
nim1=9932.2525957076
nim2=p/2*(n1*log(n1)+n2*log(n2)+n3*log(n3))
nim2=8697.69129334
logL=os1+os2-nim1-nim2
logL=-4.4957766798343
a=1-(1/n1+1/n2+1/n3-1/n)*(2*p*p+3*p-1)/6/(p+1)/(k-1)
X2=-2*a*logL
X2=8.9516537694752
df=p/2*(p+1)*(k-1)
********************************************************/
print_t0(x2,df,pr_x2);
++scroll_line;
nn1=0L; kk=0;
for (nn=1; nn<=simumax; ++nn)
{
for (l=0; l<nt; ++l) ind[l]=0;
for (k=1; k<ns; ++k)
{
for (l=0L; l<n[k]; ++l)
{
while (1)
{
l2=nt*uniform_dev();
if (ind[l2]!=(short)0) continue;
ind[l2]=k; break;
}
}
}
t1=testi();
if (t1<t0) ++nn1;
++kk;
/*************************
if (kbhit())
{
i=getch(); if (i=='.') break;
prind=1-prind;
}
******************************/
if (kk==1000)
{
if (prind)
{
sprintf(sbuf,"\n%d %g ",nn,(double)nn1/(double)nn);
sur_print(sbuf);
}
kk=0;
}
}
output_open(eout);
--nn;
eoutput("Comparing covariance matrices:");
sprintf(sbuf,"Asymptotic X^2 test: X2=%g df=%g P=%g",x2,df,pr_x2);
eoutput(sbuf);
p_sim=(double)nn1/(double)nn;
sprintf(sbuf,"Randomization test: N=%d P=%g (s.e. %g)",
nn,p_sim,sqrt(p_sim*(1-p_sim)/nn));
eoutput(sbuf);
output_close(eout);
s_end(argv);
return;
}
void muste_statmsf(char *argv)
{
int i;
// RS Variable init
prind=1;
sum=NULL;
sum2=NULL;
f=NULL;
w=NULL;
f2=NULL;
X=NULL;
rlabX=NULL;
clabX=NULL;
T=NULL;
rlabT=NULL;
clabT=NULL;
v=NULL;
s_init(argv);
typeT=lrT=lcT=0; // to avoid warnings from compiler
// specs=spec_msf;
if (g<2)
{
init_remarks();
rem_pr("STATMSF <Survo_data>,<output_line> ");
rem_pr(" LIMITS=<low1>,<up1>,<up2>,...");
rem_pr("computes means, standard deviations, and frequency distributions");
rem_pr("of active variables. Cases can be limited by IND and CASES specifications.");
rem_pr("The frequencies are computed according to a classification given by the");
rem_pr("LIMITS specification where <low1> is the lower limit of the first class 1");
rem_pr("and <up1>,<up2>,... are the upper limits of the classes 1,2,...");
rem_pr("The default setting is LIMITS=0,1,2,3,4,5 .");
wait_remarks(1);
rem_pr("STATMSF <Survo_data> / TRESHOLDS=<matrix_file>");
rem_pr("where <matrix_file> is of the form");
rem_pr("row label 1st column");
rem_pr("variable_1 treshold_value_1");
rem_pr("variable_2 treshold_value_2");
rem_pr("...");
rem_pr("computes relative frequencies of values exceeding treshold values");
rem_pr("given as the first column of <matrix_file> for variables given");
rem_pr("as row labels in <matrix_file> for active observations");
rem_pr("in <Survo_data>.");
rem_pr("The results are saved in a matrix file TAILFREQ.M .");
wait_remarks(2);
return;
}
results_line=0;
i=spec_init(r1+r-1); if (i<0) return;
i=spfind("PRIND"); if (i>=0) prind=atoi(spb[i]);
i=spfind("TRESHOLDS");
if (i>=0) { pvalues(i); return; }
if (g>2)
{
results_line=edline2(word[2],1,1);
if (results_line==0) return;
}
i=data_read_open(word[1],&d); if (i<0) return;
i=spfind("LIMITS");
if (i<0)
{
n_class=5; limit[0]=0;
for (i=1; i<=5; ++i) limit[i]=i;
}
else
{
strcpy(x,spb[i]);
n_class=split(x,osa,MAXCLASS);
for (i=0; i<n_class; ++i) limit[i]=atof(osa[i]);
--n_class;
}
i=mask(&d); if (i<0) return;
weight_variable=activated(&d,'W');
i=m_test_scaletypes(); if (i<0) return;
i=conditions(&d); if (i<0) return; /* permitted only once */
m=d.m_act;
if (m==0)
{
sur_print("\nNo active (acceptable) variables!");
WAIT; return;
}
i=m_space_allocation(); if (i<0) return;
// i=optdim_d(); if (i && i<d.m) err(0);
// i=optdim_o(); if (i && (long)i<d.n) err(0);
compute_sums();
m_printout();
data_close(&d);
s_end(argv);
}
void muste_cluster(char *argv)
{
int i,k;
double a;
char ch;
// if (argc==1) return;
s_init(argv);
if (g<2)
{
sur_print("\nUsage: CLUSTER <SURVO_data>,<output_line>");
WAIT; return;
}
tulosrivi=0;
if (g>2)
{
tulosrivi=edline2(word[2],1,1);
if (tulosrivi==0) return;
}
strcpy(aineisto,word[1]);
i=data_open(aineisto,&d); if (i<0) return;
i=sp_init(r1+r-1); if (i<0) return;
i=mask(&d); if (i<0) return;
scales(&d);
i=conditions(&d); if (i<0) return;
gvar=activated(&d,'G');
if (gvar<0)
{
sur_print("\nNo grouping variable (activated by 'G') given!");
WAIT; return;
}
ivar=-1; ivar=activated(&d,'I');
i=spfind("TRIALS");
if (i>=0) maxiter=atoi(spb[i]);
i=rand_init(); if (i<0) return; /* 30.4.1994 */
i=spfind("TEMPFILE");
if (i>=0) strcpy(tempfile,spb[i]);
else { strcpy(tempfile,etmpd); strcat(tempfile,"SURVO.CLU"); }
i=spfind("PRIND");
if (i>=0 && atoi(spb[i])>0) prind=1;
data_load(&d,1L,gvar,&a);
i=data_save(&d,1L,gvar,a);
if (i<0) return;
gvar2=(int *)muste_malloc(d.m_act*sizeof(int));
if (gvar2==NULL) { not_enough_memory(); return; }
k=0; n_saved=0; m=0;
for (i=0; i<d.m_act; ++i)
{
ch=d.vartype[d.v[i]][1];
if (ch=='G')
{
++k;
gvar2[n_saved]=d.v[i]; /* gvar=gvar2[0] */
++n_saved; continue;
}
if (ch=='I') { ++k; continue; }
d.v[m++]=d.v[i];
}
/*
printf("\nivar=%d gvar=%d m=%d\n",ivar,gvar,m); getch();
for (i=0; i<m; ++i) Rprintf(" %d",d.v[i]); getch();
printf("\n"); for (i=0; i<n_saved; ++i) Rprintf(" %d",gvar2[i]); getch();
*/
i=spfind("GROUPS");
if (i<0) ng=2; else ng=atoi(spb[i]);
if (ng<2) ng=2;
ng2=ng+2;
mn=m; if (mn<ng) mn=ng;
first_line=r+1; if (r+n_saved>r3) first_line=1;
n_show=n_saved; if (n_show>r3) n_show=r3;
i=varaa_tilat(); if (i<0) return;
i=lue_havainnot(); if (i<0) return;
hav_muistissa=havainnot_muistiin();
ortogonalisoi();
if (ivar_init) alustava_luokittelu();
LOCATE(first_line,1);
SCROLL_UP(first_line,r3+1,r3);
sur_print("\nCluster analysis: Iteration 1:");
while (sur_kbhit()) sur_getch();
it=0;
while (1)
{
while (1)
{
if (it) init_gr();
i=init_tilat();
if (i>=0) break;
if (maxiter==1) return;
}
iteroi();
++it;
if (maxiter>1) vertaa_muihin();
if (it==maxiter) break;
LOCATE(first_line,1);
sprintf(sbuf,"\nIteration %d (Cluster analysis)",it);
sur_print(sbuf);
for (i=0; i<n_show; ++i)
{
if (freq[i]==0) break;
sprintf(sbuf,"\n%d %g %d ",i+1,lambda2[i],freq[i]); sur_print(sbuf);
}
if (sur_kbhit())
{
i=sur_getch(); if (i=='.') break;
}
}
tulosta();
data_close(&d);
sur_delete(tempfile);
s_end(argv);
}
/* {{{ ftp_put
*/
int
ftp_put(ftpbuf_t *ftp, const char *path, php_stream *instream, ftptype_t type, zend_long startpos)
{
databuf_t *data = NULL;
zend_long size;
char *ptr;
int ch;
char arg[11];
if (ftp == NULL) {
return 0;
}
if (!ftp_type(ftp, type)) {
goto bail;
}
if ((data = ftp_getdata(ftp)) == NULL) {
goto bail;
}
ftp->data = data;
if (startpos > 0) {
snprintf(arg, sizeof(arg), ZEND_LONG_FMT, startpos);
if (!ftp_putcmd(ftp, "REST", arg)) {
goto bail;
}
if (!ftp_getresp(ftp) || (ftp->resp != 350)) {
goto bail;
}
}
if (!ftp_putcmd(ftp, "STOR", path)) {
goto bail;
}
if (!ftp_getresp(ftp) || (ftp->resp != 150 && ftp->resp != 125)) {
goto bail;
}
if ((data = data_accept(data, ftp)) == NULL) {
goto bail;
}
size = 0;
ptr = data->buf;
while (!php_stream_eof(instream) && (ch = php_stream_getc(instream))!=EOF) {
/* flush if necessary */
if (FTP_BUFSIZE - size < 2) {
if (my_send(ftp, data->fd, data->buf, size) != size) {
goto bail;
}
ptr = data->buf;
size = 0;
}
if (ch == '\n' && type == FTPTYPE_ASCII) {
*ptr++ = '\r';
size++;
}
*ptr++ = ch;
size++;
}
if (size && my_send(ftp, data->fd, data->buf, size) != size) {
goto bail;
}
ftp->data = data = data_close(ftp, data);
if (!ftp_getresp(ftp) || (ftp->resp != 226 && ftp->resp != 250 && ftp->resp != 200)) {
goto bail;
}
return 1;
bail:
ftp->data = data_close(ftp, data);
return 0;
}