RWiener/0000755000175100001440000000000013053307143011642 5ustar hornikusersRWiener/inst/0000755000175100001440000000000012756775466012651 5ustar hornikusersRWiener/inst/CITATION0000644000175100001440000000127712756775466014015 0ustar hornikusersnote <- sprintf("R package version %s", meta$Version) title <- sprintf("%s", meta$Title) author <- sprintf("%s", meta$Author) url <- sprintf("%s", meta$URL) bibentry(bibtype = "article", title="The {RW}iener package: An {R} package providing distribution functions for the Wiener diffusion model", author = c(person("Dominik", "Wabersich"), person("Joachim", "Vandekerckhove")), year = "2014", journal="The R Journal", volume="6", number="1", pages="49--56", note=note, header="If you use the core functions: dwiener(), pwiener(), qwiener() and rwiener(), please cite:" ) RWiener/src/0000755000175100001440000000000013053274532012436 5ustar hornikusersRWiener/src/rwiener.c0000644000175100001440000000575613053274532014272 0ustar hornikusers#include #include #include double r_random_walk(double alpha, double tau, double beta, double delta) { double dt=0.0001; double t,sigma=1; double p = .5 * (1+((delta*sqrt(dt))/sigma)); double a; //double q = .5 * (1-((mu*sqrt(dt))/sigma)); int i = 0; double y = beta*alpha; while(y < alpha && y > 0) { GetRNGstate(); a = unif_rand(); PutRNGstate(); if(a <= p) y = y + sigma*sqrt(dt); else y = y - sigma*sqrt(dt); i++; } if(y >= alpha) t = (i*dt+tau); else t = -(i*dt+tau); return t; } double r_rejection_based(double a, double ter, double z, double v) { /* mere copy of wdmrnd.cpp by JV, only changes: * - return value double instead of void * - removed *t and *x, instead returning t or -t * - added variable t (double) * - replaced GNU gsl with unif_rand() * - absol replaced with fabs * - amin replaced with fmin * - pi replaced with M_PI */ double dt=1e-15,D=.005,totaltime,startpos, Aupper,Alower,radius,lambda,F,prob,tt,dir_,l,s1,s2,tnew,t_delta; int uu; int finish; double t, r; a/=10; z/=10; v/=10; finish = 0; totaltime=0; startpos=0; Aupper=a-z; Alower=-z; radius=fmin(fabs(Aupper),fabs(Alower)); while (!finish) { if (v==0){ lambda = 0.25*D*M_PI*M_PI/(radius*radius); F=1; prob = .5; } else { lambda = 0.25*v*v/D + 0.25*D*M_PI*M_PI/(radius*radius); F=D*M_PI/(radius*v); F=F*F/(1+F*F); prob=exp(radius*v/D); prob=prob/(1+prob); } GetRNGstate(); r = unif_rand(); PutRNGstate(); dir_= rl) { GetRNGstate(); s2 = unif_rand(); PutRNGstate(); GetRNGstate(); s1 = unif_rand(); PutRNGstate(); tnew=0; t_delta=0; uu=0; while ( (fabs(t_delta)>dt) | (!uu) ) { tt = 2*++uu+1; t_delta = tt * (uu%2?-1:1) * pow(s1,(F*tt*tt)); tnew += t_delta; } l = 1 + pow(s1,-F) * tnew; }/*end while (s2>l) */ totaltime+=fabs(log(s1))/lambda; dir_=startpos+dir_*radius; if (dir_+dt>Aupper) { //*t=totaltime+ter; //*x=1; t = totaltime+ter; finish=1; return t; } else { if (dir_-dt #include #include double prob_upperbound(double v, double a, double w) { double e = exp(-2.0 * v * a * (1.0-w)); if(e == R_PosInf) return 1; else if(v == 0 || w == 1) return (1-w); else return ((1 - e) / (exp(2.0*v*a*w) - e)); } double exp_pnorm(double a, double b) { double r=0; if (R_IsNaN(r) && b < -5.5) r = 1/sqrt(2) * exp(a - b*b/2) * (0.5641882/b/b/b - 1/b/sqrt(M_PI)); else r = exp(a) * pnorm(b,0,1,1,0); return r; } int K_large(double q, double v, double a, double w) { double err = 1e-10; double sqrtL1 = sqrt(1/q) * a/M_PI; double sqrtL2 = sqrt(fmax(1.0, -2/q*a*a/M_PI/M_PI * (log(err*M_PI*q/2 * (v*v + M_PI*M_PI/a/a)) + v*a*w + v*v*q/2))); return ceil(fmax(sqrtL1, sqrtL2)); } int K_small(double q, double v, double a, double w, double epsilon) { if(v == 0) return ceil(fmax(0.0, w/2 - sqrt(q)/2/a * qnorm(fmax(0.0, fmin(1.0, epsilon/(2-2*w))),0,1,1,0))); if(v > 0) return(K_small(q, -v, a, w, exp(-2*a*w*v)*epsilon)); double S2 = w - 1 + 0.5/v/a * log(epsilon/2 * (1-exp(2*v*a))); double S3 = (0.535 * sqrt(2*q) + v*q + a*w)/2/a; double S4 = w/2 - sqrt(q)/2/a * qnorm(fmax(0.0, fmin(1.0, epsilon * a / 0.3 / sqrt(2*M_PI*q) * exp(v*v*q/2 + v*a*w))),0,1,1,0); return ceil(fmax(fmax(fmax(S2, S3), S4), 0.0)); } double Fl_lower(double q, double v, double a, double w, int K) { double F=0; for(int k=K; k>=1; k--) F = F - k / (v*v*1.0 + k*k*M_PI*M_PI/(a*1.0)/a) * exp(-v*a*w*1.0 - 0.5*v*v*q - 0.5*k*k*M_PI*M_PI/(a*1.0)/a*q) * sin(M_PI*k*w); return prob_upperbound(v, a, w) + 2.0*M_PI/(a*1.0)/a * F; } double Fs0_lower(double q, double a, double w, int K) { double F=0; for(int k=K; k>=0; k--) { F = F - pnorm((-2*k - 2 + w)*a/sqrt(q),0,1,1,0) + pnorm((-2*k - w)*a/sqrt(q),0,1,1,0); } return 2*F; } double Fs_lower(double q, double v, double a, double w, int K) { if (v == 0) return(Fs0_lower(q, a, w, K)); double S1=0,S2=0; double sqt = sqrt(q); for(int k=K; k>=1; k--) { S1 = S1 + exp_pnorm(2*v*a*k, -sign(v)*(2*a*k+a*w+v*q)/sqt) - exp_pnorm(-2*v*a*k - 2*v*a*w, sign(v)*(2*a*k+a*w-v*q)/sqt); S2 = S2 + exp_pnorm(-2*v*a*k, sign(v)*(2*a*k-a*w-v*q)/sqt) - exp_pnorm(2*v*a*k - 2*v*a*w, -sign(v)*(2*a*k-a*w+v*q)/sqt); } return prob_upperbound(v, a, w) + sign(v) * ((pnorm(-sign(v) * (a*w+v*q)/sqt,0,1,1,0) - exp_pnorm(-2*v*a*w, sign(v) * (a*w-v*q)/sqt)) + S1 + S2); } double F_lower(double q, double v, double a, double w) { /* double sigma = 1; a = a / sigma; v = v / sigma; */ double err = 1e-10; double F; int K_l = K_large(q, v, a, w); int K_s = K_small(q, v, a, w, err); if (K_l < 10*K_s) F = Fl_lower(q, v, a, w, K_l); else F = Fs_lower(q, v, a, w, K_s); return F; } double pwiener_d(double q, double alpha, double tau, double beta, double delta) { double p; if(!R_finite(q)) return R_PosInf; if (R_IsNaN(q)) return R_NaN; if (fabs(q) <= tau) return 0; if (q < 0) { // lower boundary 0 p = F_lower(fabs(q)-tau, delta, alpha, beta); } else { // upper boundary a p = F_lower(q-tau, (-delta), alpha, (1-beta)); } return p; } double pwiener_full_d(double q, double alpha, double tau, double beta, double delta) { double p; if (q < 0) return R_NaN; if(!R_finite(q)) return R_PosInf; // infinity p = pwiener_d(q, alpha,tau,beta,delta); p += pwiener_d(-q, alpha,tau,beta,delta); return p; } SEXP pwiener(SEXP q, SEXP alpha, SEXP tau, SEXP beta, SEXP delta) { double p; SEXP value; p = pwiener_d(REAL(q)[0], REAL(alpha)[0], REAL(tau)[0], REAL(beta)[0], REAL(delta)[0]); PROTECT(value = allocVector(REALSXP, 1)); REAL(value)[0] = p; UNPROTECT(1); return value; } SEXP pwiener_full(SEXP q, SEXP alpha, SEXP tau, SEXP beta, SEXP delta) { double p; SEXP value; p = pwiener_full_d(REAL(q)[0], REAL(alpha)[0], REAL(tau)[0], REAL(beta)[0], REAL(delta)[0]); PROTECT(value = allocVector(REALSXP, 1)); REAL(value)[0] = p; UNPROTECT(1); return value; } RWiener/src/dwiener.c0000644000175100001440000000547113053274532014246 0ustar hornikusers#include #include #include double dwiener_d(double q, double alpha, double tau, double beta, double delta, int give_log) { double kl, ks, ans; int k,K; double err = 1e-10; if (R_IsNaN(q + delta + alpha + beta + tau)) return R_NaN; if (!R_finite(q) || !R_finite(alpha)) return 0; if (beta < 0 || beta > 1 || alpha <= 0 || tau <= 0) return R_NaN; // q is negative for lower bound and positive for upper bound // extract RT and accuracy from q if (q<0) { q = fabs(q); } else { beta = 1-beta; delta = -delta; } q = q-tau; // remove non-decision time from q q = q/pow(alpha,2); // convert t to normalized time tt // calculate number of terms needed for large t if (M_PI*q*err<1) { // if error threshold is set low enough kl=sqrt(-2*log(M_PI*q*err)/(pow(M_PI,2)*q)); // bound kl=(kl>1/(M_PI*sqrt(q))) ? kl : 1/(M_PI*sqrt(q)); // ensure boundary conditions met } else { // if error threshold set too high kl=1/(M_PI*sqrt(q)); // set to boundary condition } // calculate number of terms needed for small t if ((2*sqrt(2*M_PI*q)*err)<1) { // if error threshold is set low enough ks=2+sqrt(-2*q*log(2*sqrt(2*M_PI*q)*err)); // bound ks=(ks>sqrt(q)+1) ? ks : sqrt(q)+1; // ensure boundary conditions are met } else { // if error threshold was set too high ks=2; // minimal kappa for that case } // compute density: f(tt|0,1,beta) ans=0; //initialize density if (ks #include #include // prototypes double pwiener_d(double q, double alpha, double tau, double beta, double delta); double pwiener_full_d(double q, double alpha, double tau, double beta, double delta); double qwiener_full_d(double p, double alpha, double tau, double beta, double delta) { if (p > 1) return R_NaN; double pmid; double qmin=0; double qmax=R_PosInf; double q=1; int c=0; do { c++; pmid = pwiener_full_d(q, alpha,tau,beta,delta); if (fabs(p)<=pmid) { // near lower point qmax = q; q = qmin + (qmax-qmin)/2; } else { // near upper point qmin = q; if (R_finite(qmax)) q = qmin + (qmax-qmin)/2; else q = q*10; } if(R_IsNaN(pmid)) return R_NaN; if(q>=1e+10) return R_PosInf; } while(fabs(p-pmid) > 1e-10 && c < 1000); // defines the accuracy return q; } double qwiener_d(double p, double alpha, double tau, double beta, double delta) { if (fabs(p) > 1) return R_NaN; double pmin=0; double pmax=1; double pmid=0; double qmin=0; double qmax=R_PosInf; double q=1; int c=0; do { c++; if (p>=0) pmid = pwiener_d(q, alpha,tau,beta,delta); else pmid = pwiener_d(-q, alpha,tau,beta,delta); if (fabs(p)<=pmid) { // near lower point pmax = pmid; qmax = q; q = qmin + (qmax-qmin)/2; pmin = pmin; // to avoid compiler warnings } else { // near upper point pmin = pmid; qmin = q; if (R_finite(qmax)) q = qmin + (qmax-qmin)/2; else q = q*10; pmax = pmax; // to avoid compiler warnings } if(R_IsNaN(pmid)) return R_NaN; if(q>=1e+10) return R_PosInf; } while(fabs(fabs(p)-pmid) > 1e-10 && c < 1000); // defines the accuracy return q; } SEXP qwiener(SEXP p, SEXP alpha, SEXP tau, SEXP beta, SEXP delta) { double q; SEXP value; q = qwiener_d(REAL(p)[0], REAL(alpha)[0], REAL(tau)[0], REAL(beta)[0], REAL(delta)[0]); PROTECT(value = allocVector(REALSXP, 1)); REAL(value)[0] = q; UNPROTECT(1); return value; } SEXP qwiener_full(SEXP p, SEXP alpha, SEXP tau, SEXP beta, SEXP delta) { double q; SEXP value; q = qwiener_full_d(REAL(p)[0], REAL(alpha)[0], REAL(tau)[0], REAL(beta)[0], REAL(delta)[0]); PROTECT(value = allocVector(REALSXP, 1)); REAL(value)[0] = q; UNPROTECT(1); return value; } RWiener/src/init.c0000644000175100001440000000174713053274532013556 0ustar hornikusers#include #include #include extern SEXP dwiener(SEXP q, SEXP alpha, SEXP tau, SEXP beta, SEXP delta, SEXP give_log); extern SEXP pwiener(SEXP q, SEXP alpha, SEXP tau, SEXP beta, SEXP delta); extern SEXP qwiener(SEXP p, SEXP alpha, SEXP tau, SEXP beta, SEXP delta); extern SEXP rwiener(SEXP alpha, SEXP tau, SEXP beta, SEXP delta); extern SEXP pwiener_full(SEXP q, SEXP alpha, SEXP tau, SEXP beta, SEXP delta); extern SEXP qwiener_full(SEXP p, SEXP alpha, SEXP tau, SEXP beta, SEXP delta); static const R_CallMethodDef CallMethods[] = { {"dwiener", (DL_FUNC) &dwiener, 6}, {"pwiener", (DL_FUNC) &pwiener, 5}, {"qwiener", (DL_FUNC) &qwiener, 5}, {"rwiener", (DL_FUNC) &rwiener, 4}, {"pwiener_full", (DL_FUNC) &pwiener_full, 5}, {"qwiener_full", (DL_FUNC) &qwiener_full, 5}, {NULL, NULL, 0} }; void R_init_RWiener(DllInfo *info) { R_registerRoutines(info, NULL, CallMethods, NULL, NULL); R_useDynamicSymbols(info, FALSE); } RWiener/NAMESPACE0000644000175100001440000000303213053264210013054 0ustar hornikusers## imported packages importFrom("stats", "logLik", "AIC", "BIC", "deviance", "density", "na.omit", "runif", "nlm", "optim", "pchisq", "coef", "nobs", "pnorm", "aggregate", "vcov", "confint", "confint.default", "qnorm" ) importFrom("graphics", "mtext", "par", "plot", "rug" ) ## C functions useDynLib("RWiener", "dwiener_c" = "dwiener", "pwiener_c" = "pwiener", "pwiener_full_c" = "pwiener_full", "qwiener_c" = "qwiener", "qwiener_full_c" = "qwiener_full", "rwiener_c" = "rwiener" ) ## exported functions export ( "dwiener", "pwiener", "qwiener", "rwiener", "print.wdm", "logLik.wdm", "AIC.wdm", "BIC.wdm", "deviance.wdm", "wdm", "estfun", "estfun.wdm", "scorefun", "scorefun.wdm", "is.wiener", "as.wiener", "revamp", "revamp.data.wiener", "revamp.numdata.wiener", "revamp.data.frame", "wiener_likelihood", "wiener_deviance", "wiener_aic", "wiener_bic", "wiener_plot", "anova.wdm", "vcov.wdm", "confint.wdm", "summary.wdm", "print.summary.wdm", "waldtest", "waldtest.wdm", "print.wwaldt" ) ## exported s3 methods S3method("print", "wdm") S3method("logLik", "wdm") S3method("AIC", "wdm") S3method("BIC", "wdm") S3method("deviance", "wdm") S3method("estfun", "wdm") S3method("scorefun", "wdm") S3method("anova", "wdm") S3method("vcov", "wdm") S3method("confint", "wdm") S3method("summary", "wdm") S3method("print", "summary.wdm") S3method("plot", "data.wiener") S3method("revamp", "data.wiener") S3method("revamp", "numdata.wiener") S3method("revamp", "data.frame") S3method("waldtest", "wdm") S3method("print", "wwaldt") RWiener/R/0000755000175100001440000000000013035446103012043 5ustar hornikusersRWiener/R/wienerdist.R0000644000175100001440000000711313002630673014346 0ustar hornikusers## internal function verifypars <- function(alpha,tau,beta,delta) { if(!is.numeric(alpha) || !is.numeric(tau) || !is.numeric(beta) || !is.numeric(delta)) { return(FALSE) } if(alpha > 0 & tau > 0 & beta >= 0 & beta <= 1) return(TRUE) else return(FALSE) } dwiener <- function(q, alpha,tau,beta,delta, resp="upper", give_log=FALSE) { if (!verifypars(alpha,tau,beta,delta) || !is.numeric(q) || !(is.character(resp) || is.factor(resp))) { stop("bad parameter values") } if (!(length(resp) == length(q))) { if(length(resp) == 1) { resp <- rep(resp, length(q)) warning("arguments q and resp differ in length - using same resp for all q") } else stop("arguments q and resp need to be of the same length") } if(class(resp) == "factor") { resp <- as.character(resp) } d <- vector("double", length=length(q)) for (i in 1:length(q)) { if (q[i]<0) stop("q must be > 0") if (resp[i] == "upper") d[i] <- .Call(dwiener_c, q[i], alpha,tau,beta,delta, give_log) else if (resp[i] == "lower") d[i] <- .Call(dwiener_c, -q[i], alpha,tau,beta,delta, give_log) else if (resp[i] == "both") d[i] <- .Call(dwiener_c, q[i], alpha,tau,beta,delta, give_log) + .Call(dwiener_c, -q[i], alpha,tau,beta,delta, give_log) else stop("resp must be either 'lower', 'upper' or 'both'") if(is.nan(d[i])) d[i] <- 0 } return(d) } pwiener <- function(q, alpha,tau,beta,delta, resp="upper") { if (!verifypars(alpha,tau,beta,delta) || !is.numeric(q) || !(is.character(resp) || is.factor(resp))) { stop("bad parameter values") } if (!(length(resp) == length(q))) { stop("arguments q and resp need to be of the same length") } if(class(resp) == "factor") { resp <- as.character(resp) } p <- vector("double", length=length(q)) for (i in 1:length(q)) { if (q[i]<0) stop("q must be > 0") if (resp[i] == "upper") p[i] <- .Call(pwiener_c, q[i], alpha,tau,beta,delta) else if (resp[i] == "lower") p[i] <- .Call(pwiener_c, -q[i], alpha,tau,beta,delta) else if (resp[i] == "both") p[i] <- .Call(pwiener_full_c, q[i], alpha,tau,beta,delta) else stop("resp must be either 'lower', 'upper' or 'both'") if(is.nan(p[i])) p[i] <- 0 } return(p) } qwiener <- function(p, alpha,tau,beta,delta, resp="upper") { if (!verifypars(alpha,tau,beta,delta) || !is.numeric(p) || !(is.character(resp) || is.factor(resp))) { stop("bad parameter values") } if (!(length(resp) == length(p))) { stop("arguments p and resp need to be of the same length") } if(class(resp) == "factor") { resp <- as.character(resp) } q <- vector("double", length=length(q)) for (i in 1:length(p)) { if (p[i]<0) stop("p must be > 0") if (resp[i] == "upper") q[i] <- .Call(qwiener_c, p[i], alpha,tau,beta,delta) else if (resp[i] == "lower") q[i] <- .Call(qwiener_c, -p[i], alpha,tau,beta,delta) else if (resp[i] == "both") q[i] <- .Call(qwiener_full_c, p[i], alpha,tau,beta,delta) else stop("resp must be either 'lower', 'upper' or 'both'") if(is.nan(q[i])) p[i] <- 0 } return(q) } rwiener <- function(n, alpha,tau,beta,delta) { if (!verifypars(alpha,tau,beta,delta)) { stop("bad parameter values") } res <- data.frame(q=vector("double"),resp=factor(levels=c("upper", "lower"))) for (i in 1:n) { r <- .Call(rwiener_c, alpha,tau,beta,delta) if (r >= 0) res[i,] <- c(r,"upper") else res[i,] <- c(abs(r),"lower") } res[,1] <- as.double(res[,1]) class(res) <- c("data.wiener", class(res)) return(res) } RWiener/R/plot.R0000644000175100001440000000161112713424767013161 0ustar hornikusers## Plot function by Rainer W. Alexandrowicz plot.data.wiener <- function(x, ...) { rt = as.double(x$q) # response time rc = as.numeric(x$resp) # response cat: 1=up 2=lo dpos = try(density(rt[rc==1],from=0)) # density upper dneg = try(density(rt[rc==2],from=0)) # density lower maxt = max(pretty(max(rt))) # overall max response time maxd = max(dpos$y,dneg$y) # overall max density par(mar=c(0,5,0,0),mfcol=c(2,1),ask=FALSE) plot(dpos,xlim=c(0,maxt),ylim=c(0,maxd),las=2,lwd=2,col="green3", main="",ylab="",ask=FALSE) rug(rt[rc== 1],col="green3") mtext("Density of positive responses",side=2,line=4,cex=0.8) plot(dneg,xlim=c(0,maxt),ylim=c(maxd,0),las=2,lwd=2,col="red", main="",ylab="",ask=FALSE) mtext("Density of negative responses",side=2,line=4,cex=0.8) rug(rt[rc==2],col="red",side=3) } RWiener/R/scorefun.R0000644000175100001440000001704513033234117014017 0ustar hornikusers## estfun generic function estfun <- function(x, ...) { UseMethod("estfun") } ## define estfun for the wdm model object (needed by sctest function) ## same as scorefun, but aggregates by id (persons) ## empirical estimation function (score function) estfun.wdm <- function(x, ...) { res <- scorefun.wdm(x) if("id" %in% names(x$data)) { res <- cbind(res, id=x$data$id) res <- aggregate(. ~ id, sum, data=as.data.frame(res))[,-1] } return(res) } ## empirical estimation function (score function) scorefun <- function(x, ...) { UseMethod("scorefun") } scorefun.wdm <- function(x, ...) { y <- x$data[,x$yvar] alpha <- x$coefficients["alpha"] tau <- x$coefficients["tau"] beta <- x$coefficients["beta"] delta <- x$coefficients["delta"] n <- length(y[,1]) res <- matrix(rep(NA,4*n), n,4) colnames(res) <- c("alpha", "tau", "beta", "delta") for (i in 1:n) { if (y[i,2] == "lower") { res[i,1] <- sclalpha(y[i,1], alpha, tau, beta, delta) res[i,2] <- scltau(y[i,1], alpha, tau, beta, delta) res[i,3] <- sclbeta(y[i,1], alpha, tau, beta, delta) res[i,4] <- scldelta(y[i,1], alpha, tau, beta, delta) } else if (y[i,2] == "upper") { res[i,1] <- sclalpha(y[i,1], alpha, tau, 1-beta, -delta) res[i,2] <- scltau(y[i,1], alpha, tau, 1-beta, -delta) res[i,3] <- sclbeta(y[i,1], alpha, tau, 1-beta, -delta) res[i,4] <- scldelta(y[i,1], alpha, tau, 1-beta, -delta) } } return(res) } pow <- function(x,y) x^y kappaLT <- function(t, err=1e-10) { (sqrt(2)*sqrt(-log(pi*err*t)/t)/pi) } kappaST <- function(t, err=1e-10) { (sqrt(2)*sqrt(-t*log(2*sqrt(2)*sqrt(pi)*err*sqrt(t))) + 2) } difflogdl01alphaST <- function(t, alpha, beta, kappa) { res <- 0; res1<-0;res2<-0;res3<-0;res4<-0 for (k in -ceiling((kappa-1)/2):floor((kappa-1)/2)) { res1 <- res1 + (-alpha*pow(beta, 3)*exp(-0.5*pow(alpha, 2)*pow(beta, 2)/t)*exp(-2*pow(alpha, 2)*pow(k, 2)/t)*exp(-2*pow(alpha, 2)*beta*k/t)/t - 4*alpha*pow(beta, 2)*k*exp(-0.5*pow(alpha, 2)*pow(beta, 2)/t)*exp(-2*pow(alpha, 2)*pow(k, 2)/t)*exp(-2*pow(alpha, 2)*beta*k/t)/t - 4*alpha*beta*pow(k, 2)*exp(-0.5*pow(alpha, 2)*pow(beta, 2)/t)*exp(-2*pow(alpha, 2)*pow(k, 2)/t)*exp(-2*pow(alpha, 2)*beta*k/t)/t ) res2 <- res2 + (-2*alpha*pow(beta, 2)*k*exp(-0.5*pow(alpha, 2)*pow(beta, 2)/t)*exp(-2*pow(alpha, 2)*pow(k, 2)/t)*exp(-2*pow(alpha, 2)*beta*k/t)/t - 8*alpha*beta*pow(k, 2)*exp(-0.5*pow(alpha, 2)*pow(beta, 2)/t)*exp(-2*pow(alpha, 2)*pow(k, 2)/t)*exp(-2*pow(alpha, 2)*beta*k/t)/t - 8*alpha*pow(k, 3)*exp(-0.5*pow(alpha, 2)*pow(beta, 2)/t)*exp(-2*pow(alpha, 2)*pow(k, 2)/t)*exp(-2*pow(alpha, 2)*beta*k/t)/t) res3 <- res3 + (beta*exp(-0.5*pow(alpha, 2)*pow(beta, 2)/t)*exp(-2*pow(alpha, 2)*pow(k, 2)/t)*exp(-2*pow(alpha, 2)*beta*k/t)) res4 <- res4 + (2*k*exp(-0.5*pow(alpha, 2)*pow(beta, 2)/t)*exp(-2*pow(alpha, 2)*pow(k, 2)/t)*exp(-2*pow(alpha, 2)*beta*k/t)) } res <- (res1+res2)/(res3+res4) + 3/alpha return(res) } difflogdl01alphaLT <- function(t, alpha, beta, kappa) { res <- 0; res1<-0;res2<-0 for (k in 1:ceiling(kappa)) { res1 <- res1 + (pow(pi, 2)*pow(k, 3)*t*exp(-0.5*pow(pi, 2)*pow(k, 2)*t/pow(alpha, 2))*sin(pi*beta*k)/pow(alpha, 3)) res2 <- res2 + (k*exp(-0.5*pow(pi, 2)*pow(k, 2)*t/pow(alpha, 2))*sin(pi*beta*k)) } res <- res1 / res2 return(res) } difflogdl01alpha <- function(t, alpha, beta) { kst <- kappaST(t) klt <- kappaLT(t) wlam <- kst - klt if(wlam < 0) difflogdl01alphaST(t, alpha, beta, kst) else difflogdl01alphaLT(t, alpha, beta, klt) } sclalpha <- function(t, alpha, tau, beta, delta) { t <- t-tau res <- -beta*delta + difflogdl01alpha(t,alpha,beta) - 2/alpha return(res) } difflogdl01tauST <- function(t, tau, alpha, beta, kappa) { res <- 0; res1<-0;res2<-0;res3<-0;res4<-0 for (k in -ceiling((kappa-1)/2):floor((kappa-1)/2)) { res1 <- res1 + (-2*pow(beta, 3)*exp(-pow(beta, 2)/(2*t - 2*tau))*exp(-4*pow(k, 2)/(2*t - 2*tau))*exp(-4*beta*k/(2*t - 2*tau))/pow(2*t - 2*tau, 2) - 8*pow(beta, 2)*k*exp(-pow(beta, 2)/(2*t - 2*tau))*exp(-4*pow(k, 2)/(2*t - 2*tau))*exp(-4*beta*k/(2*t - 2*tau))/pow(2*t - 2*tau, 2) - 8*beta*pow(k, 2)*exp(-pow(beta, 2)/(2*t - 2*tau))*exp(-4*pow(k, 2)/(2*t - 2*tau))*exp(-4*beta*k/(2*t - 2*tau))/pow(2*t - 2*tau, 2)) res2 <- res2 + (-4*pow(beta, 2)*k*exp(-pow(beta, 2)/(2*t - 2*tau))*exp(-4*pow(k, 2)/(2*t - 2*tau))*exp(-4*beta*k/(2*t - 2*tau))/pow(2*t - 2*tau, 2) - 16*beta*pow(k, 2)*exp(-pow(beta, 2)/(2*t - 2*tau))*exp(-4*pow(k, 2)/(2*t - 2*tau))*exp(-4*beta*k/(2*t - 2*tau))/pow(2*t - 2*tau, 2) - 16*pow(k, 3)*exp(-pow(beta, 2)/(2*t - 2*tau))*exp(-4*pow(k, 2)/(2*t - 2*tau))*exp(-4*beta*k/(2*t - 2*tau))/pow(2*t - 2*tau, 2)) res3 <- res3 + (beta*exp(-pow(beta, 2)/(2*t - 2*tau))*exp(-4*pow(k, 2)/(2*t - 2*tau))*exp(-4*beta*k/(2*t - 2*tau))) res4 <- res4 + (2*k*exp(-pow(beta, 2)/(2*t - 2*tau))*exp(-4*pow(k, 2)/(2*t - 2*tau))*exp(-4*beta*k/(2*t - 2*tau))) } res <- (res1+res2)/(res3+res4) + (1.5)/(t - tau) return(res) } difflogdl01tauLT <- function(t, tau, alpha, beta, kappa) { res <- 0; res1<-0;res2<-0 for (k in 1:ceiling(kappa)) { res1 <- res1 + ((0.5)*pow(pi, 2)*pow(k, 3)*exp(-0.5*pow(pi, 2)*pow(k, 2)*t)*exp((0.5)*pow(pi, 2)*pow(k, 2)*tau)*sin(pi*beta*k)) res2 <- res2 + (k*exp(-0.5*pow(pi, 2)*pow(k, 2)*t)*exp((0.5)*pow(pi, 2)*pow(k, 2)*tau)*sin(pi*beta*k)) } res <- res1 / res2 return(res) } difflogdl01tau <- function(t, tau, alpha, beta) { kst <- kappaST(t-tau) klt <- kappaLT(t-tau) wlam <- kst - klt if(wlam < 0) difflogdl01tauST(t, tau, alpha, beta, kst) else difflogdl01tauLT(t, tau, alpha, beta, klt) } scltau <- function(t, alpha, tau, beta, delta) { res <- delta^2/2 - 1/alpha^2 * difflogdl01tau(t, tau, alpha, beta) #res <- 0 return(res) } difflogdl01betaST <- function(t, alpha, beta, kappa) { res <- 0; res1<-0;res2<-0;res3<-0;res4<-0 for (k in -ceiling((kappa-1)/2):floor((kappa-1)/2)) { res1 <- res1 + (-2*pow(alpha, 2)*beta*k*exp(-0.5*pow(alpha, 2)*pow(beta, 2)/t)*exp(-2*pow(alpha, 2)*pow(k, 2)/t)*exp(-2*pow(alpha, 2)*beta*k/t)/t - 4*pow(alpha, 2)*pow(k, 2)*exp(-0.5*pow(alpha, 2)*pow(beta, 2)/t)*exp(-2*pow(alpha, 2)*pow(k, 2)/t)*exp(-2*pow(alpha, 2)*beta*k/t)/t) res2 <- res2 + (-pow(alpha, 2)*pow(beta, 2)*exp(-0.5*pow(alpha, 2)*pow(beta, 2)/t)*exp(-2*pow(alpha, 2)*pow(k, 2)/t)*exp(-2*pow(alpha, 2)*beta*k/t)/t - 2*pow(alpha, 2)*beta*k*exp(-0.5*pow(alpha, 2)*pow(beta, 2)/t)*exp(-2*pow(alpha, 2)*pow(k, 2)/t)*exp(-2*pow(alpha, 2)*beta*k/t)/t + exp(-0.5*pow(alpha, 2)*pow(beta, 2)/t)*exp(-2*pow(alpha, 2)*pow(k, 2)/t)*exp(-2*pow(alpha, 2)*beta*k/t)) res3 <- res3 + (beta*exp(-0.5*pow(alpha, 2)*pow(beta, 2)/t)*exp(-2*pow(alpha, 2)*pow(k, 2)/t)*exp(-2*pow(alpha, 2)*beta*k/t)) res4 <- res4 + (2*k*exp(-0.5*pow(alpha, 2)*pow(beta, 2)/t)*exp(-2*pow(alpha, 2)*pow(k, 2)/t)*exp(-2*pow(alpha, 2)*beta*k/t)) } res <- (res1+res2)/(res3+res4) return(res) } difflogdl01betaLT <- function(t, alpha, beta, kappa) { res <- 0; res1<-0;res2<-0 for (k in 1:ceiling(kappa)) { res1 <- res1 + (pi*pow(k, 2)*exp(-0.5*pow(pi, 2)*pow(k, 2)*t/pow(alpha, 2))*cos(pi*beta*k)) res2 <- res2 + (k*exp(-0.5*pow(pi, 2)*pow(k, 2)*t/pow(alpha, 2))*sin(pi*beta*k)) } res <- res1 / res2 return(res) } difflogdl01beta <- function(t, alpha, beta) { kst <- kappaST(t) klt <- kappaLT(t) wlam <- kst - klt if(wlam < 0) difflogdl01betaST(t, alpha, beta, kst) else difflogdl01betaLT(t, alpha, beta, klt) } sclbeta <- function(t, alpha, tau, beta, delta) { t <- t-tau res <- -alpha*delta + difflogdl01beta(t, alpha, beta) return(res) } scldelta <- function(t, alpha, tau, beta, delta) { t <- t-tau res <- -alpha*beta - delta*t return(res) } RWiener/R/deprecated.R0000644000175100001440000000160112726026604014272 0ustar hornikusers## document with all deprecated functions, kept for backwards compatibility wiener_likelihood <- function(x, data) { #warning("wiener_likelihood is deprecated, use logLik.wdm instead") obj <- list(coefficients=x,data=data) logLik.wdm(obj) } wiener_aic <- function(x, data, loss=NULL) { #warning("wiener_aic is deprecated, use AIC.wdm instead") obj <- list(coefficients=x,data=data,loss=loss) AIC.wdm(obj) } wiener_bic <- function(x, data, loss=NULL) { #warning("wiener_bic is deprecated, use BIC.wdm instead") obj <- list(coefficients=x,data=data,loss=loss) BIC.wdm(obj) } wiener_deviance <- function(x, data) { #warning("wiener_deviance is deprecated, use deviance.wdm instead") obj <- list(coefficients=x,data=data) deviance.wdm(obj) } wiener_plot <- function(data) { #warning("wiener_plot is deprecated, use plot.data.wiener instead") plot.data.wiener(data) } RWiener/R/wdm.R0000644000175100001440000002121013035431762012756 0ustar hornikusers## maximum likelihood estimation of wdm model parameters wdm <- function(data, yvar=c("q", "resp"), alpha=NULL, tau=NULL, beta=NULL, delta=NULL, xvar=NULL, start=NULL, fixed=0) { # save original function call cl <- match.call() # prepare passed arguments verifydata(data) if (is.numeric(data) & is.null(xvar)) data <- revampwiener(data, yvar=yvar) else if (length(yvar)==1) { cbind(revampwiener(data[,yvar]), data) yvar <- c("q", "resp") } fpar <- c("alpha"=unname(alpha), "tau"=unname(tau), "beta"=unname(beta), "delta"=unname(delta)) # estimate parameters if (!is.null(xvar)) { if(length(xvar)==1) { if(class(data[,xvar]) == "factor"){ res <- list() res$coefficients <- fpar for (l in levels(data[,xvar])) { est <- mle(data[data[,xvar]==l,yvar], fpar, start) est$coefficients <- est$coefficients[!(names(est$coefficients) %in% names(fpar))] names(est$coefficients) <- paste(l,names(est$coefficients), sep=":") res$coefficients <- append(res$coefficients, est$coefficients) res$counts <- append(res$counts, est$counts) res$algorithm <- append(res$algorithm, list(est$algorithm)) res$convergence <- append(res$convergence, est$convergence) res$message <- append(res$message, est$message) res$hessian <- append(res$hessian, list(est$hessian)) res$loglik <- sum(res$loglik, est$loglik) } } else stop("xvar has to be a factor") } } else res <- mle(data[,yvar], fpar, start) # prepare return object res$nobs <- length(data[,1]) res$npar <- length(res$coefficients)-fixed res$data <- data res$yvar <- yvar res$estpar <- c("alpha"=is.null(alpha), "tau"=is.null(tau), "beta"=is.null(beta), "delta"=is.null(delta)) res$call <- cl res$xvar <- xvar class(res) <- c("wdm") return(res) } ### mle function ## internal function mle <- function(data, fpar=NULL, start=NULL) { if (is.null(start)) { start <- c(runif(1,1,2),min(data[,1])/3,runif(1,.2,.8),runif(1,-1,1)) } start <- esvec(start, fpar) if (length(start)==0) { est <- list( coefficients = fpar, data = data, convergence = NULL, hessian = NULL, algorithm = list(type="None (all parameters fixed)") ) est$value <- -logLik.wdm(est) } else if (length(start)==1) { ## only one parameter: use 'Brent (optim)' est <- optim(start,efn,data=data,fpar=fpar, method="Brent", lower=-100, upper=100, hessian=TRUE, control=list(maxit=2000)) est$algorithm <- list(type="Brent (optim)", counts=est$counts, message=est$message) est$coefficients <- est$par } else { ## first: try 'BFGS (optim)' est <- tryCatch(optim(start,efn,data=data,fpar=fpar, method="BFGS",hessian=TRUE, control=list(maxit=2000)), error=function(e) NULL) if (!is.null(est)) { if (est$convergence == 0) { est$algorithm <- list(type="BFGS (optim)", counts=est$counts, message=est$message) est$coefficients <- est$par } else est <- NULL } if (is.null(est)) { ## second: try 'Nelder-Mead (optim)', then 'BFGS (optim)' opt <- optim(start,efn,data=data,fpar=fpar, method="Nelder-Mead", control=list(maxit=2000)) if (!is.null(opt)) { est <- tryCatch(optim(opt$par,efn,data=data,fpar=fpar, method="BFGS",hessian=TRUE, control=list(maxit=2000)), error=function(e) NULL) if (!is.null(est) && est$convergence == 0) { est$algorithm <- list(type="BFGS (optim) after Nelder-Mead", counts=est$counts, message=est$message) est$coefficients <- est$par } } } if (is.null(est)) { ## third: try 'Newton-type (nlm)' ## note: suppressWarnings used for nlm, as nlm inflates warning messages est <- tryCatch(suppressWarnings(nlm(efn,start,data=data,fpar=fpar,hessian=TRUE)), error=function(e) NULL) if (!is.null(est)) { if (est$code < 3) { est$convergence <- est$code est$coefficients <- est$estimate; est$estimate <- NULL est$value <- est$minimum; est$minimum <- NULL est$counts <- c(iterations=est$iterations); est$iterations <- NULL est$algorithm <- list(type="Newton-type (nlm)", gradient=est$gradient, counts=est$counts, message=est$message); est$gradient <- NULL } else est <- NULL } } if (is.null(est)) { ## fourth: try 'Nelder-Mead (optim)' est <- optim(start,efn,data=data,fpar=fpar, method="Nelder-Mead", control=list(maxit=2000)) est$algorithm <- list(type="Nelder-Mead", counts=est$counts, message=est$message) est$coefficients <- est$par } } est$message <- NULL; est$counts <- NULL par <- eparvec(est$coefficients, fpar) res <- list( coefficients = par, loglik = -est$value, convergence = est$convergence, hessian = est$hessian, algorithm = est$algorithm ) return(res) } ## internal function esvec <- function(x, fpar) { if (!is.null(fpar)) { if ("alpha" %in% names(fpar)) x[1] <- NA if ("tau" %in% names(fpar)) x[2] <- NA if ("beta" %in% names(fpar)) x[3] <- NA if ("delta" %in% names(fpar)) x[4] <- NA x <- as.numeric(na.omit(x)) } return(x) } ## internal function efn <- function(x, data, fpar=NULL) { object <- list(data=data) par <- numeric(4) if (is.null(fpar)) { par <- x } else { if("alpha" %in% names(fpar)) par[1] <- fpar["alpha"] else { par[1] <- x[1] x <- x[-1] } if("tau" %in% names(fpar)) par[2] <- fpar["tau"] else { par[2] <- x[1] x <- x[-1] } if("beta" %in% names(fpar)) par[3] <- fpar["beta"] else { par[3] <- x[1] x <- x[-1] } if("delta" %in% names(fpar)) par[4] <- fpar["delta"] else { par[4] <- x[1] x <- x[-1] } } object$coefficients <- par res <- nlogLik.wdm(object) return(res) } ## internal function eparvec <- function(x, fpar=NULL) { res <- numeric(4) names(res) <- c("alpha", "tau", "beta", "delta") if (!is.null(fpar)) { if ("alpha" %in% names(fpar)) res[1] <- NA if ("tau" %in% names(fpar)) res[2] <- NA if ("beta" %in% names(fpar)) res[3] <- NA if ("delta" %in% names(fpar)) res[4] <- NA } res[!is.na(res)] <- x res[is.na(res)] <- fpar return(res) } ## additional functions vcov.wdm <- function(object, ..., method="hessian") { # opg-estimator (outer product of gradients) if (method=="opg") res <- solve(crossprod(scorefun(object))) else if (method=="hessian") if(is.list(object$hessian)) { res <- list() for (k in 1:length(object$hessian)) { pnames <- paste0(levels(object$data[,object$xvar])[k], ":", names(object$estpar[object$estpar])) res[[k]] <- solve(object$hessian[[k]]) colnames(res[[k]]) <- pnames rownames(res[[k]]) <- colnames(res[[k]]) } } else { res <- solve(object$hessian) colnames(res) <- names(coef(object)[object$estpar]) rownames(res) <- colnames(res) } else stop("Wrong method specified") return(res) } confint.wdm <- function (object, parm, level = 0.95, ...) { if(is.list(object$hessian)) { cf <- coef(object) pnames <- names(cf) if (missing(parm)) parm <- pnames else if (is.numeric(parm)) parm <- pnames[parm] a <- (1 - level)/2 a <- c(a, 1 - a) pct <- paste0(a*100, " %") fac <- qnorm(a) ci <- array(NA, dim = c(length(parm), 2L), dimnames = list(parm, pct)) ses <- vector() for (k in 1:length(vcov(object))) { ses <- c(ses,sqrt(diag(vcov(object)[[k]]))) } ses <- ses[parm] ci[] <- cf[parm] + ses %o% fac ci } else confint.default(object, parm, level, ...) } summary.wdm <- function(object, ...) { coef <- coef(object) if(is.list(vcov(object))) { sds <- vector() for (k in 1:length(vcov(object))) { sds <- c(sds,sqrt(diag(vcov(object)[[k]]))) } } else sds <- sqrt(diag(vcov(object))) aic <- AIC(object) bic <- BIC(object) loglik <- logLik(object) cint <- confint(object) res <- list(coef=coef, sd=sds, aic=aic, bic=bic, loglik=loglik, cint=cint) class(res) <- c(class(res), "summary.wdm") return(res) } print.summary.wdm <- function(x, ...){ cat("\nCoefficients:\n") print(x$coef) cat("\n") cat("\nStandard deviation of estimated parameters:\n") print(x$sd) cat("\n") cat("\nConfidence Intervalls:\n") print(x$cint) cat("\n") cat("log-likelihood: ", x$loglik, "\nAIC: ", x$aic, "\nBIC: ", x$bic) cat("\n") } RWiener/R/likelihood.R0000644000175100001440000000237112726026605014323 0ustar hornikuserslogLik.wdm <- function(object, ...) { data <- object$data x <- object$coefficients if (length(x) == 4) { if (!verifypars(x[1],x[2],x[3],x[4])) { return(-Inf) } ll <- vector("double", length(data[,1])) for (i in 1:length(data[,1])) { ll[i] <- dwiener(as.double(data[i,1]), x[1],x[2],x[3],x[4], resp=as.character(data[i,2]), give_log=TRUE) } return(sum(ll)) } else return(object$loglik) } ## internal function nlogLik.wdm <- function(object, ...) -logLik.wdm(object, ...) deviance.wdm <- function(object, ...) { -2*logLik.wdm(object) } AIC.wdm <- function(object, ...) { if(is.null(object$loss)) { -2*logLik.wdm(object)+4*2 } else { data <- object$data x <- object$coefficients object$loss(x,data)+length(x)*2 } } BIC.wdm <- function(object, ...) { if(is.null(object$loss)) { -2*logLik.wdm(object)+4*log(length(object$data[,1])) } else { data <- object$data x <- object$coefficients if(is.list(data)) { object$loss(x,data)+length(x)*log(length(data[[1]][,1])) } else if (is.data.frame(data)) { object$loss(x,data)+length(x)*log(length(data[,1])) } else { stop("don't know how to handle the data object") } } } RWiener/R/misc.R0000644000175100001440000000457713007142431013132 0ustar hornikusers## internal function verifydata <- function(data) { if (is.null(data)) stop("missing values (no data supplied)") if (!is.wiener(data)) { if (!(is.data.frame(data) | is.numeric(data))) stop("supplied data in wrong format") } } is.wiener <- function(data) { res <- (inherits(data, "data.wiener") | inherits(data, "numdata.wiener")) return(res) } as.wiener <- function(data, yvar=c("q", "resp")) { if(is.data.frame(data) & ((as.numeric(yvar[1] %in% colnames(data))+as.numeric(yvar[2] %in% colnames(data)))==2) ) { class(data) <- c("data.wiener", "data.frame") } else if(is.numeric(data) | is.vector(data)) { class(data) <- c("numdata.wiener", "numeric") } else stop("can only convert vectors (with + / - values for upper/lower bound) or data.frames (with 2 columns: 'q' and 'resp').") return(data) } ## internal function revampwiener <- function(data, yvar=c("q", "resp"), direction="auto") { verifydata(data) if(is.data.frame(data) & (direction %in% c("wide", "auto"))) { res <- data[,yvar[1]] for (i in 1:(length(data[,1]))) { if(data[i,yvar[2]] == "upper") res[i] <- data[i,yvar[1]] else res[i] <- -data[i,yvar[1]] } class(res) <- c("numdata.wiener", "numeric") } else if ((is.vector(data) | is.numeric(data)) & (direction %in% c("long", "auto"))) { res <- data.frame(as.numeric(abs(data)), factor((data>0), levels=c("TRUE", "FALSE"), labels=c("upper", "lower"))) colnames(res) <- yvar[1:2] class(res) <- c("data.wiener", "data.frame") } else if(("numdata.wiener" %in% class(data) & direction=="wide" ) | ("data.wiener" %in% class(data) & direction=="long")) { res <- data } else warning("argument(s) not valid") return(res) } ## define revamp (wiener reshape) function to be generic revamp <- function(data, ...) UseMethod("revamp") revamp.numdata.wiener <- function(data, ...) { revampwiener(data, ...) } revamp.data.wiener <- function(data, ...) { revampwiener(data, ...) } revamp.data.frame <- function(data, ...) { revampwiener(data, ...) } print.wdm <- function(x, ...) { cat("Call:\n") print(x$call) cat("\n") cat("Parameters:\n") print(x$coefficients) cat("\n") if (!is.list(x$hessian)) { cat("Hessian:\n") print(x$hessian) cat("\n") } cat("log-Likelihood: ") print(x$loglik) cat("Convergence: ") print(x$convergence) } RWiener/R/tests.R0000644000175100001440000000627713035446103013344 0ustar hornikusersanova.wdm <- function(object, ..., test="LRT") { cl <- match.call() if(test=="LRT") { for (i in 2:(length(cl)-1)) { if(!is.object(eval(cl[[i+1]]))) break else { wdmspecific <- eval(cl[[i]]) wdmgeneral <- eval(cl[[i+1]]) G2 <- 2 * ( logLik(wdmgeneral)-logLik(wdmspecific) ) Df <- wdmgeneral$npar - wdmspecific$npar pvalue <- pchisq(G2, Df, lower.tail=FALSE) models <- as.character(c(cl[[i]], cl[[i+1]])) if (i == 2) { res <- list( models = models, modeldf = c(wdmspecific$npar, wdmgeneral$npar), model.AIC = c(AIC(wdmspecific), AIC(wdmgeneral)), model.BIC = c(BIC(wdmspecific), BIC(wdmgeneral)), model.loglik = c(logLik(wdmspecific), logLik(wdmgeneral)), G2 = c(NA, G2), Df = c(NA, Df), pvalue = c(NA, pvalue) ) } else { res$modeldf <- c(res$modeldf, wdmgeneral$npar) res$models <- c(res$models, models[2]) res$model.AIC <- c(res$model.AIC, AIC(wdmgeneral)) res$model.BIC <- c(res$model.BIC, BIC(wdmgeneral)) res$model.loglik <- c(res$model.loglik, logLik(wdmgeneral)) res$G2 <- c(res$G2, G2) res$Df <- c(res$Df, Df) res$pvalue <- c(res$pvalue, pvalue) } } } # end for loop } # end if(test==LRT) else stop("Only LRT Test implemented yet") out <- data.frame(df = res$modeldf, AIC = res$model.AIC, BIC = res$model.BIC, logLik = res$model.loglik, Df = res$Df, LRT.G2 = res$G2, pvalue = res$pvalue) dimnames(out) <- list(1:length(res$models), c("df", "AIC", "BIC", "logLik", "LRT.df", "LRT.G2", "pvalue")) structure(out, heading = c("Model comparison Table with LRTs\n", paste0("Model ", 1:length(res$models), ": ", res$models, collapse = "\n"),""), class = c("anova", "data.frame")) } ## define waldtest function to be generic waldtest <- function(object, ...) UseMethod("waldtest") ## H1: wdm ## waldtest.wdm function waldtest.wdm <- function(object, ..., theta="delta", theta0=0) { pars <- coef(object) vars <- diag(vcov(object)) names(vars) <- names(pars) n <- nobs(object) # method 1: chi-squared distribution with df=1 W2 <- ((pars[theta]-theta0)^2 / vars[theta]) chisq <- pchisq(W2, 1, lower.tail=FALSE) # method 2: normal distribution W <- (pars[theta]-theta0)/(sqrt(vars[theta])) ND <- 2 * pnorm(abs(W), lower.tail=FALSE) res <- list( W2 = W2, W2.pvalue = chisq, W = W, pvalue = ND, test = list(theta=theta,theta0=theta0) ) class(res) <- c(class(res), "wwaldt", "waldtest") return(res) } print.wwaldt <- function(x, ...) { wtab <- rbind(c(x$W2, x$W2.pvalue), c(x$W, x$pvalue) ) colnames(wtab) <- c("Test-Statistic", "pvalue") rownames(wtab) <- c("W2","W") cat("\n") cat("Wiener Wald Test") cat("\n\n") cat("Null hypothesis: ", x$test$theta, "=", x$test$theta0 , sep="") cat("\n") #cat("W2 ~ Chisq, Df=1; p-value: upper tail (one-tailed)\n") cat("W ~ Normal Distribution\n") cat("\n") print(wtab[2,]) } RWiener/MD50000644000175100001440000000237013053307143012154 0ustar hornikusers9ce95edc6215d7c9b489739f92f0e374 *DESCRIPTION 111a2a732bf4bd56006d2d6351dd2ead *NAMESPACE e87dab922ad3b551fba9a72dcfe25535 *R/deprecated.R c1f7ded2bb0874f8d5c2e89b68dc63e3 *R/likelihood.R 2d20be3d6c18a688d21613b29d2af7d0 *R/misc.R c4f58b6f12f5e6de53fa7003d124f8ca *R/plot.R 329fcfbecd72ee4bcfe0af7937436da2 *R/scorefun.R 3f94f4b38c9629c44c3698506ebb4e15 *R/tests.R 79fdd8452e38c80bda587bc0b8c89240 *R/wdm.R 49785f1d5c12486e0b2f549a324e7cdc *R/wienerdist.R fc8a6d259acc7e614944b012b7f507e1 *README 6071edd604dbeb75308cfbedc7790398 *cleanup cba358a4ef3f797a77c57f6abc9df507 *inst/CITATION 735833398d30517f600c845191e5d8ab *man/RWiener-internal.Rd c1509d73c0d7c8824b2db46dfabc637c *man/deprecated.Rd 25d9d3b8f5ab753f9f18779202fd8b13 *man/likelihood.Rd 0e0f5def5f6fd2aac7de4e79fe3fb76e *man/misc.Rd 25596a7b4e0b1ba17b6c05a196d47479 *man/plot.Rd dc60be0799c21b0123f2a533c9e108d0 *man/scorefun.Rd b7ec7647b71748d1c52ec4d8cd39e513 *man/tests.Rd 5906b8f57d8cdb148c55553006284323 *man/wdm.Rd 08fdfeadc094bbe5be7ef3da75284548 *man/wienerdist.Rd 542ed569839ae7f3b5976eb14429d899 *src/dwiener.c 31d8bb9f7ee4c327f9852b5ac8c5c775 *src/init.c c42872af42a5c6a773a8f61f77e93247 *src/pwiener.c 66de437a5b15943f695b44484c379f22 *src/qwiener.c 02248223518329ce8907e122f38c74c2 *src/rwiener.c RWiener/README0000644000175100001440000000313412735765322012540 0ustar hornikusersRWiener R package ================= The RWiener package is an extension for R, which provides wiener process distribution functions, namely the Wiener first passage time density, CDF, quantile and random functions. Using the package ----------------- :: dwiener(q, alpha,tau,beta,delta, resp="upper") pwiener(q, alpha,tau,beta,delta, resp="upper") qwiener(p, alpha,tau,beta,delta, resp="upper") rwiener(n, alpha,tau,beta,delta) *arguments*: - q being a quantile - p being the CDF value between 0 and 1 - n being an integer value > 0 - resp determining if it's for the "upper" or "lower" (i.e. error) boundary - alpha being the boundary separation parameter - tau being the non-decision time - beta being the bias - delta being the drift rate Apart from these basic functions, the package provides more functions for futher analyses, e.g. functions to compute the likelihood. These functions are used in predefined estimation routines - the wdm() function - to automatically create wdm model objects with estimated parameter values. One can also use the functions in combination with R's optim() function, to manually get parameter estimates for the model. :: wdm(data, yvar=c("q", "resp"), alpha=NULL, tau=NULL, beta=NULL, delta=NULL, xvar=NULL, start=NULL) See the R man pages for more details! Please note ----------- For an introduction and when citing this package: Wabersich, D., & Vandekerckhove, J. (2014). The RWiener Package: an R Package providing distribution functions for the wiener diffusion model. The R Journal, 6(1), 49-56. License ------- http://www.r-project.org/Licenses/GPL-2 RWiener/DESCRIPTION0000644000175100001440000000146413053307143013355 0ustar hornikusersPackage: RWiener Version: 1.3-1 Date: 2017-02-22 Title: Wiener Process Distribution Functions Authors@R: c(person("Dominik", "Wabersich", role=c("aut", "cre"), email="dominik.wabersich@gmail.com")) Author: Dominik Wabersich [aut, cre] Maintainer: Dominik Wabersich Depends: R (>= 3.0.0) Suggests: MASS Imports: stats, graphics License: GPL (>= 2) URL: https://github.com/yeagle/RWiener Description: Provides Wiener process distribution functions, namely the Wiener first passage time density, CDF, quantile and random functions. Additionally supplies a modelling function (wdm) and further methods for the resulting object. NeedsCompilation: yes Packaged: 2017-02-22 11:43:22 UTC; yeagle Repository: CRAN Date/Publication: 2017-02-22 14:13:07 RWiener/man/0000755000175100001440000000000013053273627012426 5ustar hornikusersRWiener/man/deprecated.Rd0000644000175100001440000001061213052625175015013 0ustar hornikusers\name{deprecated} \alias{wiener_likelihood} \alias{wiener_deviance} \alias{wiener_aic} \alias{wiener_bic} \title{Wiener likelihood and criterion functions (deprecated)} \description{ \code{wiener_likelihood} computes the log-likelihood for given parameter values and data. \code{wiener_deviance} computes the deviance. \code{wiener_aic} computes the AIC. \code{wiener_bic} computes the BIC. These functions can be very useful in combination with the optim funcion, to estimate parameters (see example below). } \usage{ wiener_likelihood(x, data) wiener_deviance(x, data) wiener_aic(x, data, loss=NULL) wiener_bic(x, data, loss=NULL) } \arguments{ \item{x}{vector with the four parameter values: alpha, tau, beta, delta.} \item{data}{dataframe with data. Needs a reaction time column and a accuracy/response column.} \item{loss}{Defaults to NULL, which means that the default computation is done by using -2*wiener_likelihood(x,data) in the formula. If not NULL, this can be a function to replace the default -2*wiener_likelihood(x,data) in the code and use a custom function instead.} } \details{ The described functions are deprecated, but still fully supported. They are kept for backwards compatibility and to ensure one can reproduce the examples from Wabersich & Vandekerckhove (2014). These functions are simple wrapper functions for the generic R functions reported below. The User is encouraged to use the generic R functions instead: \code{logLik.wdm}, \code{deviance.wdm}, \code{AIC.wdm}, \code{BIC.wdm}. See the corresponding help pages for more information on these functions. } \examples{ ### Example 1: Parameter estimation ## generate random data dat <- rwiener(100,2,.3,.5,0) ## compute likelihood wiener_likelihood(c(2,.3,.5,0), dat) ## estimate parameters with optim onm <- optim(c(1,.1,.1,1),wiener_deviance,data=dat, method="Nelder-Mead") est <- optim(onm$par,wiener_deviance,data=dat, method="BFGS",hessian=TRUE) est$par # parameter estimates ## the following code needs the MASS package \dontrun{sqrt(diag(MASS::ginv(est$hessian)))} # sd for parameters ### Example 2: Simple model comparison ## compare two models with deviance wiener_deviance(c(3,.3,.5,0), dat) wiener_deviance(c(3,.3,.5,0.5), dat) ## log-likelihood difference wiener_likelihood(c(3,.3,.5,0), dat)-wiener_likelihood(c(3,.3,.5,0.5), dat) \dontrun{% ### Example 3: likelihood-ratio test and Wald test ## Suppose we have data from 2 conditions dat1 <- rwiener(100,2,.3,.5,-.5) dat2 <- rwiener(100,2,.3,.5,.5) onm1 <- optim(c(1,.1,.1,1),wiener_deviance,data=dat1, method="Nelder-Mead") est1 <- optim(onm1$par,wiener_deviance,data=dat1, method="BFGS",hessian=TRUE) wiener_likelihood(est1$par,dat1)+wiener_likelihood(est1$par,dat2) # combined loglike model_ll <- function(pars,delta,dat1,dat2) { wiener_likelihood(pars,dat1)+ wiener_likelihood(c(pars[1:3],pars[4]+delta),dat2) } ## likelihood-ratio test ## 0-model: delta=0; alt-model: delta=1 model_ll(est1$par,1,dat1,dat2) ## compute likelihood ratio LR <- -2*model_ll(est1$par,0,dat1,dat2)+2*model_ll(est1$par,1,dat1,dat2) ## compare with critical X^2(1) quantile, alpha=0.05 LR > qchisq(0.95,1) ## get p-value from X^2(1) pchisq(LR,1, lower.tail=FALSE) ## Wald-Test ## estimate parameter delta and test for significance onm2 <- optim(c(1,.1,.1,1),wiener_deviance,data=dat2, method="Nelder-Mead") est2 <- optim(onm2$par,wiener_deviance,data=dat2, method="BFGS",hessian=TRUE) delta <- est2$par[4]-est1$par[4] ## the following code needs the MASS package est1.sd <- sqrt(diag(MASS::ginv(est1$hessian))) # sd for parameters WT <- (est1$par[4]-(est1$par[4]+delta))/est1.sd[4] ## compare with critical quantile N(0,1), alpha=0.05 abs(WT) > qnorm(0.975) ## get p-value from N(0,1) pnorm(WT) }% ### Example 4: Custom AIC loss function many_drifts <- function(x,datlist) { l = 0 for (c in 1:length(datlist)) { l = l + wiener_deviance(x[c(1,2,3,c+3)],datlist[[c]]) } return(l) } dat1 <- rwiener(n=100, alpha=2, tau=.3, beta=.5, delta=0.5) dat2 <- rwiener(n=100, alpha=2, tau=.3, beta=.5, delta=1) datlist <- list(dat1,dat2) wiener_aic(x=c(2,.3,.5,.5,1), data=datlist, loss=many_drifts) } \keyword{wiener_likelihood} \keyword{wiener_deviance} \keyword{wiener_aic} \keyword{wiener_bic} \references{ Wabersich, D., & Vandekerckhove, J. (2014). The RWiener package: An R package providing distribution functions for the Wiener diffusion model. The R Journal, 6(1), 49-56. } RWiener/man/likelihood.Rd0000644000175100001440000000507113053273627015043 0ustar hornikusers\name{likelihood} \alias{logLik.wdm} \alias{deviance.wdm} \alias{AIC.wdm} \alias{BIC.wdm} \title{Likelihood and criterion functions for wdm} \description{ \code{logLik.wdm} computes the log-likelihood. \code{deviance.wdm} computes the deviance. \code{AIC.wdm} computes the AIC. \code{BIC.wdm} computes the BIC. } \usage{ \method{logLik}{wdm}(object, \ldots) \method{deviance}{wdm}(object, \ldots) \method{AIC}{wdm}(object, \ldots) \method{BIC}{wdm}(object, \ldots) } \arguments{ \item{object}{a wdm object file or a list containing a \code{$par} vector with the model parameters, a \code{$data} data.frame with the data and optionally a \code{$loss} function.} \item{\ldots}{optional arguments} } \details{ The \code{$par} vector with the (four) parameter values should be in the following order: alpha, tau, beta, delta. The \code{$data} data.frame with data needs a reaction time column and a accuracy/response column. The \code{$loss} function defaults to NULL, which means that the default computation is done by using the default formula. If not NULL, this can be a function to replace the default computation in the code and use a custom function instead. The custom function takes two arguments: the parameter vector and the data.frame with the data. These functions can be very useful in combination with the optim funcion, to estimate parameters manually. Check the examples below to see how to use the provided generic functions in a manual estimation routine. } \examples{ ## generate random data dat <- rwiener(100,3,.25,.5,0.8) ## fit wdm wdm1 <- wdm(dat, alpha=3, tau=.25, beta=0.5) ## compute likelihood, AIC, BIC, deviance logLik(wdm1) AIC(wdm1) BIC(wdm1) deviance(wdm1) \dontrun{ ## estimate parameters by calling optim manually ## first define necessary wrapper function nll <- function(x, data) { object <- wdm(data, alpha=x[1], tau=x[2], beta=x[3], delta=x[4]) -logLik(object) } ## call estimation routine onm <- optim(c(1,.1,.1,1),nll,data=dat, method="Nelder-Mead") est <- optim(onm$par,nll,data=dat, method="BFGS",hessian=TRUE) est$par # parameter estimates ## use the obtained parameter estimates to create wdm object wdm2 <- wdm(dat, alpha=est$par[1], tau=est$par[2], beta=est$par[3], delta=est$par[4]) ## now the generic functions can be used again logLik(wdm2) } } \keyword{logLik.wdm} \keyword{deviance.wdm} \keyword{AIC.wdm} \keyword{BIC.wdm} \references{ Wabersich, D., & Vandekerckhove, J. (2014). The RWiener package: An R package providing distribution functions for the Wiener diffusion model. The R Journal, 6(1), 49-56. } RWiener/man/tests.Rd0000644000175100001440000000305013053056017014045 0ustar hornikusers\name{tests} \alias{anova.wdm} \alias{waldtest} \alias{waldtest.wdm} \alias{print.wwaldt} \title{Wiener Diffusion model test functions} \description{ Calculates test scores and further information for \code{\link{wdm}} model objects. } \usage{ \method{anova}{wdm}(object, \ldots, test="LRT") \method{waldtest}{wdm}(object, \ldots, theta="delta", theta0=0) } \arguments{ \item{object}{a wdm model object.} \item{test}{Statistical test to calculate, so far the only option is a likelihood-ratio test (LRT).} \item{\dots}{Further model objects or other arguments passed to methods.} \item{theta}{the name of the parameter to be tested.} \item{theta0}{the value of the parameter under the null hypothesis.} } \details{ The \code{anova.wdm} function calls the specified test and calculates the test statistics and other information for two or more nested \code{\link{wdm}} model objects. The \code{waldtest.wdm} function can be used to conduct a Wald test for a single parameter. } %\references{} %\note{} %\author{} \examples{ # a random dataset dat <- rbind(cbind(rwiener(100, 2,.3,.5,0), grp="A"), cbind(rwiener(100,2,.3,.5,1), grp="B")) # create nested wdm model objects (from specific to general) wdm1 <- wdm(dat) wdm2 <- wdm(dat, alpha=coef(wdm1)[1], tau=coef(wdm1)[2], beta=coef(wdm1)[3], xvar="grp") wdm3 <- wdm(dat, tau=coef(wdm1)[2], xvar="grp") # conduct LRT tests anova1 <- anova(wdm1,wdm2,wdm3) anova1 # waldtest wt1 <- waldtest(wdm1, theta="delta", theta0=0) wt1 } \keyword{anova.wdm} RWiener/man/RWiener-internal.Rd0000644000175100001440000000040612755652145016106 0ustar hornikusers\name{RWiener internal} \alias{verifypars} \alias{nlogLik.wiener} \alias{esvec} \alias{efn} \alias{cparvec} \alias{mle} \alias{wlrt} \title{Wiener functions internals} \description{ These functions are not to be used by the user. } \keyword{RWiener internals} RWiener/man/wdm.Rd0000644000175100001440000000737113035432410013477 0ustar hornikusers\name{wdm} \alias{wdm} \alias{print.wdm} \alias{vcov.wdm} \alias{confint.wdm} \alias{summary.wdm} \alias{print.summary.wdm} \title{Wiener diffusion model fit function} \description{ \code{wdm} creates parameter estimates for the four parameters of the Wiener model. } \usage{ wdm(data, yvar=c("q", "resp"), alpha=NULL, tau=NULL, beta=NULL, delta=NULL, xvar=NULL, start=NULL, fixed=0) \method{vcov}{wdm}(object, \ldots, method="hessian") } \arguments{ \item{data}{is the data object containing data coming from a (hypothetical) Wiener diffusion process. For further details on the data object, see \link{is.wiener}.} \item{yvar}{represents an optional vector, that can be used to define the names of the reaction time column. For further details on the data object, see \link{is.wiener}.} \item{alpha}{optional, can be used to fix the alpha parameter to the given value.} \item{tau}{optional, can be used to fix the tau parameter to the given value.} \item{beta}{optional, can be used to fix the beta parameter to the given value.} \item{delta}{optional, can be used to fix the delta parameter to the given value.} \item{xvar}{optional: group factor variable to estimate all unfixed parameters separate for the given groups.} \item{start}{an optional vector with the four starting parameter values in the following order: alpha, tau, beta, delta.} \item{fixed}{a number indicating how many of the parameters are fixed (not free). This number will be subtracted from the number of free parameters. Defaults to 0.} \item{method}{the method to use for estimating the covariance matrix of the parameter estimates. Options are \code{"opg"} for outer product of gradients or \code{"hessian"} to use the hessian matrix from the estimation routine. Defaults to \code{"hessian"}.} \item{object}{a wdm object file or a list containing a \code{$par} vector with the model parameters, a \code{$data} data.frame with the data and optionally a \code{$loss} function.} \item{\dots}{arguments passed to methods.} } \details{ The \code{wdm} function calls an estimation routine, to estimate the model parameters. If all but one parameters are fixed, a \code{"Brent (optim)"} type algorithm is used. For the estimation of more than one parameter, first a \code{"BFGS (optim)"} type algorithm is tried, if unsuccessful, a \code{"Newton type (nlm)"} algorithm is tried, if again unsuccessful, a \code{"Nelder-Mead (optim)"} algorithm is used. In case all parameters are set to fixed values, no estimation routine is called, but a \code{wdm} object will still be created. The returned \code{wdm} object is basically a list containing the parameter estimates in \code{$coefficients}. \code{$hessian} contains the numerically differentiated Hessian matrix (if available, else NULL). \code{$data} contains the data passed to the \code{wdm} function call. \code{$loglik} contains the log-likelihood value for the \code{wdm} object and its parameter estimates. \code{$estpar} contains a vector, that is \code{TRUE} if the respective parameter was estimated and \code{FALSE} if the respective parameter was set to a fixed value. Additional information is given in other list objects. The standard R functions \code{coef}, \code{vcov}, \code{confint}, \code{summary} can be used with \code{wdm} objects. } %\references{} %\note{} %\author{} \examples{ ## generate random data dat <- rbind(cbind(rwiener(100, 2,.3,.5,1), group="A"), cbind(rwiener(100,2,.3,.5,-1), group="B")) ## fit wdm wdm1 <- wdm(dat) ## extract parameters coef(wdm1) ## further models wdm2 <- wdm(dat, beta=.5) wdm3 <- wdm(dat, alpha=wdm1$coefficients[1], tau=wdm1$coefficients[2], beta=wdm1$coefficients[3], xvar="group") } \keyword{wdm} RWiener/man/scorefun.Rd0000644000175100001440000000321713035126007014531 0ustar hornikusers\name{scorefun} \alias{scorefun} \alias{scorefun.wdm} \alias{estfun} \alias{estfun.wdm} \title{Extract Empirical Estimating Functions} \description{ !EXPERIMENTAL FUNCTION! Generic function for extracting the empirical estimating functions of a fitted model. !EXPERIMENTAL FUNCTION! } \usage{ scorefun(x, \dots) estfun(x, \dots) } \arguments{ \item{x}{a fitted model object.} \item{\dots}{arguments passed to methods.} } \value{A matrix containing the empirical estimating functions. Typically, this should be an \eqn{n \times k}{n x k} matrix corresponding to \eqn{n} observations and \eqn{k} parameters. The columns should be named as in \code{\link{coef}} or \code{\link{terms}}, respectively. The estimating function (or score function) for a model - \code{scorefun} - is the derivative of the objective function with respect to the parameter vector. The empirical estimating functions is the evaluation of the estimating function at the observed data (\eqn{n} observations) and the estimated parameters (of dimension \eqn{k}). The \code{estfun} function is basically the score function, but with the additional functionality to sum up the scores by the given covariable \code{id} in the dataset. } \references{ Zeileis A (2006), Object-Oriented Computation of Sandwich Estimators. \emph{Journal of Statistical Software}, \bold{16}(9), 1--16. URL \url{http://www.jstatsoft.org/v16/i09/}. } \examples{ ## generate random data dat <- rwiener(100,1,.2,.5,0.5) ## fit wdm wdm1 <- wdm(dat) ## estimating function scores <- scorefun(wdm1) ## print head(scores) ## plot par(mfrow=c(2,2)) plot(scores[,1]);plot(scores[,2]);plot(scores[,3]);plot(scores[,4]) } RWiener/man/wienerdist.Rd0000644000175100001440000000340513052625221015062 0ustar hornikusers\name{wienerdist} \alias{dwiener} \alias{pwiener} \alias{qwiener} \alias{rwiener} \title{Wiener process distribution functions} \description{ \code{dwiener} computes the wiener first passage time density. \code{pwiener} computes the CDF for the wiener first passage time density. \code{qwiener} computes the quantile for a given CDF value. \code{rwiener} generates random quantiles from a wiener process distribution, based on the rejection based method. For all functions, the standard deviation of the diffusion process is fixed to 1. } \usage{ dwiener(q, alpha,tau,beta,delta, resp="upper", give_log=FALSE) pwiener(q, alpha,tau,beta,delta, resp="upper") qwiener(p, alpha,tau,beta,delta, resp="upper") rwiener(n, alpha,tau,beta,delta) } \arguments{ \item{q}{vector of quantiles.} \item{p}{vector of probabilities.} \item{n}{number of observations.} \item{alpha}{boundary separation parameter.} \item{tau}{non-decision time parameter.} \item{beta}{bias parameter.} \item{delta}{drift rate parameter.} \item{resp}{respone: "upper", "lower", or "both"} \item{give_log}{function returns log, if this argument is TRUE} } \examples{ ## calculate density for reactiontime 1.45, upper bound and some parameters dwiener(1.45, 2,0.3,0.5,0) ## calculate CDF for reactiontime 1.45, upper bound and some parameters pwiener(1.45, 2,0.3,0.5,0) ## calculate quantile for CDF value of 0.5, upper bound and some parameters qwiener(0.5, 2,0.3,0.5,0) ## generate one random value rwiener(1, 2,0.3,0.5,0) } \keyword{dwiener} \keyword{pwiener} \keyword{qwiener} \keyword{rwiener} \references{ Wabersich, D., & Vandekerckhove, J. (2014). The RWiener package: An R package providing distribution functions for the Wiener diffusion model. The R Journal, 6(1), 49-56. } RWiener/man/plot.Rd0000644000175100001440000000146712770513555013705 0ustar hornikusers\name{plot} \alias{plot.data.wiener} \alias{wiener_plot} \title{Wiener plot function} \description{ \code{plot} creates a density plot of correct and wrong responses for a given dataset. } \usage{ \method{plot}{data.wiener}(x, ...) } \arguments{ \item{x}{data.wiener object, which is basically a data.frame with data. Needs a reaction time column and a accuracy/response column.} \item{...}{Arguments to be passed to methods, such as graphical parameters.} } %\details{} %\references{} %\note{} %\author{} \examples{ ## generate random data dat <- rwiener(100,2,.3,.5,0) ## plot plot(dat) } \keyword{plot.data.wiener} \references{ Wabersich, D., & Vandekerckhove, J. (2014). The RWiener package: An R package providing distribution functions for the Wiener diffusion model. The R Journal, 6(1), 49-56. } RWiener/man/misc.Rd0000644000175100001440000000542513011347025013642 0ustar hornikusers\name{miscellaneous} \alias{is.wiener} \alias{as.wiener} \alias{numdata.wiener} \alias{data.wiener} \alias{revamp} \alias{revamp.data.wiener} \alias{revamp.numdata.wiener} \alias{revamp.data.frame} \title{Miscellaneous Wiener Diffusion model functions} \description{ Miscellaneous functions for the RWiener package. } \usage{ is.wiener(data) as.wiener(data, yvar=c("q", "resp")) \method{revamp}{numdata.wiener}(data, \ldots) \method{revamp}{data.wiener}(data, \ldots) } \arguments{ \item{data}{can be a data.wiener and/or data.frame with data (needs a reaction time column and a accuracy/response column). Further it can be a numdata.wiener and/or numeric with the data as single variable (lower bound reaction times are then represented as negative numbers, upper bound reaction times as positive numbers).} \item{yvar}{represents an optional vector, that can be used to define the names of the reaction time column (first value) and the accuracy/response column (second value), if a data.wiener and/or data.frame is given as data.} \item{\ldots}{optional arguments: \code{yvar} (as described above) and \code{direction}: character string that can be used to define the desired format of the returned data. \code{"wide"} returns a numdata.wiener, \code{"long"} returns a data.wiener.} } \details{ \code{data.wiener} and \code{numdata.wiener} are data objects that represent data coming from a Wiener Diffusion process. \code{data.wiener} uses a data.frame with 2 columns for the 2 response variables (\code{"q"} and \code{"resp"} by default). \code{numdata.wiener} emulates a single variable representation by using a vector, that stores the responses for the upper boundary as positive numbers and the responses for the lower boundary as negative numbers. This is similar to the transformation: Y=(2D-1)RT; where Y is the single variable, that preserves all the information from the decision variable D (1 or 0) and the reaction time variable RT. The \code{as.wiener} function can be used to create wiener data objects (\code{data.wiener} or \code{numdata.wiener}), that can be used by generic functions, e.g. \code{plot}. \code{is.wiener} checks if the given data is a wiener data object (\code{data.wiener} or \code{numdata.wiener}). \code{revamp.data.wiener} and \code{revamp.numdat.wiener} can be used to transform \code{data.wiener} objects to \code{numdata.wiener} objects and vice versa. The generic function \code{revamp}(data, \ldots) can be called for convenience. } \examples{ ## generate data dat <- rwiener(100, 4,.35,.5,0.8) ## simple function calls is.wiener(dat) dat <- as.data.frame(dat) dat <- as.wiener(dat) y <- revamp(dat) y revamp(y) } \keyword{is.wiener} \keyword{as.wiener} \keyword{revamp.numdata.wiener} \keyword{revamp.data.wiener} RWiener/cleanup0000755000175100001440000000003512711357446013230 0ustar hornikusers#!/bin/sh rm -f src/Makevars