coerce in C

git-svn-id: https://svn.r-project.org/R/trunk@87561 00db46b3-68df-0310-9c12-caf00c1e9a41

src/library/stats/R/runmed.R

@@ -1,7 +1,7 @@
 #  File src/library/stats/R/runmed.R
 #  Part of the R package, https://www.R-project.org
 #
-#  Copyright (C) 2003-2020 The R Foundation
+#  Copyright (C) 2003-2025 The R Foundation
 #  Copyright (C) 1995      Berwin A. Turlach
 #  Ported to R, added interface to Stuetzle's code and further enhanced
 #  by Martin Maechler,
@@ -66,8 +66,8 @@ runmed <- function(x, k, endrule = c("median","keep","constant"),
 	    "       na.*='%s' ( => iNAct=%d))\n"),
 		    k, endrule, iend, algorithm, na.actions[[iNAct]], iNAct))
     res <- switch(algorithm,
-                  Turlach  = .Call(C_runmed, as.double(x), 1, k, iend, iNAct, print.level),
-                  Stuetzle = .Call(C_runmed, as.double(x), 0, k, iend, iNAct, print.level))
+                  Turlach  = .Call(C_runmed, x, 1, k, iend, iNAct, print.level),
+                  Stuetzle = .Call(C_runmed, x, 0, k, iend, iNAct, print.level))
     if(endrule == "median") res <- smoothEnds(res, k = k)
 
     ## Setting attribute has the advantage that the result immediately plots

src/library/stats/src/Srunmed.c

@@ -1,6 +1,6 @@
 /*
  *  R : A Computer Language for Statistical Data Analysis
- *  Copyright (C) 2012-2023  The R Core Team
+ *  Copyright (C) 2012-2025  The R Core Team
  *  Copyright (C) 2003       The R Foundation
  *  Copyright (C) 1995-2002  Martin Maechler <[email protected]>
  *
@@ -213,9 +213,10 @@ R_xlen_t R_firstNA_dbl(const double x[], R_xlen_t n) {
 // .Call()ed from ../R/runmed.R
 SEXP runmed(SEXP sx, SEXP stype, SEXP sk, SEXP end, SEXP naAct, SEXP printLev)
 {
-    if (TYPEOF(sx) != REALSXP) error("numeric 'x' required");
-    double *x = REAL(sx), *xx;
     R_xlen_t n = XLENGTH(sx);
+    int nprot = 1;
+    if (!isReal(sx)) {sx = PROTECT(coerceVector(sx, REALSXP)); nprot++;}
+    double *x = REAL(sx), *xx;
     int type        = asInteger(stype),
 	k           = asInteger(sk),
 	end_rule    = asInteger(end),
@@ -315,6 +316,6 @@ SEXP runmed(SEXP sx, SEXP stype, SEXP sk, SEXP end, SEXP naAct, SEXP printLev)
 	default: error(_("na_action logic error (%d), please report!"), na_action);
 	}
     }
-    UNPROTECT(1);
+    UNPROTECT(nprot);
     return ans;
 }