@@ -678,3 +678,188 @@ SEXP pcountR(SEXP x, SEXP args) {
678678 UNPROTECT (1 );
679679 return ans ;
680680}
681+
682+ SEXP pcountNAR (SEXP x , SEXP args ) {
683+ if (xlength (x ) != 1 || isNull (x )) {
684+ error ("Argument 'value' must be non NULL and length 1." );
685+ }
686+ const int n = length (args );
687+ if (n < 1 ) {
688+ error ("Please supply at least 1 argument. (%d argument supplied)" , n );
689+ }
690+ const SEXP args0 = PTR_ETL (args , 0 );
691+ SEXPTYPE anstype = UTYPEOF (args0 );
692+ const R_xlen_t len0 = xlength (args0 );
693+ if (anstype != LGLSXP && anstype != INTSXP && anstype != REALSXP &&
694+ anstype != CPLXSXP && anstype != STRSXP ) {
695+ error ("Argument %d is of type %s. Only logical, integer, double, complex and"
696+ " character types are supported." , 1 , type2char (anstype ));
697+ }
698+ SEXPTYPE tx = UTYPEOF (x );
699+ if (anstype != tx ) {
700+ error ("Type of 'value' (%s) is different than type of Argument %d (%s). "
701+ "Please make sure both have the same type." , type2char (tx ), 1 , type2char (anstype ));
702+ }
703+ SEXP classx = PROTECT (getAttrib (x , R_ClassSymbol ));
704+ if (!R_compute_identical (PROTECT (getAttrib (args0 , R_ClassSymbol )), classx , 0 )) {
705+ error ("Class of 'value' is different than class of Argument %d. "
706+ "Please make sure both have the same class." , 1 );
707+ }
708+ UNPROTECT (1 );
709+ int nprotect = 0 ;
710+ const bool xf = isFactor (x );
711+ SEXP levelsx ;
712+ if (xf ) {
713+ levelsx = PROTECT (getAttrib (x , R_LevelsSymbol )); nprotect ++ ;
714+ if (!R_compute_identical (levelsx , PROTECT (getAttrib (args0 , R_LevelsSymbol )), 0 )) {
715+ error ("Levels of 'value' are different than levels of Argument %d. "
716+ "Please make sure both have the same levels." , 1 );
717+ }
718+ UNPROTECT (1 );
719+ }
720+ for (int i = 1 ; i < n ; ++ i ) {
721+ SEXPTYPE type = UTYPEOF (PTR_ETL (args , i ));
722+ R_xlen_t len1 = xlength (PTR_ETL (args , i ));
723+ if (type != anstype ) {
724+ error ("Type of argument %d is %s but argument %d is of type %s. "
725+ "Please make sure both have the same type." , i + 1 ,
726+ type2char (type ), 1 , type2char (anstype ));
727+ }
728+ if (!R_compute_identical (PROTECT (getAttrib (PTR_ETL (args , i ), R_ClassSymbol )), classx , 0 )) {
729+ error ("Class of 'value' is different than class of Argument %d. "
730+ "Please make sure both have the same class." , i + 1 );
731+ }
732+ UNPROTECT (1 );
733+ if (xf ) {
734+ if (!R_compute_identical (levelsx , PROTECT (getAttrib (PTR_ETL (args , i ), R_LevelsSymbol )), 0 )) {
735+ error ("Levels of 'value' are different than levels of Argument %d. "
736+ "Please make sure both have the same levels." , i + 1 );
737+ }
738+ UNPROTECT (1 );
739+ }
740+ if (len1 != len0 ) {
741+ error ("Argument %d is of length %zu but argument %d is of length %zu. "
742+ "If you wish to 'recycle' your argument, please use rep() to make this intent "
743+ "clear to the readers of your code." , i + 1 , len1 , 1 , len0 );
744+ }
745+ }
746+ UNPROTECT (1 + nprotect );
747+ SEXP ans ;
748+ if (len0 > INT_MAX ) {
749+ ans = PROTECT (allocVector (REALSXP , len0 )); // # nocov start
750+ double * restrict pans = REAL (ans );
751+ memset (pans , 0 , (unsigned )len0 * sizeof (double ));
752+ switch (anstype ) {
753+ case LGLSXP : {
754+ for (int i = 0 ; i < n ; ++ i ) {
755+ int * pa = LOGICAL (PTR_ETL (args , i ));
756+ for (ssize_t j = 0 ; j < len0 ; ++ j ) {
757+ if (pa [j ] == NA_LOGICAL ) {
758+ pans [j ]++ ;
759+ }
760+ }
761+ }
762+ } break ;
763+ case INTSXP : {
764+ for (int i = 0 ; i < n ; ++ i ) {
765+ int * pa = INTEGER (PTR_ETL (args , i ));
766+ for (ssize_t j = 0 ; j < len0 ; ++ j ) {
767+ if (pa [j ] == NA_INTEGER ) {
768+ pans [j ]++ ;
769+ }
770+ }
771+ }
772+ } break ;
773+ case REALSXP : {
774+ for (int i = 0 ; i < n ; ++ i ) {
775+ double * pa = REAL (PTR_ETL (args , i ));
776+ for (ssize_t j = 0 ; j < len0 ; ++ j ) {
777+ if (ISNAN (pa [j ])) {
778+ pans [j ]++ ;
779+ }
780+ }
781+ }
782+ } break ;
783+ case CPLXSXP : {
784+ for (int i = 0 ; i < n ; ++ i ) {
785+ Rcomplex * pa = COMPLEX (PTR_ETL (args , i ));
786+ for (ssize_t j = 0 ; j < len0 ; ++ j ) {
787+ if (ISNAN_COMPLEX (pa [j ])) {
788+ pans [j ]++ ;
789+ }
790+ }
791+ }
792+ } break ;
793+ case STRSXP : {
794+ for (int i = 0 ; i < n ; ++ i ) {
795+ const SEXP pa = PTR_ETL (args , i );
796+ const SEXP * restrict px = STRING_PTR (pa );
797+ for (ssize_t j = 0 ; j < len0 ; ++ j ) {
798+ if (px [j ] == NA_STRING ) {
799+ pans [j ]++ ;
800+ }
801+ }
802+ }
803+ } break ;
804+ } // # nocov end
805+ } else {
806+ ans = PROTECT (allocVector (INTSXP , len0 ));
807+ int * restrict pans = INTEGER (ans );
808+ memset (pans , 0 , (unsigned )len0 * sizeof (int ));
809+ switch (anstype ) {
810+ case LGLSXP : {
811+ for (int i = 0 ; i < n ; ++ i ) {
812+ int * pa = LOGICAL (PTR_ETL (args , i ));
813+ for (ssize_t j = 0 ; j < len0 ; ++ j ) {
814+ if (pa [j ] == NA_LOGICAL ) {
815+ pans [j ]++ ;
816+ }
817+ }
818+ }
819+ } break ;
820+ case INTSXP : {
821+ for (int i = 0 ; i < n ; ++ i ) {
822+ int * pa = INTEGER (PTR_ETL (args , i ));
823+ for (ssize_t j = 0 ; j < len0 ; ++ j ) {
824+ if (pa [j ] == NA_INTEGER ) {
825+ pans [j ]++ ;
826+ }
827+ }
828+ }
829+ } break ;
830+ case REALSXP : {
831+ for (int i = 0 ; i < n ; ++ i ) {
832+ double * pa = REAL (PTR_ETL (args , i ));
833+ for (ssize_t j = 0 ; j < len0 ; ++ j ) {
834+ if (ISNAN (pa [j ])) {
835+ pans [j ]++ ;
836+ }
837+ }
838+ }
839+ } break ;
840+ case CPLXSXP : {
841+ for (int i = 0 ; i < n ; ++ i ) {
842+ Rcomplex * pa = COMPLEX (PTR_ETL (args , i ));
843+ for (ssize_t j = 0 ; j < len0 ; ++ j ) {
844+ if (ISNAN_COMPLEX (pa [j ])) {
845+ pans [j ]++ ;
846+ }
847+ }
848+ }
849+ } break ;
850+ case STRSXP : {
851+ for (int i = 0 ; i < n ; ++ i ) {
852+ const SEXP pa = PTR_ETL (args , i );
853+ const SEXP * restrict px = STRING_PTR (pa );
854+ for (ssize_t j = 0 ; j < len0 ; ++ j ) {
855+ if (px [j ] == NA_STRING ) {
856+ pans [j ]++ ;
857+ }
858+ }
859+ }
860+ } break ;
861+ }
862+ }
863+ UNPROTECT (1 );
864+ return ans ;
865+ }
0 commit comments